diff --git a/DESCRIPTION b/DESCRIPTION index a083158f..2318be49 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,8 +12,9 @@ Description: Constructs analysis regions from the distribution of the data observations, assigns features to cells, and aggregates to cell level with optional design-effect corrections so that standard errors account for within-cell autocorrelation. Also manages coordinate reference - systems. Fits geographically weighted regression - (via 'GWmodel'; Lu et al. (2014) ), + systems. Fits geographically weighted regression (with the kernels, + diagnostics and forward selection of 'GWmodel'; Lu et al. (2014) + ), Bayesian spatial Gaussian process regression (via 'brms', using the Hilbert space approximation of Riutort-Mayol et al. (2023) ) and random forests (via 'ranger', with @@ -38,6 +39,7 @@ Imports: dplyr (>= 1.0), logger, digest, + FNN, stats, methods, utils, @@ -54,7 +56,6 @@ Suggests: gstat, ggplot2 (>= 3.4.0), patchwork, - FNN, Matrix, nlme, spdep, diff --git a/NAMESPACE b/NAMESPACE index 43ea3214..2c2730eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -30,7 +30,10 @@ S3method(print,resolution_summary) S3method(print,rf_fit) S3method(print,sac_range) S3method(print,spatial_fit) +S3method(print,spatialkit_count_rule) +S3method(print,spatialkit_pooled) S3method(print,spatialkit_split) +S3method(print,spatialkit_values_at) S3method(print,summary.spatial_fit) S3method(residuals,bayesian_fit) S3method(residuals,gwr_fit) @@ -40,6 +43,7 @@ S3method(summary,spatial_fit) export(area_of_applicability) export(assign_features_to_polygons) export(build_tessellation) +export(cell_values_at) export(clear_fitted_cache) export(clear_grid_cache) export(clip_target_for) diff --git a/NEWS.md b/NEWS.md index 756896e3..5b00f193 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,50 +1,650 @@ # spatialkit (development version) +## Breaking changes + +Defaults and results that differ from 2.0.0. Each entry says how to get the +old behaviour where there is a way. + +* `resolution_profile()` scores pooled values by default (`estimate = + "auto"`) at 4.5 observations per cell (`obs_per_cell = "auto"`), with the + centres fitted to every row. A call with a numeric response, no + predictors and none of `levels`, `n_levels`, `min_cell_n`, `sample_n` and + `range_floor` returns one level where it returned a ladder of about 20, + and its count is larger: on 3,000 rows, 667 cells where the ladder stopped + at 333. `elbow` is `NA` on one level. The profile gains + `scored_per_cell`, `loo`, `loo_se`, `share_alone` and `own_weight`, + `attr(, "estimate")` and a print line, and a layer whose scored rows share + locations raises `spatialkit_repeated_locations`. A call that sets one of + those five arguments keeps the ladder they describe and gains the same + columns, and since it now carries the pooled estimate, + `select_resolution()` with no criterion reads it by the size: it returns + the level nearest `round(n / 4.5)`, on the automatic ladder its top level, + with `spatialkit_size_not_reached`, where 2.0.0 returned Cp's pick. + `criterion = "cp"`, or `estimate = NULL` in the profile, gives Cp's count. + On the default ladder no variogram is fitted (`sac = "auto"`): `cp` and + `reliability` are `NA`, `attr(, "cp_noise")` says why, and nothing is said + about a variogram; on any other ladder it is estimated as before. The + default ladder's fits are bounded: from the 3 starts of the density kind + the call stops above about 122,000 rows with an error of class + `spatialkit_work_limit` that names the ways on (the limit is set where the + fit takes about a minute, so a call just below it runs that long and + prints nothing while it runs), and without the Matrix package `moran_i` + and `moran_z` are `NA` above 22,500 rows, with `spatialkit_moran_skipped`. + A profile passed straight as a count (`get_voronoi_seeds(n = prof)`, + `voronoi_seeds_kmeans(k = prof)`, `build_tessellation(approx_n_cells = + prof)`) is read by the size and no longer by `cp`. `estimate = NULL, + obs_per_cell = NULL` gives the previous ladder and columns; `sac = NULL` + estimates the variogram on a ladder of sizes too. + +* `resolution_profile()`, `get_voronoi_seeds()` and `voronoi_seeds_kmeans()` + build density-weighted regions by default (`partition = "density"`), kept + from the best of 3 k-means++ starts (`nstart = NULL`, `kmeans_nstart = + NULL`). Their cells are small where observations are dense, and hold + about the same number of observations each once there are more cells than + dense places. Every default call of the three functions returns other + centres and other cells. The profile, its selections and its seeds carry + the partition record (`attr(, "partition")`, `sel$partition`), and the + prints name the kind. In the profile `wss` stays the unweighted sum, + `wss_spread` is the spread of the weighted one, and a start runs for at + most 100 steps of Lloyd's iteration. The seeding functions put the rows + in coordinate order first, so their seeds no longer depend on the order + of the rows, and `get_voronoi_seeds()`'s `attr(, "kmeans")` gains + `converged` and `objective`. `density_power` and `density_k` are read, + and a default call can raise `spatialkit_empty_cells` and + `spatialkit_not_converged`. A cloud `get_voronoi_seeds()` draws inside a + `boundary` is uniform, so the kind has no density to follow there. + `method = "random"` and `"provided"` are unchanged, and a selection or a + profile passed as the count returns the centres it scored, as before. + `partition = "kmeans"` gives the previous regions with their previous + starts: the profile's best of 25 k-means++ starts, the seeding functions' + `stats::kmeans()` from 10 random starts on the rows as they come. A call + that named `partition = "density"` and no number of starts runs 3 starts + where it ran 25 (the profile) or 10 (the seeding functions); `nstart = + 25`, `kmeans_nstart = 10` or `nstart = 10` restores that. + +* `get_voronoi_seeds()` given a number of starts that is not whole, such as + `kmeans_nstart = 2.5`, and no `partition` now stops: the density kind + refuses it, with "`kmeans_nstart` must be NULL or a single positive whole + number of starts; got 2.5." With `partition = "kmeans"` the call returns + as before. + +* `select_resolution()` reads a profile by `criterion = "auto"`: the size + for pooled values, the leave-one-out minimum for plain means, `cp` for a + profile built with `estimate = NULL`. On a profile with an estimate the + count is the level nearest `round(n / 4.5)`, not Cp's minimum: on the + default profile that count itself, and on a ladder of counts the nearest + level, with `spatialkit_size_not_reached` when it is not the count. A + response with no structure is still reported, by another test: `structured + = FALSE`, and `spatialkit_no_structure` where the count becomes cells, + from the leave-one-out error against one mean. The count is then the + size's where Cp's was 2 cells or the like, since a size does not shrink + for want of structure, and `spatialkit_bound_chosen` is not raised for a + size. On a profile without an estimate nothing changes. `criterion = + "cp"` reads `cp` as before on a profile that has it. The default profile, + one level with no variogram, has none, and `criterion = "cp"` or + `"reliability"` on it is an error that says what to pass. For the count + Cp gave before, build the profile with `estimate = NULL, obs_per_cell = + NULL` (and `partition = "kmeans"` for the same regions). + +* `summarize_by_cell()` adds the pooled columns by default (`estimate = + "pooled"`): `..pooled_*`, `..pooled_w_*` and `..pooled_target_*` for + every numeric response and predictor, and the attributes `"pooled"` and + `"intervals"`. Every existing column is unchanged. The default call can + now raise the warnings of the pooled values, each once per call: + `spatialkit_pool_unavailable` (a layer with no geometry, which the call + accepts; no row with a value, a cell and a location; no two rows in any + cell), `spatialkit_pool_degenerate` (one cell, no spread inside any cell, + or no signal between cells), `spatialkit_pool_few_cells` (2 to 9 cells), + `spatialkit_pool_few_df`, `spatialkit_no_structure` (a response the cells + do not help with), `spatialkit_pool_rows_skipped`, and, on cells that + carry a count record, `spatialkit_estimate_mismatch` and + `spatialkit_cells_differ`. Small layers and layers without spatial + structure raise several. `estimate = "mean"` returns the previous frame. + +* `resolution_profile()` no longer stops when a ladder set with `levels` + has a level of more than 5,000 cells and the Matrix package is not + installed: `moran_i` and `moran_z` are `NA` at such a level, with a + warning of class `spatialkit_moran_skipped`, and every other column is + computed. Installing Matrix gives the two columns. + +* The FNN package moves from Suggests to Imports and installs with + spatialkit. The nearest-neighbour searches use it, among them the one + behind the weights of the density kind, now the default partition. The + package's own searches, which compare every pair of locations and give + the same results in a time that grows with the square of their number, + remain for a session in which FNN cannot be loaded. + +* `estimate_sac_range()` fits its variogram model without iteration, so the + same layer gives the same verdict, range and nugget whatever the unit of + the response or of the coordinates and whatever the order of its rows. + The criterion is gstat's (squared error weighted by N/h^2); for each trial + range the nugget and partial sill are solved exactly, and the range is + searched on a grid and refined. Every range and nugget moves a little. + Only the exponential family is fitted: the spherical fallback is gone. + `rejected_reason` no longer takes `"variogram model did not converge"`; + `attr(attr(x, "variogram_model"), "converged")` is `FALSE` when the + criterion has no minimum inside the ranges searched. Nothing is printed + to the console. + +* `estimate_sac_range()` tests for spatial structure before it returns a + range: Moran's I of the modelled variable on its 2, 4, 8 and 16 nearest + neighbours, with the smallest one-sided p-value multiplied by four. When + that is not below the new argument `structure_alpha` (default 0.05) the + result is `NA` with `rejected_reason` `"no spatial structure detected at + the nearest-neighbour scale"` and a pure-nugget model. On white noise + (300 points) a finite range came back for 24 of 60 layers and now comes + back for 1. The test has little power where few neighbours lie inside the + range. `structure_alpha = 1` switches the refusal off. A variogram that + no model with a range fits better than a constant is refused as `"the + empirical variogram is flat: no spatial structure at the lags resolved"`. + +* `estimate_sac_range()` gains `lags = c("adaptive", "equal")` and `n_lags`, + and `"adaptive"` is the default: the first bin ends where the closest + `max(50, n / 4)` pairs lie, and the rest widen geometrically to the + cutoff. Fifteen equal bins hid structure shorter than the first bin: on a + clustered layer with a true range of 30 the median estimate was 77 and is + now 29. A longer second structure seen at equal lags is kept in the model + and sets the range (`structures`, `short_range`), and a range the adaptive + lags leave past the largest lag falls back to the equal-lag result + (`lag_fallback`). Ranges, nuggets and the block sizes of + `make_folds(auto_range = TRUE)` change. `lags = "equal"` keeps the old + bins. + +* `estimate_sac_range()` never returns the largest directional range in + place of an all-pairs fit that identifies no range: the result is then + `NA`. The directional ranges are still attached, and `anisotropy_used` + is always `FALSE`. + +* `resolution_profile(range_floor = FALSE)` is the default. The ladder + starts at 2 cells; the floor the autocorrelation range implies is reported + in the bounds and the print, and is a level of the ladder when the layer + supports it. A range is an estimate and can be spurious, and a ladder + that started at it could not show the counts below. + `select_resolution(criterion = "reliability")` reads the levels at or + above the floor, so it returns the floor, as it did when the ladder + started there; its new argument + `range_floor = FALSE` reads every level. `resolution_profile(range_floor + = TRUE)` starts the ladder at the floor. + +* `resolution_profile()` takes its support ceiling from the rows that carry + a response (and every predictor, when predictors are given), not from + every point. A layer with a response on a quarter of its rows gets a + quarter of the ceiling, `ceiling_from` reads `"min_cell_n (rows with a + response)"`, and a warning of class `spatialkit_response_ceiling` gives + both counts. New columns `cells_resp` and `cell_resp_mean` count the + cells that hold a scored row and the scored rows per such cell. + +* `moran_z` is a diagnostic of the cell means and is no longer read as a + count rule. It grows as cells get finer than the range and is near zero + at the coarsest counts it is computed at, whatever the data. + `select_resolution(criterion = "moran_z")` is an error of class + `spatialkit_diagnostic_criterion` unless `diagnostic = TRUE`; `summary()` + leaves it out unless it is named in `criteria`; `plot()` draws its curve + with no selected level. `determine_optimal_levels()` still ranks by it + under `criterion = "morans_i"` and `"combined"`, and raises a warning of + class `spatialkit_diagnostic_ranking` when it does. + +* `get_voronoi_seeds()`, `voronoi_seeds_kmeans()` and `build_tessellation()` + read a `resolution_profile()` built without an estimate by `cp` or not at + all (one built with an estimate, the default, is read by + `criterion = "auto"`). A profile whose `cp` is `NA` was read by the next + finite criterion with a log line; it is now an error (class + `spatialkit_no_default_criterion` when another criterion is finite). A + geometry-only profile whose only finite criterion is `elbow` is still read + by it. Pass `select_resolution(profile, criterion = )` to choose another + criterion. + +* `select_features_forward()` accepts a candidate by a new default rule, + `rule = "se"`: its pooled gain has to exceed `tol` and the mean of its + per-fold gains has to exceed `se_mult` (default 1) standard errors of that + mean. With `tol = 0` any gain was accepted. `rule = "tol"` is the old + test. Every learner now has a baseline, so the selection can be empty + (see Bug fixes). + +* `area_of_applicability()` weights the predictors by the model's variable + importance by default (`weights = "auto"`): `pmax(importance, 0)` when the + model carries a finite importance for every predictor and has out-of-bag + skill, equal weights otherwise, with the reason logged. + `params$weights_source` says which. `weights = NULL` gives equal weights + as before. + +* `area_of_applicability()` measures location for a `gwr_fit` and a + `bayesian_fit`, which predict as a function of location. Location has an + index of its own (`DI_location`, element `location`): the distance to the + nearest training point over the mean distance between training points, + with the same folds and threshold rule. A point is inside only when it is + inside on both indices; `n_outside_predictors` counts the predictor index + alone. `coords = "no"` gives the old result; `coords = "yes"` measures + location for any model. + +* `fit_rf_model()` splits an unordered factor or character predictor with + `respect.unordered.factors = "order"`, which ranger's help recommends; + ranger's default, `"ignore"`, splits on the order the levels are stored + in. Forests with such a predictor change. Pass + `respect.unordered.factors` through `...` to set it yourself. + `$info$categorical_predictors` and `$info$respect_unordered_factors` record + what was done, and `print()` shows it. `print()` also reads "no spatial + information used" for a forest fitted without the coordinates. + +* The local regressions of a GWR are solved by the package, by pivoted QR on + predictors centred in each window, and GWmodel is no longer needed to fit, + predict, cross-validate or select (`sp` still is). A window of deficient + rank neither stops the fit nor returns coefficients made of rounding + error: a coefficient it cannot estimate is `NA`, and a warning of class + `spatialkit_gwr_rank_deficient` counts them. On windows of full rank the + results equal `GWmodel::gwr.basic()`'s to rounding error. `fit$engine` is + a list in GWmodel's layout (`SDF`, `GW.diagnostic`, `GW.arguments`, `lm`) + and no longer an object of class `gwrm`. `print()` heads the fit ``, + not ``. + +* With `bandwidth = NULL`, `fit_gwr_model()`, `gwr_model_selection()` and + `cv_gwr()` select the bandwidth by a search of their own: 16 log-spaced + bandwidths are scored and the best is refined. `GWmodel::bw.gwr()`'s + golden-section search assumes one minimum and returned a near-global + bandwidth when AICc had two. The scored curve is kept in + `info$bandwidth_search`. Selected bandwidths can differ from 2.0.0's; + supply `bandwidth` to fix one. Below 20 observations the bandwidth is + searched like any other. + +* `fit_gwr_model()`, `gwr_model_selection()` and `cv_gwr()` select the + default bandwidth by the leave-one-location-out sum of squares, not AICc, + when rows share a location (repeat visits, replicate samples). AICc + counts such rows as independent and is lowest where the windows reproduce + each location's mean. A warning of class + `spatialkit_gwr_repeated_locations` gives the counts; + `info$n_locations` and `info$bandwidth_search$approach` record it. A + layer with no repeated location is searched by AICc. + +* `fit_bayesian_spatial_model(standardize_predictors = TRUE)` scales its + automatic slope prior to the response: `normal(0, 2.5 * sd(y))` under an + identity link and `normal(0, 2.5 * sd(log(y)))` for the lognormal + families. The fixed `normal(0, 5)` shrank a slope of about 14,000 per SD + on a response in dollars to 0.06. Other links keep `normal(0, 5)`. The + prior used is stored as `$info$b_prior`; pass `prior` to set your own. + +* `$info$convergence_ok` of a Bayesian fit follows Stan's own diagnostics + more closely. It is `FALSE` on any divergent transition, an R-hat above + 1.05, an R-hat above 1.01 with an effective sample size under 100 per + chain, a bulk or tail effective sample size under 100 per chain, or an + E-BFMI under 0.3 in a chain. Short runs that passed can now fail. A + failed verdict raises one warning of class `spatialkit_convergence` that + names each failed check and its remedy. + +* `summarize_by_cell(deff = "variogram")` falls back to `"kish"`, not to + the uncorrected standard error, when no usable variogram exists. The + warning of class `spatialkit_deff_fallback` gives the reason. A new + column `deff_method`, present whenever a design effect is requested, names + the correction each row carries. A variogram refused because the + response shows no spatial structure is not a fallback: its pure-nugget + model gives a design effect of 1. + +* `summarize_by_cell(deff = "kish")` estimates the ICC of each predictor on + its own. One ICC was pooled over every predictor listed, so listing a + second predictor changed the first one's standard error. + `attr(, "icc")$pred` and `attr(, "deff_applied")$icc_pred` are vectors + named by predictor column. + +* Voronoi cells built on seeds reach the edge of the data the seeds stand + for. `build_tessellation(seeds, method = "voronoi")` without a boundary + clipped the cells to the seeds' own hull, and the observations outside it + were dropped by the assignment: a quarter of 3,000 uniform points at 25 + k-means seeds. The seeding functions now attach the boundary they drew + in, or the hull of the points they clustered, as `attr(, "cover")`, and + the cells are built over it. Pass `boundary` to set the extent yourself. + +* `assign_features_to_polygons()` stops on a duplicated or missing value in + the polygon ID column. Nine polygons with a zone attribute called `id` + came back as three. When the rows that share an ID are parts of one unit, + merge them first with `dplyr::summarise(dplyr::group_by(polygons_sf, ))`. + +* Conditions that were log lines are R warnings with a class, so + `tryCatch()`, `withCallingHandlers()` and `options(warn = 2)` see them: + rows dropped before a fit (`spatialkit_rows_dropped`), a constant + predictor (`spatialkit_constant_predictor`), features in no polygon + (`spatialkit_unassigned`), fewer folds than asked for + (`spatialkit_k_reduced`), a cell count chosen by a bound of the ladder + (`spatialkit_bound_chosen`) and a profile the layer does not support + (`spatialkit_not_supported`). `?resolution_profile` lists the classes of + the resolution functions. + ## New features +* `resolution_profile()`, `get_voronoi_seeds(method = "kmeans")` and + `voronoi_seeds_kmeans()` gain `partition = c("density", "kmeans")`. + `"kmeans"` is what each function did: centres that minimise the sum of + squared distances from the points. `"density"`, the default (see + Breaking changes), weights each point by its local density (the points in + the disc that reaches its `density_k`-th nearest neighbour, default 8, + over the disc's area) to the power `density_power` (0 to 2, default 1). + The cells are compact, and at power 1 they hold about the same number of + points each once there are more + cells than dense places; with fewer cells the counts are about as uneven + as under `"kmeans"`. On 2,000 simulated points with 28 dense places the + coefficient of variation of the cell counts was 0.90 under `"kmeans"` and + 0.97 under `"density"` at 10 cells, and 0.95 and 0.31 at 60 cells. The + result does not depend on the order of the rows, the unit of the + coordinates or whether FNN is installed, and points at one location share + a cell. + +* The same three functions gain `init`: `"kmeans++"` draws a start's centres + one at a time, each in proportion to its squared distance from those + already drawn, and `"random"` draws distinct locations at random, as + `stats::kmeans()` does. `resolution_profile()` defaults to `"kmeans++"`, + as before. The two seeding functions default to `NULL`: random starts for + `partition = "kmeans"`, the run they have always made, and k-means++ for + `partition = "density"`. + +* `resolution_profile()` and `voronoi_seeds_kmeans()` gain `iter_max`, the + most iterations a start runs for. `NULL`, the default, is 50 for the + k-means each has always run and 100 for random starts in the profile and + for `partition = "density"`. A kept start that was cut off at the limit, + or at `kmeans_iter` in `get_voronoi_seeds()`, is a warning of class + `spatialkit_not_converged` that carries `level`, `iter` and `iter_max`. + The k-means kind from its own starts reports as before. + +* A result built with `partition = "density"`, or with an `init` other + than the k-means kind's own, says so: `attr(, "partition")` on a profile + and on seeds, `$partition` on a `select_resolution()` result, + `params$partition` on a tessellation from + `build_tessellation()` or `create_voronoi_polygons()`. The record holds + `kind`, `init`, `density_power` and `density_k`, and for a profile and for + seeds a seeding function placed, the iterations the kept start took and + whether it converged. A selection or profile passed as the count gives + the centres it scored, so the regions built are the regions scored. + Results of the k-means kind from its own starts carry no record and are + unchanged. + +* Under `partition = "density"` the profile's `wss` is the within-cell sum + of squares with every point counted once, so `wss` and `elbow` compare + between kinds; the weighted sum the centres minimise is + `attr(, "partition")$objective`. `print()` of the profile and of a + selection, and `summary()` of the profile, name the kind. + `determine_optimal_levels()` keeps plain k-means. + +* Two more warnings have a class. `spatialkit_partition_unused`: a + selection or profile passed as the count together with a `partition`, + `init` or density setting it was not built with; the scored centres are + returned. `spatialkit_empty_cells`: a density partition in which a centre + holds no point, which happens at counts from about a fifth of the points + up, mostly from random starts. + +* `summarize_by_cell()` gains `estimate = "pooled"`. Beside each mean it + returns a pooled value, `..pooled_*`: the cell's mean pulled toward the + count-weighted mean of the 8 cells whose observations' centroids are + nearest, `..pooled_target_*`, with the weight `..pooled_w_*` on its own + mean. The weight grows with the cell's count and with how much the cells + differ from their neighbours. A cell with one observation gets a value; a + cell with none gets `NA`. It works on any polygons. Every present column + is unchanged, and `estimate = "mean"` returns the frame it always did; + `"pooled"` is the default (see Breaking changes). `attr(, "pooled")` + records the fit, and whether the cells predict a left-out observation + better than one mean for all rows. On 200 + simulated layers of 1,500 clustered observations in cells of 4.5 on + average, the root mean squared error of the pooled value at held-out + observations among the others was 0.96 of the plain mean's + (`dev/sim-pooled-values.R`; `?summarize_by_cell` describes the + simulation). + +* `summarize_by_cell()` gains `obs_level`: `..obs_lo_*` and `..obs_hi_*`, a + range for one further observation in the cell, as the pooled value plus + two quantiles of its leave-one-out residuals. It is a statement about + observations on average and describes observations among those + summarised; it is too narrow for a place with none nearby. `conf_level` + and the `..ci_*` columns are unchanged; that interval is not a range for + an observation. On the same layers the range at 0.90 held 89.6 percent of + the observations held out among the others and 75.1 percent of those in a + held-out block, and `..ci_*` at 0.90 read that way held 58.9 percent of + the first. `attr(, "intervals")` says what each interval in the frame + covers. + +* `resolution_profile()` gains `estimate` and `obs_per_cell`. + `obs_per_cell` sets the ladder in observations per cell and accepts + fractions; the centres are then fitted to every row. With `estimate` the + profile adds `loo`, the leave-one-out error of that cell value on every + row of the layer with a response, in the cells the seeds will build, with + `loo_se`, `scored_per_cell`, `share_alone` and `own_weight`. It needs no + variogram. `print()`, `summary()` and `plot()` of such a profile show + it. + +* `resolution_profile()`'s `sac` accepts `"auto"`: the variogram is + estimated as before unless `obs_per_cell` sets the ladder, where none is + fitted, `cp` and `reliability` are `NA`, and `attr(, "cp_noise")` says + why. `"auto"` is the default (see Breaking changes). + +* `resolution_profile()`'s `nstart`, `get_voronoi_seeds()`'s `kmeans_nstart` + and `voronoi_seeds_kmeans()`'s `nstart` accept `NULL`, the kind's own + number of starts: the earlier default for `partition = "kmeans"` and 3 + for `partition = "density"`. `NULL` is the default (see Breaking + changes). On a ladder set by `obs_per_cell` a fit whose cost grows with + the square of the rows is stopped above a limit, with an error of class + `spatialkit_work_limit` that names the ways on; so is the search behind + the weights of `partition = "density"` when the FNN package is not + installed. + +* `select_resolution()` gains `criterion = "size"` (the level at + `obs_per_cell` observations per cell, 4.5 unless given), `"loo"` (the + lowest leave-one-out error) and `"auto"` (size for pooled values, + leave-one-out for plain means). A size does not test the response, so + `structured` is computed for it from the leave-one-out error against one + mean for the layer. A profile built with `estimate`, passed straight to a + seeding function as the count, is read by `"auto"`, which is the default + (see Breaking changes). + +* A selection made by these rules carries `count_rule`, and the seeds, the + tessellation, the assigned layer and the summary carry it on. + `summarize_by_cell()` warns (`spatialkit_estimate_mismatch`) when the + count was chosen for one cell value and the summary reports the other, and + (`spatialkit_cells_differ`) when the cells or rows it is given are not the + ones the count was scored on. + +* The record holds the centres the profile scored (`scored$centres`). + `build_tessellation(method = "voronoi")` and `create_voronoi_polygons()` + build the cells of those centres in the CRS the profile worked in, with no + `crs` or a geographic one, whatever CRS the seeds arrive in (degrees, or + the CRS of a boundary they were placed in), each seed put at its centre as + the record holds it. On such cells `assign_features_to_polygons()` gives + a point on the edge between two cells the cell `resolution_profile()` + scored it in: its nearest centre in the record's CRS, and of two the same + distance away the lower-numbered one. On gridded locations (raster cell + centres, a regular sampling grid) the rows each cell holds are then the + rows its count was scored on, and the summary's check reads `match`. + `cell_values_at()` places a location on such an edge in the same cell, + without `seeds` and with the seeds in any order. Polygons without the + record, cells whose record says they are other cells built from the + count, and features that are not points are placed by the polygons alone. + +* New `cell_values_at()`: the value and interval of the cell at other + locations, with each location's distance from the nearest observation. + A seed outside a boundary that is not convex, in a bay or a bend of a + coast, gets `NA` in `build_tessellation()`'s `index` although its cell is + built, and the locations nearest it then have no cell and are filled from + the cell of their nearest scored row; `?cell_values_at` gives the lines + that hand such a seed its cell's ID. + +* Each warning of the pooled path of `summarize_by_cell()` is raised once + per call and reason and names the columns it applies to, in its text and in + a `columns` field. Where the pooled columns cannot be computed they are + `NA` with a warning and the plain columns are returned; the function + raises no error for them. + +* New condition classes: `spatialkit_pool_unavailable`, + `spatialkit_pool_degenerate`, `spatialkit_pool_few_cells`, + `spatialkit_pool_few_df`, `spatialkit_pool_rows_skipped`, + `spatialkit_repeated_locations`, `spatialkit_few_residuals`, + `spatialkit_estimate_mismatch`, `spatialkit_cells_differ`, + `spatialkit_size_not_reached`, `spatialkit_ladder_unused`, + `spatialkit_moran_skipped`, and the error class `spatialkit_work_limit`. + `spatialkit_no_structure` is also raised by `summarize_by_cell(estimate = + "pooled")`, and by the seeding functions for a count set by a size. + +* `make_folds()` gains `method = "knndm"`, the k-fold version of + nearest-neighbour distance matching (Linnenbrink et al. 2024). It builds + `k` folds whose held-out distances are as close as a set of candidates + allows to the distances from `prediction_points` to the data, and has no + row limit, where `"nndm"` takes at most 5,000 rows and one fit per point. + The candidates are the random partition and, for up to 50 cluster counts, + the samples clustered on their coordinates and packed into `k` folds; the + one with the smallest Wasserstein distance to the target is returned, and + `params$candidates` lists them all. The match is coarser than NNDM's. + Two cases raise a classed warning: prediction points nearer to the data + than any fold can hold a point out (`spatialkit_nndm_out_of_reach`), and + folds still closer to their training data than the prediction points are + to the samples (`spatialkit_knndm_short_of_target`). The rule that packs + clusters into folds is this package's and was not checked against + `CAST::knndm()`. + +* `make_folds()` gains `max_test` for `"buffered_loo"` and `"nndm"`: folds + are built for a seeded random subset of that many held-out points, with + every row still available for training. `"buffered_loo"` then runs on + layers its storage limit refuses. It does not lift the 5,000-row limit of + `"nndm"`; `"knndm"` is the design above it. + +* `fold_separation()` gains `prediction_points`: the locations to be + predicted. The held-out distances are then set beside the distances from + those points to the training data, and the result's `target` attribute + carries a `reading`: `"closer"` (the cross-validated error tends to read + low for that target), `"farther"` (it tends to read high), `"matched"` or + `"mixed"`. NNDM and kNNDM folds are read against the prediction distances + they carry. The table gains `target_median_dist` and `dist_gap`. + +* Every classed `estimate_sac_range()` result says how far its nugget can be + trusted. `nugget_at_bound` is `TRUE` when the fit put the nugget at zero, + which is the bound of the search and not an estimate; `first_lag` is the + shortest lag resolved; `short_lag_semivariance` is the semivariance of + nearest-neighbour pairs with no model, an upper bound on the nugget. + `?sac_nugget` describes them. The result also records `n_used`, + `n_missing`, `n_subsampled`, `structure_p`, `morans_i`, `lags` and + `lag_boundaries`. + +* `estimate_sac_range()` reads rows that share a location as one place. The + test for spatial structure is made on the location means, pairs at zero + separation are in no lag bin, and their semivariance, the variance between + visits, is returned as `zero_lag_semivariance`. When the rows outnumber + the locations by 30 or more, the nugget fitted to the variogram is not let + under it (`nugget_floor`). With `detrend = "reml"` the fit takes one row + a location, drawn under `seed`, and takes no such floor. + +* `select_resolution(criterion = "cp")` says when the count is not + identified. `structured` is `FALSE` when one cell for the whole layer + scores within `tol` of the optimum, or when the cell means at the optimum + differ from one mean by no more than chance (an F test at 5 percent, + adjusted for the levels searched; `structure_p`). The pick is unchanged. + On white noise of 300 points it was `FALSE` on 145 of 150 layers. The + functions that take the count raise a warning of class + `spatialkit_no_structure`. `resolution_profile()` keeps what one cell + scores in `attr(, "one_cell")`. + +* `determine_optimal_levels()` gains `on_no_elbow = c("warn", "na", + "error")`. The no-elbow warning has class `spatialkit_no_elbow` and + carries the count and `structured = FALSE`; `"na"` returns `NA_integer_` + in place of the chord rule's answer and `"error"` stops. + `criterion = "morans_i"` and `"combined"` run with a response and no + predictors, where they fell back to the geometric ranking. A layer of one + or two points, or with every point on one location, returns 1 under the + same rule; it returned 1 with nothing said. + +* A GWR fit gives its standard errors. `coef(fit, se = TRUE)` returns the + local estimates with their standard errors and t values, and + `predict(fit, newdata, se.fit = TRUE)` the standard error of the fitted + value (`se.fit`) and of a new observation (`se.pred`). They follow + GWmodel's definitions, treat the bandwidth as known, and are not adjusted + for the number of local tests. `print(summary(fit))` shows the effective + number of parameters and the AICc and RMSE of a global least-squares fit + on the same rows (`info$global_ols`): a GWR whose AICc is no lower has not + shown that its coefficients vary. + +* `fit_gwr_model(predictor_vars = character(0))` fits the model with a local + intercept alone, the kernel-weighted mean of the response. It is the + baseline a GWR with predictors has to beat, and + `select_features_forward()` fits it as the null model of a GWR sweep. + +* `predict()` on a GWR says when a location is beyond the reach of the fit. + When a new location's nearest training point is farther than the widest + kernel at any training location reaches, the prediction is returned and a + warning of class `spatialkit_gwr_extrapolation` gives the count. The + warning that counts `NA` predictions has class + `spatialkit_gwr_not_estimable`. Both carry their counts as fields. + `predict_surface()`, `cv_gwr()`, `cv_spatial()`, `cv_block_size_sweep()` + and `select_features_forward()` raise each once per call, with totals. + +* `gwr_model_selection()` scores the model without predictors as ``, + and `best` is `character(0)` when it wins. The table gains `delta`, each + model's criterion minus the best one's, and `print()` lists the models + within 2 of the best and names the smallest (`within_2`, + `smallest_within_2`). The sweep runs on the package's own solve, so a + candidate that is constant inside some windows no longer stops it. + `dmat_max_n` is accepted and ignored. + +* `area_of_applicability()` gains `categorical = c("refuse", "indicator", + "drop")` for factor and character predictors. `"refuse"` is the default, + as before. `"indicator"` codes each level as a 0/1 column with one shared + scale per predictor, and a row on a level no training row has gets + `DI = Inf`. `"drop"` computes the index on the numeric predictors. + +* `select_features_forward()` gains `null_fn`, a function that fits the + no-predictor model for a learner that cannot. `history` always starts + with the step-0 row and gains `gain`, `fold_gain` and `fold_gain_se`; the + result gains `baseline` (its type, score and the path reached) and + `fold_scores`. + +* `fit_bayesian_spatial_model()` reports what its GP basis resolves. The + reduced-rank basis cannot represent structure below a floor, 14 to 33 + percent of the extent along each axis at the defaults, stored in map units + as `$info$gp_resolution` and shown by `print()`. The new argument + `gp_resolution` asks for a resolution in map units and derives `gp_k` and + the length-scale prior from it, up to 50 functions per dimension. Before + compiling, a variogram range below the floor can raise a warning of class + `spatialkit_gp_resolution`. After sampling, `$info$gp_adequacy$status` + is `"ok"`, `"below_resolution"`, `"unresolved_short_range"`, + `"no_signal_above_floor"` or `"not_checked"`, from the length-scale + posterior, the process's share of the variance and a short-lag Moran's I + of the residuals; the two that say the basis is too coarse raise + `spatialkit_gp_adequacy`. `convergence_ok` stays about the sampler. + +* `cv_bayes()`'s `fold_metrics` and `compare_models()` gain a `gp_adequacy` + column beside `convergence_ok`. `cv_bayes()` and `cv_spatial()` collect + the classed warnings a Bayesian fit raises in each fold and raise each + class once, naming the folds (fields `folds`, `fold_messages`). + +* `build_tessellation()` and `create_voronoi_polygons()` gain `cover`: the + observations, or a polygon, that the cells have to hold when the + generators are seeds made elsewhere. Seeds with neither a boundary nor a + cover raise a warning of class `spatialkit_no_cover`. `params` gains + `boundary_source`, `n_outside` and `cover_outside`. + +* `assign_features_to_polygons()` records the features no polygon holds as + `attr(, "unassigned")` (`n`, `which`), beside `"ties"`, and names the + column the polygon IDs were read from when `polygon_id_col` is absent. + The new argument `quiet` silences that message. + * `fold_separation()` measures what blocked cross-validation is for: the distance from every held-out point to its nearest training point, summarised per fold. Until now the only evidence a fold scheme worked was a proxy --- the block size compared against the estimated autocorrelation range, which `make_folds()` warns about. That is a statement about the - design; this is the result, and the two can disagree in the direction that - matters. Measured on 300 points over a 1000-unit square with a fitted - range of 292.5: blocks of 343 units are wider than the range, so - `make_folds()` raises no warning at all, and yet 76 percent of the - held-out points still sit closer to a training point than the range, the - nearest of them 23.3 units away. Blocks wider than the range leak wherever - a test point sits near a block edge with training data just across it, - which in a fine grid is most of them. The returned table carries - `n_train`, `n_test`, `n_blocks`, `min_dist`, `median_dist` and - `within_range` (the share inside the range), and its `print()` method - closes with what that share means for the score. Nothing is estimated: + design; this is the result. The returned table carries `n_train`, + `n_test`, `n_blocks`, `min_dist`, `median_dist` and `mean_cor`, the + mean correlation: the mean of `exp(-3 d / range)` over the + held-out points, so a point at a twentieth of the range weighs more than + one at nine tenths of it. Nothing is estimated: the distances come from the geometry and the range is the one the folds already carry or the one you pass. A range that records its CRS (the folds' own `params$sac_range` and `params$crs`, or an `estimate_sac_range()` result) is compared with distances measured in that - CRS, so a copy of the layer in other units gives the same answer (a - US-foot copy used to report 19 percent of the hold-out inside a metre - range where the metre layer reported 89); `sac` and the distances are in - the units of the CRS the `crs` attribute names, metres for lon/lat input. + CRS, so a copy of the layer in other units gives the same answer; `sac` + and the distances are in the units of the CRS the `crs` attribute names, + metres for lon/lat input. `fold` is the `fold_id` a `cv_*()` result's `$folds` carries, so a join on - it pairs each fold's error with its own distances (it was the list - position, which after a dropped fold paired one fold's error with - another's distances). A `units` object for `sac` is refused. As in - `cv_*()`, a `make_folds()` result whose recorded rows sit at other - locations in `data_sf` is refused. Folds built on `prep_model_data()`'s - 200 points and measured on the 195 that `assign_features_to_polygons()` - kept used to be matched by position, and reported 100 percent of the - hold-out inside the range against 23--48 percent on the right layer. The - location check is skipped when one layer is POINT and the other is not, - so folds built on polygons still measure their pointized copy. The - `print()` verdict now depends on the fold scheme: "widen the blocks" is - said only of blocked folds, buffered leave-one-out is told to widen the - buffer, and random, leave-location-out and hand-made splits are told to - use blocked or buffered folds. NNDM folds are no longer called - optimistic: they are built to reproduce the prediction-to-data distances, - so the share describes the prediction task. The range line gives the - CRS's unit ("in metres"), where it used to print the CRS code as if it - were a unit ("in EPSG:32617 units"). + it pairs each fold's error with its own distances. A `units` object for + `sac` is refused. As in `cv_*()`, a `make_folds()` result whose recorded + rows sit at other locations in `data_sf` is refused; the location check is + skipped when one layer is POINT and the other is not, so folds built on + polygons still measure their pointized copy. `print()` reports the + distances and says which way the score tends to err only when it is given + the prediction locations (`prediction_points`, below); it shows the first + ten folds of a design with more than twenty. The range line gives the + CRS's unit ("in metres"). * `summary()` on a `resolution_profile()` puts every criterion's pick in one table: the level each prefers, the flat region around it, whether a ladder @@ -72,8 +672,8 @@ now names the reason in the returned object. Beside it, `orphan_rows` holds the row IDs no fold names (they enter no training set and are never scored --- non-empty only when the folds were built on a different or - subsetted layer), `n_unknown_ids` counts fold entries naming rows the data - does not have, and `n_dropped` the rows `prep_model_data()` removed before + subsetted layer), `n_unknown_ids` counts the distinct rows the folds name + that the data does not have, and `n_dropped` the rows `prep_model_data()` removed before any fold was fitted. The four together account for every row and every fold, so `n_folds_attempted - n_folds_succeeded` never has to be explained from the log. A parallel worker that was killed outright (for lack of @@ -161,10 +761,12 @@ `deff_rows`, the per-cell design effect at the cell's row count that the log line reduced to a median and a max. A `summarize_by_cell()` call that requests a design effect (any `deff` other than 1) also returns a logical - `deff_applied` column, `TRUE` on every row when the correction was applied - and `FALSE` when it fell back to the uncorrected standard errors; unlike + `deff_applied` column, `TRUE` on every row when a correction was applied + (a Kish fallback included; `deff_method` names the correction) and `FALSE` + when the standard errors are the uncorrected ones; unlike the `"deff_applied"` attribute it survives `rbind()` and - `dplyr::bind_rows()` of many results. The default frame is unchanged. + `dplyr::bind_rows()` of many results. At the default `deff = 1` the + column is not added. `assign_features_to_polygons()` reports the features that matched more than one polygon and had the `tie_break` rule decide for them, as `attr(, "ties")` and a log line; a tie-break firing on a third of the @@ -238,8 +840,8 @@ version of `cell_weight`); `..df_*`, the degrees of freedom the interval uses; and `..ci_lo_*` / `..ci_hi_*`, a t interval for the cell mean as an estimate of the grand mean, built on the design-effect-corrected standard - error. The default `conf_level = NULL` returns exactly the frame it always - did. The degrees of freedom are `n - 1` at `deff = 1`, for a numeric + error. The default `conf_level = NULL` adds none of these columns. The + degrees of freedom are `n - 1` at `deff = 1`, for a numeric `deff` and for `deff = "kish"`, because the interval's spread is estimated from the within-cell variance, whose `n - 1` df survive exchangeable correlation whatever the design effect (measured 95% coverage on the Kish @@ -363,12 +965,15 @@ the classed, inspectable shape too. * `resolution_profile()` and `select_resolution()`: the number of cells, - scored on every criterion at once. `resolution_profile()` runs a - log-spaced ladder of level counts from a floor the autocorrelation range - implies (`ceiling(area / range^2)`) to a ceiling the support implies - (`floor(n / min_cell_n)`, where `n` is every point in the layer, not the - `sample_n` subsample the k-means runs on), fits each level as the best of - 25 k-means++ restarts, and returns a data.frame with the WSS elbow + scored on every criterion at once. Given a ladder argument (`n_levels`, + for one; at the defaults it scores one size, see Breaking changes), + `resolution_profile()` runs a log-spaced ladder of level counts from 2 to + a ceiling the support implies + (`floor(n / min_cell_n)`, where `n` is the rows of the layer that carry a + response, not the `sample_n` subsample the k-means runs on), reports the + floor the autocorrelation range implies (`ceiling(area / range^2)`), + fits each level as the best of its partition's k-means++ starts (25 for + `partition = "kmeans"`), and returns a data.frame with the WSS elbow statistic (read on log-log axes, and `NA` when the points have no cluster structure to bend the curve), Mallows' C_p of the piecewise-constant approximation of the response (or of @@ -376,7 +981,8 @@ response and predictors, with the nugget from the fitted variogram as the noise variance and the penalty set for the whole layer), the standardised residual Moran's - z of the cell means, and an analytic reliability of the cell means + z of the cell means (a diagnostic, not a count rule), and an analytic + reliability of the cell means --- the share of their spread that is between-cell signal rather than sampling noise, from the variogram alone via Krige's additivity relation (Cressie 1996), the shrinkage factor of Fay and Herriot (1979) --- plus @@ -448,12 +1054,12 @@ is one short of the points rather than crediting the distinct locations. Points with empty or non-finite coordinates are dropped with an R warning, as in `determine_optimal_levels()`; it was a log line alone. - `range_floor = FALSE` starts the ladder at 2 whatever + `range_floor = FALSE`, the default, starts the ladder at 2 whatever the range and only reports the floor, so profiles whose range estimates differ (cross-validation folds) have comparable ladders; with the floor applying on one fold and not the next, reliability and the elbow moved by - a factor of 10--15 between folds. The default, `range_floor = TRUE`, - keeps the floor, and the help page describes that regime switch. Under + a factor of 10--15 between folds. `range_floor = TRUE` starts the ladder + at the floor. Under `select_on = "split"` a supplied `sac` is flagged in the log, since it must be fitted on the selection half, and the help page shows the two-call workflow. @@ -610,8 +1216,8 @@ accept what the level-selection step returned: the integer vector of ranked candidates from `determine_optimal_levels()` (its first element is used), a `select_resolution()` result (its `$best`), or a - `resolution_profile()` (read with `select_resolution()` at its default - criterion). Both were hard errors before, so nothing that worked + `resolution_profile()` (read by `cp`; a profile with no `cp` is an + error). Both were hard errors before, so nothing that worked changes; the count used and where it came from are recorded as `params$approx_n_cells` / `params$approx_n_cells_from` and as `attr(seeds, "n_from")`. The two functions the pipeline documents as a @@ -718,7 +1324,8 @@ them and the largest size that gives `k` blocks; they were dropped with only a log line. A `units` object for `block_sizes` is refused by name. On clustered data `make_folds()` can still lower `k` at the top sizes, - which the `k` column shows. The default ladder also skips sizes whose + which the `k` column shows; the sweep warns once, naming those sizes. The + default ladder also skips sizes whose grid would exceed the 1,000,000 blocks `make_folds()` builds (a 6 km x 2 m transect used to abort with an error about `block_size`), runs along the line for points on one axis-parallel line (they were refused as having "no @@ -752,12 +1359,12 @@ `info$n_local_collinear`, `info$n_local_singular` and the global `info$condition_index` (on the centred predictors) beside `AICc`. `n_local_collinear` and the warning count the windows whose slopes are - collinear (`cn_slopes` above 30, or `cn` above 1e6), so a predictor's + collinear (`cn_slopes` above 30, or singular), so a predictor's origin (degrees C or kelvin) does not change the verdict. The warning is now the exact fraction of locations rather than a sampled one, and its - thresholds (a quarter of the locations, or any) are unchanged; above a - quarter it now says that an exactly singular window stops the fit, instead - of promising non-finite coefficients. The weighted survey sees what the + thresholds (a quarter of the locations, or any) are unchanged; it says + that a coefficient an exactly singular window cannot estimate is `NA`. + The weighted survey sees what the unweighted spot-check could not: a bisquare window's edge points contribute almost nothing to the fit, so they contribute almost nothing to its conditioning. The survey also runs with a single numeric predictor, @@ -788,21 +1395,24 @@ of the variance the cell's mean would have with no data at all (`kr_ratio`, the coverage score --- near 1 the data tell the cell nothing; a share of the point sill never came near 1 for cells larger than the - range), whether it exceeds the design-based `s^2/n` of the - plain mean (`kr_exceeds_design`), and the kriged-minus-plain shift in - standard errors (`kr_shift`); plus the variance of the standardised + range), the error variance of the cell's plain mean under the same + variogram (`plain_var`), the share of it kriging removes (`kr_gain`), and + the kriged-minus-plain shift over the standard deviation the variogram + gives that difference (`kr_shift`); plus the variance of the standardised errors from blocked cross-validation (`attr(, "cv")$zscore_var`), which is about 1 when the kriging variance is right. Measured on simulated exponential fields: 0.93--1.07 with the true variogram, 0.85--1.01 with the estimated one; under blocked folds it checks the sill and range rather than the nugget (0.95--1.24 with the nugget understated tenfold), and random folds are the instrument for the nugget. The comparison the - function exists for: under uniform sampling kriged and plain means - differed by more than one standard error in 11--24 percent of cells; under - clustered sampling in 34--63 percent, with 3--27 of 16--64 cells empty - and kriged anyway. Repeat visits to one location are kriged from their - mean, with the part of the nugget that varies between visits divided by - their count; kriging them as separate rows made every kriging system + function exists for, against known cell averages on those fields: kriging + cut the plain mean's squared error by 54--56 percent under uniform and + clustered sampling alike, where `kr_var` over `plain_var` predicted + 55--58. A naive `s^2/n` below `plain_var` says the naive standard error + is too small under the variogram; `kr_var` is not compared with `s^2/n`, + which moves with the fitted sill. Repeat visits to one location are + kriged from their mean, with their pooled within-location variance + divided by their count; kriging them as separate rows made every kriging system singular and returned `NA` everywhere. Any cell or held-out location gstat still cannot solve is counted in a warning. This is the first kriging path in the package (`gstat::krige()`); its model families are @@ -858,8 +1468,8 @@ metric columns by position is unaffected; code pinning the exact column set needs the two names added. -* `voronoi_seeds_kmeans()` gains `nstart`, the number of `stats::kmeans()` - starts (default 10, as before). +* `voronoi_seeds_kmeans()` gains `nstart`, the number of starts (10 for + `partition = "kmeans"`, as before). * `cv_bayes()` and `compare_models()` say when a Bayesian fit did not converge. Both scored such a fit like any other, and only the fit's WARN @@ -867,9 +1477,10 @@ `spatialkit_quiet()` hides) said that its posterior was not to be trusted. `cv_bayes()`'s `fold_metrics` gains `convergence_ok`: `TRUE` or `FALSE` as `fit_bayesian_spatial_model()` judged that fold's sampler - (R-hat, effective sample size, divergences), and `NA` when `fit_args` - sets `check_convergence = FALSE`. A run with any `FALSE` raises one - warning naming those folds. `compare_models()` gains the same column and + (divergent transitions, R-hat, effective sample size, E-BFMI), and `NA` + when `fit_args` sets `check_convergence = FALSE`. A run with any `FALSE` + raises one warning of class `spatialkit_convergence` naming those folds + and the checks each failed. `compare_models()` gains the same column and warns once for each model that did not converge. Code that pins the exact column set of either table needs the new name added. @@ -895,6 +1506,196 @@ ## Bug fixes +* **`estimate_sac_range()` drew its `n_max` subsample over rows with nothing + to model.** 300 valued rows among 20,300 were estimated from the 74 that + fell in the draw, and 100 among 20,100 came back `NA`. Rows with a missing + or infinite response or predictor are now dropped first, and the subsample + no longer depends on the order of the rows. + +* **`estimate_sac_range(detrend = "reml")` kept the first fit to converge, + not the best.** When the true range is short against the extent the + starts of `nlme::gls()` lay in a valley of the likelihood: a layer with a + 10 km range came back at 502 km and was refused. The start is now the + best point of the profile likelihood on a grid, and the fit with the + largest log-likelihood is kept (`attr(, "reml")` gains `logLik`, + `logLik_gain` and `n_fits`). + +* **`estimate_sac_range()` returned `NA` or an R error for a bad argument + without naming it.** `cutoff`, `range_frac`, `n_max`, `seed`, + `keep_directional_fits`, `n_lags` and `structure_alpha` are checked, and a + bad value is an error that names the argument. `cutoff` above 1 and + `n_max` below 30 are errors; `n_max = Inf` means no subsample. + +* **`estimate_sac_range()` called a response constant by an absolute + floor.** A response whose standard deviation was under 1.5e-8 in its own + unit was refused, and so was one of standard deviation 1 on a mean of + 1e8. The test is now relative: under 1e-12 of the largest absolute value. + +* **The projection chosen for lon/lat input depended on the order of the + rows.** `ensure_projected()` scores candidate projections on a sample of + the points, taken at even spacing along the rows: 400 points over the + conterminous United States got an Albers CRS in some row orders and a + Lambert azimuthal one in others. The sample is now taken along the points + sorted by coordinate. + +* **`resolution_profile()` reported a layer too small for a ladder as + supported.** With fewer than two cells at `min_cell_n` it raised the + ceiling to 2 with `supported = TRUE`. It still scores two cells, with + `supported = FALSE`, `ceiling_from = "fewer than two supported cells"` and + a warning of class `spatialkit_not_supported` that says what would work. + +* **A constant response got a finite `cp`.** A response of 1e6 plus + rounding noise was scored on its rounding error and `select_resolution()` + returned 2 cells for it. `cp`, `moran_i` and `moran_z` are now `NA` at + every level, with a warning of class `spatialkit_constant_response`. + +* **`determine_optimal_levels()` returned 1 for a layer with no rows.** It + is now an error. + +* **The leakage warning of `make_folds(method = "block_kfold")` recommended + settings that stopped with an error or returned fewer folds.** It ended + "Pass block_size = or auto_range = TRUE" whatever the layout. The + warning now builds the grid the advice asks for and says what comes back: + the setting when that gives `k` folds, and otherwise the largest block + size that does and `method = "nndm"` (`"knndm"` above 5,000 rows) as the + design that needs no block size. The single-block error names that size too. + +* **`make_folds()` returned fewer folds than asked with only a log line.** + `"random_kfold"` with more folds than rows, `"block_kfold"` with fewer + than `k` occupied cells and `"leave_location_out"` with more folds than + groups now raise a warning of class `spatialkit_k_reduced`, which carries + `k_requested` and `k` and gives a setting that works. + `params$k_requested` records the `k` asked for, and `params$block_width` + and `params$block_height` the cells built. `cv_block_size_sweep()` gathers + the reductions of its sizes into one warning, and its table gains the + columns `block_width` and `block_height`. + +* **`fold_separation()` printed "this score is optimistic" from a share that + cannot give a direction.** Which way a score errs depends on how the + held-out distances compare with the distances from the prediction + locations to the data. Without `prediction_points` the function now + reports the distances and draws no conclusion. The column `within_range` + (the share of held-out points closer than the range) is replaced by + `mean_cor`, the mean correlation between a held-out point and its nearest + training point; code that reads the old column has to be changed. + `n_unknown_ids` counts each row once; it counted fold entries, so five + missing rows read as 25 at `k = 5`. + +* **`make_folds(method = "nndm")` returned plain leave-one-out without a + warning when the prediction points were nearer to the data than + leave-one-out can reach.** Excluding neighbours only lengthens a held-out + distance. A warning of class `spatialkit_nndm_out_of_reach` now says that + the cross-validated error is an upper bound for those locations, and + `params` gains `max_ecdf_deficit`, `loo_ecdf_deficit`, + `target_out_of_reach` and the Wasserstein distances. + +* **`cv_spatial()`, `cv_rf()`, `cv_gwr()`, `cv_bayes()` and + `compare_models_cv()` dropped `block_size` and `auto_range = TRUE` without + a word when `folds` was supplied.** They raise a warning of class + `spatialkit_fold_args_ignored`. + +* **`compare_models(fits, newdata = )` labelled training-residual Moran's I + as a `newdata` metric.** A new column `resid_morans_basis` says + `"in-sample"`, or `"out-of-bag"` for a forest. + +* **`compare_models_cv()`, `cv_block_size_sweep()` and + `select_features_forward()` repeated the same data warning for every + model, size or candidate set.** The warnings `prep_model_data()` raises + about a layer are raised once per call. With `parallel` above one core, a + fold's classed warning keeps its class and fields. + +* **`model_metrics(fit, newdata, draws = TRUE)` stopped with "missing value + where TRUE/FALSE needed".** `draws = TRUE` and `se.fit = TRUE` are + refused by name: the metrics take one predicted value per row. + +* **A predictor far from zero made `fit_gwr_model()` report every window as + collinear.** Windows whose condition index with the intercept (`cn`) was + above 1e6 were counted, a rule for a solve of the uncentred normal + equations. A window's slopes now count as collinear on the slope index + alone (`cn_slopes` above 30, or singular). + +* **The GWR bandwidth search could select a bandwidth at which a term is + estimable at no location.** Such a bandwidth is not selected; when every + bandwidth is like that the widest is used, with a warning and + `info$bandwidth_is_fallback = TRUE`. + +* **`area_of_applicability()` returned a threshold of 0 for repeat visits.** + With `folds = NULL` a training row that repeats another's predictor values + was its own nearest neighbour at distance 0: 60 sites visited 4 times put + 30 of 200 new points inside. Each row's reference is now its nearest row + with different values, and the same layout puts 188 inside + (`n_duplicates` counts the repeats). With `folds`, a threshold of 0 is a + warning of class `spatialkit_aoa_zero_threshold`. + +* **Without FNN, `area_of_applicability()` gave exact copies of training + rows a small non-zero distance.** About one copy in ten came out near + 1e-8 and could fall outside a threshold of 0. The distance returned is + now recomputed exactly. + +* **`select_features_forward()` always selected at least one variable with a + forest or a GWR.** A learner that could not fit an empty predictor set + had no baseline, so the first variable was accepted whatever it scored. + The baseline is now the learner's own null model (a GWR fits one), + `null_fn`, or the mean of each training fold. Under a fold-mean baseline + the first variable is tested at the end and can be dropped + (`baseline$first`); `plot()` draws the path as walked. A forest sweep can + still add noise variables after the real ones, because an extra variable + regularises the forest; `?select_features_forward` says how to read that. + `tol` takes any single number, `Inf` included. + +* **`plot()` on an area of applicability with a location index counted the + wrong rows beside the predictor threshold.** It printed the rows outside + on either index. The subtitle now counts the predictor index, location + and the total separately. + +* **One row of `newdata` with a factor level the model was not fitted with + made `predict()` on a `bayesian_fit` return `NA` for every row.** Rows + with such a value are `NA`, the rest are predicted, and a warning of class + `spatialkit_new_levels` names the predictor and the levels. Any other + failed posterior draw is a warning of class `spatialkit_predict_failed`, + where it was a log line. + +* **`prep_model_data()` dropped incomplete rows with a log line only.** + When preparing data for a fit it raises a warning of class + `spatialkit_rows_dropped` with the number and share of rows, the count by + reason and by column, and how far the response of the dropped rows sits + from that of the kept rows. A predictor with one value in every kept row + raises `spatialkit_constant_predictor`. Preparing `newdata` for + `predict()` raises neither. `attr(, "dropped")` gains `by_column`, + `response_std_diff`, `constant_predictors` and `n_duplicate_locations`. + +* `fit_bayesian_spatial_model()` stops before compiling when the response + takes a single value, and raises a warning of class + `spatialkit_gp_basis_size` when there are fewer rows than a tenth of the + basis functions. + +* **`summarize_by_cell()` let one infinite value through.** An `Inf` in a + response or predictor column made its cell's mean `Inf` and, under + `deff = "kish"`, set the ICC to 0 for every cell. Infinite values are now + left out of every statistic of their column, as `NA` is, with a warning of + class `spatialkit_nonfinite`. + +* **`kriging_adequacy()` kriged a factor on its level codes.** A response + that is not numeric or logical is an error that names the column and its + class. A logical response is kriged as 0/1. + +* **`kriging_adequacy()` capped the replicates' variance at the nugget.** + Under a model with too small a nugget the means of repeat observations + were kriged as more exact than their replicates show. Their pooled + within-location variance `sw2` is now used as it is: a mean of `m` + replicates has error variance `max(c0 - sw2, 0) + sw2 / m` for a nugget + `c0`. A warning of class `spatialkit_replicate_var_above_nugget` gives + both numbers, and `attr(, "replicates")` records them. + +* **A subset of an assigned layer kept its parent's `"unassigned"` record.** + `[` and the dplyr row verbs drop it, as they drop `"dropped"` and + `"ties"`. + +* `plot.resolution_profile()` says "fewer than two cells meet `min_cell_n`" + of a profile that is unsupported for that reason; it said the floor + exceeds the ceiling. `plot_folds()` and `print()` on a + `kriging_adequacy()` result label kNNDM folds. + * **`ensure_stable_poly_id()` stopped on a cell that is valid in its own CRS and crosses itself in lon/lat, and took `build_tessellation(method = "voronoi")` with it.** The sort key is measured on a lon/lat copy with s2. @@ -969,10 +1770,10 @@ `cp` is `NA` at every level for such a sac, where it was finite; the warning's last clause says so, and the notice is not raised. A fit that converged to a range past the lags, or on a falling variogram, still gives - `cp` its nugget. `estimate_sac_range()` returns what it did; - `?estimate_sac_range` now says that the count of `"variogram model did not - converge"` reasons understates how many fits did not converge, and where - to read it. + `cp` its nugget. (`estimate_sac_range()` no longer fits with gstat's + iterative fit: the flag is now `FALSE` when the criterion has no minimum + inside the ranges searched, and the reason `"variogram model did not + converge"` is carried only by results stored by earlier versions.) * **A clipped cell that also touched the boundary from outside was dropped, and its points left with no cell.** `st_intersection()` returns such a @@ -1110,7 +1911,7 @@ scrambling the prediction locations with no warning; `gwr_model_selection()` ranked models on 3-D distances; and `fit_gwr_model()` and `cv_gwr()` failed. Z and M are now dropped in - `prep_model_data()` and again where the data are handed to GWmodel. + `prep_model_data()` and again where a GWR takes its coordinates. * **`predict.gwr_fit()` lost every prediction to one bad location.** It went through `GWmodel::gwr.predict()`, which returns nothing for any row if @@ -1119,10 +1920,9 @@ training and new rows together exceed 10,000 (a 100 by 100 prediction grid came back all `NA`), and it built the full training hat matrix for a variance it then discarded, which is cubic in the training size. - Predictions now come from `gwr.basic(regression.points = )` in chunks, a - failing chunk is redone location by location, and only a truly singular - location is `NA`, with a warning counting them. Where the old path - worked, the values are identical. + Predictions now come from the package's own local regressions, one per + new location, and only a location with no estimable prediction is `NA`, + with a warning counting them. * **On brms 2.17 to 2.22, one far-off row moved every Bayesian prediction in the call.** brms rebuilt the Hilbert-space GP's boundary from the rows @@ -1623,7 +2423,8 @@ structured component) implies that distinct observations are uncorrelated, so it is applied as a design effect of 1 in every cell, with `deff_applied = TRUE`; it was reported as "the supplied model could not be - read", with the fallback warning. + read", with the fallback warning. (The fallback is now to `"kish"`; see + Breaking changes.) * **An empty point switched off `summarize_by_cell(deff = "variogram")` for its cell.** Its missing coordinates made the cell's mean correlation @@ -1725,9 +2526,9 @@ sill are the shorter ones, so their maximum is a lower bound, not an estimate. A converged all-pairs fit past the fitted lags is now refused whatever the directions found (`rejected_reason = "fitted range exceeds - the largest lag fitted"`, the directional ranges still attached); the - directional maximum stands in only for an all-pairs fit that is singular - or did not converge. On stationary fields whose range is close to the + the largest lag fitted"`, the directional ranges still attached), and + the directional maximum does not stand in for any other all-pairs fit + either (see Breaking changes). On stationary fields whose range is close to the cutoff this also turns a few draws from a directional maximum into `NA` (3 of 30 at an effective range of 570 on a 1000 m square). @@ -2007,18 +2808,15 @@ 221 around a true 3 with no warning, while adding a noise predictor to the same data warned at every location. One numeric predictor is now enough. -* **GWR said a singular window came back as `NaN` coefficients; it stops +* **GWR said a singular window came back as `NaN` coefficients; it stopped the fit.** GWmodel's matrix inverse throws on an exactly singular window, so a 0/1 indicator constant within clusters failed the whole fit with a bare "inv(): matrix is singular", while the help page and the collinearity - warning promised masked `NaN` coefficients. The non-finite coefficients - GWmodel does return come from co-located points, where an adaptive - bandwidth no larger than the number of observations at a site gives the - kernel zero width (160 of 160 at 40 sites of 4 observations, 4 - neighbours), and the warning blamed singular windows for those. The fit - error now says a window is singular and how many the collinearity check - found, and the non-finite warning names co-located points when they are - the cause. + warning promised masked `NaN` coefficients. The package now solves the + local regressions itself: a coefficient a window cannot estimate is `NA` + and the fit goes on (see Breaking changes). A zero-width adaptive kernel + at co-located points still leaves a window with no weighted row, and the + warning names the co-located points when they are the cause. * **An adaptive GWR bandwidth above the number of points was capped in silence.** `bandwidth = 1500`, meant as metres with `adaptive` left at @@ -2030,11 +2828,10 @@ * **Below 20 points, `bandwidth = NULL` did not fit at the bandwidth `bw.gwr()` chose.** GWmodel searches adaptive bandwidths from 20 - neighbours up to n, so with fewer points its choice exceeds n (18 for 12 - points) and was capped at n, a different kernel with a worse AICc (18.3 - against 9.7), without a word. The cap stays and now raises a warning in - `fit_gwr_model()` and `gwr_model_selection()`; supply `bandwidth` for data - this small. + neighbours up to n, so with fewer points its choice exceeded n and was + capped at n, a different kernel with a worse AICc, without a word. The + package's own search starts at the smallest bandwidth the model allows, + so a layer this small is searched like any other. * **A GWR predictor named twice raised false collinearity warnings.** `fit_gwr_model(predictor_vars = c("a", "b", "a"))` fitted correctly, but @@ -2174,9 +2971,11 @@ sampling --- have a training DI of 0; past about three quarters of the rows the threshold is 0 and only exact copies count as inside (30 sites visited four times: 0 of 200 new points inside, against 197 after deduplication). - The rule is unchanged; the result is now logged with the remedy - (leave-location-out folds, or deduplication) and `print()` shows the count - of zero training DI. + Without folds a row's reference is now its nearest row with different + predictor values, so repeats no longer set the threshold; with folds a + threshold of 0 is a classed warning that gives the remedy + (leave-location-out folds, or deduplication). See the entry on repeat + visits above. * **`area_of_applicability()` refused all-zero weights, which the advice `pmax(importance, 0)` produces whenever the model found no useful @@ -2471,8 +3270,9 @@ threw the corrected result away. When the estimate was rejected too, the one fallback raised two R warnings. A `sac` that an estimate replaces now gets a plain warning saying what replaced it, and the fallback warning is - raised once per call, only when the standard errors really are the - uncorrected ones, naming every reason, the rejected `sac` included. + raised once per call, only when the correction applied is not the one + asked for (Kish, or none), naming every reason, the rejected `sac` + included. * **`summarize_by_cell(deff = "variogram")` ignored a `sac` that carried no variogram model without saying so.** A plain number, or @@ -2482,7 +3282,7 @@ `sac` is now set aside with a warning, as a rejected `sac` is: a plain warning when a variogram is estimated instead, and the classed `spatialkit_deff_fallback` warning, naming it, when `deff` falls back - to 1. + to `"kish"`. * **`summarize_by_cell(deff = "kish")` recorded no correction when only the predictor standard errors were corrected.** The `"deff_applied"` @@ -2650,8 +3450,7 @@ `info$local_collinearity$cn` and adds `cn_slopes`: the predictors centred at their weighted mean in the window, each divided by its standard deviation over the study area. A window's slopes count as collinear when - `cn_slopes` is above 30 or singular, or when `cn` is above 1e6, where - GWmodel's uncentred solve starts losing precision in the slopes. + `cn_slopes` is above 30 or singular. `n_local_collinear` and the warning count those windows. The kelvin and degrees C fits now get the same verdict (0 of 200 locations), and a regional covariate nearly constant within clusters is still flagged @@ -2737,6 +3536,57 @@ ## Documentation +* The README, the vignettes, the help's examples, the scripts in + `inst/scripts/` and the README's figures follow the new defaults, and each + document says, where it brings in the pipeline, how to get the earlier + behaviour. `?summarize_by_cell` gives two results of a second + simulation, on fields whose level jumps at boundaries: the error of the + pooled value at observations beside such a boundary, and the coverage of + the interval for one observation in cells of one observation. + +* `?resolution_profile` describes `cp` as the error of re-measuring the + sampled sites. It no longer says `cp` estimates the error of predicting a + new observation by its cell's mean. The numbers are unchanged. + +* `?summarize_by_cell` says what `..se_*` and `..ci_*` cover at each `deff`: + at the default `deff = 1`, the cell's own mean, when its observations are + spread through the cell; under `"kish"`, `"variogram"` or a number, the + cell mean as an estimate of the population mean. It no longer names the + grand mean at every `deff`. The numbers are unchanged. + +* The README, the vignettes and the tour scripts describe the behaviour of + this version: GWR needs `sp` alone, `moran_z` is a diagnostic, the ladder + starts at 2 with the range floor reported, `kriging_adequacy()` returns + `plain_var` and `kr_gain`, `make_folds()` has six methods, and + `estimate_sac_range()` has seven refusals and no directional stand-in. + +* `?fit_rf_model` and the caution logged for `include_coords = TRUE` no + longer say that a forest given the coordinates fails wherever it has not + been. The gain from coordinates is largest between sampled points, fades + with distance and can reverse in a region the data never visited. The + advice that stays is to score such a forest with blocked or + distance-matched folds, never out of bag, and to compare it with the + forest without coordinates on the same folds; `?cv_rf` runs that + comparison in its example. + +* `?make_folds` and `?cv_block_size_sweep` no longer say that blocks built + from `block_size` are one to two times that size on each axis. That holds + on an axis at least as long as `block_size`; a shorter axis is spanned by + a single row or column of blocks as long as the extent there. + `?make_folds` says that the NNDM guarantee concerns nearest-neighbour + distances, so a learner that draws on several neighbours can still score + low on clustered samples. + +* `?area_of_applicability` has a Weights section with the cost of + importance weighting (a weak but real predictor is down-weighted by the + square of its relative importance), and says that the location index marks + a gap only when it is wider than the distance its threshold allows. + +* `?resolution_profile`, `?select_resolution` and + `?determine_optimal_levels` say what each criterion returns in practice, + and `?resolution_profile` lists which conditions are classed warnings, + classed errors, plain warnings and log lines. + * Every figure in the vignettes carries alt text, which is what a screen reader announces and the only thing a reader gets when an image fails to load. Each one states what the picture shows and what it is there to @@ -2770,12 +3620,12 @@ machine that ran it. `SPATIALKIT_TOUR_OUTPUT` writes the figures to a folder instead of the device; `SPATIALKIT_TOUR_PAUSE = "no"` skips the per-figure pause. A script skips the part that needs an absent package with a message - naming it, and scripts 02, 09 and 10 skip themselves when gstat, GWmodel or + naming it, and scripts 02, 09 and 10 skip themselves when gstat, sp or brms is absent. * Four vignettes join `spatialkit_nc_demo`: `getting-started` (installing, what the coordinates are in, the pipeline from points to a scored model and a map, and a glossary of the terms that recur), `resolution` (the ladder, the - four criteria and why they disagree), `spatial-cross-validation` (the five + criteria and why they disagree), `spatial-cross-validation` (the six fold schemes, block sizing, and reading a CV result down to the last row) and `diagnostics` (residual autocorrelation, aggregation standard errors, kriging adequacy, area of applicability, and two ways to leak). Each is executed at @@ -2884,26 +3734,18 @@ a single observation; the resolution vignette says the blocked split reduces the leak between halves rather than removing it. -* `?estimate_sac_range` now says that the exponential model is kept - whenever it converges and so overestimates the range on smoother fields - (about 1.8--2.1 times a Gaussian practical range, 1.3--1.4 times a - spherical one), and why the family is not chosen by fit (that biases - exponential fields low, to 0.82); that 15 lag bins make a range spanning - one or two of them come out long (60 m returned 89--102 m); that nothing - tests for spatial structure (white noise gave a finite range in 8 of 30 - draws); that the "decreases with distance" refusal also fires on small - samples of ordinary fields (7--9 of 60 at n = 30, 0--1 at n = 100), which - its warning now says below 100 points; that the anisotropy note goes to - the log file at INFO, not the console, and that the longest directional - range is read from `directional_fitted` after checking - `directional_status`, not `max(attr(, "directional"))`, which is `NA` - exactly when the major axis ran past the fitted lags (the note itself, the - nc_demo vignette and the help now say so); that an accepted range can - still exceed half the width of the layer, leaving - `make_folds(auto_range = TRUE)` room for one block (`range_frac`); and a - flat variogram's refusal message no longer claims the data "never reached - a sill" without mentioning that a structureless variogram ends there too. - The README counts six refusals, not five. +* `?estimate_sac_range` now says that only the exponential family is fitted + and so overestimates the range on smoother fields, and why the family is + not chosen by fit; that the "decreases with distance" refusal also fires + on small samples of ordinary fields, which its warning says below 100 + points; that the longest directional range is read from + `directional_fitted` after checking `directional_status`, not + `max(attr(, "directional"))`, which is `NA` exactly when the major axis + ran past the fitted lags; and that an accepted range can still exceed half + the width of the layer, leaving `make_folds(auto_range = TRUE)` room for + one block (`range_frac`). It has sections on the test for spatial + structure, the lags and structure at two scales, and lists the seven + `rejected_reason` values; the README counts seven refusals. * `?make_folds`: the NNDM details now say how the procedure differs from `CAST::nndm()` (a strict removal rule, one point more conservative per @@ -2928,12 +3770,12 @@ with the intercept and one for the slopes alone). `?fit_gwr_model` and `?gwr_model_selection` now state the adaptive bandwidth's floor and cap. -* `?fit_bayesian_spatial_model`: `check_convergence` says the checks write - WARN log lines and set `$info$convergence_ok` rather than "issue warnings", - and that under cmdstanr nothing is raised as an R warning; the basis - adequacy check is described as logged, and as changing neither - `convergence_ok` nor `print()` (the argument's text listed it among the - checks that set `convergence_ok` to `FALSE`); the `family` argument and +* `?fit_bayesian_spatial_model`: `check_convergence` lists the checks that + set `$info$convergence_ok` and the warning a failed verdict raises; a + section "What the basis resolves" describes the floor of the basis, the + check before compiling and the adequacy status after sampling, which + changes neither `convergence_ok`; a Warnings section lists the condition + classes; the `family` argument and the non-Gaussian section no longer promise that any response type brms can fit works here; the spatial confounding section warns that coefficients under `standardize_predictors = TRUE` are per standard deviation before @@ -2971,10 +3813,10 @@ the coordinates themselves, and the graticule on the maps, differ. * The examples of `resolution_profile()`, `select_resolution()`, `summary()` - and `plot()` on a profile use `set.seed(4)`, on which their comments hold - (C_p interior at 28 cells, reliability on the range floor); with - `set.seed(2)` C_p had moved to the support ceiling. The `plot()` example - no longer promises four panels on points that have no elbow. + and `plot()` on a profile use `set.seed(4)`, and their comments describe + either outcome for C_p (an interior level or the support ceiling) and + reliability on the range floor. The `plot()` example no longer promises + four panels on points that have no elbow. * Tour script 02 runs to the end again: step 02.6 drew the elbow's pick, which its evenly spread points no longer have, and now draws the C_p pick. @@ -3006,13 +3848,10 @@ effect, which the package page said were there; the package page lists it among the defaults that were chosen, not cited. -* `?estimate_sac_range` now says when the directional maximum is logged - (only when it stands in for a singular or non-converged all-pairs fit, at - WARN only above a ratio of 1.5, naming the directional ranges), and that a - range shorter than the first lag bin can come back several times too long - (a true 24 m returned 93--479 m at n = 1500, 19--32 m at `cutoff = 0.1`), - so a variogram at its sill in the first one or two bins calls for a - smaller `cutoff` whatever range was fitted. +* `?estimate_sac_range` now says that the largest directional range never + stands in for the all-pairs fit, and how the adaptive lags resolve a range + shorter than one equal lag bin, which equal bins returned several times + too long. * `?make_folds` no longer says `auto_range` "fits directional variograms to account for anisotropy". It sizes blocks from the omnidirectional range, @@ -3023,8 +3862,8 @@ lowered `k` just before that error is gone. The page no longer says NNDM never pushes a point's nearest-neighbour distance past `phi`: the last exclusion can take it past by one neighbour step, as in `CAST::nndm()`. - The description lists all five methods. The page now says that `k = 1` is - raised to 2 by the three k-fold methods, and that only `block_kfold` + The description lists all six methods. The page now says that `k = 1` is + raised to 2 by the k-fold methods, and that only `block_kfold` returns `params$blocks_supplied` and `params$boundary_supplied`. * The README's entry for "response 'y' is not numeric" notes that diff --git a/R/area-of-applicability.R b/R/area-of-applicability.R index fe79babd..45f89dec 100644 --- a/R/area-of-applicability.R +++ b/R/area-of-applicability.R @@ -14,9 +14,12 @@ #' Extract a numeric predictor matrix #' -#' Categorical predictors are refused instead of being silently dummy-coded: a -#' one-hot column has no meaningful standard deviation, so scaling it puts an -#' arbitrary number into a Euclidean distance. +#' Categorical predictors are refused here instead of being silently +#' dummy-coded: a one-hot column has no meaningful standard deviation, so +#' scaling it by one puts an arbitrary number into a Euclidean distance. +#' \code{.aoa_design()} is where a caller who asked for +#' \code{categorical = "indicator"} or \code{"drop"} gets them handled, with +#' a scaling that is stated; this function only ever sees the numeric ones. #' #' @keywords internal #' @noRd @@ -41,8 +44,12 @@ stop(sprintf(paste0("area_of_applicability(): predictor(s) in %s are not ", "numeric or logical: %s. The dissimilarity index is a ", "Euclidean distance in scaled predictor space and has ", - "no definition for categorical predictors; recode them ", - "yourself if you have a scaling you can defend."), + "no definition of its own for categorical predictors. ", + "Pass categorical = \"indicator\" to code each level as ", + "a 0/1 column (a level no training row has is then ", + "outside the AOA), or categorical = \"drop\" to compute ", + "the index on the numeric predictors alone; or recode ", + "them yourself if you have a scaling you can defend."), what, paste(sQuote(bad), collapse = ", ")), call. = FALSE) m <- as.matrix(sub) storage.mode(m) <- "double" @@ -51,6 +58,169 @@ } +#' Is a column categorical for the purposes of the index? +#' @keywords internal +#' @noRd +.aoa_is_categorical <- function(v) is.factor(v) || is.character(v) + + +#' Training and prediction matrices, with categorical predictors handled +#' +#' Numeric and logical predictors go through \code{.aoa_matrix()} unchanged. +#' A factor or character predictor (which is categorical is read from the +#' TRAINING data) is treated as \code{categorical} says: +#' \describe{ +#' \item{\code{"refuse"}}{\code{.aoa_matrix()}'s error, which names the two +#' alternatives.} +#' \item{\code{"drop"}}{left out of both matrices.} +#' \item{\code{"indicator"}}{one 0/1 column per level that occurs in the +#' training rows, named \code{"="}. A prediction row +#' whose level no training row has gets 0 in every one of them and is +#' flagged in \code{unseen}, so the caller can mark it outside.} +#' } +#' +#' @return A list: \code{X_tr}, \code{X_nw} (numeric matrices with the same +#' columns), \code{col_var} (the predictor each column came from), +#' \code{indicator} (logical, one per column), \code{cat_vars} (the +#' categorical predictors found), \code{vars} (the predictors still in the +#' index) and \code{unseen} (a logical matrix, prediction rows by indicator +#' predictors: the row's level is not among the training levels). +#' @keywords internal +#' @noRd +.aoa_design <- function(train, newdata, vars, + categorical = c("refuse", "indicator", "drop")) { + categorical <- match.arg(categorical) + tr <- if (inherits(train, "sf")) sf::st_drop_geometry(train) else + as.data.frame(train) + nw <- if (inherits(newdata, "sf")) sf::st_drop_geometry(newdata) else + as.data.frame(newdata) + for (side in list(list(tr, "the training data"), list(nw, "`newdata`"))) { + missing_v <- setdiff(vars, names(side[[1L]])) + if (length(missing_v) > 0L) + stop(sprintf("area_of_applicability(): predictor(s) absent from %s: %s", + side[[2L]], paste(sQuote(missing_v), collapse = ", ")), + call. = FALSE) + } + is_cat <- vapply(tr[, vars, drop = FALSE], .aoa_is_categorical, logical(1)) + cat_vars <- vars[is_cat] + num_vars <- vars[!is_cat] + none <- matrix(logical(0), nrow = nrow(nw), ncol = 0L) + # Numeric when the index was defined, categorical now: no `categorical` + # setting can line the two up, so the advice .aoa_matrix() gives would + # send the caller round in a circle. + flipped <- num_vars[vapply(nw[, num_vars, drop = FALSE], .aoa_is_categorical, + logical(1))] + flipped <- flipped[vapply(tr[, flipped, drop = FALSE], function(v) + is.numeric(v) || is.logical(v), logical(1))] + if (length(flipped) > 0L) + stop(sprintf(paste0("area_of_applicability(): predictor(s) %s are numeric ", + "or logical in the training data but categorical in ", + "`newdata` (%s); convert the column(s) first."), + paste(sQuote(flipped), collapse = ", "), + paste(vapply(flipped, function(v) class(nw[[v]])[1L], + character(1)), collapse = ", ")), call. = FALSE) + + if (length(cat_vars) == 0L || identical(categorical, "refuse")) { + # With nothing categorical this is exactly the two .aoa_matrix() calls + # the function always made; with something categorical and "refuse" the + # first of them stops, naming the predictor and the alternatives. + X_tr <- .aoa_matrix(tr, vars, "the training data") + X_nw <- .aoa_matrix(nw, vars, "`newdata`") + return(list(X_tr = X_tr, X_nw = X_nw, col_var = vars, + indicator = rep(FALSE, length(vars)), + cat_vars = character(0), vars = vars, unseen = none)) + } + + if (identical(categorical, "drop")) { + if (length(num_vars) == 0L) + stop(sprintf(paste0("area_of_applicability(): categorical = \"drop\" ", + "leaves no predictor: every one is categorical (%s). ", + "Use categorical = \"indicator\"."), + paste(sQuote(cat_vars), collapse = ", ")), call. = FALSE) + return(list(X_tr = .aoa_matrix(tr, num_vars, "the training data"), + X_nw = .aoa_matrix(nw, num_vars, "`newdata`"), + col_var = num_vars, indicator = rep(FALSE, length(num_vars)), + cat_vars = cat_vars, vars = num_vars, unseen = none)) + } + + # "indicator": the columns keep the predictors' order. + blocks_tr <- list(); blocks_nw <- list() + col_var <- character(0); indicator <- logical(0) + unseen <- matrix(FALSE, nrow = nrow(nw), ncol = length(cat_vars), + dimnames = list(NULL, cat_vars)) + for (v in vars) { + if (!(v %in% cat_vars)) { + blocks_tr[[v]] <- .aoa_matrix(tr, v, "the training data") + blocks_nw[[v]] <- .aoa_matrix(nw, v, "`newdata`") + col_var <- c(col_var, v); indicator <- c(indicator, FALSE) + next + } + if (!.aoa_is_categorical(nw[[v]])) + stop(sprintf(paste0("area_of_applicability(): predictor '%s' is %s in ", + "the training data but %s in `newdata`; its levels ", + "cannot be matched. Convert the column first."), + v, class(tr[[v]])[1L], class(nw[[v]])[1L]), call. = FALSE) + tv <- as.character(tr[[v]]) + nv <- as.character(nw[[v]]) + # Levels that OCCUR in the training rows, not the level set: a level + # with no training row is one the model never saw. + lv <- sort(unique(tv[!is.na(tv)])) + if (length(lv) == 0L) + stop(sprintf(paste0("area_of_applicability(): categorical predictor '%s' ", + "is missing on every training row."), v), + call. = FALSE) + cn <- paste0(v, "=", lv) + mt <- vapply(lv, function(l) as.numeric(tv == l), numeric(length(tv))) + mn <- vapply(lv, function(l) as.numeric(nv == l), numeric(length(nv))) + mt <- matrix(mt, nrow = length(tv), dimnames = list(NULL, cn)) + mn <- matrix(mn, nrow = length(nv), dimnames = list(NULL, cn)) + blocks_tr[[v]] <- mt + blocks_nw[[v]] <- mn + col_var <- c(col_var, rep(v, length(lv))) + indicator <- c(indicator, rep(TRUE, length(lv))) + unseen[, v] <- !is.na(nv) & !(nv %in% lv) + } + list(X_tr = do.call(cbind, unname(blocks_tr)), + X_nw = do.call(cbind, unname(blocks_nw)), + col_var = col_var, indicator = indicator, cat_vars = cat_vars, + vars = vars, unseen = unseen) +} + + +#' Group the rows of a numeric matrix that are exactly equal +#' +#' Exact means \code{==} on every column: rows are sorted lexicographically +#' and each is compared with its predecessor, so nothing is rounded or +#' pasted to text on the way (\code{duplicated()} on a matrix compares 15 +#' significant digits). The first occurrence of each distinct row is its +#' representative, and with no repeated row \code{keep} is \code{1:n}. +#' +#' @return A list: \code{keep} (row numbers of the distinct rows, ascending), +#' \code{map} (for every row, the position in \code{keep} of its +#' representative) and \code{n_dup} (rows that repeat an earlier one). +#' @keywords internal +#' @noRd +.aoa_row_groups <- function(X) { + n <- nrow(X) + if (n < 2L || ncol(X) == 0L) + return(list(keep = seq_len(n), map = seq_len(n), n_dup = 0L)) + o <- do.call(order, c(lapply(seq_len(ncol(X)), function(j) X[, j]), + list(method = "radix"))) + Xo <- X[o, , drop = FALSE] + new_grp <- c(TRUE, rowSums(Xo[-1L, , drop = FALSE] != + Xo[-n, , drop = FALSE]) > 0L) + if (all(new_grp)) + return(list(keep = seq_len(n), map = seq_len(n), n_dup = 0L)) + # The radix sort is stable, so the first row of each run is the group's + # first occurrence in the original order. + rep_row <- o[new_grp][cumsum(new_grp)] + first <- integer(n) + first[o] <- rep_row + keep <- sort(unique(first)) + list(keep = keep, map = match(first, keep), n_dup = n - length(keep)) +} + + #' Attach coordinates as ordinary predictor columns #' #' Mirrors the \code{..x}/\code{..y} naming used by \code{.rf_frame()}, so a @@ -81,11 +251,25 @@ #' Centring and scaling derived from the TRAINING data only #' +#' The 0/1 columns of a categorical predictor (\code{categorical = +#' "indicator"}) are not scaled by their own standard deviations, which +#' would put a rare level a long way from every other row for being rare. +#' All the columns of one predictor share the scale +#' \code{sqrt(1 - sum(p^2))}, \code{p} being the levels' shares of the +#' training rows. Two rows on different levels are then +#' \code{sqrt(2 / (1 - sum(p^2)))} apart on that predictor whichever levels +#' they are, two on the same level are 0 apart, and the mean squared +#' difference between two training rows is 2, exactly what a standardised +#' numeric predictor contributes. +#' +#' @param col_var,indicator As returned by \code{.aoa_design()}; \code{NULL} +#' when every column is numeric. #' @return A list with \code{center}, \code{scale} and \code{keep} (predictors #' with usable variance). #' @keywords internal #' @noRd -.aoa_scaling <- function(X_train, tol = .Machine$double.eps^0.5) { +.aoa_scaling <- function(X_train, tol = .Machine$double.eps^0.5, + col_var = NULL, indicator = NULL) { ctr <- colMeans(X_train) scl <- apply(X_train, 2L, stats::sd) # RELATIVE tolerance. An absolute floor on the raw standard deviation @@ -100,6 +284,15 @@ mag[!is.finite(mag) | mag <= 0] <- 1 keep <- is.finite(ctr) & is.finite(scl) & scl > tol * mag names(keep) <- colnames(X_train) + if (!is.null(indicator) && any(indicator)) { + for (v in unique(col_var[indicator])) { + cols <- which(indicator & col_var == v) + gini <- 1 - sum(ctr[cols]^2) + # A predictor with one level among the training rows has a constant + # column, which the variance test above has already dropped. + if (is.finite(gini) && gini > 0) scl[cols] <- sqrt(gini) + } + } list(center = ctr, scale = scl, keep = keep) } @@ -140,7 +333,8 @@ .aoa_weight_vector <- function(weights, vars, fill_vars = character(0)) { if (is.null(weights)) return(stats::setNames(rep(1, length(vars)), vars)) if (!is.numeric(weights)) - stop("area_of_applicability(): `weights` must be numeric.", call. = FALSE) + stop("area_of_applicability(): `weights` must be numeric, or NULL for ", + "equal weights, or \"auto\".", call. = FALSE) fill_vars <- intersect(fill_vars, vars) user_vars <- setdiff(vars, fill_vars) if (is.null(names(weights))) { @@ -253,10 +447,27 @@ } # Dense fallback, chunked so the query-by-reference matrix stays bounded - # regardless of grid size. ||a-b||^2 = |a|^2 + |b|^2 - 2a.b loses precision - # for near-coincident points, but the index is a ratio of that distance to - # the mean pairwise training distance, so the absolute error is negligible - # against the quantity it is divided by. + # regardless of grid size. ||a-b||^2 = |a|^2 + |b|^2 - 2a.b is used for + # the SEARCH only. It loses precision for near-coincident points: for an + # exact copy of a reference row the two terms differ by a few ulp, and the + # result is either clamped to 0 or comes out near 1e-8. That is negligible + # against an ordinary threshold, but not against a threshold at or near 0, + # where it put some exact copies of training rows outside the AOA and kept + # a threshold that should have been 0 just above it. So the distance + # returned is recomputed exactly, as sqrt(sum((q - x)^2)), for every + # reference row the search cannot tell from the nearest. + # + # Repeated reference rows cannot change a minimum, and a block of them is + # a block of ties for the exact pass, so they are collapsed first. (Not + # under `exclude`, which indexes the rows as given; the leave-one-out + # caller passes distinct rows.) + if (is.null(exclude)) { + g <- .aoa_row_groups(data) + if (g$n_dup > 0L) { + data <- data[g$keep, , drop = FALSE] + nd <- nrow(data) + } + } if (is.null(chunk_size)) chunk_size <- max(1L, min(10000L, as.integer(floor(4e6 / max(1L, nd))))) # A whole number of rows per block. A fractional chunk_size gave fractional @@ -265,26 +476,77 @@ chunk_size <- max(1L, as.integer(chunk_size)) out <- numeric(nq) dsq <- rowSums(data^2) + dmax <- max(dsq) + # The rounding error of the fast formula for one pair is a small multiple + # of eps * (|q|^2 + |x|^2), growing with the number of columns summed. + slack <- 8 * (ncol(data) + 8) * .Machine$double.eps for (s in seq.int(1L, nq, by = chunk_size)) { - e <- min(s + chunk_size - 1L, nq) - Q <- query[s:e, , drop = FALSE] - d2 <- outer(rowSums(Q^2), dsq, "+") - 2 * tcrossprod(Q, data) + e <- min(s + chunk_size - 1L, nq) + Q <- query[s:e, , drop = FALSE] + qsq <- rowSums(Q^2) + d2 <- outer(qsq, dsq, "+") - 2 * tcrossprod(Q, data) if (!is.null(exclude)) { ex <- exclude[s:e] ok <- !is.na(ex) if (any(ok)) d2[cbind(which(ok), as.integer(ex[ok]))] <- Inf } - out[s:e] <- sqrt(pmax(apply(d2, 1L, min), 0)) + out[s:e] <- .aoa_exact_row_min(d2, Q, data, slack * (qsq + dmax)) } out } +#' Row minima of a fast squared-distance block, recomputed exactly +#' +#' @param d2 Query-by-reference squared distances from the fast formula +#' (\code{Inf} where a pair is excluded). +#' @param Q,data The query and reference rows \code{d2} was built from. +#' @param tol One tolerance per query row: the rounding error \code{d2} can +#' carry. Every reference row within it of the row minimum is a candidate +#' for nearest, and the smallest exact distance among them is returned. +#' @return One distance per query row; \code{Inf} where every pair was +#' excluded. +#' @keywords internal +#' @noRd +.aoa_exact_row_min <- function(d2, Q, data, tol) { + nr <- nrow(d2) + # An exact row minimum. max.col() is not one: it calls entries within + # 1e-5 of the row's largest magnitude tied. + m <- if (ncol(d2) <= nr) { + acc <- d2[, 1L] + for (j in seq_len(ncol(d2))[-1L]) acc <- pmin(acc, d2[, j]) + acc + } else apply(d2, 1L, min) + res <- rep(Inf, nr) + res[is.nan(m)] <- NaN + lim <- m + tol + lim[!is.finite(m)] <- -Inf + cand <- which(d2 <= lim, arr.ind = TRUE) + if (nrow(cand) == 0L) return(res) + # Bounded batches: a query row among many near-coincident reference rows + # has as many candidates. + step <- 5e5L + for (b in seq.int(1L, nrow(cand), by = step)) { + idx <- b:min(b + step - 1L, nrow(cand)) + qi <- cand[idx, 1L] + ex <- sqrt(rowSums((Q[qi, , drop = FALSE] - + data[cand[idx, 2L], , drop = FALSE])^2)) + o <- order(qi, ex) + top <- !duplicated(qi[o]) + hit <- qi[o][top] + res[hit] <- pmin(res[hit], ex[o][top]) + } + res +} + + #' Mean pairwise distance among training points (the DI normaliser) #' #' @keywords internal #' @noRd -.aoa_normalizer <- function(X, max_n = 5000L, seed = 123L) { +.aoa_normalizer <- function(X, max_n = 5000L, seed = 123L, + what = c("predictors", "location")) { + what <- match.arg(what) n <- nrow(X) if (n < 2L) stop("area_of_applicability(): at least two training rows are needed.", @@ -295,18 +557,161 @@ on.exit(cleanup(), add = TRUE) X <- X[sort(sample.int(n, as.integer(max_n))), , drop = FALSE] subsampled <- TRUE - .log_info("area_of_applicability(): normaliser estimated from a %d-point subsample of %d training points.", + .log_info("area_of_applicability(): %snormaliser estimated from a %d-point subsample of %d training points.", + if (identical(what, "location")) "location " else "", as.integer(max_n), n) } m <- mean(as.numeric(stats::dist(X))) - if (!is.finite(m) || m <= 0) + if (!is.finite(m) || m <= 0) { + if (identical(what, "location")) + stop("area_of_applicability(): every training row is at the same ", + "location, so the mean distance between training points is zero ", + "and the location index is undefined. Pass coords = \"no\" to ", + "measure the predictors alone.", call. = FALSE) stop("area_of_applicability(): the mean pairwise training distance is ", "zero or undefined; the training predictors carry no spread.", call. = FALSE) + } list(value = m, subsampled = subsampled, n_used = nrow(X)) } +#' Map coordinates of both layers, for the location index +#' +#' Works on copies: the caller's \code{newdata} is returned to it unchanged. +#' The prediction layer is brought into the training layer's CRS (or, when +#' only it has one, the training layer into its), exactly as on the +#' coordinates-as-predictors path, and non-\code{POINT} geometry is reduced +#' to representative points. A geographic CRS is refused: the index is a +#' map distance, and a degree of longitude is not a fixed one. +#' +#' @param why A clause naming why location is measured, for the messages. +#' @return A list of two two-column matrices, \code{train} and \code{new}, +#' row for row with the layers; a row with an empty geometry is \code{NA}. +#' @keywords internal +#' @noRd +.aoa_location_coords <- function(train_sf, newdata, why) { + if (!inherits(train_sf, "sf") || !inherits(newdata, "sf")) + stop(sprintf(paste0("area_of_applicability(): %s, so location is measured ", + "and both the training data and `newdata` must be sf ", + "objects carrying geometry (%s). Pass coords = \"no\" ", + "to measure the predictors alone."), + why, + paste(c(if (!inherits(train_sf, "sf")) "the training data is not", + if (!inherits(newdata, "sf")) "`newdata` is not"), + collapse = "; ")), call. = FALSE) + tr_crs <- sf::st_crs(train_sf) + if (!is.na(tr_crs)) { + if (!identical(sf::st_crs(newdata), tr_crs)) + newdata <- .transform_or_stamp(newdata, tr_crs, what = "newdata", + caller = "area_of_applicability") + } else if (!is.na(sf::st_crs(newdata))) { + train_sf <- .transform_or_stamp(train_sf, sf::st_crs(newdata), + what = "the training data", + caller = "area_of_applicability") + } + if (isTRUE(sf::st_is_longlat(train_sf))) + stop("area_of_applicability(): the location index is a map distance and ", + "the training data is in a geographic CRS (longitude/latitude). ", + "Project both layers first, with sf::st_transform() or ", + "ensure_projected(), or pass coords = \"no\".", call. = FALSE) + xy <- function(x) { + if (!all(sf::st_geometry_type(x, by_geometry = TRUE) == "POINT")) + x <- coerce_to_points(x, "auto") + crd <- sf::st_coordinates(x) + if (ncol(crd) < 2L || nrow(crd) != nrow(x)) + stop("area_of_applicability(): could not extract one X/Y coordinate ", + "pair per row.", call. = FALSE) + m <- cbind(as.numeric(crd[, 1L]), as.numeric(crd[, 2L])) + colnames(m) <- c("x", "y") + m + } + list(train = xy(train_sf), new = xy(newdata)) +} + + +#' Raise the zero-threshold warning with a condition class +#' +#' \code{.warn_and_log()} with the class +#' \code{spatialkit_aoa_zero_threshold}, so that a script computing many +#' areas of applicability, or one inside a cross-validation loop, can catch +#' exactly this case with \code{tryCatch(spatialkit_aoa_zero_threshold = )} +#' or \code{withCallingHandlers()} without matching message text. +#' +#' @keywords internal +#' @noRd +.aoa_warn_zero_threshold <- function(fmt, ...) { + .warn_classed("spatialkit_aoa_zero_threshold", fmt, ...) +} + + +#' The weights `weights = "auto"` resolves to +#' +#' Meyer and Pebesma (2021) weight the predictors by the model's variable +#' importance, so that is what a model carrying one gets: +#' \code{pmax(importance, 0)}. Equal weights are the answer whenever the +#' importance is absent or does not mean anything, and each such case is +#' logged, not raised: +#' \itemize{ +#' \item no \code{model}, or one with no importance (\code{importance = +#' "none"}, a GWR, a Bayesian fit, a custom learner); +#' \item an importance that is not fully finite (it is \code{NaN} for a +#' forest with no out-of-bag rows); +#' \item an importance that does not name every predictor in use +#' (\code{predictor_vars} overridden with a column the model never saw); +#' \item no positive importance at all; +#' \item a forest with no out-of-bag skill (\code{oob_r_squared} missing +#' or at most 0): on a pure-noise response 2 to 7 of 10 importances are +#' positive by chance and the largest takes 26 to 96\% of the weight. +#' } +#' +#' @param vars The predictors in use, including any in \code{fill_vars}. +#' @param fill_vars The coordinate columns of a coordinate-using forest; +#' its importance names them, so they are weighted like the others. +#' @return A list: \code{weights} (a named numeric, or \code{NULL} for +#' equal), \code{source} (\code{"model importance"} or \code{"equal"}) +#' and \code{note}. +#' @keywords internal +#' @noRd +.aoa_auto_weights <- function(model, vars, fill_vars = character(0)) { + equal <- function(why, log = TRUE) { + if (log) + .log_info(paste0("area_of_applicability(): weights = \"auto\": %s, so ", + "every predictor counts equally."), why) + list(weights = NULL, source = "equal", note = why) + } + if (is.null(model)) return(equal("no model was given", log = FALSE)) + imp <- model$info$importance + if (is.null(imp) || length(imp) == 0L) + return(equal("the model carries no variable importance")) + if (!is.numeric(imp) || is.null(names(imp))) + return(equal("the model's importance is not a named numeric vector")) + need <- intersect(vars, names(imp)) + miss <- setdiff(setdiff(vars, fill_vars), names(imp)) + if (length(miss) > 0L) + return(equal(sprintf("the model's importance has no entry for %s", + paste(sQuote(miss), collapse = ", ")))) + if (any(!is.finite(imp[need]))) + return(equal(paste0("the model's importance is not finite (it is NaN for ", + "a forest with no out-of-bag rows)"))) + if (!any(imp[need] > 0)) + return(equal("no predictor has a positive importance")) + r2 <- .num1(model$info$oob_r_squared) + if (!is.finite(r2)) + return(equal(paste0("the model records no out-of-bag R-squared to show ", + "its importances are more than noise"))) + if (r2 <= 0) + return(equal(sprintf(paste0("the model has no out-of-bag skill (OOB ", + "R-squared %.3f), so its importances are noise"), + r2))) + type <- model$info$importance_type + type <- if (is.character(type) && length(type) == 1L && !is.na(type) && + nzchar(type)) type else "variable" + list(weights = pmax(imp[need], 0), source = "model importance", + note = sprintf("%s importance", type)) +} + + #' Normalise a fold specification into train/test position lists #' #' Accepts a \code{make_folds()} result, a bare list of \code{train}/\code{test} @@ -569,21 +974,43 @@ #' Reference nearest-neighbour distances for the training data #' +#' Without folds, each row's reference is its nearest row at a DIFFERENT +#' point of the space. A row that repeats another's values exactly (a +#' repeat visit to a site with static covariates, covariates read off a +#' raster coarser than the sampling) is the same point, not a neighbour: +#' counted as one it has a reference distance of 0, and once about three +#' quarters of the rows have such a twin the threshold is 0 and only exact +#' copies of a training row are inside. So the search runs on the distinct +#' rows, and every row takes its point's distance. With no repeated row +#' that is the search on the rows as given. +#' +#' With folds the reference is the nearest row the fold left in training, +#' as defined: a twin on the other side of a split is a row the hold-out +#' really did have in its training set. +#' +#' @param groups Optional \code{.aoa_row_groups(X)}, when the caller has it. #' @keywords internal #' @noRd .aoa_train_dist <- function(X, splits = NULL, use_fnn = requireNamespace("FNN", quietly = TRUE), - chunk_size = NULL) { + chunk_size = NULL, groups = NULL) { n <- nrow(X) if (n < 2L) stop("area_of_applicability(): at least two training rows are needed.", call. = FALSE) if (is.null(splits)) { - if (isTRUE(use_fnn)) - return(as.numeric(FNN::get.knn(X, k = 1L)$nn.dist[, 1L])) - return(.aoa_min_dist(X, X, use_fnn = FALSE, chunk_size = chunk_size, - exclude = seq_len(n))) + if (is.null(groups)) groups <- .aoa_row_groups(X) + Xd <- if (groups$n_dup > 0L) X[groups$keep, , drop = FALSE] else X + if (nrow(Xd) < 2L) + stop("area_of_applicability(): every training row has the same values ", + "on the predictors measured, so no row has a neighbour to take a ", + "reference distance from.", call. = FALSE) + d <- if (isTRUE(use_fnn)) + as.numeric(FNN::get.knn(Xd, k = 1L)$nn.dist[, 1L]) + else .aoa_min_dist(Xd, Xd, use_fnn = FALSE, chunk_size = chunk_size, + exclude = seq_len(nrow(Xd))) + return(if (groups$n_dup > 0L) d[groups$map] else d) } out <- rep(NA_real_, n) @@ -660,14 +1087,17 @@ #' #' @section How it is computed: #' Predictors are centred and scaled using the training data's own means and -#' standard deviations, then optionally weighted by variable importance. For a +#' standard deviations, then weighted by variable importance when the model +#' carries one (see \emph{Weights}). For a #' prediction point \eqn{p}, the DI is the distance to its nearest training #' point in that space, divided by the mean pairwise distance among training #' points. The same quantity is computed for the training data itself, using #' each point's nearest neighbour \emph{among the training rows of the fold #' that holds it out}. That means everything outside its own fold for random #' and block folds, and the smaller training set that buffered and NNDM folds -#' actually leave (see the next section). The threshold is then the largest +#' actually leave (see \emph{The fold scheme changes the answer}); without +#' folds it is the nearest training row with different predictor values. The +#' threshold is then the largest #' training DI that is not an upper outlier, i.e. not above the fence #' \code{Q3 + 1.5 * IQR} of the training DI, with the quartiles of #' \code{stats::quantile()}'s default type 7. Prediction points at or below @@ -689,14 +1119,33 @@ #' and the normaliser carry the same factor. Importance values can be passed #' as-is. #' -#' Each training point's reference is its nearest \emph{other} training row, so -#' an exact duplicate in predictor space (repeat visits to a site with static -#' covariates, or covariates read off a raster coarser than the sampling) has a -#' training DI of 0. Once about three quarters of the rows have a twin among -#' their reference rows the threshold is 0, and only exact copies of a -#' training row count as inside. That is logged as a caution; folds that keep -#' the duplicates together (\code{make_folds(method = "leave_location_out", -#' group_var = ...)}), or removing them, give the threshold its meaning back. +#' @section Training rows with identical predictor values: +#' Repeat visits to a site with static covariates, or covariates read off a +#' raster coarser than the sampling, give training rows that are exact copies +#' of each other in predictor space. A copy is the same point of that space, +#' not a neighbour. Counted as a neighbour it gives a training DI of 0, and +#' once about three quarters of the rows have one the threshold is 0 and only +#' exact copies of a training row count as inside (60 sites visited 4 times +#' put 30 of 200 new points inside; the same sites counted once put 188). +#' +#' With \code{folds = NULL} each training row's reference is therefore its +#' nearest row with \emph{different} values: the search runs on the distinct +#' rows and every row takes its point's distance. \code{n_duplicates} counts +#' the rows that repeat an earlier one, and a layer with none is computed +#' exactly as before. The normaliser stays the mean pairwise distance over +#' all the training rows, so a prediction point's DI is the same with and +#' without folds. +#' +#' With \code{folds} supplied the definition is applied as it stands: a +#' held-out row whose copy is on the training side of its fold has a DI of 0, +#' because that hold-out did have an identical row to learn from. If the +#' threshold comes out 0 that way, a warning of class +#' \code{spatialkit_aoa_zero_threshold} gives the count, so a script or a +#' cross-validation loop can catch it with +#' \code{tryCatch(..., spatialkit_aoa_zero_threshold = )}. Folds that keep +#' the copies together (\code{make_folds(method = "leave_location_out", +#' group_var = ...)}) give the threshold its meaning back. The same applies +#' to the location index when training rows share a location. #' #' @section The fold scheme changes the answer, and should: #' With \code{folds = NULL} the training reference is each point's nearest @@ -709,9 +1158,51 @@ #' to \code{\link{cv_spatial}}. Buffered and NNDM folds use the training set #' they actually left available, not merely "everything outside the fold". #' +#' @section Weights: +#' Meyer and Pebesma weight the predictors by the model's variable +#' importance, and with the default \code{weights = "auto"} so does this +#' function whenever \code{model} carries an importance that means +#' something: \code{pmax(model$info$importance, 0)}, which a forest from +#' \code{\link{fit_rf_model}} has. Equal weights are used, with a logged +#' note, when it does not: no \code{model}; a model with no importance +#' (\code{importance = "none"}, a GWR, a Bayesian fit); an importance that is +#' not finite (\code{NaN} for a forest with no out-of-bag rows); one that +#' names fewer predictors than are in use; no positive value; or a forest +#' with no out-of-bag skill (\code{oob_r_squared} missing or at most 0), +#' whose positive importances are noise. \code{print()} says which it was. +#' \code{weights = NULL} asks for equal weights whatever the model carries. +#' +#' What the weights buy: with 2 predictors the forest uses and 8 it does not, +#' equal weights put about 70\% of rows shifted 3 SD along a used predictor +#' (4 times the in-sample RMSE) inside the AOA and importance weights about +#' 26\%; of rows shifted 4 SD along an unused predictor (error unchanged), +#' 43\% against 93\%. What they cost: a weight multiplies the scaled column, +#' so its square enters the distance, and a weak but real predictor is +#' down-weighted by the square of its relative importance. A shift along one +#' can then go unseen (94\% inside at 1.9 times the in-sample RMSE in one +#' test, against 19\% with equal weights). +#' \code{weights = sqrt(pmax(importance, 0))} is the gentler alternative: it +#' kept most of the gain on used predictors and put 46\% of that weak-predictor +#' shift inside, at the cost of 77\% in place of 93\% inside for harmless +#' shifts. +#' #' @section Limitations: -#' Predictors must be numeric; categorical variables are refused and never -#' silently dummy-coded. Predictors whose variance is negligible \emph{relative +#' Categorical predictors (factor or character columns) have no distance of +#' their own, and by default they are refused and never silently +#' dummy-coded. \code{categorical = "indicator"} codes each level that +#' occurs in the training rows as a 0/1 column. The columns of one predictor +#' share one scale, \code{sqrt(1 - sum(p^2))} with \code{p} the levels' +#' shares of the training rows, so two rows on different levels are the same +#' distance apart whichever levels they are, two on the same level are 0 +#' apart, and the predictor adds as much to the mean squared distance between +#' training rows as one standardised numeric predictor. That scaling is a +#' choice, not a result, which is why it is not the default. A prediction row +#' on a level no training row has gets \code{DI = Inf}, is outside the AOA, +#' and a warning gives the count. \code{categorical = "drop"} leaves the +#' categorical predictors out and computes the index on the others; a level +#' the training data never has then goes unseen. +#' +#' Predictors whose variance is negligible \emph{relative #' to their own magnitude} (the test is #' \code{sd < sqrt(.Machine$double.eps) * max(abs(x))}, so the same variable in #' metres and in gigametres is treated identically) are dropped from the @@ -720,19 +1211,65 @@ #' the training data never varied in: its scaled distance along it is #' infinite, so it gets \code{DI = Inf}, is outside the AOA, and a warning #' gives the count. A point missing that value is judged on the other -#' predictors. Without \code{weights} every predictor counts equally, which -#' overstates dissimilarity along directions the model barely uses. -#' -#' @section Models fitted with the coordinates as predictors: -#' When \code{model} was fitted with \code{include_coords = TRUE} the model -#' splits on location, so the dissimilarity index has to measure location too: -#' the coordinates are added to both sides as the predictors \code{"..x"} and -#' \code{"..y"} and are then centred, scaled and weighted like any other -#' column. Without this a prediction point far outside the training extent but -#' with ordinary covariate values reads as \emph{inside} the area of -#' applicability. That is exactly the extrapolation this index exists to catch. -#' -#' This path needs geometry on both sides, so \code{train_sf} and +#' predictors. With equal weights every predictor counts the same, which +#' overstates dissimilarity along directions the model barely uses; see +#' \emph{Weights}. +#' +#' @section Models whose predictions depend on location: +#' For three kinds of model the prediction is a function of where the point +#' is, not only of its covariates, so the index has to measure location too. +#' Without that a prediction point far outside the training extent but with +#' ordinary covariate values reads as \emph{inside} the area of +#' applicability, which is exactly the extrapolation this index exists to +#' catch. \code{coords = "auto"} (the default) measures location for all +#' three; \code{coords = "no"} turns it off, with a logged caution; +#' \code{coords = "yes"} measures it for any model, or for none. +#' +#' \strong{A geographically weighted regression} (\code{gwr_fit}) has +#' coefficients that vary over the map, and \strong{a Bayesian spatial model} +#' (\code{bayesian_fit}) has a Gaussian-process term in the coordinates. For +#' these, and under \code{coords = "yes"}, location gets an index of its own, +#' built like the predictor index but in map space: \code{DI_location} is the +#' distance to the nearest training point over the mean distance between +#' training points; the training points' own values use the same folds; and +#' the threshold is the same outlier-removed maximum. A prediction point is +#' inside the AOA only if it is inside on both indices, and both DI columns +#' are returned so the cause can be read off. Location is kept apart from the +#' covariates because, as two more equally weighted columns, it is diluted as +#' covariates are added: with 12 of them, 89\% of points 200 to 500 units +#' beyond a 1000-unit training extent still read as inside, against none with +#' the separate index. In a test with a GWR whose slope rises eastward, points +#' one half to one and a half extents beyond the data had 13 times the +#' in-extent RMSE; 84\% of them were inside on the covariates alone and none +#' with location measured. +#' +#' Inside the extent the index marks an unsampled gap only where the gap is +#' wider than the distance its threshold allows, and that distance depends +#' on \code{folds}. With \code{folds = NULL} it is the spacing of the +#' training points (the outlier-removed largest nearest-neighbour distance). +#' With blocked folds it is the largest distance from a held-out point to +#' the nearest row its fold trained on, outliers removed, which grows with +#' the block size; a gap narrower than about twice that distance has no +#' cell beyond it and reads as inside. In a test with 400 training points +#' in two strips 400 units apart, the cut-off without folds was 46 to 54 +#' units and no grid cell in the middle half of the gap, 100 units or more +#' from either strip, was inside. That held although the prediction grid +#' took its covariates from the nearest observation, so that every cell's +#' covariate DI was 0. With five block folds the cut-off was 199 to 251 +#' units and 76 to 100\% of the same cells were inside (87\% on average over +#' three draws). This follows from the definition and is not a fault of the +#' index: the cross-validated error it is paired with was earned on +#' hold-outs that far from their training rows. It does mean that with +#' blocked folds the location index says nothing about a gap narrower than +#' about twice the cut-off; \code{location$threshold * location$normalizer} +#' is the cut-off in map units, and \code{print()} shows it. +#' +#' \strong{A forest fitted with \code{include_coords = TRUE}} splits on the +#' coordinates like on any other column, so there they join the predictor +#' index as \code{"..x"} and \code{"..y"} and are centred, scaled and weighted +#' with the rest. +#' +#' Either way geometry is needed on both sides, so \code{train_sf} and #' \code{newdata} must both be \code{sf} objects; a data.frame is refused #' rather than quietly measured without location. Non-\code{POINT} #' \code{newdata} (grid polygons, say) is reduced to representative points @@ -740,20 +1277,31 @@ #' a CRS the other is brought into it: reprojected when its coordinates look #' like longitude/latitude, stamped otherwise, with a warning either way. This #' is done because degrees fed into a metre-space index silently understate the -#' distances. +#' distances. The location index is a map distance and refuses training data +#' in a geographic CRS. #' #' @param newdata Prediction locations: an \code{sf} object (typically from #' \code{\link{predict_surface}}) or a data.frame, carrying the predictor -#' columns. For a model fitted with \code{include_coords = TRUE} an -#' \code{sf} object is required, non-\code{POINT} geometry is reduced to -#' representative points, and a CRS mismatch with the training data is -#' reconciled; see \emph{Models fitted with the coordinates as predictors}. +#' columns. When location is measured (a \code{gwr_fit}, a +#' \code{bayesian_fit}, a forest fitted with \code{include_coords = TRUE}, +#' or \code{coords = "yes"}) an \code{sf} object is required, +#' non-\code{POINT} geometry is reduced to representative points, and a CRS +#' mismatch with the training data is reconciled; see \emph{Models whose +#' predictions depend on location}. #' @param model A fitted \code{spatial_fit}, supplying the training data and -#' predictor names. Optional if \code{train_sf} and \code{predictor_vars} are -#' given directly, which lets this be used with any model. +#' predictor names, the importance \code{weights = "auto"} reads, and +#' whether its predictions depend on location. Optional if \code{train_sf} +#' and \code{predictor_vars} are given directly, which lets this be used +#' with any model. #' @param train_sf Training data, if not taken from \code{model}. #' @param predictor_vars Predictor names, if not taken from \code{model}. -#' @param weights Optional named numeric vector of predictor importances. Any +#' @param weights \code{"auto"} (default), \code{NULL}, or a named numeric +#' vector of predictor importances. \code{"auto"} uses +#' \code{pmax(model$info$importance, 0)} when \code{model} carries a finite +#' importance with at least one positive value, naming every predictor in +#' use, from a model with out-of-bag skill; otherwise every predictor counts +#' equally and a logged note says why (see \emph{Weights}). \code{NULL} is +#' the explicit request for equal weights. For a vector of your own, any #' positive scale works. When \code{model} was fitted with #' \code{include_coords = TRUE}, the coordinates \code{"..x"} and #' \code{"..y"} are measured as predictors too (see below), and you are not @@ -765,7 +1313,7 @@ #' permutation importance as \code{pmax(importance, 0)}. (A forest with no #' out-of-bag rows, \code{replace = FALSE} with \code{sample_fraction = 1}, #' has \code{NaN} importance, which \code{pmax()} keeps and which is -#' refused; refit it with out-of-bag rows or use \code{weights = NULL}.) +#' refused when passed by hand; \code{"auto"} uses equal weights for it.) #' \code{pmax(importance, 0)} is all zero when the model found no #' predictor useful, and then the weights cannot say anything: with a #' single predictor any weight gives the same index and zero @@ -786,7 +1334,9 @@ #' another layer, or these rows in another order -- is refused. That check #' is skipped when the folds were built on polygons and the training data #' are the points a fit reduced them to. -#' @param threshold Optional numeric override for the DI threshold. +#' @param threshold Optional numeric override for the DI threshold of the +#' predictor index. The location index, when there is one, always takes its +#' threshold from the rule. #' @param normalizer_max_n Subsample the training data to this many points when #' computing the mean pairwise distance, which is quadratic. Default 5000. #' @param seed Seed for that subsample. Default 123. @@ -794,45 +1344,94 @@ #' \code{NULL} (chosen from the training size). Otherwise a single number of #' at least 1; a fractional value is truncated to a whole number of rows. #' @param use_fnn Use \pkg{FNN} for nearest-neighbour search when available. -#' Exposed so the dense fallback can be tested. +#' Exposed so the dense fallback can be tested. The two paths return the +#' same distances: the dense one searches with a fast formula and then +#' recomputes the nearest distance exactly, so an exact copy of a training +#' row is at distance 0 on both. +#' @param coords Whether location is measured: \code{"auto"} (default) +#' measures it for a model whose predictions depend on it (a +#' \code{gwr_fit}, a \code{bayesian_fit}, a forest fitted with +#' \code{include_coords = TRUE}) and not otherwise; \code{"yes"} measures +#' it whatever the model, and with no \code{model}; \code{"no"} never +#' does, and logs a caution for a model that depends on it. See +#' \emph{Models whose predictions depend on location}. +#' @param categorical What to do with factor and character predictors: +#' \code{"refuse"} (default) stops with a message naming them and the two +#' alternatives; \code{"indicator"} codes each level as a 0/1 column and +#' marks a prediction row on a level no training row has as outside +#' (\code{DI = Inf}); \code{"drop"} computes the index on the other +#' predictors and logs which were left out. See \emph{Limitations} for the +#' scaling \code{"indicator"} uses. #' #' @return An object of class \code{aoa}: a list with #' \itemize{ #' \item \code{aoa}: \code{newdata} with a numeric \code{DI} column -#' and a logical \code{AOA} column added. This is the object the -#' computation ran on, which for a coordinate-using model is -#' \code{newdata} after pointizing, CRS reconciliation and the addition -#' of the \code{"..x"} and \code{"..y"} columns. A row whose predictors -#' are not all finite gets \code{NA} in both columns, and a row outside -#' the training range of a predictor in \code{dropped_vars} gets +#' and a logical \code{AOA} column added, and between them a numeric +#' \code{DI_location} column when location has an index of its own. +#' For a forest fitted with \code{include_coords = TRUE} it is the +#' object the computation ran on: \code{newdata} after pointizing, CRS +#' reconciliation and the addition of the \code{"..x"} and \code{"..y"} +#' columns. With a location index it is \code{newdata} as passed. A +#' row whose predictors are not all finite gets \code{NA} in \code{DI}, +#' and a row outside the training range of a predictor in +#' \code{dropped_vars}, or on a level no training row has, gets #' \code{DI = Inf} and \code{AOA = FALSE} (see \emph{Limitations}). +#' \code{AOA} is \code{DI <= threshold}, and with a location index +#' also \code{DI_location <= location$threshold}: a row outside on +#' either index is \code{FALSE}, and a row with one index missing and +#' the other inside is \code{NA}. #' \item \code{threshold}: the DI cut-off used. #' \item \code{train_DI}: the training points' own DI values. #' \item \code{normalizer}: the mean pairwise training distance. #' \item \code{weights}: the weight vector actually applied, named by #' \code{predictor_vars}. #' \item \code{predictor_vars}: the predictors used, including -#' \code{"..x"}/\code{"..y"} when the model uses coordinates and -#' excluding \code{dropped_vars}. +#' \code{"..x"}/\code{"..y"} when a forest uses the coordinates and +#' excluding \code{dropped_vars} and, under +#' \code{categorical = "drop"}, \code{categorical_vars}. #' \item \code{dropped_vars}: predictors dropped for negligible #' variance. #' \item \code{scaling}: a list with \code{center} and \code{scale}, #' each named by \code{predictor_vars}: the training means and standard #' deviations the index is computed in, so a location's DI can be -#' traced to the predictor that put it outside. +#' traced to the predictor that put it outside. A predictor coded as +#' indicators has one entry per level, named +#' \code{"="}. #' \item \code{n_outliers}: the number of training DI values above the #' \code{Q3 + 1.5 * IQR} fence, which the default threshold rule sets #' aside (the "outlier-removed" in its name); computed whether or not #' \code{threshold} was supplied. +#' \item \code{n_duplicates}: with \code{folds = NULL}, the number of +#' training rows that repeat an earlier row's predictor values exactly +#' and so share its reference distance; \code{NA} when folds were +#' supplied (see \emph{Training rows with identical predictor values}). +#' \item \code{location}: \code{NULL}, or for a location index a list +#' with \code{threshold}, \code{train_DI}, \code{normalizer} (the mean +#' distance between training points, in map units, so +#' \code{threshold * normalizer} is the cut-off as a distance), +#' \code{n_duplicates} (training rows at an earlier row's location; +#' \code{NA} when folds were supplied) and \code{n_outside} (prediction +#' rows beyond the location threshold). +#' \item \code{categorical_vars}: the factor and character predictors +#' found, coded or left out as \code{params$categorical} says. #' \item \code{n_train}, \code{n_new}, \code{n_inside}, #' \code{n_outside}, \code{n_na}: row counts. \code{n_train} counts the #' training rows that survived the finite-value filter; \code{n_new} is #' every row of \code{newdata}, so -#' \code{n_new = n_inside + n_outside + n_na}. +#' \code{n_new = n_inside + n_outside + n_na}, with \code{n_na} the +#' rows whose \code{AOA} is \code{NA}. +#' \code{n_outside_predictors} counts the rows beyond the predictor +#' threshold, which is \code{n_outside} unless there is a location +#' index. #' \item \code{params} records the call: \code{folds_supplied}, #' \code{n_folds}, \code{folds_method}, \code{threshold_supplied}, #' \code{normalizer_max_n}, \code{normalizer_n_used}, -#' \code{normalizer_subsampled}, \code{weights_supplied} and +#' \code{normalizer_subsampled}, \code{weights_supplied} (the caller +#' passed a vector), \code{weights_source} (\code{"model importance"}, +#' \code{"supplied"} or \code{"equal"}), \code{weights_note} (the kind +#' of importance, or why the weights are equal), \code{coords} +#' (\code{"location index"}, \code{"predictors"} or \code{"none"}), +#' \code{categorical} and #' \code{seed}. \code{folds_method} is the \code{method} of a #' \code{\link{make_folds}()} result (\code{"block_kfold"}, #' \code{"random_kfold"}, ...), \code{"labels"} for a vector of fold @@ -878,12 +1477,17 @@ #' table(res$aoa$AOA) #' @export area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, - predictor_vars = NULL, weights = NULL, + predictor_vars = NULL, weights = "auto", folds = NULL, threshold = NULL, normalizer_max_n = 5000L, seed = 123L, chunk_size = NULL, use_fnn = requireNamespace("FNN", - quietly = TRUE)) { + quietly = TRUE), + coords = c("auto", "yes", "no"), + categorical = c("refuse", "indicator", + "drop")) { + coords <- match.arg(coords) + categorical <- match.arg(categorical) if (!is.null(model)) { if (!inherits(model, "spatial_fit")) stop("area_of_applicability(): `model` must be a spatial_fit.", @@ -940,14 +1544,47 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, .aoa_check_fold_probe(folds, train_sf, tr_row_ids) } - # A model fitted with the coordinates as predictors splits on location, so - # the dissimilarity index has to measure location too. Without this, a - # prediction point far outside the training extent but with ordinary - # covariate values reads as INSIDE the area of applicability -- exactly the - # extrapolation the index exists to catch, and exactly the failure mode that - # makes coordinate predictors dangerous in the first place. - coord_model <- !is.null(model) && isTRUE(model$info$include_coords) + # A model whose predictions depend on location has to have location + # measured. Without it, a prediction point far outside the training extent + # but with ordinary covariate values reads as INSIDE the area of + # applicability -- exactly the extrapolation the index exists to catch. + # There are two kinds of such model, and location enters the index + # differently for each: + # "predictors" a forest fitted with include_coords = TRUE splits on the + # coordinates like on any column, so they join the + # predictor index as "..x"/"..y" and take a weight; + # "index" a GWR's coefficients and a Bayesian fit's Gaussian + # process are functions of location whatever the + # covariates are, so location gets an index of its own -- + # distance to the nearest training point in map space -- + # and a point must be inside on both. As two more + # equally weighted columns it would be diluted: with 12 + # covariates, 89% of points 200 to 500 units beyond a + # 1000-unit extent still read as inside. + xy_predictors <- !is.null(model) && isTRUE(model$info$include_coords) + location_model <- !is.null(model) && + inherits(model, c("gwr_fit", "bayesian_fit")) + coord_mode <- switch(coords, + auto = if (xy_predictors) "predictors" else if (location_model) "index" + else "none", + yes = if (xy_predictors) "predictors" else "index", + no = "none") + if (identical(coords, "no") && (xy_predictors || location_model)) + .log_warn(paste0("area_of_applicability(): coords = \"no\", so location is ", + "not measured although this model's predictions depend on ", + "it (%s). A point far from every training point reads as ", + "inside when its covariates are ordinary."), + if (xy_predictors) "a forest fitted with include_coords = TRUE" + else sprintf("a %s", class(model)[1L])) + coord_model <- identical(coord_mode, "predictors") coord_vars <- if (coord_model) c("..x", "..y") else character(0) + loc_xy <- if (identical(coord_mode, "index")) + .aoa_location_coords(train_sf, newdata, + why = if (location_model) + sprintf("this model's predictions depend on location (a %s)", + class(model)[1L]) + else "coords = \"yes\"") + else NULL if (coord_model) { if (!inherits(train_sf, "sf") || !inherits(newdata, "sf")) stop("area_of_applicability(): this model uses the coordinates as ", @@ -973,8 +1610,20 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, predictor_vars <- unique(c(predictor_vars, "..x", "..y")) } - X_tr_full <- .aoa_matrix(train_sf, predictor_vars, "the training data") - X_nw_full <- .aoa_matrix(newdata, predictor_vars, "`newdata`") + des <- .aoa_design(train_sf, newdata, predictor_vars, categorical) + X_tr_full <- des$X_tr + X_nw_full <- des$X_nw + cat_vars <- des$cat_vars + if (length(cat_vars) > 0L && identical(categorical, "drop")) + .log_warn(paste0("area_of_applicability(): categorical = \"drop\": the ", + "index is computed on %s alone. %s %s not measured, so a ", + "prediction row on a level the training data never has ", + "reads as inside when its other predictors are ordinary."), + paste(des$vars, collapse = ", "), + paste(sQuote(cat_vars), collapse = ", "), + if (length(cat_vars) == 1L) "is" else "are") + predictor_vars <- des$vars + col_var <- des$col_var # Training rows carrying NA or Inf cannot define a reference distance. # complete.cases() alone would let an Inf through, and it would then poison @@ -982,35 +1631,73 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, # predictor and report it as having "no variance" -- a false diagnosis that # silently removes a dimension the index is supposed to be measuring. tr_ok <- apply(X_tr_full, 1L, function(r) all(is.finite(r))) + # A row with no usable location has no place in a location index either. + if (!is.null(loc_xy)) + tr_ok <- tr_ok & is.finite(loc_xy$train[, 1L]) & is.finite(loc_xy$train[, 2L]) if (!all(tr_ok)) { if (sum(tr_ok) < 2L) stop("area_of_applicability(): fewer than two training rows with finite ", "values for every predictor.", call. = FALSE) - .log_warn("area_of_applicability(): dropping %d training row(s) with missing or non-finite predictor values.", - sum(!tr_ok)) + .log_warn("area_of_applicability(): dropping %d training row(s) with missing or non-finite predictor values%s.", + sum(!tr_ok), + if (!is.null(loc_xy)) " or no usable location" else "") if (!is.null(folds)) stop("area_of_applicability(): the training data has missing predictor ", "values, so `folds` row positions can no longer be matched. Remove ", "the incomplete rows before building folds.", call. = FALSE) X_tr_full <- X_tr_full[tr_ok, , drop = FALSE] + if (!is.null(loc_xy)) loc_xy$train <- loc_xy$train[tr_ok, , drop = FALSE] # Unreachable when folds were supplied (the branch above stops), but keeps # the IDs aligned with X_tr_full for anything added later. if (!is.null(tr_row_ids)) tr_row_ids <- tr_row_ids[tr_ok] } - sc <- .aoa_scaling(X_tr_full) - dropped <- names(sc$keep)[!sc$keep] + sc <- .aoa_scaling(X_tr_full, col_var = col_var, indicator = des$indicator) + # Columns and predictors are the same thing unless a categorical predictor + # was coded as indicators: then a predictor is dropped when none of its + # columns has variance (one level among the training rows), and a single + # column of a predictor that is kept can be dropped too (a level whose only + # rows were removed above). + dropped_cols <- names(sc$keep)[!sc$keep] + used_vars <- unique(col_var[sc$keep]) + # Named by predictor, or by column when the predictor itself is kept. + # Subscripted assignment, not ifelse(): with nothing dropped ifelse() + # returns logical(0), and `dropped_vars` is documented, and was always + # returned, as a character vector. + dropped <- as.character(col_var[!sc$keep]) + one_col <- dropped %in% used_vars + dropped[one_col] <- dropped_cols[one_col] + dropped <- unique(dropped) if (length(dropped) > 0L) .log_warn(paste0("area_of_applicability(): dropping predictor(s) with no ", "variance in the training data: %s. A prediction point ", "taking a different value there is extrapolation along ", "it, and is marked outside the AOA with DI = Inf."), paste(dropped, collapse = ", ")) - used_vars <- names(sc$keep)[sc$keep] + used_cols <- names(sc$keep)[sc$keep] Z_tr <- .aoa_apply_scaling(X_tr_full, sc) Z_nw <- .aoa_apply_scaling(X_nw_full, sc) + # Where the weights come from. "auto" reads the model's own variable + # importance when it has one that means something; NULL is the explicit + # request for equal weights; anything else is the caller's vector. + if (identical(weights, "auto")) { + aw <- .aoa_auto_weights(model, predictor_vars, fill_vars = coord_vars) + weights <- aw$weights + w_source <- aw$source + w_note <- aw$note + w_given <- FALSE + } else if (is.null(weights)) { + w_source <- "equal" + w_note <- "weights = NULL" + w_given <- FALSE + } else { + w_source <- "supplied" + w_note <- NA_character_ + w_given <- TRUE + } + # Weighting convention: the scaled COLUMN is multiplied by the weight, so a # weight w contributes w^2 to the squared distance. This is what CAST -- # the reference implementation, by the paper's own authors -- does, and @@ -1020,9 +1707,17 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, # NOT what is used here. # The weights that matter are those of the predictors kept; if the only # non-zero ones sat on predictors dropped above, the rest are all zero. - w_vec <- unname(w <- .aoa_equal_if_all_zero( - .aoa_weight_vector(weights, predictor_vars, - fill_vars = coord_vars)[used_vars])) + w_kept <- .aoa_weight_vector(weights, predictor_vars, + fill_vars = coord_vars)[used_vars] + if (!identical(w_source, "equal") && length(w_kept) > 0L && + all(w_kept == 0)) { + w_note <- sprintf("every %s weight on a predictor kept is zero", + if (w_given) "supplied" else "importance") + w_source <- "equal" + } + w <- .aoa_equal_if_all_zero(w_kept) + # One weight per predictor; an indicator-coded predictor's columns share it. + w_vec <- unname(w[col_var[sc$keep]]) Z_tr <- sweep(Z_tr, 2L, w_vec, "*") Z_nw <- sweep(Z_nw, 2L, w_vec, "*") @@ -1046,9 +1741,21 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, "\"block_kfold\") to match a blocked cv_*() result.")) norm <- .aoa_normalizer(Z_tr, max_n = normalizer_max_n, seed = seed) + # Without folds a row that repeats another's predictor values exactly is + # the same point of predictor space, not its neighbour; see + # .aoa_train_dist(). + groups <- if (is.null(splits)) .aoa_row_groups(Z_tr) else NULL + n_dup <- if (is.null(groups)) NA_integer_ else as.integer(groups$n_dup) train_d <- .aoa_train_dist(Z_tr, splits = splits, use_fnn = use_fnn, - chunk_size = chunk_size) + chunk_size = chunk_size, groups = groups) train_DI <- train_d / norm$value + if (isTRUE(n_dup > 0L)) + .log_info(paste0("area_of_applicability(): %d of %d training rows repeat ", + "another row's predictor values exactly (%d distinct ", + "points). A repeat is the same point of predictor space, ", + "not a neighbour, so each row's reference is the nearest ", + "row with different values."), + n_dup, nrow(Z_tr), nrow(Z_tr) - n_dup) thr <- if (is.null(threshold)) .aoa_threshold(train_DI) else { if (!is.numeric(threshold) || length(threshold) != 1L || @@ -1058,25 +1765,28 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, as.numeric(threshold) } - # Each training row's reference is its nearest OTHER training row, so an - # exact duplicate in predictor space -- repeat measurements at a site with - # static covariates, covariates read off a raster coarser than the sampling - # -- has a training DI of 0, and random folds put twins on both sides. Once - # about three quarters of the rows have one, Q3 and the IQR are 0 and so is - # the threshold: 30 sites visited 4 times put 0 of 200 new points inside, - # against 197 after deduplication, with nothing said. The rule is applied - # as defined; the caution says why it came out that way. + # With folds, each training row's reference is the nearest row its fold + # left in training, so a row with an exact duplicate on the other side of + # the split -- repeat measurements at a site with static covariates, + # covariates read off a raster coarser than the sampling -- has a training + # DI of 0. That is the definition, not an error: the hold-out really did + # have an identical row to learn from. But once about three quarters of + # the rows have one, Q3 and the IQR are 0 and so is the threshold, and only + # exact copies of a training row are inside. A result that degenerate is + # raised as a warning with a class, so a script or a cv loop can catch it. if (is.null(threshold) && thr == 0) - .log_warn(paste0("area_of_applicability(): the DI threshold is 0 because ", - "%d of %d training rows have an exact duplicate in ", - "predictor space among their reference rows (training ", - "DI = 0), so only prediction points identical to a ", - "training row count as inside. Repeat measurements at a ", - "site, or covariates coarser than the sampling, do this: ", - "pass folds that keep the duplicates together ", - "(make_folds(method = \"leave_location_out\", group_var = ", - "...)), or remove the duplicate rows."), - sum(train_DI == 0), length(train_DI)) + .aoa_warn_zero_threshold( + paste0("area_of_applicability(): the DI threshold is 0 because %d of %d ", + "training rows have an exact duplicate in predictor space among ", + "the rows their fold trains on (training DI = 0), so only ", + "prediction points identical to a training row count as inside. ", + "Repeat measurements at a site, or covariates coarser than the ", + "sampling, do this when the folds split them. Pass folds that ", + "keep the duplicates together (make_folds(method = ", + "\"leave_location_out\", group_var = ...)), or folds = NULL, ", + "which measures each row against the nearest row with different ", + "values."), + sum(train_DI == 0), length(train_DI)) # NA or Inf predictors in newdata give NA DI rather than a misleading number. # Same test as the training side above, deliberately: complete.cases() alone @@ -1091,6 +1801,22 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, use_fnn = use_fnn, chunk_size = chunk_size) / norm$value + # A level no training row has: the model has nothing to say about it, and + # no distance to a training row is defined along that predictor. + if (ncol(des$unseen) > 0L) { + unseen <- rowSums(des$unseen) > 0L & !is.na(DI) + if (any(unseen)) { + DI[unseen] <- Inf + .warn_and_log(paste0("area_of_applicability(): %d of %d prediction ", + "row(s) carry a level of %s that no training row ", + "has; they are marked outside the AOA with DI = Inf."), + sum(unseen), length(DI), + paste(sQuote(colnames(des$unseen)[ + colSums(des$unseen[unseen, , drop = FALSE]) > 0L]), + collapse = ", ")) + } + } + # A predictor dropped for having no training variance is not in the # distance, so a prediction row taking a different value there was judged # on the other predictors alone: a land-cover dummy that is 0 throughout the @@ -1100,17 +1826,18 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, # "Different" means outside the training range by more than the relative # tolerance .aoa_scaling() drops the predictor with; a missing value cannot # be compared and leaves the row to the other predictors. - if (length(dropped) > 0L) { - Xd_tr <- X_tr_full[, dropped, drop = FALSE] + if (length(dropped_cols) > 0L) { + Xd_tr <- X_tr_full[, dropped_cols, drop = FALSE] lo <- apply(Xd_tr, 2L, min) hi <- apply(Xd_tr, 2L, max) mag <- pmax(abs(lo), abs(hi)) mag[!is.finite(mag) | mag <= 0] <- 1 slack <- .Machine$double.eps^0.5 * mag - Xd_nw <- X_nw_full[, dropped, drop = FALSE] + Xd_nw <- X_nw_full[, dropped_cols, drop = FALSE] off <- sweep(Xd_nw, 2L, lo - slack, "<") | sweep(Xd_nw, 2L, hi + slack, ">") off[is.na(off)] <- FALSE - beyond <- rowSums(off) > 0L & !is.na(DI) + # Rows already outside on an unseen level are not counted a second time. + beyond <- rowSums(off) > 0L & !is.na(DI) & is.finite(DI) if (any(beyond)) { DI[beyond] <- Inf .warn_and_log(paste0("area_of_applicability(): %d of %d prediction ", @@ -1119,14 +1846,70 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, "are extrapolation along it and are marked outside ", "the AOA with DI = Inf."), sum(beyond), length(DI), - paste(sQuote(dropped[colSums(off[beyond, , drop = FALSE]) > 0L]), + paste(sQuote(dropped_cols[colSums(off[beyond, , drop = FALSE]) > 0L]), collapse = ", ")) } } + inside <- DI <= thr + # The location index: the same construction as the predictor index, in map + # space. Distance to the nearest training point, over the mean pairwise + # distance between training points; the training points' own values taken + # the same way (same folds, same rule for repeated locations); the same + # outlier-removed maximum as the threshold. The coordinates are centred + # and not scaled: map distance is isotropic, and a study area longer than + # it is wide is not a reason to count a kilometre north as more than a + # kilometre east. + location <- NULL + DI_loc <- NULL + if (!is.null(loc_xy)) { + xy_ctr <- colMeans(loc_xy$train) + C_tr <- sweep(loc_xy$train, 2L, xy_ctr, "-") + C_nw <- sweep(loc_xy$new, 2L, xy_ctr, "-") + norm_loc <- .aoa_normalizer(C_tr, max_n = normalizer_max_n, seed = seed, + what = "location") + loc_groups <- if (is.null(splits)) .aoa_row_groups(C_tr) else NULL + train_DI_loc <- .aoa_train_dist(C_tr, splits = splits, use_fnn = use_fnn, + chunk_size = chunk_size, + groups = loc_groups) / norm_loc$value + thr_loc <- .aoa_threshold(train_DI_loc) + if (thr_loc == 0) + .aoa_warn_zero_threshold( + paste0("area_of_applicability(): the location threshold is 0 because ", + "%d of %d training rows share their location with a row their ", + "fold trains on, so only prediction points at a training ", + "location count as inside. Repeat measurements at a site do ", + "this when the folds split them. Pass folds that keep a site ", + "together (make_folds(method = \"leave_location_out\", ", + "group_var = ...)), or folds = NULL, which measures each site ", + "against the nearest other site."), + sum(train_DI_loc == 0), length(train_DI_loc)) + loc_ok <- is.finite(C_nw[, 1L]) & is.finite(C_nw[, 2L]) + DI_loc <- rep(NA_real_, nrow(C_nw)) + if (any(loc_ok)) + DI_loc[loc_ok] <- .aoa_min_dist(C_nw[loc_ok, , drop = FALSE], C_tr, + use_fnn = use_fnn, + chunk_size = chunk_size) / norm_loc$value + inside_loc <- DI_loc <= thr_loc + # Inside means inside on both. R's three-valued `&` is the right rule + # for a missing value: a row outside on one index is outside whatever + # the other would have said, and a row inside on one with the other + # missing is not classified. + inside <- inside & inside_loc + location <- list( + threshold = thr_loc, + train_DI = train_DI_loc, + normalizer = norm_loc$value, + n_duplicates = if (is.null(loc_groups)) NA_integer_ + else as.integer(loc_groups$n_dup), + n_outside = sum(!inside_loc, na.rm = TRUE) + ) + } + out <- newdata out$DI <- DI + if (!is.null(DI_loc)) out$DI_location <- DI_loc out$AOA <- inside structure( @@ -1138,19 +1921,26 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, weights = w, predictor_vars = used_vars, dropped_vars = dropped, - # The space the index is computed in: each predictor's training centre - # and SD. Without them a location's DI cannot be traced to the + # The space the index is computed in: each column's training centre + # and scale. Without them a location's DI cannot be traced to the # predictor that put it outside. - scaling = list(center = sc$center[used_vars], - scale = sc$scale[used_vars]), + scaling = list(center = sc$center[used_cols], + scale = sc$scale[used_cols]), # Training DI values above the Q3 + 1.5 IQR fence: the ones the # default threshold rule sets aside as outliers. n_outliers = .aoa_fence_outliers(train_DI), + # Training rows that repeat another row's predictor values exactly and + # so share its reference distance; NA when folds set the reference. + n_duplicates = n_dup, + # The location index, when one was measured; NULL otherwise. + location = location, + categorical_vars = cat_vars, n_train = nrow(Z_tr), n_new = nrow(Z_nw), n_inside = sum(inside, na.rm = TRUE), n_outside = sum(!inside, na.rm = TRUE), - n_na = sum(is.na(DI)), + n_na = sum(is.na(inside)), + n_outside_predictors = sum(DI > thr, na.rm = TRUE), params = list( folds_supplied = !is.null(splits), n_folds = if (is.null(splits)) 0L else length(splits), @@ -1159,7 +1949,12 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, normalizer_max_n = normalizer_max_n, normalizer_n_used = norm$n_used, normalizer_subsampled = norm$subsampled, - weights_supplied = !is.null(weights), + weights_supplied = w_given, + weights_source = w_source, + weights_note = w_note, + coords = switch(coord_mode, predictors = "predictors", + index = "location index", "none"), + categorical = categorical, seed = seed ) ), @@ -1204,7 +1999,13 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, #' Summarises where the model may be trusted: how many prediction locations #' fall inside the area of applicability and how many outside, the #' dissimilarity threshold that separated them, and the predictors the index -#' was computed over (naming any dropped for having no usable variance). The +#' was computed over (naming any dropped for having no usable variance). It +#' also says where the weights came from (the model's importance, a vector +#' the caller supplied, or equal weights and why), whether location was +#' measured and how, how categorical predictors were handled, and how many +#' training rows repeat another's predictor values. With a location index +#' the rows outside are split into those outside on the predictors and those +#' outside on location. The #' proportion outside is the headline number. A map that extrapolates over #' much of its extent is reporting predictions its training data cannot #' support, whatever the cross-validation score said. @@ -1221,15 +2022,40 @@ print.aoa <- function(x, ...) { if (length(x$dropped_vars) > 0L) cat(sprintf(" dropped : %s (no training variance)\n", paste(x$dropped_vars, collapse = ", "))) + if (length(x$categorical_vars) > 0L) + cat(sprintf(" categorical : %s %s\n", + paste(x$categorical_vars, collapse = ", "), + if (identical(x$params$categorical, "drop")) + "left out of the index (categorical = \"drop\")" + else "coded as one 0/1 column per level")) + # Where the weights came from. An object built before the source was + # recorded says only whether the caller supplied any. + src <- x$params$weights_source + note <- x$params$weights_note + note <- if (is.character(note) && length(note) == 1L && !is.na(note) && + nzchar(note)) note else NULL cat(sprintf(" weighted : %s\n", - if (isTRUE(x$params$weights_supplied)) "yes" else - "no (all predictors count equally)")) + if (is.null(src)) { + if (isTRUE(x$params$weights_supplied)) "yes" else + "no (all predictors count equally)" + } else switch(src, + "model importance" = sprintf( + "yes, by the model's %s, floored at 0", + note %||% "variable importance"), + supplied = "yes, by the weights supplied", + sprintf("no (all predictors count equally%s)", + if (is.null(note)) "" else paste0(": ", note))))) cat(sprintf(" training : %d points\n", x$n_train)) + n_dup <- suppressWarnings(as.integer(x$n_duplicates %||% NA_integer_)) cat(sprintf(" reference : %s\n", if (isTRUE(x$params$folds_supplied)) sprintf("nearest point outside each of %d CV folds (%s)", x$params$n_folds, .aoa_folds_label(x$params$folds_method)) + else if (isTRUE(n_dup > 0L)) + sprintf(paste0("nearest training point with different values ", + "(no folds supplied; %d of %d rows repeat ", + "another's values)"), n_dup, x$n_train) else "nearest other training point (no folds supplied)")) cat(sprintf(" normaliser : %.4f (mean pairwise distance%s)\n", x$normalizer, @@ -1246,16 +2072,42 @@ print.aoa <- function(x, ...) { cat(sprintf(paste0(" (%d of %d training DI are 0: exact ", "duplicates in predictor space)\n"), n_zero, length(x$train_DI))) + loc <- x$location + if (is.list(loc)) { + cat(sprintf(paste0(" location : measured on its own; threshold %.4f ", + "(%s map units from the nearest training point)\n"), + loc$threshold, format(signif(loc$threshold * loc$normalizer, 4)))) + if (isTRUE(loc$threshold == 0)) + cat(sprintf(paste0(" (%d of %d training rows share a ", + "location with a row their fold trains on)\n"), + sum(loc$train_DI == 0, na.rm = TRUE), length(loc$train_DI))) + } else if (identical(x$params$coords, "predictors")) { + cat(" location : measured as the predictors ..x and ..y\n") + } else if (!is.null(x$params$coords)) { + cat(" location : not measured\n") + } cat("\n") pct <- if (x$n_new > 0L) 100 * x$n_inside / x$n_new else NA_real_ cat(sprintf(" %d of %d prediction points inside the AOA (%.1f%%)\n", x$n_inside, x$n_new, pct)) + if (is.list(loc) && x$n_outside > 0L) + cat(sprintf(paste0(" %d outside: %d on the predictors, %d on location ", + "(a point can be both)\n"), + x$n_outside, x$n_outside_predictors %||% NA_integer_, + loc$n_outside)) if (x$n_na > 0L) - cat(sprintf(" %d with missing predictors (DI = NA)\n", x$n_na)) + cat(sprintf(" %d %s\n", x$n_na, + if (is.list(loc)) + "not classified (a predictor or the location is missing)" + else "with missing predictors (DI = NA)")) n_inf <- sum(is.infinite(x$aoa$DI)) if (n_inf > 0L) - cat(sprintf(" %d outside on a dropped predictor (DI = Inf)\n", n_inf)) + cat(sprintf(" %d outside on %s (DI = Inf)\n", n_inf, + if (length(x$categorical_vars) > 0L && + identical(x$params$categorical, "indicator")) + "a level no training row has, or on a dropped predictor" + else "a dropped predictor")) if (x$n_outside > 0L) cat("\nPredictions outside the AOA are extrapolations; the ", "cross-validated\nperformance estimate does not cover them.\n", diff --git a/R/assignment.R b/R/assignment.R index 68a5c7ab..14d51f16 100644 --- a/R/assignment.R +++ b/R/assignment.R @@ -19,10 +19,25 @@ #' #' @param features_sf An sf object containing features to assign. #' @param polygons_sf An sf or sfc polygonal layer. -#' @param polygon_id_col Name of the polygon identifier column. Default "poly_id". +#' @param polygon_id_col Name of the polygon identifier column: the column of +#' `polygons_sf` the IDs are read from, and the name they are returned +#' under. Default "poly_id". When `polygons_sf` has no column of that name, +#' the IDs are read from the first of `"poly_id"`, `"polygon_id"`, `"id"`, +#' `"cell_id"` and `"grid_id"` it carries, and a message names the column +#' that was used; when it has none of them, the polygons are numbered +#' `1, 2, ...` in row order, and a message says so. The column the IDs are +#' read from must hold one distinct, non-missing value per polygon: a +#' duplicated or missing ID is an error, because features in different +#' polygons would come back under one ID. That includes a unit stored as +#' several rows that share its ID (a region split into `POLYGON` parts): +#' merge the parts into one row per ID first, for example with +#' `dplyr::summarise(dplyr::group_by(polygons_sf, ))`, which +#' keeps the unit one cell. Numbering the rows would make each part a cell +#' of its own. #' @param keep_unassigned Logical; retain features that fall inside no #' polygon, carrying \code{NA} in the ID column. Default FALSE, which drops -#' them. +#' them with a warning of class \code{"spatialkit_unassigned"} that gives +#' their number. #' @param predicate Binary spatial predicate function. Default sf::st_intersects. #' Not used when \code{largest} applies: sf then assigns polygon features by #' overlap area and never calls the predicate. @@ -49,7 +64,12 @@ #' edge of two grid cells), the one whose bounding-box centre is lowest, #' then leftmost, so the choice does not depend on the order of the rows; #' \code{"first"} keeps the first match (original order-dependent -#' behavior). +#' behavior). On cells built from the centres a profile scored, a point on +#' the edge between two of them is placed by the profile's rule whichever +#' is given (see Value). +#' @param quiet Logical; suppress this function's \code{message()}s (the one +#' naming a fallback ID column). It does not silence R warnings. Default +#' \code{FALSE}. #' @return An sf object with `polygon_id_col` attached, one row per input #' feature (fewer if `keep_unassigned = FALSE` dropped unmatched ones), in #' the CRS `features_sf` arrived in. A column of `features_sf` already @@ -61,10 +81,26 @@ #' falls inside any polygon #' the result is empty (or all-`NA` with `keep_unassigned = TRUE`) and a #' warning is raised, since the usual cause is two layers in different -#' places (a CRS that could only be stamped, not reprojected). The +#' places (a CRS that could only be stamped, not reprojected). +#' +#' Features that fall inside no polygon are counted on the attribute +#' `"unassigned"`: a list with `n`, `which` (their row positions in +#' `features_sf`) and `n_rows`. With `keep_unassigned = FALSE` they are not +#' in the result, and a warning of class `"spatialkit_unassigned"` gives +#' their number (`tryCatch(spatialkit_unassigned = )` catches it without +#' matching the message; the condition carries `n` and `total`). The usual +#' causes are a polygon layer that stops short of the data (a coastline +#' drawn at another scale, a tessellation of seeds built without a +#' `boundary` or `cover`; see [build_tessellation()]) and points outside +#' the study area. With `keep_unassigned = TRUE` they are kept with an +#' `NA` ID and no warning is raised, unless every feature is unassigned. +#' +#' The #' attribute `"ties"` records how many features matched more than one #' polygon (with `largest`, overlapped several by exactly the same area) -#' and had the `tie_break` rule decide for them: a list with `n`, +#' and had the `tie_break` rule decide for them (on cells built from the +#' centres a profile scored, the profile's rule then places the points +#' among them, as the last paragraph says): a list with `n`, #' `which` (their row positions in `features_sf`), `rule` and `n_rows` #' (the number of rows returned, which the record was made for). A large #' `n` means the polygon layer overlaps, and per-cell counts built from the @@ -74,7 +110,56 @@ #' with no `"ties"` attribute, so nothing reports the parent's count #' for a different set of rows. `sf::st_drop_geometry()` keeps the record, #' since the rows are the same; see \code{\link{[.spatialkit_rows}} for -#' what binding such data frames does. +#' what binding such data frames does. The `"unassigned"` record is +#' stamped and removed the same way. +#' +#' When `polygons_sf` carries `attr(, "count_rule")`, the record of how +#' its cell count was set (cells from [build_tessellation()] on seeds +#' placed from a [select_resolution()] result or from a profile built with +#' an `estimate`), the result carries the same record. +#' [summarize_by_cell()] reads it and checks that the rows and cells it is +#' given are the ones the count was scored on. It is a plain attribute: a +#' row subset keeps it and `dplyr::mutate()`, `dplyr::select()` and +#' `dplyr::arrange()` drop it, which is why the summary also looks for it +#' on its `cells_sf`. The profile scores a feature that is not a point at +#' one point of it (`coerce_to_points(, "auto")`), in the cell of the +#' nearest centre; this function gives a polygon feature to the cell it +#' overlaps most. A feature that straddles a cell boundary can therefore +#' be assigned to another cell than the one it was scored in, and the +#' summary does not compare the two for such a layer. To assign the +#' features as they were scored, assign their points: +#' `assign_features_to_polygons(coerce_to_points(features_sf, "auto"), polygons_sf)`. +#' +#' When that record says the cells are the ones the profile scored +#' (`scored_cells` is `TRUE`: the cells [build_tessellation()] builds on a +#' selection's seeds, or on the seeds a seeding function returns for one) +#' and holds the centres it scored (`count_rule$scored$centres`), a point +#' on the edge between two or more of those cells is given the cell +#' [resolution_profile()] scored it in: that of its nearest centre, +#' measured in the CRS the record names, and of centres the same distance +#' away the lower-numbered one. Such points occur on gridded locations +#' (raster cell centres, a regular sampling grid), where a row can lie the +#' same distance from two centres and the polygons hold it in either cell +#' or in both. The rows each cell holds are then the rows its count was +#' scored on, and [summarize_by_cell()]'s check of them reads `"match"`. +#' A point counts as on the edge when it lies within a margin of both +#' cells: one part in 1e10 of the largest coordinate of the cells, 0.44 mm +#' at a UTM northing of 4,400 km. [build_tessellation()] draws such cells +#' in the CRS the record names, around the centres as the record holds +#' them, whatever CRS the seeds came back in (unless its `crs` names +#' another projected CRS), so their corners carry only the rounding of +#' that computation, far less than the margin. A point +#' farther from its nearest centre's cell keeps the polygon that holds it, +#' and so do features that are not points, points without a CRS beside a +#' record with one, and a join in longitude and latitude. A centre's cell +#' is the one cell that holds it and no other centre; a centre outside a +#' boundary that clipped its cell away from it has the cell, among those +#' that hold no centre, whose inside is nearest it. Cells built from other +#' seeds leave most centres without a cell, and their points to the +#' polygons. Polygons without the record, such as polygons +#' the caller brings, and cells whose record says `scored_cells` is +#' `FALSE` or `NA` (other cells built from the count, such as a lattice +#' sized by it) are placed by the polygons alone. #' @examples #' library(sf) #' set.seed(1) @@ -98,8 +183,10 @@ assign_features_to_polygons <- function( features_sf, polygons_sf, polygon_id_col = "poly_id", keep_unassigned = FALSE, predicate = sf::st_intersects, largest = TRUE, - tie_break = c("smallest_area", "first") + tie_break = c("smallest_area", "first"), + quiet = FALSE ) { + .msg <- function(...) if (!isTRUE(quiet)) message(...) if (!inherits(features_sf, "sf")) stop("assign_features_to_polygons(): `features_sf` must be an sf object.") if (!inherits(polygons_sf, "sf")) { @@ -109,6 +196,9 @@ assign_features_to_polygons <- function( if (nrow(polygons_sf) == 0L) stop("assign_features_to_polygons(): `polygons_sf` has zero rows.") tie_break <- match.arg(tie_break) + # The record of how the cells' count was set, when they carry one: copied + # onto the assigned rows, where summarize_by_cell() looks for it first. + count_rule <- .count_rule_get(polygons_sf) orig_crs <- sf::st_crs(features_sf) # The join runs in the polygons' CRS whenever that is projected: it is the @@ -128,12 +218,66 @@ assign_features_to_polygons <- function( # CRS and returned there, as before. f_geom <- if (is.na(orig_crs)) sf::st_geometry(f) else sf::st_geometry(features_sf) - id_candidates <- c(polygon_id_col, "poly_id", "polygon_id", "id", "cell_id", "grid_id") + id_candidates <- unique(c(polygon_id_col, "poly_id", "polygon_id", "id", "cell_id", "grid_id")) id_col <- id_candidates[id_candidates %in% names(p)][1] + # Which column the IDs came from is said whenever it is not the one asked + # for. A fallback used to be taken without a word: nine polygons carrying a + # zone attribute called `id` came back as three "polygons", and nine keyed + # by `GEOID` came back numbered 1 to 9 with the GEOIDs unused. + id_source <- "the column named by `polygon_id_col`" if (length(id_col) == 0L || is.na(id_col)) { id_col <- polygon_id_col p[[id_col]] <- seq_len(nrow(p)) + id_source <- "row numbers" + .log_info(paste0("assign_features_to_polygons(): `polygons_sf` has no '%s' ", + "column and none of the fallback ID columns; polygons numbered ", + "1 to %d in row order."), polygon_id_col, nrow(p)) + .msg(sprintf(paste0( + "assign_features_to_polygons(): `polygons_sf` has no '%s' column, and none ", + "of the fallback ID columns (%s); the polygons are numbered 1 to %d in row ", + "order. To use an ID the polygons already carry, name its column with ", + "`polygon_id_col`."), + polygon_id_col, + paste(sprintf("'%s'", setdiff(id_candidates, polygon_id_col)), collapse = ", "), + nrow(p))) + } else if (!identical(id_col, polygon_id_col)) { + id_source <- sprintf("read because `polygons_sf` has no '%s' column", polygon_id_col) + .log_info(paste0("assign_features_to_polygons(): `polygons_sf` has no '%s' ", + "column; polygon IDs read from its '%s' column."), + polygon_id_col, id_col) + .msg(sprintf(paste0( + "assign_features_to_polygons(): `polygons_sf` has no '%s' column; the ", + "polygon IDs are read from its '%s' column and returned as `%s`."), + polygon_id_col, id_col, polygon_id_col)) } + # One distinct, non-missing ID per polygon. A duplicated ID merged the + # features of two polygons under one label (a `poly_id` repeated once gave 8 + # IDs for 9 polygons), and a missing one made the features inside that + # polygon look unassigned, so they were dropped: neither raised a condition. + # Rows that share an ID on purpose (one unit stored as several POLYGON + # rows) are refused with the rest, since the two cases look the same from + # here; the message says how to keep such a unit whole, because numbering + # the rows would split it into one cell per part. + ids_p <- p[[id_col]] + id_na <- sum(is.na(ids_p)) + id_dup <- sum(duplicated(ids_p[!is.na(ids_p)])) + if (id_na > 0L || id_dup > 0L) + stop(sprintf(paste0( + "assign_features_to_polygons(): the polygon ID column '%s' (%s) holds %d ", + "duplicated and %d missing value(s) among %d polygon(s), so features in ", + "different polygons would share an ID or lose theirs. Give every polygon ", + "its own ID (polygons_sf$%s <- seq_len(nrow(polygons_sf)), or ", + "ensure_stable_poly_id()), or name the column that holds one with ", + "`polygon_id_col`.%s"), + id_col, id_source, id_dup, id_na, nrow(p), polygon_id_col, + if (id_dup > 0L) sprintf(paste0( + " If the rows that share an ID are the parts of one unit (a region ", + "stored as several polygons), merge them into one row per ID first, so ", + "the unit stays one cell: dplyr::summarise(dplyr::group_by(polygons_sf, ", + "%s)). Numbering the rows would make each part a cell of its own."), + if (identical(make.names(id_col), id_col)) id_col + else sprintf("`%s`", id_col)) + else ""), call. = FALSE) # The polygons' ID travels through the join under a reserved name and is # renamed to `polygon_id_col` afterwards. Under its source name, a @@ -343,24 +487,61 @@ assign_features_to_polygons <- function( } else { joined <- joined[!duplicated(joined[["..pre_join_row_id"]]), , drop = FALSE] } + # On cells built from the centres a profile scored, a point on the edge + # between two of them goes to the cell the profile scored it in, whatever + # `tie_break` picked or which side of the edge rounding put it on: its + # nearest centre, a tie to the lower-numbered one. Then the rows each cell + # holds are the rows its count was scored on. + if (!is.null(count_rule)) { + on_edge <- .scored_edge_cells(f, p, id_col, joined, polygon_id_col, count_rule, + features_sf) + if (length(on_edge$rows)) { + joined[[polygon_id_col]][on_edge$rows] <- on_edge$ids + .log_info(paste0("assign_features_to_polygons(): %d point(s) on the edge between two ", + "cells resolution_profile() scored were given the cell it scored ", + "them in, that of their nearest centre."), + length(on_edge$rows)) + } + } + # Which features matched no polygon, by their row in `features_sf`, read + # before the row key goes. + unassigned_rows <- sort(joined[["..pre_join_row_id"]][is.na(joined[[polygon_id_col]])]) joined[["..pre_join_row_id"]] <- NULL - n_unassigned <- sum(is.na(joined[[polygon_id_col]])) + n_unassigned <- length(unassigned_rows) + n_features <- nrow(joined) # Zero matches is almost never what the caller meant, and it is silent: the # function returns an empty sf and every downstream step reports zero rows # without saying why. The usual cause is a CRS mismatch that could only be # stamped rather than reprojected, which puts the two layers in different # places. - if (n_unassigned == nrow(joined) && nrow(joined) > 0L) - .warn_and_log(paste0("assign_features_to_polygons(): none of the %d ", + if (n_unassigned == n_features && n_features > 0L) + .warn_classed("spatialkit_unassigned", + paste0("assign_features_to_polygons(): none of the %d ", "feature(s) fall inside any polygon. Check that the ", "two layers cover the same ground -- a CRS that had to ", "be stamped rather than reprojected is the usual ", "cause -- or pass a different `predicate`."), - nrow(joined)) + n_features, data = list(n = n_unassigned, total = n_features)) + else if (n_unassigned > 0L && !keep_unassigned) + # Rows removed from the result are data dropped, which the caller has to + # be able to catch: this was one INFO line in the temp log, and a + # tessellation of 25 k-means seeds built without a boundary lost 764 of + # 3,000 observations (the edge of the study area, so the cell means moved + # too) with no condition raised and nothing on the result. + .warn_classed("spatialkit_unassigned", + paste0("assign_features_to_polygons(): %d of %d feature(s) ", + "(%.1f%%) fall inside no polygon and are left out of ", + "the result; attr(, \"unassigned\")$which gives their ", + "rows in `features_sf`. Check that the polygons cover ", + "the features (cells built from seeds need a ", + "`boundary` or a `cover`; see build_tessellation()), or ", + "pass keep_unassigned = TRUE to keep them with an NA ID."), + n_unassigned, n_features, 100 * n_unassigned / n_features, + data = list(n = n_unassigned, total = n_features)) else if (n_unassigned > 0L) - .log_info("assign_features_to_polygons(): %d of %d feature(s) fall inside no polygon.", - n_unassigned, nrow(joined)) + .log_info("assign_features_to_polygons(): %d of %d feature(s) fall inside no polygon and are kept with an NA ID.", + n_unassigned, n_features) if (!keep_unassigned) { joined <- joined[!is.na(joined[[polygon_id_col]]), , drop = FALSE] @@ -373,7 +554,13 @@ assign_features_to_polygons <- function( list(n = length(tie_rows), which = as.integer(tie_rows), rule = tie_break)) - joined + # The features no polygon holds, beside the ties: the count used to exist + # only in a log line. Stamped the same way, and removed by a subset with + # the other records named in .row_record_attrs (R/utils.R). + joined <- .set_row_record(joined, "unassigned", + list(n = n_unassigned, + which = as.integer(unassigned_rows))) + .count_rule_put(joined, count_rule) } @@ -424,6 +611,125 @@ assign_features_to_polygons <- function( } +#' Points on the edge between cells a profile scored, placed as it placed them +#' +#' On cells whose record of their count sits beside the centres the profile +#' scored (\code{.scored_centres()}), \code{resolution_profile()} gave each +#' row to its nearest centre in the record's CRS, a tie to the lower-numbered +#' centre (\code{.nearest_centre()}), and the polygons hold a row that is the +#' same distance from two centres in either cell, or in both. A point the +#' join placed in a cell, that lies within \code{.edge_tol()} of the edge of +#' that cell and of the cell of the centre the profile's rule gives it, is +#' given that cell. A point farther from that cell than the margin keeps +#' the cell it has: it is not on their shared edge, so the cells are not the +#' ones scored there (built in another CRS, say), and the summary's check +#' says so. +#' +#' The cell of a centre is the one cell that holds it, when it holds no +#' other centre: a Voronoi cell holds its own centre and no other, so cells +#' built from other seeds (a subset of the centres) leave most centres +#' without one, and the points tied to those keep their cells. A centre in +#' no cell stands outside a boundary that clipped its cell away from it; +#' its cell is then the one cell holding no centre whose point on the +#' surface has it as its nearest centre, when no other such cell has. +#' +#' Edges are measured in the CRS of the join: a projected one, or none on +#' either side when the record names none. Polygons in longitude and +#' latitude, features without a CRS beside a record with one, or the +#' reverse, are left as the join placed them. +#' +#' @param f The join's copy of the features, in the join's CRS, one row per +#' row of \code{features}. +#' @param p The polygons, in the join's CRS, with their IDs in \code{id_col}. +#' @param id_col The ID column of \code{p}. +#' @param joined The join, one row per feature: \code{..pre_join_row_id} +#' (the row of \code{f}) and the polygon's ID in \code{id}. +#' @param id The name of the ID column of \code{joined}. +#' @param rec The record of the count the polygons carry. +#' @param features The features as the caller passed them. +#' @return A list: \code{rows}, the rows of \code{joined} whose cell +#' changes, and \code{ids}, the ID each gets. +#' @keywords internal +#' @noRd +.scored_edge_cells <- function(f, p, id_col, joined, id, rec, features) { + none <- list(rows = integer(0), ids = p[[id_col]][integer(0)]) + cen <- .scored_centres(rec) + if (is.null(cen)) return(none) + crs_j <- sf::st_crs(p) + crs_r <- rec$crs + crs_f <- sf::st_crs(features) + if (!is.na(crs_j) && isTRUE(sf::st_is_longlat(crs_j))) return(none) + if (!is.na(crs_r) && isTRUE(sf::st_is_longlat(crs_r))) return(none) + if (is.na(crs_r) != is.na(crs_j) || is.na(crs_r) != is.na(crs_f)) return(none) + + # The points the join placed in a cell. + ids_p <- p[[id_col]] + at <- match(joined[[id]], ids_p) + src <- joined[["..pre_join_row_id"]] + gf <- sf::st_geometry(f) + point <- sf::st_geometry_type(gf, by_geometry = TRUE) == "POINT" & !sf::st_is_empty(gf) + rows <- which(!is.na(at) & point[src]) + if (!length(rows)) return(none) + + # Those within the margin of their own cell's edge. The others lie inside + # it, away from every other cell. + gp <- sf::st_geometry(p) + tol <- .edge_tol(sf::st_bbox(gp)) + edge <- suppressWarnings(sf::st_boundary(gp)) + d <- as.numeric(sf::st_distance(gf[src[rows]], edge[at[rows]], by_element = TRUE)) + rows <- rows[which(d <= tol)] + if (!length(rows)) return(none) + + # Their nearest centre, from their coordinates in the record's CRS, as the + # profile measured them. + pts <- features[src[rows], , drop = FALSE] + if (!is.na(crs_r) && !isTRUE(crs_f == crs_r)) pts <- sf::st_transform(pts, crs_r) + xy <- unname(sf::st_coordinates(pts)[, 1:2, drop = FALSE]) + ok <- is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + rows <- rows[ok] + if (!length(rows)) return(none) + g <- .nearest_centre(xy[ok, 1L], xy[ok, 2L], cen[, 1L], cen[, 2L], + use_fnn = .has_backend("FNN")) + + # The cell of each centre: the one cell that holds it and no other centre. + where <- sf::st_as_sf(data.frame(x = cen[, 1L], y = cen[, 2L]), coords = c("x", "y"), + crs = crs_r) + if (!is.na(crs_r) && !isTRUE(crs_r == crs_j)) where <- sf::st_transform(where, crs_j) + hit <- sf::st_intersects(where, gp) + cell <- rep(NA_integer_, nrow(cen)) + one <- lengths(hit) == 1L + cell[one] <- vapply(hit[one], function(h) h[1L], integer(1)) + cell[cell %in% cell[duplicated(cell) & !is.na(cell)]] <- NA_integer_ + # A centre in no cell lies outside a boundary that clipped its cell away + # from it. Its cell is the one, among the cells that hold no centre, whose + # inside is nearer it than any other centre: a point on that cell's surface + # has it as its nearest centre, and no other such cell has. + lost <- which(lengths(hit) == 0L) + if (length(lost)) { + empty <- setdiff(seq_along(gp), unlist(hit)) + if (length(empty)) { + inside <- suppressWarnings(sf::st_point_on_surface(gp[empty])) + if (!is.na(crs_r) && !isTRUE(crs_r == crs_j)) inside <- sf::st_transform(inside, crs_r) + ixy <- unname(sf::st_coordinates(inside)[, 1:2, drop = FALSE]) + fin <- is.finite(ixy[, 1L]) & is.finite(ixy[, 2L]) + k <- rep(NA_integer_, length(empty)) + k[fin] <- .nearest_centre(ixy[fin, 1L], ixy[fin, 2L], cen[, 1L], cen[, 2L], + use_fnn = .has_backend("FNN")) + own <- !is.na(k) & k %in% lost & !(k %in% k[duplicated(k) & !is.na(k)]) + cell[k[own]] <- empty[own] + } + } + + # A point goes to its centre's cell when it lies on that cell's edge too. + to <- cell[g] + move <- which(!is.na(to) & to != at[rows]) + if (!length(move)) return(none) + d_to <- as.numeric(sf::st_distance(gf[src[rows[move]]], gp[to[move]], by_element = TRUE)) + move <- move[which(d_to <= tol)] + list(rows = rows[move], ids = ids_p[to[move]]) +} + + #' Correlation implied by a fitted gstat variogram model #' #' Converts a fitted variogram to a correlation function of distance, giving @@ -792,30 +1098,28 @@ assign_features_to_polygons <- function( } -#' Warn that a requested design effect fell back to 1 +#' Warn that a requested design effect was not the one applied #' -#' \code{.warn_and_log()} with a condition class, so that a caller running -#' many summaries can catch exactly this case -- the standard errors are the -#' uncorrected ones although a correction was asked for -- with -#' \code{tryCatch(spatialkit_deff_fallback = )} or -#' \code{withCallingHandlers()}, rather than by matching message text. +#' The classed warning for a design effect that fell back: to 1 for a refused +#' number, and to \code{"kish"} (or, when its ICCs are 0, to nothing) for a +#' \code{"variogram"} request with no usable model. The class is +#' \code{"spatialkit_deff_fallback"} in both cases. #' #' @keywords internal #' @noRd -.warn_deff_fallback <- function(fmt, ...) { - msg <- sprintf(fmt, ...) - # raising = TRUE: the warning below shows it, so a knitted document must - # not repeat the line as a message (see .sk_console_appender()). - .sk_log(logger::WARN, msg, raising = TRUE) - warning(warningCondition(msg, class = "spatialkit_deff_fallback")) - invisible(msg) +.warn_deff_fallback <- function(fmt, ..., data = list()) { + .warn_classed("spatialkit_deff_fallback", fmt, ..., data = data) } #' Summarize features by polygon/cell ID #' #' Aggregates an sf point dataset into one row per cell. By default computes -#' counts and means, but the aggregation function is configurable. +#' counts and means, but the aggregation function is configurable. It also +#' returns a pooled value for each cell, its mean pulled toward the mean of +#' the cells around it (`estimate = "pooled"`, the default; `estimate = +#' "mean"` leaves it out), and can return a range for one further +#' observation. #' #' This is the third step of the package's pipeline, taking the labelled layer #' from [assign_features_to_polygons()] down to cell level. What distinguishes @@ -843,7 +1147,20 @@ assign_features_to_polygons <- function( #' `deff` applied one. With `deff = 1` and no missing values it equals `n`. #' Pass it as the `weights` argument of a downstream regression. #' -#' @section Spatial autocorrelation and standard-error bias: +#' An infinite value (`Inf`, `-Inf`) in a response or predictor column is +#' treated as missing, as `NA` and `NaN` are, in every statistic of that +#' column: the `agg_funs` results, `..sd_*`, `..se_*`, the interval columns, +#' `..neff_*`, `cell_weight` and the design effect. `n` still counts the row. +#' A warning of class `"spatialkit_nonfinite"` names the columns and gives the +#' number of rows and cells affected (the condition carries `n` and +#' `columns`). [kriging_adequacy()], [resolution_profile()], +#' [estimate_sac_range()] and [prep_model_data()] leave such rows out too, so +#' the steps of one pipeline agree on a cell's mean. A function in `agg_funs` +#' therefore never sees an infinite value: `max` returns the largest finite +#' value, and infinities cannot be counted through `agg_funs`. +#' +#' # Spatial autocorrelation and standard-error bias +#' #' By default (`deff = 1`), the `..se_*` columns are computed as #' `sd / sqrt(n)`, which treats the observations within each cell as #' independent. When data are spatially autocorrelated (the common case for the @@ -859,13 +1176,13 @@ assign_features_to_polygons <- function( #' wide; see "What the standard error estimates" before setting `deff`. #' #' Setting `deff = "kish"` applies an approximate correction using Kish's -#' design effect. Separate intra-class correlations (ICCs) are estimated for -#' response and predictor variables via a one-way random-effects decomposition -#' across all cells. Each variable type's ICC is used for its own SE -#' adjustment, and each cell's effective sample size is reduced to -#' `n_i / (1 + (n_i - 1) * rho)`. This is a first-order correction that -#' does not require a full spatial covariance model but does require enough -#' cells and observations for a stable ICC estimate. +#' design effect. An intra-class correlation (ICC) is estimated for every +#' summarised column on its own, the response and each predictor, via a +#' one-way random-effects decomposition across all cells. Each column's ICC +#' is used for that column's SE adjustment, and each cell's effective sample +#' size is reduced to `n_i / (1 + (n_i - 1) * rho)`. This is a first-order +#' correction that does not require a full spatial covariance model but does +#' require enough cells and observations for a stable ICC estimate. #' #' A design effect estimated from the data (`"kish"` or `"variogram"`) comes #' with a second, small-sample correction. The within-cell correlation that @@ -894,19 +1211,26 @@ assign_features_to_polygons <- function( #' For rigorous inference under spatial dependence, consider fitting an #' explicit spatial covariance model (e.g. via \code{\link{fit_bayesian_spatial_model}}). #' -#' @section What the standard error estimates: -#' The `..se_*` columns are the standard error of the cell mean **as an -#' estimate of the population (grand) mean**: the unconditional quantity, in -#' which the cell's own realised deviation is part of the error. That is the -#' right quantity when cells are treated as samples from a common population, -#' and the design-effect correction is calibrated for it: measured 95% interval -#' coverage of the grand mean is 0.95 with `deff = "kish"` (and 0.29 with the -#' naive SE) on exchangeable within-cell correlation, and 0.93 with -#' `deff = "variogram"` on a simulated Gaussian field. -#' -#' It is **not** the standard error of the cell's own mean (the block average -#' over that cell), which is what a cell-level map or a regression on cell -#' values usually wants. For that quantity the naive `sd / sqrt(n)` is the +#' # What the standard error estimates +#' +#' What the `..se_*` columns estimate follows `deff`. At the default, +#' `deff = 1`, `sd / sqrt(n)` is the standard error of **the cell's own +#' mean**, the mean of the units the cell holds, and it is the right one when +#' the cell's observations are spread through the cell. Under +#' `deff = "kish"`, `"variogram"` or a number other than 1 the columns are the +#' standard error of the cell mean **as an estimate of the population (grand) +#' mean**: the unconditional quantity, in which the cell's own realised +#' deviation is part of the error, widened for the correlation inside the +#' cell. That is the right quantity when cells are treated as samples from a +#' common population: measured 95% interval coverage of the grand mean is +#' 0.95 with `deff = "kish"` (and 0.29 with the naive SE) on exchangeable +#' within-cell correlation, and 0.93 with `deff = "variogram"` on a simulated +#' Gaussian field. +#' +#' The corrected standard error is **not** that of the cell's own mean (the +#' block average over that cell), which is what a cell-level map or a +#' regression on cell values usually wants. For that quantity the naive +#' `sd / sqrt(n)` is the #' better of the two on offer: measured coverage 0.95 under exchangeable #' within-cell correlation, against very nearly 1.00 for the #' design-effect-corrected SE, which is too wide by the factor @@ -920,9 +1244,15 @@ assign_features_to_polygons <- function( #' they are measurements of the cells themselves and the sampling within cells #' is reasonably uniform. #' -#' @section Design effects and variable types: -#' `deff = "kish"` estimates a separate ICC for response and predictor -#' variables and applies each to its own columns. `deff = "variogram"` fits or +#' # Design effects and variable types +#' +#' `deff = "kish"` estimates a separate ICC for each summarised column, the +#' response and every predictor, and applies each to that column alone: +#' listing or removing a predictor leaves every other column's standard error, +#' effective n and interval as they were. (One ICC used to be pooled over all +#' the predictors, which was right for a column only when they all shared it: +#' beside a predictor with an ICC of 0.87, one with an ICC of 0 had its +#' standard error multiplied by 3.1.) `deff = "variogram"` fits or #' accepts **one** correlation function and applies it to every numeric column, #' because a variogram is a property of the field being modelled rather than of #' a variable type; a predictor whose spatial structure differs markedly from @@ -939,15 +1269,19 @@ assign_features_to_polygons <- function( #' corrects response columns a warning says that their standard errors are #' understated, as [kriging_adequacy()] warns about the same mismatch. #' -#' @section Confidence intervals: +#' # Confidence intervals +#' #' With `conf_level` set, every numeric response and predictor column gains #' four more columns: `..neff_*`, that column's effective sample size in the #' cell (its non-missing count over its design effect, the per-column version #' of `cell_weight`); `..df_*`, the degrees of freedom the interval uses; and -#' `..ci_lo_*` / `..ci_hi_*`, a t interval for the **cell mean as an estimate -#' of the grand mean**. The estimand is the same as `..se_*`'s, so everything -#' in "What the standard error estimates" applies to it, including that it is -#' not an interval for the cell's own block average. The interval is +#' `..ci_lo_*` / `..ci_hi_*`, a t interval for a mean. Which mean follows +#' `deff`, as for `..se_*`: at the default, `deff = 1`, **the cell's own +#' mean**, when its observations are spread through the cell; under +#' `deff = "kish"`, `"variogram"` or a number other than 1, the **cell mean as +#' an estimate of the population (grand) mean**. Everything in "What the +#' standard error estimates" applies to it, including that the corrected +#' interval is not one for the cell's own block average. The interval is #' `mean +/- qt((1 + conf_level) / 2, df) * se`, centred on the plain mean of #' the column's non-missing values whatever `agg_funs` computes, and is `NA` #' wherever the standard error is (a single observation; complete redundancy @@ -956,6 +1290,17 @@ assign_features_to_polygons <- function( #' counts such a cell (1, or `1 / deff` for a numeric `deff`), so the two #' differ there. #' +#' At no setting is `..ci_*` a range for one observation: it is an interval +#' for a mean, and it narrows as a cell's count grows where the spread of +#' single observations does not. The interval for one further observation in +#' a cell has its own argument and columns, `obs_level` with +#' `estimate = "pooled"` and `..obs_lo_*` / `..obs_hi_*` (see "Intervals: +#' which one answers which question"). In the simulation described there, +#' `..ci_*` at `conf_level = 0.90` held 58.9 percent of the observations held +#' out among the others, and the interval for one observation at +#' `obs_level = 0.90` held 89.6 percent. Away from the observations no +#' interval here is calibrated. +#' #' The degrees of freedom are **not** `neff - 1`. The interval's spread comes #' from the within-cell sample variance, and under exchangeable correlation #' (`deff = "kish"`) that variance keeps its `n - 1` degrees of freedom @@ -981,6 +1326,276 @@ assign_features_to_polygons <- function( #' under it: a mis-specified variogram, or an ICC estimated from too few #' cells, moves the coverage with it. #' +#' # Pooled values +#' +#' With `estimate = "pooled"` every numeric column also gets a pooled value. +#' That is the default; `estimate = "mean"` leaves the pooled columns out +#' and returns the frame of earlier versions. +#' A cell's value, plain or pooled, estimates the cell's *level*: the +#' expected value of one further observation located in the cell the way its +#' observations were. It is not the average of a surface over the cell's +#' area, which would give weight to ground that holds no observation. +#' +#' For one column, write `n`, `S` and `m = S / n` for the count, the sum and +#' the mean of a cell's rows, `N` for the rows in all and `K` for the cells +#' that hold one. Then +#' +#' * `sigma2 = sum((y - m)^2) / (N - K)` is the spread of the observed values +#' about their cell's mean; +#' * the target `t` of a cell is the mean of the rows of its neighbours, +#' `sum(S) / sum(n)` over them. The neighbours are the 8 cells whose +#' centroids are nearest, the centroid of a cell being the mean of the +#' coordinates of its rows. The polygons are not read, so two cells are +#' neighbours whether or not they touch, and a cell is never its own +#' neighbour; +#' * `tau2 = max(0, (sum(n * (m - t)^2) - K * sigma2) / N)` is the mean +#' squared distance between a cell's level and its target, the target's own +#' error included; +#' * the own weight is `w = tau2 / (tau2 + sigma2 / n)`; +#' * the pooled value is `w * m + (1 - w) * t`. +#' +#' The own weight is the share of the pooled value that is the cell's own +#' mean. It grows with the cell's count and with `tau2`. At 1 the pooled +#' value is the plain mean; at 0 it is the target and holds none of the +#' cell's own values. Pooled values are for maps and for predicting +#' observations. `..pooled_w_*` is not a regression weight. The plain +#' columns are the same under either `estimate`, and they are the ones to +#' use, with `cell_weight`, in a regression on cell values: each column is +#' pulled toward its neighbours by its own amount, so a regression of pooled +#' responses on pooled predictors is not a regression of the levels. +#' +#' The cells can be any polygons the rows were assigned to, the package's +#' own or ones the caller brings, with IDs of any type: only each row's cell +#' and location are read. Each column is pooled on its own rows, those with +#' a value, a cell and a location, with its own centroids, neighbours, +#' `sigma2` and `tau2`; a +#' missing value in one column changes nothing in another. A cell with one +#' such row gets a value. A cell with none gets `NA`, never a value made from +#' its neighbours. The pooled columns do not read `agg_funs` or `deff`: the +#' mean that is pooled is the arithmetic mean whatever `agg_funs` computes, +#' and no design effect enters `sigma2`, `tau2`, the weights or the interval +#' of `obs_level`. +#' +#' Three cases change what the numbers rest on, and each is a warning (see +#' "Conditions"). With 2 to 9 cells the neighbours of a cell are all the +#' others, so its target is the mean of every row outside it, and the overall +#' mean lies between that target and the cell's own mean. A cell whose own +#' weight is below its share of the rows, `n / N`, then gets a pooled value +#' on the far side of the overall mean from its plain mean, and two cells can +#' change order. When few cells hold two rows, `sigma2` is estimated from few +#' values and every weight rests on it: `df` in `attr(, "pooled")` is the +#' number of values beyond one per cell. And when `tau2` comes out at 0, +#' every own weight is 0 and each pooled value is its target; with two +#' cells that is the other cell's mean, so the two values change places. +#' +#' A tie between two candidate neighbours goes to the centroid with the +#' lower x, then the lower y, and the centroids are summed with the rows in +#' coordinate order, so a cell's neighbours do not depend on the order of the +#' rows. The values then agree to rounding: a cell's sums are taken in the +#' order of its rows. +#' The tie is between distances computed from the coordinates in the CRS the +#' distances are measured in (see `estimate`), so on gridded locations the +#' same layer in another CRS or unit can give a cell another neighbour. +#' +#' The figures on this page that describe pooled values and the two +#' intervals come from one simulation, `dev/sim-pooled-values.R` in the +#' package's repository, whose header holds its settings and seeds. It draws 200 +#' layers on a square of side 1,000. Each has 2,100 clustered locations +#' (four fifths of them round 25 parent points with a standard deviation of +#' 40, the rest uniform) and a response that is a field with covariance +#' `exp(-d / 100)` plus noise of variance 0.3. The 300 locations nearest a +#' random centre are held out as a block, 300 of the others are held out at +#' random, and the 1,500 left are the layer: 333 cells at 4.5 observations a +#' cell from [resolution_profile()] with `partition = "density"`, +#' `select_resolution(criterion = "size")`, [get_voronoi_seeds()], +#' [build_tessellation()] and [assign_features_to_polygons()], summarised +#' with `estimate = "pooled"`. A held-out observation is given the value of +#' its cell by [cell_values_at()]. At the observations held out at random +#' the root mean squared error of the pooled value was 0.96 of the plain +#' mean's: 0.84 in cells that hold one of the layer's observations, 0.95 in +#' cells of 2 to 4, 0.98 in cells of 5 to 9 and 0.99 in cells of 10 or +#' more. In the held-out block it was 0.95. +#' +#' `structured` in `attr(, "pooled")` says whether these cells predict a +#' left-out observation better than one mean for all rows. It is `FALSE` +#' when the leave-one-out error of one mean (`loo_one_cell`) is within 2 +#' percent of that of the pooled values (`loo`) or below it, or when the F +#' test of the cell means against one mean has `p >= 0.05` +#' (`structure_p`). `FALSE` raises a warning of class +#' `"spatialkit_no_structure"`, and the values are returned. On a response +#' without spatial structure they still make a smooth map, because each is +#' mostly the mean of its neighbours. With white noise as the response on +#' the simulation's 200 layers the median own weight was 0.11, `tau2` was 0 +#' on 20 layers, the warning was raised on all 200, and a cell's pooled +#' value had a correlation of 0.79 with the mean of the pooled values of its +#' 8 nearest cells, where the plain means had one of -0.02. +#' +#' The pooling model implies an error variance for a pooled value as an +#' estimate of the cell's level, `(1 - w) * tau2`. It is not returned, and +#' neither is an interval for the level, because no check has confirmed an +#' interval built from it; `sigma2`, `tau2` and `..pooled_w_*` are in the +#' result for a reader who wants to form it. In the simulation, with a +#' cell's level taken as the mean of the noise-free field over further +#' locations drawn in it like the data's, the squared error of the pooled +#' value was 0.98 of `(1 - w) * tau2` among the observations and 6.9 times +#' it in the held-out block: away from the observations it is too small. +#' +#' Beside a sharp boundary the pooled value can be further from a cell's +#' level than the plain mean, because its target takes in cells across the +#' boundary. A second simulation measured this on fields whose level jumps +#' at county boundaries: one level for each county, alone and with a smooth +#' field added, on two layouts of real locations (892 and 2,634 points, each +#' in a county), with noise of 5, 20 or 50 percent of an observation's +#' variance, 200 layers of each, five random folds, and on each fold the +#' cells the package's defaults build from the training observations. A +#' held-out observation is a boundary row when every training observation +#' of its cell lies in its own county and more than half of those of the +#' cell's neighbours lie in other counties. Boundary rows were 21.75 to +#' 28.04 percent of the held-out observations. Over them the root mean +#' squared error of the pooled value against the noise-free field, as a +#' geometric mean over the layers of its ratio to the plain mean's, was +#' from 9.16 percent lower to 56.36 percent higher. On county levels alone +#' it was 43.21 and 56.36 percent higher with 5 percent noise, 11.23 and +#' 20.58 percent higher with 20 percent, and from 3.79 percent lower to 1.47 +#' percent higher with 50 percent; with the smooth field added it was from +#' 9.16 percent lower to 1.59 percent higher. Over all held-out observations +#' the pooled value's error was the lower of the two in every setting, by +#' 1.75 to 18.73 percent. +#' +#' # Intervals: which one answers which question +#' +#' Two families of interval columns can be in the frame. Each has its own +#' argument, and neither changes the other. +#' +#' | Family | Columns | Target | Centre | Asked for by | +#' |---|---|---|---|---| +#' | observation | `..obs_lo_*`, `..obs_hi_*` | one further observation in the cell | pooled value | `obs_level` | +#' | mean | `..ci_lo_*`, `..ci_hi_*` | a mean, never one observation | plain mean | `conf_level` | +#' +#' The observation of the first is one located in the cell the way the +#' data's were. `obs_level` needs `estimate = "pooled"`: without it the call +#' is an error, not an interval round the plain mean. The mean the second +#' covers follows `deff`: at `deff = 1` the cell's own mean, when its +#' observations are spread through the cell; under `deff = "kish"`, +#' `"variogram"` or a number other than 1 the cell mean as an estimate of +#' the population mean (see "Confidence intervals", which also describes +#' `..neff_*` and `..df_*`). No interval and no standard error is returned +#' for a cell's level as the pooled value estimates it. +#' `attr(, "intervals")` says the same of the frame in hand, one row per +#' family present. +#' +#' The interval for one observation is the pooled value plus two quantiles +#' of the leave-one-out residuals of the pooled values. The residual `e` of +#' a row is its value minus the pooled value of its cell computed without +#' it: the cell's mean and own weight are computed again without the row, +#' and `sigma2`, `tau2` and the targets are held. With +#' `p = (1 - obs_level) / 2`, +#' `..obs_lo = pooled + quantile(e, p)` and +#' `..obs_hi = pooled + quantile(e, 1 - p)`. +#' +#' * It is a statement about observations on average: of further +#' observations located like the data, about `obs_level` of them fall +#' inside the interval of their cell. It does not hold cell by cell (the +#' second simulation below gives the coverage in cells of one +#' observation). +#' * The two offsets are the same in every cell. The interval's centre +#' varies over the map and its width does not. It does not narrow where a +#' cell holds more rows: the offsets are quantiles of the errors of +#' predicting single observations, and the spread of observations inside a +#' cell is in every one of them. +#' * It is wide. One observation is uncertain. +#' * Only the level 0.90 has been checked. Another level is computed the +#' same way. +#' * Each residual is the error of predicting an observation from the other +#' rows of its cell and from the cells around it, so the interval +#' describes locations among the observations. A cell's value and interval +#' describe the part of the cell where its observations lie, and a Voronoi +#' cell can reach far past them toward the edge of the study area. The +#' interval is too narrow for a cell with no observation, a gap in the +#' layer or ground beyond the layer's edge. +#' +#' In the simulation described under "Pooled values", the interval at +#' `obs_level = 0.90` held 89.6 percent of the observations held out at +#' random among the others (83.7 to 94.0 percent in single layers) and 75.1 +#' percent of those in the held-out block. `..ci_*` at `conf_level = 0.90`, +#' read as a range for one observation, held 58.9 and 49.2 percent of them, +#' over the held-out observations whose cell has that interval. +#' [cell_values_at()] returns each location's distance from the nearest +#' observation, and its help gives the coverage by that distance. +#' +#' The second simulation described under "Pooled values" read the +#' interval at `obs_level = 0.90` on smooth fields of two ranges and on +#' county levels with a smooth field, with 20 or 50 percent noise, on both +#' layouts: twelve settings. Setting by setting it held 89.38 to 89.79 +#' percent of the held-out observations. Counted by the training +#' observations in an observation's cell (1, 2 to 4, 5 to 9, 10 or more), it +#' held at least 85.65 percent in every class but one: on county levels with +#' a smooth field, on the layout of 892 points with 20 percent noise, it +#' held 83.74 percent of the 4,878 observations whose cell held one training +#' observation. On fields of that kind it is not a 90 percent interval in +#' such cells: there it held 83.74 to 87.83 percent with 20 or 50 percent +#' noise, and 82.64 and 82.94 percent with 5 percent. +#' +#' Away from the observations no interval here is calibrated. +#' +#' # Conditions +#' +#' What the pooled columns and the count record have to say is raised as R +#' warnings with a class, so `tryCatch( = )` and +#' `withCallingHandlers()` catch each without matching its text. A warning +#' of the pooled columns is raised once per call and reason, for all the +#' columns it applies to: its text names them and the condition carries them +#' in `columns`, in the order of the pooled columns. A field said to be by +#' column is a vector named by those columns, and the numbers of each column +#' are in `attr(, "pooled")`. +#' +#' * `"spatialkit_pool_unavailable"`: the pooled columns of a column are +#' `NA`. The plain columns are returned, and this is never an error. +#' `reason` is `"no coordinates"` (a layer without geometry), +#' `"no located value"` (no row with a value, a cell and a location), +#' `"no cell holds two values"` (the condition also carries `n` and +#' `cells` by column) or `"work limit"`. The last is the case of many +#' cells without the 'FNN' package: the neighbour search then compares +#' every pair of cells and is not made above +#' `getOption("spatialkit.exact_pairs_max", 2e9)` pairs, which is about +#' 44,700 cells (the condition also carries `work`, `limit`, and `cells` +#' by column). With 'FNN' there is no such limit, and the result is the +#' same. +#' * `"spatialkit_pool_degenerate"`: the pooled values were computed and +#' carry no pooling. `reason` is `"one cell"` (the pooled value is the +#' plain mean; also `n` by column), `"no spread inside any cell"` (every +#' own weight is 1; also `constant` by column) or `"no signal between +#' cells"` (`tau2` is 0 and every own weight is 0; also `sigma2` by +#' column). +#' * `"spatialkit_pool_few_cells"`: 2 to 9 cells, so each target is the mean +#' of all the other cells (`cells`, and `own_weight`, the smallest, by +#' column). +#' * `"spatialkit_pool_few_df"`: `sigma2` rests on fewer than 30 values +#' beyond one per cell (`needed`, and `df`, `n` and `cells` by column). +#' * `"spatialkit_no_structure"`: `structured` is `FALSE` (see "Pooled +#' values"). The text says which of the two tests failed, and `beats` is +#' `TRUE` for a column whose pooled values beat one mean while the F test +#' does not tell the cell means from one mean (also `criterion = "loo"`, +#' `estimate = "pooled"`, and by column `n`, the cells, `one_cell`, `loo` +#' and `structure_p`). +#' * `"spatialkit_pool_rows_skipped"`: rows with a value and a cell have +#' empty or non-finite coordinates. They count in `n` and the plain +#' columns and take no part in the pooled ones (`n`, `cells`). +#' * `"spatialkit_repeated_locations"`, with `obs_level`: rows with a value +#' share a location. A residual leaves one row out and keeps the others at +#' its location, so the interval then describes a further observation at a +#' place already observed (`n` and `total` by column). +#' * `"spatialkit_few_residuals"`, with `obs_level`: fewer than five +#' residuals are expected beyond each end of the interval, which at 0.90 +#' is fewer than 100 residuals (`needed`, `level`, and `n` by column). +#' * `"spatialkit_estimate_mismatch"` and `"spatialkit_cells_differ"`: the +#' two checks of the count record, described under "Value". +#' +#' The two about few cells and few values are raised for columns whose +#' weights were estimated, and the two of `obs_level` for columns whose +#' interval is read from residuals, so a constant column raises +#' `"spatialkit_pool_degenerate"` and no other. +#' #' @param assigned_points_sf An sf object with a cell identifier column. #' @param response_var Optional response column name for per-cell #' aggregation: a single character string. A name that is not a column, or @@ -998,7 +1613,10 @@ assign_features_to_polygons <- function( #' \code{f} for a variable \code{f} holding a function), #' \code{stats::median} gives \code{median}, and any other expression gives #' \code{agg1}; pass a named list to choose the name. Anything else falls -#' back to the default mean with a warning. +#' back to the default mean with a warning. The functions receive each +#' column with its infinite values already set to \code{NA} (see +#' "Details"), so they need \code{na.rm = TRUE} as they do for missing +#' values. #' @param cells_sf Optional polygon sf layer to join cell geometries onto #' the output. When supplied, the return value is an sf object with #' the polygon geometry from cells_sf, with one row per cell in `cells_sf`. @@ -1030,40 +1648,46 @@ assign_features_to_polygons <- function( #' supported, with a nugget and with several structured components #' (each weighted by its partial sill) and with gstat's 2-D geometric #' anisotropy (`vgm(..., anis = c(angle, ratio))`), applied as gstat -#' applies it. A model of any other family falls back to `deff = 1` -#' with a warning naming it, and so does a request with no usable -#' model (none supplied and none could be estimated, or a rejected -#' fit that could not be replaced by an estimate); see "Value" for how -#' to detect a fallback. A model with no structured component (a pure +#' applies it. A request that cannot be met falls back to `"kish"`, +#' with a warning of class `"spatialkit_deff_fallback"` that gives the +#' reason and the ICCs: a model of any other family (named in the +#' warning), or no usable model (none supplied and none could be +#' estimated, or a rejected fit that could not be replaced by an +#' estimate). The standard errors, intervals and `cell_weight` are then +#' Kish's, and the uncorrected ones only where Kish's own ICC is 0; the +#' `deff_method` column says which on every row (see "Value"). The +#' variogram route needs an identified range, which a layer does not +#' always have, so read `deff_method` for the fallback. A model with +#' no structured component (a pure #' nugget) implies that distinct observations are uncorrelated, so it #' is applied as a design effect of 1 in every cell, not treated as a -#' fallback. Points with empty +#' fallback. That includes the model [estimate_sac_range()] returns +#' when it finds no spatial structure (an `NA` range whose +#' `rejected_reason` says so): the answer is then a design effect of +#' 1, `deff_method` reads `"variogram"`, and no fallback warning is +#' raised. Points with empty #' geometry count towards their cells' values but not towards the #' correlation, with a warning.} -#' \item{`"kish"`}{Estimate per-variable-type intra-class correlations -#' (ICCs) from the grouped data using a one-way random-effects ANOVA -#' decomposition (one ICC for the response variable and a separate -#' ICC for the predictor variables), then apply Kish's formula per +#' \item{`"kish"`}{Estimate an intra-class correlation (ICC) for each +#' summarised column from the grouped data using a one-way +#' random-effects ANOVA decomposition (one ICC for the response and one +#' for each predictor), then apply Kish's formula per #' cell: `deff_i = 1 + (n_i - 1) * rho`. The ICC is the ANOVA #' (method-of-moments) estimator with Donner's `n0` for unequal cell #' sizes, not the REML estimate a mixed model returns: on a single #' unbalanced draw the two can differ by 0.1--0.2 (one check with cell #' sizes 3 to 77 and a true ICC of 0.5 gave 0.33 against REML's 0.51), #' while balanced designs agree to about 0.01. Neither is wrong, so do -#' not read the difference as a defect. When multiple columns are -#' pooled for a single ICC estimate (e.g. several predictor variables), -#' each column is z-scored before pooling so that variables with -#' different scales contribute equally to the variance decomposition. -#' The response-specific ICC -#' is used for response SEs and the predictor-specific ICC for -#' predictor SEs. The response's ICC is never applied to predictor -#' columns or vice versa, and it is the response's ICC (not the -#' predictors') that sets `cell_weight` whenever a response was given. +#' not read the difference as a defect. Each column's ICC is used +#' for that column's SEs and for no other: the response's ICC is never +#' applied to a predictor, nor one predictor's to another. It is the +#' response's ICC that sets `cell_weight` whenever a response was +#' given, and the first predictor's own ICC otherwise. #' Requires at least 2 cells with 2+ observations and at least 2 residual #' degrees of freedom (`N - k >= 2`); the ICC is taken as 0 (no -#' correction for that variable type) otherwise, and likewise when the +#' correction for that column) otherwise, and likewise when the #' estimate itself comes out at or below 0. The `"deff_applied"` -#' attribute is attached when either ICC is positive, so when both are +#' attribute is attached when any ICC is positive, so when all are #' 0 there is none.} #' \item{A positive number}{Applied as a uniform design effect to every #' cell, as `sd * sqrt(deff / n)`, exactly `sqrt(deff)` times the @@ -1081,8 +1705,10 @@ assign_features_to_polygons <- function( #' it is set aside rather than correcting by a shape that was not trusted #' enough to report a range: the variogram is then estimated as if no `sac` #' had been given, with a plain warning saying so, or, where that is not -#' possible, `deff` falls back to 1 with the fallback warning, which names -#' the rejection. A `sac` with no `variogram_model` attribute -- a plain +#' possible, `deff` falls back to `"kish"` with the fallback warning, which +#' names the rejection. The exception is a `sac` refused because no spatial +#' structure was found, whose model is a pure nugget: it is used, and gives +#' a design effect of 1. A `sac` with no `variogram_model` attribute -- a plain #' number or a `units` object, say -- is a range without a correlation #' function, and is set aside the same way. A `sac` fitted to residuals #' (`attr(sac, "detrended")` `TRUE`) is used as given, with a warning when @@ -1118,37 +1744,86 @@ assign_features_to_polygons <- function( #' @param conf_level Optional confidence level in (0, 1), such as `0.95`. #' When given, every numeric response and predictor column also gets #' `..neff_*`, `..df_*`, `..ci_lo_*` and `..ci_hi_*` (see "Confidence -#' intervals"). Default `NULL`: no interval columns, and the frame is -#' exactly what it was before this argument existed. +#' intervals"). Default `NULL`: no such columns. +#' @param estimate Which value of a cell the frame reports: `"pooled"` +#' (default) or `"mean"`. With `"mean"` the frame is the one described +#' above, the frame of earlier versions, whose default this was. With +#' `"pooled"` every numeric response and predictor column also +#' gets a pooled value, `w * m + (1 - w) * t`: the cell's own mean `m` and a +#' target `t`, the mean of the rows of the 8 cells whose observations' +#' centroids are nearest (all the other cells when there are fewer than 10; +#' the polygons are not read). The own weight is +#' `w = tau2 / (tau2 + sigma2 / n)`, where `n` is the cell's count, +#' `sigma2` the spread of the observations about their cell's mean and +#' `tau2` the mean squared distance between a cell's level and its target. +#' Each column is pooled on its own rows: those with a value, a cell and a +#' location. `agg_funs`, `deff`, `sac` and `conf_level` do not enter the +#' pooled columns, and every other column is computed as with `"mean"`. +#' Lon/lat coordinates, and coordinates without a CRS that look like +#' degrees, are projected for the distances between centroids, as +#' [resolution_profile()] projects them. The projection is chosen from +#' every row of the layer, those without a value or a cell included, so on +#' such input the rows a column does not use can still decide the CRS its +#' distances are measured in; a layer projected beforehand is used in its +#' own CRS. When the input carries the record of its cells' count (see +#' "Value") and that record names a projected CRS, the one the profile +#' worked in, the distances are measured in it, whatever CRS the layer is +#' in. The value is matched as [match.arg()] matches a choice, so an +#' abbreviation (`"m"`) is accepted and `NULL` is the default. See "Pooled +#' values" for what the pooled value estimates and what its numbers rest +#' on, "Value" for the columns and the attributes, and "Conditions" for +#' the warnings. +#' @param obs_level Optional level in (0, 1), such as `0.90`, of an interval +#' for one further observation in a cell, located like the data. It needs +#' `estimate = "pooled"`: the interval is the pooled value plus the +#' `(1 - obs_level) / 2` and `(1 + obs_level) / 2` quantiles of the +#' leave-one-out residuals of the pooled values, so its two offsets are the +#' same in every cell. It is a statement about observations on average, +#' not about each cell. It is a separate argument from `conf_level`, whose +#' interval is for a mean and is not a range for an observation. Any level +#' strictly between 0 and 1 is computed the same way; only 0.90 has been +#' checked (see "Intervals: which one answers which question"). Default +#' `NULL`: no such interval. #' @return A tibble/data.frame (or sf if cells_sf given) with per-cell #' summaries: the ID column, `n` (rows in the cell), one column per #' `agg_funs` entry per variable, `..sd_*` / `..se_*` for every numeric #' response and predictor, `..neff_*` / `..df_*` / `..ci_lo_*` / #' `..ci_hi_*` for the same columns when `conf_level` is given, -#' `cell_weight`, `deff_applied` when a design effect was requested (any -#' `deff` other than 1), and `cell_area` / `n_per_area` when -#' `area = TRUE`. An input column also called `n` is not allowed to shadow -#' the count. -#' -#' `deff_applied` is `TRUE` on every row when the requested correction was -#' applied (exactly when the `"deff_applied"` attribute below is attached; -#' under `"kish"`, when any standard-error column was corrected) -#' and `FALSE` when it fell back to the uncorrected standard errors: a -#' refused `deff`, a `"variogram"` request with no usable model, or -#' `"kish"` ICCs of 0 for every variable type (and `NA` on a `cells_sf` -#' row no point fell in). -#' Unlike the attribute it survives `rbind()` and +#' `cell_weight`, `deff_applied` and `deff_method` when a design effect +#' was requested (any `deff` other than 1), and `cell_area` / `n_per_area` +#' when `area = TRUE`. An input column also called `n` is not allowed to +#' shadow the count. +#' +#' `deff_applied` is `TRUE` on every row when a design-effect correction +#' was applied (exactly when the `"deff_applied"` attribute below is +#' attached; under `"kish"`, when any standard-error column was corrected) +#' and `FALSE` when the standard errors are the uncorrected ones: a +#' refused `deff`, or `"kish"` ICCs of 0 for every column (and `NA` on a +#' `cells_sf` row no point fell in). `deff_method` names the correction +#' the standard errors carry, since their column names do not change with +#' it: `"variogram"`, `"kish"` or `"fixed"` when the one requested was +#' applied, `"none"` when none was, and `"kish (variogram fallback)"` or +#' `"none (variogram fallback)"` when a `"variogram"` request could not be +#' met and Kish stood in for it (the second when Kish's ICCs were 0 too). +#' So `deff_applied` is `TRUE` on a Kish fallback row: test +#' `deff_method == "variogram"` to keep only rows the variogram corrected. +#' Unlike the attribute, both columns survive `rbind()` and #' `dplyr::bind_rows()` of many results. A fallback is also signalled by a -#' warning of class `"spatialkit_deff_fallback"` (a Kish ICC of 0 is -#' reported on `attr(, "icc")` instead), which +#' warning of class `"spatialkit_deff_fallback"` (a Kish ICC of 0 under a +#' `"kish"` request is reported on `attr(, "icc")` instead), which #' `tryCatch(spatialkit_deff_fallback = )` catches without matching the -#' message; it is raised only when the standard errors really are the -#' uncorrected ones. +#' message. It is raised when the correction requested was not the one +#' applied: a refused number (the standard errors are then the uncorrected +#' ones) or a `"variogram"` request that fell back to Kish; the condition +#' of the second carries `requested` and `used`. #' #' When a correction was actually applied, an attribute `"deff_applied"` is #' attached recording it: `method` plus `icc_resp`/`icc_pred` and `deff` -#' for `"kish"` (`deff` is the primary variable's per-cell design effect, -#' all 1 when only the predictor ICC was positive), +#' for `"kish"` (`icc_pred` is a vector named by predictor column, one ICC +#' each; `deff` is the primary variable's per-cell design effect, +#' all 1 when only a predictor's ICC was positive; `requested` and +#' `fallback_reason` are added when a `"variogram"` request fell back to +#' it), #' `deff`/`deff_rows`/`rbar`/`crs`/`max_n` for `"variogram"` (`deff` is #' the design effect at the primary variable's non-missing count per cell, #' `deff_rows` at the cell's row count, which is the vector the log line @@ -1157,12 +1832,14 @@ assign_features_to_polygons <- function( #' (`deff`, `deff_rows` and `rbar` alike) is realigned to the joined row #' order, so `deff[i]` and `rbar[i]` still describe row `i`; cells with no #' observations carry `NA`. No attribute is attached when no correction was -#' applied: `deff = 1`, a `deff = "kish"` request whose ICCs are all 0, or -#' a `"variogram"` request that could not be fitted. A `deff = "kish"` request always -#' records the ICCs it estimated on an attribute `"icc"` (`resp` and -#' `pred`, `NA` for a variable type with no numeric column), whether or not +#' applied: `deff = 1`, or a `deff = "kish"` request (or Kish fallback) +#' whose ICCs are all 0. A `deff = "kish"` request, and a `"variogram"` +#' request that fell back to it, always +#' records the ICCs it estimated on an attribute `"icc"` (`resp`, and +#' `pred`, a vector named by predictor column; `NA` for a variable type +#' with no numeric column), whether or not #' they were positive enough to apply, so a result with no `"deff_applied"` -#' still says what the ICC came out as. +#' still says what the ICCs came out as. #' #' The ID column keeps its input type when `cells_sf`'s ID column and the #' summarised IDs already have the same class. When the classes differ, both @@ -1170,6 +1847,108 @@ assign_features_to_polygons <- function( #' returned ID column is therefore character. Whole numbers are written out #' in full for that (`"100000"`, never `"1e+05"`), so an integer and a #' double ID of the same cell still match. +#' +#' With `estimate = "pooled"`, each numeric column `v` with its prefix +#' (`resp_` or `pred_`) gains `..pooled_` (the pooled value), +#' `..pooled_w_` (the own weight, 0 to 1; it is not a regression +#' weight) and `..pooled_target_` (the target), and with +#' `obs_level` also `..obs_lo_` and `..obs_hi_`. +#' They follow every column listed above and precede `cell_area` and +#' `n_per_area`, the response's first, then each predictor's. A cell with +#' no row that has a value, a cell and a location gets `NA`, never a value +#' made from its neighbours. Two attributes are attached. +#' `attr(, "pooled")`, of class `"spatialkit_pooled"`, records what was +#' fitted: `toward`, `neighbours`, `crs` (the CRS the centroid distances +#' were measured in), `obs_level`, `conf_level`, `intervals` and `columns`, +#' a list with one entry per pooled column holding `column`, `role` +#' (`"response"` or `"predictor"`), `n` (rows used), `cells`, `df` (values +#' beyond one per cell, which `sigma2` rests on), `neighbours` (the cells +#' in each target), `sigma2`, `tau2`, `own_weight` (the median weight), +#' `share_alone` (the share of rows that are the only one in their cell), +#' `loo` and `loo_se` (the leave-one-out mean squared error of the pooled +#' value, and its standard error over rows), `loo_one_cell` (the same error +#' with one mean for all rows), `structured` and `structure_p` (whether the +#' cells predict a left-out observation better than one mean, and the +#' p-value of the F test of the cell means against one mean, which has to +#' be below 0.05 as well), `offsets` (the two offsets of the interval), +#' `repeated`, `skipped`, `constant` and `status`. `attr(, "intervals")` is +#' the same data frame as `attr(, "pooled")$intervals`: one row per family +#' of interval columns in the frame, saying what it covers, what it is +#' centred on, its level and its method. Away from the observations no +#' interval here is calibrated. +#' +#' Where the pooled columns of a column cannot be computed they are `NA`, +#' with a warning of class `"spatialkit_pool_unavailable"` and not an +#' error, and the plain columns are returned. "Conditions" lists that +#' class and the other warnings of the pooled columns, with what each +#' condition carries. +#' +#' When `assigned_points_sf` carries `attr(, "count_rule")`, or `cells_sf` +#' does (the assigned layer's is read first), the result carries that +#' record with one more element, `check`, whatever `estimate` is. The +#' record is the one [select_resolution()] wrote: `rule`, `estimate` (the +#' cell value the count was chosen for), `cells`, `obs_per_cell`, +#' `response`, `scored` (what the profile scored at the count: the rows, +#' the cells that hold one, the leave-one-out error among them, and the +#' centres the rows were given to), +#' `partition`, `crs` and `scored_cells`. It has class +#' `"spatialkit_count_rule"` and a print method. `check$estimate` is +#' `"match"` or `"mismatch"`: whether the summary reports the estimate the +#' count was chosen for (`NA` for a count chosen for neither). A mismatch +#' is a warning of class `"spatialkit_estimate_mismatch"` (fields +#' `chosen_for`, `reported`, `rule`, `cells`), and the summary is returned +#' as asked. `check$cells` is `"match"`, `"differ"` or `"not checked: +#' "`: the response is fitted again on the rows and cells given, +#' with the estimate the profile scored, and its scored rows, its occupied +#' cells and its leave-one-out error are compared with the record's, the +#' error to a relative tolerance of 1e-8. The first that differs is a +#' warning of class `"spatialkit_cells_differ"` (fields `what`: `"n"`, +#' `"cells"` or `"loo"`; `scored`; `found`): rows were dropped or moved +#' between cells, or the layer is another one. The same class with `what = +#' "record"` (fields `field`, `scored`, `found`) is raised when the +#' assigned layer and `cells_sf` carry different records, so the rows were +#' assigned to other cells than the `cells_sf` given: the cells of another +#' selection, or the scored cells of a selection beside other cells built +#' from its count, such as a lattice sized by it. `check$cells` is then +#' `"differ"`, whatever the comparison of the rows finds. The comparison +#' is not made, and `check$cells` says why, when the response is another +#' column or was not summarised, the profile read the selection half +#' (`select_on = "split"`), the cells are not the ones the profile scored +#' (`scored_cells` is `FALSE` or `NA`), the profile scored no estimate, the +#' input has no coordinates, the features are not points (see +#' [assign_features_to_polygons()]), or the fit was stopped by the limit on +#' an exact search without the 'FNN' package. Cells and rows without a +#' record, such as polygons the caller brings, are not checked and raise +#' neither warning. +#' +#' A row that is the same distance from two centres lies on the boundary +#' between their cells, which happens on gridded locations. +#' [resolution_profile()] scores such a row in the cell of the +#' lower-numbered centre, and [assign_features_to_polygons()], on cells +#' built from the centres the profile scored, gives a point on that +#' boundary the same cell, measured in the CRS the record names, so the +#' comparison reads `"match"` on gridded locations too. +#' [build_tessellation()] draws those cells in the CRS the record names, +#' whatever CRS the seeds arrive in, unless its `crs` names another +#' projected CRS. Cells built in another projected CRS are the +#' nearest-centre cells of that CRS, so a row near a boundary, on it or +#' not, can sit in another cell than the profile put it in. So can a row +#' joined in longitude and latitude (rows and cells both in degrees), and +#' a row that reached the record's CRS by another transformation than the +#' profile's, which can settle a tie the other way. The comparison then +#' reports `"differ"`, with `what = "loo"` when it finds the same rows in +#' the same number of cells with another leave-one-out error. The +#' summary's own numbers describe the cells as assigned. +#' +#' The comparison uses the fit of the pooled columns when that is a fit of +#' the estimate the profile scored, and fits the response once more +#' otherwise. Without the 'FNN' package that fit compares every pair of +#' cell centroids (pooled values) or, for each row alone in its cell, +#' every other location (plain means), and above +#' `options(spatialkit.exact_pairs_max = )` pairs it is not made +#' (`"not checked: work limit"`). A summary is not compared when neither +#' layer carries the record: `attr(x, "count_rule") <- NULL` on the +#' assigned layer and on `cells_sf` removes it. #' @examples #' library(sf) #' set.seed(1) @@ -1189,12 +1968,16 @@ assign_features_to_polygons <- function( #' grid <- create_grid_polygons(bnd, target_cells = 9, type = "square") #' assigned <- assign_features_to_polygons(pts, grid) #' +#' # Nine cells are too few for pooled values (each would be pulled toward +#' # all the other cells), so these summaries report plain means alone: +#' # estimate = "mean". #' # IID standard errors (default) vs Kish design-effect adjustment. The #' # correction is large here, and meant to be: about 22 points per cell that #' # all share the cell's part of the trend carry far fewer than 22 #' # independent pieces of information about the cell mean. -#' naive <- summarize_by_cell(assigned, response_var = "val") -#' kish <- summarize_by_cell(assigned, response_var = "val", deff = "kish") +#' naive <- summarize_by_cell(assigned, response_var = "val", estimate = "mean") +#' kish <- summarize_by_cell(assigned, response_var = "val", deff = "kish", +#' estimate = "mean") #' data.frame(n = naive$n, #' se_naive = naive$..se_resp_val, #' se_kish = kish$..se_resp_val) @@ -1203,9 +1986,35 @@ assign_features_to_polygons <- function( #' # A 95% interval for each cell mean as an estimate of the grand mean, on #' # the Kish-corrected standard error and n - 1 degrees of freedom. #' ci <- summarize_by_cell(assigned, response_var = "val", deff = "kish", -#' conf_level = 0.95) +#' conf_level = 0.95, estimate = "mean") #' ci[, c("poly_id", "n", "resp_mean_val", "..neff_resp_val", "..df_resp_val", #' "..ci_lo_resp_val", "..ci_hi_resp_val")] +#' +#' # Pooled values, and a range for one observation: a smooth field plus +#' # noise at 400 points, on an 8 x 8 grid, so that a cell holds about six. +#' set.seed(2) +#' east <- runif(400, 0, 8000) +#' north <- runif(400, 0, 8000) +#' pts2 <- st_as_sf( +#' data.frame(x = 5e5 + east, y = 5e6 + north, +#' val = 10 + 3 * sin(east / 1500) + 3 * cos(north / 1200) + +#' rnorm(400)), +#' coords = c("x", "y"), crs = 32632 +#' ) +#' bnd2 <- st_sf(geometry = st_sfc(st_polygon(list(rbind( +#' c(5e5, 5e6), c(5e5 + 8000, 5e6), c(5e5 + 8000, 5e6 + 8000), +#' c(5e5, 5e6 + 8000), c(5e5, 5e6) +#' ))), crs = 32632)) +#' grid2 <- create_grid_polygons(bnd2, target_cells = 64, type = "square") +#' assigned2 <- assign_features_to_polygons(pts2, grid2) +#' # estimate = "pooled" is the default. +#' pooled <- summarize_by_cell(assigned2, response_var = "val", obs_level = 0.90) +#' # The plain mean, the pooled value and the weight on the cell's own mean. +#' head(pooled[, c("poly_id", "n", "resp_mean_val", "..pooled_resp_val", +#' "..pooled_w_resp_val")]) +#' # The range for one further observation in a cell. +#' head(pooled[, c("poly_id", "..obs_lo_resp_val", "..obs_hi_resp_val")]) +#' attr(pooled, "pooled") # what was fitted, and what the interval covers #' @references #' Faes, C., Molenberghs, G., Aerts, M., Verbeke, G. and Kenward, M. G. (2009). #' The effective sample size and an alternative small-sample @@ -1230,14 +2039,35 @@ summarize_by_cell <- function(assigned_points_sf, deff_max_n = 500L, quiet = TRUE, conf_level = NULL, - area = FALSE) { + area = FALSE, + estimate = c("pooled", "mean"), + obs_level = NULL) { .msg <- function(...) if (!quiet) message(...) + estimate <- match.arg(estimate) if (!is.null(conf_level) && (!is.numeric(conf_level) || length(conf_level) != 1L || !is.finite(conf_level) || conf_level <= 0 || conf_level >= 1)) stop("summarize_by_cell(): `conf_level` must be a single number strictly ", "between 0 and 1 (0.95 for a 95% interval), or NULL for no intervals.", call. = FALSE) + # Strictly between 0 and 1 as the interval reads the level: through its tail + # probability rounded to 12 decimals (.obs_offsets()). That is 0.5 for a + # level of 0 and anything below, 0 for a level of 1 and anything above, and + # also for a level within 1e-12 of either, which would give the median + # twice or the range of the residuals. + if (!is.null(obs_level) && + (!is.numeric(obs_level) || length(obs_level) != 1L || !is.finite(obs_level) || + round((1 - obs_level) / 2, 12) <= 0 || round((1 - obs_level) / 2, 12) >= 0.5)) + stop("summarize_by_cell(): `obs_level` must be a single number strictly ", + "between 0 and 1 (0.90 for a 90% interval), or NULL for no interval.", + call. = FALSE) + # The interval for one observation has one centre, the pooled value. With + # plain means it is refused, not centred on the plain mean without a word. + if (!is.null(obs_level) && identical(estimate, "mean")) + stop("summarize_by_cell(): `obs_level` needs estimate = \"pooled\": the interval ", + "for an observation is built from the leave-one-out residuals of the pooled ", + "value and is centred on it. `conf_level` gives the plain mean's t interval, ", + "which is not a range for an observation.", call. = FALSE) if (!is.logical(area) || length(area) != 1L || is.na(area)) stop("summarize_by_cell(): `area` must be TRUE or FALSE.", call. = FALSE) # c("val", "flag") used to stop with "the condition has length > 1", and a @@ -1252,8 +2082,8 @@ summarize_by_cell <- function(assigned_points_sf, stop("summarize_by_cell(): `predictor_vars` must be a character vector of ", "column names, or NULL.", call. = FALSE) # Whether the caller asked for a design effect at all. Only then does the - # result carry the per-row `deff_applied` column, so a default call returns - # exactly the frame it always has. + # result carry the per-row `deff_applied` column, so a call at the default + # deff = 1 gains no column for it. deff_requested <- !(is.numeric(deff) && length(deff) == 1L && isTRUE(deff == 1)) # A density needs the cells, and it needs them in a CRS whose areas are @@ -1283,6 +2113,17 @@ summarize_by_cell <- function(assigned_points_sf, "lon/lat input -- and pass those."), .fold_crs_label(cells_sf), 100 * area_err), call. = FALSE) } + # The record of how the cells' count was set, when the input carries one: + # on the assigned rows first, on the cells second. It is read from the + # cells here, before that layer is cut down to its ID column. + rule_rows <- .count_rule_get(assigned_points_sf) + rule_cells <- if (is.null(cells_sf)) NULL else .count_rule_get(cells_sf) + count_rule <- if (!is.null(rule_rows)) rule_rows else rule_cells + # The CRS the profile worked in, in which the pooled values' distances are + # then measured too. + count_crs <- if (!is.null(count_rule) && inherits(count_rule$crs, "crs") && + !is.na(count_rule$crs) && !isTRUE(sf::st_is_longlat(count_rule$crs))) + count_rule$crs else NULL df <- sf::st_drop_geometry(assigned_points_sf) # --- locate ID column --- @@ -1361,8 +2202,15 @@ summarize_by_cell <- function(assigned_points_sf, # Helper: estimate intra-class correlation via one-way random-effects ANOVA. # Returns a single rho in [0, 1] or 0 if estimation fails. + # + # Called with ONE column at a time (see .kish_iccs() below): an ICC is a + # property of a variable, and one pooled value for several predictors was + # right for none of them unless they all shared it. With an ICC-0 and an + # ICC-0.87 predictor on 60 cells of 12, the pooled 0.42 multiplied both + # standard errors by 3.13 where their own ICCs give 1.00 and 8.96, so the + # grand-mean interval covered 1.000 and 0.492 against 0.958 and 0.950. + # The body still accepts several columns, and what follows describes that. .estimate_icc <- function(df, id_col, var_cols) { - # Pool across all supplied numeric columns for a single global ICC estimate. # Each variable is z-scored before pooling so that variables with larger # scales do not dominate the between/within variance decomposition. # @@ -1463,39 +2311,92 @@ summarize_by_cell <- function(assigned_points_sf, if (length(present)) pred_num <- .resolve_numeric(df, present, "predictor") } + # --- infinite values are missing values --- + # One rule, applied once, before anything reads the columns: an infinite + # value in a summarised column is treated as NA is. Left in, one Inf made + # its cell's mean Inf and its SE NA while ..neff_ and cell_weight still + # counted the row, and under deff = "kish" it set the ICC to 0 (sd() of the + # column is NaN), so EVERY cell's standard error came back uncorrected (0.169 + # against 1.365 on the clean cells) with no condition raised. + # kriging_adequacy(), resolution_profile(), estimate_sac_range() and + # prep_model_data() already drop such rows, so one pipeline reported two + # means for the same cell. Masking `df` here, and not at each site that + # counts or averages, is what keeps the mean, sd, se, interval, effective n, + # cell_weight, the Kish ICC and the variogram's row selection on the same + # rows. NaN is missing already (is.na(NaN) is TRUE), so it is not counted. + inf_cols <- character(0) + inf_note <- character(0) + inf_rows <- 0L + for (v in unique(c(resp_num, pred_num))) { + is_inf <- is.infinite(df[[v]]) + if (!any(is_inf)) next + inf_cols <- c(inf_cols, v) + inf_rows <- inf_rows + sum(is_inf) + inf_note <- c(inf_note, sprintf( + "%s '%s' %d row(s) in %d cell(s)", + if (v %in% resp_num) "response" else "predictor", v, sum(is_inf), + length(unique(df[[id_col]][is_inf])))) + df[[v]][is_inf] <- NA + } + if (length(inf_cols)) + .warn_classed("spatialkit_nonfinite", paste0( + "summarize_by_cell(): %d infinite value(s) are treated as missing: %s. ", + "Every statistic of %s (`agg_funs`, sd, se, the interval, the effective ", + "n, cell_weight and the design effect) leaves them out, as it leaves out ", + "NA; `n` still counts the rows. Recode or remove them to silence this."), + inf_rows, paste(inf_note, collapse = "; "), + if (length(inf_cols) > 1L) "those columns" else "that column", + data = list(n = inf_rows, columns = inf_cols)) + # --- estimate ICC for Kish correction if requested --- + # One ICC per summarised column, the response's and each predictor's own. + # Called here for deff = "kish", and from the variogram block below when a + # "variogram" request cannot be met and falls back to Kish. resp_rho <- NULL pred_rho <- NULL - if (use_kish) { + .kish_iccs <- function() { + resp <- NULL + pred <- NULL if (length(resp_num) > 0L) { - resp_rho <- .estimate_icc(df, id_col, resp_num) - if (resp_rho > 0) { + resp <- .estimate_icc(df, id_col, resp_num) + if (resp > 0) { .msg(sprintf( - "summarize_by_cell(): Kish deff using response ICC = %.4f", resp_rho + "summarize_by_cell(): Kish deff using response ICC = %.4f", resp )) } else { .msg("summarize_by_cell(): response ICC estimate <= 0; Kish deff not applied for response.") } } if (length(pred_num) > 0L) { - pred_rho <- .estimate_icc(df, id_col, pred_num) - if (pred_rho > 0) { - .msg(sprintf( - "summarize_by_cell(): Kish deff using predictor ICC = %.4f", pred_rho - )) - } else { - .msg("summarize_by_cell(): predictor ICC estimate <= 0; Kish deff not applied for predictors.") + # Named by column; the SE closures look their own column up. + pred <- vapply(pred_num, function(v) .estimate_icc(df, id_col, v), + numeric(1)) + names(pred) <- pred_num + for (v in pred_num) { + if (pred[[v]] > 0) { + .msg(sprintf( + "summarize_by_cell(): Kish deff using predictor ICC = %.4f for '%s'", + pred[[v]], v + )) + } else { + .msg(sprintf(paste0("summarize_by_cell(): predictor ICC estimate <= 0 for ", + "'%s'; Kish deff not applied for it."), v)) + } } } - if (is.null(resp_rho) && is.null(pred_rho)) { + if (is.null(resp) && is.null(pred)) .msg("summarize_by_cell(): no numeric columns for ICC estimation; deff = 1.") - resp_rho <- 0 - pred_rho <- 0 - } - # Fill in zeros for the type that has no columns - if (is.null(resp_rho)) resp_rho <- 0 - if (is.null(pred_rho)) pred_rho <- 0 + # Zero for the type that has no columns + list(resp = if (is.null(resp)) 0 else resp, + pred = if (is.null(pred)) 0 else pred) + } + if (use_kish) { + icc_est <- .kish_iccs() + resp_rho <- icc_est$resp + pred_rho <- icc_est$pred } + # Set when a "variogram" request fell back to Kish: why, for the record. + vgm_fallback <- NULL # --- build combined function list for across() --- # Each prefix (resp_, pred_) gets user agg_funs + sd + se, with names @@ -1551,7 +2452,11 @@ summarize_by_cell <- function(assigned_points_sf, # NA row contributes nothing to the mean, so it cannot contribute to # the mean's clustering either. if (.kish) { - deff_i <- max(1, 1 + (n_valid - 1) * .rho) + # A named `.rho` holds one ICC per column (the predictors'); each + # column takes its own. across() runs one closure list over all + # the predictor columns, so the column is asked for here. + rho_i <- if (!is.null(names(.rho))) .rho[[dplyr::cur_column()]] else .rho + deff_i <- max(1, 1 + (n_valid - 1) * rho_i) } else if (!is.null(.rbar)) { # Variogram path. The mean pairwise correlation is over the # locations of the observations that ENTER this column's mean, so @@ -1663,7 +2568,19 @@ summarize_by_cell <- function(assigned_points_sf, no_fit <- NULL # why no model is available, for the warning below set_aside <- NULL # why a supplied `sac` was not used set_aside_so <- "" # and what that means, for the replacement warning - if (!is.null(sac) && is.na(suppressWarnings(as.numeric(sac))[1L]) && + # One refusal is an answer and not a failed fit. When + # estimate_sac_range() finds no spatial structure it returns NA with a + # pure-nugget model at the variance of the variable (.sac_no_structure(), + # R/utils.R). Under that model distinct observations are uncorrelated and + # the design effect is 1 exactly, which is the pure-nugget route below. + # Set aside with the other refusals, it raised the fallback warning and + # handed the request to Kish for a layer the variogram had just answered. + no_structure <- function(s) + .sac_no_structure(s) && .vgm_is_pure_nugget(attr(s, "variogram_model")) + structure_note <- NULL # the refusal that gave the pure nugget, for the log + if (no_structure(sac)) { + structure_note <- as.character(attr(sac, "rejected_reason"))[1L] + } else if (!is.null(sac) && is.na(suppressWarnings(as.numeric(sac))[1L]) && !is.null(attr(sac, "rejected_reason"))) { set_aside <- sprintf("the supplied `sac` reports no usable range (%s)", as.character(attr(sac, "rejected_reason"))[1L]) @@ -1714,6 +2631,11 @@ summarize_by_cell <- function(assigned_points_sf, if (inherits(est, "try-error")) { no_fit <- sprintf("estimate_sac_range() failed: %s", conditionMessage(attr(est, "condition"))) + } else if (no_structure(est)) { + # No structure in the response: the pure nugget is the model. + structure_note <- as.character(attr(est, "rejected_reason"))[1L] + vgm_model <- attr(est, "variogram_model") + vgm_crs <- attr(est, "crs") } else if (is.na(suppressWarnings(as.numeric(est))[1L]) && !is.null(attr(est, "rejected_reason"))) { no_fit <- sprintf(paste0("the variogram estimated from `response_var` ", @@ -1734,8 +2656,10 @@ summarize_by_cell <- function(assigned_points_sf, # be reported as "the supplied model could not be read", with the # fallback warning and deff_applied FALSE. .log_info(paste0("summarize_by_cell(): the variogram model is a pure ", - "nugget, so distinct observations are uncorrelated and ", - "the design effect is 1 in every cell.")) + "nugget%s, so distinct observations are uncorrelated and ", + "the design effect is 1 in every cell."), + if (is.null(structure_note)) "" + else sprintf(" (the variogram's verdict: %s)", structure_note)) cor_fn <- function(h) 0 * h } if (is.null(cor_fn)) { @@ -1744,25 +2668,52 @@ summarize_by_cell <- function(assigned_points_sf, other <- if (is.data.frame(vgm_model) && "model" %in% names(vgm_model)) setdiff(unique(as.character(vgm_model$model)), c("Nug", names(.vgm_shape_fns))) else character(0) - if (length(other)) { - .warn_deff_fallback(paste0("summarize_by_cell(): deff = \"variogram\" ", - "supports exponential, spherical and Gaussian ", - "variogram models (plus a nugget); the supplied ", - "model uses %s. Falling back to deff = 1."), - paste(sQuote(other, FALSE), collapse = ", ")) - } else { - .warn_deff_fallback(paste0("summarize_by_cell(): deff = \"variogram\" requires ", - "a fitted variogram model; none was available (%s). ", - "Pass one via `sac = estimate_sac_range(...)`. ", - "Falling back to deff = 1, so the standard errors ", - "are the uncorrected ones."), - paste(c(set_aside, - if (is.null(no_fit)) "the supplied model could not be read" - else no_fit), - collapse = "; ")) - } - use_vgm <- FALSE - deff <- 1 + why <- if (length(other)) + sprintf(paste0("deff = \"variogram\" supports exponential, spherical and ", + "Gaussian variogram models (plus a nugget); the supplied ", + "model uses %s."), + paste(sQuote(other, FALSE), collapse = ", ")) + else + sprintf(paste0("deff = \"variogram\" requires a fitted variogram model; ", + "none was available (%s). Pass one via ", + "`sac = estimate_sac_range(...)`."), + paste(c(set_aside, + if (is.null(no_fit)) "the supplied model could not be read" + else no_fit), + collapse = "; ")) + # The request cannot be met. It used to fall back to deff = 1, the + # uncorrected interval, under the same column names: the interval with + # no correction at all for a caller who asked for one. A range goes + # unidentified often enough that this is an ordinary case, not a + # corner. Kish needs no variogram, so it is the fallback; the + # uncorrected SE is returned only when Kish's own ICC is 0, and either + # way the rows say which. + use_vgm <- FALSE + use_kish <- TRUE + deff <- 1 + vgm_fallback <- why + icc_est <- .kish_iccs() + resp_rho <- icc_est$resp + pred_rho <- icc_est$pred + icc_txt <- paste(c( + if (length(resp_num)) sprintf("response '%s' %.3f", resp_num[[1L]], resp_rho), + if (length(pred_num)) sprintf("predictor '%s' %.3f", pred_num, pred_rho)), + collapse = ", ") + if (max(resp_rho, pred_rho, 0) > 0) + .warn_deff_fallback(paste0( + "summarize_by_cell(): %s Falling back to deff = \"kish\" (ICC: %s): ", + "the standard errors carry Kish's correction in place of the ", + "variogram's, and `deff_method` reads \"kish (variogram fallback)\" ", + "on every row."), + why, icc_txt, data = list(requested = "variogram", used = "kish")) + else + .warn_deff_fallback(paste0( + "summarize_by_cell(): %s Falling back to deff = \"kish\", whose ICC ", + "is 0 (%s), so the standard errors are the uncorrected ones; ", + "`deff_method` reads \"none (variogram fallback)\" on every row."), + why, + if (nzchar(icc_txt)) icc_txt else "no numeric column to estimate it from", + data = list(requested = "variogram", used = "none")) } else { if (!is.null(set_aside)) .warn_and_log(paste0("summarize_by_cell(): %s%s. It was set aside, ", @@ -1907,23 +2858,31 @@ summarize_by_cell <- function(assigned_points_sf, # 20), deflating a cell whose response is uncorrelated on the strength of a # predictor that happens to be clustered. The response SE is already left # at deff = 1 in that case, as documented; cell_weight has to agree with it. + # With no response the primary variable is the FIRST predictor, and the + # weight is built from that predictor's own ICC. From an ICC pooled over + # every predictor listed, an unclustered primary predictor's weight fell + # from 12 to 2.12 when a clustered one was listed after it. primary_rho <- if (has_resp) max(resp_rho, 0) - else if (has_pred) max(pred_rho, 0) + else if (has_pred) max(pred_rho[[1L]], 0) else 0 deff_per_cell <- pmax(1, 1 + (n_valid_primary - 1) * primary_rho) if (primary_rho > 0) out$cell_weight <- n_valid_primary / deff_per_cell - # Recorded whenever EITHER ICC corrected its columns. Keyed on the + # Recorded whenever ANY ICC corrected its column. Keyed on the # primary variable alone, a clustered predictor beside an unclustered # response had its SEs inflated 11x on rows marked deff_applied = FALSE, # with no attribute. `deff` stays the primary variable's (all 1 then). if (max(resp_rho, pred_rho, 0) > 0) { - attr(out, "deff_applied") <- list( + attr(out, "deff_applied") <- c(list( method = "kish", icc_resp = if (has_resp) resp_rho else NA_real_, + # One ICC per predictor column, named by column. icc_pred = if (has_pred) pred_rho else NA_real_, deff = deff_per_cell - ) + ), + # A "variogram" request that fell back here says so, and why. + if (!is.null(vgm_fallback)) + list(requested = "variogram", fallback_reason = vgm_fallback)) } } else if (use_vgm && !is.null(vgm_rbar)) { # The ..se_ closures have already applied the per-column design effect @@ -1979,7 +2938,8 @@ summarize_by_cell <- function(assigned_points_sf, if (use_kish) attr(out, "icc") <- list( resp = if (has_resp) as.numeric(resp_rho) else NA_real_, - pred = if (has_pred) as.numeric(pred_rho) else NA_real_) + # Named by predictor column: each has its own. + pred = if (has_pred) pred_rho else NA_real_) # The same fact per row. The attribute does not survive rbind(), # dplyr::bind_rows() or most dplyr verbs, so results combined across calls # (a simulation, a benchmark over many layers) could not tell a row whose @@ -1987,8 +2947,78 @@ summarize_by_cell <- function(assigned_points_sf, # fires when the variogram is rejected -- often when correlation is # strongest. Only when a design effect was requested, so the default # frame is unchanged. - if (deff_requested) - out$deff_applied <- !is.null(attr(out, "deff_applied")) + if (deff_requested) { + applied <- !is.null(attr(out, "deff_applied")) + out$deff_applied <- applied + # Which correction the standard errors carry, by name, since the columns + # keep their names whatever was applied: "variogram", "kish" or "fixed" + # when the one asked for was applied, "none" when it was not (a refused + # number, Kish ICCs of 0), and "kish (variogram fallback)" or + # "none (variogram fallback)" when a "variogram" request could not be + # met and Kish stood in for it. + out$deff_method <- paste0( + if (applied) attr(out, "deff_applied")$method else "none", + if (!is.null(vgm_fallback)) " (variogram fallback)" else "") + } + + # --- pooled values --- + # Appended after every column above, so each of those keeps its name, its + # values and its position, and before the join below adds the geometry. + # Nothing here reads `agg_funs` or `deff`: a column is pooled on its own + # scored rows, from their values, their cells and their coordinates. + pooled <- NULL + if (identical(estimate, "pooled") && (has_resp || has_pred)) { + # The design effect the t interval carries is the one recorded above as + # applied, not the one asked for: a refused number, and Kish ICCs of 0 for + # every column, leave the default's numbers, and the table of intervals + # then describes them as the default's. + deff_carried <- attr(out, "deff_applied") + pooled <- .pooled_columns( + assigned_points_sf, df, id_col, out[[id_col]], resp_num, pred_num, + obs_level = obs_level, conf_level = conf_level, + deff_label = .deff_label( + deff_carried, + # Under Kish each column has its own ICC, and one of 0 leaves that + # column's standard error as it is. + kish_zero = if (use_kish) + unique(c(if (has_resp && resp_rho <= 0) resp_num, + if (has_pred) pred_num[pred_rho <= 0]))), + crs = count_crs) + for (nm in names(pooled$columns)) out[[nm]] <- pooled$columns[[nm]] + attr(out, "pooled") <- pooled$record + attr(out, "intervals") <- pooled$record$intervals + .pooled_warnings(pooled$events, obs_level) + } + + # --- the record of how the cells' count was set --- + # Read and checked whatever `estimate` is, and attached with the result of + # its checks: whether the summary reports the estimate the count was + # chosen for, and whether the cells and rows it was given are the ones the + # profile scored. Nothing above depends on it but the CRS of the pooled + # values' distances. + if (!is.null(count_rule)) { + # What the engine finds for the response on the rows summarised. Under + # pooled values with a count scored for them it is the fit just made; + # otherwise one more fit of the response. + found <- function(est) { + if (identical(est, "pooled") && !is.null(pooled)) { + r <- pooled$record$columns[[paste0("resp_", response_var)]] + return(list(n = r$n, cells = r$cells, loo = r$loo, status = r$status)) + } + loc <- if (!is.null(pooled)) pooled$loc else .pooled_xy(assigned_points_sf, count_crs) + res <- .pool_column(df[[response_var]], df[[id_col]], loc$xy, NULL, want = est, + use_fnn = .has_backend("FNN")) + list(n = res$record$n, cells = res$record$cells, + loo = if (is.null(res$fit)) NA_real_ + else if (identical(est, "pooled")) res$fit$loo_pooled + else res$fit$loo_mean, + status = res$record$status) + } + attr(out, "count_rule") <- .count_rule_check( + count_rule, other = if (!is.null(rule_rows)) rule_cells, + estimate = estimate, response_var = response_var, summarised = resp_num, + layer = assigned_points_sf, found = found) + } if (!is.null(cells_sf)) { if (!inherits(cells_sf, "sf")) { @@ -2076,10 +3106,21 @@ summarize_by_cell <- function(assigned_points_sf, # observations get NA). deff_attr <- attr(out, "deff_applied") icc_attr <- attr(out, "icc") + pooled_attr <- attr(out, "pooled") + rule_attr <- attr(out, "count_rule") pre_join_id <- as.character(out[[id_col]]) out <- dplyr::left_join(cells_slim, out, by = id_col) if (!is.null(icc_attr)) attr(out, "icc") <- icc_attr + # The record of the count, with the result of its checks. It is the + # one read above, not whatever the cells' own attribute holds. + attr(out, "count_rule") <- rule_attr + # The record of the pooled columns and its table of intervals, which + # the join drops as it drops "icc". + if (!is.null(pooled_attr)) { + attr(out, "pooled") <- pooled_attr + attr(out, "intervals") <- pooled_attr$intervals + } if (isTRUE(area)) { # Planar areas in the cells' own (verified equal-area) CRS, as @@ -2134,3 +3175,529 @@ summarize_by_cell <- function(assigned_points_sf, out[whole] <- sprintf("%.0f", x[whole] + 0) # + 0 turns -0 into 0 out } + + +# ----------------------------------------------------------------------------- +# Pooled values in summarize_by_cell() +# ----------------------------------------------------------------------------- + +# Beyond this a coordinate is not read as a location: the squared distance +# between two such points is not a finite number, and the two neighbour +# searches then stop or disagree. +.POOL_XY_MAX <- 1e150 + +#' The coordinates the pooled values are computed from +#' +#' One row per row of the layer, in a projected CRS. Features that are not +#' points are reduced to one point each first, and the points are then +#' projected, in that order, which is the order \code{resolution_profile()} +#' takes: lon/lat coordinates, and CRS-less ones that look like degrees, go +#' through \code{ensure_projected()}, so degrees are never read as distances. +#' The projection is chosen from every row of the layer, as the profile +#' chooses it. +#' +#' A feature with an empty geometry has \code{NA} coordinates, and so has one +#' with a coordinate beyond \code{.POOL_XY_MAX}: both are rows without a +#' location to the caller. The warning sf raises when it takes a point on +#' the surface of a lon/lat polygon is not passed on: the point is one of the +#' polygon's, and it is projected before any distance is taken. +#' +#' @param layer The assigned layer. +#' @param crs \code{NULL}, or the projected CRS to measure in: the one the +#' record of the cells' count names, in which the profile measured. The +#' points are then put in that CRS, and no other is chosen. +#' @return \code{NULL} when the layer has no geometry (a plain data frame); +#' otherwise a list with \code{xy}, a two-column matrix, and \code{crs}, +#' the CRS its distances are measured in. +#' @keywords internal +#' @noRd +.pooled_xy <- function(layer, crs = NULL) { + if (!inherits(layer, "sf")) return(NULL) + if (nrow(layer) == 0L) + return(list(xy = matrix(numeric(0), 0L, 2L), crs = sf::st_crs(layer))) + if (!all(sf::st_geometry_type(layer, by_geometry = TRUE) == "POINT")) + layer <- withCallingHandlers( + coerce_to_points(layer, "auto"), + warning = function(w) + if (grepl("st_point_on_surface may not give correct results", + conditionMessage(w), fixed = TRUE)) + invokeRestart("muffleWarning")) + layer <- if (is.null(crs)) ensure_projected(layer) + else ensure_projected(layer, target_crs = crs) + xy <- unname(sf::st_coordinates(layer)[, 1:2, drop = FALSE]) + far <- abs(xy[, 1L]) > .POOL_XY_MAX | abs(xy[, 2L]) > .POOL_XY_MAX + xy[which(far), ] <- NA_real_ + list(xy = xy, crs = sf::st_crs(layer)) +} + + +#' The design effect the t interval carries, as a call writes it +#' +#' Read from what \code{summarize_by_cell()} recorded as applied, so that the +#' table of intervals describes the standard errors the frame holds: a +#' request that was refused, or that corrected no column, reads \code{1}. +#' +#' @param applied The \code{"deff_applied"} attribute of the summary, or +#' \code{NULL} when no correction was applied. +#' @param kish_zero Under Kish's correction, the columns whose ICC is 0 and +#' whose standard errors are therefore the uncorrected ones. +#' @return One string for \code{.intervals_table()}: \code{1}, +#' \code{"kish"} or \code{"variogram"} with their quotes, or the number. +#' It reads \code{1} only when nothing was applied: the table takes the +#' words of its row from that. +#' @keywords internal +#' @noRd +.deff_label <- function(applied, kish_zero = character(0)) { + if (is.null(applied)) return("1") + switch(applied$method, + kish = paste0( + "\"kish\"", + if (length(kish_zero)) + sprintf("; 1 for %s, whose ICC is 0", .cols_text(kish_zero))), + variogram = "\"variogram\"", + { + # A number applied is above 1, and is written so that it does not read 1. + lab <- format(applied$deff, digits = 15) + if (identical(lab, "1")) sprintf("%.17g", applied$deff) else lab + }) +} + + +#' Pooled columns, their record and the events to warn about +#' +#' What \code{summarize_by_cell(estimate = "pooled")} adds to its grouped +#' summary. Every numeric column is fitted once, on its own scored rows +#' (\code{.pool_column()}), the response first and then the predictors in the +#' order given; a column named as both is fitted once and returned under both +#' prefixes. The centroids and neighbours of the cells depend on which rows +#' are scored and not on their values, so a column whose scored rows are +#' those of an earlier column is handed that column's. +#' +#' @param layer The assigned layer as the caller passed it. +#' @param df Its attribute table, infinite values already set to \code{NA}. +#' @param id_col Name of the ID column of \code{df}. +#' @param out_ids The IDs of the summary's rows, in its order. +#' @param resp_num,pred_num The numeric response and predictor columns. +#' @param obs_level,conf_level The two levels of the call, or \code{NULL}. +#' @param deff_label The design effect of the t interval, as +#' \code{.intervals_table()} takes it. +#' @param crs \code{NULL}, or the CRS the distances are measured in, as +#' \code{.pooled_xy()} takes it. +#' @return A list: \code{columns}, the new columns by name, in the order they +#' are appended; \code{record}, the list of class \code{spatialkit_pooled}; +#' \code{events}, what \code{.pooled_warnings()} reads; and \code{loc}, the +#' coordinates the columns were fitted on (\code{.pooled_xy()}'s list). +#' @keywords internal +#' @noRd +.pooled_columns <- function(layer, df, id_col, out_ids, resp_num, pred_num, + obs_level, conf_level, deff_label, crs = NULL) { + use_fnn <- .has_backend("FNN") + id <- df[[id_col]] + loc <- .pooled_xy(layer, crs) + xy <- loc$xy + cols <- unique(c(resp_num, pred_num)) + located <- if (is.null(xy)) NULL else is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + + fits <- stats::setNames(vector("list", length(cols)), cols) + kept <- list() # the scored rows and geometry of earlier columns + unlocated <- logical(nrow(df)) # rows with a value, a cell and no location + for (v in cols) { + geo <- NULL + if (!is.null(xy)) { + valued <- is.finite(df[[v]]) & !is.na(id) + scored <- valued & located + unlocated <- unlocated | (valued & !located) + for (k in kept) if (identical(k$mask, scored)) { geo <- k$geo; break } + } + res <- .pool_column(df[[v]], id, xy, obs_level, want = "pooled", + use_fnn = use_fnn, geo = geo) + if (is.null(geo) && !is.null(res$geo)) + kept[[length(kept) + 1L]] <- list(mask = res$mask, geo = res$geo) + # Kept of a column: what the frame, the record and the warnings read. Its + # fit, with the residuals, and its own copy of the mask and the geometry + # are let go here, so that many columns do not hold them all at once. + fits[[v]] <- res[c("ids", "value", "w", "target", "obs_lo", "obs_hi", "record", + "work", "limit")] + } + + columns <- list() + records <- list() + roles <- rbind( + data.frame(prefix = rep("resp_", length(resp_num)), column = resp_num, + role = rep("response", length(resp_num)), stringsAsFactors = FALSE), + data.frame(prefix = rep("pred_", length(unique(pred_num))), column = unique(pred_num), + role = rep("predictor", length(unique(pred_num))), stringsAsFactors = FALSE)) + for (i in seq_len(nrow(roles))) { + v <- roles$column[i] + nm <- paste0(roles$prefix[i], v) + res <- fits[[v]] + at <- match(out_ids, res$ids) + columns[[paste0("..pooled_", nm)]] <- res$value[at] + columns[[paste0("..pooled_w_", nm)]] <- res$w[at] + columns[[paste0("..pooled_target_", nm)]] <- res$target[at] + if (!is.null(obs_level)) { + columns[[paste0("..obs_lo_", nm)]] <- res$obs_lo[at] + columns[[paste0("..obs_hi_", nm)]] <- res$obs_hi[at] + } + rec <- res$record + rec$column <- v + rec$role <- roles$role[i] + records[[nm]] <- rec + } + + record <- structure( + list(toward = "neighbours", + neighbours = .POOL_NEIGHBOURS, + crs = if (is.null(loc)) sf::NA_crs_ else loc$crs, + obs_level = obs_level, + conf_level = conf_level, + intervals = .intervals_table(obs_level, conf_level, deff_label), + columns = records), + class = "spatialkit_pooled") + + events <- list( + records = lapply(fits, function(r) r$record), + w_min = vapply(fits, function(r) + if (length(r$w) && !all(is.na(r$w))) min(r$w, na.rm = TRUE) else NA_real_, numeric(1)), + work = vapply(fits, function(r) as.numeric(r$work), numeric(1)), + limit = vapply(fits, function(r) as.numeric(r$limit), numeric(1)), + skipped_rows = sum(unlocated), + skipped_cells = length(unique(id[unlocated]))) + list(columns = columns, record = record, events = events, loc = loc) +} + + +#' Raise what happened to the pooled columns, once per call and reason +#' +#' Each event is raised once, for all the columns it applies to: the text +#' names them (\code{.cols_text()}) and the condition carries them in +#' \code{columns}, in the order of the frame. A field "by column" is a +#' vector named by those columns. The numbers of each column are in +#' \code{attr(, "pooled")}. +#' +#' @param ev The \code{events} of \code{.pooled_columns()}. +#' @param obs_level The level of the interval for one observation, or +#' \code{NULL}. +#' @return \code{NULL}, invisibly. +#' @keywords internal +#' @noRd +.pooled_warnings <- function(ev, obs_level) { + rec <- ev$records + cols <- names(rec) + if (!length(cols)) return(invisible(NULL)) + of <- function(field, as = as.numeric) + stats::setNames(as(unlist(lapply(rec, function(r) r[[field]]))), cols) + status <- of("status", as.character) + n <- of("n", as.integer) + cells <- of("cells", as.integer) + df <- of("df", as.integer) + one <- function(w) length(w) == 1L + listed <- function(x) paste(format(x, trim = TRUE), collapse = ", ") + + # ---- the pooled columns are NA -------------------------------------------- + w <- cols[status == "no coordinates"] + if (length(w)) + .warn_classed("spatialkit_pool_unavailable", paste0( + "summarize_by_cell(): estimate = \"pooled\" needs the observations' locations, ", + "and `assigned_points_sf` carries no geometry: the pooled columns are NA. The ", + "plain columns are unaffected."), + data = list(reason = "no coordinates", columns = w)) + w <- cols[status == "no located value"] + if (length(w)) + .warn_classed("spatialkit_pool_unavailable", paste0( + "summarize_by_cell(): the pooled columns of %s are NA: no row has a value of ", + "%s, a cell and a location."), + .cols_text(w), if (one(w)) "it" else "any of them", + data = list(reason = "no located value", columns = w)) + w <- cols[status == "no cell holds two values"] + if (length(w)) + .warn_classed("spatialkit_pool_unavailable", paste0( + "summarize_by_cell(): the pooled columns of %s are NA: %s, so the spread of ", + "values inside a cell cannot be estimated and nothing can set a weight. The ", + "plain columns are unaffected."), + .cols_text(w), + if (one(w)) "no cell holds two values of it" + else "for none of them does any cell hold two values", + data = list(reason = "no cell holds two values", columns = w, + n = n[w], cells = cells[w])) + w <- cols[status == "work limit"] + if (length(w)) { + top <- w[which.max(cells[w])] # the column with the most cells + .warn_classed("spatialkit_pool_unavailable", paste0( + "summarize_by_cell(): the pooled columns of %s are NA: finding each cell's ", + "neighbours among %d cells without the FNN package would compare %.2g pairs, ", + "above the limit of %.2g (options(spatialkit.exact_pairs_max = )). Install FNN: ", + "the result is the same. The plain columns are unaffected."), + .cols_text(w), cells[[top]], ev$work[[top]], ev$limit[[top]], + data = list(reason = "work limit", columns = w, work = ev$work[[top]], + limit = ev$limit[[top]], cells = cells[w])) + } + + # ---- the pooled values carry no pooling ------------------------------------ + w <- cols[status == "one cell"] + if (length(w)) + .warn_classed("spatialkit_pool_degenerate", paste0( + "summarize_by_cell(): the values of %s lie in one cell, so there is nothing to ", + "pool toward: the pooled value is the plain mean and its weight is 1."), + .cols_text(w), + data = list(reason = "one cell", columns = w, n = n[w])) + w <- cols[status == "no spread inside any cell"] + if (length(w)) + .warn_classed("spatialkit_pool_degenerate", paste0( + "summarize_by_cell(): the values of %s do not vary inside any cell, so every ", + "own weight is 1 and the pooled value is the plain mean. attr(, \"pooled\") says ", + "which columns are constant."), + .cols_text(w), + data = list(reason = "no spread inside any cell", columns = w, + constant = of("constant", as.logical)[w])) + w <- cols[status == "no signal between cells"] + if (length(w)) + .warn_classed("spatialkit_pool_degenerate", paste0( + "summarize_by_cell(): every own weight of %s is 0: the cell means differ from ", + "their neighbours' means by no more than the spread inside the cells explains. ", + "Each pooled value is then the mean of the cell's nearest cells and holds none ", + "of the cell's own values."), + .cols_text(w), + data = list(reason = "no signal between cells", columns = w, + sigma2 = of("sigma2")[w])) + + # ---- values were computed, and rest on little ------------------------------- + # The columns whose weights were estimated. Where no value varies inside a + # cell the weights are set to 1 and `sigma2` to 0: nothing rests on the + # count of cells or of values there, and nothing is said of either. + fitted <- status %in% c("ok", "no signal between cells") + w <- cols[fitted & cells >= 2L & cells <= 9L] + if (length(w)) + .warn_classed("spatialkit_pool_few_cells", paste0( + "summarize_by_cell(): %s %s values in fewer than 10 cells (%s), so each cell's ", + "target is the mean of all the other cells, not of cells near it. A cell with a ", + "small own weight then gets a pooled value on the far side of the overall mean ", + "from its plain mean, and two cells can change order. The `..pooled_w_*` columns ", + "hold the weights; estimate = \"mean\" gives the plain means."), + .cols_text(w), if (one(w)) "has" else "have", listed(cells[w]), + data = list(columns = w, cells = cells[w], own_weight = ev$w_min[w])) + w <- cols[fitted & cells >= 2L & df >= 1L & df < .POOL_MIN_DF] + if (length(w)) + .warn_classed("spatialkit_pool_few_df", paste0( + "summarize_by_cell(): the spread of %s inside a cell is estimated from fewer ", + "than %d values beyond one per cell (%s), and every own weight rests on it: the ", + "pooled values and their weights are unstable."), + .cols_text(w), .POOL_MIN_DF, listed(df[w]), + data = list(columns = w, needed = .POOL_MIN_DF, df = df[w], n = n[w], + cells = cells[w])) + + # ---- the cells do no better than one mean ----------------------------------- + # The rule has two tests (.no_structure()), and the text says which failed. + # `worse`: one mean predicts a left-out row as well as the pooled values do. + # `untold`: the pooled values predict it better, and the F test does not + # tell the cell means from one mean, which is what it returns where few + # values beyond one per cell stand behind it. + structured <- of("structured", as.logical) + w <- cols[!is.na(structured) & !structured] + if (length(w)) { + loo <- of("loo"); loo_one <- of("loo_one_cell"); p <- of("structure_p") + own <- of("own_weight") + beats <- .beats_one_mean(loo[w], loo_one[w]) + worse <- w[!beats] + untold <- w[beats] + says <- sprintf(paste0("leave-one-out error %s against %s; F test of the cells ", + "against one mean, p = %s; median own weight %.2f"), + vapply(loo[w], function(v) format(signif(v, 4)), character(1)), + vapply(loo_one[w], function(v) format(signif(v, 4)), character(1)), + vapply(p[w], function(v) format(signif(v, 2)), character(1)), + own[w]) + # One column: its numbers stand in the sentence. Several: they follow the + # sentences, which are what the reader has to see and R prints a warning's + # first getOption("warning.length") characters only. + inside <- if (one(w)) sprintf(" (%s)", says) else "" + text <- c( + if (length(worse)) sprintf(paste0( + "the pooled values of %s predict a left-out observation no better than one ", + "mean for all rows%s, so %s no spatial structure these cells can use. The ", + "values are returned. A map of them looks smooth because each is mostly its ", + "neighbours' mean, not because the response varies smoothly."), + .cols_text(worse), inside, if (one(worse)) "it shows" else "they show"), + if (length(untold)) sprintf(paste0( + "%s pooled values of %s predict a left-out observation better than one mean ", + "for all rows, but the F test does not tell the cell means from one mean%s, so ", + "no spatial structure these cells can use is shown%s"), + if (length(worse)) "The" else "the", .cols_text(untold), inside, + if (length(worse)) sprintf(" for %s either.", if (one(untold)) "it" else "them") + else ". The values are returned."), + if (!one(w)) .each_text(sprintf("'%s': %s.", w, says))) + .warn_classed("spatialkit_no_structure", "summarize_by_cell(): %s", + paste(text, collapse = " "), + data = list(criterion = "loo", n = cells[w], one_cell = loo_one[w], columns = w, + estimate = "pooled", loo = loo[w], structure_p = p[w], + beats = stats::setNames(beats, w))) + } + + # ---- rows left out, and what the interval rests on -------------------------- + if (ev$skipped_rows > 0L) + .warn_classed("spatialkit_pool_rows_skipped", paste0( + "summarize_by_cell(): %d row(s) in %d cell(s) have empty or non-finite ", + "coordinates. They count in `n` and the plain columns and take no part in the ", + "pooled columns."), + ev$skipped_rows, ev$skipped_cells, + data = list(n = ev$skipped_rows, cells = ev$skipped_cells, + columns = cols[of("skipped", as.integer) > 0L])) + if (!is.null(obs_level)) { + # The columns whose interval is read from residuals: both offsets are + # numbers, and the column is not constant. The interval of a constant + # column has no width because its residuals are set to 0; it rests on no + # count of them and says nothing of where a further observation lies. + has <- vapply(rec, function(r) !is.null(r$offsets) && all(is.finite(r$offsets)) && + !isTRUE(r$constant), logical(1)) + repeated <- of("repeated", as.integer) + w <- cols[has & repeated > 0L] + if (length(w)) + .warn_classed("spatialkit_repeated_locations", paste0( + "summarize_by_cell(): rows with a value share a location with another row ", + "(%s). The leave-one-out error leaves one row out and keeps the others at its ", + "location, so it, and an interval built from it, describes a further ", + "observation at a place already observed, not an observation at a new place."), + .each_text(sprintf("%d of the %d rows of '%s'", repeated[w], n[w], w), sep = "; ", + more = "and %d more"), + data = list(columns = w, n = repeated[w], total = n[w])) + # The count at which five residuals are expected beyond each end. It is a + # whole number wherever it fits one, and a double above that. + p_lo <- round((1 - obs_level) / 2, 12) + needed <- ceiling(round(.FEW_RESIDUALS / p_lo, 6)) + if (needed <= .Machine$integer.max) needed <- as.integer(needed) + w <- cols[has & n * p_lo < .FEW_RESIDUALS] + if (length(w)) + .warn_classed("spatialkit_few_residuals", paste0( + "summarize_by_cell(): the %s%% interval of %s rests on fewer than %s ", + "leave-one-out residuals (%s), the number at which five are expected beyond ", + "each end; its ends are unstable."), + .level_text(obs_level), .cols_text(w), format(needed, scientific = FALSE), + listed(n[w]), + data = list(columns = w, needed = needed, level = obs_level, n = n[w])) + } + invisible(NULL) +} + + +#' Whether the pooled values predict a left-out row better than one mean +#' +#' The first of the two tests of \code{.no_structure()}, with the margin the +#' summary hands that rule. The warning and the print read it to say which +#' test a column failed. +#' +#' @param loo,loo_one The leave-one-out errors of the pooled values and of one +#' mean for all rows. +#' @return \code{TRUE} where one mean's error is above the pooled values' by +#' more than \code{.STRUCTURE_TOL}. +#' @keywords internal +#' @noRd +.beats_one_mean <- function(loo, loo_one) !(loo_one <= loo * (1 + .STRUCTURE_TOL)) + + +#' The numbers of each column, for at most six of them +#' +#' A warning that gives numbers column by column gives them for the first six +#' columns, as \code{.cols_text()} names six: the text of a warning is printed +#' to \code{getOption("warning.length")} characters, and the numbers of every +#' column are in \code{attr(, "pooled")}. +#' +#' @param pieces One string per column. +#' @param sep What joins them. +#' @param more What stands for the columns left out, with \code{\%d} for +#' their number. +#' @return One string. +#' @keywords internal +#' @noRd +.each_text <- function(pieces, sep = " ", more = "And %d more, in attr(, \"pooled\").") { + k <- length(pieces) + if (k <= 6L) return(paste(pieces, collapse = sep)) + paste(c(pieces[1:6], sprintf(more, k - 6L)), collapse = sep) +} + + +#' A level as a percentage, with the digits it was given with +#' +#' @param level A level strictly between 0 and 1. +#' @return \code{"90"} for 0.9 and \code{"99.9999999"} for 0.999999999; +#' \code{format()} alone writes seven digits and reads the second as 100. +#' @keywords internal +#' @noRd +.level_text <- function(level) format(100 * level, digits = 15) + + +#' @export +print.spatialkit_pooled <- function(x, ...) { + label <- function(name) sprintf(" %-12s: ", name) + indent <- strrep(" ", 16L) + sci <- function(v) sprintf("%.2e", v) + pct <- function(level) paste0(.level_text(level), "%") + count <- function(k, what) sprintf("%d %s%s", as.integer(k), what, if (k == 1L) "" else "s") + # The words beside an interval's columns, read from what the table says the + # interval covers. + target <- function(covers) + if (startsWith(covers, "one further observation")) "ONE OBSERVATION" + else if (grepl("population mean", covers, fixed = TRUE)) "THE POPULATION MEAN" + else "THE CELL'S MEAN" + offset <- function(o) sprintf("value %s %s", if (o < 0) "-" else "+", + format(signif(abs(o), 3))) + iv <- x$intervals + shown <- rep(FALSE, NROW(iv)) + obs <- which(iv$centre == "pooled value") + + for (nm in names(x$columns)) { + r <- x$columns[[nm]] + cat(sprintf("Cell values: %s, %s in %s\n", r$column, count(r$n, "row"), + count(r$cells, "cell"))) + if (!identical(r$status, "ok")) { + cat(label("status"), r$status, "\n", sep = "") + next + } + cat(label("value"), "..pooled_", nm, ", pooled toward ", + if (r$cells <= 9L) sprintf("all the other cells (%d of them)", r$neighbours) + else sprintf("the %d nearest cells (centroids of the rows)", r$neighbours), + "\n", sep = "") + cat(label("variances"), "inside cells ", sci(r$sigma2), " (from ", + count(r$df, "value"), " beyond one per cell);\n", indent, + "between a cell and its target ", sci(r$tau2), "\n", sep = "") + cat(label("own weight"), sprintf("median %.2f (..pooled_w_%s)\n", r$own_weight, nm), + sep = "") + cat(label("alone"), sprintf("%.1f%% of the rows are the only one in their cell\n", + 100 * r$share_alone), sep = "") + cat(label("loo"), sci(r$loo), + " (leave-one-out mean squared error of the pooled value);\n", indent, + "one mean for all rows: ", sci(r$loo_one_cell), + # Which of the rule's two tests failed (.no_structure()). + if (isFALSE(r$structured)) { + if (.beats_one_mean(r$loo, r$loo_one_cell)) + sprintf(": the F test does not tell these cells from one mean (p = %s)", + format(signif(r$structure_p, 2))) + else ": these cells do no better than one mean" + }, + "\n", sep = "") + if (length(obs) && !is.null(r$offsets)) { + cat(label("interval"), pct(iv$level[obs]), " for ", target(iv$covers[obs]), + sprintf(" (..obs_lo_%s, ..obs_hi_%s):\n", nm, nm), indent, + if (all(is.finite(r$offsets))) + sprintf("%s to %s, quantiles of %s", offset(r$offsets[1L]), + offset(r$offsets[2L]), count(r$n, "leave-one-out residual")) + else "not available", + "\n", sep = "") + shown[obs] <- TRUE + } + } + + rest <- which(!shown) + if (length(rest)) { + cat("Also in the frame\n") + for (i in rest) { + covers <- strsplit(iv$covers[i], "; ", fixed = TRUE)[[1L]] + head <- sprintf(" %s : ", iv$columns[i]) + cat(head, pct(iv$level[i]), " for ", target(iv$covers[i]), " (", iv$method[i], + "), centred on the ", iv$centre[i], + if (length(covers) > 1L) + paste0(";\n", strrep(" ", nchar(head)), paste(covers[-1L], collapse = "; ")), + "\n", sep = "") + } + } + cat("Away from the observations no interval here is calibrated.\n") + invisible(x) +} diff --git a/R/block-size-sweep.R b/R/block-size-sweep.R index 97195ddf..fecb765f 100644 --- a/R/block-size-sweep.R +++ b/R/block-size-sweep.R @@ -39,7 +39,7 @@ #' dropped. The count is of grid cells: on clustered data a grid #' of \code{k} or more cells can have fewer than \code{k} that hold points, #' and \code{make_folds()} then lowers \code{k} at that size, which the -#' \code{k} column shows. On an extent much longer than it is wide every +#' \code{k} column shows; the sweep warns once, naming the sizes. On an extent much longer than it is wide every #' rung can fall below the autocorrelation range while longer blocks would #' still fit \code{k} times along the longer side; the sweep warns when #' that happens, and \code{block_sizes} is then the way to reach past the @@ -47,8 +47,25 @@ #' (\code{make_folds()}'s \code{params$crs}, metres for geographic input), #' and the returned table records that CRS. Each is the \emph{minimum} block #' edge handed to \code{make_folds()}, which fits a whole number of cells -#' across the extent, so the cells are somewhat longer than the size on the -#' axis (up to twice as long). +#' across each axis of the extent, so on an axis at least as long as the +#' size the cells are somewhat longer than it (up to just under twice as +#' long). An axis shorter than the size is spanned by one row or column of +#' cells, which are then shorter than the size there. The +#' \code{block_width} and \code{block_height} columns give the cells built +#' at each size. +#' +#' @section Warnings raised once for the sweep: +#' Every size is a \code{\link{cv_spatial}()} on the same layer. The +#' warnings \code{\link{prep_model_data}()} raises about that layer (class +#' \code{spatialkit_rows_dropped}, counting the incomplete rows dropped, and +#' \code{spatialkit_constant_predictor}) are raised once, not once per +#' size. With a GWR learner, the two warnings in +#' which \code{predict()} counts held-out locations +#' (\code{"spatialkit_gwr_not_estimable"} and +#' \code{"spatialkit_gwr_extrapolation"}) are raised once each, under this +#' function's name, with the totals over every size; the same rows are +#' predicted at every size, so a location can be counted once per size (see +#' \code{\link{predict.gwr_fit}}). #' #' @param data_sf An sf object with the response and predictors. #' @param response_var,predictor_vars Column names. @@ -86,7 +103,9 @@ #' reference), \code{method}, \code{blocks_used}, \code{k} (the folds #' actually built), \code{n_folds_succeeded}, \code{value} (the pooled #' metric), \code{fold_min}, \code{fold_max} and \code{fold_sd} (its spread -#' across folds). Attributes: \code{metric}, \code{sac_range} (the +#' across folds), and \code{block_width} and \code{block_height} (the +#' width and height of the grid cells built at that size, \code{NA} for +#' the random reference). Attributes: \code{metric}, \code{sac_range} (the #' effective range, or \code{NA}), \code{crs}, \code{k} (the folds #' requested, which \code{print()} and \code{plot()} report), #' \code{n_fits}, \code{response_var}, and \code{results}, the full @@ -137,6 +156,13 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, stop("cv_block_size_sweep(): ", paste(sQuote(fixed), collapse = ", "), " cannot be passed through `...`; the sweep sets them.", call. = FALSE) + # The layer is prepared here, for the ladder, and again by cv_spatial() at + # every size. Each preparation finds the same incomplete rows and the same + # constant predictors, so the warnings that report them are raised by the + # first and not repeated by the others. + end_run <- .once_per_run(.prep_warning_classes) + on.exit(end_run(), add = TRUE) + # The extent the ladder is built over, in the CRS the folds will use. pts <- prep_model_data(data_sf, response_var, predictor_vars) bb <- sf::st_bbox(pts) @@ -315,11 +341,18 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, # response is handed to make_folds(): its leakage warning would fire at # every size below the range, and this sweep is that diagnostic drawn out. if (!("..row_id" %in% names(data_sf))) data_sf$..row_id <- seq_len(nrow(data_sf)) + # make_folds() warns, with the class spatialkit_k_reduced, when it returns + # fewer folds than asked. In a sweep that can happen at several sizes (a + # grid of k or more cells can have fewer than k that hold points), so the + # warnings are caught here by class and raised once, after the last size, + # naming the sizes; the `k` column carries the count at each. run_one <- function(bs, method) { - f <- if (identical(method, "random_kfold")) - make_folds(data_sf, k = k, method = "random_kfold", seed = seed) - else - make_folds(data_sf, k = k, method = "block_kfold", block_size = bs, seed = seed) + f <- withCallingHandlers( + if (identical(method, "random_kfold")) + make_folds(data_sf, k = k, method = "random_kfold", seed = seed) + else + make_folds(data_sf, k = k, method = "block_kfold", block_size = bs, seed = seed), + spatialkit_k_reduced = function(w) invokeRestart("muffleWarning")) args <- c(list(data_sf = data_sf, response_var = response_var, predictor_vars = predictor_vars, fit_fn = fit_fn, folds = f, k = k, seed = seed), dots) @@ -340,24 +373,52 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, fold_min = if (length(fv)) min(fv) else NA_real_, fold_max = if (length(fv)) max(fv) else NA_real_, fold_sd = if (length(fv) > 1L) stats::sd(fv) else NA_real_, + # The cells built. A whole number of them is fitted across each axis, + # so they are 1 to under 2 times `block_size` on an axis at least that + # long, and as long as the extent (shorter than `block_size`) on an + # axis that is not. + block_width = as.numeric(f$params$block_width %||% NA_real_), + block_height = as.numeric(f$params$block_height %||% NA_real_), stringsAsFactors = FALSE)) } + # A GWR learner counts, at every size, the held-out locations it cannot + # estimate and those beyond the reach of a fold's fit, and cv_spatial() + # raises each count once per cross-validation. Collected over the sweep, + # each is raised once, with the totals: the same rows are predicted at + # every size, so a location can be counted once per size. rows <- list(); results <- list() - if (isTRUE(include_random)) { - .msg("cv_block_size_sweep(): random folds (the leaky reference) ...") - one <- suppressMessages(run_one(NA_real_, "random_kfold")) - results[["random_kfold"]] <- one$cv - rows[[length(rows) + 1L]] <- one$row - } - for (bs in block_sizes) { - .msg(sprintf("cv_block_size_sweep(): block size %s ...", format(signif(bs, 4)))) - one <- suppressMessages(run_one(bs, "block_kfold")) - results[[as.character(signif(bs, 6))]] <- one$cv - rows[[length(rows) + 1L]] <- one$row - } + .gwr_tally_predict_warnings({ + if (isTRUE(include_random)) { + .msg("cv_block_size_sweep(): random folds (the leaky reference) ...") + one <- suppressMessages(run_one(NA_real_, "random_kfold")) + results[["random_kfold"]] <- one$cv + rows[[length(rows) + 1L]] <- one$row + } + for (bs in block_sizes) { + .msg(sprintf("cv_block_size_sweep(): block size %s ...", format(signif(bs, 4)))) + one <- suppressMessages(run_one(bs, "block_kfold")) + results[[as.character(signif(bs, 6))]] <- one$cv + rows[[length(rows) + 1L]] <- one$row + } + }, caller = "cv_block_size_sweep", refits = TRUE) out <- do.call(rbind, rows) rownames(out) <- NULL + fewer <- which(is.finite(out$k) & out$k < k) + if (length(fewer)) + .warn_and_log(paste0("cv_block_size_sweep(): fewer than the k = %d folds ", + "asked for in %d of the %d cross-validations (%s), ", + "where fewer than %d blocks hold points. Those rows ", + "are not %d-fold results like the others; the `k` ", + "column gives the folds built. Pass `block_sizes` ", + "without those sizes, or a smaller `k`, to compare ", + "like with like."), + k, length(fewer), nrow(out), + paste(sprintf("%s: %d folds", + ifelse(is.na(out$block_size[fewer]), "random folds", + paste("block size", format(signif(out$block_size[fewer], 4)))), + out$k[fewer]), collapse = "; "), + k, k) structure(out, metric = metric, sac_range = sac_range, crs = .fold_crs_label(pts), k = k, n_fits = n_fits, diff --git a/R/cell-values-at.R b/R/cell-values-at.R new file mode 100644 index 00000000..6dd6f45c --- /dev/null +++ b/R/cell-values-at.R @@ -0,0 +1,869 @@ +# R/cell-values-at.R +# ----------------------------------------------------------------------------- +# The value of a cell at other locations +# ----------------------------------------------------------------------------- +# cell_values_at() gives new locations the value and interval of their cell, +# by the rule the held-out rows of an evaluation are scored with: the cell +# of the nearest seed (or the polygon that holds the location), and for a +# location in no cell, or in a cell with neither a scored row nor a value, +# the cell of the nearest scored row. Beside each value it returns the +# location's distance from the nearest observation. + + +#' The columns of a summary that hold a column's cell value +#' +#' The response's columns are read before a predictor's, and within either +#' the pooled value before the plain mean. +#' +#' @param nms The names of the summary's columns. +#' @param v The summarised column. +#' @return \code{NULL} when the summary holds neither value of \code{v}; +#' otherwise a list: \code{value} (the column's name), \code{estimate} +#' (\code{"pooled"} or \code{"mean"}) and \code{lo}, \code{hi} (the names +#' of the interval's columns, or \code{NULL} when the summary does not hold +#' both beside a pooled value). +#' @keywords internal +#' @noRd +.values_at_columns <- function(nms, v) { + for (p in c("resp_", "pred_")) { + pooled <- paste0("..pooled_", p, v) + plain <- paste0(p, "mean_", v) + if (pooled %in% nms) { + lo <- paste0("..obs_lo_", p, v) + hi <- paste0("..obs_hi_", p, v) + both <- all(c(lo, hi) %in% nms) + return(list(value = pooled, estimate = "pooled", + lo = if (both) lo, hi = if (both) hi)) + } + if (plain %in% nms) + return(list(value = plain, estimate = "mean", lo = NULL, hi = NULL)) + } + NULL +} + + +#' The geometry of a layer, one point per feature +#' +#' @param layer An sf layer. +#' @return An sf layer with the geometry column and no other, row for row +#' with \code{layer}. A feature that is not a point is reduced to one by +#' \code{coerce_to_points(, "auto")}, whose conditions are passed on; an +#' empty geometry stays an empty point. +#' @keywords internal +#' @noRd +.values_at_points <- function(layer) { + g <- sf::st_sf(geometry = sf::st_geometry(layer)) + if (nrow(g) > 0L && !all(sf::st_geometry_type(g, by_geometry = TRUE) == "POINT")) + g <- coerce_to_points(g, "auto") + g +} + + +#' A point layer where the scored rows are read +#' +#' @param pts A layer of points, as \code{.values_at_points()} returns it. +#' @param arg The argument the layer came from, for the messages. +#' @param what What the layer holds, in the words of the messages. +#' @param crs The working CRS; \code{NA} when the coordinates of +#' \code{points} are used as they are. +#' @param points_crs The CRS of \code{points} as it was passed. +#' @param as_lonlat Whether \code{points} carries no CRS and its coordinates +#' were taken for longitude and latitude. +#' @return \code{pts} in the CRS the scored rows are measured in. A layer +#' without a CRS beside \code{points} without one is read as +#' \code{points} was read: as EPSG:4326 when \code{as_lonlat}, and as it is +#' otherwise. +#' @keywords internal +#' @noRd +.values_at_place <- function(pts, arg, what, crs, points_crs, as_lonlat) { + own <- sf::st_crs(pts) + if (is.na(own)) { + if (!is.na(points_crs)) + stop(sprintf(paste0("cell_values_at(): `%s` has no CRS and `points` has one; set it ", + "with sf::st_set_crs() so the %s can be placed."), arg, what), + call. = FALSE) + if (as_lonlat) pts <- sf::st_transform(sf::st_set_crs(pts, 4326), crs) + return(pts) + } + if (is.na(crs)) + stop(sprintf(paste0("cell_values_at(): `%s` has a CRS and `points` has none; set the ", + "CRS of `points` with sf::st_set_crs() so the %s can be placed."), + arg, what), call. = FALSE) + ensure_projected(pts, target_crs = crs) +} + + +#' The coordinates of a point layer +#' +#' @param pts A layer of points. +#' @return A two-column matrix, one row per point; \code{NA} for an empty +#' point and for one with a coordinate beyond \code{.POOL_XY_MAX}, from +#' which no distance can be taken. +#' @keywords internal +#' @noRd +.values_at_xy <- function(pts) { + if (nrow(pts) == 0L) return(matrix(numeric(0), 0L, 2L)) + xy <- unname(sf::st_coordinates(pts)[, 1:2, drop = FALSE]) + far <- abs(xy[, 1L]) > .POOL_XY_MAX | abs(xy[, 2L]) > .POOL_XY_MAX + xy[which(far | !is.finite(xy[, 1L]) | !is.finite(xy[, 2L])), ] <- NA_real_ + xy +} + + +#' The nearest centre of every point, where many points can tie +#' +#' The answer of \code{.nearest_centre()}: the nearest centre by squared +#' distance in R's arithmetic, a tie to the lower centre number. That +#' function searches a point whose two nearest centres tie against every +#' centre, which is the right trade where the centres are a partition's and +#' few points tie. Here the centres can be every scored location of a layer +#' and the points a grid laid over them, so that most points tie; searched +#' that way the time grows with the points times the centres. A tied point +#' is given a longer shortlist from the kd-tree instead, twice as long each +#' round, until its furthest member is further than its nearest by more than +#' one part in a thousand million: every centre as near as the nearest is +#' then on the list, and the lowest-numbered of them is taken. A point whose +#' shortlist would hold every centre is searched exactly. +#' +#' @param x,y Coordinates of the points. +#' @param cx,cy Coordinates of the centres. +#' @param use_fnn Whether to use \pkg{FNN}. Without it, and for up to 16 +#' centres, the search is \code{.nearest_centre()}'s exact one. +#' @return Integer vector: the centre of each point. +#' @keywords internal +#' @noRd +.values_at_nearest <- function(x, y, cx, cy, use_fnn) { + K <- length(cx) + if (!isTRUE(use_fnn) || K <= 16L) return(.nearest_centre(x, y, cx, cy, use_fnn = FALSE)) + cen <- cbind(cx, cy) + out <- integer(length(x)) + todo <- seq_along(x) + k <- 2L + while (length(todo)) { + if (k >= K) { + out[todo] <- .nearest_exact(x[todo], y[todo], cx, cy) + break + } + qx <- x[todo]; qy <- y[todo] + nn <- matrix(FNN::get.knnx(cen, cbind(qx, qy), k = k)$nn.index, length(todo), k) + d2 <- matrix((qx - cx[nn])^2 + (qy - cy[nn])^2, length(todo), k) + best <- do.call(pmin, lapply(seq_len(k), function(j) d2[, j])) + far <- do.call(pmax, lapply(seq_len(k), function(j) d2[, j])) + # The lowest-numbered of the centres at the least distance. + nn[d2 > best] <- K + 1L + pick <- do.call(pmin, lapply(seq_len(k), function(j) nn[, j])) + done <- far > best * (1 + 1e-9) + out[todo[done]] <- pick[done] + todo <- todo[!done] + k <- 2L * k + } + out +} + + +#' The centres the profile scored, when the seeds are those centres +#' +#' The seeds of a \code{select_resolution()} result, and the seeds +#' \code{get_voronoi_seeds()} hands on from one, are the centres the profile +#' scored, and come back in the CRS of the points they were placed for. Put +#' back in the CRS the profile measured in, they differ from the centres by +#' the rounding of the two transformations, which can settle a tie between +#' two seeds the other way, and a caller may hand them in another order +#' (sorted by their cell, say), which settles a tie by that order. The +#' centres as the record holds them, in its order, settle it as the profile +#' did. +#' +#' @param rule The summary's record of the count, or \code{NULL}. +#' @param seed_xy The seeds' coordinates in the working CRS, one row per row +#' of \code{seeds}. +#' @param crs The working CRS. +#' @param use_fnn Whether \pkg{FNN} is used, as the call's other searches +#' are told. +#' @return When the record sits beside the centres +#' (\code{.scored_centres()}), the working CRS is the record's (or both +#' have none), and the seeds are the centres (\code{.seeds_as_centres()}): +#' a list of \code{centres}, the record's, and \code{seed}, for each centre +#' the row of \code{seeds} that is it. \code{NULL} otherwise, and the +#' seeds are searched as they are. +#' @keywords internal +#' @noRd +.values_at_centres <- function(rule, seed_xy, crs, use_fnn = .has_backend("FNN")) { + cen <- .scored_centres(rule) + if (is.null(cen)) return(NULL) + if (!inherits(crs, "crs") || is.na(crs) != is.na(rule$crs)) return(NULL) + if (!is.na(crs) && !isTRUE(crs == rule$crs)) return(NULL) + of <- .seeds_as_centres(seed_xy, cen, use_fnn) + if (is.null(of)) return(NULL) + list(centres = cen, seed = of) +} + + +#' Cell IDs written in the class of a summary's ID column +#' +#' IDs are matched as text. An ID that matches a row of the summary is that +#' row's. One that matches none (a cell the summary has no row for) is +#' converted from its text: to a number for a numeric column, to a level +#' added to the levels for a factor. +#' +#' @param text Character vector of IDs, \code{NA} for none. +#' @param ids The summary's ID column. +#' @return A vector of the class of \code{ids}, as long as \code{text}, when +#' every ID can be written in that class. When one that matches no row +#' cannot (a string that is no number or a fraction beside an integer +#' column, a string that is not the text of a number beside a double one, +#' any ID beside a column of another class than character, factor, integer +#' and double), the result is \code{text}: an ID is never turned into +#' another ID or into \code{NA}. +#' @keywords internal +#' @noRd +.values_at_ids <- function(text, ids) { + at <- match(text, .id_as_character(ids), incomparables = NA) + miss <- which(!is.na(text) & is.na(at)) + if (is.character(ids)) return(text) + if (is.factor(ids)) { + lev <- c(levels(ids), setdiff(unique(text[miss]), levels(ids))) + return(factor(text, levels = lev, ordered = is.ordered(ids))) + } + out <- ids[at] + if (!length(miss)) return(out) + read <- if (is.integer(ids) && !is.object(ids)) suppressWarnings(as.integer(text[miss])) + else if (is.double(ids) && !is.object(ids)) suppressWarnings(as.numeric(text[miss])) + else NULL + # Written back, the number has to be the ID it was read from. + if (is.null(read) || !identical(.id_as_character(read), text[miss])) return(text) + out[miss] <- read + out +} + + +#' Cell values at other locations +#' +#' Gives each location of `newdata` the value of the cell it lies in, read +#' from a [summarize_by_cell()] result: the pooled value when the summary +#' holds one, the plain mean otherwise, with the interval for one +#' observation when the summary holds it. Beside each value it returns the +#' location's distance from the nearest observation, since a cell's value +#' describes the part of the cell where its observations lie. +#' +#' The function works in six steps. +#' +#' 1. *The working CRS.* The CRS the summary measured in: the one in +#' `attr(values, "count_rule")` when that record names a projected CRS, +#' else the one in `attr(values, "pooled")`, else the CRS of `points` +#' when it is projected and the one [ensure_projected()] picks for it +#' when it is not. `points`, `newdata` and `seeds` are transformed to it. +#' When neither `points` nor `newdata` has a CRS the coordinates are used +#' as they are, unless those of `points` look like longitude and latitude: +#' both are then read as EPSG:4326, as [summarize_by_cell()] reads +#' `points`, with [ensure_projected()]'s warning. +#' 2. *The scored rows.* The rows of `points` with a finite `response_var`, +#' a cell ID and finite coordinates. Their distinct locations are the +#' observations every distance below is taken from. +#' 3. *The cell of a location.* With `seeds`, the cell of the nearest seed. +#' That is the Voronoi cell before its clip to the cover, so every +#' location has one, unless its nearest seed has an `NA` ID. A location +#' nearest such a seed has no cell, even where the polygon that holds it +#' has scored rows. [build_tessellation()] gives `NA` in `index` to a +#' seed that lies in no cell: one whose cell the clip removed, and one +#' outside a boundary that is not convex, whose clipped cell exists +#' (see "Seeds outside the boundary"). Without `seeds`, the polygon of +#' `values` that holds the +#' location, by [assign_features_to_polygons()] with its default +#' `tie_break` and the summary's record of the count, so a location on +#' the edge between two cells the profile scored is placed as that +#' function places such a row (see "Ties"); a location in no polygon has +#' no cell. Polygons without a +#' CRS are read as that function read them for the rows of `points`: the +#' locations are handed to it in the CRS of `points`, whatever CRS +#' `newdata` arrived in. +#' 4. *The value.* The cell's pooled value of `response_var`, +#' `..pooled_` with the prefix `resp_` or `pred_`, +#' when `values` has that column; otherwise its mean, +#' `mean_`. The column `estimate` says which. For a +#' column summarised as response and as predictor the response's columns +#' are read. The interval is the cell's `..obs_lo_` +#' and `..obs_hi_` when `values` has them. +#' 5. *The fill.* A location with no cell, or whose cell holds no scored row +#' and has no value in `values`, takes the value and interval of the cell +#' of its nearest scored row. `filled` is then `TRUE` and `filled_from` is +#' that cell's ID. The ID column still holds the location's own cell, as +#' step 3 finds it, so the two columns together say where a location lies +#' and where its value came from. A cell that holds a scored row is not +#' filled. Where `values` +#' has no value for such a cell (the summary could not compute the pooled +#' columns, or has no row for the cell), its locations have `value = NA` +#' and `filled = FALSE`; a filled value is `NA` in the same case, when +#' the cell it is taken from has none. +#' 6. *The distance.* `dist_nearest` is the distance from the location to +#' the nearest location of a scored row, in the units of the working CRS. +#' `dist_ratio` is that distance over the layer's spacing: the median, +#' over the distinct locations of the scored rows, of the distance to the +#' nearest other one. +#' +#' Cell IDs are matched as text. The ID column of `values` is character when +#' the summary joined a `cells_sf` whose IDs were of another class than the +#' assigned layer's, while `points` and `seeds` keep the class they had; the +#' IDs of all three are written out as text before any match, and both ID +#' columns returned have the class of the ID column of `values` wherever +#' that class can hold every ID (see Value). +#' +#' @section Seeds outside the boundary: +#' A k-means seed can lie outside a boundary that is not convex, in a bay or +#' a bend of a coast (see [get_voronoi_seeds()]). Its cell, clipped to the +#' boundary, holds ground and observations, but the seed lies in no cell, so +#' `seeds$cell_id <- tess$index` gives it `NA`. The locations nearest it then +#' have `NA` in the ID column and are filled from the cell of their nearest +#' scored row, which can be another cell than the one that holds them. +#' Every point of a Voronoi cell is nearer its own seed than any other, so a +#' point inside each cell that no seed lies in finds that cell's seed. In a +#' projected CRS: +#' ``` +#' seeds$cell_id <- tess$index +#' own <- tess$cells[!tess$cells$cell_id %in% tess$index, ] +#' near <- sf::st_nearest_feature(sf::st_point_on_surface(sf::st_geometry(own)), +#' seeds) +#' seeds$cell_id[near] <- own$cell_id +#' ``` +#' Each location inside the boundary then has the cell that holds it, and +#' none is filled for want of a seed. A seed whose cell the clip removed +#' keeps `NA`. +#' +#' @section Ties: +#' A location the same distance from two seeds takes the one that comes +#' first in `seeds`. For the seeds of a [select_resolution()] result that is +#' the lower-numbered centre, the rule [resolution_profile()] scores with. +#' When the summary's record of the count holds the centres the profile +#' scored and `seeds` are those centres (the seeds a selection carries, or +#' those a seeding function returns for it), in any order and any CRS, the +#' distances are taken to the centres as the record holds them, a tie goes +#' to the lower-numbered centre, and each centre gives the ID of the seed +#' that stands at it. Seeds count as the centres when they are as many and +#' each lies at a different centre, within a thousandth of its distance from +#' the next nearest one, so a seed that came back from another CRS with its +#' coordinates rounded, or seeds sorted by their cell, do not settle a tie +#' another way. A location on the edge between two such cells then takes +#' the cell [assign_features_to_polygons()] gives a row there, with `seeds` +#' and without. Other seeds, among them a subset of the centres, are +#' searched as given. A +#' location the same distance from two locations of scored rows takes the +#' one with the lower x coordinate, then the lower y; among scored rows at +#' one location that lie in different cells, the cell that comes first in +#' the order of the IDs (ascending for numbers, the C-locale order for +#' strings, the order of the levels for a factor). Neither rule depends on +#' the order of the rows of `points`, or on whether the \pkg{FNN} package is +#' installed. A tie is a tie between distances computed from the coordinates +#' in the working CRS, so on gridded locations the same layer in another CRS +#' or unit can put a location on a boundary in the other cell. +#' +#' @section Away from the observations: +#' The value and the interval describe locations among the observations. +#' The interval's two ends are quantiles of leave-one-out errors, each the +#' error of predicting an observation from the others around it, so it says +#' nothing of a location far from every observation: a gap in the layer, or +#' ground beyond its edge. Away from the observations no interval here is +#' calibrated. `dist_nearest` and `dist_ratio` say how far each location is +#' from the data. No threshold is applied to either and no location is +#' flagged or left out. [area_of_applicability()] and [fold_separation()] +#' are the tools for deciding where a prediction applies. +#' +#' A simulation shows how the interval's coverage falls with `dist_ratio` +#' (`dev/sim-pooled-values.R` in the package's repository; "Pooled values" in +#' [summarize_by_cell()] describes it). Each of 200 layers has 1,500 +#' clustered observations in 333 cells, 300 further observations held out +#' at random among them and 300 held out as a block, which leaves a gap in +#' the layer. Over the held-out observations of all layers, the interval at +#' `obs_level = 0.90` held 91.5 percent of those with a `dist_ratio` below +#' 1, 89.2 percent from 1 to 2, 83.9 percent from 2 to 4, 77.9 percent from +#' 4 to 8 and 69.5 percent above 8. It held 89.6 percent of the observations +#' held out at random and 75.1 percent of those in the block. A second +#' simulation, on fields whose level jumps at boundaries, gave this +#' function's interval to held-out observations; "Intervals: which one +#' answers which question" in [summarize_by_cell()] gives its coverage, which +#' in cells of one training observation fell short of `obs_level` on one kind +#' of field. +#' +#' @section Without the FNN package: +#' The function makes three nearest-neighbour searches: each location's +#' nearest scored location, each location's nearest seed, and each scored +#' location's nearest other one (for the spacing). With \pkg{FNN} each uses +#' a kd-tree. Without it each compares every pair, and a search that would +#' compare more than `getOption("spatialkit.exact_pairs_max", 2e9)` pairs +#' stops the call first, with an error of class `spatialkit_work_limit` +#' that names the search (the fields `work`, `limit` and `what`). The search +#' for the spacing does not depend on the number of locations asked for: +#' above about 44,700 distinct scored locations the call stops without +#' \pkg{FNN} however few they are. The result is the same with and without +#' the package. +#' +#' @param newdata The locations: an sf layer. A feature that is not a point +#' is reduced to one with [`coerce_to_points(, "auto")`][coerce_to_points]. +#' No column of it is read. With no CRS while `points` has one, the call +#' stops. +#' @param values The [summarize_by_cell()] result for `points`. It must hold +#' the ID column and a cell value of `response_var`: the pooled value +#' (`estimate = "pooled"`) or the mean (the default `agg_funs`). With +#' `seeds = NULL` it must also carry the cell polygons, which it does when +#' it was made with `cells_sf`. +#' @param points The assigned layer `values` was computed from: an sf layer +#' with the ID column and `response_var`, and at least one scored row. +#' @param response_var Name of the summarised column wanted: the response, +#' or a predictor. +#' @param id_col Name of the ID column, found as [summarize_by_cell()] finds +#' it: when `points` has no column of that name, the first of `"poly_id"`, +#' `"polygon_id"` and `"cell_id"` it has. It cannot have the name of +#' another column of the result (`value`, `estimate`, `obs_lo`, `obs_hi`, +#' `filled`, `filled_from`, `dist_nearest`, `dist_ratio`). +#' @param seeds `NULL`, or the seeds the cells were built on: an sf POINT +#' layer with a column named as the ID column that gives each seed's cell. +#' For cells from `tess <- build_tessellation(seeds)` that is +#' `seeds$cell_id <- tess$index` when the ID column is `"cell_id"`, after +#' which a seed outside a boundary that is not convex needs its cell's ID +#' (see "Seeds outside the boundary"). Two +#' seeds at different locations with one ID are an error; seeds that share +#' a location share its cell, as `index` gives them. `NA` marks a seed +#' without a cell. +#' +#' @return A data frame with one row per row of `newdata`, in its order: +#' \describe{ +#' \item{the ID column}{The cell the location lies in, under the name of +#' the ID column; `NA` for a location in no cell.} +#' \item{`value`}{The cell's value, or for a filled row the value of the +#' cell in `filled_from`.} +#' \item{`estimate`}{`"pooled"` or `"mean"`: which value of the summary +#' `value` is.} +#' \item{`obs_lo`, `obs_hi`}{The interval for one observation, when +#' `values` holds it.} +#' \item{`filled`}{`TRUE` when the location has no cell, or its cell +#' neither a scored row nor a value, and the value is that of the cell +#' of the nearest scored row.} +#' \item{`filled_from`}{For a filled row, the ID of the cell the value +#' came from; `NA` otherwise.} +#' \item{`dist_nearest`}{Distance to the nearest location of a scored +#' row, in the units of the working CRS.} +#' \item{`dist_ratio`}{`dist_nearest` over the spacing; `NA` when the +#' scored rows sit on one location.} +#' } +#' A row of `newdata` with an empty geometry, or with a coordinate that is +#' not finite or lies beyond 1e150, has `NA` in every column. The two ID +#' columns have the class of the ID column of `values`; when a cell that +#' `values` has no row for has an ID that class cannot hold (a string +#' beside numbers), both are character. +#' +#' What produced the frame is in `attr(, "values_at")`, a list of class +#' `"spatialkit_values_at"` with a print method: `assignment` (`"seeds"` +#' or `"polygons"`), `crs` (the working CRS), `column` (`response_var`), +#' `estimate`, `obs_level` (the level of the interval columns; `NULL` +#' without them, and `NA` when `values` holds them and no longer says at +#' what level), `n` (the scored rows), `locations` (their distinct +#' locations), `spacing` (what `dist_ratio` divides by; `NA` with one +#' location), +#' `filled` (how many rows of `newdata` were filled) and `count_rule` (the +#' summary's record of how the cell count was set, or `NULL`). It describes +#' the call: a subset of the frame's rows keeps it as it is. +#' +#' The function raises no classed warning of its own. It passes on what +#' [coerce_to_points()], a CRS transformation and +#' [assign_features_to_polygons()] raise, but for one warning: the one +#' that function raises when no location at all falls in a polygon is +#' neither raised nor logged, since every such row has `filled = TRUE`, +#' which says the same row by row. +#' @examples +#' library(sf) +#' set.seed(1) +#' n <- 400 +#' east <- runif(n, 0, 1e4) +#' north <- runif(n, 0, 1e4) +#' all_pts <- st_as_sf( +#' data.frame(x = 5e5 + east, y = 5e6 + north, +#' income = 30 + 5 * sin(east / 2000) + 5 * cos(north / 1500) + +#' rnorm(n)), +#' coords = c("x", "y"), crs = 32632 +#' ) +#' pts <- all_pts[1:350, ] +#' newpts <- all_pts[351:400, ] +#' +#' # The count from a size, the cells, the observations in them, the values, +#' # all at the defaults: pooled values at 4.5 observations per cell. +#' prof <- resolution_profile(pts, "income") +#' sel <- select_resolution(prof) +#' seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts) +#' tess <- build_tessellation(seeds, method = "voronoi") +#' asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id") +#' out <- summarize_by_cell(asg, "income", id_col = "cell_id", +#' cells_sf = tess$cells, obs_level = 0.90) +#' +#' # The value at other locations, each placed in the cell of its nearest +#' # seed. `tess$index` gives the cell of each seed. +#' seeds$cell_id <- tess$index +#' at <- cell_values_at(newpts, out, asg, "income", id_col = "cell_id", +#' seeds = seeds) +#' head(at) +#' attr(at, "values_at") +#' +#' # Without the seeds a location is placed in the polygon that holds it. One +#' # beyond the layer's edge lies in no polygon: it is filled from the cell of +#' # the nearest observation, and `dist_ratio` says how far that is. +#' beyond <- st_sf(geometry = st_sfc(st_point(c(5e5 + 2e4, 5e6 + 5e3)), crs = 32632)) +#' cell_values_at(rbind(st_sf(geometry = st_geometry(newpts[1:2, ])), beyond), +#' out, asg, "income", id_col = "cell_id") +#' @family aggregation +#' @seealso [summarize_by_cell()], which computes `values`; +#' [build_tessellation()], whose `index` gives each seed's cell; +#' [area_of_applicability()] and [fold_separation()] for where a +#' prediction applies. +#' @export +cell_values_at <- function(newdata, values, points, response_var, id_col = "poly_id", + seeds = NULL) { + # ---- the arguments --------------------------------------------------------- + if (!inherits(newdata, "sf")) + stop("cell_values_at(): `newdata` must be an sf object.", call. = FALSE) + if (!inherits(points, "sf")) + stop("cell_values_at(): `points` must be an sf object.", call. = FALSE) + if (!is.data.frame(values)) + stop("cell_values_at(): `values` must be the summarize_by_cell() result for ", + "`points` (a data frame).", call. = FALSE) + if (!is.character(response_var) || length(response_var) != 1L || + is.na(response_var) || !nzchar(response_var)) + stop("cell_values_at(): `response_var` must be a single column name (a character ", + "string).", call. = FALSE) + if (!is.character(id_col) || length(id_col) != 1L || is.na(id_col) || !nzchar(id_col)) + stop("cell_values_at(): `id_col` must be a single column name (a character string).", + call. = FALSE) + + # The ID column, found in `points` as summarize_by_cell() finds it; the + # summary's own ID column carries that name. + rows <- sf::st_drop_geometry(points) + id_candidates <- unique(c(id_col, "poly_id", "polygon_id", "cell_id")) + id_found <- id_candidates[id_candidates %in% names(rows)] + if (!length(id_found)) + stop("cell_values_at(): could not find an ID column in `points`. Looked for: ", + paste(id_candidates, collapse = ", "), ".", call. = FALSE) + id_col <- id_found[[1L]] + if (!(id_col %in% names(values))) + stop(sprintf(paste0("cell_values_at(): `values` has no ID column '%s', the ID column ", + "of `points`; it must be the summarize_by_cell() result for ", + "`points`."), id_col), call. = FALSE) + # The frame returned names its first column after the ID column, so that + # name cannot be another column's. + reserved <- c("value", "estimate", "obs_lo", "obs_hi", "filled", "filled_from", + "dist_nearest", "dist_ratio") + if (id_col %in% reserved) + stop(sprintf(paste0("cell_values_at(): the ID column is named '%s', which is a column ", + "of the result (%s). Rename it in `points`, `values` and `seeds`."), + id_col, paste(reserved, collapse = ", ")), call. = FALSE) + if (!(response_var %in% names(rows))) + stop(sprintf("cell_values_at(): `points` has no column '%s'.", response_var), + call. = FALSE) + + cols <- .values_at_columns(names(values), response_var) + if (is.null(cols)) { + # The names of the role the column has in `values`: a predictor's when the + # summary holds another statistic of it as a predictor and none as the + # response, the response's otherwise. + of_it <- endsWith(names(values), paste0("_", response_var)) + p <- if (any(of_it & startsWith(names(values), "pred_")) && + !any(of_it & startsWith(names(values), "resp_"))) "pred_" else "resp_" + stop(sprintf(paste0("cell_values_at(): `values` has no cell value of '%s' (neither ", + "`..pooled_%s` nor `%s`). Summarise it with summarize_by_cell() ", + "first, with the mean in `agg_funs` or with estimate = \"pooled\"."), + response_var, paste0(p, response_var), + paste0(p, "mean_", response_var)), call. = FALSE) + } + + by_seeds <- !is.null(seeds) + if (!by_seeds) { + polygons <- inherits(values, "sf") && nrow(values) > 0L && + all(sf::st_geometry_type(values, by_geometry = TRUE) %in% c("POLYGON", "MULTIPOLYGON")) + if (!polygons) + stop(sprintf(paste0("cell_values_at(): `values` carries no cell polygons, so a ", + "location cannot be placed in a cell. Build `values` with ", + "`cells_sf`, or pass the seeds the cells were built on as ", + "`seeds` (seeds$%s <- tess$index)."), id_col), call. = FALSE) + } else { + if (!inherits(seeds, "sf") || !(id_col %in% names(sf::st_drop_geometry(seeds))) || + !all(sf::st_geometry_type(seeds, by_geometry = TRUE) == "POINT")) + stop(sprintf(paste0("cell_values_at(): `seeds` must be an sf POINT layer with a ", + "column '%s' that gives each seed's cell; for cells from ", + "build_tessellation(seeds), set seeds$%s <- tess$index."), + id_col, id_col), call. = FALSE) + seed_ids <- .id_as_character(seeds[[id_col]]) + # Seeds at different locations with one ID are refused, and counted: every + # seed whose ID another seed elsewhere carries. Seeds on one location + # are not: build_tessellation() gives them one cell, and `index` repeats + # its ID for each of them. + shared <- unique(seed_ids[duplicated(seed_ids) & !is.na(seed_ids)]) + if (length(shared)) { + at_seed <- sf::st_coordinates(seeds)[, 1:2, drop = FALSE] + among <- which(seed_ids %in% shared) + first <- among[match(seed_ids[among], seed_ids[among])] + apart <- !((at_seed[among, 1L] == at_seed[first, 1L] & + at_seed[among, 2L] == at_seed[first, 2L]) %in% TRUE) + twice <- sum(seed_ids[among] %in% seed_ids[among][apart]) + if (twice > 0L) + stop(sprintf(paste0("cell_values_at(): %d seeds have the cell of another in ", + "`seeds$%s`; each seed stands for one cell. Set the column ", + "from the tessellation built on these seeds ", + "(seeds$%s <- tess$index)."), + twice, id_col, id_col), call. = FALSE) + } + } + + points_crs <- sf::st_crs(points) + if (is.na(sf::st_crs(newdata)) && !is.na(points_crs)) + stop("cell_values_at(): `newdata` has no CRS and `points` has one; set it with ", + "sf::st_set_crs() so the locations can be placed.", call. = FALSE) + + # ---- 1. the working CRS ---------------------------------------------------- + # The record's, else the pooled record's, each when it is a projected CRS; + # else what the summary's own rule gives for `points`. + rule <- .count_rule_get(values) + pooled <- attr(values, "pooled") + measured <- function(crs) + inherits(crs, "crs") && !is.na(crs) && !isTRUE(sf::st_is_longlat(crs)) + crs_given <- if (!is.null(rule) && measured(rule$crs)) rule$crs + else if (is.list(pooled) && measured(pooled$crs)) pooled$crs + else NULL + at_rows <- .pooled_xy(points, crs_given) + crs <- at_rows$crs + # Points without a CRS whose coordinates the step above took for lon/lat + # have moved; a layer without a CRS beside them is read the same way. + as_lonlat <- FALSE + if (is.na(points_crs) && !is.na(crs) && nrow(points) > 0L) { + raw <- .values_at_xy(suppressWarnings(.values_at_points(points))) + as_lonlat <- isTRUE(any(at_rows$xy != raw, na.rm = TRUE)) + } + + # ---- 2. the scored rows and their distinct locations ----------------------- + y <- rows[[response_var]] + row_id <- rows[[id_col]] + xy <- at_rows$xy + scored <- is.numeric(y) & is.finite(y) & !is.na(row_id) & + is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + n_scored <- sum(scored) + if (n_scored == 0L) + stop(sprintf(paste0("cell_values_at(): `points` has no row with a value of '%s', a ", + "cell and a location."), response_var), call. = FALSE) + sx <- xy[scored, 1L] + sy <- xy[scored, 2L] + sid <- row_id[scored] + # The cells in the order of their IDs, and the rows by location and then by + # cell: the first row of a location is the one in the first of those cells. + cells <- unique(sid) + cells <- cells[order(cells, method = "radix")] + gi <- match(sid, cells) + o <- order(sx, sy, gi) + sx <- sx[o]; sy <- sy[o] + first <- c(TRUE, sx[-1L] != sx[-n_scored] | sy[-1L] != sy[-n_scored]) + ux <- sx[first] + uy <- sy[first] + U <- length(ux) + u_cell <- .id_as_character(cells)[gi[o][first]] + + # ---- the locations asked for ----------------------------------------------- + m <- nrow(newdata) + where <- .values_at_points(newdata) + placed <- .values_at_place(where, "newdata", "locations", crs, points_crs, as_lonlat) + q <- .values_at_xy(placed) + live <- which(is.finite(q[, 1L]) & is.finite(q[, 2L])) + qx <- q[live, 1L] + qy <- q[live, 2L] + + if (by_seeds) { + seed_xy <- .values_at_xy(.values_at_place(.values_at_points(seeds), "seeds", "seeds", + crs, points_crs, as_lonlat)) + seed_at <- which(is.finite(seed_xy[, 1L]) & is.finite(seed_xy[, 2L])) + } + + # ---- the bound on the exact searches ---------------------------------------- + # All three before any of them starts. The third does not depend on the + # locations asked for. + use_fnn <- .has_backend("FNN") + if (!use_fnn) { + limit <- .exact_pairs_max() + n_loc <- function(k) sprintf("%s location%s", format(k), if (k == 1L) "" else "s") + .work_guard(as.numeric(length(live)) * U, limit, what = "nearest scored location", + caller = "cell_values_at", + search = sprintf("finding the nearest of %d scored location%s for %s", U, + if (U == 1L) "" else "s", n_loc(length(live)))) + if (by_seeds) + .work_guard(as.numeric(length(live)) * length(seed_at), limit, what = "nearest seed", + caller = "cell_values_at", + search = sprintf("finding the nearest of %d seed%s for %s", + length(seed_at), if (length(seed_at) == 1L) "" else "s", + n_loc(length(live)))) + if (U > 1L) + .work_guard(as.numeric(U) * U, limit, what = "spacing", caller = "cell_values_at", + search = sprintf(paste0("the spacing of the scored rows (the nearest other ", + "of each of %d scored locations)"), U)) + } + + # ---- 3. the cell of a location ---------------------------------------------- + cell <- rep(NA_character_, length(live)) + if (by_seeds) { + if (length(live) && length(seed_at)) { + # Seeds that are the centres the profile scored, in any order, are + # searched at the centres as the record holds them and in its order, so + # a location the same distance from two goes where the profile and the + # assignment put it, whatever rounding a change of CRS brought to the + # seeds. Each centre takes the ID of the seed that is it. + as_cen <- .values_at_centres(rule, seed_xy, crs, use_fnn) + if (is.null(as_cen)) { + if (!is.null(.scored_centres(rule))) + .log_info(paste0("cell_values_at(): the %d seeds are not the %d centres the ", + "summary's record holds, so they are searched as given, and a ", + "location the same distance from two seeds takes the one that ", + "comes first in `seeds`."), + nrow(seed_xy), nrow(.scored_centres(rule))) + j <- .values_at_nearest(qx, qy, seed_xy[seed_at, 1L], seed_xy[seed_at, 2L], use_fnn) + cell <- seed_ids[seed_at][j] + } else { + cen <- as_cen$centres + j <- .values_at_nearest(qx, qy, cen[, 1L], cen[, 2L], use_fnn) + cell <- seed_ids[as_cen$seed[j]] + } + } + } else if (length(live) && !all(is.na(values[[id_col]]))) { + # The assignment is given the points and no column of `newdata`, so none + # can collide with the ID column, and the cells' polygons with their IDs + # and no other column or class of `values`. A row of `values` without + # an ID is no cell. + feat <- where[live, , drop = FALSE] + has_id <- !is.na(values[[id_col]]) + cells_at <- sf::st_sf( + stats::setNames(data.frame(values[[id_col]][has_id], stringsAsFactors = FALSE), id_col), + geometry = sf::st_geometry(values)[has_id]) + # With the summary's record of the count, which the rows were assigned + # with: a location on the edge between two cells the profile scored goes + # where the profile put such a row. + cells_at <- .count_rule_put(cells_at, rule) + # `frame` is the CRS the coordinates of `points` are read in, which is + # where the rows were assigned from. Points without a CRS are given it + # beside polygons that carry one, and not left for the assignment to + # stamp with the polygons' CRS. Polygons without a CRS take the CRS of + # the features handed to that function, so the points go there in + # `frame`, as the rows did, whatever CRS `newdata` arrived in. + frame <- if (!is.na(points_crs)) points_crs + else if (as_lonlat) sf::st_crs(4326) else crs + if (is.na(sf::st_crs(feat))) { + if (!is.na(sf::st_crs(cells_at)) && !is.na(frame)) feat <- sf::st_set_crs(feat, frame) + } else if (is.na(sf::st_crs(cells_at)) && !is.na(frame) && sf::st_crs(feat) != frame) { + feat <- sf::st_transform(feat, frame) + } + # That function's warning that no feature falls in any polygon is neither + # raised nor logged: every such row is returned with filled = TRUE. Its + # other warnings pass. + answered <- .answer_for_classed("spatialkit_unassigned") + held <- tryCatch( + assign_features_to_polygons(feat, cells_at, polygon_id_col = id_col, + keep_unassigned = TRUE, quiet = TRUE), + finally = answered()) + if (nrow(held) != length(live)) + stop("cell_values_at(): the assignment returned ", nrow(held), " rows for ", + length(live), " locations.", call. = FALSE) + cell <- .id_as_character(held[[id_col]]) + } + + # ---- 5 and 6. the nearest scored row, and how far it is ---------------------- + near <- if (length(live)) .values_at_nearest(qx, qy, ux, uy, use_fnn) else integer(0) + dist <- sqrt((qx - ux[near])^2 + (qy - uy[near])^2) + spacing <- NA_real_ + if (U > 1L) { + other <- .nearest_location_search(cbind(ux, uy), seq_len(U), use_fnn, + caller = "cell_values_at") + spacing <- stats::median(sqrt((ux - ux[other])^2 + (uy - uy[other])^2)) + } + + # ---- 4 and 5. the value, the cell's own or the nearest scored row's ---------- + value_ids <- .id_as_character(values[[id_col]]) + val <- as.numeric(values[[cols$value]]) + row_of <- function(id) match(id, value_ids, incomparables = NA) + # Filled: no cell, or a cell with no value in `values` and no scored row. + # A cell that holds a scored row keeps what `values` has for it, be it NA. + filled <- is.na(val[row_of(cell)]) & !(cell %in% .id_as_character(cells)) + from <- ifelse(filled, u_cell[near], NA_character_) + taken <- row_of(ifelse(filled, from, cell)) + + # ---- the frame: one row per row of `newdata` --------------------------------- + whole <- function(x, na) { out <- rep(na, m); out[live] <- x; out } + ids <- .values_at_ids(c(whole(cell, NA_character_), whole(from, NA_character_)), + values[[id_col]]) + has_interval <- !is.null(cols$lo) + out <- data.frame(id = ids[seq_len(m)], + value = whole(val[taken], NA_real_), + estimate = whole(rep(cols$estimate, length(live)), NA_character_), + stringsAsFactors = FALSE) + if (has_interval) { + out$obs_lo <- whole(as.numeric(values[[cols$lo]])[taken], NA_real_) + out$obs_hi <- whole(as.numeric(values[[cols$hi]])[taken], NA_real_) + } + out$filled <- whole(filled, NA) + out$filled_from <- ids[m + seq_len(m)] + out$dist_nearest <- whole(dist, NA_real_) + out$dist_ratio <- whole(dist / spacing, NA_real_) + names(out)[1L] <- id_col + + obs_level <- if (!has_interval) NULL + else if (is.list(pooled) && is.numeric(pooled$obs_level) && + length(pooled$obs_level) == 1L) pooled$obs_level + else NA_real_ + attr(out, "values_at") <- structure( + list(assignment = if (by_seeds) "seeds" else "polygons", + crs = crs, + column = response_var, + estimate = cols$estimate, + obs_level = obs_level, + n = n_scored, + locations = U, + spacing = spacing, + filled = sum(filled), + count_rule = rule), + class = "spatialkit_values_at") + out +} + + +#' @export +print.spatialkit_values_at <- function(x, ...) { + label <- function(name) sprintf(" %-12s: ", name) + indent <- strrep(" ", 16L) + count <- function(k, what) + sprintf("%s %s%s", format(k), what, if (isTRUE(k == 1L)) "" else "s") + cat(sprintf("Cell values at other locations: %s, the %s\n", x$column, + if (identical(x$estimate, "pooled")) "pooled value" else "plain mean")) + cat(label("cell"), + if (identical(x$assignment, "seeds")) + "of the nearest seed (the Voronoi cell before its clip to the cover)" + else "the polygon of `values` that holds the location", + "\n", sep = "") + if (!is.null(x$obs_level)) + cat(label("interval"), + if (is.numeric(x$obs_level) && length(x$obs_level) == 1L && !is.na(x$obs_level)) + paste0(.level_text(x$obs_level), "% ") + else "", + "for ONE OBSERVATION (obs_lo, obs_hi), centred on the value\n", sep = "") + crs <- .fold_crs_label(x$crs) + cat(label("scored rows"), count(x$n, "row"), " at ", count(x$locations, "location"), + if (is.na(crs)) ", coordinates without a CRS" else paste0(", measured in ", crs), + "\n", sep = "") + cat(label("spacing"), + if (is.na(x$spacing)) + "not available: the scored rows sit on one location, so dist_ratio is NA" + else paste0(format(signif(x$spacing, 4)), ", the median distance from a scored ", + "location to the\n", indent, "nearest other; dist_ratio is ", + "dist_nearest over it"), + "\n", sep = "") + cat(label("filled"), + if (isTRUE(x$filled == 0L)) "no location" + else paste0(count(x$filled, "location"), if (isTRUE(x$filled == 1L)) " has" else " have", + " no cell with a value and ", + if (isTRUE(x$filled == 1L)) "takes" else "take", " that of\n", indent, + "the cell of the nearest scored row (filled_from)"), + "\n", sep = "") + rule <- x$count_rule + if (is.list(rule) && length(rule$cells) == 1L && length(rule$rule) == 1L) + cat(label("count"), count(rule$cells, "cell"), ", set by ", rule$rule, + " (the summary's record, in `count_rule`)\n", sep = "") + if (!is.null(x$obs_level)) + cat("Away from the observations no interval here is calibrated.\n") + invisible(x) +} diff --git a/R/count-rule.R b/R/count-rule.R new file mode 100644 index 00000000..6bdf20ad --- /dev/null +++ b/R/count-rule.R @@ -0,0 +1,718 @@ +# R/count-rule.R +# ----------------------------------------------------------------------------- +# The record of how a cell count was set +# ----------------------------------------------------------------------------- +# select_resolution() writes one list, `count_rule`, when the count is set on +# the path that names an estimate: the profile carries one, or the criterion +# is "size" or "loo". It says which rule set the count, for which estimate, +# and what the profile scored at that count. A selection from a profile +# without an estimate by "cp", "reliability", "elbow" or "moran_z" carries +# none, and neither does a count given as a number. +# +# The record travels as the attribute "count_rule": from the selection's +# seeds to the seeds a seeding function returns, to the cells built on them +# (and `params$count_rule` of the tessellation), to the layer assigned to the +# cells, to the summary. summarize_by_cell() reads it and checks two +# things: that it reports the estimate the count was chosen for, and that +# the cells and rows it is given are the ones the profile scored. + + +#' The rows a size divides, read off a profile's bounds +#' +#' The rows with a response when the profile had one and some row carried +#' it, every point otherwise: the number \code{resolution_profile()} divides +#' by \code{obs_per_cell}. +#' +#' @param bounds \code{attr(, "bounds")}, or \code{NULL} for an +#' object that has lost it (a column subset). +#' @return One integer; \code{NA} when \code{bounds} holds no count. +#' @keywords internal +#' @noRd +.count_rule_rows <- function(bounds) { + if (!is.list(bounds)) return(NA_integer_) + one <- function(v) is.numeric(v) && length(v) == 1L && is.finite(v) + if (one(bounds$n_response) && bounds$n_response > 0) return(as.integer(bounds$n_response)) + if (one(bounds$n) && bounds$n > 0) return(as.integer(bounds$n)) + NA_integer_ +} + + +#' A profile's value of one column at one level +#' +#' @param profile A \code{resolution_profile}, or a subset of one. +#' @param level The level (cell count). +#' @param column Name of the column. +#' @return One number; \code{NA} when the profile has no such column or no +#' such level. +#' @keywords internal +#' @noRd +.profile_at <- function(profile, level, column) { + if (!all(c("levels", column) %in% names(profile))) return(NA_real_) + at <- match(as.integer(level), as.integer(profile[["levels"]])) + if (is.na(at)) return(NA_real_) + as.numeric(profile[[column]])[at] +} + + +#' The centres a profile scored at one level +#' +#' The matrix \code{resolution_profile()} keeps in \code{attr(, "centres")} +#' for the level, which its estimate gave each scored row to by +#' \code{.nearest_centre()}, as it is: the coordinates in the profile's CRS +#' and the centres in the order they were numbered in. +#' +#' @param profile A \code{resolution_profile}. +#' @param level The level (cell count). +#' @return A two-column numeric matrix without dimnames, one row per centre; +#' \code{NULL} when the profile holds no centres at that level (a column +#' subset, which has lost them). +#' @keywords internal +#' @noRd +.profile_centres <- function(profile, level) { + cen <- attr(profile, "centres", exact = TRUE) + xy <- if (is.list(cen)) cen[[as.character(level)]] else NULL + if (!is.matrix(xy) || !is.numeric(xy) || nrow(xy) < 1L || ncol(xy) < 2L) return(NULL) + xy <- unname(xy[, 1:2, drop = FALSE]) + storage.mode(xy) <- "double" + xy +} + + +#' The centres a record sits beside +#' +#' @param rec A record of a count (\code{.count_rule_get()}), or \code{NULL}. +#' @return \code{rec$scored$centres} when the record says it sits beside the +#' centres the profile scored (\code{scored_cells} is \code{TRUE}) and holds +#' one finite centre per cell of the count, two at least, with a CRS object +#' (which may be \code{NA}); \code{NULL} otherwise, and then no point is +#' placed by the profile's rule. +#' @keywords internal +#' @noRd +.scored_centres <- function(rec) { + if (is.null(rec) || !isTRUE(rec$scored_cells) || !is.list(rec$scored) || + !inherits(rec$crs, "crs")) + return(NULL) + cen <- rec$scored$centres + if (!is.matrix(cen) || !is.numeric(cen) || ncol(cen) != 2L || nrow(cen) < 2L || + !identical(nrow(cen), as.integer(rec$cells)) || !all(is.finite(cen))) + return(NULL) + cen +} + + +#' The CRS the cells of a record's centres are drawn in +#' +#' @param rec A record of a count, or \code{NULL}. +#' @return The record's CRS when it sits beside the centres the profile +#' scored (\code{.scored_centres()}) and that CRS is a projected one; +#' \code{NULL} otherwise. +#' @keywords internal +#' @noRd +.scored_crs <- function(rec) { + if (is.null(.scored_centres(rec))) return(NULL) + crs <- rec$crs + if (is.na(crs) || isTRUE(sf::st_is_longlat(crs))) return(NULL) + crs +} + + +#' The nearest and the next nearest centre of every point +#' +#' @param x,y Coordinates of the points. +#' @param cx,cy Coordinates of the centres, two at least. +#' @param use_fnn Whether to use \pkg{FNN}. Without it the search is +#' exact, over every centre. +#' @return A list: \code{first}, the nearest centre of each point, and +#' \code{d1} and \code{d2}, the squared distances to it and to the next +#' nearest, both computed in R from the coordinates. +#' @keywords internal +#' @noRd +.two_nearest <- function(x, y, cx, cy, use_fnn = .has_backend("FNN")) { + if (isTRUE(use_fnn) && length(cx) > 16L) { + nn <- matrix(FNN::get.knnx(cbind(cx, cy), cbind(x, y), k = 2L)$nn.index, length(x), 2L) + a <- nn[, 1L]; b <- nn[, 2L] + da <- (x - cx[a])^2 + (y - cy[a])^2 + db <- (x - cx[b])^2 + (y - cy[b])^2 + swap <- db < da + return(list(first = ifelse(swap, b, a), d1 = pmin(da, db), d2 = pmax(da, db))) + } + d1 <- (x - cx[1L])^2 + (y - cy[1L])^2 + d2 <- rep(Inf, length(x)) + first <- rep.int(1L, length(x)) + for (j in seq_along(cx)[-1L]) { + d <- (x - cx[j])^2 + (y - cy[j])^2 + nearer <- d < d1 + d2 <- ifelse(nearer, d1, pmin(d2, d)) + d1[nearer] <- d[nearer] + first[nearer] <- j + } + list(first = first, d1 = d1, d2 = d2) +} + + +#' Which centre each seed is +#' +#' Seeds are the centres a record holds when they are as many, and each lies +#' at a different centre: within one part in a thousand of its distance from +#' the next nearest centre, or within \code{.edge_tol()} of the centres' +#' coordinates when that is more. The seeds a selection carries, and those a +#' seeding function returns for one, are the centres in the profile's order, +#' in the CRS of the points they were placed for; put back in the record's +#' CRS they have moved by the rounding of the two transformations, a few +#' millimetres at most (Lambert azimuthal equal-area across a continent), and +#' a thousandth of the distance between two centres is far more than that +#' for centres more than a few metres apart. Seeds in another order, sorted +#' by their cell for example, are matched all the same. Seeds placed by a +#' fit of their own lie metres from the centres and are not. +#' +#' @param xy Two-column matrix of the seeds' coordinates, in the record's +#' CRS. +#' @param cen The record's centres (\code{.scored_centres()}). +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return Integer vector, for each centre the row of \code{xy} that is it; +#' \code{NULL} when the seeds are not the centres. +#' @keywords internal +#' @noRd +.seeds_as_centres <- function(xy, cen, use_fnn = .has_backend("FNN")) { + if (is.null(cen) || !is.matrix(xy) || ncol(xy) < 2L) return(NULL) + K <- nrow(cen) + if (nrow(xy) != K || K < 2L || !all(is.finite(xy[, 1:2]))) return(NULL) + two <- .two_nearest(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L], use_fnn) + if (anyDuplicated(two$first)) return(NULL) + tol <- .edge_tol(c(range(cen[, 1L]), range(cen[, 2L]))) + if (!all(sqrt(two$d1) <= pmax(1e-3 * sqrt(two$d2), tol))) return(NULL) + of <- integer(K) + of[two$first] <- seq_len(K) + of +} + + +#' How far from an edge a point can lie and still be on it +#' +#' The corners of Voronoi cells are computed in floating point, so a point +#' the same distance from two centres can lie a little inside either cell. +#' Rounding grows with the size of the coordinates, so the margin is one +#' part in 1e10 of the largest coordinate of the layer: 0.44 mm at a UTM +#' northing of 4,400 km, far more than the rounding of the corners and far +#' less than the spacing of gridded locations. The cells +#' \code{create_voronoi_polygons()} draws on seeds that are the centres are +#' drawn around the centres as the record holds them +#' (\code{.seeds_as_centres()}), so rounding the seeds took on through +#' another CRS does not move their edges. +#' +#' @param bb A bounding box (\code{sf::st_bbox()}), in the CRS the distance +#' is taken in. +#' @return One positive number, in the units of that CRS. +#' @keywords internal +#' @noRd +.edge_tol <- function(bb) { + m <- suppressWarnings(max(abs(as.numeric(bb)), na.rm = TRUE)) + 1e-10 * max(1, if (is.finite(m)) m else 1) +} + + +#' Whether a level's cells beat one mean, for the profile's estimate +#' +#' The rule of \code{.no_structure()} on the numbers a profile with an +#' estimate keeps: the leave-one-out error at the level, that of one mean +#' for every scored row, and the F test of the cells against one mean. The +#' comparison is made only while the \code{loo} column is the one the +#' references were recorded with (\code{attr(, "estimate")$loo_levels}); a +#' profile whose column was edited has no reference. +#' +#' @param profile A \code{resolution_profile}. +#' @param level The level (cell count). +#' @param tol The margin by which the cells have to beat one mean. +#' @param n_searched The number of levels the level was chosen among. +#' @return A list: \code{structured}, \code{structure_p} and \code{beats} +#' as \code{.no_structure()} returns them, \code{loo} (the error at the +#' level) and \code{one_cell} (that of one mean). Every element is +#' \code{NA} for a profile without an estimate, without the column, or +#' whose column is not the one recorded. +#' @keywords internal +#' @noRd +.estimate_structure <- function(profile, level, tol, n_searched = 1L) { + none <- list(structured = NA, structure_p = NA_real_, beats = NA, + loo = NA_real_, one_cell = NA_real_) + est <- attr(profile, "estimate", exact = TRUE) + if (!is.list(est) || !all(c("levels", "loo") %in% names(profile))) return(none) + lv <- profile[["levels"]] + ref <- est$loo_levels + one <- est$loo_one_cell %||% NA_real_ + same <- length(one) == 1L && is.finite(one) && !is.null(ref) && + all(as.character(lv) %in% names(ref)) && + isTRUE(all.equal(unname(ref[as.character(lv)]), as.numeric(profile[["loo"]]))) + if (!same) return(none) + loo <- .profile_at(profile, level, "loo") + p <- if (is.null(est$f_p)) NA_real_ else unname(est$f_p[as.character(level)])[1L] + r <- .no_structure(loo, one, p, tol, n_searched = n_searched) + list(structured = r$structured, + structure_p = if (is.finite(r$structure_p)) r$structure_p else NA_real_, + beats = r$beats, loo = loo, one_cell = one) +} + + +#' The record of how a count was set +#' +#' Built by \code{select_resolution()}, which puts it in the selection as +#' \code{count_rule} and, marked as sitting beside the scored centres, on +#' the selection's seeds. +#' +#' @param profile The \code{resolution_profile} the count was read off. +#' @param rule The criterion applied: \code{"size"}, \code{"loo"}, +#' \code{"cp"}, \code{"reliability"}, \code{"elbow"} or \code{"moran_z"}. +#' @param cells The count chosen. +#' @param obs_per_cell_asked The size asked for; \code{NA} unless +#' \code{rule} is \code{"size"}. +#' @param structured Whether the cells at that count beat one mean for the +#' profile's estimate, for the \code{scored} list. +#' @param scored_cells Whether the centres the record sits beside are the +#' ones the profile scored: \code{NA} for a record that stands for a count +#' alone. +#' @return A list of class \code{spatialkit_count_rule} with the fields +#' \code{version}, \code{rule}, \code{estimate}, \code{cells}, +#' \code{obs_per_cell}, \code{obs_per_cell_asked}, \code{response}, +#' \code{n}, \code{n_points}, \code{n_fit}, \code{seed}, \code{features}, +#' \code{scored}, \code{partition}, \code{crs} and \code{scored_cells}. +#' \code{estimate} is the estimate the rule was computed for: the +#' profile's for \code{"size"} and \code{"loo"}, \code{"mean"} for +#' \code{"cp"}, which scores plain means, and \code{NA} for the other +#' rules. \code{scored} is \code{NULL} for a profile without an estimate. +#' Its last element, \code{centres}, is the matrix of the centres the +#' profile scored at the count, in \code{crs} and in the profile's order +#' (\code{NULL} when the profile no longer holds them): each scored row was +#' given to the nearest of them, a tie to the lower-numbered one, and +#' \code{assign_features_to_polygons()} and \code{cell_values_at()} read +#' them to place a point on the edge between two cells the same way. +#' @keywords internal +#' @noRd +.count_rule_new <- function(profile, rule, cells, obs_per_cell_asked = NA_real_, + structured = NA, scored_cells = NA) { + cells <- as.integer(cells) + bounds <- attr(profile, "bounds", exact = TRUE) + est <- attr(profile, "estimate", exact = TRUE) + has_est <- is.list(est) && !is.null(est$value) + int_of <- function(v) + if (is.numeric(v) && length(v) == 1L && is.finite(v)) as.integer(v) else NA_integer_ + n <- .count_rule_rows(bounds) + scored <- NULL + if (has_est) { + occupied <- if (is.null(est$cells)) NA_integer_ + else int_of(unname(est$cells[as.character(cells)])[1L]) + scored <- list( + estimate = as.character(est$value), + n = int_of(est$n), + cells = occupied, + loo = .profile_at(profile, cells, "loo"), + loo_se = .profile_at(profile, cells, "loo_se"), + loo_one_cell = as.numeric(est$loo_one_cell %||% NA_real_)[1L], + share_alone = .profile_at(profile, cells, "share_alone"), + own_weight = .profile_at(profile, cells, "own_weight"), + structured = as.logical(structured)[1L], + rows = as.character(est$rows %||% NA_character_)[1L], + centres = .profile_centres(profile, cells)) + } + part <- .partition_record(profile) + nstart <- attr(profile, "nstart", exact = TRUE) + crs <- attr(profile, "centres_crs", exact = TRUE) + structure(list( + version = 1L, + rule = rule, + estimate = if (rule %in% c("size", "loo")) + (if (has_est) as.character(est$value) else NA_character_) + else if (identical(rule, "cp")) "mean" + else NA_character_, + cells = cells, + obs_per_cell = if (is.na(n)) NA_real_ else n / cells, + obs_per_cell_asked = as.numeric(obs_per_cell_asked)[1L], + response = if (has_est && !is.null(est$response)) as.character(est$response)[1L] + else NA_character_, + n = n, + n_points = if (is.list(bounds)) int_of(bounds$n) else NA_integer_, + n_fit = if (is.list(bounds)) int_of(bounds$n_sample) else NA_integer_, + # A profile built with `seed = NULL` keeps none, and neither does one + # without an estimate. + seed = if (has_est && !is.null(est$seed)) est$seed else NA_integer_, + features = if (has_est && !is.null(est$features)) as.character(est$features)[1L] + else NA_character_, + scored = scored, + partition = c(part[.partition_fields()], + list(nstart = if (is.null(nstart)) NA_integer_ else nstart)), + crs = if (inherits(crs, "crs")) crs else sf::NA_crs_, + scored_cells = as.logical(scored_cells)[1L]), + class = "spatialkit_count_rule") +} + + +#' The record of a count a layer carries +#' +#' A record is read only when it is one this code can read: a list of class +#' \code{spatialkit_count_rule} whose \code{version} is \code{1L} and +#' which names one rule, one count and one estimate (which may be +#' \code{NA}). Anything else is treated as no record, so a record of +#' another version, or one a caller cut down, is not checked against and not +#' handed on. +#' +#' @param x Any object. +#' @return \code{attr(x, "count_rule")} when it is such a record; +#' \code{NULL} otherwise. +#' @keywords internal +#' @noRd +.count_rule_get <- function(x) { + rec <- attr(x, "count_rule", exact = TRUE) + if (!is.list(rec) || !inherits(rec, "spatialkit_count_rule")) return(NULL) + one <- function(v) length(v) == 1L + readable <- identical(rec$version, 1L) && + is.character(rec$rule) && one(rec$rule) && !is.na(rec$rule) && + is.numeric(rec$cells) && one(rec$cells) && !is.na(rec$cells) && + one(rec$estimate) && (is.character(rec$estimate) || is.na(rec$estimate)) + if (readable) rec else NULL +} + + +#' Put the record of a count on a layer +#' +#' @param x The layer: seeds, cells or assigned rows. +#' @param rec The record, or \code{NULL} for none. +#' @param scored_cells \code{NULL} to leave the record's \code{scored_cells} +#' as it is; otherwise its new value: \code{TRUE} beside the centres the +#' profile scored, \code{FALSE} beside other centres placed at that count. +#' @return \code{x}, with \code{attr(, "count_rule")} set when \code{rec} is +#' a record and left as it was otherwise. +#' @keywords internal +#' @noRd +.count_rule_put <- function(x, rec, scored_cells = NULL) { + if (is.null(rec)) return(x) + if (!is.null(scored_cells)) rec$scored_cells <- as.logical(scored_cells)[1L] + attr(x, "count_rule") <- rec + x +} + + +# The fields in which two records of one path agree, in the order they are +# compared: the first that differs is the one a warning names. The first +# five say which selection the cells were built from; `scored_cells` says +# whether they are that selection's scored cells or other cells built from +# its count (a lattice, seeds a function placed itself), so rows assigned to +# the one and summarised with the other differ in it and in nothing else. +.count_rule_same_fields <- c("rule", "estimate", "cells", "crs", "scored$loo", + "scored_cells") + +#' The first field in which two records differ +#' +#' A layer of assigned rows and the cells it is summarised with each carry +#' the record of the selection their cells were built from. When the two +#' selections are not the same one, the records differ in the rule, the +#' estimate, the count, the CRS or the leave-one-out error the profile +#' scored. When they are the same selection and the cells are not the same +#' cells (its scored cells beside a lattice sized by it), the records differ +#' in \code{scored_cells}. +#' +#' @param a,b Two records. +#' @return \code{NULL} when the two agree in all six; otherwise a list with +#' \code{field}, the name of the first that differs, and \code{a} and +#' \code{b}, its two values as text. +#' @keywords internal +#' @noRd +.count_rule_differs <- function(a, b) { + value <- function(rec, field) switch(field, + "crs" = rec$crs, + "scored$loo" = if (is.list(rec$scored)) rec$scored$loo else NULL, + rec[[field]]) + text <- function(v, field) { + if (is.null(v)) return("none") + if (identical(field, "crs")) + return(if (inherits(v, "crs") && !is.na(v)) as.character(v$input)[1L] else "NA") + if (is.numeric(v) && !is.integer(v)) return(format(v, digits = 8)) + v <- as.character(v)[1L] + if (is.na(v)) "NA" else v + } + same <- function(x, y, field) { + if (is.null(x) || is.null(y)) return(is.null(x) && is.null(y)) + if (identical(field, "crs")) { + if (!inherits(x, "crs") || !inherits(y, "crs")) return(identical(x, y)) + if (is.na(x) || is.na(y)) return(is.na(x) && is.na(y)) + return(isTRUE(x == y)) + } + if (identical(field, "scored$loo")) return(.same_loo(x, y)) + identical(x, y) + } + for (field in .count_rule_same_fields) { + x <- value(a, field); y <- value(b, field) + if (!same(x, y, field)) + return(list(field = field, a = text(x, field), b = text(y, field))) + } + NULL +} + + +#' Whether two leave-one-out errors are one number +#' +#' @param a,b Two errors. +#' @return \code{TRUE} when both are missing, or when they agree to a +#' relative tolerance of \code{.RECORD_TOL}; \code{FALSE} for a missing +#' error against a number. +#' @keywords internal +#' @noRd +.same_loo <- function(a, b) { + a <- as.numeric(a)[1L]; b <- as.numeric(b)[1L] + if (is.na(a) || is.na(b)) return(is.na(a) && is.na(b)) + abs(a - b) <= .RECORD_TOL * max(abs(a), abs(b)) +} + + +#' Check a summary against the record of its cells' count +#' +#' Three things, in this order, each with a warning of its own where it +#' fails. The warnings are raised here; the summary is returned as asked. +#' \enumerate{ +#' \item Two records. When the cells handed to the summary carry another +#' record than the assigned rows do, the rows were assigned to other +#' cells than those: class \code{spatialkit_cells_differ} with +#' \code{what = "record"}. The checks below run against the record of +#' the assigned rows. +#' \item The estimate. When the count was chosen for plain means or for +#' pooled values and the summary reports the other: class +#' \code{spatialkit_estimate_mismatch}. +#' \item The cells and the rows. The engine is run on the response with +#' the estimate the profile scored, and its scored rows, its occupied +#' cells and its leave-one-out error are compared with the record's, the +#' last to a relative tolerance of \code{.RECORD_TOL}. The first that +#' differs is named: class \code{spatialkit_cells_differ} with +#' \code{what} one of \code{"n"}, \code{"cells"} and \code{"loo"}. +#' } +#' The third is skipped, and the reason kept, where the record's numbers do +#' not describe the cells in hand or cannot be computed again: the profile +#' scored no estimate, or read the selection half; other cells were built +#' from the count, or the record does not say whose centres these are; the +#' response is another column, or was not summarised; the input has no +#' coordinates; the features summarised are not points; the fit was stopped +#' before an exact search above the limit (\code{.work_guard()}). +#' +#' Features that are not points are assigned by largest overlap, where the +#' profile scored each at one point in the cell of the nearest centre, so a +#' difference there says nothing about rows dropped. It is the layer +#' summarised that decides: the points of such features +#' (\code{coerce_to_points()}), assigned as points, are the rows the profile +#' scored, and are checked like any points, whatever the record's +#' \code{features} says of the layer profiled. +#' +#' @param rec The record the summary reads: that of the assigned rows, or of +#' the cells when the rows carry none. +#' @param other The record of the cells when the assigned rows carry one +#' too; \code{NULL} otherwise. +#' @param estimate The estimate the summary reports. +#' @param response_var The call's \code{response_var}, or \code{NULL}. +#' @param summarised The response columns the call summarised. +#' @param layer The layer summarised, as the caller passed it. +#' @param found A function of one estimate, \code{"mean"} or +#' \code{"pooled"}, that returns what the engine finds for the response on +#' the rows summarised: a list with \code{n} (scored rows), \code{cells} +#' (the cells that hold one), \code{loo} (the leave-one-out error of that +#' estimate) and \code{status} (\code{"work limit"} when the fit was +#' stopped). It is called only when the third check runs. +#' @return \code{rec} with one more element, \code{check}: a list with +#' \code{estimate} (\code{"match"}, \code{"mismatch"}, or \code{NA} for a +#' count chosen for neither estimate) and \code{cells} (\code{"match"}, +#' \code{"differ"}, or \code{"not checked: "}). \code{cells} is +#' \code{"differ"} also when the two records differ. +#' @keywords internal +#' @noRd +.count_rule_check <- function(rec, other = NULL, estimate, response_var, summarised, + layer, found) { + value_name <- function(est) if (identical(est, "pooled")) "pooled value" else "plain mean" + check <- list(estimate = NA_character_, cells = NA_character_) + + # ---- 1. Two records --------------------------------------------------------- + records_differ <- FALSE + if (!is.null(other)) { + d <- .count_rule_differs(rec, other) + if (!is.null(d)) { + records_differ <- TRUE + .warn_classed("spatialkit_cells_differ", + paste0("summarize_by_cell(): `assigned_points_sf` and `cells_sf` carry ", + "different count records (%s: %s against %s), so the rows were ", + "assigned to other cells than the `cells_sf` given. The record of ", + "the assigned layer is used."), + d$field, d$a, d$b, + data = list(what = "record", field = d$field, scored = d$a, found = d$b)) + } + } + + # ---- 2. The estimate -------------------------------------------------------- + chosen <- rec$estimate + if (is.character(chosen) && length(chosen) == 1L && chosen %in% c("mean", "pooled")) { + check$estimate <- if (identical(chosen, estimate)) "match" else "mismatch" + if (identical(check$estimate, "mismatch")) + .warn_classed("spatialkit_estimate_mismatch", + paste0("summarize_by_cell(): the number of cells (%d, set by %s) was ", + "chosen for the %s, and this summary reports the %s. %s"), + as.integer(rec$cells), rec$rule, value_name(chosen), value_name(estimate), + if (identical(chosen, "pooled")) + paste0("At this cell size plain means of small cells are noisy: pass ", + "estimate = \"pooled\", or choose the count for plain means ", + "(resolution_profile(estimate = \"mean\")).") + else + paste0("Pooled values are valid on these cells; the count that suits ", + "them is set by a size (criterion = \"size\")."), + data = list(chosen_for = chosen, reported = estimate, rule = rec$rule, + cells = as.integer(rec$cells))) + } + + # ---- 3. The cells and the rows ---------------------------------------------- + sc <- rec$scored + why <- if (!is.list(sc) || !isTRUE(sc$estimate %in% c("mean", "pooled"))) + "the profile scored no estimate" + else if (!identical(sc$rows, "all")) "the profile read the selection half" + else if (isFALSE(rec$scored_cells)) "other cells were built from this count" + else if (!isTRUE(rec$scored_cells)) "the record does not say whose centres these are" + else if (is.null(response_var)) "the response was not summarised" + else if (!identical(response_var, rec$response)) "the response is another column" + else if (!response_var %in% summarised) "the response was not summarised" + else if (!inherits(layer, "sf")) "the input has no coordinates" + else if (!all(sf::st_geometry_type(layer, by_geometry = TRUE) == "POINT")) + "the features are not points" + else NULL + if (is.null(why)) { + got <- found(sc$estimate) + if (identical(got$status, "work limit")) why <- "work limit" + } + if (!is.null(why)) { + check$cells <- if (records_differ) "differ" else paste("not checked:", why) + rec$check <- check + return(rec) + } + + int_of <- function(v) if (is.numeric(v) && length(v) == 1L) as.integer(v) else NA_integer_ + num_of <- function(v) if (is.numeric(v) && length(v) == 1L) as.numeric(v) else NA_real_ + a <- list(n = int_of(sc$n), cells = int_of(sc$cells), loo = num_of(sc$loo)) + b <- list(n = int_of(got$n), cells = int_of(got$cells), loo = num_of(got$loo)) + what <- if (!identical(a$n, b$n)) "n" + else if (!identical(a$cells, b$cells)) "cells" + else if (!.same_loo(a$loo, b$loo)) "loo" + else NULL + check$cells <- if (is.null(what) && !records_differ) "match" else "differ" + if (!is.null(what)) { + num <- function(v) if (is.na(v)) "NA" else format(v, digits = 6) + .warn_classed("spatialkit_cells_differ", + paste0("summarize_by_cell(): these are not the cells and rows the count ", + "was scored on (%s differs). The profile scored %d rows of '%s' in ", + "%d cells with a leave-one-out error of %s; here %d rows in %d ", + "cells give %s. %s"), + c(n = "the number of rows", cells = "the number of cells", + loo = "the leave-one-out error")[[what]], + a$n, rec$response, a$cells, num(a$loo), b$n, b$cells, num(b$loo), + if (identical(what, "loo")) + paste0("The same number of rows and cells was found, so rows sit in ", + "other cells than the profile put them in, or values changed: ", + "rows exactly on a boundary between two cells (gridded ", + "locations) can be assigned to the other cell, and coordinates ", + "that reached this CRS by another transformation can settle a ", + "tie between neighbouring cells the other way.") + else + paste0("Rows were dropped or moved between cells: points outside every ", + "cell, a boundary that clips the cells, a subset of the rows, or ", + "another layer."), + data = list(what = what, scored = a, found = b)) + } + rec$check <- check + rec +} + + +#' @export +print.spatialkit_count_rule <- function(x, ...) { + label <- function(name) sprintf(" %-12s: ", name) + indent <- strrep(" ", 16L) + one <- function(v) length(v) == 1L && !is.na(v) + # An error is written as print.spatialkit_pooled() writes it, so the two + # records of one summary show one number one way. + num <- function(v) if (is.numeric(v) && one(v)) sprintf("%.2e", v) else "NA" + count <- function(k, what) + sprintf("%s %s%s", format(k), what, if (isTRUE(k == 1L)) "" else "s") + + # ---- the count and what set it ---------------------------------------------- + asked <- x$obs_per_cell_asked + how <- c(if (identical(x$rule, "size") && is.numeric(asked) && one(asked)) + paste(.per_cell_text(asked), "asked"), + if (is.numeric(x$n) && one(x$n)) + sprintf("%s / %s = %.2f", count(x$n, "row"), count(x$cells, "cell"), + x$n / x$cells)) + cat(sprintf("Count: %s, set by %s%s\n", count(x$cells, "cell"), x$rule, + if (length(how)) sprintf(" (%s)", paste(how, collapse = "; ")) else "")) + + # ---- the estimate the rule was computed for --------------------------------- + cat(label("chosen for"), + if (identical(x$estimate, "pooled")) "the pooled value" + else if (identical(x$estimate, "mean")) "the plain mean" + # A size and the leave-one-out error score the profile's estimate, so + # without one the object the count was read off named none (a profile + # built without an estimate, or a column subset, which loses it). + else if (isTRUE(x$rule %in% c("size", "loo"))) + "no cell value: the profile names no estimate" + else sprintf("no cell value: %s scores none", x$rule), + "\n", sep = "") + + # ---- the cells -------------------------------------------------------------- + part <- x$partition + nstart <- part$nstart + starts <- .partition_label(part, if (is.numeric(nstart) && one(nstart)) nstart else NULL) + # The seed with every digit: 100000, not 1e+05. + seed <- if (is.numeric(x$seed) && one(x$seed)) format(x$seed, scientific = FALSE) + if (!is.null(seed)) + starts <- if (endsWith(starts, ")")) + paste0(substr(starts, 1L, nchar(starts) - 1L), "; seed ", seed, ")") + else sprintf("%s (seed %s)", starts, seed) + fitted <- if (!one(x$n_fit) || !one(x$n_points)) NULL + else if (x$n_fit < x$n_points) + sprintf("fitted to a subsample of %d of the %d points", + as.integer(x$n_fit), as.integer(x$n_points)) + else "fitted to every row" + half <- is.list(x$scored) && identical(x$scored$rows, "selection half") + whose <- if (isTRUE(x$scored_cells)) + paste0("these are the cells the profile scored", if (half) ", on half the rows") + else if (isFALSE(x$scored_cells)) + "other cells were built from this count: not the cells the profile scored" + else "the record stands for the count and sits beside no centres" + # What built the cells, wrapped where the density kind's settings make it + # long; whose cells they are starts a line of its own. + built <- strwrap(paste0(paste(c(if (identical(part$kind, "density")) "density" + else if (identical(part$kind, "kmeans")) "k-means", + starts, fitted), collapse = ", "), ";"), + width = 64) + cat(label("cells"), paste(built, collapse = paste0("\n", indent)), "\n", + indent, whose, "\n", sep = "") + + # ---- what the profile scored at the count ----------------------------------- + sc <- x$scored + if (is.list(sc)) + cat(label("scored"), + sprintf("loo %s on %s in %s (one cell: %s)%s\n", num(sc$loo), + if (half) sprintf("the %s of the selection half", count(sc$n, "row")) + else count(sc$n, "row"), + count(sc$cells, "cell"), num(sc$loo_one_cell), + if (is.numeric(sc$share_alone) && one(sc$share_alone)) + sprintf("; %.1f%% of rows alone", 100 * sc$share_alone) + else ""), + sep = "") + + # ---- the summary's checks, on a summary only -------------------------------- + ck <- x$check + if (is.list(ck)) { + skipped <- is.character(ck$cells) && startsWith(ck$cells, "not checked: ") + cat(label(if (skipped) "not checked" else "checked"), + if (identical(ck$cells, "match")) "the cells and rows summarised are the ones scored" + else if (identical(ck$cells, "differ")) + "the cells and rows summarised are not the ones scored" + else if (skipped) substring(ck$cells, nchar("not checked: ") + 1L) + else ck$cells, + "\n", sep = "") + if (identical(ck$estimate, "mismatch")) + cat(indent, + if (identical(x$estimate, "pooled")) + "the summary reports the plain mean, not the pooled value" + else "the summary reports the pooled value, not the plain mean", + "\n", sep = "") + } + invisible(x) +} diff --git a/R/cross-validation.R b/R/cross-validation.R index 48176c36..aba0ce7f 100644 --- a/R/cross-validation.R +++ b/R/cross-validation.R @@ -468,8 +468,8 @@ #' Turns \code{.cv_run_folds()}'s \code{fit_errors} into \code{" First error: #' "}, or \code{""} when no fold reported one. Without this, "all 5 folds #' failed" is the whole diagnosis a user gets when the backend package is not -#' installed. The word "brms" (or "GWmodel") never appears, even though -#' calling the fitter directly says so plainly. +#' installed. The word "brms" (or "sp", or "ranger") never appears, even +#' though calling the fitter directly says so plainly. #' #' @param res The list returned by \code{.cv_run_folds()}. #' @return Character(1); empty when there is nothing to add. @@ -807,7 +807,7 @@ # Fit model on training fold. # # The error TEXT is returned, not just logged: when every fold fails for the - # same reason -- overwhelmingly the "package 'brms'/'GWmodel' is required" + # same reason -- overwhelmingly the "package 'brms' is required" kind of # case -- the caller's "all N folds failed" warning is the only thing the # user sees, and without the cause it never names the missing backend. fit_obj <- try(fit_one(train_sf), silent = TRUE) @@ -1120,8 +1120,7 @@ #' parallel using \code{parallel::mclapply()}, which yields near-linear #' speedup on macOS and Linux. On Windows, forked parallelism is not #' available and execution falls back to sequential with a message. -#' \code{cv_gwr()} never asks for it: GWmodel's OpenMP code deadlocks in a -#' forked worker (see the comment there). +#' \code{cv_gwr()} never asks for it (see the comment there). #' #' @param dat_sf Prepared sf data (projected, clean). #' @param response_var Character(1). @@ -1184,6 +1183,11 @@ sample.int(.Machine$integer.max, n_folds) } + # The label each fold reports: its index in the original fold object (see + # .cv_fit_one_fold()), or its position here when it carries none. + labels <- vapply(remapped_folds, function(f) as.integer(f$fold_id %||% NA), integer(1)) + labels[is.na(labels)] <- seq_along(remapped_folds)[is.na(labels)] + fold_worker <- function(i) { # .with_seed() saves and restores .Random.seed, so seeding a fold never # leaks into the caller's RNG state. @@ -1191,6 +1195,11 @@ cleanup_i <- .with_seed(fold_seeds[i]) on.exit(cleanup_i(), add = TRUE) } + # Which fold is running, for a caller that collects the folds' warnings + # and names the folds they came from (.cv_collect_fold_warnings()). + outer_fold <- .cv_fold_state$fold + .cv_fold_state$fold <- labels[i] + on.exit(.cv_fold_state$fold <- outer_fold, add = TRUE) .cv_fit_one_fold( i = i, dat_sf = dat_sf, response_var = response_var, remapped_fold = remapped_folds[[i]], keep_idx = keep_idx, @@ -1206,24 +1215,27 @@ # conditions do not cross the fork, so fit_gwr_model()'s documented # integer-response warning, raised in every fold, reached nobody under # parallel = 2 while the sequential run showed all four. Collect them in - # the worker and re-raise in the parent, once per distinct message. + # the worker and re-raise in the parent, once per distinct message. A + # warning of one of the package's own classes comes back as the condition + # it was, class and fields kept, so that a handler written for the class + # sees it in a parallel run as in a sequential one (.cv_relay_warning()). # An error that escapes .cv_fit_one_fold() -- the documented shape errors # of `metrics` and `fold_info_fn` -- aborts a sequential run. In a worker # it became that fold's try-error, and the run carried on without it. It # is caught here, carried back, and raised again in the parent below. caught_worker <- function(i) { - msgs <- character(0) + caught <- list() res <- tryCatch( withCallingHandlers( fold_worker(i), warning = function(w) { - msgs <<- c(msgs, conditionMessage(w)) + caught[[length(caught) + 1L]] <<- .cv_relay_warning(w) invokeRestart("muffleWarning") }), error = function(e) list(escaped = conditionMessage(e))) # .cv_fit_one_fold() returns NULL for an unusable fold; NULL cannot # carry an attribute, so wrap the pair instead. - list(res = res, fold_warnings = msgs) + list(res = res, fold_warnings = caught) } # mc.preschedule = FALSE: one fork per fold. Prescheduled, mclapply() # hands each core a chunk of folds, copies one fold's try-error to every @@ -1236,9 +1248,21 @@ seq_along(remapped_folds), caught_worker, mc.cores = cores, mc.preschedule = FALSE ) - relayed <- unique(unlist(lapply(results, function(z) - if (!inherits(z, "try-error")) z$fold_warnings), use.names = FALSE)) - for (m in relayed) warning(m, call. = FALSE) + relayed <- do.call(c, lapply(results, function(z) + if (!inherits(z, "try-error")) as.list(z$fold_warnings))) + said <- character(0) + for (w in relayed) { + classed <- inherits(w, "condition") + # The two warnings in which predict() on a GWR counts locations are + # raised every time: the caller adds their counts up, and two folds can + # count the same. + if (!(classed && inherits(w, .gwr_counted_classes))) { + key <- if (classed) paste(class(w)[1L], conditionMessage(w), sep = "\r") else w + if (key %in% said) next + said <- c(said, key) + } + if (classed) warning(w) else warning(w, call. = FALSE) + } results <- lapply(results, function(z) if (inherits(z, "try-error")) z else z$res) esc <- which(vapply(results, function(z) is.list(z) && !inherits(z, "try-error") && !is.null(z$escaped), logical(1))) @@ -1263,8 +1287,6 @@ # fold_stat, and a note when its fold_info_fn failed. `$` (not `[[`) # throughout, because a successful fold's list has no "error" element and # `[[` would abort. - labels <- vapply(remapped_folds, function(f) as.integer(f$fold_id %||% NA), integer(1)) - labels[is.na(labels)] <- seq_along(remapped_folds)[is.na(labels)] status <- character(n_folds); msg <- character(n_folds) for (i in seq_len(n_folds)) { z <- results[[i]] @@ -1299,6 +1321,219 @@ } +# The fold a cross-validation is fitting and predicting at this moment (its +# label), while .cv_run_folds() runs it; NULL otherwise. +.cv_fold_state <- new.env(parent = emptyenv()) + +#' A fold's warning in the form a parallel worker hands back +#' +#' R conditions do not cross a fork, so a worker collects what its fold +#' raised and the parent raises it again. A warning of one of the package's +#' own classes (\code{spatialkit_*}) goes back as the condition itself, with +#' its fields and the fold's label as \code{fold}; its call is dropped, as +#' the package's own carry none. Any other warning goes back as its text: +#' a condition of another package can hold a call or a backtrace with the +#' fold's data in it. +#' +#' @param w The warning condition. +#' @return The condition, or its message. +#' @keywords internal +#' @noRd +.cv_relay_warning <- function(w) { + if (!any(startsWith(class(w), "spatialkit_"))) return(conditionMessage(w)) + w$call <- NULL + if (is.null(w$fold)) w$fold <- .cv_fold_state$fold + w +} + + +#' Collect the warnings a Bayesian fit raises in each fold +#' +#' \code{fit_bayesian_spatial_model()} raises up to four classed warnings +#' about a fit: more basis functions than the rows support +#' (\code{"spatialkit_gp_basis_size"}), a variogram range below what the +#' basis resolves (\code{"spatialkit_gp_resolution"}), a sampler that did not +#' converge (\code{"spatialkit_convergence"}) and a basis the fitted model +#' shows to be too coarse (\code{"spatialkit_gp_adequacy"}). None says which +#' fold it came from, and a cross-validation passed each on once per fold. +#' Wrapped in this they are muffled as they arrive and returned with the +#' label of the fold that raised them, for +#' \code{.cv_raise_fold_warnings()} to raise once per class. Each fold's +#' own line stays in the log. +#' +#' @param expr The code that runs the folds. +#' @return A list: \code{value}, the value of \code{expr}, and \code{said}, +#' one entry per warning with \code{class}, \code{fold}, \code{message} +#' and, for a convergence warning, \code{failed} (the checks that failed). +#' @keywords internal +#' @noRd +.cv_collect_fold_warnings <- function(expr) { + said <- list() + note <- function(w) { + # The fold a relayed warning was marked with in its worker, or the one + # running now. A warning from no fold is not this function's to hold + # back, and is passed on as it is. + fold <- as.integer(w$fold %||% .cv_fold_state$fold %||% NA_integer_)[1L] + if (is.na(fold)) return(invisible(NULL)) + said[[length(said) + 1L]] <<- list( + class = intersect(.cv_fold_warning_classes, class(w))[1L], + fold = fold, + message = conditionMessage(w), + failed = as.character(w$failed %||% character(0))) + invokeRestart("muffleWarning") + } + value <- withCallingHandlers(expr, + spatialkit_gp_basis_size = note, + spatialkit_gp_resolution = note, + spatialkit_convergence = note, + spatialkit_gp_adequacy = note) + list(value = value, said = said) +} + +.cv_fold_warning_classes <- c("spatialkit_gp_basis_size", "spatialkit_gp_resolution", + "spatialkit_convergence", "spatialkit_gp_adequacy") + +# The checks of the sampler, as fit_bayesian_spatial_model() names them on a +# convergence warning (`failed`) and as a message names them. +.cv_convergence_checks <- c(divergent = "divergent transitions", rhat = "R-hat", + ess = "effective sample size", ebfmi = "E-BFMI") + + +#' Raise the folds' Bayesian warnings once per class, naming the folds +#' +#' The other half of \code{.cv_collect_fold_warnings()}. One warning per +#' class, of that class, under the caller's name. Each names the folds, +#' carries them as \code{folds} and every fold's own text as +#' \code{fold_messages} (named by fold), and quotes the first fold's text. +#' +#' The convergence warning covers the folds that were scored: a fold whose +#' sampler did not converge is scored like any other, and that is what the +#' warning is about. \code{cv_bayes()} knows them from +#' \code{fold_metrics$convergence_ok}; a caller without that column knows +#' them from the warnings collected. +#' +#' @param caller Function name the messages carry. +#' @param said What \code{.cv_collect_fold_warnings()} collected. +#' @param scored Labels of the folds that produced scores. +#' @param n_run Number of folds run. +#' @param not_converged Labels of the scored folds whose fit reports +#' \code{convergence_ok = FALSE}, or \code{NULL} when the caller has no +#' such record. +#' @return \code{invisible(NULL)}; called for the warnings. +#' @keywords internal +#' @noRd +.cv_raise_fold_warnings <- function(caller, said, scored, n_run, + not_converged = NULL) { + of_class <- function(cl) { + x <- Filter(function(z) identical(z$class, cl), said) + x <- x[!duplicated(vapply(x, function(z) z$fold, integer(1)))] + x[order(vapply(x, function(z) z$fold, integer(1)))] + } + own_text <- function(z) sub("^fit_bayesian_spatial_model\\(\\): ", "", z$message) + texts_of <- function(x) stats::setNames( + vapply(x, function(z) z$message, character(1)), + vapply(x, function(z) as.character(z$fold), character(1))) + others <- function(x) if (length(x) > 1L) + " The log has the other folds' text, and the condition carries every fold's as `fold_messages`." + else "" + in_cv_bayes <- identical(caller, "cv_bayes") + + # ---- The sampler ---- + conv <- of_class("spatialkit_convergence") + conv_folds <- vapply(conv, function(z) z$fold, integer(1)) + bad <- sort(unique(as.integer( + if (is.null(not_converged)) intersect(conv_folds, scored) else not_converged))) + if (length(bad)) { + conv <- conv[conv_folds %in% bad] + failed <- stats::setNames(lapply(conv, function(z) z$failed), + vapply(conv, function(z) as.character(z$fold), character(1))) + failed <- failed[lengths(failed) > 0L] + any_failed <- unique(unlist(failed, use.names = FALSE)) + where <- if (in_cv_bayes) "`fit_args`" else "the learner's call" + detail <- if (length(failed) == length(bad)) { + # Every such fold said which checks failed: name them, and give the + # remedy of each check that failed somewhere. + remedy <- c( + if ("divergent" %in% any_failed) + sprintf("raise `control = list(adapt_delta = ...)` in %s for the divergent transitions", where), + if (any(c("rhat", "ess") %in% any_failed)) + sprintf("raise `iter` in %s for %s", where, + paste(c(if ("rhat" %in% any_failed) "R-hat", + if ("ess" %in% any_failed) "the effective sample size"), + collapse = " and ")), + if ("ebfmi" %in% any_failed) + paste0("a low E-BFMI comes from the shape of the posterior, so a longer ", + "warmup can help and otherwise the model or its priors need changing")) + sprintf(" The checks that failed: %s. The log has each fold's values.%s", + paste(sprintf("fold %s: %s", names(failed), vapply(failed, function(f) + paste(.cv_convergence_checks[intersect(names(.cv_convergence_checks), f)], + collapse = ", "), character(1))), collapse = "; "), + if (length(remedy)) { + r <- paste(remedy, collapse = "; ") + sprintf(" %s%s.", toupper(substr(r, 1L, 1L)), substr(r, 2L, nchar(r))) + } else "") + } else { + sprintf(paste0(" The log says which checks failed (divergent transitions, ", + "R-hat, effective sample size, E-BFMI): raise ", + "`control = list(adapt_delta = ...)` in %s for divergent ", + "transitions, `iter` for R-hat and the effective sample size."), + where) + } + .warn_classed( + "spatialkit_convergence", + paste0("%s(): the sampler did not converge in %d of %d fold(s) (fold %s); ", + "their scores enter `overall` like the others but come from ", + "unreliable posteriors.%s%s"), + caller, length(bad), length(scored), paste(bad, collapse = ", "), + if (in_cv_bayes) " fold_metrics$convergence_ok marks them." else "", + detail, + data = list(folds = bad, failed = failed, fold_messages = texts_of(conv))) + } + + # ---- The basis against the rows ---- + big <- of_class("spatialkit_gp_basis_size") + if (length(big)) + .warn_classed( + "spatialkit_gp_basis_size", + paste0("%s(): in %d of %d fold(s) (fold %s) the training rows are fewer ", + "than one per ten basis functions. Fold %d: %s%s"), + caller, length(big), n_run, + paste(vapply(big, function(z) z$fold, integer(1)), collapse = ", "), + big[[1L]]$fold, own_text(big[[1L]]), others(big), + data = list(folds = vapply(big, function(z) z$fold, integer(1)), + fold_messages = texts_of(big))) + + # ---- The basis against a variogram fitted before sampling ---- + res <- of_class("spatialkit_gp_resolution") + if (length(res)) + .warn_classed( + "spatialkit_gp_resolution", + paste0("%s(): in %d of %d fold(s) (fold %s) the Gaussian-process basis ", + "may not resolve the autocorrelation range. Fold %d: %s%s"), + caller, length(res), n_run, + paste(vapply(res, function(z) z$fold, integer(1)), collapse = ", "), + res[[1L]]$fold, own_text(res[[1L]]), others(res), + data = list(folds = vapply(res, function(z) z$fold, integer(1)), + fold_messages = texts_of(res))) + + # ---- The basis against the fitted model ---- + adq <- of_class("spatialkit_gp_adequacy") + if (length(adq)) + .warn_classed( + "spatialkit_gp_adequacy", + paste0("%s(): in %d of %d fold(s) (fold %s) the fitted model shows a ", + "Gaussian-process basis too coarse for the structure in the ", + "data%s. Fold %d: %s%s"), + caller, length(adq), n_run, + paste(vapply(adq, function(z) z$fold, integer(1)), collapse = ", "), + if (in_cv_bayes) "; fold_metrics$gp_adequacy has each fold's status" else "", + adq[[1L]]$fold, own_text(adq[[1L]]), others(adq), + data = list(folds = vapply(adq, function(z) z$fold, integer(1)), + fold_messages = texts_of(adq))) + invisible(NULL) +} + + #' The per-fold status of a cross-validation, dropped folds included #' #' \code{.remap_folds()} drops folds with an empty test set or fewer than two @@ -1434,53 +1669,110 @@ #' fitted to residuals, which is what removes the residual-variogram bias #' (Lark, Cullis and Welham 2006). The fit is #' \eqn{O(n^3)}, so it runs on at most \code{max_n} rows (a seeded random -#' subsample when there are more; exact duplicate locations are dropped first, -#' because a spatial correlation structure cannot take a zero distance between -#' distinct observations) and the trend coefficients are then applied to every -#' row. Several starting ranges are tried; the first fit that converges is -#' kept. +#' subsample when there are more) and the trend coefficients are then applied +#' to every row. +#' +#' A spatial correlation structure cannot take a zero distance between +#' distinct observations, so the fit uses one row a location. Where a +#' location has several rows (repeat visits), the one used is drawn at +#' random under \code{seed}. It is not "the first": the rows arrive sorted +#' by coordinates and then by the response, so the first row of a location is +#' its smallest response, and a fit to those is a fit to the minimum of each +#' location's visits (with four visits of unit noise the intercept came out +#' 1.04 low and the nugget at 0.41 for a truth of 1). It is not the mean of +#' the visits either: the mean of \eqn{m} visits carries a \eqn{1/m} share of +#' the variance between visits, and the nugget fitted to means is short by +#' that factor. The rows are put in a fixed order first (coordinates, then +#' the other columns), so neither draw depends on the order they came in. +#' +#' The REML likelihood of a short range on a large layer has a valley between +#' the optimum and the plateau where the fit is the same as with no +#' correlation, and a start in that valley can climb either side. So the +#' start is chosen from the likelihood, and the fit kept is the best of the +#' starts tried, by its REML log-likelihood, never the first that converges. +#' The profile REML log-likelihood is evaluated on a grid (range parameter: +#' the median nearest-neighbour distance of the rows used, times 1/4 to 64 in +#' powers of two, capped at a third of the extent; nugget proportion 0.05, +#' 0.3, 0.6 and 0.9), which costs one Cholesky factorisation a point, and +#' \code{gls()} starts from the best grid point. When that fit fails, or +#' ends below the grid's best value, the three extent-based starts (a tenth, +#' a thirtieth and a third of the extent) are fitted as well and the fit +#' with the largest log-likelihood is kept. A fit is not discarded for a +#' nugget near 0 or near 1: the likelihood decides. #' #' @param mf A model frame (trend formula already applied, incomplete rows #' excluded) with the projected coordinates in columns \code{.sac_x} and #' \code{.sac_y}. #' @param fml The trend formula. -#' @param extent A length scale of the layer, used to pick starting ranges. +#' @param extent A length scale of the layer, used to bound starting ranges. #' @return \code{NULL} when no fit converged, else a list with \code{beta} #' (named trend coefficients), \code{range} (the exponential range #' parameter), \code{nugget_prop}, \code{sigma2}, \code{n_used}, -#' \code{subsampled} and \code{pair_floor}: the 30th-shortest distance -#' between the rows the fit used (after the de-duplication and the -#' subsample), the distance a range has to reach for 30 pairs of those -#' points to lie inside it. +#' \code{subsampled}, \code{n_colocated} (the rows left out because another +#' row of their location was drawn), \code{pair_floor} (the 30th-shortest +#' distance between the rows the fit used, after the draw of one row a +#' location and the subsample: the distance a range has to reach for 30 +#' pairs of those points to lie inside it), \code{logLik} (the REML +#' log-likelihood of the fit kept), \code{logLik_null} (that of the same +#' trend with independent errors, \code{NA} when it could not be fitted) +#' and \code{n_fits} (how many starts were fitted). #' @keywords internal #' @noRd .reml_trend <- function(mf, fml, extent, max_n = 400L, seed = 123L) { if (!requireNamespace("nlme", quietly = TRUE)) return(NULL) d <- mf - # Duplicate locations: keep the first of each. + # A fixed order of the rows: coordinates, then every other column. Both + # draws below index rows, and gls() sums over them in order. + sort_cols <- c(".sac_x", ".sac_y", setdiff(names(d), c(".sac_x", ".sac_y"))) + ord <- tryCatch( + do.call(order, c(unname(lapply(d[sort_cols], function(x) + if (is.numeric(x) || is.logical(x)) as.numeric(x) else as.character(x))), + list(method = "radix"))), + error = function(e) NULL) + if (length(ord) == nrow(d)) d <- d[ord, , drop = FALSE] dup <- duplicated(d[, c(".sac_x", ".sac_y")]) - if (any(dup)) d <- d[!dup, , drop = FALSE] + if (any(dup) || nrow(d) > max_n) { + cleanup <- .with_seed(seed) + on.exit(cleanup(), add = TRUE) + } + # One row a location, drawn at random: the first row of each location in a + # random order of the rows. Nothing is drawn when no location repeats, so + # a layer of distinct locations gets the subsample it always got. + n_colocated <- 0L + if (any(dup)) { + n_repeated <- sum(!duplicated(d[dup, c(".sac_x", ".sac_y"), drop = FALSE])) + perm <- sample.int(nrow(d)) + keep <- sort(perm[!duplicated(d[perm, c(".sac_x", ".sac_y"), drop = FALSE])]) + n_colocated <- nrow(d) - length(keep) + d <- d[keep, , drop = FALSE] + .log_info(paste0("estimate_sac_range(): %d location(s) have more than one ", + "row. The REML fit uses one row a location, drawn at ", + "random under `seed` (%d of %d row(s)); the trend it fits ", + "is then removed from every row."), + n_repeated, nrow(d), nrow(d) + n_colocated) + } n <- nrow(d) subsampled <- FALSE if (n > max_n) { - cleanup <- .with_seed(seed) - on.exit(cleanup(), add = TRUE) d <- d[sample.int(n, max_n), , drop = FALSE] subsampled <- TRUE } - if (nrow(d) < 30L) return(NULL) + n <- nrow(d) + if (n < 30L) return(NULL) # The REML range is fitted to these point pairs, not to a binned variogram, # so the shortest range it can identify is set by how many of them are # close: 30 pairs is the usual minimum per lag (Journel and Huijbregts). - pd <- as.numeric(stats::dist(d[, c(".sac_x", ".sac_y")])) + D <- as.matrix(stats::dist(d[, c(".sac_x", ".sac_y")])) + pd <- D[upper.tri(D)] pair_floor <- if (length(pd) >= 30L) sort(pd, partial = 30L)[30L] else NA_real_ - rm(pd) - starts <- unique(pmax(extent * c(1 / 10, 1 / 30, 1 / 3), sqrt(.Machine$double.eps))) - for (r0 in starts) { + + # One gls() fit from a starting range and nugget proportion; NULL when it + # fails or its parameters are not usable. + fit_from <- function(r0, nug0) { fit <- tryCatch( withCallingHandlers( nlme::gls(fml, data = d, - correlation = nlme::corExp(value = c(r0, 0.1), + correlation = nlme::corExp(value = c(r0, nug0), form = ~ .sac_x + .sac_y, nugget = TRUE), method = "REML"), @@ -1490,18 +1782,88 @@ invokeRestart("muffleWarning") }), error = function(e) NULL) - if (is.null(fit)) next + if (is.null(fit)) return(NULL) cs <- try(stats::coef(fit$modelStruct$corStruct, unconstrained = FALSE), silent = TRUE) - if (inherits(cs, "try-error") || !all(is.finite(cs))) next + if (inherits(cs, "try-error") || !all(is.finite(cs))) return(NULL) rng <- as.numeric(cs[["range"]]); nug <- as.numeric(cs[["nugget"]]) s2 <- as.numeric(fit$sigma)^2 - if (!is.finite(rng) || rng <= 0 || !is.finite(s2) || s2 <= 0) next - return(list(beta = stats::coef(fit), range = rng, nugget_prop = nug, - sigma2 = s2, n_used = nrow(d), subsampled = subsampled, - pair_floor = pair_floor)) + ll <- suppressWarnings(as.numeric(stats::logLik(fit))) + if (!is.finite(rng) || rng <= 0 || !is.finite(s2) || s2 <= 0) return(NULL) + list(beta = stats::coef(fit), range = rng, nugget_prop = nug, sigma2 = s2, + logLik = if (length(ll) == 1L && is.finite(ll)) ll else NA_real_) } - NULL + + # The profile REML log-likelihood of (range, nugget proportion), up to a + # constant: trend and variance profiled out. NULL when the design cannot + # be built, and then every start is fitted and compared by gls()'s own + # log-likelihood. + X <- try(stats::model.matrix(fml, d), silent = TRUE) + y <- try(stats::model.response(stats::model.frame(fml, d)), silent = TRUE) + profile_ll <- NULL + if (!inherits(X, "try-error") && !inherits(y, "try-error") && + is.numeric(y) && nrow(X) == n && length(y) == n) { + profile_ll <- function(r, nug) { + R <- (1 - nug) * exp(-D / r) + diag(R) <- 1 + U <- tryCatch(chol(R), error = function(e) NULL) + if (is.null(U)) return(-Inf) + Xs <- backsolve(U, X, transpose = TRUE) + ys <- backsolve(U, y, transpose = TRUE) + qrx <- qr(Xs) + df <- n - qrx$rank + rss <- sum(qr.resid(qrx, ys)^2) + if (df < 1L || !is.finite(rss) || rss <= 0) return(-Inf) + rd <- abs(diag(qr.R(qrx)))[seq_len(qrx$rank)] + -0.5 * (df * log(rss / df) + 2 * sum(log(diag(U))) + 2 * sum(log(rd))) + } + } + + floor_r <- sqrt(.Machine$double.eps) + legacy <- unique(pmax(extent * c(1 / 10, 1 / 30, 1 / 3), floor_r)) + starts <- lapply(legacy, function(r) c(r, 0.1)) + grid_best <- -Inf + if (!is.null(profile_ll)) { + nn <- D; diag(nn) <- Inf + nn_med <- stats::median(apply(nn, 1L, min)) + r_grid <- unique(pmax(pmin(nn_med * 2^(-2:6), extent / 3), floor_r)) + g <- expand.grid(r = r_grid, nug = c(0.05, 0.3, 0.6, 0.9)) + g$ll <- mapply(profile_ll, g$r, g$nug) + if (any(is.finite(g$ll))) { + j <- which.max(g$ll) + grid_best <- g$ll[j] + starts <- c(list(c(g$r[j], g$nug[j])), starts) + } + } + + best <- NULL + n_fits <- 0L + for (s in starts) { + f <- fit_from(s[1L], s[2L]) + n_fits <- n_fits + 1L + if (!is.null(f)) { + # Fits are compared on one scale: the profile value at the fitted + # parameters where it is available, gls()'s log-likelihood otherwise. + f$score <- if (!is.null(profile_ll)) profile_ll(f$range, f$nugget_prop) + else f$logLik + if (is.null(best) || isTRUE(f$score > best$score)) best <- f + } + # The grid start is fitted first. When its fit ends at least as high as + # the grid's best value there is nothing a start in the valley could add. + if (n_fits == 1L && is.finite(grid_best) && !is.null(best) && + isTRUE(best$score >= grid_best - 0.01)) break + } + if (is.null(best)) return(NULL) + + ll_null <- tryCatch( + suppressWarnings(as.numeric(stats::logLik(nlme::gls(fml, data = d, method = "REML")))), + error = function(e) NA_real_) + list(beta = best$beta, range = best$range, nugget_prop = best$nugget_prop, + sigma2 = best$sigma2, n_used = n, subsampled = subsampled, + n_colocated = as.integer(n_colocated), + pair_floor = pair_floor, logLik = best$logLik, + logLik_null = if (length(ll_null) == 1L && is.finite(ll_null)) ll_null else NA_real_, + n_fits = n_fits) } @@ -1509,26 +1871,32 @@ #' #' A semivariance that falls as distance grows leaves the range unidentified: #' a model with a monotone rise to a sill is being fitted to a curve that has -#' none. The net change in \code{gamma} across the bins in the shorter half -#' of the lags, weighted by the pairs supporting each step, is compared with -#' the mean semivariance over those bins; a net fall of more than \code{tol} -#' of that mean is a decrease. Measured on 60 draws each (n = 250, tol = -#' 0.15): 0 of an exponential field, 2 percent of white noise, 98 percent of a -#' field with a periodic (hole-effect) component, 100 percent of a layer whose -#' variance differs between a dense cluster and the rest. The tolerance is -#' fixed while the noise in the short-lag bins grows as the sample shrinks, so -#' small samples trip it on ordinary fields: an exponential field with -#' effective range 300 and nugget 0.2 was refused in 7--9 of 60 draws at -#' n = 30, 3--6 at n = 50 and 0--1 at n = 100, and with range 150 in 15--16 -#' of 60 at n = 30. The refusal is the conservative outcome (geometric -#' blocks, with a warning), so it is left as it is. An unremoved trend -#' is \emph{not} what produces this shape. A trend makes the variogram rise -#' without reaching a sill, which the over-cutoff rejection catches, so the -#' message aimed at this case must not say "trend". +#' none. The net change in \code{gamma} across the lags in the shorter half +#' of the variogram, weighted by the pairs supporting each step, is compared +#' with the mean semivariance over those lags; a net fall of more than +#' \code{tol} of that mean is a decrease. +#' +#' The steps are taken between lag classes of equal width, as many as there +#' are bins in the shorter half. Bins that are already equally spaced are +#' their own classes. Geometrically spaced bins (\code{lags = "adaptive"} +#' in \code{estimate_sac_range()}) crowd the short lags, and their pair +#' counts grow with the square of the lag, so the pair weights would let the +#' last few steps speak for all of them; pooling the bins that share a class +#' (pair-weighted) puts the steps back on an even footing in distance, and a +#' variogram that rises steeply over its first bins and then levels off is +#' not called decreasing. +#' +#' The tolerance is fixed while the noise in the short-lag bins grows as the +#' sample shrinks, so small samples trip it on ordinary fields. The refusal +#' is the conservative outcome (geometric blocks, with a warning), so it is +#' left as it is. An unremoved trend is \emph{not} what produces this +#' shape. A trend makes the variogram rise without reaching a sill, which +#' the over-cutoff rejection catches, so the message aimed at this case must +#' not say "trend". #' #' @param vg An empirical variogram from \code{gstat::variogram()}. #' @return \code{TRUE} for a net decrease, \code{FALSE} otherwise (including -#' when fewer than \code{min_bins} bins fall in the shorter half). +#' when fewer than \code{min_bins} lag classes fall in the shorter half). #' @keywords internal #' @noRd .variogram_decreasing <- function(vg, frac = 0.5, min_bins = 4L, tol = 0.15) { @@ -1538,35 +1906,656 @@ drop = FALSE] if (nrow(vg) < min_bins) return(FALSE) vg <- vg[order(vg$dist), , drop = FALSE] - short <- vg[vg$dist <= frac * max(vg$dist), , drop = FALSE] - if (nrow(short) < min_bins) return(FALSE) - w <- pmin(utils::head(short$np, -1L), utils::tail(short$np, -1L)) + upper <- frac * max(vg$dist) + short <- vg[vg$dist <= upper, , drop = FALSE] + if (nrow(short) < min_bins || !(upper > 0)) return(FALSE) + # Equal-width lag classes over the shorter half; a class takes the + # pair-weighted mean of the bins in it. + k <- nrow(short) + cls <- pmin(k, pmax(1L, as.integer(ceiling(short$dist / (upper / k) - 1e-9)))) + np <- as.numeric(tapply(short$np, cls, sum)) + gamma <- as.numeric(tapply(short$np * short$gamma, cls, sum)) / np + if (length(np) < min_bins) return(FALSE) + w <- pmin(utils::head(np, -1L), utils::tail(np, -1L)) if (!any(w > 0)) return(FALSE) - net <- sum(w * diff(short$gamma)) / sum(w) * (nrow(short) - 1L) - scale <- stats::weighted.mean(short$gamma, short$np) + net <- sum(w * diff(gamma)) / sum(w) * (length(np) - 1L) + scale <- stats::weighted.mean(gamma, np) is.finite(net) && is.finite(scale) && scale > 0 && net < -tol * scale } +#' The k nearest other rows of a coordinate matrix +#' +#' \pkg{FNN}'s kd-tree when it is installed, a blocked brute-force search +#' otherwise. Meant for distinct locations: on exact duplicates the kd-tree +#' can drop a twin. +#' +#' @param xy Numeric matrix, two columns. +#' @param k Number of neighbours; capped at \code{nrow(xy) - 1}. +#' @return A list with \code{index} and \code{dist}, each \code{nrow(xy)} by +#' \code{k}, neighbours in order of distance. +#' @keywords internal +#' @noRd +.sac_knn <- function(xy, k) { + n <- nrow(xy) + k <- min(as.integer(k), n - 1L) + if (k < 1L) + return(list(index = matrix(integer(0), n, 0L), dist = matrix(numeric(0), n, 0L))) + if (requireNamespace("FNN", quietly = TRUE)) { + nn <- FNN::get.knn(xy, k = k) + return(list(index = matrix(nn$nn.index, n, k), dist = matrix(nn$nn.dist, n, k))) + } + idx <- matrix(0L, n, k); dst <- matrix(0, n, k) + for (s in seq(1L, n, by = 500L)) { + r <- s:min(n, s + 499L) + d <- sqrt(outer(xy[r, 1L], xy[, 1L], "-")^2 + outer(xy[r, 2L], xy[, 2L], "-")^2) + d[cbind(seq_along(r), r)] <- Inf + for (i in seq_along(r)) { + o <- order(d[i, ])[seq_len(k)] + idx[r[i], ] <- o + dst[r[i], ] <- d[i, o] + } + } + list(index = idx, dist = dst) +} + + +#' Lag boundaries spaced geometrically from the scale of the closest pairs +#' +#' The first bin runs from zero to the distance within which +#' \code{max(50, n / 4)} pairs of distinct locations lie (read from +#' nearest-neighbour distances, and capped at a quarter of the cutoff); the +#' rest are spaced geometrically from there to the cutoff. Equal bins out to +#' half the extent are far wider than the spacing of close pairs on a dense +#' layer, so structure shorter than one bin is invisible to them and is +#' counted as nugget. +#' +#' The size of the first bin is a trade. A larger one, \code{max(150, n / +#' 2)} pairs, is steadier on a layer with no structure, but the test for +#' spatial structure already refuses those (white noise at n = 300, 400 +#' draws: a finite range in 8 with this rule and in 10 with the larger bin, +#' a nugget under a tenth of the sill in 3 and in 2), and on structured +#' layers the larger bin loses the short lags the nugget is read from: with +#' an effective range of 60 on 300 points over a 1000 m square the nugget +#' came out under 0.05 (truth 0.2) in 24 of 34 identified fits against 16, +#' and at 80 points in 19 of 24 against 14 of 25. +#' +#' The ratio between boundaries is at least \code{sqrt(1 + min_np / m0)}, +#' which is what gives a ring \code{min_np} pairs when pairs grow with the +#' square of the distance, so the number of bins past the first is +#' \code{n_lags} or fewer, and at least 5. +#' +#' @param xy Coordinates of the points the variogram is computed on. +#' @param cutoff_dist The largest lag. +#' @param n_lags The most bins wanted past the first. +#' @return Increasing upper boundaries; the last is \code{cutoff_dist}. +#' @keywords internal +#' @noRd +.sac_lag_boundaries <- function(xy, cutoff_dist, n_lags = 15L, min_np = 30L) { + u <- unique(xy) + nu <- nrow(u) + m0 <- max(50, nrow(xy) / 4) + lo <- cutoff_dist / 4 + if (nu >= 3L) { + k <- min(max(10L, as.integer(ceiling(4 * m0 / nu)) + 2L), nu - 1L) + kd <- sort(as.numeric(.sac_knn(u, k)$dist)) + kd <- kd[is.finite(kd) & kd > 0] + # Each pair is listed from both of its ends. The margin keeps the pair + # the boundary was read from inside the first bin whatever the rounding + # of its distance, so the bins hold the same pairs in any unit. + if (length(kd)) + lo <- min(kd[min(length(kd), as.integer(ceiling(2 * m0)))] * (1 + 1e-9), + cutoff_dist / 4) + } + nb <- floor(log(cutoff_dist / lo) / log(sqrt(1 + min_np / m0))) + nb <- max(5L, min(as.integer(n_lags), as.integer(nb))) + exp(seq(log(lo), log(cutoff_dist), length.out = nb + 1L)) +} + + +#' Merge neighbouring variogram bins until each holds enough pairs +#' +#' From the shortest lag up, bins are pooled until the pool holds +#' \code{min_np} pairs; a short tail joins the bin before it. The pooled +#' semivariance and distance are the pair-weighted means, which is what the +#' classical estimator gives for the union of the bins, so no pair is lost. +#' +#' @param vg An empirical variogram (\code{np}, \code{dist}, \code{gamma}). +#' @return The variogram with merged rows, ordered by distance. +#' @keywords internal +#' @noRd +.sac_merge_bins <- function(vg, min_np = 30L) { + if (!is.data.frame(vg) || nrow(vg) < 2L) return(vg) + vg <- vg[order(vg$dist), , drop = FALSE] + if (all(vg$np >= min_np)) return(vg) + grp <- integer(nrow(vg)); g <- 1L; acc <- 0 + for (i in seq_len(nrow(vg))) { + grp[i] <- g + acc <- acc + vg$np[i] + if (acc >= min_np) { g <- g + 1L; acc <- 0 } + } + if (acc > 0 && g > 1L) grp[grp == g] <- g - 1L + np <- as.numeric(tapply(vg$np, grp, sum)) + out <- vg[!duplicated(grp), , drop = FALSE] + out$dist <- as.numeric(tapply(vg$np * vg$dist, grp, sum)) / np + out$gamma <- as.numeric(tapply(vg$np * vg$gamma, grp, sum)) / np + out$np <- np + rownames(out) <- NULL + out +} + + +#' Take the pairs at zero separation out of the first bin of a variogram +#' +#' \pkg{gstat} counts two rows that share a location as a pair in the first +#' lag bin, of the all-pairs variogram and of each directional one. Such a +#' pair is not at a lag. The semivariance jumps at zero (between visits to +#' one location it is the variance between visits; at any positive +#' separation the variation between locations is added), and a bin that +#' mixes the two sides of the jump gets a mean distance and a semivariance +#' in between, which a model reads as a rise from a low nugget. On 100 +#' locations visited 5 times, with independent location effects of variance +#' 1 and a variance between visits of 0.3, the fitted nugget was 0 and the +#' range twice the spacing of the locations, where the variogram at positive +#' lags is flat at 1.3. So the first bin keeps its pairs at positive +#' separations only, and the semivariance at zero separation is reported on +#' its own (\code{zero_lag_semivariance}). +#' +#' @param vg An empirical variogram from \code{gstat::variogram()}, rows by +#' increasing distance. +#' @param zero_pairs,zero_ss The number of pairs at zero separation and the +#' sum of their half squared differences, in the units of \code{vg$gamma}. +#' @param first_bound The upper edge of the first bin. +#' @return \code{vg} with the pairs taken out of its first row, or without +#' that row when it held no others. Unchanged when there are no such +#' pairs, or when the first row cannot hold them (fewer pairs than that, +#' or a remainder that would lie outside the bin or below zero), which +#' would mean \pkg{gstat} had not put them there. +#' @keywords internal +#' @noRd +.sac_drop_zero_lag <- function(vg, zero_pairs, zero_ss, first_bound) { + if (!is.data.frame(vg) || !nrow(vg) || !isTRUE(zero_pairs > 0)) return(vg) + np1 <- as.numeric(vg$np[1L]) + rest <- np1 - as.numeric(zero_pairs) + if (!is.finite(rest) || rest < 0) return(vg) + if (rest == 0) { + # Nothing but pairs at zero separation: there is no bin left. + if (isTRUE(vg$dist[1L] <= 1e-12 * first_bound)) vg <- vg[-1L, , drop = FALSE] + return(vg) + } + d <- np1 * vg$dist[1L] / rest + g <- (np1 * vg$gamma[1L] - zero_ss) / rest + if (!is.finite(d) || !is.finite(g) || d > first_bound * (1 + 1e-8) || + g < -1e-8 * abs(vg$gamma[1L])) return(vg) + vg$np[1L] <- rest + vg$dist[1L] <- d + vg$gamma[1L] <- max(g, 0) + vg +} + + +#' Fit a nugget-plus-structure variogram model by profile weighted least squares +#' +#' The fit behind \code{estimate_sac_range()}. The criterion is +#' \pkg{gstat}'s default for \code{fit.variogram()}: squared error weighted +#' by \eqn{N / h^2}. The lags are divided by the cutoff and the +#' semivariances by their pair-weighted mean first, so nothing in the fit +#' depends on a unit. For a trial range the nugget and the partial sill are +#' the two-parameter least-squares solution with both kept non-negative, +#' which is exact (the unconstrained solution, or one of the two edges). +#' The only search is therefore over the range: a logarithmic grid of +#' effective ranges from a quarter of the first lag to \code{upper} times +#' the cutoff, then a one-dimensional refinement around the best grid point. +#' There is no start value, no iteration limit and no singular fit, so the +#' same variogram gives the same model whatever the units, and a change in +#' the last bits of the data moves the result by about as much. +#' +#' The nugget can be given a floor above zero (\code{nugget_min}): the +#' semivariance of pairs at zero separation, where a layer has repeat visits +#' to its locations. That is the variance between visits, and the limit of +#' the semivariance from positive lags cannot lie under it. The solution +#' stays exact: the unconstrained one where it clears the floor, else the +#' better of the fit with the nugget on its floor and the constant (the +#' weighted mean semivariance, or the floor when that is higher). +#' +#' @param vg An empirical variogram (\code{np}, \code{dist}, \code{gamma}). +#' @param cutoff_dist The largest lag, in the units of \code{vg$dist}. +#' @param family \code{"Exp"} or \code{"Sph"}. +#' @param upper Top of the range grid, as a multiple of the cutoff. +#' @param nugget_min The least nugget allowed, in the units of +#' \code{vg$gamma}; 0 for none. +#' @return \code{NULL} when fewer than three bins hold pairs. Otherwise a +#' \pkg{gstat} variogram model. When no model with a range fits better +#' than a constant it is a pure nugget (one row); else a nugget row and a +#' structured row. Attributes: \code{converged} (\code{FALSE} when the +#' criterion is still falling at either end of the grid, so that the range, +#' the nugget and the sill are the grid's edge and not a minimum), +#' \code{SSErr} (the weighted squared error on the scaled axes) and +#' \code{gain} (the share of the constant model's weighted squared error +#' that the model removes). +#' @keywords internal +#' @noRd +.sac_fit_model <- function(vg, cutoff_dist, family = "Exp", upper = 4, + n_grid = 121L, nugget_min = 0) { + if (!is.data.frame(vg) || !all(c("np", "dist", "gamma") %in% names(vg))) + return(NULL) + ok <- is.finite(vg$gamma) & is.finite(vg$dist) & is.finite(vg$np) & + vg$np > 0 & vg$dist > 0 + if (sum(ok) < 3L || !is.finite(cutoff_dist) || cutoff_dist <= 0) return(NULL) + h <- vg$dist[ok] / cutoff_dist + np <- as.numeric(vg$np[ok]) + gbar <- sum(np * vg$gamma[ok]) / sum(np) + if (!is.finite(gbar) || gbar <= 0) return(NULL) + g <- vg$gamma[ok] / gbar + w <- np / h^2 + w <- w / sum(w) + shape <- if (identical(family, "Sph")) + function(r) ifelse(h < r, 1.5 * h / r - 0.5 * (h / r)^3, 1) + else function(r) 1 - exp(-3 * h / r) # r is the EFFECTIVE range + mg <- sum(w * g) + # The nugget's floor on the scaled axis: 0 unless one was given. + n0 <- if (is.finite(nugget_min) && nugget_min > 0) nugget_min / gbar else 0 + # The best constant: the weighted mean, or the floor when that is higher. + c0 <- max(mg, n0) + sse0 <- sum(w * (g - c0)^2) + # Nugget, partial sill and weighted squared error at effective range r. + # Two terms, each with a lower bound: the least-squares solution is the + # unconstrained one where it is allowed, and otherwise lies on an edge, + # the constant (no partial sill) or the nugget on its floor. + solve_at <- function(r) { + f <- shape(r) + mf <- sum(w * f) + df <- f - mf + sff <- sum(w * df^2) + best <- c(c0, 0, sse0) + if (sff > 1e-12) { + b1 <- sum(w * df * (g - mg)) / sff + b0 <- mg - b1 * mf + if (b1 > 0 && b0 >= n0) { + s <- sum(w * (g - b0 - b1 * f)^2) + if (s < best[3L]) best <- c(b0, b1, s) + } else if (b1 > 0 || n0 > mg) { + # The nugget on its floor, and the partial sill solved alone. + c1 <- sum(w * f * (g - n0)) / sum(w * f^2) + s <- sum(w * (g - n0 - c1 * f)^2) + if (c1 > 0 && s < best[3L]) best <- c(n0, c1, s) + } + } + best + } + lr <- seq(log(min(h) / 4), log(upper), length.out = n_grid) + val <- vapply(lr, function(x) solve_at(exp(x))[3L], numeric(1)) + j <- which.min(val) + r_hat <- exp(lr[j]) + at_edge <- j == 1L || j == n_grid + if (!at_edge) { + o <- stats::optimize(function(x) solve_at(exp(x))[3L], + c(lr[j - 1L], lr[j + 1L]), tol = 1e-10) + if (isTRUE(o$objective <= val[j])) r_hat <- exp(o$minimum) + } + b <- solve_at(r_hat) + if (!(b[2L] > 0) || !(b[3L] < sse0 * (1 - 1e-8))) { + m <- gstat::vgm(psill = if (n0 > mg) nugget_min else mg * gbar, + model = "Nug", range = 0) + attr(m, "converged") <- TRUE + attr(m, "SSErr") <- sse0 + attr(m, "gain") <- 0 + return(m) + } + # A nugget on its floor is the floor, to the last bit (dividing by the + # scale and multiplying back does not promise that). + nug <- if (n0 > 0 && b[1L] <= n0) nugget_min else b[1L] * gbar + m <- gstat::vgm(psill = b[2L] * gbar, model = family, + range = r_hat * cutoff_dist / (if (identical(family, "Sph")) 1 else 3), + nugget = nug) + attr(m, "singular") <- FALSE + attr(m, "converged") <- !at_edge + attr(m, "SSErr") <- b[3L] + attr(m, "gain") <- 1 - b[3L] / sse0 + m +} + + +#' Add a second, longer structure of a given range to a fitted variogram model +#' +#' One exponential structure fitted to lags that resolve the spacing of the +#' points follows the shortest structure a layer has. When the layer also +#' has a weaker structure many times longer, the range of that fit is the +#' short one, and blocks sized from it leave the long structure across +#' folds. Equal lags, blind to the short structure, fit the long one. This +#' puts the two together on one variogram: a nugget, a short exponential +#' structure and a long one, both ranges given, with the nugget and the two +#' partial sills solved by non-negative least squares (exactly, by trying +#' each set of free terms) under the weights of \code{.sac_fit_model()}. +#' The short range is not searched again. Left free beside a long +#' structure it shrinks towards the first lag and takes the nugget with it: +#' on a layer with a nugget of 0.4 that put the nugget at 0 in 2 of 5 fits. +#' +#' @param vg An empirical variogram (\code{np}, \code{dist}, \code{gamma}). +#' @param cutoff_dist The largest lag. +#' @param r_short,r_long Effective ranges of the two structures. +#' @param min_share The least share of the model's semivariance at the +#' largest lag that the long structure has to carry. +#' @param converged Whether the fit that gave \code{r_long} found a minimum +#' inside the ranges it searched. When it did not, \code{r_long} is the +#' edge of that search, and the long structure's partial sill, solved at +#' that range, is no more a fitted value than the range is. +#' @param nugget_min The least nugget allowed, as in \code{.sac_fit_model()}. +#' @return \code{NULL} when the variogram does not support the long +#' structure: its share is under \code{min_share}, or the short structure +#' gets no partial sill. Otherwise a \pkg{gstat} model with a nugget and +#' two exponential rows, short then long, with attributes \code{converged} +#' (as given: the model's sill is a fitted value only when the long range +#' is), \code{SSErr} and \code{long_share}. +#' @keywords internal +#' @noRd +.sac_fit_nested <- function(vg, cutoff_dist, r_short, r_long, min_share = 0.10, + converged = TRUE, nugget_min = 0) { + if (!is.data.frame(vg) || !all(c("np", "dist", "gamma") %in% names(vg))) + return(NULL) + ok <- is.finite(vg$gamma) & is.finite(vg$dist) & is.finite(vg$np) & + vg$np > 0 & vg$dist > 0 + if (sum(ok) < 5L || !is.finite(r_short) || !is.finite(r_long) || + r_short <= 0 || r_long <= r_short) return(NULL) + h <- vg$dist[ok] / cutoff_dist + np <- as.numeric(vg$np[ok]) + gbar <- sum(np * vg$gamma[ok]) / sum(np) + if (!is.finite(gbar) || gbar <= 0) return(NULL) + g <- vg$gamma[ok] / gbar + w <- np / h^2 + w <- w / sum(w) + rs <- r_short / cutoff_dist + rl <- r_long / cutoff_dist + # The nugget's floor is taken off first and put back after, so the three + # terms solved are all at or above zero. + n0 <- if (is.finite(nugget_min) && nugget_min > 0) nugget_min / gbar else 0 + g <- g - n0 + X <- cbind(1, 1 - exp(-3 * h / rs), 1 - exp(-3 * h / rl)) + M <- crossprod(X * w, X) + v <- as.numeric(crossprod(X * w, g)) + gwg <- sum(w * g * g) + best <- c(0, 0, 0, gwg) + for (S in list(1L, 2L, 3L, c(1L, 2L), c(1L, 3L), c(2L, 3L), 1:3)) { + b <- tryCatch(solve(M[S, S, drop = FALSE], v[S]), error = function(e) NULL) + if (is.null(b) || any(!is.finite(b)) || any(b < 0)) next + sse <- gwg - 2 * sum(b * v[S]) + sum(b * as.numeric(M[S, S, drop = FALSE] %*% b)) + if (sse < best[4L]) { full <- numeric(3); full[S] <- b; best <- c(full, sse) } + } + on_floor <- n0 > 0 && !(best[1L] > 0) + best[1L] <- best[1L] + n0 + # The long structure's part of the model at the largest lag. + long_at <- best[3L] * (1 - exp(-3 / rl)) + total_at <- best[1L] + best[2L] * (1 - exp(-3 / rs)) + long_at + share <- if (total_at > 0) long_at / total_at else 0 + if (!(best[2L] > 0) || !(best[3L] > 0) || !(share >= min_share)) return(NULL) + m <- gstat::vgm(psill = best[3L] * gbar, model = "Exp", range = r_long / 3, + add.to = gstat::vgm(psill = best[2L] * gbar, model = "Exp", + range = r_short / 3, + nugget = if (on_floor) nugget_min + else best[1L] * gbar)) + attr(m, "singular") <- FALSE + attr(m, "converged") <- isTRUE(converged) + attr(m, "SSErr") <- best[4L] + attr(m, "long_share") <- share + m +} + + +#' Test for spatial structure at the nearest-neighbour scale +#' +#' Moran's I of the modelled variable on row-standardised k-nearest-neighbour +#' weights, for k = 2, 4, 8 and 16, each standardised with the Cliff and Ord +#' moments for regression residuals (\code{.morans_residual_moments()}), so +#' the same statistic serves a raw response (an intercept-only design) and +#' the residuals of a trend on predictors (that trend's design). The p-value +#' is the smallest one-sided normal p over the four graphs, multiplied by +#' their number (Bonferroni). It needs no random numbers. Several graphs +#' are used because one neighbourhood size misses structure at other scales. +#' Measured on a 1000 m square: on white noise the adjusted p-value is below +#' 0.05 in 0.041 of 1000 layers at n = 300 and 0.053 at n = 100; with a +#' nugget of a fifth of the sill it is below 0.05 for 88 percent of fields +#' of effective range 60 at n = 300, 75 percent of range 150 at n = 100, and +#' 21 percent of range 30 at n = 300, where the range is about the spacing +#' of the points and there is little for any test to find. +#' +#' Rows that share a location (repeat visits) are not neighbours in space: +#' they are the same place. Left as rows, each visit's nearest neighbours +#' are the other visits to its own location, and the statistic measures how +#' alike those are, which a location's own effect produces with no structure +#' between locations at all: on 100 locations visited 5 times, with +#' independent location effects, it found "structure" in 40 of 40 layers. +#' So the test is made on locations: the response and each column of the +#' design are averaged over the rows of a location, and the neighbours are +#' the nearest other locations. The moments are those of independent, +#' equal-variance errors; means over unequal numbers of visits differ in +#' variance, which they do not allow for, so with very unequal visit counts +#' the p-value is approximate. +#' +#' @param xy Coordinates (n by 2). +#' @param y The response. +#' @param X Design matrix of the trend removed from it, or \code{NULL} for an +#' intercept alone. The statistic is computed on the OLS residuals of +#' \code{y} on \code{X}. +#' @return \code{NULL} when it cannot be computed, else a list with \code{p} +#' (the adjusted p-value), \code{morans_i} (Moran's I on the 8 nearest +#' neighbours, or on the graph nearest to 8 when the layer is too small), +#' \code{table} (\code{k}, \code{morans_i}, \code{z}, \code{p} for +#' each graph) and \code{n_locations} (the distinct locations the test was +#' made on; fewer than the rows when locations repeat). +#' @keywords internal +#' @noRd +.sac_structure_test <- function(xy, y, X = NULL, ks = c(2L, 4L, 8L, 16L)) { + n <- length(y) + if (is.null(X)) X <- matrix(1, n, 1L) + if (!is.matrix(X) || nrow(X) != n || nrow(xy) != n) return(NULL) + y <- as.numeric(y) + loc <- .sac_locations(xy) + if (length(loc$first) < n) { + xy <- xy[loc$first, , drop = FALSE] + y <- as.numeric(rowsum(y, loc$id)) / loc$size + X <- rowsum(X, loc$id) / loc$size + n <- length(y) + } + e <- tryCatch(qr.resid(qr(X), y), error = function(e) NULL) + if (is.null(e)) return(NULL) + den <- sum(e^2) + if (!is.finite(den) || den <= 0) return(NULL) + ks <- ks[ks <= n - 2L] + if (!length(ks)) return(NULL) + # One kd-tree query serves every graph when no distance ties with the next + # at a graph's edge: the k nearest then get 1 / k each, which is what + # .build_knn_weights() returns. Ties (a regular grid) go to + # .build_knn_weights(), whose tie rule does not depend on the order of the + # rows. The locations are distinct by now. + nn <- NULL + if (requireNamespace("FNN", quietly = TRUE) && + requireNamespace("Matrix", quietly = TRUE)) { + kq <- min(max(ks) + 1L, n - 1L) + nn <- FNN::get.knn(xy, k = kq) + nn$tol <- 1e-9 * max(1, max(abs(xy))) + } + weights_for <- function(k) { + if (!is.null(nn) && k < ncol(nn$nn.dist) && + !any(nn$nn.dist[, k + 1L] - nn$nn.dist[, k] <= + nn$nn.dist[, k] * 1e-9 + nn$tol)) + return(Matrix::sparseMatrix(i = rep(seq_len(n), k), + j = as.integer(nn$nn.index[, seq_len(k)]), + x = 1 / k, dims = c(n, n), repr = "C")) + .build_knn_weights(xy, k = k) + } + rows <- lapply(ks, function(k) { + W <- weights_for(k) + sp <- inherits(W, "Matrix") + S0 <- sum(W) + I <- (n / S0) * sum(e * as.numeric(W %*% e)) / den + mom <- .morans_residual_moments(W, X, S0, sp) + if (is.null(mom) || !isTRUE(mom$VI > 0)) return(c(k, I, NA_real_, NA_real_)) + z <- (I - mom$EI) / sqrt(mom$VI) + c(k, I, z, stats::pnorm(z, lower.tail = FALSE)) + }) + tab <- as.data.frame(do.call(rbind, rows)) + names(tab) <- c("k", "morans_i", "z", "p") + tab$k <- as.integer(tab$k) + okp <- is.finite(tab$p) + list(p = if (any(okp)) min(1, sum(okp) * min(tab$p[okp])) else NA_real_, + morans_i = tab$morans_i[which.min(abs(tab$k - 8L))], + table = tab, n_locations = as.integer(n)) +} + + +#' Group the rows of a coordinate matrix by location +#' +#' Rows are at one location when both coordinates are equal to the last bit. +#' +#' @param xy Coordinates (n by 2). +#' @return A list with \code{id} (the location of each row, numbered in order +#' of first appearance), \code{first} (the first row of each location) and +#' \code{size} (the rows at each). +#' @keywords internal +#' @noRd +.sac_locations <- function(xy) { + key <- paste(sprintf("%.17g", xy[, 1L] + 0), sprintf("%.17g", xy[, 2L] + 0), sep = "\r") + id <- match(key, unique(key)) + list(id = id, first = which(!duplicated(id)), size = tabulate(id, max(id, 0L))) +} + + +#' Semivariance at the two shortest separations a layer has, with no model +#' +#' Two numbers that need no variogram model and bracket the nugget, which is +#' the limit of the semivariance as the separation shrinks to zero. +#' +#' \strong{Nearest-neighbour pairs.} Each location is paired with the +#' nearest other location, each such pair of locations counted once. Half +#' the mean squared difference between a row of one and a row of the other, +#' averaged over the pairs of locations, is the semivariance at about the +#' nearest-neighbour distance. The semivariance does not fall as the lag +#' shrinks, so this bounds the nugget from above, up to its sampling error. +#' One pair a location, and not the closest pairs of the layer, because +#' those come from its densest part alone. Where a location has several +#' rows, every pairing of its rows with those of its neighbour counts, with +#' equal weight, and the pair of locations still counts once. +#' +#' \strong{Pairs at zero separation.} Rows that share a location (repeat +#' visits). Half the mean squared difference over every pair of rows at one +#' location is the variance between visits: the part of the nugget that is +#' measurement, without the variation at scales shorter than the spacing of +#' the locations, and so a bound on the nugget from below. Every pair is +#' used, not one partner a row: the rows arrive sorted by their value, and +#' pairing each with the next pairs neighbouring order statistics, which +#' reads low (0.205 for a variance of 0.300 at 8 visits). +#' +#' @param xy Coordinates (n by 2). +#' @param v The modelled variable. +#' @return A list with \code{gamma}, \code{pairs} and \code{dist} (the +#' semivariance of the nearest-neighbour pairs of locations, their number +#' and their median separation; \code{NA}, 0 and \code{NA} when there is +#' one location), and \code{zero_gamma}, \code{zero_pairs}, +#' \code{zero_ss} and \code{zero_df} (the semivariance of the pairs of +#' rows at one location, their number, the sum of their half squared +#' differences, and the degrees of freedom behind it: the rows less the +#' locations; \code{NA}, 0, 0 and 0 when no location repeats). +#' @keywords internal +#' @noRd +.sac_short_lag <- function(xy, v) { + n <- nrow(xy) + out <- list(gamma = NA_real_, pairs = 0L, dist = NA_real_, + zero_gamma = NA_real_, zero_pairs = 0L, zero_ss = 0, zero_df = 0L) + if (n < 2L) return(out) + v <- as.numeric(v) + loc <- .sac_locations(xy) + G <- length(loc$first) + m <- loc$size + mu <- v[loc$first] + ss <- numeric(G) # sum of squares about the location mean + if (G < n) { + mu <- as.numeric(rowsum(v, loc$id)) / m + ss <- as.numeric(rowsum((v - mu[loc$id])^2, loc$id)) + # Over the m (m - 1) / 2 pairs of rows at a location, the half squared + # differences sum to m / 2 times its sum of squares about its mean. + zp <- sum(m * (m - 1) / 2) + zs <- sum(m / 2 * ss) + out$zero_pairs <- if (zp <= .Machine$integer.max) as.integer(zp) else zp + out$zero_ss <- zs + out$zero_gamma <- zs / zp + out$zero_df <- n - G + } + if (G < 2L) return(out) + nn <- .sac_knn(xy[loc$first, , drop = FALSE], 1L) + i <- seq_len(G); j <- nn$index[, 1L] + a <- pmin(i, j); b <- pmax(i, j) + keep <- !duplicated(cbind(a, b)) + a <- a[keep]; b <- b[keep] + # The mean squared difference between a row of location a and a row of + # location b: the squared difference of the two means plus each + # location's mean square about its own. + out$gamma <- mean(0.5 * ((mu[a] - mu[b])^2 + ss[a] / m[a] + ss[b] / m[b])) + out$pairs <- length(a) + out$dist <- stats::median(nn$dist[keep, 1L]) + out +} + + #' The nugget of an estimated autocorrelation range #' #' The nugget variance of the variogram model behind a -#' \code{\link{estimate_sac_range}()} result: the semivariance at zero -#' separation, i.e. measurement error plus variation at scales shorter than -#' the first lag bin of the empirical variogram (gstat's bins are -#' \code{cutoff / 15} wide, about \code{max_dist / 30} at the default -#' \code{cutoff}), which can be far wider than the spacing of close pairs. -#' It is extrapolated to zero from that bin, not observed, and a fit that -#' runs into its lower bound reports exactly 0. It is carried as the -#' \code{nugget} attribute of every classed result, identified or rejected, -#' because it is the number a resolution criterion for a tessellation needs -#' (the short-lag variance that no cell can average away). +#' \code{\link{estimate_sac_range}()} result: the model's semivariance as +#' the separation shrinks to zero, i.e. measurement error plus variation at +#' scales shorter than the first lag of the empirical variogram. It is +#' extrapolated to zero from that lag, not observed, so it is only as good +#' as the first lag is short: \code{attr(x, "first_lag")} says where the +#' extrapolation starts. +#' With \code{lags = "adaptive"} (the default) that is the separation of the +#' closest pairs of points; with \code{lags = "equal"} it is the middle of a +#' bin \code{cutoff * max_dist / n_lags} wide, which on a dense layer can be +#' many times the spacing of close pairs, and structure shorter than that +#' bin is then counted as nugget. +#' +#' Three more attributes say how far to trust it. +#' \code{attr(x, "nugget_at_bound")} is \code{TRUE} when the fit put the +#' nugget at its lower bound (0, or within 1e-4 of the sill): that is the +#' bound and not an estimate, and a criterion that uses it as a noise +#' variance has no penalty left. \code{attr(x, "short_lag_semivariance")} +#' is the semivariance of nearest-neighbour pairs, computed with no model: +#' each location is paired with the nearest other location +#' (\code{short_lag_pairs} and \code{short_lag_dist} give the number of +#' such pairs and their median separation). A semivariance does not fall +#' as the lag shrinks, so this value bounds the nugget from above, up to its +#' sampling error; a fitted nugget well above it is contradicted by the +#' closest pairs. \code{attr(x, "zero_lag_semivariance")} exists where +#' locations were visited more than once (\code{zero_lag_pairs} is not 0): +#' it is the semivariance of every pair of rows that share a location, that +#' is, the variance between visits to one place. That is the measurement +#' part of the nugget, observed and not extrapolated, without the variation +#' at scales below the spacing of the locations, so it bounds the nugget +#' from below. Such pairs are at no lag and are in no bin of the +#' variogram: the model, and so the nugget, describe positive separations. +#' The variogram fit uses the bound, though: where it rests on 30 degrees +#' of freedom or more (rows less locations) the nugget is not let under it, +#' and \code{attr(x, "nugget_floor")} holds the value (0 when there is no +#' floor). With \code{detrend = "reml"} the model is built from the REML +#' parameters and takes no floor: its nugget can come out below the +#' variance between visits, and \code{nugget_floor} is 0. +#' A nugget equal to its floor is the variance between visits, a +#' measurement, and \code{nugget_at_bound} stays \code{FALSE} for it. +#' +#' When \code{attr(x, "lag_fallback")} is \code{TRUE} the result is the +#' equal-lag one although adaptive lags were asked for (see "The lags" in +#' \code{\link{estimate_sac_range}}), and its nugget is extrapolated from +#' the first equal bin. +#' +#' The nugget is carried as the \code{nugget} attribute of every classed +#' result, identified or rejected, because it is the number a resolution +#' criterion for a tessellation needs (the short-lag variance that no cell +#' can average away). On a result refused for want of spatial structure it +#' is the variance of the modelled variable, which is the nugget of the +#' model that refusal supports. #' #' @param x A \code{sac_range} object, or anything else. #' @return A single number: the nugget in the units of the response's #' variance; \code{NA_real_} when \code{x} carries no fitted model (a bare -#' \code{NA} from a run that could not fit anything, a rejected result whose -#' fits were all singular, or an object that is not a \code{sac_range}). +#' \code{NA} from a run that could not fit anything, a rejected result with +#' too few lag bins to fit, or an object that is not a \code{sac_range}). #' @seealso \code{\link{estimate_sac_range}}, which produces the object. #' @family cross-validation #' @examples @@ -1580,6 +2569,9 @@ #' xy$z <- as.numeric(t(chol(exp(-D / 150) + diag(0.5, n))) %*% rnorm(n)) #' r <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), "z") #' print(sac_nugget(r)) # the fitted nugget variance, on the sill's scale +#' attr(r, "nugget_at_bound") # FALSE: an estimate, not the bound +#' attr(r, "short_lag_semivariance") # what the closest pairs say, no model +#' attr(r, "zero_lag_pairs") # 0: no location was visited twice #' sac_nugget(NA) # nothing fitted: NA #' } #' @export @@ -1593,42 +2585,141 @@ sac_nugget <- function(x) { #' Estimate the spatial autocorrelation range from data #' -#' Fits exponential (or spherical) variogram models and returns the -#' \emph{effective range}: for the exponential model, three times the fitted -#' range parameter, which is where the semivariance reaches ~95 % of the -#' sill; for the spherical model (fitted only when the exponential fit is -#' singular or does not converge) the fitted range itself, which is where the -#' spherical semivariance reaches its sill exactly. Both are the distance -#' beyond which two observations are (near) uncorrelated, which is what a -#' block or a buffer has to exceed. -#' -#' The exponential model is kept whenever it converges, without comparing it -#' with the spherical fit, and on fields smoother than exponential that makes -#' the range long. Measured on simulated fields (n = 300 on a 1000 m square, -#' 30 draws each): about 1.8--2.1 times the practical range of a Gaussian -#' covariance, and 1.3--1.4 times the range of a spherical one, while an -#' exponential field came back at 0.97 of its effective range. The error is -#' on the safe side (blocks too large, cross-validation pessimistic), and it -#' is kept on purpose: choosing the family by the smaller weighted sum of -#' squares corrects the spherical case but sends exponential fields low, to -#' about 0.82 of the truth, which is the direction that leaks. +#' Fits an exponential variogram model with a nugget and returns the +#' \emph{effective range}: three times the fitted range parameter, which is +#' where the semivariance reaches about 95 percent of the sill. It is the +#' distance beyond which two observations are (near) uncorrelated, which is +#' what a block or a buffer has to exceed. +#' +#' The result is a function of the data alone. The same layer gives the +#' same answer whatever the unit of the response or of the coordinates and +#' whatever the order of its rows, and a change in the last bits of the +#' values changes the answer by about as much. Three things make it so. +#' The rows are sorted by their coordinates as supplied, then by the +#' response and the predictors, before anything else, so the projection +#' chosen for lon/lat input, the \code{n_max} subsample and the pair sums +#' do not depend on their order. (Rows that share a location are therefore +#' in the order of their values, and no step treats the first of them as +#' special.) The variogram is computed on the standardised variable, and a +#' response is called constant only when its standard deviation is under +#' 1e-12 of its largest absolute value, which no change of unit alters. +#' And the model is fitted without iteration: the criterion is \pkg{gstat}'s weighted least +#' squares (weights \eqn{N / h^2}) on lags divided by the cutoff; for each +#' trial range the nugget and the partial sill are solved exactly, with both +#' kept at or above zero; and the range is found by a search over a +#' logarithmic grid from a quarter of the first lag to four cutoffs, refined +#' in one dimension. There is no start value, no iteration limit and no +#' fit that fails to converge. +#' +#' Only the exponential family is fitted. On fields smoother than +#' exponential that makes the range long, which is the safe side (blocks too +#' large, cross-validation pessimistic). Choosing the family by the smaller +#' weighted sum of squares would correct a spherical field but send +#' exponential fields low, the direction that leaks. +#' +#' \strong{Spatial structure is tested first.} A variogram model can be +#' fitted to anything, and on a layer with no structure the fit returns a +#' finite range for a large share of draws. So Moran's I of the modelled +#' variable is computed on its 2, 4, 8 and 16 nearest neighbours, each +#' standardised with the moments that fit the variable (those of regression +#' residuals when \code{predictor_vars} are given), and the smallest +#' one-sided p-value is multiplied by four. When that adjusted p-value is +#' not below \code{structure_alpha}, the result is \code{NA} with +#' \code{rejected_reason} \code{"no spatial structure detected at the +#' nearest-neighbour scale"}, a pure-nugget model and no fitted range. The +#' test uses no random numbers. \code{structure_p}, \code{morans_i} and +#' \code{structure_test} are attached to every classed result. Measured on +#' a 1000 m square with 300 points, the test refuses 388 of 400 white-noise +#' layers and 8 get a finite range, against 196 with the test off. +#' Its power is limited where few neighbours lie inside the range. With a +#' nugget of a fifth of the sill it finds structure in 88 percent of fields +#' of effective range 60 on 300 points, and in 21 percent at range 30, which +#' is about the spacing of those points. A short range on a sparse layer +#' can therefore be refused; \code{structure_alpha = 1} switches the +#' refusal off. Rows that share a location (repeat visits) are one place +#' and not each other's neighbours, so on such a layer the test is made on +#' the means of the locations: what it asks is whether locations near each +#' other are alike, which a location's own effect, however large, does not +#' answer. With very unequal numbers of visits the p-value is approximate. +#' +#' \strong{The lags.} With \code{lags = "adaptive"} (the default) the first +#' bin runs from zero to the distance within which the closest +#' \code{max(50, n / 4)} pairs of distinct locations lie, and up to +#' \code{n_lags} further bins are spaced geometrically from there to the +#' cutoff; a bin holding fewer than 30 pairs is merged with the next. The +#' short lags are then resolved at the spacing of the points, which is what +#' the nugget and a short range are read from. With \code{lags = "equal"} +#' there are \code{n_lags} bins of equal width out to the cutoff, as +#' \pkg{gstat} bins by default; each is \code{cutoff * max_dist / n_lags} +#' wide, a structure shorter than the first of them is invisible and is +#' counted as nugget, and the range fitted is that of whatever longer +#' structure the layer has. Below about a hundred points neither binning +#' resolves much and the adaptive bins bring no gain. +#' +#' Two rows at one location are a pair at zero separation, and are in no +#' bin, whichever the binning: the variogram and the model describe positive +#' separations. Their semivariance, the variance between visits to a +#' location, is returned on its own as \code{zero_lag_semivariance}, and +#' the nugget fitted to the variogram is not let under it when the layer has +#' 30 or more rows beyond one a location to estimate it from (a model from +#' \code{detrend = "reml"} takes no such floor); see +#' \code{\link{sac_nugget}}. +#' +#' The adaptive lags put little weight on the long ones, and a weak, long +#' structure under much noise can be clear at equal lags while the adaptive +#' fit runs past the largest lag. So when the adaptive range is refused as +#' past the fitted lags and the equal-lag fit has a range it would itself +#' return, the result is the equal-lag one, whole, exactly as +#' \code{lags = "equal"} gives it, with \code{lags} saying \code{"equal"} +#' and \code{lag_fallback} set to \code{TRUE}. Its nugget is then the +#' equal-lag nugget. No other refusal falls back. +#' +#' \strong{Structure at two scales.} One structure fitted to lags that +#' resolve the spacing of the points follows the shortest structure of the +#' layer. A layer can have a weaker structure several times longer as well, +#' and blocks sized from the short one would leave the long one across +#' folds. So with \code{lags = "adaptive"} the equal-lag fit is made too, +#' and when its range is at least twice the adaptive one, a model with a +#' nugget and both structures, at those two ranges, is fitted to the +#' adaptive variogram. That model is returned (\code{structures} is 2 and +#' \code{short_range} holds the range of the short structure) and the range +#' is the long one, unless the long structure carries under 3 percent of +#' the model's semivariance at the largest lag: then the lags that resolve +#' the layer give the equal-lag range nothing, and the single structure +#' stands. The bar is low because the two mistakes are not alike. A long +#' structure that is missed sizes blocks too small, which leaks. One that +#' is believed in error returns the equal-lag range, which is too long and +#' makes a validation pessimistic, and \code{short_range} still holds the +#' short one. When the equal-lag range is one that \code{lags = "equal"} +#' would itself refuse (past the fitted lags, as under an unremoved trend), +#' the model with it is refused as well, the answer is taken away and not +#' lengthened, and the long structure has to carry 10 percent. +#' +#' Measured on a clustered layer of 1200 points over a 1000 m square, 30 +#' draws each. With structures of range 20 and 200 both are kept in 20 +#' draws, and the range returned is under half the equal-lag one in 1; with +#' 40 and 400, in 18 and 1; with 30 and 300, in 21 and 0; with 15 and 450, +#' in 28 and 1. With one structure of range 40 a second is kept in 4, and +#' the range is within a factor 2 of the truth in 27 draws (19 with equal +#' lags); with one of range 30, in 7 and 25 (14). The nugget comes from the +#' adaptive lags either way: where it is 0.3, the median is 0.32 to 0.35, +#' and 0.49 to 0.65 with equal lags. A long structure whose equal-lag +#' range is under twice the adaptive one is not separated: the range is +#' then that of the single fit, which lies between the two. #' #' The estimate is the \strong{omnidirectional} (all-pairs) fit. Directional #' variograms are fitted as well, at 0° (N–S), 45°, 90° (E–W) and 135° #' azimuths with a ±22.5° tolerance. Those four windows tile all 180 distinct #' azimuths exactly once, and their ranges are returned in the #' \code{directional} attribute, with their largest-over-smallest ratio in -#' \code{anisotropy}. They are a diagnostic, not the answer, for two reasons. -#' Each direction sees about a quarter of the point pairs, and the maximum of -#' four quarter-sample fits is biased upward: on simulated \emph{isotropic} -#' fields it came in about 40% above the truth, and no hurdle placed in -#' front of it (all four directions fitted, ratio above 1.5, maximum above -#' 1.5× the all-pairs fit) kept it out. One isotropic field rotated in 10° -#' steps "established" anisotropy in 14 of 18 orientations. And the windows +#' \code{anisotropy}. They are a diagnostic and never the answer, for two +#' reasons. Each direction sees about a quarter of the point pairs, and the +#' maximum of four quarter-sample fits is biased upward. And the windows #' are fixed to the coordinate axes, so any answer built from them changes -#' when the layer is rotated, which a property of the field must not do. The -#' all-pairs fit is the best-powered estimate available and is invariant to -#' rotation. +#' when the layer is rotated, which a property of the field must not do. +#' The all-pairs fit is the best-powered estimate available and is invariant +#' to rotation. When it identifies no range, no range is returned: the +#' largest directional range does not stand in for it. #' #' Where a field is \emph{known} to be anisotropic, blocks must be at least #' as large as the longest autocorrelation range to avoid leakage, and the @@ -1644,59 +2735,19 @@ sac_nugget <- function(x) { #' 1.5 is written to the package log at INFO level with that advice, which #' reaches the session log file but not the console (the ratio passes 1.5 on #' most isotropic fields too); \code{print()} shows the directional ranges -#' and the ratio, and \code{attr(range, "anisotropy")} holds it. Only when -#' the omnidirectional fit is singular or did not converge is the directional -#' maximum returned in its place, and \code{anisotropy_used} is \code{TRUE} -#' in that case alone. An omnidirectional fit that converged to a range past -#' the fitted lags is refused (see the Value section) whatever the directions -#' found: the directions that reached a sill are the shorter ones, so their -#' maximum is a lower bound, not an estimate. -#' -#' A direction whose fit fails, does not converge, or reports a range beyond -#' the longest fitted lag is excluded and recorded as \code{NA} in the +#' and the ratio, and \code{attr(range, "anisotropy")} holds it. +#' +#' A direction whose variogram is flat or has too few bins, whose range runs +#' beyond the longest fitted lag, or whose fit has no minimum inside the +#' ranges searched is excluded and recorded as \code{NA} in the #' \code{directional} attribute. #' -#' Every variogram model is fitted \strong{with a nugget}. A nugget-free model -#' forces the curve through the origin, and on any real measurement (which has -#' one) \pkg{gstat}'s default N/h² weights buy that constraint by collapsing -#' the range: with a 50% nugget the fitted range came back at about 0.45 of the -#' truth, so \code{make_folds(auto_range = TRUE)} built blocks less than half -#' the correlation length it reported. -#' -#' The lags are binned the way \pkg{gstat} bins them by default, 15 bins out -#' to the cutoff, each \code{cutoff * max_dist / 15} wide (about 47 m on a -#' 1000 m square at the defaults). A range spanning only one or two bins is -#' resolved coarsely and comes out long: exponential fields with an effective -#' range of 60 m (n = 300 on a 1000 m square, 30 draws) returned a median of -#' 89--102 m, where the same fields binned over a 200 m cutoff gave 65--68, -#' and at a range of 300 m there was no bias. A range shorter than the -#' first bin cannot be resolved at all and can come back several times too -#' long: an effective range of 24 m (n = 1500 on a 1000 m square, 8 draws) -#' returned 93--479 m, five of them as the directional maximum, against -#' 19--32 m at \code{cutoff = 0.1}; the first bin's semivariance was 92--99 -#' percent of the fitted sill in all eight. So whenever the empirical -#' variogram is already at its sill in the first one or two bins -#' (\code{plot()} the result), run it again with a smaller \code{cutoff}, -#' whatever range was fitted. -#' -#' Nothing tests whether the layer has spatial structure at all. On white -#' noise (n = 300 on a 1000 m square, 30 draws) the estimate was a finite, -#' spurious range (57--533 m) in 8 draws and a refusal in the rest, mostly -#' as past the fitted lags or not converged, and only once as no model -#' fitted; with \code{detrend = "reml"} it was finite in 13 of 30 (21--453 -#' m), and 16 of the refusals were ranges of 0.18--12.5 m, too short for 30 -#' pairs of points to lie inside them. A -#' spurious range errs towards larger blocks, so the harm is mostly lost -#' training data, but a caller who needs to know whether there is any -#' structure should look at the variogram (\code{plot()} on the result) -#' rather than at whether the answer is \code{NA}. -#' -#' When the all-pairs fit is singular or did not converge and two or more -#' directions reached a sill, the directional maximum is returned in its -#' place (\code{anisotropy_used = TRUE}), and a log warning names the -#' directional ranges when their ratio exceeds 1.5. When the all-pairs -#' estimate is used and the directional ranges vary by more than 1.5, a log -#' note (INFO) names them instead. +#' The model is fitted \strong{with a nugget}. A nugget-free model forces +#' the curve through the origin, and on any real measurement (which has one) +#' the \eqn{N / h^2} weights buy that constraint by collapsing the range. +#' The fitted nugget can sit at its lower bound of zero; the result then +#' carries \code{nugget_at_bound = TRUE}, and \code{\link{sac_nugget}} says +#' what else is attached to judge a nugget by. #' #' The returned range is in the coordinate units of the (projected) data and #' can be passed directly to \code{make_folds(block_size = ...)} so that CV @@ -1709,7 +2760,10 @@ sac_nugget <- function(x) { #' would otherwise return a range in 3-D while every consumer of it works in #' 2-D map distance; and rows with empty or non-finite coordinates are dropped #' with a logged count. -#' @param response_var Character(1) name of the response column. For a +#' @param response_var Character(1) name of the response column. Rows where +#' it is missing or infinite are left out before anything else is done, so +#' they neither take part in the choice of projection for lon/lat input +#' nor use up the \code{n_max} subsample. For a #' count or other response whose variance tracks its mean, see the section #' on non-Gaussian responses: the range is still estimated, but it is a #' less reliable number than for a Gaussian response. @@ -1720,18 +2774,29 @@ sac_nugget <- function(x) { #' set by \code{detrend}, and it matters: see "Detrending and the #' residual-variogram bias". Rows whose response or predictor is missing #' or infinite are left out of that fit, and so of the variogram, with a -#' logged count. -#' @param n_max Maximum number of points to subsample before fitting. -#' Variogram estimation is O(n²) so this keeps runtime bounded. +#' logged count. When that leaves fewer than 30 rows the result is the +#' unclassed \code{NA} that says how many were left (see Value). One +#' case differs, as it always has: when no row at all has every predictor +#' (one is missing on every row) no trend can be fitted, and the variogram +#' is of the raw response, with an R warning and \code{detrended} set to +#' \code{FALSE}. +#' @param n_max Maximum number of points the variogram is computed on, at +#' least 30; \code{Inf} for no limit. Variogram estimation is O(n²) so +#' this keeps runtime bounded. A layer with more rows that carry a value +#' is cut to a seeded random subsample of this size, drawn after rows with +#' nothing to model have been left out and with the rows in a fixed order, +#' so the subsample does not depend on how the layer is sorted. The +#' counts are returned as the attributes \code{n_used}, \code{n_missing} +#' and \code{n_subsampled}. #' @param cutoff Fraction of the maximum inter-point distance to use as the -#' variogram lag cutoff. That distance is the farthest pair, found on the -#' convex hull, and not the bounding-box diagonal, which depends on how the -#' axes are oriented. Default 0.5. +#' variogram lag cutoff, above 0 and at most 1. That distance is the +#' farthest pair, found on the convex hull, and not the bounding-box +#' diagonal, which depends on how the axes are oriented. Default 0.5. #' @param range_frac Positive numeric. A fitted range exceeding #' \code{range_frac * cutoff * max_dist} (that is, beyond the longest lag #' the empirical variogram was actually fitted over) is treated as #' unidentified and \code{NA_real_} is returned. -#' \code{gstat::fit.variogram()} yields a finite number even when the +#' A model fit yields a finite number even when the #' variogram never reaches a sill, and such a value extrapolates past the #' observed lags instead of measuring a long autocorrelation range. Passing #' it to \code{make_folds(auto_range = TRUE)} would collapse the block grid to @@ -1742,45 +2807,62 @@ sac_nugget <- function(x) { #' half the width of the bounding box in one direction or the other. An #' accepted range between the two leaves #' \code{make_folds(auto_range = TRUE)} room for a single block of that -#' size (see its \code{auto_range} argument for what it does then). On a -#' 1000 m square with an exponential field of effective range 570 (n = 300), -#' 9 of 30 draws were accepted in that band. Lowering \code{range_frac} to fit the +#' size (see its \code{auto_range} argument for what it does then). +#' Lowering \code{range_frac} to fit the #' grid would turn those estimates into \code{NA} and the blocks into #' geometric ones smaller than the range. #' @param seed RNG seed for the \code{n_max} subsample, restored afterwards so #' the caller's random stream is untouched. Default \code{123L}: the #' subsample is an internal approximation and no part of the answer, and -#' leaving it unseeded made the returned range differ between runs on -#' identical input (19531, 19589, 19605 on three calls) and silently advanced -#' the caller's RNG. Pass \code{NULL} for the old unseeded behaviour, or a +#' leaving it unseeded would make the returned range differ between runs on +#' identical input and silently advance the caller's RNG. Pass \code{NULL} +#' for an unseeded subsample, or a #' different number to check how sensitive the estimate is to the subsample. -#' Ignored when \code{nrow(points_sf) <= n_max}, where nothing is sampled. -#' The \code{reml_max_n} subsample uses the same seed. +#' Ignored when no more than \code{n_max} rows carry a value, where nothing +#' is sampled. The \code{reml_max_n} subsample uses the same seed, and so +#' does the draw of one row a location that \code{detrend = "reml"} makes +#' on a layer with repeat visits. #' @param detrend How the trend on \code{predictor_vars} is removed; #' ignored when there are none. \code{"ols"} (default) fits it by ordinary -#' least squares and fits the variogram to the residuals. This is the -#' long-standing behaviour, which underestimates the range (see the section +#' least squares and fits the variogram to the residuals, which +#' underestimates the range (see the section #' below). \code{"reml"} fits the trend and an exponential-plus-nugget #' covariance together by residual maximum likelihood with #' \code{nlme::gls()}, returns the REML range, and attaches the empirical #' variogram of the REML residuals for inspection. It needs \pkg{nlme}, -#' costs \eqn{O(n^3)} (about 2 s at 300 points, 12 s at 500, 45 s at 800), -#' and so runs on at most \code{reml_max_n} points; when it does not -#' converge the \code{"ols"} path runs instead with an R warning saying so. +#' costs \eqn{O(n^3)}, and so runs on at most \code{reml_max_n} points; +#' when it does not converge the \code{"ols"} path runs instead with an R +#' warning saying so. The start of the fit is chosen from the profile +#' REML likelihood on a grid of ranges and nugget proportions, and when +#' more than one start is fitted the fit with the largest log-likelihood +#' is kept. #' @param reml_max_n Positive integer, at least 30. With \code{detrend = #' "reml"}, the trend and covariance are fitted on a seeded random subsample -#' of this many points when the layer has more (exact duplicate locations -#' are dropped first); the fitted trend is then removed from every point. -#' Default 400. Raise it for a better-determined fit at the cost above. -#' @param keep_directional_fits Logical. Attach each direction's empirical +#' of this many points when the layer has more; the fitted trend is then +#' removed from every point. The fit takes one row a location: where a +#' location has several rows (repeat visits), one of them is drawn at +#' random under \code{seed}, so that the nugget fitted is the variance +#' between visits and not that of their minimum or of their mean. +#' Default 400. Raise it for a better-determined fit at a cubic cost. +#' @param keep_directional_fits \code{TRUE} or \code{FALSE}. Attach each +#' direction's empirical #' variogram and fitted model as \code{directional_fits}? Defaults to -#' \code{FALSE}: the four variograms are most of the object's size (42.1 KB -#' of 59.3 KB at \eqn{n = 400}, and the difference between a 52.4 KB and a -#' 94.6 KB \code{make_folds(auto_range = TRUE)} result), while the numbers +#' \code{FALSE}: the four variograms are most of the object's size, while +#' the numbers #' read from them (\code{directional}, \code{directional_fitted}, #' \code{directional_status}, \code{anisotropy}) are attached either #' way, and \code{plot()} draws the effective variogram from its own #' attribute. Set \code{TRUE} to inspect the directional curves. +#' @param lags How the lags are binned: \code{"adaptive"} (default) or +#' \code{"equal"}; see "The lags" above. +#' @param n_lags A whole number from 5 to 100, default 15. With +#' \code{lags = "equal"}, the number of bins. With +#' \code{lags = "adaptive"}, the most bins spaced geometrically past the +#' first; fewer are used when that many would hold under 30 pairs each. +#' @param structure_alpha The level of the test for spatial structure, above +#' 0 and at most 1; default 0.05. A layer whose adjusted p-value is not +#' below it gets no range. \code{1} switches the refusal off; the test +#' is still computed and attached. #' @section Detrending and the residual-variogram bias: #' Fitting a variogram to the residuals of a least-squares trend #' underestimates both the sill and the range, because the trend fit absorbs @@ -1788,29 +2870,18 @@ sac_nugget <- function(x) { #' 2006). Blocks sized from that range are then too small and a blocked #' validation is less conservative than it claims. How large the effect is #' depends on how smooth the trend terms are in space, and on how many there -#' are. Measured for this estimator on simulated exponential fields (n = -#' 300, true effective range 300, nugget 0.2, 40--60 draws), as the median -#' ratio of the estimate from the trend-removed data to the estimate from -#' the true field: -#' \itemize{ -#' \item a white-noise covariate: OLS 1.00, REML 0.99 (no bias to speak of); -#' \item a spatially smooth covariate (a random field with range 300 or -#' 1000): OLS 0.97, REML 0.95--0.98; -#' \item a linear trend in the coordinates: OLS 0.92, REML 1.04; -#' \item a quadratic trend in the coordinates (five terms): OLS 0.75, -#' REML 1.06. -#' } -#' So for ordinary covariates the OLS bias is a few percent, and for trend -#' surfaces in the coordinates it is large. Iterating between a GLS trend +#' are: for ordinary covariates it is a few percent, and for trend surfaces +#' in the coordinates it is large. Iterating between a GLS trend #' fit and a variogram refit (Neuman and Jacobson 1984) recovers only part of -#' it (0.80 in the quadratic case), because the variogram of GLS residuals +#' it, because the variogram of GLS residuals #' is biased too; REML does not fit a variogram to residuals at all, which is #' why \code{detrend = "reml"} returns its own range estimate. Its price is #' a single family (exponential with nugget), a cubic cost in \code{n}, and #' a somewhat wider sampling spread. The default stays \code{"ols"} so that -#' existing scripts return what they did; a script that detrends on smooth +#' existing scripts keep their method; a script that detrends on smooth #' or coordinate-based terms should pass \code{detrend = "reml"}, or size its -#' blocks with a margin. +#' blocks with a margin. Detrending removes a trend the predictors explain. +#' It does not make an unidentified range identified. #' #' @section Count and other non-Gaussian responses: #' The empirical variogram assumes second-order stationarity: a variance that @@ -1829,7 +2900,7 @@ sac_nugget <- function(x) { #' structure: the residuals of an OLS fit to a count still have a variance #' that tracks the fitted mean. The principled remedy is a variogram of #' Pearson residuals from a model in the right family, which this function -#' does not compute. Until it does, treat the range from a count response as no +#' does not compute. Treat the range from a count response as no #' more than an order of magnitude, size blocks conservatively from it, and #' prefer \code{\link{make_folds}(method = "nndm")}, which does not depend on a #' fitted range at all. @@ -1842,13 +2913,15 @@ sac_nugget <- function(x) { #' with the fit attached as attributes \code{directional} (the 0°, 45°, #' 90° and 135° ranges, named by azimuth; \code{NA} where that #' direction's fit was unusable), \code{anisotropy} (largest -#' over smallest), \code{anisotropy_used} (logical: \code{TRUE} only when -#' the all-pairs fit was singular or did not converge and the -#' directional maximum stands in for it), \code{directional_status} +#' over smallest), \code{anisotropy_used} (always \code{FALSE}: the +#' all-pairs fit is the estimate; kept for code that reads it), +#' \code{directional_status} #' (per azimuth, why a direction is #' \code{NA} in \code{directional}: \code{"ok"}, \code{"over_cutoff"} #' (its range ran past the largest lag fitted), \code{"not_converged"} -#' or \code{"no_fit"}), \code{directional_fitted} (the range each +#' (its fit has no minimum inside the ranges searched) +#' or \code{"no_fit"} (a flat variogram, or too few bins)), +#' \code{directional_fitted} (the range each #' direction's fit reported whether or not it was usable, so a refused #' directional range stays recoverable) and \code{directional_fits} (a #' list by azimuth of each direction's empirical \code{variogram} and @@ -1861,91 +2934,121 @@ sac_nugget <- function(x) { #' \code{FALSE}), \code{detrend_method} (\code{"ols"} or \code{"reml"} #' when detrended, \code{NA} otherwise), \code{reml} (with #' \code{detrend = "reml"}: a list with \code{n_used}, -#' \code{subsampled}, \code{nugget_prop} and \code{sigma2} from the -#' REML fit; \code{NULL} otherwise), +#' \code{subsampled}, \code{nugget_prop}, \code{sigma2}, +#' \code{logLik} (the REML log-likelihood of the fit kept), +#' \code{logLik_gain} (its gain over the same trend with independent +#' errors) and \code{n_fits} (the starts fitted); \code{NULL} +#' otherwise), #' \code{crs} (the projected CRS the variogram was #' fitted in: the unit of the range), \code{max_dist}, -#' \code{cutoff_dist}, \code{variogram} (the empirical variogram), -#' \code{variogram_model} (the fitted \code{gstat} model, or with -#' \code{detrend = "reml"} a \code{gstat} model built from the REML -#' parameters) and \code{nugget} (that model's nugget variance; see -#' \code{\link{sac_nugget}}), so the fit can be inspected and need not +#' \code{cutoff_dist}, \code{variogram} (the empirical variogram, in +#' the units of the response's variance), +#' \code{variogram_model} (the fitted model, in \pkg{gstat}'s layout, +#' or with \code{detrend = "reml"} one built from the REML +#' parameters), \code{nugget} (that model's nugget variance; see +#' \code{\link{sac_nugget}}), \code{nugget_at_bound} (\code{TRUE} when +#' the nugget is at its lower bound, within 1e-4 of the sill, and so +#' is not an estimate), \code{first_lag} (the mean separation in the +#' first bin: the shortest lag resolved, from which the nugget is +#' extrapolated), \code{bins_below_range} (how many bins lie inside +#' the fitted range; with fewer than three the split between nugget +#' and structure rests on very little), +#' \code{short_lag_semivariance}, \code{short_lag_pairs} and +#' \code{short_lag_dist} (the semivariance of nearest-neighbour pairs +#' of locations with no model, their number and their median +#' separation: an upper bound on the nugget), +#' \code{zero_lag_semivariance} and \code{zero_lag_pairs} (the +#' semivariance of the pairs of rows that share a location, which is +#' the variance between visits to one place and a lower bound on the +#' nugget, and their number; \code{NA} and 0 when no location has two +#' rows), \code{nugget_floor} (the value the fitted nugget was not let +#' under: \code{zero_lag_semivariance} when the rows outnumber the +#' locations by 30 or more, else 0, and always 0 with +#' \code{detrend = "reml"}), \code{structure_p}, +#' \code{morans_i} and +#' \code{structure_test} (the adjusted p-value of the test for +#' spatial structure, Moran's I on the 8 nearest neighbours, and the +#' statistic, z and p for each neighbourhood size), +#' \code{structures} and \code{short_range} (how many structures the +#' model has besides the nugget, and the effective range of the short +#' one when there are two, \code{NA} otherwise), \code{lags}, +#' \code{lag_boundaries} and \code{lag_fallback} (the binning behind +#' the result, its upper bin edges, and \code{TRUE} when adaptive lags +#' were asked for and the equal-lag result is returned; see "The +#' lags"), and +#' \code{n_used}, \code{n_missing} and \code{n_subsampled} (the points +#' the variogram was computed on, the rows left out for a missing +#' response or predictor, and the rows left out by the \code{n_max} +#' subsample), so the fit can be inspected and need not #' be taken on trust.} -#' \item{Rejected range}{\code{NA_real_} when a range was fitted but is -#' not identified: it exceeds \code{range_frac * cutoff * max_dist} (see -#' \code{range_frac}), which applies to the all-pairs fit even when some -#' directions reached a sill; or too few pairs of points lie inside -#' it to identify it, because it is shorter than the shortest lag the -#' empirical variogram resolves (the mean separation in its first -#' bin) or, with \code{detrend = "reml"}, than the distance within -#' which 30 pairs of the points the REML fit used lie, when that is -#' shorter (the REML range is fitted to the point pairs, not to the -#' bins). A structure that short cannot be told from a nugget, and -#' the bound is about identification, not a test for spatial -#' structure (see above). Or the -#' model did not converge; or the empirical -#' variogram \emph{decreases} with distance over its shorter lags (a -#' net fall of more than 15 percent of the mean semivariance there, -#' weighted by pairs), which is the shape of a periodic, hole-effect -#' structure or of a variance that differs between a dense cluster and -#' the rest of the layer. Sampling noise in the short-lag bins of a -#' small sample can make that fall too: on exponential fields it -#' refused 7--9 of 60 draws at n = 30, 3--6 at n = 50 and 0--1 at -#' n = 100 (effective range 300 on a 1000 m square), and 15--16 of 60 -#' at n = 30 with a range of 150. An unremoved trend makes the -#' variogram rise instead; when it rises past the fitted lags the first -#' test catches it, but a milder trend only lengthens the fitted range -#' and passes, which is what \code{predictor_vars} is for. Last, the -#' fitted range can be non-positive. It is classed \code{sac_range} as -#' well, so it prints as \code{NA} without dumping its -#' attributes, and it carries \code{max_dist}, \code{cutoff_dist}, -#' \code{variogram}, \code{variogram_model} and \code{nugget} (the -#' evidence for the rejection), plus \code{rejected_range} (the value -#' that was refused), \code{rejected_reason} (one of -#' \code{"fitted range exceeds the largest lag fitted"}, -#' \code{"fitted range is below the shortest lag fitted"}, -#' \code{"variogram model did not converge"}, -#' \code{"empirical variogram decreases with distance"}, -#' \code{"fitted range is non-positive or non-finite"}, -#' \code{"no variogram model could be fitted (singular fits)"}), \code{crs} -#' (so the units the rejected number was in stay recoverable, which is -#' what \code{plot()} labels its axis from), -#' \code{detrend_method}, \code{reml} (as on success) and, for -#' \code{"fitted range is below the shortest lag fitted"}, -#' \code{range_floor} (the distance the refused range fell short of). -#' The reason names one ground for the refusal: a falling variogram -#' first, then a range past the largest lag, and the fit not having -#' converged only when neither holds. A fit that did not converge is -#' therefore most often recorded as past the largest lag, and the count -#' of \code{"variogram model did not converge"} understates how many -#' did not. The model itself says: -#' \code{attr(attr(range, "variogram_model"), "converged")} is -#' \code{FALSE} when no start of either model family converged -#' (\pkg{gstat} stopped at its iteration limit), whatever the reason, -#' and its nugget and sill are then where the optimiser halted, as its -#' range is. A model built from REML parameters carries no such -#' attribute. \code{\link{resolution_profile}()} reads it. -#' The refused range carries \code{directional}, -#' \code{anisotropy}, \code{anisotropy_used}, \code{directional_status}, -#' \code{directional_fitted} and, with -#' \code{keep_directional_fits = TRUE}, \code{directional_fits} as well: -#' the directional sweep runs whatever becomes of the all-pairs fit, and -#' its per-azimuth outcome is what says whether any direction reached -#' a sill the pooled variogram did not, or whether every direction ran -#' past the fitted lags alike. The same shape, with -#' \code{rejected_range = NA}, \code{variogram_model = NULL} and -#' \code{nugget = NA}, is returned when no variogram model could be -#' fitted at all (both the exponential and the spherical fit singular, -#' which a flat, nugget-only variogram can produce, though on white -#' noise it was the outcome in only 1 of 30 draws: see above); -#' \code{rejected_reason} says so and the empirical variogram is still -#' attached.} +#' \item{Rejected range}{\code{NA_real_} when no range is identified. +#' It is classed \code{sac_range} as well, so it prints as \code{NA} +#' without dumping its attributes, and it carries every attribute of +#' a success (the evidence for the rejection), plus +#' \code{rejected_range} (the value that was refused, \code{NA} when +#' none was fitted) and \code{rejected_reason}, one of: +#' \itemize{ +#' \item \code{"no spatial structure detected at the +#' nearest-neighbour scale"}: the test above. The model attached +#' is a pure nugget at the variance of the modelled variable, and +#' nothing fitted is handed on. +#' \item \code{"the empirical variogram is flat: no spatial +#' structure at the lags resolved"}: no model with a range fits +#' the variogram better than a constant. The model attached is +#' that constant, a pure nugget. +#' \item \code{"empirical variogram decreases with distance"}: the +#' semivariance falls over the shorter lags (a net fall of more +#' than 15 percent of the mean semivariance there, weighted by +#' pairs), which is the shape of a periodic, hole-effect +#' structure or of a variance that differs between a dense +#' cluster and the rest of the layer. Sampling noise in the +#' short-lag bins of a small sample can make that fall too. +#' \item \code{"fitted range exceeds the largest lag fitted"}: the +#' range is past \code{range_frac * cutoff * max_dist} (see +#' \code{range_frac}). An unremoved trend ends here when the +#' variogram rises past the fitted lags; a milder trend only +#' lengthens the fitted range and passes, which is what +#' \code{predictor_vars} is for. +#' \item \code{"fitted range is below the shortest lag fitted"}: +#' too few pairs of points lie inside the range to identify it, +#' because it is shorter than the shortest lag the +#' empirical variogram resolves (\code{first_lag}) or, with +#' \code{detrend = "reml"}, than the distance within +#' which 30 pairs of the points the REML fit used lie, when that is +#' shorter (the REML range is fitted to the point pairs, not to the +#' bins). A structure that short cannot be told from a nugget. +#' \code{range_floor} holds the distance the refused range fell +#' short of. +#' \item \code{"fitted range is non-positive or non-finite"}. +#' \item \code{"no variogram model could be fitted (singular +#' fits)"}: fewer than three lag bins hold point pairs. +#' \code{variogram_model} is \code{NULL} and \code{nugget} is +#' \code{NA}. +#' } +#' The reason names one ground for the refusal, in the order above. +#' \code{attr(attr(range, "variogram_model"), "converged")} says one +#' thing more about the model: it is \code{FALSE} when the +#' least-squares criterion is still falling at an edge of the ranges +#' searched (a variogram with no sill inside four cutoffs), and the +#' nugget and sill of such a model are that edge and not fitted +#' values. For a model with two structures the flag is that of the +#' equal-lag fit the long range came from: when that fit has no +#' minimum, the long structure's range and partial sill are the edge +#' of its search and the flag is \code{FALSE}, although the nugget +#' and the short structure were fitted at the adaptive lags. A model +#' built from REML parameters carries no such +#' attribute. \code{\link{resolution_profile}()} reads it, and takes +#' no nugget from a model marked \code{FALSE}. Results +#' stored by earlier versions can carry +#' \code{"variogram model did not converge"} as their reason and +#' \code{anisotropy_used = TRUE}; neither is produced any more.} #' \item{No fit}{An unclassed \code{NA_real_} when estimation could not #' be attempted at all, whose one attribute, \code{rejected_reason}, #' says why: \code{"package 'gstat', which the variogram needs, is not #' installed"}, \code{" points, fewer than the 30 a variogram range #' is estimated from"}, \code{" point(s) with a finite value to -#' model, fewer than the 30 a variogram range is estimated from"}, +#' model, fewer than the 30 a variogram range is estimated from"} +#' (the count is of the whole layer's rows with a value), #' \code{"the response is constant"}, \code{"the residuals on #' predictor_vars are constant: the predictors explain the response #' exactly"} or \code{"the points have no extent (the largest distance @@ -1958,6 +3061,9 @@ sac_nugget <- function(x) { #' \code{is.finite()}, so every downstream guard treats all three the same #' way it always did. #' @references +#' Cliff, A. D. and Ord, J. K. (1981). \emph{Spatial Processes: Models and +#' Applications}. Pion, London. +#' #' Lark, R. M., Cullis, B. R. and Welham, S. J. (2006). On spatial prediction #' of soil properties in the presence of a spatial trend: the empirical best #' linear unbiased predictor (E-BLUP) with REML. \emph{European Journal of @@ -1987,7 +3093,8 @@ sac_nugget <- function(x) { #' # shown on its own, and every one of these is worth reading. #' print(r) # the effective range, in metres #' print(attr(r, "directional")) # the four directional ranges -#' print(attr(r, "variogram_model")) # the fitted gstat model behind it +#' print(attr(r, "variogram_model")) # the fitted model behind it +#' print(attr(r, "structure_p")) # the test for spatial structure #' #' # A field whose range the data cannot pin down: the variogram never #' # reaches a sill within the lags fitted, so the answer is NA with the @@ -1996,7 +3103,14 @@ sac_nugget <- function(x) { #' r2 <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), #' response_var = "trend") #' print(r2) +#' attr(r2, "rejected_reason") #' attr(r2, "rejected_range") +#' +#' # White noise: no structure, so no range. +#' xy$noise <- rnorm(n) +#' r3 <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), +#' response_var = "noise") +#' attr(r3, "rejected_reason") #' } #' @export estimate_sac_range <- function(points_sf, response_var, @@ -2005,12 +3119,52 @@ estimate_sac_range <- function(points_sf, response_var, range_frac = 1.0, seed = 123L, detrend = c("ols", "reml"), reml_max_n = 400L, - keep_directional_fits = FALSE) { + keep_directional_fits = FALSE, + lags = c("adaptive", "equal"), + n_lags = 15L, + structure_alpha = 0.05) { detrend <- match.arg(detrend) + lags <- match.arg(lags) if (!is.numeric(reml_max_n) || length(reml_max_n) != 1L || !is.finite(reml_max_n) || reml_max_n < 30) stop("estimate_sac_range(): `reml_max_n` must be a single number of at ", "least 30.", call. = FALSE) + # A bad value used to come back as an unrelated refusal ("no variogram + # model could be fitted" for cutoff = 0) or as a bare R error that named no + # argument ("missing value where TRUE/FALSE needed"). + bad_arg <- function(arg, what, x) + stop(sprintf("estimate_sac_range(): `%s` must be %s; got %s.", arg, what, + if (is.null(x)) "NULL" + else if (length(x) != 1L) sprintf("%s of length %d", class(x)[1L], length(x)) + else if (is.numeric(x) || is.logical(x)) format(x) + else sprintf("%s (%s)", class(x)[1L], format(x))), + call. = FALSE) + one_number <- function(x) is.numeric(x) && length(x) == 1L && !is.na(x) + if (!one_number(cutoff) || !(cutoff > 0) || cutoff > 1) + bad_arg("cutoff", paste0("a single number above 0 and at most 1 (the share ", + "of the largest distance between two points that ", + "the lags run to)"), cutoff) + if (!one_number(range_frac) || !is.finite(range_frac) || !(range_frac > 0)) + bad_arg("range_frac", "a single finite number above 0", range_frac) + if (!one_number(n_max) || n_max < 30) + bad_arg("n_max", paste0("a single number of at least 30 (the fewest points ", + "a variogram range is estimated from; Inf for no ", + "subsample)"), n_max) + if (!is.logical(keep_directional_fits) || length(keep_directional_fits) != 1L || + is.na(keep_directional_fits)) + bad_arg("keep_directional_fits", "TRUE or FALSE", keep_directional_fits) + if (!is.null(seed) && (!one_number(seed) || !is.finite(seed) || + abs(seed) > .Machine$integer.max)) + bad_arg("seed", "NULL or a single whole number", seed) + if (!one_number(n_lags) || !is.finite(n_lags) || n_lags < 5 || n_lags > 100 || + n_lags != floor(n_lags)) + bad_arg("n_lags", "a single whole number from 5 to 100", n_lags) + if (!one_number(structure_alpha) || !(structure_alpha > 0) || structure_alpha > 1) + bad_arg("structure_alpha", paste0("a single number above 0 and at most 1 ", + "(1 switches the refusal off)"), structure_alpha) + n_max <- if (is.finite(n_max)) floor(n_max) else Inf + n_lags <- as.integer(n_lags) + # The early NA returns carry their reason as `rejected_reason`, so a caller # (make_folds(auto_range = TRUE), kriging_adequacy(), summarize_by_cell()) # can say why no range came back: the log line alone is invisible under @@ -2031,19 +3185,14 @@ estimate_sac_range <- function(points_sf, response_var, if (!all(sf::st_geometry_type(points_sf, by_geometry = TRUE) == "POINT")) points_sf <- coerce_to_points(points_sf, "auto") - # gstat::variogram() uses EVERY coordinate dimension, so an XYZ layer had its - # elevation folded into each lag and the returned "range" was a length in - # 3-D -- while the block grid, the buffered-LOO buffer, nndm's neighbour - # distances and summarize_by_cell(deff = "variogram") all work in 2-D map - # distance. Measured: 413.6 against 136.8 for the same stations with a - # 0-2000 m elevation column. Nothing warned. + # gstat::variogram() uses EVERY coordinate dimension, so an XYZ layer has + # its elevation folded into each lag and the "range" is a length in 3-D, + # while the block grid, the buffered-LOO buffer, nndm's neighbour distances + # and summarize_by_cell(deff = "variogram") all work in 2-D map distance. points_sf <- sf::st_zm(points_sf, drop = TRUE, what = "ZM") - # A row with an empty or non-finite geometry makes gstat fail in EVERY - # direction, so one bad point among 200 turned the whole layer's estimate - # into NA under a "no variogram model could be fitted" message -- blaming - # the fit rather than the row, and disagreeing with make_folds(), which drops such - # rows and says how many. + # A row with an empty or non-finite geometry makes gstat fail in every + # direction; it is dropped, with a count, as make_folds() drops it. bad_geom <- sf::st_is_empty(points_sf) if (!all(bad_geom)) { xy_chk <- suppressWarnings(sf::st_coordinates(points_sf[!bad_geom, ])) @@ -2056,54 +3205,29 @@ estimate_sac_range <- function(points_sf, response_var, points_sf <- points_sf[!bad_geom, , drop = FALSE] } - pts <- ensure_projected(points_sf) - - # Subsample if large. - # - # `seed` defaults to a constant, NOT to NULL. .with_seed(NULL) deliberately - # neither seeds nor restores -- the right behaviour for a function whose - # randomness is part of its answer -- but this subsample is not that: it is - # an internal approximation to keep an O(n^2) variogram tractable, and its - # only effects are to make the returned range irreproducible above n_max - # (measured: 19531, 19589, 19605 on three calls with identical input) and to - # advance the caller's RNG stream as a side effect of a function that looks - # like a summary statistic. make_folds(auto_range = TRUE) then sizes its - # blocks from a number that changes between runs. - n <- nrow(pts) - if (n > n_max) { - cleanup <- .with_seed(seed) - on.exit(cleanup(), add = TRUE) - idx <- sample.int(n, n_max) - pts <- pts[idx, , drop = FALSE] - n <- n_max - } - - if (n < 30L) { + if (nrow(points_sf) < 30L) { .log_warn("estimate_sac_range(): fewer than 30 points; variogram estimate unreliable. Returning NA.") return(structure(NA_real_, rejected_reason = sprintf( - "%d points, fewer than the 30 a variogram range is estimated from", n))) + "%d points, fewer than the 30 a variogram range is estimated from", + nrow(points_sf)))) } - # Build the variable to model: raw response or OLS residuals. - # - # Validate the column first. as.numeric() on a factor returns its LEVEL - # CODES -- 1, 2, 3 in whatever order the levels happen to sit -- so a factor - # response produced a variogram of an arbitrary integer relabelling of the - # categories, and the estimated range changed when the levels were reordered - # (measured: 3700 against 2497 on the same data). A character column becomes - # all-NA and is caught only by the "too few finite values" guard downstream, - # which blames the data rather than the column type. + # The variable to model: validate the column first. as.numeric() on a + # factor returns its LEVEL CODES, an arbitrary relabelling of the + # categories, so the range of a factor response changes when the levels are + # reordered; a character column becomes all-NA and would be blamed on the + # data rather than on the column type. if (!is.character(response_var) || length(response_var) != 1L || is.na(response_var)) stop("estimate_sac_range(): `response_var` must be a single column name.", call. = FALSE) - pts_df <- sf::st_drop_geometry(pts) - if (!(response_var %in% names(pts_df))) + df_all <- sf::st_drop_geometry(points_sf) + if (!(response_var %in% names(df_all))) stop(sprintf("estimate_sac_range(): column '%s' not found in `points_sf`.", response_var), call. = FALSE) - y <- pts_df[[response_var]] - if (!is.numeric(y)) { - if (is.logical(y)) { - y <- as.numeric(y) # 0/1 is a well-defined variogram target + y_all <- df_all[[response_var]] + if (!is.numeric(y_all)) { + if (is.logical(y_all)) { + y_all <- as.numeric(y_all) # 0/1 is a well-defined variogram target } else { stop(sprintf(paste0("estimate_sac_range(): response '%s' is %s, and a ", "variogram needs a numeric variable. A factor's ", @@ -2112,63 +3236,136 @@ estimate_sac_range <- function(points_sf, response_var, "changes when the levels are reordered. Encode the ", "column numerically first."), response_var, - if (is.factor(y)) "a factor" else sprintf("of class %s", - paste(class(y), collapse = "/"))), + if (is.factor(y_all)) "a factor" else sprintf("of class %s", + paste(class(y_all), collapse = "/"))), call. = FALSE) } } - detrended <- FALSE - detrend_method <- NA_character_ - reml_fit <- NULL - if (!is.null(predictor_vars) && length(predictor_vars) > 0L) { - df <- pts_df + has_pred <- !is.null(predictor_vars) && length(predictor_vars) > 0L + if (has_pred) { # A predictor that is not a column is an error, as it is everywhere else - # in the package: intersect() used to drop it silently, and with every - # name unknown the RAW response was modelled -- so make_folds(auto_range = - # TRUE) sized blocks from range 88.5 instead of the residual range 362.2 - # with nothing said. - missing_preds <- setdiff(predictor_vars, names(df)) + # in the package: dropped silently, the RAW response would be modelled. + missing_preds <- setdiff(predictor_vars, names(df_all)) if (length(missing_preds)) stop("estimate_sac_range(): predictor_vars ", paste(sQuote(missing_preds), collapse = ", "), " not found in the data.", call. = FALSE) - fml <- stats::reformulate(predictor_vars, response_var) - # The rows the trend is fitted on: a finite response and every predictor - # present and, if numeric, finite. lm()'s na.exclude drops NA but not - # Inf, so one Inf predictor or response aborted the fit ("NA/NaN/Inf in - # 'x'") and the variogram fell back to the RAW response, a different - # estimand (2950 against 2168 with that row removed); complete.cases() let - # it into the REML fit too, which then "did not converge". - # prep_model_data() and resolution_profile() already leave such rows out. - fin <- is.finite(y) & Reduce(`&`, lapply(predictor_vars, function(v) { - x <- df[[v]] + } + + # Rows with nothing to model go first, before the projection is chosen and + # before the n_max subsample is drawn. Drawn over every row, the subsample + # spent its budget on rows that never enter the variogram: 300 valued rows + # among 20,300 were estimated from the 74 that fell in the draw, and 100 + # among 20,100 came back as "20 point(s) with a finite value". lm()'s + # na.exclude drops NA but not Inf, so the rows are chosen here: a finite + # response and every predictor present and, if numeric, finite. + fin <- is.finite(y_all) + if (has_pred) { + fin_pred <- Reduce(`&`, lapply(predictor_vars, function(v) { + x <- df_all[[v]] if (is.numeric(x)) is.finite(x) else !is.na(x) }), TRUE) - if (any(!fin)) - .log_info(paste0("estimate_sac_range(): %d of %d row(s) have a missing or ", + if (!any(fin & fin_pred) && sum(fin) >= 30L) { + # No row at all has every predictor (one is missing on every row), so + # no trend can be fitted: the detrending fit fails, as it always did + # here, and the raw response is modelled. That is a different + # estimand, so it is an R warning, not a log line. When some rows are + # complete but fewer than 30, there is a trend to fit and too little + # to fit a variogram to: that is the NA below, with their count. + .warn_and_log(paste0("estimate_sac_range(): the %s detrending on %s ", + "failed (none of the %d row(s) with a response has ", + "every predictor present and finite); the ", + "variogram is fitted to the RAW response instead, ", + "which includes the trend."), + if (identical(detrend, "reml")) "REML" else "OLS", + paste(predictor_vars, collapse = " + "), sum(fin)) + has_pred <- FALSE + } else { + fin <- fin & fin_pred + } + } + n_missing <- sum(!fin) + if (n_missing > 0L) + .log_info(if (has_pred) + paste0("estimate_sac_range(): %d of %d row(s) have a missing or ", "non-finite response or predictor and are left out of ", - "the detrending fit and the variogram."), - sum(!fin), length(fin)) + "the detrending fit and the variogram.") + else + paste0("estimate_sac_range(): %d of %d row(s) have a missing or ", + "non-finite response and are left out of the variogram."), + n_missing, length(fin)) + if (sum(fin) < 30L) { + .log_warn("estimate_sac_range(): too few finite values after filtering; returning NA.") + return(structure(NA_real_, rejected_reason = sprintf(paste0( + "%d point(s) with a finite value to model, fewer than the 30 a ", + "variogram range is estimated from"), sum(fin)))) + } + if (n_missing > 0L) points_sf <- points_sf[fin, , drop = FALSE] + + # Rows in a canonical order: the coordinates as supplied first, then the + # response and the predictors to break ties between repeat visits to one + # location. Three steps below read the rows in order. The projection of a + # lon/lat layer is chosen by scoring candidates on rows taken at even + # spacing down the layer; the subsample indexes rows; and gstat sums the + # pairs of a bin in row order. Unsorted, the same layer with its rows + # permuted got another subsample and a variogram that differed in its last + # bits; sorted after the projection, a layer over a continental extent + # still got an Albers CRS in one row order and a Lambert azimuthal one in + # another, and a range of 506,838 against 505,530. So the sort comes + # before all three. Nothing below may read meaning into the order of rows + # that share a location: there it is the order of their values. + xy_in <- sf::st_coordinates(points_sf)[, 1:2, drop = FALSE] + df_in <- sf::st_drop_geometry(points_sf) + ord <- do.call(order, c( + list(xy_in[, 1L], xy_in[, 2L], as.numeric(df_in[[response_var]])), + if (has_pred) lapply(predictor_vars, function(v) { + x <- df_in[[v]] + if (is.numeric(x) || is.logical(x)) as.numeric(x) else as.character(x) + }), + list(method = "radix"))) + points_sf <- points_sf[ord, , drop = FALSE] + + pts <- ensure_projected(points_sf) + + # Subsample if large. `seed` defaults to a constant, NOT to NULL: the + # subsample is an internal approximation that keeps an O(n^2) variogram + # tractable, not part of the answer, so it must not make the range differ + # between runs on identical input or advance the caller's RNG stream. + n <- nrow(pts) + n_subsampled <- 0L + if (n > n_max) { + cleanup <- .with_seed(seed) + on.exit(cleanup(), add = TRUE) + idx <- sort(sample.int(n, n_max)) + pts <- pts[idx, , drop = FALSE] + n_subsampled <- as.integer(n - n_max) + n <- nrow(pts) + .log_info("estimate_sac_range(): the variogram is computed on a random subsample of %d of the %d point(s) with a value (n_max).", + n, n + n_subsampled) + } + + pts_df <- sf::st_drop_geometry(pts) + y_raw <- as.numeric(pts_df[[response_var]]) + y <- y_raw + xy <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] + detrended <- FALSE + detrend_method <- NA_character_ + reml_fit <- NULL + # The design of the trend removed from the response, for the structure + # test: an intercept alone unless a detrending fit succeeds. + X_design <- matrix(1, n, 1L) + if (has_pred) { + df <- pts_df + fml <- stats::reformulate(predictor_vars, response_var) # REML: trend and covariance fitted together, so the trend is a GLS fit # under the fitted correlation and the range is the REML estimate, not a - # variogram of residuals. Measured on simulated fields (n = 300, true - # effective range 300, 40-60 draws): the OLS residual variogram returned - # a median 0.97 of the oracle range for a spatially smooth covariate, 0.92 - # for a linear trend in the coordinates and 0.75 for a quadratic one; REML - # 0.95-1.06 throughout. On failure the OLS path below runs instead. + # variogram of residuals. On failure the OLS path below runs instead. if (identical(detrend, "reml")) { - xy_tr <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] - df$.sac_x <- xy_tr[, 1]; df$.sac_y <- xy_tr[, 2] - # Finite rows only, chosen here rather than by na.action so the same - # row set can carry the coordinates alongside the model frame and the - # residuals can be put back at their positions afterwards. - keep <- fin & is.finite(df$.sac_x) & is.finite(df$.sac_y) - mf <- df[keep, c(response_var, predictor_vars, ".sac_x", ".sac_y"), drop = FALSE] - if (sum(keep) >= 30L) { - extent <- max(diff(range(xy_tr[keep, 1])), diff(range(xy_tr[keep, 2])), 1) - reml_fit <- .reml_trend(mf, fml, extent = extent, max_n = reml_max_n, - seed = seed) - } + df$.sac_x <- xy[, 1L]; df$.sac_y <- xy[, 2L] + mf <- df[, c(response_var, predictor_vars, ".sac_x", ".sac_y"), drop = FALSE] + extent <- max(diff(range(xy[, 1L])), diff(range(xy[, 2L])), 1) + reml_fit <- .reml_trend(mf, fml, extent = extent, max_n = reml_max_n, + seed = seed) if (is.null(reml_fit)) { .warn_and_log(paste0("estimate_sac_range(): the REML detrending on %s ", "did not converge%s; falling back to OLS ", @@ -2180,13 +3377,12 @@ estimate_sac_range <- function(points_sf, response_var, } else { X <- try(stats::model.matrix(fml, mf), silent = TRUE) b <- if (inherits(X, "try-error")) NA_real_ else reml_fit$beta[colnames(X)] - if (inherits(X, "try-error") || anyNA(b) || nrow(X) != sum(keep)) { + if (inherits(X, "try-error") || anyNA(b) || nrow(X) != n) { .warn_and_log("estimate_sac_range(): the REML trend coefficients do not match the design; falling back to OLS detrending.") reml_fit <- NULL } else { - r_all <- rep(NA_real_, nrow(df)) - r_all[keep] <- as.numeric(mf[[response_var]] - X %*% b) - y <- r_all + y <- as.numeric(mf[[response_var]] - X %*% b) + X_design <- X detrended <- TRUE detrend_method <- "reml" .log_info(paste0("estimate_sac_range(): REML detrending on %s fitted ", @@ -2198,9 +3394,7 @@ estimate_sac_range <- function(points_sf, response_var, } } } - lm_fit <- if (is.null(reml_fit)) - try(stats::lm(fml, data = df[fin, , drop = FALSE]), silent = TRUE) - else NULL + lm_fit <- if (is.null(reml_fit)) try(stats::lm(fml, data = df), silent = TRUE) else NULL if (is.null(lm_fit)) { # REML handled the trend above; nothing to do here. } else if (inherits(lm_fit, "try-error")) { @@ -2213,32 +3407,45 @@ estimate_sac_range <- function(points_sf, response_var, .try_error_message(lm_fit)) } else { resid <- stats::residuals(lm_fit) - if (length(resid) != sum(fin)) { + if (length(resid) != n) { .warn_and_log("estimate_sac_range(): OLS residual length (%d) does not match data rows (%d); the variogram is fitted to the RAW response instead.", - length(resid), sum(fin)) + length(resid), n) } else { - y <- rep(NA_real_, length(fin)) - y[fin] <- as.numeric(resid) + y <- as.numeric(resid) + Xl <- try(stats::model.matrix(lm_fit), silent = TRUE) + if (!inherits(Xl, "try-error") && is.matrix(Xl) && nrow(Xl) == n) X_design <- Xl detrended <- TRUE detrend_method <- "ols" } } } - pts$..sac_var <- as.numeric(y) - pts <- pts[is.finite(pts$..sac_var), , drop = FALSE] - if (nrow(pts) < 30L) { + ok_y <- is.finite(y) + if (sum(ok_y) < 30L) { .log_warn("estimate_sac_range(): too few finite values after filtering; returning NA.") return(structure(NA_real_, rejected_reason = sprintf(paste0( "%d point(s) with a finite value to model, fewer than the 30 a ", - "variogram range is estimated from"), nrow(pts)))) + "variogram range is estimated from"), sum(ok_y)))) + } + if (!all(ok_y)) { + pts <- pts[ok_y, , drop = FALSE]; xy <- xy[ok_y, , drop = FALSE] + y <- y[ok_y]; y_raw <- y_raw[ok_y]; X_design <- X_design[ok_y, , drop = FALSE] + n <- length(y) } # A variable with no variance has no autocorrelation structure to estimate: - # every semivariance is 0, and gstat's fit returned a finite "range" (168 - # for an exactly-explained response, 673 for a constant one) that was then - # used to size blocks. There is no range; say so. - if (stats::sd(pts$..sac_var) < sqrt(.Machine$double.eps) * - max(1, abs(mean(pts$..sac_var)))) { + # every semivariance is 0. There is no range; say so. "No variance" is + # judged against the size of the response's own values and against nothing + # absolute: a spread under 1e-12 of the largest of them is rounding (the + # residuals of an exact fit come out near 1e-16 of it), and anything wider + # is data. The floor used to be sqrt(.Machine$double.eps) times max(1, + # |mean|), which called a response constant once its unit made its + # standard deviation smaller than 1.5e-8, and one of standard deviation 1 + # on a mean of 1e8 as well. The size is divided out before the squares + # are taken, so neither end of the floating-point range is in the way. + y_size <- max(abs(y_raw)) + y_mean <- mean(y) + y_sd <- if (is.finite(y_size) && y_size > 0) y_size * stats::sd(y / y_size) else 0 + if (!is.finite(y_sd) || !(y_sd > 1e-12 * y_size)) { .log_warn(paste0("estimate_sac_range(): the variable being modelled is ", "constant (zero variance%s), so it has no autocorrelation ", "range. Returning NA."), @@ -2249,14 +3456,18 @@ estimate_sac_range <- function(points_sf, response_var, "the residuals on predictor_vars are constant: the predictors explain the response exactly" else "the response is constant")) } - - # Empirical variogram. The lag cutoff is a fraction of the maximum - # inter-point distance, as documented -- NOT of the bounding-box diagonal. - # The diagonal is a property of the axes, not of the points: it grows by up - # to sqrt(2) when the same layer is rotated 45 degrees, so the variogram was - # binned differently and the fitted range moved (257 vs 394 on one field; - # pinning the cutoff restored 257 exactly). The farthest pair lies on the - # convex hull, whose vertex count is tiny, so this is cheap at any n. + y_var <- y_sd^2 + # The variogram is computed on the standardised variable and put back on + # the response's scale afterwards, and the model is fitted on scaled axes + # (see .sac_fit_model()), so nothing below depends on the unit of the + # response. Only the geometry and this one column go to gstat. + pts <- sf::st_sf(..sac_var = (y - y_mean) / y_sd, geometry = sf::st_geometry(pts)) + + # The lag cutoff is a fraction of the maximum inter-point distance, as + # documented, NOT of the bounding-box diagonal. The diagonal is a property + # of the axes, not of the points: it grows by up to sqrt(2) when the same + # layer is rotated 45 degrees. The farthest pair lies on the convex hull, + # whose vertex count is tiny, so this is cheap at any n. max_dist <- try({ hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(pts))) hv <- unique(sf::st_coordinates(hull)[, 1:2, drop = FALSE]) @@ -2272,441 +3483,353 @@ estimate_sac_range <- function(points_sf, response_var, cutoff_dist <- as.numeric(cutoff * max_dist) - # --- Helper: fit a variogram model and return the effective range -------- - # gstat::fit.variogram() signals a failed fit by setting attr(., "singular") - # to TRUE and emitting a warning -- it returns normally rather than throwing. - # Testing only for a try-error therefore (a) made the "Sph" fallback below - # unreachable, and (b) let a singular fit's `range` flow straight out as the - # estimated autocorrelation range, which make_folds(auto_range = TRUE) then - # sizes spatial blocks from. The `max_supported` guard further down only - # catches ranges beyond the fitted lags, not fitting artefacts inside them. - # A NON-CONVERGED fit is unusable for the same reason a singular one is: the - # returned `range` is wherever the optimiser happened to stop, not a fitted - # parameter. gstat signals it with a real R warning ("No convergence after - # 200 iterations") and then returns normally, so try() -- which catches only - # errors -- let both the warning escape to the user and the untrustworthy - # range flow onward. - # - # This matters more since the sweep went to four directions: each variogram - # gets about half the point pairs a two-direction sweep gave it, so a - # direction failing to converge is now routine rather than exceptional, and - # `plot(fit, type = "variogram")` started emitting a bare gstat warning on - # ordinary data. The caller already handles an unusable direction -- it is - # excluded from the maximum, and the isotropic fallback (which pools every - # pair, and therefore converges far more readily) takes over when fewer than - # two directions survive. So the answer is to refuse the fit, not to pass a - # warning up about a fit nothing was going to use. - # - # Other warnings are muffled but LOGGED rather than dropped: they say - # something about the data even when the fit is usable. - .fit_one_vgm <- function(vg, model_type) { - # WITH a nugget. gstat::vgm(model = "Exp") alone is a nugget-free model, - # which forces the fitted curve through the origin; on any real - # measurement (which has one) gstat's default N/h^2 weights then buy that - # constraint by collapsing the range. Measured on simulated fields with a - # 50% nugget the nugget-free fit returned about 0.45 of the true range, so - # make_folds(auto_range = TRUE) built blocks less than half the - # correlation length it reported. A nugget model on the same empirical - # variogram recovered the truth (ratio 1.09). The partial-sill range is - # the one to keep, and fit.variogram() returns the nugget as row 1 and the - # structured component as row 2, which .vgm_range_of() already reads. - fit_from <- function(range0) { - converged <- TRUE - m <- withCallingHandlers( - try(gstat::fit.variogram( - vg, gstat::vgm(psill = NA, model = model_type, range = range0, - nugget = NA)), - silent = TRUE), - warning = function(w) { - msg <- conditionMessage(w) - if (grepl("convergence", msg, ignore.case = TRUE)) { - converged <<- FALSE - } else { - .log_info("estimate_sac_range(): gstat::fit.variogram(%s) warned: %s", - model_type, msg) - } - invokeRestart("muffleWarning") - } - ) - if (inherits(m, "try-error") || !is.data.frame(m)) return(NULL) - if (isTRUE(attr(m, "singular"))) return(NULL) - attr(m, "converged") <- converged - m - } - # SEVERAL starting ranges, not gstat's one. With `range = NA` gstat - # starts the optimiser at a third of the longest lag; for a field whose - # range is a small fraction of the extent that start is ten times too - # long, the nugget and the partial sill trade off along the way, and - # whether the Gauss-Newton iteration lands or collapses to a singular - # model depends on floating-point details -- the same 250-point field fitted - # on one machine and came back singular on another. Shorter and longer - # starts are tried as well, and the winner is the converged, non-singular - # fit with the smallest weighted sum of squares (gstat's own criterion, - # attr "SSErr"), which is a property of the data rather than of the path - # the optimiser took. A non-converged fit is kept only when nothing - # converged: its range must never size a block -- that is what the - # `converged` flag is for -- but the model and its empirical variogram are - # still the most useful thing a user can look at, and a sill-less - # variogram is precisely the case worth looking at. - dmax <- max(vg$dist, na.rm = TRUE) - starts <- if (is.finite(dmax) && dmax > 0) - c(NA_real_, dmax / 10, dmax / 30, dmax / 2) else NA_real_ - fits <- Filter(Negate(is.null), lapply(starts, fit_from)) - if (!length(fits)) return(NULL) - conv <- vapply(fits, function(m) !identical(attr(m, "converged"), FALSE), - logical(1)) - if (any(conv)) fits <- fits[conv] - sse <- vapply(fits, function(m) { - v <- attr(m, "SSErr") - if (is.null(v) || !is.finite(v)) Inf else as.numeric(v) - }, numeric(1)) - fits[[which.min(sse)]] + # --- Is there spatial structure at all? ---------------------------------- + # A variogram model can be fitted to anything, and on white noise (300 + # points) it returned a finite range for 24 of 60 layers. The + # test is made before any range is believed; see .sac_structure_test(). + # The response and the trend's design go in, so that residuals are judged + # against the null that fits them. + structure_test <- tryCatch(.sac_structure_test(xy, y_raw, X_design), + error = function(e) { + .log_info("estimate_sac_range(): the test for spatial structure could not be computed (%s); no range is refused on its account.", + conditionMessage(e)) + NULL + }) + structure_p <- if (is.null(structure_test)) NA_real_ else structure_test$p + no_structure <- structure_alpha < 1 && is.finite(structure_p) && + structure_p >= structure_alpha + # The semivariance of nearest-neighbour pairs and of pairs at zero + # separation. Computed on the standardised variable, as gstat sees it + # (`zero_ss` stays on that scale: emp_vgm() takes those pairs out of the + # first bin with it), and reported in the units of the response's variance. + short_lag <- .sac_short_lag(xy, pts$..sac_var) + short_lag$gamma <- short_lag$gamma * y_var + short_lag$zero_gamma <- short_lag$zero_gamma * y_var + # The variance between visits to a location is a floor under the nugget: + # the semivariance at a positive lag has that variance in it, and the + # variation between locations on top. It is used when it rests on 30 + # degrees of freedom or more (rows less locations). Without it, on 100 + # locations visited 5 times with a range of 300 between them, the nugget + # extrapolated from the positive lags was under the variance between + # visits in 22 of 27 fits and exactly 0 in 7, while 1000 pairs of visits + # put that variance at 0.30 (0.28 to 0.32) for a truth of 0.3. + nugget_floor <- if (isTRUE(short_lag$zero_df >= 30L) && + is.finite(short_lag$zero_gamma)) short_lag$zero_gamma else 0 + + # --- Lag bins ------------------------------------------------------------- + # "adaptive": the first bin ends at the distance within which the closest + # max(50, n / 4) pairs lie and the rest are spaced geometrically out to + # the cutoff, with bins of fewer than 30 pairs merged into the next. + # "equal": n_lags bins of equal width, gstat's default at n_lags = 15. + # Both sets of boundaries exist whichever is asked for: the default looks + # at the equal bins as well (a second, longer structure; a range the + # adaptive bins leave past the lags). + bounds_of <- list( + adaptive = if (identical(lags, "adaptive")) + .sac_lag_boundaries(xy, cutoff_dist, n_lags = n_lags) else NULL, + equal = cutoff_dist * seq_len(n_lags) / n_lags) + emp_vgm <- function(alpha = NULL, binning = lags) { + adaptive <- identical(binning, "adaptive") + vg <- try( + if (is.null(alpha)) { + if (adaptive) + gstat::variogram(..sac_var ~ 1, data = pts, cutoff = cutoff_dist, + boundaries = bounds_of$adaptive) + else + gstat::variogram(..sac_var ~ 1, data = pts, cutoff = cutoff_dist, + width = cutoff_dist / n_lags) + } else { + if (adaptive) + gstat::variogram(..sac_var ~ 1, data = pts, cutoff = cutoff_dist, + boundaries = bounds_of$adaptive, alpha = alpha, + tol.hor = 22.5) + else + gstat::variogram(..sac_var ~ 1, data = pts, cutoff = cutoff_dist, + width = cutoff_dist / n_lags, alpha = alpha, tol.hor = 22.5) + }, + silent = TRUE) + if (inherits(vg, "try-error") || !inherits(vg, "data.frame") || !NROW(vg)) + return(NULL) + # Rows that share a location are pairs at zero separation, which gstat + # puts in the first bin of every variogram; they are not at a lag. + vg <- .sac_drop_zero_lag(vg, short_lag$zero_pairs, short_lag$zero_ss, + first_bound = bounds_of[[binning]][1L]) + if (!NROW(vg)) return(NULL) + if (adaptive) vg <- .sac_merge_bins(vg) + vg$gamma <- vg$gamma * y_var + vg } + # The largest lag the empirical variogram is fitted over. A fitted range + # beyond it is extrapolation past every observed lag rather than a long + # correlation length; each DIRECTION is tested against it too. + max_supported <- range_frac * cutoff_dist + # Top of the range grid, in cutoffs: past any range that can be accepted. + grid_upper <- max(4, 2 * range_frac) + + # --- Fit a variogram model and return its effective range ---------------- + # An exponential model WITH a nugget. A nugget-free model forces the curve + # through the origin, and on any real measurement (which has one) the + # N/h^2 weights buy that constraint by collapsing the range. NA when + # fewer than three bins hold pairs, or when no model with a range fits + # better than a constant; the model, and whether its minimum lies inside + # the ranges searched, travel as attributes. .fit_vgm_range <- function(vg) { - if (inherits(vg, "try-error") || !inherits(vg, "data.frame") || NROW(vg) < 3L) return(NA_real_) - # Exponential first, spherical as the fallback -- but a CONVERGED fit of - # either beats a non-converged fit of the preferred one. On a field with - # no nugget the exponential fit runs into the nugget's zero bound and - # gstat reports non-convergence from every start, while the spherical fit - # converges cleanly; taking the exponential's non-converged range would - # then throw away a usable estimate (and the caller must refuse a - # non-converged range, so the omnidirectional fit would count as failed). - fits <- list(Exp = .fit_one_vgm(vg, "Exp")) - conv <- function(m) !is.null(m) && !identical(attr(m, "converged"), FALSE) - if (!conv(fits$Exp)) fits$Sph <- .fit_one_vgm(vg, "Sph") - vgm_model <- if (conv(fits$Exp)) fits$Exp - else if (conv(fits$Sph)) fits$Sph - else if (!is.null(fits$Exp)) fits$Exp - else fits$Sph - if (is.null(vgm_model)) { - # Both the exponential and the spherical fit were singular or errored: - # there is no identified range, so say so rather than returning one. - .log_warn("estimate_sac_range(): both the exponential and the spherical fit to this variogram are singular; no range is identified from it.") - return(NA_real_) - } - spatial_rows <- vgm_model[vgm_model$model != "Nug", , drop = FALSE] - if (nrow(spatial_rows) == 0L || all(!is.finite(spatial_rows$range))) - return(NA_real_) - raw_range <- max(spatial_rows$range, na.rm = TRUE) - model_type <- spatial_rows$model[which.max(spatial_rows$range)] - eff <- if (identical(as.character(model_type), "Exp")) 3 * raw_range else raw_range + m <- .sac_fit_model(vg, cutoff_dist, "Exp", upper = grid_upper, + nugget_min = nugget_floor) + if (!is.data.frame(m)) return(NA_real_) + sp <- m[as.character(m$model) != "Nug", , drop = FALSE] + if (nrow(sp) == 0L || !all(is.finite(sp$range))) + return(structure(NA_real_, flat_model = m)) + eff <- 3 * max(sp$range) if (!is.finite(eff) || eff <= 0) return(NA_real_) - # Carry the fitted model out so callers can inspect the fit rather than - # trust a bare number, and the convergence flag with it: a range from an - # optimiser that stopped at its iteration limit is where it happened to - # stop, not a fitted parameter, so it must not size a block -- while the - # variogram behind it stays available to plot. - structure(eff, vgm_model = vgm_model, - converged = !identical(attr(vgm_model, "converged"), FALSE)) + structure(eff, vgm_model = m, + converged = !identical(attr(m, "converged"), FALSE)) } - # The largest lag the empirical variogram is fitted over. A fitted range - # beyond it is extrapolation past every observed lag rather than a long - # correlation length -- see the rejection block further down, which applies - # the same bound to the final answer. Hoisted here so each DIRECTION can be - # tested against it too. - max_supported <- range_frac * cutoff_dist + # --- One binning: the four directional variograms and the all-pairs one --- + # Directions at 0/45/90/135 degrees with a tolerance of 22.5: gstat counts + # azimuth clockwise from north (0 = N-S, 90 = E-W), and these four windows + # tile all 180 azimuths with no overlap and no gap. They are a diagnostic + # and never the answer: each sees about a quarter of the pairs, and the + # windows are fixed to the coordinate axes. + # + # The all-pairs variogram is the estimate. It pools every point pair, so + # it is the best-powered fit available and the only one that does not + # change when the layer is rotated. The directional maximum never stands + # in for it. It used to, when this fit was singular or had not converged: + # on isotropic fields (150 sites, effective range 30 km) that was 6 of 86 + # identified ranges, at a median 3.9 times the truth against 1.4 for the + # all-pairs answers. + dir_az <- c(0, 45, 90, 135) + first_lag_of <- function(vg) { + if (!is.data.frame(vg)) return(NA_real_) + d1 <- vg$dist[is.finite(vg$dist) & is.finite(vg$np) & vg$np > 0] + if (length(d1)) min(d1) else NA_real_ + } + sweep_lags <- function(binning, vg_iso = emp_vgm(binning = binning), + iso_fit = .fit_vgm_range(vg_iso)) { + dir_fits <- lapply(dir_az, function(az) { + vg_dir <- emp_vgm(az, binning = binning) + list(vg = vg_dir, fit = .fit_vgm_range(vg_dir)) + }) + dir_ranges <- vapply(dir_fits, function(f) as.numeric(f$fit), numeric(1)) + dir_conv <- vapply(dir_fits, + function(f) !identical(attr(f$fit, "converged"), FALSE), + logical(1)) + # A direction counts only if its fit is BOTH finite and identified, i.e. + # within the longest lag the variogram was fitted over. + dir_ok <- is.finite(dir_ranges) & dir_ranges <= max_supported & dir_conv + # The per-azimuth outcome, kept rather than collapsed: no model, a range + # past the fitted lags and a criterion with no minimum inside the ranges + # searched are three different findings. + dir_status <- ifelse(!is.finite(dir_ranges), "no_fit", + ifelse(dir_ranges > max_supported, "over_cutoff", + ifelse(!dir_conv, "not_converged", "ok"))) + usable <- dir_ranges + usable[!dir_ok] <- NA_real_ + list(lags = binning, lag_bounds = bounds_of[[binning]], + vg_iso = vg_iso, iso_fit = iso_fit, first_lag = first_lag_of(vg_iso), + dir_ranges = dir_ranges, dir_ok = dir_ok, + dir_success = sum(dir_ok) >= 2L, + dir_status = stats::setNames(dir_status, as.character(dir_az)), + dir_fitted = stats::setNames(dir_ranges, as.character(dir_az)), + dir_detail = stats::setNames(lapply(dir_fits, function(f) + list(variogram = if (inherits(f$vg, "data.frame")) f$vg else NULL, + model = attr(f$fit, "vgm_model"))), as.character(dir_az)), + usable = usable, + anisotropy = if (sum(dir_ok) >= 2L) + max(usable, na.rm = TRUE) / min(usable, na.rm = TRUE) else NA_real_) + } + # What the refusals further down will say of a range fitted to a + # variogram, in their order: "none" (no model with a range), "decreasing", + # "over" (past the fitted lags; a fit with no minimum inside the ranges + # searched ends here or at "under"), "under" (below the first lag), "ok". + range_verdict <- function(fit, vg, first_lag) { + r <- as.numeric(fit) + if (!is.finite(r) || r <= 0) return("none") + if (.variogram_decreasing(vg)) return("decreasing") + if (is.finite(max_supported) && r > max_supported) return("over") + if (is.finite(first_lag) && r < first_lag) return("under") + "ok" + } + + S <- sweep_lags(lags) - # --- Directional variograms (0/45/90/135 deg, tolerance 22.5 deg) -------- - # gstat uses azimuth in degrees clockwise from north. 0 = N-S, 90 = E-W. + # --- What the equal lags add to the adaptive ones ------------------------- + # One structure fitted to lags that resolve the closest pairs follows the + # SHORTEST structure of the layer, and those lags leave little weight on + # the long ones. Two things follow, and the equal-lag fit of the all-pairs + # variogram answers both. # - # FOUR directions, not two. A +/-22.5 window around 0 and 90 covers - # [337.5, 22.5] and [67.5, 112.5] -- exactly 90 of the 180 distinct azimuths. - # Every direction between 23 and 67 degrees, and between 113 and 157, fell - # into NEITHER window, so a field whose major axis lay there was measured by - # two variograms that both cut across it. Measured on simulated anisotropic - # fields (ratio 3:1, true major-axis range 300): the estimate came back at - # 255 and 249 for major axes at 0 and 90 degrees, but 151 and 147 at 45 and - # 135 -- half the true range. make_folds(auto_range = TRUE) sizes its blocks - # from this number, so a diagonally-oriented field silently got blocks half - # as wide as the correlation it was meant to separate, which is the exact - # leakage blocked CV exists to prevent. + # A second, longer structure. A layer that also has a weaker structure + # several times longer would have its blocks sized from the short one, + # which is the direction that leaks. Equal lags do not see the short + # structure and fit the long one. When the equal-lag range is at least + # twice the adaptive one, a model with both structures, at those two + # ranges, is fitted to the adaptive variogram (.sac_fit_nested()). It is + # kept, and the range is the long one, unless the long structure gets + # under 3 percent of that model's semivariance at the largest lag: then + # the lags that resolve the layer give the equal-lag range nothing, and + # the single structure stands. The bar is low on purpose. With a ratio + # of 3 and a share of 10 percent the long structure was dropped where the + # field has one: on a clustered layer of 1200 points over a 1000 m square + # (30 draws each) with structures of range 20 and 200, the range returned + # was under half the equal-lag one in 8 draws, and is in 1 now; with 40 + # and 400, in 8 and 1; with 30 and 300, in 8 and 0. The price is paid on + # layers with one short structure, where a noisy equal-lag range is + # believed more often: with one structure of range 40 a second is kept in + # 4 of 30 draws (0 before) and the range is within a factor 2 of the + # truth in 27 (29 before, 19 with equal lags); with range 30, 7 and 25 (0 + # and 29, and 14 with equal lags). That error is on the long side, where + # blocks are too large and a validation pessimistic, and `short_range` + # still holds the short structure. When the equal-lag range is one that + # lags = "equal" would itself refuse (past the fitted lags, most often), + # keeping it takes the answer away instead of lengthening it, and the bar + # stays at 10 percent: an unremoved trend clears it (of 12 draws of a + # short structure under a linear trend the equal-lag range ran past the + # lags in 11, and 9 of those cleared it), a noisy long lag mostly does not. # - # c(0, 45, 90, 135) at +/-22.5 tiles all 180 azimuths with no overlap and no - # gap. The cost is that each variogram uses about half as many pairs as a - # 2-direction sweep would, which is why the isotropic fallback below matters: - # on sparse data one of the four is more likely to fail to fit. - dir_az <- c(0, 45, 90, 135) - dir_fits <- lapply(dir_az, function(az) { - vg_dir <- try( - gstat::variogram(..sac_var ~ 1, data = pts, - cutoff = cutoff_dist, - alpha = az, tol.hor = 22.5), - silent = TRUE - ) - list(vg = vg_dir, fit = .fit_vgm_range(vg_dir)) - }) - dir_ranges <- vapply(dir_fits, function(f) as.numeric(f$fit), numeric(1)) - - # A direction counts only if its fit is BOTH finite and identified, i.e. - # within the longest lag the variogram was fitted over. The global check - # further down applies exactly this test to the final answer; applying it per - # direction as well is what keeps one starved direction from deciding the - # result. Splitting 180 degrees four ways leaves each variogram about half - # the point pairs a two-direction sweep would give it, so on small or - # irregular samples one direction can come back with a fit that never reaches - # a sill -- observed at 15908 and 24982 against 82-196 for the other three. - # Taking the max of that is not "conservative", it is reading a failed fit as - # a long correlation length, and the global guard then discards the whole - # estimate even though three directions agreed. - dir_conv <- vapply(dir_fits, - function(f) !identical(attr(f$fit, "converged"), FALSE), - logical(1)) - dir_ok <- is.finite(dir_ranges) & dir_ranges <= max_supported & dir_conv - # Two usable directions are enough to say something about anisotropy. Below - # that, the isotropic variogram -- which pools every pair and is therefore - # the stable estimate -- is the honest fallback. - dir_success <- sum(dir_ok) >= 2L - - # The per-azimuth outcome, kept rather than collapsed: `usable` below holds - # NA for every direction that failed, but a fit that never converged, one - # whose range ran past the fitted lags and one that could not be fitted at - # all are three different findings, and the refused range itself -- the - # most informative number when a field is anisotropic and the sweep could - # not use it -- was unrecoverable. All three ride on every classed return, - # the rejected ones included: the four fits ran regardless, and the - # rejected path is precisely where a user needs to know whether the field - # is anisotropic. The empirical variogram and fitted model of each - # direction travel too, so the sweep can be drawn. - dir_status <- ifelse(!is.finite(dir_ranges), "no_fit", - ifelse(!dir_conv, "not_converged", - ifelse(dir_ranges > max_supported, "over_cutoff", "ok"))) - dir_status <- stats::setNames(dir_status, as.character(dir_az)) - dir_fitted <- stats::setNames(dir_ranges, as.character(dir_az)) - dir_detail <- stats::setNames(lapply(dir_fits, function(f) - list(variogram = if (inherits(f$vg, "data.frame")) f$vg else NULL, - model = attr(f$fit, "vgm_model"))), as.character(dir_az)) - # Four empirical variograms, one per azimuth, are most of what this object - # weighs: at n = 400 they are 42.1 KB of a 59.3 KB estimate, and - # make_folds(auto_range = TRUE) parks one in `params`, which took that - # folds object from 52.4 KB to 94.6 KB -- for something nothing in the - # package reads. plot() draws the effective variogram from the - # `variogram` attribute, and the per-direction ranges and outcomes are in - # `directional`, `directional_fitted` and `directional_status` either way. - # Kept on request, for looking at the directional curves themselves. - dir_detail_out <- if (isTRUE(keep_directional_fits)) dir_detail else NULL - - # Defined here, not inside the branch below: the success return reports it as - # the `directional` attribute on BOTH paths, and the isotropic fallback never - # enters that branch. - usable <- dir_ranges - usable[!dir_ok] <- NA_real_ - anisotropy <- NA_real_ - aniso_used <- FALSE - fit_converged <- TRUE - vg_used <- NULL - vgm_used <- NULL - - # --- Select the effective range ------------------------------------------ - # The ISOTROPIC variogram is fitted unconditionally, not only as a fallback. - # It pools every point pair, so it is the best-powered estimate available, - # and it is the yardstick the directional sweep has to beat before its - # maximum is believed: splitting 180 degrees four ways leaves each - # directional variogram about a quarter of the pairs, and the maximum of - # four noisy estimates is biased upward. Measured on ISOTROPIC simulated - # fields, the max-of-four came in about 40% above the truth and the - # "notable anisotropy" warning fired on the majority of them -- so the - # warning was mostly false alarms and the number it reported was mostly - # sampling error. Blocks sized 40% too wide are not "conservative", they - # throw away training data in every fold. - vg_iso_always <- try( - gstat::variogram(..sac_var ~ 1, data = pts, cutoff = cutoff_dist), - silent = TRUE - ) - iso_fit_always <- .fit_vgm_range(vg_iso_always) - iso_ok <- is.finite(iso_fit_always) && - as.numeric(iso_fit_always) <= max_supported && - !identical(attr(iso_fit_always, "converged"), FALSE) - # A converged all-pairs fit whose range runs past the fitted lags is not an - # unusable fit but a finding: the pooled variogram, which sees every pair, - # reached no sill. The directional maximum must not stand in for it. The - # directions that did reach a sill are by construction the SHORTER ones (a - # trend's cross-slope directions, an anisotropic field's minor axes), so - # their maximum is a lower bound on the range, not an estimate of it, and - # whether two of them happened to fit flipped the answer between NA and a - # finite range from one draw to the next: with an east-west trend on an - # exponential field of range 150, 12 of 30 draws returned 131-596 this way - # with anisotropy_used = TRUE, and 16 others NA. It goes to the rejection - # below, as the documentation always said a trend would. - iso_over <- is.finite(iso_fit_always) && - !identical(attr(iso_fit_always, "converged"), FALSE) && - as.numeric(iso_fit_always) > max_supported - + # A range the adaptive lags leave past the largest lag. A weak, long + # structure under much noise (a nugget of half the sill or more) can show + # at equal lags and not at adaptive ones, whose long lags carry little + # weight. When the adaptive range is refused as past the fitted lags and + # the equal-lag fit has a range it would itself return, the equal-lag + # result is the answer, whole: its variogram, its model, its directional + # sweep and its first lag, as lags = "equal" gives them, with + # `lag_fallback` set. Of 120 such layers (four designs) that was 14. + # Nothing falls back from the other refusals: a range under the first + # adaptive lag or a flat adaptive variogram is no structure the wider + # equal bins can resolve, and on white noise that passed the structure + # test their equal-lag fits are what came back finite. + short_range <- NA_real_ + lag_fallback <- FALSE + if (identical(lags, "adaptive") && is.null(reml_fit)) { + ada <- range_verdict(S$iso_fit, S$vg_iso, S$first_lag) + if (ada %in% c("ok", "over")) { + eq_vg <- emp_vgm(binning = "equal") + eq_fit <- .fit_vgm_range(eq_vg) + eq_conv <- !identical(attr(eq_fit, "converged"), FALSE) + # Whether lags = "equal" would return the equal-lag range. + eq_ok <- eq_conv && + identical(range_verdict(eq_fit, eq_vg, first_lag_of(eq_vg)), "ok") + if (identical(ada, "ok") && is.finite(eq_fit) && + as.numeric(eq_fit) >= 2 * as.numeric(S$iso_fit)) { + two <- .sac_fit_nested(S$vg_iso, cutoff_dist, + r_short = as.numeric(S$iso_fit), + r_long = as.numeric(eq_fit), + min_share = if (eq_ok) 0.03 else 0.10, + converged = eq_conv, nugget_min = nugget_floor) + if (is.data.frame(two)) { + short_range <- 3 * two$range[2L] + .log_info(paste0("estimate_sac_range(): structure at two scales. The ", + "equal-lag fit has an effective range of %.4g, %.1f ", + "times the %.4g fitted on the adaptive lags, and a ", + "structure of that range carries %.0f%% of the ", + "semivariance at the largest lag. The model has both ", + "(short range %.4g) and the longer range is the ", + "estimate.%s"), + as.numeric(eq_fit), as.numeric(eq_fit) / as.numeric(S$iso_fit), + as.numeric(S$iso_fit), 100 * attr(two, "long_share"), + short_range, + if (eq_conv) "" else paste0( + " The equal-lag fit has no minimum inside the ranges ", + "searched, so the long range and its partial sill are the ", + "edge of the search and the model is marked converged = ", + "FALSE.")) + S$iso_fit <- structure(as.numeric(eq_fit), vgm_model = two, + converged = eq_conv) + } + } else if (identical(ada, "over") && eq_ok) { + .log_info(paste0("estimate_sac_range(): the range fitted on the ", + "adaptive lags (%.4g) is past the largest lag fitted ", + "(%.4g), and the equal-lag fit has a range inside the ", + "lags (%.4g). The equal-lag result is returned, as ", + "lags = \"equal\" gives it (attr(range, ", + "\"lag_fallback\") is TRUE): its nugget is ", + "extrapolated from a first bin %.4g wide."), + as.numeric(S$iso_fit), max_supported, as.numeric(eq_fit), + cutoff_dist / n_lags) + S <- sweep_lags("equal", vg_iso = eq_vg, iso_fit = eq_fit) + lag_fallback <- TRUE + } + } + } + # The binning behind the result: the one asked for unless it fell back. + lags_used <- S$lags + lag_bounds <- S$lag_bounds + vg_iso <- S$vg_iso + iso_fit <- S$iso_fit + first_lag <- S$first_lag + dir_ranges <- S$dir_ranges + dir_ok <- S$dir_ok + dir_success <- S$dir_success + dir_status <- S$dir_status + dir_fitted <- S$dir_fitted + usable <- S$usable + anisotropy <- S$anisotropy + # Four empirical variograms are most of what the object weighs and nothing + # in the package reads them, so they are kept on request only. + dir_detail_out <- if (isTRUE(keep_directional_fits)) S$dir_detail else NULL + + vg_used <- vg_iso + vgm_used <- NULL + effective_range <- NA_real_ if (!is.null(reml_fit)) { - # --- REML detrending: the range is the REML estimate --------------------- + # --- REML detrending: the range is the REML estimate ------------------- # Not a variogram fitted to the REML residuals: a residual variogram is - # biased toward a shorter range whatever fitted the trend (measured 0.80 - # of the oracle for GLS residuals under a quadratic trend), and the REML + # biased toward a shorter range whatever fitted the trend, and the REML # parameters are the estimate that does not carry that bias. The - # empirical variogram of the residuals is attached for inspection -- the - # model line drawn through it is the REML model, and a curve sitting - # below that line at long lags is the bias made visible -- and the - # directional sweep on the residuals stays the diagnostic it always is. + # empirical variogram of the residuals is attached for inspection, and + # the model line drawn through it is the REML model. effective_range <- 3 * reml_fit$range vgm_used <- gstat::vgm(psill = reml_fit$sigma2 * (1 - reml_fit$nugget_prop), model = "Exp", range = reml_fit$range, nugget = reml_fit$sigma2 * reml_fit$nugget_prop) - vg_used <- if (inherits(vg_iso_always, "data.frame")) vg_iso_always else NULL - if (dir_success) - anisotropy <- max(usable, na.rm = TRUE) / min(usable, na.rm = TRUE) - } else if (dir_success && !iso_over) { - dir_max <- max(usable, na.rm = TRUE) - anisotropy <- dir_max / min(usable, na.rm = TRUE) - winner <- which.max(usable) - if (any(!dir_ok)) - .log_info(paste0("estimate_sac_range(): %d of %d directional variograms ", - "did not yield an identified range (%s) and were ", - "excluded."), - sum(!dir_ok), length(dir_az), - paste(sprintf("%d\u00b0", dir_az[!dir_ok]), collapse = ", ")) - - # Anisotropy has to clear TWO hurdles before the directional maximum is - # used: a ratio the sweep itself considers notable, and a maximum that - # stands clearly above the all-pairs estimate. On an isotropic field the - # second hurdle is what the noise cannot clear, because the isotropic fit - # is centred on the truth while the directional maximum scatters around - # it. - # Three hurdles, and the first is the one the noise cannot fake: ALL FOUR - # directions must have produced a usable fit. Geometric anisotropy is a - # smooth function of azimuth, so it shows up in every direction; a sweep in - # which two directions failed to reach a sill has no azimuthal pattern to - # report, only two noisy numbers, and taking their ratio as evidence is how - # a field with a true range of 80 came back at 248 (the all-pairs fit said - # 84). Then the usual two: a ratio the sweep considers notable, and a - # maximum that stands clearly above the all-pairs estimate. - # The directional maximum is NEVER preferred over a usable all-pairs fit. - # Three hurdles were tried (all four directions fitted, ratio > 1.5, - # maximum > 1.5 x the all-pairs estimate) and still let the noise through: - # on ONE isotropic exponential field (true range 150, n = 300) they - # declared anisotropy in 14 of 18 axis orientations and returned ranges - # from 225 to 529 -- a 2.35x spread produced by nothing but the direction - # the axes happened to point. Four windows fixed in CRS azimuth cannot - # give a rotation-invariant answer, and the maximum of four quarter-sample - # fits is biased upward whatever hurdle is put in front of it. So the - # all-pairs range is the estimate; the directional ranges are reported as - # a diagnostic, and a caller who KNOWS the field is anisotropic can size - # blocks from the longest directional range explicitly. Not from - # max(attr(x, "directional")): on exactly such a field the major axis is - # the direction most likely to run past the fitted lags, which makes it NA - # there and the maximum NA (or, with na.rm = TRUE, the second-longest). - if (iso_ok) { - effective_range <- as.numeric(iso_fit_always) - vg_used <- vg_iso_always - vgm_used <- attr(iso_fit_always, "vgm_model") - if (is.finite(anisotropy) && anisotropy > 1.5) - .log_info( - paste0("estimate_sac_range(): the directional ranges vary by a factor ", - "of %.1f (%s). Each direction sees about a quarter of the ", - "point pairs and the windows are fixed to the coordinate axes, ", - "so this spread is expected on an isotropic field too; the ", - "all-directions estimate (%.1f) is used. If the field is known ", - "to be anisotropic, size blocks from the longest directional ", - "range instead: max(attr(range, \"directional_fitted\"), ", - "na.rm = TRUE), after checking attr(range, ", - "\"directional_status\"), since a direction that is not \"ok\" ", - "has no identified range."), - anisotropy, - paste(sprintf("%d\u00b0 = %.1f", dir_az[dir_ok], dir_ranges[dir_ok]), - collapse = ", "), - as.numeric(iso_fit_always)) - } else { - # The isotropic fit is singular or did not converge (one that converged - # past the fitted lags goes to the refusal instead, see `iso_over`); the - # directional sweep is all there is. - aniso_used <- TRUE - effective_range <- dir_max - vg_used <- dir_fits[[winner]]$vg - vgm_used <- attr(dir_fits[[winner]]$fit, "vgm_model") - if (is.finite(anisotropy) && anisotropy > 1.5) - .log_warn( - "estimate_sac_range(): notable anisotropy detected (range ratio %.1f). Directional ranges: %s. Using the maximum.", - anisotropy, - paste(sprintf("%d\u00b0 = %.1f", dir_az[dir_ok], dir_ranges[dir_ok]), - collapse = ", ") - ) - } + } else if (is.finite(iso_fit)) { + effective_range <- as.numeric(iso_fit) + vgm_used <- attr(iso_fit, "vgm_model") } else { - # --- Isotropic variogram (fallback when directional fits fail) ---------- - # Also reached when the all-pairs fit converged past the fitted lags - # (`iso_over`), whatever the directions did, so the refusal below sees it. - # The same all-pairs variogram and fit as above; it was recomputed here, - # which cost a second fit and logged its failure twice. - vg_iso <- vg_iso_always - iso_range <- iso_fit_always - if (dir_success) - anisotropy <- max(usable, na.rm = TRUE) / min(usable, na.rm = TRUE) - if (is.finite(iso_range)) { - # A gstat fit that stopped at its iteration limit reports a range that is - # wherever the optimiser happened to be, not a fitted parameter. Record - # it so the rejection block below refuses the VALUE while keeping the - # variogram for inspection. - fit_converged <- !identical(attr(iso_range, "converged"), FALSE) - # as.numeric() strips the vgm_model attribute .fit_vgm_range() attaches; - # it is re-attached under its documented name below, and leaving both - # would ship the same object under two attribute names. - effective_range <- as.numeric(iso_range) - vg_used <- vg_iso - vgm_used <- attr(iso_range, "vgm_model") - } else { - # Neither directional nor isotropic succeeded. The VALUE is NA, but the - # empirical variogram is still the thing to look at: both fits being - # singular is one thing a flat, nugget-only variogram produces -- - # residuals with no spatial structure at the lags resolved -- and - # returning a bare NA left plot(type = "variogram") unable to draw - # exactly that picture ("could not be fitted; there may be too few - # finite residuals"). Only one: on 30 draws of white noise this branch - # was reached once, and eight came back with a finite (spurious) range. - .log_warn(paste0("estimate_sac_range(): no variogram model could be fitted ", - "(the exponential and spherical fits are both singular, ", - "which a flat, nugget-only variogram can produce); ", - "returning NA. The empirical variogram is attached for ", - "inspection: call plot() on the returned value.")) - return(structure( - NA_real_, - class = c("sac_range", "numeric"), - directional = stats::setNames(usable, as.character(dir_az)), - anisotropy = anisotropy, - anisotropy_used = FALSE, - directional_status = dir_status, - directional_fitted = dir_fitted, - directional_fits = dir_detail_out, - detrended = isTRUE(detrended), - detrend_method = detrend_method, - max_dist = as.numeric(max_dist), - cutoff_dist = as.numeric(cutoff_dist), - crs = sf::st_crs(pts), - variogram = if (inherits(vg_iso, "data.frame")) vg_iso else NULL, - variogram_model = NULL, - nugget = NA_real_, - rejected_range = NA_real_, - rejected_reason = "no variogram model could be fitted (singular fits)" - )) - } + # No structured model: a flat variogram (a pure nugget is the best fit), + # or too few bins to fit one to. + vgm_used <- attr(iso_fit, "flat_model") } # The nugget of whatever model stands behind the answer, identified or not: - # the semivariance at zero separation, which a resolution criterion needs - # and which used to be reachable only by reading gstat's row layout. + # its semivariance as the separation shrinks to zero. A fit that runs + # into the nugget's lower bound reports 0 (or, by REML, a value within + # rounding of it), which is the bound and not an estimate; it is marked, + # never handed on bare. nugget_val <- .vgm_nugget_of(vgm_used) - # The REML fit's own numbers, on the refusals as on the success: a refused - # REML range is exactly where how many points it used and how much of the - # variance it put in the nugget are worth reading. + sill_val <- if (is.data.frame(vgm_used)) sum(as.numeric(vgm_used$psill)) else NA_real_ + nugget_at_bound <- if (is.finite(nugget_val) && is.finite(sill_val) && sill_val > 0) + nugget_val <= 1e-4 * sill_val else NA + # Bins inside the fitted range; with two structures, inside the short one, + # which is the one the nugget is told apart from. + bins_below <- if (is.finite(effective_range) && is.data.frame(vg_used)) + sum(vg_used$dist < (if (is.finite(short_range)) short_range else effective_range)) + else NA_integer_ + # The REML fit's own numbers, on the refusals as on the success. reml_attr <- if (is.null(reml_fit)) NULL else list(n_used = reml_fit$n_used, subsampled = isTRUE(reml_fit$subsampled), - nugget_prop = reml_fit$nugget_prop, sigma2 = reml_fit$sigma2) - - if (!is.finite(effective_range) || effective_range <= 0) { - # Classed like every other refusal, so the evidence travels with the NA; - # this used to be the one path that returned a bare, attribute-less NA - # from inside a completed fit. - .log_warn("estimate_sac_range(): estimated range is non-positive or non-finite; returning NA.") - return(structure( - NA_real_, + nugget_prop = reml_fit$nugget_prop, sigma2 = reml_fit$sigma2, + logLik = reml_fit$logLik, + logLik_gain = reml_fit$logLik - reml_fit$logLik_null, + n_fits = reml_fit$n_fits) + + # Every classed return is built here, so each carries the same evidence: + # the directional sweep, the variogram, the model, the nugget and how far + # it can be trusted, the structure test, and what the lags and the row + # counts were. + finish <- function(value, ...) { + structure( + value, class = c("sac_range", "numeric"), directional = stats::setNames(usable, as.character(dir_az)), anisotropy = anisotropy, - anisotropy_used = isTRUE(aniso_used), + # Always FALSE: the all-pairs fit is the estimate or there is none. + # Kept so that code reading it, and objects stored with it, still work. + anisotropy_used = FALSE, directional_status = dir_status, directional_fitted = dir_fitted, directional_fits = dir_detail_out, @@ -2715,60 +3838,128 @@ estimate_sac_range <- function(points_sf, response_var, reml = reml_attr, max_dist = as.numeric(max_dist), cutoff_dist = as.numeric(cutoff_dist), + # The CRS the variogram was fitted in: the unit of the range. crs = sf::st_crs(pts), variogram = vg_used, variogram_model = vgm_used, nugget = nugget_val, - rejected_range = as.numeric(effective_range), - rejected_reason = "fitted range is non-positive or non-finite" - )) + nugget_at_bound = nugget_at_bound, + first_lag = as.numeric(first_lag), + bins_below_range = bins_below, + short_lag_semivariance = short_lag$gamma, + short_lag_pairs = short_lag$pairs, + short_lag_dist = short_lag$dist, + zero_lag_semivariance = short_lag$zero_gamma, + zero_lag_pairs = short_lag$zero_pairs, + # The floor the variogram fit held the nugget to; the REML model is + # not fitted to the variogram and has none. + nugget_floor = if (is.null(reml_fit)) nugget_floor else 0, + structure_p = structure_p, + morans_i = if (is.null(structure_test)) NA_real_ else structure_test$morans_i, + structure_test = if (is.null(structure_test)) NULL else structure_test$table, + structures = if (is.data.frame(vgm_used)) + sum(as.character(vgm_used$model) != "Nug") else NA_integer_, + short_range = as.numeric(short_range), + lags = lags_used, + lag_fallback = lag_fallback, + lag_boundaries = as.numeric(lag_bounds), + n_used = as.integer(n), + n_missing = as.integer(n_missing), + n_subsampled = as.integer(n_subsampled), + ... + ) + } + + # --- No spatial structure: no range, whatever was fitted ------------------ + if (no_structure) { + best <- structure_test$table[which.min(structure_test$table$p), , drop = FALSE] + .log_warn( + paste0("estimate_sac_range(): no spatial structure detected at the ", + "nearest-neighbour scale: Moran's I of %s on the %d nearest ", + "neighbours is %.3f (z = %.2f), the strongest of the %d ", + "neighbourhoods tested, and the adjusted p-value is %.3f, not ", + "below structure_alpha = %s.%s Neighbouring values are no more ", + "alike than distant ones, so there is no range to estimate. ", + "Returning NA. plot() the returned value to see the variogram; ", + "set structure_alpha = 1 to fit a range regardless."), + if (detrended) "the residuals on predictor_vars" else "the response", + best$k, best$morans_i, best$z, nrow(structure_test$table), structure_p, + format(structure_alpha), + if (isTRUE(structure_test$n_locations < n)) + sprintf(paste0(" The %d rows lie at %d locations, and the test is ", + "made on the location means: rows that share a ", + "location are not neighbours."), + n, structure_test$n_locations) + else "") + # The model the test supports is a pure nugget at the sample variance. + # Whatever was fitted is not attached: a spurious fit's nugget was under + # half the sill in 7 of 60 white-noise layers at n = 300. + vgm_used <- gstat::vgm(psill = y_var, model = "Nug", range = 0) + attr(vgm_used, "converged") <- TRUE + nugget_val <- y_var + nugget_at_bound <- FALSE + bins_below <- NA_integer_ + short_range <- NA_real_ + return(finish(NA_real_, rejected_range = NA_real_, + rejected_reason = .sac_reason_no_structure)) + } + + if (is.null(reml_fit) && !is.finite(iso_fit)) { + if (is.data.frame(vgm_used)) { + .log_warn(paste0("estimate_sac_range(): the empirical variogram is flat: ", + "no model with a range fits it better than a constant ", + "(%.3g), so there is no range to estimate at the lags ", + "resolved (%.3g to %.3g). Returning NA. The empirical ", + "variogram is attached for inspection: call plot() on ", + "the returned value."), + nugget_val, first_lag, cutoff_dist) + return(finish(NA_real_, rejected_range = NA_real_, + rejected_reason = .sac_reason_flat)) + } + .log_warn(paste0("estimate_sac_range(): no variogram model could be fitted: ", + "fewer than three lag bins hold point pairs; returning NA. ", + "The empirical variogram is attached for inspection: call ", + "plot() on the returned value.")) + return(finish(NA_real_, rejected_range = NA_real_, + rejected_reason = "no variogram model could be fitted (singular fits)")) + } + + if (any(!dir_ok) && dir_success) + .log_info(paste0("estimate_sac_range(): %d of %d directional variograms ", + "did not yield an identified range (%s) and were ", + "excluded from the directional diagnostic."), + sum(!dir_ok), length(dir_az), + paste(sprintf("%d\u00b0", dir_az[!dir_ok]), collapse = ", ")) + + if (!is.finite(effective_range) || effective_range <= 0) { + .log_warn("estimate_sac_range(): estimated range is non-positive or non-finite; returning NA.") + return(finish(NA_real_, rejected_range = as.numeric(effective_range), + rejected_reason = "fitted range is non-positive or non-finite")) } # --- Reject ranges the data cannot actually support ----------------------- - # gstat::fit.variogram() returns a finite number even when the empirical - # variogram never reaches a sill. The range is then unidentified and the - # value is a fitting artefact, not an autocorrelation range. - # - # The test is against the CUTOFF distance, not the extent: the empirical - # variogram is only computed out to `cutoff * max_dist`, so a fitted range - # beyond that is extrapolation past the longest lag ever observed. No amount - # of data at shorter lags identifies it. (With the default cutoff = 0.5 this - # is half the extent, but the rationale is the fitted lag limit rather than an - # arbitrary fraction of the study area.) - # - # Returning such a value silently is worse than returning NA, because - # make_folds(auto_range = TRUE) sizes spatial blocks from it: a range - # spanning the data yields one block covering everything, which silently - # defeats blocked cross-validation. - over_cutoff <- is.finite(max_supported) && effective_range > max_supported + # A model fit returns a finite number even when the empirical variogram + # never reaches a sill. The range is then unidentified and the value is a + # fitting artefact, not an autocorrelation range. The test is against the + # CUTOFF distance, not the extent: a fitted range beyond the longest lag + # observed is extrapolation. Returning such a value silently is worse than + # returning NA, because make_folds(auto_range = TRUE) sizes spatial blocks + # from it: a range spanning the data yields one block covering everything. + over_cutoff <- is.finite(max_supported) && effective_range > max_supported # A semivariance that FALLS with distance over the shorter lags has no sill # to reach, so the range fitted through it is not identified either. This - # is not the trend signature -- a trend makes the curve rise without a sill, - # which `over_cutoff` catches -- but a periodic (hole-effect) structure, or - # a variance that differs between a dense cluster and the rest of the layer - # (see .variogram_decreasing() for the measured rates). - decreasing <- .variogram_decreasing(vg_used) + # is not the trend signature (a trend makes the curve rise without a sill, + # which `over_cutoff` catches) but a periodic (hole-effect) structure, or + # a variance that differs between a dense cluster and the rest of the layer. + decreasing <- .variogram_decreasing(vg_used) # The mirror of `over_cutoff` at the other end of the lags: a range too # short for enough pairs of points to lie inside it is not identified, and - # the data cannot tell it from a nugget. For the variogram fits the bound + # the data cannot tell it from a nugget. For the variogram fit the bound # is the shortest lag the variogram resolves (the mean separation in its - # first non-empty bin): a range below it was fitted to no bin inside it. - # The REML range is fitted to the point pairs themselves, not to the bins, - # so its bound is the distance within which the points it used have 30 - # pairs (the usual minimum per lag), capped at that first lag so that it - # never refuses what the bin bound accepts. Against the first lag alone the - # REML answer depended on a `cutoff` it never uses: 10 of 20 REML estimates - # of a true 30 m range (n = 400, 1000 m square) were refused at 14.5-28.8 - # m, and all ten came back at cutoff = 0.1; now none is refused at either. - # The cap keeps some of that dependence where the first lag is the shorter - # (a small cutoff, or a sparse layer). The bound is about identification, - # not a test for structure: iid noise can put 30 pairs inside a spurious - # range (3 of the 19 white-noise REML ranges below the first lag, n = 300, - # now pass at 21-24 m), and a true short range can fall below it. - first_lag <- if (is.data.frame(vg_used) && all(c("dist", "np") %in% names(vg_used))) { - d1 <- vg_used$dist[is.finite(vg_used$dist) & is.finite(vg_used$np) & vg_used$np > 0] - if (length(d1)) min(d1) else NA_real_ - } else NA_real_ + # first bin). The REML range is fitted to the point pairs themselves, not + # to the bins, so its bound is the distance within which the points it + # used have 30 pairs (the usual minimum per lag), capped at that first lag + # so that it never refuses what the bin bound accepts. range_floor <- first_lag floor_is_pairs <- FALSE if (!is.null(reml_fit) && is.finite(reml_fit$pair_floor %||% NA_real_) && @@ -2777,15 +3968,12 @@ estimate_sac_range <- function(points_sf, response_var, floor_is_pairs <- TRUE } under_lag <- is.finite(range_floor) && effective_range < range_floor - # Non-convergence is refused on the same terms and for the same reason: the - # number is not a fitted parameter. gstat signals it with a warning and - # returns anyway, which is why it needs its own test rather than riding on - # the cutoff bound -- a non-converged range can land inside the bound and - # would otherwise have sized a block. - if (over_cutoff || !fit_converged || decreasing || under_lag) { - # What to try next. "Supply `predictor_vars`" was said of a range that - # was already of the residuals on them. REML is suggested only where it - # was not asked for (a REML fit that failed has fallen back to OLS). + + if (over_cutoff || decreasing || under_lag) { + # What to try next. "Supply `predictor_vars`" must not be said of a + # range that is already of the residuals on them. REML is suggested only + # where it was not asked for (a REML fit that failed has fallen back to + # OLS). detrend_advice <- if (isTRUE(detrended)) paste0("try predictors that carry the trend (coordinate terms, for ", "instance)", @@ -2804,12 +3992,10 @@ estimate_sac_range <- function(points_sf, response_var, "the returned value, and set a block size explicitly."), effective_range, # The fixed 15% tolerance does not widen with the sampling noise of - # the short-lag bins: 7-9 of 60 ordinary exponential fields were - # refused at n = 30, 0-1 at n = 100 (see .variogram_decreasing()). - if (nrow(pts) < 100L) + # the short-lag bins, so small samples trip it on ordinary fields. + if (n < 100L) sprintf(paste0(" With %d points the short-lag bins are noisy enough ", - "for an ordinary field to show this shape as well."), - nrow(pts)) + "for an ordinary field to show this shape as well."), n) else "" ) } else if (over_cutoff) { @@ -2825,7 +4011,7 @@ estimate_sac_range <- function(points_sf, response_var, effective_range, max_supported, format(range_frac), cutoff_dist, detrend_advice ) - } else if (fit_converged && !is.null(reml_fit)) { + } else if (!is.null(reml_fit)) { .log_warn( paste0("estimate_sac_range(): the REML range (%.3g) is shorter than ", "%s (%.3g): fewer than 30 pairs of the %d points the REML fit ", @@ -2838,107 +4024,72 @@ estimate_sac_range <- function(points_sf, response_var, "(the mean separation in its first bin)"), range_floor, as.integer(reml_fit$n_used) ) - } else if (fit_converged) { + } else if (identical(lags_used, "equal")) { .log_warn( paste0("estimate_sac_range(): the fitted range (%.3g) is shorter than ", "the shortest lag the variogram resolves (%.3g, the mean ", "separation in its first bin), so no lag inside it was fitted ", "and it cannot be told from a nugget. Returning NA. If the ", "empirical variogram is at its sill from the first bin, re-run ", - "with a smaller `cutoff` (the bins are cutoff * max_dist / 15 ", - "wide); plot() the returned value to see it."), + "with a smaller `cutoff` (the bins are cutoff * max_dist / ", + "n_lags wide) or with lags = \"adaptive\", which starts the ", + "bins at the closest pairs; plot() the returned value to see it."), effective_range, range_floor ) } else { .log_warn( - paste0("estimate_sac_range(): the variogram model did not converge ", - "(gstat stopped at its iteration limit), so the range it ", - "reports (%.0f) is where the optimiser halted rather than a ", - "fitted parameter. Returning NA. Raise `cutoff` to fit longer ", - "lags, %s, or set a block size explicitly. The empirical ", - "variogram is attached for inspection: call plot() on the ", - "returned value."), - effective_range, detrend_advice + paste0("estimate_sac_range(): the fitted range (%.3g) is shorter than ", + "the shortest lag the variogram resolves (%.3g, the mean ", + "separation of the closest pairs of points, which fill its ", + "first bin), so no lag inside it was fitted and it cannot be ", + "told from a nugget. Returning NA. The points are too far apart ", + "to measure a range that short; plot() the returned value to ", + "see the variogram."), + effective_range, range_floor ) } - # The VALUE is NA -- the range is genuinely unidentified and must not be - # used to size blocks -- but the variogram that justified the rejection has - # already been computed, and throwing it away leaves the user no way to see - # WHY. It is exactly the case where plot(type = "variogram") is most worth - # looking at: a curve that never reaches a sill. Attributes do not affect - # is.finite()/is.na(), so every downstream guard behaves as before. - # - # The class is set here too, exactly as on the success return. Without it - # print.sac_range() never fired for a rejected range, so printing one - # dumped the whole empirical variogram and the fitted gstat model to the - # console as raw attributes instead of showing "NA". - return(structure( + # The VALUE is NA: the range is unidentified and must not size blocks. + # The variogram that justified the rejection travels with it, so the + # refusal can be looked at: attributes do not affect is.finite()/is.na(). + return(finish( NA_real_, - class = c("sac_range", "numeric"), - directional = stats::setNames(usable, as.character(dir_az)), - anisotropy = anisotropy, - anisotropy_used = isTRUE(aniso_used), - directional_status = dir_status, - directional_fitted = dir_fitted, - directional_fits = dir_detail_out, - detrended = isTRUE(detrended), - detrend_method = detrend_method, - reml = reml_attr, - max_dist = as.numeric(max_dist), - cutoff_dist = as.numeric(cutoff_dist), - crs = sf::st_crs(pts), - variogram = vg_used, - variogram_model = vgm_used, - nugget = nugget_val, rejected_range = as.numeric(effective_range), rejected_reason = if (decreasing) "empirical variogram decreases with distance" else if (over_cutoff) "fitted range exceeds the largest lag fitted" - else if (fit_converged) - "fitted range is below the shortest lag fitted" - else "variogram model did not converge", + else "fitted range is below the shortest lag fitted", # The distance the refused range fell short of, for that refusal only. - range_floor = if (!decreasing && !over_cutoff && fit_converged) + range_floor = if (!decreasing && !over_cutoff) as.numeric(range_floor) else NULL )) } - structure( - effective_range, - class = c("sac_range", "numeric"), - directional = stats::setNames(usable, as.character(dir_az)), - anisotropy = anisotropy, - # Whether the returned number is the directional maximum (anisotropy - # established) or the all-pairs estimate. Without it the `directional` - # attribute alone cannot tell a caller which of the two was used, and - # plot(type = "variogram") needs to know whose variogram it is drawing. - anisotropy_used = isTRUE(aniso_used), - # Per azimuth: why a direction is NA in `directional`, the range its fit - # reported whether or not it was usable, and the empirical variogram and - # model behind it. - directional_status = dir_status, - directional_fitted = dir_fitted, - directional_fits = dir_detail_out, - # Whether the variogram is of OLS residuals on `predictor_vars` (TRUE) or - # of the raw response. make_folds(auto_range = TRUE) and - # summarize_by_cell(deff = "variogram") both need to know which. - detrended = isTRUE(detrended), - # "ols" or "reml" when detrended, NA otherwise; and the REML fit's own - # numbers when it was used, so the caller can see how much of the layer - # the trend was estimated on. - detrend_method = detrend_method, - reml = reml_attr, - max_dist = as.numeric(max_dist), - cutoff_dist = as.numeric(cutoff_dist), - # The CRS the variogram was fitted in. Its range is a length in these - # units; summarize_by_cell(deff = "variogram") transforms the points to it - # before evaluating the correlation function at within-cell distances. - crs = sf::st_crs(pts), - variogram = vg_used, - variogram_model = vgm_used, - nugget = nugget_val - ) + if (is.finite(anisotropy) && anisotropy > 1.5 && is.null(reml_fit)) + .log_info( + paste0("estimate_sac_range(): the directional ranges vary by a factor ", + "of %.1f (%s). Each direction sees about a quarter of the ", + "point pairs and the windows are fixed to the coordinate axes, ", + "so this spread is expected on an isotropic field too; the ", + "all-directions estimate (%.1f) is used. If the field is known ", + "to be anisotropic, size blocks from the longest directional ", + "range instead: max(attr(range, \"directional_fitted\"), ", + "na.rm = TRUE), after checking attr(range, ", + "\"directional_status\"), since a direction that is not \"ok\" ", + "has no identified range."), + anisotropy, + paste(sprintf("%d\u00b0 = %.1f", dir_az[dir_ok], dir_ranges[dir_ok]), + collapse = ", "), + effective_range) + if (isTRUE(nugget_at_bound)) + .log_info(paste0("estimate_sac_range(): the fitted nugget (%.3g on a sill ", + "of %.3g) is at its lower bound, so it is a bound and not ", + "an estimate (attr(range, \"nugget_at_bound\") is TRUE). ", + "The semivariance of nearest-neighbour pairs, %.3g at a ", + "median separation of %.3g, bounds the nugget from above."), + nugget_val, sill_val, short_lag$gamma, short_lag$dist) + + finish(effective_range) } @@ -2952,21 +4103,30 @@ estimate_sac_range <- function(points_sf, response_var, } -#' Whether the gstat fit behind a variogram model converged, or NA -#' -#' estimate_sac_range() marks every model gstat fits with a `converged` -#' attribute (see .fit_one_vgm()): FALSE when the optimiser stopped at its -#' iteration limit from every start, so that the range, the sill and the -#' nugget are where it halted. This is the record of non-convergence to read. -#' `rejected_reason` names one ground for a refusal, and a falling variogram -#' and a range past the largest lag come before the optimiser in it, so a fit -#' that did not converge and whose range also runs past the fitted lags is -#' "fitted range exceeds the largest lag fitted". That is most of them: 96 -#' of the 102 all-pairs fits that did not converge over 200 simulated layers -#' (trends, ranges longer than the extent, 40-60 points, white noise) carried -#' that reason, and 6 "variogram model did not converge". NA when the model -#' says nothing either way: one built from REML parameters, one made by hand, -#' or no model at all. +#' Whether the fit behind a variogram model found a minimum, or NA +#' +#' estimate_sac_range() marks every model it fits with a `converged` +#' attribute (see .sac_fit_model()): FALSE when the weighted least-squares +#' criterion is still falling at an edge of the ranges searched, so that the +#' range, the sill and the nugget are that edge and not a minimum. That is +#' a variogram with no sill inside four cutoffs (or a structure far below +#' the first lag), and its nugget is not a fitted value either. +#' `rejected_reason` names one ground for a refusal and does not say this: +#' such a fit is "fitted range exceeds the largest lag fitted" (or "... is +#' below the shortest lag fitted"), as is a fit with a proper minimum just +#' past the lags, whose nugget is sound. The flag is what tells the two +#' apart, and resolution_profile() reads it. A model with two structures +#' carries the flag of the equal-lag fit that gave the long range (see +#' .sac_fit_nested()): FALSE there means the long range and its partial sill +#' are the edge of that search, so the model's sill is not a fitted value. +#' Its nugget and short structure were fitted at the adaptive lags and are +#' sound, but the flag is one bit for the whole model and is read as it +#' always was: nothing is taken from a model marked FALSE. NA when the +#' model says nothing +#' either way: one built from REML parameters, one made by hand, or no model +#' at all. Objects stored by earlier versions carry gstat's verdict here +#' (FALSE when its optimiser stopped at the iteration limit), which is read +#' the same way. #' @keywords internal #' @noRd .vgm_converged <- function(vm) { @@ -3061,7 +4221,9 @@ print.sac_range <- function(x, ...) { #' Compute grid dimensions that respect a minimum block size #' #' Given a bounding box and a minimum block edge length, returns nx/ny -#' values such that each cell is at least \code{block_size} wide and tall. +#' values such that each cell is at least \code{block_size} long on every +#' axis of the extent that is at least that long; a shorter axis gets one +#' row or column, whose cells are as long as the extent there. #' #' @param bb An sf bbox. #' @param block_size Positive numeric minimum block edge length (CRS units). @@ -3162,8 +4324,8 @@ print.sac_range <- function(x, ...) { #' Create spatial cross-validation folds #' #' Builds train/test splits by random k-fold, spatial block k-fold, -#' leave-location-out, buffered leave-one-out or nearest-neighbour distance -#' matching (NNDM) leave-one-out. +#' leave-location-out, buffered leave-one-out, nearest-neighbour distance +#' matching (NNDM) leave-one-out or its k-fold version (kNNDM). #' #' For \code{block_kfold}, the default grid sizing is purely geometric and #' unrelated to the autocorrelation range of the data. When blocks are @@ -3171,7 +4333,13 @@ print.sac_range <- function(x, ...) { #' leak across folds and CV metrics become optimistic. Use #' \code{block_size} to set a minimum block edge length (in CRS units), or #' set \code{auto_range = TRUE} to estimate the range from an empirical -#' variogram and enforce it automatically. +#' variogram and enforce it automatically. When a response is given and the +#' blocks come out smaller than the estimated range, the warning says what +#' range-sized blocks would yield on this layout before recommending them: +#' the setting and the grid it builds when that gives \code{k} folds, and +#' otherwise how many folds it gives (or that it leaves a single block), the +#' largest block size that still gives \code{k} folds, and +#' \code{method = "nndm"} as the design that needs no block size. #' #' @param points_sf An sf object. Any Z or M dimension is dropped before #' folding: \code{sf::st_distance()} uses every coordinate dimension, so an @@ -3185,21 +4353,34 @@ print.sac_range <- function(x, ...) { #' A fraction, \code{NA} or a vector is an error, because a non-integer used #' to truncate silently and leave the last rows in no test set at all. #' Not every method honours it. \code{"buffered_loo"} and \code{"nndm"} are -#' leave-one-out schemes and always return \code{k = n} regardless of what +#' leave-one-out schemes and always return one fold per held-out point +#' (\code{k = n}, or \code{max_test} when that is given) regardless of what #' was asked for; \code{"block_kfold"} lowers it when the grid yields fewer #' than \code{k} non-empty blocks, and \code{"leave_location_out"} lowers it -#' when there are fewer than \code{k} distinct groups. \code{k = 1} is -#' raised to 2 by \code{"random_kfold"}, \code{"block_kfold"} and -#' \code{"leave_location_out"}, since one fold has no training set. Read +#' when there are fewer than \code{k} distinct groups. \code{"random_kfold"} +#' and \code{"knndm"} lower it only when the layer has fewer than \code{k} +#' rows. \code{k = 1} is +#' raised to 2 by \code{"random_kfold"}, \code{"block_kfold"}, +#' \code{"leave_location_out"} and \code{"knndm"}, since one fold has no +#' training set. Read #' the \code{k} element of the returned list, and do not assume the -#' requested value. A -#' reduction is written to the package log and raises no R warning, so -#' \code{tryCatch(warning = )} will not see it and \code{suppressWarnings()} -#' will not hide it. +#' requested value; \code{params$k_requested} keeps the value asked for. +#' Returning fewer folds than asked raises a warning of class +#' \code{"spatialkit_k_reduced"}, whose message gives both counts, the +#' reason and a setting that works; the condition carries them as +#' \code{k_requested} and \code{k}, so +#' \code{tryCatch(spatialkit_k_reduced = )} or +#' \code{withCallingHandlers()} can act on it without reading the text. +#' (Before this version a reduction was a log line only.) #' @param method One of \code{"random_kfold"}, \code{"block_kfold"}, -#' \code{"buffered_loo"}, \code{"leave_location_out"} or \code{"nndm"}. See -#' \strong{Details} for what each one does and when it is appropriate. -#' @param seed Optional integer RNG seed. +#' \code{"buffered_loo"}, \code{"leave_location_out"}, \code{"nndm"} or +#' \code{"knndm"}. See \strong{Details} for what each one does and when it +#' is appropriate. +#' @param seed Optional integer RNG seed. \code{"nndm"} is deterministic and +#' reads it only to draw the \code{max_test} subset; \code{"buffered_loo"} +#' likewise. \code{"knndm"} uses it for the random partition among its +#' candidates, for ties in the packing, and above 4,000 points for the +#' k-means starts, so its folds are reproducible only with a seed. #' @param block_nx,block_ny Optional grid dimensions for block_kfold, each a #' single whole number >= 1. Give both, or give one and the other is #' derived from the extent's aspect ratio so that the blocks are roughly @@ -3220,10 +4401,21 @@ print.sac_range <- function(x, ...) { #' block size that matters for leakage is the autocorrelation range, which #' is what \code{block_size} and \code{auto_range} control. #' @param block_size Optional positive numeric minimum block edge length, -#' \strong{in the units of the CRS the folds are built in}. When supplied, -#' grid dimensions are clamped so that every block is at least this wide and -#' tall. Takes precedence over \code{block_nx}/\code{block_ny} and -#' \code{block_multiplier}. +#' \strong{in the units of the CRS the folds are built in}. Takes +#' precedence over \code{block_nx}/\code{block_ny} and +#' \code{block_multiplier}. When supplied, a whole number of blocks is +#' fitted across each axis of the extent: as many as leave every block at +#' least this long on that axis. On an axis at least as long as +#' \code{block_size} the blocks built are therefore from one to just under +#' two times this size. An axis shorter than \code{block_size} cannot +#' hold a block that long: a single row or column spans it, and its blocks +#' are as long as the extent on that axis, which is less than the size +#' asked (a 39.8 km by 5 km extent with \code{block_size = 10000} gets +#' three blocks 13.3 km wide and 5 km tall). \code{params$block_width} and +#' \code{params$block_height} record what was built. A size that leaves +#' fewer than \code{k} blocks holding points returns that many folds, +#' with a warning (see \code{k}); one that leaves a single block is an +#' error. Both name the largest size that still gives \code{k} folds. #' #' Which CRS that is depends on the input. Projected input is used as it #' stands, so \code{block_size} is in your own CRS's units. Geographic @@ -3255,11 +4447,17 @@ print.sac_range <- function(x, ...) { #' times that parameter for an exponential fit), so its blocks are larger #' than \pkg{blockCV}'s from the same variogram. When no range is #' identified, the geometric grid is used instead, with a warning that -#' gives the reason. An identified range above half the extent in both -#' directions leaves room for a single block, and \code{make_folds()} then -#' stops with an error naming the size, rather than return one fold with -#' an empty training set: pass a smaller \code{block_size}, or use -#' \code{method = "nndm"}. +#' gives the reason. Range-sized blocks do not fit every layout. On a +#' square extent at \code{k = 5} a range up to a third of the side gives +#' five folds; up to half, a 2 x 2 grid and four folds, returned with the +#' \code{"spatialkit_k_reduced"} warning; and above half the extent in +#' both directions there is room for a single block, and +#' \code{make_folds()} stops with an error naming the size, rather than +#' return one fold with an empty training set. The warning and the error +#' name the largest block size that still gives \code{k} folds on this +#' layout and how far below the range it is; \code{method = "nndm"} is the +#' design that does not depend on a block size. The message printed when +#' the range is used states the grid and the block size built. #' @param range_frac Passed through to \code{estimate_sac_range()} when #' \code{auto_range = TRUE}. A fitted range beyond the longest lag the #' empirical variogram was fitted over is rejected as unidentified, and block @@ -3295,7 +4493,8 @@ print.sac_range <- function(x, ...) { #' sites it has already seen, which random k-fold reports as excellent #' performance. #' @param prediction_points Optional \code{sf} layer of the locations you -#' actually intend to predict onto. Required for \code{method = "nndm"}. +#' actually intend to predict onto. Required for \code{method = "nndm"} and +#' \code{method = "knndm"}. #' The grid from \code{\link{predict_surface}()} is the natural choice; a #' non-POINT layer (grid cells, polygons) is reduced to representative points #' first, so the target distances are point-to-point. A point-to-polygon @@ -3306,7 +4505,12 @@ print.sac_range <- function(x, ...) { #' data any fold's training set may be reduced to by neighbour exclusion. #' Default \code{0.5}, as in \code{CAST::nndm()}. Where it binds, the #' distance matching stops short and the cross-validation stays optimistic; -#' see \strong{Details}. +#' see \strong{Details}. For \code{method = "knndm"}: the smallest fraction +#' of the data a fold may leave for training, so a candidate whose largest +#' fold holds more than \code{1 - min_train} of the rows is set aside (the +#' \code{maxp = 0.5} of \code{CAST::knndm()} is \code{min_train = 0.5}). +#' Equal folds leave \code{1 - 1/k} of the data, so a value above that is +#' an error. #' @param phi For \code{method = "nndm"}: the distance up to which the two #' nearest-neighbour distance distributions are matched, in the CRS the #' folds are built in. Matching is attempted only while a held-out @@ -3361,21 +4565,165 @@ print.sac_range <- function(x, ...) { #' their row index as in CAST, so the folds do not depend on the order of the #' rows. #' -#' Where neither limit binds, the realised distribution is then never -#' \emph{more optimistic} than the target: \eqn{G_j^*(r) \le G_{ij}(r)} up to -#' the granularity of the neighbour distances, which is the property the -#' method exists to deliver. Beyond \code{phi} no matching is attempted, by +#' Where neither limit binds, the realised distribution of +#' \emph{nearest-neighbour distances} is then never shorter than the target: +#' \eqn{G_j^*(r) \le G_{ij}(r)} up to the granularity of the neighbour +#' distances, which is the property the method exists to deliver. It is a +#' statement about the distance to the one nearest training point. A learner +#' that draws on several neighbours (a forest, a k-nearest-neighbour mean, a +#' kriging neighbourhood) also depends on how far the second and later +#' neighbours are, which NNDM does not match, so on clustered samples its +#' cross-validated error can still read low with the nearest-neighbour +#' distances matched exactly. Beyond \code{phi} no matching is attempted, by #' design. \code{min_train} is different: when the prediction locations lie #' further from the samples than a fold can be made to hold out (clustered #' samples and a prediction domain well beyond them, the layout NNDM is meant #' for), it stops the matching early and the realised distances stay -#' optimistic. \code{params$n_at_min_train} counts the folds that were held +#' too short. \code{params$n_at_min_train} counts the folds that were held #' at the floor while still closer than the target allows, and #' \code{make_folds()} warns when that leaves more than one point's worth of #' excess at or below \code{phi}. Lower \code{min_train} to match further, or #' read the cross-validated score as an upper bound on performance at the #' prediction locations. #' +#' The match has a second side. \code{params$max_ecdf_deficit} is the +#' largest amount by which the target distribution runs above the realised +#' one, the mirror of \code{params$max_ecdf_excess}: the share of prediction +#' points within some distance of the data that the folds do not reproduce. +#' Part of it is the granularity of the matching. Excluding a neighbour +#' moves a held-out point out to its next remaining neighbour, and on +#' clustered samples that can be the next cluster, well past the prediction +#' distances. +#' +#' The other part no setting reaches. Excluding neighbours can only lengthen +#' a held-out distance, so when the prediction points sit \emph{nearer} to +#' the data than the samples sit to each other (prediction points among the +#' samples, or a regular sample predicted between its nodes) the folds +#' returned are plain leave-one-out and are still farther from their +#' training data than the prediction points are. The cross-validated error +#' is then pessimistic for those locations: an upper bound on the error +#' there. \code{params$loo_ecdf_deficit} is the largest amount by which +#' the target distribution runs above that of plain leave-one-out. When it +#' exceeds \code{params$ecdf_deficit_tol}, three times +#' \eqn{\sqrt{1/n + 1/m}} for \eqn{n} folds and \eqn{m} prediction points +#' (about three times the chance difference between two samples of one +#' distribution), \code{make_folds()} raises a warning of class +#' \code{"spatialkit_nndm_out_of_reach"} and sets +#' \code{params$target_out_of_reach} to \code{TRUE}. +#' +#' On small samples no deficit can exceed that tolerance. A deficit is a +#' difference of two shares, so it is at most 1, and the tolerance is 1 or +#' more whenever \eqn{nm/(n+m) \le 9}: for nine folds or fewer whatever the +#' number of prediction points, and for up to eighteen folds with as many +#' prediction points. There the same warning is raised in one case only, +#' complete separation: every prediction point nearer to the data than any +#' sample is to its nearest other sample (a deficit of exactly 1), provided +#' the two sets are large enough for that ordering to mean something, which +#' is taken as \code{choose(n + m, n) >= 1000} ways of interleaving them (17 +#' prediction points for 3 folds, 7 for 6 folds, 4 for 12 folds). +#' \code{params$target_separated} records the ordering whether or not it +#' was enough to warn, and the warning's condition carries it as +#' \code{separated}. With very few samples it can hold for a grid over the +#' samples' own extent, because a few points hug the box they span; the +#' folds are then farther than the grid all the same. A partial shortfall +#' on such a sample (most prediction points nearer than leave-one-out +#' reaches, not all) is not warned about: the tolerance is 1 or more at +#' these sizes, which no difference of shares exceeds, so only complete +#' separation can be reported. Compare +#' \code{params$target_median} with \code{params$realised_median}. +#' +#' \code{params$wasserstein} is the Wasserstein distance between the target +#' and realised distributions, in distance units, and +#' \code{params$wasserstein_loo} the same for plain leave-one-out: equal +#' when nothing was excluded, smaller when the matching helped. +#' +#' \strong{kNNDM.} \code{"knndm"} is the k-fold version of that idea +#' (Linnenbrink et al. 2024): \code{k} folds, and so \code{k} model fits, +#' whose held-out distances are as close to the same target as a set of +#' candidates allows. It has no row limit, and is the method to use above +#' the 5,000 rows \code{"nndm"} takes or when a model is too costly to refit +#' once per point. It is not an equal of NNDM below that: a fold design has +#' far fewer degrees of freedom than one exclusion set per point, so the +#' match is coarser. +#' +#' The candidates are a random k-fold partition (the one +#' \code{"random_kfold"} builds with the same \code{seed}) and, for each of +#' up to 50 cluster counts spaced evenly on the log scale from \code{k} to +#' one fewer than the number of distinct locations, the samples clustered on +#' their coordinates and the clusters merged into \code{k} folds. Few large +#' clusters give folds that are whole regions, far from their training data; +#' many small ones approach the random partition. Up to 4,000 points the +#' clustering is Ward's (\code{stats::hclust(method = "ward.D2")}), cut at +#' each count. Above that, where the n by n distance matrix it needs is no +#' longer affordable, k-means first reduces the samples to 4,000 groups +#' (Lloyd's algorithm from random sample locations, at most ten passes) and +#' Ward's method is continued from those groups; a count above 4,000 is a +#' k-means run of its own. \code{params$clustering} says which +#' (\code{"ward"} or \code{"kmeans+ward"}). Clusters are merged by the packing +#' \code{"block_kfold"} uses for its blocks, largest first and each to the +#' fold with the fewest points so far (see \strong{Fold balance}). +#' \code{CAST::knndm()} merges clusters by a rule of its own, which this was +#' \emph{not} checked against, so the folds are not expected to equal CAST's. +#' +#' Each candidate is scored by the Wasserstein distance \eqn{W} between its +#' held-out distances (each point's distance to the nearest point of another +#' fold) and the target distances, and the smallest \eqn{W} is returned. A +#' candidate is set aside without being scored when its largest fold leaves +#' less than \code{min_train} of the rows for training or holds more than +#' \code{balance_tol} times the points of its smallest; the random partition +#' is always kept. So \code{params$wasserstein} is never above +#' \code{params$wasserstein_random}, the \eqn{W} of that random partition, +#' and \code{params$candidates} lists every candidate with its cluster count, +#' fold sizes and \eqn{W}. \code{params$chosen} is \code{"random"} when no +#' clustering came closer, which is the right answer for samples spread +#' evenly over the prediction area. +#' +#' Read \eqn{W} against the mean target distance. On 400 points in 12 +#' clusters predicted onto a grid over their extent (12 draws, 5 and 10 +#' folds) the folds returned had \eqn{W} at 0.32 of the mean target distance, +#' against 0.70 to 0.72 for a random partition and 0.01 for \code{"nndm"}. +#' A 5-nearest-neighbour learner scored 9 to 11 percent high on them, where +#' random folds scored 23 to 25 percent low and \code{"nndm"} 6 percent low. +#' On 2,000 points in 40 clusters of unequal size the ratio was 0.07 to +#' 0.10, against 0.56 to 0.59 for a random partition and 0.003 to 0.006 for +#' \code{"nndm"}; on 30,000 points of that layout it was 0.11 to 0.15, and +#' on 100,000 points 0.27. So the method removes most of the mismatch of a +#' random partition and leaves more of it than NNDM does, in either +#' direction: \eqn{W} has no sign. On 400 evenly spread points the random +#' partition or one close to it came back and the two scored alike (3.3 and +#' 3.5 percent high). With few folds a random partition is itself farther +#' than the target, since each fold trains on \code{1 - 1/k} of the points: +#' at \code{k = 2} on evenly spread points the mean held-out distance was 9 +#' to 53 percent above the target mean (60 draws of 100 to 1,000 points), +#' and no candidate is nearer. +#' +#' Construction took 2 s at 8,000 points and 10 s at 30,000 with ten folds +#' (37 s at 100,000) with \pkg{FNN} installed, and three to four times that +#' without it; it grows with the number of folds. +#' +#' Two cases are warned about, each with a condition class. When the +#' prediction points sit nearer to the data than a sample is to its nearest +#' other sample, no fold design reaches them, since a held-out point is never +#' nearer to its training data than that; the test is the one +#' \code{"nndm"} applies, the warning has the same class, +#' \code{"spatialkit_nndm_out_of_reach"}, and what comes back is the random +#' partition or a candidate as fine as one. In the other direction, the +#' closest candidate can still be +#' short of the target: prediction points well beyond the samples lie farther +#' from the data than \code{k} folds of those samples can be held apart. +#' When the mean held-out distance of the folds returned is below the mean +#' target distance by more than a quarter of it and by at least half of +#' \eqn{W} (the test \code{\link{fold_separation}()} words as +#' \code{"closer"}), \code{make_folds()} raises a warning of class +#' \code{"spatialkit_knndm_short_of_target"} and sets +#' \code{params$short_of_target}: the cross-validated error then tends to +#' read low for those locations. Fewer folds hold out larger regions. +#' Short of either warning the folds can still differ from the target at +#' some distances; \code{params$max_ecdf_excess} and +#' \code{params$max_ecdf_deficit} give the largest difference each way, and +#' \code{\link{fold_separation}()} reads the folds against the same +#' prediction points fold by fold. +#' #' An earlier version of this package drew one random radius per point from #' \eqn{G_{ij}} and excluded up to the order statistic \emph{closest} to it, #' which rounds down half the time: on a two-cluster layout the realised @@ -3385,6 +4733,11 @@ print.sac_range <- function(x, ...) { #' the largest remaining excess; compare \code{params$target_median} with #' \code{params$realised_median} as well. #' @references +#' Linnenbrink, J., Mila, C., Ludwig, M. and Meyer, H. (2024). kNNDM CV: +#' k-fold nearest-neighbour distance matching cross-validation for map +#' accuracy estimation. \emph{Geoscientific Model Development} \strong{17}, +#' 5897-5912. \doi{10.5194/gmd-17-5897-2024} +#' #' Mila, C., Mateu, J., Pebesma, E. and Meyer, H. (2022). Nearest neighbour #' distance matching Leave-One-Out Cross-Validation for map validation. #' \emph{Methods in Ecology and Evolution} \strong{13}, 1304-1316. @@ -3425,6 +4778,26 @@ print.sac_range <- function(x, ...) { #' check. The value is the tolerance of a check, not a target the packing #' aims for: see \strong{Fold balance} below for what the packing can and #' cannot do. \code{params$balance_ratio} carries the ratio achieved. +#' For \code{"knndm"} it is a limit and not a check: a candidate whose +#' largest fold holds more than \code{balance_tol} times the points of its +#' smallest is set aside, so the folds returned are always within it. +#' @param max_test For \code{"buffered_loo"} and \code{"nndm"}: optional +#' whole number of at least 2. Folds are built for a random subset of that +#' many held-out points (drawn under \code{seed}), and every row stays +#' available for training, so each fold returned is the fold the full +#' design has for that point. The model is then refitted \code{max_test} +#' times and not \code{n} times, and the folds hold +#' \code{4 * n * max_test} bytes of row indices in place of +#' \code{4 * n^2}, which lets \code{"buffered_loo"} run on layers its +#' storage limit otherwise refuses. It does not lift the 5,000-row limit of +#' \code{"nndm"}, whose cost is the matching itself; for that there is +#' \code{"knndm"}. Rows that are not held out have \code{NA} in +#' \code{assignment$fold}. For \code{"nndm"} the matching still runs over +#' all \code{n} points and \code{params} describes all of them. +#' \code{\link{area_of_applicability}()} needs every training row in a +#' test fold and refuses a subset. Default +#' \code{NULL}: every point is held out once. An error for the k-fold +#' methods, whose number of folds is \code{k}. #' @section Supplied blocks: #' A polygon layer passed as \code{blocks} is aligned to the points the way #' \code{boundary} is: CRS-less points are aligned to blocks that carry a CRS @@ -3457,8 +4830,9 @@ print.sac_range <- function(x, ...) { #' density of the points. #' #' @section Fold balance: -#' Only \code{"block_kfold"} balances the number of points per fold, and it -#' does so by packing: blocks are taken largest first and each goes to the +#' \code{"block_kfold"} and \code{"knndm"} balance the number of points per +#' fold, and they do so by packing: blocks (for \code{"knndm"}, clusters of +#' the samples) are taken largest first and each goes to the #' fold with the fewest points so far, ties broken at random. This is the #' longest-processing-time rule for multiway partitioning. Measured against #' the optimum by enumeration (two folds, up to ten blocks, heavy-tailed block @@ -3476,6 +4850,11 @@ print.sac_range <- function(x, ...) { #' dense, so check \code{params$block_scale} against the autocorrelation #' range as you would a grid. #' +#' \code{"knndm"} chooses its clusters, so for it \code{balance_tol} is a +#' limit: a clustering whose packing exceeds it is not a candidate, and the +#' folds returned are within it (\code{params$fold_sizes}, +#' \code{params$balance_ratio}). +#' #' The other methods do not balance point counts. \code{"random_kfold"} is #' balanced by construction (fold sizes differ by at most one); #' \code{"buffered_loo"} and \code{"nndm"} hold out one point per fold; @@ -3525,12 +4904,45 @@ print.sac_range <- function(x, ...) { #' \code{params$blocks_supplied} that says whether the blocks came from #' \code{blocks} or from a grid built here, and #' \code{params$boundary_supplied} whether a \code{boundary} was given. -#' Every method's \code{params} carries +#' \code{params$block_width} and \code{params$block_height} are the width +#' and height of the grid cells built, before any clipping to a +#' \code{boundary} (\code{NA} for supplied \code{blocks}); they are what +#' \code{block_size} turned into: at least that size on an axis long +#' enough to hold it, and the whole extent on an axis that is not (see +#' \code{block_size}). +#' Every method's \code{params} carries \code{params$k_requested}, the +#' \code{k} that was asked for (\code{NA} when none was given), beside +#' the \code{k} returned, and #' \code{params$row_probe}, a small sample of row IDs and coordinates #' that every \code{cv_*()} compares against the data it is handed, so #' folds built from a different layer of the same size are refused, never #' applied silently. #' +#' For \code{"knndm"}, \code{params} carries \code{chosen} +#' (\code{"random"} or \code{"clusters"}), \code{n_clusters} (the number of +#' clusters packed into the folds; \code{NA} for the random partition), +#' \code{clustering} (\code{"ward"} or \code{"kmeans+ward"}; \code{NA} when +#' no cluster count was tried), \code{candidates} (a data frame with one row +#' per candidate, the random partition first: \code{candidate}, +#' \code{n_clusters}, \code{largest_fold}, \code{balance_ratio}, +#' \code{admissible} and \code{W}, which is \code{NA} for a candidate set +#' aside), \code{wasserstein}, \code{wasserstein_random} and +#' \code{wasserstein_loo} (the Wasserstein distance to the target of the +#' folds returned, of the random partition among the candidates and of +#' plain leave-one-out, in distance units), \code{fold_sizes}, +#' \code{balance_ratio}, \code{target_distances} and +#' \code{realised_distances} (one per prediction point, and one per row: +#' its distance to the nearest point of another fold) with their medians +#' and means, and the diagnostics \code{"nndm"} reports under the same +#' names: \code{max_ecdf_excess}, \code{max_ecdf_deficit}, +#' \code{loo_ecdf_deficit}, \code{ecdf_deficit_tol}, +#' \code{target_separated} and \code{target_out_of_reach}, with +#' \code{short_of_target} for the opposite case (see \strong{Details}). +#' +#' With \code{max_test}, \code{"buffered_loo"} and \code{"nndm"} return +#' that many folds, \code{assignment$fold} is \code{NA} for the rows not +#' held out, and \code{params$max_test} records the value. +#' #' For the methods that work in projected space, \code{params} also carries a #' \code{crs} element naming the CRS the folds were built in (an #' \code{"EPSG:code"} string where there is one, otherwise the CRS's input @@ -3557,10 +4969,16 @@ print.sac_range <- function(x, ...) { #' #' # Buffered leave-one-out: neighbours within 100 units excluded from training #' loo <- make_folds(pts, k = 1, method = "buffered_loo", buffer = 100) +#' +#' # Three folds matched to the distances from a prediction grid to the data +#' grid <- st_make_grid(pts, n = c(10, 10), what = "centers") +#' km <- make_folds(pts, k = 3, method = "knndm", prediction_points = grid, +#' seed = 42) +#' km$params[c("chosen", "n_clusters", "wasserstein", "wasserstein_random")] #' @export make_folds <- function(points_sf, k, method = c("random_kfold", "block_kfold", "buffered_loo", - "leave_location_out", "nndm"), + "leave_location_out", "nndm", "knndm"), seed = NULL, block_nx = NULL, block_ny = NULL, block_multiplier = 3, block_size = NULL, auto_range = FALSE, range_frac = 1.0, response_var = NULL, @@ -3568,7 +4986,7 @@ make_folds <- function(points_sf, k, predictor_vars = NULL, boundary = NULL, buffer = NULL, min_train = 0.5, phi = NULL, drop_empty_blocks = TRUE, blocks = NULL, - balance_tol = 3) { + balance_tol = 3, max_test = NULL) { method <- match.arg(method) cleanup <- .with_seed(seed) @@ -3611,13 +5029,18 @@ make_folds <- function(points_sf, k, stop("make_folds(): `k` must be a single whole number >= 1; got ", paste(format(k), collapse = ", "), ".", call. = FALSE) k <- as.integer(k) - } else if (method %in% c("random_kfold", "block_kfold", "leave_location_out")) { + } else if (method %in% c("random_kfold", "block_kfold", "leave_location_out", + "knndm")) { # A missing or NULL k skipped the check above and died at the first # `if (k < 2)` with R's "argument is of length zero". The two - # leave-one-out methods never read k, so only these three need it. + # leave-one-out methods never read k, so only the k-fold ones need it. stop(sprintf(paste0("make_folds(): `k` (the number of folds) is required ", "for method = \"%s\"."), method), call. = FALSE) } + # The k that was asked for travels with the k that is returned. Three + # methods can return fewer folds than asked, and a result whose `k` is 4 + # could not say whether 4 or 5 had been requested. + k_requested <- if (!missing(k) && !is.null(k)) k else NA_integer_ # block_size was tested with `is.numeric(block_size) && block_size > 0` and # anything failing that was silently ignored -- yet echoed back unchanged in # params$block_size, so a negative, zero or character value looked honoured. @@ -3671,6 +5094,26 @@ make_folds <- function(points_sf, k, stop("make_folds(): `balance_tol` must be a single number >= 1 (Inf disables ", "the imbalance warning); got ", paste(format(balance_tol), collapse = ", "), ".", call. = FALSE) + # `max_test` belongs to the two leave-one-out methods. It is refused for + # the others, as `blocks` is: a k-fold design that quietly ignored it would + # score every row while the caller believed a subset had been asked for. + if (!is.null(max_test)) { + if (!(method %in% c("buffered_loo", "nndm"))) + stop(sprintf(paste0( + "make_folds(): `max_test` is only used by the leave-one-out methods, ", + "\"buffered_loo\" and \"nndm\", where it limits how many held-out ", + "points are built and scored; got method = \"%s\", whose number of ", + "folds is `k`."), method), call. = FALSE) + if (inherits(max_test, "units") || !is.numeric(max_test) || + length(max_test) != 1L || !is.finite(max_test) || + max_test != round(max_test) || max_test < 2 || + max_test > .Machine$integer.max) + stop("make_folds(): `max_test` must be a single whole number >= 2 (the ", + "number of held-out points to build folds for); got ", + if (length(max_test)) paste(format(max_test), collapse = ", ") + else "a value of length 0", ".", call. = FALSE) + max_test <- as.integer(max_test) + } # The provenance probe is taken on the geometry AS SUPPLIED -- before # pointization -- because that is what the cv_*() wrappers will probe too. row_probe <- .fold_row_probe(points_sf) @@ -3719,13 +5162,23 @@ make_folds <- function(points_sf, k, # it if it is handed the wrong data. (Taken above, on the input geometry.) .ret <- function(method, k, folds, assignment, params) list(method = method, k = k, folds = folds, assignment = assignment, - params = c(params, list(row_probe = row_probe))) + params = c(params, list(k_requested = k_requested, + row_probe = row_probe))) # ---- RANDOM K-FOLD ---- if (method == "random_kfold") { n <- nrow(points_sf) if (k < 2) k <- 2L - if (k > n) { .log_warn("make_folds(random_kfold): k > n; reducing."); k <- n } + if (k > n) k <- n + # Fewer folds than asked is a different cross-validation from the one the + # caller wrote down. It was a log line only, which tryCatch(), knitr and + # spatialkit_quiet() never show. + if (!is.na(k_requested) && k < k_requested) + .warn_k_reduced(k_requested, k, paste0( + "make_folds(random_kfold): returning %d folds, not the k = %d asked ", + "for: the layer has %d rows with usable coordinates and every fold ", + "holds out at least one. This is leave-one-out; pass k <= %d for ", + "fewer, larger folds."), k, k_requested, n, n) row_ids <- points_sf$..row_id idx <- sample.int(n, n) sizes <- rep(floor(n / k), k) @@ -3835,6 +5288,9 @@ make_folds <- function(points_sf, k, } sac_range <- NA_real_ size_from_range <- FALSE + # The extent the grid is laid over. Read before the range is, because + # what a range-sized block yields depends on it. + bb <- sf::st_bbox(reg) if (isTRUE(auto_range) && !is.null(response_var)) { # `seed` here is make_folds()'s own, whose default is NULL -- meaning # "do not seed the FOLD assignment". Forwarding that NULL re-opened the @@ -3856,19 +5312,35 @@ make_folds <- function(points_sf, k, sac_range )) } else if (is.finite(sac_range) && sac_range > 0) { - message(sprintf( - "make_folds(block_kfold): estimated spatial autocorrelation range = %.1f CRS units; using as minimum block size.", - sac_range - )) # auto_range sets block_size only if the caller didn't supply one if (is.null(block_size)) { block_size <- sac_range size_from_range <- TRUE - } else if (block_size < sac_range) { - .warn_and_log( - "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", - block_size, sac_range - ) + # The range is a MINIMUM edge: a whole number of blocks is fitted + # across each axis, so on an axis at least as long as the range a + # block is 1 to under 2 times the range, and an axis shorter than + # the range is spanned by one row or column, shorter than the + # range. Say what is built, since that, not the range, is the + # design. + built <- .block_dims_from_size(bb, block_size) + message(sprintf( + "make_folds(block_kfold): estimated spatial autocorrelation range = %.1f CRS units; using as minimum block size. Over the %s extent that is a %s x %s grid of blocks %s wide and %s tall.", + sac_range, .block_extent_chr(bb), + format(built$nx, scientific = FALSE), format(built$ny, scientific = FALSE), + format(signif(as.numeric(bb["xmax"] - bb["xmin"]) / built$nx, 4)), + format(signif(as.numeric(bb["ymax"] - bb["ymin"]) / built$ny, 4)) + )) + } else { + message(sprintf( + "make_folds(block_kfold): estimated spatial autocorrelation range = %.1f CRS units; using as minimum block size.", + sac_range + )) + if (block_size < sac_range) + .warn_and_log( + "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. %s", + block_size, sac_range, + .block_range_advice(pts, reg, bb, sac_range, k, mention_auto = FALSE) + ) } } else { # The caller asked for range-sized blocks and is not getting them. @@ -3919,8 +5391,6 @@ make_folds <- function(points_sf, k, seed = if (is.null(seed)) 123L else seed) } - bb <- sf::st_bbox(reg) - if (!blocks_supplied) { # Determine grid dimensions: block_size constrains nx/ny if (!is.null(block_size) && is.numeric(block_size) && block_size > 0) { @@ -3932,8 +5402,9 @@ make_folds <- function(points_sf, k, if (!isTRUE(auto_range) && is.finite(sac_range) && sac_range > 0 && block_size < sac_range) { .warn_and_log( - "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", - block_size, sac_range + "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. %s", + block_size, sac_range, + .block_range_advice(pts, reg, bb, sac_range, k, mention_auto = FALSE) ) } # If the caller also supplied explicit block_nx/block_ny, warn about override @@ -3946,15 +5417,10 @@ make_folds <- function(points_sf, k, nx <- size_dims$nx ny <- size_dims$ny - # Ensure at least k blocks so each fold can get one. A single block - # is refused further down, so do not announce a k it will never use. - if (nx * ny < k && nx * ny >= 2) { - .log_warn( - "make_folds(block_kfold): block_size produces only %d blocks (< k = %d). Reducing k to match.", - nx * ny, k - ) - k <- max(2L, nx * ny) - } + # A grid of fewer than k cells lowers k. That is decided once, further + # down, from the blocks that hold points: a cell count announced here + # could be lowered again there (a 3 x 3 grid with four occupied cells + # is four folds, not nine), and a single block is an error. } else if (is.null(block_nx) && is.null(block_ny)) { w <- as.numeric(bb["xmax"] - bb["xmin"]) h <- as.numeric(bb["ymax"] - bb["ymin"]) @@ -3982,9 +5448,17 @@ make_folds <- function(points_sf, k, if (is.finite(sac_range) && sac_range > 0 && length(split_cells)) { min_cell <- min(split_cells) if (min_cell < sac_range) { + # The advice used to be "Pass block_size = or auto_range + # = TRUE" whatever the layout. On a square extent at k = 5 that + # gives five folds only for a range between a quarter and a third + # of the side: up to a half it returned four folds, and above it + # stopped with the single-block error, whose own advice led back + # here. .block_range_advice() builds the grid the advice asks + # for and says what comes back. .warn_and_log( - "make_folds(): block dimension (%.1f) < autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. Pass block_size = %.0f or auto_range = TRUE.", - min_cell, sac_range, ceiling(sac_range) + "make_folds(): block dimension (%.1f) < autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. %s", + min_cell, sac_range, + .block_range_advice(pts, reg, bb, sac_range, k) ) } } @@ -4013,8 +5487,9 @@ make_folds <- function(points_sf, k, min_cell <- min(split_cells) if (min_cell < sac_range) { .warn_and_log( - "make_folds(): block_nx/block_ny yield blocks smaller than autocorrelation range (%.1f). Consider using block_size = %.0f.", - sac_range, ceiling(sac_range) + "make_folds(): block_nx/block_ny yield blocks smaller than autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. %s", + sac_range, + .block_range_advice(pts, reg, bb, sac_range, k) ) } } @@ -4078,28 +5553,12 @@ make_folds <- function(points_sf, k, call. = FALSE) } - grid <- sf::st_make_grid(reg, n = c(nx, ny), what = "polygons", square = TRUE) - grid <- .safe_make_valid(grid) - reg_union <- .safe_make_valid(sf::st_union(reg)) - grid <- suppressWarnings(sf::st_intersection(grid, reg_union)) - # Clipping to a boundary drops the cells outside it and renumbers the - # rest, so a cell's index in the full grid is carried from the "idx" - # attribute instead: that is what params$blocks$source_row promises. - # Where the boundary only touches a cell at a corner or along an edge - # the intersection is a zero-area POINT or LINESTRING, which used to be - # kept as a block of its own -- packed into a fold when empty blocks - # were kept, and able to catch a point lying exactly on the boundary as - # a one-point block. Keep the areal pieces only, unless there are none - # (points on one straight line have a region of zero area, and every - # piece of it is a line). - cell_idx <- attr(grid, "idx") - cell_idx <- if (is.matrix(cell_idx) && nrow(cell_idx) == length(grid)) - as.integer(cell_idx[, 1L]) else seq_along(grid) - areal <- sf::st_dimension(grid) %in% 2L - if (any(areal) && !all(areal)) { - grid <- grid[areal]; cell_idx <- cell_idx[areal] - } - grid_sf <- sf::st_as_sf(grid) + # .block_grid() lays the cells and clips them to the region. The + # leakage advice and the k warning build their trial grids with the same + # function, so what they say a block size yields is what it yields. + built_grid <- .block_grid(reg, nx, ny) + grid_sf <- built_grid$grid_sf + cell_idx <- built_grid$cell_idx n_blocks <- as.integer(nx * ny) } else { # The caller's polygons are the blocks. Their row order is the block @@ -4222,24 +5681,98 @@ make_folds <- function(points_sf, k, "spatial split to make and the one fold would have ", "an empty training set. Supply smaller blocks."), nrow(pts)), call. = FALSE) - how <- if (!is.null(block_size)) - sprintf("the block size (%s)", format(block_size)) + how <- if (size_from_range) + sprintf("the block size (%s, the estimated autocorrelation range)", + format(as.numeric(block_size))) + else if (!is.null(block_size)) + sprintf("the block size (%s)", format(as.numeric(block_size))) else if (!is.null(block_nx) || !is.null(block_ny)) "the requested block_nx/block_ny" else "the automatic grid (block_multiplier x k blocks over the extent)" + # What to do instead, worked out for this layout. The old text said + # "set auto_range = FALSE if the size came from the estimated + # autocorrelation range", which returns the default grid and its leakage + # warning, and that warning said to set auto_range = TRUE. + alt <- if (!is.null(block_size)) + .block_largest_size_for_k(pts, reg, bb, k, below = block_size) else NULL + todo <- if (size_from_range) + paste0("Block folds cannot be separated by this range here. ", + if (is.null(alt)) + sprintf("No block size down to 1/200 of the extent gives %d blocks that hold points. ", k) + else sprintf(paste0("The largest block_size that gives %d ", + "folds is %s, %.0f%% of the range. "), + k, alt$chr, 100 * alt$size / as.numeric(sac_range)), + .block_other_method(nrow(pts))) + else if (!is.null(block_size)) { + if (is.null(alt)) + sprintf("No block size down to 1/200 of the extent gives %d blocks that hold points; pass a smaller `k`, or blocks that follow the points (`blocks`).", k) + else sprintf("Pass a smaller `block_size`: the largest that gives %d folds is %s.", + k, alt$chr) + } else if (!is.null(block_nx) || !is.null(block_ny)) + "Ask for more blocks." + else + "Every point lies in one block of the grid; block folds need points in at least two." stop(sprintf(paste0("make_folds(block_kfold): %s produces a single block ", - "covering the whole extent, so there is no spatial ", - "split to make and the one fold would have an empty ", - "training set. Pass a smaller `block_size` (or more ", - "blocks), or set auto_range = FALSE if the size came ", - "from the estimated autocorrelation range."), how), + "covering the whole extent (%s), so there is no ", + "spatial split to make and the one fold would have ", + "an empty training set. %s"), + how, .block_extent_chr(bb), todo), call. = FALSE) } if (B < k) { - .log_warn("make_folds(block_kfold): only %d blocks hold points (blocks < k; reducing k from %d to %d).", - B, k, B) + # Raised as a condition with its own class, not only logged: a result + # with fewer folds than asked is a different cross-validation, and + # under knitr, tryCatch() or spatialkit_quiet() the log line never + # reached the caller. Raised once, here, from the blocks that hold + # points, whichever of the grid's cell count or its empty cells is the + # cause. + k_asked <- k k <- B + why <- if (blocks_supplied) + sprintf("%d of the %d supplied blocks hold points", B, n_blocks) + else if (size_from_range) + sprintf(paste0("the estimated autocorrelation range (%s), used as the ", + "block size, builds a %s x %s grid over the %s extent ", + "and %d of its blocks hold points"), + format(as.numeric(block_size)), format(nx, scientific = FALSE), + format(ny, scientific = FALSE), .block_extent_chr(bb), B) + else if (!is.null(block_size)) + sprintf(paste0("block_size = %s builds a %s x %s grid over the %s ", + "extent and %d of its blocks hold points"), + format(as.numeric(block_size)), format(nx, scientific = FALSE), + format(ny, scientific = FALSE), .block_extent_chr(bb), B) + else if (!is.null(block_nx) || !is.null(block_ny)) + sprintf("the requested %s x %s grid has %d blocks that hold points", + format(nx, scientific = FALSE), format(ny, scientific = FALSE), B) + else + sprintf("the automatic %s x %s grid has %d blocks that hold points", + format(nx, scientific = FALSE), format(ny, scientific = FALSE), B) + alt <- if (!blocks_supplied && !is.null(block_size)) + .block_largest_size_for_k(pts, reg, bb, k_asked, below = block_size) else NULL + todo <- if (blocks_supplied) + sprintf("Supply blocks that divide the points further, or pass k = %d.", B) + else if (size_from_range) + paste0(if (is.null(alt)) "" + else sprintf(paste0("The largest block_size that gives %d folds ", + "is %s, %.0f%% of the range, so its folds ", + "are separated by less than the range. "), + k_asked, alt$chr, 100 * alt$size / as.numeric(sac_range)), + sprintf("Pass k = %d to keep range-sized blocks. ", B), + .block_other_method(nrow(pts))) + else if (!is.null(block_size)) { + if (is.null(alt)) sprintf("Pass k = %d, or blocks that follow the points (`blocks`).", B) + else sprintf(paste0("For %d folds pass block_size = %s (the largest ", + "that gives %d), or pass k = %d to keep these blocks."), + k_asked, alt$chr, k_asked, B) + } else if (!is.null(block_nx) || !is.null(block_ny)) + sprintf("Ask for a finer grid, or pass k = %d.", B) + else + sprintf("Pass a larger `block_multiplier`, blocks that follow the points (`blocks`), or k = %d.", B) + .warn_k_reduced(k_asked, k, paste0( + "make_folds(block_kfold): returning %d folds, not the k = %d asked ", + "for: %s, and every fold needs a block of its own. %s"), + k, k_asked, why, todo) } # Counted over every block in the grid, not over 1..B. B used to be the @@ -4282,14 +5815,13 @@ make_folds <- function(points_sf, k, # ratio by 0.004 on average and never brought an over-tolerance packing # under 3:1 -- imbalance past the tolerance lives in the block sizes, not # in the packing, so no search is offered. The remedy is `blocks`. - order_blk <- order(blk_sizes, decreasing = TRUE) - fold_loads <- integer(k); fold_blocks <- vector("list", k) - for (i in seq_along(order_blk)) { - j <- which(fold_loads == min(fold_loads)) - if (length(j) > 1) j <- sample(j, 1L) - fold_blocks[[j]] <- c(fold_blocks[[j]], order_blk[i]) - fold_loads[j] <- fold_loads[j] + blk_sizes[order_blk[i]] - } + # The rule is .pack_largest_first(), which method = "knndm" uses for its + # clusters too. Each fold's blocks are listed in the order they were + # placed. + packed <- .pack_largest_first(blk_sizes, k) + fold_loads <- packed$loads + fold_blocks <- lapply(seq_len(k), function(j) + packed$order[packed$fold_of[packed$order] == j]) # The residual imbalance is checked against the tolerance and, past it, # raised as a warning a pipeline can catch -- not only logged. No fold @@ -4347,6 +5879,20 @@ make_folds <- function(points_sf, k, blocks = block_polys, block_multiplier = block_multiplier, block_size = block_size, + # What was built. `block_size` is a minimum edge and a + # whole number of cells is fitted across each axis, so + # on an axis at least as long as `block_size` a cell is + # 1 to under 2 times as long (asked 4000, built + # 4981.6). An axis shorter than `block_size` is spanned + # by one row or column, and the cell is then as long as + # the extent there: shorter than asked (asked 10000 on + # a 39840 x 4969 extent, built 13280 x 4969). NA for + # supplied blocks, which have no single width; see + # `block_scale`. + block_width = if (blocks_supplied) NA_real_ else + as.numeric(bb["xmax"] - bb["xmin"]) / nx, + block_height = if (blocks_supplied) NA_real_ else + as.numeric(bb["ymax"] - bb["ymin"]) / ny, sac_range = sac_range, auto_range = auto_range, balance_ratio = balance_ratio, @@ -4382,35 +5928,52 @@ make_folds <- function(points_sf, k, else ""), call. = FALSE) pts <- ensure_projected(points_sf) n <- nrow(pts) + # With `max_test`, folds are built for a seeded random subset of the + # held-out points only. Every row stays available for training, so the + # folds built are the ones the full design would have for those points. + scored <- .loo_scored_rows(n, max_test) + n_s <- length(scored) # The cost is QUADRATIC in n whatever the buffer: every one of the n # splits stores its own training-row vector of length about n, so the # fold object alone is ~4 n^2 bytes. The old threshold of 20000 admitted # 1.6 GB of splits (measured 1.7 GB of R objects at n = 19999), before # .remap_folds() copied them. The cap is now stated in bytes and the - # message says what the request would cost. - split_gb <- 4 * as.numeric(n)^2 / 1024^3 + # message says what the request would cost. `max_test` splits cost + # 4 * n * max_test bytes, which is what makes the method usable past the + # cap. + split_gb <- 4 * as.numeric(n) * as.numeric(n_s) / 1024^3 if (split_gb > 0.6) { stop(sprintf(paste0( "make_folds(buffered_loo): n = %d would produce %d leave-one-out ", "splits holding about %.2f GB of row indices (the training vector of ", "every split is ~n long, so storage grows as n^2), before the model is ", - "refitted %d times. Use 'block_kfold' instead, or subset the data."), - n, n, split_gb, n), call. = FALSE) + "refitted %d times. Use 'block_kfold' instead, or subset the data.%s"), + n, n_s, split_gb, n_s, + # The largest subset that stays under the cap, as a round number. + sprintf(paste0(" Or pass `max_test` to build and score a random ", + "subset of the held-out points while every row stays ", + "available for training: max_test = %s keeps the ", + "splits under 0.6 GB here."), + format(max(2, floor(.signif_down( + 0.6 * 1024^3 / (4 * as.numeric(n)), 2L))), + scientific = FALSE, trim = TRUE))), call. = FALSE) } else if (split_gb > 0.1) { .log_warn( "make_folds(buffered_loo): n = %d produces %d splits holding about %.2f GB of row indices, and the model will be refitted %d times; this may be slow.", - n, n, split_gb, n + n, n_s, split_gb, n_s ) } - nb <- sf::st_is_within_distance(sf::st_geometry(pts), sf::st_geometry(pts), - dist = buffer) - splits <- vector("list", n) + nb <- sf::st_is_within_distance(sf::st_geometry(pts)[scored], + sf::st_geometry(pts), dist = buffer) + splits <- vector("list", n_s) row_ids <- pts$..row_id - for (i in seq_len(n)) { - excl <- sort(unique(nb[[i]])) + for (i in seq_len(n_s)) { + # The held-out point is within any positive buffer of itself, so it is + # among the excluded rows. + excl <- sort(unique(c(scored[i], nb[[i]]))) # Row-ID (not positional) splits — see comment in the random_kfold branch. splits[[i]] <- list(train = row_ids[setdiff(seq_len(n), excl)], - test = row_ids[i]) + test = row_ids[scored[i]]) } # A buffer that spans the data leaves EVERY fold with an empty training @@ -4443,9 +6006,13 @@ make_folds <- function(points_sf, k, if (is.na(crs_lbl)) "the data's CRS" else crs_lbl) } - return(.ret(method, n, splits, - .safe_tibble(row_id = pts$..row_id, fold = seq_len(n)), - list(buffer = buffer, crs = .fold_crs_label(pts)))) + # A row that is not held out has no fold: NA in `assignment`. + prm <- list(buffer = buffer, crs = .fold_crs_label(pts)) + if (!is.null(max_test)) prm$max_test <- max_test + return(.ret(method, n_s, splits, + .safe_tibble(row_id = pts$..row_id, + fold = match(seq_len(n), scored)), + prm)) } # ---- LEAVE-LOCATION-OUT (grouped) ---- @@ -4474,11 +6041,14 @@ make_folds <- function(points_sf, k, call. = FALSE) # k groups per fold; k >= n_g degenerates to leave-one-group-out. - if (k > n_g) { - .log_warn("make_folds(leave_location_out): k = %d exceeds the %d distinct groups; using leave-one-group-out.", k, n_g) - k <- n_g - } + if (k > n_g) k <- n_g if (k < 2L) k <- 2L + if (!is.na(k_requested) && k < k_requested) + .warn_k_reduced(k_requested, k, paste0( + "make_folds(leave_location_out): returning %d folds, not the k = %d ", + "asked for: `%s` has %d distinct groups and a group is never split ", + "across folds. This is leave-one-group-out; pass k <= %d to hold out ", + "several groups per fold."), k, k_requested, group_var, n_g, n_g) grp_fold <- sample(rep(seq_len(k), length.out = n_g)) # Positional lookup via match(), never by name: name-indexing is what @@ -4508,53 +6078,17 @@ make_folds <- function(points_sf, k, "makes about n^2/2 removals at O(n) each, so the worst case is O(n^3) ", "time (about nine minutes at n = 3000). NNDM then produces n ", "leave-one-out folds, so the model is refitted n times. Use ", - "'block_kfold' instead, or subset your data."), n), - call. = FALSE) + "method = \"knndm\", which matches k folds to the same prediction ", + "points and has no row limit, or 'block_kfold', or subset your data."), + n), call. = FALSE) if (n < 3L) stop("make_folds(nndm): need at least 3 points.", call. = FALSE) - if (is.null(prediction_points)) - stop("make_folds(nndm): `prediction_points` is required -- NNDM matches ", - "the training-to-test distance distribution to the distance ", - "distribution from your actual prediction locations to the training ", - "data. Use the grid you intend to predict onto (see ", - "predict_surface()).", call. = FALSE) - # Prediction locations are frequently the grid CELLS a surface will be - # drawn on, not their centres. Every other geometry input in this file is - # pointized first; this one was not, so a POLYGON layer gave point-to- - # POLYGON distances -- zero for every cell that contains a training point. - # The target distance distribution was then pulled towards 0, far fewer - # neighbours were excluded, and the distance-matched CV quietly degenerated - # towards plain LOO: the optimistic direction. - if (inherits(prediction_points, "sfc")) - prediction_points <- sf::st_sf(geometry = prediction_points) - if (!all(sf::st_geometry_type(prediction_points, - by_geometry = TRUE) == "POINT")) { - .log_info(paste0("make_folds(nndm): `prediction_points` are not POINTs; ", - "using representative points so the target distances ", - "are point-to-point.")) - prediction_points <- coerce_to_points(prediction_points, "auto") - } - if (is.na(sf::st_crs(pts)) && !is.na(sf::st_crs(prediction_points))) { - pts <- .transform_or_stamp(pts, sf::st_crs(prediction_points), - what = "points_sf", caller = "make_folds") - } - # Aligned as `boundary` is: a CRS-less layer gets the warning, naming it. - pred <- if (is.null(.crs_or_null(pts))) ensure_projected(prediction_points) - else .transform_or_stamp(prediction_points, sf::st_crs(pts), - what = "prediction_points", - caller = "make_folds") - pred <- sf::st_zm(pred, drop = TRUE, what = "ZM") - - # Target: distance from each prediction location to its nearest training - # point. This is the distance regime the model will actually face, and the - # one an arbitrary fixed buffer has no reason to reproduce. - g_target <- .nn_dist_to(pred, pts) - g_target <- g_target[is.finite(g_target)] - if (!length(g_target)) - stop("make_folds(nndm): could not compute prediction-to-training ", - "distances.", call. = FALSE) - + # The prediction points, aligned to the samples, and the distance from + # each to its nearest sample: the target of the matching. + tg <- .nndm_target(pts, prediction_points, "nndm") + pts <- tg$pts; pred <- tg$pred; g_target <- tg$g_target + # A `units` object passes is.numeric() and then fails the comparison # inside the units package with a message that names no argument. if (inherits(min_train, "units") || !is.numeric(min_train) || @@ -4662,6 +6196,9 @@ make_folds <- function(points_sf, k, removed <- integer(n) at_floor <- logical(n) Gjstar <- nn_d[, 1L] + # Plain leave-one-out's distances, kept for scale: the Wasserstein + # distance of the folds to the target is reported beside this one's. + loo_d <- Gjstar # Ties in Gjstar -- every mutual-nearest-neighbour pair, all of a regular # grid -- are broken by a key that depends on the GEOMETRY, not on the # row order: the point's rank in (x, y) lexicographic order. CAST breaks @@ -4705,14 +6242,21 @@ make_folds <- function(points_sf, k, Gjstar[si] <- sv nn_d <- NULL # only the neighbour ids are needed now - splits <- vector("list", n) + # The matching above runs over every point, with or without `max_test`: + # what a fold excludes depends on all the others. `max_test` only limits + # which of the n folds are built and returned, a seeded random subset, so + # the folds returned are the ones the full design has for those points + # and every diagnostic below still describes all n. + scored <- .loo_scored_rows(n, max_test) + splits <- vector("list", length(scored)) n_excluded <- removed realised <- Gjstar - for (i in seq_len(n)) { + for (s in seq_along(scored)) { + i <- scored[s] drop_idx <- if (removed[i] > 0L) nn_i[i, seq_len(removed[i])] else integer(0) drop_idx <- drop_idx[!is.na(drop_idx)] train_i <- setdiff(seq_len(n), c(i, drop_idx)) - splits[[i]] <- list(train = row_ids[train_i], test = row_ids[i]) + splits[[s]] <- list(train = row_ids[train_i], test = row_ids[i]) } # The paper's own diagnostic: largest excess of realised over target. fin <- is.finite(realised) @@ -4756,23 +6300,85 @@ make_folds <- function(points_sf, k, format(min_train), n_at_floor, n, phi, excess_phi, n, stats::median(realised[fin]), stats::median(g_target)) - # Exclusion is not always needed. When prediction locations sit no further - # from the training data than training points sit from each other, plain - # LOO already reproduces the target distribution and nothing is removed -- - # that is the correct answer, not a failure. Conversely NNDM cannot pull - # training points closer, so it cannot match a target that is shorter than - # the training nearest-neighbour distances. - .log_info(paste0("make_folds(nndm): %d folds. Target prediction-to-training ", + # The mirror of the excess: the largest amount by which the TARGET + # distribution runs above the realised one, the share of prediction points + # within some distance of the data that the folds do not reproduce. It + # has two sources. Excluding a neighbour moves a held-out point out to + # its next remaining neighbour, which on clustered samples can be far + # beyond the prediction distances: that part is the granularity of the + # matching. The other part was there before anything was excluded. + max_deficit <- .ecdf_deficit(realised, g_sorted) + # Exclusion can only lengthen a held-out distance, so where the target + # runs above plain leave-one-out's own distribution no setting can reach + # it. When prediction locations sit about as far from the data as the + # samples sit from each other, plain leave-one-out already matches and + # nothing is removed, which is the right answer. When they sit NEARER + # (prediction points among the samples, a regular sample predicted + # between its nodes), the folds returned are plain leave-one-out and + # still too far, and that was an INFO line only: prediction points 5 m + # from 200 samples gave a target median of 6.6 against a realised 355.7, + # with no removal, an excess of 0 and no warning. The rule, and what it + # was calibrated on, is .nndm_reach(); method = "knndm" applies the same + # one. + reach <- .nndm_reach(loo_d, g_target) + loo_deficit <- reach$deficit + deficit_tol <- reach$tolerance + past_tol <- reach$past_tol + loo_fin <- reach$loo_fin + separated <- reach$separated + out_of_reach <- reach$out_of_reach + # The Wasserstein distance between the two distributions (the area + # between their ECDFs, in distance units), with plain leave-one-out's for + # scale: equal when nothing was excluded, smaller when matching helped. + w_real <- if (any(fin)) .fold_sep_compare(realised[fin], g_target)$w1 else NA_real_ + w_loo <- if (length(loo_fin)) .fold_sep_compare(loo_fin, g_target)$w1 else NA_real_ + if (out_of_reach) + .warn_nndm_out_of_reach(loo_deficit, deficit_tol, separated, paste0( + "make_folds(nndm): the prediction points sit nearer to the data than ", + "leave-one-out can reach. Their distance to the nearest sample has ", + "median %.4g; a sample's nearest other sample is a median of %.4g ", + "away, and the folds hold each point out at a median of %.4g from ", + "its training data (%s). %s ", + "Excluding neighbours can only lengthen a held-out distance, so no ", + "setting closes this gap: the cross-validated error is pessimistic ", + "for these prediction locations, an upper bound on the error there. ", + "If the prediction points were meant to cover a wider area than the ", + "samples, check that `prediction_points` is that layer."), + stats::median(g_target), stats::median(loo_fin), + stats::median(realised[fin]), + if (n_iter == 0L) "plain leave-one-out, no neighbour excluded" + else sprintf("%d neighbour exclusion(s) in all", n_iter), + # The evidence, by the rule that fired. + if (past_tol) sprintf(paste0( + "The share of prediction points within a distance of the data runs ", + "above leave-one-out's share by as much as %.3f, past the %.3f ", + "allowed for %d folds and %d prediction points."), + loo_deficit, deficit_tol, n, n_g) + else sprintf(paste0( + "Every one of the %d prediction points is nearer to the data (%s ", + "at most) than any sample is to its nearest other sample (%s at ", + "least). With %d folds and %d prediction points the allowance for a ", + "difference between the two shares is %.3f, more than a difference ", + "of shares can be, so the warning rests on that complete separation."), + n_g, format(signif(max(g_target), 4)), format(signif(min(loo_fin), 4)), + n, n_g, deficit_tol)) + + .log_info(paste0("make_folds(nndm): %d folds%s. Target prediction-to-training ", "distance: median %.1f. Realised test-to-training distance: ", "median %.1f, excluding a median of %.1f training point(s) ", "per fold (%d removals in total; largest remaining excess ", - "of realised over target ECDF %.3f)."), - n, stats::median(g_target), stats::median(realised[fin]), - stats::median(n_excluded), n_iter, max_excess) - - return(.ret(method, n, splits, - .safe_tibble(row_id = row_ids, fold = seq_len(n)), - list(seed = seed, n_prediction_points = nrow(pred), + "of realised over target ECDF %.3f, largest deficit %.3f)."), + n, + if (length(scored) < n) + sprintf(" matched, %d of them built (max_test)", length(scored)) + else "", + stats::median(g_target), stats::median(realised[fin]), + stats::median(n_excluded), n_iter, max_excess, max_deficit) + + return(.ret(method, length(scored), splits, + # A row that is not held out has no fold: NA. + .safe_tibble(row_id = row_ids, fold = match(seq_len(n), scored)), + c(list(seed = seed, n_prediction_points = nrow(pred), crs = .fold_crs_label(pts), min_train = min_train, phi = phi, # The effective buffer each fold ended up with. @@ -4780,10 +6386,233 @@ make_folds <- function(points_sf, k, median_excluded = stats::median(n_excluded), n_removed_total = n_iter, max_ecdf_excess = max_excess, + # The other side of the match: how far the target runs + # above the folds' distribution, and above plain + # leave-one-out's, which no exclusion can reach. + # target_out_of_reach is TRUE when the warning above + # was raised: the latter is past its tolerance, or the + # two sets of distances are completely separated + # (target_separated) and large enough to say so. + max_ecdf_deficit = max_deficit, + loo_ecdf_deficit = loo_deficit, + ecdf_deficit_tol = deficit_tol, + target_separated = separated, + target_out_of_reach = out_of_reach, + wasserstein = w_real, + wasserstein_loo = w_loo, n_at_min_train = n_at_floor, target_median = stats::median(g_target), realised_median = stats::median(realised[fin]), target_distances = g_target, + realised_distances = realised), + # Present only when a subset of the folds was asked for. + if (!is.null(max_test)) list(max_test = max_test)))) + } + + # ---- kNNDM: k-fold nearest-neighbour distance matching ---- + if (method == "knndm") { + pts <- ensure_projected(points_sf) + n <- nrow(pts) + if (n < 3L) + stop("make_folds(knndm): need at least 3 points.", call. = FALSE) + + # The same target as method = "nndm": the distance from each prediction + # point to its nearest sample. + tg <- .nndm_target(pts, prediction_points, "knndm") + pts <- tg$pts; pred <- tg$pred; g_target <- tg$g_target + + if (inherits(min_train, "units") || !is.numeric(min_train) || + length(min_train) != 1L || !is.finite(min_train) || min_train <= 0 || + min_train >= 1) + stop("make_folds(knndm): `min_train` must be a single number in (0, 1).", + call. = FALSE) + + if (k < 2L) k <- 2L + if (k > n) k <- n + if (!is.na(k_requested) && k < k_requested) + .warn_k_reduced(k_requested, k, paste0( + "make_folds(knndm): returning %d folds, not the k = %d asked for: ", + "the layer has %d rows with usable coordinates and every fold holds ", + "out at least one. This is leave-one-out; pass k <= %d for fewer, ", + "larger folds."), k, k_requested, n, n) + # k folds hold 1/k of the rows each when they are equal, so no k-fold + # design leaves a training set above 1 - 1/k of the data. A min_train + # past that asks for something no candidate can give. + if ((1 - min_train) < 1 / k - 1e-9) + stop(sprintf(paste0( + "make_folds(knndm): min_train = %s cannot be met with k = %d folds: ", + "equal folds hold 1/%d of the rows each, which leaves a training set ", + "of %s of the data at most. Use min_train <= %s, or more folds."), + format(min_train), k, k, format(signif(1 - 1 / k, 3)), + format(.signif_down(1 - 1 / k, 3L))), call. = FALSE) + + xy <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] + row_ids <- pts$..row_id + res <- .knndm_folds(xy, g_target, k, min_train = min_train, + balance_tol = balance_tol) + lab <- res$fold + realised <- res$realised + fin <- is.finite(realised) + cand <- res$candidates + chosen <- cand[res$chosen, , drop = FALSE] + is_random <- identical(chosen$candidate, "random") + fold_sizes <- tabulate(lab, nbins = k) + + splits <- lapply(seq_len(k), function(j) + # Row-ID (not positional) splits -- see the random_kfold branch. + list(train = row_ids[lab != j], test = row_ids[lab == j])) + + # Both sides of the match, as method = "nndm" reports them. + g_sorted <- sort(g_target) + max_excess <- if (any(fin)) .ecdf_deficit(g_target, sort(realised[fin])) + else NA_real_ + max_deficit <- .ecdf_deficit(realised, g_sorted) + # No fold design holds a point out nearer than its nearest other sample, + # so a target that plain leave-one-out cannot reach is out of reach of + # every candidate here too. The rule is the one "nndm" applies, on the + # same two sets of distances. + loo_d <- res$loo_distances + reach <- .nndm_reach(loo_d, g_target) + w_loo <- if (length(reach$loo_fin)) + .fold_sep_compare(reach$loo_fin, g_target)$w1 else NA_real_ + n_g <- length(g_target) + design <- if (is_random) "the random partition" + else sprintf("%d clusters of the samples packed into %d folds", + chosen$n_clusters, k) + if (reach$out_of_reach) + .warn_nndm_out_of_reach(reach$deficit, reach$tolerance, reach$separated, + paste0( + "make_folds(knndm): the prediction points sit nearer to the data than ", + "any fold can hold a point out. Their distance to the nearest sample ", + "has median %.4g; a sample's nearest other sample is a median of %.4g ", + "away, and the %d folds returned (%s) hold each point out at a median ", + "of %.4g from its training data. %s ", + "A held-out point is never nearer to its training data than to its ", + "nearest other sample, so no number of folds and no clustering ", + "closes this gap: the cross-validated error is pessimistic for these ", + "prediction locations, an upper bound on the error there. If the ", + "prediction points were meant to cover a wider area than the samples, ", + "check that `prediction_points` is that layer."), + stats::median(g_target), stats::median(reach$loo_fin), k, design, + stats::median(realised[fin]), + # The evidence, by the rule that fired. + if (reach$past_tol) sprintf(paste0( + "The share of prediction points within a distance of the data runs ", + "above the share of samples within that distance of another sample ", + "by as much as %.3f, past the %.3f allowed for %d samples and %d ", + "prediction points."), + reach$deficit, reach$tolerance, n, n_g) + else sprintf(paste0( + "Every one of the %d prediction points is nearer to the data (%s ", + "at most) than any sample is to its nearest other sample (%s at ", + "least). With %d samples and %d prediction points the allowance for ", + "a difference between the two shares is %.3f, which no ", + "difference of shares can exceed, so the warning rests on that complete ", + "separation."), + n_g, format(signif(max(g_target), 4)), + format(signif(min(reach$loo_fin), 4)), n, n_g, reach$tolerance)) + + n_set_aside <- sum(cand$candidate == "clusters" & !cand$admissible) + # The other direction is the optimistic one. The candidate kept is the + # closest of those tried, which is not the same as close: prediction + # points well beyond the samples lie farther from the data than k folds + # of these samples can be held apart (12 clusters over a 10 km box, + # predicted onto a 30 km one: held-out median 1427 against a target of + # 7220, and nothing said). The test is the one fold_separation() words + # as "closer" on the distance scale: the mean held-out distance below the + # target's by more than a quarter of it, and by at least half of W, so + # that the gap is a shift to one side and not two distributions crossing. + # Over 20 draws each of uniform, 12-cluster and 4-cluster samples of 100, + # 300 and 1,000 points at 2, 5 and 10 folds: with the prediction grid + # over the samples' own extent it fired in 0 of 180 uniform layouts, 4 of + # 180 with 12 clusters and 52 of 180 with 4 clusters (two or ten folds + # cannot follow four clusters, and the grid fills the gaps between them); + # with the grid over a box 1.5, 2 and 3 times as wide, in 315, 529 and + # 540 of 540. The out-of-reach warning above fired in none of those + # 2,160 and in 540 of 540 with prediction points 5 m from the samples. + mean_real <- mean(realised[fin]) + mean_target <- mean(g_target) + short <- identical(.fold_sep_reading(mean_real - mean_target, chosen$W, + .fold_sep_tol_dist * mean_target), + "closer") + if (short) { + is_cl <- cand$candidate == "clusters" + coarsest <- !is_random && + chosen$n_clusters == min(cand$n_clusters[is_cl & cand$admissible]) + # The clusterings with fewer clusters than the one kept, all of them + # set aside when it is the coarsest allowed. + n_coarser <- if (is_random) 0L else + sum(is_cl & !cand$admissible & cand$n_clusters < chosen$n_clusters) + .warn_knndm_short(mean_real, mean_target, paste0( + "make_folds(knndm): the %d folds returned (%s) hold each point out ", + "at a mean of %.4g from its training data, and the prediction points ", + "sit a mean of %.4g from the data (medians %.4g and %.4g). This is ", + "the closest of the %d candidates scored (Wasserstein distance %.4g; ", + "the random partition %.4g) and it is still short of the target, so ", + "the cross-validated error tends to read low for these prediction ", + "locations: read the score as an upper bound on performance there.%s"), + k, design, mean_real, mean_target, stats::median(realised[fin]), + stats::median(g_target), sum(cand$admissible), chosen$W, res$w_random, + if (coarsest && n_coarser > 0L) sprintf(paste0( + " It is the coarsest clustering allowed: the %d with fewer clusters ", + "left a fold with more than %s of the rows (min_train = %s) or more ", + "than %s times the points of another (balance_tol). Fewer folds ", + "hold out larger regions."), + n_coarser, format(signif(1 - min_train, 3)), format(min_train), + format(balance_tol)) + else if (coarsest) sprintf(paste0( + " It is the coarsest clustering there is, one cluster per fold, so ", + "these samples cannot be held further apart in %d folds. Fewer ", + "folds hold out larger regions."), k) + else "") + } + .log_info(paste0("make_folds(knndm): %d folds from %s. Target ", + "prediction-to-data distance: median %.1f. Held-out-to-", + "training distance: median %.1f. Wasserstein distance to ", + "the target %.4g (random partition %.4g, leave-one-out ", + "%.4g). %d cluster count(s) tried by %s clustering, %d ", + "set aside by min_train or balance_tol."), + k, design, stats::median(g_target), stats::median(realised[fin]), + chosen$W, res$w_random, w_loo, + sum(cand$candidate == "clusters"), + if (is.na(res$clustering)) "no" else res$clustering, n_set_aside) + + return(.ret(method, k, splits, + .safe_tibble(row_id = row_ids, fold = lab), + list(seed = seed, n_prediction_points = nrow(pred), + crs = .fold_crs_label(pts), + min_train = min_train, + # What was chosen: "random", or the clustering and the + # number of clusters packed into the k folds. + clustering = res$clustering, + chosen = chosen$candidate, + n_clusters = chosen$n_clusters, + # Every candidate tried, the random partition first. + candidates = cand, + # The distance between the folds' held-out distances and + # the target's, beside the same for the random partition + # among the candidates and for plain leave-one-out. + wasserstein = chosen$W, + wasserstein_random = res$w_random, + wasserstein_loo = w_loo, + max_ecdf_excess = max_excess, + max_ecdf_deficit = max_deficit, + loo_ecdf_deficit = reach$deficit, + ecdf_deficit_tol = reach$tolerance, + target_separated = reach$separated, + target_out_of_reach = reach$out_of_reach, + # TRUE when the warning above was raised: the folds are + # still closer to their training data than the + # prediction points are to the samples. + short_of_target = short, + fold_sizes = fold_sizes, + balance_ratio = max(fold_sizes) / min(fold_sizes), + balance_tol = balance_tol, + target_median = stats::median(g_target), + realised_median = stats::median(realised[fin]), + target_mean = mean_target, + realised_mean = mean_real, + target_distances = g_target, realised_distances = realised))) } @@ -4791,6 +6620,873 @@ make_folds <- function(points_sf, k, } +# ----------------------------------------------------------------------------- +# make_folds() helpers: conditions a caller can catch, and what a block size +# yields on a given layout +# ----------------------------------------------------------------------------- + +#' Warn that fewer folds are returned than were asked for +#' +#' \code{.warn_and_log()} with a condition class and two fields, so that a +#' caller running many fold constructions can catch exactly this case with +#' \code{tryCatch(spatialkit_k_reduced = )} or +#' \code{withCallingHandlers()} and read \code{k_requested} and \code{k} +#' from the condition, without matching message text. +#' +#' @param k_requested,k The number of folds asked for and returned. +#' @param fmt,... The message, as for \code{sprintf()}. +#' @keywords internal +#' @noRd +.warn_k_reduced <- function(k_requested, k, fmt, ...) { + .warn_classed("spatialkit_k_reduced", fmt, ..., + data = list(k_requested = as.integer(k_requested), + k = as.integer(k))) +} + + +#' Warn that NNDM's prediction points are nearer than leave-one-out reaches +#' +#' Classed as \code{spatialkit_nndm_out_of_reach}, with the statistic and its +#' tolerance as fields \code{deficit} and \code{tolerance}, and +#' \code{separated}: whether every prediction distance is shorter than every +#' leave-one-out distance, which is what the warning rests on where the +#' tolerance is 1 or more. +#' +#' @param deficit,tolerance The largest amount by which the target ECDF runs +#' above leave-one-out's, and the amount allowed. +#' @param separated Logical: complete separation of the two sets of +#' distances. +#' @param fmt,... The message, as for \code{sprintf()}. +#' @keywords internal +#' @noRd +.warn_nndm_out_of_reach <- function(deficit, tolerance, separated, fmt, ...) { + .warn_classed("spatialkit_nndm_out_of_reach", fmt, ..., + data = list(deficit = deficit, tolerance = tolerance, + separated = isTRUE(separated))) +} + + +#' The prediction points of the distance-matched methods, and their distances +#' +#' What \code{method = "nndm"} and \code{method = "knndm"} share: the +#' prediction points reduced to POINTs and brought into the samples' CRS, and +#' the distance from each to its nearest sample, which is the target both +#' methods match. +#' +#' Prediction locations are frequently the grid CELLS a surface will be drawn +#' on, not their centres. A POLYGON layer gives point-to-POLYGON distances, +#' zero for every cell that contains a training point: the target +#' distribution is pulled towards 0 and the matching degenerates towards +#' plain leave-one-out, the optimistic direction. So the layer is pointized +#' first, as every other geometry input of \code{make_folds()} is. +#' +#' @param pts The projected samples. +#' @param prediction_points The argument as passed. +#' @param label \code{"nndm"} or \code{"knndm"}, for the messages. +#' @return A list: \code{pts} (stamped with the prediction points' CRS when +#' they had none), \code{pred} and \code{g_target}, the finite distances. +#' @keywords internal +#' @noRd +.nndm_target <- function(pts, prediction_points, label) { + if (is.null(prediction_points)) + stop("make_folds(", label, "): `prediction_points` is required -- ", + if (identical(label, "knndm")) "kNNDM" else "NNDM", " matches ", + "the training-to-test distance distribution to the distance ", + "distribution from your actual prediction locations to the training ", + "data. Use the grid you intend to predict onto (see ", + "predict_surface()).", call. = FALSE) + if (inherits(prediction_points, "sfc")) + prediction_points <- sf::st_sf(geometry = prediction_points) + if (!all(sf::st_geometry_type(prediction_points, + by_geometry = TRUE) == "POINT")) { + .log_info(paste0("make_folds(%s): `prediction_points` are not POINTs; ", + "using representative points so the target distances ", + "are point-to-point."), label) + prediction_points <- coerce_to_points(prediction_points, "auto") + } + if (is.na(sf::st_crs(pts)) && !is.na(sf::st_crs(prediction_points))) { + pts <- .transform_or_stamp(pts, sf::st_crs(prediction_points), + what = "points_sf", caller = "make_folds") + } + # Aligned as `boundary` is: a CRS-less layer gets the warning, naming it. + pred <- if (is.null(.crs_or_null(pts))) ensure_projected(prediction_points) + else .transform_or_stamp(prediction_points, sf::st_crs(pts), + what = "prediction_points", + caller = "make_folds") + pred <- sf::st_zm(pred, drop = TRUE, what = "ZM") + + # Target: distance from each prediction location to its nearest training + # point. This is the distance regime the model will actually face, and the + # one an arbitrary fixed buffer has no reason to reproduce. + g_target <- .nn_dist_to(pred, pts) + g_target <- g_target[is.finite(g_target)] + if (!length(g_target)) + stop("make_folds(", label, "): could not compute prediction-to-training ", + "distances.", call. = FALSE) + list(pts = pts, pred = pred, g_target = g_target) +} + + +#' Largest amount by which a target ECDF runs above that of a set of distances +#' +#' \code{max(G(r) - F(r))} over every distance \code{r} in either set, with +#' \code{G} the ECDF of the target and \code{F} that of \code{d}: the share of +#' prediction points within some distance of the data that \code{d} does not +#' reproduce. Swapping the two arguments gives the excess. +#' +#' @param d Distances; non-finite values are dropped. +#' @param g_sorted The target distances, sorted. +#' @return A number in \code{[0, 1]}, or \code{NA} when \code{d} has no finite +#' value. +#' @keywords internal +#' @noRd +.ecdf_deficit <- function(d, g_sorted) { + d <- sort(d[is.finite(d)]) + if (!length(d)) return(NA_real_) + at <- sort(unique(c(d, g_sorted))) + max(findInterval(at, g_sorted) / length(g_sorted) - + findInterval(at, d) / length(d)) +} + + +#' Are the prediction points nearer to the data than any fold can hold out? +#' +#' A held-out point is never nearer to its training data than to its nearest +#' other sample, the distance plain leave-one-out gives. So where the target +#' distribution runs above leave-one-out's, no fold design reaches it: not +#' NNDM, which only excludes neighbours, and not a k-fold design, whose +#' training sets are smaller still. This is the rule both methods apply. +#' +#' Two ECDFs of one distribution differ by chance by about +#' \code{sqrt(1/n + 1/m)}. Three times that was exceeded in none of 556 +#' layouts whose folds match their target (uniform, clustered and graded +#' samples of 100 to 1000 points against grids and random prediction points, +#' 30 to 4000 of them; the largest ratio was 2.4) and in all 136 layouts +#' built out of reach (the smallest was 3.6). One fold's worth, \code{1/n}, +#' fires on every matching layout. +#' +#' That tolerance is 1 or more whenever \code{n * m / (n + m) <= 9}: for nine +#' samples or fewer whatever the target, and for up to eighteen with as many +#' prediction points. A deficit is a difference of two shares and cannot +#' exceed 1, so there the rule above cannot fire and plain leave-one-out came +#' back without a word however near the prediction points were (12 samples, +#' prediction points 5 m from each: target median 5, realised 1097, no +#' warning). The one case that needs no tolerance is complete separation: +#' every prediction distance shorter than every leave-one-out distance, a +#' deficit of exactly 1. It is reported when the two sets are large enough +#' for that ordering to mean something, taken as +#' \code{choose(n + m, n) >= 1000} ways of interleaving them (17 prediction +#' points for 3 samples, 7 for 6, 4 for 12). The count is a floor on the +#' sizes, not an error rate, and was set on layouts run through +#' \code{make_folds(method = "nndm")}: uniform, clustered and graded samples +#' of 3 to 18 points with prediction points over the samples' own extent, 300 +#' layouts per cell. With 2 to 5 random prediction points the two sets were +#' separated in 1055 of 8100 layouts, with medians as close as 1.06 to 1; the +#' floor passes over all but 12 of them. With grids of 9 to 400 points it +#' warned in 262 of 900 layouts of 3 samples (the grids above the floor), 46 +#' of 900 of 4, 18 of 1200 of 5, 6 of 1200 of 6 and none of 6000 of 8 to 18. +#' In every layout warned about, leave-one-out sat at least 1.38 times as far +#' as the target by the median and 1.8 times by the mean, so the statement +#' was true of those folds: a few samples hug the box they span. Of layouts +#' built out of reach (prediction points 5 m from each of 9, 12 or 16 +#' samples), it warned in 300 of 300, none of them by the share rule. +#' +#' @param loo_d Each sample's distance to its nearest other sample. +#' @param g_target The finite prediction-to-data distances. +#' @return A list: \code{deficit} (the largest amount by which the target +#' ECDF runs above leave-one-out's), \code{tolerance}, \code{past_tol}, +#' \code{loo_fin} (the finite leave-one-out distances), \code{separated} +#' and \code{out_of_reach}. +#' @keywords internal +#' @noRd +.nndm_reach <- function(loo_d, g_target) { + n <- length(loo_d); n_g <- length(g_target) + deficit <- .ecdf_deficit(loo_d, sort(g_target)) + tolerance <- 3 * sqrt(1 / n + 1 / n_g) + past_tol <- is.finite(deficit) && deficit > tolerance + loo_fin <- loo_d[is.finite(loo_d)] + separated <- length(loo_fin) > 0L && max(g_target) < min(loo_fin) + sep_counts <- separated && lchoose(n + n_g, n) >= log(1000) + list(deficit = deficit, tolerance = tolerance, past_tol = past_tol, + loo_fin = loo_fin, separated = separated, + out_of_reach = past_tol || sep_counts) +} + + +#' The held-out rows of a leave-one-out design +#' +#' Every row, or with \code{max_test} a random subset of that size, sorted. +#' The draw uses the session RNG, which \code{make_folds()} has seeded when +#' it was given a \code{seed}. +#' +#' @param n Number of rows. +#' @param max_test \code{NULL}, or the number of held-out points to keep. +#' @return Sorted row positions. +#' @keywords internal +#' @noRd +.loo_scored_rows <- function(n, max_test = NULL) { + if (is.null(max_test) || max_test >= n) return(seq_len(n)) + sort(sample.int(n, max_test)) +} + + +#' Pack blocks into k folds, largest first +#' +#' The longest-processing-time rule for multiway partitioning: the blocks +#' are taken in decreasing order of size and each goes to the fold with the +#' fewest points so far, ties broken at random. \code{"block_kfold"} packs +#' its grid cells this way and \code{"knndm"} its clusters. +#' +#' @param sizes Integer points per block. +#' @param k Number of folds. +#' @return A list: \code{fold_of} (the fold of each block), \code{loads} +#' (points per fold) and \code{order} (the order the blocks were placed +#' in). +#' @keywords internal +#' @noRd +.pack_largest_first <- function(sizes, k) { + ord <- order(sizes, decreasing = TRUE) + loads <- integer(k); fold_of <- integer(length(sizes)) + for (b in ord) { + j <- which(loads == min(loads)) + if (length(j) > 1) j <- sample(j, 1L) + fold_of[b] <- j + loads[j] <- loads[j] + sizes[b] + } + list(fold_of = fold_of, loads = loads, order = ord) +} + + +#' The fold of each row under a random k-fold partition +#' +#' The partition \code{method = "random_kfold"} builds: one permutation of +#' the rows cut into \code{k} runs whose sizes differ by at most one. Drawn +#' from the same RNG state it gives the same folds, which is how the random +#' candidate of \code{"knndm"} is the partition \code{"random_kfold"} returns +#' for the same \code{seed}. +#' +#' @param n Number of rows. +#' @param k Number of folds, at most \code{n}. +#' @return Integer fold labels, one per row. +#' @keywords internal +#' @noRd +.random_fold_labels <- function(n, k) { + idx <- sample.int(n, n) + sizes <- rep(floor(n / k), k) + remainder <- n - sum(sizes) + if (remainder > 0) sizes[seq_len(remainder)] <- sizes[seq_len(remainder)] + 1L + lab <- integer(n) + lab[idx] <- rep.int(seq_len(k), sizes) + lab +} + + +#' Nearest row of \code{data} to each row of \code{query}, in the plane +#' +#' \pkg{FNN}'s kd-tree when it is installed, and otherwise +#' \code{sf::st_nearest_feature()}, which is indexed too. The distance is +#' Euclidean in both. +#' +#' @param query,data Two-column coordinate matrices. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return A list: \code{index} (row of \code{data}) and \code{dist}. +#' @keywords internal +#' @noRd +.nn_xy <- function(query, data, + use_fnn = requireNamespace("FNN", quietly = TRUE)) { + if (isTRUE(use_fnn)) { + kn <- FNN::get.knnx(data, query, k = 1L) + return(list(index = as.integer(kn$nn.index[, 1L]), + dist = as.numeric(kn$nn.dist[, 1L]))) + } + idx <- sf::st_nearest_feature(.xy_points(query), .xy_points(data)) + list(index = idx, + dist = sqrt((query[, 1L] - data[idx, 1L])^2 + + (query[, 2L] - data[idx, 2L])^2)) +} + + +#' A coordinate matrix as planar points with no CRS +#' @keywords internal +#' @noRd +.xy_points <- function(m) + sf::st_geometry(sf::st_as_sf(data.frame(x = m[, 1L], y = m[, 2L]), + coords = c("x", "y"))) + + +#' Each point's distance to the nearest other point +#' +#' The held-out distance of plain leave-one-out. A co-located duplicate is +#' at distance 0. +#' +#' @param xy Two-column coordinate matrix with at least two rows. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return A numeric vector, one distance per row. +#' @keywords internal +#' @noRd +.loo_dist_xy <- function(xy, use_fnn = requireNamespace("FNN", quietly = TRUE)) { + if (isTRUE(use_fnn)) + return(as.numeric(FNN::get.knn(xy, k = 1L)$nn.dist[, 1L])) + # sf::st_nearest_feature(x) with `y` missing gives each feature's nearest + # among the others, in n^2 time: 68 s at 8,000 points. The indexed search + # needs two sets. Two different rows differ in at least one bit of their + # (zero-based) row number, so a row's nearest other point lies in the + # opposite half for one of those bits, and no point of an opposite half is + # nearer than it. The smallest opposite-half distance over the bits is + # therefore the distance wanted, from log2(n) pairs of indexed searches + # (0.5 s at 8,000 points). + n <- nrow(xy) + row0 <- seq_len(n) - 1L + d <- rep(Inf, n) + for (bit in seq_len(max(1L, ceiling(log2(n)))) - 1L) { + half <- bitwAnd(bitwShiftR(row0, bit), 1L) + 1L + d <- pmin(d, .fold_nn_dist(xy, half, 2L, FALSE), na.rm = TRUE) + } + d +} + + +#' Each point's distance to the nearest point of another fold +#' +#' @param xy Two-column coordinate matrix. +#' @param lab Integer fold label per row, in \code{1..k}. +#' @param k Number of folds. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return A numeric vector, one distance per row; \code{NA} for a point +#' whose fold holds every row. +#' @keywords internal +#' @noRd +.knndm_heldout_dist <- function(xy, lab, k, use_fnn) { + # One point per fold is leave-one-out, and one nearest-neighbour search + # then stands for the n searches of the loop over folds. + if (k == nrow(xy) && !anyDuplicated(lab)) return(.loo_dist_xy(xy, use_fnn)) + .fold_nn_dist(xy, lab, k, use_fnn) +} + + +#' The loop behind \code{.knndm_heldout_dist()}: one search per fold +#' @keywords internal +#' @noRd +.fold_nn_dist <- function(xy, lab, k, use_fnn) { + d <- rep(NA_real_, nrow(xy)) + for (f in seq_len(k)) { + te <- lab == f + if (!any(te) || all(te)) next + d[te] <- .nn_xy(xy[te, , drop = FALSE], xy[!te, , drop = FALSE], + use_fnn)$dist + } + d +} + + +#' Cluster counts tried by kNNDM +#' +#' From \code{k} clusters (one per fold) to one fewer than the number of +#' distinct locations (nearly every point a cluster of its own), evenly +#' spaced on the log scale. +#' +#' @param k Number of folds. +#' @param n_distinct Number of distinct locations. +#' @param len Number of counts before duplicates are dropped. +#' @return Increasing integers, or \code{integer(0)} when there are too few +#' distinct locations to form more than \code{k} clusters. +#' @keywords internal +#' @noRd +.knndm_cluster_counts <- function(k, n_distinct, len = 50L) { + top <- n_distinct - 1L + if (top < k) return(integer(0)) + unique(as.integer(round(exp(seq(log(k), log(top), length.out = len))))) +} + + +#' k-means clusters of the coordinates, for kNNDM on large samples +#' +#' Used to reduce a large sample to groups Ward's method can start from, and +#' for cluster counts above the number of those groups. Lloyd's algorithm from \code{q} distinct sample locations drawn at random, +#' stopped after \code{iter_max} passes or when no point changes cluster. +#' The nearest-centre step is an indexed search, so a pass costs about +#' \code{n log q}, where \code{stats::kmeans()} compares every point with +#' every centre (\code{n q}; at 20,000 points and 2,000 centres, 0.8 s +#' against 0.09 s for ten passes). The clusters are candidates to be scored +#' by their distance to the target, so a run that has not converged costs +#' nothing but a slightly different candidate. A centre that attracts no +#' point is dropped, so fewer than \code{q} clusters can come back. +#' +#' @param xy Two-column coordinate matrix. +#' @param xy_u Its distinct rows. +#' @param q Number of clusters asked for, at most \code{nrow(xy_u)}. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @param iter_max Passes. +#' @return Integer cluster labels \code{1..q'}, one per row of \code{xy}. +#' @keywords internal +#' @noRd +.knndm_kmeans <- function(xy, xy_u, q, use_fnn, iter_max = 10L) { + cen <- xy_u[sample.int(nrow(xy_u), q), , drop = FALSE] + cl <- integer(0) + for (it in seq_len(iter_max)) { + new <- .nn_xy(xy, cen, use_fnn)$index + new <- match(new, sort(unique(new))) + if (identical(new, cl)) break + cl <- new + cen <- unname(rowsum(xy, cl) / tabulate(cl)) + } + cl +} + + +#' Ward's clustering continued from groups of points +#' +#' \code{stats::hclust(method = "ward.D2")} started in the middle of the +#' dendrogram: the groups stand for merges already made, and the tree above +#' them is the one Ward's method builds from there. The dissimilarity of two +#' groups of sizes \eqn{a} and \eqn{b} whose centroids are \eqn{d} apart is +#' \eqn{\sqrt{2ab/(a+b)}\,d}, which is \eqn{d} for two single points and is +#' what the Lance-Williams update of \code{"ward.D2"} carries, and the sizes +#' go in as \code{members}. Started from an 80-cluster cut of a full Ward +#' tree on 600 points it reproduces every coarser cut of that tree. +#' +#' @param xy Two-column coordinate matrix. +#' @param grp Integer group label per row, \code{1..m} with \code{m >= 2}. +#' @return An \code{hclust} tree over the \code{m} groups. +#' @keywords internal +#' @noRd +.ward_from_groups <- function(xy, grp) { + sz <- tabulate(grp) + m <- length(sz) + dc <- stats::dist(rowsum(xy, grp) / sz) + # A `dist` object runs down the columns of the lower triangle. + col <- rep(seq_len(m - 1L), times = (m - 1L):1L) + a <- as.numeric(sz[col]) + b <- as.numeric(sz[sequence((m - 1L):1L) + col]) + col <- NULL + dc[] <- sqrt(2 * a * b / (a + b)) * as.numeric(dc) + stats::hclust(dc, method = "ward.D2", members = sz) +} + + +#' Choose k folds whose held-out distances are closest to a target +#' +#' The core of \code{make_folds(method = "knndm")}, after Linnenbrink et al. +#' (2024). The candidates are a random k-fold partition and, for each of a +#' ladder of cluster counts, the samples clustered on their coordinates and +#' the clusters packed into \code{k} folds largest first. Each admissible +#' candidate is scored by the Wasserstein distance \eqn{W} between its +#' held-out distances (each point's distance to the nearest point of another +#' fold) and the target distances, and the smallest \eqn{W} wins; a tie goes +#' to the earlier candidate, the random partition first. +#' +#' A cluster candidate is admissible when its largest fold leaves at least +#' \code{min_train} of the rows for training (or holds no more than an equal +#' share, \code{ceiling(n / k)}, where \code{min_train} allows less than +#' that) and its largest fold holds at most \code{balance_tol} times as many +#' points as its smallest. The random partition is always admissible. +#' +#' Clustering is Ward's (\code{stats::hclust(method = "ward.D2")}), cut at +#' each count, up to \code{ward_max} points, which needs the n by n distance +#' matrix (64 MB at 4,000 points, 1.6 GB at 20,000). Above that the samples +#' are first reduced to \code{ward_max} groups by k-means +#' (\code{.knndm_kmeans()}) and Ward's method is continued from those groups +#' (\code{.ward_from_groups()}); a count above the number of groups is a +#' k-means run of its own. On a 40-cluster layout of unequal cluster sizes +#' with a grid target (10 folds, 3 draws each) the folds chosen had \eqn{W} +#' at 0.09 to 0.12 of the mean target distance with Ward on all 8,000 points +#' and 0.09 to 0.11 from 4,000 groups, where k-means at every count gave 0.16 +#' to 0.19; at 30,000 points, 0.11 to 0.15 from 4,000 groups against 0.18 to +#' 0.25; at 100,000 points 0.27 (one draw), the count chosen (12,648) being +#' above the groups. A random partition stood at 0.58 to 0.62 throughout. +#' With and without \pkg{FNN} the folds were identical in all six draws at +#' 8,000 and 30,000 points. +#' +#' @param xy Two-column coordinate matrix of the samples. +#' @param g_target Finite prediction-to-data distances. +#' @param k Number of folds, between 2 and \code{nrow(xy)}. +#' @param min_train,balance_tol As in \code{make_folds()}. +#' @param use_fnn Whether to use \pkg{FNN} for the nearest-neighbour searches. +#' @param ward_max Largest sample clustered hierarchically. +#' @param n_ladder Number of cluster counts tried, before duplicates. +#' @return A list: \code{fold} (label per row), \code{realised} (held-out +#' distance per row), \code{chosen} (row of \code{candidates}), +#' \code{candidates} (a data frame: \code{candidate}, \code{n_clusters}, +#' \code{largest_fold}, \code{balance_ratio}, \code{admissible}, +#' \code{W}), \code{w_random}, \code{clustering} (\code{"ward"}, +#' \code{"kmeans+ward"}, or \code{NA} when no cluster count was tried) and +#' \code{loo_distances}. +#' @keywords internal +#' @noRd +.knndm_folds <- function(xy, g_target, k, min_train = 0.5, balance_tol = 3, + use_fnn = requireNamespace("FNN", quietly = TRUE), + ward_max = 4000L, n_ladder = 50L) { + n <- nrow(xy) + w_of <- function(d) { + d <- d[is.finite(d)] + if (length(d)) .fold_sep_compare(d, g_target)$w1 else NA_real_ + } + one <- function(candidate, n_clusters, loads, admissible, W) + data.frame(candidate = candidate, n_clusters = as.integer(n_clusters), + largest_fold = if (length(loads)) max(loads) else NA_integer_, + balance_ratio = if (length(loads) && min(loads) > 0) + max(loads) / min(loads) else NA_real_, + admissible = admissible, W = W, stringsAsFactors = FALSE) + # The largest fold a cluster candidate may have. + cap <- max(ceiling(n / k), floor((1 - min_train) * n + 1e-9)) + + # The random partition is drawn before anything else touches the RNG, so + # that it is the one "random_kfold" builds from the same seed. + lab_best <- .random_fold_labels(n, k) + d_best <- .knndm_heldout_dist(xy, lab_best, k, use_fnn) + w_random <- w_of(d_best) + cand <- list(one("random", NA_integer_, tabulate(lab_best, nbins = k), TRUE, + w_random)) + w_best <- if (is.finite(w_random)) w_random else Inf + best <- 1L + + distinct <- !duplicated(xy) + qs <- .knndm_cluster_counts(k, sum(distinct), n_ladder) + clustering <- NA_character_ + if (length(qs)) { + use_ward <- n <= ward_max + clustering <- if (use_ward) "ward" else "kmeans+ward" + if (use_ward) { + tree <- stats::hclust(stats::dist(xy), method = "ward.D2") + groups <- NULL; n_groups <- n + } else { + # Too many points for the n by n distance matrix: k-means reduces them + # to at most `ward_max` groups and Ward's method carries on from those. + xy_u <- xy[distinct, , drop = FALSE] + groups <- .knndm_kmeans(xy, xy_u, min(ward_max, nrow(xy_u) - 1L), use_fnn) + n_groups <- max(groups) + tree <- if (n_groups >= 2L) .ward_from_groups(xy, groups) else NULL + } + for (q in qs) { + cl <- if (use_ward) stats::cutree(tree, k = q) + else if (!is.null(tree) && q <= n_groups) + stats::cutree(tree, k = q)[groups] + # More clusters than groups: k-means at that count. + else .knndm_kmeans(xy, xy_u, q, use_fnn) + sizes <- tabulate(cl) + if (length(sizes) < k) { + cand[[length(cand) + 1L]] <- one("clusters", length(sizes), integer(0), + FALSE, NA_real_) + next + } + pk <- .pack_largest_first(sizes, k) + ok <- min(pk$loads) > 0L && max(pk$loads) <= cap && + max(pk$loads) / min(pk$loads) <= balance_tol + w_q <- NA_real_ + if (ok) { + lab <- pk$fold_of[cl] + d <- .knndm_heldout_dist(xy, lab, k, use_fnn) + w_q <- w_of(d) + if (is.finite(w_q) && w_q < w_best) { + w_best <- w_q; lab_best <- lab; d_best <- d + best <- length(cand) + 1L + } + } + cand[[length(cand) + 1L]] <- one("clusters", length(sizes), pk$loads, ok, + w_q) + } + } + list(fold = lab_best, realised = d_best, chosen = best, + candidates = do.call(rbind, cand), w_random = w_random, + clustering = clustering, + loo_distances = .loo_dist_xy(xy, use_fnn)) +} + + +#' Warn that kNNDM's best candidate is still closer than the target +#' +#' Classed as \code{spatialkit_knndm_short_of_target}, with the two mean +#' distances as fields \code{held_out_mean} and \code{target_mean}. +#' +#' @param held_out_mean,target_mean Mean held-out-to-training distance of the +#' folds returned, and mean prediction-to-data distance. +#' @param fmt,... The message, as for \code{sprintf()}. +#' @keywords internal +#' @noRd +.warn_knndm_short <- function(held_out_mean, target_mean, fmt, ...) { + .warn_classed("spatialkit_knndm_short_of_target", fmt, ..., + data = list(held_out_mean = held_out_mean, + target_mean = target_mean)) +} + + +#' The extent of a bbox, for a message +#' @keywords internal +#' @noRd +.block_extent_chr <- function(bb) { + sprintf("%s x %s", + format(signif(as.numeric(bb["xmax"] - bb["xmin"]), 4)), + format(signif(as.numeric(bb["ymax"] - bb["ymin"]), 4))) +} + + +#' Lay the block grid of block_kfold over a region +#' +#' The cells of an \code{nx} by \code{ny} grid over the bounding box of +#' \code{reg}, clipped to it. Clipping to a boundary drops the cells outside +#' it and renumbers the rest, so a cell's index in the full grid is carried +#' from the "idx" attribute: that is what \code{params$blocks$source_row} +#' promises. Where the boundary only touches a cell at a corner or along an +#' edge the intersection is a zero-area POINT or LINESTRING, which used to be +#' kept as a block of its own, packed into a fold when empty blocks were kept +#' and able to catch a point lying exactly on the boundary as a one-point +#' block. Only the areal pieces are kept, unless there are none (points on +#' one straight line have a region of zero area, and every piece of it is a +#' line). +#' +#' @param reg The region: an sf/sfc polygon layer (or the points' bbox). +#' @param nx,ny Grid dimensions. +#' @return A list with \code{grid_sf} (the blocks) and \code{cell_idx} (each +#' block's index in the full grid). +#' @keywords internal +#' @noRd +.block_grid <- function(reg, nx, ny) { + grid <- sf::st_make_grid(reg, n = c(nx, ny), what = "polygons", square = TRUE) + grid <- .safe_make_valid(grid) + reg_union <- .safe_make_valid(sf::st_union(reg)) + grid <- suppressWarnings(sf::st_intersection(grid, reg_union)) + cell_idx <- attr(grid, "idx") + cell_idx <- if (is.matrix(cell_idx) && nrow(cell_idx) == length(grid)) + as.integer(cell_idx[, 1L]) else seq_along(grid) + areal <- sf::st_dimension(grid) %in% 2L + if (any(areal) && !all(areal)) { + grid <- grid[areal]; cell_idx <- cell_idx[areal] + } + list(grid_sf = sf::st_as_sf(grid), cell_idx = cell_idx) +} + + +#' How many blocks of an nx by ny grid hold points +#' +#' Builds the grid as \code{make_folds()} does and assigns the points as it +#' does (the first cell that contains each), so the count is the number of +#' folds that grid can support. \code{NA} for a grid too large to build. +#' +#' @param pts Projected points. +#' @param reg The block region. +#' @param nx,ny Grid dimensions. +#' @return An integer count, or \code{NA}. +#' @keywords internal +#' @noRd +.block_occupied <- function(pts, reg, nx, ny) { + n_cells <- as.numeric(nx) * as.numeric(ny) + if (!is.finite(n_cells) || n_cells > 1e5) return(NA_integer_) + g <- tryCatch(.block_grid(reg, nx, ny), error = function(e) NULL) + if (is.null(g)) return(NA_integer_) + hits <- sf::st_intersects(pts, g$grid_sf) + id <- vapply(hits, function(ix) if (length(ix)) ix[1] else NA_integer_, 1L) + length(unique(id[!is.na(id)])) +} + + +#' The same count from the coordinates alone, for searching +#' +#' Bins the points into the cells of the grid over \code{bb} by arithmetic. +#' A point on a shared edge goes to the lower cell, as the first-cell rule of +#' \code{make_folds()} sends it. Rounding can still differ from the polygon +#' test for a point within an ulp of an edge, so a size found this way is +#' confirmed with \code{.block_occupied()} before it is quoted. +#' +#' @param xy Coordinate matrix. +#' @param bb The region's bbox. +#' @param nx,ny Grid dimensions. +#' @return An integer count. +#' @keywords internal +#' @noRd +.block_occupied_fast <- function(xy, bb, nx, ny) { + w <- as.numeric(bb["xmax"] - bb["xmin"]); h <- as.numeric(bb["ymax"] - bb["ymin"]) + ix <- if (w > 0) pmin(nx, pmax(1, ceiling((xy[, 1L] - as.numeric(bb["xmin"])) / (w / nx)))) + else rep(1, nrow(xy)) + iy <- if (h > 0) pmin(ny, pmax(1, ceiling((xy[, 2L] - as.numeric(bb["ymin"])) / (h / ny)))) + else rep(1, nrow(xy)) + length(unique((iy - 1) * nx + ix)) +} + + +#' A length no smaller than \code{x}, rounded for a message +#' +#' The size a leakage warning names must be at least the range, and must read +#' back as the number that was tried. Rounded up to a whole unit from 10 +#' upward, and to three significant figures below it (a range of 0.3712 km +#' used to be quoted as a block size of 1). +#' +#' @param x A positive number. +#' @return A number no smaller than \code{x}. +#' @keywords internal +#' @noRd +.block_size_at_least <- function(x) { + if (!is.finite(x) || x <= 0) return(x) + if (x >= 10) return(ceiling(x)) + p <- 10^(floor(log10(x)) - 2) + ceiling(x / p) * p +} + + +#' The largest block size, below a bound, that gives k blocks holding points +#' +#' The grid \code{.block_dims_from_size()} builds changes only at sizes +#' \code{w / i} and \code{h / j}, so those (a hair under each, down to a +#' two-hundredth of the extent) are the candidates, largest first. A +#' candidate whose grid has at least \code{k} occupied cells is rounded down +#' to three significant figures, as it will be quoted, and the grid at that +#' quoted number is then built and counted for real: the size returned is one +#' that \code{make_folds(block_size = )} has in effect already been run with. +#' +#' @param pts Projected points. +#' @param reg The block region. +#' @param bb Its bbox. +#' @param k Blocks needed. +#' @param below Sizes at or above this are not considered. +#' @return \code{NULL} when none is found, else a list with \code{size} +#' (numeric), \code{chr} (as quoted), \code{nx} and \code{ny}. +#' @keywords internal +#' @noRd +.block_largest_size_for_k <- function(pts, reg, bb, k, below = Inf) { + below <- as.numeric(below)[1L] + w <- as.numeric(bb["xmax"] - bb["xmin"]); h <- as.numeric(bb["ymax"] - bb["ymin"]) + cand <- c(if (is.finite(w) && w > 0) w / seq_len(200L), + if (is.finite(h) && h > 0) h / seq_len(200L)) * (1 - 1e-9) + cand <- sort(unique(cand[is.finite(cand) & cand > 0 & cand < below]), + decreasing = TRUE) + if (!length(cand)) return(NULL) + xy <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] + confirmed <- 0L + for (b in cand) { + d <- .block_dims_from_size(bb, b) + if (as.numeric(d$nx) * as.numeric(d$ny) < k) next + if (.block_occupied_fast(xy, bb, d$nx, d$ny) < k) next + chr <- format(.signif_down(b), scientific = FALSE, trim = TRUE) + size <- suppressWarnings(as.numeric(chr)) + if (!is.finite(size) || size <= 0 || size >= below) next + ds <- .block_dims_from_size(bb, size) + occ <- .block_occupied(pts, reg, ds$nx, ds$ny) + if (!is.na(occ) && occ >= k) + return(list(size = size, chr = chr, nx = ds$nx, ny = ds$ny)) + confirmed <- confirmed + 1L + if (confirmed >= 8L) break + } + NULL +} + + +#' Name the fold method that does not depend on a block size +#' +#' @param n Number of points. +#' @return Character(1). +#' @keywords internal +#' @noRd +.block_other_method <- function(n) { + if (n <= 5000L) + return(paste0("method = \"nndm\" does not depend on a block size: it ", + "builds leave-one-out folds matched to the distances from ", + "`prediction_points` to the data.")) + # Above the leave-one-out method's row limit the k-fold version is the one + # that runs. The sentence used to end at the limit, naming a method and + # then saying it could not be used. + sprintf(paste0("method = \"knndm\" does not depend on a block size: it ", + "builds k folds matched to the distances from ", + "`prediction_points` to the data. (method = \"nndm\", its ", + "leave-one-out version, takes at most 5000 rows, and this ", + "layer has %d.)"), n) +} + + +#' Warn that block-building arguments arrived beside supplied folds +#' +#' \code{block_size} and \code{auto_range} are read only when a +#' \code{cv_*()} function builds its own folds. Beside supplied +#' \code{folds} they used to be dropped without a word, so +#' \code{cv_spatial(folds = random_folds, auto_range = TRUE)} ran on the +#' random folds and looked like a range-sized blocked run. \code{k} is not +#' checked: the package's own callers always pass it with their folds, and +#' it is documented as used only when \code{folds} is \code{NULL}. The +#' warning carries the class \code{spatialkit_fold_args_ignored}. +#' +#' @param folds The \code{folds} argument as the caller received it. +#' @param block_size,auto_range The two arguments. +#' @param caller Name for the message. +#' @return \code{TRUE}, invisibly, when it warned. +#' @keywords internal +#' @noRd +.warn_fold_args_ignored <- function(folds, block_size, auto_range, caller) { + if (is.null(folds)) return(invisible(FALSE)) + given <- c(if (!is.null(block_size)) "`block_size`", + if (isTRUE(auto_range)) "`auto_range = TRUE`") + if (!length(given)) return(invisible(FALSE)) + several <- length(given) > 1L + msg <- sprintf(paste0( + "%s(): %s %s no effect because `folds` is supplied: the folds are used ", + "as given and no blocks are built. Pass %s to make_folds() when building ", + "the folds, or leave `folds` NULL to have them built here."), + caller, paste(given, collapse = " and "), if (several) "have" else "has", + if (several) "them" else "it") + .warn_classed("spatialkit_fold_args_ignored", "%s", msg) + invisible(TRUE) +} + + +#' What following a leakage warning's advice yields on this layout +#' +#' The leakage warnings of \code{make_folds(method = "block_kfold")} used to +#' end "Pass block_size = or auto_range = TRUE" whatever the extent. +#' This builds the grid that size asks for, counts the blocks that hold +#' points, and words the advice by the outcome: the setting and what it +#' builds when that gives \code{k} folds; otherwise how many folds it gives +#' (or that it stops with the single-block error), the largest block size +#' that still gives \code{k} folds and how far below the range that is, and +#' the method that does not depend on a block size. +#' +#' @param pts Projected points. +#' @param reg The block region. +#' @param bb Its bbox. +#' @param sac_range The estimated range. +#' @param k Folds asked for. +#' @param mention_auto Whether \code{auto_range = TRUE} alone would size the +#' blocks from the range (it would not beside an explicit \code{block_size}). +#' @return Character(1), one or more sentences. +#' @keywords internal +#' @noRd +.block_range_advice <- function(pts, reg, bb, sac_range, k, mention_auto = TRUE) { + # An estimate_sac_range() result carries a class and a dozen attributes, + # which arithmetic and format() would drag into the text. + sac_range <- as.numeric(sac_range)[1L] + ext <- .block_extent_chr(bb) + size_chr <- format(.block_size_at_least(sac_range), scientific = FALSE, trim = TRUE) + size <- as.numeric(size_chr) + d <- .block_dims_from_size(bb, size) + occ <- .block_occupied(pts, reg, d$nx, d$ny) + # auto_range = TRUE sizes the grid from the range itself, not from the + # rounded figure quoted here; it is named only when both build one grid. + da <- .block_dims_from_size(bb, sac_range) + auto <- isTRUE(mention_auto) && identical(c(da$nx, da$ny), c(d$nx, d$ny)) + setting <- if (auto) sprintf("block_size = %s or auto_range = TRUE", size_chr) + else sprintf("block_size = %s", size_chr) + grid_chr <- sprintf("%s x %s", format(d$nx, scientific = FALSE), + format(d$ny, scientific = FALSE)) + if (is.na(occ)) return(sprintf("Pass %s.", setting)) + if (occ >= k) + return(sprintf(paste0("Pass %s: over this %s extent that builds a %s grid ", + "in which %d blocks hold points, enough for k = %d ", + "folds."), setting, ext, grid_chr, occ, k)) + alt <- .block_largest_size_for_k(pts, reg, bb, k, below = size) + alt_txt <- if (is.null(alt)) + sprintf("No block size down to 1/200 of the extent gives %d blocks that hold points.", k) + else sprintf(paste0("The largest block_size that gives %d folds is %s, ", + "%.0f%% of the range, so its folds are separated by ", + "less than the range."), k, alt$chr, 100 * alt$size / as.numeric(sac_range)) + other <- .block_other_method(nrow(pts)) + if (occ >= 2L) + return(sprintf(paste0("Blocks of the range leave %d blocks that hold ", + "points over this %s extent (a %s grid), so %s ", + "returns %d folds, not %d. %s %s"), + occ, ext, grid_chr, setting, occ, k, alt_txt, other)) + sprintf(paste0("A block of the range leaves a single block that holds ", + "points over this %s extent, so block folds cannot be ", + "separated by the range here: %s stops with an error. %s %s"), + ext, setting, alt_txt, other) +} + + # ----------------------------------------------------------------------------- # GWR Cross-Validation (now delegates to .cv_run_folds) # ----------------------------------------------------------------------------- @@ -4830,7 +7526,8 @@ make_folds <- function(points_sf, k, #' error. IDs naming no row in the prepared data are dropped with #' a logged count (expected when rows were removed for missing values; a sign #' the folds came from other data when they were not). -#' @param k Number of folds. Default 5. +#' @param k Number of folds to build when \code{folds} is \code{NULL}; not +#' read when \code{folds} is supplied. Default 5. #' @param seed RNG seed. Default 123. #' @param adaptive Logical; use adaptive bandwidth. Default TRUE. #' @param bandwidth Optional bandwidth, applied to every fold. For @@ -4838,23 +7535,28 @@ make_folds <- function(points_sf, k, #' \code{adaptive = FALSE} a distance in the units of the \strong{projected} #' CRS the folds are fitted in (geographic input is projected first, so a #' value in degrees is read as metres). \code{NULL} (default) selects a -#' bandwidth per fold with \code{GWmodel::bw.gwr()}, which is reported in -#' \code{fold_metrics$bandwidth}. See \code{\link{fit_gwr_model}}. +#' bandwidth per fold from that fold's training rows, by the search +#' \code{\link{fit_gwr_model}()} runs (its section Bandwidth selection: +#' AICc, or the leave-one-location-out sum of squares when observations +#' share a location), and reports it in \code{fold_metrics$bandwidth}. #' @param kernel Kernel function type. #' @param boundary Optional polygonal sf/sfc for CRS alignment. #' @param pointize Geometry coercion strategy. -#' @param block_size Optional minimum block edge length for spatial CV blocks -#' (projected CRS units). Blocks are then at least as large as the -#' spatial autocorrelation range. +#' @param block_size Optional minimum block edge length (projected CRS +#' units) for the blocks built when \code{folds} is \code{NULL}; see +#' \code{\link{make_folds}()}. It is a size you choose and is not +#' compared with the autocorrelation range unless one can be estimated, in +#' which case a smaller size is warned about. Beside supplied +#' \code{folds} it has nothing to size and raises a warning (class +#' \code{spatialkit_fold_args_ignored}). #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, #' estimate the autocorrelation range and use it as the minimum block size. -#' Default \code{FALSE}. +#' Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +#' the same warning as \code{block_size}. #' @param parallel Accepted so that every \code{cv_*()} function takes the #' same arguments, but the GWR folds always run one after another in this -#' R process. GWmodel is built with OpenMP, and OpenMP (GNU libgomp) -#' deadlocks \code{parallel::mclapply()}'s forked workers once a GWR has -#' been fitted in the session, for example by \code{fit_gwr_model()}, so -#' forking would hang the call. A value asking for more than one core +#' R process, where the warnings \code{predict()} raises for each fold are +#' collected into one. A value asking for more than one core #' raises a warning saying so. Default \code{FALSE}. #' @param metrics Optional scoring function of your own, a #' \code{function(y, yhat)} returning a named numeric vector; its names @@ -4875,11 +7577,16 @@ make_folds <- function(points_sf, k, #' statuses and for \code{orphan_rows}. \code{Adj_R2} is \code{NA} #' in both \code{overall} and \code{fold_metrics}: the pooled predictions #' have no single parameter count, and a GWR's effective parameter count is -#' not its predictor count (see \code{\link{cv_spatial}}). +#' not its predictor count (see \code{\link{cv_spatial}}). A held-out +#' location whose local regression cannot be estimated has \code{yhat} +#' \code{NA}, and one beyond the reach of its fold's fit is predicted and +#' scored; each case raises one warning for the whole run (classes +#' \code{"spatialkit_gwr_not_estimable"} and +#' \code{"spatialkit_gwr_extrapolation"}), with the totals over the folds +#' that had any. See \code{\link{predict.gwr_fit}}. #' @family cross-validation #' @examples -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' if (requireNamespace("sp", quietly = TRUE)) { #' library(sf) #' set.seed(1) #' n <- 60 @@ -4905,10 +7612,9 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, parallel = FALSE, metrics = NULL) { if (!inherits(data_sf, "sf")) stop("cv_gwr(): `data_sf` must be an sf object.") metrics <- .check_metrics_fn(metrics, "cv_gwr") - if (!requireNamespace("GWmodel", quietly = TRUE)) - stop("cv_gwr(): package 'GWmodel' is required.", call. = FALSE) if (!requireNamespace("sp", quietly = TRUE)) - stop("cv_gwr(): package 'sp' is required (for GWmodel interop).", call. = FALSE) + stop("cv_gwr(): package 'sp' is required (a GWR fit keeps its local ", + "estimates in a SpatialPointsDataFrame).", call. = FALSE) # match.arg() is the whole of kernel validation: it refuses a wrong case, # NA or a vector, so a separate repair step after it could never run. @@ -4932,6 +7638,7 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, # Refuse folds built from other data before anything is fitted: the splits # are row IDs, so a wrong `folds` of the right size applies silently. .check_fold_probe(folds, data_sf, "cv_gwr") + .warn_fold_args_ignored(folds, block_size, auto_range, "cv_gwr") if (is.null(folds)) { message("cv_gwr(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") @@ -4973,34 +7680,39 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, # parsimony. We set p = NULL so that per-fold Adj_R² is reported as NA, # consistent with the pooled metric and with cv_bayes(). # - # GWR folds never fork. GWmodel is built with OpenMP, and GNU libgomp is - # not fork-safe: once any GWR has run in this session (fit_gwr_model(), a - # sequential cv_gwr(), select_gwr_variables(), a bare GWmodel::bw.gwr()) the - # parent holds an OpenMP thread pool that a forked child inherits without - # its threads, so the child's first parallel region waits on a futex for - # ever and parallel::mclapply() never returns. That was the ordinary - # fit-then-cross-validate order, and it hung with no timeout. Nothing - # visible from R says whether the pool exists, so the folds run here, one - # after another. A PSOCK cluster would avoid the fork, but its workers - # need this same spatialkit installed, which pkgload::load_all() or any - # development copy does not give them, and they cannot see what a - # `metrics` closure reads from the global environment. The other cv_*() - # keep mclapply(): ranger runs its own threads, not libgomp's. + # GWR folds never fork. The rule was made for the engine this function + # had: GWmodel is built with OpenMP, GNU libgomp is not fork-safe, and once + # any GWR had run in the session a forked child's first parallel region + # waited on a futex for ever, so parallel::mclapply() never returned. The + # local regressions are now solved by this package and no GWmodel code + # runs in a fold. The folds still run here, one after another: forked + # folds have not been tested with the package's own solve (its batched + # scoring is BLAS matrix products, and an OpenMP-threaded BLAS is the same + # hazard). A PSOCK cluster would avoid the fork, but its workers need this + # same spatialkit installed, which pkgload::load_all() or any development + # copy does not give them, and they cannot see what a `metrics` closure + # reads from the global environment. if (.resolve_n_cores(parallel) > 1L) { .warn_and_log(paste0( "cv_gwr(): `parallel` is ignored and the %d folds run one after ", - "another. GWmodel runs OpenMP code, which deadlocks forked (mclapply) ", - "workers once a GWR has been fitted in the session."), + "another: GWR folds are not run in forked workers."), length(remapped_folds)) parallel <- FALSE } - res <- .cv_run_folds( - dat_sf = dat_sf, response_var = response_var, - predictor_vars = predictor_vars, - remapped_folds = remapped_folds, keep_idx = keep_idx, - fit_one = fit_one, fold_info_fn = fold_info_fn, - p = NULL, parallel = parallel, seed = seed, metrics = metrics - ) + # predict() on a GWR warns per call about held-out locations it cannot + # estimate and about those beyond the reach of the fold's fit. The folds + # run in this process, so the per-fold warnings are collected here and each + # class is raised once, with the totals over the folds that had any. No + # n_total: fold schemes differ in how many rows they predict. + res <- .gwr_tally_predict_warnings( + .cv_run_folds( + dat_sf = dat_sf, response_var = response_var, + predictor_vars = predictor_vars, + remapped_folds = remapped_folds, keep_idx = keep_idx, + fit_one = fit_one, fold_info_fn = fold_info_fn, + p = NULL, parallel = parallel, seed = seed, metrics = metrics + ), + caller = "cv_gwr") preds <- if (length(res$pred_rows)) do.call(rbind, res$pred_rows) else data.frame(`..row_id` = integer(), fold = integer(), @@ -5077,7 +7789,8 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' error. IDs naming no row in the prepared data are dropped with #' a logged count (expected when rows were removed for missing values; a sign #' the folds came from other data when they were not). -#' @param k Number of folds. Default 5. +#' @param k Number of folds to build when \code{folds} is \code{NULL}; not +#' read when \code{folds} is supplied. Default 5. #' @param seed RNG seed. Default 123. It seeds fold construction \strong{and}, #' through a per-fold draw, each fold's Stan sampler, so two seeds give #' different posteriors even on identical \code{folds}. A \code{seed} in @@ -5100,11 +7813,15 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' \code{95}), each given once; anything else is an error. Each becomes a #' column \code{coverage_} of \code{fold_metrics}, named at full #' precision (\code{0.975} gives \code{coverage_97.5}). -#' @param block_size Optional minimum block edge length for spatial CV blocks -#' (projected CRS units). +#' @param block_size Optional minimum block edge length (projected CRS +#' units) for the blocks built when \code{folds} is \code{NULL}; see +#' \code{\link{make_folds}()}. Beside supplied \code{folds} it has +#' nothing to size and raises a warning (class +#' \code{spatialkit_fold_args_ignored}). #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, #' estimate the autocorrelation range and use it as the minimum block size. -#' Default \code{FALSE}. +#' Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +#' the same warning as \code{block_size}. #' @param parallel Logical or positive integer. If \code{TRUE}, #' auto-detect the number of cores and fit folds in parallel via #' \code{parallel::mclapply()} (macOS / Linux; falls back to sequential @@ -5124,6 +7841,21 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' posterior predictive \code{summary} (mean or median) of each held-out #' row; a score that needs the draws belongs in \code{predictive_coverage} #' and \code{CRPS}, which this function computes itself. +#' @section Warnings from the folds: +#' \code{\link{fit_bayesian_spatial_model}()} warns about a fit under four +#' condition classes: \code{spatialkit_gp_basis_size}, +#' \code{spatialkit_gp_resolution}, \code{spatialkit_convergence} and +#' \code{spatialkit_gp_adequacy} (see its \strong{Warnings}). Each fold is +#' a fit, and none of those warnings says which fold it came from, so they +#' are collected as the folds run and each class is raised once after the +#' last fold, under this function's name and with the same class. Each +#' warning names the folds and carries \code{folds} (their labels) and +#' \code{fold_messages} (every fold's own text, named by fold) as fields of +#' the condition. The convergence warning covers the folds that were +#' scored and gives the checks each failed, also as the field +#' \code{failed}; the other three quote the first fold's own text. Each +#' fold's own line is in the log. Warnings that Stan or \pkg{brms} raise +#' themselves are not collected and are passed on. #' @inheritSection model_metrics Percentage errors on responses with zeros #' @inheritSection model_metrics Which metrics survive a non-Gaussian response #' @return A list with \code{overall}, \code{fold_metrics}, @@ -5147,12 +7879,22 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' see \code{\link{cv_spatial}}. #' \code{fold_metrics} carries, beyond the columns its siblings share, #' \code{gp_k}, \code{gp_n_basis}, \code{n_draws}, \code{CRPS}, the -#' \code{coverage_*} columns and \code{convergence_ok}: \code{TRUE} or +#' \code{coverage_*} columns, \code{convergence_ok} and +#' \code{gp_adequacy}. \code{convergence_ok} is \code{TRUE} or #' \code{FALSE} as \code{\link{fit_bayesian_spatial_model}()} judged that -#' fold's sampler (R-hat, effective sample size, divergences), \code{NA} +#' fold's sampler (divergent transitions, R-hat, effective sample size and +#' E-BFMI; see its \code{check_convergence}), \code{NA} #' when \code{fit_args} sets \code{check_convergence = FALSE}. A fold that #' did not converge is scored like the others, so a run with any -#' \code{FALSE} raises one warning naming those folds. +#' \code{FALSE} raises one warning of class \code{spatialkit_convergence} +#' naming those folds and the checks each failed. +#' \code{gp_adequacy} is what that fold's posterior said about its +#' Gaussian-process basis (\code{"ok"}, \code{"below_resolution"}, +#' \code{"unresolved_short_range"}, \code{"no_signal_above_floor"} or +#' \code{"not_checked"}; see "What the basis resolves" in +#' \code{\link{fit_bayesian_spatial_model}}). A fold whose basis was +#' found too coarse is scored like the others too. See \strong{Warnings +#' from the folds}. #' The \code{predictive_coverage} entries (one per #' \code{coverage_levels} value, plus \code{mean_CRPS}) are averages across #' folds \strong{weighted by each fold's \code{n_pred}}, because the per-fold @@ -5228,6 +7970,7 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, # Refuse folds built from other data before anything is fitted: the splits # are row IDs, so a wrong `folds` of the right size applies silently. .check_fold_probe(folds, data_sf, "cv_bayes") + .warn_fold_args_ignored(folds, block_size, auto_range, "cv_bayes") if (is.null(folds)) { message("cv_bayes(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") @@ -5279,12 +8022,19 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, n_draws = NA_integer_, CRPS = NA_real_, # TRUE / FALSE as fit_bayesian_spatial_model() judged the fold's - # sampler (R-hat, ESS, divergences), NA when nothing was checked. A - # fold whose posterior did not converge scores like any other, so the - # table has to say which ones those are. + # sampler (divergences, R-hat, ESS, E-BFMI), NA when nothing was + # checked. A fold whose posterior did not converge scores like any + # other, so the table has to say which ones those are. convergence_ok = { v <- fit_obj$info$convergence_ok if (is.logical(v) && length(v) == 1L) v else NA + }, + # What the fold's posterior said about its GP basis + # ($info$gp_adequacy$status): a fold whose basis was too coarse scores + # like any other. + gp_adequacy = { + v <- fit_obj$info$gp_adequacy$status + if (is.character(v) && length(v) == 1L) v else NA_character_ } ) # Pre-initialise coverage columns so every fold emits the same schema @@ -5340,14 +8090,21 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, extras } - res <- .cv_run_folds( + # Each fold's fit can raise three classed warnings of its own: a sampler + # that did not converge, a variogram range below what the basis resolves, + # and a basis the fitted model shows to be too coarse. None says which + # fold it is, and passed on they arrived once per fold beside this + # function's own summary of the same folds. They are collected here with + # their fold and raised once per class after the folds, naming the folds. + collected <- .cv_collect_fold_warnings(.cv_run_folds( dat_sf = dat_sf, response_var = response_var, predictor_vars = predictor_vars, remapped_folds = remapped_folds, keep_idx = keep_idx, fit_one = fit_one, fold_info_fn = fold_info_fn, predict_args = list(summary = summary), p = NULL, parallel = parallel, seed = seed, metrics = metrics - ) + )) + res <- collected$value # Every fold carries a yhat_sd column: the posterior predictive SD where # the draws succeeded, NA where compute_pred_intervals = FALSE or the @@ -5371,7 +8128,7 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, n_MAPE = integer(), n_SMAPE = integer(), CRPS = numeric(), gp_k = integer(), gp_n_basis = integer(), n_draws = integer(), - convergence_ok = logical()) + convergence_ok = logical(), gp_adequacy = character()) if (!nrow(folds_df)) for (cn in .user_metric_names(metrics)) folds_df[[cn]] <- numeric() @@ -5391,25 +8148,15 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, n_attempted, n_succeeded) } - # The convergence checks log each fold's R-hat, ESS and divergences, but a - # log line is invisible under knitr, spatialkit_quiet() and tryCatch(), and - # a fold whose sampler did not converge is scored like any other: its RMSE, - # CRPS and coverage enter `overall` with nothing in the result to say so. - # One R warning per run names those folds; fold_metrics$convergence_ok - # marks them. - if (nrow(folds_df) && "convergence_ok" %in% names(folds_df)) { - bad <- which(folds_df$convergence_ok %in% FALSE) - if (length(bad)) - .warn_and_log(paste0("cv_bayes(): the sampler did not converge in %d of %d ", - "fold(s) (fold %s); their scores enter `overall` like ", - "the others but come from unreliable posteriors. ", - "fold_metrics$convergence_ok marks them and the log ", - "gives each fold's R-hat, ESS and divergences; raise ", - "`iter` (or `control = list(adapt_delta = ...)`) in ", - "`fit_args`."), - length(bad), nrow(folds_df), - paste(folds_df$fold[bad], collapse = ", ")) - } + # A fold whose sampler did not converge is scored like any other: its + # RMSE, CRPS and coverage enter `overall`. One R warning per run names + # those folds and the checks each failed; fold_metrics$convergence_ok marks + # them. The two warnings about the basis are raised the same way. + .cv_raise_fold_warnings( + "cv_bayes", collected$said, scored = folds_df$fold, + n_run = length(remapped_folds), + not_converged = if (nrow(folds_df) && "convergence_ok" %in% names(folds_df)) + folds_df$fold[folds_df$convergence_ok %in% FALSE] else integer(0)) list(overall = .cv_overall_metrics(preds, metrics), fold_metrics = folds_df, predictions = preds, folds = .bare_folds(remapped_folds), @@ -5529,7 +8276,8 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' error. IDs naming no row in the prepared data are dropped with #' a logged count. #' Built via \code{block_kfold} when \code{NULL}. -#' @param k Number of folds. +#' @param k Number of folds to build when \code{folds} is \code{NULL}; not +#' read when \code{folds} is supplied. #' @param seed RNG seed. #' @param boundary Optional boundary for fold construction. #' @param pointize Geometry coercion strategy. @@ -5554,19 +8302,23 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' @param p Number of predictors for Adj R² (NULL to skip). Only meaningful #' for models with a fixed global parameter count; pass NULL for models #' with spatially varying coefficients (e.g. GWR). -#' @param block_size Optional minimum block edge length for spatial CV blocks -#' (projected CRS units). +#' @param block_size Optional minimum block edge length (projected CRS +#' units) for the blocks built when \code{folds} is \code{NULL}; see +#' \code{\link{make_folds}()}. Beside supplied \code{folds} it has +#' nothing to size and raises a warning (class +#' \code{spatialkit_fold_args_ignored}). #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, #' estimate the autocorrelation range and use it as the minimum block size. -#' Default \code{FALSE}. +#' Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +#' the same warning as \code{block_size}. #' @param parallel Logical or positive integer. If \code{TRUE}, #' auto-detect the number of cores and fit folds in parallel via #' \code{parallel::mclapply()} (macOS / Linux; falls back to sequential #' on Windows). If an integer > 1, use that many cores. Default -#' \code{FALSE} (sequential). A learner that runs OpenMP code (GWmodel, -#' or an xgboost built with GNU libgomp) can hang the forked workers once -#' it has run in the session; keep such a \code{fit_fn} sequential, as -#' \code{\link{cv_gwr}()} does. +#' \code{FALSE} (sequential). A learner that runs OpenMP code (a +#' function of GWmodel, or an xgboost built with GNU libgomp) can hang the +#' forked workers once it has run in the session; keep such a +#' \code{fit_fn} sequential. #' @param metrics Optional scoring function of your own; see \strong{Your #' own metrics} below. Default \code{NULL}: the built-in metrics only. #' @param .caller Internal. The name the messages carry, so a wrapper such as @@ -5607,6 +8359,25 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' only the two vectors but is also pooled. \code{compare_models_cv()} #' hands one \code{metrics} to every backend, so the columns are comparable #' across the rows of its \code{overall}. +#' @section Warnings a learner raises in every fold: +#' A warning from a fold's fit or from its \code{predict()} reaches the +#' caller as it is raised, so a learner that warns in every fold warns once +#' per fold. Two groups of the package's own warnings are collected over the +#' folds instead and raised once per call, under this function's name and +#' with the class they had: +#' \itemize{ +#' \item the two in which \code{predict()} on a GWR counts locations +#' (\code{"spatialkit_gwr_not_estimable"} and +#' \code{"spatialkit_gwr_extrapolation"}), with the totals over the folds +#' that had any, as \code{\link{cv_gwr}()} raises them (see +#' \code{\link{predict.gwr_fit}}); +#' \item the four \code{\link{fit_bayesian_spatial_model}()} raises about +#' a fit, naming the folds, as \code{\link{cv_bayes}()} raises them (see +#' \strong{Warnings from the folds} there). +#' } +#' With \code{parallel} above one core a fold's warnings are raised after +#' the folds have run, once per distinct text; one of the package's own +#' classes keeps its class and its fields. #' @inheritSection model_metrics Percentage errors on responses with zeros #' @return A list with \code{overall}, \code{fold_metrics}, \code{predictions}, #' \code{folds}, the two fold counts \code{n_folds_attempted} and @@ -5739,6 +8510,7 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, # Refuse folds built from other data before anything is fitted: the splits # are row IDs, so a wrong `folds` of the right size applies silently. .check_fold_probe(folds, data_sf, .caller) + .warn_fold_args_ignored(folds, block_size, auto_range, .caller) if (is.null(folds)) { message(.caller, "(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") @@ -5755,14 +8527,26 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, cleanup_cv <- .with_seed(seed) on.exit(cleanup_cv(), add = TRUE) - res <- .cv_run_folds( - dat_sf = dat_sf, response_var = response_var, - predictor_vars = predictor_vars, - remapped_folds = remapped_folds, keep_idx = keep_idx, - fit_one = fit_fn, fold_info_fn = fold_info_fn, - predict_args = predict_args, p = p, - parallel = parallel, seed = seed, metrics = metrics - ) + # A `fit_fn` that returns a GWR is predicted fold by fold like cv_gwr()'s, + # and predict() on a GWR counts per call the held-out locations it cannot + # estimate and those beyond the reach of the fold's fit. They are + # collected here as cv_gwr() collects them, and each class is raised once + # with the totals. No other backend signals either class, so for every + # other learner this does nothing. + # A `fit_fn` that returns a Bayesian fit raises that fit's classed warnings + # in every fold (see cv_bayes()); they are collected with their fold and + # raised once per class below. + collected <- .cv_collect_fold_warnings(.gwr_tally_predict_warnings( + .cv_run_folds( + dat_sf = dat_sf, response_var = response_var, + predictor_vars = predictor_vars, + remapped_folds = remapped_folds, keep_idx = keep_idx, + fit_one = fit_fn, fold_info_fn = fold_info_fn, + predict_args = predict_args, p = p, + parallel = parallel, seed = seed, metrics = metrics + ), + caller = .caller)) + res <- collected$value # bind_rows(), as for fold_stats below: a fold whose fold_info_fn returned # no `..per_row` (conditionally, with the wrong row count, or because it @@ -5797,6 +8581,9 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, .cv_warn_failed_folds(.caller, res, preds, length(keep_idx), n_attempted, n_succeeded) } + if (length(collected$said)) + .cv_raise_fold_warnings(.caller, collected$said, scored = folds_df$fold, + n_run = length(remapped_folds)) list(overall = .cv_overall_metrics(preds, metrics), fold_metrics = folds_df, predictions = preds, diff --git a/R/crs-geometry.R b/R/crs-geometry.R index 6ca97617..18f48636 100644 --- a/R/crs-geometry.R +++ b/R/crs-geometry.R @@ -462,7 +462,8 @@ #' choose between candidate projections by measurement rather than by rule of #' thumb. #' -#' The sample is taken by evenly spaced index (no RNG), so the result is +#' The sample is taken at even spacing along the points sorted by coordinate +#' (no RNG, and no dependence on the order of the rows), so the result is #' reproducible; \code{max_n} keeps the pairwise work bounded. #' #' @param x_ll An sf/sfc object in a geographic CRS. Non-POINT geometry is @@ -567,7 +568,18 @@ } n <- length(g) if (n < 2L) return(NA_real_) - if (n > max_n) g <- g[unique(round(seq(1, n, length.out = max_n)))] + if (n > max_n) { + # Evenly spaced along the points sorted by coordinate, not along the + # rows as they come. By row, the 40 points measured changed with the + # order of the layer, the candidates' errors with them, and near a tie + # the projection chosen: 400 points over the conterminous United States + # got an Albers CRS in some row orders and a Lambert azimuthal one in + # others, and everything measured in that CRS afterwards (a variogram + # range, the blocks sized from it) moved with the order of the rows. + cc <- sf::st_coordinates(g)[, 1:2, drop = FALSE] + ord <- order(cc[, 1L], cc[, 2L]) + g <- g[ord[unique(round(seq(1, n, length.out = max_n)))]] + } # Ellipsoidal geodesics, not sf's s2 sphere: the sphere is itself # 0.24-0.56% off WGS84, which is the size of the errors being ranked. ll <- sf::st_coordinates(sf::st_transform(g, 4326))[, 1:2, drop = FALSE] @@ -706,7 +718,7 @@ #' with \code{fitted(fit)} by up to the response's standard deviation. #' #' Coordinates are taken to be lon/lat when the bounding box fits the -#' [-180, 180] x [-90, 90] envelope AND the data look \emph{positively} +#' \code{[-180, 180] x [-90, 90]} envelope AND the data look \emph{positively} #' geographic: an extent above one degree on some axis, OR fractional #' coordinates with the precision of decimal degrees. #' @@ -719,7 +731,7 @@ #' reading a small planar survey as degrees produces coordinates that are #' obviously wrong and a warning that names the assumption. Requiring BOTH #' tests would not help: a genuine study area 0.01 degrees across passes only -#' the precision test, and a [0, 1]-normalised planar layer passes it too. +#' the precision test, and a \code{[0, 1]}-normalised planar layer passes it too. #' When the data are planar, set the CRS explicitly, as the warning says. #' #' @param x An sf/sfc object with no CRS. diff --git a/R/evaluation.R b/R/evaluation.R index 8e81913e..2f2060cf 100644 --- a/R/evaluation.R +++ b/R/evaluation.R @@ -69,8 +69,8 @@ #' @noRd .model_available <- function(model_name) { switch(model_name, - "GWR" = requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE), + # The GWR is solved by this package; sp holds the fit's Spatial table. + "GWR" = requireNamespace("sp", quietly = TRUE), "Bayesian" = requireNamespace("brms", quietly = TRUE), "RF" = requireNamespace("ranger", quietly = TRUE), FALSE @@ -276,6 +276,12 @@ } +# The most observations the dense fallback of .build_knn_weights() takes: it +# holds an n x n matrix. resolution_profile() reads the same number to know +# at which levels Moran's z cannot be computed without FNN and Matrix. +.KNN_DENSE_MAX <- 5000L + + #' Build a row-standardised k-nearest-neighbour sparse weight matrix #' #' For each observation the \code{k} closest \emph{other} observations receive @@ -328,7 +334,7 @@ # entered whenever either is missing and always allocates W <- matrix(0,n,n), # so keying it on FNN alone let an unbounded n x n allocation through whenever # FNN was present but Matrix was not (or use_matrix = FALSE). - if (!(has_fnn && has_matrix) && n > 5000L) + if (!(has_fnn && has_matrix) && n > .KNN_DENSE_MAX) stop("n = ", n, " requires FNN for k-NN weights, and Matrix to hold them sparsely (the dense fallback would allocate an n*n matrix). Install both with install.packages(c(\"FNN\", \"Matrix\")).", call. = FALSE) # The sparse path is bounded too. k >= n - 1 is a complete graph -- n(n-1) @@ -1124,8 +1130,13 @@ print.morans_i <- function(x, ...) { #' #' @param fits Named list of \code{spatial_fit} objects. #' @return A data.frame with columns \code{model}, \code{resid_morans_I}, -#' \code{resid_morans_z}, \code{resid_morans_p} and \code{resid_morans_null} -#' (which null the p-value was computed against, per model). +#' \code{resid_morans_z}, \code{resid_morans_p}, \code{resid_morans_null} +#' (which null the p-value was computed against, per model) and +#' \code{resid_morans_basis} (which residuals the statistic was computed +#' on: \code{"out-of-bag"} for a fit whose \code{residuals()} are +#' out-of-bag, \code{"in-sample"} otherwise, \code{NA} when no statistic +#' was computed). The residuals are always the fit's own, so the basis is +#' never \code{"newdata"}. #' @keywords internal #' @noRd .residual_morans_table <- function(fits) { @@ -1140,11 +1151,19 @@ print.morans_i <- function(x, ...) { data.frame(model = nms[i], resid_morans_I = NA_real_, resid_morans_z = NA_real_, resid_morans_p = NA_real_, resid_morans_null = NA_character_, + resid_morans_basis = NA_character_, stringsAsFactors = FALSE) } else { + # residual_morans_i() reads residuals(fit): the rows the model was + # fitted to, whatever `newdata` compare_models() was given. The same + # rule as evaluate_insample()'s metric_basis without newdata: a + # forest's are out-of-bag, every other backend's in-sample. data.frame(model = nms[i], resid_morans_I = mi$observed, resid_morans_z = mi$z, resid_morans_p = mi$p_value, resid_morans_null = mi$null, + resid_morans_basis = + if (isTRUE(fits[[i]]$info$fitted_are_oob)) "out-of-bag" + else "in-sample", stringsAsFactors = FALSE) } }) @@ -1309,12 +1328,27 @@ evaluate_insample <- function(fits, newdata = NULL, ...) { #' \code{TRUE} or \code{FALSE} for a Bayesian fit whose convergence was #' checked (see \code{\link{fit_bayesian_spatial_model}}) and \code{NA} #' otherwise; a fit that did not converge is ranked like the others, so it -#' also raises a warning. Alongside the metrics it +#' also raises a warning. \code{gp_adequacy} is what the posterior of a +#' Bayesian fit said about its Gaussian-process basis (\code{"ok"}, +#' \code{"below_resolution"}, \code{"unresolved_short_range"}, +#' \code{"no_signal_above_floor"} or \code{"not_checked"}; see "What the +#' basis resolves" in \code{\link{fit_bayesian_spatial_model}}) and +#' \code{NA} for the other backends. A basis found too coarse scores like +#' one that was adequate, so read the column beside the metrics. Alongside +#' the metrics it #' carries -#' \code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and -#' \code{resid_morans_null}, the last of which names the null +#' \code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p}, +#' \code{resid_morans_null} and \code{resid_morans_basis}. +#' \code{resid_morans_null} names the null #' \code{\link{residual_morans_i}} scored each model against, since that -#' choice is per-fit and governs how much the p-value is worth. A +#' choice is per-fit and governs how much the p-value is worth. +#' \code{resid_morans_basis} says which residuals the statistic was +#' computed on. They are always the residuals of the rows the model was +#' fitted to, also when \code{newdata} is given, so the column reads +#' \code{"in-sample"}, or \code{"out-of-bag"} for a forest, and never +#' \code{"newdata"}: beside \code{metric_basis = "newdata"} the Moran +#' columns describe the training residuals, not the prediction errors on +#' \code{newdata}, and the two can differ in sign. A #' significant p-value is noted in the log (not raised as an R warning): #' positive autocorrelation as structure the model may have missed, #' negative (\code{resid_morans_z < 0}) as the alternating residuals of a @@ -1369,6 +1403,11 @@ compare_models <- function(fits, newdata = NULL, ...) { # TRUE / FALSE as fit_bayesian_spatial_model() judged the sampler, NA for # other backends and for a Bayesian fit whose checks were not run. met_df$convergence_ok <- NA + # What the posterior said about the GP basis ($info$gp_adequacy$status), + # NA for other backends and for a fit saved before the status existed. A + # basis found too coarse scores like one that was adequate, so the table + # has to say which rows those are. + met_df$gp_adequacy <- NA_character_ for (i in seq_len(nrow(met_df))) { nm <- met_df$model[i] # By index, not fits[[nm]]: name lookup returns the FIRST match, so with two @@ -1395,9 +1434,13 @@ compare_models <- function(fits, newdata = NULL, ...) { met_df$LOOIC[i] <- obj$info$looic %||% NA_real_ ok <- obj$info$convergence_ok met_df$convergence_ok[i] <- if (is.logical(ok) && length(ok) == 1L) ok else NA - # The fit logged its R-hat, ESS and divergences, but a log line is - # invisible under knitr, spatialkit_quiet() and tryCatch(), and the - # row is ranked like the others. + st <- obj$info$gp_adequacy$status + met_df$gp_adequacy[i] <- if (is.character(st) && length(st) == 1L) st + else NA_character_ + # The fit raised its own warning (class spatialkit_convergence) when + # it was made, naming the checks that failed: divergent transitions, + # R-hat, effective sample size, E-BFMI. That was another call, and + # the row is ranked here like the others, so it is said again. if (isFALSE(ok)) .warn_and_log(paste0("compare_models(): the sampler of Bayesian model ", "'%s' did not converge (see print() on the fit, ", @@ -1462,6 +1505,11 @@ compare_models <- function(fits, newdata = NULL, ...) { collapse = ", ")) # --- Post-fit residual spatial autocorrelation check --- + # Computed on each fit's own residuals, whatever `newdata` is. With + # newdata the row's metric_basis reads "newdata", and the Moran columns + # beside it used to carry no basis of their own: a GWR row showed newdata + # RMSE beside I = -0.097 from its training residuals, where the newdata + # errors had I = +0.111. resid_morans_basis says which they are. moran_df <- .residual_morans_table(fits) met_df <- merge(met_df, moran_df, by = "model", all.x = TRUE, sort = FALSE) @@ -1476,22 +1524,26 @@ compare_models <- function(fits, newdata = NULL, ...) { p_val <- met_df$resid_morans_p[i] I_val <- met_df$resid_morans_I[i] z_val <- met_df$resid_morans_z[i] + # Which residuals, said in the line: with `newdata` the reader would + # otherwise take them for the prediction errors on it. + basis <- met_df$resid_morans_basis[i] + basis <- if (is.character(basis) && !is.na(basis)) basis else "in-sample" if (is.finite(p_val) && p_val < 0.05) { if (is.finite(z_val) && z_val < 0) .log_warn( - paste0("compare_models(): residuals of '%s' show significant ", + paste0("compare_models(): the %s residuals of '%s' show significant ", "negative spatial autocorrelation (Moran's I = %.4f, ", "p = %.4g): neighbouring residuals alternate in sign, as ", "in-sample residuals of a model that tracks the data closely ", "(a GP, a small-bandwidth GWR) do. That points to ", "over-fitting, not to missed spatial structure."), - met_df$model[i], I_val, p_val) + basis, met_df$model[i], I_val, p_val) else .log_warn( - paste0("compare_models(): residuals of '%s' show significant ", + paste0("compare_models(): the %s residuals of '%s' show significant ", "spatial autocorrelation (Moran's I = %.4f, p = %.4g). ", "The model may not fully capture the spatial structure."), - met_df$model[i], I_val, p_val + basis, met_df$model[i], I_val, p_val ) } } @@ -1583,7 +1635,8 @@ compare_models <- function(fits, newdata = NULL, ...) { #' \emph{none} of the requested backends is installed, nothing is left to #' compare and the call errors with \code{"no viable models."}. Guard with #' \code{requireNamespace()} when the model set is not known in advance. -#' @param k Number of folds. Default 5. +#' @param k Number of folds to build when \code{folds} is \code{NULL}; not +#' read when \code{folds} is supplied. Default 5. #' @param seed RNG seed. Default 123. #' @param folds Optional fold definitions: a \code{\link{make_folds}()} return #' value, or a bare list of \code{list(train =, test =)} pairs of @@ -1615,7 +1668,10 @@ compare_models <- function(fits, newdata = NULL, ...) { #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. #' @param block_size Optional minimum block edge length for the shared spatial #' CV blocks (projected CRS units), passed to \code{\link{make_folds}()} -#' when \code{folds} is \code{NULL}. Default \code{NULL}. +#' when \code{folds} is \code{NULL}. Default \code{NULL}. Beside +#' supplied \code{folds} it has nothing to size and raises a warning +#' (class \code{spatialkit_fold_args_ignored}); so does +#' \code{auto_range = TRUE}. #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, #' the autocorrelation range of the response (detrended on #' \code{predictor_vars}) is estimated and used as the minimum block size of @@ -1667,6 +1723,11 @@ compare_models <- function(fits, newdata = NULL, ...) { #' stay in its \code{*_cv} element and in \code{attr(overall, "all_rows")}, #' a table of the same shape. \code{by_fold} and the Bayesian coverage and #' CRPS columns are per fold and are not recomputed. +#' Every model is cross-validated on the layer as passed, so the warnings +#' \code{\link{prep_model_data}()} raises about that layer (class +#' \code{spatialkit_rows_dropped}, counting the incomplete rows dropped, +#' and \code{spatialkit_constant_predictor}) are raised once for the +#' comparison, not once per model. #' Only the models that actually ran appear, so check which names are #' present; there is not always one entry per requested model, because a #' backend whose package is missing is dropped with a message. When \strong{no} requested backend @@ -1692,11 +1753,10 @@ compare_models <- function(fits, newdata = NULL, ...) { #' ) #' dat$price <- 10 + 0.01 * (st_coordinates(dat)[, 1] - 5e5) + #' 2 * dat$elev + rnorm(n) -#' # The random forest, and GWR beside it when GWmodel is installed, on the +#' # The random forest, and GWR beside it when sp is installed, on the #' # same folds. "Bayesian" is left out here because a Stan fit per fold #' # takes minutes; add it to `models` for a run to report. -#' models <- c("RF", if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) "GWR") +#' models <- c("RF", if (requireNamespace("sp", quietly = TRUE)) "GWR") #' cmp <- compare_models_cv(dat, "price", "elev", models = models, k = 3, #' rf_args = list(num_trees = 100), #' gwr_args = list(bandwidth = 30)) @@ -1748,6 +1808,12 @@ compare_models_cv <- function( cleanup <- .with_seed(seed) on.exit(cleanup(), add = TRUE) + # Every backend's cv_*() prepares the layer for itself and finds the same + # incomplete rows and the same constant predictors, so the warnings that + # report them are raised by the first model and not repeated by the others. + end_run <- .once_per_run(.prep_warning_classes) + on.exit(end_run(), add = TRUE) + # Build the folds ONCE. Leaving folds = NULL let each backend call # make_folds() for itself, and any difference in the arguments that reach it # -- or simply seed = NULL -- produced a different split per model: measured, @@ -1774,6 +1840,7 @@ compare_models_cv <- function( # them at (119 of 150 L-shaped parcels changed fold against a standalone # cv_gwr(pointize = "centroid")). The provenance probe stays on the geometry # as supplied, which is what each cv_*() checks it against. + .warn_fold_args_ignored(folds, block_size, auto_range, "compare_models_cv") if (is.null(folds)) { pointized <- !all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT") fold_src <- if (pointized) coerce_to_points(data_sf, pointize) else data_sf diff --git a/R/feature-selection.R b/R/feature-selection.R index 65538cb7..87e6a496 100644 --- a/R/feature-selection.R +++ b/R/feature-selection.R @@ -5,8 +5,11 @@ #' Greedy forward feature selection with spatially blocked inner folds #' #' Selects predictors by repeatedly adding whichever candidate most improves a -#' cross-validated score, stopping when no candidate improves it by more than -#' \code{tol}. +#' cross-validated score, stopping when the best candidate's improvement is +#' no larger than the fold-to-fold noise in it (\code{rule = "se"}, the +#' default) or no larger than \code{tol} (\code{rule = "tol"}). The first +#' variable has a baseline to beat with every learner, so the selection can +#' be empty. #' #' \strong{The inner folds must be spatial, and that is the entire point.} #' Nested selection is only worth doing if the inner loop is blocked the same @@ -27,6 +30,156 @@ #' that inside \code{n} outer leave-one-out folds multiplies it by \code{n}. #' \code{max_fits} guards against that. #' +#' @section When a variable is accepted: +#' Each candidate set is scored by cross-validation on the same inner folds, +#' and the candidate with the best pooled score is the one considered. Under +#' \code{rule = "se"} it is accepted when two things hold: the pooled score +#' improves by more than \code{tol}, and the mean of the per-fold +#' improvements (the metric computed in each fold for the set with and +#' without the candidate, and differenced) exceeds \code{se_mult} times the +#' standard error of that mean across the folds. This is the +#' one-standard-error idea of Breiman et al. (1984) applied to a step: a gain +#' the folds do not agree on is not evidence that the variable predicts. The +#' fold is the unit because under spatially blocked folds the errors within a +#' block are correlated, so a standard error over rows would understate the +#' noise. With \code{tol = 0} and any gain accepted (the previous default, +#' still available as \code{rule = "tol"}), a GWR sweep over one real +#' predictor and six noise candidates added a noise variable in 11 runs of +#' 20; the default rule added one in 4 of 20 and kept the real predictor in +#' all 20. The rule costs power on weak predictors: a second real predictor +#' with a coefficient of 0.3 against 1 was kept in 14 runs of 20, against 18 +#' of 20 when any gain was accepted. With few folds the standard error is +#' itself noisy, so raise \code{k} before lowering \code{se_mult}. +#' \code{history} records each candidate's pooled gain, mean per-fold gain +#' and its standard error, and \code{fold_scores} the per-fold scores +#' themselves, so every decision can be checked. +#' +#' @section The baseline for the first variable: +#' The first variable is compared with a model that has no predictors, which +#' is recorded as step 0 of \code{history}. Which model that is depends on +#' the learner, and \code{baseline$type} says which was used: +#' \describe{ +#' \item{\code{"null model"}}{\code{fit_fn(train_sf, character(0))}, when +#' the learner can fit it. Step 1 is tested against it like any other +#' step.} +#' \item{\code{"null_fn"}}{the model \code{null_fn(train_sf)} returns, for +#' a learner that cannot fit an empty set but has a natural +#' no-predictor model. Step 1 is tested against it.} +#' \item{\code{"fold mean"}}{the mean response of each fold's training +#' rows, when neither is available; \code{\link{fit_rf_model}} refuses +#' an empty predictor set. Here +#' the first variable is \emph{provisional}: it is added without a test, +#' the sweep continues by the rule, and the finished set is kept only if +#' it beats the fold mean by the same rule; otherwise nothing is +#' selected, and \code{baseline$path} holds the set that was reached. +#' The test is at the end of the path, not at step 1, because a forest +#' on a single variable can lose to the mean when two variables together +#' beat it clearly (at a true \eqn{R^2} of 0.33 the best single-variable +#' forest had RMSE 1.276 against 1.206 for the mean and 1.101 for the +#' pair), so a test at step 1 would select nothing there. The first +#' variable of a kept path then gets a test of its own; see \emph{The +#' first variable under a fold-mean baseline}.} +#' } +#' Without a baseline, as before, at least one variable was always selected: +#' with a forest, in 10 draws of 10 on a response unrelated to every +#' candidate. +#' +#' @section The first variable under a fold-mean baseline: +#' The test at the end of the path is of the whole set, so it does not show +#' that the first variable belongs in it: two real predictors and an +#' unrelated candidate that happened to score best alone beat the mean as +#' the two real ones do. A kept path of two or more variables is therefore +#' scored once more without its first variable (one more set, \code{k} more +#' fits). That variable is dropped from \code{selected} when the set is no +#' better with it by the rule and the rest of the path still beats the fold +#' mean by the rule. \code{baseline$first} records the test and +#' \code{baseline$path} keeps the set as the sweep reached it, so +#' \code{selected} is \code{baseline$path[-1]} after a drop. A path of one +#' variable needs no second test: the test against the fold mean was the +#' test of that variable. +#' +#' This test is the one every later variable passed, an improvement of the +#' set by the rule, and it has the same limit. In 20 forest sweeps at a true +#' \eqn{R^2} of 0.33, with two real predictors and three unrelated +#' candidates, the path began with an unrelated candidate in 3: it was +#' dropped in 2 and kept in 1, where the forest scored better with it than +#' without (\emph{Selection with a random forest} says why it can). At a +#' true \eqn{R^2} of 0.15, 9 selections of 20 were kept, 3 of them began +#' with an unrelated candidate, and all 3 kept it for that reason. So in a +#' selection of two or more variables from a learner that falls back to the +#' fold mean, \code{selected[1]} has been shown to improve the set, not to +#' predict on its own. The test also costs power on a weak first predictor, +#' as the rule does at every step: with one real predictor of coefficient +#' 0.3 and five unrelated candidates, a linear learner that refuses the +#' empty set kept the real predictor in 77 sweeps of 100, against 80 before +#' this test existed and 77 for the same learner fitting its own null model +#' (in the 3 sweeps that differ it was the first variable, its gain was +#' within one standard error, and the learner with a null model selected +#' nothing). When the set is no better with the first variable but +#' the rest of the path does not beat the fold mean by the rule either, the +#' two cannot be told apart: the set is kept whole, a caution is logged, and +#' \code{baseline$first$note} says the variable is unproven. A learner that +#' fits its own null model gets no such test: its first variable passed one +#' at step 1. +#' +#' @section The baseline for a GWR: +#' For a GWR the fold mean is a weak baseline, because every GWR carries a +#' local intercept and beats a global mean on any smooth response whatever +#' its predictors are: on a smooth response unrelated to six candidates, a +#' GWR sweep against the fold mean selected one of them in 20 runs of 20. +#' Each of those paths had one variable, which the test of the first +#' variable above does not reach. The comparison that matters there is with +#' the kernel-weighted local mean at the same bandwidth, a GWR with a local +#' intercept and no predictors: against it the same sweeps selected a +#' variable in 4 runs of 20. \code{\link{fit_gwr_model}} fits that model +#' when its \code{predictor_vars} is \code{character(0)}, so a +#' \code{fit_fn} that hands its variables to \code{fit_gwr_model()} gets it +#' as the null model, and the first variable is tested against it at step 1 +#' (\code{baseline$type} is \code{"null model"}). Give such a \code{fit_fn} +#' a fixed \code{bandwidth}, so that every set is fitted under the kernel +#' the baseline has; with \code{bandwidth = NULL} each set, the empty one +#' included, searches for its own. A \code{fit_fn} that refuses an empty +#' set falls back to the fold mean, and the sweep logs a caution: read a GWR +#' selection of one variable made that way as unproven, or supply the local +#' mean as \code{null_fn}, as the second half of the example at the end of +#' this page does for a learner written by hand. +#' +#' \code{predict()} on a GWR warns about held-out locations it cannot +#' estimate and about those beyond the reach of a fold's fit (classes +#' \code{"spatialkit_gwr_not_estimable"} and +#' \code{"spatialkit_gwr_extrapolation"}; see +#' \code{\link{predict.gwr_fit}}). The sweep raises each once, under this +#' function's name, with the totals over the candidate sets it scored; every +#' set is predicted on the same rows, so a location can be counted once per +#' set. +#' +#' @section Selection with a random forest: +#' A forest confounds selection with tuning. Adding a predictor that carries +#' no signal still changes how the trees split, and with ranger's default +#' node size that regularises the forest: in one test the cross-validated +#' RMSE was 1.458 with the real predictor alone, 1.340 with a noise variable +#' added, and 1.341 with the real predictor alone and +#' \code{min_node_size = 20}. The noise variable bought what tuning the node +#' size buys. That gain is real, so no acceptance rule refuses it: with one +#' real predictor and six noise candidates a forest sweep kept the real one +#' in 20 runs of 20 and added 1.35 noise variables per run under the default +#' rule (2.4 per run, over 10 runs, when any gain was accepted). Setting the +#' node size in +#' \code{fit_fn} reduces this without removing it (0.8 per run at +#' \code{min_node_size = 20}). So a variable in a forest selection may be +#' there as a tuning effect wherever in the order it was added: later +#' additions with small gains are the usual case, and the first variable is +#' another, because a forest sweep starts from the fold mean and its first +#' variable is tested as an addition to the others (see \emph{The first +#' variable under a fold-mean baseline}). Compare the selected set with a +#' tuned forest on the variables you have other reasons to believe in: +#' \preformatted{ +#' fit_fn <- function(train_sf, vars) +#' fit_rf_model(train_sf, "z", vars, min_node_size = 20) +#' } +#' On a response unrelated to every candidate the same sweeps selected +#' nothing in 20 runs of 20 (19 of 20 with the larger node size). +#' #' @section The score is not a performance estimate: #' \code{$score} is the cross-validated \code{metric} of the winning set at #' the final step: the best of every candidate set the sweep scored. That @@ -54,13 +207,14 @@ #' size so inner and outer blocks are on the same spatial scale. #' @param metric Score to optimise: \code{"RMSE"}, \code{"MAE"} (minimised) or #' \code{"R2"} (maximised). Default \code{"RMSE"}. -#' @param tol Minimum improvement required to accept a variable. Default 0, -#' meaning any improvement is accepted. The first variable is judged against -#' the null (intercept-only) model, so \code{tol} bites from step 1, but -#' only when that null model can be scored. Backends that refuse a -#' zero-length \code{predictor_vars} (\code{\link{fit_rf_model}} and -#' \code{\link{fit_gwr_model}} both do) have no null score, and there the -#' first variable is accepted unconditionally. +#' @param tol Minimum improvement of the pooled score required to accept a +#' variable, in the units of \code{metric}. Default 0. It is a floor +#' under both rules: with \code{rule = "tol"} it is the whole test, and +#' with \code{rule = "se"} the per-fold test applies as well. The first +#' variable is judged against a baseline with every learner; see \emph{The +#' baseline for the first variable}. Any single number is accepted: +#' \code{Inf} leaves nothing selected, and \code{-Inf} puts no floor under +#' a step. #' @param max_vars Optional cap on how many predictors to select. #' @param max_fits Abort if the sweep would exceed this many model fits. #' Default 5000. @@ -93,23 +247,61 @@ #' Both halves come back in \code{$split}. See the "Post-selection #' inference" section of \code{\link{determine_optimal_levels}} for the #' trade: coverage for half the sample. +#' @param rule How a step is judged. \code{"se"} (default) accepts the best +#' candidate when its pooled gain exceeds \code{tol} and its mean per-fold +#' gain exceeds \code{se_mult} standard errors of that mean; +#' \code{"tol"} accepts any pooled gain above \code{tol}, the behaviour +#' before this argument existed. See \emph{When a variable is accepted}. +#' @param se_mult Number of standard errors the mean per-fold gain must +#' exceed under \code{rule = "se"}. Default 1; 0 asks only that the mean +#' per-fold gain be positive. +#' @param null_fn Optional function \code{(train_sf)} returning a fitted +#' model with no predictors, used as the baseline for the first variable +#' when \code{fit_fn} cannot fit an empty predictor set. Default +#' \code{NULL}: \code{fit_fn(train_sf, character(0))} is tried, and the +#' training-fold mean is used when that fails. The example builds one. #' @return A list of class \code{"feature_selection"} (so that #' \code{\link{plot.feature_selection}()} draws the selection path) with -#' \code{selected} (the chosen predictors, in the order they were added), -#' \code{score}, \code{score_holdout}, \code{history}, \code{params} and -#' \code{split}. +#' \code{selected} (the chosen predictors, in the order they were added; +#' possibly none), \code{score}, \code{score_holdout}, \code{history}, +#' \code{params}, \code{split}, \code{baseline} and \code{fold_scores}. #' \code{score} is the winning set's cross-validated \code{metric} at the #' final step: the \strong{selection-internal} optimum, optimistically #' biased because it was chosen as the best of many (see the section above), #' and \code{NA} when nothing was selected. \code{history} is a data.frame -#' with \code{step}, \code{variable}, \code{score} and \code{n_pred}, -#' holding every candidate evaluated at every step; when the null model -#' could be scored it also carries a \code{step = 0} row named -#' \code{""} giving that baseline, so the first variable's gain can be -#' read off directly. Every set is scored on the same rows: those the null -#' model's cross-validation predicted or, when there is no null model, -#' those any step-1 set predicted; \code{params$n_scored} counts them (a -#' warning says so when that is fewer than all). \code{n_pred} is how many +#' with \code{step}, \code{variable}, \code{score}, \code{n_pred}, +#' \code{gain}, \code{fold_gain} and \code{fold_gain_se}, +#' holding every candidate evaluated at every step, and a \code{step = 0} +#' row named \code{""} giving the baseline, so the first variable's +#' gain can be read off directly. \code{gain} is the candidate set's +#' improvement in the pooled score over the set it was added to (the +#' baseline at step 1), \code{fold_gain} the mean of the per-fold +#' improvements and \code{fold_gain_se} its standard error: the three +#' numbers the rule reads. \code{fold_scores} is a data.frame with +#' \code{step}, \code{variable}, \code{fold} and \code{score}: the metric +#' of every set in every fold. \code{baseline} is a list with +#' \code{type} (\code{"null model"}, \code{"null_fn"} or +#' \code{"fold mean"}), \code{score}, \code{path} (the set the sweep +#' reached), \code{gain}, \code{fold_gain} and \code{fold_gain_se} (that +#' set against the baseline), \code{kept} (\code{FALSE} when the path +#' did not beat a fold-mean baseline and \code{selected} is empty for that +#' reason; \code{NA} when the path is empty) and \code{first}. +#' \code{first} is \code{NULL} unless the baseline is the fold mean and a +#' path of two or more variables was kept; it is then the test of the +#' first variable, a list with \code{variable}; \code{gain}, +#' \code{fold_gain} and \code{fold_gain_se} (the path against the path +#' without that variable); \code{rest}, a list with \code{vars}, +#' \code{score}, \code{gain}, \code{fold_gain} and \code{fold_gain_se} +#' (the path without it, and that set against the baseline); +#' \code{dropped} (\code{TRUE} when the variable was taken out: +#' \code{selected} is then \code{path[-1]} and \code{score} is +#' \code{rest$score}); and \code{note}, the verdict in words. The set +#' scored for that test is not a step of the sweep, so it is not in +#' \code{history} or \code{fold_scores}. Every set is scored on the +#' same rows: those the null model's cross-validation predicted or, when +#' the baseline is the fold mean, those any step-1 set predicted; +#' \code{params$n_scored} counts them (a warning says so when that is +#' fewer than all). \code{n_pred} is how many #' rows the set's cross-validation predicted. A set that left some of the #' scored rows unpredicted, because a fold failed for it, has \code{score} #' \code{NA}, with a warning naming it: scored on the rows it did predict @@ -126,16 +318,19 @@ #' are in neither. #' \code{params} records \code{metric}, \code{method}, \code{k}, #' \code{tol}, \code{seed}, \code{auto_range}, \code{select_on}, -#' \code{n_candidates}, \code{estimated_fits} and \code{n_scored}. +#' \code{n_candidates}, \code{estimated_fits}, \code{n_scored}, +#' \code{rule}, \code{se_mult} and \code{baseline} (its type). #' @references +#' Breiman, L., Friedman, J. H., Olshen, R. A. and Stone, C. J. (1984). +#' \emph{Classification and Regression Trees}. Wadsworth. +#' #' Cawley, G. C. and Talbot, N. L. C. (2010). On over-fitting in model #' selection and subsequent selection bias in performance evaluation. #' \emph{Journal of Machine Learning Research}, 11, 2079--2107. #' \url{https://jmlr.org/papers/v11/cawley10a.html} #' @family cross-validation #' @examples -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' if (requireNamespace("sp", quietly = TRUE)) { #' library(sf) #' set.seed(1) #' n <- 120 @@ -146,10 +341,49 @@ #' ) #' pts$resp <- 3 * pts$a + 2 * pts$b + rnorm(n, 0, 0.3) #' +#' # The learner: a GWR with an adaptive bisquare kernel reaching the 30th +#' # nearest training point. With no variables it is the kernel-weighted +#' # local mean, which is the baseline: a GWR's local intercept beats a +#' # global mean on any smooth response, so the first variable has to beat +#' # the local mean under the same kernel. #' fit_fn <- function(tr, vars) fit_gwr_model(tr, "resp", vars, bandwidth = 30) #' sel <- select_features_forward(pts, "resp", c("a", "b", "noise"), fit_fn, #' k = 3, quiet = TRUE) #' sel$selected +#' sel$baseline$type # "null model": step 1 was tested against it +#' sel$history[sel$history$step <= 1, c("step", "variable", "score", "gain")] +#' +#' # A learner that cannot fit an empty set takes its no-predictor model +#' # through `null_fn`. Here the same local mean, written as a spatial_fit +#' # of its own with a predict() method, for a learner that insists on a +#' # variable. Without `null_fn` that sweep would start from the mean of +#' # each training fold. +#' needs_one <- function(tr, vars) { +#' if (!length(vars)) stop("this learner needs a predictor") +#' fit_gwr_model(tr, "resp", vars, bandwidth = 30) +#' } +#' local_mean <- function(tr, bandwidth = 30) { +#' new_spatial_fit("local_mean_fit", +#' engine = list(xy = st_coordinates(tr), y = tr$resp, +#' bandwidth = bandwidth), +#' formula = resp ~ 1, response_var = "resp", +#' predictor_vars = character(0), data_sf = tr) +#' } +#' predict.local_mean_fit <- function(object, newdata = NULL, ...) { +#' e <- object$engine +#' at <- if (is.null(newdata)) e$xy else st_coordinates(newdata) +#' vapply(seq_len(nrow(at)), function(i) { +#' d <- sqrt((e$xy[, 1] - at[i, 1])^2 + (e$xy[, 2] - at[i, 2])^2) +#' h <- sort(d)[min(e$bandwidth, length(d))] # the kernel's reach here +#' w <- ifelse(d > h, 0, (1 - d^2 / h^2)^2) # bisquare weights +#' sum(w * e$y) / sum(w) +#' }, numeric(1)) +#' } +#' registerS3method("predict", "local_mean_fit", predict.local_mean_fit) +#' sel2 <- select_features_forward(pts, "resp", c("a", "b", "noise"), needs_one, +#' k = 3, quiet = TRUE, null_fn = local_mean) +#' sel2$baseline$type # "null_fn" +#' all.equal(sel2$baseline$score, sel$baseline$score) # the same baseline #' } #' @export select_features_forward <- function(train_sf, response_var, candidate_vars, @@ -160,10 +394,65 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, tol = 0, max_vars = NULL, max_fits = 5000L, seed = 123, quiet = FALSE, auto_range = FALSE, - select_on = c("all", "split")) { + select_on = c("all", "split"), + rule = c("se", "tol"), se_mult = 1, + null_fn = NULL) { + # Every candidate set is a cv_spatial() of the same rows, and each prepares + # them for itself. A candidate that takes one value in every row is + # reported by each set that holds it, in the same words (class + # spatialkit_constant_predictor): raised by the first, not repeated. + end_run <- .once_per_run(.prep_warning_classes) + on.exit(end_run(), add = TRUE) + # A GWR learner counts, in every cross-validation of the sweep, the + # held-out locations it cannot estimate and those beyond the reach of a + # fold's fit, and cv_spatial() raises each count once per candidate set. + # Collected over the sweep, each is raised once, with the totals. Every + # set is predicted on the same rows, so a location can be counted once per + # set. No other learner signals either class. + .gwr_tally_predict_warnings( + .select_features_forward( + train_sf, response_var, candidate_vars, fit_fn, k = k, method = method, + block_size = block_size, metric = metric, tol = tol, + max_vars = max_vars, max_fits = max_fits, seed = seed, quiet = quiet, + auto_range = auto_range, select_on = select_on, rule = rule, + se_mult = se_mult, null_fn = null_fn), + caller = "select_features_forward", refits = TRUE) +} + +# The sweep itself; select_features_forward() is this with the counted +# warnings of a GWR learner collected over it. +.select_features_forward <- function(train_sf, response_var, candidate_vars, + fit_fn, k = 5, + method = c("block_kfold", "random_kfold"), + block_size = NULL, + metric = c("RMSE", "MAE", "R2"), + tol = 0, max_vars = NULL, + max_fits = 5000L, seed = 123, + quiet = FALSE, auto_range = FALSE, + select_on = c("all", "split"), + rule = c("se", "tol"), se_mult = 1, + null_fn = NULL) { method <- match.arg(method) metric <- match.arg(metric) select_on <- match.arg(select_on) + rule <- match.arg(rule) + .check_scalar(se_mult, "se_mult", "select_features_forward", min = 0, + what = "a single non-negative number") + # Any one number that is not missing. `tol = Inf` asks for nothing to be + # selected and `-Inf` puts no floor under a step; both were accepted before + # `tol` was checked at all, so .check_scalar(), which wants a finite value, + # is not the test. + if (!is.numeric(tol) || length(tol) != 1L || is.na(tol)) + stop(sprintf(paste0("select_features_forward(): `tol` must be a single ", + "number (Inf and -Inf are allowed); got %s."), + if (length(tol) != 1L) + sprintf("%s of length %d", class(tol)[1L], length(tol)) + else if (is.numeric(tol)) format(tol) + else class(tol)[1L]), call. = FALSE) + if (!is.null(null_fn) && !is.function(null_fn)) + stop("select_features_forward(): `null_fn` must be NULL or a function of ", + "(train_sf) returning a fitted model with no predictors.", + call. = FALSE) .msg <- function(...) if (!quiet) message(...) if (!inherits(train_sf, "sf")) @@ -283,7 +572,7 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, " Adjust `method`, `k` or `block_size`.", call. = FALSE) # Every set is scored on ONE fixed row set, `ref_ids`: the rows the null - # model predicted, or, when there is no null model (RF and GWR refuse an + # model predicted, or, when there is no null model (a forest refuses an # empty predictor set), the rows any step-1 candidate predicted. # cv_spatial()'s `overall` pools whichever folds survived, so a set whose # fit or predict failed on a fold -- a factor level found in one block @@ -294,13 +583,20 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, # Rows the reference runs did not predict (a fold that fails for every set, # from geometry rather than predictors) drop out of every score alike. ref_ids <- NULL - run_set <- function(vars) { - inner_fit <- function(tr) fit_fn(tr, vars) + # The classes of the models the learner returns, noted as they are fitted: + # the fold-mean baseline means something different for a GWR (see below). + fit_classes <- character(0) + run_set <- function(vars, inner_fit = function(tr) fit_fn(tr, vars)) { + noting_fit <- function(tr) { + f <- inner_fit(tr) + fit_classes <<- union(fit_classes, class(f)) + f + } # cv_spatial()'s own partial-failure warning is muffled: the consequence # for the sweep is reported below, once per step, in the sweep's terms. res <- try(withCallingHandlers( suppressMessages( - cv_spatial(train_sf, response_var, vars, fit_fn = inner_fit, + cv_spatial(train_sf, response_var, vars, fit_fn = noting_fit, folds = folds, seed = seed)), warning = function(w) if (.is_failed_folds_warning(w)) invokeRestart("muffleWarning")), @@ -317,6 +613,50 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, val <- .cv_overall_metrics(pr[pr$`..row_id` %in% ref_ids, , drop = FALSE])[[metric]] if (is.null(val) || !is.finite(val)) NA_real_ else as.numeric(val) } + # The same metric fold by fold, on the reference rows: what the "se" rule + # reads. Named by fold; NULL for a set that does not cover the rows. + fold_scores_of <- function(pr) { + if (!length(ref_ids) || !covers_ref(pr) || is.null(pr$fold)) return(NULL) + sub <- pr[pr$`..row_id` %in% ref_ids, , drop = FALSE] + vapply(split(seq_len(nrow(sub)), sub$fold), function(ix) { + v <- .cv_overall_metrics(sub[ix, , drop = FALSE])[[metric]] + if (is.null(v) || !is.finite(v)) NA_real_ else as.numeric(v) + }, numeric(1)) + } + # Paired per-fold improvement of set `a` over set `b`: its mean and the + # standard error of that mean across the folds both sets scored. + paired_gain <- function(pr_a, pr_b) { + fa <- fold_scores_of(pr_a); fb <- fold_scores_of(pr_b) + out <- list(mean = NA_real_, se = NA_real_, n = 0L) + if (is.null(fa) || is.null(fb)) return(out) + cm <- intersect(names(fa), names(fb)) + d <- if (metric == "R2") fa[cm] - fb[cm] else fb[cm] - fa[cm] + d <- d[is.finite(d)] + out$n <- length(d) + if (length(d) >= 1L) out$mean <- mean(d) + if (length(d) >= 2L) out$se <- stats::sd(d) / sqrt(length(d)) + out + } + # Does a gain count? Always more than `tol` on the pooled score; under + # rule = "se" also a mean per-fold gain above se_mult standard errors. + # With fewer than two folds scored there is no standard error, and the + # step is judged on `tol` alone, said once. + se_missing_said <- FALSE + accepts <- function(gain, pg) { + if (!(is.finite(gain) && gain > tol)) return(FALSE) + if (identical(rule, "tol")) return(TRUE) + if (!is.finite(pg$se) || !is.finite(pg$mean)) { + if (!se_missing_said) { + se_missing_said <<- TRUE + .warn_and_log(paste0( + "select_features_forward(): rule = \"se\" needs the %s of at least ", + "two folds to compare two sets, and %d could be scored for both; ", + "such steps are judged on `tol` alone."), metric, pg$n) + } + return(TRUE) + } + pg$mean > se_mult * pg$se + } set_ref <- function(ids, from) { ref_ids <<- ids if (length(ids) && length(ids) < nrow(train_sf)) @@ -330,42 +670,84 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, selected <- character(0) remaining <- candidate_vars history <- list() + fold_hist <- list() + keep_folds <- function(step, variable, pr) { + fs <- fold_scores_of(pr) + if (is.null(fs)) return(invisible(NULL)) + fold_hist[[length(fold_hist) + 1L]] <<- data.frame( + step = step, variable = variable, fold = names(fs), score = unname(fs), + stringsAsFactors = FALSE) + } - # Score the EMPTY set first, so step 1 has something to beat. `best` used to - # start at Inf/-Inf with the stopping test gated on is.finite(best), which - # made the first step unconditional: whatever the winning candidate's score, - # it was accepted. On a pure-noise response a "predictive" feature was - # therefore selected in 100% of runs, and in 23% of them the returned set was - # WORSE in CV RMSE than fitting nothing at all -- while the documentation - # says the sweep stops "when no candidate improves it by more than `tol`". - # An intercept-only fit is not something every backend can do, so fall back - # to the old unconditional first step when it fails, and say so. - # A backend that cannot fit an intercept-only model -- fit_rf_model() and - # fit_gwr_model() both refuse a zero-length predictor_vars -- makes - # cv_spatial() report "all folds failed", which is expected here and handled - # by the fallback below. suppressWarnings() silences the R condition, but - # the k "fold i fit failed" lines and the "all k folds failed" line are - # LOGGER records, which no condition handler touches: every successful - # RF/GWR run printed them, identical to a genuinely failed run's, even with - # quiet = TRUE. Raise the console threshold for the probe alone; the file - # trace (index 1) keeps the lines, where a diagnostic belongs. The rows - # the null model predicts, when it can be fitted, are the rows every set - # is scored on. - null_run <- logger::with_log_threshold( - suppressWarnings(run_set(character(0))), - threshold = logger::FATAL, namespace = "spatialkit", index = 2) - if (n_pred_of(null_run) > 0L) - set_ref(sort(unique(null_run$`..row_id`)), "the null (intercept-only) model") - null_score <- score_on(null_run) - best <- if (is.finite(null_score)) null_score else worst - if (!is.finite(null_score)) - .msg("select_features_forward(): the null (intercept-only) model could not ", - "be scored, so the first variable is accepted unconditionally.") - else - history[[length(history) + 1L]] <- data.frame( + # Step 0: something for the first variable to beat. `best` used to start + # at Inf/-Inf with the stopping test gated on is.finite(best), which made + # the first step unconditional whenever the empty set could not be scored + # -- and fit_rf_model() refuses a zero-length predictor_vars, as + # fit_gwr_model() did. With either as the learner a variable was therefore + # always selected: in 10 draws of 10 on a response unrelated to every + # candidate, 2.6 to 3.1 variables on average. There are three baselines, + # tried in this order: + # "null_fn" the caller's own no-predictor model; + # "null model" fit_fn(train_sf, character(0)), when the learner can; + # "fold mean" the training-fold mean, which needs no model at all. + # The first two gate step 1 like any other step. The fold mean does not: + # a one-variable forest loses to it even when two variables together beat + # it clearly (true R2 0.33: 1.276 against 1.206 for the best single + # variable, 1.101 for the pair), so gating step 1 on it turned "always + # selects something" into "never selects anything" at moderate signal. + # There the first variable is provisional, and the baseline is applied to + # the finished path instead: the set is kept only if it beats the fold + # mean by the same rule every step is held to, and its first variable + # only if the set is better with it (the block after the sweep). + # + # A backend that cannot fit an intercept-only model makes cv_spatial() + # report "all folds failed", which is expected here. suppressWarnings() + # silences the R condition, but the k "fold i fit failed" lines and the + # "all k folds failed" line are LOGGER records, which no condition handler + # touches: every successful RF/GWR run printed them, identical to a + # genuinely failed run's, even with quiet = TRUE. Raise the console + # threshold for the probe alone; the file trace (index 1) keeps the lines, + # where a diagnostic belongs. The rows the null model predicts, when it + # can be fitted, are the rows every set is scored on. + baseline_type <- NA_character_ + null_score <- NA_real_ + base_pr <- NULL + if (!is.null(null_fn)) { + null_run <- run_set(character(0), inner_fit = function(tr) null_fn(tr)) + if (n_pred_of(null_run) == 0L) + stop("select_features_forward(): `null_fn` gave no cross-validated ", + "prediction on any fold. It must be a function of (train_sf) that ", + "returns a fitted model with a predict() method, as `fit_fn` does.", + call. = FALSE) + baseline_type <- "null_fn" + } else { + null_run <- logger::with_log_threshold( + suppressWarnings(run_set(character(0))), + threshold = logger::FATAL, namespace = "spatialkit", index = 2) + if (n_pred_of(null_run) > 0L) baseline_type <- "null model" + } + if (!is.na(baseline_type)) { + set_ref(sort(unique(null_run$`..row_id`)), + if (identical(baseline_type, "null_fn")) "the `null_fn` model" + else "the null (intercept-only) model") + null_score <- score_on(null_run) + if (is.finite(null_score)) base_pr <- null_run + else baseline_type <- NA_character_ # fall through to the fold mean + } + best <- if (is.finite(null_score)) null_score else worst + best_pr <- base_pr + step0 <- function() { + history <<- c(list(data.frame( step = 0L, variable = "", score = unname(null_score), - n_pred = n_pred_of(null_run), stringsAsFactors = FALSE - ) + n_pred = n_pred_of(base_pr), gain = NA_real_, fold_gain = NA_real_, + fold_gain_se = NA_real_, stringsAsFactors = FALSE)), history) + fs <- fold_scores_of(base_pr) + if (!is.null(fs)) + fold_hist <<- c(list(data.frame( + step = 0L, variable = "", fold = names(fs), score = unname(fs), + stringsAsFactors = FALSE)), fold_hist) + } + if (!is.na(baseline_type)) step0() repeat { if (length(remaining) == 0L || length(selected) >= max_steps) break @@ -374,13 +756,64 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, if (is.null(ref_ids)) set_ref(sort(unique(unlist(lapply(runs, `[[`, "..row_id")))), "the step-1 candidate sets together") + + # No baseline from the learner: the training-fold mean, read off the + # runs just made. cv_spatial() records each held-out row's training-fold + # mean of the response beside its prediction, and every candidate set + # was scored on the same rows and folds, so this is that mean scored on + # the sweep's own folds with no further fit. + if (is.na(baseline_type)) { + bp <- .fs_fold_mean_predictions(runs) + sc <- score_on(bp) + if (is.finite(sc)) { + baseline_type <- "fold mean" + base_pr <- bp; null_score <- sc + best <- sc; best_pr <- bp + step0() + .msg(sprintf(paste0( + "select_features_forward(): `fit_fn` cannot fit a model with no ", + "predictors, so the baseline is the training-fold mean (%s = %.4f). ", + "The first variable is provisional: the finished set is kept only ", + "if it beats that baseline, and its first variable only if the set ", + "is better with it."), metric, sc)) + # Every GWR carries a local intercept, so it beats a global mean on + # any smooth response whatever its predictors are: against the fold + # mean a GWR sweep kept one of six unrelated candidates in 20 runs + # of 20, against 4 of 20 with the kernel-weighted local mean as the + # baseline. fit_gwr_model() fits that model for character(0), so a + # GWR sweep arrives here only when its `fit_fn` refuses the empty + # set itself. The caller is told what the baseline does and does + # not show, and the two ways to the right one. + if ("gwr_fit" %in% fit_classes) + .log_warn(paste0( + "select_features_forward(): the learner is a GWR and the ", + "baseline is the training-fold mean. A GWR beats a global mean ", + "on any smooth response through its local intercept alone, so ", + "passing this baseline does not show that the first variable ", + "predicts. The comparison that does is with the kernel-weighted ", + "local mean at the same bandwidth (an intercept-only GWR): let ", + "`fit_fn` pass character(0) on to fit_gwr_model(), which fits ", + "it, or pass a function fitting it as `null_fn`. The example in ", + "?select_features_forward builds one.")) + } + } + step_scores <- vapply(runs, score_on, numeric(1)) names(step_scores) <- remaining n_pred <- vapply(runs, n_pred_of, integer(1)) + step_gain <- if (metric == "R2") step_scores - best else best - step_scores + step_gain[!is.finite(step_gain)] <- NA_real_ + step_pg <- lapply(runs, paired_gain, pr_b = best_pr) history[[length(history) + 1L]] <- data.frame( step = length(selected) + 1L, variable = remaining, - score = unname(step_scores), n_pred = n_pred, stringsAsFactors = FALSE + score = unname(step_scores), n_pred = n_pred, + gain = unname(step_gain), + fold_gain = vapply(step_pg, `[[`, numeric(1), "mean"), + fold_gain_se = vapply(step_pg, `[[`, numeric(1), "se"), + stringsAsFactors = FALSE ) + for (j in seq_along(runs)) + keep_folds(length(selected) + 1L, remaining[j], runs[[j]]) # Sets that predicted some reference rows but not all. One predicting # none has already raised cv_spatial()'s "all folds failed" warning. short <- which(n_pred > 0L & !vapply(runs, covers_ref, logical(1))) @@ -413,6 +846,7 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, # sets do not produce the same cross-validated metric to the last digit, # so the signature is unambiguous. if (length(selected) == 0L && length(step_scores) >= 2L && + identical(baseline_type, "null model") && is.finite(null_score) && all(is.finite(step_scores)) && isTRUE(all.equal(unname(step_scores), rep(null_score, length(step_scores)), tolerance = 1e-12))) @@ -429,17 +863,133 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, cand_score <- step_scores[[idx]] gain <- if (metric == "R2") cand_score - best else best - cand_score - if (is.finite(best) && !(gain > tol)) { - .msg(sprintf("select_features_forward(): no candidate improves %s by more than %g; stopping.", - metric, tol)) + # The first variable is not tested against the fold mean; see above. + provisional <- identical(baseline_type, "fold mean") && length(selected) == 0L + if (is.finite(best) && !provisional && !accepts(gain, step_pg[[idx]])) { + .msg(if (identical(rule, "se") && is.finite(gain) && gain > tol) + sprintf(paste0( + "select_features_forward(): the best candidate, %s, improves %s by ", + "%.4g, but its mean gain per fold (%.4g) is within %g standard ", + "error(s) of zero (SE %.4g over %d folds); stopping."), + cand, metric, gain, step_pg[[idx]]$mean, se_mult, step_pg[[idx]]$se, + step_pg[[idx]]$n) + else + sprintf("select_features_forward(): no candidate improves %s by more than %g; stopping.", + metric, tol)) break } selected <- c(selected, cand) remaining <- setdiff(remaining, cand) best <- cand_score - .msg(sprintf("select_features_forward(): + %s (%s = %.4f)", - cand, metric, cand_score)) + best_pr <- runs[[idx]] + .msg(sprintf("select_features_forward(): + %s (%s = %.4f)%s", + cand, metric, cand_score, + if (provisional) " [provisional]" else "")) + } + + # The finished path against the baseline. For a learner that scored its + # own null model every step has already beaten the one before, so this + # only reports the total. For the fold-mean baseline it is the test the + # first step was spared: a path that does not beat the mean by the rule is + # not a selection. + path <- selected + path_gain <- NA_real_ + path_pg <- list(mean = NA_real_, se = NA_real_, n = 0L) + kept <- NA + if (length(path) > 0L && is.finite(null_score)) { + path_gain <- if (metric == "R2") best - null_score else null_score - best + path_pg <- paired_gain(best_pr, base_pr) + kept <- TRUE + if (identical(baseline_type, "fold mean") && !accepts(path_gain, path_pg)) { + kept <- FALSE + .msg(sprintf(paste0( + "select_features_forward(): the set reached, {%s}, does not beat the ", + "training-fold mean by the rule (%s %.4f against %.4f; mean gain per ", + "fold %.4g, SE %.4g), so nothing is selected."), + paste(path, collapse = ", "), metric, best, null_score, + path_pg$mean, path_pg$se)) + selected <- character(0) + } + } + + # The first variable of a path that started from the fold mean. It was + # added without a test, and the test above is of the whole set: two real + # predictors and a candidate that happened to score best alone beat the + # mean as clearly as the two real ones do. At a true R2 of 0.33 a forest + # sweep's kept selection began with an unrelated candidate in 3 runs of 20. + # So a kept path of two or more is scored once more without its first + # variable (one more set, k more fits), and that variable stays only if + # the set is better with it by the rule every other variable was held to. + # It is dropped only when the rest of the path still beats the fold mean + # by the rule on its own; otherwise the set is kept whole and the variable + # is reported as unproven. A path of one needs no such step: the test + # against the fold mean above was the test of that variable. + first <- NULL + if (identical(baseline_type, "fold mean") && isTRUE(kept) && + length(path) >= 2L) { + v1 <- path[1L] + rest <- path[-1L] + rest_pr <- run_set(rest) + rest_score <- score_on(rest_pr) + first <- list(variable = v1, gain = NA_real_, fold_gain = NA_real_, + fold_gain_se = NA_real_, + rest = list(vars = rest, score = rest_score, gain = NA_real_, + fold_gain = NA_real_, fold_gain_se = NA_real_), + dropped = FALSE, note = NA_character_) + brace <- function(v) paste0("{", paste(v, collapse = ", "), "}") + if (!is.finite(rest_score)) { + first$note <- "not tested: the set without it could not be scored" + .warn_and_log(paste0( + "select_features_forward(): %s was added first, without a test, and ", + "the set without it, %s, could not be scored on the %d scored rows ", + "(%d of them predicted), so it could not be tested at the end ", + "either. It stays in the selection, unproven."), + v1, brace(rest), length(ref_ids), + sum(ref_ids %in% rest_pr$`..row_id`)) + } else { + g1 <- if (metric == "R2") best - rest_score else rest_score - best + pg1 <- paired_gain(best_pr, rest_pr) + g0 <- if (metric == "R2") rest_score - null_score else null_score - rest_score + pg0 <- paired_gain(rest_pr, base_pr) + first$gain <- g1 + first$fold_gain <- pg1$mean; first$fold_gain_se <- pg1$se + first$rest$gain <- g0 + first$rest$fold_gain <- pg0$mean; first$rest$fold_gain_se <- pg0$se + if (accepts(g1, pg1)) { + first$note <- "kept: the set is better with it by the rule" + .msg(sprintf(paste0( + "select_features_forward(): %s, added first without a test, is ", + "kept: without it %s is %.4f against %.4f (mean gain per fold ", + "%.4g, SE %.4g)."), + v1, metric, rest_score, best, pg1$mean, pg1$se)) + } else if (accepts(g0, pg0)) { + first$dropped <- TRUE + first$note <- "dropped: the set is no better with it by the rule" + .msg(sprintf(paste0( + "select_features_forward(): %s was added first, without a test. ", + "Without it, %s scores %s %.4f against %.4f with it (mean gain per ", + "fold from %s %.4g, SE %.4g), so it is dropped."), + v1, brace(rest), metric, rest_score, best, v1, pg1$mean, pg1$se)) + selected <- rest + best <- rest_score + best_pr <- rest_pr + } else { + first$note <- paste0("kept, unproven: the set is no better with it by ", + "the rule, and without it the set does not beat ", + "the baseline by the rule") + .log_warn(paste0( + "select_features_forward(): %s was added first, without a test, ", + "and this selection does not show that it predicts. Without it, ", + "%s scores %s %.4f against %.4f with it: a mean gain per fold of ", + "%.4g with SE %.4g, which the rule does not count. It is kept ", + "because %s does not beat the training-fold mean (%.4f) by the ", + "rule on its own (mean gain per fold %.4g, SE %.4g). Read %s as ", + "unproven."), + v1, brace(rest), metric, rest_score, best, pg1$mean, pg1$se, + brace(rest), null_score, pg0$mean, pg0$se, v1) + } + } } # The honest score: the selected set fitted on the selection half and @@ -475,12 +1025,55 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, score_holdout = score_holdout, history = if (length(history)) do.call(rbind, history) else data.frame(step = integer(0), variable = character(0), score = numeric(0), - n_pred = integer(0)), + n_pred = integer(0), gain = numeric(0), fold_gain = numeric(0), + fold_gain_se = numeric(0)), params = list(metric = metric, method = method, k = k, tol = tol, seed = seed, auto_range = isTRUE(auto_range), select_on = select_on, n_candidates = p, estimated_fits = est_fits, - n_scored = length(ref_ids)), - split = split + n_scored = length(ref_ids), + rule = rule, se_mult = se_mult, + baseline = baseline_type), + split = split, + # What step 1 had to beat, and what the finished path made of it. + baseline = list(type = baseline_type, score = null_score, + path = path, gain = path_gain, + fold_gain = path_pg$mean, fold_gain_se = path_pg$se, + kept = kept, + # The end-of-path test of a first variable added without + # one; NULL when there was no such test to make. + first = first), + # The metric of every set in every fold, for auditing the rule. + fold_scores = if (length(fold_hist)) do.call(rbind, fold_hist) else + data.frame(step = integer(0), variable = character(0), + fold = character(0), score = numeric(0)) ), class = c("feature_selection", "list")) } + + +#' The training-fold mean as a set of cross-validated predictions +#' +#' Built from candidate runs that \code{cv_spatial()} already made: each of +#' their prediction rows carries \code{y_train_mean}, the mean response of +#' the rows its fold trained on. Used as \code{yhat} it is the prediction +#' of a model with no predictors, on the same rows and the same folds, at no +#' further fit. +#' +#' @param runs A list of prediction frames (or \code{NULL}s) from the sweep. +#' @return A prediction frame with one row per row any run predicted, or +#' \code{NULL} when no run predicted anything. +#' @keywords internal +#' @noRd +.fs_fold_mean_predictions <- function(runs) { + need <- c("..row_id", "fold", "y", "y_train_mean") + ok <- Filter(function(pr) is.data.frame(pr) && nrow(pr) > 0L && + all(need %in% names(pr)), runs) + if (!length(ok)) return(NULL) + bp <- do.call(rbind, lapply(ok, function(pr) pr[, need, drop = FALSE])) + bp <- bp[!duplicated(bp[["..row_id"]]), , drop = FALSE] + bp <- bp[is.finite(bp$y) & is.finite(bp$y_train_mean), , drop = FALSE] + if (!nrow(bp)) return(NULL) + bp$yhat <- bp$y_train_mean + rownames(bp) <- NULL + bp +} diff --git a/R/fold-separation.R b/R/fold-separation.R index eef07734..6adbe375 100644 --- a/R/fold-separation.R +++ b/R/fold-separation.R @@ -1,25 +1,80 @@ -#' How far the held-out points actually sit from the training data +#' How far the held-out points sit from the training data #' #' Blocked cross-validation exists to put distance between a test point and #' the training points that could tell you its value. Whether it succeeded is -#' a measurement, and until now the package only offered a proxy for it: the -#' block size compared against the estimated autocorrelation range, reported -#' by \code{\link{make_folds}()} as a warning. That comparison is about the -#' \emph{design}. This is about the \emph{result}: for every held-out point, -#' the distance to its nearest training point, summarised per fold. +#' a measurement, and \code{\link{make_folds}()} only offers a proxy for it: +#' the block size compared against the estimated autocorrelation range, +#' reported as a warning. That comparison is about the \emph{design}. This +#' is about the \emph{result}: for every held-out point, the distance to its +#' nearest training point, summarised per fold. #' -#' The two can disagree, and the direction is not obvious. Blocks wider than -#' the range still leak wherever a test point sits near a block edge with -#' training data just across it, which is most of the points in a fine block -#' grid; conversely a fold whose blocks are narrower than the range can still -#' separate well if the points inside them are clustered. The share of -#' held-out points closer to training data than the correlation range is the -#' number that settles it, and it is the last column here. +#' The distances do not say by themselves which way a score errs. A +#' cross-validated error reads low when the held-out points sit closer to +#' their training data than the locations the model will predict at, and high +#' when they sit farther, so the same held-out distances can go with either, +#' depending on the target. Random folds on evenly sited data, scored for a +#' map of the sampled area, are close to unbiased although nearly every +#' held-out point has a training neighbour inside the range; range-sized +#' blocks on the same data read high; random folds on clustered data scored +#' for a map of the whole region read low. So without a prediction target +#' the function reports the distances and draws no conclusion. Give it +#' \code{prediction_points} and it sets the held-out distances beside the +#' distances from those points to the same training data, and words its +#' reading by the signed gap between the two. #' #' Nothing is estimated: the distances come from the geometry, and the range, #' when one is shown, is the one the folds already carry (\code{make_folds( #' auto_range = TRUE)} records it) or the one you pass as \code{sac}. #' +#' @section Reading the gap: +#' With a target, the held-out distances and the prediction distances are +#' compared as two distributions. Each fold's prediction distances are +#' measured to that fold's own training rows, so that a five-fold design is +#' not read as too far only because each fold trains on four fifths of the +#' sites; the distances to all sites are reported beside them. (With more +#' than 50 folds, the leave-one-out schemes, every training set is nearly the +#' whole sample and the prediction points are measured against all sites +#' once.) Folds count by their share of the held-out points. +#' +#' Two numbers summarise the comparison: the signed difference of the means, +#' held-out minus prediction (the signed area between the two cumulative +#' distributions), and the Wasserstein distance \eqn{W_1} (the unsigned +#' area). When a range is available both are also given on the correlation +#' scale, after each distance \eqn{d} is replaced by \eqn{1 - \rho(d)}, with +#' \eqn{\rho} the correlation the range implies (see \code{mean_cor} +#' under Value). That scale counts a difference between two distances well +#' inside the range and ignores one between two distances beyond it. +#' +#' The reading is taken on the correlation scale when there is a range, with +#' a tolerance of 0.1, and otherwise on the mean distance, with a tolerance +#' of a quarter of the prediction mean. (When the prediction points are +#' measured to all sites and every one lies on a site, as when the sites +#' themselves are passed as \code{prediction_points} to a leave-one-out +#' design, the prediction mean and with it that tolerance +#' are 0: held-out distances above 0 then read \code{"farther"}, and +#' held-out distances that are all 0 as well read \code{"matched"}. With +#' 50 folds or fewer the points are measured to each fold's own training +#' rows, which leave out that fold's held-out sites, so the mean is above 0 +#' and the quarter rule gives the reading.) +#' \describe{ +#' \item{\code{"closer"}}{The gap is below minus the tolerance and at least +#' half of \eqn{W_1} in size: the held-out points sit closer to their +#' training data than the prediction points do, and the cross-validated +#' error tends to read low for that target.} +#' \item{\code{"farther"}}{The gap is above the tolerance and at least +#' half of \eqn{W_1}: the held-out points sit farther, and the error +#' tends to read high.} +#' \item{\code{"matched"}}{The gap is within the tolerance and +#' \eqn{W_1} within twice the tolerance.} +#' \item{\code{"mixed"}}{The two distributions cross, closer at some +#' distances and farther at others (the gap is under half of +#' \eqn{W_1}, or it is within the tolerance while \eqn{W_1} is not), so +#' the distances give no single direction.} +#' } +#' The reading is a statement about nearest-neighbour distances, not a +#' measured bias. A learner that draws on several neighbours can still score +#' low on clustered samples whose nearest-neighbour distances match. +#' #' @param folds A \code{\link{make_folds}()} result, or its \code{$folds} #' element (a list of \code{train}/\code{test} splits). #' @param data_sf The layer the folds were built on. Row identifiers are @@ -33,7 +88,8 @@ #' the other is not. #' @param sac Optional: an \code{\link{estimate_sac_range}()} result or a #' single number. Defaults to the range the folds carry, if any. Supplying -#' one adds the \code{within_range} column and the closing verdict. A +#' one adds the \code{mean_cor} column and, with a prediction target, +#' the gap on the correlation scale. A #' range that records its CRS (the folds' own, or an #' \code{estimate_sac_range()} result) is compared with distances measured #' in that CRS, whatever CRS \code{data_sf} is in. A bare number is taken @@ -42,6 +98,22 @@ #' metres, in the CRS \code{\link{ensure_projected}()} chooses (as for #' \code{make_folds()}'s \code{block_size}), not degrees. A \code{units} #' object is refused. +#' @param prediction_points Optional \code{sf} or \code{sfc} layer of the +#' locations the model will predict at: the grid from +#' \code{\link{predict_surface}()}, or a grid over the region of interest +#' (\code{sf::st_make_grid(region, what = "centers")}). A non-POINT layer +#' is reduced to one representative point per feature, as in +#' \code{make_folds(method = "nndm")}, so pass grid cells or points, not +#' one polygon of the region. It is brought into the CRS the distances are +#' measured in. Default \code{NULL}: no target and no reading, except for +#' NNDM and kNNDM folds (\code{method = "nndm"} and \code{"knndm"}), which +#' carry the distances from the prediction points they were built for and +#' are compared against those, measured to all sites. The carried +#' distances are lengths in the CRS the folds were built in +#' (\code{folds$params$crs}). When the distances here are measured in +#' another CRS (\code{data_sf} is in another projected CRS, or \code{sac} +#' records another), the two are not compared, \code{print()} says so, and +#' passing \code{prediction_points} has the target measured here. #' @return A data.frame of class \code{fold_separation}, one row per fold: #' \code{fold} (the fold's number: for the \code{$folds} of a #' \code{cv_*()} result, the \code{fold_id} its \code{fold_metrics} use, @@ -49,11 +121,50 @@ #' \code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} #' for a scheme with no blocks), \code{min_dist} and \code{median_dist} #' (distance from a held-out point to its nearest training point, in the -#' units of the CRS the \code{crs} attribute names), and -#' \code{within_range} (the share of held-out points closer to -#' training data than \code{sac}; \code{NA} without one). Attributes: -#' \code{method}, \code{sac_range}, \code{crs} (the CRS the distances were -#' measured in) and \code{n_unknown_ids}. +#' units of the CRS the \code{crs} attribute names), \code{mean_cor}, +#' \code{target_median_dist} (the median distance from the prediction +#' points to the fold's training data) and \code{dist_gap} (the fold's mean +#' held-out distance minus its mean prediction distance); the last two are +#' \code{NA} without a target, and \code{print()} shows them under the +#' headings \code{target} and \code{gap}. +#' +#' \code{mean_cor} is a mean correlation, \code{NA} without a +#' range: the mean over the fold's held-out points of \eqn{\rho(d)}, the +#' correlation the range leaves between a point and its nearest training +#' point at distance \eqn{d}. It is 1 for a point on top of training data +#' and falls towards 0 beyond the range, so a point at a twentieth of the +#' range counts for more than one at nine tenths of it. \eqn{\rho(d)} is +#' \eqn{\exp(-3 d / range)}, the exponential model whose effective range is +#' the range given (0.05 at the range), or the spherical model when the +#' range comes from an \code{estimate_sac_range()} fit that was spherical; +#' the \code{range_model} attribute says which. Earlier development +#' versions had a column \code{within_range} in its place: the share of +#' held-out points closer than the range, which counted every such point +#' the same. +#' +#' Attributes: \code{method}, \code{sac_range}, \code{range_model}, +#' \code{crs} (the CRS the distances were measured in), +#' \code{n_unknown_ids} (the number of distinct rows the folds name that +#' \code{data_sf} does not have, each counted once however many folds +#' mention it, as in the \code{cv_*()} field of the same name), +#' \code{pooled} (a list with the number, minimum, median and mean of the +#' held-out distances over all folds, and the pooled \code{mean_cor}) +#' and \code{target}: \code{NULL} without a prediction target, otherwise a +#' list with \code{n_prediction_points}, \code{source}, \code{basis} +#' (\code{"each fold's training data"} or \code{"all sites"}), +#' \code{held_out_mean}, \code{held_out_median}, \code{target_mean}, +#' \code{target_median}, \code{target_all_mean}, \code{target_all_median} +#' (the prediction distances to all sites), \code{mean_diff}, \code{w1}, +#' \code{cor_gap}, \code{cor_w1} (\code{NA} without a range), \code{scale} +#' (\code{"correlation"} or \code{"distance"}), \code{tolerance}, +#' \code{reading} (see \strong{Reading the gap}) and +#' \code{nndm_out_of_reach} (for NNDM and kNNDM folds, the +#' \code{params$target_out_of_reach} that \code{make_folds()} recorded; +#' \code{NA} for other schemes). \code{not_compared} is \code{NULL}, or, +#' for NNDM or kNNDM folds whose carried target was not compared because the +#' distances here are measured in another CRS, one sentence naming the two +#' CRSs; \code{target} is then \code{NULL} and \code{print()} gives the +#' sentence where it would otherwise say that no target is given. #' @family cross-validation #' @seealso \code{\link{make_folds}()} for the fold schemes and the block #' sizing this measures the outcome of; \code{\link{cv_block_size_sweep}()} @@ -67,7 +178,7 @@ #' coords = c("x", "y"), crs = 32632 #' ) #' -#' # Random folds put a training point almost on top of every held-out one. +#' # Random folds put a training point close to every held-out one. #' random <- make_folds(pts, k = 4, method = "random_kfold", seed = 1) #' print(fold_separation(random, pts, sac = 200)) #' @@ -75,8 +186,14 @@ #' blocked <- make_folds(pts, k = 4, method = "block_kfold", #' block_size = 250, seed = 1) #' print(fold_separation(blocked, pts, sac = 200)) +#' +#' # Which of the two suits a map of the sampled square? Compare each with +#' # the distances from the cells of that map to the training data. +#' cells <- st_make_grid(pts, n = c(20, 20), what = "centers") +#' print(fold_separation(random, pts, sac = 200, prediction_points = cells)) +#' print(fold_separation(blocked, pts, sac = 200, prediction_points = cells)) #' @export -fold_separation <- function(folds, data_sf, sac = NULL) { +fold_separation <- function(folds, data_sf, sac = NULL, prediction_points = NULL) { if (!inherits(data_sf, "sf")) stop("fold_separation(): `data_sf` must be an sf object.", call. = FALSE) splits <- if (is.list(folds) && !is.null(folds$folds)) folds$folds else folds @@ -84,6 +201,10 @@ fold_separation <- function(folds, data_sf, sac = NULL) { !all(vapply(splits, function(s) is.list(s) && !is.null(s$test), logical(1)))) stop("fold_separation(): `folds` must be a make_folds() result or its ", "`$folds` element (a list of train/test splits).", call. = FALSE) + # A bare split list has no `params`; `$` on it would partial-match nothing + # and return NULL, which is what the lookups below rely on. + params <- if (is.list(folds) && !is.null(folds$folds) && is.list(folds$params)) + folds$params else NULL # Same row-identity convention as make_folds() and every cv_*(): the stamped # column when there is one, row position otherwise. Getting this wrong @@ -93,7 +214,7 @@ fold_separation <- function(folds, data_sf, sac = NULL) { # Which is what happened when the folds came from another layer: built on # prep_model_data()'s 200 points and measured on the 195 that # assign_features_to_polygons() kept, every row after the first dropped one - # was paired with its neighbour's folds, and within_range read 1.0 against + # was paired with its neighbour's folds, and the range column read 1.0 against # 0.23-0.48 on the right layer, with nothing said. cv_*() refuse such folds # through the probe make_folds() records; so does this. .check_fold_provenance(folds, data_sf, "fold_separation") @@ -104,21 +225,21 @@ fold_separation <- function(folds, data_sf, sac = NULL) { stop("fold_separation(): `sac` must be a plain number in the units of the ", "CRS the distances are measured in (metres for lon/lat input); got ", format(sac), ".", call. = FALSE) - sac_val <- if (!is.null(sac)) suppressWarnings(as.numeric(sac)[1L]) else - suppressWarnings(as.numeric(folds$params$sac_range %||% NA_real_)[1L]) - if (!length(sac_val) || !is.finite(sac_val)) sac_val <- NA_real_ + sac_obj <- if (!is.null(sac)) sac else params$sac_range + sac_val <- if (!is.null(sac_obj)) suppressWarnings(as.numeric(sac_obj)[1L]) else NA_real_ + if (!length(sac_val) || !is.finite(sac_val) || sac_val <= 0) sac_val <- NA_real_ # A range is a length in the CRS it was measured in. The one the folds # carry is in the folds' CRS (params$crs), and an estimate_sac_range() # result records its own; measuring the distances in whatever CRS data_sf - # happened to arrive in compared a metre range with foot distances and - # printed a verdict about leakage that was off by a factor of 3.3. So when - # the range says where it is from, the distances are measured there. A - # bare number says nothing, and stays in data_sf's (projected) units. + # happened to arrive in compared a metre range with foot distances, off by + # a factor of 3.3. So when the range says where it is from, the distances + # are measured there. A bare number says nothing, and stays in data_sf's + # (projected) units. rng_crs <- NULL if (is.finite(sac_val)) { cr <- if (!is.null(sac)) attr(sac, "crs") - else attr(folds$params$sac_range, "crs") %||% folds$params$crs + else attr(params$sac_range, "crs") %||% params$crs cr <- if (is.null(cr)) NULL else tryCatch(sf::st_crs(cr), error = function(e) NULL) if (!is.null(cr) && !is.na(cr) && !isTRUE(sf::st_is_longlat(cr))) @@ -131,6 +252,7 @@ fold_separation <- function(folds, data_sf, sac = NULL) { pts <- if (is.null(rng_crs)) ensure_projected(pts) else .transform_or_stamp(pts, rng_crs, what = "data_sf", caller = "fold_separation") pts <- sf::st_zm(pts, drop = TRUE, what = "ZM") + crs_lbl <- .fold_crs_label(pts) # A distance is only meaningful between finite coordinates. xy <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] @@ -138,18 +260,87 @@ fold_separation <- function(folds, data_sf, sac = NULL) { if (!any(ok)) stop("fold_separation(): `data_sf` has no usable coordinates.", call. = FALSE) - fold_blocks <- folds$params$fold_blocks - unknown <- 0L - - rows <- lapply(seq_along(splits), function(j) { + # Each fold's rows in this layer. A row the folds name and the layer does + # not have appears once in one fold's test set and once in every other + # fold's training set, so the unknown IDs are collected and counted once + # each: five missing rows read as 15, 25 or 50 at k = 3, 5 or 10 (and as + # 996 over 200 buffered leave-one-out folds) when the mentions were summed, + # where the cv_*() field of the same name says 5. + unknown_ids <- vector("list", length(splits)) + idx <- lapply(seq_along(splits), function(j) { s <- splits[[j]] te <- match(s$test, ids) tr <- match(s$train, ids) - unknown <<- unknown + sum(is.na(te)) + sum(is.na(tr)) - te <- te[!is.na(te) & ok[te]] - tr <- tr[!is.na(tr) & ok[tr]] + unknown_ids[[j]] <<- c(s$test[is.na(te)], s$train[is.na(tr)]) + list(te = te[!is.na(te) & ok[te]], tr = tr[!is.na(tr) & ok[tr]]) + }) + unknown <- length(unique(unlist(unknown_ids, use.names = FALSE))) + + # ---- The prediction target, when there is one ---------------------------- + # Supplied points are measured here. NNDM and kNNDM folds carry the + # distances from the prediction points they were built for, to all sites; + # those serve when nothing is supplied and they were measured in the CRS + # used here. + pred <- NULL; d_all <- NULL; target_source <- NA_character_ + target_note <- NULL + # The two distance-matched methods, and the name each goes by in a sentence. + matched <- is.character(folds$method) && length(folds$method) == 1L && + folds$method %in% c("nndm", "knndm") + matched_name <- if (matched && identical(folds$method, "knndm")) "kNNDM" else "NNDM" + if (!is.null(prediction_points)) { + pred <- .fold_sep_prediction_points(prediction_points, pts) + sites <- sort(unique(unlist(lapply(idx, function(i) c(i$te, i$tr)), + use.names = FALSE))) + if (length(sites)) { + d_all <- .nn_dist_to(pred, pts[sites, ]) + d_all <- d_all[is.finite(d_all)] + } + target_source <- "prediction_points" + } else if (matched && is.numeric(params$target_distances)) { + if (identical(params$crs, crs_lbl)) { + d_all <- params$target_distances[is.finite(params$target_distances)] + target_source <- sprintf("the prediction points the %s folds were built for", + matched_name) + } else { + # The carried distances are lengths in the CRS the folds were built in. + # Measured here in another one (`data_sf` arrived in it, or `sac` + # records it), the held-out distances cannot be set beside them, and + # the target was dropped without a word: the print then said "No + # prediction target is given" of folds that were built for one. The + # reason is kept and printed in that sentence's place. + crs_chr <- function(v) if (is.character(v) && length(v) == 1L && !is.na(v)) v + else "a layer with no recorded CRS" + target_note <- sprintf(paste0( + "These %s folds carry the distances from their %d prediction ", + "points to the data in %s, and the distances here are measured in ", + "%s, so the two are not compared."), + matched_name, + as.integer(params$n_prediction_points %||% length(params$target_distances)), + crs_chr(params$crs), crs_chr(crs_lbl)) + .log_info(paste0("fold_separation(): %s Pass `prediction_points` to ", + "have the target measured here."), target_note) + } + } + if (!length(d_all)) d_all <- NULL + per_fold_target <- !is.null(pred) && !is.null(d_all) && length(splits) <= 50L + + cor_fn <- .fold_sep_cor_fn(sac_val, sac_obj) + rho <- cor_fn$fn + fold_blocks <- params$fold_blocks + d_cv <- vector("list", length(splits)); d_tg <- vector("list", length(splits)) + + rows <- lapply(seq_along(splits), function(j) { + s <- splits[[j]] + te <- idx[[j]]$te; tr <- idx[[j]]$tr d <- if (length(te) && length(tr)) .nn_dist_to(pts[te, ], pts[tr, ]) else numeric(0) d <- d[is.finite(d)] + d_cv[[j]] <<- d + # What the fold's own model would face at the prediction points. + tg <- if (is.null(d_all) || !length(tr)) numeric(0) + else if (per_fold_target) { + v <- .nn_dist_to(pred, pts[tr, ]); v[is.finite(v)] + } else d_all + if (per_fold_target) d_tg[[j]] <<- tg data.frame( # A cv_*() result's $folds carries each split's index in the original # fold list as fold_id, and its fold_metrics are labelled by it. After @@ -162,28 +353,255 @@ fold_separation <- function(folds, data_sf, sac = NULL) { length(fold_blocks[[j]]) else NA_integer_, min_dist = if (length(d)) min(d) else NA_real_, median_dist = if (length(d)) stats::median(d) else NA_real_, - within_range = if (length(d) && is.finite(sac_val)) mean(d < sac_val) else NA_real_, + mean_cor = if (length(d) && !is.null(rho)) mean(rho(d)) else NA_real_, + target_median_dist = if (length(tg)) stats::median(tg) else NA_real_, + dist_gap = if (length(d) && length(tg)) mean(d) - mean(tg) else NA_real_, stringsAsFactors = FALSE ) }) out <- do.call(rbind, rows) if (unknown > 0L) - .log_info(paste0("fold_separation(): %d fold entr(ies) name rows `data_sf` ", - "does not have, and were skipped. Are these the folds ", + .log_info(paste0("fold_separation(): the folds name %d row(s) `data_sf` ", + "does not have, which were skipped. Are these the folds ", "this layer was split into?"), unknown) + + cv_all <- unlist(d_cv, use.names = FALSE) + pooled <- list( + n = length(cv_all), + min_dist = if (length(cv_all)) min(cv_all) else NA_real_, + median_dist = if (length(cv_all)) stats::median(cv_all) else NA_real_, + mean_dist = if (length(cv_all)) mean(cv_all) else NA_real_, + mean_cor = if (length(cv_all) && !is.null(rho)) mean(rho(cv_all)) else NA_real_) + + target <- NULL + if (!is.null(d_all) && length(cv_all)) { + if (per_fold_target) { + # Folds count by their share of the held-out points, as they do in a + # pooled cross-validation score. + n_cv <- lengths(d_cv); n_tg <- lengths(d_tg) + use <- which(n_cv > 0L & n_tg > 0L) + tg_all <- unlist(d_tg[use], use.names = FALSE) + tg_w <- rep(n_cv[use] / n_tg[use], times = n_tg[use]) + } else { + tg_all <- d_all; tg_w <- rep(1, length(d_all)) + } + if (length(tg_all)) { + cmp <- .fold_sep_compare(cv_all, tg_all, tg_w) + cmp_cor <- if (is.null(rho)) list(diff = NA_real_, w1 = NA_real_) + else .fold_sep_compare(1 - rho(cv_all), 1 - rho(tg_all), tg_w) + on_cor <- !is.null(rho) + tol <- if (on_cor) .fold_sep_tol_cor else .fold_sep_tol_dist + # On the distance scale the tolerance is a share of the prediction + # mean, so the gap is read in distance units against that share of the + # mean. It used to be divided by the mean first. Prediction points on + # top of the sites (a model scored where it was sampled) have a + # prediction mean of 0: the gap was then Inf, or 0 / 0, the reading NA, + # and the print said no target had been given. With every prediction + # distance 0 the tolerance is 0 and the held-out distances lie wholly + # on one side: a held-out mean above 0 reads "farther", and one of 0 + # reads "matched". + reading <- if (on_cor) .fold_sep_reading(cmp_cor$diff, cmp_cor$w1, tol) + else .fold_sep_reading(cmp$diff, cmp$w1, tol * cmp$mean_b) + target <- list( + n_prediction_points = if (!is.null(pred)) nrow(pred) else length(d_all), + source = target_source, + basis = if (per_fold_target) "each fold's training data" else "all sites", + held_out_mean = cmp$mean_a, held_out_median = stats::median(cv_all), + target_mean = cmp$mean_b, + target_median = if (per_fold_target) .fold_sep_wquantile(tg_all, tg_w, 0.5) + else stats::median(tg_all), + target_all_mean = mean(d_all), target_all_median = stats::median(d_all), + mean_diff = cmp$diff, w1 = cmp$w1, + cor_gap = cmp_cor$diff, cor_w1 = cmp_cor$w1, + scale = if (on_cor) "correlation" else "distance", + tolerance = tol, + reading = reading, + # What make_folds(method = "nndm") or "knndm" found about its own + # target: TRUE when the prediction points are nearer than + # leave-one-out reaches, which no fold design can match. + nndm_out_of_reach = if (matched) + isTRUE(params$target_out_of_reach) else NA) + } + } + structure(out, class = c("fold_separation", "data.frame"), method = folds$method %||% "supplied splits", - sac_range = sac_val, n_unknown_ids = unknown, - crs = .fold_crs_label(pts)) + sac_range = sac_val, range_model = cor_fn$model, + n_unknown_ids = unknown, crs = crs_lbl, + pooled = pooled, target = target, + # Why a target the folds carry is not in `target` (NULL when + # there is nothing to explain). Not named `target_...`: attr() + # matches partially, so attr(x, "target") would return this + # sentence whenever `target` itself is NULL. + not_compared = if (is.null(target)) target_note else NULL) +} + + +# Tolerances of the reading (see "Reading the gap" in ?fold_separation). +# Over 60 draws of random five-fold splits on evenly sited points (150 and +# 300 of them, ranges of 30 and 100 km on boxes 300 to 800 km wide), compared +# with a grid over the same box, the gap ran from -0.064 to +0.025 on the +# correlation scale and from -0.16 to +0.08 of the prediction mean on the +# distance scale, and every draw read "matched". Random folds on clustered +# points against the same grids gave -0.15 or below and -0.44 or below (32 +# of 32 "closer"). +.fold_sep_tol_cor <- 0.10 +.fold_sep_tol_dist <- 0.25 + + +#' Bring the prediction points into the CRS the distances are measured in +#' +#' @param prediction_points An sf/sfc layer, as passed. +#' @param pts The data points, already in the measuring CRS. +#' @return An sf POINT layer with finite coordinates. +#' @keywords internal +#' @noRd +.fold_sep_prediction_points <- function(prediction_points, pts) { + if (inherits(prediction_points, "sfc")) + prediction_points <- sf::st_sf(geometry = prediction_points) + if (!inherits(prediction_points, "sf")) + stop("fold_separation(): `prediction_points` must be an sf or sfc layer of ", + "the locations to be predicted; got an object of class ", + class(prediction_points)[1L], ".", call. = FALSE) + if (!nrow(prediction_points)) + stop("fold_separation(): `prediction_points` has no rows.", call. = FALSE) + if (!all(sf::st_geometry_type(prediction_points, by_geometry = TRUE) == "POINT")) { + .log_info(paste0("fold_separation(): `prediction_points` are not POINTs; ", + "using one representative point per feature so the ", + "target distances are point-to-point.")) + prediction_points <- coerce_to_points(prediction_points, "auto") + } + if (is.null(.crs_or_null(pts))) { + if (!is.na(sf::st_crs(prediction_points))) + stop("fold_separation(): `data_sf` has no CRS and `prediction_points` has ", + "one, so the distance between them cannot be measured. Set the CRS ", + "of `data_sf` with sf::st_set_crs().", call. = FALSE) + pred <- prediction_points + } else { + pred <- .transform_or_stamp(prediction_points, sf::st_crs(pts), + what = "prediction_points", + caller = "fold_separation") + } + pred <- sf::st_zm(pred, drop = TRUE, what = "ZM") + empty <- sf::st_is_empty(pred) + if (any(empty)) pred <- pred[!empty, , drop = FALSE] + xy <- if (nrow(pred)) sf::st_coordinates(pred)[, 1:2, drop = FALSE] else matrix(0, 0, 2) + keep <- is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + if (!any(keep)) + stop("fold_separation(): `prediction_points` has no usable coordinates.", + call. = FALSE) + pred[keep, , drop = FALSE] +} + + +#' The correlation a range leaves at a distance +#' +#' The weight behind \code{mean_cor} and the correlation-scale gap: 1 at +#' distance 0, falling towards 0 beyond the range. The range is an effective +#' range, so the exponential form is \code{exp(-3 d / range)}. A range that +#' carries a single-structure spherical \code{variogram_model} (an +#' \code{estimate_sac_range()} fit) uses the spherical form instead; any +#' other model, and a bare number, is read as exponential. +#' +#' @param range A positive number, or \code{NA}. +#' @param sac_obj The object the range came from, for its model attribute. +#' @return A list with \code{fn} (\code{NULL} without a range) and +#' \code{model} (\code{"Exp"}, \code{"Sph"} or \code{NA}). +#' @keywords internal +#' @noRd +.fold_sep_cor_fn <- function(range, sac_obj = NULL) { + if (!is.finite(range) || range <= 0) return(list(fn = NULL, model = NA_character_)) + vm <- tryCatch(attr(sac_obj, "variogram_model"), error = function(e) NULL) + fam <- "Exp" + if (is.data.frame(vm) && "model" %in% names(vm)) { + st <- setdiff(as.character(vm$model), "Nug") + if (length(st) == 1L && identical(st, "Sph")) fam <- "Sph" + } + fn <- if (identical(fam, "Sph")) + function(d) ifelse(d >= range, 0, 1 - 1.5 * (d / range) + 0.5 * (d / range)^3) + else function(d) exp(-3 * d / range) + list(fn = fn, model = fam) +} + + +#' Quantiles of a weighted sample (inverse of the weighted ECDF) +#' +#' @param x Values. +#' @param w Non-negative weights, one per value. +#' @param p Probabilities. +#' @return The smallest value whose cumulative weight share reaches each +#' \code{p}. +#' @keywords internal +#' @noRd +.fold_sep_wquantile <- function(x, w, p) { + o <- order(x); x <- x[o] + cw <- cumsum(w[o]); cw <- cw / cw[length(cw)] + x[pmin(length(x), findInterval(p, cw, left.open = TRUE) + 1L)] +} + + +#' Signed mean difference and Wasserstein distance of two distance samples +#' +#' \code{diff} is \code{mean(a)} minus the weighted mean of \code{b}: the +#' signed area between the two cumulative distributions. \code{w1} is the +#' unsigned area, the Wasserstein-1 distance, from the two quantile functions +#' on 2000 probability midpoints. \code{w1} is never below \code{|diff|}; +#' the two are equal when one distribution lies wholly to one side of the +#' other, and \code{w1} is the larger when they cross. +#' +#' @param a Unweighted values (the held-out distances). +#' @param b Values with weights \code{wb} (the prediction distances). +#' @return A list: \code{mean_a}, \code{mean_b}, \code{diff}, \code{w1}. +#' @keywords internal +#' @noRd +.fold_sep_compare <- function(a, b, wb = rep(1, length(b))) { + p <- (seq_len(2000L) - 0.5) / 2000 + qa <- .fold_sep_wquantile(a, rep(1, length(a)), p) + qb <- .fold_sep_wquantile(b, wb, p) + mean_a <- mean(a); mean_b <- stats::weighted.mean(b, wb) + d <- mean_a - mean_b + list(mean_a = mean_a, mean_b = mean_b, diff = d, + w1 = max(mean(abs(qa - qb)), abs(d))) +} + + +#' Word a gap between held-out and prediction distances +#' +#' @param gap Signed gap, held-out minus prediction, on the reading's scale: +#' the correlation scale, or distance units. +#' @param w1 The Wasserstein distance on the same scale. +#' @param tol The tolerance on that scale. In distance units it is a share +#' of the prediction mean and can be 0, when every prediction point lies +#' on a site. +#' @return \code{"closer"}, \code{"farther"}, \code{"matched"}, +#' \code{"mixed"}, or \code{NA} when an argument is not finite. +#' @keywords internal +#' @noRd +.fold_sep_reading <- function(gap, w1, tol) { + if (!is.finite(gap) || !is.finite(w1) || !is.finite(tol)) return(NA_character_) + # Two identical distributions are matched whatever the tolerance. With a + # tolerance of 0 (prediction points on the sites, on the distance scale) + # the test below would otherwise name a side for a gap of exactly 0. + if (gap == 0 && w1 == 0) return("matched") + # A direction needs a net shift past the tolerance that is also most of + # the difference between the two distributions. When they cross, the + # signed area is the remainder of two opposite ones and names no side. + if (abs(gap) >= tol && abs(gap) >= 0.5 * w1) + return(if (gap < 0) "closer" else "farther") + if (abs(gap) < tol && w1 < 2 * tol) return("matched") + "mixed" } #' @export print.fold_separation <- function(x, ...) { - sac <- attr(x, "sac_range"); crs <- attr(x, "crs") + sac <- attr(x, "sac_range"); crs <- attr(x, "crs"); tg <- attr(x, "target") + if (is.null(sac)) sac <- NA_real_ + if (is.null(crs)) crs <- NA_character_ cat(sprintf("Fold separation: %s, %d fold(s), %d held-out point(s)%s\n", - attr(x, "method"), nrow(x), sum(x$n_test, na.rm = TRUE), + attr(x, "method") %||% "supplied splits", nrow(x), + sum(x$n_test, na.rm = TRUE), if (is.na(crs)) "" else sprintf(" (%s)", crs))) # The unit of the CRS, not its identifier: "in EPSG:32617 units" named no # unit. The CRS itself is on the line above. @@ -194,79 +612,161 @@ print.fold_separation <- function(x, ...) { else if (!is.na(unit)) sprintf(" (in %s, like the distances)", unit) else sprintf(" (in the units of %s, like the distances)", crs))) } + if (is.list(tg)) + cat(sprintf(" prediction target: %d point(s)%s, measured to %s\n", + as.integer(tg$n_prediction_points), + if (identical(tg$source, "prediction_points")) "" + else sprintf(" (%s)", tg$source), tg$basis)) + num <- function(v) format(signif(v, 4)) df <- as.data.frame(x) df$min_dist <- signif(df$min_dist, 4) df$median_dist <- signif(df$median_dist, 4) - if (all(is.na(df$within_range))) df$within_range <- NULL - else df$within_range <- ifelse(is.na(df$within_range), "NA", - sprintf("%.0f%%", 100 * df$within_range)) + # The two target columns are shown under shorter headings (`target` for + # target_median_dist, `gap` for dist_gap), so that the table of a blocked + # design with a range and a target fits an 80-column line. + tgt <- df[["target_median_dist"]]; gap <- df[["dist_gap"]] + df$target_median_dist <- NULL; df$dist_gap <- NULL + if (!is.null(tgt) && !all(is.na(tgt))) df$target <- signif(tgt, 4) + if (!is.null(gap) && !all(is.na(gap))) df$gap <- signif(gap, 4) + # A mean correlation, so two decimals, not a percentage of points. + wr <- df$mean_cor; df$mean_cor <- NULL + if (!is.null(wr) && !all(is.na(wr))) + df$mean_cor <- ifelse(is.na(wr), "NA", sprintf("%.2f", wr)) if (all(is.na(df$n_blocks))) df$n_blocks <- NULL - cat("\n"); print(df, row.names = FALSE); cat("\n") - if (is.finite(sac)) { - share <- stats::weighted.mean(x$within_range, x$n_test, na.rm = TRUE) - closest <- suppressWarnings(min(x$min_dist, na.rm = TRUE)) - # Every fold can be unmeasurable at once -- no test rows anywhere, or none - # with a usable coordinate -- and then weighted.mean() over an all-NA - # vector is NaN and min() is Inf, so the `share > 0.5` test below aborted - # on "missing value where TRUE/FALSE needed". Say there is nothing to - # report instead of failing to say it. - if (!is.finite(share) || !is.finite(closest)) { - cat(strwrap(paste("No held-out point could be measured against the", - "range, so there is no separation to report. Check", - "n_test above: a fold with no scorable rows is a", - "finding about the fold scheme, not about the model."), - width = 74, prefix = " "), sep = "\n") - return(invisible(x)) - } - # The verdict is about leakage, so it is stated in terms of what leaks: - # a held-out point closer to training data than the range is one whose - # value the training set partly carries. - cat(strwrap(sprintf(paste0("%.0f%% of held-out points sit closer to a ", - "training point than the correlation range ", - "(%s), and the closest is %s away. %s"), - 100 * share, format(sac, digits = 4), - format(signif(closest, 3)), - .fold_separation_advice(attr(x, "method"), share)), - width = 74, prefix = " "), sep = "\n") + # A leave-one-out design has one row per point. Printing hundreds of + # one-point folds pushed the summary below off the screen; the object + # itself keeps every row. + shown <- if (nrow(df) > 20L) 10L else nrow(df) + cat("\n"); print(df[seq_len(shown), , drop = FALSE], row.names = FALSE) + if (shown < nrow(df)) + cat(sprintf(" ... and %d more fold(s); as.data.frame() shows every row\n", + nrow(df) - shown)) + cat("\n") + + say <- function(...) cat(strwrap(paste0(...), width = 74, prefix = " "), sep = "\n") + # An object from before `pooled` was recorded still prints. + pl <- attr(x, "pooled") + if (!is.list(pl)) + pl <- list(min_dist = suppressWarnings(min(x$min_dist, na.rm = TRUE)), + median_dist = NA_real_, + mean_cor = if (is.null(x$mean_cor)) NA_real_ else + stats::weighted.mean(x$mean_cor, x$n_test, na.rm = TRUE)) + # Every fold can be unmeasurable at once: no test rows anywhere, or none + # with a usable coordinate. Say there is nothing to report. + if (!is.finite(pl$min_dist)) { + say("No held-out point could be measured against its training data, so ", + "there is no separation to report. Check n_test above: a fold with ", + "no scorable rows is a finding about the fold scheme, not about the ", + "model.") + return(invisible(x)) } + say(if (is.finite(pl$median_dist)) + sprintf("Held-out points sit a median of %s from their nearest training point; the closest is %s away.", + num(pl$median_dist), num(pl$min_dist)) + else sprintf("The closest held-out point is %s from its nearest training point.", + num(pl$min_dist)), + if (is.finite(sac) && is.finite(pl$mean_cor)) + sprintf(paste0(" Under the range of %s that leaves a mean correlation ", + "of %.2f between a held-out point and its nearest ", + "training point (%s)."), + format(sac, digits = 4), pl$mean_cor, + if (identical(attr(x, "range_model"), "Sph")) + "the spherical correlation, averaged over the hold-out: 1 at distance 0, 0 at the range" + else "exp(-3 d / range) averaged over the hold-out: 1 at distance 0, 0.05 at the range") + else "") + say(.fold_separation_advice(tg, attr(x, "method"), attr(x, "not_compared"))) invisible(x) } -#' What to make of the share of the hold-out inside the range, per fold scheme +#' The closing lines of print.fold_separation(): the target and the reading +#' +#' Without a prediction target the distances carry no direction, so nothing +#' is concluded and no remedy is named. With one, the two sets of distances +#' are stated with their signed gap, and the reading is worded as a statement +#' about distances and the way a score tends to read for that target. #' -#' "Widen the blocks" was said of every scheme, including random folds, -#' leave-location-out and buffered LOO, which have no blocks, and NNDM, whose -#' folds are built to reproduce the prediction-to-data distances: a high -#' share there describes how close the prediction points sit to the data, not -#' an optimistic design. +#' "No prediction target is given" is said only when none exists. A target +#' the folds carry that could not be compared here gets its reason +#' (\code{note}) in that sentence's place, and a target that was measured but +#' has no reading gets its numbers and a statement that none is drawn. The +#' no-target sentence used to stand for all three, so it could appear under +#' a header naming the target, or for NNDM folds built for one. +#' @param target \code{attr(x, "target")}: a list, or \code{NULL}. #' @param method The fold method (\code{attr(x, "method")}). -#' @param share The share of held-out points within the range. +#' @param note \code{attr(x, "not_compared")}: why a target that exists is +#' not in \code{target}, or \code{NULL}. #' @return Character(1). #' @keywords internal #' @noRd -.fold_separation_advice <- function(method, share) { - method <- if (is.character(method) && length(method) == 1L && !is.na(method)) - method else "supplied splits" - if (share <= 0.1) - return("Little of the hold-out is within reach of the training data.") - if (identical(method, "nndm")) - return(paste("NNDM folds reproduce the distances from the prediction", - "points to the data, so this share describes how close the", - "prediction points themselves sit to the data, not a leak in", - "the design; compare the folds' params$realised_median with", - "params$target_median to check the match.")) - remedy <- switch(method, - block_kfold = "widen the blocks", - buffered_loo = "widen the buffer to at least the range", - "use blocked or buffered folds") - if (share > 0.5) - return(paste0("Most of the hold-out is inside the range of its own ", - "training data, so this score is optimistic: ", remedy, ".")) - if (identical(method, "block_kfold")) - return(paste("A minority leaks, which is the usual price of contiguous", - "blocks at the edges.")) - paste0("A minority leaks; to hold it out, ", remedy, ".") +.fold_separation_advice <- function(target, method = NULL, note = NULL) { + if (!is.list(target)) { + if (is.character(note) && length(note) == 1L && !is.na(note) && nzchar(note)) + return(paste(note, "Pass `prediction_points` to have the target measured here.")) + return(paste("No prediction target is given, so these are distances and", + "no conclusion about the score: a cross-validated error reads", + "low when the hold-out sits closer to its training data than", + "the locations to be predicted do, and high when it sits", + "farther. Pass `prediction_points` to compare the two.")) + } + rdg <- target$reading + if (!(is.character(rdg) && length(rdg) == 1L && !is.na(rdg))) rdg <- NA_character_ + num <- function(v) format(signif(v, 4)) + # The sign is taken from the number as it prints, so a gap that rounds to + # zero is not shown as "-0.00". + signed <- function(v, fmt = NULL) { + if (!is.finite(v)) return(format(v)) + shown <- if (is.null(fmt)) num(abs(v)) else sprintf(fmt, abs(v)) + zero <- isTRUE(suppressWarnings(as.numeric(shown)) == 0) + paste0(if (zero) "" else if (v > 0) "+" else "-", shown) + } + facts <- sprintf(paste0( + "The prediction points sit a median of %s from %s. Held-out minus ", + "prediction: %s in mean distance (W1 %s)%s."), + num(target$target_median), + if (identical(target$basis, "all sites")) "the nearest of all sites" + else sprintf("the same training data (%s from the nearest of all sites)", + num(target$target_all_median)), + signed(target$mean_diff), num(target$w1), + if (is.finite(target$cor_gap %||% NA_real_)) + sprintf("; %s on the correlation scale (W1 %.2f)", + signed(target$cor_gap, "%.2f"), target$cor_w1) + else "") + # Measured, and not readable: the numbers stand, and nothing is concluded + # from them. (Not reachable from fold_separation() as it stands, where + # every gap is finite; kept so that an NA reading can never print as "no + # target".) + if (is.na(rdg)) + return(paste(facts, "The gap is not a finite number on the reading's", + "scale, so no reading is drawn from these distances.")) + reading <- switch(rdg, + closer = paste( + "The held-out points sit closer to their training data than the", + "prediction points do, so the cross-validated error tends to read low", + "for these prediction points."), + farther = paste0( + "The held-out points sit farther from their training data than the ", + "prediction points do, so the cross-validated error tends to read high ", + "for these prediction points.", + if (identical(method, "nndm") && isTRUE(target$nndm_out_of_reach)) + paste0(" NNDM can only lengthen a held-out distance, so it cannot ", + "match prediction points this near to the data.") + else if (identical(method, "knndm") && isTRUE(target$nndm_out_of_reach)) + paste0(" A held-out point is never nearer to its training data than ", + "to its nearest other sample, so kNNDM cannot match prediction ", + "points this near to the data.") + else ""), + matched = paste( + "The held-out points sit about as far from their training data as the", + "prediction points do. Matched nearest-neighbour distances do not make", + "a score unbiased by themselves: a learner that draws on several", + "neighbours can still read low on clustered samples."), + mixed = paste( + "The two distributions cross: the held-out points sit closer than the", + "prediction points at some distances and farther at others, so the", + "distances give no single direction for the score."), + "") + paste(facts, reading) } diff --git a/R/kriging-adequacy.R b/R/kriging-adequacy.R index 0178edb9..18f60f40 100644 --- a/R/kriging-adequacy.R +++ b/R/kriging-adequacy.R @@ -14,10 +14,9 @@ #' function measures it, changing no cell value: for every cell it reports #' the block-kriging estimate and variance implied by a fitted variogram, #' that variance as a share of the variance the cell's mean would have with -#' no data at all, and, where the cell has points, -#' whether it exceeds the design-based variance of the plain mean, -#' \eqn{s^2/n}; and it scores the variogram itself by blocked -#' cross-validation. +#' no data at all, and, where the cell has points, the error variance of its +#' plain mean under the same variogram and the share of that variance kriging +#' removes; and it scores the variogram itself by blocked cross-validation. #' #' @section Reading the columns: #' \describe{ @@ -38,15 +37,55 @@ #' cell at 0.05 is well determined; a cell at 0.8 is mostly prior. #' \code{NA} when the model is a pure nugget, where a cell mean has no #' prior variance to be a share of.} -#' \item{\code{kr_exceeds_design}}{\code{TRUE} where the kriging variance is -#' larger than \eqn{s^2/n} from the cell's own points: kriging is not -#' earning its keep there, and that is said per cell instead of -#' globally. \code{NA} for cells with fewer than two points, where -#' \eqn{s^2} does not exist.} -#' \item{\code{kr_shift}}{The kriged estimate minus the plain mean, in -#' units of the plain mean's standard error (\code{NA} where that is not -#' defined). How much the aggregator would move the value, against the -#' precision the value has.} +#' \item{\code{plain_var}}{The error variance of the cell's plain mean as +#' an estimate of the cell's average, under the same variogram and the +#' same discretisation of the cell as \code{kr_var}: +#' \eqn{a' C a - 2 a' \bar c(B) + \bar C(B,B)}, with \eqn{a} the plain +#' mean's weights on the cell's observations, \eqn{C} their covariances +#' (the nugget on the diagonal), \eqn{\bar c(B)} their covariances with +#' the cell and \eqn{\bar C(B,B)} the covariance within it. It is the +#' model's counterpart of \code{se^2}. \eqn{s^2/n} is the variance the +#' plain mean would have if the cell's points were independent draws; +#' under spatial correlation it understates the error, most where a +#' cell's points sit close together, so \code{se^2 / plain_var} below 1 +#' says the naive standard error is too small if the variogram is right. +#' Defined from one point up. \code{NA} for a cell with no point and for +#' a cell left out of the kriging.} +#' \item{\code{kr_gain}}{\code{1 - kr_var / plain_var}: the share of the +#' plain mean's error variance that kriging removes in the cell. Both +#' variances come from the one variogram, so the gain does not move when +#' sill and nugget are multiplied by a constant (unless locations are +#' repeated, whose replicate variance is read off the data and does not +#' scale with the model). It is at least 0: the +#' kriging neighbourhood always holds the cell's own points, the plain +#' mean is one unbiased combination of them, and kriging is the best +#' such combination. It is what the variogram expects, not what +#' happened: read it beside \code{attr(, "cv")$zscore_var}, which says +#' whether the variogram's variances are the right size. \code{NA} +#' where \code{plain_var} is. \code{kr_var} is not compared with +#' \eqn{s^2/n}. That comparison +#' sets a variance from the model against one from the cell's own +#' spread, so it moves with the fitted sill: the same data with the same +#' kriged estimates put 4, 27 and 67 of 70 cells above as sill and +#' nugget were multiplied by 1/3, 1 and 3. And it does not mark cells +#' where kriging fails to pay: against known cell averages on simulated +#' fields (eight runs, clustered and uniform layouts, estimated and true +#' variograms) kriging cut the plain mean's error by 20--53 percent in +#' the cells above and by 27--60 percent in the rest.} +#' \item{\code{kr_shift}}{The kriged estimate minus the plain mean, over +#' the standard deviation the variogram gives that difference, +#' \code{sqrt(plain_var - kr_var)} (the kriging error is uncorrelated +#' with the difference, so the two variances subtract). Under the right +#' variogram it has variance 1: about 32 percent of cells beyond 1 and 5 +#' percent beyond 2. More than that says the plain means and the +#' variogram disagree, so the counts \code{print()} gives are a check of +#' the variogram on the cells themselves, beside the cross-validation +#' statistic. In units of the naive standard error \eqn{s/\sqrt{n}} +#' the same shift has a variance of 1.4--8.4 on clustered layouts, so +#' counts beyond 1 and 2 in that unit overstate the disagreement. +#' \code{NA} for a cell with no point, and where the two variances agree +#' to within a ten-thousandth, which is where kriging returns the plain +#' mean.} #' } #' #' @section The cross-validation statistic: @@ -77,18 +116,32 @@ #' kriged from all the others. #' #' @section What it said about block kriging as an aggregator: -#' On the same simulated fields, with 16, 36 and 64 square cells: under -#' uniform sampling the kriged and plain cell means differed by more than -#' one standard error in 11--24 percent of cells and by more than two in -#' 0--7 percent, the kriging variance exceeded \eqn{s^2/n} in 10--26 percent -#' of populated cells, and at most one cell was empty. Under clustered -#' sampling (eight clusters of 60-unit spread) the two aggregators parted: -#' shifts above one standard error in 34--63 percent of cells and above two -#' in 9--25 percent, the kriging variance below \eqn{s^2/n} in only -#' 13--52 percent of populated cells, and 3--27 of the cells empty, each with -#' a kriged estimate and variance where the plain mean has nothing. -#' So a block-kriging aggregator earns its place on clustered layers and -#' rarely on uniform ones, and this function says which kind a layer is. +#' On the same simulated fields, with 16, 36 and 64 square cells, under +#' uniform sampling and under clustered sampling (eight clusters of 60-unit +#' spread), eight draws each, with the true variogram and with the estimated +#' one (96 runs, 2,978 cells with points among them). \code{kr_var} was +#' below \code{plain_var} in every such cell, and \code{kr_gain} ran from +#' 0.14 to 0.86 (median 0.48 uniform, 0.52 clustered). Against the true +#' cell averages kriging cut the plain mean's squared error by 54--56 +#' percent (its RMSE by 33 percent) on both layouts, where mean +#' \code{kr_var} over mean \code{plain_var} predicted 55--58 percent. In +#' the third of cells with the lowest \code{kr_gain} the cut in squared +#' error was 39--49 percent and in the third with the highest 59--66 +#' percent, in all four combinations of layout and variogram, so the column +#' ranks cells by what kriging buys. \code{kr_shift} had a mean square of +#' 0.99--1.10, with 33--36 percent of cells beyond 1 and 4--6 percent beyond +#' 2. +#' +#' What the layout changed was the naive standard error and the empty cells. +#' Under uniform sampling \eqn{s^2/n} was below \code{plain_var} in 52--57 +#' percent of cells with two or more points (median ratio 0.88--0.96), and at +#' most two cells were empty. Under clustered sampling it was below in +#' 76--98 percent (median ratio 0.19--0.58), and 1--5 of 16 cells, 8--17 of +#' 36 and 23--36 of 64 were empty, each with a kriged estimate and variance +#' where the plain mean has nothing. So on these fields kriging removed +#' about half of the plain mean's error variance on either layout; +#' clustering decides how far the naive standard error can be trusted and +#' how many cells have no plain mean at all. #' #' @section What this needs: #' A variogram model. \code{sac} is a \code{\link{estimate_sac_range}()} @@ -100,9 +153,10 @@ #' model attached) is used with a warning that says why it was refused, and #' the reason is kept as \code{attr(, "rejected_reason")}: a range past the #' fitted lags means the sill was never reached and the ratios rest on an -#' extrapolation; a fit that did not converge stopped wherever the optimiser -#' halted; a variogram that falls with distance, or a range below the -#' shortest lag, describes the data poorly at some lags. +#' extrapolation; a variogram that falls with distance, or a range below the +#' shortest lag, describes the data poorly at some lags; and a response in +#' which \code{estimate_sac_range()} found no spatial structure comes with a +#' pure-nugget model, which gives kriging no correlation to use. #' #' The model has to be of the response itself. A variogram of residuals #' (\code{estimate_sac_range(predictor_vars = ...)}, \code{attr(, @@ -148,22 +202,47 @@ #' its replicates, with a warning; \code{n} and \code{mean} still count every #' point. How much of the nugget \eqn{c_0} a mean of \eqn{m} replicates #' keeps is read off the replicates: their pooled within-location variance -#' \eqn{s_w^2}, capped at \eqn{c_0}, is the part that differs from visit to -#' visit and averages down, and the rest is micro-scale variation the visits -#' share, so the mean carries error variance \eqn{c_0 - s_w^2 + s_w^2/m}. -#' That goes to \pkg{gstat} as a known measurement error (its -#' \code{weights}) on the model with the nugget set to zero. For replicates -#' that differ only by measurement error this is exactly the kriging of every -#' observation, and for identical replicates it is the kriging of one; a -#' location seen once is kriged as before. In the cross-validation a -#' location is held out whole, under the fold of its first row, and its -#' error variance is part of its standardised error. A cell or held-out -#' location \pkg{gstat} still cannot krige is reported \code{NA} with a -#' warning, and \code{print()} says how many. +#' \eqn{s_w^2} is the part that differs from visit to visit and averages +#' down, and what the nugget holds beyond it is micro-scale variation the +#' visits share, so the mean carries error variance +#' \eqn{\max(c_0 - s_w^2, 0) + s_w^2/m}. That goes to \pkg{gstat} as a known +#' measurement error (its \code{weights}) on the model with the nugget set +#' to zero. For replicates that differ only by measurement error this is +#' exactly the kriging of every observation, and for identical replicates it +#' is the kriging of one. \code{plain_var} uses the same error variances: +#' the observations a cell has at one location share the micro-scale part +#' and average the rest. +#' +#' When \eqn{s_w^2} is above \eqn{c_0} the replicates show more variation +#' between visits than the model has room for (with a zero nugget, any at +#' all). The replicate variance is then used as it is: a mean of \eqn{m} is +#' kriged with error variance \eqn{s_w^2/m}, and a location seen once with +#' \eqn{s_w^2} where the model gives it \eqn{c_0}. Capping it at +#' \eqn{c_0} would krige the means as more exact than their replicates show +#' them to be: on ten simulated layers of 200 stations visited twice with a +#' measurement variance of 0.5, under the field's own variogram with no +#' nugget, the cross-validation statistic reads 2.96--4.42 with the cap and +#' 0.84--1.15 without it. The warning then carries the class +#' \code{"spatialkit_replicate_var_above_nugget"} and both numbers, which +#' \code{attr(, "replicates")} records and \code{print()} repeats. The +#' replicate variance is an estimate (its degrees of freedom are in the +#' warning and the record), and the variogram still says \eqn{c_0}: refit +#' it with a nugget of at least \eqn{s_w^2}. +#' +#' In the cross-validation a location is held out whole, under the fold of +#' its first row, and its error variance is part of its standardised error. +#' A cell or held-out location \pkg{gstat} still cannot krige is reported +#' \code{NA} with a warning, and \code{print()} says how many. #' #' @param assigned_points_sf Points with a cell identifier column, as #' \code{\link{assign_features_to_polygons}()} returns. -#' @param response_var The response column. +#' @param response_var The response column: numeric or logical. A logical +#' column is kriged as 0/1, so its cell mean is a share. Any other class +#' (a factor, an ordered factor, character, a date) is an error naming the +#' column and its class, and is never converted: a factor's level codes are +#' an arbitrary relabelling, and kriging them gave a variogram, kriged +#' estimates and plain means that all changed with the order of the +#' levels. For a category, pass an indicator (\code{x == "level"}). #' @param cells_sf The cell polygons, with the matching ID column. A layer #' with no CRS is taken to be in the points' CRS (and points with none in #' the cells'), with a warning. @@ -203,8 +282,9 @@ #' @return An \code{sf} object of class \code{"kriging_adequacy"}, one row #' per cell with the cell geometry and: the ID column, \code{n} (points in #' the cell), \code{mean} (the plain mean), \code{se} (its naive standard -#' error), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, -#' \code{kr_exceeds_design}, \code{kr_shift} and \code{kr_n_used} (how many +#' error), \code{plain_var} (the plain mean's error variance under the +#' variogram), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, +#' \code{kr_gain}, \code{kr_shift} and \code{kr_n_used} (how many #' locations the cell was kriged from; \code{NA} for a cell left out). #' Attributes: #' \code{variogram} (the model frame), \code{sill}, \code{nugget}, @@ -214,9 +294,16 @@ #' \code{zscore_var}, \code{zscore_mean}, \code{rmse}, \code{n_pred}, #' \code{k}, \code{method}), \code{nmax}, \code{n_points} (the points #' used), \code{n_locations} (the distinct locations among them, which -#' the kriging used) and \code{cells_left_out} (counts of cells left out, +#' the kriging used), \code{cells_left_out} (counts of cells left out, #' named \code{shape} for \code{max_box_ratio} and \code{size} for -#' \code{max_neighbours}). +#' \code{max_neighbours}) and \code{replicates} (\code{NULL} when no two +#' points share a location; otherwise a list with \code{n_points}, the +#' points that share one, \code{within_var}, their pooled within-location +#' variance, \code{df}, its degrees of freedom, \code{nugget}, the +#' variogram's, \code{nugget_used}, the larger of the two, which is the +#' error variance a location seen once is kriged with, and +#' \code{above_nugget}, \code{TRUE} when the replicate variance exceeds +#' the variogram's nugget). #' @references #' Cressie, N. (1993). \emph{Statistics for Spatial Data}, revised edition. #' Wiley. (Block kriging, chapter 3; cross-validation of the kriging @@ -256,6 +343,34 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, !(response_var %in% names(assigned_points_sf))) stop("kriging_adequacy(): `response_var` must name a column of `assigned_points_sf`.", call. = FALSE) + # The response's type, before anything converts it. as.numeric() under + # suppressWarnings() used to be the first thing done to the column, so a + # factor was kriged on its level codes (and its plain means were means of + # codes): on one three-level factor, reordering the levels moved the nugget + # 0.102 / 0.436 / 0.271 and changed which cells were flagged, with nothing + # said. A character column of numbers and a Date were converted the same + # way, and a character column of labels ended in "fewer than 10 points with + # a finite response", which blames the data. estimate_sac_range() refuses + # a factor, but it only ever saw the converted copy, and is not called at + # all when `sac` is supplied. + resp_raw <- sf::st_drop_geometry(assigned_points_sf)[[response_var]] + if (!(is.numeric(resp_raw) || is.logical(resp_raw))) + stop(sprintf(paste0( + "kriging_adequacy(): response '%s' is %s, and kriging needs a numeric or ", + "logical variable. %s For a category, pass an indicator column ", + "(%s == \"\"): it is kriged as 0/1 and its cell mean is that ", + "level's share."), + response_var, + if (is.factor(resp_raw)) "a factor" + else sprintf("of class %s", paste(class(resp_raw), collapse = "/")), + if (is.factor(resp_raw)) + paste0("A factor's codes are an arbitrary relabelling of its levels: the ", + "variogram, the kriged estimates and the plain cell means would ", + "all change when the levels are reordered.") + else + paste0("It is not converted for you; convert it with as.numeric() ", + "first if its numbers are what you mean."), + response_var), call. = FALSE) if (!is.numeric(nmax) || length(nmax) != 1L || !is.finite(nmax) || nmax < 1) stop("kriging_adequacy(): `nmax` must be a single positive number.", call. = FALSE) @@ -333,7 +448,8 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, caller = "kriging_adequacy") else .align_crs(cells_in, pts) cells <- .safe_make_valid(cells) - z <- suppressWarnings(as.numeric(sf::st_drop_geometry(pts)[[response_var]])) + # Numeric or logical by the check above, so nothing is coerced to NA here. + z <- as.numeric(sf::st_drop_geometry(pts)[[response_var]]) ok <- is.finite(z) & !sf::st_is_empty(pts) if (sum(ok) < 10L) stop("kriging_adequacy(): fewer than 10 points with a finite response; nothing ", @@ -377,22 +493,32 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, stop("kriging_adequacy(): the variogram model has no positive sill.", call. = FALSE) range_identified <- is.finite(suppressWarnings(as.numeric(sac))) # Why the range was refused, kept on the result: "sill never reached" was - # said of every refusal, and a non-converged fit, a variogram that falls - # with distance and one that runs past the fitted lags are different + # said of every refusal, and a variogram that falls with distance, one that + # runs past the fitted lags and one with no spatial structure are different # findings about the model the variances rest on. rejected_reason <- if (range_identified) NA_character_ else as.character(attr(sac, "rejected_reason") %||% "no effective range")[1L] - if (!range_identified) - .warn_and_log(paste0("kriging_adequacy(): the variogram's range was not ", - "identified (%s), so the model the kriging variances ", - "and ratios rest on is one the data did not pin down."), - rejected_reason) + if (!range_identified) { + # A layer with no spatial structure comes with a pure nugget + # (.sac_no_structure(), R/utils.R). That model is what the data support, + # so "one the data did not pin down" was the wrong thing to say of it. + if (.sac_no_structure(sac) && all(fam == "Nug")) + .warn_and_log(paste0("kriging_adequacy(): the variogram's range was not ", + "identified (%s), and the model that comes with ", + "that verdict is a pure nugget: no spatial ", + "correlation was found for kriging to use."), + rejected_reason) + else + .warn_and_log(paste0("kriging_adequacy(): the variogram's range was not ", + "identified (%s), so the model the kriging variances ", + "and ratios rest on is one the data did not pin down."), + rejected_reason) + } # A variogram of residuals on predictors describes what the predictors left # over, and it is the response itself that is kriged here, with no # predictors: the variance they explained is missing from the model. # Measured with a spatially structured covariate: the variance of the - # standardised CV errors went from 0.67-1.53 to 4.3-5.2, and no cell was - # flagged as kriging worse than its plain mean where 2-7 had been. + # standardised CV errors went from 0.67-1.53 to 4.3-5.2. if (isTRUE(attr(sac, "detrended"))) .warn_and_log(paste0("kriging_adequacy(): `sac` is the variogram of the ", "residuals on predictors (detrend = \"%s\"), but the ", @@ -412,12 +538,13 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, # from the mean of its replicates instead (the plain cell means below still # use every point). The replicates say how much of the nugget that mean # keeps: their pooled within-location variance is the part that differs - # between visits (capped at the nugget) and averages down by the count; the - # rest is micro-scale variation the visits share. That goes to gstat as a - # known measurement error (`weights` = 1 / variance) on the model with its - # nugget zeroed: a location seen once gets the whole nugget, as before; - # replicates differing only by measurement error give the kriging of every - # observation; identical replicates give the kriging of one. + # between visits and averages down by the count; what the nugget holds + # beyond it is micro-scale variation the visits share. That goes to gstat + # as a known measurement error (`weights` = 1 / variance) on the model with + # its nugget zeroed: a location seen once gets the whole nugget (or the + # replicate variance, when that is the larger); replicates differing only + # by measurement error give the kriging of every observation; identical + # replicates give the kriging of one. xy <- sf::st_coordinates(kp)[, 1:2, drop = FALSE] key <- paste(xy[, 1], xy[, 2]) loc <- match(key, unique(key)) @@ -426,18 +553,61 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, vk <- vm w <- NULL err_var <- rep(0, nrow(kk)) # already in vk's nugget when w is NULL + replicates <- NULL # the record of the step below, for the result + # The two parts of the nugget, as the plain mean's variance below needs + # them: `micro` is shared by every observation at a location, `me` differs + # from one observation to the next. With one observation per location the + # two cannot be told apart and do not need to be: the nugget is then that + # observation's own. + micro <- nugget + me <- 0 if (any(!first)) { m_loc <- tabulate(loc) kk$..z <- as.numeric(rowsum(kp$..z, loc)) / m_loc - me <- min(sum((kp$..z - kk$..z[loc])^2) / sum(m_loc - 1L), nugget) - err_var <- nugget - me + me / m_loc + # The replicates' own estimate of what differs between visits. It used to + # be capped at the nugget, the most the model lets replicates differ by: + # 40 stations visited twice with a replicate variance of 0.09, under a + # model with no nugget, were reported as "0 of 0" and kriged as exact + # (CV z-variance 1.61, where the uncapped variance below gives 1.32). The + # replicates measure the variance between visits directly, so it is used + # as it is; what the nugget holds beyond it is the micro-scale part, and + # when the replicates exceed the nugget that part is zero. The rule is + # continuous where the two meet: adding the replicate variance on top of + # the whole nugget instead would take a mean of three from c0 / 3 to + # c0 + c0 / 3 as the replicate variance crosses c0. + df_w <- sum(m_loc - 1L) + sw2 <- sum((kp$..z - kk$..z[loc])^2) / df_w + me <- sw2 + micro <- max(nugget - sw2, 0) + above <- is.finite(sw2) && sw2 > nugget + 1e-8 * sill + err_var <- micro + me / m_loc vk$psill[fam == "Nug"] <- 0 w <- 1 / err_var - .warn_and_log(paste0("kriging_adequacy(): %d point(s) share a location with another; ", - "kriging from the mean at each of the %d distinct locations, with ", - "the part of the nugget that differs between replicates (%.3g of ", - "%.3g) divided by their count."), - sum(m_loc[loc] > 1L), nrow(kk), me, nugget) + n_rep <- sum(m_loc[loc] > 1L) + replicates <- list(n_points = n_rep, within_var = sw2, df = as.integer(df_w), + nugget = nugget, nugget_used = max(nugget, sw2), + above_nugget = above) + if (above) + .warn_classed("spatialkit_replicate_var_above_nugget", paste0( + "kriging_adequacy(): %d point(s) share a location with another; ", + "kriging from the mean at each of the %d distinct locations. Their ", + "pooled within-location variance is %.3g (%d degrees of freedom), ", + "above the variogram's nugget of %.3g, so the model has less room than ", + "the replicates show between visits. The replicate variance is used ", + "as the measurement-error variance: a location seen m times is kriged ", + "with error variance %.3g / m, a nugget of %.3g for a location seen ", + "once, and kr_var, plain_var and the cross-validation statistic are ", + "computed with it. Refit the variogram with a nugget of at least %.3g ", + "so the model says the same; attr(, \"replicates\") records both ", + "numbers."), + n_rep, nrow(kk), sw2, as.integer(df_w), nugget, sw2, sw2, sw2, + data = list(within_var = sw2, nugget = nugget)) + else + .warn_and_log(paste0("kriging_adequacy(): %d point(s) share a location with another; ", + "kriging from the mean at each of the %d distinct locations, with ", + "the part of the nugget that differs between replicates (%.3g of ", + "%.3g) divided by their count."), + n_rep, nrow(kk), me, nugget) } # summarize_by_cell()'s conversion: as.character() writes a double from 1e5 @@ -535,11 +705,44 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, # divided by the sill, an empty cell far from every datum read about 0.1, # and a large empty cell ranked below small populated ones. Not computed # for a sliver, whose discretisation is what it was left out to avoid. - prior_var <- rep(NA_real_, nrow(cells)) - if (any(!sliver)) - prior_var[!sliver] <- .block_prior_var(cells[!sliver, , drop = FALSE], vm) + # + # And the plain mean's own error variance under the same model, plain_var: + # what kr_var has to be set against to say what kriging buys in a cell. + # kr_var used to be compared with s^2/n, the variance the plain mean would + # have if the cell's points were independent draws, as `kr_exceeds_design`. + # That flag was read as marking cells where kriging does not pay, and it + # does not: against known cell averages kriging cut the error by 20-53% in + # flagged cells and 27-60% in the rest. It was not on one footing either, + # one variance from the model and one from the cell's own spread: the same + # data with identical kriged estimates flagged 4, 27 and 67 of 70 cells as + # the sill went x1/3, x1 and x3. Both variances now come from the one + # variogram and the one discretisation of the cell. Computed for the cells + # that are kriged and hold a point; the cells left out are left out of + # this as well (a sliver for its discretisation, an oversized cell for the + # pairs of its own locations). + xy_loc <- xy[first, , drop = FALSE] + rows_of <- split(seq_len(nrow(kp)), + factor(match(ids_pts, ids_cells), levels = seq_len(nrow(cells)))) + own_pts <- vector("list", nrow(cells)) + for (ci in which(kriged & lengths(rows_of) > 0L)) { + l <- loc[rows_of[[ci]]] + u <- unique(l) + cnt <- tabulate(match(l, u), nbins = length(u)) + # A location's `cnt` observations in the cell share its micro-scale part + # and average their own measurement errors: the error variance the + # kriging gives a mean of that many, and the whole nugget for one + # observation at a location seen once. + own_pts[[ci]] <- list(xy = xy_loc[u, , drop = FALSE], a = cnt / length(l), + e = micro + me / cnt) + } + prior_var <- plain_var <- rep(NA_real_, nrow(cells)) + if (any(!sliver)) { + bv <- .block_model_vars(cells[!sliver, , drop = FALSE], vm, own_pts[!sliver]) + prior_var[!sliver] <- bv$prior + plain_var[!sliver] <- bv$plain + } - # --- the plain means and their design-based variance, per cell --- + # --- the plain means and their naive standard error, per cell --- n_c <- as.integer(table(factor(ids_pts, levels = ids_cells))) m_c <- tapply(kp$..z, factor(ids_pts, levels = ids_cells), mean) v_c <- tapply(kp$..z, factor(ids_pts, levels = ids_cells), stats::var) @@ -551,11 +754,29 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, out$n <- n_c out$mean <- as.numeric(m_c) out$se <- se_c + out$plain_var <- plain_var out$kr_pred <- kr_pred out$kr_var <- kr_var out$kr_ratio <- ifelse(prior_var > 0, pmin(pmax(kr_var / prior_var, 0), 1), NA_real_) - out$kr_exceeds_design <- ifelse(is.finite(s2_n), kr_var > s2_n, NA) - out$kr_shift <- ifelse(is.finite(se_c) & se_c > 0, (kr_pred - out$mean) / se_c, NA_real_) + # The share of the plain mean's error variance that kriging removes. gstat's + # block variance and the same variance written out here agree to about + # 2e-6 of their size, so a gain within a ten-thousandth below 0 is 0. + gain <- ifelse(is.finite(plain_var) & plain_var > 0, 1 - kr_var / plain_var, NA_real_) + gain[is.finite(gain) & gain < 0 & gain > -1e-4] <- 0 + out$kr_gain <- gain + # The kriged estimate minus the plain mean, over the standard deviation the + # model gives that difference. The kriging error is uncorrelated with any + # difference of two unbiased combinations of the neighbourhood's data, so + # Var(plain - truth) = Var(kriged - truth) + Var(kriged - plain), and the + # difference has variance plain_var - kr_var. Over s/sqrt(n), as it was, + # its variance on clustered layouts ran 1.4-8.4 against a nominal 1, so + # the printed count of shifts beyond 2 reached 40% of cells where 3% is + # the figure on the model's own scale. Not defined where the two + # variances agree to within a ten-thousandth, which is where kriging + # returns the plain mean and both terms of the ratio are rounding error. + shift_var <- plain_var - kr_var + out$kr_shift <- ifelse(is.finite(shift_var) & shift_var > 1e-4 * plain_var, + (kr_pred - out$mean) / sqrt(pmax(shift_var, 0)), NA_real_) out$kr_n_used <- nb$n_used @@ -623,6 +844,7 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, cv = cv, nmax = as.integer(nmax), n_points = nrow(kp), n_locations = nrow(kk), cells_left_out = c(shape = sum(sliver), size = sum(nb$too_big)), + replicates = replicates, response_var = response_var, class = c("kriging_adequacy", class(out))) } @@ -720,31 +942,86 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, } -#' The variance each cell's mean has with no data, \eqn{\bar C(B,B)} +#' Two variances of a cell's mean under the variogram, on one discretisation +#' +#' \code{prior} is the variance each cell's mean has with no data, +#' \eqn{\bar C(B,B)}: the covariance averaged over all pairs of points of the +#' cell, on the discretisation gstat's predict() gives a polygon (its default +#' `sps.args`: spsample(n = 500, type = "regular", offset = c(0.5, 0.5))), +#' and without the nugget, which gstat leaves out of block-to-block +#' covariances. This is the block-kriging variance of a cell no datum +#' informs, before ordinary kriging adds the variance of the estimated mean. +#' 0 for a pure nugget. +#' +#' \code{plain} is the error variance of the plain mean of the cell's own +#' observations as an estimate of the cell's average: with the cell's +#' locations \eqn{p_l}, the share \eqn{a_l} of the cell's observations at +#' each, and the error variance \eqn{e_l} of the mean of those (the nugget +#' for one observation; see the caller for replicates), +#' \deqn{V = \sum_{l,l'} a_l a_{l'} C(p_l - p_{l'}) + \sum_l a_l^2 e_l +#' - 2 \sum_l a_l \bar C(p_l, B) + \bar C(B,B),} +#' with \eqn{C} the covariance without the nugget, which sits on the data +#' diagonal only, as gstat block-kriges it. The plain mean is one unbiased +#' linear combination of the data in the cell's kriging neighbourhood, and +#' ordinary kriging is the best of them, so the block-kriging variance of a +#' cell never exceeds this. Both come from the same 500 points. #' -#' The covariance averaged over all pairs of points of the cell, on the -#' discretisation gstat's predict() gives a polygon (its default `sps.args`: -#' spsample(n = 500, type = "regular", offset = c(0.5, 0.5))), and without -#' the nugget, which gstat leaves out of block-to-block covariances. This is -#' the block-kriging variance of a cell no datum informs, before ordinary -#' kriging adds the variance of the estimated mean. 0 for a pure nugget. +#' @param cells The cells (none of them a sliver). +#' @param vm The variogram model frame. +#' @param own Optional list, one entry per cell: \code{NULL} for a cell +#' whose plain variance is not wanted, else a list with \code{xy} (a +#' two-column matrix of the cell's distinct locations), \code{a} (their +#' weights in the plain mean, summing to 1) and \code{e} (their error +#' variances). +#' @return A list with \code{prior} and \code{plain}, one value per cell; +#' \code{plain} is \code{NA} where \code{own} gives nothing. #' @keywords internal #' @noRd -.block_prior_var <- function(cells, vm) { +.block_model_vars <- function(cells, vm, own = NULL) { + nc <- nrow(cells) sv <- vm[as.character(vm$model) != "Nug", , drop = FALSE] c0 <- sum(sv$psill) - if (!nrow(sv) || !(c0 > 0)) return(rep(0, nrow(cells))) + structured <- nrow(sv) > 0L && isTRUE(c0 > 0) + has_own <- if (is.null(own)) rep(FALSE, nc) else !vapply(own, is.null, logical(1)) + prior <- rep(0, nc) + plain <- rep(NA_real_, nc) + # A pure nugget: no covariance between distinct places, so a cell mean has + # no prior variance and the plain mean's error is its data's own. + if (!structured) { + for (i in which(has_own)) plain[i] <- sum(own[[i]]$a^2 * own[[i]]$e) + return(list(prior = prior, plain = plain)) + } + covf <- function(d) gstat::variogramLine(sv, dist_vector = d, covariance = TRUE)$gamma + # sum_ij wa_i wb_j C(|A_i - B_j|), a block of rows at a time so a cell of + # thousands of locations does not hold all its pairs at once. + wsum <- function(A, wa, B, wb) { + step <- max(1L, as.integer(2e6 %/% nrow(B))) + tot <- 0 + for (s in seq(1L, nrow(A), by = step)) { + i <- s:min(nrow(A), s + step - 1L) + d <- sqrt(outer(A[i, 1L], B[, 1L], "-")^2 + outer(A[i, 2L], B[, 2L], "-")^2) + cv <- matrix(covf(as.numeric(d)), nrow = length(i)) + tot <- tot + sum(wa[i] * as.numeric(cv %*% wb)) + } + tot + } geo <- sf::as_Spatial(sf::st_set_crs(sf::st_geometry(cells), sf::NA_crs_)) - vapply(seq_along(geo), function(i) { + for (i in seq_len(nc)) { g <- sp::coordinates(sp::spsample(geo[i], n = 500, type = "regular", offset = c(0.5, 0.5))) m <- nrow(g) - if (m < 2L) return(c0) - # Each pair once from dist(), both orders, plus the m zero-distance pairs. - cv <- gstat::variogramLine(sv, dist_vector = as.numeric(stats::dist(g)), - covariance = TRUE)$gamma - (2 * sum(cv) + m * c0) / m^2 - }, numeric(1)) + prior[i] <- if (m < 2L) c0 else { + # Each pair once from dist(), both orders, plus the m zero-distance pairs. + cv <- covf(as.numeric(stats::dist(g))) + (2 * sum(cv) + m * c0) / m^2 + } + if (has_own[i] && m >= 1L) { + o <- own[[i]] + plain[i] <- wsum(o$xy, o$a, o$xy, o$a) + sum(o$a^2 * o$e) - + 2 * wsum(o$xy, o$a, g[, 1:2, drop = FALSE], rep(1 / m, m)) + prior[i] + } + } + list(prior = prior, plain = pmax(plain, 0)) } @@ -823,14 +1100,38 @@ print.kriging_adequacy <- function(x, ...) { cat(sprintf(paste0(" kriging variance / no-data variance of the cell mean (1 = nothing ", "from the data): median %.3f, range %.3f-%.3f; %d cell(s) above 0.5\n"), stats::median(r), min(r), max(r), sum(r > 0.5))) - pop <- df[is.finite(df$kr_exceeds_design), , drop = FALSE] - if (nrow(pop)) - cat(sprintf(" kriging variance exceeds s^2/n in %d of the %d cell(s) with two or more points\n", - sum(pop$kr_exceeds_design), nrow(pop))) + # Kriging against the plain mean, both variances from the one variogram. + # A subset or an object from before these columns existed has none. + gn <- df$kr_gain[is.finite(df$kr_gain)] + if (length(gn)) + cat(sprintf(paste0(" kr_gain, the share of the plain mean's error variance that kriging ", + "removes under this variogram (1 - kr_var / plain_var): median %.2f, ", + "range %.2f-%.2f over the %d cell(s) with points and a kriged ", + "estimate\n"), + stats::median(gn), min(gn), max(gn), length(gn))) sh <- df$kr_shift[is.finite(df$kr_shift)] if (length(sh)) - cat(sprintf(" kriged minus plain mean: |shift| > 1 SE in %d of %d cell(s), > 2 SE in %d\n", - sum(abs(sh) > 1), length(sh), sum(abs(sh) > 2))) + cat(sprintf(paste0(" kriged minus plain mean, over the standard deviation the variogram ", + "gives that difference (sqrt(plain_var - kr_var)): |shift| > 1 in %d ", + "of %d cell(s), > 2 in %d (about %.0f and %.0f when the variogram is ", + "right)\n"), + sum(abs(sh) > 1), length(sh), sum(abs(sh) > 2), + 0.317 * length(sh), 0.046 * length(sh))) + # The naive standard error against the same model: s^2/n is the plain + # mean's variance if the cell's points were independent draws. + nv <- (df$se^2 / df$plain_var)[is.finite(df$se) & is.finite(df$plain_var) & + df$plain_var > 0] + if (length(nv)) + cat(sprintf(paste0(" naive s^2/n below plain_var (the naive standard error is too ", + "small if the variogram is right) in %d of the %d cell(s) with two ", + "or more points; median s^2/n over plain_var %.2f\n"), + sum(nv < 1), length(nv), stats::median(nv))) + rp <- attr(x, "replicates") + if (is.list(rp) && isTRUE(rp$above_nugget)) + cat(sprintf(paste0(" replicates: pooled within-location variance %.3g is above the ", + "nugget %.3g and is used as the measurement-error variance, a nugget ", + "of %.3g for a location seen once\n"), + rp$within_var, rp$nugget, rp$nugget_used)) n_empty <- sum(df$n == 0L) n_empty_kr <- sum(df$n == 0L & kr_ok) cat(sprintf(" empty cells: %d (kriged estimate and variance available for %s)\n", @@ -842,6 +1143,7 @@ print.kriging_adequacy <- function(x, ...) { random_kfold = "random k-fold CV", buffered_loo = "buffered leave-one-out CV", nndm = "NNDM leave-one-out CV", + knndm = "kNNDM k-fold CV", leave_location_out = "leave-location-out CV", "CV") if (is.finite(cv$zscore_var %||% NA_real_)) diff --git a/R/level-selection.R b/R/level-selection.R index 236f206a..c1626293 100644 --- a/R/level-selection.R +++ b/R/level-selection.R @@ -301,22 +301,40 @@ #' it says how rough the objective is at this \code{k}, which a profile can #' report so that a flat region is shown at its real width. #' +#' With \code{init = "random"} each restart starts from \code{k} distinct +#' locations drawn at random (\code{.random_centers()}), the draws +#' \code{stats::kmeans(centers = k, nstart = nstart)} makes, so the best of +#' them is the fit that call returns, and their spread is kept as well. +#' #' @param xy Numeric matrix of coordinates. #' @param k Number of clusters (\code{>= 2}). #' @param nstart Number of restarts. #' @param iter.max Passed to \code{stats::kmeans()}. +#' @param init \code{"kmeans++"} (default) or \code{"random"}: how each +#' restart's starting centres are drawn. #' @return \code{NULL} when every restart failed; otherwise a list with #' \code{km} (the best \code{kmeans} fit), \code{wss} (its #' \code{tot.withinss}), \code{spread} (\code{(max - min) / min} of #' \code{tot.withinss} across the restarts that ran) and \code{n_ok}. #' @keywords internal #' @noRd -.kmeans_best <- function(xy, k, nstart = 25L, iter.max = 50L) { +.kmeans_best <- function(xy, k, nstart = 25L, iter.max = 50L, init = "kmeans++") { best <- NULL; w <- rep(NA_real_, nstart) + random <- identical(init, "random") + # The distinct rows random starts are drawn from, found once. Fewer of + # them than centres is what stats::kmeans() refuses as "more cluster + # centers than distinct data points". + cn <- if (random) unique(xy) else NULL + if (random && nrow(cn) < k) return(NULL) for (r in seq_len(nstart)) { - km <- try(suppressWarnings(stats::kmeans(xy, centers = .kmeanspp_centers(xy, k), - iter.max = iter.max, nstart = 1L)), - silent = TRUE) + km <- if (random) + try(suppressWarnings(stats::kmeans(xy, centers = .random_centers(xy, cn, k, nstart), + iter.max = iter.max, nstart = 1L)), + silent = TRUE) + else + try(suppressWarnings(stats::kmeans(xy, centers = .kmeanspp_centers(xy, k), + iter.max = iter.max, nstart = 1L)), + silent = TRUE) if (inherits(km, "try-error")) next w[r] <- km$tot.withinss if (is.null(best) || km$tot.withinss < best$tot.withinss) best <- km @@ -379,28 +397,60 @@ #' @param predictors Numeric matrix of predictor values. #' @param cluster_ids Integer vector of cluster assignments. The cluster count #' is derived from this vector, so it is not passed separately. +#' @param grouped Whether the cell means are formed by grouped sums, one pass +#' over the rows for all the cells. \code{FALSE} (default) makes a pass +#' over all the rows for each cell, which costs rows times cells and is +#' quadratic in the rows when the cells are a fixed size. The two give the +#' same means to rounding, so a caller whose numbers are held to the last +#' bit keeps the default. +#' @param use_fnn,use_matrix Whether \pkg{FNN} and \pkg{Matrix} may be used +#' for the neighbour weights of the cell means; handed to +#' \code{.build_knn_weights()}, which stops above \code{.KNN_DENSE_MAX} +#' cells without both. #' @return A named numeric vector \code{c(I = , z = )}: Moran's I on the -#' cell-level OLS residuals, and its standardised deviate. Values of -#' \code{z} near 0 indicate the resolution captures the spatial pattern; -#' positive values indicate residual spatial autocorrelation remains. Both +#' cell-level OLS residuals, and its standardised deviate. With no +#' predictors those residuals are the centred cell means, so this is the +#' autocorrelation among the cell means: a \code{z} near 0 says that +#' neighbouring cell means are unrelated, which happens when the cells are +#' as wide as the range of the field or wider (and at about 10 to 20 cells +#' whatever the data, where the 8-neighbour graph is close to complete), +#' and a positive \code{z} that neighbouring cells resemble each other, +#' which they do more and more as the cells get finer than the range. It +#' is not a measure of the structure the cells leave unexplained. Both #' are \code{NA_real_} when the statistic is not computable at this \code{k}. #' @keywords internal #' @noRd -.morans_i_for_k <- function(xy, response, predictors, cluster_ids) { +.morans_i_for_k <- function(xy, response, predictors, cluster_ids, grouped = FALSE, + use_fnn = .has_backend("FNN"), + use_matrix = .has_backend("Matrix")) { # Aggregate to cell-level means cell_ids <- sort(unique(cluster_ids)) n_cells <- length(cell_ids) if (n_cells < 4L) return(.morans_na()) - cell_resp <- numeric(n_cells) - cell_xy <- matrix(0, n_cells, 2) - cell_pred <- matrix(0, n_cells, ncol(predictors)) + if (isTRUE(grouped)) { + # The means of the loop below from one pass over the rows: sums by cell + # over counts by cell. A missing response is left out of its cell's mean, + # as mean(na.rm = TRUE) leaves it out, and a cell with none gets NaN. + g <- match(cluster_ids, cell_ids) + cnt <- tabulate(g, nbins = n_cells) + seen <- !is.na(response) + cell_resp <- as.numeric(rowsum(ifelse(seen, response, 0), g)) / + as.numeric(rowsum(as.numeric(seen), g)) + cell_xy <- unname(rowsum(xy[, 1:2, drop = FALSE], g)) / cnt + cell_pred <- if (ncol(predictors)) unname(rowsum(predictors, g)) / cnt + else matrix(0, n_cells, 0L) + } else { + cell_resp <- numeric(n_cells) + cell_xy <- matrix(0, n_cells, 2) + cell_pred <- matrix(0, n_cells, ncol(predictors)) - for (j in seq_along(cell_ids)) { - mask <- cluster_ids == cell_ids[j] - cell_resp[j] <- mean(response[mask], na.rm = TRUE) - cell_xy[j, ] <- colMeans(xy[mask, , drop = FALSE]) - cell_pred[j, ] <- colMeans(predictors[mask, , drop = FALSE]) + for (j in seq_along(cell_ids)) { + mask <- cluster_ids == cell_ids[j] + cell_resp[j] <- mean(response[mask], na.rm = TRUE) + cell_xy[j, ] <- colMeans(xy[mask, , drop = FALSE]) + cell_pred[j, ] <- colMeans(predictors[mask, , drop = FALSE]) + } } # Fit OLS on cell means @@ -430,7 +480,8 @@ # to the geometric ranking when none of them clears the floor. if (n <= n_neighbors + 1L) return(.morans_na()) - W <- .build_knn_weights(cell_xy[ok, , drop = FALSE], k = n_neighbors) + W <- .build_knn_weights(cell_xy[ok, , drop = FALSE], k = n_neighbors, + use_fnn = use_fnn, use_matrix = use_matrix) # Moran's I = (n / S0) * (e' W e) / (e' e) S0 <- sum(W) @@ -494,8 +545,14 @@ #' triangles, an L-shape, density gradients and jittered lattices sagged at #' most 0.16, and two to ten separated clusters at least 0.6 once #' \code{max_levels} passed the cluster count. With no elbow the function -#' warns and returns the linear-axis answer, which the ladder chose, not the -#' data. An elongated extent also bends, at about its aspect ratio, because +#' warns (a warning of class \code{spatialkit_no_elbow}, which carries the +#' count as \code{k} and the largest sag as \code{sag}) and returns the +#' linear-axis answer, which the ladder chose, not the data: about +#' \eqn{\sqrt{K_{max}}}, 3 or 4 cells at the default, close to one mean for +#' the whole layer. \code{on_no_elbow = "na"} returns \code{NA} there and +#' \code{"error"} stops, so that a count which is not a finding is not +#' passed on as one. An elongated extent also bends, at about its aspect +#' ratio, because #' the first cuts go across its long axis (0.2--0.45 for a 4:1 rectangle); #' past the threshold that bend is reported as an elbow, and it describes #' the extent's shape rather than clusters in it. When locations repeat @@ -506,13 +563,35 @@ #' curve has no elbow, the number of distinct locations is the elbow. #' #' When \code{response_var} and \code{predictor_vars} are provided, the -#' geometric WSS elbow is supplemented with Moran's I computed on OLS -#' residuals at each candidate k. The Moran's I profile measures how much -#' spatial autocorrelation in the response remains *unexplained* at a given -#' tessellation resolution. It is a direct reflection of the spatial process -#' being modeled instead of the mere geometric compactness of coordinates. -#' The combined criterion selects the k that best balances geometric parsimony -#' and residual spatial independence. +#' geometric WSS elbow is supplemented with Moran's I of the cell means at +#' each candidate k: the cell means are regressed on the cell-mean +#' predictors (on an intercept alone when \code{criterion = "morans_i"} or +#' \code{"combined"} is asked for with a response and no predictors) and +#' Moran's I is computed on the residuals over each cell's 8 nearest cells. +#' That statistic tests whether \emph{neighbouring cells} are independent. +#' It does not measure the autocorrelation the cells leave unexplained in +#' the response, and it does not say how well they represent it: on an +#' autocorrelated response it grows as the cells get finer than the range, +#' because neighbouring cells then resemble each other, and it is close to 0 +#' at about 10 to 20 cells whatever the data, where the neighbour graph is +#' nearly complete. The model-aware criteria prefer the candidate with the +#' smallest \eqn{|z|}, which is the count at which neighbouring cell means +#' stop resembling each other, cells about as wide as the range. Only the +#' elbow's neighbourhood is scored, so the response moves the answer by at +#' most a few cells either side of the geometric elbow. \strong{A ranking +#' that Moran's z took part in is a ranking by a diagnostic, not by a count +#' rule}, and it is returned with a warning of class +#' \code{spatialkit_diagnostic_ranking} that says so and gives the count +#' ranked first, the first count the statistic could be computed at and the +#' counts scored. Measured on 500 points with a response alone and +#' \code{criterion = "morans_i"}: the first-ranked count was 10 to 13 on 16 +#' of 16 white-noise layers and on 16 of 16 exponential fields +#' (\code{max_levels} 40 and 80), and 10 was the first count the statistic +#' could be computed at on all 32. \code{\link{select_resolution}()} +#' refuses the same statistic unless asked with \code{diagnostic = TRUE}; +#' here the criterion is asked for by name, or taken when both model +#' variables are supplied, so the count is returned and the warning carries +#' the caveat. #' #' To keep memory use and runtime bounded for large \code{max_levels}, the #' initial k-means sweep records only within-cluster sum-of-squares (WSS) @@ -541,6 +620,14 @@ #' version on a curve that had such a bump can differ from the one made now; #' where the earlier curve was clean, the selection is the same. #' +#' \strong{The sweep is plain k-means, whatever the regions are built with +#' afterwards.} This function has no \code{partition} argument: the elbow is +#' a reading of the sum of squares that plain k-means minimises, and the +#' cells behind Moran's z are that partition's. A count returned here says +#' nothing about density-weighted regions; +#' \code{\link{resolution_profile}()}, whose regions are of that kind by +#' default, scores counts of those. +#' #' \strong{The model-aware criteria rank on the standardised deviate, not on #' |Moran's I|.} Both \eqn{E[I]} and \eqn{Var[I]} depend on the number of #' cells, so \eqn{|I|} falls as \code{k} grows whether or not the finer @@ -620,8 +707,9 @@ #' coordinate order before either, so the answer does not depend on the #' order they come in. #' @param response_var Optional response column name. When provided alongside -#' \code{predictor_vars}, enables model-aware level selection via Moran's I -#' on OLS residuals. Must be numeric or logical (logicals are read as 0/1); +#' \code{predictor_vars}, or with \code{criterion = "morans_i"} or +#' \code{"combined"}, enables model-aware level selection via Moran's I +#' of the cell means. Must be numeric or logical (logicals are read as 0/1); #' a factor or character response raises an error and is never coerced, #' because the residuals of an OLS fit to arbitrary level codes carry no #' meaning to test for autocorrelation. Rows where it, or a predictor, is @@ -629,29 +717,60 @@ #' out of Moran's I; a logged warning gives their number. #' @param predictor_vars Optional predictor column names. Must be numeric or #' logical (logicals are read as 0/1); factor/character columns raise an -#' error. +#' error. Without them the model-aware criteria regress the cell means on +#' an intercept alone, as \code{\link{resolution_profile}()} does. #' @param criterion One of \code{"geometric"} (default when no response given), -#' \code{"morans_i"} (select the k whose residual Moran's I is least -#' \emph{significant}), or \code{"combined"} (rank-average of the WSS +#' \code{"morans_i"} (among the candidates around the elbow, the k at which +#' Moran's I of the cell means, or of their regression residuals, is least +#' \emph{significant}: the count at which neighbouring cells stop +#' resembling each other, not the count that represents the response +#' best), or \code{"combined"} (rank-average of the WSS #' curve's log-log sag, the quantity the elbow is read from, and that same -#' significance). Falls back to \code{"geometric"}, -#' with a warning, when \code{response_var} or \code{predictor_vars} is not +#' significance). Whenever Moran's z orders the candidates returned, +#' under either, a warning of class +#' \code{spatialkit_diagnostic_ranking} says that the ranking is by a +#' diagnostic of the cell means; its condition carries \code{k} (the +#' count ranked first), \code{criterion}, \code{first_computable} (the +#' first count at which the statistic is finite), \code{window} +#' (the first and last count tried) and \code{upgraded} (whether +#' \code{"combined"} was taken because both model variables were +#' supplied). Falls back to \code{"geometric"}, +#' with a warning, when \code{response_var} is not #' given, and with a logged warning when no candidate clears the #' nine-cell resolution floor described in \strong{Details}. A #' \code{response_var} or \code{predictor_vars} naming a column that is not #' in \code{data_sf} is an error. Supplying #' both \code{response_var} and \code{predictor_vars} upgrades #' \code{"geometric"} to \code{"combined"}: the selection then depends on -#' the response (see "Post-selection inference"). +#' the response (see "Post-selection inference"). A \code{response_var} +#' alone leaves \code{"geometric"} as it is. #' @param select_on \code{"all"} (default) selects on every point; #' \code{"split"} reads the response on one spatially blocked half of the #' points only and returns the other half as the set to estimate on, so #' that the standard errors computed downstream on the chosen cells are not #' post-selection. The count is still chosen for the whole layer. See #' "Post-selection inference". +#' @param on_no_elbow What to do when the count is not a finding about the +#' data: the WSS curve has no elbow, the ladder is too short to show one, +#' or there are too few points or locations for a ladder at all. +#' \code{"warn"} (default) returns the count the chord rule or the ladder +#' gives, with a warning of class \code{spatialkit_no_elbow} whose +#' condition carries \code{k} (that count), \code{sag} (the largest +#' log-log sag of the curve; an elbow needs \eqn{\log 1.25}) and +#' \code{structured = FALSE}, so a caller can catch it without matching +#' the message. \code{"na"} returns \code{NA_integer_} there and logs the +#' reason, and every result under \code{"na"} carries the attributes +#' \code{structured} (\code{FALSE} with the \code{NA}, \code{TRUE} with a +#' count the elbow chose) and \code{sag}, so one test of +#' \code{attr(k, "structured")} covers both outcomes; +#' \code{"error"} stops with an error of that class. Under the +#' model-aware criteria the candidates are scored around the elbow, so +#' with no elbow the ladder places that window and the same applies. #' @section Post-selection inference: -#' When the selection reads the response (here, whenever both -#' \code{response_var} and \code{predictor_vars} are supplied), everything +#' When the selection reads the response (here, whenever a model-aware +#' criterion runs: both \code{response_var} and \code{predictor_vars} +#' supplied, or \code{"morans_i"} or \code{"combined"} asked for with a +#' response), everything #' estimated afterwards on the chosen cells is estimated on data that already #' influenced the choice, and its standard errors are post-selection ones: #' descriptive, not at nominal coverage (Gao, Bien and Witten 2022; Chen and @@ -701,9 +820,17 @@ #' and read inferential results only off cells whose points all are. #' @return An integer vector of candidate level counts, \strong{best first}: #' under the geometric criterion the elbow, then its lower and upper -#' neighbours (with a warning when the WSS curve has no elbow and the first -#' is the ladder's choice; see Details); under the model-aware criteria the -#' candidates in rank order. +#' neighbours (with a warning of class \code{spatialkit_no_elbow} when the +#' WSS curve has no elbow and the first is the ladder's choice, or +#' \code{NA_integer_} under \code{on_no_elbow = "na"}, where the result +#' also carries the attributes \code{structured} and \code{sag}; see +#' Details); under the model-aware +#' criteria the candidates in rank order, with a warning of class +#' \code{spatialkit_diagnostic_ranking} when Moran's z took part in the +#' ranking. A layer with no points is an +#' error, and one with fewer than three points, or with every point on +#' one location, has no ladder: it returns 1 under the same +#' \code{on_no_elbow} rule. #' \code{k[1]} is therefore the top-ranked count on every path, and #' \code{top_n = 1} returns it alone. When #' \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is @@ -712,7 +839,9 @@ #' the relative between-restart spread at each \code{k} (\code{wss_spread}), #' the number of rising steps on it (\code{wss_bumps}), the restart #' budget (\code{nstart}), the geometric elbow the evaluated -#' neighbourhood was drawn around (\code{knee_k}), the \code{k} at which +#' neighbourhood was drawn around (\code{knee_k}), whether the WSS curve +#' has an elbow (\code{structured}) and its largest log-log sag +#' (\code{sag}), the \code{k} at which #' k-means failed (\code{failed_k}; their \code{wss} entries are #' interpolated from the neighbours, not measured) and the \code{k} the #' model-aware pass actually scored (\code{eval_ks}, the elbow's @@ -788,12 +917,18 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, predictor_vars = NULL, criterion = c("geometric", "morans_i", "combined"), - select_on = c("all", "split")) { + select_on = c("all", "split"), + on_no_elbow = c("warn", "na", "error")) { if (!inherits(data_sf, "sf")) stop("determine_optimal_levels(): `data_sf` must be an sf object.") criterion <- match.arg(criterion) select_on <- match.arg(select_on) + on_no_elbow <- match.arg(on_no_elbow) + # A layer with no rows used to return 1, a cell count for nothing. + if (nrow(data_sf) == 0L) + stop("determine_optimal_levels(): `data_sf` has no rows, so there is no layer to ", + "choose a cell count for.", call. = FALSE) # A named column that is not there is an error, as it is in # resolution_profile(). It used to count as "no model variables": a typo # in response_var silently kept the geometric criterion that supplying both @@ -812,25 +947,31 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, if (length(missing_p)) stop("determine_optimal_levels(): predictor_vars ", paste(sQuote(missing_p, FALSE), collapse = ", "), " not found.", call. = FALSE) - has_model_vars <- !is.null(response_var) && !is.null(predictor_vars) - - # Auto-upgrade to combined when model variables are available - if (has_model_vars && criterion == "geometric") { + # Auto-upgrade to combined when both model variables are available + upgraded <- FALSE + both_given <- !is.null(response_var) && !is.null(predictor_vars) + if (both_given && criterion == "geometric") { criterion <- "combined" + upgraded <- TRUE .log_info("determine_optimal_levels(): response_var and predictor_vars supplied; using combined criterion (geometric + Moran's I).") } - # Fall back if model variables not available for model-aware criteria. A + # Fall back when a model-aware criterion has no response to read. A # warning, not a log line: the caller asked for a criterion and gets another. - if (!has_model_vars && criterion != "geometric") { - .warn_and_log(paste0("determine_optimal_levels(): criterion = '%s' needs both ", - "response_var and predictor_vars, and %s not given; falling ", - "back to geometric."), + # A response without predictors is enough: .morans_i_for_k() regresses the + # cell means on an intercept alone, as resolution_profile() has it do, and + # a caller who asked for "morans_i" with a response used to be told it + # "needs both" and handed the geometric ranking. + if (is.null(response_var) && criterion != "geometric") { + .warn_and_log(paste0("determine_optimal_levels(): criterion = '%s' needs a ", + "response_var, and none was given%s; falling back to geometric."), criterion, - if (is.null(response_var) && is.null(predictor_vars)) "neither was" - else if (is.null(response_var)) "response_var was" - else "predictor_vars were") + if (is.null(predictor_vars)) "" else " (predictor_vars alone score nothing)") criterion <- "geometric" } + # The model-aware pass runs whenever a model-aware criterion stands, with + # the predictors given or with none. + has_model_vars <- criterion != "geometric" + if (has_model_vars && is.null(predictor_vars)) predictor_vars <- character(0) # MULTIPOINT must be coerced too, not merely admitted: st_coordinates() # returns one row per VERTEX, so any multi-vertex feature makes xy[i, ] a @@ -878,13 +1019,52 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # half's extent and clusters (2 where the layer has 4) was then applied # to the whole layer. } + # `found` is set once the elbow has been read, under on_no_elbow = "na": + # the result then carries `structured` and `sag` whichever way it went, so + # one test of attr(, "structured") covers both. + found <- NULL .with_split <- function(out) { if (!is.null(split)) attr(out, "split") <- split + if (!is.null(found)) { + attr(out, "structured") <- found$structured + attr(out, "sag") <- found$sag + } out } + # A count that is not a finding about the data: what the caller is told, + # and what is returned, under `on_no_elbow`. The warning carries a class + # and the numbers: code that runs this over many layers could otherwise + # tell such a count from an elbow only by matching the message. Returns + # NULL when the caller goes on to return the count ("warn"), or the value + # to return ("na"). + .not_a_finding <- function(k, sag, fmt, ...) { + msg <- sprintf(fmt, ...) + fields <- list(k = as.integer(k), sag = as.numeric(sag), structured = FALSE) + if (identical(on_no_elbow, "error")) + stop(do.call(errorCondition, + c(list(message = msg, class = "spatialkit_no_elbow", call = NULL), fields))) + if (identical(on_no_elbow, "na")) { + .log_warn("%s Returning NA (on_no_elbow = \"na\").", msg) + return(.with_split(structure(NA_integer_, structured = FALSE, sag = as.numeric(sag)))) + } + .warn_classed("spatialkit_no_elbow", "%s", msg, data = fields) + NULL + } + n <- nrow(xy) - if (n < 3L) return(.with_split(1L)) + if (n < 1L) + stop("determine_optimal_levels(): no point of `data_sf` has coordinates, so there ", + "is no layer to choose a cell count for.", call. = FALSE) + # One or two points used to return 1 with nothing said. + if (n < 3L) { + na <- .not_a_finding(1L, NA_real_, + paste0("determine_optimal_levels(): %d point%s too few for a ", + "ladder of cell counts (it takes three). k = 1 is not a ", + "finding about the data."), + n, if (n == 1L) " is" else "s are") + return(if (is.null(na)) .with_split(1L) else na) + } cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) @@ -977,7 +1157,14 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # thirty times each could not reach k = 5. n_uniq <- nrow(unique(round(xy, 8))) k_max <- min(k_max, n_uniq) - if (k_max < 2L) return(.with_split(1L)) + if (k_max < 2L) { + na <- .not_a_finding(1L, NA_real_, + paste0("determine_optimal_levels(): the %d points sit on %d ", + "distinct location, so there is no ladder of cell counts. ", + "k = 1 is not a finding about the data."), + nrow(xy), n_uniq) + return(if (is.null(na)) .with_split(1L) else na) + } # Which bound ended the ladder, for the messages below: they used to name # max_levels whatever did, and on five stations at max_levels = 12 it was # the stations. @@ -1006,6 +1193,10 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # WSS curve is read for its shape, and optimisation noise on it is what # produced the concave bump the elbow rule once selected. See # .kmeans_best() for the measured effect and the citations. + # The sweep is plain k-means, the kind "kmeans" of .partition_centres(), + # from k-means++ starts: the elbow is a reading of the sum of squares that + # kind minimises. resolution_profile(partition = "density") is where a + # density-weighted partition is scored. nstart <- 25L wss <- numeric(k_max) wss_spread <- numeric(k_max) @@ -1018,7 +1209,8 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, } else { # Assignments are discarded on purpose: only the WSS is kept from this # sweep, which bounds memory for large max_levels (see Details). - kb <- .kmeans_best(xy, k, nstart = nstart) + kb <- .partition_centres(xy, k, partition = "kmeans", init = "kmeans++", + nstart = nstart) if (is.null(kb)) { wss[k] <- wss[k - 1L] failed_k <- c(failed_k, k) @@ -1043,7 +1235,13 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, } wss[fk] <- (wss[lo] + wss[hi]) / 2 } - if (k_max < 2L) return(.with_split(1L)) + if (k_max < 2L) { + na <- .not_a_finding(1L, NA_real_, + paste0("determine_optimal_levels(): k-means failed at every k ", + "from 2, so there is no ladder of cell counts. k = 1 is ", + "not a finding about the data.")) + return(if (is.null(na)) .with_split(1L) else na) + } } elbow <- .elbow_from_wss(wss, max_k = k_max, min_k = 1L, return_neighbors = TRUE) @@ -1053,8 +1251,14 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # silently: it used to be handed on as if the data had chosen it. # A ladder of two levels has no line to test, and used to be told it fell # in one. + # The largest sag the curve reaches: what an elbow is measured by, and + # reported whether or not it is one. + max_sag <- suppressWarnings(max(elbow$diagnostics$sag, na.rm = TRUE)) + if (!is.finite(max_sag)) max_sag <- NA_real_ + not_found <- NULL if (!isTRUE(elbow$structured) && k_max < 3L) - .warn_and_log(paste0("determine_optimal_levels(): a ladder of k = 1 to %d (ended ", + not_found <- .not_a_finding(elbow$knee_k, max_sag, + paste0("determine_optimal_levels(): a ladder of k = 1 to %d (ended ", "by %s) is too short to read an elbow from: it takes three ", "levels to see a bend. k = %d is not a finding about the ", "data; %s"), @@ -1063,7 +1267,8 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, "raise max_levels to 3 or more." else "choose the count on other grounds.") else if (!isTRUE(elbow$structured)) - .warn_and_log(paste0("determine_optimal_levels(): the WSS curve has no elbow: on ", + not_found <- .not_a_finding(elbow$knee_k, max_sag, + paste0("determine_optimal_levels(): the WSS curve has no elbow: on ", "log-log axes it falls in a straight line, as it does for ", "points with no cluster structure. k = %d is where the chord ", "rule lands on such a curve, set by the ladder (k = 1 to %d, ", @@ -1072,6 +1277,10 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, elbow$knee_k, k_max, k_max_from, if (criterion == "geometric") "" else "; the model-aware criteria are evaluated around it") + # on_no_elbow = "na": NA, with the flag and the sag, in place of the count; + # and the same two attributes on a count the elbow did choose. + if (!is.null(not_found)) return(not_found) + if (identical(on_no_elbow, "na")) found <- list(structured = TRUE, sag = max_sag) # A WSS curve that rises anywhere is one where some k landed in a worse # optimum than its neighbour, and the elbow read from it is partly noise. @@ -1121,7 +1330,8 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, moran_z <- rep(NA_real_, k_max) # standardised deviate, used for ranking wss_eval <- wss for (k in eval_ks) { - kb <- .kmeans_best(xy, k, nstart = nstart) + kb <- .partition_centres(xy, k, partition = "kmeans", init = "kmeans++", + nstart = nstart) if (is.null(kb)) next km <- kb$km wss_eval[k] <- km$tot.withinss @@ -1136,6 +1346,54 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # Ranking is on |z|. |I| is not comparable across k -- see .morans_i_for_k(). valid_moran <- is.finite(moran_z[eval_ks]) + # Said, with a class, whenever Moran's z orders the candidates returned. + # It is a diagnostic of the cell means and not a count rule (see Details), + # and select_resolution() refuses the same statistic unless asked with + # `diagnostic = TRUE`. Here the caller asked for the criterion, or got it + # by supplying both model variables, so the count is returned, and what + # ranked it is not left to the help page: with a response alone, + # criterion = "morans_i" returned 10 to 13 cells on 16 of 16 white-noise + # layers and 16 of 16 exponential fields of 500 points, 10 being the first + # count the statistic can be computed at. + .ranked_by_diagnostic <- function(k_first) { + scored <- eval_ks[valid_moran] + .warn_classed( + "spatialkit_diagnostic_ranking", + paste0("determine_optimal_levels(): criterion = '%s'%s ranks the candidates by %s", + "|Moran's z| of %s over each cell's 8 nearest cells. That is a diagnostic ", + "of whether neighbouring cells are independent, not a count rule: |z| is ", + "near 0 at about 10 to 20 cells whatever the response and grows as the ", + "cells get finer than the range, so the smallest |z| does not say how well ", + "the cells represent the response. k = %d is ranked first; the statistic is ", + "computable from k = %d, and the window tried was k = %d to %d. %s for the elbow's ", + "ranking; resolution_profile() with select_resolution(criterion = \"cp\") ", + "reads a count off the response."), + criterion, + if (upgraded) " (taken because `response_var` and `predictor_vars` were both supplied)" + else "", + if (criterion == "morans_i") "" + else if (isTRUE(elbow$structured)) + "the average of two ranks, the WSS curve's sag and " + else "the average of two ranks of which one, the WSS curve's sag, is flat (the curve has no elbow), so in effect by ", + if (ncol(pred_mat) > 0L) + "the residuals of the cell means regressed on the cell-mean predictors" + else "the cell means", + as.integer(k_first), as.integer(min(scored)), + as.integer(min(eval_ks)), as.integer(max(eval_ks)), + # With both model variables "geometric" is read as "combined", so + # there it is the variables that have to go; and when the criterion + # was named as well, leaving a variable out is not enough, because the + # named criterion still ranks by Moran's z. + if (upgraded) "Leave out `response_var` or `predictor_vars`" + else if (both_given) + paste0("Use criterion = \"geometric\" and leave out `response_var` or ", + "`predictor_vars` (with both, \"geometric\" is read as \"combined\")") + else "Use criterion = \"geometric\"", + data = list(k = as.integer(k_first), criterion = criterion, + first_computable = as.integer(min(scored)), + window = as.integer(range(eval_ks)), upgraded = upgraded)) + } + if (!any(valid_moran)) { # A window that ends at nine cells or fewer cannot score anything (see # the resolution floor in Details), and on points with no cluster @@ -1188,12 +1446,15 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, out <- as.integer(head(ranked, max(1L, as.integer(top_n)))) out[out < 1L] <- 1L; out[out > k_max] <- k_max out <- unique(out) + .ranked_by_diagnostic(out[1L]) attr(out, "diagnostics") <- list(moran_i = moran_vals, moran_z = moran_z, wss = wss[1:k_max], wss_spread = wss_spread[1:k_max], wss_bumps = wss_bumps, nstart = nstart, knee_k = knee_k, failed_k = failed_k, - eval_ks = eval_ks) + eval_ks = eval_ks, + structured = isTRUE(elbow$structured), + sag = max_sag) return(.with_split(out)) } @@ -1237,7 +1498,8 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, eval_ks = eval_ks, criterion = "geometric", fallback = sprintf(paste0("the elbow (k = %d) is below the ten cells ", - "Moran's I needs"), knee_k) + "Moran's I needs"), knee_k), + structured = isTRUE(elbow$structured), sag = max_sag ) return(.with_split(out)) } @@ -1270,6 +1532,7 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, out <- as.integer(eval_ks[head(best_idx, max(1L, as.integer(top_n)))]) out[out < 1L] <- 1L; out[out > k_max] <- k_max out <- unique(out) + .ranked_by_diagnostic(out[1L]) attr(out, "diagnostics") <- list( moran_i = moran_vals, moran_z = moran_z, wss = wss[1:k_max], wss_eval = wss_eval[1:k_max], @@ -1281,7 +1544,8 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, knee_k = knee_k, failed_k = failed_k, combined_rank = stats::setNames(combined_rank, eval_ks), eval_ks = eval_ks, - criterion = "combined" + criterion = "combined", + structured = isTRUE(elbow$structured), sag = max_sag ) .with_split(out) } diff --git a/R/model-bayesian.R b/R/model-bayesian.R index bda3333e..07bff8a6 100644 --- a/R/model-bayesian.R +++ b/R/model-bayesian.R @@ -250,16 +250,786 @@ } +# --------------------------------------------------------------------------- +# The automatic slope prior +# --------------------------------------------------------------------------- + +# brms families whose location parameter is on the scale of log(response) +# although they report an identity link. +.brms_log_location_families <- c("lognormal", "shifted_lognormal", + "hurdle_lognormal") + +#' The automatic slope prior for standardised predictors +#' +#' A slope per standard deviation of a predictor is on the scale of the linear +#' predictor. Under an identity link that is the scale of the response, so a +#' fixed \code{normal(0, 5)} is a different prior for every choice of units: +#' it left 98.6 percent of a slope alone with income in thousands of dollars +#' and 0.007 percent of the same slope with income in dollars. The prior is +#' therefore \code{normal(0, 2.5 * s)}, where \code{s} is the standard +#' deviation of whatever the linear predictor is a model of: +#' \itemize{ +#' \item \code{sd(y)} for an identity link (gaussian, student, skew_normal +#' and the like, and mixtures of them); +#' \item \code{sd(log(y))} for the lognormal families, which report an +#' identity link while their location is on the log scale; +#' \item nothing for any other link (log, logit, ...), where the linear +#' predictor has a scale of its own and the fixed \code{normal(0, 5)} +#' stays. +#' } +#' A predictor standardised to unit SD cannot move the response by much more +#' than one SD of the response per SD of its own, so 2.5 of them is weak +#' without being flat. This is the default scaling of \pkg{rstanarm} +#' (Gabry and Goodrich, "Prior Distributions for rstanarm Models"). +#' +#' @param y The response on the training rows. +#' @param family As handed to \code{brms::brm()}. +#' @return A list with \code{spec} (the Stan distribution string), +#' \code{scale} (\code{s}; 1 on the unit scale), \code{basis} +#' (\code{"sd"}, \code{"sd_log"} or \code{"unit"}) and \code{label} (how to +#' say it). +#' @keywords internal +#' @noRd +.b_prior_auto <- function(y, family) { + unit <- list(spec = "normal(0, 5)", scale = 1, basis = "unit", + label = "fixed, on the scale of the link") + fam <- tryCatch({ + f <- family + if (is.function(f)) f <- f() + if (is.character(f)) f <- brms::brmsfamily(f[[1L]]) + f + }, error = function(e) NULL) + if (!is.list(fam)) return(unit) + parts <- if (is.list(fam$mix) && length(fam$mix) > 0L) fam$mix else list(fam) + one <- function(p, nm) { + v <- tryCatch(as.character(p[[nm]])[1L], error = function(e) NA_character_) + if (length(v) != 1L) NA_character_ else v + } + links <- vapply(parts, one, character(1), nm = "link") + fams <- vapply(parts, one, character(1), nm = "family") + if (anyNA(links) || !all(links == "identity")) return(unit) + if (!(is.numeric(y) || is.logical(y))) return(unit) + y <- as.numeric(y) + on_log <- fams %in% .brms_log_location_families + if (all(on_log)) { + v <- y[is.finite(y) & y > 0] + s <- if (length(v) > 1L) stats::sd(log(v)) else NA_real_ + basis <- "sd_log"; label <- "2.5 x SD of the log response" + } else if (!any(on_log)) { + v <- y[is.finite(y)] + s <- if (length(v) > 1L) stats::sd(v) else NA_real_ + basis <- "sd"; label <- "2.5 x SD of the response" + } else { + return(unit) + } + # A constant response has no scale to give. normal(0, 0) passes + # brms::validate_prior() and Stan cannot use it, so fall back to one unit. + if (!is.finite(s) || s <= 0) { + s <- 1; basis <- "unit"; label <- "2.5; the response has no spread" + } + # %.10g, as for the length-scale prior: fixed-point formatting rounds a + # small scale to the literal 0. + list(spec = sprintf("normal(0, %.10g)", 2.5 * s), scale = s, basis = basis, + label = label) +} + + +#' The slope prior brms will use, read back from validate_prior() +#' +#' @param vp The table \code{brms::validate_prior()} returned, or \code{NULL}. +#' @param requested The automatic prior's spec, or \code{NULL} when none was +#' set. +#' @return One string: the class-level \code{b} priors (\code{"(flat)"} for +#' brms's default), then any coefficient-level ones as \code{name: prior}. +#' The requested spec, or \code{"(flat)"}, when \code{vp} cannot be read. +#' @keywords internal +#' @noRd +.b_prior_used <- function(vp, requested = NULL) { + fallback <- if (is.null(requested)) "(flat)" else requested + if (is.null(vp) || !is.data.frame(vp) || + !all(c("class", "coef", "prior") %in% names(vp))) + return(fallback) + is_b <- vp$class == "b" + if (!any(is_b)) return(fallback) + cls <- unique(vp$prior[is_b & !nzchar(vp$coef)]) + cls[!nzchar(cls)] <- "(flat)" + if (!length(cls)) cls <- "(flat)" + own <- is_b & nzchar(vp$coef) & nzchar(vp$prior) + paste(c(unique(cls), + if (any(own)) unique(sprintf("%s: %s", vp$coef[own], vp$prior[own]))), + collapse = "; ") +} + + +# --------------------------------------------------------------------------- +# What the basis resolves, in map units +# --------------------------------------------------------------------------- + +#' The linear unit of a layer's CRS, for a message +#' @keywords internal +#' @noRd +.gp_unit_label <- function(x) { + u <- tryCatch(sf::st_crs(x)$units_gdal, error = function(e) NULL) + if (length(u) != 1L || is.na(u) || !nzchar(u)) "CRS units" else u +} + +#' A distance in map units, for a message +#' @keywords internal +#' @noRd +.gp_fmt_dist <- function(v) { + ifelse(is.finite(v), + format(signif(v, 3), big.mark = ",", scientific = FALSE, trim = TRUE), + "NA") +} + +#' Basis functions per dimension needed to resolve an effective range +#' +#' The inversion of \code{m >= 1.75 * c * S / ell}, with the effective range +#' turned into a length-scale on the axis where it is shortest in scaled +#' units (the one with the larger coordinate SD). +#' +#' @param range Effective range in map units. +#' @param gp_c,S Boundary factor and pooled centred range. +#' @param xy_scale The two coordinate SDs the axes were divided by. +#' @return An integer-valued numeric (not capped). +#' @keywords internal +#' @noRd +.gp_k_needed <- function(range, gp_c, S, xy_scale) { + ell <- (range / .gp_se_range_factor) / max(xy_scale) + ceiling(1.75 * gp_c * S / ell) +} + + +#' Parse the length-scale prior this package sets +#' +#' @param spec A prior string: \code{"inv_gamma(a, b)"} or +#' \code{"normal(0, s)"} (a half-normal, since \code{lscale} has a lower +#' bound of 0). Anything else, or several different entries, is not parsed. +#' @return A list with \code{cdf} (a function) and \code{var}, or \code{NULL}. +#' @keywords internal +#' @noRd +.lscale_prior_parse <- function(spec) { + if (!is.character(spec) || length(spec) != 1L || is.na(spec)) return(NULL) + num <- "\\s*([-+0-9.eE]+)\\s*" + m <- regmatches(spec, regexec(paste0("^inv_gamma\\(", num, ",", num, "\\)$"), + spec))[[1L]] + if (length(m) == 3L) { + a <- suppressWarnings(as.numeric(m[2L])); b <- suppressWarnings(as.numeric(m[3L])) + if (!is.finite(a) || !is.finite(b) || a <= 0 || b <= 0) return(NULL) + return(list( + cdf = function(x) 1 - stats::pgamma(1 / x, shape = a, rate = b), + var = if (a > 2) b^2 / ((a - 1)^2 * (a - 2)) else NA_real_)) + } + m <- regmatches(spec, regexec(paste0("^normal\\(\\s*0\\s*,", num, "\\)$"), + spec))[[1L]] + if (length(m) == 2L) { + s <- suppressWarnings(as.numeric(m[2L])) + if (!is.finite(s) || s <= 0) return(NULL) + return(list(cdf = function(x) 2 * stats::pnorm(x / s) - 1, + var = s^2 * (1 - 2 / pi))) + } + NULL +} + + +#' Moran's I of a variable's OLS residuals over a weight matrix +#' +#' One-sided (greater), with the Cliff and Ord regression-residual moments. +#' +#' @param y Numeric response. +#' @param X Design matrix with its intercept column. +#' @param W Weight matrix, base or \pkg{Matrix}. +#' @return A list with \code{I}, \code{z} and \code{p}, or \code{NULL} when +#' it cannot be computed. +#' @keywords internal +#' @noRd +.gp_resid_moran <- function(y, X, W) { + n <- length(y) + e <- stats::lm.fit(X, y)$residuals + e <- e - mean(e) + S0 <- sum(W) + if (!is.finite(S0) || S0 <= 0 || sum(e^2) <= 0) return(NULL) + I <- as.numeric((n / S0) * sum(e * (W %*% e)) / sum(e^2)) + mom <- .morans_residual_moments(W = W, X = X, S0 = S0, + is_sparse = inherits(W, "Matrix")) + if (is.null(mom) || !is.finite(mom$VI) || mom$VI <= 0) return(NULL) + z <- (I - mom$EI) / sqrt(mom$VI) + list(I = I, z = z, p = stats::pnorm(z, lower.tail = FALSE)) +} + +#' Short-lag Moran's I of a variable's OLS residuals +#' +#' Over the \code{k} nearest neighbours. Used before fitting to ask whether +#' the response has any spatial structure at short range before a variogram +#' range below the basis floor is taken at its word. +#' \code{estimate_sac_range()} tests for structure itself and refuses most +#' white-noise layers, and still returned a finite range below the floor in +#' 3 of 60 draws. +#' +#' @param xy Coordinate matrix. +#' @param y Numeric response. +#' @param X Design matrix without the intercept, or \code{NULL}. +#' @param k Neighbours. 4: the short lag is where structure the basis cannot +#' resolve shows. +#' @return A list with \code{I}, \code{z} and \code{p} (one-sided, greater), +#' or \code{NULL} when it cannot be computed. +#' @keywords internal +#' @noRd +.gp_short_lag_moran <- function(xy, y, X = NULL, k = 4L) { + tryCatch({ + y <- as.numeric(y) + xy <- as.matrix(xy)[, 1:2, drop = FALSE] + n <- length(y) + if (n < 10L || nrow(xy) != n || !all(is.finite(y)) || !all(is.finite(xy))) + return(NULL) + X <- if (is.null(X) || !length(X)) matrix(1, n, 1L) else cbind(1, as.matrix(X)) + .gp_resid_moran(y, X, .build_knn_weights(xy, k = k)) + }, error = function(e) NULL) +} + +# The correlation that defines an effective range: the distance at which it +# has fallen to this (.gp_se_range_factor is the same 0.05 for the kernel). +.gp_range_correlation <- 0.05 + +#' Moran's I of a variable's OLS residuals at the basis floor's distance +#' +#' Over the pairs of points between 0.75 and 1.25 floors apart. An effective +#' range is the distance at which the correlation has fallen to 0.05, so a +#' response whose range is below the floor is uncorrelated at the floor's +#' distance, and one that is still correlated there has structure the floor +#' does not bound. A variogram can return a short range for such a response: +#' on squared-exponential fields with ranges of 60 and 90 km it returned 5 to +#' 7 km in 1 to 9 of 60 draws, each with significant short-lag +#' autocorrelation. Asking that this statistic not be both above 0.05 and +#' significant took the warnings on those fields from 15 of 180 draws to 2, +#' on a sine with a 96 km wavelength from 8 of 60 to 0, and on fields with +#' ranges of 8 to 15 km from 178 of 180 to 176. +#' +#' The band needs every pairwise distance, so more than \code{max_n} rows are +#' thinned to \code{max_n} at even steps through the rows (no random draw: +#' the fit must leave the caller's random-number stream where it was). +#' +#' @param xy Coordinate matrix. +#' @param y Numeric response. +#' @param X Design matrix without the intercept, or \code{NULL}. +#' @param floor The floor, in map units. +#' @param max_n Most rows used. +#' @return A list with \code{I}, \code{z}, \code{p} (one-sided, greater), +#' \code{band} (the two distances) and \code{n_pairs}, or \code{NULL} when +#' it cannot be computed (no pair in the band, among other reasons). +#' @keywords internal +#' @noRd +.gp_floor_moran <- function(xy, y, X = NULL, floor, max_n = 1500L) { + tryCatch({ + y <- as.numeric(y) + xy <- as.matrix(xy)[, 1:2, drop = FALSE] + n <- length(y) + if (n < 10L || nrow(xy) != n || !all(is.finite(y)) || !all(is.finite(xy)) || + !is.finite(floor) || floor <= 0) + return(NULL) + X <- if (is.null(X) || !length(X)) matrix(1, n, 1L) else cbind(1, as.matrix(X)) + if (n > max_n) { + keep <- unique(round(seq(1, n, length.out = max_n))) + xy <- xy[keep, , drop = FALSE]; y <- y[keep]; X <- X[keep, , drop = FALSE] + } + band <- c(0.75, 1.25) * floor + D <- as.matrix(stats::dist(xy)) + W <- (D >= band[1L] & D < band[2L]) * 1 + diag(W) <- 0 + out <- .gp_resid_moran(y, X, W) + if (is.null(out)) return(NULL) + out$band <- band + out$n_pairs <- sum(W) / 2 + out + }, error = function(e) NULL) +} + + +#' Compare the response's estimated range with what the basis resolves +#' +#' Run before anything is compiled. The floor of the basis is known from the +#' coordinates alone, and a range below it means minutes of sampling for a +#' surface that cannot hold the structure. +#' +#' A variogram range below the floor is taken as the reach of the structure +#' only when two things agree with it: the variable is autocorrelated at +#' short range, and it is no longer autocorrelated at the floor's distance. +#' Without the first the range is noise (a variogram fitted to white noise +#' can still return a short range: 3 of 60 draws). Without the second the +#' range is contradicted: structure reaches at least to the floor, and the +#' variogram either fitted a smooth surface badly or found a short range +#' beside a longer one. +#' +#' @param dat_sf The prepared training layer. +#' @param response_var,predictor_vars Column names. +#' @param resolution Named \code{c(x, y)}: the smallest effective range the +#' basis resolves along each axis, in map units. +#' @param gp_c,S,xy_scale As in \code{.gp_k_needed()}. +#' @return A list with \code{status} (\code{"ok"}, \code{"below_floor"}, +#' \code{"below_floor_no_autocorrelation"}, +#' \code{"below_floor_long_range"}, \code{"not_estimated"} or +#' \code{"not_run"}), \code{range} (map units, or \code{NA}), \code{floor} +#' (the coarser axis's), \code{k_needed}, \code{moran}, +#' \code{moran_floor} and \code{reason}. +#' @keywords internal +#' @noRd +.gp_prefit_range_check <- function(dat_sf, response_var, predictor_vars, + resolution, gp_c, S, xy_scale) { + out <- list(status = "not_run", range = NA_real_, + floor = max(resolution), k_needed = NA_real_, moran = NULL, + moran_floor = NULL, reason = NA_character_) + df <- sf::st_drop_geometry(dat_sf) + y <- df[[response_var]] + if (!(is.numeric(y) || is.logical(y))) { + out$reason <- "the response is not numeric" + return(out) + } + # The range of what the GP is asked to model: the response net of the + # predictors when there are any. A predictor estimate_sac_range() cannot + # detrend on (it stops) falls back to the raw response. + est <- function(pv) tryCatch( + suppressWarnings(suppressMessages( + estimate_sac_range(dat_sf, response_var, + predictor_vars = if (length(pv)) pv else NULL))), + error = function(e) structure(NA_real_, rejected_reason = conditionMessage(e), + failed = TRUE)) + r <- est(predictor_vars) + if (isTRUE(attr(r, "failed")) && length(predictor_vars) > 0L) + r <- est(character(0)) + rng <- suppressWarnings(as.numeric(r))[1L] + + design <- function() { + X <- NULL + if (length(predictor_vars) > 0L) + X <- tryCatch( + stats::model.matrix(stats::reformulate(predictor_vars), data = df)[, -1L, drop = FALSE], + error = function(e) NULL) + xy <- sf::st_coordinates(dat_sf)[, 1:2, drop = FALSE] + if (!is.null(X) && nrow(X) != nrow(xy)) X <- NULL + list(xy = xy, X = X) + } + moran <- function() { + d <- design() + .gp_short_lag_moran(d$xy, as.numeric(y), d$X) + } + + if (!is.finite(rng) || rng <= 0) { + out$status <- "not_estimated" + out$reason <- attr(r, "rejected_reason") %||% "no range was returned" + out$moran <- moran() + # Both tests, so the log can say which way an unestimated range leans. + if (!is.null(out$moran) && isTRUE(out$moran$p < 0.05)) { + d <- design() + out$moran_floor <- .gp_floor_moran(d$xy, as.numeric(y), d$X, + floor = out$floor) + } + return(out) + } + out$range <- rng + out$k_needed <- .gp_k_needed(rng, gp_c, S, xy_scale) + if (rng >= out$floor) { + out$status <- "ok" + return(out) + } + # Below the floor. A variogram fitted to a response with no spatial + # structure can still return a short range (estimate_sac_range() refuses + # most such layers itself; 3 of 60 white-noise draws got one), so the + # range is taken at its word only when the short-lag autocorrelation is + # there (or cannot be tested). + out$moran <- moran() + if (!(is.null(out$moran) || isTRUE(out$moran$p < 0.05))) { + out$status <- "below_floor_no_autocorrelation" + return(out) + } + # And only when the autocorrelation is gone by the floor's distance. Any + # real structure makes the short-lag test significant, long-range structure + # included, so that test alone let a spuriously short range through. + d <- design() + out$moran_floor <- .gp_floor_moran(d$xy, as.numeric(y), d$X, floor = out$floor) + mf <- out$moran_floor + out$status <- if (!is.null(mf) && isTRUE(mf$I > .gp_range_correlation) && + isTRUE(mf$p < 0.05)) + "below_floor_long_range" else "below_floor" + out +} + + +# --------------------------------------------------------------------------- +# Sampler diagnostics +# --------------------------------------------------------------------------- + +# The thresholds convergence_ok is judged by; see @param check_convergence +# for where each comes from. R-hat has two: above .bayes_rhat_max fails +# whatever else holds, above .bayes_rhat_caution fails only beside too few +# effective draws (.bayes_rhat_tiers()). +.bayes_rhat_max <- 1.05 +.bayes_rhat_caution <- 1.01 +.bayes_ess_per_chain <- 100 +.bayes_ebfmi_min <- 0.3 + +#' Sort R-hat values into the ones that fail and the ones to caution on +#' +#' One cut at 1.01 over every parameter fails fits that have converged. This +#' model has several hundred basis weights, and the largest of several hundred +#' R-hat values is near 1.01 by chance at the default run length. Four +#' default fits (four chains of 1,000 post-warmup draws, about 540 +#' parameters) had maxima of 1.005 to 1.011 with every effective sample size +#' at least 1,086 against 400 required, and one of the four was failed on a +#' single basis weight at 1.011. Chains that have converged by construction +#' (540 independent AR(1) parameters, four chains of 1,000 draws, eight +#' replicates each) give the same picture: at an effective sample size near +#' 1,300 the largest R-hat was 1.008 to 1.011 and one replicate in eight had +#' a parameter above 1.01; near 450 it was 1.027 to 1.032, with 130 to 160 +#' parameters above 1.01 and none above 1.05. +#' +#' The same simulation ties the two recommendations of Vehtari et al. (2021) +#' together: parameters with an effective sample size of 350 to 450 had a +#' mean R-hat of 1.009. So a value above 1.01 is a failure when the +#' parameter's effective sample size is also short, a caution when it is not, +#' and a failure above 1.05 either way. +#' +#' @param rhat_vals Named R-hat values (\code{NaN} for a constant parameter). +#' @param neff_vals Named ratios from \code{brms::neff_ratio()}, or +#' \code{NULL}. +#' @param n_draws,n_chains Post-warmup draws over all chains, and chains. +#' @return A list with \code{failed} and \code{caution}, the parameter names +#' in each. A parameter above 1.01 whose effective sample size cannot be +#' read fails. +#' @keywords internal +#' @noRd +.bayes_rhat_tiers <- function(rhat_vals, neff_vals = NULL, n_draws = NA_real_, + n_chains = NA_real_) { + nm <- names(rhat_vals) + above <- which(rhat_vals > .bayes_rhat_caution) + if (!length(above)) return(list(failed = character(0), caution = character(0))) + ess <- rep(NA_real_, length(rhat_vals)) + counts_known <- is.numeric(n_draws) && length(n_draws) == 1L && + is.finite(n_draws) && n_draws > 0 && is.numeric(n_chains) && + length(n_chains) == 1L && is.finite(n_chains) && n_chains > 0 + if (counts_known && is.numeric(neff_vals) && !is.null(names(neff_vals)) && + !is.null(nm)) + ess <- unname(neff_vals[nm]) * n_draws + enough <- is.finite(ess) & ess >= .bayes_ess_per_chain * n_chains + fails <- above[rhat_vals[above] > .bayes_rhat_max | !enough[above]] + list(failed = nm[fails], caution = nm[setdiff(above, fails)]) +} + +#' Parameters whose bulk or tail effective sample size is too small +#' +#' \code{brms::neff_ratio()} is \code{min(bulk ESS, tail ESS) / draws}, so the +#' smaller of the two effective sample sizes is the ratio times the number of +#' post-warmup draws. The rule is absolute, 100 per chain, as Stan's own +#' warning is: a share of the draws asks for 100 in all at +#' \code{chains = 2, iter = 1000} and for 2,000 at four chains of 10,000. +#' +#' @param neff_vals Named ratios from \code{brms::neff_ratio()}. +#' @param n_draws Post-warmup draws over all chains. +#' @param n_chains Number of chains. +#' @return The names of the parameters below +#' \code{.bayes_ess_per_chain * n_chains}; \code{character(0)} when the +#' draw or chain count is unknown. +#' @keywords internal +#' @noRd +.bayes_low_ess <- function(neff_vals, n_draws, n_chains) { + if (!is.numeric(n_draws) || length(n_draws) != 1L || !is.finite(n_draws) || + !is.numeric(n_chains) || length(n_chains) != 1L || !is.finite(n_chains) || + n_draws <= 0 || n_chains <= 0) + return(character(0)) + names(neff_vals)[which(neff_vals * n_draws < .bayes_ess_per_chain * n_chains)] +} + +#' E-BFMI per chain from brms::nuts_params() +#' +#' The energy Bayesian fraction of missing information of Betancourt (2016): +#' the mean squared change in energy between successive transitions over the +#' variance of the energy. +#' +#' @param np The data.frame \code{brms::nuts_params()} returns. +#' @return A named numeric, one per chain; length 0 when the energies are +#' absent. +#' @keywords internal +#' @noRd +.bayes_ebfmi <- function(np) { + if (!is.data.frame(np) || !all(c("Parameter", "Value", "Chain") %in% names(np))) + return(numeric(0)) + en <- np[np$Parameter == "energy__", , drop = FALSE] + if (!nrow(en)) return(numeric(0)) + if ("Iteration" %in% names(en)) en <- en[order(en$Chain, en$Iteration), ] + vapply(split(en$Value, en$Chain), function(e) { + if (length(e) < 3L || !is.finite(stats::var(e)) || stats::var(e) <= 0) + return(NA_real_) + (sum(diff(e)^2) / length(e)) / stats::var(e) + }, numeric(1)) +} + +#' What to do about each sampler check that failed +#' +#' The remedy differs by check. More iterations bring R-hat down and the +#' effective sample size up. They do not remove divergent transitions, which +#' need a smaller step size (a higher \code{adapt_delta}), and a low E-BFMI +#' comes from the shape of the posterior. A fit whose only failure was two +#' divergent transitions used to be told to run more iterations. +#' +#' @param failed Character: any of \code{"divergent"}, \code{"rhat"}, +#' \code{"ess"} and \code{"ebfmi"}. +#' @param iter,chains,adapt_delta The settings the fit ran with. +#' @return One string, a sentence per remedy, in the order above. +#' @keywords internal +#' @noRd +.bayes_convergence_advice <- function(failed, iter, chains, adapt_delta = NULL) { + out <- character(0) + if ("divergent" %in% failed) { + ad <- suppressWarnings(as.numeric(adapt_delta %||% NA_real_))[1L] + out <- c(out, sprintf( + paste0("For the divergent transitions, raise adapt_delta in `control`", + "%s; more iterations do not remove them."), + if (is.finite(ad)) sprintf(" (now %.2f)", ad) else "")) + } + what <- c(if ("rhat" %in% failed) "bring R-hat down", + if ("ess" %in% failed) "raise the effective sample size") + if (length(what) > 0L) + out <- c(out, sprintf( + "Run more iterations (iter = %s, chains = %s now) to %s.", + format(iter), format(chains), paste(what, collapse = " and "))) + if ("ebfmi" %in% failed) + out <- c(out, paste0( + "A low E-BFMI comes from the shape of the posterior, not the run ", + "length: a longer warmup can help, and otherwise the model or its ", + "priors need changing.")) + paste(out, collapse = " ") +} + + +# --------------------------------------------------------------------------- +# GP adequacy +# --------------------------------------------------------------------------- + +#' Largest gap between a prior's distribution function and a sample's +#' +#' The Kolmogorov-Smirnov distance between the draws of a parameter and its +#' prior: 0 when the posterior is the prior, 1 when they share no mass. It +#' sees a posterior that moved as well as one that narrowed, which the ratio +#' of variances does not: a length-scale posterior pushed to the long side of +#' its prior is wider than the prior and has moved almost all of its mass. +#' +#' @param x Numeric draws. +#' @param cdf The prior's distribution function. +#' @return A number in 0 to 1, or \code{NA} with fewer than two finite draws. +#' @keywords internal +#' @noRd +.gp_prior_gap <- function(x, cdf) { + x <- sort(x[is.finite(x)]) + n <- length(x) + if (n < 2L) return(NA_real_) + Fx <- cdf(x) + if (!all(is.finite(Fx))) return(NA_real_) + max(seq_len(n) / n - Fx, Fx - (seq_len(n) - 1) / n) +} + +# The thresholds of "not identified"; see .gp_adequacy(). +.gp_share_floor <- 0.01 +.gp_contraction_floor <- 0.25 +.gp_prior_gap_floor <- 0.30 + +#' What the posterior says about the Gaussian process, against its basis +#' +#' Two questions the single "share of draws below the floor" could not +#' separate. Did the data give the Gaussian process anything to carry? If +#' so, does the posterior want a shorter length-scale than the basis +#' resolves? The share below the floor cannot answer the first: with a +#' derived basis the prior puts under 1 percent of its mass below the floor, +#' so a posterior equal to the prior gives 1 percent against a 10 percent +#' trigger, and with a small user \code{gp_k} the share restates the prior +#' (0.984 prior, 0.986 posterior). +#' +#' "Not identified" is decided on one of two things, and \code{identified_by} +#' records which. +#' \itemize{ +#' \item With a residual standard deviation on the scale of the Gaussian +#' process (a gaussian or lognormal family), on the share of the variance +#' the process carries, \code{sdgp^2 / (sdgp^2 + sigma^2)}: not identified +#' when its 2.5 percent quantile is under 0.01. On nine fits that +#' quantile was 0.000 to 0.003 for the three with nothing to find (white +#' noise, a 30 km field under a 97 km floor, \code{gp_k = 6}) and 0.17 to +#' 0.94 for the six with a surface. +#' \item Without one, on the length-scales: not identified when on every +#' axis the posterior neither narrowed (it kept more than three quarters +#' of its prior's variance) nor moved (the largest gap between its +#' distribution function and the prior's is under 0.30). On the +#' length-scale draws of the same nine fits the gap was 0.07 to 0.15 for +#' the three with nothing to find and 0.60 to 0.95 for the five whose +#' posterior moved; the sixth sat at its prior's median and is identified +#' by narrowing (0.63 and 0.81 of the variance gone, gaps 0.15 and 0.25). +#' Draws from the prior itself give a gap under 0.20 in 999 of 1,000 +#' samples of 100. This rule agrees with the share on eight of the nine +#' and calls the \code{gp_k = 6} fit identified (one axis lost 0.32 of +#' its prior's variance), as the rule it replaces did; it has been run +#' on no fit of a family without a residual standard deviation. +#' } +#' The variance ratio alone is not a test of identification, and was used as +#' one: a surface smoother than the prior expects (a plane, a range longer +#' than the extent) moves the length-scale to the long side of its prior, +#' where the posterior is wider than the prior and the ratio's "contraction" +#' is negative. Three fits whose Gaussian process carried 0.57 to 0.94 of +#' the variance at the 2.5 percent quantile had contractions of -0.34 to +#' -2.27 and were reported as having found no spatial structure. +#' +#' @param ls_draws Matrix of length-scale draws, one column per length-scale. +#' @param sdgp_draws,sigma_draws Numeric draws, or \code{NULL}. +#' @param gp_ell_min The smallest length-scale the basis resolves. +#' @param prior_spec The length-scale prior string, for the contraction and +#' the gap. +#' @param xy_scale Coordinate SDs, to report ranges in map units. +#' @return A list; see \code{$info$gp_adequacy} in +#' \code{?fit_bayesian_spatial_model}. \code{status} is \code{"ok"}, +#' \code{"below_resolution"} or \code{"not_identified"}. It is what the +#' posterior says and no more: the caller reads the residuals next +#' (\code{.gp_fit_resid_moran()}) and splits both \code{"not_identified"} +#' and \code{"ok"} on what is left in them. +#' @keywords internal +#' @noRd +.gp_adequacy <- function(ls_draws, sdgp_draws = NULL, sigma_draws = NULL, + gp_ell_min, prior_spec = NULL, xy_scale = c(1, 1)) { + qs <- c(0.025, 0.5, 0.975) + ls_draws <- as.matrix(ls_draws) + frac_below <- mean(as.numeric(ls_draws) < gp_ell_min, na.rm = TRUE) + + pr <- .lscale_prior_parse(prior_spec) + contraction <- prior_gap <- rep(NA_real_, ncol(ls_draws)) + names(contraction) <- names(prior_gap) <- colnames(ls_draws) + if (!is.null(pr)) { + if (is.finite(pr$var) && pr$var > 0) + contraction[] <- 1 - apply(ls_draws, 2L, stats::var) / pr$var + prior_gap[] <- apply(ls_draws, 2L, .gp_prior_gap, cdf = pr$cdf) + } + + share <- NULL + if (is.numeric(sdgp_draws) && is.numeric(sigma_draws) && + length(sdgp_draws) == length(sigma_draws) && length(sdgp_draws) > 0L) { + sh <- sdgp_draws^2 / (sdgp_draws^2 + sigma_draws^2) + share <- stats::quantile(sh, qs, names = FALSE, na.rm = TRUE) + names(share) <- c("q2.5", "q50", "q97.5") + } + sdgp <- NULL + if (is.numeric(sdgp_draws) && length(sdgp_draws) > 0L) { + sdgp <- stats::quantile(sdgp_draws, qs, names = FALSE, na.rm = TRUE) + names(sdgp) <- c("q2.5", "q50", "q97.5") + } + + # The share decides wherever there is one. The length-scales decide only + # where there is not, and there a posterior that moved counts as much as + # one that narrowed. + identified <- NA; identified_by <- NA_character_ + if (!is.null(share) && is.finite(share[["q2.5"]])) { + identified <- share[["q2.5"]] >= .gp_share_floor + identified_by <- "spatial_share" + } else if (all(is.finite(prior_gap))) { + narrowed <- is.finite(contraction) & contraction >= .gp_contraction_floor + moved <- prior_gap >= .gp_prior_gap_floor + identified <- any(narrowed | moved) + identified_by <- "length_scale" + } + + # The posterior effective range per length-scale, in map units. One + # length-scale per axis under gp_iso = FALSE; a shared one is reported on + # both axes, each with its own scaling. + # A family with several distributional parameters has one GP each, and so + # more columns than axes; no single range describes that fit. + eff <- NULL + if (ncol(ls_draws) %in% c(1L, 2L)) { + axes <- if (ncol(ls_draws) == 2L) list(x = 1L, y = 2L) else list(x = 1L, y = 1L) + eff <- t(vapply(seq_along(axes), function(i) + .gp_se_range_factor * xy_scale[[i]] * + stats::quantile(ls_draws[, axes[[i]]], qs, names = FALSE, na.rm = TRUE), + numeric(3))) + dimnames(eff) <- list(names(axes), c("q2.5", "q50", "q97.5")) + } + + status <- if (identical(identified, FALSE)) "not_identified" + else if (is.finite(frac_below) && frac_below > 0.10) "below_resolution" + else "ok" + list(status = status, frac_below = frac_below, identified = identified, + identified_by = identified_by, contraction = contraction, + prior_gap = prior_gap, spatial_share = share, sdgp = sdgp, + effective_range = eff) +} + +# The test on the residuals that the status is split on: neighbours and level. +.gp_resid_k <- 4L +.gp_resid_level <- 0.05 + +#' Short-lag Moran's I of a fitted model's residuals +#' +#' What the posterior of the Gaussian process cannot say: whether the surface +#' it fitted left structure behind. A process that carries a share of the +#' variance at a range clear of the floor is all \code{.gp_adequacy()} sees +#' in a response with a regional trend plus structure finer than the basis, +#' and in one with the trend alone. The residuals tell them apart, over the +#' few nearest neighbours and one-sided: ten fits of 400 points on a 100 km +#' square (floor 32 to 33 km) with a component at 8 or 12 km gave p of +#' 5.3e-10 to 0.014, five of them under a posterior that read "ok". See +#' "What the basis resolves" in \code{?fit_bayesian_spatial_model} for the +#' fits with no such component. +#' +#' The fitted values come from \code{fitted()}, which caches them, so the +#' pass over the posterior is not repeated by \code{summary()} or +#' \code{residuals()}. +#' +#' @param obj A \code{bayesian_fit}. +#' @param fam_name The family's name, or \code{NA}. +#' @param k Neighbours. +#' @return A list with \code{test} (a list with \code{I}, \code{z}, the +#' one-sided \code{p} and \code{k}, or \code{NULL}) and \code{reason} (why +#' there is no test, or \code{NA}). +#' @keywords internal +#' @noRd +.gp_fit_resid_moran <- function(obj, fam_name = NA_character_, k = .gp_resid_k) { + none <- function(why) list(test = NULL, reason = why) + if (isTRUE(fam_name %in% .brms_category_families)) + return(none("an ordinal or categorical family has no residual per row")) + res <- tryCatch(suppressWarnings(suppressMessages(stats::residuals(obj))), + error = function(e) e) + if (inherits(res, "error")) + return(none(sprintf("residuals() failed: %s", conditionMessage(res)))) + if (!is.numeric(res) || length(res) != obj$n || sum(is.finite(res)) < 10L) + return(none("residuals() did not return a finite number for at least 10 rows")) + mor <- tryCatch(suppressWarnings(suppressMessages( + residual_morans_i(obj, alternative = "greater", k = k))), + error = function(e) NULL) + p <- suppressWarnings(as.numeric(mor$p_value %||% NA_real_))[1L] + if (is.null(mor) || !is.finite(p)) + return(none("Moran's I could not be computed on the residuals")) + list(test = list(I = mor$observed, z = mor$z, p = p, k = as.integer(k)), + reason = NA_character_) +} + + #' Fit a Bayesian spatial regression with a 2D Gaussian Process (via brms) #' #' Fits a regression whose residual spatial structure is modelled explicitly, as #' a Gaussian process over the coordinates, and so kept out of the errors. Two #' things follow, and they are the reasons to reach for this backend. First, -#' every quantity comes with a posterior, so predictions carry calibrated -#' intervals instead of point estimates. Score them with +#' every quantity comes with a posterior, so predictions carry intervals +#' instead of point estimates. Whether those intervals are calibrated is +#' something to measure, not assume: score them with #' \code{\link{cv_bayes}()}, which reports held-out interval coverage and CRPS. -#' Second, the fitted length-scale is itself an estimate of how far the spatial -#' dependence reaches, a number you can read and report. +#' Second, the spatial term is a smooth regional surface at a stated +#' resolution. The Gaussian process is fitted through a reduced-rank basis, +#' and that basis has a floor: an effective range below which it cannot +#' represent structure, reported in map units as \code{$info$gp_resolution} +#' and by \code{print()}. With the defaults the floor is 14 to 33 percent of +#' the extent along each axis (about 32 km on a uniform 100 km square, 155 km +#' east-west and 63 km north-south on the census tracts of North Carolina). +#' Structure shorter than the floor is counted as noise: the fitted range comes +#' out too long, the residual standard deviation too large, and the intervals +#' too narrow where the structure is. See "What the basis resolves" below. +#' +#' The fitted length-scale is an estimate of how far the spatial dependence +#' reaches only when its posterior sits clear of both that floor and its +#' prior. \code{$info$gp_adequacy} says whether it does, and when it does +#' \code{$info$gp_adequacy$effective_range} holds the posterior effective range +#' per axis in map units (the raw \code{lscale} draws are in per-axis +#' standardised units and are not a distance). #' #' Choose it over \code{\link{fit_gwr_model}()} when you want one global #' relationship plus an explicit spatial random field, and uncertainty you can @@ -293,7 +1063,25 @@ #' @param gp_k Positive integer giving the number of GP basis functions #' \emph{per dimension}, or NULL (default) to derive it from the #' length-scale/domain ratio. The fitted model carries -#' \code{gp_k^2} basis functions, not \code{gp_k} (see Details). +#' \code{gp_k^2} basis functions, not \code{gp_k} (see Details). A value +#' above the derived one makes the basis finer, and the length-scale +#' prior's lower tail moves down to the length-scale that basis resolves, +#' because a finer basis under the default prior gains almost nothing. A +#' value below the derived one leaves the prior where it was, mostly below +#' what the basis resolves; that share is stored as +#' \code{$info$gp_adequacy$prior_mass_below}, logged when it passes 10 +#' percent and flagged by \code{print()}. To ask for a resolution in map +#' units, use \code{gp_resolution} and leave this \code{NULL}. +#' @param gp_resolution The shortest effective range the basis should resolve, +#' as a single positive number in the units of the data's CRS (metres for a +#' UTM layer), or NULL (default) for the percentile rule described under +#' Details. \code{gp_k} is derived from it, and the length-scale prior's +#' lower tail moves with the basis. It can only refine: a value the default +#' basis already resolves leaves the default basis in place. It is an error +#' when the basis it needs exceeds the cap of 50 functions per dimension +#' (2,500 in all); the message gives the basis size needed and the shortest +#' range the cap reaches on this layout. Cost grows with +#' \code{gp_k^2}. Give \code{gp_resolution} or \code{gp_k}, not both. #' @param gp_iso Logical; passed to \code{brms::gp(iso = )}. \code{FALSE} #' (the default) fits a separate length-scale per coordinate axis, letting the #' model learn any directional structure from the data. \code{TRUE} fits a @@ -310,8 +1098,19 @@ #' length-scale, so raising \code{gp_c} raises the derived \code{gp_k} with #' it, up to the cap of 50 per dimension (a capped value is logged). #' @param prior Optional brms prior specification. When NULL and -#' \code{standardize_predictors = TRUE}, weakly informative -#' \code{normal(0, 5)} priors are set on regression coefficients. +#' \code{standardize_predictors = TRUE}, a weakly informative prior is set on +#' the regression coefficients, on the scale of the linear predictor: +#' \code{normal(0, 2.5 * sd(y))} under an identity link (gaussian, student, +#' skew-normal and mixtures of them), \code{normal(0, 2.5 * sd(log(y)))} for +#' the lognormal families, whose location is on the log scale, and the fixed +#' \code{normal(0, 5)} under any other link (log, logit and so on), where the +#' linear predictor has a scale of its own. \code{sd()} is taken over the +#' training rows. The result therefore does not depend on the units of the +#' response: a fixed \code{normal(0, 5)} under an identity link, which is +#' what earlier versions set, left a slope alone when income was in +#' thousands of dollars and shrank the same slope to nothing when it was in +#' dollars. The prior brms used is stored as \code{$info$b_prior} and shown +#' by \code{print()}. When \code{prior} is given, no slope prior is added. #' A data-informed GP length-scale prior is always appended #' automatically unless \code{prior} already contains an entry with #' \code{class = "lscale"}. @@ -346,29 +1145,70 @@ #' predictors, so \code{coef()} reports a slope per standard deviation of #' each predictor and an intercept at the predictor means, not the raw-unit #' values \code{stats::lm()} would give; see \code{\link{coef.bayesian_fit}}. -#' @param check_convergence Logical; after fitting, check for divergent -#' transitions, R-hat above 1.05 and an effective-sample-size ratio below -#' 0.1. Each problem found is written to the log as a WARN line (shown on -#' the console unless \code{\link{spatialkit_quiet}()} is on), sets -#' \code{$info$convergence_ok} to \code{FALSE}, and is detailed in -#' \code{$info$convergence_diagnostics}; \code{print()} on the fit flags it. -#' The GP basis is also checked against the posterior length-scale (see -#' Details): a basis too coarse for it is logged as a WARN line, and the -#' share of draws it cannot resolve is recorded as -#' \code{$info$convergence_diagnostics$gp_lscale_below_resolution}, but it -#' does not change \code{convergence_ok} and \code{print()} does not flag -#' it. None of these are raised as R warnings by the fit itself; the -#' functions that score fits do raise one: \code{\link{cv_bayes}()} names -#' the folds whose sampler did not converge (and marks them in -#' \code{fold_metrics$convergence_ok}), and -#' \code{\link{compare_models}()} names such a model (column -#' \code{convergence_ok}). Under \pkg{rstan} the sampler raises its own -#' R-hat and ESS warnings; under \pkg{cmdstanr} nothing does, so read -#' \code{$info$convergence_ok}. \code{FALSE} skips -#' the checks and leaves \code{convergence_ok} \code{NA} (not checked). +#' @param check_convergence Logical; after fitting, read the sampler's +#' diagnostics and set \code{$info$convergence_ok}. The verdict follows +#' Stan's own diagnostics, with these thresholds: +#' \itemize{ +#' \item any divergent transition after warmup; +#' \item bulk or tail effective sample size below 100 per chain for any +#' parameter (Vehtari et al. 2021; the rule \pkg{rstan} warns on). It +#' is an absolute count: a share of the draws, which earlier versions +#' used, asks for 100 in all at \code{chains = 2, iter = 1000}; +#' \item rank-normalised split R-hat, in two tiers. Above 1.05, the +#' value \pkg{rstan}'s own sampler warning uses, for any parameter. +#' Above 1.01, the value Vehtari et al. (2021) recommend, for a +#' parameter whose effective sample size is also below the count in +#' the previous item, or cannot be read; +#' \item E-BFMI below 0.3 in any chain (Betancourt 2016). +#' } +#' An R-hat between 1.01 and 1.05 on a parameter with enough effective +#' draws is a caution, not a failure: it is stored by name in +#' \code{$info$convergence_diagnostics$rhat_caution}, logged, and counted +#' by \code{print()}. The reason is the number of parameters. This model +#' has one weight per basis function, about 540 parameters at the usual +#' basis, and the largest of that many R-hat values sits near 1.01 in a +#' fit that has converged: four fits at the default four chains of 2,000 +#' iterations had largest values of 1.005, 1.009, 1.009 and 1.011, with +#' every effective sample size at least 1,086 against the 400 required. +#' Chains that have converged by construction (540 independent +#' parameters, four chains of 1,000 draws) had a largest value of 1.008 to +#' 1.011 at an effective sample size near 1,300, and 130 to 160 values +#' above 1.01, none above 1.05, at an effective sample size near 450. +#' Vehtari et al. give 1.01 beside an effective sample size above 400, and +#' an R-hat of 1.01 is about what an effective sample size of 400 gives +#' (1.009 on average in the same chains), so the two are read together +#' here. +#' +#' Transitions that stop at \code{max_treedepth} are counted and logged but +#' do not change the verdict: Stan treats them as a cost, not as invalid +#' draws. A failed verdict sets \code{convergence_ok} to \code{FALSE}, +#' raises one R warning of class \code{spatialkit_convergence} naming each +#' failed check with its count and its first five parameters, and +#' \code{print()} flags it; \code{$info$convergence_diagnostics} holds every +#' value. The warning closes with the remedy for the checks that failed: a +#' higher \code{adapt_delta} for divergent transitions, which more +#' iterations do not remove, and more iterations for R-hat and effective +#' sample size. \code{\link{cv_bayes}()} marks such folds in +#' \code{fold_metrics$convergence_ok} and \code{\link{compare_models}()} +#' names such a model. A short run usually fails, on effective sample +#' size: two fits of two chains and 300 post-warmup draws each had two or +#' three parameters below 100 effective draws per chain, and 66 and 76 of +#' their 537 parameters above R-hat 1.01. +#' +#' The same step checks the GP basis against the posterior and the +#' residuals (see "What the basis resolves") and stores the result as +#' \code{$info$gp_adequacy}. The residuals need the fitted values, one +#' pass over the posterior that \code{fitted()} caches for later calls. +#' That check is about the approximation, not the sampler, so it does not +#' change \code{convergence_ok}; \code{print()} and \code{summary()} show +#' its status, and two of its states raise a warning of class +#' \code{spatialkit_gp_adequacy}. \code{FALSE} skips +#' all of these and leaves \code{convergence_ok} \code{NA} (not checked) +#' and the adequacy status \code{"not_checked"}. #' Default TRUE. #' @param pointize Strategy for non-point geometry coercion. -#' @param boundary Optional polygonal sf/sfc for CRS harmonization. +#' @param boundary Optional polygonal sf/sfc whose CRS the data are projected +#' to. It is not a clip: rows outside it are kept. #' @param .already_prepped Logical (internal). If \code{TRUE}, skip the #' \code{prep_model_data()} call because the caller has already projected, #' coerced, and filtered the data. The data must then have plain POINT @@ -384,8 +1224,9 @@ #' estimated length-scale to the domain extent, following #' Riutort-Mayol et al. (2023): \code{gp_c} is set large enough to contain the #' upper length-scale bound, and \code{gp_k} large enough to resolve the lower -#' one. The derived value is typically 21-25 per dimension and is largely -#' independent of \code{n}. +#' one. The derived value depends on the layout, not on \code{n}: 23 on a +#' uniform square, 27 to 38 on the census tracts of Iowa, North Carolina and +#' Texas, and the cap of 50 on California's, whose tracts are clustered. #' #' The domain extent used is the one \code{brms::gp(c = )} itself multiplies: #' the full pooled range of the column-centred coordinates @@ -408,14 +1249,158 @@ #' adequacy check below are all expressed in those standardised units, a second #' normalisation would leave every length-scale quantity in the wrong units. #' -#' After fitting, the posterior length-scale is compared against the smallest -#' scale the chosen basis can resolve -#' (\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); when -#' more than 10% of the posterior mass falls below it a WARN line is logged -#' and the share is recorded as -#' \code{$info$convergence_diagnostics$gp_lscale_below_resolution}, which is -#' the signal that \code{gp_k} should be raised. This runs with the other -#' checks, so only under \code{check_convergence = TRUE}. +#' \strong{What the basis resolves.} +#' The smallest length-scale the chosen basis can resolve is +#' \code{1.75 * gp_c * S / gp_k}, stored in standardised units as +#' \code{$info$gp_ell_min}. As an effective range (the distance at which the +#' squared-exponential correlation has fallen to 5 percent, 2.45 length-scales) +#' and in map units it is \code{$info$gp_resolution}, one value per axis +#' because each coordinate is divided by its own standard deviation. The +#' floor is soft: the basis keeps 99 percent of a process's variance at the +#' floor, 69 percent at half of it and 41 percent at a third. The default +#' length-scale prior is what makes it bind, with 1 percent of its mass below +#' the floor and about one part in a hundred million below half of it. +#' +#' Three checks hold the basis against the data. +#' \enumerate{ +#' \item Before anything is compiled, the autocorrelation range of the +#' response (of its OLS residuals when there are predictors) is estimated +#' with \code{\link{estimate_sac_range}()} and compared with the coarser +#' axis's floor. That range is a variogram estimate and can be wrong in +#' both directions, so a range below the floor raises a warning only when +#' two other things agree with it. The same variable is autocorrelated +#' at short range (Moran's I over 4 nearest neighbours, one-sided, at 5 +#' percent): a variogram fitted to a response with no spatial structure +#' can still return a short range (in 3 of 60 white-noise draws; +#' \code{estimate_sac_range()} refuses most such layers itself). And it is +#' no longer autocorrelated at the floor's distance (Moran's I over the +#' pairs 0.75 to 1.25 floors apart is not both above 0.05, the +#' correlation that defines an effective range, and significant at 5 +#' percent): a variogram can also return a short range for a surface +#' that is smooth over long distances. The warning has class +#' \code{spatialkit_gp_resolution}, gives both numbers and the basis size +#' that would resolve the range, says that it is an estimate which the +#' check after sampling tests against the residuals of the fitted model, +#' and says when the basis size is past the +#' cap or past the number of rows, where kriging is the better tool if +#' the range is right. A short range the floor-distance test contradicts +#' is logged and shown by \code{print()} without a warning: it can still +#' mean short-range structure beside a longer one, which the basis counts +#' as noise. Nothing before sampling separates the two; the residuals +#' after it do (the third check). A range that cannot be +#' estimated is logged with the reason and shown by \code{print()}; the +#' result is in \code{$info$gp_prefit}. In 60 simulated draws each +#' (400 points on a 100 km square, floor 33 km) the warning was raised +#' for 59 fields with a range of 8 to 15 km; for 0 or 1 fields +#' that were squared-exponential with a range of 60 or 90 km, a sine or +#' a plane; for 2 of white noise; and for 5 exponential fields with a +#' 60 km range. An exponential field has structure at every scale, and +#' a fit of one with a 50 km range had 62 percent of its length-scale +#' draws below the floor, so those 5 are not plainly wrong. +#' \item Also before sampling, the share of the length-scale prior below +#' the floor is computed (\code{$info$gp_adequacy$prior_mass_below}). A +#' derived basis keeps it near 0.01; a small \code{gp_k} does not (0.98 +#' at \code{gp_k = 6} where the derived value is 23), and a share above +#' 0.10 is logged and flagged by \code{print()}. +#' \item After sampling, under \code{check_convergence = TRUE}, the +#' posterior and the residuals are read. The posterior says whether the +#' Gaussian process carries a share of the variance and where its +#' length-scale sits against the floor. It cannot say what the surface +#' left behind, so the residuals are tested for autocorrelation at short +#' range in every fit (Moran's I over 4 nearest neighbours, one-sided, +#' at 5 percent; \code{$info$gp_adequacy$residual_moran}). +#' \code{$info$gp_adequacy$status} is one of: +#' \describe{ +#' \item{\code{"ok"}}{The Gaussian process carries a share of the +#' variance, its length-scale is clear of the floor, and the +#' residuals show no autocorrelation at short range. A surface +#' smoother than the prior expects (a plane, a range longer than the +#' extent) is \code{"ok"}: its length-scale posterior sits on the +#' long side of the prior and is wider than it.} +#' \item{\code{"below_resolution"}}{The Gaussian process carries a +#' share of the variance and more than 10 percent of the +#' length-scale draws fall below the floor. The 10 percent trigger +#' is this package's operationalisation of the check Riutort-Mayol +#' et al. recommend, not a figure from the paper.} +#' \item{\code{"unresolved_short_range"}}{The residuals are +#' autocorrelated at short range: the signature of structure finer +#' than the basis, counted as noise. It is reached two ways, and +#' \code{$info$gp_adequacy$identified} says which. The Gaussian +#' process carries no variance that can be told from zero +#' (\code{FALSE}): all of the structure is below the floor. Or it +#' carries a share and its length-scale is clear of the floor +#' (\code{TRUE}): it fitted a surface, and finer structure sits +#' beside it, as with a regional trend plus short-range structure.} +#' \item{\code{"no_signal_above_floor"}}{The Gaussian process carries +#' no variance that can be told from zero, and the residuals show +#' nothing left over. A response with no spatial structure gives +#' this, so it is not a failure by itself.} +#' \item{\code{"not_checked"}}{\code{check_convergence = FALSE}.} +#' } +#' The second and third raise a warning of class +#' \code{spatialkit_gp_adequacy}; the fourth is logged. When the +#' residuals cannot be tested (an ordinal or categorical family has no +#' residual per row; a posterior that cannot be drawn), the status rests +#' on the posterior alone, a line is logged, the reason is in +#' \code{$info$gp_adequacy$residual_untested}, and \code{print()} keeps +#' its flag on a variogram range that was below the floor. +#' +#' The residual test rests on fits of points on a 100 km square whose +#' floor is 32 to 33 km. Sampled fits: ten of a response with a +#' component below the floor (a field with an 8 or 12 km range, alone or +#' beside a plane or a field with a 90 km range) had p of 5.3e-10 to +#' 0.014, and five of the ten had a posterior that reads \code{"ok"}; +#' twelve of a response with none (planes, bowls, a sine, fields with +#' ranges of 45 to 200 km) had p of 0.66 to 0.97. At the posterior mode +#' of the same model, computed without sampling, the test was +#' significant in 0 of 160 fits of fields with ranges of 45 to 200 km +#' and in 3 of 120 fits of a plane, a bowl and a sine (one noise draw of +#' the 40, shared by the three, whose own Moran's I has p = 0.003); +#' and in 16 to 18 of 20 fits of each of four responses with an 8 km +#' field in them, where the length-scale at the mode was below the floor +#' in 0 or 1 of the 20. On a fit with nothing left over the test is +#' conservative, because the surface takes up part of the noise and +#' leaves the residuals slightly negatively autocorrelated (median I of +#' -0.03 to -0.07). It is not sharp just below the floor: a field with +#' a 20 km range was significant in 8 of 20 fits, and there it is the +#' length-scale draws that report it (\code{"below_resolution"}). An +#' exponential field has structure at every scale and can be reported +#' with a range above the floor (8 of 20 fits at 60 km). The 5 percent +#' level is the usual one and is not tuned; with many rows a small +#' leftover autocorrelation is significant, so read the size of I +#' beside its p. +#' +#' "No variance +#' that can be told from zero" is decided on the Gaussian process's share +#' of the variance, \code{sdgp^2 / (sdgp^2 + sigma^2)}: its 2.5 percent +#' quantile is under 0.01. On nine fits that quantile was 0.000 to 0.003 +#' for the three with nothing for the process to find and 0.17 to 0.94 +#' for the six with a surface; the threshold rests on those nine. It +#' does not mark off a response whose structure is all below the floor: +#' on five fits of a field with an 8 km range under a 33 km floor the +#' quantile was 0.000, 0.000, 0.001, 0.015 and 0.019, so two of the five +#' count as carrying a share, and it is the residual test that reports +#' them. The +#' share exists for a gaussian or lognormal family. For any other +#' family the length-scales decide instead: the process is not identified +#' when on every axis the posterior kept more than three quarters of its +#' prior's variance and the largest gap between its distribution function +#' and the prior's is under 0.30. That second rule has been checked on +#' the length-scale draws of the same nine gaussian fits, where it agrees +#' with the share on eight, and on no fit of another family. +#' \code{$info$gp_adequacy$identified_by} says which rule was used. The width of the length-scale posterior does not +#' decide by itself, because a posterior that moved to longer +#' length-scales is wider than its prior; and the share of draws below +#' the floor cannot detect an unidentified process, because a posterior +#' the data did not move puts 1 percent below the floor, the same as the +#' prior. +#' } +#' A response whose range is below the floor needs a finer basis and a prior +#' that allows the shorter length-scale, both of which \code{gp_resolution} +#' sets, up to the cap. Past the cap this model is the wrong tool: resolving +#' a 30 km range on the North Carolina tracts would take 156 functions per +#' dimension, 24,336 in all for 2,672 points. Kriging has no such floor; see +#' \code{\link{kriging_adequacy}()} for cell means. #' #' \strong{Coordinate scaling and anisotropy.} #' Before fitting the GP, X and Y coordinates are each centred and divided by @@ -446,6 +1431,40 @@ #' Model-specific metadata lives in \code{$info} (coords: the names of the #' scaled coordinate columns handed to \code{brms::gp()}; coord_scaling, #' predictor_scaling, gp_k, gp_c, gp_iso, gp_n_basis, gp_ell_min, +#' gp_resolution: the smallest effective range the basis resolves, as +#' \code{c(x, y)} in map units; gp_resolution_requested: the +#' \code{gp_resolution} argument, or \code{NULL}; +#' gp_prefit: the check made before sampling, a list with \code{status} +#' (\code{"ok"}; \code{"below_floor"}, the one that warns; +#' \code{"below_floor_no_autocorrelation"} and +#' \code{"below_floor_long_range"}, a range below the floor that the +#' short-lag or the floor-distance test did not bear out; +#' \code{"not_estimated"} or \code{"not_run"}), \code{range} (the +#' estimated range in map units), \code{floor}, \code{k_needed}, +#' \code{moran} and \code{moran_floor} (the two Moran's I tests, each with +#' \code{I}, \code{z} and a one-sided \code{p}), \code{reason} and +#' \code{unit}; +#' gp_adequacy: a list with \code{status} (see Details), \code{frac_below} +#' (the share of length-scale draws below \code{gp_ell_min}), +#' \code{identified} and \code{identified_by} (\code{"spatial_share"} or +#' \code{"length_scale"}, the rule that decided it; see Details), +#' \code{contraction} (one minus the ratio of posterior to prior variance, +#' per length-scale, negative when the posterior is the wider of the two) +#' and \code{prior_gap} (the largest gap between the posterior's and the +#' prior's distribution functions, per length-scale; both \code{NA} for a +#' length-scale prior this function did not set), \code{spatial_share} and +#' \code{sdgp} (2.5, +#' 50 and 97.5 percent quantiles; the share only for a gaussian or lognormal +#' family), \code{effective_range} (the posterior effective range per axis +#' in map units, same quantiles), \code{residual_moran} (the test on the +#' residuals the status rests on: \code{I}, \code{z}, a one-sided \code{p} +#' and \code{k}, the number of neighbours; absent when it could not be +#' run, and \code{residual_untested} then says why), \code{resolution}, +#' \code{unit} and \code{prior_mass_below}; +#' b_prior: the slope prior brms used (\code{"(flat)"} for its default, +#' \code{NA} for a model with no slopes), and b_prior_source: where it came +#' from; predictor_levels: the levels each factor or character predictor +#' has in the training rows, which \code{predict()} holds new data to; #' gp_S: the pooled centred range \code{brms::gp(c = )} multiplies; #' gp_cmeans: the column means brms centred the scaled coordinates on; #' gp_xy_range: the training extrema of the scaled coordinates, which @@ -458,15 +1477,48 @@ #' semicolon-separated, if brms resolved the axes differently); loo, looic, #' convergence_ok (\code{TRUE} or \code{FALSE}, and \code{NA} when nothing #' was checked, as under \code{check_convergence = FALSE}), -#' convergence_diagnostics: \code{n_divergent}, -#' \code{max_rhat}, \code{min_neff_ratio}, and \code{rhat_failed} / -#' \code{neff_failed}, the parameters that failed each check by name with -#' their values (empty when none failed), which is what makes a failed -#' check actionable; and n_dropped: the rows +#' convergence_diagnostics: \code{n_divergent}, \code{n_max_treedepth}, +#' \code{ebfmi} (per chain), \code{max_rhat}, \code{min_neff_ratio}, +#' \code{min_ess} (the smallest bulk or tail effective sample size) and +#' \code{ess_required} (100 per chain), and \code{rhat_failed} / +#' \code{neff_failed} / \code{ess_failed}, the parameters that failed each +#' check by name with their values (R-hat, ESS ratio and ESS; empty when +#' none failed), which is what makes a failed check actionable, +#' \code{rhat_caution}, the parameters whose R-hat is between 1.01 and 1.05 +#' with enough effective draws, which do not fail the verdict, plus +#' \code{gp_lscale_below_resolution} and \code{gp_adequacy}, the share and +#' status described under Details; and n_dropped: the rows #' \code{prep_model_data()} removed for missing or non-finite values or a #' bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}). #' The raw brmsfit is in \code{$engine}. #' @family model fitting +#' @section Warnings: +#' Every warning this function raises carries a condition class, so a caller +#' can catch or muffle exactly one of them by name: +#' \describe{ +#' \item{\code{spatialkit_rows_dropped}, +#' \code{spatialkit_constant_predictor}}{From +#' \code{\link{prep_model_data}()}: incomplete rows were dropped, with the +#' counts; a predictor takes one value in every row kept.} +#' \item{\code{spatialkit_gp_basis_size}}{Fewer than one row per ten basis +#' functions.} +#' \item{\code{spatialkit_gp_resolution}}{A variogram fitted before +#' compiling puts the response's range below what the basis resolves, and +#' the autocorrelation of the response agrees. An estimate; the check +#' after sampling tests it against the residuals of the fitted model.} +#' \item{\code{spatialkit_convergence}}{The sampler's diagnostics fail.} +#' \item{\code{spatialkit_gp_adequacy}}{The basis is too coarse for the +#' data: the posterior asks for a shorter length-scale than it resolves +#' (\code{"below_resolution"}), or the residuals are autocorrelated at +#' short range (\code{"unresolved_short_range"}).} +#' } +#' A response that takes a single value is an error, raised before anything +#' is compiled. The convergence warning carries the checks that failed as +#' \code{failed} (\code{"divergent"}, \code{"ebfmi"}, \code{"rhat"}, +#' \code{"ess"}). \code{\link{cv_bayes}()} fits once per fold; it collects +#' the last four classes from its folds and raises each once for the run, +#' naming the folds, and \code{\link{cv_spatial}()} does the same for a +#' \code{fit_fn} that calls this function. #' @section Non-Gaussian responses: #' Nothing in this function is Gaussian-specific except its default. A #' numeric count, binary (0/1 or logical) or bounded response passes straight @@ -580,6 +1632,14 @@ #' } #' } #' @references +#' Betancourt, M. (2016). Diagnosing suboptimal cotangent disintegrations in +#' Hamiltonian Monte Carlo. arXiv:1604.00695. +#' +#' Vehtari, A., Gelman, A., Simpson, D., Carpenter, B. and Burkner, P.-C. +#' (2021). Rank-normalization, folding, and localization: an improved R-hat +#' for assessing convergence of MCMC (with discussion). \emph{Bayesian +#' Analysis} \strong{16}, 667--718. \doi{10.1214/20-BA1221} +#' #' Riutort-Mayol, G., Burkner, P.-C., Andersen, M. R., Solin, A. and #' Vehtari, A. (2023). Practical Hilbert space approximate Bayesian #' Gaussian processes for probabilistic programming. @@ -636,6 +1696,7 @@ fit_bayesian_spatial_model <- function( check_convergence = TRUE, pointize = "auto", boundary = NULL, + gp_resolution = NULL, .already_prepped = FALSE ) { if (!inherits(data_sf, "sf")) @@ -742,6 +1803,19 @@ fit_bayesian_spatial_model <- function( response_var), call. = FALSE) + # A response with one value leaves nothing for the regression or the GP to + # explain. It used to reach the compiler: a minute of C++ and then a + # sampler with sigma running into zero, for a model that could have been + # refused from the column alone. + if (length(unique(y_resp)) <= 1L) + stop(sprintf(paste0("fit_bayesian_spatial_model(): response '%s' takes a ", + "single value (%s) in all %d row(s), so there is no ", + "variation for the regression or the Gaussian process ", + "to explain. Check the column and the filter that ", + "produced these rows."), + response_var, format(y_resp[[1L]]), nrow(dat_sf)), + call. = FALSE) + # NOTE: prep_model_data() coerces geometry to points and drops incomplete # rows, and projects the CRS *whenever one can be established* -- # ensure_projected() passes a CRS-less dataset through unchanged when its @@ -827,7 +1901,52 @@ fit_bayesian_spatial_model <- function( gp_spec <- .gp_basis_spec(cbind(dat_df[["..x"]], dat_df[["..y"]]), ls_bounds, c = gp_c) gp_k_auto <- is.null(gp_k) - if (gp_k_auto) gp_k <- gp_spec$k + k_cap <- as.integer(floor(sqrt(.gp_max_basis))) + xy_scale <- c(x = x_scale, y = y_scale) + unit_lbl <- .gp_unit_label(dat_sf) + + # ---- A requested resolution, in map units ---- + # The percentile rule sizes the basis from the layout alone; this sizes it + # from the shortest effective range the caller wants represented. It can + # only refine: a request the derived basis already meets keeps the derived + # basis. Past the cap it is an error, not a silent cap, because the caller + # asked for a range the model then cannot hold. + gp_resolution_requested <- NULL + if (!is.null(gp_resolution)) { + if (!is.numeric(gp_resolution) || length(gp_resolution) != 1L || + !is.finite(gp_resolution) || gp_resolution <= 0) + stop(sprintf(paste0("fit_bayesian_spatial_model(): `gp_resolution` must ", + "be a single positive number: the shortest effective ", + "range the basis should resolve, in the units of the ", + "data's CRS (%s)."), unit_lbl), call. = FALSE) + if (!gp_k_auto) + stop(paste0("fit_bayesian_spatial_model(): pass `gp_resolution` or ", + "`gp_k`, not both. `gp_resolution` derives `gp_k`."), + call. = FALSE) + c_use <- if (is.null(gp_c)) gp_spec$c else gp_c + k_req <- .gp_k_needed(gp_resolution, c_use, gp_spec$S, xy_scale) + if (!is.finite(k_req) || k_req > k_cap) { + finest <- .gp_se_range_factor * (1.75 * c_use * gp_spec$S / k_cap) * xy_scale + stop(sprintf(paste0("fit_bayesian_spatial_model(): `gp_resolution` = %s ", + "%s needs gp_k = %s per dimension (%s basis ", + "functions), above the cap of %d (%d). At the cap ", + "this layout resolves effective ranges from %s %s ", + "along x and %s %s along y. A shorter range is ", + "outside what the reduced-rank GP can represent ", + "here: use kriging, or model cell means (see ", + "kriging_adequacy())."), + .gp_fmt_dist(gp_resolution), unit_lbl, + format(k_req, big.mark = ",", scientific = FALSE), + format(k_req^2, big.mark = ",", scientific = FALSE), + k_cap, k_cap^2, + .gp_fmt_dist(finest[["x"]]), unit_lbl, + .gp_fmt_dist(finest[["y"]]), unit_lbl), + call. = FALSE) + } + gp_resolution_requested <- as.numeric(gp_resolution) + gp_k <- max(as.integer(k_req), gp_spec$k) + } + if (is.null(gp_k)) gp_k <- gp_spec$k if (is.null(gp_c)) gp_c <- gp_spec$c # Validate before the arithmetic below divides by gp_k. Previously an @@ -853,21 +1972,72 @@ fit_bayesian_spatial_model <- function( # resolution of the basis brms will actually build, not of a notional one. # Reported here and re-checked against the posterior after fitting. gp_ell_min <- 1.75 * gp_c * gp_spec$S / gp_k + # The same floor as an effective range in map units, per axis: what a user + # can hold against the distances in their data. The axes differ because + # each coordinate was divided by its own SD. + gp_resolution_xy <- .gp_se_range_factor * gp_ell_min * xy_scale .log_info( paste0("fit_bayesian_spatial_model(): GP basis k = %d per dimension, ", "c = %.2f; TOTAL basis functions = %d (n = %d). ", - "Smallest resolvable length-scale = %.4f on scaled coords."), - gp_k, gp_c, gp_k^2, nrow(dat_sf), gp_ell_min + "Smallest resolvable length-scale = %.4f on scaled coords: ", + "effective ranges from %s %s along x and %s %s along y."), + gp_k, gp_c, gp_k^2, nrow(dat_sf), gp_ell_min, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl ) - if (isTRUE(gp_spec$capped) && isTRUE(gp_k_auto)) + if (isTRUE(gp_spec$capped) && isTRUE(gp_k_auto) && + is.null(gp_resolution_requested)) .log_warn( - paste0("fit_bayesian_spatial_model(): derived GP basis count was capped ", - "at %d. The approximation may under-resolve short-range structure; ", - "pass a larger gp_k explicitly if short-range spatial variation ", - "matters."), - gp_k^2 + paste0("fit_bayesian_spatial_model(): the derived GP basis was capped ", + "at %d per dimension (%d basis functions), the most this function ", + "fits. It resolves effective ranges from %s %s along x and %s %s ", + "along y; shorter structure is counted as noise."), + gp_k, gp_k^2, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl ) + # ---- The length-scale prior follows a basis the caller made finer ---- + # The prior's lower 1% tail sits at the percentile bound, and the derived + # basis is sized to that bound. A finer basis under the same prior gains + # almost nothing, because the prior, not the basis, then holds the + # length-scale up: on fields with a 15 km range, k = 50 with the percentile + # prior fitted a 34 km range, the same as an exact GP under that prior, and + # 17.6 km once the tail was moved to what k = 50 resolves. So the tail + # moves down with the basis. It never moves up: a basis coarser than the + # bound would pin the prior into a sliver (1.76 to 1.89 at gp_k = 6), and + # that case is reported below as prior mass under the floor instead. Only + # a basis finer than the derived one (an explicit gp_k above it, or a + # gp_resolution that needed more) moves the tail, so a default fit, and a + # request the derived basis already meets, have the prior they always had. + if (gp_k > gp_spec$k && gp_ell_min < ls_bounds[["lower"]]) { + .log_info( + paste0("fit_bayesian_spatial_model(): gp_k = %d resolves a shorter ", + "length-scale (%.4f) than the prior's lower bound (%.4f); the ", + "prior's lower 1%% tail moves to %.4f so the finer basis can be ", + "used."), + gp_k, gp_ell_min, ls_bounds[["lower"]], gp_ell_min + ) + ls_bounds[["lower"]] <- gp_ell_min + } + + # Fewer than one row per ten basis functions. The approximation is still a + # valid GP prior, but most weights are then set by that prior alone and the + # sampler pays for all of them. + if (nrow(dat_sf) < gp_k^2 / 10) + .warn_classed( + "spatialkit_gp_basis_size", + paste0("fit_bayesian_spatial_model(): %d row(s) against %d basis ", + "functions (gp_k = %d per dimension), fewer than one row per ten ", + "basis functions. Most basis weights are then set by their prior, ", + "not the data, and sampling is slow. A smaller `gp_k` is cheaper ", + "but resolves less (now effective ranges from %s %s along x and ", + "%s %s along y); with this few rows kriging fits the same kind ", + "of model exactly."), + nrow(dat_sf), gp_k^2, gp_k, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl) + # Optional predictor standardization — store transform params so # predictions can be computed correctly on new data. predictor_scaling <- NULL @@ -927,15 +2097,25 @@ fit_bayesian_spatial_model <- function( # 2. GP length-scale prior (always, unless the user's prior already # includes an "lscale" class entry). + prior_from_user <- !is.null(prior) + b_prior_auto <- NULL if (is.null(prior)) { prior_parts <- list() if (isTRUE(standardize_predictors) && length(predictor_vars) > 0L) { + # The scale follows the response wherever the linear predictor is on + # the response's scale (.b_prior_auto()). A fixed normal(0, 5) is a + # different prior for every choice of units: with income in dollars it + # shrank a slope of 10,236 per SD to 0.3, with the same income in + # thousands it left 98.8% of it, and convergence_ok was TRUE both times. + b_prior_auto <- .b_prior_auto(y_resp, family) # One row per distributional parameter's slopes (.b_prior_rows()): a # dpar-less row matches no slope of a categorical or mixture model. prior_parts <- c(prior_parts, list( - .b_prior_rows("normal(0, 5)", fml, dat_df, family) + .b_prior_rows(b_prior_auto$spec, fml, dat_df, family) )) - .log_info("fit_bayesian_spatial_model(): using weakly informative normal(0,5) priors on standardized coefficients.") + .log_info(paste0("fit_bayesian_spatial_model(): slope prior %s on the ", + "standardised coefficients (%s)."), + b_prior_auto$spec, b_prior_auto$label) } prior <- if (length(prior_parts) > 0L) Reduce(`+`, prior_parts) else NULL } @@ -1110,6 +2290,161 @@ fit_bayesian_spatial_model <- function( } } + # The slope prior, read from the same table: what brms will use, not what + # was asked for. NA when the model has no slopes. + b_prior_used <- if (length(predictor_vars) > 0L) + .b_prior_used(if (is.data.frame(vp)) vp else NULL, b_prior_auto$spec) + else NA_character_ + b_prior_source <- if (length(predictor_vars) == 0L) NA_character_ + else if (!is.null(b_prior_auto)) sprintf("automatic: %s", b_prior_auto$label) + else if (prior_from_user) "from `prior`" + else "brms default" + + # ---- Prior mass below the basis floor ---- + # Known before sampling, and it bounds what the post-fit share can say: a + # posterior that the data did not move leaves this much below the floor. + # A derived basis keeps it near 0.01. A small user gp_k does not: 0.984 at + # gp_k = 6 on a layout whose derived value is 23, where the post-fit share + # (0.986) only restated it. + ls_prior_parsed <- .lscale_prior_parse(gp_lscale_prior_used) + prior_mass_below <- if (is.null(ls_prior_parsed)) NA_real_ + else as.numeric(ls_prior_parsed$cdf(gp_ell_min)) + if (is.finite(prior_mass_below) && prior_mass_below > 0.10) + .log_warn( + paste0("fit_bayesian_spatial_model(): %.0f%% of the length-scale prior ", + "(%s) lies below the smallest length-scale gp_k = %d resolves ", + "(%.4f on scaled coords; effective ranges from %s %s along x and ", + "%s %s along y). The basis is too coarse for the prior, so the ", + "share of posterior draws below that floor will be high whatever ", + "the data say.%s"), + 100 * prior_mass_below, gp_lscale_prior_used, gp_k, gp_ell_min, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl, + if (!gp_k_auto && gp_k < gp_spec$k) + sprintf(" Leave `gp_k` NULL (the derived value is %d) or raise it.", + gp_spec$k) + else "") + + # ---- The response's own range against the floor ---- + gp_prefit <- .gp_prefit_range_check( + dat_sf, response_var, predictor_vars, resolution = gp_resolution_xy, + gp_c = gp_c, S = gp_spec$S, xy_scale = xy_scale) + gp_prefit$unit <- unit_lbl + range_of <- if (length(predictor_vars) > 0L) + "the response net of the predictors" else "the response" + if (identical(gp_prefit$status, "below_floor")) { + # A variogram estimate, made before anything is fitted. It is said as + # one: the range can be wrong, and the check after sampling reads the + # fitted model and its residuals. The message used to state the range + # as fact and tell the caller the model could not represent it. It does + # not say the later check "supersedes" it either: that check answers on + # the residuals, and a status of "ok" over residuals nobody had read left + # a warning that was right withdrawn by a check that had not looked. + k_need <- gp_prefit$k_needed + k_txt <- format(k_need, big.mark = ",", scientific = FALSE) + k2_txt <- format(k_need^2, big.mark = ",", scientific = FALSE) + advice <- if (k_need > k_cap) + sprintf(paste0("Resolving it would take gp_k = %s per dimension (%s ", + "basis functions), above the cap of %d; if the fitted ", + "model bears the range out, use kriging, or model cell ", + "means (see kriging_adequacy())."), k_txt, k2_txt, k_cap) + else + sprintf(paste0("Resolving it would take gp_k = %s per dimension (%s ", + "basis functions): gp_resolution = %s fits that basis.%s"), + k_txt, k2_txt, format(signif(gp_prefit$range, 3), + scientific = FALSE, trim = TRUE), + if (k_need^2 > nrow(dat_sf)) + sprintf(paste0(" That is more basis functions than the %d ", + "row(s); if the range is right, kriging (see ", + "kriging_adequacy() for cell means) is usually ", + "the better tool."), + nrow(dat_sf)) + else "") + mf <- gp_prefit$moran_floor + .warn_classed( + "spatialkit_gp_resolution", + paste0("fit_bayesian_spatial_model(): a variogram fitted before ", + "sampling puts the autocorrelation range of %s at %s %s, shorter ", + "than the %s %s this basis resolves (gp_k = %d: effective ranges ", + "from %s %s along x and %s %s along y). This is an estimate and ", + "can be wrong%s; the check after sampling ($info$gp_adequacy, ", + "shown by print()) reads the fitted model and tests its ", + "residuals for what the surface left behind. If ", + "the range is right, structure at that range is counted as ", + "noise: the surface is smoothed over it and the intervals are ", + "too narrow. %s"), + range_of, .gp_fmt_dist(gp_prefit$range), unit_lbl, + .gp_fmt_dist(gp_prefit$floor), unit_lbl, gp_k, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl, + if (!is.null(mf)) + sprintf(paste0(", though the autocorrelation at the floor's distance ", + "agrees with it (Moran's I = %.3f over pairs %s to %s ", + "%s apart)"), mf$I, .gp_fmt_dist(mf$band[1L]), + .gp_fmt_dist(mf$band[2L]), unit_lbl) + else "", + advice) + } else if (identical(gp_prefit$status, "below_floor_long_range")) { + mf <- gp_prefit$moran_floor + .log_warn( + paste0("fit_bayesian_spatial_model(): a variogram fitted before ", + "sampling puts the autocorrelation range of %s at %s %s, below ", + "the %s %s this basis resolves, but %s is still autocorrelated ", + "at that distance (Moran's I = %.3f over pairs %s to %s %s ", + "apart, one-sided p = %.2g; an effective range ends where the ", + "correlation falls to 0.05). The variogram's range is therefore ", + "not the reach of the structure, and no warning is raised on ", + "it. Either the variogram fitted a smooth surface badly, or ", + "there is short-range structure beside a longer one, which this ", + "basis counts as noise; the check after sampling ", + "($info$gp_adequacy) tells the two apart on the residuals of ", + "the fitted model."), + range_of, .gp_fmt_dist(gp_prefit$range), unit_lbl, + .gp_fmt_dist(gp_prefit$floor), unit_lbl, range_of, mf$I, + .gp_fmt_dist(mf$band[1L]), .gp_fmt_dist(mf$band[2L]), unit_lbl, mf$p) + } else if (identical(gp_prefit$status, "not_estimated")) { + mor <- gp_prefit$moran + .log_warn( + paste0("fit_bayesian_spatial_model(): the autocorrelation range of %s ", + "could not be estimated before fitting (%s), so the basis ", + "(effective ranges from %s %s along x and %s %s along y) was not ", + "checked against it.%s"), + range_of, gp_prefit$reason, + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl, + if (!is.null(mor) && isTRUE(mor$p < 0.05)) { + # Any real structure is autocorrelated at short range, long-range + # structure included, so that alone does not point below the floor. + mf <- gp_prefit$moran_floor + if (!is.null(mf) && isTRUE(mf$I > .gp_range_correlation) && + isTRUE(mf$p < 0.05)) + sprintf(paste0(" It is still autocorrelated at the floor's ", + "distance (Moran's I = %.3f over pairs %s to %s %s ", + "apart, one-sided p = %.2g), so its structure ", + "reaches at least as far as the basis resolves."), + mf$I, .gp_fmt_dist(mf$band[1L]), .gp_fmt_dist(mf$band[2L]), + unit_lbl, mf$p) + else + sprintf(paste0(" It is autocorrelated at short range (Moran's I = ", + "%.3f over 4 nearest neighbours, one-sided p = %.2g)", + "%s, so a range below that floor is not ruled out."), + mor$I, mor$p, + if (!is.null(mf)) + sprintf(" and not at the floor's distance (Moran's I = %.3f)", + mf$I) + else "") + } else "") + } else if (identical(gp_prefit$status, "below_floor_no_autocorrelation")) { + .log_info( + paste0("fit_bayesian_spatial_model(): a variogram fitted to %s gave a ", + "range of %s %s, below the basis floor, but it shows no ", + "short-range autocorrelation (Moran's I = %.3f over 4 nearest ", + "neighbours, one-sided p = %.2g), so that range is not read as ", + "structure."), + range_of, .gp_fmt_dist(gp_prefit$range), unit_lbl, + gp_prefit$moran$I, gp_prefit$moran$p) + } + brm_args <- list( formula = fml, data = dat_df, family = family, prior = prior, chains = chains, iter = iter, warmup = warmup, cores = cores, @@ -1126,62 +2461,143 @@ fit_bayesian_spatial_model <- function( # check_convergence = FALSE returned convergence_ok = TRUE over an empty # diagnostics list -- a verdict on checks that never happened, for a fit # whose max R-hat was 1.28 -- and print() had nothing to caveat. + # + # The verdict follows Stan's own diagnostics (see @param check_convergence + # for the source of each threshold). It used to cut R-hat at 1.05 and to + # judge effective sample size as a share of the draws, which equals 100 + # per chain only at the default 4 x 2000: a fit of 2 x 600 with bulk and + # tail ESS of 130 and 137 passed while rstan raised both of its ESS + # warnings on it. convergence_ok <- NA convergence_diagnostics <- list() + conv_problems <- character(0) + # Which checks failed, so the advice that closes the warning fits them. + conv_failed <- character(0) + gp_adequacy <- list(status = "not_checked") if (isTRUE(check_convergence) && inherits(fit, "brmsfit")) { convergence_ok <- TRUE - # Divergent transitions + # Chains and post-warmup draws, read from the fit; the call's own + # arguments when the fit cannot say. + n_chains <- tryCatch(as.numeric(brms::nchains(fit)), error = function(e) NA_real_) + if (length(n_chains) != 1L || !is.finite(n_chains) || n_chains < 1) + n_chains <- suppressWarnings(as.numeric(chains))[1L] + n_draws <- tryCatch(as.numeric(brms::ndraws(fit)), error = function(e) NA_real_) + if (length(n_draws) != 1L || !is.finite(n_draws) || n_draws < 1) + n_draws <- suppressWarnings(as.numeric(chains) * + (as.numeric(iter) - as.numeric(warmup)))[1L] + + # Divergent transitions, tree-depth saturation and E-BFMI np <- tryCatch(brms::nuts_params(fit), error = function(e) NULL) if (!is.null(np)) { n_divergent <- sum(np$Value[np$Parameter == "divergent__"], na.rm = TRUE) convergence_diagnostics$n_divergent <- n_divergent if (n_divergent > 0L) { convergence_ok <- FALSE - .log_warn( - "fit_bayesian_spatial_model(): %d divergent transition(s) detected. Consider increasing adapt_delta (currently %.2f) or reparameterizing the model.", - n_divergent, control$adapt_delta %||% 0.8 - ) + conv_failed <- c(conv_failed, "divergent") + conv_problems <- c(conv_problems, sprintf( + "%d divergent transition(s) after warmup", n_divergent)) + } + # Transitions that stopped at the tree-depth limit. Stan calls this an + # efficiency concern, not a validity one, so it is recorded and logged + # and does not change the verdict. + td <- np$Value[np$Parameter == "treedepth__"] + if (length(td) > 0L) { + max_td <- suppressWarnings(as.numeric(control$max_treedepth %||% 10))[1L] + n_max_td <- sum(td >= max_td, na.rm = TRUE) + convergence_diagnostics$n_max_treedepth <- n_max_td + if (n_max_td > 0L) + .log_warn( + paste0("fit_bayesian_spatial_model(): %d transition(s) stopped at ", + "max_treedepth = %s. That slows sampling and does not by ", + "itself invalidate the draws; raise max_treedepth in ", + "`control` if the effective sample size is low."), + n_max_td, format(max_td)) + } + ebfmi <- .bayes_ebfmi(np) + if (length(ebfmi) > 0L) { + convergence_diagnostics$ebfmi <- ebfmi + low_e <- which(ebfmi < .bayes_ebfmi_min) + if (length(low_e) > 0L) { + convergence_ok <- FALSE + conv_failed <- c(conv_failed, "ebfmi") + conv_problems <- c(conv_problems, sprintf( + "E-BFMI below %s in chain(s) %s (%s)", format(.bayes_ebfmi_min), + paste(names(ebfmi)[low_e], collapse = ", "), + paste(sprintf("%.2f", ebfmi[low_e]), collapse = ", "))) + } } } - # R-hat. Both accessors run under .muffle_ess_cap(): posterior's - # "The ESS has been capped" arrives once per well-mixed basis weight. + # R-hat and effective sample size. Both accessors run under + # .muffle_ess_cap(): posterior's "The ESS has been capped" arrives once + # per well-mixed basis weight. Both are read before either is judged, + # because an R-hat between 1.01 and 1.05 is judged beside the effective + # sample size of the same parameter. rhat_vals <- tryCatch({ rh <- .muffle_ess_cap(brms::rhat(fit)) if (is.numeric(rh)) rh else NULL }, error = function(e) NULL) - + neff_vals <- tryCatch({ + ne <- .muffle_ess_cap(brms::neff_ratio(fit)) + if (is.numeric(ne)) ne else NULL + }, error = function(e) NULL) + if (!is.null(rhat_vals)) { + if (is.null(names(rhat_vals))) + names(rhat_vals) <- sprintf("parameter %d", seq_along(rhat_vals)) # brms::rhat() returns NaN for a parameter that is constant across # draws, which `lprior` frequently is. Two consequences had to be - # guarded. `names(rhat_vals)[rhat_vals > 1.05]` keeps one NA element per - # NaN entry -- so convergence_ok was set FALSE and the warning named - # "NA" -- while which() drops them. And max(..., na.rm = TRUE) over an - # all-NA vector is -Inf with a warning, not a diagnostic. + # guarded. A logical subscript keeps one NA element per NaN entry -- + # so convergence_ok was set FALSE and the warning named "NA" -- while + # which() drops them. And max(..., na.rm = TRUE) over an all-NA + # vector is -Inf with a warning, not a diagnostic. max_rhat <- if (any(is.finite(rhat_vals))) max(rhat_vals[is.finite(rhat_vals)]) else NA_real_ convergence_diagnostics$max_rhat <- max_rhat - bad_rhat <- names(rhat_vals)[which(rhat_vals > 1.05)] - # Every failing parameter by name, with its value -- the log line + # Two tiers (.bayes_rhat_tiers()): above 1.05 fails; above 1.01 fails + # when that parameter's effective sample size is short as well, and is + # a caution when it is not. One cut at 1.01 over about 540 parameters + # failed a default fit whose largest R-hat was 1.011 and whose smallest + # effective sample size was 1,278 against 400 required. + tiers <- .bayes_rhat_tiers(rhat_vals, neff_vals, n_draws, n_chains) + bad_rhat <- tiers$failed + # Every failing parameter by name, with its value -- the message # names five, and "max R-hat 1.09" is not actionable where # "sdgp_gp..x..y has R-hat 1.09" is. An empty named numeric when none. - convergence_diagnostics$rhat_failed <- rhat_vals[bad_rhat] + convergence_diagnostics$rhat_failed <- rhat_vals[bad_rhat] + convergence_diagnostics$rhat_caution <- rhat_vals[tiers$caution] + n_caution <- length(tiers$caution) if (length(bad_rhat) > 0L) { convergence_ok <- FALSE + conv_failed <- c(conv_failed, "rhat") + n_hi <- sum(rhat_vals[bad_rhat] > .bayes_rhat_max) + conv_problems <- c(conv_problems, sprintf( + paste0("%d parameter(s) fail on R-hat (max %.3f): %d above %s, %d ", + "above %s with %s%s: %s"), + length(bad_rhat), max_rhat, n_hi, format(.bayes_rhat_max), + length(bad_rhat) - n_hi, format(.bayes_rhat_caution), + if (is.null(neff_vals)) + "an effective sample size that could not be read" + else "too few effective draws", + if (n_caution > 0L) + sprintf(" (%d more above %s have enough and are not counted)", + n_caution, format(.bayes_rhat_caution)) else "", + paste(utils::head(bad_rhat, 5), collapse = ", "))) + } else if (n_caution > 0L) { .log_warn( - "fit_bayesian_spatial_model(): %d parameter(s) have R-hat > 1.05 (max = %.3f): %s. The model may not have converged.", - length(bad_rhat), max_rhat, - paste(utils::head(bad_rhat, 5), collapse = ", ") - ) + paste0("fit_bayesian_spatial_model(): %d of %d parameter(s) have ", + "R-hat between %s and %s (max %.3f), each with at least the ", + "%s effective draws required. Among this many parameters ", + "that happens by chance in a converged fit, so ", + "$info$convergence_ok does not fail on it; ", + "$info$convergence_diagnostics$rhat_caution names them."), + n_caution, sum(is.finite(rhat_vals)), format(.bayes_rhat_caution), + format(.bayes_rhat_max), max_rhat, + format(.bayes_ess_per_chain * n_chains)) } } - - # Effective sample size ratio - neff_vals <- tryCatch({ - ne <- .muffle_ess_cap(brms::neff_ratio(fit)) - if (is.numeric(ne)) ne else NULL - }, error = function(e) NULL) - + + # Effective sample size if (!is.null(neff_vals)) { # Same NaN hazard as R-hat above: a constant parameter has no effective # sample size. which() drops the NAs a logical subscript would keep as @@ -1190,15 +2606,22 @@ fit_bayesian_spatial_model <- function( min_neff <- if (any(is.finite(neff_vals))) min(neff_vals[is.finite(neff_vals)]) else NA_real_ convergence_diagnostics$min_neff_ratio <- min_neff - low_neff <- names(neff_vals)[which(neff_vals < 0.1)] + # neff_ratio is min(bulk, tail) ESS over the draws, so the smaller of + # the two effective sample sizes is the ratio times the draws. + convergence_diagnostics$min_ess <- min_neff * n_draws + convergence_diagnostics$ess_required <- .bayes_ess_per_chain * n_chains + low_neff <- .bayes_low_ess(neff_vals, n_draws, n_chains) convergence_diagnostics$neff_failed <- neff_vals[low_neff] + convergence_diagnostics$ess_failed <- neff_vals[low_neff] * n_draws if (length(low_neff) > 0L) { convergence_ok <- FALSE - .log_warn( - "fit_bayesian_spatial_model(): %d parameter(s) have effective sample size ratio < 0.1 (min = %.3f): %s. Consider running longer chains.", - length(low_neff), min_neff, - paste(utils::head(low_neff, 5), collapse = ", ") - ) + conv_failed <- c(conv_failed, "ess") + conv_problems <- c(conv_problems, sprintf( + paste0("%d parameter(s) with bulk or tail effective sample size ", + "under %s (%s per chain x %s chain(s); min %.0f): %s"), + length(low_neff), format(.bayes_ess_per_chain * n_chains), + format(.bayes_ess_per_chain), format(n_chains), min_neff * n_draws, + paste(utils::head(low_neff, 5), collapse = ", "))) } } @@ -1208,9 +2631,15 @@ fit_bayesian_spatial_model <- function( # resolve, the Hilbert-space approximation is inadequate and nothing else # here would say so. Riutort-Mayol et al. (2023) recommend checking that # the posterior length-scale lies inside the region the basis resolves and - # raising m when it does not; the 10% posterior-mass trigger below is this + # raising m when it does not; the 10% posterior-mass trigger is this # package's operationalisation of that check, not a figure from the paper. - # It is what makes a smaller default gp_k safe rather than merely cheaper. + # + # That share alone is blind when the data do not inform the length-scale: + # the posterior then equals the prior, which puts about 1% below the floor + # by construction. .gp_adequacy() therefore asks first whether the GP is + # identified at all; the residual check that splits "no structure" from + # "structure the basis cannot hold" needs the fitted values and runs once + # the fit object exists, below. # # brms names GP parameters lscale(gp...) / sdgp(gp...), embedding the # covariate names, so match on the prefix rather than a literal term name. @@ -1220,20 +2649,28 @@ fit_bayesian_spatial_model <- function( error = function(e) NULL ) if (!is.null(ls_draws) && length(ls_draws) > 0L) { - frac_below <- mean(as.numeric(ls_draws) < gp_ell_min, na.rm = TRUE) - convergence_diagnostics$gp_lscale_below_resolution <- frac_below - if (is.finite(frac_below) && frac_below > 0.10) - .log_warn( - paste0("fit_bayesian_spatial_model(): %.0f%% of posterior ", - "length-scale draws fall below the smallest scale this basis ", - "can resolve (%.4f). Consider raising gp_k (currently %d, ", - "%d total basis functions)."), - 100 * frac_below, gp_ell_min, gp_k, gp_k^2 - ) + one_col <- function(pattern, regex) { + m <- tryCatch(as.matrix(fit, variable = pattern, regex = regex), + error = function(e) NULL) + if (is.matrix(m) && ncol(m) == 1L) as.numeric(m[, 1L]) else NULL + } + sdgp_draws <- one_col("^sdgp", TRUE) + # The share of variance the GP carries needs a residual SD on the same + # scale as the GP: a Gaussian response, or one Gaussian on the log scale. + sigma_draws <- if (fam_name %in% c("gaussian", "lognormal")) + one_col("sigma", FALSE) else NULL + gp_adequacy <- .gp_adequacy(ls_draws, sdgp_draws, sigma_draws, + gp_ell_min = gp_ell_min, + prior_spec = gp_lscale_prior_used, + xy_scale = xy_scale) + convergence_diagnostics$gp_lscale_below_resolution <- gp_adequacy$frac_below } # Every accessor failed, so nothing was checked after all. if (!length(convergence_diagnostics)) convergence_ok <- NA } + gp_adequacy$resolution <- gp_resolution_xy + gp_adequacy$unit <- unit_lbl + gp_adequacy$prior_mass_below <- prior_mass_below loo_obj <- NULL; looic <- NA_real_ if (isTRUE(compute_loo)) { @@ -1257,7 +2694,7 @@ fit_bayesian_spatial_model <- function( } } - new_spatial_fit( + obj <- new_spatial_fit( subclass = "bayesian_fit", engine = fit, formula = fml, @@ -1275,6 +2712,19 @@ fit_bayesian_spatial_model <- function( gp_lscale_prior = gp_lscale_prior_used, gp_n_basis = gp_k^2, gp_ell_min = gp_ell_min, + # The same floor as an effective range in map units, per axis, and the + # request that set it when there was one. + gp_resolution = gp_resolution_xy, + gp_resolution_requested = gp_resolution_requested, + gp_prefit = gp_prefit, + gp_adequacy = gp_adequacy, + # The slope prior brms used and where it came from. + b_prior = b_prior_used, + b_prior_source = b_prior_source, + # The levels each categorical predictor has in the training rows, which + # are the levels brms kept; predict() and fitted() hand brms these and + # no others. + predictor_levels = .bayes_predictor_levels(dat_cols, predictor_vars), # The scaled-coordinate extrema of the training data, the column means # brms centred them on, and the pooled centred range it derived the # boundary L = c * S from. predict() needs them: brms 2.17 to 2.22 @@ -1299,6 +2749,224 @@ fit_bayesian_spatial_model <- function( predictor_scaling = predictor_scaling ) ) + + # ---- What the surface left behind ---- + # The posterior of the GP cannot say whether structure was left in the + # residuals, and that is the question for both of its verdicts. + # + # A GP the data did not identify looks the same in its hyperparameters + # whether the response is white noise or has structure finer than the + # basis: sdgp near zero and a length-scale posterior equal to its prior. + # What separates them is what is left in the residuals at short range, over + # the few nearest neighbours and one-sided: on a field with a 30 km range + # under a 97 to 251 km floor the residual Moran's I had p = 0.003 at 4 + # neighbours and 0.065 at the default 8 two-sided, and white noise on the + # same layout 0.36. + # + # A GP the data did identify looks the same whether the surface it fitted + # is all there is or sits beside structure finer than the basis. A weak + # plane plus a field with an 8 km range under a 33 km floor gave a share of + # the variance of 0.09 to 0.54 at ranges of 55 and 72 km, 2 percent of the + # length-scale draws below the floor, and so "ok", over residuals with a + # Moran's I of 0.143 (p = 5.6e-06) and a fitted surface that explained 19 + # percent of the response. The residuals were read only for an + # unidentified GP, so nothing was said. They are read for every fit whose + # posterior was, and "ok" is not returned over autocorrelated ones. + if (!identical(gp_adequacy$status, "not_checked")) { + rm_res <- .gp_fit_resid_moran(obj, fam_name) + gp_adequacy$residual_moran <- rm_res$test + if (is.null(rm_res$test)) gp_adequacy$residual_untested <- rm_res$reason + left_over <- !is.null(rm_res$test) && rm_res$test$p < .gp_resid_level + gp_adequacy$status <- switch( + gp_adequacy$status, + not_identified = if (left_over) "unresolved_short_range" + else "no_signal_above_floor", + ok = if (left_over) "unresolved_short_range" else "ok", + gp_adequacy$status) + obj$info$gp_adequacy <- gp_adequacy + } + # The adequacy status rides with the other diagnostics when any were read; + # an unchecked fit keeps its empty list. + if (length(obj$info$convergence_diagnostics) > 0L) + obj$info$convergence_diagnostics$gp_adequacy <- gp_adequacy$status + + # ---- Say what was found ---- + # One classed R warning for a failed sampler verdict. The checks used to + # be log lines only, which spatialkit_quiet(), knitr and tryCatch() hide, + # and under cmdstanr nothing else warns. + if (identical(convergence_ok, FALSE) && length(conv_problems) > 0L) + .warn_classed( + "spatialkit_convergence", + paste0("fit_bayesian_spatial_model(): the sampler's diagnostics fail, ", + "so $info$convergence_ok is FALSE: %s. %s ", + "$info$convergence_diagnostics has every value."), + paste(conv_problems, collapse = "; "), + .bayes_convergence_advice(conv_failed, iter = iter, chains = chains, + adapt_delta = control$adapt_delta), + # Which checks failed ("divergent", "ebfmi", "rhat", "ess"), for a + # caller that fits fold by fold and reports them by fold. + data = list(failed = conv_failed)) + + floor_txt <- sprintf("%s %s along x and %s %s along y", + .gp_fmt_dist(gp_resolution_xy[["x"]]), unit_lbl, + .gp_fmt_dist(gp_resolution_xy[["y"]]), unit_lbl) + # What "not identified" rested on, as the clause that opens both messages: + # the share of the variance where there is one, the length-scales where + # there is not. + id_txt <- function() { + sh <- gp_adequacy$spatial_share + if (identical(gp_adequacy$identified_by, "spatial_share") && !is.null(sh)) + return(sprintf( + paste0("the Gaussian process carries no variance that can be told ", + "from zero (its share of the variance has a 95%% interval of ", + "%.3f to %.3f)"), sh[["q2.5"]], sh[["q97.5"]])) + ct <- gp_adequacy$contraction + pg <- gp_adequacy$prior_gap + sprintf( + paste0("the data did not move the Gaussian process's length-scale from ", + "its prior (largest gap between the two distribution functions ", + "%s%s)"), + paste(sprintf("%.2f", pg), collapse = " and "), + if (length(ct) && all(is.finite(ct))) + sprintf("; %s of the prior's variance kept", + paste(sprintf("%.0f%%", 100 * (1 - ct)), collapse = " and ")) + else "") + } + # What can still be done about a basis found short: a finer one if the cap + # allows, and otherwise a different model. + finest_cap <- .gp_se_range_factor * (1.75 * gp_c * gp_spec$S / k_cap) * xy_scale + finer_txt <- if (!gp_k_auto && gp_k < gp_spec$k) + sprintf(paste0("`gp_k` = %d is below the value derived for this layout ", + "(%d): leave `gp_k` NULL, or raise it."), gp_k, gp_spec$k) + else if (gp_k >= k_cap) + sprintf(paste0("The basis is at the cap of %d per dimension, so this ", + "model cannot hold a shorter range: use kriging, or model ", + "cell means (see kriging_adequacy())."), k_cap) + else sprintf( + paste0("A `gp_resolution` below %s %s gives a finer basis; the cap of %d ", + "per dimension reaches %s %s along x and %s %s along y.%s"), + .gp_fmt_dist(max(gp_resolution_xy)), unit_lbl, k_cap, + .gp_fmt_dist(finest_cap[["x"]]), unit_lbl, + .gp_fmt_dist(finest_cap[["y"]]), unit_lbl, + # The variogram's short range, whichever way the check before fitting + # read it: this text is used only where the fitted model agrees with it. + if (gp_prefit$status %in% c("below_floor", "below_floor_long_range") && + is.finite(gp_prefit$range) && gp_prefit$range < max(finest_cap)) + sprintf(paste0(" The range a variogram gave before fitting (%s %s) is ", + "below that; if it is right, kriging, or a model of cell ", + "means (see kriging_adequacy()), suits these data better."), + .gp_fmt_dist(gp_prefit$range), unit_lbl) + else "") + rm_test <- gp_adequacy$residual_moran + # What an identified GP found, as the clause that opens its message: the + # share of the variance where there is one, and the range it sits at. + found_txt <- function() { + sh <- gp_adequacy$spatial_share + eff <- gp_adequacy$effective_range + at <- if (is.matrix(eff) && all(is.finite(eff[, "q50"]))) + sprintf(" at an effective range of %s %s along x and %s %s along y", + .gp_fmt_dist(eff[["x", "q50"]]), unit_lbl, + .gp_fmt_dist(eff[["y", "q50"]]), unit_lbl) + else "" + if (!is.null(sh) && all(is.finite(sh))) + sprintf(paste0("the Gaussian process carries %.2f to %.2f of the ", + "variance (95%% interval)%s"), sh[["q2.5"]], sh[["q97.5"]], at) + else sprintf("the Gaussian process fitted a surface%s", at) + } + if (identical(gp_adequacy$status, "below_resolution")) { + .warn_classed( + "spatialkit_gp_adequacy", + paste0("fit_bayesian_spatial_model(): %.0f%% of the posterior ", + "length-scale draws fall below the smallest length-scale this ", + "basis resolves (gp_k = %d, %d basis functions: effective ranges ", + "from %s). The data ask for a shorter range than the basis can ", + "hold, so the fitted range is too long and part of the structure ", + "is counted as noise.%s %s"), + 100 * gp_adequacy$frac_below, gp_k, gp_k^2, floor_txt, + if (!is.null(rm_test) && rm_test$p < .gp_resid_level) + sprintf(paste0(" The residuals are autocorrelated at short range ", + "(Moran's I = %.3f over %d nearest neighbours, ", + "one-sided p = %.2g)."), rm_test$I, rm_test$k, rm_test$p) + else "", + finer_txt) + } else if (identical(gp_adequacy$status, "unresolved_short_range") && + identical(gp_adequacy$identified, FALSE)) { + .warn_classed( + "spatialkit_gp_adequacy", + paste0("fit_bayesian_spatial_model(): %s, but the residuals are ", + "autocorrelated at short range (Moran's I = %.3f over %d nearest ", + "neighbours, one-sided p = %.2g). Structure with an effective ", + "range under %s cannot be held by this basis (gp_k = %d) and is ", + "counted as noise, so the surface misses it and the intervals do ", + "not cover it. %s"), + id_txt(), rm_test$I, rm_test$k, rm_test$p, floor_txt, gp_k, finer_txt) + } else if (identical(gp_adequacy$status, "unresolved_short_range")) { + # An identified GP over residuals that are still autocorrelated: a + # surface was found, and structure finer than the basis sits beside it. + .warn_classed( + "spatialkit_gp_adequacy", + paste0("fit_bayesian_spatial_model(): %s, and the residuals are still ", + "autocorrelated at short range (Moran's I = %.3f over %d nearest ", + "neighbours, one-sided p = %.2g). The surface left structure ", + "behind. Structure with an effective range under %s cannot be ", + "held by this basis (gp_k = %d) and is counted as noise, so the ", + "surface misses it and the intervals do not cover it. %s"), + found_txt(), rm_test$I, rm_test$k, rm_test$p, floor_txt, gp_k, finer_txt) + } else if (identical(gp_adequacy$status, "ok") && is.null(rm_test)) { + # "ok" on the posterior alone. Said, because the residuals are what a + # surface beside finer structure is caught by. + .log_warn( + paste0("fit_bayesian_spatial_model(): the residuals could not be tested ", + "for autocorrelation at short range (%s), so the adequacy status ", + "\"ok\" rests on the posterior alone: %s, with %.0f%% of the ", + "length-scale draws below what the basis resolves. Structure ", + "finer than the basis beside that surface would not show there."), + gp_adequacy$residual_untested %||% "no reason recorded", found_txt(), + 100 * gp_adequacy$frac_below) + } else if (identical(gp_adequacy$status, "no_signal_above_floor")) { + # Not a failure by itself: a response with no spatial structure gives the + # same picture, and the residuals show nothing left over. + .log_warn( + paste0("fit_bayesian_spatial_model(): %s, and the residuals %s. A ", + "response with no spatial structure gives this. Structure with ", + "an effective range under %s could not be held by this basis in ", + "any case and would be counted as noise."), + id_txt(), + if (!is.null(rm_test)) + sprintf(paste0("show no autocorrelation at short range (Moran's I = ", + "%.3f over %d nearest neighbours, one-sided p = %.2g)"), + rm_test$I, rm_test$k, rm_test$p) + else sprintf("could not be tested for autocorrelation (%s)", + gp_adequacy$residual_untested %||% "no reason recorded"), + floor_txt) + } + + obj +} + + +#' The levels each categorical predictor takes in the training rows +#' +#' brms drops unused levels when it builds the model frame, and at predict +#' time refuses any \code{newdata} factor whose \emph{level set} is not a +#' subset of the ones it kept, whatever values the rows carry. These are +#' those levels: the values that occur, in the factor's own order. +#' +#' @param df The training data, without geometry. +#' @param predictor_vars Predictor names. +#' @return A named list, one element per factor or character predictor, each +#' a list with \code{levels} and \code{ordered}; empty when there is none. +#' @keywords internal +#' @noRd +.bayes_predictor_levels <- function(df, predictor_vars) { + out <- list() + for (cn in intersect(predictor_vars, names(df))) { + v <- df[[cn]] + if (!(is.factor(v) || is.character(v))) next + f <- droplevels(as.factor(v)) + out[[cn]] <- list(levels = levels(f), ordered = is.ordered(v)) + } + out } diff --git a/R/model-classes.R b/R/model-classes.R index 7d5f8ab2..907c7140 100644 --- a/R/model-classes.R +++ b/R/model-classes.R @@ -166,14 +166,21 @@ new_spatial_fit <- function(subclass, engine, formula, response_var, #' #' Shows the one-screen summary of a \code{gwr_fit}, a \code{bayesian_fit} or a #' custom subclass: backend, formula, number of observations, CRS, and the few -#' backend-specific numbers worth seeing immediately (GWR bandwidth, GP basis -#' size). An \code{rf_fit} has its own method (see +#' backend-specific numbers worth seeing immediately (GWR bandwidth; for a +#' \code{bayesian_fit} the GP basis size, the smallest effective range that +#' basis resolves in map units, the slope prior, and a flagged line when the +#' sampler's diagnostics or the basis-adequacy check failed). An +#' \code{rf_fit} has its own method (see #' \code{\link{print.rf_fit}}), which shows the same header plus the forest #' settings. It is what you get by typing the object's name, and the quickest #' way to confirm a fit used the data, predictors and CRS you meant. For fit #' quality use \code{\link{model_metrics}()} or \code{\link{summary}()} #' instead. Nothing printed here is an out-of-sample score. #' +#' For a \code{gwr_fit} the bandwidth and AICc are followed by the effective +#' number of parameters and, when any local window is of deficient rank, by +#' the number of such windows. +#' #' @param x A \code{spatial_fit} object. #' @param ... Ignored. #' @return \code{x}, invisibly (called for its side effect). @@ -181,8 +188,11 @@ new_spatial_fit <- function(subclass, engine, formula, response_var, #' @export print.spatial_fit <- function(x, ...) { subclass <- class(x)[1L] + # The parenthesis names the package that computes the fit. A GWR is solved + # by this package (see ?fit_gwr_model, "The local solve"), so it has none; + # "GWR (GWmodel)" was the header while GWmodel::gwr.basic() made the fit. label <- switch(subclass, - gwr_fit = "GWR (GWmodel)", + gwr_fit = "GWR", bayesian_fit = "Bayesian Spatial GP (brms)", subclass ) @@ -215,13 +225,35 @@ print.spatial_fit <- function(x, ...) { x$info$kernel %||% "bisquare")) if (is.finite(x$info$AICc %||% NA_real_)) cat(sprintf(" AICc : %.2f\n", x$info$AICc)) + # The effective number of parameters, 2 tr(S) - tr(S'S): what the local + # regressions cost in degrees of freedom, against the handful of global + # coefficients the formula shows. + enp <- suppressWarnings(as.numeric(x$info$enp %||% NA_real_))[1L] + if (is.finite(enp)) + cat(sprintf(" Eff. parameters: %.1f of %d observations\n", enp, x$n)) + # A count the coefficient table needs read beside it: windows that could + # not estimate every coefficient return NA for those they could not. + n_def <- suppressWarnings(as.integer(x$info$n_rank_deficient %||% 0L))[1L] + if (isTRUE(n_def > 0L)) + cat(sprintf(paste0(" Rank-deficient windows: %d of %d (their ", + "unestimable coefficients are NA; see ", + "$info$nonfinite_coef)\n"), n_def, x$n)) } if (subclass == "bayesian_fit") { cat(sprintf(" GP basis: %d per dim (%d total)\n", x$info$gp_k %||% NA_integer_, x$info$gp_n_basis %||% NA_integer_)) + for (ln in .bayes_gp_print_lines(x$info)) cat(ln, "\n", sep = "") if (is.finite(x$info$looic %||% NA_real_)) cat(sprintf(" LOOIC : %.2f\n", x$info$looic)) + # The slope prior the model used. A standardised fit sets one, and it is + # part of what the coefficients mean. + bp <- x$info$b_prior + if (is.character(bp) && length(bp) == 1L && !is.na(bp)) + cat(sprintf(" Slope prior: %s%s\n", bp, + if (is.character(x$info$b_prior_source) && + !is.na(x$info$b_prior_source)) + sprintf(" (%s)", x$info$b_prior_source) else "")) # The coefficients of a standardised fit are per SD of each predictor, and # nothing coef() returns says so. if (length(x$info$predictor_scaling) > 0L) @@ -236,11 +268,127 @@ print.spatial_fit <- function(x, ...) { cat(" Convergence: NOT CHECKED (fitted with check_convergence = FALSE?)\n") else if (!isTRUE(cv_ok)) cat(" ** Convergence warnings present -- see $info$convergence_diagnostics\n") + else { + # Passed, with a caution: R-hat between 1.01 and 1.05 on parameters + # that have enough effective draws. Not flagged, and not hidden. + n_caution <- length(x$info$convergence_diagnostics$rhat_caution) + if (n_caution > 0L) + cat(sprintf(paste0(" Convergence: passed; %d parameter(s) with R-hat ", + "between 1.01 and 1.05 and enough effective draws ", + "(see $info$convergence_diagnostics$rhat_caution)\n"), + n_caution)) + } } invisible(x) } +#' What print() says about a bayesian_fit's Gaussian process +#' +#' The smallest effective range the basis resolves, in map units; the +#' posterior effective range when the fit identified one inside that; and one +#' flagged line for every way the basis was found short: before fitting +#' (prior mass under the floor, the response's own range under it) and after +#' (the adequacy status). The range estimated before fitting is a variogram +#' estimate, and what answers it is the residuals of the fitted model. It is +#' printed unflagged only when the status is \code{"ok"} and that status +#' rests on a residual test that found no autocorrelation at short range; +#' the line then gives the test. A status of \code{"ok"} on the posterior +#' alone does not unflag it: a Gaussian process that carries a share of the +#' variance at a long range says nothing about an 8 km range beside it, and +#' "the fitted model does not bear that out" was printed over such fits. A +#' fit saved by an earlier version carries none of these fields and prints +#' none of these lines. +#' +#' @param info A \code{bayesian_fit}'s \code{$info}, or a summary's. +#' @return Character vector of lines, possibly empty. +#' @keywords internal +#' @noRd +.bayes_gp_print_lines <- function(info) { + out <- character(0) + fmt <- function(v) format(signif(v, 3), big.mark = ",", scientific = FALSE, + trim = TRUE) + res <- suppressWarnings(as.numeric(info$gp_resolution)) + ad <- info$gp_adequacy + unit <- ad$unit %||% info$gp_prefit$unit %||% "CRS units" + st <- ad$status + if (length(res) == 2L && all(is.finite(res))) + out <- c(out, sprintf( + " GP resolves: effective ranges from %s (x) and %s (y) %s; shorter structure is counted as noise", + fmt(res[1L]), fmt(res[2L]), unit)) + pm <- suppressWarnings(as.numeric(ad$prior_mass_below %||% NA_real_))[1L] + if (is.finite(pm) && pm > 0.10) + out <- c(out, sprintf( + " ** %.0f%% of the length-scale prior lies below what this basis resolves (gp_k too small for the prior)", + 100 * pm)) + pf <- info$gp_prefit + # The residual test the status was split on, when there is one. + rm_test <- ad$residual_moran + rm_ok <- is.list(rm_test) && is.numeric(rm_test$I) && is.numeric(rm_test$p) && + length(rm_test$I) == 1L && length(rm_test$p) == 1L && + is.finite(rm_test$I) && is.finite(rm_test$p) + rm_txt <- if (rm_ok) + sprintf(" (Moran's I = %.3f, one-sided p = %.2g)", rm_test$I, rm_test$p) else "" + if (identical(pf$status, "below_floor")) { + out <- c(out, if (identical(st, "ok") && rm_ok) sprintf( + " Range before fitting: a variogram put it at %s %s, below what the basis resolves; after fitting, the residuals show no autocorrelation at short range%s", + fmt(pf$range), unit, rm_txt) + else if (identical(st, "ok")) sprintf( + " ** Range before fitting: a variogram put it at %s %s, below what the basis resolves (an estimate; the residuals were not tested after fitting)", + fmt(pf$range), unit) + else sprintf( + " ** Range before fitting: a variogram put it at %s %s, below what the basis resolves (an estimate; see GP adequacy)", + fmt(pf$range), unit)) + } else if (identical(pf$status, "below_floor_long_range")) { + # A short range beside structure that reaches the floor. The fitted + # model says whether the short range was there as well: in residuals + # that are still autocorrelated, or in length-scale draws below the floor. + out <- c(out, if (isTRUE(st %in% c("unresolved_short_range", "below_resolution"))) sprintf( + " ** Range before fitting: a variogram put it at %s %s, below what the basis resolves; the response is also autocorrelated at the floor's distance (see GP adequacy)", + fmt(pf$range), unit) + else sprintf( + " Range before fitting: a variogram put it at %s %s, but the response is still autocorrelated at the floor's distance, so that is not read as its range", + fmt(pf$range), unit)) + } else if (identical(pf$status, "not_estimated")) + out <- c(out, sprintf(" Range before fitting: not estimated (%s)", + pf$reason %||% "no reason recorded")) + eff <- ad$effective_range + # The share of the variance the GP carries, when that is what the status + # was decided on; what the length-scales said, when it was not. + sh <- ad$spatial_share + sh_txt <- if (is.numeric(sh) && length(sh) == 3L && all(is.finite(sh))) + sprintf("the GP's share of the variance is %.3f to %.3f (95%% interval)", + sh[[1L]], sh[[3L]]) + else if (identical(ad$identified, FALSE)) + "the data did not move the GP's length-scale from its prior" + else "the GP fitted a surface" + if (identical(st, "ok") && is.matrix(eff) && all(dim(eff) == c(2L, 3L)) && + all(is.finite(eff))) + out <- c(out, sprintf( + " GP range: %s (x, 95%% interval %s to %s) and %s (y, %s to %s) %s, posterior median effective range", + fmt(eff[1L, 2L]), fmt(eff[1L, 1L]), fmt(eff[1L, 3L]), + fmt(eff[2L, 2L]), fmt(eff[2L, 1L]), fmt(eff[2L, 3L]), unit)) + else if (identical(st, "below_resolution")) + out <- c(out, sprintf(paste0( + " ** GP adequacy: below_resolution -- %.0f%% of length-scale draws fall ", + "below what the basis resolves; the fitted range is too long"), + 100 * (ad$frac_below %||% NA_real_))) + else if (identical(st, "unresolved_short_range")) + out <- c(out, sprintf(paste0( + " ** GP adequacy: unresolved_short_range -- %s, and the residuals are ", + "autocorrelated at short range%s"), sh_txt, rm_txt)) + else if (identical(st, "no_signal_above_floor")) + out <- c(out, sprintf(paste0( + " GP adequacy: no_signal_above_floor -- %s, and the residuals %s"), + sh_txt, + if (is.null(ad$residual_moran)) "were not tested" + else "show no autocorrelation at short range")) + if (!is.null(st) && !(st %in% c("ok", "not_checked"))) + out <- c(out, " (see $info$gp_adequacy)") + out +} + + #' Coerce and check a response column before scoring it #' #' \code{is.finite()} on a character column is \code{FALSE} everywhere, so an @@ -284,6 +432,14 @@ print.spatial_fit <- function(x, ...) { #' Adjusted R-squared is suppressed: GWR's effective parameter count far #' exceeds the global predictor count, and a GP model has no simple \code{p}. #' +#' For a \code{gwr_fit}, \code{print()} on the result adds what the +#' in-sample metrics are to be read against: the effective number of +#' parameters and residual degrees of freedom, the number of local windows +#' of deficient rank, the number of locations when observations share one, +#' and the AICc and RMSE of one global least-squares +#' regression on the same rows beside the fit's own AICc +#' (\code{$info$global_ols}; see \code{\link{fit_gwr_model}}). +#' #' @param object A \code{spatial_fit} object. #' @param ... Ignored. #' @inheritSection model_metrics Percentage errors on responses with zeros @@ -363,6 +519,39 @@ print.summary.spatial_fit <- function(x, ...) { sprintf(" (over %d of %d rows)", n_s, m$n) else "" cat(sprintf(" SMAPE = %.2f%%%s\n", m$SMAPE, sub)) } + # What the local regressions cost and how many could not estimate every + # coefficient: the two numbers the in-sample metrics of a GWR are read + # against. From the fit's own decomposition (see ?fit_gwr_model). + if (identical(x$class, "gwr_fit")) { + enp <- suppressWarnings(as.numeric(x$info$enp %||% NA_real_))[1L] + edf <- suppressWarnings(as.numeric(x$info$edf %||% NA_real_))[1L] + if (is.finite(enp) && is.finite(edf)) + cat(sprintf(paste0("\n Effective parameters: %.1f (residual degrees of ", + "freedom %.1f)\n"), enp, edf)) + n_def <- suppressWarnings(as.integer(x$info$n_rank_deficient %||% 0L))[1L] + if (isTRUE(n_def > 0L)) + cat(sprintf(paste0(" Rank-deficient windows: %d of %d (their ", + "unestimable coefficients are NA)\n"), n_def, x$n)) + # Observations that share a location: the AICc lines below and the + # standard errors count them as independent. + n_loc <- suppressWarnings(as.integer(x$info$n_locations %||% NA_integer_))[1L] + if (isTRUE(n_loc < x$n)) + cat(sprintf(paste0(" Locations: %d for %d observations (AICc and the ", + "standard errors count\n the observations at one ", + "location as independent)\n"), n_loc, x$n)) + # One global regression on the same rows, by the same AICc: what the GWR + # has to beat to have shown that its coefficients vary. + ols <- x$info$global_ols + aicc <- suppressWarnings(as.numeric(x$info$AICc %||% NA_real_))[1L] + if (is.list(ols) && is.finite(ols$AICc %||% NA_real_)) { + cat(sprintf(paste0(" Global least squares on the same rows: AICc %.2f, ", + "RMSE %.4f\n"), ols$AICc, ols$RMSE)) + if (is.finite(aicc)) + cat(sprintf(" This fit: AICc %.2f (%s the global fit's by %.2f)\n", + aicc, if (aicc < ols$AICc) "below" else "not below", + abs(aicc - ols$AICc))) + } + } # The same convergence verdict print() on the fit gives. The summary carried # it in $info and never showed it, so metrics from a posterior that had not # converged printed exactly like metrics from one that had. @@ -372,6 +561,26 @@ print.summary.spatial_fit <- function(x, ...) { cat("\n Convergence: NOT CHECKED (fitted with check_convergence = FALSE?)\n") else if (!isTRUE(cv_ok)) cat("\n ** Convergence warnings present -- see $info$convergence_diagnostics\n") + else { + # The caution print() on the fit gives: passed, with R-hat between 1.01 + # and 1.05 on parameters that have enough effective draws. + n_caution <- length(x$info$convergence_diagnostics$rhat_caution) + if (n_caution > 0L) + cat(sprintf(paste0("\n Convergence: passed; %d parameter(s) with R-hat ", + "between 1.01 and 1.05 and enough effective draws ", + "(see $info$convergence_diagnostics$rhat_caution)\n"), + n_caution)) + } + } + # What the basis could not hold changes how the metrics above read: a GP + # that counted short-range structure as noise scores like one that found + # none. The same lines print() on the fit gives, for any status but "ok". + if (identical(x$class, "bayesian_fit")) { + st <- x$info$gp_adequacy$status + if (!is.null(st) && !(st %in% c("ok", "not_checked"))) { + cat("\n") + for (ln in .bayes_gp_print_lines(x$info)) cat(ln, "\n", sep = "") + } } invisible(x) } @@ -450,7 +659,10 @@ print.summary.spatial_fit <- function(x, ...) { #' @param newdata Optional sf object for out-of-sample evaluation. If NULL, #' fitted values are used (in-sample, or out-of-bag for an \code{rf_fit}; #' see above). -#' @param ... Additional arguments passed to predict(). +#' @param ... Additional arguments passed to predict(). The metrics are +#' computed from one predicted value per row, so \code{draws = TRUE} (a +#' Bayesian fit) and \code{se.fit = TRUE} (a GWR), with which +#' \code{predict()} returns a matrix or a list, are refused. #' @section Which metrics survive a non-Gaussian response: #' RMSE and MAE are defined for any numeric response and are what to read for #' a count, a rate or a bounded outcome. MAPE and SMAPE assume a response @@ -508,6 +720,23 @@ model_metrics <- function(object, ...) UseMethod("model_metrics") #' @export model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { .check_dots_newdata(list(...), newdata, "model_metrics") + # The metrics are computed from one predicted value per row. Two predict() + # arguments make a method return something else: `draws = TRUE` (a + # bayesian_fit: a draws x rows matrix) and `se.fit = TRUE` (a gwr_fit: a + # list). Either reached .compute_reg_metrics() and stopped with "missing + # value where TRUE/FALSE needed", or with an error about a list. + dots <- list(...) + shaped <- intersect(names(dots)[vapply(dots, isTRUE, logical(1))], + c("draws", "se.fit")) + if (length(shaped)) + stop("model_metrics(): ", paste(sprintf("`%s = TRUE`", shaped), collapse = " and "), + " cannot be passed through `...`: the metrics are computed from one ", + "predicted value per row, and with it predict() returns ", + if (identical(shaped, "draws")) "a matrix of posterior draws" + else if (identical(shaped, "se.fit")) "a list with the standard errors" + else "more than that", + ". Call predict() yourself for those, or cv_bayes() for CRPS and ", + "interval coverage.", call. = FALSE) if (is.null(newdata)) { y_hat <- .fitted_checked(object, .caller = "model_metrics") y_obs <- sf::st_drop_geometry(object$data_sf)[[object$response_var]] @@ -585,40 +814,119 @@ model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { #' Predict from a GWR spatial model #' #' When \code{newdata} is NULL, returns the in-sample fitted values. -#' Otherwise estimates the local coefficients at each new location with -#' \code{GWmodel::gwr.basic(regression.points = )}, with the fit's kernel and -#' bandwidth (an adaptive bandwidth counts neighbours among the training -#' points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. These are the -#' values \code{GWmodel::gwr.predict()} returns, without its prediction -#' variance, which this method never returned and which costs time cubic in -#' the number of training points. Each location stands alone: one that cannot -#' be estimated does not affect the others. +#' Otherwise solves one local regression at each new location, with the +#' fit's kernel and bandwidth (an adaptive bandwidth counts neighbours among +#' the training points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. +#' The local regressions are weighted least squares solved by a pivoted QR, +#' the solve \code{\link{fit_gwr_model}()} uses; on a window of full rank the +#' values equal those of \code{GWmodel::gwr.predict()} to rounding error, and +#' at a training location with that row's own predictors they equal +#' \code{fitted()}. Each location stands alone: one that cannot be +#' estimated does not affect the others. #' \code{newdata} is first transformed to the CRS used during fitting #' (via \code{ensure_projected()}), so predictions are computed in a #' single coordinate system regardless of the CRS newdata arrives in. #' +#' @section When a prediction is NA: +#' A prediction is returned when it is estimable from the training points +#' that carry weight at the new location, and is \code{NA} otherwise: +#' \itemize{ +#' \item no training point carries weight there (a location beyond a fixed +#' bisquare, tricube or boxcar bandwidth); +#' \item the training points in the window cannot place the new row: a +#' predictor is constant among them at a value other than the new row's +#' (a regional indicator, at a location whose window lies wholly in +#' another region), or fewer of them carry weight than the new row needs. +#' } +#' Where a predictor is constant in the window at the new row's own value, +#' its coefficient is not needed and the prediction is returned. The +#' decision uses the rule and the tolerance of the fit (see +#' \code{\link{fit_gwr_model}}, \strong{The local solve}). A warning of +#' class \code{"spatialkit_gwr_not_estimable"} counts the \code{NA} +#' predictions. +#' +#' @section Locations beyond the reach of the fit: +#' An adaptive bandwidth always finds its neighbours, and a Gaussian or an +#' exponential kernel weights every training point, so a location far from +#' the data still gets a number: the local regression of training points +#' that are all far away, extrapolated. When a new location's nearest +#' training point is farther than the widest kernel used at any training +#' location reaches, the prediction is returned and a warning of class +#' \code{"spatialkit_gwr_extrapolation"} counts those locations and gives +#' the range of their distances. The widest kernel is the largest distance +#' from a training point to its \code{bandwidth}-th nearest neighbour +#' (\code{object$info$max_kernel_width}), or the bandwidth itself when it is +#' fixed. A bisquare, tricube or boxcar kernel reaches as far as its width; +#' a Gaussian or exponential kernel has no edge, and its reach is taken as +#' three widths. The check is on distance alone and is lenient: a location +#' just outside the data is not flagged. +#' +#' The warning is raised once per call, with that call's counts. +#' \code{\link{predict_surface}()}, which predicts a grid in chunks, and +#' \code{\link{cv_gwr}()} and \code{\link{cv_spatial}()}, which predict +#' fold by fold, collect the warnings of their pieces and raise one under +#' their own name, with the totals and the number of calls they are over +#' (\code{calls}). The folds of a cross-validation are separate fits, so +#' a cross-validation gives the smallest and the largest reach among them. +#' \code{\link{cv_block_size_sweep}()} and +#' \code{\link{select_features_forward}()} run many cross-validations of +#' one learner and raise one warning for the sweep. A sweep predicts the +#' same rows from several fits, so its totals count a location once for each +#' fit that put it out of reach, and the message says so. +#' \code{model_metrics(fit, newdata)} is +#' one call and raises the warning once. A loop of your own over +#' \code{predict()} gets one warning per call; the condition carries its +#' numbers as fields (\code{n_far}, +#' \code{n}, \code{reach}, and \code{nearest}, the smallest and largest +#' distance to a nearest training point), so a handler can total them: +#' \code{withCallingHandlers(..., spatialkit_gwr_extrapolation = function(w) +#' \{ total <<- total + w$n_far; invokeRestart("muffleWarning") \})}. To +#' drop it where extrapolation is intended, use +#' \code{suppressWarnings(predict(fit, newdata), classes = +#' "spatialkit_gwr_extrapolation")}. The warning that counts \code{NA} +#' predictions (class \code{"spatialkit_gwr_not_estimable"}) carries +#' \code{n_na}, \code{n} and \code{n_empty} and is collected the same way. +#' #' @param object A \code{gwr_fit} object. #' @param newdata An sf object with the same predictors. #' The response variable need not be present (true out-of-sample prediction #' is supported). NULL = fitted values. +#' @param se.fit Logical; also return standard errors. Default \code{FALSE}. #' @param ... Ignored. -#' @return Numeric vector aligned to \code{nrow(newdata)}, with \code{NA} for -#' rows dropped as missing or non-finite, and for locations whose local -#' regression cannot be estimated (too few training points within a fixed -#' bandwidth, or a singular local design); a warning counts those. If the -#' design matrix for \code{newdata} cannot be built, every value is -#' \code{NA} and a warning says why. CRS-less +#' @return With \code{se.fit = FALSE}, a numeric vector aligned to +#' \code{nrow(newdata)}, with \code{NA} for rows dropped as missing or +#' non-finite, and for locations whose local regression cannot be +#' estimated (see \strong{When a prediction is NA}); a warning counts +#' those. If the design matrix for \code{newdata} cannot be built, every +#' value is \code{NA} and a warning says why. CRS-less #' \code{newdata} first receives the interpretation the training data got, so #' the same rows land where they did at fit time. +#' +#' With \code{se.fit = TRUE}, a list: \code{fit} (that vector), +#' \code{se.fit} (the standard error of the fitted value, +#' \eqn{\hat\sigma\sqrt{s^\top s}} with \eqn{s} the weights the local +#' regression puts on the training responses), \code{se.pred} (the standard +#' error of a new observation there, \eqn{\hat\sigma\sqrt{1 + s^\top s}}, +#' the square root of \code{GWmodel::gwr.predict()}'s prediction variance), +#' \code{residual.scale} (\eqn{\hat\sigma}, from the fit's residual sum of +#' squares over its effective degrees of freedom) and \code{df} (those +#' degrees of freedom). The standard errors treat the bandwidth as known +#' and the local model as true at each location; they do not measure the +#' bias of a local fit and are \code{NA} where the prediction is. #' @family methods on a fitted model #' @export -predict.gwr_fit <- function(object, newdata = NULL, ...) { +predict.gwr_fit <- function(object, newdata = NULL, se.fit = FALSE, ...) { .check_dots(list(...), "predict.gwr_fit") - if (is.null(newdata)) return(fitted(object)) + if (!is.logical(se.fit) || length(se.fit) != 1L || is.na(se.fit)) + stop("predict.gwr_fit(): `se.fit` must be TRUE or FALSE.", call. = FALSE) + if (is.null(newdata)) { + if (!se.fit) return(fitted(object)) + # The standard errors need each row's weights on the training responses, + # which the fit does not keep; the training rows are predicted afresh. + newdata <- object$data_sf + } .check_predict_newdata(newdata, object, "predict.gwr_fit") - if (!requireNamespace("GWmodel", quietly = TRUE)) - stop("predict.gwr_fit(): package 'GWmodel' is required.", call. = FALSE) if (!requireNamespace("sp", quietly = TRUE)) stop("predict.gwr_fit(): package 'sp' is required.", call. = FALSE) @@ -652,14 +960,22 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { clean_idx <- seq_len(n_orig) %in% newdata$..orig_row_id.. newdata$..orig_row_id.. <- NULL + # What comes back when nothing can be predicted, in the shape asked for. + na_result <- function() { + v <- rep(NA_real_, n_orig) + if (!se.fit) return(v) + list(fit = v, se.fit = v, se.pred = v, + residual.scale = NA_real_, df = NA_real_) + } + # Degrade to an all-NA vector when nothing survived cleaning, matching # predict.rf_fit() and predict.bayesian_fit(). Without this a zero-row - # layer would reach the chunk loop below and come back as a warning about - # the local regressions, which are not what went wrong. + # layer would reach the local regressions below and come back as a warning + # about them, which are not what went wrong. if (n_new == 0L) { .log_warn(paste0("predict.gwr_fit(): every row of newdata was dropped as ", "missing or non-finite; returning %d NA(s)."), n_orig) - return(rep(NA_real_, n_orig)) + return(na_result()) } needed_cols <- unique(c(object$response_var, object$predictor_vars)) @@ -668,46 +984,93 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { bw <- object$info$bandwidth adaptive <- object$info$adaptive %||% TRUE if (isTRUE(adaptive)) bw <- as.integer(round(bw)) + kernel <- object$info$kernel %||% "bisquare" - # One local regression per new location (see .gwr_predict_at()), not - # GWmodel::gwr.predict(), which returned every prediction as NA in three - # common cases: one location with an empty or singular window (a grid cell - # beyond a fixed bandwidth, a point inside a held-out block) threw inv()'s - # error for all of them; more than 10000 training plus new rows failed on - # "object 'DM3.given' not found", and more than 5000 training rows on "No - # regression point is fixed". It also built the n_train x n_train hat - # matrix for a prediction variance this method never returned, cubic in the - # training size, on every call and so on every cv_gwr() fold. - preds_clean <- tryCatch( + # One local regression per new location (see .gwr_predict_at()), each + # solved for itself, so a location whose window is empty or cannot place + # its row (a grid cell beyond a fixed bandwidth, a point inside a held-out + # block) is NA and the others are what they would be without it. + res <- tryCatch( .gwr_predict_at(object$formula, sp_train, newdata_df = sf::st_drop_geometry(newdata), rp = sf::st_coordinates(newdata)[, 1:2, drop = FALSE], - bw = bw, kernel = object$info$kernel %||% "bisquare", - adaptive = adaptive), + bw = bw, kernel = kernel, adaptive = adaptive, + se = se.fit), error = function(e) e ) - if (inherits(preds_clean, "error")) { + if (inherits(res, "error")) { # A real warning(), not only a logger line. A logger line is invisible # to tryCatch(warning = ), to withCallingHandlers(), to # testthat::expect_warning() and to R CMD check, so a predict() that # returns nothing but NA left no trace a caller could act on. .warn_and_log(paste0("predict.gwr_fit(): the local regressions could not ", "be evaluated, so every prediction is NA. Cause: %s"), - conditionMessage(preds_clean)) - preds_clean <- rep(NA_real_, n_new) - } else if (anyNA(preds_clean)) { - n_na <- sum(is.na(preds_clean)) - .warn_and_log(paste0("predict.gwr_fit(): %d of %d location(s) have no ", - "estimable local regression, so their predictions are ", - "NA; the other %d are unaffected. Too few training ", - "points carry weight within the %s bandwidth (%s) ", - "there, or the local design is singular."), - n_na, n_new, n_new - n_na, - if (isTRUE(adaptive)) "adaptive" else "fixed", format(bw)) + conditionMessage(res)) + return(na_result()) + } + preds_clean <- res$fitted + + # The two counted warnings carry their counts as fields of the condition + # (see .gwr_tally_predict_warnings(), which a caller that predicts in + # chunks or folds uses to raise each once with totals). + if (anyNA(preds_clean)) { + is_na <- is.na(preds_clean) + n_na <- sum(is_na) + n_empty <- sum(is_na & res$n_window == 0L) + bw_text <- sprintf("%s bandwidth (%s)", + if (isTRUE(adaptive)) "adaptive" else "fixed", format(bw)) + .gwr_warn( + "spatialkit_gwr_not_estimable", "%s", + .gwr_not_estimable_msg("predict.gwr_fit", n_na, n_new, n_empty, bw_text), + data = list(n_na = n_na, n = n_new, n_empty = n_empty, + bw_text = bw_text, calls = 1L), + tallied = TRUE) + } + + # A prediction at a location no window of the fit reached. An adaptive + # bandwidth always finds its neighbours and a Gaussian kernel weights every + # point, so far from the data a number still comes back; it is counted + # here, against the reach of the widest kernel at any training location. + kr <- .gwr_kernel_reach(object, sp::coordinates(sp_train), bw, adaptive, + kernel) + far <- !is.na(preds_clean) & is.finite(res$nearest) & + is.finite(kr$reach) & res$nearest > kr$reach + if (any(far)) { + rng <- range(res$nearest[far]) + reach_text <- sprintf( + "%s in the units of the fit's CRS%s", format(signif(kr$reach, 4)), + if (kernel %in% c("gaussian", "exponential")) + sprintf(", three times the widest %s bandwidth of %s", kernel, + format(signif(kr$width, 4))) else "") + .gwr_warn( + "spatialkit_gwr_extrapolation", "%s", + .gwr_extrapolation_msg("predict.gwr_fit", sum(far), n_new, reach_text, + rng), + data = list(n_far = sum(far), n = n_new, reach = kr$reach, + reach_text = reach_text, nearest = rng, calls = 1L), + tallied = TRUE) } # Expand back to original length, filling dropped rows with NA. - .expand_predictions(preds_clean, clean_idx, n_orig) + fit_vals <- .expand_predictions(preds_clean, clean_idx, n_orig) + if (!se.fit) return(fit_vals) + + sigma2 <- suppressWarnings(as.numeric(object$info$sigma2 %||% NA_real_))[1L] + if (!is.finite(sigma2)) + .warn_and_log(paste0("predict.gwr_fit(): the fit carries no residual ", + "variance (it has no effective residual degrees of ", + "freedom, a fitted value of its own is NA, or it was ", + "not made by fit_gwr_model()), so `se.fit` and ", + "`se.pred` are NA.")) + vf <- res$var_fit + vf[is.na(preds_clean)] <- NA_real_ + list(fit = fit_vals, + se.fit = .expand_predictions(sqrt(sigma2 * vf), clean_idx, n_orig), + se.pred = .expand_predictions(sqrt(sigma2 * (1 + vf)), clean_idx, + n_orig), + residual.scale = sqrt(sigma2), + df = suppressWarnings( + as.numeric(object$info$edf %||% NA_real_))[1L]) } @@ -755,10 +1118,75 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { } } + # Hand brms each categorical predictor with exactly the levels it was + # fitted with. brms compares the LEVEL SET of a newdata factor with the + # levels it kept, not the values the rows carry, and it drops unused levels + # when fitting. So a factor that merely listed an extra level no row had, + # and the training data itself whenever one of its levels had no rows (any + # ordinary subset), were refused with "New factor levels are not allowed": + # fitted() and summary() stopped, and predict() returned NA for every row. + # A value outside the fitted levels becomes NA here, and brms would predict + # the reference level for it; predict.bayesian_fit() removes those rows + # before this is reached. + lv <- .bayes_fit_levels(object) + for (cn in intersect(names(lv), names(pred_df))) + pred_df[[cn]] <- factor(as.character(pred_df[[cn]]), + levels = lv[[cn]]$levels, + ordered = isTRUE(lv[[cn]]$ordered)) + pred_df } +#' The levels a bayesian_fit's categorical predictors were fitted with +#' +#' Stored at fit time as \code{$info$predictor_levels}. A fit saved by an +#' earlier version has none, and gets them the way they were made: from the +#' values that occur in its training rows. +#' +#' @param object A \code{bayesian_fit}. +#' @return A named list, one element per factor or character predictor, each +#' a list with \code{levels} and \code{ordered}. +#' @keywords internal +#' @noRd +.bayes_fit_levels <- function(object) { + lv <- object$info$predictor_levels + if (is.list(lv)) return(lv) + df <- tryCatch(sf::st_drop_geometry(object$data_sf), error = function(e) NULL) + if (is.null(df)) return(list()) + .bayes_predictor_levels(df, object$predictor_vars) +} + + +#' Rows of newdata that carry a level the model was not fitted with +#' +#' @param object A \code{bayesian_fit}. +#' @param newdata The prediction layer. +#' @return A list with \code{unseen} (logical, one per row), \code{bad} (a +#' named list of per-column logical masks, only for columns with such +#' rows) and \code{named} (one string per such column, naming the levels). +#' A missing value is not an unseen level; the row cleaning handles it. +#' @keywords internal +#' @noRd +.bayes_unseen_levels <- function(object, newdata) { + lv <- .bayes_fit_levels(object) + out <- list(unseen = rep(FALSE, nrow(newdata)), bad = list(), + named = character(0)) + for (cn in intersect(names(lv), names(newdata))) { + val <- as.character(newdata[[cn]]) + bad <- !is.na(val) & !(val %in% lv[[cn]]$levels) + if (!any(bad)) next + out$unseen <- out$unseen | bad + out$bad[[cn]] <- bad + out$named <- c(out$named, sprintf( + "'%s': %s (fitted with %s)", cn, + paste(sQuote(unique(val[bad]), q = FALSE), collapse = ", "), + paste(sQuote(lv[[cn]]$levels, q = FALSE), collapse = ", "))) + } + out +} + + #' Hold the GP boundary at the value the model was fitted with #' #' brms 2.17 to 2.22 store \code{Xgp}, \code{dmax} and \code{cmeans} in a fit's @@ -987,6 +1415,20 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { #' factor puts that edge well outside the training data, so only #' \code{newdata} reaching far past it is affected. #' +#' @section Levels of a categorical predictor: +#' A factor or character predictor is handed to brms with the levels the model +#' was fitted with: the values that occur in the training rows +#' (\code{object$info$predictor_levels}). brms compares the level \emph{set} +#' of a \code{newdata} factor with those, so without this a factor that only +#' listed an extra level, or a model fitted on a subset whose factor kept an +#' unused level, was refused outright. A row whose value is not among the +#' fitted levels has no prediction: it is returned as \code{NA}, the other +#' rows are predicted, and one warning of class \code{spatialkit_new_levels} +#' names the predictor, the levels and the number of rows. A prediction +#' therefore does not depend on which other rows share the call, and +#' \code{\link{predict_surface}()} returns the same surface at any +#' \code{chunk_size}. +#' #' @description #' Applies the same newdata preparation pipeline as \code{predict.gwr_fit()}: #' non-point geometries are coerced to points, the data is projected to the @@ -1006,9 +1448,14 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { #' point summary. Default FALSE. #' @param ... Ignored. #' @return Numeric vector of length \code{nrow(newdata)}, or a -#' \code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. If the +#' \code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. Rows +#' with a missing or non-finite predictor or coordinate, and rows carrying +#' a level of a categorical predictor the model was not fitted with, are +#' \code{NA} (an \code{NA} column with \code{draws = TRUE}); the other +#' rows are unaffected. If the #' posterior draw fails the result is all \code{NA} (a 1-row matrix for -#' \code{draws = TRUE}) and the cause is logged. An ordinal or categorical +#' \code{draws = TRUE}) with a warning of class +#' \code{spatialkit_predict_failed} that gives the cause. An ordinal or categorical #' family is not a failed draw and is an error under #' \code{type = "epred"}: its expected value is a probability per response #' category, not one number per row. Use \code{type = "predict", @@ -1076,6 +1523,27 @@ predict.bayesian_fit <- function(object, newdata = NULL, newdata <- .replay_crs_assumption(newdata, object$data_sf, "predict.bayesian_fit") newdata <- ensure_projected(newdata, target_crs = .crs_or_null(training_crs)) + # ---- Levels the model was not fitted with ---- + # One such row used to turn every prediction of the call into NA, with a + # log line and no R condition: brms refuses the whole newdata, and the + # failed draw was returned as all NA. The rows are set aside here, the + # rest are predicted, and one warning says which levels and how many rows. + # Setting the value to NA lets the row cleaning below drop them, so they + # come back NA through the same path as any incomplete row. They must not + # reach brms as NA: it predicts the reference level for an NA factor value + # (1.07 where the row's own level gave 3.11). + lv_chk <- .bayes_unseen_levels(object, newdata) + if (any(lv_chk$unseen)) { + for (cn in names(lv_chk$bad)) newdata[[cn]][lv_chk$bad[[cn]]] <- NA + .warn_classed( + "spatialkit_new_levels", + paste0("predict.bayesian_fit(): %d of %d row(s) of `newdata` carry a ", + "level the model was not fitted with (%s). Their predictions ", + "are NA; the other %d row(s) are predicted as usual."), + sum(lv_chk$unseen), n_orig, paste(lv_chk$named, collapse = "; "), + n_orig - sum(lv_chk$unseen)) + } + # Sentinel row ID: after prep_model_data()'s single-pass cleaning (which also # coerces non-POINT geometry, MULTIPOINT included, so st_coordinates() in # .prepare_brms_pred_df() stays one row per observation) we can derive @@ -1090,7 +1558,8 @@ predict.bayesian_fit <- function(object, newdata = NULL, if (nrow(newdata) == 0L) { .log_warn(paste0("predict.bayesian_fit(): every row of newdata was dropped ", - "as missing or non-finite; returning %d NA(s)."), n_orig) + "as missing, non-finite or carrying an unfitted level; ", + "returning %d NA(s)."), n_orig) return(if (draws) matrix(NA_real_, nrow = 1L, ncol = n_orig) else rep(NA_real_, n_orig)) } @@ -1146,10 +1615,17 @@ predict.bayesian_fit <- function(object, newdata = NULL, .stop_if_category_epred(draw_mat, model_obj, "predict.bayesian_fit", hint = .category_draws_hint) if (inherits(draw_mat, "try-error") || !is.matrix(draw_mat)) { - .log_warn("predict.bayesian_fit(): posterior draw failed: %s", - if (inherits(draw_mat, "try-error")) .try_error_message(draw_mat) - else sprintf("brms returned a %s, not a draws x rows matrix", - class(draw_mat)[1L])) + # A real warning with a class, not only a log line: every prediction of + # the call is NA, and a log line is invisible to tryCatch(), + # options(warn = 2), knitr and spatialkit_quiet(). + .warn_classed( + "spatialkit_predict_failed", + paste0("predict.bayesian_fit(): the posterior draw failed, so all %d ", + "prediction(s) are NA. Cause: %s"), + n_orig, + if (inherits(draw_mat, "try-error")) .try_error_message(draw_mat) + else sprintf("brms returned a %s, not a draws x rows matrix", + class(draw_mat)[1L])) # Honour the documented return shape: a matrix when draws = TRUE, so a # caller that indexes columns is not handed a vector on the failure path. return(if (draws) matrix(NA_real_, nrow = 1L, ncol = n_orig) @@ -1474,45 +1950,76 @@ residuals.bayesian_fit <- function(object, ...) { #' #' @section What is and is not returned: #' Only the model terms: the intercept and one column per predictor. -#' GWmodel's \code{SDF} data slot carries a good deal more alongside them +#' The engine's \code{SDF} data slot carries a good deal more alongside them #' (standard errors, t-values, the observed response, the fitted values, the #' residuals, \code{Local_R2}): 15 columns for a two-predictor fit, of which 3 #' are coefficients. Returning the whole slot would have made #' \code{coef(fit)$Local_R2} and \code{coef(fit)$a_SE} read like coefficients -#' and \code{ncol(coef(fit))} a meaningless number. Reach for -#' \code{object$engine$SDF} when you want the rest; it is the unmodified -#' GWmodel object. -#' -#' If the model terms cannot be located in the \code{SDF} (a GWmodel that +#' and \code{ncol(coef(fit))} a meaningless number. Ask for the standard +#' errors and t values with \code{se = TRUE}; reach for +#' \code{object$engine$SDF} when you want the rest. +#' +#' A coefficient is \code{NA} at a location whose local window cannot +#' estimate it: a predictor that does not vary among the observations that +#' carry weight there has no slope, and the intercept is then not identified +#' either unless the predictor is 0 there. \code{object$info$nonfinite_coef} +#' is the mask, and \code{\link{fit_gwr_model}} raises a warning that counts +#' them. +#' +#' If the model terms cannot be located in the \code{SDF} (an engine that #' names its coefficient columns differently), the whole slot is returned with #' a warning saying so. The call neither errors nor returns a silently short #' table. #' +#' @section Standard errors: +#' With \code{se = TRUE} the local standard errors and t values come with the +#' estimates. A standard error is +#' \eqn{\hat\sigma\sqrt{(C C^\top)_{jj}}}{sigma * sqrt(diag(C C'))}, with +#' \eqn{C = (X^\top W X)^{-1} X^\top W} the weights the local regression puts +#' on the responses and \eqn{\hat\sigma^2} the residual sum of squares over +#' the fit's effective degrees of freedom: the definition +#' \code{GWmodel::gwr.basic()} uses, computed from the QR decomposition that +#' gave the estimate. They treat the bandwidth as known. The t values are +#' one test per term and location, tens to thousands of them and strongly +#' dependent, so a map of \eqn{|t| > 2} overstates what is significant; no +#' p-value, adjusted or not, is returned. What an adjustment for the number +#' of tests needs is on the fit: the t values here, the effective number of +#' parameters \code{object$info$enp} and the residual degrees of freedom +#' \code{object$info$edf}. When observations share a location the standard +#' errors are too small as well (see \code{\link{fit_gwr_model}}, +#' \strong{Observations that share a location}). +#' #' @param object A \code{gwr_fit} object. +#' @param se Logical; also return the standard errors and t values. Default +#' \code{FALSE}. #' @param ... Ignored. -#' @return A data.frame of local coefficient estimates: one row per -#' observation, one column per model term. +#' @return With \code{se = FALSE}, a data.frame of local coefficient +#' estimates: one row per observation, one column per model term. With +#' \code{se = TRUE}, a list of three such data.frames: \code{estimate}, +#' \code{se} and \code{t}. #' Never \code{NULL}: when the engine carries no \code{SDF} component this #' errors, following the \code{coef()} contract described in #' \code{\link{new_spatial_fit}}. #' @family methods on a fitted model #' @export -coef.gwr_fit <- function(object, ...) { +coef.gwr_fit <- function(object, se = FALSE, ...) { + if (!is.logical(se) || length(se) != 1L || is.na(se)) + stop("coef.gwr_fit(): `se` must be TRUE or FALSE.", call. = FALSE) sdf <- tryCatch(object$engine$SDF, error = function(e) NULL) # Returning NULL here would be indistinguishable from "this GWR has no # coefficients", which is never true. See ?new_spatial_fit for the contract. if (is.null(sdf)) - stop("coef.gwr_fit(): the fit carries no GWmodel `SDF` component, so the ", + stop("coef.gwr_fit(): the fit carries no `SDF` component, so the ", "local coefficients cannot be extracted.", call. = FALSE) dat <- if (inherits(sdf, "Spatial")) sdf@data else sf::st_drop_geometry(sdf) - # Keep only the model terms. gwr.basic()'s SDF is + # Keep only the model terms. The SDF is # c(colnames(betas), "y", "yhat", "residual", "CV_Score", "Stud_residual", # paste0(colnames(betas), "_SE"), paste0(colnames(betas), "_TV"), # "Local_R2") # so the coefficients are the leading block and everything after it is a # diagnostic. Match on the model-matrix column names (normalised, so - # "(Intercept)" and GWmodel's "Intercept" agree) and take the FIRST unclaimed + # "(Intercept)" and the SDF's "Intercept" agree) and take the FIRST unclaimed # SDF column for each -- coefficients come first, so first-match is the # coefficient even when a predictor shares a name with a diagnostic column. want <- tryCatch( @@ -1528,14 +2035,39 @@ coef.gwr_fit <- function(object, ...) { cand <- setdiff(which(sdf_n == w), pos) if (length(cand) > 0L) pos <- c(pos, cand[[1L]]) } - if (length(pos) == length(want)) return(dat[, pos, drop = FALSE]) + if (length(pos) == length(want)) { + est <- dat[, pos, drop = FALSE] + if (!se) return(est) + # The standard errors and t values sit in two blocks of the same width + # after the five diagnostic columns; they are taken by position, checked + # against their names, so a predictor called `a_SE` cannot stand in. + k <- length(pos) + i_se <- k + 5L + seq_len(k) + i_tv <- 2L * k + 5L + seq_len(k) + laid_out <- identical(pos, seq_len(k)) && ncol(dat) >= 3L * k + 5L && + identical(names(dat)[i_se], paste0(names(dat)[pos], "_SE")) && + identical(names(dat)[i_tv], paste0(names(dat)[pos], "_TV")) + if (!laid_out) + stop("coef.gwr_fit(): the fit's `SDF` does not carry standard errors ", + "and t values in the layout fit_gwr_model() writes ", + "(_SE and _TV after the coefficients), so ", + "`se = TRUE` cannot be answered.", call. = FALSE) + se_df <- dat[, i_se, drop = FALSE] + tv_df <- dat[, i_tv, drop = FALSE] + names(se_df) <- names(est) + names(tv_df) <- names(est) + return(list(estimate = est, se = se_df, t = tv_df)) + } .log_warn(paste0("coef.gwr_fit(): matched only %d of %d model term(s) to a ", - "column of GWmodel's SDF, so the full SDF data slot is ", + "column of the engine's SDF, so the full SDF data slot is ", "returned instead of the coefficients alone. Columns such ", "as *_SE, *_TV, residual and Local_R2 are diagnostics, ", "not coefficients."), length(pos), length(want)) } + if (se) + stop("coef.gwr_fit(): the model terms could not be located in the fit's ", + "`SDF`, so `se = TRUE` cannot be answered.", call. = FALSE) dat } diff --git a/R/model-gwr.R b/R/model-gwr.R index 3e2efa13..0bfc5e83 100644 --- a/R/model-gwr.R +++ b/R/model-gwr.R @@ -2,12 +2,12 @@ # Internal helpers # ----------------------------------------------------------------------------- -#' Coerce an sf object to SpatialPointsDataFrame for GWmodel +#' Coerce an sf object to SpatialPointsDataFrame #' -#' GWmodel's core functions (gwr.basic, bw.gwr, gwr.model.selection) currently -#' require Spatial* inputs. Unlike the archived spgwr package, GWmodel is -#' actively maintained and may gain native sf support in the future; -#' centralizing the coercion here makes a future migration trivial. +#' A fit's engine keeps its results as a Spatial object, the layout GWmodel's +#' functions return, and the GWR functions take the training rows and their +#' two coordinates from one. Centralising the coercion here keeps that in one +#' place. #' #' @param data_sf An sf object with POINT geometry. #' @param keep_cols Character vector of column names to retain. NULL = all. @@ -17,37 +17,40 @@ #' @noRd .to_sp <- function(data_sf, keep_cols = NULL) { if (!requireNamespace("sp", quietly = TRUE)) - stop(".to_sp(): package 'sp' is required for GWmodel.", call. = FALSE) + stop(".to_sp(): package 'sp' is required: a GWR fit keeps its data and ", + "its local estimates as Spatial objects.", call. = FALSE) if (!is.null(keep_cols)) { keep_cols <- intersect(keep_cols, names(data_sf)) data_sf <- data_sf[, keep_cols, drop = FALSE] } - # GWmodel is strictly 2-D: gw.dist() rejects a third coordinate column for - # the data points and reshapes regression points with matrix(, ncol = 2). - # prep_model_data() already drops Z/M; this covers the callers that skip it - # (fit_gwr_model(.already_prepped = TRUE)) and a fit made before it did. + # A GWR is strictly 2-D: distances are taken between the first two + # coordinates. prep_model_data() already drops Z/M; this covers the callers + # that skip it (fit_gwr_model(.already_prepped = TRUE)) and a fit made + # before it did. data_sf <- .drop_zm(data_sf) methods::as(data_sf, "Spatial") } -#' Is GWmodel's AICc outside its domain? +#' Is the AICc outside its domain? #' -#' GWmodel's AICc (Hurvich et al. 1998, its C++ \code{gwr_diag1()} and -#' \code{AICc_rss1()}) is +#' The AICc of a GWR as GWmodel defines it (Hurvich et al. 1998, its C++ +#' \code{gwr_diag1()} and \code{AICc_rss1()}; \code{.gwr_diagnostics()} +#' computes the same) is #' \deqn{n \log(RSS/n) + n \log(2\pi) + n (n + tr S) / (n - 2 - tr S),} #' defined only for \eqn{tr S < n - 2}. Past that point the penalty changes #' sign, and a (near-)interpolating fit scores a huge NEGATIVE AICc that ranks #' it first everywhere it is compared. GWmodel's AIC from the same fit is #' \eqn{n \log(RSS/n) + n \log(2\pi) + n + tr S}, so #' \eqn{AICc - AIC = (n + tr S)(2 + tr S) / (n - 2 - tr S)}: AICc exceeds AIC -#' exactly when the denominator is positive. The domain is therefore read off -#' GWmodel's own two numbers, without the hat-matrix trace (which gwr.basic() -#' does not return, and which \code{enp = 2 tr S - tr S'S} is not). An +#' exactly when the denominator is positive. The domain can therefore be +#' read off the two numbers alone, which is what a table of them (a selection +#' sweep's, or one an injected engine returns) allows; \code{fit_gwr_model()} +#' has the trace itself and checks both. An #' infinite AICc (a residual sum of squares of exactly 0, or #' \eqn{tr S = n - 2}) is outside the domain too. #' -#' @param aic,aicc Numeric vectors of equal length, GWmodel's AIC and AICc. +#' @param aic,aicc Numeric vectors of equal length, the AIC and the AICc. #' @return Logical vector: \code{TRUE} where AICc is known to be undefined, #' \code{FALSE} where it is defined or cannot be checked (\code{NA} AIC). #' @keywords internal @@ -59,10 +62,11 @@ } -#' GWmodel's hat-matrix trace, recovered from its AIC +#' The hat-matrix trace, recovered from the AIC #' #' \code{AIC - (n log(RSS/n) + n log(2 pi) + n)}; see -#' \code{.gwr_aicc_undefined()}. For messages only: it loses precision when +#' \code{.gwr_aicc_undefined()}. For a fit that carries the AIC and the +#' residual sum of squares but not the trace: it loses precision when #' the residual sum of squares is tiny, and is \code{NA} when it is zero. #' @keywords internal #' @noRd @@ -100,9 +104,8 @@ #' A fixed bandwidth is a length in the CRS the fit runs in, and that is not #' necessarily the CRS the caller was looking at: prep_model_data() projects #' geographic input, so 0.2 "degrees" becomes 0.2 metres and every local -#' regression is empty. Shared by \code{fit_gwr_model()} and -#' \code{gwr_model_selection()}, whose sweep otherwise died on GWmodel's bare -#' "inv(): matrix is singular" with nothing about the bandwidth. +#' regression holds its own observation alone. Shared by +#' \code{fit_gwr_model()} and \code{gwr_model_selection()}. #' #' @param dat The prepared sf layer the fit runs on. #' @param bandwidth The supplied fixed bandwidth. @@ -123,7 +126,8 @@ "fit runs in (%s), which prep_model_data() may have ", "chosen -- geographic input is projected first, so a ", "value in degrees is read as metres. Every local ", - "window is likely to be empty."), + "window is then likely to hold its own observation ", + "alone."), fn, format(as.numeric(bandwidth)), format(signif(extent_x, 4)), if (is.null(fit_units) || is.na(fit_units)) "unit" else fit_units, @@ -133,30 +137,30 @@ } -#' The explanation appended to GWmodel's "matrix is singular" +#' What makes a local window rank deficient, and what to do about it #' -#' One exactly singular window makes Armadillo's \code{inv()} throw and -#' GWmodel stop the whole call; the bare message names neither the window nor -#' the cause. Used by \code{fit_gwr_model()} (with the survey's count of -#' singular windows) and by \code{gwr_model_selection()} (without one). +#' The closing sentences of the warning \code{fit_gwr_model()} raises when +#' the local solve finds windows of deficient rank. #' -#' @param n_sing Number of singular windows the survey found, or 0 when -#' there was no survey. -#' @return A character string starting with " -- ". +#' @param selected The bandwidth, formatted, when it was selected by the +#' search and not supplied; \code{NULL} otherwise. +#' @return A character string starting with a space. #' @keywords internal #' @noRd -.gwr_singular_hint <- function(n_sing = 0L) { - paste0(" -- at least one local window's design is singular, and ", - "GWmodel stops the whole fit rather than return that window. ", - if (isTRUE(n_sing > 0L)) - sprintf("The collinearity survey found %d singular window(s). ", - as.integer(n_sing)) else "", - "Typical causes are a predictor that is constant inside a ", - "window (a regional indicator, say), a bandwidth that leaves a ", - "window fewer observations than parameters (a fixed bandwidth in ", - "the wrong units, for one), and neighbours tied at the kernel's ", - "edge (a regular grid), which the bisquare and tricube kernels give ", - "weight 0; use a larger bandwidth or drop the predictor.") +.gwr_rank_hint <- function(selected = NULL) { + paste0(" Typical causes are a predictor that is constant inside a window ", + "(a regional indicator, say), a bandwidth that leaves a window ", + "fewer observations than parameters (a fixed bandwidth in the wrong ", + "units, for one), and neighbours tied at the kernel's edge (a ", + "regular grid), which the bisquare and tricube kernels give weight ", + "0. Use a larger bandwidth or drop the predictor; a predictor that ", + "is constant over whole regions can only be given one global ", + "coefficient (a mixed GWR, GWmodel::gwr.mixed()).", + if (is.null(selected)) "" else sprintf(paste0( + " No bandwidth was supplied: the search selected this one (%s) ", + "on the fitted values, which those windows do estimate; supply a ", + "larger one as `bandwidth` if every coefficient is wanted at ", + "every location."), selected)) } @@ -193,16 +197,17 @@ } -#' Extract fitted or predicted values from a GWmodel GWR result +#' Extract fitted or predicted values from a GWR engine object #' -#' **Unified extraction function** used by \code{fitted.gwr_fit()} (in-sample -#' evaluation, R/model-classes.R). \code{predict.gwr_fit()} used it too, on -#' a \code{gwr.predict()} result (\code{mode = "predict"}); it now computes -#' its predictions itself (see \code{.gwr_predict_at()}). Replaces the -#' previously duplicated .extract_gwr_fitted() and .extract_gwr_predictions() -#' functions. +#' Used by \code{fitted.gwr_fit()} (in-sample evaluation, +#' R/model-classes.R). \code{mode = "predict"} reads the table of a +#' \code{GWmodel::gwr.predict()} result, which \code{predict.gwr_fit()} does +#' not produce (see \code{.gwr_predict_at()}). #' -#' Implements four strategies in order: +#' A fit made by \code{fit_gwr_model()} carries its fitted values in +#' \code{$fitted}, and those are returned. For any other engine object +#' (GWmodel's own, or one from an earlier version) four strategies follow, in +#' order: #' 1. Look for a direct prediction/fitted column in the SDF. #' 2. Reconstruct from local coefficients × design matrix. #' 3. Compute y − residual (works for in-sample gwr.basic results). @@ -224,7 +229,16 @@ mode = c("auto", "basic", "predict")) { mode <- match.arg(mode) na_vec <- rep(NA_real_, n) - + + # A fit made by fit_gwr_model() carries its fitted values outright. They + # are not always the coefficients times the design: in a window of + # deficient rank a coefficient is NA while the fitted value is estimable. + # Matched exactly: `$fitted` would also take an element called + # `fitted.values`. + fv <- tryCatch(gwr_obj[["fitted", exact = TRUE]], error = function(e) NULL) + if (mode != "predict" && is.numeric(fv) && length(fv) == n) + return(as.numeric(fv)) + sdf <- tryCatch(gwr_obj$SDF, error = function(e) NULL) if (is.null(sdf)) return(na_vec) @@ -328,7 +342,7 @@ # while data.matrix() would quietly substitute factor codes for it. # Refuse and fall through instead. if (!all(vapply(cf_df, is.numeric, logical(1)))) { - .log_warn(paste0(".extract_gwr_values(): GWmodel's SDF carries a ", + .log_warn(paste0(".extract_gwr_values(): the fit's SDF carries a ", "non-numeric column for a model term, so the local ", "coefficients cannot be multiplied through; trying ", "the remaining strategies.")) @@ -341,7 +355,7 @@ } } else if (length(shared) >= 1L) { .log_warn(paste0(".extract_gwr_values(): only %d of %d model-matrix ", - "term(s) matched a column in GWmodel's SDF, so the ", + "term(s) matched a column in the fit's SDF, so the ", "local coefficients cannot reconstruct the full linear ", "predictor; trying the remaining strategies."), length(shared), ncol(mm)) @@ -373,15 +387,24 @@ # Main GWR fitting function # ----------------------------------------------------------------------------- -#' Fit a Geographically Weighted Regression (GWR) via GWmodel +#' Fit a Geographically Weighted Regression (GWR) #' -#' Fits a GWR using GWmodel on an sf dataset with either adaptive or fixed -#' bandwidth. +#' Fits a Gaussian GWR on an sf dataset with an adaptive or a fixed +#' bandwidth. The kernels, the bandwidth conventions and the diagnostics are +#' those of the GWmodel package. The local regressions are solved by this +#' package, each as a weighted least squares by pivoted QR, so a window whose +#' design is rank deficient neither stops the fit nor returns coefficients +#' made of rounding error. #' #' @param data_sf An sf object with response, predictors, and geometries. #' @param response_var Response column name. #' @param predictor_vars Predictor column names (numeric columns; a name given -#' twice counts once). +#' twice counts once). \code{character(0)} fits the model with a local +#' intercept alone: the fitted value at a location is the kernel-weighted +#' mean of the response around it. That is the baseline a GWR with +#' predictors has to beat, since any GWR beats a global mean through its +#' local intercept, and \code{\link{select_features_forward}()} fits it as +#' the null model of a GWR sweep. #' @param adaptive Logical; use adaptive bandwidth. Default TRUE. When TRUE, #' bandwidth is an integer number of nearest neighbours. When FALSE, #' bandwidth is a fixed distance in CRS units. @@ -392,12 +415,12 @@ #' for lon/lat data is 0.2 metres, not 0.2 degrees. Read the CRS off #' \code{sf::st_crs(fit$data_sf)}, or pass \code{target_crs} to #' \code{\link{ensure_projected}} beforehand to fix the units yourself. -#' If NULL (default), bandwidth is selected automatically via -#' \code{GWmodel::bw.gwr()}. With \code{adaptive = FALSE}, a bandwidth -#' smaller than a ten-thousandth of the data's extent raises a warning naming -#' the extent and the CRS the fit runs in: every local window is then likely -#' to be empty, which used to produce a fit whose coefficients were all -#' \code{NaN} with nothing raised anywhere. With \code{adaptive = TRUE} +#' If NULL (default), the bandwidth with the lowest AICc is searched for +#' (the lowest leave-one-location-out error when observations share a +#' location); see \strong{Bandwidth selection}. With \code{adaptive = FALSE}, a +#' bandwidth smaller than a ten-thousandth of the data's extent raises a +#' warning naming the extent and the CRS the fit runs in: every local +#' window then holds its own observation alone. With \code{adaptive = TRUE} #' the count is rounded, and one too small for the model is raised, with a #' warning, to the smallest that gives every local regression more points #' of non-zero weight than parameters: the number of predictors plus 3 for @@ -407,9 +430,7 @@ #' leaves a window fewer weighted points; then use a larger bandwidth. #' A count above the number of #' observations is capped at it, with a warning (a distance meant for -#' \code{adaptive = FALSE}, most often). \code{bw.gwr()} searches adaptive -#' bandwidths from 20 neighbours up, so below 20 observations its choice is -#' capped the same way, with a warning, and is not an optimised bandwidth. +#' \code{adaptive = FALSE}, most often). #' @param kernel Kernel function type. One of "bisquare" (default), #' "gaussian", "tricube", "boxcar", "exponential". #' @param .already_prepped Logical (internal). If \code{TRUE}, skip the @@ -418,6 +439,169 @@ #' redundant second pass on every fold. End users should leave this at the #' default \code{FALSE}. #' +#' @section The local solve: +#' At every observation the model is a weighted least squares on the +#' observations whose kernel weight is above zero. It is solved by a +#' Householder QR with column pivoting of the window's weighted design, never +#' by inverting \eqn{X^\top W X}{X'WX}. Before the factorisation each row is +#' multiplied by the square root of its weight over the window's largest +#' weight, and each predictor is divided by its standard deviation over the +#' whole data and centred in the window, so nothing below depends on a +#' predictor's origin or units: an indicator coded 0/1 and one coded +#' 288.7/289.3 give the same fit. +#' +#' One tolerance, \code{1e-7}, decides what a window can estimate: +#' \itemize{ +#' \item \strong{Rank.} A predictor is aliased in a window when the part +#' of it that the terms entered before it do not explain varies there by +#' less than \code{1e-7} of its standard deviation over the study area +#' (the length of that part over the weighted rows). A predictor that is +#' constant among the weighted observations, two predictors that are +#' exactly collinear there, and a window with fewer weighted observations +#' than parameters are the cases. No weight is cut off: under a Gaussian +#' or exponential kernel every observation enters, and distant ones stop +#' counting only through this rule. +#' \item \strong{Coefficients.} A coefficient is returned when it has one +#' value over all least-squares solutions of the window, and is \code{NA} +#' otherwise. The slope of an aliased predictor is \code{NA}. So is the +#' intercept when a predictor is constant in the window at a value other +#' than 0, because it would absorb that value times the slope; when the +#' constant is 0 the intercept is identified and returned. The slopes of +#' the other predictors are returned. +#' \item \strong{Fitted values.} The fitted value at an observation is +#' always estimable (its own row is in its window) and is returned, also +#' where a coefficient is \code{NA}. +#' } +#' A window of deficient rank does not stop the fit. A warning of class +#' \code{"spatialkit_gwr_rank_deficient"} says how many windows are affected +#' and how many coefficients of each term are \code{NA}; +#' \code{info$n_rank_deficient}, \code{info$n_local_singular}, +#' \code{info$nonfinite_coef} and the \code{rank} column of +#' \code{info$local_collinearity} locate them. When many windows hold a +#' predictor constant, a local coefficient is the wrong model for it: its +#' effect is identified only as one global coefficient (a mixed GWR, as +#' \code{GWmodel::gwr.mixed()} fits). +#' +#' The leverage of each observation, the trace of the hat matrix, the +#' residual sum of squares, AICc and the coefficients' standard errors come +#' from the same decomposition. On a window of full rank every one of them +#' equals what \code{GWmodel::gwr.basic()} returns, to rounding error: the +#' largest relative difference in any cell of the six fits the package's +#' tests compare is \code{3e-12}. They are not bit-identical, since GWmodel +#' inverts the normal equations. +#' +#' @section Bandwidth selection: +#' With \code{bandwidth = NULL} the AICc is scored on 16 bandwidths spaced +#' evenly in the logarithm over the whole range, and then refined by a +#' golden-section search between the grid points either side of the best +#' (and, for a count of neighbours, at the counts next to the one it ends +#' on). That is about 20 to 35 fits of the model in all. +#' The range runs, for an adaptive bandwidth, from the smallest count the +#' model's parameters allow to every observation; for a fixed one, from the +#' distance at which half of the windows hold one observation more than the +#' model has parameters (a third of it for the Gaussian and exponential +#' kernels) to the largest distance between two observations. The bandwidth +#' returned is the best of all those scored. +#' +#' A golden-section search over the whole range, which +#' \code{GWmodel::bw.gwr()} runs, assumes the criterion has one minimum. It +#' has several when the coefficients vary at a range that only a few dozen +#' observations resolve, and that search then returns a bandwidth near the +#' top of the range, a nearly global regression, as the selected one. +#' +#' A candidate bandwidth with windows of deficient rank is scored on its +#' fitted values, which those windows do estimate. One at which AICc is +#' undefined (\eqn{tr(S)} not below \eqn{n - 2}) cannot be selected, and +#' neither can one at which a term of the model is estimable at no location: +#' the fit would have no coefficient for it anywhere. +#' +#' The criterion at a candidate comes from the local solve. Under a Gaussian +#' or an exponential kernel, which weight every observation at every +#' location, the fitted value and leverage of a window that is far from rank +#' deficient are computed from its centred cross-products, many windows to +#' one matrix product, and the windows that are not are left to the QR; the +#' two routes agree to rounding error (\code{1e-9} relative in the package's +#' tests) and take the same rank decisions. A default-bandwidth fit with one +#' of those kernels and two predictors then takes 1.1 to 1.6 times as long +#' as \code{GWmodel::bw.gwr()} followed by \code{gwr.basic()} (2.0 s +#' against 1.6 s at 1,000 observations and 7.4 s against 5.7 s at 2,000, +#' fixed Gaussian, on one machine), and 3 to 5 times as long by the QR +#' alone. With several strongly correlated predictors more windows are +#' left to the QR and the fit is slower than that. The fit at the selected +#' bandwidth is always the QR's. +#' +#' Everything scored is kept in \code{info$bandwidth_search}: +#' \code{approach} (the criterion minimised, \code{"AICc"} or \code{"CV"}), +#' \code{by_location} and \code{n_locations} (see \strong{Observations +#' that share a location}), \code{curve} +#' (bandwidth, criterion, trace of the hat matrix, windows of deficient rank, +#' and whether the point belongs to the grid or the refinement), +#' \code{undefined} (how many of the bandwidths scored have no criterion, +#' by reason), +#' \code{n_local_minima} and \code{multimodal} (local minima on the grid), +#' \code{within} and \code{flat} (the range of bandwidths whose AICc is +#' within 2 of the minimum, and whether half the grid is), +#' \code{near_global} (the widest bandwidth of the range is within 2 of the +#' minimum), \code{at_upper} and \code{at_lower} (the minimum is at an end +#' of the range). When any of these holds, one logged line says so (on the +#' console, unless \code{\link{spatialkit_quiet}()} is on; in the trace only +#' for the folds of a cross-validation); it is a +#' message, not a warning, because a minimum at or near the top of the range +#' is the ordinary outcome for a process whose coefficients do not vary. +#' Read \code{near_global} as "AICc does not tell this fit from one global +#' regression". +#' +#' AICc is an in-sample criterion and rewards interpolation between +#' neighbours. The bandwidth it selects can score worse than a wider one on +#' held-out spatial blocks; \code{\link{cv_gwr}} with a supplied +#' \code{bandwidth} is the check. +#' +#' @section Observations that share a location: +#' Rows with the same coordinates (several years at one station, replicate +#' samples of one plot, records geocoded to one address) get one kernel +#' weight at every regression point. \code{info$n_locations} is the number +#' of distinct locations, and when it is below \code{n} a warning of class +#' \code{"spatialkit_gwr_repeated_locations"} gives the counts. Three things +#' follow. +#' +#' \strong{The bandwidth is not selected by AICc.} AICc counts the rows at +#' one location as independent observations. When a location has an effect +#' of its own, which is the usual case, a window that holds little but the +#' location reproduces its mean, the residual sum of squares falls to the +#' spread within locations, and AICc is lowest where the windows +#' interpolate: on 100 simulated sites with 3 observations each it is 58 at +#' 5 to 10 neighbours, 90 at 13 and 221 at 58, while the error of prediction +#' at new sites is 46 at 10 neighbours, 1.35 at 13 and 0.15 at 150. A floor on +#' the bandwidth does not repair that, because the criterion keeps falling +#' towards the floor. With \code{bandwidth = NULL} the search therefore +#' minimises the +#' \strong{leave-one-location-out} sum of squares: each location's +#' observations are predicted by the local regression there without any of +#' them, the kernel keeping its width, and the squared errors are summed. +#' It is computed from the hat matrix of the fit at each bandwidth, without +#' refitting. A bandwidth at which some location cannot be predicted from +#' the others cannot be selected. \code{info$bandwidth_search$approach} is +#' then \code{"CV"} and \code{by_location} is \code{TRUE}. On a layer +#' without repeat locations nothing changes: the criterion is AICc. +#' +#' \strong{The range of an adaptive search counts locations.} It starts at +#' the smallest count that gives every window one location more than the +#' model has parameters, and for a fixed bandwidth at the distance at which +#' half the windows hold that many locations. +#' +#' \strong{AICc and the standard errors still assume independence.} +#' \code{info$AICc}, the comparison with the global regression in +#' \code{summary()} and the standard errors of \code{coef(se = TRUE)} and +#' \code{predict(se.fit = TRUE)} treat every row as an independent +#' observation. With an effect shared by the rows of a location the standard +#' errors are too small, and AICc compared across bandwidths favours the +#' small ones. \code{info$AICc} is \code{NA}, with a warning, when the fit +#' (nearly) reproduces the mean of the observations at each location: +#' \eqn{tr(S)} is then not below the number of rows that differ in location +#' or in a predictor, minus 2, and the value the formula gives measures only +#' the spread among observations that share a location. If the repeats are +#' replicates of one measurement, fit their means, one row per location. +#' #' @section Collinearity diagnostics: #' The function computes **scaled condition indices** of the design and #' warns when one exceeds 30, the conventional threshold, which Wheeler & @@ -436,19 +620,19 @@ #' predictor, and a change of origin (degrees C or kelvin, a year or years #' since 2000) does not move it. #' -#' **Local** indices are then computed at **every** location, on the design -#' the local regression there inverts: each row weighted by the square root +#' **Local** indices are then computed at **every** location, on the weighted +#' design of the local regression there: each row weighted by the square root #' of its kernel weight at the bandwidth the model is fitted with (supplied or -#' selected), with rows of negligible weight dropped. A window left with -#' fewer rows than columns counts as singular. Two indices are kept for each -#' window, as columns of `info$local_collinearity`: +#' selected), with rows of negligible weight (below 1e-8) dropped. A window +#' left with fewer rows than columns counts as singular. Two indices are +#' kept for each window, as columns of `info$local_collinearity`: #' \describe{ #' \item{\code{cn}}{Belsley's index of the intercept plus the predictors, #' scaled to unit length but not centred. A predictor whose values in the #' window are far from 0 against their spread (a year, a temperature in #' kelvin) is collinear with the intercept and raises it: the local #' intercept is then an extrapolation to 0 and is ill-determined, but the -#' slopes are not. It is what GWmodel's own solve sees.} +#' slopes are not.} #' \item{\code{cn_slopes}}{The index for the slopes: the predictors centred at #' their weighted mean in the window and each divided by its standard #' deviation over the whole study area. It is 1 when the predictors vary @@ -458,27 +642,33 @@ #' It does not depend on the predictors' origin or units.} #' } #' A window's slopes count as collinear when `cn_slopes` is above 30 or -#' singular, or when `cn` is above 1e6, where GWmodel's uncentred solve starts -#' to lose precision in the slopes too. Those windows are counted in -#' `info$n_local_collinear`. A predictor that is constant, or nearly so, -#' inside a window is caught this way whether it is alone or has company, so a -#' single predictor is surveyed too. +#' singular. Those windows are counted in `info$n_local_collinear`. A +#' predictor that is constant, or nearly so, inside a window is caught this +#' way whether it is alone or has company, so a single predictor is surveyed +#' too. `cn` does not enter: the local solve centres each predictor in its +#' window, so a predictor far from zero (a year, a temperature in kelvin, a +#' coordinate) has the slopes it would have at any other origin, and is not +#' flagged, however large `cn` is. The one exception is a `cn` that is +#' singular to machine precision, where the predictor's spread is lost in the +#' rounding of its own values. #' #' A warning is issued whenever **any** location has collinear slopes; the #' wording reports a percentage when more than 25% of locations are affected #' and a count otherwise. Both are real R warnings, not log lines. -#' Coefficients at a near-singular window are unstable and can be implausibly -#' large. An **exactly** singular window (an indicator that is constant -#' inside it, or fewer observations than parameters) makes GWmodel stop, so -#' the fit fails with an error that says so; the window is not returned as -#' `NaN`. A window with only `cn` above 30 raises no warning: +#' Coefficients at a near-singular window are least-squares estimates with +#' little to rest on, and can be implausibly large. An **exactly** singular +#' window (an indicator that is constant inside it, or fewer observations +#' than parameters) is of deficient rank: the coefficients it cannot estimate +#' are `NA` and the fit is returned (see \strong{The local solve}). +#' A window with only `cn` above 30 raises no warning: #' `plot(fit, type = "coefficients", term = "Intercept")` masks it, and slope #' maps do not. Centre such a predictor if you want an interpretable local -#' intercept. +#' intercept. The survey is a caution about how well a coefficient is +#' determined, on rows whose weight is not negligible; the solve's rank is +#' the statement about whether it is determined at all. #' -#' After the fit, the local coefficient surfaces are scanned and a further -#' warning counts local regressions that came back non-finite. GWmodel -#' returns those where the kernel weights are undefined: with an adaptive +#' A further warning counts local regressions that have no fitted value. +#' That happens where the kernel weights are undefined: with an adaptive #' bandwidth of `k`, a location where `k` or more observations share the same #' coordinates has a kernel of zero width, and every kernel but the boxcar #' divides 0 by 0 there. The warning names that cause when it applies. @@ -490,29 +680,59 @@ #' Supports \code{predict()}, \code{fitted()}, \code{residuals()}, #' \code{coef()}, \code{summary()}, and \code{model_metrics()}. #' Model-specific metadata lives in \code{$info}: bandwidth, adaptive, -#' kernel, AICc (\code{NA}, with a warning, where GWmodel's AICc is +#' kernel, AICc (\code{NA}, with a warning, where AICc is #' undefined: its effective number of parameters \eqn{tr(S)} is not below #' \eqn{n - 2}, the local regressions all but interpolate the data, and the -#' large negative value GWmodel reports would rank the fit above any -#' other), \code{bandwidth_is_fallback} (\code{TRUE} when automatic -#' selection failed and the arbitrary fallback was used), +#' large negative value the formula gives would rank the fit above any +#' other; also where the fit reproduces the mean of the observations at +#' each location, see \strong{Observations that share a location}), +#' \code{bandwidth_is_fallback} (\code{TRUE} when no bandwidth could +#' be selected: the search failed and the arbitrary fallback was used, or +#' no bandwidth has a defined criterion and the widest was used), #' \code{condition_index} (the global index), \code{local_collinearity} #' (one row per observation: \code{row}, \code{x}, \code{y}, -#' \code{n_window}, \code{cn} and \code{cn_slopes}; see -#' \strong{Collinearity diagnostics}), \code{n_local_collinear} (the +#' \code{n_window}, \code{cn} and \code{cn_slopes}, see +#' \strong{Collinearity diagnostics}, then \code{rank}, the rank the local +#' solve found, and \code{leverage}, the observation's diagonal of the hat +#' matrix), \code{n_local_collinear} (the #' locations whose slopes count as collinear), \code{n_local_singular} -#' (the locations whose local coefficients came back non-finite), +#' (the locations with a local coefficient that is \code{NA}), +#' \code{n_rank_deficient} (the windows whose rank is below the number of +#' parameters), \code{n_saturated} (the windows whose fitted value is their +#' own observation: leverage 1), #' \code{nonfinite_coef} (a logical matrix, one row per observation and #' one column per term, with \code{Intercept} first, \code{TRUE} where the -#' local coefficient came back non-finite, so the count in -#' \code{n_local_singular} can be placed) and \code{n_dropped} (the rows +#' local coefficient is \code{NA}, so the count in +#' \code{n_local_singular} can be placed), \code{n_dropped} (the rows #' \code{prep_model_data()} removed for missing or non-finite values or a -#' bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}). -#' The raw GWmodel result is in \code{$engine}. +#' bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}), +#' \code{n_locations} (the distinct locations of the rows fitted; see +#' \strong{Observations that share a location}), +#' \code{tr_S}, \code{enp}, \code{edf} and \code{sigma2} (the trace of the +#' hat matrix, the effective number of parameters +#' \eqn{2\,tr(S) - tr(S^\top S)}, the effective residual degrees of freedom +#' and the residual variance, as GWmodel defines them), +#' \code{global_ols} (\code{RSS}, \code{RMSE} and \code{AICc} of one +#' least-squares regression on the same rows, the AICc by the same formula +#' with the regression's rank as its trace; a GWR whose AICc is no lower +#' has not shown that its coefficients vary, and \code{summary()} prints +#' the two side by side), +#' \code{rank_tolerance}, \code{max_kernel_width} (the widest kernel at any +#' observation, which \code{predict()} measures new locations against) and +#' \code{bandwidth_search} (see \strong{Bandwidth selection}; \code{NULL} +#' when a bandwidth was supplied). +#' +#' \code{$engine} holds the fit in the layout of the object +#' \code{GWmodel::gwr.basic()} returns, under the same names: \code{SDF} (a +#' \code{SpatialPointsDataFrame} of the local coefficients, \code{y}, +#' \code{yhat}, \code{residual}, \code{CV_Score}, \code{Stud_residual}, the +#' standard errors \code{_SE}, the t values \code{_TV} and +#' \code{Local_R2}), \code{GW.diagnostic}, \code{GW.arguments} and +#' \code{lm} (the global least-squares fit). It is a plain list, not a +#' \code{gwrm} object. #' @family model fitting #' @examples -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' if (requireNamespace("sp", quietly = TRUE)) { #' library(sf) #' set.seed(1) #' n <- 60 @@ -526,6 +746,7 @@ #' fit <- fit_gwr_model(dat, "price", "elev", bandwidth = 30) #' print(summary(fit)) # print(): only a block's last value shows on its own #' head(predict(fit, newdata = dat)) # newdata is re-projected if needed +#' head(coef(fit, se = TRUE)$se) # local standard errors #' } #' @export fit_gwr_model <- function(data_sf, response_var, predictor_vars, @@ -536,24 +757,26 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, .already_prepped = FALSE) { if (!inherits(data_sf, "sf")) stop("fit_gwr_model(): `data_sf` must be an sf object.") - if (!requireNamespace("GWmodel", quietly = TRUE)) - stop("fit_gwr_model(): package 'GWmodel' is required. Install with install.packages('GWmodel').", - call. = FALSE) + # GWmodel is not needed: the local regressions, the bandwidth search and + # the diagnostics are computed here. sp is, for the Spatial table the + # fit's engine keeps its results in. if (!requireNamespace("sp", quietly = TRUE)) - stop("fit_gwr_model(): package 'sp' is required (for GWmodel interop).", - call. = FALSE) + stop("fit_gwr_model(): package 'sp' is required (the fit keeps its ", + "local estimates in a SpatialPointsDataFrame). Install with ", + "install.packages('sp').", call. = FALSE) # match.arg() is the whole of kernel validation: an invalid value never gets # past it. kernel <- match.arg(kernel) - # prep_model_data() accepts character(0) so an intercept-only spatial GP can - # be fitted; a GWR needs at least one predictor to vary locally, and - # reformulate() would otherwise fail with a bare message naming neither - # this function nor the argument. - if (!is.character(predictor_vars) || length(predictor_vars) < 1L) - stop("fit_gwr_model(): `predictor_vars` must name at least one predictor; ", - "there are no local coefficients to estimate otherwise.", - call. = FALSE) + # character(0) is the model without predictors: a local intercept alone, + # which is the kernel-weighted mean of the response at each location. It + # is the baseline a GWR with predictors has to beat (a GWR beats a global + # mean through its local intercept whatever its predictors are), and + # select_features_forward() fits it as its null model. + if (!is.character(predictor_vars)) + stop("fit_gwr_model(): `predictor_vars` must be a character vector of ", + "column names (character(0) for the model with a local intercept ", + "alone).", call. = FALSE) # A name given twice is one term: the formula collapses it, so the fit was # right, but the collinearity checks ran on the duplicated matrix and warned # "exactly singular" and "100% of locations collinear" (Inf condition @@ -567,7 +790,7 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # down runs only in the adaptive branch. Unvalidated, NA gives "missing # value where TRUE/FALSE needed", a length-2 vector gives "the condition has # length > 1", and with adaptive = FALSE a zero or negative distance reaches - # GWmodel::gwr.basic() untouched. + # the kernel untouched. if (!is.null(bandwidth) && (!is.numeric(bandwidth) || length(bandwidth) != 1L || !is.finite(bandwidth) || bandwidth <= 0)) @@ -612,14 +835,11 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, stop("fit_gwr_model(): geometry must be POINT after prep. ", "Run prep_model_data() (or coerce_to_points()) first.", call. = FALSE) - # A factor or character predictor is refused. This began as a guard for - # predict(): gwr.basic() builds its design with model.matrix(), so a factor - # fits cleanly, while GWmodel's gwr.predict() indexes the prediction frame - # by the raw variable names and failed with "non-numeric argument to binary - # operator", which predict.gwr_fit() turned into all NA. predict.gwr_fit() - # no longer calls gwr.predict(), but the refusal stays: gwr_model_selection() - # refuses the same columns on this function's account, and accepting them - # is a change of its own. Reject the column here, where it can be named. + # A factor or character predictor is refused. A factor is several + # model-matrix columns under one name, which the collinearity survey, the + # coefficient table and gwr_model_selection() (one variable, one column) + # are not written for; gwr_model_selection() refuses the same columns on + # this function's account. Reject the column here, where it can be named. non_num <- predictor_vars[ !vapply(sf::st_drop_geometry(dat)[, predictor_vars, drop = FALSE], is.numeric, logical(1))] @@ -673,10 +893,8 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # Gaussian GWR to a binary outcome without a word. if (is.logical(resp_vals)) resp_vals <- as.numeric(resp_vals) # A factor or character response is refused here, as fit_rf_model() and - # fit_bayesian_spatial_model() refuse it. Past this point it reached - # bw.gwr(), failed there twice with "Not compatible with requested type", - # drew the arbitrary-fallback warning, and then stopped in gwr.basic() with - # "'x' must contain finite values only", none of which names the column. + # fit_bayesian_spatial_model() refuse it, with a message that names the + # column; past this point it would fail in the arithmetic, which does not. if (!is.numeric(resp_vals)) stop(sprintf(paste0("fit_gwr_model(): response '%s' is not numeric (it is ", "%s). GWR here is a Gaussian regression: convert a ", @@ -799,49 +1017,92 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # NOTE: dat is already projected by prep_model_data(), so no # additional .is_longlat() / ensure_projected() call is needed. - fml <- stats::reformulate(termlabels = predictor_vars, response = response_var) - + # reformulate() refuses an empty set of terms; "1" is the intercept alone. + fml <- stats::reformulate( + termlabels = if (length(predictor_vars)) predictor_vars else "1", + response = response_var) + needed_cols <- unique(c(response_var, predictor_vars)) sp_dat <- .to_sp(dat, needed_cols) - + # The local regressions are solved here (.gwr_local_solve()), on the model + # matrix and the two coordinates GWmodel's functions were handed. + dsn <- .gwr_design(fml, sp_dat@data) + X <- dsn$X + y <- dsn$y + coords <- sp::coordinates(sp_dat) + # The locations of the layer. Rows that share one are weighted alike at + # every regression point; see "Observations that share a location" in the + # documentation for what follows from that. + loc <- .gwr_locations(coords) + n_distinct <- if (loc$n < n_obs) .gwr_n_distinct(X, loc$id) else n_obs + # --- Bandwidth selection --- bandwidth_is_fallback <- FALSE bw_fallback_raw <- NA_real_ + bw_search <- NULL + bw_none_defined <- FALSE # A fixed bandwidth is a length in the CRS the fit runs in, and that is not # necessarily the CRS the caller was looking at: prep_model_data() projects # geographic input, so 0.2 "degrees" becomes 0.2 metres and every local - # regression is empty -- all coefficients NaN, all fitted values NA, - # summary() reporting n = 0 -- with nothing raised anywhere. Say so at the - # moment the mismatch is visible. + # regression holds its own observation alone. Say so at the moment the + # mismatch is visible. if (!is.null(bandwidth) && !adaptive) .gwr_warn_tiny_fixed_bw(dat, bandwidth, "fit_gwr_model") if (is.null(bandwidth)) { - # .gwr_quietly(): bw.gwr() writes its golden-section search trace with bare - # cat(), which neither suppressMessages() nor suppressWarnings() touches. - # cv_gwr(bandwidth = NULL) calls this once per fold, so without it a - # five-fold CV dumps five full traces. gwr_model_selection() already does - # the same thing and documents why. - bw <- tryCatch( - .gwr_quietly(suppressWarnings( - GWmodel::bw.gwr(fml, data = sp_dat, approach = "AICc", - kernel = kernel, adaptive = adaptive) - )), + # A grid first, then a refinement round its minimum (.gwr_bw_search()). + # A golden-section search over the whole range, GWmodel::bw.gwr()'s, + # assumes one minimum and returns a near-global bandwidth when the + # coefficients vary at short range. cv_gwr(bandwidth = NULL) runs this + # once per fold. + bw_search <- tryCatch( + .gwr_bw_search(X, y, coords, kernel, adaptive, approach = "AICc"), error = function(e) { - .log_warn("fit_gwr_model(): bw.gwr() failed: %s", conditionMessage(e)) - NA_real_ + .log_warn("fit_gwr_model(): the bandwidth search failed: %s", + conditionMessage(e)) + NULL } ) + bw <- if (is.null(bw_search)) NA_real_ else bw_search$bandwidth - # Test the LENGTH first. This condition sits outside the tryCatch above, - # so a bw.gwr() that returns numeric(0) or a length-2 vector -- neither is - # an error, so neither is caught -- reached `!is.finite(bw)` and raised a - # bare "'length = 2' in coercion to 'logical(1)'" from a line that names - # neither the function nor the cause. Anything that is not one usable - # positive number takes the fallback instead. + # Anything that is not one usable positive number takes the fallback. if (length(bw) != 1L || !is.numeric(bw) || !is.finite(bw) || bw <= 0) { bw <- .fallback_bandwidth(sp_dat, adaptive) bandwidth_is_fallback <- TRUE bw_fallback_raw <- as.numeric(bw) + } else if (isTRUE(bw_search$none_defined)) { + # Nothing to select: the widest window is used, and it is not an + # optimised bandwidth, which compare_models() says of a fallback too. + bandwidth_is_fallback <- TRUE + bw_none_defined <- TRUE + .warn_and_log(paste0("fit_gwr_model(): no bandwidth from %s to %s%s has ", + "a defined %s, so none could be selected: at ", + "each of the %d tried %s. The widest, %s, is ", + "used. Supply `bandwidth`, or use fewer ", + "predictors or more observations."), + format(signif(bw_search$range[1L], 6)), + format(signif(bw_search$range[2L], 6)), + if (adaptive) " neighbours" else "", + .gwr_bw_criterion_name(bw_search, score = TRUE), + bw_search$n_evaluations, + .gwr_bw_undefined_text(bw_search, n_obs), + format(signif(bw, 6))) + } else { + # What the grid showed, in one line: a message on the console for a + # direct call, never a warning (a minimum at the top of the range is + # the ordinary outcome when the coefficients do not vary). A fold of a + # cross-validation writes it to the trace only, or it would be printed + # once per fold. + note <- .gwr_bw_search_note(bw_search, adaptive) + if (nzchar(note)) + (if (isTRUE(.already_prepped)) .log_info else .log_warn)( + paste0("fit_gwr_model(): bandwidth %s%s selected by %s ", + "from %d scored between %s and %s: %s See ", + "info$bandwidth_search."), + format(signif(bw, 6)), if (adaptive) " neighbours" else "", + .gwr_bw_criterion_name(bw_search), + bw_search$n_evaluations, + format(signif(bw_search$range[1L], 6)), + format(signif(bw_search$range[2L], 6)), note) } } else { bw <- as.numeric(bandwidth) @@ -887,13 +1148,11 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, "bandwidth.") else "") bw <- min_bw } - # Capped at n, as before, but no longer in silence. A supplied count - # above n is most often a distance passed with adaptive left at TRUE: - # 1500 (metres) on 200 points became a near-global fit whose local slopes - # varied half as much as the intended one's. And bw.gwr() searches - # adaptive bandwidths from 20 up to n, a reversed range below 20 points, - # so its choice there exceeds n and the fit is not at the bandwidth it - # chose. The fallback's own warning already names its clamp. + # Capped at n, and said. A supplied count above n is most often a + # distance passed with adaptive left at TRUE: 1500 (metres) on 200 points + # became a near-global fit whose local slopes varied half as much as the + # intended one's. The search never goes past n, and the fallback's own + # warning names its clamp. if (bw > max_bw) { if (!is.null(bandwidth)) .warn_and_log(paste0("fit_gwr_model(): an adaptive bandwidth of %d ", @@ -902,14 +1161,6 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, "count of neighbours; for a distance in CRS ", "units, set adaptive = FALSE."), bw, n_obs, n_obs) - else if (!bandwidth_is_fallback) - .warn_and_log(paste0("fit_gwr_model(): GWmodel::bw.gwr() searches ", - "adaptive bandwidths from 20 neighbours up to n, ", - "a range that is empty for %d observations, and ", - "returned %d; using %d. Neither is an optimised ", - "bandwidth: with this few observations, supply ", - "`bandwidth`."), - n_obs, bw, n_obs) bw <- max_bw } } @@ -919,7 +1170,7 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # and a warning naming a bandwidth the fit did not use sends the reader # looking for a number that appears nowhere in the result. Both are named # when they differ. - if (bandwidth_is_fallback) { + if (bandwidth_is_fallback && !bw_none_defined) { bw_used <- as.numeric(bw) warning( sprintf( @@ -951,113 +1202,184 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } # --- Fit GWR --- - # One exactly singular window makes Armadillo's inv() throw "matrix is - # singular", and gwr.basic() stops the whole fit; it never returns such a - # window as NaN. The bare message names neither the window nor the cause, - # while the survey above has just counted the singular windows, so say both. - fit <- tryCatch( - GWmodel::gwr.basic(formula = fml, data = sp_dat, bw = bw, - kernel = kernel, adaptive = adaptive), - error = function(e) { - msg <- conditionMessage(e) - n_sing <- if (is.null(local_cn_df)) 0L else sum(is.infinite(local_cn_df$cn)) - hint <- if (!grepl("singular", msg, fixed = TRUE)) "" else - .gwr_singular_hint(n_sing) - stop(sprintf("fit_gwr_model(): GWR fit failed: %s%s", msg, hint), - call. = FALSE) - } - ) + # One pivoted QR per window. A window of deficient rank does not stop the + # fit and does not return rounding error: the coefficients it cannot + # estimate are NA, and its fitted value is returned when it is estimable, + # which at a training point it always is. + sv <- .gwr_local_solve(X, y, coords, bw, kernel, adaptive, what = "fit") + dg <- .gwr_diagnostics(y, sv$fitted, sv$leverage, sv$var_fit) + fit <- .gwr_engine(sv, dg, fml, sp_dat, X, y, bw, kernel, adaptive) - # A non-finite local coefficient comes back without an error, and nothing - # downstream says so: fitted(), residuals(), summary() and model_metrics() - # all drop the non-finite rows, so a fit in which 182 of 200 local - # regressions failed reported n = 18 and R2 = 0.96 as though that were the - # whole model. Count them and say so. The cause is NOT a singular window - # (that stops the fit above) but undefined kernel weights: an adaptive - # bandwidth whose bw-th nearest neighbour is at distance zero -- bw or more - # observations at one location -- gives every kernel but the boxcar 0/0. - # The survey saw those windows as empty (n_window 0), which is how the - # warning can name the cause instead of guessing. - # The per-row, per-term mask of non-finite local coefficients is kept + # The per-row, per-term mask of local coefficients that are not estimates # (`info$nonfinite_coef`), not only its row count: the count says how many - # local regressions failed, the mask says which, and which term. NULL when - # the coefficient table could not be read. - nonfinite_mask <- tryCatch({ - sdf <- fit$SDF - if (is.null(sdf)) NULL else { - b <- as.data.frame(sdf) - cols <- intersect(c("Intercept", predictor_vars), names(b)) - if (!length(cols)) NULL - else { - ok <- vapply(b[cols], - function(z) is.finite(suppressWarnings(as.numeric(z))), - logical(nrow(b))) - if (!is.matrix(ok)) ok <- matrix(ok, nrow = nrow(b), - dimnames = list(NULL, cols)) - !ok - } - } - }, error = function(e) NULL) - bad_rows <- if (is.null(nonfinite_mask)) logical(0) else - apply(nonfinite_mask, 1L, any) + # local regressions are affected, the mask says which, and which term. + nonfinite_mask <- !is.finite(sv$coef) + bad_rows <- apply(nonfinite_mask, 1L, any) n_bad_local <- sum(bad_rows) - if (n_bad_local > 0L) { - n_zero_width <- if (isTRUE(adaptive) && !is.null(local_cn_df) && - nrow(local_cn_df) == length(bad_rows)) - sum(bad_rows & local_cn_df$n_window == 0L, na.rm = TRUE) else 0L + no_fit <- is.na(sv$fitted) + deficient <- sv$rank < n_params + n_saturated <- sum(sv$leverage >= 1 - .gwr_rank_tol(), na.rm = TRUE) + + # A window with no fitted value. Nothing downstream says so by itself: + # fitted(), residuals(), summary() and model_metrics() all drop the rows + # without one, so a fit in which 182 of 200 local regressions had none + # reported n = 18 and R2 = 0.96 as though that were the whole model. The + # cause is undefined kernel weights: an adaptive bandwidth whose bw-th + # nearest neighbour is at distance zero -- bw or more observations at one + # location -- gives every kernel but the boxcar 0/0, and no row of such a + # window carries weight. + if (any(no_fit)) { + n_zero_width <- if (isTRUE(adaptive)) sum(no_fit & sv$n_window == 0L) else 0L cause <- if (n_zero_width > 0L) sprintf(paste0(" -- at %d of them %d or more observations share one ", "location, so the adaptive kernel has zero width and its ", "weights are 0/0. Use a bandwidth larger than the most ", "observations at any one location, or aggregate repeat ", "observations first"), n_zero_width, as.integer(bw)) - else " (undefined kernel weights or a numerically degenerate local design)" + else " (undefined kernel weights)" .warn_and_log(paste0("fit_gwr_model(): %d of %d local regression(s) ", "returned non-finite coefficients%s. fitted(), ", "residuals() and every metric are computed from the ", "%d that succeeded, so they describe part of the ", "study area only."), - n_bad_local, n_obs, cause, n_obs - n_bad_local) + sum(no_fit), n_obs, cause, n_obs - sum(no_fit)) + } + + # Windows of deficient rank that do have a fitted value: some coefficients + # are NA there, and the caller has to be told which and how many. + part <- deficient & !no_fit + if (any(part)) { + by_term <- colSums(nonfinite_mask[part, , drop = FALSE]) + sat_part <- sum(part & sv$leverage >= 1 - .gwr_rank_tol(), na.rm = TRUE) + .gwr_warn( + "spatialkit_gwr_rank_deficient", + paste0("fit_gwr_model(): %d of %d local regressions are rank deficient ", + "at the bandwidth in use (%s%s, %s kernel): among the ", + "observations that carry weight there a predictor does not ", + "vary, the predictors are exactly collinear, or fewer ", + "observations than the %d parameters carry weight. The ", + "coefficients those windows cannot estimate are NA (%s) and are ", + "counted in info$n_local_singular; their fitted values are ", + "estimable and are returned%s.%s"), + sum(part), n_obs, format(bw), if (adaptive) " neighbours" else "", + kernel, n_params, + paste(sprintf("%s at %d", colnames(nonfinite_mask), by_term), + collapse = ", "), + if (sat_part > 0L) + sprintf(paste0("; %d of those windows hold as many weighted ", + "observations as they have estimable coefficients, so ", + "the fitted value there is the observation itself"), + sat_part) else "", + .gwr_rank_hint( + selected = if (is.null(bandwidth) && !bandwidth_is_fallback) + format(bw) else NULL)) } # AICc extraction - AICc_val <- NA_real_ - if (!is.null(fit$GW.diagnostic) && !is.null(fit$GW.diagnostic$AICc)) { - AICc_val <- suppressWarnings(as.numeric(fit$GW.diagnostic$AICc)) - # Outside its domain (tr S >= n - 2) GWmodel's AICc is a large negative - # number, -15033 for a 100-point fit whose windows interpolate, and - # compare_models() and print() took it as the best fit there is. Report - # NA and say why; see .gwr_aicc_undefined(). - AIC_val <- suppressWarnings(as.numeric(fit$GW.diagnostic$AIC %||% NA_real_)) - if (length(AICc_val) == 1L && length(AIC_val) == 1L && - isTRUE(.gwr_aicc_undefined(AIC_val, AICc_val))) { - trS <- .gwr_trace_s(AIC_val, fit$GW.diagnostic$RSS.gw %||% NA_real_, - n_obs) - # "Use a larger bandwidth" cannot be followed once an adaptive one is - # already every observation: the remedy is then fewer parameters, more - # data, or a kernel that does not give the farthest point weight 0. - remedy <- if (isTRUE(adaptive) && bw >= n_obs) - sprintf(paste0("Even the widest adaptive window (all %d observations) ", - "leaves too few residual degrees of freedom for %d ", - "parameters: use fewer predictors, more observations, ", - "or a gaussian or exponential kernel."), - n_obs, n_params) - else - sprintf("The bandwidth (%s%s) is too small for %d parameters; use a larger one.", - format(bw), if (adaptive) " neighbours" else "", n_params) - .warn_and_log(paste0("fit_gwr_model(): AICc is undefined for this fit ", - "and is reported as NA. Its effective number of ", - "parameters, tr(S) = %s, is not below n - 2 = %d, ", - "so the local regressions (nearly) interpolate the ", - "data, and there GWmodel's AICc formula turns ", - "negative: its value (%s) would rank this fit above ", - "better ones. %s"), - if (is.na(trS)) "?" else format(round(trS, 2)), - n_obs - 2L, format(signif(AICc_val, 6)), remedy) - AICc_val <- NA_real_ - } + AICc_val <- dg$AICc + # Outside its domain (tr S >= n - 2) the AICc formula gives a large negative + # number, -15033 for a 100-point fit whose windows interpolate, and + # compare_models() and print() took it as the best fit there is. Report + # NA and say why; see .gwr_aicc_undefined(). + if (isTRUE(.gwr_aicc_undefined(dg$AIC, dg$AICc)) || + isTRUE(dg$tr_S >= n_obs - 2)) { + trS <- dg$tr_S + # "Use a larger bandwidth" cannot be followed once an adaptive one is + # already every observation: the remedy is then fewer parameters, more + # data, or a kernel that does not give the farthest point weight 0. + remedy <- if (isTRUE(adaptive) && bw >= n_obs) + sprintf(paste0("Even the widest adaptive window (all %d observations) ", + "leaves too few residual degrees of freedom for %d ", + "parameters: use fewer predictors, more observations, ", + "or a gaussian or exponential kernel."), + n_obs, n_params) + else + sprintf("The bandwidth (%s%s) is too small for %d parameters; use a larger one.", + format(bw), if (adaptive) " neighbours" else "", n_params) + .warn_and_log(paste0("fit_gwr_model(): AICc is undefined for this fit ", + "and is reported as NA. Its effective number of ", + "parameters, tr(S) = %s, is not below n - 2 = %d, ", + "so the local regressions (nearly) interpolate the ", + "data, and there the AICc formula turns ", + "negative: its value (%s) would rank this fit above ", + "better ones. %s"), + if (is.na(trS)) "?" else format(round(trS, 2)), + n_obs - 2L, format(signif(AICc_val, 6)), remedy) + AICc_val <- NA_real_ + } else if (n_distinct < n_obs && isTRUE(dg$tr_S >= n_distinct - 2)) { + # Rows that share a location and every predictor value get one fitted + # value, so this fit is a fit to the means of the groups they form, and + # it has (all but) one parameter for each mean. The formula still gives + # a number, because it counts every row; that number measures the spread + # inside the groups and nothing the bandwidth is responsible for. + .warn_and_log(paste0("fit_gwr_model(): AICc is reported as NA for this ", + "fit. The %d observations are %d distinct ", + "combinations of location and predictor values, and ", + "the fit's effective number of parameters, tr(S) = ", + "%s, is not below that number minus 2 (%d): the ", + "local regressions (nearly) reproduce the mean of ", + "the observations at each location, so the value ", + "the formula gives (%s) measures only the spread ", + "among observations that share a location, and it ", + "can rank this fit above one that predicts at a ", + "new location. Use a larger bandwidth."), + n_obs, n_distinct, format(round(dg$tr_S, 2)), + n_distinct - 2L, format(signif(AICc_val, 6))) + AICc_val <- NA_real_ } - + if (!is.finite(AICc_val)) AICc_val <- NA_real_ + + # Several observations at one location. Said once, with the counts: the + # numbers below that assume independent observations, and how the + # bandwidth was chosen. A fold of a cross-validation writes it to the + # trace only, as it does the note on the search. + if (loc$n < n_obs) { + repeat_msg <- sprintf( + paste0("fit_gwr_model(): the %d observations are at %d distinct ", + "location(s) (%d hold more than one observation, the most %d). ", + "AICc, the standard errors and the comparison with the global ", + "regression count the observations at one location as ", + "independent. They ", + "are not when a location has an effect of its own: AICc then ", + "falls as the bandwidth shrinks and the standard errors are ", + "too small.%s If the repeats are replicates of one ", + "measurement, fit their means, one row per location."), + n_obs, loc$n, sum(loc$size > 1L), max(loc$size), + if (is.null(bandwidth) && !bandwidth_is_fallback && + isTRUE(bw_search$by_location)) + sprintf(paste0(" No bandwidth was supplied: it was selected by %s ", + "(each location predicted from the others), not by ", + "AICc."), .gwr_bw_criterion_name(bw_search)) + else "") + if (isTRUE(.already_prepped)) .log_info("%s", repeat_msg) + else .gwr_warn("spatialkit_gwr_repeated_locations", "%s", repeat_msg) + } + + # The benchmark a GWR is read against: one least-squares regression on the + # same rows, scored by the same AICc formula (its hat-matrix trace is its + # rank). A GWR whose AICc is no lower has not shown that its coefficients + # vary. + ols_rss <- sum(stats::residuals(fit$lm)^2) + ols_rank <- fit$lm$rank + global_ols <- list( + RSS = ols_rss, + RMSE = sqrt(ols_rss / n_obs), + AICc = if (isTRUE(ols_rss > 0) && n_obs - 2 - ols_rank > 0) + n_obs * log(ols_rss / n_obs) + n_obs * log(2 * pi) + + n_obs * ((n_obs + ols_rank) / (n_obs - 2 - ols_rank)) else NA_real_) + + # The survey and the solve, side by side for each window: the condition + # indices, then the rank the solve found and the leverage of the window's + # own observation. + if (is.null(local_cn_df)) + local_cn_df <- data.frame(row = seq_len(n_obs), x = coords[, 1L], + y = coords[, 2L], n_window = sv$n_window, + cn = NA_real_, cn_slopes = NA_real_) + n_local_collinear <- if (is.null(local_collinearity)) NA_integer_ else + sum(.gwr_slopes_collinear(local_cn_df, own_solve = TRUE)) + local_cn_df$rank <- sv$rank + local_cn_df$leverage <- sv$leverage + new_spatial_fit( subclass = "gwr_fit", engine = fit, @@ -1078,28 +1400,71 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, condition_index = global_cn, # One row per observation: the two condition indices (cn, with the # intercept and uncentred; cn_slopes, for the slopes) of the - # kernel-weighted local design at that location. NULL only when - # there is no numeric predictor to survey. + # kernel-weighted local design at that location, the rank the local + # solve found there and the leverage of the location's own observation. local_collinearity = local_cn_df, # The locations whose SLOPES are collinear; an ill-determined # intercept alone (cn > 30 only) is not counted. - n_local_collinear = if (is.null(local_cn_df)) NA_integer_ else - sum(.gwr_slopes_collinear(local_cn_df)), + n_local_collinear = n_local_collinear, + # The locations with a coefficient that is not an estimate (NA), the + # windows of deficient rank among them, and the windows whose fitted + # value is their own observation. n_local_singular = n_bad_local, + n_rank_deficient = sum(deficient), + n_saturated = n_saturated, # One row per observation, one column per term (Intercept first): - # TRUE where GWmodel returned a non-finite local coefficient. + # TRUE where the local coefficient is not an estimate. nonfinite_coef = nonfinite_mask, - n_dropped = n_dropped + n_dropped = n_dropped, + # The distinct locations of the training rows: fewer than `n` when + # observations share a location. + n_locations = loc$n, + # The global numbers of the fit, from the same decomposition as the + # coefficients: trace of the hat matrix, effective number of parameters + # and degrees of freedom, residual variance. + tr_S = dg$tr_S, + enp = dg$enp, + edf = dg$edf, + sigma2 = dg$sigma2, + # One global least-squares fit on the same rows, by the same criterion. + global_ols = global_ols, + rank_tolerance = .gwr_rank_tol(), + # The widest kernel at any training location: predict() compares a new + # location's distance to its nearest training point with it. + max_kernel_width = suppressWarnings(max(sv$width, na.rm = TRUE)), + # What the bandwidth search scored, NULL when a bandwidth was supplied. + bandwidth_search = bw_search ) ) } +#' The distance parameter of the kernel at one regression point +#' +#' The bandwidth itself when it is a distance; for an adaptive bandwidth the +#' distance to the \code{bw}-th nearest point, and \code{bw / length(d)} +#' times the largest distance when \code{bw} exceeds the number of points, +#' as GWmodel has it. +#' +#' @param d Numeric vector of distances from the regression point. +#' @param bw Bandwidth: a distance, or a neighbour count when adaptive. +#' @param adaptive Logical. +#' @return One number. +#' @keywords internal +#' @noRd +.gw_kernel_width <- function(d, bw, adaptive) { + if (!isTRUE(adaptive)) return(as.numeric(bw)) + k <- max(1L, as.integer(round(bw))) + if (k <= length(d)) sort.int(d, partial = k)[k] else k / length(d) * max(d) +} + + #' Kernel weights of GWmodel's five kernels #' #' The same definitions, written the same way, as \code{GWmodel::gw.weight()} -#' (its C++ \code{gw_weight_*()}), so the weighted local design surveyed below -#' is the one \code{gwr.basic()} inverts. For an adaptive bandwidth \code{bw} +#' (its C++ \code{gw_weight_*()}), so a window of the local solve, and of the +#' collinearity survey, is the window \code{GWmodel::gwr.basic()} would +#' weight. For an adaptive bandwidth \code{bw} #' is a neighbour count and the kernel's distance parameter is the distance to #' the \code{bw}-th nearest point; a count above \code{length(d)} widens the #' kernel to \code{bw / length(d)} times the largest distance, as GWmodel does. @@ -1109,22 +1474,21 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' window (weight 1) and on the rim of a bisquare or tricube one (weight 0). #' And a zero-width kernel (\code{h = 0}: the \code{bw} nearest points share #' one location) is not an indicator of those points: every kernel but the -#' boxcar gives them \code{0/0 = NaN}, which is where GWmodel's non-finite -#' local coefficients come from. +#' boxcar gives them \code{0/0 = NaN}, and a window whose weights are +#' undefined has no weighted row and no local regression. #' #' @param d Numeric vector of distances from the regression point. #' @param bw Bandwidth: a distance, or a neighbour count when adaptive. #' @param kernel One of the validated kernel names. #' @param adaptive Logical. +#' @param h The kernel's distance parameter, when the caller has it already +#' (\code{.gw_kernel_width()}). #' @return Numeric weights, one per element of \code{d} (\code{NaN} where #' GWmodel's are). #' @keywords internal #' @noRd -.gw_kernel_weights <- function(d, bw, kernel, adaptive) { - h <- if (isTRUE(adaptive)) { - k <- max(1L, as.integer(round(bw))) - if (k <= length(d)) sort(d, partial = k)[k] else k / length(d) * max(d) - } else as.numeric(bw) +.gw_kernel_weights <- function(d, bw, kernel, adaptive, + h = .gw_kernel_width(d, bw, adaptive)) { # The spelling below is GWmodel's, not a simplification of it: d / h would # give the same weights for h > 0 but not GWmodel's NaN for h = 0. switch(kernel, @@ -1136,6 +1500,1513 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } +#' The rows of a window and their kernel weights +#' +#' What \code{which(w > 0)} and \code{w[w > 0]} give for +#' \code{w <- .gw_kernel_weights(d, , kernel, , h = h)}, without computing a +#' weight for every point: the three kernels with an edge are evaluated only +#' at the points not beyond it. The values are the same to the last bit (the +#' expressions are those of \code{.gw_kernel_weights()}), an undefined weight +#' (a zero-width kernel) is dropped as \code{w > 0} drops it, and the rows +#' come back in their order in \code{d}. +#' +#' @param d Numeric vector of distances from the regression point. +#' @param h The kernel's distance parameter (\code{.gw_kernel_width()}). +#' @param kernel One of the validated kernel names. +#' @return A list: \code{rows} (integer indices into \code{d}) and \code{w} +#' (their weights, all above zero). +#' @keywords internal +#' @noRd +.gw_window <- function(d, h, kernel) { + if (kernel == "gaussian" || kernel == "exponential") { + w <- if (kernel == "gaussian") exp(d^2 / (-2 * h^2)) else exp(-d / h) + rows <- which(w > 0) + return(list(rows = rows, w = w[rows])) + } + inside <- which(!(d > h)) + di <- d[inside] + w <- switch(kernel, + tricube = (1 - di^3 / h^3)^3, + boxcar = rep(1, length(di)), + (1 - di^2 / h^2)^2) # bisquare + keep <- which(w > 0) + list(rows = inside[keep], w = w[keep]) +} + + +#' The one tolerance of the local solve +#' +#' Used twice in \code{.gwr_local_solve()}, on the same triangular factor: a +#' diagonal entry below it ends the window's rank, and a coefficient or a +#' fitted value is estimable when what the window cannot place of it is no +#' larger than this times its largest term. \code{stats::lm()} uses the same +#' number for its own rank decision. +#' +#' @return \code{1e-7}. +#' @keywords internal +#' @noRd +.gwr_rank_tol <- function() 1e-7 + + +#' One weighted least squares per regression point, by pivoted QR +#' +#' The local regression at a point \eqn{u} minimises +#' \eqn{\sum_r w_r(u)\,(y_r - x_r^\top\beta)^2} over the training rows whose +#' kernel weight is above zero. It is solved here, for every row of +#' \code{rp}, by a Householder QR with column pivoting (LAPACK +#' \code{dgeqp3}, through \code{qr(LAPACK = TRUE)}) of the window's weighted +#' design, and never by inverting \eqn{X^\top W X}: the inverse squares the +#' design's condition number, and on a window of deficient rank it returns +#' rounding error or stops, according to how the predictor happens to be +#' coded. +#' +#' \strong{The design that is factored.} Rows are multiplied by +#' \eqn{\sqrt{w / \max w}}, so the largest weight in a window is 1 whatever +#' the kernel's scale. Each predictor is divided by its standard deviation +#' over the whole training data and centred, first on the regression point's +#' own value (an exact subtraction for nearby values, which leaves a predictor +#' that is constant in the window exactly zero) and then on its weighted mean +#' in the window. The centred columns are orthogonal to the intercept, so +#' neither the rank nor any result depends on a predictor's origin or units: +#' a temperature in kelvin and in degrees C, an indicator coded 0/1 and +#' 288.7/289.3, give the same ranks, fitted values and slopes. +#' +#' \strong{The rank rule.} With column pivoting the diagonal of the +#' triangular factor does not increase, and each entry is the length of what +#' is left of the next column once the columns already entered are projected +#' out. The window's rank is the number of leading entries of at least +#' \code{tol}. In words: a predictor is aliased in a window when the part of +#' it that the terms before it do not explain varies there, summed over the +#' weighted rows, by less than \code{tol} of its standard deviation over the +#' study area. No weight is cut off: under a Gaussian or an exponential +#' kernel every row enters, and distant rows whose weights are tiny against +#' the window's largest stop counting only through this rule. +#' +#' \strong{Estimability.} In a window of deficient rank a linear function +#' \eqn{c^\top\beta} of the coefficients has one value for every least-squares +#' solution exactly when \eqn{c} lies in the row space of the weighted +#' design. That is tested on the same factor with the same \code{tol}: with +#' \eqn{R = [R_{11}\; R_{12}]} in pivot order, the part of \eqn{c} the window +#' cannot place is \eqn{c_2 - R_{12}^\top R_{11}^{-\top} c_1}, and \eqn{c} is +#' estimable when no entry of it exceeds \code{tol} times the largest entry +#' of \eqn{c}. Every original coefficient is tested (its row of the +#' transformation back from the centred, scaled columns) and reported +#' \code{NA} when it fails, not only the column the pivoting left out: with a +#' predictor constant at \eqn{v} in a window its slope is aliased and so is +#' the intercept, which would otherwise absorb \eqn{v} times the slope, unless +#' \eqn{v = 0}. The fitted or predicted value is tested the same way, with +#' \eqn{c} the regression point's own row: it is always estimable at a +#' training point (its row is in its own window), and at a new location it is +#' \code{NA} when a predictor there takes a value the window's rows cannot +#' place. +#' +#' \strong{What comes from the same decomposition.} With +#' \eqn{t = R_{11}^{-\top} c_1} and \eqn{Q_1} the first \code{rank} columns of +#' \eqn{Q}, \eqn{c^\top\hat\beta = t^\top Q_1^\top W^{1/2} y}, so the weights +#' the estimate puts on the observations are \eqn{W^{1/2} Q_1 t}. For the +#' regression point's own row those weights are its row of the hat matrix: +#' the leverage is its entry at the point itself, and its sum of squares is +#' the point's share of \eqn{tr(S^\top S)}. For a coefficient the sum of +#' squares is the factor its variance multiplies \eqn{\sigma^2} by, the +#' diagonal of \eqn{C C^\top} with \eqn{C = (X^\top W X)^{-1} X^\top W} in +#' GWmodel's notation. On a window of full rank all of these equal +#' \code{GWmodel::gwr.basic()}'s to rounding error. +#' +#' @param X Training design matrix, the intercept (a column of ones) first. +#' A design without an intercept is scaled by each column's root mean +#' square and not centred. +#' @param y Response, one value per row of \code{X}. +#' @param coords Two-column matrix of the training coordinates. +#' @param bw,kernel,adaptive The bandwidth settings; see +#' \code{.gw_kernel_weights()}. An adaptive bandwidth counts neighbours +#' among the training points. +#' @param rp Two-column matrix of regression points, or \code{NULL} for the +#' training points themselves. +#' @param X_rp Design matrix at \code{rp} (same columns as \code{X}). +#' @param what \code{"fit"}: coefficients, their variance factors, fitted +#' values, hat rows. \code{"score"}: fitted values and leverage only, for +#' the bandwidth search and the selection sweep. \code{"predict"}: fitted +#' values at \code{rp}, with their variance factor when \code{se = TRUE}. +#' @param se For \code{what = "predict"}: also return the variance factor of +#' each prediction. +#' @param tol The tolerance; see above. +#' @param loc The training layer's locations (\code{.gwr_locations()}), for +#' \code{what = "score"} when the leave-one-location-out score is wanted; +#' \code{NULL} otherwise. +#' @return A list. Always \code{fitted} (\code{NA} where not estimable), +#' \code{rank} (0 where no row carries weight), \code{n_window} (rows with +#' weight above zero), \code{n_coef} and \code{width} (the kernel's distance +#' parameter at each regression point). When the regression points are the +#' training points, \code{leverage} and \code{n_estimable} (for each term, +#' the number of windows that estimate it); with \code{loc} on a layer whose +#' locations repeat, \code{hat_loc} (for each row at a shared location, its +#' hat-matrix entries on the rows of that location, in row order). For +#' \code{"fit"} also \code{coef} and +#' \code{coef_var} (one row per regression point, one column per term, +#' \code{NA} where not estimable; multiply \code{coef_var} by +#' \eqn{\sigma^2} for the variance), \code{var_fit} (the fitted value's +#' variance factor, its hat row's sum of squares), \code{q_diag} (the +#' diagonal of \eqn{(I - S)^\top (I - S)}) and \code{local_r2} (GWmodel's +#' local \eqn{R^2}). For \code{"predict"} with \code{se = TRUE}, +#' \code{var_fit}. +#' @keywords internal +#' @noRd +.gwr_local_solve <- function(X, y, coords, bw, kernel, adaptive, + rp = NULL, X_rp = NULL, + what = c("fit", "score", "predict"), + se = FALSE, tol = .gwr_rank_tol(), loc = NULL) { + what <- match.arg(what) + self <- is.null(rp) + if (self) { rp <- coords; X_rp <- X } + n <- nrow(X); kk <- ncol(X); m <- nrow(rp) + icpt <- kk >= 1L && all(X[, 1L] == 1) + jp <- if (icpt) seq_len(kk)[-1L] else seq_len(kk) + p <- length(jp) + s <- rep(1, p) + if (p) { + s <- if (icpt) apply(X[, jp, drop = FALSE], 2L, stats::sd) + else sqrt(colMeans(X[, jp, drop = FALSE]^2)) + # A predictor with no spread over the whole data has no scale to offer; + # it is exactly constant in every window and aliased there whatever the + # divisor. + s[!is.finite(s) | s <= 0] <- 1 + } + inv_s <- 1 / s + Xs <- sweep(X[, jp, drop = FALSE], 2L, s, "/") + Xs_rp <- sweep(X_rp[, jp, drop = FALSE], 2L, s, "/") + cx <- coords[, 1L]; cy <- coords[, 2L]; rx <- rp[, 1L]; ry <- rp[, 2L] + full <- what == "fit" + need_q <- full || (what == "predict" && isTRUE(se)) + + yhat <- rep(NA_real_, m) + rk <- integer(m) + nw <- integer(m) + width <- rep(NA_real_, m) + near <- if (self) NULL else rep(NA_real_, m) + # A regression point without a location or with a missing predictor has + # no local regression; its row stays NA. + usable <- is.finite(rx) & is.finite(ry) & + rowSums(!is.finite(X_rp)) == 0L + lev <- if (self) rep(NA_real_, m) else NULL + vfit <- if (need_q) rep(NA_real_, m) else NULL + # The windows at which each term is estimable, counted for the training + # points: a term that no window estimates has no coefficient anywhere. + nest <- if (self) integer(kk) else NULL + # Each training row's hat entries on the rows that share its location, for + # the leave-one-location-out score (see .gwr_lolo_residuals()). Kept only + # where a location holds more than one row. + by_loc <- self && !need_q && !is.null(loc) && loc$n < n + if (by_loc) { + loc_rows <- split(seq_len(n), loc$id) + shared <- loc$size[loc$id] > 1L + hat_loc <- vector("list", n) + } + if (full) { + B <- matrix(NA_real_, m, kk, dimnames = list(NULL, colnames(X))) + V <- B + qd <- numeric(n); tssw <- numeric(n); rssw <- numeric(n) + dyb <- (y - mean(y))^2 + } + # Each original coefficient as a function of the centred, scaled ones: a + # slope is its scaled slope over the predictor's standard deviation, and + # the intercept takes every centring back out. + back <- function(xf, mu) + if (!p) matrix(1, 1L, 1L) + else if (icpt) rbind(c(1, -(xf + mu)), cbind(0, diag(inv_s, p, p)), + deparse.level = 0L) + else diag(inv_s, p, p) + + todo <- which(usable) + # A kernel that weights every row: the score of the windows that are far + # from rank deficient comes from their cross-products, a block at a time + # (.gwr_score_dense()); the loop below takes the others. + if (self && what == "score" && icpt && n > 1L && + kernel %in% c("gaussian", "exponential")) { + ds <- .gwr_score_dense(X, y, coords, bw, kernel, adaptive, + loc = if (by_loc) loc else NULL) + hit <- which(ds$done & usable) + yhat[hit] <- ds$fitted[hit] + lev[hit] <- ds$leverage[hit] + rk[hit] <- kk + nw[hit] <- ds$n_window[hit] + width[hit] <- ds$width[hit] + nest <- nest + length(hit) + if (by_loc) hat_loc[hit] <- ds$hat_loc[hit] + todo <- setdiff(todo, hit) + } + + for (i in todo) { + d <- sqrt((cx - rx[i])^2 + (cy - ry[i])^2) + if (!self) near[i] <- min(d) + h <- .gw_kernel_width(d, bw, adaptive) + width[i] <- h + # Rows with weight above zero. An undefined weight (0/0 from a + # zero-width adaptive kernel) is not above zero, so such a window has no + # rows, rank 0 and nothing estimable. + win <- .gw_window(d, h, kernel) + rows <- win$rows + mk <- length(rows) + nw[i] <- mk + if (!mk) next + wk <- win$w + wt <- wk / max(wk) + sw <- sqrt(wt) + xf <- NULL; mu <- NULL + if (!p) { + Z <- matrix(sw, ncol = 1L) + cfit <- 1 + } else if (icpt) { + xf <- Xs_rp[i, ] + D <- Xs[rows, , drop = FALSE] - rep(xf, each = mk) + mu <- colSums(wt * D) / sum(wt) + Z <- cbind(sw, sw * (D - rep(mu, each = mk)), deparse.level = 0L) + # The regression point's own row in these columns: its predictors are + # the centre of the first subtraction, so they are 0 - mu. + cfit <- c(1, -mu) + } else { + xf <- Xs_rp[i, ] + Z <- sw * Xs[rows, , drop = FALSE] + cfit <- xf + } + q <- qr(Z, LAPACK = TRUE) + qm <- q$qr + piv <- q$pivot + nr <- min(mk, kk) + dg <- abs(qm[cbind(seq_len(nr), seq_len(nr))]) + r <- 0L + while (r < nr && is.finite(dg[r + 1L]) && dg[r + 1L] >= tol) r <- r + 1L + rk[i] <- r + if (!r) next + i1 <- seq_len(r) + R11 <- qm[i1, i1, drop = FALSE] + qty <- qr.qty(q, sw * y[rows])[i1] + # The fitted value first, by the same operations whatever is asked of the + # window, so that predict() at a training point returns fitted()'s value + # to the last bit. `cfit` is the regression point's own row. + cP <- cfit[piv] + t1 <- backsolve(R11, cP[i1], transpose = TRUE) + est1 <- TRUE + if (r < kk) { + i2 <- (r + 1L):kk + R12 <- qm[i1, i2, drop = FALSE] + est1 <- max(abs(cP[i2] - drop(crossprod(R12, t1)))) <= + tol * max(abs(cfit)) + } + fi <- if (self) match(i, rows) else NA_integer_ + # A training point's own row is a row of its window, at the window's + # largest weight, so it is in the row space whatever the test's rounding. + if (!is.na(fi)) est1 <- TRUE + if (est1) yhat[i] <- sum(t1 * qty) + if (!need_q) { + if (self && est1 && !is.na(fi)) { + # The point's own row of the weighted design is sqrt(wt) * cfit, so + # its leverage needs no Q. + lev[i] <- wt[fi] * sum(t1^2) + # Nor do its hat entries on the rows at its own location: the first + # `r` columns of Q are the pivoted design times the inverse of R11. + if (by_loc && shared[i]) { + fg <- match(loc_rows[[loc$id[i]]], rows) + if (!anyNA(fg)) + hat_loc[[i]] <- sw[fg] * drop(Z[fg, piv[i1], drop = FALSE] %*% + backsolve(R11, t1)) + } + } + if (self) { + if (r == kk) nest <- nest + 1L + else { + Tm <- back(xf, mu) + TP <- Tm[, piv, drop = FALSE] + T1 <- backsolve(R11, t(TP[, i1, drop = FALSE]), transpose = TRUE) + rho <- TP[, i2, drop = FALSE] - crossprod(T1, R12) + nest <- nest + (apply(abs(rho), 1L, max) <= + tol * apply(abs(Tm), 1L, max)) + } + } + next + } + # Column j of H: the weights function j's estimate puts on the window's + # observations. Its first column is the regression point's hat row. + A <- sw * qr.qy(q, diag(1, mk, r)) + srow <- drop(A %*% t1) + if (est1) vfit[i] <- sum(srow^2) + if (!full) next + if (self && est1 && !is.na(fi)) { + lev[i] <- srow[fi] + qd[rows] <- qd[rows] + srow^2 + qd[i] <- qd[i] + 1 - 2 * srow[fi] + tssw[rows] <- tssw[rows] + wk * dyb[i] + rssw[rows] <- rssw[rows] + wk * (y[i] - yhat[i])^2 + } + Tm <- back(xf, mu) + TP <- Tm[, piv, drop = FALSE] + T1 <- backsolve(R11, t(TP[, i1, drop = FALSE]), transpose = TRUE) + ok <- rep(TRUE, kk) + if (r < kk) { + rho <- TP[, i2, drop = FALSE] - crossprod(T1, R12) + ok <- apply(abs(rho), 1L, max) <= tol * apply(abs(Tm), 1L, max) + } + if (self) nest <- nest + ok + B[i, ok] <- drop(crossprod(T1, qty))[ok] + V[i, ok] <- colSums((A %*% T1)^2)[ok] + } + + out <- list(fitted = yhat, rank = rk, n_window = nw, n_coef = kk, + width = width) + if (self) { + out$leverage <- lev + out$n_estimable <- as.integer(nest) + } else out$nearest <- near + if (by_loc) out$hat_loc <- hat_loc + if (need_q) out$var_fit <- vfit + if (full) { + out$coef <- B + out$coef_var <- V + out$q_diag <- qd + out$local_r2 <- (tssw - rssw) / tssw + } + out +} + + +#' Fitted values and leverages for a kernel that weights every row +#' +#' A Gaussian or an exponential kernel gives every training row a weight at +#' every regression point, so each window of \code{.gwr_local_solve()} is a +#' QR of the whole design: \code{n} factorisations of \code{n} rows at each +#' bandwidth a search scores, which made a default-bandwidth fit three to +#' five times slower than one through \code{GWmodel::bw.gwr()}. What a +#' score needs, the fitted value and the leverage at each training point, is +#' computed here for many windows at once. +#' +#' With the predictors centred on their means over the data and divided by +#' their standard deviations, the weighted sums a window's regression needs +#' (\eqn{\sum w}, \eqn{\sum w x}, \eqn{\sum w x x^\top}, \eqn{\sum w y}, +#' \eqn{\sum w x y}) are one matrix product of the kernel weights of a block +#' of regression points with the columns they are sums of. From them, for +#' each window, the cross-product of the predictors centred at their weighted +#' mean, \eqn{C = \sum w x x^\top - (\sum w x)(\sum w x)^\top / \sum w}; the +#' slopes solve \eqn{C b = c_y}, the fitted value is +#' \eqn{\bar y_w + a^\top b} with \eqn{a} the point's predictors less their +#' weighted mean, and the leverage is \eqn{1/\sum w + a^\top C^{-1} a} (the +#' point's own weight is the largest, 1). \eqn{C} is the cross-product of +#' the columns \code{.gwr_local_solve()} factors, so these are the same +#' numbers by another route. The systems are solved by a Cholesky +#' factorisation of each window's correlation matrix, written out over the +#' block. +#' +#' \strong{Which windows are answered here.} Forming \eqn{C} squares the +#' design's condition number, so a window is answered only where that costs +#' nothing that shows, and is left to the QR otherwise (\code{done} is +#' \code{FALSE}): +#' \itemize{ +#' \item every weight is defined, and each predictor's centred sum of +#' squares is at least \code{1e-8} and at least \code{1e-4} of its +#' uncentred one, so the subtraction that centres it keeps twelve digits; +#' \item the determinant of the window's correlation matrix is at least +#' \eqn{e \times 10^{-4}}. The other eigenvalues multiply to less than +#' \eqn{e} (they average at most \eqn{p/(p-1)}), so the smallest +#' eigenvalue is at least \code{1e-4} and the Cholesky solve is good to +#' about eleven digits. +#' } +#' Under both conditions the smallest singular value of the window's design +#' is at least \code{1e-6}, ten times the solve's tolerance, so the QR finds +#' the window of full rank as well: no rank decision is taken here. +#' +#' @param X,y,coords,bw,kernel,adaptive As for \code{.gwr_local_solve()}; +#' \code{X} has the intercept first and \code{kernel} is \code{"gaussian"} +#' or \code{"exponential"}. +#' @param loc The layer's locations when each row's hat entries on the rows +#' of its own location are wanted (see \code{.gwr_local_solve()}), else +#' \code{NULL}. +#' @param cells Largest number of cells of a block's weight matrix. +#' @return A list, one value per training row: \code{done}, \code{fitted}, +#' \code{leverage}, \code{width}, \code{n_window} and, with \code{loc}, +#' \code{hat_loc}. The values of a row that is not \code{done} are not to +#' be used. +#' @keywords internal +#' @noRd +.gwr_score_dense <- function(X, y, coords, bw, kernel, adaptive, loc = NULL, + cells = 2^21) { + n <- nrow(X); p <- ncol(X) - 1L + jp <- seq_len(p) + 1L + yhat <- rep(NA_real_, n); lev <- rep(NA_real_, n) + width <- rep(NA_real_, n); nw <- integer(n); done <- logical(n) + by_loc <- !is.null(loc) && loc$n < n + if (by_loc) { + loc_rows <- split(seq_len(n), loc$id) + shared <- loc$size[loc$id] > 1L + hat_loc <- vector("list", n) + } + if (p) { + s <- apply(X[, jp, drop = FALSE], 2L, stats::sd) + s[!is.finite(s) | s <= 0] <- 1 + Xc <- sweep(sweep(X[, jp, drop = FALSE], 2L, + colMeans(X[, jp, drop = FALSE])), 2L, s, "/") + # The pairs (a, b), a <= b, of predictors, and where each sits. + ia <- rep(seq_len(p), times = rev(seq_len(p))) + ib <- unlist(lapply(seq_len(p), function(a) a:p)) + q <- length(ia) + at <- matrix(0L, p, p) + at[cbind(ia, ib)] <- seq_len(q); at[cbind(ib, ia)] <- seq_len(q) + dg <- at[cbind(seq_len(p), seq_len(p))] + M <- cbind(1, y, Xc, Xc * y, Xc[, ia, drop = FALSE] * Xc[, ib, drop = FALSE], + deparse.level = 0L) + } else { + M <- cbind(1, y, deparse.level = 0L) + } + cx <- coords[, 1L]; cy <- coords[, 2L] + B <- max(1L, min(n, as.integer(cells %/% n))) + gauss <- kernel == "gaussian" + for (start in seq.int(1L, n, by = B)) { + I <- start:min(n, start + B - 1L) + nb <- length(I) + # The distances and weights of .gw_window(), a block of regression + # points at a time. + D <- sqrt(outer(cx[I], cx, "-")^2 + outer(cy[I], cy, "-")^2) + h <- if (isTRUE(adaptive)) + vapply(seq_len(nb), function(r) .gw_kernel_width(D[r, ], bw, TRUE), + numeric(1)) + else rep(as.numeric(bw), nb) + W <- if (gauss) exp(D^2 / (-2 * h^2)) else exp(-D / h) + width[I] <- h + nw[I] <- as.integer(rowSums(W > 0, na.rm = TRUE)) + Mo <- W %*% M + S0 <- Mo[, 1L] + ybar <- Mo[, 2L] / S0 + ok <- is.finite(S0) & is.finite(h) & h > 0 + if (!p) { + ok <- ok & is.finite(ybar) + ok[is.na(ok)] <- FALSE + yhat[I[ok]] <- ybar[ok]; lev[I[ok]] <- 1 / S0[ok]; done[I] <- ok + if (by_loc) for (r in which(ok & shared[I])) { + i <- I[r] + hat_loc[[i]] <- rep(1 / S0[r], length(loc_rows[[loc$id[i]]])) + } + next + } + S1 <- Mo[, 2L + seq_len(p), drop = FALSE] + Sxy <- Mo[, 2L + p + seq_len(p), drop = FALSE] + S2 <- Mo[, 2L + 2L * p + seq_len(q), drop = FALSE] + xbar <- S1 / S0 + Cm <- S2 - S1[, ia, drop = FALSE] * xbar[, ib, drop = FALSE] + cyv <- Sxy - S1 * ybar + a <- Xc[I, , drop = FALSE] - xbar + cjj <- Cm[, dg, drop = FALSE] + thin <- rowSums(!(cjj >= pmax(1e-8, 1e-4 * S2[, dg, drop = FALSE]))) + ok <- ok & !is.na(thin) & thin == 0L + sdw <- suppressWarnings(sqrt(cjj)) + # Cholesky of each window's correlation matrix, the windows of the block + # side by side: L[, i, j] holds entry (i, j) of every window's factor. + L <- array(0, c(nb, p, p)) + dets <- rep(1, nb) + for (j in seq_len(p)) { + v <- rep(1, nb) + if (j > 1L) v <- v - rowSums(matrix(L[, j, seq_len(j - 1L)], nb)^2) + dets <- dets * v + ljj <- suppressWarnings(sqrt(v)) + L[, j, j] <- ljj + if (j < p) for (i in (j + 1L):p) { + e <- Cm[, at[i, j]] / (sdw[, i] * sdw[, j]) + if (j > 1L) + e <- e - rowSums(matrix(L[, i, seq_len(j - 1L)], nb) * + matrix(L[, j, seq_len(j - 1L)], nb)) + L[, i, j] <- e / ljj + } + } + ok <- ok & is.finite(dets) & dets >= exp(1) * 1e-4 + # Solve the windows' systems for one right-hand side each. + solve_block <- function(R) { + Z <- R + for (j in seq_len(p)) { + e <- R[, j] + if (j > 1L) + e <- e - rowSums(matrix(L[, j, seq_len(j - 1L)], nb) * + Z[, seq_len(j - 1L), drop = FALSE]) + Z[, j] <- e / L[, j, j] + } + sol <- Z + for (j in rev(seq_len(p))) { + e <- Z[, j] + if (j < p) + e <- e - rowSums(matrix(L[, (j + 1L):p, j], nb) * + sol[, (j + 1L):p, drop = FALSE]) + sol[, j] <- e / L[, j, j] + } + sol / sdw + } + slope <- solve_block(cyv / sdw) + u <- solve_block(a / sdw) + yh <- ybar + rowSums(a * slope) + lv <- 1 / S0 + rowSums(a * u) + ok <- ok & is.finite(yh) & is.finite(lv) + ok[is.na(ok)] <- FALSE + yhat[I[ok]] <- yh[ok]; lev[I[ok]] <- lv[ok]; done[I] <- ok + # The hat entries of a row on the rows at its own location, which share + # its window and its weight of 1. + if (by_loc) for (r in which(ok & shared[I])) { + i <- I[r] + g <- loc_rows[[loc$id[i]]] + hat_loc[[i]] <- 1 / S0[r] + + drop((Xc[g, , drop = FALSE] - rep(xbar[r, ], each = length(g))) %*% u[r, ]) + } + } + out <- list(done = done, fitted = yhat, leverage = lev, width = width, + n_window = nw) + if (by_loc) out$hat_loc <- hat_loc + out +} + + +#' The design matrix and response of a GWR, and the design at new rows +#' +#' Built as GWmodel builds them (\code{model.frame()} and +#' \code{model.matrix()} on the formula), with the intercept's column named +#' \code{Intercept}. The design at new rows comes from the fitted terms, so +#' its columns are the coefficients' columns in the same order (a predictor +#' named twice gives one column, not two); \code{na.pass} keeps its rows +#' aligned with the new locations. +#' +#' @param formula The model formula. +#' @param data data.frame of the training rows. +#' @param newdata Optional data.frame of new rows, with the predictors. +#' @return A list: \code{X}, \code{y} and, with \code{newdata}, \code{X_new}. +#' @keywords internal +#' @noRd +.gwr_design <- function(formula, data, newdata = NULL) { + mf <- stats::model.frame(formula, data = data, drop.unused.levels = TRUE) + tt <- stats::terms(mf) + X <- stats::model.matrix(tt, mf) + y <- as.numeric(stats::model.response(mf)) + name_int <- function(m) { + i <- match("(Intercept)", colnames(m)) + if (!is.na(i)) colnames(m)[i] <- "Intercept" + m + } + out <- list(X = name_int(X), y = y) + if (!is.null(newdata)) { + tt_new <- stats::delete.response(tt) + out$X_new <- name_int(stats::model.matrix(tt_new, stats::model.frame( + tt_new, newdata, na.action = stats::na.pass, + xlev = stats::.getXlevels(tt, mf)))) + } + out +} + + +#' Assemble the fit's engine object in the layout GWmodel uses +#' +#' \code{fit$engine} was the object \code{GWmodel::gwr.basic()} returned, and +#' code that reads it (the package's own \code{coef()} and \code{fitted()}, +#' and users' scripts) reads \code{$SDF} and \code{$GW.diagnostic}. The +#' local solve's results are therefore laid out the same way: \code{SDF} is a +#' \code{SpatialPointsDataFrame} with the coefficient columns first, then +#' \code{y}, \code{yhat}, \code{residual}, \code{CV_Score}, +#' \code{Stud_residual}, the standard errors (\code{_SE}), the t values +#' (\code{_TV}) and \code{Local_R2}; \code{GW.diagnostic} and +#' \code{GW.arguments} carry GWmodel's fields under GWmodel's names, and +#' \code{lm} is the global least-squares fit. \code{CV_Score} is 0, as +#' \code{gwr.basic()} leaves it unless asked for it. A coefficient a window +#' cannot estimate is \code{NA}, with its standard error and t value. +#' +#' @param sv What \code{.gwr_local_solve(what = "fit")} returned. +#' @param dg What \code{.gwr_diagnostics()} returned for it. +#' @param formula,sp_dat,X,y The model formula, the training layer as a +#' Spatial object, the design matrix and the response. +#' @param bw,kernel,adaptive The bandwidth settings. +#' @return A list: \code{GW.arguments}, \code{GW.diagnostic}, \code{lm}, +#' \code{SDF}, \code{fitted} (the fitted values, \code{NA} where not +#' estimable) and \code{solver} (the method and its tolerance). +#' @keywords internal +#' @noRd +.gwr_engine <- function(sv, dg, formula, sp_dat, X, y, bw, kernel, adaptive) { + n <- length(y) + betas <- sv$coef + yhat <- sv$fitted + residual <- y - yhat + stud <- residual / sqrt(dg$sigma2 * sv$q_diag) + se <- sqrt(dg$sigma2 * sv$coef_var) + tv <- betas / se + gwres <- data.frame(betas, y, yhat, residual, numeric(n), stud, se, tv, + sv$local_r2) + nm <- colnames(betas) + colnames(gwres) <- c(nm, "y", "yhat", "residual", "CV_Score", + "Stud_residual", paste(nm, "SE", sep = "_"), + paste(nm, "TV", sep = "_"), "Local_R2") + # The training rows' own names, as GWmodel's table carries them. + rownames(gwres) <- rownames(sp_dat@data) + crd <- sp::coordinates(sp_dat) + rownames(crd) <- rownames(gwres) + sdf <- sp::SpatialPointsDataFrame(coords = crd, data = gwres, + proj4string = sp_dat@proj4string, + match.ID = FALSE) + lms <- stats::lm(formula, data = sp_dat@data) + lms$x <- X + lms$y <- y + list( + GW.arguments = list(formula = formula, rp.given = FALSE, hatmatrix = TRUE, + bw = bw, kernel = kernel, adaptive = adaptive, p = 2, + theta = 0, longlat = FALSE, DM.given = FALSE, + F123.test = FALSE), + GW.diagnostic = list(RSS.gw = dg$RSS, AIC = dg$AIC, AICc = dg$AICc, + enp = dg$enp, edf = dg$edf, gw.R2 = dg$R2, + gwR2.adj = dg$R2_adj, BIC = dg$BIC), + lm = lms, + SDF = sdf, + fitted = yhat, + solver = list(method = "pivoted Householder QR per window (LAPACK dgeqp3)", + tolerance = .gwr_rank_tol()) + ) +} + + +#' GWmodel's global diagnostics, from the local solve +#' +#' The formulas of GWmodel's \code{gwr_diag1()}, on the trace of the hat +#' matrix and of \eqn{S^\top S} that \code{.gwr_local_solve()} returns: +#' \deqn{AIC = n \log(RSS/n) + n \log(2\pi) + n + tr S,} +#' \deqn{AICc = n \log(RSS/n) + n \log(2\pi) + n (n + tr S) / (n - 2 - tr S),} +#' \deqn{BIC = n \log(RSS/n) + n \log(2\pi) + \log(n)\, tr S,} +#' effective number of parameters \eqn{2\,tr S - tr S^\top S}, effective +#' degrees of freedom \eqn{n - 2\,tr S + tr S^\top S}, and the residual +#' variance \eqn{RSS / edf}. AICc is returned as the formula gives it, also +#' outside its domain (\eqn{tr S \ge n - 2}); \code{.gwr_aicc_undefined()} is +#' the guard. Every value is \code{NA} when a fitted value is: the fit then +#' covers part of the data only and has no residual sum of squares. +#' +#' @param y Response. +#' @param fitted,leverage Fitted values and leverages, one per observation. +#' @param var_fit Sum of squares of each hat row, or \code{NULL} when only +#' AIC, AICc, BIC and the trace are wanted. +#' @return A named list: \code{RSS}, \code{tr_S}, \code{tr_StS}, \code{AIC}, +#' \code{AICc}, \code{BIC}, \code{enp}, \code{edf}, \code{sigma2}, +#' \code{R2}, \code{R2_adj}. +#' @keywords internal +#' @noRd +.gwr_diagnostics <- function(y, fitted, leverage, var_fit = NULL) { + n <- length(y) + na <- list(RSS = NA_real_, tr_S = NA_real_, tr_StS = NA_real_, + AIC = NA_real_, AICc = NA_real_, BIC = NA_real_, enp = NA_real_, + edf = NA_real_, sigma2 = NA_real_, R2 = NA_real_, + R2_adj = NA_real_) + if (!n || anyNA(fitted) || anyNA(leverage)) return(na) + rss <- sum((y - fitted)^2) + tr_s <- sum(leverage) + base <- n * log(rss / n) + n * log(2 * pi) + out <- na + out$RSS <- rss + out$tr_S <- tr_s + out$AIC <- base + n + tr_s + out$AICc <- base + n * ((n + tr_s) / (n - 2 - tr_s)) + out$BIC <- base + log(n) * tr_s + if (!is.null(var_fit) && !anyNA(var_fit)) { + tr_sts <- sum(var_fit) + edf <- n - 2 * tr_s + tr_sts + out$tr_StS <- tr_sts + out$enp <- 2 * tr_s - tr_sts + out$edf <- edf + out$sigma2 <- if (isTRUE(edf > 0)) rss / edf else NA_real_ + yss <- sum((y - mean(y))^2) + out$R2 <- 1 - rss / yss + out$R2_adj <- 1 - (1 - out$R2) * (n - 1) / (edf - 1) + } + out +} + + +#' The distinct locations of a layer +#' +#' Two rows are at one location when both coordinates are equal, which is +#' when the kernel gives them one weight at every regression point. Compared +#' as numbers, not as printed text. +#' +#' @param coords Two-column coordinate matrix. +#' @return A list: \code{id} (the location of each row, numbered from 1 in +#' order of first appearance), \code{n} (the number of locations) and +#' \code{size} (the rows at each). +#' @keywords internal +#' @noRd +.gwr_locations <- function(coords) { + n <- nrow(coords) + if (n < 2L) return(list(id = seq_len(n), n = n, size = rep(1L, n))) + cx <- coords[, 1L]; cy <- coords[, 2L] + o <- order(cx, cy) + sx <- cx[o]; sy <- cy[o] + first <- c(TRUE, sx[-1L] != sx[-n] | sy[-1L] != sy[-n]) + first[is.na(first)] <- TRUE + id <- integer(n) + id[o] <- cumsum(first) + id <- match(id, unique(id)) + list(id = id, n = max(id), size = tabulate(id)) +} + + +#' The number of rows that differ in location or in a predictor +#' +#' Rows at one location with one set of predictor values receive one fitted +#' value at every bandwidth, so a GWR of \code{n} such rows is a GWR of the +#' means of the groups they form. Its hat-matrix trace cannot exceed the +#' number of groups, and at that number the fit reproduces every group's mean. +#' +#' @param X Design matrix. +#' @param id Location of each row (\code{.gwr_locations()$id}). +#' @return One integer, \code{nrow(X)} when no two rows agree in both. +#' @keywords internal +#' @noRd +.gwr_n_distinct <- function(X, id) { + n <- nrow(X) + if (n < 2L) return(n) + o <- do.call(order, c(list(id), lapply(seq_len(ncol(X)), function(j) X[, j]))) + Xo <- X[o, , drop = FALSE] + io <- id[o] + same <- io[-1L] == io[-n] & + rowSums(Xo[-1L, , drop = FALSE] != Xo[-n, , drop = FALSE]) == 0L + as.integer(n - sum(same, na.rm = TRUE)) +} + + +#' Leave-one-location-out residuals, from the hat matrix +#' +#' The residual of each observation when its location is predicted by the +#' local regression there without any observation of that location, the +#' kernel keeping the width it has in the fit. The rows at one location +#' share one window and one weight, so the local regression there is one +#' weighted least squares and the usual deletion identity holds for the +#' group: with \eqn{H_{gg}} the block of the hat matrix on the location's +#' rows and \eqn{e_g} their residuals, the residuals without the location +#' are \eqn{(I - H_{gg})^{-1} e_g}. For a location with one row that is +#' \eqn{e_i / (1 - h_{ii})}, the leave-one-out residual. +#' +#' \eqn{I - H_{gg}} is singular exactly when the other locations in the +#' window cannot place one of the location's rows: nothing predicts it but +#' its own observations. The residuals of such a location are \code{NA}. +#' Singular is judged at the solve's tolerance, as a leverage of 1 is. +#' +#' @param resid Residuals of the fit, one per row. +#' @param leverage Leverages, one per row. +#' @param hat_loc What \code{.gwr_local_solve(loc = )} returned as +#' \code{hat_loc}. +#' @param loc The layer's locations (\code{.gwr_locations()}). +#' @param tol The solve's tolerance. +#' @return Numeric vector, one per row, \code{NA} where no prediction without +#' the location exists. +#' @keywords internal +#' @noRd +.gwr_lolo_residuals <- function(resid, leverage, hat_loc, loc, + tol = .gwr_rank_tol()) { + n <- length(resid) + out <- rep(NA_real_, n) + one <- loc$size[loc$id] == 1L + ok <- one & is.finite(resid) & is.finite(leverage) & leverage < 1 - tol + out[ok] <- resid[ok] / (1 - leverage[ok]) + if (all(one)) return(out) + rows <- split(seq_len(n), loc$id) + for (g in which(loc$size > 1L)) { + r <- rows[[g]] + hb <- hat_loc[r] + if (anyNA(resid[r]) || any(vapply(hb, is.null, logical(1)))) next + M <- diag(1, length(r)) - do.call(rbind, hb) + sv <- svd(M, nu = 0L, nv = 0L)$d + if (!all(is.finite(sv)) || min(sv) < tol) next + out[r] <- solve(M, resid[r]) + } + out +} + + +#' The bandwidth criterion at one bandwidth +#' +#' One pass of \code{.gwr_local_solve(what = "score")} and the criterion from +#' its fitted values and leverages. \code{"AICc"} is GWmodel's corrected AIC +#' (see \code{.gwr_diagnostics()}). \code{"CV"} is the leave-one-location-out +#' sum of squares (\code{.gwr_lolo_residuals()}). On a layer without repeat +#' locations that is the leave-one-out sum +#' \eqn{\sum (e_i / (1 - h_{ii}))^2}, which equals refitting each window +#' without its own observation, as \code{GWmodel::bw.gwr()} does. Where +#' locations repeat, leaving one row out leaves its twins in, and the score +#' then rewards a window that holds little but the location itself. +#' +#' A bandwidth is scored \code{Inf}, so that no search settles on it, and +#' \code{why} names the first of these that applies (a fitted value, then +#' the residual sum of squares, then the criterion's own domain, then the +#' terms): +#' \describe{ +#' \item{\code{"fitted"}}{a fitted value is not estimable;} +#' \item{\code{"rss"}}{the residual sum of squares is 0;} +#' \item{\code{"term"}}{a term is estimable at no location, so the model +#' has no coefficient for it anywhere;} +#' \item{\code{"df"}}{AICc is outside its domain (\eqn{tr S \ge n - 2});} +#' \item{\code{"df_distinct"}}{\eqn{tr S} is not below the number of rows +#' that differ in location or in a predictor, minus 2 +#' (\code{.gwr_n_distinct()}): the fit all but reproduces the mean of +#' each group of rows that share both, and the AICc of that fit to the +#' means is outside its domain;} +#' \item{\code{"leave_out"}}{for \code{"CV"}, a location rests on its own +#' observations (for a single row, leverage 1 to the solve's tolerance), +#' so its prediction without them does not exist.} +#' } +#' +#' @param X,y,coords,bw,kernel,adaptive As for \code{.gwr_local_solve()}. +#' @param approach \code{"AICc"} or \code{"CV"}. +#' @param loc The layer's locations (\code{.gwr_locations()}); worked out +#' when \code{NULL}. +#' @param n_distinct \code{.gwr_n_distinct()} of the design; worked out when +#' \code{NULL}. +#' @return A list: \code{value} (the criterion, possibly \code{Inf}), +#' \code{why} (\code{""} when the criterion is defined), \code{RSS}, +#' \code{tr_S}, \code{AIC}, \code{AICc} (as the formulas give them, +#' \code{NA} where a fitted value is not estimable), \code{n_deficient} +#' (windows of deficient rank) and \code{n_distinct}. +#' @keywords internal +#' @noRd +.gwr_criterion <- function(X, y, coords, bw, kernel, adaptive, + approach = "AICc", loc = NULL, n_distinct = NULL) { + n <- length(y) + cv <- identical(approach, "CV") + if (is.null(loc)) loc <- .gwr_locations(coords) + repeats <- loc$n < n + if (is.null(n_distinct)) + n_distinct <- if (repeats) .gwr_n_distinct(X, loc$id) else n + sv <- .gwr_local_solve(X, y, coords, bw, kernel, adaptive, what = "score", + loc = if (cv && repeats) loc else NULL) + dg <- .gwr_diagnostics(y, sv$fitted, sv$leverage) + value <- Inf + why <- "" + # The first reason that applies is the one reported; a term that no window + # estimates comes last, since a fit that interpolates has none either. + no_term <- any(sv$n_estimable == 0L) + if (!is.finite(dg$RSS)) { + why <- "fitted" + } else if (!(dg$RSS > 0)) { + why <- "rss" + } else if (cv) { + loo <- if (repeats) + .gwr_lolo_residuals(y - sv$fitted, sv$leverage, sv$hat_loc, loc) + else if (all(sv$leverage < 1 - .gwr_rank_tol())) + (y - sv$fitted) / (1 - sv$leverage) + else NA_real_ + if (anyNA(loo)) why <- "leave_out" + else if (no_term) why <- "term" + else value <- sum(loo^2) + } else if (!(dg$tr_S < n - 2) || !is.finite(dg$AICc)) { + why <- "df" + } else if (!(dg$tr_S < n_distinct - 2)) { + why <- "df_distinct" + } else if (no_term) { + why <- "term" + } else { + value <- dg$AICc + } + list(value = value, why = why, RSS = dg$RSS, tr_S = dg$tr_S, AIC = dg$AIC, + AICc = dg$AICc, n_deficient = sum(sv$rank < sv$n_coef), + n_distinct = n_distinct) +} + + +#' The range a bandwidth search covers +#' +#' Adaptive: from the smallest count that leaves every window a residual +#' degree of freedom (\code{.gwr_min_adaptive_bw()}) to every observation. +#' On a layer whose locations repeat the count has to buy locations, not +#' rows: the lower end is then the smallest count at which every window +#' holds one location more than the model has parameters (the rows of the +#' nearest such locations, and one more row for the bisquare and tricube +#' kernels, which give the farthest row weight 0). +#' +#' Fixed: up to the largest distance between two observations. The lower end +#' is the distance at which half of the windows hold one location more than +#' the model has parameters (the median, over the observations, of the +#' distance to the location that completes such a window); a third of that +#' for the Gaussian and exponential kernels, which weight points beyond their +#' bandwidth. It is the median and not the largest of those distances +#' because one isolated observation would otherwise set the floor for the +#' whole layer: its own window may be short of points at a bandwidth that +#' suits the rest, the local solve returns what that window can estimate, and +#' the criterion counts it. Below the lower end most windows interpolate and +#' the criterion is undefined. +#' +#' \code{GWmodel::bw.gwr()} searches adaptive counts from 20 up, whatever the +#' model, and fixed distances from a 5000th of the largest, where most +#' windows hold their own point alone. +#' +#' @param coords Two-column coordinate matrix. +#' @param n_params Parameters of the local model, the intercept included. +#' @param kernel,adaptive Kernel name; whether the bandwidth counts +#' neighbours. +#' @param loc The layer's locations (\code{.gwr_locations()}). +#' @return \code{c(lower, upper)}; equal when there is one candidate, and +#' \code{NA} when every observation is at one location. +#' @keywords internal +#' @noRd +.gwr_bw_range <- function(coords, n_params, kernel, adaptive, + loc = .gwr_locations(coords)) { + n <- nrow(coords) + nl <- loc$n + repeats <- nl < n + if (isTRUE(adaptive) && !repeats) { + lo <- min(.gwr_min_adaptive_bw(n_params, kernel), n) + return(as.numeric(c(lo, n))) + } + # One row per location, in the order the locations are numbered (which is + # the rows' own order when none repeats). + at <- !duplicated(loc$id) + ux <- coords[at, 1L]; uy <- coords[at, 2L] + if (isTRUE(adaptive)) { + need <- min(as.integer(n_params) + 1L, nl) + edge <- kernel %in% c("bisquare", "tricube") + lo <- 0 + for (g in seq_len(nl)) { + d <- sqrt((ux - ux[g])^2 + (uy - uy[g])^2) + dn <- sort.int(d, partial = need)[need] + # A kernel with an edge weights the rows strictly inside the distance + # of the count-th nearest row; the others weight that row too. + lo <- max(lo, if (edge) sum(loc$size[d <= dn]) + 1L + else sum(loc$size[d < dn]) + 1L) + } + return(as.numeric(c(min(lo, n), n))) + } + # The (n_params + 2)-th smallest distance from a location, itself included + # at 0: with a kernel that gives its edge weight 0 the window then holds + # n_params + 1 weighted locations. + kth <- min(as.integer(n_params) + 2L, nl) + dk <- numeric(nl); hi <- 0 + for (g in seq_len(nl)) { + d <- sqrt((ux - ux[g])^2 + (uy - uy[g])^2) + dk[g] <- sort.int(d, partial = kth)[kth] + hi <- max(hi, max(d)) + } + if (!is.finite(hi) || hi <= 0) return(c(NA_real_, NA_real_)) + lo <- stats::median(dk[loc$id]) + if (kernel %in% c("gaussian", "exponential")) lo <- lo / 3 + # Every observation at one of very few locations: no distance to go by. + if (!is.finite(lo) || lo <= 0) lo <- hi / 5000 + c(min(lo, hi), hi) +} + + +#' Search for the bandwidth that minimises AICc or the leave-one-out score +#' +#' \code{GWmodel::bw.gwr()} runs a golden-section search over the whole +#' range, which is right when the criterion has one minimum. It has several +#' whenever the coefficients vary at a range only a few dozen points resolve: +#' the search then throws away the lower part of the range at its first +#' step and returns a near-global bandwidth labelled as selected. This +#' search scores a coarse grid first and refines inside the bracket round the +#' grid's minimum: +#' \enumerate{ +#' \item \code{n_grid} bandwidths spaced evenly in the logarithm between the +#' two ends of \code{.gwr_bw_range()} (whole numbers when adaptive); +#' \item a golden-section search between the grid points either side of the +#' best one, to a bracket of two neighbours (adaptive) or a thousandth of +#' the bandwidth (fixed), at most \code{max_refine} steps; for an +#' adaptive bandwidth the counts within two of the best are then scored +#' too, while that finds a better one (three times at most), because the +#' criterion is jagged from one count to the next; +#' \item the best of every bandwidth scored, grid included, is returned. +#' } +#' Each bandwidth is scored once (\code{.gwr_criterion()}, through the local +#' QR solve), so a candidate with windows of deficient rank is scored on its +#' estimable fitted values and not as \code{Inf} or as rounding error. +#' +#' \strong{Layers whose locations repeat.} When two or more rows share a +#' location, \code{"AICc"} is not used and the search minimises the +#' leave-one-location-out score instead (\code{approach} comes back as +#' \code{"CV"}, \code{requested} as \code{"AICc"}, \code{by_location} as +#' \code{TRUE}). AICc counts the rows at one location as independent +#' observations. When a location has an effect of its own, a window that +#' holds little but the location reproduces its mean, the residual sum of +#' squares falls to the spread within locations, and AICc is lowest at the +#' bandwidths where the windows interpolate: on 100 sites with 3 rows each +#' it was 58 at 5 to 10 neighbours, 90 at 13 and 221 at 58, while the error +#' of prediction at new sites was 46 at 10 neighbours, 1.35 at 13 and 0.15 +#' at 150. A floor on the bandwidth does not help, since the criterion goes +#' on falling towards it. Predicting each location from the others asks the +#' question a bandwidth is chosen for. \code{"CV"} leaves out whole locations for the same reason: with a +#' twin left in, the leave-one-out prediction of a row is its twin. +#' +#' What the grid shows is kept: the number of local minima on it, the range +#' of bandwidths whose criterion is within 2 of the minimum (1 percent of it +#' for \code{"CV"}), whether the widest bandwidth of the range is one of +#' them, and whether the minimum sits at either end of the range. +#' +#' @param X,y,coords,kernel,adaptive As for \code{.gwr_local_solve()}. +#' @param approach \code{"AICc"} or \code{"CV"}. +#' @param n_grid Number of grid bandwidths. +#' @param max_refine Largest number of golden-section steps. +#' @return A list: \code{bandwidth} (\code{NA} when the range is empty), +#' \code{criterion}, \code{approach} (the criterion minimised), +#' \code{requested} (the one asked for), \code{by_location} (\code{TRUE} +#' when locations repeat, so that the score leaves out whole locations), +#' \code{n_locations}, \code{range}, \code{curve} (a +#' data.frame of every bandwidth scored: \code{bandwidth}, \code{criterion}, +#' \code{tr_S}, \code{n_deficient} and \code{stage}, \code{"grid"} or +#' \code{"refine"}), \code{n_evaluations}, \code{n_local_minima}, +#' \code{multimodal}, \code{within} (the smallest and largest scored +#' bandwidth within the margin of the minimum), \code{flat} (at least half +#' of the grid is within the margin), \code{near_global} (the widest +#' bandwidth of the range is within the margin, so the criterion does not +#' tell the selected fit from a global one), \code{at_upper}, +#' \code{at_lower}, \code{none_defined} (no bandwidth has a finite +#' criterion; the widest is then returned) and \code{undefined} (how many +#' of the bandwidths scored have no criterion, by the reason +#' \code{.gwr_criterion()} gives). +#' @keywords internal +#' @noRd +.gwr_bw_search <- function(X, y, coords, kernel, adaptive, approach = "AICc", + n_grid = 16L, max_refine = 12L) { + adaptive <- isTRUE(adaptive) + loc <- .gwr_locations(coords) + by_location <- loc$n < nrow(coords) + requested <- approach + # AICc counts the rows at one location as independent; see above. + if (by_location && identical(approach, "AICc")) approach <- "CV" + n_distinct <- if (by_location) .gwr_n_distinct(X, loc$id) else nrow(X) + rng <- .gwr_bw_range(coords, ncol(X), kernel, adaptive, loc) + out <- list(bandwidth = NA_real_, criterion = NA_real_, approach = approach, + requested = requested, by_location = by_location, + n_locations = loc$n, + range = rng, curve = NULL, n_evaluations = 0L, + n_local_minima = NA_integer_, multimodal = NA, within = rng, + flat = NA, near_global = NA, at_upper = NA, at_lower = NA, + none_defined = NA, undefined = integer(0)) + if (anyNA(rng)) return(out) + lo <- rng[1L]; hi <- rng[2L] + + bws <- numeric(0); val <- numeric(0); trs <- numeric(0) + ndef <- integer(0); stage <- character(0); why <- character(0) + score <- function(b, st) { + hit <- match(b, bws) + if (!is.na(hit)) return(val[hit]) + cr <- tryCatch(.gwr_criterion(X, y, coords, b, kernel, adaptive, approach, + loc = loc, n_distinct = n_distinct), + error = function(e) NULL) + v <- if (is.null(cr) || !is.finite(cr$value)) Inf else cr$value + bws <<- c(bws, b); val <<- c(val, v) + trs <<- c(trs, if (is.null(cr)) NA_real_ else cr$tr_S) + ndef <<- c(ndef, if (is.null(cr)) NA_integer_ else cr$n_deficient) + stage <<- c(stage, st) + why <<- c(why, if (is.null(cr)) "error" else cr$why) + v + } + + grid <- if (hi > lo) exp(seq(log(lo), log(hi), length.out = max(2L, n_grid))) + else lo + if (adaptive) grid <- unique(pmin(pmax(round(grid), lo), hi)) + grid[1L] <- lo; grid[length(grid)] <- hi + gval <- vapply(grid, score, numeric(1), st = "grid") + + if (!any(is.finite(gval))) { + # Nothing to choose between: the widest window is the only one that can + # have residual degrees of freedom, and the caller says so. + out$bandwidth <- hi + out$none_defined <- TRUE + } else { + out$none_defined <- FALSE + j <- which.min(gval) + a <- grid[max(j - 1L, 1L)]; b <- grid[min(j + 1L, length(grid))] + gr <- (sqrt(5) - 1) / 2 + snap <- function(z) if (adaptive) round(z) else z + wide <- function() if (adaptive) (b - a) > 2 else + (b - a) > 1e-3 * max(a, .Machine$double.eps) + if (wide()) { + x1 <- snap(b - gr * (b - a)); x2 <- snap(a + gr * (b - a)) + f1 <- score(x1, "refine"); f2 <- score(x2, "refine") + steps <- 0L + while (wide() && x1 < x2 && steps < max_refine) { + # Ties, two Inf among them, close in on the wider bandwidth. + if (f1 < f2) { + b <- x2; x2 <- x1; f2 <- f1 + x1 <- snap(b - gr * (b - a)); f1 <- score(x1, "refine") + } else { + a <- x1; x1 <- x2; f1 <- f2 + x2 <- snap(a + gr * (b - a)); f2 <- score(x2, "refine") + } + steps <- steps + 1L + } + } + if (adaptive) { + # Whole numbers: the few left inside the bracket are each scored. + if ((b - a) >= 1 && (b - a) <= 4) + for (z in seq(a, b)) score(z, "refine") + # Over whole numbers the criterion is jagged from one count to the + # next, so the counts within two of the best are scored as well, again + # while that finds a better one, three times at most. + for (pass in 1:3) { + at <- bws[which.min(val)] + cand <- setdiff(seq(max(lo, at - 2), min(hi, at + 2)), bws) + if (!length(cand)) break + was <- min(val) + for (z in cand) score(z, "refine") + if (!(min(val) < was)) break + } + } + best <- which.min(val) + out$bandwidth <- bws[best] + out$criterion <- val[best] + } + + ord <- order(bws) + out$curve <- data.frame(bandwidth = bws[ord], criterion = val[ord], + tr_S = trs[ord], n_deficient = ndef[ord], + stage = stage[ord], stringsAsFactors = FALSE) + out$n_evaluations <- length(bws) + # Why the bandwidths without a criterion have none, for the caller's + # message when that is all of them. + bad <- why[nzchar(why)] + out$undefined <- vapply(split(bad, bad), length, integer(1)) + fin <- is.finite(gval) + # Local minima on the grid: below both neighbours (an end point has one). + ng <- length(grid) + left <- c(Inf, gval[-ng]); right <- c(gval[-1L], Inf) + out$n_local_minima <- sum(fin & gval < left & gval < right) + out$multimodal <- out$n_local_minima > 1L + if (isFALSE(out$none_defined)) { + margin <- if (identical(approach, "CV")) 0.01 * abs(out$criterion) else 2 + near <- is.finite(val) & val <= out$criterion + margin + out$within <- range(bws[near]) + out$flat <- sum(fin & gval <= out$criterion + margin) >= ng / 2 && ng >= 4L + out$near_global <- isTRUE(gval[ng] <= out$criterion + margin) + out$at_upper <- isTRUE(out$bandwidth >= hi) + out$at_lower <- isTRUE(out$bandwidth <= lo) && hi > lo + } + out +} + + +#' The name of the criterion a bandwidth search minimised +#' +#' @param bs What \code{.gwr_bw_search()} returned. +#' @param score \code{TRUE} for the noun a bandwidth "has" (a score), +#' \code{FALSE} for the method it was selected by. +#' @return \code{"AICc"}, or the name of the cross-validation. +#' @keywords internal +#' @noRd +.gwr_bw_criterion_name <- function(bs, score = FALSE) { + if (!identical(bs$approach, "CV")) return("AICc") + paste0(if (isTRUE(bs$by_location)) "leave-one-location-out" + else "leave-one-out", + if (score) " score" else " cross-validation") +} + + +#' Why the bandwidths a search scored have no criterion +#' +#' For the warning raised when that is every one of them. +#' +#' @param bs What \code{.gwr_bw_search()} returned. +#' @param n Number of observations. +#' @return The reasons, joined by "or", as the clause that follows "at each +#' of the bandwidths tried". +#' @keywords internal +#' @noRd +.gwr_bw_undefined_text <- function(bs, n) { + text <- c( + df = sprintf(paste0("the local regressions leave too few ", + "residual degrees of freedom (tr(S) is not ", + "below n - 2 = %d)"), n - 2L), + df_distinct = paste0("the local regressions all but reproduce the mean ", + "of each group of observations that share a ", + "location and predictor values"), + fitted = "a fitted value cannot be estimated", + term = "a term can be estimated at no location", + leave_out = if (isTRUE(bs$by_location)) + "a location cannot be predicted from the others" + else "an observation cannot be predicted from the others", + rss = "the residual sum of squares is 0", + error = "the local regressions could not be solved") + hit <- intersect(names(text), names(bs$undefined)) + if (!length(hit)) hit <- c("df", "fitted") + paste(text[hit], collapse = ", or ") +} + + +#' One sentence on what a bandwidth search's grid showed +#' +#' For the line \code{fit_gwr_model()} and \code{gwr_model_selection()} +#' log once per search. Empty when there is nothing to remark on. +#' +#' @param bs What \code{.gwr_bw_search()} returned. +#' @param adaptive Whether the bandwidth counts neighbours. +#' @return A character string, possibly \code{""}. +#' @keywords internal +#' @noRd +.gwr_bw_search_note <- function(bs, adaptive) { + if (is.null(bs) || !isFALSE(bs$none_defined)) return("") + unit <- if (isTRUE(adaptive)) " neighbours" else "" + bits <- character(0) + if (isTRUE(bs$at_upper)) + bits <- c(bits, sprintf(paste0( + "the minimum is at the top of the range (%s%s), so the fit is close to ", + "one global regression"), format(signif(bs$bandwidth, 6)), unit)) + else if (isTRUE(bs$near_global)) + bits <- c(bits, sprintf(paste0( + "the widest bandwidth of the range (%s%s) scores within %s of the ", + "minimum, so the criterion does not tell this fit from one global ", + "regression"), format(signif(bs$range[2L], 6)), unit, + if (identical(bs$approach, "CV")) "1 percent" else "2")) + if (isTRUE(bs$at_lower)) + bits <- c(bits, sprintf(paste0( + "the minimum is at the bottom of the range (%s%s), the smallest ", + "bandwidth the model's parameters allow"), + format(signif(bs$bandwidth, 6)), unit)) + if (isTRUE(bs$multimodal)) + bits <- c(bits, sprintf(paste0( + "the criterion has %d local minima on the %d-point grid, so the ", + "bandwidth is the best of those scored and not the one minimum of a ", + "smooth curve"), bs$n_local_minima, sum(bs$curve$stage == "grid"))) + if (isTRUE(bs$flat)) + bits <- c(bits, sprintf(paste0( + "the criterion is flat: bandwidths from %s to %s%s are within %s of ", + "the minimum"), format(signif(bs$within[1L], 6)), + format(signif(bs$within[2L], 6)), unit, + if (identical(bs$approach, "CV")) "1 percent" else "2")) + if (!length(bits)) return("") + paste0(paste(bits, collapse = "; "), ".") +} + + +#' How far the widest kernel of a fit reaches +#' +#' What \code{predict.gwr_fit()} compares a new location's distance to its +#' nearest training point with. The widest kernel is the bandwidth itself +#' when it is fixed; for an adaptive one it is the largest distance from a +#' training point to its \code{bw}-th nearest training point, which +#' \code{fit_gwr_model()} keeps as \code{info$max_kernel_width} and which is +#' worked out from the training coordinates for a fit that does not carry it +#' (one put together by hand). A bisquare, tricube or boxcar kernel reaches +#' as far as its width and no farther. A Gaussian or exponential kernel has +#' no edge; its reach is taken as three widths, where a point's weight is +#' 0.011 (Gaussian) or 0.05 (exponential) of the weight at the centre. +#' +#' @param object The \code{gwr_fit}. +#' @param coords Two-column matrix of the training coordinates. +#' @param bw,adaptive,kernel The fit's bandwidth settings. +#' @return A list: \code{width} (the widest kernel) and \code{reach}. +#' @keywords internal +#' @noRd +.gwr_kernel_reach <- function(object, coords, bw, adaptive, kernel) { + width <- if (!isTRUE(adaptive)) as.numeric(bw) else { + kept <- suppressWarnings(as.numeric(object$info$max_kernel_width %||% NA_real_)) + if (length(kept) == 1L && is.finite(kept)) kept else { + cx <- coords[, 1L]; cy <- coords[, 2L] + out <- 0 + for (i in seq_along(cx)) + out <- max(out, .gw_kernel_width(sqrt((cx - cx[i])^2 + (cy - cy[i])^2), + bw, TRUE)) + out + } + } + list(width = width, + reach = if (kernel %in% c("gaussian", "exponential")) 3 * width else width) +} + + +#' Raise a warning with a condition class, and log it +#' +#' \code{.warn_and_log()} with a class, for the GWR conditions a caller may +#' want to catch by name (\code{tryCatch(spatialkit_gwr_rank_deficient = )}, +#' \code{withCallingHandlers()}) and not by matching message text. +#' +#' @param class The condition class. +#' @param fmt,... As for \code{sprintf()}. +#' @param data Named list of fields to put on the condition, so that a +#' handler reads the counts and does not parse the message. +#' @param tallied \code{TRUE} for a warning that +#' \code{.gwr_tally_predict_warnings()} collects: while it is collecting, +#' the line is not logged here, since the total is logged once at the end. +#' @return The message, invisibly. +#' @keywords internal +#' @noRd +.gwr_warn <- function(class, fmt, ..., data = NULL, tallied = FALSE) { + # Logged and raised by the package's one classed-warning helper, except + # while a collector is totalling: then it is raised for the collector only. + if (!(isTRUE(tallied) && isTRUE(.gwr_predict_state$tally > 0L))) + return(.warn_classed(class, fmt, ..., data = data %||% list())) + msg <- sprintf(fmt, ...) + warning(do.call(warningCondition, + c(list(message = msg, class = class, call = NULL), data))) + invisible(msg) +} + + +# Whether .gwr_tally_predict_warnings() is collecting (its nesting depth). +.gwr_predict_state <- new.env(parent = emptyenv()) + +# The two warnings in which predict() on a GWR counts locations, and which +# .gwr_tally_predict_warnings() totals. +.gwr_counted_classes <- c("spatialkit_gwr_extrapolation", + "spatialkit_gwr_not_estimable") + + +#' The text of the two counted warnings of predict.gwr_fit() +#' +#' Shared by \code{predict.gwr_fit()}, which raises them for one call, and +#' \code{.gwr_tally_predict_warnings()}, which raises them once for many. +#' +#' @param caller Name of the function the message is from. +#' @param n_far,n Locations beyond the reach, and locations predicted. +#' @param reach_text The reach, described. +#' @param nearest Smallest and largest distance from a counted location to +#' its nearest training point. +#' @param calls Number of calls the counts are totalled over, when more than +#' one. +#' @param refits \code{TRUE} when the calls predicted the same rows from +#' several fits (a sweep of cross-validations), so that a location is +#' counted once for each fit that put it out of reach. +#' @return The message. +#' @keywords internal +#' @noRd +.gwr_extrapolation_msg <- function(caller, n_far, n, reach_text, nearest, + calls = 1L, refits = FALSE) { + sprintf(paste0("%s(): %d of %d location(s) are farther from every ", + "training point than the widest kernel of the fit reaches ", + "(%s): the nearest training point is %s away%s. No local ", + "regression of the fit rested on points that far off, so ", + "the prediction(s) there are extrapolations in space. They ", + "are returned as computed; keep them out of a map or a ", + "score unless that is intended."), + caller, n_far, n, reach_text, + if (nearest[2L] > nearest[1L]) + sprintf("%s to %s", format(signif(nearest[1L], 4)), + format(signif(nearest[2L], 4))) + else format(signif(nearest[1L], 4)), + .gwr_totals_clause(calls, refits)) +} + +# " (totals over the N prediction calls that found any)", for a message that +# totals more than one call; with `refits`, also that a location predicted by +# several fits is counted once for each. +.gwr_totals_clause <- function(calls, refits = FALSE) { + if (!(calls > 1L)) return("") + sprintf(" (totals over the %d prediction calls that found any%s)", calls, + if (isTRUE(refits)) + "; a location predicted by several fits is counted once for each" + else "") +} + +#' The text of the warning that counts predictions that are NA +#' +#' See \code{.gwr_extrapolation_msg()}. +#' +#' @param caller Name of the function the message is from. +#' @param n_na,n,n_empty Locations without a prediction, locations +#' predicted, and those without a prediction where no training point +#' carries weight. +#' @param bw_text The bandwidth, described. +#' @param calls Number of calls the counts are totalled over. +#' @param refits As for \code{.gwr_extrapolation_msg()}. +#' @return The message. +#' @keywords internal +#' @noRd +.gwr_not_estimable_msg <- function(caller, n_na, n, n_empty, bw_text, + calls = 1L, refits = FALSE) { + sprintf(paste0("%s(): %d of %d location(s) have no estimable local ", + "regression, so their predictions are NA; the other %d are ", + "unaffected%s. At %d of them no training point carries ", + "weight within the %s. At %d the training points in the ", + "window cannot place the new row: a predictor is constant ", + "among them at a value other than the new row's, the ", + "predictors there are exactly collinear, or fewer points ", + "carry weight than the row needs."), + caller, n_na, n, n - n_na, + .gwr_totals_clause(calls, refits), + n_empty, bw_text, n_na - n_empty) +} + + +#' Raise predict.gwr_fit()'s counted warnings once for a loop of calls +#' +#' \code{predict.gwr_fit()} counts the locations it cannot estimate +#' (\code{"spatialkit_gwr_not_estimable"}) and those beyond the reach of the +#' fit (\code{"spatialkit_gwr_extrapolation"}) for the call it is in. A +#' caller that predicts in pieces, a surface in chunks or a cross-validation +#' in folds, would pass on one warning per piece, each with that piece's +#' counts. Wrapped in this, the pieces' warnings are collected from the +#' fields the conditions carry and each class is raised once, with the totals +#' and under the caller's name. +#' +#' Collectors nest: one that runs inside another raises its totals for the +#' outer one alone, which adds them to its own, so a sweep of +#' cross-validations (\code{cv_block_size_sweep()}, +#' \code{select_features_forward()}) raises each class once for the sweep. +#' +#' @param expr The code that calls \code{predict()} one or more times. +#' @param caller Name of the calling function, for the messages. +#' @param n_total Number of locations predicted over all calls, when the +#' caller knows it; otherwise the totals are over the calls that warned. +#' @param refits \code{TRUE} for a caller whose calls predict the same rows +#' from several fits: the message then says that a location is counted once +#' for each. +#' @return The value of \code{expr}. +#' @keywords internal +#' @noRd +.gwr_tally_predict_warnings <- function(expr, caller, n_total = NULL, + refits = FALSE) { + far <- list(calls = 0L, n_far = 0L, n = 0L, nearest = numeric(0), + reach = numeric(0), reach_text = "") + na <- list(calls = 0L, n_na = 0L, n = 0L, n_empty = 0L, + bw_text = character(0)) + depth <- .gwr_predict_state$tally %||% 0L + .gwr_predict_state$tally <- depth + 1L + on.exit(.gwr_predict_state$tally <- depth, add = TRUE) + value <- withCallingHandlers( + expr, + spatialkit_gwr_extrapolation = function(w) { + far$calls <<- far$calls + (w$calls %||% 1L) + far$n_far <<- far$n_far + w$n_far + far$n <<- far$n + w$n + far$nearest <<- range(c(far$nearest, w$nearest)) + far$reach <<- range(c(far$reach, w$reach)) + far$reach_text <<- w$reach_text + invokeRestart("muffleWarning") + }, + spatialkit_gwr_not_estimable = function(w) { + na$calls <<- na$calls + (w$calls %||% 1L) + na$n_na <<- na$n_na + w$n_na + na$n <<- na$n + w$n + na$n_empty <<- na$n_empty + w$n_empty + na$bw_text <<- union(na$bw_text, w$bw_text) + invokeRestart("muffleWarning") + }) + # Back at the caller's depth before the totals are raised, so that they + # are logged here unless the caller is collected in turn. + .gwr_predict_state$tally <- depth + if (na$n_na > 0L) { + n <- if (is.null(n_total)) na$n else as.integer(n_total) + # One fit has one bandwidth. Folds that each searched for their own do + # not, and the message then names no single one. + bw_text <- if (length(na$bw_text) == 1L) na$bw_text + else "bandwidth of the fit that predicted it (the fits' bandwidths differ)" + .gwr_warn("spatialkit_gwr_not_estimable", "%s", + .gwr_not_estimable_msg(caller, na$n_na, n, na$n_empty, + bw_text, na$calls, refits), + data = list(n_na = na$n_na, n = n, n_empty = na$n_empty, + bw_text = bw_text, calls = na$calls), + tallied = TRUE) + } + if (far$n_far > 0L) { + n <- if (is.null(n_total)) far$n else as.integer(n_total) + # One fit has one reach. The folds of a cross-validation are different + # fits, each with its own: the message then gives the smallest and the + # largest, and `reach` carries both. + one_reach <- !(far$reach[2L] > far$reach[1L]) + reach <- if (one_reach) far$reach[1L] else far$reach + reach_text <- if (one_reach) far$reach_text + else sprintf(paste0("%s to %s in the units of the fits' CRS: each call ", + "predicted from a fit of its own, with its own reach"), + format(signif(far$reach[1L], 4)), + format(signif(far$reach[2L], 4))) + .gwr_warn("spatialkit_gwr_extrapolation", "%s", + .gwr_extrapolation_msg(caller, far$n_far, n, reach_text, + far$nearest, far$calls, refits), + data = list(n_far = far$n_far, n = n, reach = reach, + reach_text = reach_text, nearest = far$nearest, + calls = far$calls), + tallied = TRUE) + } + value +} + + #' Survey the local collinearity of every fitting window #' #' At each observation, forms the kernel-weighted local design that the local @@ -1143,8 +3014,8 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' \describe{ #' \item{\code{cn}}{Belsley's scaled condition index of \eqn{W^{1/2} X}, #' intercept included (\code{cbind(1, xmat)}), columns scaled to unit -#' length but not centred. This is the design GWmodel inverts, and the -#' literature's local index (Wheeler 2007; +#' length but not centred. This is the weighted design as it stands, and +#' the literature's local index (Wheeler 2007; #' \code{GWmodel::gwr.collin.diagno()} computes the same). It is right #' about the INTERCEPT: a predictor whose values in the window are far #' from 0 against their spread makes the local intercept an extrapolation @@ -1180,10 +3051,14 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' nothing here either; rows with negligible weight are dropped before the #' SVD. So are rows whose weight is undefined (\code{NaN}, a zero-width #' adaptive kernel at co-located points), and a window left with fewer rows -#' than columns counts as singular (\code{Inf}) in both indices: GWmodel -#' returns non-finite coefficients there. Every location is surveyed, not a -#' sample: the map of coefficients needs a value at each, and the survey's -#' cost is the same order as the fit's. +#' than columns counts as singular (\code{Inf}) in both indices: the local +#' solve finds it of deficient rank. The survey drops rows whose weight is +#' below 1e-8 and the solve drops none, so under a Gaussian or exponential +#' kernel the survey can call a window singular that the solve finds of full +#' rank on distant, lightly weighted rows; the survey's verdict is then the +#' caution that the coefficients rest on very little. Every location is +#' surveyed, not a sample: the map of coefficients needs a value at each, and +#' the survey's cost is the same order as the fit's. #' #' @param coords Matrix of coordinates, one row per observation. #' @param xmat Numeric matrix of the numeric predictors. @@ -1257,25 +3132,40 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' Which windows' local slopes count as collinear #' #' A window's slopes are collinear when their own index (\code{cn_slopes}) is -#' above 30 or singular, or when the uncentred index with the intercept -#' (\code{cn}) is above 1e6. The second condition is numerical, not -#' statistical: GWmodel inverts the uncentred \eqn{X^\top W X}, whose -#' condition number is about \code{cn^2}, and shifting a predictor's origin -#' until \code{cn} reached 1.6e6 moved its local slopes by 0.4\% of their -#' spread, 1.6e7 by 25\%, and 1.6e8 made GWmodel stop with "matrix is -#' singular". A survey without \code{cn_slopes} (a fit made before it -#' existed) falls back to \code{cn > 30}. \code{NA} (a survey that did not -#' run) counts as collinear, as it always has. +#' above 30 or singular. The uncentred index with the intercept (\code{cn}) +#' says nothing about the slopes of a fit this package solved: the local +#' solve centres each predictor in its window before it factors the design, +#' so a predictor's origin does not enter. With a predictor shifted by 1e7 +#' (\code{cn} about 3e7) the slopes of a 200-point fit moved by 1e-9, which +#' is the precision the shifted column itself has. Only a \code{cn} that is +#' singular to machine precision counts: the predictor's spread is then lost +#' in the rounding of its own values. +#' +#' A fit whose engine is GWmodel's object (one made by an earlier version) +#' was solved from the uncentred \eqn{X^\top W X}, whose condition number is +#' about \code{cn^2}: shifting a predictor's origin until \code{cn} reached +#' 1.6e6 moved its local slopes by 0.4\% of their spread, 1.6e7 by 25\%, and +#' 1.6e8 made GWmodel stop with "matrix is singular". For such a fit a +#' \code{cn} above 1e6 counts as collinear too. A fit of this package is +#' told by the \code{rank} column its survey carries. +#' +#' A survey without \code{cn_slopes} (a fit made before it existed) falls +#' back to \code{cn > 30}. \code{NA} (a survey that did not run) counts as +#' collinear, as it always has. #' #' @param lc A survey, as \code{.gwr_local_collinearity()} returns it. +#' @param own_solve Whether the fit was solved by this package's local +#' solve. By default, whether the survey carries the solve's \code{rank}. #' @return Logical vector, one element per row of \code{lc}. #' @keywords internal #' @noRd -.gwr_slopes_collinear <- function(lc) { +.gwr_slopes_collinear <- function(lc, own_solve = !is.null(lc$rank)) { cn <- lc$cn if (is.null(lc$cn_slopes)) return(!is.finite(cn) | cn > 30) cs <- lc$cn_slopes - !is.finite(cs) | cs > 30 | !is.finite(cn) | cn > 1e6 + out <- !is.finite(cs) | cs > 30 | !is.finite(cn) + if (!isTRUE(own_solve)) out <- out | cn > 1e6 + out } @@ -1291,17 +3181,18 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, if (is.null(local_cn_df) || !nrow(local_cn_df) || all(is.na(local_cn_df$cn))) return(invisible(NULL)) n <- nrow(local_cn_df) - slope_bad <- .gwr_slopes_collinear(local_cn_df) + # Called by fit_gwr_model() before the solve's columns are added to the + # survey, for a fit the package's own solve is about to make. + slope_bad <- .gwr_slopes_collinear(local_cn_df, own_solve = TRUE) n_extreme <- sum(slope_bad) frac <- n_extreme / n - # What happens at those windows is said as GWmodel does it: a near-singular - # window returns implausibly large coefficients, an exactly singular one - # makes Armadillo's inv() throw and GWmodel stop the whole fit. Non-finite - # coefficients come from undefined kernel weights, not from singularity, and - # the post-fit warning names that cause. + # What happens at those windows: a near-singular window returns + # coefficients that are least squares and may be implausibly large; an + # exactly singular one returns NA for the coefficients it cannot estimate, + # and the warning raised after the fit counts them. if (frac > 0.25) { .warn_and_log( - "fit_gwr_model(): local collinearity: %.0f%% of %d locations have a collinear local design (the predictors, centred in the kernel-weighted window, have scaled condition index > 30 against their spread over the study area, or the window is singular) at the bandwidth in use. Local regressions there are unstable and their coefficients may be implausibly large, and an exactly singular window makes GWmodel stop the fit; plot(fit, type = \"coefficients\") masks them.", + "fit_gwr_model(): local collinearity: %.0f%% of %d locations have a collinear local design (the predictors, centred in the kernel-weighted window, have scaled condition index > 30 against their spread over the study area, or the window is singular) at the bandwidth in use. Local regressions there are unstable and their coefficients may be implausibly large, and a coefficient that an exactly singular window cannot estimate is NA; plot(fit, type = \"coefficients\") masks them.", frac * 100, n ) } else if (n_extreme > 0L) { @@ -1327,18 +3218,14 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' GWR predictions at new locations, one local regression each #' -#' Estimates the local coefficients at every row of \code{rp} and returns -#' \eqn{x^\top\hat\beta(u)}. The coefficients are GWmodel's own and are -#' bit-identical to those \code{GWmodel::gwr.predict()} computed: the same -#' \code{gw.dist()} distances, the same kernel weights (an adaptive bandwidth -#' counts neighbours among the TRAINING points) and the same Armadillo -#' \code{inv(X'WX) X'Wy}. They come from -#' \code{gwr.basic(regression.points = )}, which stops at the coefficients, -#' in chunks. One empty or singular window makes Armadillo's \code{inv()} -#' throw and takes its whole call with it, so a chunk that throws is redone -#' one location at a time with the call \code{gwr.predict()} made per point, -#' \code{gw_reg_1()}, and only the windows that really are singular come back -#' \code{NA}. +#' Solves the local regression at every row of \code{rp} with +#' \code{.gwr_local_solve()}, on the kernel weights of the training points +#' (an adaptive bandwidth counts neighbours among the TRAINING points), and +#' returns \eqn{x^\top\hat\beta(u)}. Each location stands alone: a window +#' that carries no weight, or whose rows cannot place the new row's +#' predictors, gives \code{NA} for that location and leaves the others as +#' they are. At a training location with that row's own predictors the +#' value is \code{fitted()}'s, to the last bit. #' #' @param formula The fitted model formula. #' @param sp_train SpatialPointsDataFrame of the training data, 2-D. @@ -1346,74 +3233,29 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' @param rp Two-column numeric matrix of the new rows' coordinates, in the #' training CRS. #' @param bw,kernel,adaptive The fit's bandwidth settings. -#' @param max_cells Largest training-by-chunk distance matrix, in cells. -#' @return Numeric vector, one value per row of \code{rp}: \code{NA} where -#' the local regression cannot be estimated. +#' @param se Also return the variance factor of each prediction. +#' @return A list, each element with one value per row of \code{rp}: +#' \code{fitted} (\code{NA} where the local regression cannot be +#' estimated), \code{rank}, \code{n_window}, \code{nearest} (distance to +#' the nearest training point), \code{width} (the kernel's distance +#' parameter there) and, with \code{se = TRUE}, \code{var_fit} (multiply by +#' the residual variance for the variance of the fitted value). #' @keywords internal #' @noRd .gwr_predict_at <- function(formula, sp_train, newdata_df, rp, bw, kernel, - adaptive, max_cells = 4e6) { - mf <- stats::model.frame(formula, data = sp_train@data, - drop.unused.levels = TRUE) - tt <- stats::terms(mf) - X <- stats::model.matrix(tt, mf) - y <- as.numeric(stats::model.response(mf)) - k <- ncol(X) - - # The design at the new rows, from the fitted terms and factor levels, so - # that its columns are the coefficients' columns in the same order (a - # duplicated predictor name, for one, gives one column, not two). na.pass - # keeps the rows aligned with `rp`. - tt_new <- stats::delete.response(tt) - X_new <- stats::model.matrix(tt_new, stats::model.frame( - tt_new, newdata_df, na.action = stats::na.pass, - xlev = stats::.getXlevels(tt, mf))) - if (nrow(X_new) != nrow(rp) || ncol(X_new) != k) + adaptive, se = FALSE) { + dsn <- .gwr_design(formula, sp_train@data, newdata_df) + k <- ncol(dsn$X) + if (nrow(dsn$X_new) != nrow(rp) || ncol(dsn$X_new) != k) stop(sprintf(paste0("the design matrix for newdata is %d x %d, but the ", "model has %d term(s) for %d location(s)."), - nrow(X_new), ncol(X_new), k, nrow(rp)), call. = FALSE) - - dp <- sp::coordinates(sp_train) - n_rp <- nrow(rp) - beta <- matrix(NA_real_, n_rp, k) - # The distance matrix is computed here with gw.dist(), as gwr.predict() did, - # and passed in: above 5000 training plus new points gwr.basic() switches to - # computing distances inside its C++ loop, and its coefficients then differ - # from gwr.predict()'s in the last bit. Chunks are sized to keep the - # matrix under `max_cells`. - chunk <- max(1L, min(1000L, as.integer(max_cells %/% nrow(dp)))) - for (s in seq.int(1L, n_rp, by = chunk)) { - idx <- s:min(s + chunk - 1L, n_rp) - rp_i <- rp[idx, , drop = FALSE] - d_i <- GWmodel::gw.dist(dp.locat = dp, rp.locat = rp_i) - g <- tryCatch( - suppressWarnings(GWmodel::gwr.basic( - formula, data = sp_train, regression.points = rp_i, bw = bw, - kernel = kernel, adaptive = adaptive, dMat = d_i)), - error = function(e) NULL) - if (!is.null(g)) { - beta[idx, ] <- as.matrix(g$SDF@data[, seq_len(k), drop = FALSE]) - next - } - # The matrix form of gw.weight() sorts each column once; the vector form - # re-sorts the distances for every element. - w_i <- GWmodel::gw.weight(d_i, bw, kernel, adaptive) - for (j in seq_along(idx)) { - b <- tryCatch(GWmodel::gw_reg_1(X, y, w_i[, j])$beta, - error = function(e) NULL) - if (!is.null(b)) beta[idx[j], ] <- b - } - } - - # Summed term by term in double precision, the order GWmodel's gw_fitted() - # uses, so the values equal gwr.predict()'s and, at the training locations, - # fitted()'s to the bit. rowSums() accumulates in long double and differs - # from both in the last place. - yhat <- X_new[, 1L] * beta[, 1L] - for (j in seq_len(k)[-1L]) yhat <- yhat + X_new[, j] * beta[, j] - yhat <- unname(yhat) - yhat[!is.finite(yhat)] <- NA_real_ - yhat + nrow(dsn$X_new), ncol(dsn$X_new), k, nrow(rp)), call. = FALSE) + sv <- .gwr_local_solve(dsn$X, dsn$y, sp::coordinates(sp_train), bw, kernel, + adaptive, rp = rp, X_rp = dsn$X_new, + what = "predict", se = se) + sv$fitted <- unname(sv$fitted) + sv$fitted[!is.finite(sv$fitted)] <- NA_real_ + sv } diff --git a/R/model-prep.R b/R/model-prep.R index 82aa5bc1..d3d9d6a4 100644 --- a/R/model-prep.R +++ b/R/model-prep.R @@ -27,7 +27,10 @@ #' @param predictor_vars Predictor column names. May be \code{character(0)} #' for an intercept-only model (\code{fit_bayesian_spatial_model()} supports #' one; the GWR and random-forest backends do not and reject it themselves). -#' @param boundary Optional sf/sfc for CRS alignment. +#' @param boundary Optional sf/sfc whose CRS the data are projected to. It +#' is not a clip: rows that fall outside it are kept. Subset +#' \code{data_sf} yourself (for example with \code{sf::st_filter()}) to +#' restrict the rows. #' @param pointize Strategy for non-point geometry coercion, passed to #' \code{\link{coerce_to_points}}. One of \code{"auto"} (default), #' \code{"centroid"}, \code{"point_on_surface"}, \code{"surface"} (an alias @@ -46,8 +49,19 @@ #' layer carries that column, else \code{NULL}) and \code{reason} (one per #' dropped row: \code{"geometry"}, \code{"missing"} or #' \code{"non_finite"}, in that order of precedence when several apply), +#' \code{by_column} (for each modelling column, and for +#' \code{"(geometry)"}, how many of the dropped rows it is missing or +#' non-finite in; a row can count under several), +#' \code{response_std_diff} (the mean response of the dropped rows minus +#' that of the kept rows, in standard deviations of the response over both; +#' \code{NA} when the response is not numeric, or is itself missing in +#' every dropped row), #' plus \code{n_rows}, the number of rows returned, which the record was -#' made for. +#' made for. The same record carries two marks on the rows that were +#' kept: \code{constant_predictors}, the names of the predictors that take +#' one value in every returned row (\code{character(0)} when none does), +#' and \code{n_duplicate_locations}, the number of returned rows whose +#' coordinates repeat those of an earlier row. #' Every fit stores \code{n} as \code{$info$n_dropped}. The record #' describes the rows this call returned and does not survive subsetting: #' \code{clean[i, ]}, like \code{dplyr::filter()}, \code{slice()} or @@ -65,6 +79,37 @@ #' envelope is included in that, deliberately; only coordinates the heuristic #' declines are passed through as-is. Set the CRS on \code{data_sf} if the #' data are planar. +#' @section Warnings: +#' When preparing data for a fit (\code{require_response = TRUE}) two +#' conditions are raised as R warnings, each with a class so it can be caught +#' by name with \code{tryCatch()} or \code{withCallingHandlers()}: +#' \describe{ +#' \item{\code{spatialkit_rows_dropped}}{Rows were dropped. The message +#' gives the number and share of rows, the count by reason and by +#' column, and, for a numeric response, how far the mean response of +#' the dropped rows sits from that of the kept rows. A fit on the rows +#' that remain describes those rows only; when the difference is large +#' the rows are not missing at random and the fit is biased towards the +#' complete ones.} +#' \item{\code{spatialkit_constant_predictor}}{A predictor takes a single +#' value in every row that remains. Its coefficient cannot be told from +#' the intercept: a GWR window is rank-deficient, a Bayesian slope is +#' its prior, and a forest ignores it. The predictor is kept; drop it +#' from \code{predictor_vars}.} +#' } +#' Every fitter and every \code{cv_*()} function prepares its data here and +#' passes these on. \code{\link{compare_models_cv}()}, +#' \code{\link{cv_block_size_sweep}()} and +#' \code{\link{select_features_forward}()} run several cross-validations +#' of one layer, each of which prepares it, and raise a warning of either +#' class once per distinct text for the run. +#' +#' With \code{require_response = FALSE} (how every \code{predict()} method +#' prepares \code{newdata}) neither is raised: the dropped rows are written +#' to the log and to the record, and the prediction for each comes back +#' \code{NA}, so nothing is lost without a trace. Repeated locations are +#' legitimate (repeat visits to one site) and are counted in the record and +#' the log, never warned about. #' @family model fitting #' @family spatial data preparation #' @examples @@ -75,7 +120,8 @@ #' pred = c(1, 2, 3, 4, Inf)), #' coords = c("x", "y"), crs = 32632 #' ) -#' clean <- prep_model_data(dat, "resp", "pred") # drops rows 3 (NA) and 5 (Inf) +#' # Drops rows 3 (NA) and 5 (Inf), and warns that it did, with the counts. +#' clean <- suppressWarnings(prep_model_data(dat, "resp", "pred")) #' attr(clean, "dropped") #' @export prep_model_data <- function(data_sf, response_var, predictor_vars, @@ -210,12 +256,133 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, keep <- ok_cc & ok_fin & ok_geom dropped <- sum(!keep) dropped_geo <- sum(!ok_geom) - if (dropped > 0) - .log_warn(paste0("prep_model_data(): dropping %d row(s) with non-finite or ", - "missing values (%d of them with an empty or non-finite ", - "geometry)."), dropped, dropped_geo) + drop_idx <- unname(which(!keep)) + drop_reason <- as.character(ifelse(!ok_geom[drop_idx], "geometry", + ifelse(!ok_cc[drop_idx], "missing", "non_finite"))) + + # How many of the dropped rows each column is responsible for. A row can + # count under several columns, so these do not sum to `dropped`. + col_bad <- lapply(df, function(v) { + b <- is.na(v) + if (is.numeric(v)) b <- b | !is.finite(v) + b + }) + by_column <- vapply(col_bad, function(b) sum(b & !keep), integer(1)) + if (dropped_geo > 0L) by_column <- c(by_column, `(geometry)` = dropped_geo) + + # Where the dropped rows sit on the response. Rows that go missing on a + # predictor for reasons tied to the outcome leave a fit that describes the + # complete rows only: in the case that prompted this, 41% of the rows were + # dropped and the mean response moved from 0.03 to -0.62 with nothing said. + # Measured in SDs of the response over the rows where it is finite, so the + # number does not depend on its units. + response_std_diff <- NA_real_ + shift_se <- NA_real_ + resp_means <- c(dropped = NA_real_, kept = NA_real_) + if (require_response && dropped > 0L && sum(keep) > 0L) { + y_all <- sf::st_drop_geometry(data_sf)[[response_var]] + if (is.logical(y_all)) y_all <- as.numeric(y_all) + if (is.numeric(y_all)) { + y_drop <- y_all[!keep]; y_drop <- y_drop[is.finite(y_drop)] + y_keep <- y_all[keep] + s_all <- stats::sd(c(y_drop, y_keep)) + if (length(y_drop) > 0L && is.finite(s_all) && s_all > 0) { + resp_means <- c(dropped = mean(y_drop), kept = mean(y_keep)) + response_std_diff <- unname((resp_means[["dropped"]] - + resp_means[["kept"]]) / s_all) + # Two standard errors of a difference of means in SD units: below + # that, a handful of dropped rows says nothing about why they are + # missing, and the message states the difference without reading it. + shift_se <- sqrt(1 / length(y_drop) + 1 / length(y_keep)) + } + } + } + + if (dropped > 0L) { + n_miss <- sum(drop_reason == "missing") + n_nonf <- sum(drop_reason == "non_finite") + cols_txt <- paste(sprintf("%s %d", names(by_column), by_column)[by_column > 0L], + collapse = ", ") + if (require_response) { + shift_txt <- if (is.finite(response_std_diff)) + sprintf(paste0(" The response '%s' averages %s in the dropped rows ", + "that have one and %s in the kept rows, a difference ", + "of %.2f SD%s."), + response_var, format(signif(resp_means[["dropped"]], 4)), + format(signif(resp_means[["kept"]], 4)), response_std_diff, + if (abs(response_std_diff) >= 0.2 && + abs(response_std_diff) > 2 * shift_se) + ", more than two standard errors, so the rows are not missing at random and the fit describes the kept rows, not the layer" + else "") + else "" + .warn_classed( + "spatialkit_rows_dropped", + paste0("prep_model_data(): dropped %d of %d row(s) (%.1f%%): %d with ", + "a missing value, %d with a non-finite value, %d with an empty ", + "or non-finite geometry. Rows affected by column: %s.%s The ", + "fit uses the %d row(s) that remain; attr(, \"dropped\") lists ", + "the rows removed."), + dropped, nrow(data_sf), 100 * dropped / nrow(data_sf), + n_miss, n_nonf, dropped_geo, cols_txt, shift_txt, sum(keep)) + } else { + # Prediction mode. Every predict() method returns NA at exactly these + # rows, so the result itself says which they are; an R warning per call + # would fire on every chunk of a predict_surface() grid with covariate + # gaps. The log line and the record stay. + .log_warn(paste0("prep_model_data(): dropping %d row(s) with non-finite or ", + "missing values (%d of them with an empty or non-finite ", + "geometry). Rows affected by column: %s."), + dropped, dropped_geo, cols_txt) + } + } out <- data_sf[keep, , drop = FALSE] + + # Two marks on the rows that remain. A predictor that takes one value in + # every row cannot be told from the intercept (it is one source of the + # rank-deficient GWR windows), and repeated locations change what a + # neighbour count and a distance quantile mean. Both passed through + # unmarked. + out_df <- sf::st_drop_geometry(out) + constant_predictors <- character(0) + if (nrow(out) >= 2L && length(predictor_vars) > 0L) { + is_const <- vapply(intersect(predictor_vars, names(out_df)), function(cn) { + v <- out_df[[cn]] + if (is.numeric(v)) isTRUE(max(v) == min(v)) else length(unique(v)) <= 1L + }, logical(1)) + constant_predictors <- names(is_const)[is_const] + } + xy_out <- xy_mat + n_duplicate_locations <- NA_integer_ + if (nrow(xy_out) == length(keep) && ncol(xy_out) >= 2L) { + xy_out <- xy_out[keep, , drop = FALSE] + # complex(): one hashable value per location, far faster than + # duplicated() on a two-column matrix, which pastes each row. + n_duplicate_locations <- sum(duplicated(complex(real = xy_out[, 1L], + imaginary = xy_out[, 2L]))) + } else if (nrow(out) > 0L) { + xy_k <- sf::st_coordinates(sf::st_geometry(out)) + if (nrow(xy_k) == nrow(out) && ncol(xy_k) >= 2L) + n_duplicate_locations <- sum(duplicated(complex(real = xy_k[, 1L], + imaginary = xy_k[, 2L]))) + } + if (require_response) { + if (length(constant_predictors) > 0L) + .warn_classed( + "spatialkit_constant_predictor", + paste0("prep_model_data(): predictor(s) %s take a single value in all ", + "%d row(s) kept, so their coefficients cannot be told from the ", + "intercept (a GWR window is rank-deficient, a Bayesian slope is ", + "its prior). They are kept in the data; remove them from ", + "`predictor_vars`."), + paste(sQuote(constant_predictors), collapse = ", "), nrow(out)) + if (isTRUE(n_duplicate_locations > 0L)) + .log_info(paste0("prep_model_data(): %d of %d row(s) kept share their ", + "coordinates with an earlier row (repeated locations); ", + "attr(, \"dropped\")$n_duplicate_locations records the ", + "count."), + n_duplicate_locations, nrow(out)) + } # What was dropped, with the rows' identities. The three masks above used # to be collapsed into the counts of that log line and nothing else, so a # fit's $n was the post-cleaning row count with no trace of how many rows @@ -224,17 +391,22 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, # as passed (point coercion and projection keep the row order); the row IDs # are given as well when the layer carries `..row_id`, which is what the # cross-validation functions name rows by. - drop_idx <- unname(which(!keep)) # Stamped and classed, so that the record cannot outlive the rows it - # describes: `out[i, ]` returns a plain layer without it. + # describes: `out[i, ]` returns a plain layer without it. The two marks on + # the kept rows ride in the same record for that reason: as plain + # attributes they would survive `[` and describe rows the subset no longer + # has. out <- .set_row_record(out, "dropped", list( n = as.integer(dropped), n_geometry = as.integer(dropped_geo), which = drop_idx, row_id = if ("..row_id" %in% names(data_sf)) data_sf[["..row_id"]][drop_idx] else NULL, - reason = as.character(ifelse(!ok_geom[drop_idx], "geometry", - ifelse(!ok_cc[drop_idx], "missing", "non_finite"))) + reason = drop_reason, + by_column = by_column, + response_std_diff = response_std_diff, + constant_predictors = constant_predictors, + n_duplicate_locations = as.integer(n_duplicate_locations) )) out } @@ -275,11 +447,23 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, #' These are the bounds a length-scale \emph{prior} is calibrated over, not #' the scales a fitted model can resolve: that depends on the basis size #' (\code{gp_k} in \code{\link{fit_bayesian_spatial_model}()}, which reports -#' it as \code{$info$gp_ell_min}). Both bounds are fixed fractions of the +#' it as \code{$info$gp_ell_min}, and in map units as +#' \code{$info$gp_resolution}). Both bounds are fixed fractions of the #' spread of pairwise distances, so they do not shrink as points are added to -#' the same area. A surface whose range sits below what the basis resolves -#' needs a larger \code{gp_k}: more points help the data identify a short -#' range, but they make neither these bounds nor the derived basis finer. +#' the same area: more points help the data identify a short range, but they +#' make neither these bounds nor the derived basis finer. +#' +#' The lower bound is the 25th percentile of the pairwise distances, as an +#' effective range. On real layouts that is 14 to 33 percent of the extent +#' along each axis (about 32 km on a uniform 100 km square), and the prior +#' built on it puts 1 percent of its mass below it. A surface whose range +#' is shorter needs two things, not one: a basis fine enough to represent it +#' and a prior that allows it. A larger \code{gp_k} under the prior +#' calibrated here changes almost nothing, because the prior still holds the +#' length-scale above this bound. \code{fit_bayesian_spatial_model()} +#' therefore moves the prior's lower tail down to the length-scale the basis +#' resolves whenever \code{gp_resolution} or an explicit \code{gp_k} asks +#' for a finer basis than the one derived from these bounds. #' #' @param coords_xy Numeric matrix or data.frame of coordinates with at least #' two columns; the first two are used, and replicated rows are collapsed @@ -346,6 +530,17 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { } +# The cap on the TOTAL number of basis functions, gp_k^2. One constant, read +# by .gp_basis_spec() for the derived k and by fit_bayesian_spatial_model() +# for a requested gp_resolution, so the two cannot disagree. +.gp_max_basis <- 2500L + +# sqrt(2 log 20): the distance, in length-scales, at which a +# squared-exponential correlation has fallen to 5 percent. An "effective +# range" is this many length-scales. +.gp_se_range_factor <- sqrt(2 * log(20)) + + #' Choose GP basis count and boundary factor from the length-scale/domain ratio #' #' Implements the practical recommendations of Riutort-Mayol et al. (2023, @@ -420,7 +615,7 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { #' @keywords internal #' @noRd .gp_basis_spec <- function(coords_xy, ls_bounds, - k_min = 10L, max_basis = 2500L, c = NULL) { + k_min = 10L, max_basis = .gp_max_basis, c = NULL) { # Reproduce brms::choose_L()'s domain measure exactly: centre each column, # then take the range over the POOLED matrix. na.rm mirrors brms. xy <- as.matrix(coords_xy)[, 1:2, drop = FALSE] diff --git a/R/model-rf.R b/R/model-rf.R index 24e1f7af..dfed00f9 100644 --- a/R/model-rf.R +++ b/R/model-rf.R @@ -22,12 +22,22 @@ #' @noRd .warn_include_coords <- function() { .log_warn_once("rf_include_coords", - paste0("fit_rf_model(): include_coords = TRUE. A forest given ", - "the coordinates can reproduce the training surface by ", - "memorising location and then fail wherever it has not ", - "been; random cross-validation will not detect this. ", - "Score the result with cv_rf() and blocked folds, not ", - "with the out-of-bag error (Meyer et al. 2019).")) + paste0("fit_rf_model(): include_coords = TRUE. The forest ", + "splits on location and can fit the training surface ", + "by memorising location, so the out-of-bag error and ", + "random cross-validation overstate its accuracy. How ", + "much the coordinates help depends on ", + "how far from the training data the predictions are: ", + "the gain is largest between sampled points, fades ", + "with distance, and can reverse in a region the data ", + "never visited (Meyer et al. 2019). Score the forest ", + "with cv_rf() and blocked or distance-matched folds ", + "(make_folds(method = \"block_kfold\") or \"nndm\"), ", + "and compare it on the same folds with the forest ", + "fitted without coordinates: build the folds once ", + "with make_folds() and pass them as `folds` to two ", + "cv_rf() calls, one with include_coords = TRUE and ", + "one without. ?cv_rf shows the two calls.")) } @@ -156,18 +166,65 @@ #' \code{\link{predict_surface}}, \code{\link{area_of_applicability}} and the #' \code{plot()} method like any other backend. #' -#' @section Coordinates are not predictors by default: -#' Handing a random forest the x and y coordinates lets it reproduce the -#' training surface almost exactly by memorising location, and then fail badly -#' anywhere it has not seen. Random cross-validation will not catch this: -#' nearby points leak between folds, so the memorised surface scores well. -#' That is how the practice became common. Meyer et al. (2019) show the -#' collapse directly. \code{include_coords} therefore defaults to -#' \code{FALSE}, and setting it to \code{TRUE} logs a caution, once per -#' session (it is a deliberate choice, so it is not raised as an R warning, -#' and it is not repeated for every fold of a cross-validation). If you do use it, -#' score the model with \code{\link{cv_spatial}} and blocked folds, never with -#' the out-of-bag error. +#' @section Coordinates as predictors: +#' \code{include_coords = TRUE} adds the x and y coordinates to the +#' predictors. They are the only spatial information a forest can be given: +#' without them it sees the covariates alone, and \code{print()} says "no +#' spatial information used". The default is \code{FALSE}. +#' +#' What the coordinates buy depends on where the predictions are wanted. A +#' forest splits on location as on any column, so it follows the training +#' surface closely between sampled points, and has nothing but the nearest +#' edge of the data to go on beyond them. Between sampled points the +#' coordinates can lower the error, most where the covariates carry little +#' of the spatial structure themselves, and the gain fades with distance +#' from the training data. +#' Beyond the autocorrelation range, or in a region the data never visited, +#' it can reverse: in a simulated hold-out of an unvisited strip the forest +#' with coordinates was 5.2\% worse on average and 31\% worse in the worst +#' run. Meyer et al. (2019) report larger failures of the same kind. With +#' covariates that carry the spatial structure themselves, expect less from +#' the coordinates. +#' +#' What does not change is how such a forest has to be scored. It fits +#' location closely, nearby points leak between random folds, and the +#' out-of-bag error is a random hold-out too, so both overstate its +#' accuracy. Score it with \code{\link{cv_rf}} and +#' blocked folds (\code{make_folds(method = "block_kfold")}) or folds +#' matched to the prediction distance (\code{method = "nndm"}), at the +#' distances the map will be used at, never with the out-of-bag error, and +#' compare the two forests on the same folds. That comparison is two calls: +#' build the folds once and hand them to \code{cv_rf()} with and without +#' the coordinates. +#' \preformatted{ +#' folds <- make_folds(dat, k = 5, method = "block_kfold") +#' plain <- cv_rf(dat, "z", c("a", "b"), folds = folds) +#' with_xy <- cv_rf(dat, "z", c("a", "b"), folds = folds, +#' include_coords = TRUE) +#' c(plain = plain$overall$RMSE, with_xy = with_xy$overall$RMSE) +#' } +#' \code{\link{cv_rf}} runs the same comparison in its example and reads it +#' fold by fold. Setting +#' \code{include_coords = TRUE} logs that advice, once per session (it is a +#' deliberate choice, so it is not raised as an R warning, and it is not +#' repeated for every fold of a cross-validation). +#' +#' @section Categorical predictors: +#' A predictor that is an unordered factor or a character column is split +#' with \code{respect.unordered.factors = "order"}: ranger orders its levels +#' by mean response once, before growing, and splits on that order. That is +#' the handling ranger's own help recommends. ranger's default for a +#' regression forest, \code{"ignore"}, splits on the order the levels happen +#' to be stored in (alphabetical, for most data), which for a nominal +#' variable is arbitrary: with a 40-level factor carrying random level +#' effects, the test RMSE was 1.05 by level order against 0.57 by response +#' order, lower in 10 draws of 10. Pass \code{respect.unordered.factors} +#' through \code{...} to choose otherwise (\code{"ignore"}, or +#' \code{"partition"} for every two-way split of the levels, which is slow +#' beyond a few levels). Ordered factors are left alone and split on their +#' own order, and with \code{splitrule = "extratrees"} ranger's own default +#' for that rule, \code{"partition"}, is kept. The setting is recorded in +#' \code{$info$respect_unordered_factors} and printed with the fit. #' #' @section The out-of-bag error is a random hold-out: #' \code{ranger}'s OOB error holds each observation out of the trees that did @@ -210,7 +267,8 @@ #' high-cardinality predictors (Strobl et al. 2007), which is why permutation #' is the default despite costing more. #' @param include_coords Add the coordinates as predictors. Default -#' \code{FALSE}; see above. +#' \code{FALSE}, which leaves the forest with no spatial information; see +#' \emph{Coordinates as predictors}. #' @param replace Logical; grow each tree on a bootstrap sample drawn #' \emph{with} replacement (\code{TRUE}, ranger's default and this one) or #' on a subsample drawn without replacement (\code{FALSE}). Strobl et al. @@ -245,11 +303,18 @@ #' \code{sample.fraction}, \code{x}, \code{y}) are rejected with a #' message naming the wrapper argument to use instead. Passing them here #' would reach \code{ranger()} twice and fail the call. +#' \code{respect.unordered.factors} passed here overrides the +#' \code{"order"} this function sets when a predictor is categorical; see +#' \emph{Categorical predictors}. #' #' @return An \code{rf_fit} object (inherits from \code{spatial_fit}). #' \code{$info} carries \code{num_trees}, \code{mtry}, \code{min_node_size}, #' \code{importance_type}, \code{importance} (a named numeric, or #' \code{NULL} when \code{importance = "none"}), \code{include_coords}, +#' \code{categorical_predictors} (the unordered factor and character +#' predictors, possibly none) and \code{respect_unordered_factors} (how +#' ranger was told to split them: \code{"order"} unless overridden through +#' \code{...}, and \code{NA} when there is none and nothing was passed), #' \code{replace} and \code{sample_fraction} (the sampling each tree was #' grown on, with \code{sample_fraction} resolved to the number ranger #' used), \code{oob_rmse} and \code{oob_r_squared} (each \code{NA_real_} when @@ -272,10 +337,12 @@ #' solution. \emph{BMC Bioinformatics} 8, 25. \doi{10.1186/1471-2105-8-25} #' #' @seealso \code{\link{cv_rf}} for a spatially blocked performance estimate, -#' \code{\link{area_of_applicability}}, which can take -#' \code{weights = pmax(fit$info$importance, 0)} when that importance is -#' finite (it is \code{NaN} when no row is out of bag; see "What -#' fitted() returns"). +#' \code{\link{area_of_applicability}}, which weights the predictors by +#' \code{pmax(fit$info$importance, 0)} by default when that importance is +#' finite and the forest has out-of-bag skill (it is \code{NaN} when no row +#' is out of bag; see "What fitted() returns"), and which needs +#' \code{categorical = "indicator"} or \code{"drop"} for a forest with a +#' factor predictor. #' @family model fitting #' @examples #' if (requireNamespace("ranger", quietly = TRUE)) { @@ -393,16 +460,51 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, num_threads <- .sanitize_core_count( if (is.null(num_threads)) getOption("mc.cores", 1L) else num_threads) + # Unordered factors and character columns. ranger's default for a + # regression forest, respect.unordered.factors = "ignore", splits them on + # the order their levels are stored in, which for a nominal variable is + # usually the alphabet: a 40-level factor with random level effects gave a + # test RMSE of 1.05 that way against 0.57 with "order" (levels ordered by + # mean response once, before growing), lower in 10 draws of 10. ranger's + # help recommends "order", so that is what a categorical predictor gets + # unless the caller says otherwise through `...`. Ordered factors carry an + # order of their own and are untouched by the setting. The one case left + # to ranger is splitrule = "extratrees", where its own default is already + # "partition" and not "ignore". + cat_pred <- names(X)[vapply(X, function(v) + (is.factor(v) && !is.ordered(v)) || is.character(v), logical(1))] + ruf_set <- "respect.unordered.factors" %in% dot_names + extratrees <- "splitrule" %in% dot_names && + identical(list(...)[["splitrule"]], "extratrees") + ruf_order <- !ruf_set && !extratrees && length(cat_pred) > 0L + ruf <- if (ruf_set) { + v <- list(...)[["respect.unordered.factors"]] + if (is.null(v)) NA_character_ + else if (is.logical(v)) (if (isTRUE(v)) "order" else "ignore") + else as.character(v)[1L] + } else if (length(cat_pred) == 0L) NA_character_ + else if (extratrees) "partition" else "order" + # .call_capturing_stderr(): ranger diagnoses a bad argument on stderr from # C++ and then throws "User interrupt or internal error.", so the message # this reported named nothing a caller could act on while the real reason # printed itself to the console past every handler. + # Two spelled-out calls rather than do.call(): ranger keeps its call, and + # do.call() would put the whole predictor frame inside it. rr <- .call_capturing_stderr(function() - ranger::ranger(x = X, y = y, num.trees = as.integer(num_trees), - mtry = mtry, min.node.size = min_node_size, - importance = importance, seed = seed, - replace = replace, sample.fraction = sample_fraction, - num.threads = num_threads, ...)) + if (ruf_order) + ranger::ranger(x = X, y = y, num.trees = as.integer(num_trees), + mtry = mtry, min.node.size = min_node_size, + importance = importance, seed = seed, + replace = replace, sample.fraction = sample_fraction, + num.threads = num_threads, + respect.unordered.factors = "order", ...) + else + ranger::ranger(x = X, y = y, num.trees = as.integer(num_trees), + mtry = mtry, min.node.size = min_node_size, + importance = importance, seed = seed, + replace = replace, sample.fraction = sample_fraction, + num.threads = num_threads, ...)) if (!is.null(rr$error)) stop(sprintf("fit_rf_model(): ranger() failed: %s", .stderr_reason(rr$error, rr$stderr)), call. = FALSE) @@ -448,7 +550,9 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, # suggests for area_of_applicability() are refused too. if (identical(importance, "permutation")) paste0(" area_of_applicability() cannot be weighted by ", - "that importance either: pass weights = NULL.") + "that importance either: pass weights = NULL, or ", + "leave its default weights = \"auto\", which uses ", + "equal weights for this fit.") else "") } else if (!fold_fit && n_no_oob > 0L) { .warn_and_log(paste0("fit_rf_model(): %d of %d rows were sampled by every ", @@ -484,6 +588,10 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, importance_type = importance, importance = imp, include_coords = isTRUE(include_coords), + # The unordered factor and character predictors, and how ranger was + # told to split them (NA: none, and nothing passed). + categorical_predictors = cat_pred, + respect_unordered_factors = ruf, replace = isTRUE(replace), sample_fraction = sample_fraction, oob_rmse = if (is.finite(oob_mse)) sqrt(oob_mse) else NA_real_, @@ -583,6 +691,22 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, #' whole spatial blocks, so neighbours of a held-out point are not sitting in #' the training set. #' +#' @section Comparing the forest with and without coordinates: +#' Whether \code{include_coords = TRUE} lowers the error depends on how far +#' from the training data the predictions are (see \emph{Coordinates as +#' predictors} in \code{\link{fit_rf_model}}), so it is a comparison to make +#' on your own data, at the block size the map will be used at. Score the +#' two forests on the same folds: build the folds once with +#' \code{\link{make_folds}} and pass the result as \code{folds} to two +#' calls, one with \code{include_coords = TRUE} and one without. Each fold +#' then holds out the same rows in both, so the two \code{overall} rows +#' compare like with like and the two \code{fold_metrics} tables pair up +#' fold by fold. A difference in \code{overall} that is small beside the +#' spread of the per-fold differences is not evidence for either forest. +#' The example below runs the comparison. \code{\link{compare_models_cv}} +#' takes one set of forest arguments (\code{rf_args}) per call, so it scores +#' one of the two forests, not both. +#' #' @param data_sf An sf object. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. @@ -609,6 +733,10 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, #' four threads in total, where it would otherwise mean four times the #' session's \code{mc.cores}. #' @param block_size,auto_range,boundary Passed to \code{\link{cv_spatial}}. +#' \code{block_size} and \code{auto_range = TRUE} size the blocks built +#' when \code{folds} is \code{NULL}; beside supplied \code{folds} they +#' have nothing to size and raise a warning of class +#' \code{spatialkit_fold_args_ignored}. #' @param pointize How non-POINT geometry is reduced to a point before #' fitting; passed to \code{\link{cv_spatial}}. Default \code{"auto"}. #' @param metrics Optional scoring function of your own, passed to @@ -636,6 +764,18 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, #' ) #' dat$z <- 2 * dat$a + rnorm(n, 0, 0.3) #' cv_rf(dat, "z", "a", k = 4)$overall +#' +#' # The forest with and without the coordinates, on the same blocked +#' # folds. (The second call logs the include_coords caution, once per +#' # session; this comparison is what it asks for.) This response has no +#' # spatial structure, so here the coordinates can only cost accuracy. +#' folds <- make_folds(dat, k = 4, method = "block_kfold", seed = 1) +#' plain <- cv_rf(dat, "z", "a", folds = folds, num_trees = 200) +#' with_xy <- cv_rf(dat, "z", "a", folds = folds, num_trees = 200, +#' include_coords = TRUE) +#' c(plain = plain$overall$RMSE, with_xy = with_xy$overall$RMSE) +#' # Fold by fold: positive where the coordinates lowered the error. +#' plain$fold_metrics$RMSE - with_xy$fold_metrics$RMSE #' } #' @export cv_rf <- function(data_sf, response_var, predictor_vars, folds = NULL, k = 5, @@ -895,9 +1035,14 @@ coef.rf_fit <- function(object, ...) { #' #' Shows the forest's shape (formula, n, number of trees, \code{mtry}, node #' size) along with the out-of-bag error and, prominently, whether the -#' coordinates were used as predictors. That last line is the one to check: -#' a forest fitted with \code{include_coords = TRUE} can memorise location and -#' score well out-of-bag while failing everywhere it has not been. +#' coordinates were used as predictors. That line is the one to check. A +#' forest fitted without them prints "no spatial information used": it sees +#' the covariates alone. One fitted with \code{include_coords = TRUE} fits +#' location closely, so its out-of-bag error overstates its accuracy and it +#' has to be scored with blocked or distance-matched folds; see +#' \emph{Coordinates as predictors} in \code{\link{fit_rf_model}}. When a +#' predictor is an unordered factor or a character column, a line says how +#' ranger was told to split it. #' #' @param x An \code{rf_fit}. #' @param ... Ignored. @@ -918,7 +1063,21 @@ print.rf_fit <- function(x, ...) { x$info$num_trees %||% NA_integer_, format(x$info$mtry %||% NA), format(x$info$min_node_size %||% NA))) cat(sprintf(" Coords as predictors: %s\n", - if (isTRUE(x$info$include_coords)) "YES - see ?fit_rf_model" else "no")) + if (isTRUE(x$info$include_coords)) + "YES - score with blocked folds; see ?fit_rf_model" + else "no - no spatial information used; see ?fit_rf_model")) + # Only when the fit recorded it and there is something to say. + catp <- x$info$categorical_predictors + ruf <- x$info$respect_unordered_factors + if (length(catp) > 0L && is.character(ruf) && length(ruf) == 1L && !is.na(ruf)) + cat(sprintf(" Categorical: %s split by %s (respect.unordered.factors = \"%s\")\n", + paste(catp, collapse = ", "), + switch(ruf, + order = "levels ordered by mean response", + ignore = "stored level order", + partition = "every two-way partition of the levels", + "ranger's rule"), + ruf)) # Only when the fit recorded it: an rf_fit built before these fields # existed prints as it did. if (!is.null(x$info$replace)) { diff --git a/R/model-selection-gwr.R b/R/model-selection-gwr.R index 8452d475..14421765 100644 --- a/R/model-selection-gwr.R +++ b/R/model-selection-gwr.R @@ -1,52 +1,54 @@ # ============================================================================= -# GWR-specific model selection (wrapper for GWmodel::gwr.model.selection) +# GWR-specific model selection (the forward sweep of +# GWmodel::gwr.model.selection, scored by the package's local solve) # ============================================================================= # # Design note # ----------- -# Every call into GWmodel is confined to .gwr_ms_engine(). Everything after -# it -- criterion extraction, model-list normalisation, ranking -- is pure and -# is tested directly, and the engine itself is injectable so the assembly path -# can be exercised without GWmodel installed. This matters because GWmodel is -# in Suggests: without the split, the entire function would be untested on any -# machine that does not have it, which is every CRAN check machine. +# Every model is scored inside .gwr_ms_engine(). Everything after it -- +# criterion extraction, model-list normalisation, ranking -- is pure and is +# tested directly, and the engine itself is injectable so the assembly path +# can be exercised on its own. The engine returns its sweep in the layout +# GWmodel's function returns, which is what the helpers below read. # ============================================================================= -#' Extract the ranking criterion from GWmodel's model-selection diagnostics +#' Extract the ranking criterion from a model-selection diagnostic table #' -#' \code{GWmodel::gwr.model.selection()} documents its diagnostic table -#' (\code{GWR.df}) as "a data frame consited of four columns: bandwidth, AIC, -#' AICc, RSS". So \strong{AICc is column 3}, and column 2 is the uncorrected -#' AIC. GWmodel builds the table with \code{rbind()} over unnamed vectors +#' The table has the layout of \code{GWmodel::gwr.model.selection()}'s +#' \code{GWR.df}, which GWmodel documents as "a data frame consited of four +#' columns: bandwidth, AIC, AICc, RSS". So \strong{AICc is column 3}, and +#' column 2 is the uncorrected AIC. The package's own engine names the four +#' columns and the criterion is found by name. GWmodel builds its table with +#' \code{rbind()} over unnamed vectors #' (\code{c(bw, aic.rss[2], aic.rss[3], aic.rss[1])} in \code{Model.selection.r}), -#' so it never carries column names: the by-name branch below cannot fire on a -#' real GWmodel return, and the positional fallback is the path every real call -#' takes. Getting it wrong is not a fallback-only risk, it is the normal case. +#' so a table that comes from it, or from an injected engine that copies it, +#' carries no column names and is read by position. #' Reading column 2 ranks on AIC while labelling the result AICc, which selects #' larger models than AICc would and can carry a pure-noise predictor. #' -#' The by-name branch is kept for a future GWmodel that labels the table, and -#' for injected test engines. -#' #' @param gwr_df The second element of the \code{gwr.model.selection()} return. #' @param criterion Column name to look for, matched case-insensitively. #' @return A list with \code{values} (numeric, non-finite coerced to -#' \code{NA}), \code{column}, \code{column_name}, \code{by_name}, +#' \code{NA}), \code{raw} (the same before that coercion, so that an +#' infinite criterion can be told from a missing one), \code{column}, +#' \code{column_name}, \code{by_name}, #' \code{shape_ok} (\code{TRUE} when the table has the documented four #' columns, or when the column was located by name) and \code{label}. #' @keywords internal #' @noRd .gwr_ms_criterion <- function(gwr_df, criterion = "AICc") { if (is.null(gwr_df)) - stop(".gwr_ms_criterion(): GWmodel returned no diagnostic table.", + stop(".gwr_ms_criterion(): the engine returned no diagnostic table.", call. = FALSE) # A bare numeric vector (no dim) is unambiguous: it IS the criterion. if (is.atomic(gwr_df) && is.null(dim(gwr_df))) { vals <- suppressWarnings(as.numeric(gwr_df)) + raw_vals <- vals vals[!is.finite(vals)] <- NA_real_ - return(list(values = vals, column = 1L, column_name = NA_character_, + return(list(values = vals, raw = raw_vals, column = 1L, + column_name = NA_character_, by_name = FALSE, shape_ok = FALSE, label = sprintf("%s (assumed: unlabelled vector)", criterion))) } @@ -82,6 +84,7 @@ raw <- if (is_df) gwr_df[[col]] else gwr_df[, col] vals <- suppressWarnings(as.numeric(raw)) + raw_vals <- vals vals[!is.finite(vals)] <- NA_real_ col_name <- if (!is.null(cn) && nzchar(cn[[col]])) cn[[col]] else NA_character_ @@ -93,7 +96,7 @@ sprintf("%s (assumed: column %d, labelled '%s')", criterion, col, col_name) else sprintf("%s (assumed: column %d, unlabelled)", criterion, col) - list(values = vals, column = col, column_name = col_name, + list(values = vals, raw = raw_vals, column = col, column_name = col_name, by_name = by_name, shape_ok = shape_ok, label = label) } @@ -144,7 +147,7 @@ #' @noRd .gwr_ms_varsets <- function(model_list, response_var) { if (!is.list(model_list) || length(model_list) == 0L) - stop(".gwr_ms_varsets(): GWmodel returned an empty model list.", + stop(".gwr_ms_varsets(): the engine returned an empty model list.", call. = FALSE) lapply(model_list, function(m) { @@ -176,13 +179,15 @@ #' @param minimise Logical; \code{TRUE} for AICc/CV, \code{FALSE} for a #' criterion where larger is better. #' @return A data.frame with \code{rank}, \code{n_vars}, \code{variables}, -#' \code{criterion}. +#' \code{criterion} and \code{delta}, the criterion's distance from the +#' best model's (0 in the first row, \code{NA} where the criterion is). A +#' model without predictors is labelled \code{}. #' @keywords internal #' @noRd .gwr_ms_table <- function(varsets, values, minimise = TRUE) { n <- length(varsets) if (length(values) != n) - stop(sprintf(paste0(".gwr_ms_table(): GWmodel returned %d model(s) but ", + stop(sprintf(paste0(".gwr_ms_table(): the engine returned %d model(s) but ", "%d criterion value(s); the two cannot be aligned."), n, length(values)), call. = FALSE) @@ -202,18 +207,23 @@ df$n_vars, na.last = TRUE) df <- df[ord, , drop = FALSE] df$rank <- seq_len(nrow(df)) + # How far each model is from the best: the gap a reader would otherwise + # subtract by hand before calling one model selected. + df$delta <- if (all(is.na(df$criterion))) NA_real_ + else if (minimise) df$criterion - min(df$criterion, na.rm = TRUE) + else max(df$criterion, na.rm = TRUE) - df$criterion rownames(df) <- NULL attr(df, "varsets") <- varsets[ord] df } -#' Run an expression, optionally swallowing GWmodel's progress output +#' Run an expression, optionally swallowing output written with cat() #' -#' GWmodel reports progress with bare \code{cat()}, so neither -#' \code{suppressMessages()} nor \code{suppressWarnings()} touches it. A sweep -#' prints one "Now calibrating the model" block per candidate (190 of them at -#' 19 candidates), plus the full golden-section bandwidth trace. +#' GWmodel's functions report progress with bare \code{cat()}, which neither +#' \code{suppressMessages()} nor \code{suppressWarnings()} touches; a call +#' to one of them (in a test that compares against GWmodel, say) is wrapped +#' in this to keep the console clean. #' #' @param expr Expression to evaluate (forced exactly once). #' @param quiet Logical; discard output written to stdout. @@ -230,79 +240,76 @@ } -#' Run GWmodel's model-selection sweep +#' Run the forward model-selection sweep +#' +#' The sweep \code{GWmodel::gwr.model.selection()} defines, scored by the +#' package's own local solve. Starting from no predictor, each step fits the +#' current model plus each remaining candidate in turn, keeps the candidate +#' with the lowest AICc, and goes on until every candidate is in: +#' \code{p (p + 1) / 2} models for \code{p} candidates, each at the one +#' bandwidth. A model whose AICc is outside its domain is passed over when a +#' step is chosen. The model without predictors (a local mean) is scored at +#' the same bandwidth. #' -#' All GWmodel interaction lives here so the rest of the function is testable -#' without it. +#' Everything that scores a model lives here, so the rest of +#' \code{gwr_model_selection()} is testable with an injected engine. #' #' @return A list with \code{model_list}, \code{gwr_df}, \code{bandwidth}, -#' \code{bandwidth_source}, \code{used_dmat} and \code{raw} (GWmodel's -#' unmodified return, which the caller passes straight through to the public -#' result). \code{.engine} is a documented injection point, so this list is -#' the contract an injected engine has to satisfy, \code{raw} included. +#' \code{bandwidth_source}, \code{used_dmat} and \code{raw} (the sweep's +#' model list and diagnostic table in the layout +#' \code{GWmodel::gwr.model.selection()} returns, which the caller passes +#' straight through to the public result). \code{.engine} is a documented +#' injection point, so this list is the contract an injected engine has to +#' satisfy, \code{raw} included. Two further elements are optional: +#' \code{null_model} (a numeric vector named \code{bandwidth}, \code{AIC}, +#' \code{AICc} and \code{RSS} for the model without predictors; without it +#' the table has no \code{} row), \code{bandwidth_search} (what +#' \code{.gwr_bw_search()} returned), and \code{undefined} with +#' \code{null_undefined} (for each model of the sweep, and for the one +#' without predictors, the reason \code{.gwr_criterion()} gives why its +#' criterion is not usable, \code{""} when it is). #' @keywords internal #' @noRd .gwr_ms_engine <- function(dat, response_var, candidate_vars, bandwidth, adaptive, kernel, bw_approach, dmat_max_n, quiet = TRUE) { - if (!requireNamespace("GWmodel", quietly = TRUE)) - stop("gwr_model_selection(): package 'GWmodel' is required. ", - "Install with install.packages('GWmodel').", call. = FALSE) + # GWmodel is not needed: the sweep runs on the package's own local solve. if (!requireNamespace("sp", quietly = TRUE)) - stop("gwr_model_selection(): package 'sp' is required (GWmodel interop).", - call. = FALSE) + stop("gwr_model_selection(): package 'sp' is required (the sweep hands ", + "the data to the local solve as a Spatial object). Install with ", + "install.packages('sp').", call. = FALSE) n_obs <- nrow(dat) n_cand <- length(candidate_vars) sp_dat <- .to_sp(dat, unique(c(response_var, candidate_vars))) - - # One distance matrix reused across every candidate fit and the bandwidth - # search. GWmodel recomputes distances per call otherwise, and the sweep - # makes n_cand*(n_cand+1)/2 + bandwidth-search calls. n^2 doubles: 2000 - # points is 32 MB, which is why this is capped rather than unconditional. - dMat <- NULL - # `Inf` means no cap -- always precompute. It was gated on is.finite(), so - # Inf meant NEVER precompute: with adaptive = FALSE the sweep then died on - # n = 100 (a fixed bandwidth needs the matrix) and blamed the caller. - if (!is.na(dmat_max_n) && n_obs <= dmat_max_n) { - dMat <- tryCatch( - GWmodel::gw.dist(dp.locat = sp::coordinates(sp_dat)), - error = function(e) { - .log_warn("gwr_model_selection(): gw.dist() failed (%s); GWmodel will recompute distances per model.", - conditionMessage(e)) - NULL - } - ) - } + df <- sp_dat@data + coords <- sp::coordinates(sp_dat) + y <- as.numeric(df[[response_var]]) + # The design of one model: the intercept and its predictors' columns. The + # candidates are numeric (gwr_model_selection() refuses anything else), so + # this is the model matrix. + design <- function(vars) + cbind(Intercept = 1, as.matrix(df[, vars, drop = FALSE])) # --- Bandwidth ------------------------------------------------------------ # One bandwidth is used for every candidate model: that is what makes the # criterion comparable across them, and it is also the method's main # limitation (see the function's documentation). bandwidth_source <- "supplied" + bw_search <- NULL if (is.null(bandwidth)) { - full_fml <- stats::reformulate(termlabels = candidate_vars, - response = response_var) - # bw.gwr() distinguishes a supplied distance matrix with missing(dMat), - # NOT is.null(dMat). Passing dMat = NULL explicitly therefore takes the - # *supplied* branch, where dim(NULL)[1] != n evaluates to logical(0) and - # the if() dies with "missing value where TRUE/FALSE needed". dMat is NULL - # on three ordinary paths -- dmat_max_n = 0, n_obs above dmat_max_n - # (default 2000), and a failed gw.dist() -- so every dataset over 2000 - # points used to land in the fallback-bandwidth branch below with the - # message blaming GWmodel. Build the call instead and simply omit the - # argument, which is what makes missing(dMat) true. - bw_args <- list(formula = full_fml, data = sp_dat, approach = bw_approach, - kernel = kernel, adaptive = adaptive) - if (!is.null(dMat)) bw_args$dMat <- dMat - bw <- tryCatch( - .gwr_quietly(suppressWarnings(do.call(GWmodel::bw.gwr, bw_args)), quiet), + # The grid-then-refine search fit_gwr_model() uses, on the model with + # every candidate; see .gwr_bw_search(). + bw_search <- tryCatch( + .gwr_bw_search(design(candidate_vars), y, coords, kernel, adaptive, + approach = bw_approach), error = function(e) { - .log_warn("gwr_model_selection(): bw.gwr() failed: %s", + .log_warn("gwr_model_selection(): the bandwidth search failed: %s", conditionMessage(e)) - NA_real_ + NULL } ) + bw <- if (is.null(bw_search)) NA_real_ else bw_search$bandwidth if (!isTRUE(is.finite(bw)) || bw <= 0) { bw <- .fallback_bandwidth(sp_dat, adaptive) bandwidth_source <- "fallback" @@ -311,8 +318,39 @@ "bandwidth = %.4f. Supply `bandwidth` explicitly ", "for a defensible comparison."), bw), call. = FALSE) + } else if (isTRUE(bw_search$none_defined)) { + bandwidth_source <- "widest (no bandwidth has a defined criterion)" + .warn_and_log(paste0("gwr_model_selection(): no bandwidth from %s to ", + "%s%s has a defined %s for the model with every ", + "candidate, so none could be selected: at each of ", + "the %d tried %s. The widest, %s, is used. ", + "Supply `bandwidth`, or use fewer candidates or ", + "more observations."), + format(signif(bw_search$range[1L], 6)), + format(signif(bw_search$range[2L], 6)), + if (isTRUE(adaptive)) " neighbours" else "", + .gwr_bw_criterion_name(bw_search, score = TRUE), + bw_search$n_evaluations, + .gwr_bw_undefined_text(bw_search, n_obs), + format(signif(bw, 6))) } else { - bandwidth_source <- sprintf("bw.gwr(%s) on the full model", bw_approach) + # Where locations repeat the search leaves out whole locations, for + # either criterion asked for; see .gwr_bw_search(). + bandwidth_source <- sprintf( + "%s search on the full model", + if (isTRUE(bw_search$by_location)) "leave-one-location-out CV" + else bw_approach) + note <- .gwr_bw_search_note(bw_search, adaptive) + if (nzchar(note)) + .log_warn(paste0("gwr_model_selection(): bandwidth %s%s selected by ", + "%s from %d scored between %s and %s: %s See ", + "$bandwidth_search."), + format(signif(bw, 6)), + if (isTRUE(adaptive)) " neighbours" else "", + .gwr_bw_criterion_name(bw_search), + bw_search$n_evaluations, + format(signif(bw_search$range[1L], 6)), + format(signif(bw_search$range[2L], 6)), note) } } else { bw <- as.numeric(bandwidth) @@ -320,7 +358,7 @@ # Clamp against the LARGEST model in the sweep (all candidates + intercept), # not the smallest. A bandwidth that supports a one-variable fit can leave - # the full model underdetermined, and GWmodel would fail partway through. + # the full model underdetermined. if (isTRUE(adaptive)) { bw <- as.integer(round(bw)) if (n_cand + 2L > n_obs) @@ -348,8 +386,7 @@ bw <- min_bw } # Capped at n, and said: a supplied count above n is most often a - # distance meant for adaptive = FALSE, and bw.gwr() searches from 20 up - # to n, so below 20 points its choice exceeds n. See fit_gwr_model(). + # distance meant for adaptive = FALSE. See fit_gwr_model(). if (bw > n_obs) { if (identical(bandwidth_source, "supplied")) .warn_and_log(paste0("gwr_model_selection(): an adaptive bandwidth of ", @@ -358,79 +395,86 @@ "of neighbours; for a distance in CRS units, set ", "adaptive = FALSE."), bw, n_obs, n_obs) - else if (!identical(bandwidth_source, "fallback")) - .warn_and_log(paste0("gwr_model_selection(): GWmodel::bw.gwr() ", - "searches adaptive bandwidths from 20 neighbours ", - "up to n, a range that is empty for %d ", - "observations, and returned %d; using %d. Neither ", - "is an optimised bandwidth: with this few ", - "observations, supply `bandwidth`."), - n_obs, bw, n_obs) bw <- as.integer(n_obs) } } # A supplied fixed bandwidth in the wrong units (degrees read as metres) - # empties every window, and the sweep then died on GWmodel's bare "inv(): - # matrix is singular"; fit_gwr_model() says what is wrong, and so does this. + # leaves every window its own observation alone; fit_gwr_model() says what + # is wrong, and so does this. if (!isTRUE(adaptive) && identical(bandwidth_source, "supplied")) .gwr_warn_tiny_fixed_bw(dat, bw, "gwr_model_selection") - # A FIXED bandwidth needs the distance matrix. Without one, - # gwr.model.selection() sets dMat <- matrix(0, 0, 0) and then asserts - # stopifnot(bw > min(dMat)); min() of an empty matrix is Inf, so the - # assertion can never hold and the sweep dies with the bare - # "(bw > min(dMat)) is not TRUE". Say so here, where the remedies are - # nameable, rather than letting a fixed-bandwidth sweep on n > dmat_max_n - # stop unexplained. - if (!isTRUE(adaptive) && is.null(dMat)) - stop(sprintf(paste0("gwr_model_selection(): a fixed bandwidth ", - "(adaptive = FALSE) requires the precomputed n x n ", - "distance matrix, and none was built for these %d ", - "observations%s. GWmodel asserts `bw > min(dMat)`, and ", - "min() of the empty matrix it substitutes is Inf, so ", - "the sweep cannot start. Either allow the matrix -- ", - "`dmat_max_n = %d` or more, costing about %.3g MB -- ", - "or use `adaptive = TRUE`, which needs no distance ", - "matrix."), - n_obs, - if (is.finite(dmat_max_n) && n_obs > dmat_max_n) - sprintf(" (dmat_max_n = %s)", format(dmat_max_n)) else "", - n_obs, (as.numeric(n_obs)^2 * 8) / 1024^2), - call. = FALSE) - - # `approach` is deliberately NOT forwarded. It only steers gwr.model.selection's - # own bandwidth search, and bw is always explicit here; GWmodel's documented - # example leaves it at its "CV" default and still reports AICc in the - # diagnostic table, so passing it could only introduce a version-dependent - # difference for no gain. - # - # `dMat` is omitted rather than passed as NULL for the same reason as in - # bw.gwr() above: gwr.model.selection() branches on missing(dMat). - ms_args <- list(DeVar = response_var, InDeVars = candidate_vars, - data = sp_dat, bw = bw, adaptive = adaptive, kernel = kernel) - if (!is.null(dMat)) ms_args$dMat <- dMat - res <- tryCatch( - .gwr_quietly(do.call(GWmodel::gwr.model.selection, ms_args), quiet), - error = function(e) { - msg <- conditionMessage(e) - stop(sprintf("gwr_model_selection(): gwr.model.selection() failed: %s%s", - msg, if (grepl("singular", msg, fixed = TRUE)) - .gwr_singular_hint() else ""), call. = FALSE) + # --- The sweep -------------------------------------------------------------- + # c(bandwidth, AIC, AICc, RSS) for one model, the row GWmodel's table has, + # and the value a forward step is chosen on: AICc, or Inf outside its domain. + # `why` is the reason a model that the formula gives a number for is still + # not comparable (.gwr_criterion()): its fit reproduces the mean of the + # observations at each location, or a term of it is estimable nowhere. + loc <- .gwr_locations(coords) + score <- function(vars) { + cr <- .gwr_criterion(design(vars), y, coords, bw, kernel, adaptive, + approach = "AICc", loc = loc) + list(row = c(bw, cr$AIC, cr$AICc, cr$RSS), value = cr$value, + n_deficient = cr$n_deficient, why = cr$why) + } + n_sweep <- n_cand * (n_cand + 1L) / 2L + model_list <- vector("list", n_sweep) + # GWmodel's table has these four columns and no names; they are named here, + # so the criterion is found by name and not by position. + gwr_df <- matrix(NA_real_, n_sweep, 4L, + dimnames = list(NULL, c("bandwidth", "AIC", "AICc", + "RSS"))) + n_def <- integer(n_sweep) + why <- character(n_sweep) + level <- character(0) + remaining <- candidate_vars + tag <- 0L + for (i in seq_len(n_cand)) { + step <- numeric(length(remaining)) + for (j in seq_along(remaining)) { + vars <- c(level, remaining[j]) + tag <- tag + 1L + fml <- paste0(response_var, "~", paste(vars, collapse = "+")) + # Progress, for a long sweep watched with quiet = FALSE. + if (!isTRUE(quiet)) + cat(sprintf("Now calibrating model %d of %d: %s\n", tag, n_sweep, fml)) + sc <- score(vars) + model_list[[tag]] <- list(fml, vars) + gwr_df[tag, ] <- sc$row + n_def[tag] <- sc$n_deficient + why[tag] <- sc$why + step[j] <- sc$value } - ) - - if (!is.list(res) || length(res) < 2L) - stop("gwr_model_selection(): gwr.model.selection() returned an unexpected ", - "shape (expected a list of a model list and a diagnostic table).", - call. = FALSE) + idx <- if (any(is.finite(step))) which.min(step) else 1L + level <- c(level, remaining[idx]) + remaining <- remaining[-idx] + } + if (!isTRUE(quiet)) + cat(sprintf("Now calibrating the model without predictors: %s~1\n", + response_var)) + null <- score(character(0)) - model_list <- if (!is.null(res$model.list)) res$model.list else res[[1L]] - gwr_df <- if (!is.null(res$GWR.df)) res$GWR.df else res[[2L]] + # A model with windows of deficient rank is scored on its estimable fitted + # values, which is sound, but its coefficients are NA there: say how many + # models that concerns before one of them is selected and fitted. + if (any(n_def > 0L, na.rm = TRUE)) + .log_warn(paste0("gwr_model_selection(): %d of %d model(s) have local ", + "windows of deficient rank at bandwidth %s (up to %d of ", + "%d windows). They are scored on their fitted values, ", + "which those windows do estimate; fit_gwr_model() on such ", + "a model returns NA for the coefficients they cannot."), + sum(n_def > 0L, na.rm = TRUE), n_sweep, format(bw), + max(n_def, na.rm = TRUE), n_obs) + raw <- list(model_list, gwr_df) list(model_list = model_list, gwr_df = gwr_df, bandwidth = bw, bandwidth_source = bandwidth_source, - used_dmat = !is.null(dMat), raw = res) + used_dmat = FALSE, raw = raw, + null_model = c(bandwidth = as.numeric(bw), AIC = null$row[2L], + AICc = null$row[3L], RSS = null$row[4L]), + bandwidth_search = bw_search, + undefined = why, null_undefined = null$why) } @@ -440,10 +484,15 @@ #' Forward model selection for geographically weighted regression #' -#' Wraps \code{GWmodel::gwr.model.selection()}, which grows a GWR model one -#' predictor at a time and scores every intermediate model with a corrected -#' Akaike information criterion. GWmodel returns two loosely-coupled lists; -#' this function returns a ranked table. +#' Grows a GWR model one predictor at a time and scores every intermediate +#' model with a corrected Akaike information criterion, the sweep +#' \code{GWmodel::gwr.model.selection()} defines, and returns a ranked table +#' with each model's distance from the best. The model without predictors is +#' scored too. Every model is fitted by the package's own local solve (see +#' \code{\link{fit_gwr_model}}, \strong{The local solve}), so a candidate +#' that is constant inside some windows, a regional indicator say, is scored +#' on what those windows do estimate and neither stops the sweep nor scores +#' as rounding error. #' #' @section What this optimises, and what it does not: #' The criterion is \strong{in-sample}. AICc penalises the effective number of @@ -457,7 +506,7 @@ #' disagreement is itself informative. It usually means a candidate is #' predictive only locally. #' -#' Two further limitations follow from the method itself: +#' One further limitation follows from the method itself: #' #' \itemize{ #' \item \strong{One bandwidth for every model.} Comparing criteria across @@ -467,27 +516,57 @@ #' (Lu et al. 2014); it is not an implementation shortcut. Refit the #' selected model with \code{bandwidth = NULL} to re-optimise once the #' variable set is settled. -#' \item \strong{The null model is never evaluated.} The sweep starts from -#' one predictor, so the result always names at least one. It cannot tell -#' you that none of the candidates help. #' } #' +#' @section The model without predictors, and the gaps: +#' The forward sweep starts from one predictor, so by itself it always names +#' at least one, whether or not any candidate helps. The model without +#' predictors, a local mean at the sweep's bandwidth, is therefore scored as +#' well and ranked with the others as \code{}. When it ranks first, +#' \code{best} is \code{character(0)}: no candidate improves on it. +#' +#' The \code{delta} column of \code{table} is each model's criterion minus +#' the best one's. Differences of AICc below about 2 do not separate two +#' models (Burnham and Anderson 2002), so \code{within_2} lists the models +#' that close to the best and \code{smallest_within_2} names the one among +#' them with the fewest predictors, which is the one to prefer when several +#' are that close. \code{best} is still the model with the lowest criterion. +#' +#' @section Observations that share a location: +#' When rows of \code{data_sf} have the same coordinates, the bandwidth +#' search leaves out whole locations, for either \code{bw_approach} (see +#' \code{\link{fit_gwr_model}}, \strong{Observations that share a +#' location}); \code{bandwidth_source} then reads +#' \code{"leave-one-location-out CV search on the full model"}. The models +#' are still ranked by AICc, which counts the rows at one location as +#' independent, so the gaps overstate what a predictor adds when a location +#' has an effect of its own; a warning of class +#' \code{"spatialkit_gwr_repeated_locations"} says so with the counts. A +#' model whose fit reproduces the mean of the observations at each location +#' (every such model scores the same, whatever its predictors) has criterion +#' \code{NA} and is listed last, as is one with a term that no local window +#' can estimate; a warning names them. +#' #' @section Cost: #' The sweep fits \code{p * (p + 1) / 2} GWR models for \code{p} candidates -#' (55 at p = 10, 210 at p = 20), each over all \code{n} locations. +#' (55 at p = 10, 210 at p = 20), and the one without predictors, each over +#' all \code{n} locations. #' \code{max_models} stops the call before it runs for hours. #' #' @param data_sf An \code{sf} object with response, predictors and geometry. #' @param response_var Response column name. #' @param candidate_vars Character vector naming at least two \strong{numeric} #' predictors to choose among. Factor, character and logical candidates are -#' refused: GWmodel fits a factor as several model-matrix columns while this +#' refused: a factor is several model-matrix columns while this #' sweep counts it as one variable, so the criteria would not be comparable, #' and \code{\link{fit_gwr_model}()}, the documented next step, takes only #' numerics. Encode them as numeric indicators first. #' @param bandwidth Bandwidth held fixed across all candidate models. If -#' \code{NULL} (default) it is selected with \code{GWmodel::bw.gwr()} on the -#' model containing every candidate. Integer neighbour count when +#' \code{NULL} (default) it is searched for on the model containing every +#' candidate, by the grid-then-refine search of +#' \code{\link{fit_gwr_model}()} (see its \strong{Bandwidth selection}); +#' what the search scored is returned in \code{bandwidth_search}. Integer +#' neighbour count when #' \code{adaptive = TRUE}; otherwise a distance in the units of the #' **projected** CRS the sweep runs in, which \code{prep_model_data()} may #' have chosen for you. Geographic input is projected before the bandwidth @@ -501,36 +580,44 @@ #' (a regular grid), which leaves a window fewer weighted points; then use #' a larger bandwidth. An adaptive count below 1 or above R's largest #' integer is refused, as in \code{\link{fit_gwr_model}()}. -#' One above the number of observations is capped at it, with a warning; -#' below 20 observations that includes \code{bw.gwr()}'s choice, since its -#' adaptive search starts at 20 neighbours. +#' One above the number of observations is capped at it, with a warning. #' @param adaptive Logical; adaptive (nearest-neighbour) bandwidth. Default #' \code{TRUE}. #' @param kernel Weighting kernel. One of \code{"bisquare"} (default), #' \code{"gaussian"}, \code{"tricube"}, \code{"boxcar"}, #' \code{"exponential"}. #' @param bw_approach Criterion for the bandwidth search: \code{"AICc"} -#' (default) or \code{"CV"}. Matches \code{\link{fit_gwr_model}}'s default. +#' (default) or \code{"CV"}, the leave-one-out sum of squared prediction +#' errors. Matches \code{\link{fit_gwr_model}}'s default. When +#' observations share a location the search leaves out whole locations +#' whichever is asked for; see \strong{Observations that share a +#' location}. #' @param max_models Refuse the call if the sweep would exceed this many model #' fits. Default 200, which admits up to 19 candidates. -#' @param dmat_max_n Precompute and reuse an \code{n} x \code{n} distance -#' matrix when \code{n} is at most this. Default 2000 (about 32 MB). Set to 0 -#' to disable. -#' @param quiet Discard GWmodel's progress output. Default \code{TRUE}, because -#' GWmodel writes it with bare \code{cat()} that no \code{suppressMessages()} -#' can silence, and emits one block per candidate model, so it scales with the -#' square of the candidate count. Set \code{FALSE} to watch a long sweep -#' progress. +#' @param dmat_max_n Not used. The sweep takes its distances window by +#' window and builds no \code{n} x \code{n} distance matrix, so a fixed +#' bandwidth works at any \code{n}. The argument is accepted so that calls +#' written with it run. +#' @param quiet Print no progress. Default \code{TRUE}. With \code{FALSE} one +#' line is written (with \code{cat()}) as each model is fitted, to watch a +#' long sweep progress. #' @param .engine Internal; injectable backend used for testing. #' #' @return An object of class \code{gwr_model_selection}, a list with: -#' \code{best} (character vector of the selected predictors); +#' \code{best} (character vector of the selected predictors, the model with +#' the lowest criterion; \code{character(0)} when that is the model without +#' predictors); #' \code{table} (ranked data.frame of every model evaluated, with columns -#' \code{rank}, \code{n_vars}, \code{variables} and \code{criterion}; -#' \code{criterion} is \code{NA}, and the model ranked last, where GWmodel -#' could not evaluate it or where AICc is undefined because the model's +#' \code{rank}, \code{n_vars}, \code{variables}, \code{criterion} and +#' \code{delta}, the criterion minus the best model's; the model without +#' predictors is the row \code{}; +#' \code{criterion} is \code{NA}, and the model ranked last, where it +#' could not be evaluated or where AICc is undefined because the model's #' effective number of parameters \eqn{tr(S)} is not below \eqn{n - 2}, #' which raises a warning); +#' \code{within_2} (the rows of \code{table} whose \code{delta} is at most +#' 2) and \code{smallest_within_2} (the predictors of the smallest model +#' among them); #' \code{criterion} (label for the criterion actually read, noting when it #' had to be located positionally); #' \code{criterion_by_name} (logical: whether that column was found by @@ -544,25 +631,37 @@ #' candidate set the sweep ran over, both echoed by \code{print()}); #' \code{bandwidth}, \code{bandwidth_source}, \code{adaptive} and #' \code{kernel} (the smoothing held fixed across the sweep, and where it -#' came from); -#' \code{n_obs}, \code{n_models}, \code{used_dmat}; and \code{raw} -#' (GWmodel's unmodified return: the two-element list of its model list and -#' its diagnostic table). +#' came from: \code{"supplied"}, or the criterion's name followed by +#' \code{"search on the full model"}, the criterion being +#' \code{"leave-one-location-out CV"} when observations share a location); +#' \code{bandwidth_search} (what the search scored, as +#' \code{\link{fit_gwr_model}} keeps it; \code{NULL} when the bandwidth was +#' supplied); +#' \code{n_obs}, \code{n_models} (the rows of \code{table}), +#' \code{used_dmat} (always \code{FALSE}); and \code{raw} +#' (the forward sweep in the layout \code{GWmodel::gwr.model.selection()} +#' returns: the two-element list of its model list and its diagnostic +#' table, without the model that has no predictors). #' #' @section Using $raw with GWmodel directly: -#' \code{raw} is GWmodel's own \code{list(model.list, GWR.df)}, so its two -#' elements have to be unpacked before GWmodel's own helpers will take them: -#' \code{GWmodel::gwr.model.view()} takes \code{(DeVar, InDeVars, model.list)}, -#' so the call is +#' \code{raw} has the layout of GWmodel's own \code{list(model.list, GWR.df)}, +#' so its two elements have to be unpacked before GWmodel's helpers will take +#' them: \code{GWmodel::gwr.model.view()} takes +#' \code{(DeVar, InDeVars, model.list)}, so the call is #' \preformatted{ #' GWmodel::gwr.model.view(sel$response_var, sel$candidate_vars, sel$raw[[1]]) #' } #' Pass \code{sel$raw[[1]]}, not \code{sel$raw}. The diagnostic table is -#' \code{sel$raw[[2]]}, an unlabelled numeric matrix whose columns are -#' \code{bandwidth}, \code{AIC}, \code{AICc}, \code{RSS} in that order; the -#' \code{criterion} column of \code{$table} is its third column. +#' \code{sel$raw[[2]]}, a numeric matrix whose columns are +#' \code{bandwidth}, \code{AIC}, \code{AICc}, \code{RSS} in that order (and +#' are named so); the \code{criterion} column of \code{$table} is its third +#' column. #' #' @references +#' Burnham, K. P. and Anderson, D. R. (2002). \emph{Model Selection and +#' Multimodel Inference: A Practical Information-Theoretic Approach}, 2nd +#' edition. Springer. +#' #' Lu, B., Harris, P., Charlton, M. and Brunsdon, C. (2014). The GWmodel R #' package: further topics for exploring spatial heterogeneity using #' geographically weighted models. \emph{Geo-spatial Information Science} @@ -573,8 +672,7 @@ #' selected model. #' @family cross-validation #' @examples -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' if (requireNamespace("sp", quietly = TRUE)) { #' library(sf) #' set.seed(1) #' n <- 80 @@ -585,7 +683,7 @@ #' ) #' dat$z <- 2 * dat$a - dat$b + rnorm(n, 0, 0.5) #' sel <- gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 30) -#' print(sel) # every model tried, by AICc +#' print(sel) # every model tried, by AICc, with the gaps #' print(sel$best) # the winning predictor set: a and b, not noise #' fit <- fit_gwr_model(dat, "z", sel$best) #' fit @@ -612,12 +710,12 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, bw_approach <- match.arg(bw_approach) # Validate `bandwidth` here, not inside .gwr_ms_engine(): the engine is an - # injectable test seam and requires GWmodel, so a check placed there would - # be skipped for injected engines and unreachable without GWmodel. + # injectable test seam, so a check placed there would be skipped for + # injected engines. # Unvalidated, NA reaches the engine's clamp as "missing value where # TRUE/FALSE needed", a length-2 vector as "the condition has length > 1", # and with adaptive = FALSE (no clamp at all) a zero or negative distance - # goes straight into GWmodel. + # goes straight into the kernel. if (!is.null(bandwidth) && (!is.numeric(bandwidth) || length(bandwidth) != 1L || !is.finite(bandwidth) || bandwidth <= 0)) @@ -679,7 +777,7 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, is.numeric, logical(1)) if (any(!cand_types)) stop(sprintf(paste0("gwr_model_selection(): candidate(s) %s are not numeric. ", - "GWmodel fits a factor as several model-matrix columns ", + "A factor is several model-matrix columns ", "while this sweep counts it as one variable, so the ", "criteria would not be comparable -- and fit_gwr_model(), ", "the documented next step, rejects it outright. Encode ", @@ -697,15 +795,31 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, varsets <- .gwr_ms_varsets(eng$model_list, response_var) crit <- .gwr_ms_criterion(eng$gwr_df, criterion = "AICc") - # A model whose AICc is outside its domain (tr S >= n - 2: its local fits - # interpolate the data) gets a large negative AICc from GWmodel, and the - # sweep ranked it first: at n = 60 a model of `a` plus three noise - # variables won with -66689. Set those to NA so they rank last, and say so. - # GWmodel picked its own forward steps on the same numbers, which the - # warning says too. Unguarded when the AIC column cannot be located. aic <- .gwr_ms_aic_column(eng$gwr_df, crit) - if (!is.null(aic) && length(aic) == length(crit$values)) { - undef <- !is.na(crit$values) & .gwr_aicc_undefined(aic, crit$values) + # The model without predictors, when the engine scored it: a local mean at + # the sweep's bandwidth, ranked with the others as ``. Without it the + # sweep starts from one predictor and can only ever name at least one, + # whether or not any candidate helps. + null <- eng$null_model + has_null <- is.numeric(null) && !is.null(names(null)) && + all(c("AIC", "AICc") %in% names(null)) + if (has_null) { + varsets <- c(list(character(0)), varsets) + crit$values <- c(if (is.finite(null[["AICc"]])) null[["AICc"]] else NA_real_, + crit$values) + crit$raw <- c(null[["AICc"]], crit$raw) + if (!is.null(aic)) aic <- c(null[["AIC"]], aic) + } + # A model whose AICc is outside its domain (tr S >= n - 2: its local fits + # interpolate the data) gets a large negative AICc from the formula, minus + # infinity when the residual sum of squares is exactly 0, and the sweep + # ranked it first: at n = 60 a model of `a` plus three noise variables won + # with -66689. Set those to NA so they rank last, and say so. Judged on + # the criterion as the engine returned it, so that an infinite one counts. + # Unguarded when the AIC column cannot be located. + if (!is.null(aic) && length(aic) == length(crit$values) && + length(crit$raw) == length(crit$values)) { + undef <- !is.na(crit$raw) & .gwr_aicc_undefined(aic, crit$raw) if (any(undef)) { crit$values[undef] <- NA_real_ # No larger adaptive bandwidth exists once it is every observation. @@ -715,9 +829,8 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, "of %d model(s) at bandwidth %s and they are ranked ", "last: their effective number of parameters tr(S) ", "is not below n - 2 = %d, so their local fits ", - "(nearly) interpolate the data. GWmodel chose its ", - "forward steps on the same values, so the sweep ", - "past them may not follow the best path. %s"), + "(nearly) interpolate the data. A forward step is ", + "chosen among the models whose AICc is defined. %s"), sum(undef), length(undef), format(eng$bandwidth), nrow(dat) - 2L, if (at_n) @@ -730,29 +843,85 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, else "Use a larger bandwidth.") } } + # Two more kinds of model have a number from the formula and still cannot + # be ranked, and the engine says which (`undefined`). One reproduces the + # mean of the observations at each location: on a layer whose locations + # repeat, every such model scores the same, whatever its predictors. The + # other has a term that no window estimates, so it has no coefficient for + # it anywhere. Both rank last. + why <- eng$undefined + if (is.character(why) && length(why) == length(eng$model_list)) { + if (has_null) why <- c(as.character(eng$null_undefined %||% "")[1L], why) + labels <- vapply(varsets, function(v) + if (length(v)) paste(v, collapse = " + ") else "", character(1)) + sat <- why == "df_distinct" & !is.na(crit$values) + term <- why == "term" & !is.na(crit$values) + if (any(sat) || any(term)) { + crit$values[sat | term] <- NA_real_ + .warn_and_log(paste0("gwr_model_selection(): %d of %d model(s) are not ", + "ranked at bandwidth %s; their criterion is NA and ", + "they are listed last.%s%s Use a larger bandwidth."), + sum(sat | term), length(why), format(eng$bandwidth), + if (any(sat)) + sprintf(paste0(" %d (%s) reproduce the mean of the ", + "observations at each location, or ", + "nearly: their effective number of ", + "parameters tr(S) is not below the ", + "number of distinct rows of location ", + "and predictors minus 2, so AICc ", + "measures only the spread among ", + "observations that share a location."), + sum(sat), paste(labels[sat], collapse = "; ")) + else "", + if (any(term)) + sprintf(paste0(" %d (%s) have a term that no local ", + "window can estimate, so no ", + "coefficient for it exists anywhere."), + sum(term), paste(labels[term], collapse = "; ")) + else "") + } + } + # Several observations at one location: said once, with the counts. + loc <- .gwr_locations(sf::st_coordinates(dat)[, 1:2, drop = FALSE]) + if (loc$n < nrow(dat)) + .gwr_warn( + "spatialkit_gwr_repeated_locations", + paste0("gwr_model_selection(): the %d observations are at %d distinct ", + "location(s) (%d hold more than one observation, the most %d). ", + "AICc counts the ", + "observations at one location as independent. They are not ", + "when a location has an effect of its own, and the gaps in the ", + "table then overstate what a predictor adds.%s Confirm the ", + "selection with select_features_forward(), or fit the means of ", + "replicate observations, one row per location."), + nrow(dat), loc$n, sum(loc$size > 1L), max(loc$size), + if (isTRUE(eng$bandwidth_search$by_location) && + isFALSE(eng$bandwidth_search$none_defined)) + sprintf(paste0(" No bandwidth was supplied: it was selected by %s ", + "(each location predicted from the others)."), + .gwr_bw_criterion_name(eng$bandwidth_search)) + else "") tab <- .gwr_ms_table(varsets, crit$values, minimise = TRUE) - # GWmodel builds GWR.df with rbind() over unnamed vectors, so it never - # carries column names and this branch is the normal path, not an edge case. - # The documented column order is c(bandwidth, AIC, AICc, RSS): AICc is - # column 3. Reading column 2 would rank on the uncorrected AIC while - # labelling the answer AICc. - if (!crit$by_name) - .log_info(paste0("gwr_model_selection(): GWmodel's diagnostic table carries ", - "no column names (it is built by rbind() over unnamed ", - "vectors), so AICc is read positionally from column %d of ", - "the documented c(bandwidth, AIC, AICc, RSS) layout. Check ", - "$raw if the ranking looks wrong."), crit$column) - # A shape other than those four columns means the assumption above no longer - # holds and the ranking may be built on a different criterion entirely. + # The diagnostic table is in GWmodel's layout, a matrix of + # c(bandwidth, AIC, AICc, RSS): AICc is column 3, and reading column 2 would + # rank on the uncorrected AIC while labelling the answer AICc. An unnamed + # table of any other shape (an injected engine's) is read at the same + # position and the ranking is flagged as unverified. if (!isTRUE(crit$shape_ok) && !isTRUE(crit$by_name)) - .log_warn(paste0("gwr_model_selection(): GWmodel's diagnostic table does ", + .log_warn(paste0("gwr_model_selection(): the diagnostic table does ", "not have the documented four columns (bandwidth, AIC, ", "AICc, RSS); AICc was read from column %d of a table with ", "a shape this version does not recognise. Treat the ", "ranking as unverified and check $raw."), crit$column) best_set <- attr(tab, "varsets")[[1L]] + # The models a difference of 2 does not separate from the best, and the + # smallest of them: the usual reading of AICc differences (Burnham and + # Anderson 2002) is that such models have about the same support, and then + # the one with fewest predictors is the one to prefer. + close_i <- which(!is.na(tab$delta) & tab$delta <= 2) + small_i <- close_i[order(tab$n_vars[close_i], tab$criterion[close_i])][1L] n_failed <- sum(is.na(tab$criterion)) if (n_failed > 0L) .log_warn("gwr_model_selection(): %d of %d models produced a non-finite criterion and were ranked last.", @@ -765,6 +934,10 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, list( best = best_set, table = tab, + # The rows of `table` within 2 of the best, and the predictors of the + # smallest model among them (character(0) for the model without any). + within_2 = tab[close_i, , drop = FALSE], + smallest_within_2 = attr(tab, "varsets")[[small_i]], criterion = crit$label, # How the criterion column was found: by name, or by its documented # position (`criterion_column`), and whether the table had the four @@ -782,6 +955,7 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, n_obs = nrow(dat), n_models = nrow(tab), used_dmat = isTRUE(eng$used_dmat), + bandwidth_search = eng$bandwidth_search, raw = eng$raw ), class = "gwr_model_selection" @@ -792,16 +966,23 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, #' Print a GWR model selection result #' #' Shows the forward-selection trail: the response, the candidate predictors, -#' and the top-ranked models with their criterion values, so you can see both -#' which model won and by how much. A shallow gap between the first few rows -#' means the ranking is not well identified and the choice of predictors should -#' not be treated as settled. Check the gap before reporting one model as the -#' selected one. +#' and the top-ranked models with their criterion values and, in the +#' \code{delta} column, how far each is from the best. Below the table it +#' lists the models within 2 of the best, which a difference in AICc does not +#' separate (Burnham and Anderson 2002), and names the smallest of them. When +#' several models are that close the ranking is not well identified and the +#' choice of predictors should not be treated as settled; when the model +#' without predictors (\code{}) is among them, no candidate has been +#' shown to help. #' #' @param x A \code{gwr_model_selection} object. #' @param n Number of top-ranked models to show. Default 10. #' @param ... Ignored. #' @return \code{x}, invisibly. +#' @references +#' Burnham, K. P. and Anderson, D. R. (2002). \emph{Model Selection and +#' Multimodel Inference: A Practical Information-Theoretic Approach}, 2nd +#' edition. Springer. #' @family print methods #' @export print.gwr_model_selection <- function(x, n = 10L, ...) { @@ -822,8 +1003,33 @@ print.gwr_model_selection <- function(x, n = 10L, ...) { if (n_show < nrow(x$table)) cat(sprintf(" ... %d more (see $table)\n", nrow(x$table) - n_show)) - cat(sprintf("\nSelected: %s ~ %s\n", x$response_var, - paste(x$best, collapse = " + "))) + rhs <- function(v) if (length(v)) paste(v, collapse = " + ") else "1" + cat(sprintf("\nSelected: %s ~ %s\n", x$response_var, rhs(x$best))) + if (!length(x$best)) + cat(" The model without predictors has the lowest criterion: no candidate\n", + " improves on a local mean at this bandwidth.\n", sep = "") + + # The gaps, worked out: which models a difference of 2 does not separate + # from the best, and the smallest of them. A table without `delta` (an + # object from an earlier version) prints as it did. + tab <- x$table + if (is.data.frame(tab) && "delta" %in% names(tab)) { + close <- which(!is.na(tab$delta) & tab$delta <= 2) + if (length(close) > 1L) { + cat(sprintf("\nWithin 2 of the best (a difference this small does not separate models):\n")) + for (i in close) + cat(sprintf(" %s ~ %s (+%.2f)\n", x$response_var, + if (identical(tab$variables[i], "")) "1" + else tab$variables[i], tab$delta[i])) + small <- close[order(tab$n_vars[close], tab$criterion[close])][1L] + cat(sprintf("Smallest of them: %s ~ %s\n", x$response_var, + if (identical(tab$variables[small], "")) "1" + else tab$variables[small])) + } else if (nrow(tab) > 1L && is.finite(tab$delta[2L])) { + cat(sprintf("\nNo other model is within 2 of the best; the runner-up is %.2f away.\n", + tab$delta[2L])) + } + } cat("\nThe criterion is in-sample and every model shares one bandwidth.\n") cat("Confirm with select_features_forward() before relying on this.\n") invisible(x) diff --git a/R/partition.R b/R/partition.R new file mode 100644 index 00000000..f3faab5e --- /dev/null +++ b/R/partition.R @@ -0,0 +1,855 @@ +# ============================================================================= +# The partition engine: the centres whose Voronoi cells are the regions. +# +# Two kinds of partition, each from one of two starting rules: +# +# kind "kmeans" minimises the sum over the points of the squared distance +# to the nearest centre. Its centres follow the square root +# of the point density, so a cell in a dense place holds +# several times the points of a cell in a sparse place. +# kind "density" minimises the same sum with each point weighted by +# (local density)^power. With power 1 the centres follow +# the point density itself. Once there are more cells than +# dense places (clusters of points) the cells hold about +# the same number of points each; with fewer, a cell takes +# in whole dense places, large and small, and the counts +# are about as uneven as those of the kind "kmeans". +# +# start "kmeans++" the first centre is a point drawn at random, each later +# one a point drawn in proportion to its (weighted) +# squared distance from the nearest centre so far +# start "random" k distinct locations drawn at random +# +# .partition_centres() is the one entry point. resolution_profile(), +# determine_optimal_levels(), get_voronoi_seeds() and voronoi_seeds_kmeans() +# all take their centres from it. +# ============================================================================= + +# The starting rules, in the order the arguments list them. +.partition_inits <- function() c("kmeans++", "random") + +# Two constants of the density kind, both fractions of the extent of the +# points (the diagonal of their bounding box), so that neither depends on the +# unit the coordinates are in. +# +# The neighbour distance a local density is read from is not taken below +# 1e-6 of the extent. Repeated locations never reach it: the distance is +# measured between distinct locations (see .density_weights()). It is for +# locations that are distinct only in their last digits. +# +# Lloyd's iteration stops when no coordinate of a centre changes by 1e-12 of +# the extent or more. A step in which a point changes cell moves a centre by +# far more than that, so in practice it stops when the cells stop changing. +.DENSITY_FLOOR_REL <- 1e-6 +.DENSITY_TOL_REL <- 1e-12 + +# Starts of the density kind when the caller sets no number: the best of +# three is kept. The kind "kmeans" keeps the number each function has always +# run. +.NSTART_DENSITY <- 3L + + +# The four fields of a partition record that say what built the regions. +.partition_fields <- function() c("kind", "init", "density_power", "density_k") + + +#' Match `init` with a message that names the function +#' +#' \code{match.arg()} on a value that is not a string stops with "'arg' must +#' be NULL or a character vector", which names neither the argument nor the +#' function. +#' +#' @param init The value the caller passed. +#' @param caller Function name for the message. +#' @param null_ok Whether \code{NULL} is a value of its own (the seeding +#' functions' default). +#' @return \code{"kmeans++"} or \code{"random"}, or \code{NULL} when +#' \code{init} is \code{NULL} and \code{null_ok}. +#' @keywords internal +#' @noRd +.match_init <- function(init, caller, null_ok = FALSE) { + if (is.null(init) && isTRUE(null_ok)) return(NULL) + choices <- .partition_inits() + hit <- if (is.character(init) && length(init) == 1L && !is.na(init)) + pmatch(init, choices) else NA_integer_ + if (is.na(hit)) + stop(sprintf("%s(): `init` should be one of %s%s; got %s.", caller, + paste(sprintf("\"%s\"", choices), collapse = ", "), + if (isTRUE(null_ok)) ", or NULL" else "", + if (is.character(init) && length(init) == 1L && !is.na(init)) + sprintf("\"%s\"", init) + else if (length(init) != 1L) + sprintf("%s of length %d", class(init)[1L], length(init)) + else if (is.character(init)) "NA" + else class(init)[1L]), + call. = FALSE) + choices[hit] +} + + +#' Validate the partition arguments of a public function +#' +#' \code{partition} and \code{init} arrive already matched (\code{partition} +#' by \code{match.arg()} in the caller, as the neighbouring arguments are; +#' \code{init} by \code{.match_init()}). +#' \code{density_power} and \code{density_k} are checked here whatever the +#' kind, so that a value that makes no sense is refused and not ignored, and +#' a value set under \code{partition = "kmeans"}, where neither is read, is +#' reported: here, or by the caller through \code{.warn_density_unused()} +#' once it knows that a k-means run is what the call gets (a seeding function +#' handed a selection returns scored centres, which may be density ones). +#' +#' @param partition,init The kind and the starting rule in force. +#' @param density_power,density_k As the caller received them. +#' @param caller Function name for the messages. +#' @param warn_unused Whether to report here a density setting that +#' \code{partition = "kmeans"} does not read. +#' @return A list with \code{kind}, \code{init}, \code{density_power} and +#' \code{density_k} (the last two \code{NA} for \code{kind = "kmeans"}), +#' the record the result objects carry, and two elements for the caller: +#' \code{asked} (the two density settings as given) and \code{unused} (the +#' names of those set to something other than the default under +#' \code{kind = "kmeans"}). +#' @keywords internal +#' @noRd +.check_partition_args <- function(partition, init, density_power, density_k, caller, + warn_unused = TRUE) { + .check_scalar(density_power, "density_power", caller, min = 0, max = 2, + what = "a single number from 0 to 2") + .check_scalar(density_k, "density_k", caller, min = 1, + max = .Machine$integer.max, + what = "a single positive whole number of neighbours") + if (density_k != floor(density_k)) + stop(sprintf("%s(): `density_k` must be a single positive whole number of neighbours; got %s.", + caller, format(density_k)), call. = FALSE) + asked <- list(density_power = as.numeric(density_power), density_k = as.integer(density_k)) + if (identical(partition, "kmeans")) { + part <- list(kind = "kmeans", init = init, + density_power = NA_real_, density_k = NA_integer_, asked = asked, + unused = c(if (!isTRUE(all.equal(density_power, 1))) "density_power", + if (density_k != 8) "density_k")) + if (isTRUE(warn_unused)) .warn_density_unused(part, caller) + return(part) + } + list(kind = "density", init = init, + density_power = asked$density_power, density_k = asked$density_k, + asked = asked, unused = character(0)) +} + + +#' Say that a density setting was given where no density partition is built +#' +#' @param part A \code{.check_partition_args()} result. +#' @param caller Function name for the message. +#' @return \code{NULL}, invisibly; a warning when \code{part$unused} names a +#' setting. +#' @keywords internal +#' @noRd +.warn_density_unused <- function(part, caller) { + set <- part$unused + if (length(set)) + .warn_and_log(paste0("%s(): %s %s read by partition = \"density\" only, and ", + "partition = \"kmeans\" ignores %s."), + caller, paste(sprintf("`%s`", set), collapse = " and "), + if (length(set) > 1L) "are" else "is", + if (length(set) > 1L) "them" else "it") + invisible(NULL) +} + + +#' Check a count of starts or an iteration limit before the engine reads it +#' +#' @param x The value. +#' @param arg,caller Names for the message. +#' @param what What the number counts, for the message. +#' @param null_ok Whether the argument also takes \code{NULL}, which the +#' caller has dealt with; the message then names it. +#' @return \code{x} as an integer. +#' @keywords internal +#' @noRd +.check_whole_count <- function(x, arg, caller, what, null_ok = FALSE) { + what <- sprintf("%sa single positive whole number of %s", + if (isTRUE(null_ok)) "NULL or " else "", what) + .check_scalar(x, arg, caller, min = 1, max = .Machine$integer.max, what = what) + if (x != floor(x)) + stop(sprintf("%s(): `%s` must be %s; got %s.", caller, arg, what, format(x)), + call. = FALSE) + as.integer(x) +} + + +#' The partition record a result object carries, or the default it stands for +#' +#' A result built by a kind or a starting rule other than its function's own +#' default carries \code{attr(, "partition")} (a tessellation carries it as +#' \code{params$partition}, a \code{select_resolution()} result as +#' \code{$partition}). A profile, a selection or a layer of k-means seeds +#' with no record was built by plain k-means. +#' +#' An object that is not a k-means result has no kind: seeds of +#' \code{method = "random"} or \code{"provided"}, a grid or a triangulation, +#' and anything else. So has a Voronoi tessellation with no record, because +#' its cells do not say whether the points they were built on were k-means +#' seeds or the observations themselves. +#' +#' @param x A resolution profile, a selection, a layer of seeds or a +#' tessellation. +#' @return A list with \code{kind}, \code{init}, \code{density_power} and +#' \code{density_k}. For a k-means result with no record \code{kind} is +#' \code{"kmeans"} and \code{init} is \code{NA}: the starting rule is then +#' the default of the function that made it. For an object that is not a +#' k-means result, or does not say, every element is \code{NA}. +#' @keywords internal +#' @noRd +.partition_record <- function(x) { + rec <- attr(x, "partition", exact = TRUE) + if (is.null(rec) && is.list(x) && !inherits(x, "data.frame")) + rec <- if (is.list(x[["params"]])) x[["params"]][["partition"]] else x[["partition"]] + if (is.list(rec) && !is.null(rec$kind)) + return(rec[.partition_fields()]) + kmeans_made <- inherits(x, c("resolution_profile", "resolution_selection")) || + (inherits(x, "sf") && "method" %in% names(x) && nrow(x) > 0L && + all(x[["method"]] %in% "kmeans")) + list(kind = if (kmeans_made) "kmeans" else NA_character_, init = NA_character_, + density_power = NA_real_, density_k = NA_integer_) +} + + +#' A partition's kind and starting rule in words +#' +#' For the print method of a profile and the log lines of the seeding +#' functions. +#' +#' @param rec A partition record. +#' @param nstart Number of starts, or \code{NULL} to leave it out. +#' @return One string, such as \code{"25 density-weighted k-means++ starts +#' (power 1, 8 neighbours)"}. +#' @keywords internal +#' @noRd +.partition_label <- function(rec, nstart = NULL) { + rule <- if (identical(rec$init, "random")) "random" else "k-means++" + paste0(if (is.null(nstart)) "" else paste0(format(nstart), " "), + if (identical(rec$kind, "density")) "density-weighted " else "", + rule, " start", if (is.null(nstart) || !identical(as.numeric(nstart), 1)) "s" else "", + if (identical(rec$kind, "density")) + sprintf(" (power %s, %d neighbour%s)", format(rec$density_power), + as.integer(rec$density_k), + if (identical(as.integer(rec$density_k), 1L)) "" else "s") + else "") +} + + +#' Say that some centres of a density partition hold no point +#' +#' A centre of the density kind that loses its points stays where it is +#' (see \code{.density_kmeans()}), so a partition can come back with fewer +#' occupied cells than centres, and the start that is kept can be such a +#' one: the starts are ranked by the weighted sum alone. It happens at high +#' counts, from about a fifth of the points up, and mostly from random +#' starts (the figures are in the "Conditions" list of +#' \code{resolution_profile()}). It is said when it happens: the count +#' asked for is then not the count of regions that hold data. The kind +#' \code{"kmeans"} never returns such a centre. +#' +#' @param sizes Points per centre. +#' @param caller Function name for the message. +#' @param what What the centres are called there (\code{"seeds"}). +#' @return \code{NULL}, invisibly; a warning of class +#' \code{spatialkit_empty_cells} when a size is 0. +#' @keywords internal +#' @noRd +.warn_empty_seeds <- function(sizes, caller, what = "seeds") { + empty <- sum(sizes == 0L) + if (empty > 0L) + .warn_classed("spatialkit_empty_cells", + paste0("%s(): %d of the %d %s hold no point (a centre of ", + "partition = \"density\" that loses its points stays where it ", + "is), so %d of their Voronoi cells will hold a point."), + caller, empty, length(sizes), what, length(sizes) - empty, + data = list(level = length(sizes), empty = as.integer(empty))) + invisible(NULL) +} + + +#' Say that the start that was kept had not converged at the iteration limit +#' +#' The centres returned are then those of the last step. A longer run moves +#' them further and can move points between cells, so the partition is close +#' to, and not at, the local optimum the start leads to. +#' +#' @param caller Function name for the message. +#' @param level The count, or the counts, of cells at which it happened. +#' @param iter Iterations the kept start took at each of them. +#' @param iter_max The limit. +#' @param kind The kind of partition. +#' @param arg The argument of \code{caller} that raises the limit. +#' @param of Number of levels the caller built, when it built more than one. +#' @return \code{NULL}, invisibly, after a warning of class +#' \code{spatialkit_not_converged} that carries \code{level}, \code{iter} +#' and \code{iter_max}. +#' @keywords internal +#' @noRd +.warn_not_converged <- function(caller, level, iter, iter_max, kind, arg, of = NULL) { + level <- as.integer(level) + one <- identical(as.integer(iter_max), 1L) + steps <- if (identical(kind, "density")) + paste(if (one) "step" else "steps", "of Lloyd's iteration") + else paste(if (one) "iteration" else "iterations", "of k-means") + shown <- if (length(level) > 6L) + paste0(paste(utils::head(level, 6L), collapse = ", "), ", ...") + else paste(level, collapse = ", ") + where <- if (is.null(of)) sprintf("at %s cells", shown) + else sprintf("at %d of the %d levels (%s cells)", length(level), as.integer(of), shown) + .warn_classed("spatialkit_not_converged", + paste0("%s(): %s the start that was kept had not converged after %d %s ", + "(partition = \"%s\"). The centres are those of the last step; a ", + "longer run can still move points between cells. Raise `%s` to ", + "let it finish."), + caller, where, as.integer(iter_max), steps, kind, arg, + data = list(level = level, iter = as.integer(iter), + iter_max = as.integer(iter_max))) + invisible(NULL) +} + + +#' The centres of a partition of the points into k regions +#' +#' The one place the package computes region centres. +#' +#' \strong{Kind \code{"kmeans"}.} With \code{init = "kmeans++"} this is +#' \code{.kmeans_best()} as it always was: the best of \code{nstart} +#' k-means++ starts, each one run of \code{stats::kmeans()} from its seeds. +#' With \code{init = "random"} each start is \code{k} distinct locations +#' drawn at random, as \code{stats::kmeans(centers = k)} draws them; +#' \code{one_call = TRUE} hands the whole job to one +#' \code{stats::kmeans(centers = k, nstart = nstart)} call, which is what the +#' seeding functions have always run, warnings and errors included. +#' +#' \strong{Kind \code{"density"}.} See \code{.density_kmeans()}. +#' +#' @param xy Numeric matrix of finite coordinates; the first two columns are +#' used. +#' @param k Number of centres. +#' @param partition \code{"kmeans"} or \code{"density"}. +#' @param init \code{"kmeans++"} or \code{"random"}. +#' @param nstart Number of starts; the best is kept. +#' @param iter.max Iteration limit of each start: \code{stats::kmeans()}'s +#' for the kind \code{"kmeans"}, Lloyd steps for the kind \code{"density"}. +#' @param density_power,density_k The weight's power and the number of +#' neighbours the local density is read from. Kind \code{"density"} only. +#' @param sort_rows Kind \code{"kmeans"} only: put the rows in coordinate +#' order before the starts are drawn, so that the result does not depend on +#' the order they come in. \code{FALSE} where the caller has already put +#' them in an order of its own, and where the rows are clustered as given. +#' The kind \code{"density"} always works in coordinate order. +#' @param one_call See above. +#' @param use_fnn Whether the kind \code{"density"} may use \pkg{FNN} to +#' shortlist neighbours. The answer is the same without it. +#' @return \code{NULL} when no start produced a partition; otherwise a list +#' with \code{centers} (a \code{k x 2} matrix), \code{cluster} (the centre +#' of each row of \code{xy}, in the order given), \code{size} (points per +#' centre), \code{withinss} (per cell, the unweighted sum of squared +#' distances of its points from their mean), \code{wss} (their total), +#' \code{objective} (what the starts minimised and were ranked by: the same +#' total for the kind \code{"kmeans"}, the weighted sum for the kind +#' \code{"density"}), \code{spread} (\code{(max - min) / min} of the +#' objective over the starts that ran; \code{NA} under \code{one_call}), +#' \code{n_ok} (starts that ran), \code{iter} (iterations of the best +#' start; \code{stats::kmeans()} reports one more than the limit for a fit +#' it cut off, which is held to the limit here except under +#' \code{one_call}, whose record is the one the seeding functions have +#' always returned), \code{converged} (whether that start stopped before +#' the limit: +#' for the kind \code{"kmeans"}, whether \code{stats::kmeans()} returned +#' it with no fault) and \code{km} (the \code{stats::kmeans()} fit; +#' \code{NULL} for the kind \code{"density"}). +#' @keywords internal +#' @noRd +.partition_centres <- function(xy, k, partition = "kmeans", init = "kmeans++", + nstart = 25L, iter.max = 50L, + density_power = 1, density_k = 8L, + sort_rows = FALSE, one_call = FALSE, + use_fnn = requireNamespace("FNN", quietly = TRUE)) { + if (identical(partition, "density")) + return(.density_kmeans(xy, k, power = density_power, k_nn = density_k, + init = init, nstart = nstart, iter.max = iter.max, + use_fnn = use_fnn)) + o <- if (isTRUE(sort_rows)) order(xy[, 1L], xy[, 2L]) else NULL + xs <- if (is.null(o)) xy else xy[o, , drop = FALSE] + if (identical(init, "random") && isTRUE(one_call)) { + km <- stats::kmeans(xs, centers = k, iter.max = iter.max, nstart = nstart) + spread <- NA_real_; n_ok <- NA_integer_ + } else { + kb <- .kmeans_best(xs, k, nstart = nstart, iter.max = iter.max, init = init) + if (is.null(kb)) return(NULL) + km <- kb$km; spread <- kb$spread; n_ok <- kb$n_ok + } + cluster <- km$cluster + if (!is.null(o)) { cluster <- integer(length(o)); cluster[o] <- km$cluster } + list(centers = unname(km$centers[, 1:2, drop = FALSE]), cluster = cluster, + size = as.integer(km$size), withinss = as.numeric(km$withinss), + wss = km$tot.withinss, objective = km$tot.withinss, + spread = spread, n_ok = n_ok, + iter = if (identical(init, "random") && isTRUE(one_call)) as.integer(km$iter) + else min(as.integer(km$iter), as.integer(iter.max)), + # `ifault` is 2 for a fit that ran out of iterations and 4 for one + # whose quick-transfer stage did; stats::kmeans() warns of both. + converged = is.null(km$ifault) || identical(as.integer(km$ifault), 0L), + km = km) +} + + +#' Starting centres drawn as stats::kmeans(centers = k) draws them +#' +#' \code{k} distinct locations: rows of the distinct rows \code{cn} drawn +#' without replacement. With a single start \code{stats::kmeans()} first +#' draws among all the rows and falls back to the distinct ones only when two +#' of the rows drawn coincide; that is followed here, so the best of +#' \code{nstart} starts made this way is the fit +#' \code{stats::kmeans(xy, centers = k, nstart = nstart)} returns. +#' +#' @param xy Numeric matrix of coordinates. +#' @param cn Its distinct rows, \code{unique(xy)}. +#' @param k Number of centres. +#' @param nstart Number of starts the caller runs. +#' @return A \code{k}-row matrix of starting centres. +#' @keywords internal +#' @noRd +.random_centers <- function(xy, cn, k, nstart) { + if (nstart == 1L) { + cen <- xy[sample.int(nrow(xy), k), , drop = FALSE] + if (!any(duplicated(cen))) return(cen) + } + cn[sample.int(nrow(cn), k), , drop = FALSE] +} + + +# ----------------------------------------------------------------------------- +# The density kind +# ----------------------------------------------------------------------------- + +#' The distinct locations of a set of points, in coordinate order +#' +#' The density kind works on locations: a place visited thirty times is one +#' location with thirty points. The order (first coordinate, then second) is +#' the same whatever order the rows come in, which is what makes the kind +#' independent of it; rows at one location are interchangeable. +#' +#' @param xy Two-column matrix of finite coordinates. +#' @return A list: \code{order} (the permutation that sorts the rows), +#' \code{u} (the distinct locations, sorted), \code{m} (points at each) and +#' \code{gid} (the location of each sorted row). +#' @keywords internal +#' @noRd +.partition_locations <- function(xy) { + n <- nrow(xy) + o <- order(xy[, 1L], xy[, 2L]) + xs <- xy[o, , drop = FALSE] + first <- c(TRUE, xs[-1L, 1L] != xs[-n, 1L] | xs[-1L, 2L] != xs[-n, 2L]) + gid <- cumsum(first) + list(order = o, u = unname(xs[first, , drop = FALSE]), m = tabulate(gid), gid = gid) +} + + +#' For chosen rows, the k nearest other locations by exact search +#' +#' Every squared distance is \code{(x - x')^2 + (y - y')^2} in R's own +#' arithmetic, and ties go to the lower row number. This is the definition +#' the kd-tree path of \code{.knn_locations()} has to agree with. +#' +#' @param x,y Coordinates of the locations. +#' @param rows The rows to search for. +#' @param k Number of neighbours, below \code{length(x)}. +#' @return An integer matrix, \code{length(rows) x k}. +#' @keywords internal +#' @noRd +.knn_exact_rows <- function(x, y, rows, k) { + n <- length(x) + out <- matrix(0L, length(rows), k) + if (!length(rows)) return(out) + # Blocks of rows, so that the block-by-n matrix of distances stays small. + per <- max(1L, as.integer(2e6 %/% n)) + for (from in seq.int(1L, length(rows), by = per)) { + at <- from:min(from + per - 1L, length(rows)) + r <- rows[at] + d2 <- outer(x[r], x, "-")^2 + outer(y[r], y, "-")^2 + d2[cbind(seq_along(r), r)] <- Inf # a location is not its own neighbour + # order() leaves ties in their original order: the lower row number first. + out[at, ] <- t(apply(d2, 1L, function(v) order(v)[seq_len(k)])) + } + out +} + + +#' For rows whose neighbours tie, the k nearest other locations from a kd-tree +#' +#' The answer of \code{.knn_exact_rows()} without its comparison of each row +#' with every location. \pkg{FNN} shortlists more neighbours than are +#' wanted, R recomputes their distances, and the \code{k} nearest are taken +#' with the same rule: by distance, ties to the lower row number. A +#' shortlist is long enough when its furthest member is further than the +#' \code{k}-th, by more than one part in a thousand million: every location +#' as near as the \code{k}-th is then on it. A row whose shortlist ends +#' inside the tie gets one twice as long, up to all the other locations. On +#' a lattice, or on coordinates rounded to the metre, most rows tie and a +#' short list settles each, so the time grows with the number of locations +#' and not with its square. +#' +#' @param u Two-column matrix of distinct locations. +#' @param rows The rows to search for. +#' @param k Number of neighbours, below \code{nrow(u)}. +#' @return An integer matrix, \code{length(rows) x k}. +#' @keywords internal +#' @noRd +.knn_tied_rows <- function(u, rows, k) { + n <- nrow(u); x <- u[, 1L]; y <- u[, 2L] + out <- matrix(0L, length(rows), k) + todo <- seq_along(rows) + q <- min(n - 1L, 2L * (k + 1L)) + while (length(todo)) { + r <- rows[todo]; nr <- length(r) + # The location itself comes back as its own nearest neighbour. + nn <- matrix(FNN::get.knnx(u, u[r, , drop = FALSE], k = q + 1L)$nn.index, nr, q + 1L) + self <- nn == r + none <- which(rowSums(self) != 1L) + if (length(none)) { self[none, ] <- FALSE; self[none, q + 1L] <- TRUE } + cand <- matrix(t(nn)[!t(self)], nr, q, byrow = TRUE) + d2 <- matrix((x[cand] - x[r])^2 + (y[cand] - y[r])^2, nr, q) + # Each row's candidates by distance, then by row number: column i of + # `ord` is row i's, nearest first. + ord <- matrix(order(rep.int(seq_len(nr), q), d2, cand), nrow = q) + pick <- ord[seq_len(k), , drop = FALSE] + dk <- d2[pick[k, ]] + far <- d2[ord[q, ]] + done <- q >= n - 1L | far > dk * (1 + 1e-9) + # as.vector(): a two-column matrix of positions would be read as pairs + # of (row, column). + if (any(done)) + out[todo[done], ] <- matrix(cand[as.vector(pick[, done, drop = FALSE])], + sum(done), k, byrow = TRUE) + todo <- todo[!done] + q <- min(n - 1L, 2L * q) + } + out +} + + +#' The k nearest other locations of every location +#' +#' With \pkg{FNN} the kd-tree shortlists \code{k + 1} neighbours and R +#' recomputes their distances. A row whose next neighbour is no further than +#' its \code{k}-th, to within one part in a thousand million, is settled by +#' \code{.knn_tied_rows()} with the rule of the exact search, so the set +#' returned for every row is the one the exact search gives and the two paths +#' agree to the last bit. Without \pkg{FNN} every row is searched exactly, +#' which compares each location with every other. +#' +#' @param u Two-column matrix of distinct locations. +#' @param k Number of neighbours, below \code{nrow(u)}. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return A list: \code{idx} (an \code{nrow(u) x k} matrix of row numbers; +#' the set matters, the order within a row does not) and \code{d} (the +#' distance to the furthest of them, the \code{k}-th nearest). +#' @keywords internal +#' @noRd +.knn_locations <- function(u, k, use_fnn = requireNamespace("FNN", quietly = TRUE)) { + n <- nrow(u); x <- u[, 1L]; y <- u[, 2L] + d2_of <- function(idx) matrix((x[idx] - x)^2 + (y[idx] - y)^2, n, ncol(idx)) + if (isTRUE(use_fnn)) { + kq <- min(k + 1L, n - 1L) + idx <- matrix(FNN::get.knn(u, k = kq)$nn.index, n, kq) + d2 <- d2_of(idx) + dk <- do.call(pmax, lapply(seq_len(k), function(j) d2[, j])) + close <- if (kq > k) which(d2[, kq] <= dk * (1 + 1e-9)) else integer(0) + idx <- idx[, seq_len(k), drop = FALSE] + if (length(close)) { + idx[close, ] <- .knn_tied_rows(u, close, k) + d2 <- d2_of(idx) + dk <- do.call(pmax, lapply(seq_len(k), function(j) d2[, j])) + } + return(list(idx = idx, d = sqrt(dk))) + } + idx <- .knn_exact_rows(x, y, seq_len(n), k) + d2 <- d2_of(idx) + list(idx = idx, d = sqrt(do.call(pmax, lapply(seq_len(k), function(j) d2[, j])))) +} + + +#' For chosen points, the nearest centre by exact search +#' +#' One pass over the centres, each compared with every point at once. A +#' centre replaces the best so far only when it is strictly nearer, so a tie +#' goes to the lower centre number. +#' +#' @param x,y Coordinates of the points. +#' @param cx,cy Coordinates of the centres. +#' @return Integer vector: the centre of each point. +#' @keywords internal +#' @noRd +.nearest_exact <- function(x, y, cx, cy) { + best <- (x - cx[1L])^2 + (y - cy[1L])^2 + idx <- rep.int(1L, length(x)) + for (j in seq_along(cx)[-1L]) { + d2 <- (x - cx[j])^2 + (y - cy[j])^2 + nearer <- d2 < best + best[nearer] <- d2[nearer] + idx[nearer] <- j + } + idx +} + + +#' The nearest centre of every point +#' +#' With \pkg{FNN} the kd-tree shortlists the two nearest centres and R +#' recomputes both distances. A point whose two candidates are within one +#' part in a thousand million of each other is searched exactly, so the +#' answer is the one \code{.nearest_exact()} gives for every point, with or +#' without \pkg{FNN}: on a lattice, where a point can be the same distance +#' from two centres, the cells do not depend on which is installed. Up to 16 +#' centres the exact search is the faster of the two and is used either way +#' (measured at 1,500 to 100,000 points; the kd-tree wins from about 32). +#' +#' @param x,y Coordinates of the points. +#' @param cx,cy Coordinates of the centres. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return Integer vector: the centre of each point. +#' @keywords internal +#' @noRd +.nearest_centre <- function(x, y, cx, cy, + use_fnn = requireNamespace("FNN", quietly = TRUE)) { + K <- length(cx) + if (K == 1L) return(rep.int(1L, length(x))) + if (!isTRUE(use_fnn) || K <= 16L) return(.nearest_exact(x, y, cx, cy)) + nn <- FNN::get.knnx(cbind(cx, cy), cbind(x, y), k = 2L)$nn.index + a <- nn[, 1L]; b <- nn[, 2L] + da <- (x - cx[a])^2 + (y - cy[a])^2 + db <- (x - cx[b])^2 + (y - cy[b])^2 + out <- a + swap <- db < da + out[swap] <- b[swap] + close <- which(pmax(da, db) <= pmin(da, db) * (1 + 1e-9)) + if (length(close)) out[close] <- .nearest_exact(x[close], y[close], cx, cy) + out +} + + +#' Density weights of the distinct locations +#' +#' The local density at a location is the number of other points at it and +#' at its \code{k_nn} nearest other locations, over the area of the disc that +#' reaches the furthest of them: \eqn{count / (\pi d^2)}. Where no location +#' repeats this is \eqn{k_{nn} / (\pi d^2)} with \eqn{d} the distance to the +#' \code{k_nn}-th nearest neighbour, the usual nearest-neighbour estimate. +#' Measuring \eqn{d} between distinct locations keeps it above zero where +#' locations repeat: a point with \code{k_nn} others on top of it has a +#' \code{k_nn}-th neighbour at distance zero and no density by the usual +#' estimate, and a floor on that distance gives every such point the same +#' enormous weight, which hands the whole partition to the repeated +#' locations. Counted this way a place visited thirty times is thirty points +#' in a disc of ordinary size. +#' +#' The weight of a point is its density to the power \code{power}, scaled so +#' that the weights of the points average one. +#' +#' @param u Distinct locations, already divided by the extent. +#' @param m Points at each location. +#' @param power The power, from 0 to 2. +#' @param k_nn Number of neighbours. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return The weight of one point at each location. All one when +#' \code{power} is 0 or there is one location. +#' @keywords internal +#' @noRd +.density_weights <- function(u, m, power, k_nn, use_fnn) { + n_u <- nrow(u) + if (power == 0 || n_u < 2L) return(rep(1, n_u)) + kk <- min(as.integer(k_nn), n_u - 1L) + nn <- .knn_locations(u, kk, use_fnn) + d <- pmax(nn$d, .DENSITY_FLOOR_REL) + cnt <- (m - 1) + rowSums(matrix(m[nn$idx], n_u, kk)) + w <- (cnt / (pi * d^2))^power + w / mean(rep.int(w, m)) +} + + +#' Weighted k-means++ starting centres +#' +#' The first centre is a location drawn with probability proportional to its +#' weight; each later one is drawn with probability proportional to its +#' weight times its squared distance from the nearest centre so far (Arthur +#' and Vassilvitskii 2007, with weights). A location that already holds a +#' centre has distance zero and is not drawn again. +#' +#' @param x,y Coordinates of the locations. +#' @param W Weight of each location (the weights of its points, summed). +#' @param k Number of centres, at most the number of locations. +#' @return Row numbers of the \code{k} starting centres. +#' @keywords internal +#' @noRd +.wkmeanspp <- function(x, y, W, k) { + n <- length(x) + idx <- integer(k) + idx[1L] <- sample.int(n, 1L, prob = W) + d2 <- (x - x[idx[1L]])^2 + (y - y[idx[1L]])^2 + if (k > 1L) for (j in 2:k) { + wd <- W * d2 + cs <- cumsum(wd) + tot <- cs[n] + # The first location whose cumulative weight passes the draw: what + # findInterval(draw, cs) + 1 returns, without its checks that `cs` is + # sorted and has no NA, which read the whole vector twice more. + pick <- if (is.finite(tot) && tot > 0) + min(n, sum(cs <= stats::runif(1L) * tot) + 1L) else NA_integer_ + # A draw that rounds up to the total lands on the last location, which + # may already hold a centre; the last location that can be drawn is the + # one meant. + if (!is.na(pick) && !(wd[pick] > 0)) pick <- max(which(wd > 0)) + if (is.na(pick)) { + free <- setdiff(seq_len(n), idx[seq_len(j - 1L)]) + pick <- free[sample.int(length(free), 1L)] + } + idx[j] <- pick + d2 <- pmin.int(d2, (x - x[pick])^2 + (y - y[pick])^2) + } + idx +} + + +#' Density-weighted k-means +#' +#' Each point gets the weight (local density)^\code{power}, and the centres +#' minimise the weighted sum of squared distances from each point to its +#' nearest centre. A start is \code{k} locations (weighted k-means++, or +#' drawn at random), refined by Lloyd's iteration: each location goes to its +#' nearest centre, each centre moves to the weighted mean of its points, and +#' a centre left without a point stays where it is. The iteration stops when +#' no coordinate of a centre changes by \code{.DENSITY_TOL_REL} of the extent +#' or more, or after \code{iter.max} steps. The start with the lowest +#' weighted sum is kept. +#' +#' What makes the result depend on nothing but the points: +#' \itemize{ +#' \item \emph{Row order.} The work is done on the distinct locations in +#' coordinate order, so the random draws index the same locations +#' whatever order the rows come in. +#' \item \emph{Units.} The coordinates are centred on their bounding box +#' and divided by its diagonal first. The floor on the neighbour +#' distance and the stopping tolerance are fractions of that diagonal, +#' and the centres are put back in the caller's units at the end. +#' \item \emph{Repeated locations.} See \code{.density_weights()}. Points +#' at one location always share a cell. +#' \item \emph{\pkg{FNN}.} It shortlists neighbours; every distance that +#' decides anything is computed in R, and near-ties are settled by an +#' exact search with one tie rule (see \code{.nearest_centre()}). +#' } +#' +#' With \code{power = 0} every weight is one and this is plain k-means by +#' Lloyd's iteration: the objective of the kind \code{"kmeans"}, reached by a +#' different algorithm, so the centres are close to that kind's and not equal +#' to them. +#' +#' @param xy Numeric matrix of finite coordinates; the first two columns are +#' used. +#' @param k Number of centres, from 1 to the number of distinct locations. +#' @param power,k_nn The weight's power and the number of neighbours. +#' @param init \code{"kmeans++"} or \code{"random"}. +#' @param nstart,iter.max Starts, and Lloyd steps per start. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @return As \code{.partition_centres()}, with \code{km} \code{NULL} and +#' two further elements: \code{weights} (the weight of each row of +#' \code{xy}) and \code{converged} (whether the best start stopped before +#' \code{iter.max}). \code{NULL} when \code{k} is below 1 or above the +#' number of distinct locations. +#' @keywords internal +#' @noRd +.density_kmeans <- function(xy, k, power = 1, k_nn = 8L, init = "kmeans++", + nstart = 3L, iter.max = 50L, + use_fnn = requireNamespace("FNN", quietly = TRUE)) { + xy <- unname(as.matrix(xy)[, 1:2, drop = FALSE]) + storage.mode(xy) <- "double" + if (!all(is.finite(xy))) + stop(".density_kmeans(): non-finite coordinates.", call. = FALSE) + n <- nrow(xy); k <- as.integer(k) + loc <- .partition_locations(xy) + n_u <- nrow(loc$u) + if (n < 1L || is.na(k) || k < 1L || k > n_u) return(NULL) + + # Centred on the bounding box and divided by its diagonal. The midpoint + # and the diagonal are read off minima and maxima, which do not depend on + # row order. + lo <- c(min(loc$u[, 1L]), min(loc$u[, 2L])); hi <- c(max(loc$u[, 1L]), max(loc$u[, 2L])) + mid <- (lo + hi) / 2 + extent <- sqrt(sum((hi - lo)^2)) + if (!is.finite(extent)) return(NULL) + if (!(extent > 0)) extent <- 1 # one location + zx <- (loc$u[, 1L] - mid[1L]) / extent + zy <- (loc$u[, 2L] - mid[2L]) / extent + m <- loc$m + + # Without FNN every search is exact and compares each point with every + # other, or with every centre. Said once, where it starts to be felt. + if (!isTRUE(use_fnn) && n_u > 5000L) + .log_warn_once("density_no_fnn", + paste0("partition = \"density\" on %d locations without the FNN ", + "package: the neighbour searches compare every pair of ", + "locations, and every location with every centre at each ", + "step. The result is the same; install FNN to get it sooner."), + n_u) + w <- .density_weights(cbind(zx, zy), m, power, k_nn, use_fnn) + W <- m * w + zw <- cbind(W, zx * W, zy * W) + + nstart <- max(1L, as.integer(nstart)); iter.max <- max(1L, as.integer(iter.max)) + best <- NULL + objs <- rep(NA_real_, nstart) + for (r in seq_len(nstart)) { + start <- if (identical(init, "random")) sample.int(n_u, k) else .wkmeanspp(zx, zy, W, k) + cx <- zx[start]; cy <- zy[start] + it <- 0L; moved <- Inf + while (it < iter.max) { + it <- it + 1L + a <- .nearest_centre(zx, zy, cx, cy, use_fnn) + s <- rowsum(zw, a, reorder = TRUE) + id <- as.integer(rownames(s)) + nx <- cx; ny <- cy + nx[id] <- s[, 2L] / s[, 1L] + ny[id] <- s[, 3L] / s[, 1L] + moved <- max(abs(nx - cx), abs(ny - cy)) + cx <- nx; cy <- ny + if (moved < .DENSITY_TOL_REL) break + } + # The cells are those of the centres as they now stand. + a <- .nearest_centre(zx, zy, cx, cy, use_fnn) + obj <- sum(W * ((zx - cx[a])^2 + (zy - cy[a])^2)) + if (!is.finite(obj) || !all(is.finite(cx)) || !all(is.finite(cy))) next + objs[r] <- obj + if (is.null(best) || obj < best$obj) + best <- list(cx = cx, cy = cy, a = a, obj = obj, iter = it, + converged = moved < .DENSITY_TOL_REL) + } + if (is.null(best)) return(NULL) + + a <- best$a + size <- as.integer(tabulate(rep.int(a, m), nbins = k)) + # Unweighted, about each cell's own mean: the within-cell sum of squares of + # the coordinates, which depends on the cells alone and is the quantity the + # kind "kmeans" reports. + sm <- rowsum(cbind(m, zx * m, zy * m), a, reorder = TRUE) + id <- as.integer(rownames(sm)) + mx <- numeric(k); my <- numeric(k) + mx[id] <- sm[, 2L] / sm[, 1L]; my[id] <- sm[, 3L] / sm[, 1L] + ss <- rowsum(m * ((zx - mx[a])^2 + (zy - my[a])^2), a, reorder = TRUE) + withinss <- numeric(k) + withinss[as.integer(rownames(ss))] <- ss[, 1L] * extent^2 + + cluster <- integer(n); cluster[loc$order] <- a[loc$gid] + weights <- numeric(n); weights[loc$order] <- w[loc$gid] + ok <- objs[is.finite(objs)] + list(centers = cbind(best$cx * extent + mid[1L], best$cy * extent + mid[2L]), + cluster = cluster, size = size, withinss = withinss, wss = sum(withinss), + objective = best$obj * extent^2, + spread = if (length(ok) > 1L && min(ok) > 0) (max(ok) - min(ok)) / min(ok) else 0, + n_ok = length(ok), iter = best$iter, km = NULL, + weights = weights, converged = best$converged) +} diff --git a/R/plotting-diagnostics.R b/R/plotting-diagnostics.R index 61cd8041..0429dfc6 100644 --- a/R/plotting-diagnostics.R +++ b/R/plotting-diagnostics.R @@ -222,11 +222,19 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { #' fence, so the curve reaches it exactly when no training value was fenced #' off and runs past it, by the tail the fence removed, when some were. #' A prediction location outside on a predictor dropped for having no -#' training variance has \code{DI = Inf}: it counts in the prediction curve, +#' training variance, or under \code{categorical = "indicator"} on a level no +#' training row has, has \code{DI = Inf}: it counts in the prediction curve, #' which then tops out below 1, and the caption says how many are off the #' axis. A location with a missing predictor (\code{DI = NA}) is neither #' inside nor outside; it is left out of the curve and the caption counts it. #' +#' When location has an index of its own (a \code{gwr_fit}, a +#' \code{bayesian_fit}, or \code{coords = "yes"}; see +#' \code{\link{area_of_applicability}()}), the curves and the dashed line are +#' the predictor index alone. The subtitle then counts three things: the +#' locations beyond the predictor threshold, those beyond the location +#' threshold, and those outside the area of applicability, which is either. +#' #' @param x An \code{aoa} object from \code{\link{area_of_applicability}()}. #' @param type \code{"ecdf"} (default), the two empirical distribution #' functions on one axis, or \code{"histogram"}, the prediction DI as bars @@ -275,14 +283,21 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { di_new <- di_all[is.finite(di_all)] di_tr <- di_tr[is.finite(di_tr)] n_all <- x$n_new %||% length(di_all) + # What DI = Inf means for this result: a dropped predictor, and under + # categorical = "indicator" also a level no training row has, which is how + # print.aoa() words it. A row on an unseen level was captioned "outside + # on a dropped predictor". + unseen_level <- length(x$categorical_vars) > 0L && + identical(x$params$categorical, "indicator") if (!length(di_new)) { if (n_inf == 0L) stop("plot.aoa(): no finite dissimilarity index at any prediction location ", "(every row had a missing or non-finite predictor).", call. = FALSE) stop(sprintf(paste0("plot.aoa(): no finite dissimilarity index to plot: %d of ", - "%d prediction locations are outside on a predictor dropped ", + "%d prediction locations are outside on %sa predictor dropped ", "for having no training variance (DI = Inf)%s."), n_inf, n_all, + if (unseen_level) "a level no training row has, or on " else "", if (n_na) sprintf(" and %d %s a missing predictor (DI = NA)", n_na, if (n_na == 1L) "has" else "have") else ""), call. = FALSE) @@ -305,9 +320,31 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { q_in <- if (any(di_new <= thr)) stats::quantile(di_new[di_new <= thr], 0.9) / thr else NA_real_ # Both of these ran past the right edge of the figure at the width a help # page and a vignette draw it, so each is broken where it reads naturally. - subtitle <- sprintf( + # + # The count beside "(DI > threshold)" is of the predictor index. With a + # location index `n_outside` is the rows outside on EITHER index, so it is + # not that count: a GWR result with 10 of 100 rows beyond the predictor + # threshold and all 100 beyond the location threshold read "100 of 100 + # prediction locations outside (DI > 0.017)", then "90% of those inside". + # `n_outside_predictors` is the count the threshold belongs to; an object + # from before it existed has no location index, and its `n_outside` is it. + loc <- x$location + has_loc <- is.list(loc) + n_out_pred <- x$n_outside_predictors %||% x$n_outside %||% + (sum(di_new > thr) + n_inf) + subtitle <- if (has_loc) + sprintf(paste0("%d of %d prediction locations outside on the predictors ", + "(DI > %.3g)\n%d outside on location; %d outside the AOA ", + "(either)%s"), + n_out_pred, n_all, thr, loc$n_outside %||% NA_integer_, + x$n_outside %||% NA_integer_, + if (is.finite(q_in)) + sprintf(paste0("\n90%% of those inside on the predictors sit ", + "below %.0f%% of that threshold"), 100 * q_in) + else "") + else sprintf( "%d of %d prediction locations outside (DI > %.3g)%s", - x$n_outside %||% sum(di_new > thr), n_all, thr, + n_out_pred, n_all, thr, if (is.finite(q_in)) sprintf("\n90%% of those inside sit below %.0f%% of the threshold", 100 * q_in) else "") @@ -333,10 +370,16 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { caption <- sprintf("Threshold %s\n%s", if (isTRUE(x$params$threshold_supplied)) "supplied" else "from the training DI", cv_line) + if (has_loc) + caption <- paste0(caption, sprintf(paste0( + "\nThe curves are the predictor index; location is a second index ", + "(DI_location, threshold %.3g)"), as.numeric(loc$threshold))) if (n_inf) caption <- paste0(caption, sprintf(paste0( - "\n%d prediction location%s outside on a dropped predictor (DI = Inf) ", + "\n%d prediction location%s outside on %sa dropped predictor (DI = Inf) ", "%s off the axis"), n_inf, if (n_inf == 1L) "" else "s", + # Broken after the first clause: the line is too long for the figure. + if (unseen_level) "a level no training row has,\nor on " else "", if (n_inf == 1L) "is" else "are")) if (n_na) caption <- paste0(caption, sprintf( @@ -623,12 +666,25 @@ plot_calibration <- function(cv, ...) { #' choosing, not the criterion. A criterion that is \code{NA} at every #' level is left out with a log line rather than drawn empty. #' +#' A profile whose ladder is one size (\code{obs_per_cell} set to one +#' number, or the default profile) has one level, set by the size. Each +#' criterion that is finite there is drawn as one point in its panel, with +#' no selected level and no band, and the caption says that the size set +#' the count. +#' #' @param x A \code{resolution_profile}. #' @param criteria Character vector of criteria to draw, any of -#' \code{"cp"}, \code{"reliability"}, \code{"elbow"}, \code{"moran_z"}, -#' \code{"wss"}. Default: every one of the four selectable criteria that -#' is finite at some level. \code{"wss"} is the raw curve behind -#' \code{"elbow"} and has no selected point. +#' \code{"cp"}, \code{"reliability"}, \code{"elbow"}, \code{"loo"}, +#' \code{"moran_z"}, \code{"wss"}. Default: the first five, each where it +#' is finite at some level. \code{"cp"}, \code{"reliability"}, +#' \code{"elbow"} and \code{"loo"} (the leave-one-out error of the +#' estimate the profile was built for; a profile built without +#' \code{estimate} has no such column, and a column of that name added +#' to one is drawn only when named here) are count criteria and get a +#' selected level and a shaded band. \code{"moran_z"} +#' is a diagnostic of the cell means and not a count rule (see +#' \code{\link{select_resolution}()}), and \code{"wss"} is the raw curve +#' behind \code{"elbow"}: both are drawn as curves with no selected point. #' @param tol Passed to \code{\link{select_resolution}()} for the flat region. #' @param ... Ignored. #' @return A \code{ggplot} object. @@ -662,10 +718,23 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { stop("plot.resolution_profile(): `x` has no levels to draw; it is an ", if (nrow(x) == 0L) "empty" else "incomplete", " subset of a resolution profile.", call. = FALSE) - selectable <- c("cp", "reliability", "elbow", "moran_z") - allowed <- c(selectable, "wss") + # The count criteria get a selected level and a band. moran_z is drawn by + # default as well, as a curve only: select_resolution() refuses to read a + # count from it unless asked with diagnostic = TRUE. + # `loo` is drawn like the other count criteria where it is the column + # resolution_profile() wrote. A profile built without an estimate has + # none, and a column of that name a caller added to it is drawn only when + # named (.loo_by_default()), so its plot is the one it always was. + selectable <- c("cp", "reliability", "elbow", "loo") + by_default <- c(selectable, "moran_z") + allowed <- c(by_default, "wss") + # A ladder of one size is one level, set by the size: nothing was chosen + # among levels, so no level is marked and no band is drawn. + bounds <- attr(x, "bounds") + one_size <- is.list(bounds) && length(bounds$obs_per_cell) == 1L if (is.null(criteria)) { - criteria <- selectable[vapply(selectable, function(cn) + read <- if (.loo_by_default(x)) by_default else setdiff(by_default, "loo") + criteria <- read[vapply(read, function(cn) any(is.finite(suppressWarnings(as.numeric(x[[cn]])))), logical(1))] if (!length(criteria)) criteria <- "wss" } @@ -685,7 +754,8 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { labels <- c(cp = "Mallows' Cp (lower is better)", reliability = "Reliability of cell means (higher is better)", elbow = "WSS elbow statistic (higher is better)", - moran_z = "|Moran's z| of cell means (lower is better)", + loo = "Leave-one-out error (lower is better)", + moran_z = "|Moran's z| of cell means (a diagnostic, not a count rule)", wss = "Within-cluster sum of squares") rows <- list(); chosen <- list(); flat <- list(); notes <- character(0) skipped <- character(0) @@ -700,7 +770,7 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { if (!any(ok)) { skipped <- c(skipped, cn); next } rows[[cn]] <- data.frame(panel = labels[[cn]], x = lv[ok], y = v[ok], stringsAsFactors = FALSE) - if (cn %in% selectable) { + if (cn %in% selectable && !one_size) { sel <- try(select_resolution(x, criterion = cn, tol = tol), silent = TRUE) if (!inherits(sel, "try-error")) { chosen[[cn]] <- data.frame(panel = labels[[cn]], x = sel$best, @@ -726,19 +796,34 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { .log_info("plot.resolution_profile(): %s NA at every level; not drawn.", paste(skipped, collapse = ", ")) df <- do.call(rbind, rows) - bounds <- attr(x, "bounds") subtitle <- if (is.list(bounds)) sprintf("%d levels from %d to %d cells (floor %s, ceiling %s)%s", nrow(x), min(lv), max(lv), if (is.finite(bounds$floor %||% NA)) format(bounds$floor) else "none", if (is.finite(bounds$ceiling %||% NA)) format(bounds$ceiling) else "none", - if (isTRUE(bounds$supported)) "" else "; the floor exceeds the ceiling") + # Why a profile is not supported, as its bounds record it: "the + # floor exceeds the ceiling" was also said of a layer with fewer + # than two cells at min_cell_n, under "floor 2, ceiling 2". + if (isTRUE(bounds$supported)) "" + else if (identical(bounds$ceiling_from, "fewer than two supported cells")) + sprintf("; fewer than two cells meet min_cell_n = %s", format(bounds$min_cell_n)) + else if (identical(bounds$ceiling_from, "fewer than two cells of the size")) + "; fewer than two cells of the size asked for" + else "; the floor exceeds the ceiling") else NULL - caption <- paste(c("Red: the level each criterion selects; shaded: within tolerance of its optimum", - notes), collapse = "\n") + caption <- if (one_size) + sprintf(paste0("the ladder is one size (obs_per_cell = %s); the count is set by the ", + "size,\nand no criterion chooses among levels."), + format(as.numeric(bounds$obs_per_cell))) + else paste(c("Red: the level each criterion selects; shaded: within tolerance of its optimum", + notes), collapse = "\n") + # One point has no line through it: ggplot2 draws nothing for one and says + # so, once a panel, each time the plot is printed. Every other profile, a + # one-level profile on another ladder included, keeps its line layer. .plot_sweep(df, chosen = do.call(rbind, chosen), flat = do.call(rbind, flat), title = "Resolution profile", subtitle = subtitle, caption = caption, - x_lab = "Number of cells", y_lab = NULL, log_x = log_x) + x_lab = "Number of cells", y_lab = NULL, log_x = log_x, + connect = !one_size) } @@ -759,6 +844,12 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { #' was computed (\code{select_on = "split"}) it is drawn as a separate mark #' at the final step and named in the caption. #' +#' With a learner that cannot fit an empty predictor set the first variable +#' is added without a test and can be dropped at the end +#' (\code{baseline$first$dropped}). The path drawn is then the one the sweep +#' walked, with that variable hollow and labelled "dropped at the end", and +#' the red mark is the selected set, scored without it. +#' #' @param x The list returned by \code{\link{select_features_forward}()}. #' @param ... Ignored. #' @return A \code{ggplot} object. @@ -795,8 +886,16 @@ plot.feature_selection <- function(x, ...) { minimise <- !(metric %in% c("R2", "Adj_R2")) selected <- x$selected n_sel <- length(selected) + # The path the sweep walked. It is the selection, unless the first + # variable was added without a test (a fold-mean baseline) and dropped at + # the end: `selected` is then the path without it, and matching + # selected[s] to step s would draw sets that were never on the path. + first_dropped <- isTRUE(x$baseline$first$dropped) && + length(x$baseline$path) == n_sel + 1L + walked <- if (first_dropped) x$baseline$path else selected + n_walk <- length(walked) - # The accepted variable at step s is selected[s]; the path runs through + # The accepted variable at step s is walked[s]; the path runs through # its score. Steps past n_sel were scored and rejected (nothing cleared # tol), and their best candidate is drawn as part of the path too, so the # stop is visible as a flattening rather than as a cut -- but hollow and @@ -808,18 +907,27 @@ plot.feature_selection <- function(x, ...) { for (s in sort(unique(h$step))) { idx <- which(h$step == s) if (s == 0L) { pick <- idx[1L] } - else if (s <= n_sel) { pick <- idx[match(selected[s], h$variable[idx])] } + else if (s <= n_walk) { pick <- idx[match(walked[s], h$variable[idx])] } else { pick <- idx[if (minimise) which.min(h$score[idx]) else which.max(h$score[idx])] } if (length(pick) == 1L && !is.na(pick)) path_rows <- c(path_rows, pick) } - rejected <- path_rows[h$step[path_rows] > n_sel] + rejected <- path_rows[h$step[path_rows] > n_walk] h$role[path_rows] <- "path" h$role[rejected] <- "rejected" h$label[path_rows] <- h$variable[path_rows] h$label[rejected] <- paste(h$variable[rejected], "(not added)") + if (first_dropped) { + undone <- path_rows[h$step[path_rows] == 1L] + h$role[undone] <- "rejected" + h$label[undone] <- paste(h$variable[undone], "(dropped at the end)") + } df <- data.frame(panel = metric, x = h$step, y = as.numeric(h$score), role = h$role, label = h$label, stringsAsFactors = FALSE) - chosen <- if (n_sel > 0L && n_sel %in% h$step) { + sel_score <- suppressWarnings(as.numeric(x$score %||% NA_real_)) + chosen <- if (first_dropped && length(sel_score) == 1L && is.finite(sel_score)) { + # The selected set is not a step of the walk; its own score marks it. + data.frame(panel = metric, x = n_sel, y = sel_score) + } else if (n_sel > 0L && n_sel %in% h$step) { i <- path_rows[h$step[path_rows] == n_sel] data.frame(panel = metric, x = n_sel, y = as.numeric(h$score[i[1L]])) } else data.frame(panel = character(0), x = numeric(0), y = numeric(0)) @@ -833,6 +941,9 @@ plot.feature_selection <- function(x, ...) { else "The intercept-only model could not be scored, so the path starts at the first variable", if (n_sel == 0L) "Nothing was selected" else sprintf("Selected: %s", paste(selected, collapse = ", ")), + if (first_dropped) + sprintf(paste0("%s was added first without a test and dropped at the end;\n", + "red marks the selected set, scored without it"), walked[1L]), if (is.finite(holdout)) sprintf("Blue: hold-out score of the selected set on the estimation half (%.3g)", holdout) ), collapse = "\n") @@ -869,8 +980,7 @@ plot.feature_selection <- function(x, ...) { #' @return A \code{ggplot} object. #' @family plotting #' @examples -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE) && +#' if (requireNamespace("sp", quietly = TRUE) && #' requireNamespace("ggplot2", quietly = TRUE)) { #' library(sf) #' set.seed(1) diff --git a/R/plotting-fits.R b/R/plotting-fits.R index ebe63bc4..e5039e9f 100644 --- a/R/plotting-fits.R +++ b/R/plotting-fits.R @@ -73,10 +73,8 @@ #' The distance axis is labelled in the units of the CRS the variogram #' was actually fitted in, which is not necessarily the fit's own CRS #' (lon/lat data are projected first). Each curve is the variogram -#' \code{estimate_sac_range()} returns for its variable: all point pairs, -#' or, when the all-pairs fit was unusable, the widest of four directions, -#' which is named with its azimuth (in the title for the residuals, in the -#' caption for the response). A fit that identified no range says why in +#' \code{estimate_sac_range()} returns for its variable, which is over +#' all point pairs. A fit that identified no range says why in #' the subtitle, since the overlaid model line is then not a fit to believe. #' Requires 'gstat'.} #' \item{\code{"coefficients"}}{For a GWR fit only: the local coefficient @@ -85,8 +83,10 @@ #' collinear for that term are drawn hollow and grey #' (\code{mask = TRUE}): for a slope, where the kernel-weighted #' window's slope condition index (\code{cn_slopes}, predictors -#' centred in the window) is above 30 or the window is singular, or -#' where the index with the intercept (\code{cn}) is above 1e6; for +#' centred in the window) is above 30 or the window is singular; a +#' predictor far from zero is not masked, because the local solve +#' centres each window and the index with the intercept (\code{cn}) +#' does not enter; for #' the Intercept, where \code{cn} is above 30 (a predictor far from 0 #' against its local spread makes the local intercept an #' extrapolation). They are masked because the smooth surface a naive map draws @@ -283,7 +283,10 @@ plot.spatial_fit <- function(x, type = c("residuals", "observed_predicted", # map of a temperature in kelvin, identical to the one in degrees C that # was drawn. A fit made before `cn_slopes` existed falls back to `cn`. is_intercept <- identical(term, "Intercept") && !("Intercept" %in% x$predictor_vars) - cn_bad <- if (is.data.frame(lc) && nrow(lc) == nrow(dat)) { + # A fit with no predictors has a local intercept and nothing it could be + # collinear with: the map is of local means, and nothing is masked. + cn_bad <- if (!length(x$predictor_vars)) rep(FALSE, nrow(dat)) + else if (is.data.frame(lc) && nrow(lc) == nrow(dat)) { if (is_intercept) (!is.finite(lc$cn) | lc$cn > 30) else .gwr_slopes_collinear(lc) } else rep(FALSE, nrow(dat)) @@ -362,8 +365,11 @@ plot.spatial_fit <- function(x, type = c("residuals", "observed_predicted", #' rather than refused. #' #' Nothing is recomputed: the plot reads the \code{variogram}, -#' \code{variogram_model}, \code{crs}, \code{directional} and -#' \code{anisotropy_used} attributes the estimate already carries. The +#' \code{variogram_model}, \code{crs} and \code{rejected_reason} +#' attributes the estimate already carries. The variogram is the one over +#' all point pairs; a result stored by an earlier version, whose range could +#' be that of the widest of four directions (\code{anisotropy_used} +#' \code{TRUE}), is titled with its azimuth. The #' distance axis is in the units of the CRS the variogram was actually fitted #' in, which \code{estimate_sac_range()} may have chosen itself for lon/lat #' input. @@ -453,11 +459,13 @@ plot.sac_range <- function(x, ...) { if (is.null(u) || is.na(u) || !nzchar(u)) "CRS units" else u }, error = function(e) "CRS units") - # Which variogram is this? When anisotropy was established, - # estimate_sac_range() returns the single azimuth with the widest range -- - # about a quarter of the point pairs -- and calling that plainly by `what` - # overstates the structure for the plot whose whole purpose is to show how - # much there is. NA: all pairs; "": one direction, azimuth unknown. + # Which variogram is this? estimate_sac_range() returns the all-pairs + # variogram and sets anisotropy_used to FALSE. An object stored by an + # earlier version can carry TRUE: its range was that of the single azimuth + # with the widest range -- about a quarter of the point pairs -- and + # calling that plainly by `what` overstates the structure for the plot + # whose whole purpose is to show how much there is. NA: all pairs; "": + # one direction, azimuth unknown. azimuth_of <- function(s) { if (!isTRUE(attr(s, "anisotropy_used"))) return(NA_character_) dir_r <- attr(s, "directional") @@ -506,9 +514,8 @@ plot.sac_range <- function(x, ...) { linewidth = 0.8) } # Each curve is whichever variogram estimate_sac_range() returned for its - # variable: all pairs, or the widest single direction when the all-pairs - # fit was unusable -- which a response carrying a trend often is while - # its residuals are not. The overlay was labelled plainly as the + # variable: all pairs, or, on an object stored by an earlier version, the + # widest single direction. The overlay was labelled plainly as the # response whichever it was, and its sill and range set against an # all-pairs residual curve over four times as many pairs. ov_az <- azimuth_of(overlay) @@ -525,8 +532,8 @@ plot.sac_range <- function(x, ...) { s_res <- sill_of(vm); s_resp <- sill_of(ovm) both_ok <- same_pairs && is.finite(sac) && is.finite(overlay) && is.finite(s_res) && is.finite(s_resp) && s_resp > 0 - # A range can be missing for several reasons (no sill within the lags, a - # fit that did not converge, a falling or flat variogram), so the clause + # A range can be missing for several reasons (no sill within the lags, no + # spatial structure, a falling or flat variogram), so the clause # says only that none was identified. "Reached no identified sill" # described every case as a still-rising curve. The residual reason is # in the subtitle; the response's appears nowhere else, so it is named. @@ -567,23 +574,25 @@ plot.sac_range <- function(x, ...) { } else if (!is.null(attr(sac, "rejected_range"))) { # A variogram that never reaches a sill is the single most useful thing to # SEE, so draw it and label why no range is marked, rather than refusing. - # estimate_sac_range() records WHICH of two reasons applied; hard-coding - # the sill wording for both captioned a non-converged fit with a sentence - # its own two numbers refute (range 11 "exceeds" a cutoff of 682). + # estimate_sac_range() records WHICH reason applied; hard-coding the sill + # wording for all of them captioned a refusal with a sentence its own two + # numbers refute (range 11 "exceeds" a cutoff of 682). reason <- attr(sac, "rejected_reason") p <- p + ggplot2::labs( subtitle = .wrap_label( if (identical(reason, "variogram model did not converge")) + # Not produced any more: a result stored by a version that fitted + # the model with gstat's iterative fit can carry it. sprintf(paste0("No effective range: the fit stopped at gstat's ", "iteration limit, so the range it reports (%.0f) is ", "where the optimiser halted, not a fitted parameter."), attr(sac, "rejected_range")) else if (isTRUE(grepl("^no variogram model", reason))) - # Both model fits singular: the picture of residuals with no spatial - # structure at the lags resolved. There is no model line to draw. + # Fewer than three lag bins hold point pairs, so nothing was + # fitted and there is no model line to draw. (A flat variogram + # has a reason of its own and is captioned with it, below.) paste0("No effective range: no variogram model could be fitted ", - "(a flat, nugget-only variogram -- no spatial structure at ", - "these lags).") + "(fewer than three lag bins hold point pairs).") else if (identical(reason, "empirical variogram decreases with distance")) # The shape of a periodic structure or of a variance that differs # between a dense cluster and the rest -- not of a trend, which rises @@ -653,7 +662,8 @@ plot.sac_range <- function(x, ...) { #' the parameter that decides whether the scheme leaks, read from #' \code{folds$params}: the block size (and the estimated range when #' \code{auto_range} found one), the buffer, the number of location groups, -#' or the median NNDM exclusion. +#' the median NNDM exclusion, or, for kNNDM folds, that they are matched to +#' the prediction distances. #' #' @param folds A list returned by \code{make_folds()}. #' @param points_sf The \code{sf} layer the folds were built from. @@ -802,5 +812,6 @@ plot_folds <- function(folds, points_sf, boundary = NULL, blocks = TRUE) { sprintf("Distance-matched exclusion, median %s%s", num(prm$median_buffer), units) else "Distance-matched exclusion (NNDM)", + knndm = "k folds matched to the distances from the prediction points (kNNDM)", NULL) } diff --git a/R/plotting.R b/R/plotting.R index 09beb245..f46b348a 100644 --- a/R/plotting.R +++ b/R/plotting.R @@ -65,10 +65,12 @@ #' coords = c("x", "y"), crs = 32632 #' ) #' # Cells from the points, the response aggregated onto them, and the map -#' # shaded by the cell mean rather than by an arbitrary ID. +#' # shaded by the cell mean rather than by an arbitrary ID. Each cell +#' # holds one point, so there is nothing to pool: estimate = "mean". #' tess <- build_tessellation(pts, method = "voronoi", quiet = TRUE) #' cells <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), -#' response_var = "z", cells_sf = tess$cells) +#' response_var = "z", cells_sf = tess$cells, +#' estimate = "mean") #' plot_tessellation_map(cells, features_sf = pts, fill_col = "resp_mean_z", #' legend_title = "mean z") #' } diff --git a/R/pool.R b/R/pool.R new file mode 100644 index 00000000..6cc5ca77 --- /dev/null +++ b/R/pool.R @@ -0,0 +1,1027 @@ +# ============================================================================= +# Region values pooled toward their neighbours: the engine. +# +# For one column, with its rows in regions 1..K. A region's plain mean is +# m_j = S_j / n_j. Its pooled value is +# +# L_j = w_j m_j + (1 - w_j) t_j +# +# t_j the target: the mean of the rows of the 8 regions whose centroids +# are nearest region j's (all the other regions when there are +# fewer than 9), region j itself never among them +# sigma2 the spread of the rows about their region's mean, +# sum (y_i - m_g(i))^2 / (N - K) +# tau2 the mean squared distance between a region's level and its +# target, max(0, (Q - K sigma2) / N) with Q = sum n_j (m_j - t_j)^2; +# the target's own error is part of it +# w_j the own weight, tau2 / (tau2 + sigma2 / n_j): it grows with the +# region's count +# +# Both estimates have a leave-one-out error: each row predicted by the value +# of its region with that row taken out, sigma2, tau2, the centroids, the +# neighbours and the targets held. +# +# .pool_fit() is the one place this arithmetic is written. Its expressions +# are held, bit for bit, to the reference functions in +# tests/testthat/helper-pool-reference.R, so an edit that reorders a sum is a +# change of result. .pool_column() prepares one column of an assigned layer +# for it. Everything in this file is internal. +# +# Two things the result must not depend on, and how each is kept out: +# +# the order of the rows The centroids are summed with the rows in +# coordinate order, and a row's nearest other row +# is found through the distinct locations in that +# order. Sums of the response are taken in the +# rows' own order, which moves a result in its last +# bits and no further. +# whether FNN is there Every search has an exact path in base R, and the +# kd-tree path returns the same answer to the last +# bit: a row whose candidates tie is searched again +# by the exact rule. +# ============================================================================= + +# Regions in a target. +.POOL_NEIGHBOURS <- 8L + +# Rows per region: the size a count is set by when none is given, and the +# sizes of a ladder of sizes, coarsest first. +.OBS_PER_CELL_DEFAULT <- 4.5 +.OBS_PER_CELL_LADDER <- c(18, 12, 9, 6, 4.5, 3, 2) + +# Relative difference up to which two leave-one-out errors, computed at two +# ends of the pipeline on the same rows and regions, are the same number. +.RECORD_TOL <- 1e-8 + +# An interval's ends are called unstable when fewer residuals than this are +# expected beyond each of them. +.FEW_RESIDUALS <- 5 + +# sigma2 is called unstable when it rests on fewer values beyond one per +# region than this. +.POOL_MIN_DF <- 30L + +# Regions beat one mean for all rows when the one mean's leave-one-out error +# is above theirs by more than this fraction. +.STRUCTURE_TOL <- 0.02 + +# The most pairs an exact search compares, unless +# options(spatialkit.exact_pairs_max = ) sets another number +# (.exact_pairs_max()), and the most point-to-centre comparisons of a +# partition fit at a fixed size. +.EXACT_PAIRS_MAX <- 2e9 +.FIT_WORK_MAX <- 1e10 + + +# ----------------------------------------------------------------------------- +# Backends and the bound on exact searches +# ----------------------------------------------------------------------------- + +#' Whether an optional package can be loaded +#' +#' How the code in this file asks whether \pkg{FNN} is there. The answer is +#' passed down as \code{use_fnn}, so replacing this one function switches the +#' backend off for a whole call. +#' +#' @param pkg Package name. +#' @return \code{TRUE} or \code{FALSE}. +#' @keywords internal +#' @noRd +.has_backend <- function(pkg) requireNamespace(pkg, quietly = TRUE) + + +#' The most pairs an exact search may compare +#' +#' @return \code{getOption("spatialkit.exact_pairs_max")}, or +#' \code{.EXACT_PAIRS_MAX} when the option is not set. A value that is not +#' one number of pairs is an error and not a silent return to the default. +#' @keywords internal +#' @noRd +.exact_pairs_max <- function() { + lim <- getOption("spatialkit.exact_pairs_max", .EXACT_PAIRS_MAX) + if (!is.numeric(lim) || length(lim) != 1L || is.na(lim) || lim < 0) + stop("options(spatialkit.exact_pairs_max = ) must be a single number of pairs, ", + "0 or more; got ", + if (length(lim) != 1L) sprintf("%s of length %d", class(lim)[1L], length(lim)) + else if (is.numeric(lim)) format(lim) else class(lim)[1L], + ".", call. = FALSE) + as.numeric(lim) +} + + +#' Stop before an exact search that would compare too many pairs +#' +#' An exact search compares every row asked for with every candidate, so its +#' cost is a product the caller knows before it starts. Above the limit the +#' call stops, with an error of class \code{spatialkit_work_limit} that names +#' the search, the product, the limit and the way on. +#' +#' @param work The number of pairs the search would compare. +#' @param limit The most it may compare: \code{.exact_pairs_max()}. +#' @param what A short name of the search, kept in the condition's +#' \code{what} field. +#' @param caller Name of the exported function, for the message. +#' @param remedy The message's last sentence. +#' @param search The search in the words of the message; \code{what} when not +#' given. +#' @param data Further fields for the condition, as a named list. +#' @return \code{NULL}, invisibly, when \code{work} is within \code{limit}. +#' @keywords internal +#' @noRd +.work_guard <- function(work, limit, what, caller, + remedy = "Install FNN: the result is the same.", + search = what, data = list()) { + if (!(work > limit)) return(invisible(NULL)) + msg <- sprintf(paste0("%s(): %s would compare %.2g pairs without the FNN package, above ", + "the limit of %.2g (options(spatialkit.exact_pairs_max = )). %s"), + caller, search, work, limit, remedy) + stop(do.call(errorCondition, + c(list(message = msg, class = "spatialkit_work_limit", call = NULL, + work = as.numeric(work), limit = as.numeric(limit), what = what), + data))) +} + + +# ----------------------------------------------------------------------------- +# Small pieces of the arithmetic +# ----------------------------------------------------------------------------- + +#' The weight a pooled value gives the region's own mean +#' +#' @param tau2 Mean squared distance between a region's level and its target. +#' @param v Variance of the region's own mean, \code{sigma2 / n}. +#' @return \code{tau2 / (tau2 + v)}; 1 where both are 0. +#' @keywords internal +#' @noRd +.pool_weight <- function(tau2, v) ifelse(tau2 + v > 0, tau2 / (tau2 + v), 1) + + +#' Whether a sum of squares is rounding error on the scale of the values +#' +#' The test \code{resolution_profile()} applies to a constant response. A +#' column with no spread still has a sum of squares above zero when its value +#' is not exact in binary (0.1, 1/3), and dividing one such sum by another +#' gives weights that mean nothing. +#' +#' @param ss A sum of squared deviations of \code{y}. +#' @param y The values. +#' @return \code{TRUE} when \code{ss} is at most +#' \code{100 * .Machine$double.eps^2 * sum(y^2)}. +#' @keywords internal +#' @noRd +.no_spread <- function(ss, y) ss <= 100 * .Machine$double.eps^2 * sum(y^2) + + +#' The sum of squares inside the regions, about means without the rounding of +#' their sums +#' +#' A region's mean is its sum over its count, and a sum of values that are +#' not exact in binary is off by a rounding error that grows with the count. +#' In a region of 500 rows that all hold 0.1 the mean is not 0.1, and the sum +#' of squares about it is that error and not zero: above 100 rows or so it +#' passes the bound of \code{.no_spread()}, and a column with no spread +#' inside any region would be fitted as if it had some. Here each mean is +#' corrected by the mean of the residuals about it, which is how +#' \code{mean()} corrects its own sum, and the squares are taken about the +#' corrected means. The result is never above the sum about the uncorrected +#' means by more than rounding. +#' +#' @param res The rows' residuals about their region's mean, \code{y - m[gi]}. +#' @param gi Region of each row, \code{1..K}. +#' @param n Rows per region. +#' @return One number. +#' @keywords internal +#' @noRd +.ss_within <- function(res, gi, n) sum((res - (as.numeric(rowsum(res, gi)) / n)[gi])^2) + + +#' A coordinate matrix as the searches need it +#' +#' The kd-tree is handed every column of the matrix it is given, and the +#' exact search and the tie rule read the first two. A third column (a +#' height, a part number) would therefore give one answer with \pkg{FNN} and +#' another without, so it is refused and not dropped. Whole-number storage +#' is made double: \code{rowsum()} of integers returns \code{NA} without a +#' warning once a sum passes \code{.Machine$integer.max}. +#' +#' @param xy The matrix. +#' @param rows The number of rows it must have, or \code{NULL} for any. +#' @param who Name of the calling function, for the message. +#' @param arg Name of the argument, for the message. +#' @return \code{xy} as a matrix of doubles. +#' @keywords internal +#' @noRd +.pool_xy <- function(xy, rows, who, arg = "xy") { + if (!is.matrix(xy) || !is.numeric(xy) || ncol(xy) != 2L || + (!is.null(rows) && nrow(xy) != rows)) + stop(sprintf("%s(): `%s` must be a numeric matrix with two columns%s.", who, arg, + if (is.null(rows)) "" else " and one row per value"), call. = FALSE) + if (!is.double(xy)) storage.mode(xy) <- "double" + xy +} + + +#' The number of regions a size gives +#' +#' @param n Number of rows the size divides. +#' @param obs_per_cell Rows per region. +#' @return \code{n / obs_per_cell} rounded as R rounds (a half goes to the +#' even number), and at least 2. +#' @keywords internal +#' @noRd +.count_at <- function(n, obs_per_cell) pmax(2L, as.integer(round(n / obs_per_cell))) + + +#' The two offsets of the interval for one observation +#' +#' Quantiles of the leave-one-out residuals at \code{(1 - level) / 2} and its +#' complement. The probability is rounded to 12 places: \code{(1 - 0.9) / 2} +#' is \code{0.04999999999999999} in floating point, and a quantile taken +#' there differs in its last bits from the one at 0.05. +#' +#' @param e Leave-one-out residuals. +#' @param level The level of the interval, strictly between 0 and 1. +#' @return \code{c(lo, hi)}, to be added to a region's value; two \code{NA} +#' when there are fewer than two residuals or one is missing. +#' @keywords internal +#' @noRd +.obs_offsets <- function(e, level) { + if (length(e) < 2L || anyNA(e)) return(c(NA_real_, NA_real_)) + p <- round((1 - level) / 2, 12) + stats::quantile(e, c(p, 1 - p), names = FALSE, type = 7) +} + + +#' Whether regions predict a left-out row better than one mean for all rows +#' +#' Two things have to hold. The leave-one-out error of one mean is above +#' the regions' by more than \code{tol}; and the region means differ from one +#' mean by more than chance, by an F test at 5 percent after a Bonferroni +#' adjustment for the levels the count was searched over. The first alone +#' has no sampling error in it. This is the rule \code{select_resolution()} +#' applies to \code{cp}, with the leave-one-out error in its place. +#' +#' @param loo Leave-one-out error of the regions' values. +#' @param loo_one The same error with one mean for all rows. +#' @param p The p-value of the F test of the region means against one mean. +#' @param tol The margin, as a fraction of \code{loo}. +#' @param n_searched Number of levels the count was searched over. +#' @return A list: \code{structured} (\code{TRUE}, \code{FALSE}, or \code{NA} +#' when an error is not finite, or when the regions beat one mean and there +#' is no p-value), \code{structure_p} (the adjusted p-value) and +#' \code{beats} (the first condition alone). +#' @keywords internal +#' @noRd +.no_structure <- function(loo, loo_one, p, tol, n_searched = 1L) { + if (!length(p)) p <- NA_real_ + p_adj <- min(1, p * n_searched) + beats <- !(loo_one <= loo * (1 + tol)) + structured <- + if (!is.finite(loo) || !is.finite(loo_one)) NA + else if (!beats || (is.finite(p_adj) && p_adj >= 0.05)) FALSE + else if (is.finite(p_adj)) TRUE + else NA + list(structured = structured, structure_p = p_adj, beats = beats) +} + + +#' Column names in the words of a warning +#' +#' @param cols Character vector of names. +#' @return One string: \code{'a'}; \code{'a' and 'b'}; \code{'a', 'b' and +#' 'c'}; beyond six names the first six and the number of the rest, +#' \code{'a', 'b', 'c', 'd', 'e', 'f' and 4 more}. +#' @keywords internal +#' @noRd +.cols_text <- function(cols) { + q <- sprintf("'%s'", cols) + k <- length(q) + if (k == 0L) return("") + if (k == 1L) return(q) + if (k <= 6L) return(paste(paste(q[-k], collapse = ", "), "and", q[k])) + sprintf("%s and %d more", paste(q[1:6], collapse = ", "), k - 6L) +} + + +# ----------------------------------------------------------------------------- +# Neighbours of the regions +# ----------------------------------------------------------------------------- + +#' The regions whose centroids are nearest each region's +#' +#' The centroids are put in coordinate order (first coordinate, then second), +#' searched, and the result mapped back to the regions' numbers. A tie +#' between two candidates therefore goes to the lower first coordinate, then +#' the lower second, whatever the regions are numbered. Regions whose +#' centroids coincide exactly are told apart by their number, the one place +#' the numbering decides anything. A region is never its own neighbour. +#' +#' A centroid that shares its point with \code{k} others or more is not +#' searched for at all: its neighbours are the first \code{k} of them in that +#' order, all at distance 0. That is what a search returns for it, and it +#' keeps a layer whose regions lie on one point by the thousand (rows that +#' carry the coordinates of a coarser unit, or a placeholder) from costing +#' the square of their number: a kd-tree asked about such a centroid has to +#' list every other one on its point before it can tell which come first. +#' +#' For the rest, with \pkg{FNN} the kd-tree returns one neighbour more than +#' is wanted, where there are that many other regions (ten regions or more +#' for eight neighbours), and R recomputes the squared distances. A row is +#' settled when it is not among its own neighbours and its distances rise by +#' more than one part in a thousand million from each neighbour to the next; +#' it keeps the tree's first \code{k}. Every other row is searched again by +#' \code{.knn_tied_rows()}, by distance and then by row, which is the rule of +#' the exact search. Without \pkg{FNN} each of them is searched exactly, +#' which compares it with every centroid; the pairs that makes, the rows +#' searched for times the centroids, are what \code{.work_guard()} stops +#' above the limit. The two paths return the same matrix. +#' +#' @param cen Two-column matrix of centroids, one row per region. +#' @param k Number of neighbours wanted. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @param caller Name of the exported function, for the work guard's message. +#' @return An integer matrix with a row per region and \code{min(k, K - 1)} +#' columns, nearest first. +#' @keywords internal +#' @noRd +.region_neighbours <- function(cen, k, use_fnn, caller = "resolution_profile") { + cen <- .pool_xy(cen, NULL, ".region_neighbours", "cen") + K <- nrow(cen) + k <- min(as.integer(k), K - 1L) + if (k < 1L) return(matrix(0L, K, 0L)) + o <- order(cen[, 1L], cen[, 2L]) + u <- unname(cen[o, , drop = FALSE]) + x <- u[, 1L]; y <- u[, 2L] + # Centroids on one point stand together in this order, lowest number first. + first <- c(TRUE, x[-1L] != x[-K] | y[-1L] != y[-K]) + run <- cumsum(first) + from <- which(first)[run] # where each centroid's point starts + many <- tabulate(run)[run] > k # k others or more on its own point + idx <- matrix(0L, K, k) + if (any(many)) { + # The first k + 1 of the point, less the centroid itself when it is one. + at <- which(many) + j <- matrix(rep(seq_len(k) - 1L, each = length(at)), length(at), k) + idx[at, ] <- from[at] + j + (j >= at - from[at]) + } + rest <- which(!many) + if (!isTRUE(use_fnn)) { + .work_guard(as.numeric(length(rest)) * K, .exact_pairs_max(), what = "cell neighbours", + caller = caller, + search = sprintf("finding each cell's neighbours among %d cells", K)) + idx[rest, ] <- .knn_exact_rows(x, y, rest, k) + } else if (length(rest)) { + kq <- min(k + 1L, K - 1L) + nn <- matrix(FNN::get.knn(u, k = kq)$nn.index, K, kq)[rest, , drop = FALSE] + d2 <- matrix((x[nn] - x[rest])^2 + (y[nn] - y[rest])^2, length(rest), kq) + own <- rowSums(nn == rest) > 0L + tied <- if (kq > 1L) + rowSums(d2[, -1L, drop = FALSE] <= d2[, -kq, drop = FALSE] * (1 + 1e-9)) > 0L + else rep(FALSE, length(rest)) + idx[rest, ] <- nn[, seq_len(k), drop = FALSE] + redo <- rest[own | tied] + if (length(redo)) idx[redo, ] <- .knn_tied_rows(u, redo, k) + } + out <- matrix(0L, K, k) + out[o, ] <- o[idx] + out +} + + +#' Centroids of the regions and each region's neighbours +#' +#' The centroid of a region is the mean of the coordinates of its rows. The +#' rows are summed in coordinate order, so the centroids are the same numbers +#' to the last bit whatever order the rows come in. On gridded locations +#' that is what keeps the neighbours fixed: summed in row order the centroids +#' of a lattice differ in their last bits from one row order to the next, and +#' exact ties between them fall differently. +#' +#' @param gi Region of each row, \code{1..K}. +#' @param K Number of regions. +#' @param xy Two-column matrix of the rows' coordinates; any other number of +#' columns is an error. +#' @param n Rows per region. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @param caller Name of the exported function, for the work guard's message. +#' @return A list: \code{cen} (a \code{K x 2} matrix) and \code{nb} (the +#' matrix of \code{.region_neighbours()} for \code{.POOL_NEIGHBOURS} +#' neighbours). It depends on the rows and their regions and not on the +#' values, so one serves every column that has the same rows. +#' @keywords internal +#' @noRd +.pool_geometry <- function(gi, K, xy, n, use_fnn, caller = "resolution_profile") { + xy <- .pool_xy(xy, length(gi), ".pool_geometry") + o <- order(xy[, 1L], xy[, 2L]) + cen <- rowsum(xy[o, , drop = FALSE], gi[o]) / n + list(cen = cen, nb = .region_neighbours(cen, .POOL_NEIGHBOURS, use_fnn, caller)) +} + + +# ----------------------------------------------------------------------------- +# The nearest other row +# ----------------------------------------------------------------------------- + +#' For chosen locations, the nearest other location, searched +#' +#' With \pkg{FNN} the kd-tree returns the three nearest locations of each one +#' asked for, itself among them, and R recomputes the squared distances. A +#' location is settled when it is one of its own three and its two nearest +#' others differ by more than one part in a thousand million. Every other +#' location is searched again by \code{.knn_tied_rows()}, which settles a tie +#' by row, so a lattice costs no comparison of every pair. Without \pkg{FNN} +#' the search is exact and is stopped by \code{.work_guard()} above the +#' limit. The two paths return the same locations. +#' +#' @param u Two-column matrix of distinct locations in coordinate order, at +#' least two. +#' @param q The locations to search for, as rows of \code{u}. +#' @param use_fnn Whether to use \pkg{FNN}. +#' @param caller Name of the exported function, for the work guard's message. +#' @return For each of \code{q} the row of \code{u} nearest it and not it; a +#' tie goes to the lower row, which is the lower first coordinate and then +#' the lower second. +#' @keywords internal +#' @noRd +.nearest_location_search <- function(u, q, use_fnn, caller = "resolution_profile") { + U <- nrow(u) + nq <- length(q) + if (!isTRUE(use_fnn)) { + .work_guard(as.numeric(nq) * U, .exact_pairs_max(), what = "nearest other location", + caller = caller, + search = sprintf("finding the nearest other location of %d of %d locations", + nq, U)) + return(.knn_exact_rows(u[, 1L], u[, 2L], q, 1L)[, 1L]) + } + kq <- min(3L, U) + nn <- matrix(FNN::get.knnx(u, u[q, , drop = FALSE], k = kq)$nn.index, nq, kq) + d2 <- matrix((u[nn, 1L] - u[q, 1L])^2 + (u[nn, 2L] - u[q, 2L])^2, nq, kq) + own <- nn == q + d2[own] <- Inf + at <- cbind(seq_len(nq), max.col(-d2, ties.method = "first")) + best <- d2[at] + out <- nn[at] + d2[at] <- Inf + # The nearest of what is left: the second nearest other location, when the + # three hold one. + second <- if (kq > 2L) pmin(d2[, 1L], d2[, 2L], d2[, 3L]) else rep(Inf, nq) + redo <- which(rowSums(own) != 1L | !(second > best * (1 + 1e-9))) + if (length(redo)) out[redo] <- .knn_tied_rows(u, q[redo], 1L)[, 1L] + out +} + + +#' For chosen locations, the nearest other location, searched once +#' +#' The nearest other location of a location does not depend on the regions. +#' With \code{cache} given, each one found is kept there and no location is +#' searched twice, so fits of the same rows in one set of regions after +#' another share their searches. The cache holds the locations it was filled +#' for and starts again when it is handed others. +#' +#' @param u,q,use_fnn,caller As for \code{.nearest_location_search()}. +#' @param cache \code{NULL}, or an environment. +#' @return As \code{.nearest_location_search()}. +#' @keywords internal +#' @noRd +.nearest_location <- function(u, q, use_fnn, cache = NULL, caller = "resolution_profile") { + if (is.null(cache)) return(.nearest_location_search(u, q, use_fnn, caller)) + if (!identical(cache$u, u)) { + cache$u <- u + cache$nearest <- rep(NA_integer_, nrow(u)) + } + todo <- q[is.na(cache$nearest[q])] + if (length(todo)) + cache$nearest[todo] <- .nearest_location_search(u, todo, use_fnn, caller) + cache$nearest[q] +} + + +#' For chosen rows, a nearest other row +#' +#' Chosen so that the region of the row returned does not depend on the order +#' of the rows. +#' \enumerate{ +#' \item The rows are put in the order of their first coordinate, their +#' second, then their region. A run of equal coordinates is a location, +#' and the first row of a location is the one in the lowest-numbered +#' region. +#' \item A row that shares its location with other rows takes the first +#' other row there: the first row of the location, or the second when it +#' is the first itself. +#' \item A row alone at its location takes the first row of its nearest +#' other location; a tie between locations goes to the lower first +#' coordinate, then the lower second. +#' } +#' An exact search on the rows as given breaks a tie by row number, so on +#' gridded locations the neighbour would change with the order of the rows. +#' Where no two locations tie and none repeats, the row returned is the +#' nearest other row. +#' +#' @param xy Two-column matrix of finite coordinates, one row per row; any +#' other number of columns is an error. +#' @param gi Region of each row. +#' @param rows The rows to find a neighbour for. +#' @param use_fnn Whether to use \pkg{FNN}. The answer is the same without. +#' @param cache \code{NULL}, or an environment in which the nearest other +#' location of each location searched is kept (\code{.nearest_location()}). +#' @param caller Name of the exported function, for the work guard's message. +#' @return For each of \code{rows}, a row of \code{xy} that is not it; +#' \code{NA} when \code{xy} has one row. +#' @keywords internal +#' @noRd +.nearest_other <- function(xy, gi, rows, use_fnn, cache = NULL, + caller = "resolution_profile") { + xy <- .pool_xy(xy, length(gi), ".nearest_other") + if (!length(rows)) return(integer(0)) + n <- nrow(xy) + o <- order(xy[, 1L], xy[, 2L], gi) + xs <- xy[o, , drop = FALSE] + first <- c(TRUE, xs[-1L, 1L] != xs[-n, 1L] | xs[-1L, 2L] != xs[-n, 2L]) + loc <- cumsum(first) # the location of each sorted row + head <- which(first) # the first sorted row of each location + m <- tabulate(loc) # rows at each location + u <- unname(xs[first, , drop = FALSE]) + at <- integer(n) + at[o] <- seq_len(n) + pos <- at[rows] # where each row asked for stands + L <- loc[pos] + ans <- rep(NA_integer_, length(rows)) + shared <- m[L] > 1L + if (any(shared)) { + h <- head[L[shared]] + ans[shared] <- ifelse(pos[shared] == h, h + 1L, h) + } + if (!all(shared) && nrow(u) > 1L) { + q <- sort(unique(L[!shared])) + nl <- .nearest_location(u, q, use_fnn, cache, caller) + ans[!shared] <- head[nl[match(L[!shared], q)]] + } + o[ans] +} + + +# ----------------------------------------------------------------------------- +# The fit +# ----------------------------------------------------------------------------- + +#' Refuse centroids and neighbours that cannot be those of \code{K} regions +#' +#' A fit reads the \code{geo} it is handed in place of computing its own. +#' One of another number of regions would not stop it: \code{S[nb]} is +#' reshaped to \code{K} rows whatever \code{nb} holds, and the targets come +#' out as sums over other regions, with no \code{NA} and no error. This +#' checks what can be checked without computing the geometry again: the two +#' shapes, that every neighbour is a region, and that none is the region +#' itself. It cannot tell the geometry of these regions from that of other +#' regions of the same number; the caller answers for that. +#' +#' @param geo The list to check: \code{cen} and \code{nb}. +#' @param K Number of regions. +#' @return \code{NULL}, invisibly; an error when \code{geo} does not fit. +#' @keywords internal +#' @noRd +.pool_geo_check <- function(geo, K) { + k <- min(.POOL_NEIGHBOURS, K - 1L) + ok <- is.list(geo) && + is.matrix(geo$cen) && is.numeric(geo$cen) && identical(dim(geo$cen), c(K, 2L)) && + !anyNA(geo$cen) && + is.matrix(geo$nb) && is.numeric(geo$nb) && identical(dim(geo$nb), c(K, k)) && + !anyNA(geo$nb) && all(geo$nb >= 1L & geo$nb <= K) && !any(geo$nb == seq_len(K)) + if (!ok) + stop(sprintf(paste0(".pool_fit(): `geo` must hold the centroids and neighbours of these ", + "%d regions: `cen` %d x 2, and `nb` %d x %d with every entry another ", + "region."), K, K, K, k), call. = FALSE) + invisible(NULL) +} + + +#' Pooled values, plain means and their leave-one-out errors for one column +#' +#' The first of these that holds decides what is returned, and \code{status} +#' is its name. +#' \describe{ +#' \item{\code{"one cell"}}{\code{K} is 1. The value is the plain mean and +#' its weight 1; there is no target and no \code{tau2}. Each residual is +#' the plain one, \code{(y - m) N / (N - 1)}, and every leave-one-out +#' error their mean square. For a constant column \code{sigma2} and the +#' residuals are exactly 0 and the errors \code{NA}. With one row, +#' \code{sigma2}, the residuals and the errors are \code{NA}.} +#' \item{\code{"no cell holds two values"}}{\code{N <= K}: \code{sigma2} +#' has no estimate and nothing is fitted. \code{n}, \code{S}, \code{m}, +#' \code{N}, \code{K}, \code{constant} and \code{flat} are returned and +#' everything else is \code{NA} (\code{NULL} for the residuals).} +#' \item{\code{"no spread inside any cell"}}{\code{flat}: the sum of +#' squares inside the regions is rounding error, by \code{.no_spread()} +#' on the sum the fit uses or on the same sum about means corrected for +#' the rounding of their own sums (\code{.ss_within()}). \code{sigma2} +#' is 0, every weight 1 and the value the plain mean; the residual of a +#' row that shares its region is 0. When the column is constant over all +#' its rows as well (\code{constant}), \code{tau2} is 0, every residual +#' is 0 and every leave-one-out error is \code{NA}: no level fits a +#' constant better than another. These are set, not computed, because +#' the formulas would divide one rounding error by another.} +#' \item{\code{"no signal between cells"}}{\code{tau2} is 0: every weight +#' is 0 and each value is its target.} +#' \item{\code{"ok"}}{None of the above.} +#' } +#' +#' Leaving one row out: under plain means a row in a region of two or more is +#' predicted by the mean of the others, and a row alone in its region by the +#' mean of the region of its nearest other row (\code{.nearest_other()}). +#' Under pooled values the region's mean and own weight are computed again +#' without the row and \code{sigma2}, \code{tau2} and the target are held; a +#' region left empty takes its target. The target never holds the row, since +#' a region is not its own neighbour. Rows at one location are left out one +#' at a time. +#' +#' @param y Finite values, at least one. They are read as doubles, so a +#' column of whole numbers gives the fit of \code{as.numeric()} of it. +#' @param gi Region of each, integers \code{1..K}, every region present. +#' @param K Number of regions. +#' @param xy Two-column matrix of finite coordinates in a projected CRS, one +#' row per value. A matrix with a third column is an error: the caller +#' takes the two it means. +#' @param want Which estimates' leave-one-out residuals to compute: a +#' non-empty subset of \code{c("pooled", "mean")}. Everything else is +#' computed whatever it holds. +#' @param nn1 For each row its nearest other row, or \code{NULL} to have it +#' found for the rows that need one: those alone in their region, when +#' \code{"mean"} is wanted. +#' @param geo \code{NULL}, or \code{fit[c("cen", "nb")]} of an earlier fit on +#' the same rows and regions; neither is then computed again. One whose +#' shape is not that of \code{K} regions is an error +#' (\code{.pool_geo_check()}); one of other regions of the same number +#' cannot be told from the right one and gives wrong targets. +#' @param use_fnn Whether to use \pkg{FNN}. The answer is the same without. +#' @param cache \code{NULL}, or an environment for \code{.nearest_other()}. +#' @param caller Name of the exported function, for the message of the error +#' that stops an exact search above the limit +#' (\code{spatialkit_work_limit}). +#' @return A list: \code{n}, \code{S}, \code{m} (rows, sum and plain mean of +#' each region), \code{N}, \code{K}, \code{sigma2}, \code{cen}, \code{nb}, +#' \code{target}, \code{Q}, \code{tau2}, \code{w}, \code{value} (the pooled +#' value), \code{resid_pooled}, \code{resid_mean} (leave-one-out residuals, +#' one per row; \code{NULL} for an estimate not in \code{want}), +#' \code{loo_pooled}, \code{loo_pooled_se}, \code{loo_mean}, +#' \code{loo_mean_se} (their mean square and its standard error over rows; +#' \code{NA} for an estimate not in \code{want}), \code{loo_one}, +#' \code{loo_one_se} (the same for one mean for all rows), \code{f_p} (the +#' p-value of the F test of the region means against one mean; \code{NA} +#' when \code{flat}, with one region, or when \code{N - K < 1}), +#' \code{constant}, \code{flat} and \code{status}. +#' @keywords internal +#' @noRd +.pool_fit <- function(y, gi, K, xy, want = c("pooled", "mean"), nn1 = NULL, geo = NULL, + use_fnn = .has_backend("FNN"), cache = NULL, + caller = "resolution_profile") { + want <- unique(want) + if (!length(want) || !all(want %in% c("pooled", "mean"))) + stop(".pool_fit(): `want` must be \"pooled\", \"mean\" or both.", call. = FALSE) + # Whole numbers are summed as doubles: rowsum() of integers returns NA + # without a warning once a region's sum passes .Machine$integer.max. + y <- as.numeric(y) + K <- as.integer(K) + N <- length(y) + if (N < 1L || length(gi) != N) + stop(".pool_fit(): `y` must hold at least one value and `gi` the region of each.", + call. = FALSE) + # tabulate() leaves out what is not among 1..K, so the first comparison + # fails for a number outside them and the second for one with no row. + n <- tabulate(gi, K) + if (sum(n) != N || !all(n > 0L)) + stop(".pool_fit(): the regions must be numbered 1 to K with a row in each.", + call. = FALSE) + S <- as.numeric(rowsum(y, gi)) + xy <- .pool_xy(xy, N, ".pool_fit") + if (!is.null(geo)) .pool_geo_check(geo, K) + m <- S / n + res <- y - m[gi] + ss_w <- sum(res^2) + tss <- sum((y - mean(y))^2) + const <- .no_spread(tss, y) # constant over the rows + # No spread inside any region. The second test is on the sum of squares the + # fit uses; the third is on the same sum about means that carry no rounding + # of their own, without which a column constant inside large regions fails + # the second (.ss_within()). + flat <- const || .no_spread(ss_w, y) || .no_spread(.ss_within(res, gi, n), y) + # Mean square of a set of residuals, and its standard error over rows. + loo_of <- function(e) c(mean(e^2), stats::sd(e^2) / sqrt(N)) + none <- c(NA_real_, NA_real_) + + out <- list(n = n, S = S, m = m, N = N, K = K, sigma2 = NA_real_, + cen = NA_real_, nb = NA_integer_, target = rep(NA_real_, K), + Q = NA_real_, tau2 = NA_real_, w = rep(NA_real_, K), + value = rep(NA_real_, K), resid_pooled = NULL, resid_mean = NULL, + loo_pooled = NA_real_, loo_pooled_se = NA_real_, + loo_mean = NA_real_, loo_mean_se = NA_real_, + loo_one = NA_real_, loo_one_se = NA_real_, f_p = NA_real_, + constant = const, flat = flat, status = NA_character_) + + # ---- 1. One region: nothing to pool toward ------------------------------- + if (K == 1L) { + if (is.null(geo)) geo <- .pool_geometry(gi, K, xy, n, use_fnn, caller) + e <- if (N == 1L) NA_real_ else if (const) numeric(N) else res * N / (N - 1) + loo <- if (N == 1L || const) none else loo_of(e) + out$sigma2 <- if (N == 1L) NA_real_ else if (const) 0 else ss_w / (N - 1) + out$cen <- geo$cen + out$nb <- geo$nb + out$w <- 1 + out$value <- m + if ("pooled" %in% want) { + out$resid_pooled <- e; out$loo_pooled <- loo[1L]; out$loo_pooled_se <- loo[2L] + } + if ("mean" %in% want) { + out$resid_mean <- e; out$loo_mean <- loo[1L]; out$loo_mean_se <- loo[2L] + } + out$loo_one <- loo[1L]; out$loo_one_se <- loo[2L] + out$flat <- const + out$status <- "one cell" + return(out) + } + + # ---- 2. No region holds two rows: sigma2 has no estimate ----------------- + if (N <= K) { + out$status <- "no cell holds two values" + return(out) + } + + # ---- 3 to 5. The fit ------------------------------------------------------ + sigma2 <- if (flat) 0 else ss_w / (N - K) + if (is.null(geo)) geo <- .pool_geometry(gi, K, xy, n, use_fnn, caller) + cen <- geo$cen # centroids, summed in coordinate order + nb <- geo$nb # K x min(8, K - 1) + Sn <- rowSums(matrix(S[nb], K)); Nn <- rowSums(matrix(n[nb], K)) + target <- Sn / Nn + Q <- sum(n * (m - target)^2) + tau2 <- if (const) 0 else max(0, (Q - K * sigma2) / N) + w <- if (flat) rep(1, K) else .pool_weight(tau2, sigma2 / n) + value <- if (flat) m else w * m + (1 - w) * target + + # Leave one row out. + nj <- n[gi]; n1 <- nj - 1L; d1 <- pmax(n1, 1L) + if ("mean" %in% want) { + eP <- if (flat) numeric(N) else res * nj / d1 + sng <- nj == 1L + if (!const && any(sng)) { + if (is.null(nn1)) { + nn1 <- integer(N) + nn1[sng] <- .nearest_other(xy, gi, which(sng), use_fnn, cache, caller) + } + eP[sng] <- y[sng] - m[gi[nn1[sng]]] + } + loo <- if (const) none else loo_of(eP) + out$resid_mean <- eP; out$loo_mean <- loo[1L]; out$loo_mean_se <- loo[2L] + } + if ("pooled" %in% want) { + m1 <- (S[gi] - y) / d1 + w1 <- ifelse(n1 >= 1L, if (flat) 1 else .pool_weight(tau2, sigma2 / d1), 0) + eL <- if (const) numeric(N) else y - (w1 * m1 + (1 - w1) * target[gi]) + if (flat && !const) eL[n1 >= 1L] <- 0 + loo <- if (const) none else loo_of(eL) + out$resid_pooled <- eL; out$loo_pooled <- loo[1L]; out$loo_pooled_se <- loo[2L] + } + # One mean for all rows: the reference every count has to beat. + e1 <- (y - mean(y)) * N / (N - 1) + loo <- if (const) none else loo_of(e1) + + out$sigma2 <- sigma2 + out$cen <- cen + out$nb <- nb + out$target <- target + out$Q <- Q + out$tau2 <- tau2 + out$w <- w + out$value <- value + out$loo_one <- loo[1L]; out$loo_one_se <- loo[2L] + out$f_p <- if (flat) NA_real_ else + stats::pf(max(((tss - ss_w) / (K - 1)) / (ss_w / (N - K)), 0), K - 1, N - K, + lower.tail = FALSE) + out$status <- if (flat) "no spread inside any cell" + else if (tau2 == 0) "no signal between cells" + else "ok" + out +} + + +# ----------------------------------------------------------------------------- +# One column of an assigned layer +# ----------------------------------------------------------------------------- + +#' Region values of one column, from its rows +#' +#' A row is scored when its value is finite, its region's ID is not missing +#' and its coordinates are finite; every other row is, for this column, as if +#' absent. The regions are the distinct IDs among the scored rows, in the +#' order \code{u[order(u, method = "radix")]}: ascending for numbers, the +#' C-locale order for strings on every platform, the order of the levels for +#' a factor. +#' +#' \code{status} is that of \code{.pool_fit()}, or one of three set here, +#' under each of which the values are \code{NA}: \code{"no coordinates"} +#' (\code{xy} is \code{NULL}) and \code{"no located value"} (no scored row), +#' both before any fit, and \code{"work limit"} when the fit is stopped +#' before an exact search above the limit. That stop is an error of class +#' \code{spatialkit_work_limit} inside the fit and a status here: the caller +#' still has its plain columns to return. No warning is raised here. +#' +#' @param y The column's values, one per row. +#' @param id The region of each row, of any type; \code{NA} for a row in +#' none. +#' @param xy Two-column matrix of the rows' coordinates in a projected CRS, +#' or \code{NULL} when the rows have none. +#' @param obs_level \code{NULL}, or the level of the interval for one +#' observation. +#' @param want,use_fnn As for \code{.pool_fit()}. +#' @param geo \code{NULL}, or the \code{geo} this function returned for an +#' earlier column with the same \code{mask} and the same \code{id}. The +#' fit refuses one of another number of regions and cannot tell one of +#' other regions of the same number, so the caller answers for passing it +#' only between columns whose scored rows are the same. +#' @return A list. Per region, in the order of \code{ids}: \code{ids}, +#' \code{n} (scored rows), \code{value}, \code{w}, \code{target}, and +#' \code{obs_lo}, \code{obs_hi} (\code{NULL} without \code{obs_level}). +#' \code{record}: the column's entry in the record of a summary, with +#' \code{column} and \code{role} left \code{NA} for the caller. +#' \code{mask}: which rows are scored. \code{geo}: the centroids and +#' neighbours the fit used, its own or the ones handed in, for a later +#' column with the same mask; \code{NULL} when no fit used any. +#' \code{fit}: the list of \code{.pool_fit()}, or \code{NULL} when no fit +#' ran or it was stopped. +#' \code{work}, \code{limit}: the pairs and the limit of the search that +#' stopped the fit, \code{NA} otherwise. +#' @keywords internal +#' @noRd +.pool_column <- function(y, id, xy, obs_level, want, use_fnn, geo = NULL) { + rows <- length(y) + valued <- is.finite(y) & !is.na(id) + offsets <- if (is.null(obs_level)) NULL else c(NA_real_, NA_real_) + record <- list(column = NA_character_, role = NA_character_, + n = 0L, cells = 0L, df = NA_integer_, neighbours = NA_integer_, + sigma2 = NA_real_, tau2 = NA_real_, own_weight = NA_real_, + share_alone = NA_real_, loo = NA_real_, loo_se = NA_real_, + loo_one_cell = NA_real_, structured = NA, structure_p = NA_real_, + offsets = offsets, repeated = 0L, skipped = 0L, constant = NA, + status = NA_character_) + out <- list(ids = id[0L], n = integer(0), value = numeric(0), w = numeric(0), + target = numeric(0), obs_lo = NULL, obs_hi = NULL, record = record, + mask = logical(rows), geo = NULL, fit = NULL, + work = NA_real_, limit = NA_real_) + if (!is.null(obs_level)) out$obs_lo <- out$obs_hi <- numeric(0) + + if (is.null(xy)) { + out$record$skipped <- sum(valued) + out$record$status <- "no coordinates" + return(out) + } + located <- is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + mask <- valued & located + out$mask <- mask + out$record$skipped <- sum(valued & !located) + if (!any(mask)) { + out$record$status <- "no located value" + return(out) + } + + ys <- y[mask] # the fit reads it as doubles + ids <- id[mask] + xs <- cbind(xy[mask, 1L], xy[mask, 2L]) + u <- unique(ids) + u <- u[order(u, method = "radix")] + gi <- match(ids, u) + K <- length(u) + N <- length(ys) + n <- tabulate(gi, K) + na_K <- rep(NA_real_, K) + out$ids <- u + out$n <- n + out$value <- out$w <- out$target <- na_K + if (!is.null(obs_level)) out$obs_lo <- out$obs_hi <- na_K + out$record$n <- N + out$record$cells <- K + out$record$df <- N - K + out$record$neighbours <- min(.POOL_NEIGHBOURS, K - 1L) + out$record$share_alone <- sum(n == 1L) / N + out$record$repeated <- .repeated_rows(xs) + + fit <- tryCatch( + .pool_fit(ys, gi, K, xs, want = want, geo = geo, use_fnn = use_fnn, + caller = "summarize_by_cell"), + spatialkit_work_limit = function(e) e) + if (inherits(fit, "spatialkit_work_limit")) { + out$work <- fit$work + out$limit <- fit$limit + out$record$status <- "work limit" + return(out) + } + + out$fit <- fit + out$value <- fit$value + out$w <- fit$w + out$target <- fit$target + if (is.matrix(fit$cen)) out$geo <- fit[c("cen", "nb")] + out$record$sigma2 <- fit$sigma2 + out$record$tau2 <- fit$tau2 + out$record$own_weight <- stats::median(fit$w) + out$record$loo <- fit$loo_pooled + out$record$loo_se <- fit$loo_pooled_se + out$record$loo_one_cell <- fit$loo_one + out$record$constant <- fit$constant + out$record$status <- fit$status + if (K >= 2L && !fit$flat && is.finite(fit$loo_pooled)) { + s <- .no_structure(fit$loo_pooled, fit$loo_one, fit$f_p, tol = .STRUCTURE_TOL) + out$record$structured <- s$structured + out$record$structure_p <- s$structure_p + } + if (!is.null(obs_level)) { + off <- .obs_offsets(fit$resid_pooled, obs_level) + out$record$offsets <- off + out$obs_lo <- fit$value + off[1L] + out$obs_hi <- fit$value + off[2L] + } + out +} + + +#' How many rows share their location with another row +#' +#' @param xy Two-column matrix of finite coordinates. +#' @return The number of rows whose coordinates are those of another row. +#' @keywords internal +#' @noRd +.repeated_rows <- function(xy) { + n <- nrow(xy) + if (n < 2L) return(0L) + o <- order(xy[, 1L], xy[, 2L]) + x <- xy[o, 1L]; y <- xy[o, 2L] + as_before <- c(FALSE, x[-1L] == x[-n] & y[-1L] == y[-n]) + sum(as_before | c(as_before[-1L], FALSE)) +} + + +# ----------------------------------------------------------------------------- +# The intervals a summary's frame holds +# ----------------------------------------------------------------------------- + +#' The intervals in a summary's frame, and what each covers +#' +#' One row per family of interval columns in the frame. The interval for one +#' observation is centred on the pooled value; the t interval is centred on +#' the plain mean, and what it covers follows the design effect: the cell's +#' own mean at a design effect of 1, the cell mean as an estimate of the +#' population mean under any other. Neither row is written when its level +#' was not asked for. +#' +#' @param obs_level Level of the interval for one observation, or +#' \code{NULL}. +#' @param conf_level Level of the plain mean's t interval, or \code{NULL}. +#' @param deff_label The design effect the t interval was built with, as it +#' is written in a call: \code{1}, \code{"kish"} (with its quotes), +#' \code{"variogram"} or a number. It reads \code{1} exactly when the +#' interval carries none, which is what \code{.deff_label()} writes. +#' @return A data frame with the columns \code{columns} (the stems of the two +#' interval columns), \code{covers}, \code{centre}, \code{level} and +#' \code{method}; no row when both levels are \code{NULL}. +#' @keywords internal +#' @noRd +.intervals_table <- function(obs_level, conf_level, deff_label) { + obs <- !is.null(obs_level) + ci <- !is.null(conf_level) + own <- identical(as.character(deff_label), "1") + data.frame( + columns = c(character(0), + if (obs) "..obs_lo_, ..obs_hi_", + if (ci) "..ci_lo_, ..ci_hi_"), + covers = c(character(0), + if (obs) paste0("one further observation in the cell, located like the data; ", + "on average over observations, not cell by cell"), + if (ci && own) paste0("the cell's own mean, when its observations are spread ", + "through the cell; not a range for one observation"), + if (ci && !own) paste0("the cell mean as an estimate of the population mean; ", + "not a range for one observation")), + centre = c(character(0), if (obs) "pooled value", if (ci) "plain mean"), + level = c(numeric(0), if (obs) as.numeric(obs_level), if (ci) as.numeric(conf_level)), + method = c(character(0), + if (obs) "quantiles of leave-one-out residuals", + if (ci) sprintf("t, deff = %s", deff_label)), + stringsAsFactors = FALSE) +} + + +# ----------------------------------------------------------------------------- +# Moran's z of the cell means above the dense limit +# ----------------------------------------------------------------------------- + +#' Whether Moran's z is left out, on every ladder, where it cannot be computed +#' +#' Above \code{.KNN_DENSE_MAX} cells the neighbour weights of the cell means +#' need \pkg{FNN} and \pkg{Matrix}. When either is missing a profile +#' leaves \code{moran_i} and \code{moran_z} \code{NA} at such a level, with +#' a warning, whatever its ladder. Were this \code{FALSE}, only a ladder +#' set by \code{obs_per_cell} would do so, and every other ladder would stop +#' there with the error of \code{.build_knn_weights()}. +#' +#' @return \code{TRUE}. +#' @keywords internal +#' @noRd +.moran_skip_any_ladder <- function() TRUE diff --git a/R/predict-surface.R b/R/predict-surface.R index 025e4747..c585f021 100644 --- a/R/predict-surface.R +++ b/R/predict-surface.R @@ -158,7 +158,11 @@ #' @param chunk_size Rows per prediction call. Default 5000. A pure #' performance knob: rows do not interact, and for a \code{bayesian_fit} the #' GP boundary is held at its fitted value whatever the chunk holds; see -#' \code{\link{predict.bayesian_fit}}. +#' \code{\link{predict.bayesian_fit}}. The two warnings in which +#' \code{\link{predict.gwr_fit}()} counts locations (classes +#' \code{"spatialkit_gwr_extrapolation"} and +#' \code{"spatialkit_gwr_not_estimable"}) are raised once for the grid, +#' with its totals, whatever the number of chunks. #' @param se Logical; also return a standard-error/posterior-SD column where the #' backend supports it. Default FALSE. For a \code{bayesian_fit} this is #' the SD of the posterior draws \code{predict()} returns, and those are of @@ -365,42 +369,49 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, any(nzchar(dot_names) & startsWith("summary", dot_names)) derive_pred <- se_ok && !supplied_summary - for (s in starts) { - e <- min(s + chunk_size - 1L, n) - idx <- s:e - blk <- grid[idx, , drop = FALSE] + # A GWR's predict() counts, per call, the locations it cannot estimate and + # those beyond the reach of the fit, and warns with that call's counts. + # Predicting in chunks would pass on one warning per chunk; collected here, + # each class is raised once with the totals over the grid. Other backends + # signal neither class, so for them this only evaluates the loop. + .gwr_tally_predict_warnings({ + for (s in starts) { + e <- min(s + chunk_size - 1L, n) + idx <- s:e + blk <- grid[idx, , drop = FALSE] - got_pred <- FALSE - if (se_ok) { - d <- try(stats::predict(object, newdata = blk, draws = TRUE, ...), - silent = TRUE) - if (inherits(d, "try-error") || !is.matrix(d)) { - se_ok <- FALSE # backend has no draw interface; report once - } else { - se_vec[idx] <- apply(d, 2L, stats::sd) - if (derive_pred) { - preds_vec[idx] <- colMeans(d) - got_pred <- TRUE + got_pred <- FALSE + if (se_ok) { + d <- try(stats::predict(object, newdata = blk, draws = TRUE, ...), + silent = TRUE) + if (inherits(d, "try-error") || !is.matrix(d)) { + se_ok <- FALSE # backend has no draw interface; report once + } else { + se_vec[idx] <- apply(d, 2L, stats::sd) + if (derive_pred) { + preds_vec[idx] <- colMeans(d) + got_pred <- TRUE + } } } - } - if (!got_pred) { - p <- try(stats::predict(object, newdata = blk, ...), silent = TRUE) - if (inherits(p, "try-error")) - stop("predict_surface(): prediction failed on rows ", s, "-", e, ": ", - as.character(p), call. = FALSE) - # One value per row, or the assignment below recycles or truncates - # whatever came back into .pred without a word that means anything. - if (length(p) != length(idx)) - stop(sprintf(paste0("predict_surface(): predict() returned %d value(s) ", - "for the %d rows %d-%d; expected one per row. Check ", - "what the backend's predict() returns for the ", - "arguments passed through `...`."), - length(p), length(idx), s, e), call. = FALSE) - preds_vec[idx] <- as.numeric(p) + if (!got_pred) { + p <- try(stats::predict(object, newdata = blk, ...), silent = TRUE) + if (inherits(p, "try-error")) + stop("predict_surface(): prediction failed on rows ", s, "-", e, ": ", + as.character(p), call. = FALSE) + # One value per row, or the assignment below recycles or truncates + # whatever came back into .pred without a word that means anything. + if (length(p) != length(idx)) + stop(sprintf(paste0("predict_surface(): predict() returned %d value(s) ", + "for the %d rows %d-%d; expected one per row. Check ", + "what the backend's predict() returns for the ", + "arguments passed through `...`."), + length(p), length(idx), s, e), call. = FALSE) + preds_vec[idx] <- as.numeric(p) + } } - } + }, caller = "predict_surface", n_total = n) if (isTRUE(se) && !se_ok) .log_warn(paste0("predict_surface(): `se = TRUE` but this backend does not ", diff --git a/R/resolution-profile.R b/R/resolution-profile.R index f149a23e..567efd1e 100644 --- a/R/resolution-profile.R +++ b/R/resolution-profile.R @@ -133,58 +133,705 @@ } +# ----------------------------------------------------------------------------- +# A ladder set by a size, the estimate's columns, and the two bounds on cost +# ----------------------------------------------------------------------------- + +#' A refused value in the words of an error message +#' +#' @param x The value the caller passed. +#' @return One string: a string in its quotes, numbers as they print (the +#' first six of them), \code{numeric(0)} for a vector of no length, and the +#' class of anything else. +#' @keywords internal +#' @noRd +.got_text <- function(x) { + if (is.null(x)) return("NULL") + if (!(is.character(x) || is.numeric(x) || is.logical(x)) || is.object(x)) + return(sprintf("an object of class %s", class(x)[1L])) + if (!length(x)) return(sprintf("%s(0)", class(x)[1L])) + # Each number as it prints alone: format() of the vector would pad them to + # a common number of decimals. + v <- if (is.character(x)) ifelse(is.na(x), "NA", sprintf("\"%s\"", x)) + else vapply(x, function(one) format(one), "") + txt <- paste(utils::head(v, 6L), collapse = ", ") + if (length(v) > 6L) txt <- paste0(txt, ", ...") + if (length(v) > 1L) sprintf("c(%s)", txt) else txt +} + + +#' Items joined as a sentence lists them +#' +#' @param x Character vector, at least one item. +#' @return \code{a}; \code{a and b}; \code{a, b and c}. +#' @keywords internal +#' @noRd +.and_text <- function(x) { + k <- length(x) + if (k <= 1L) return(paste(x)) + paste(paste(x[-k], collapse = ", "), "and", x[k]) +} + + +#' Whether a value is the string "auto" +#' +#' Read by its value alone. A string taken from a named vector or list +#' (\code{cfg["sac"]}) carries a name, and one built by another package can +#' carry a class; \code{identical(x, "auto")} is \code{FALSE} of both. +#' +#' @param x The value the caller passed. +#' @return \code{TRUE} or \code{FALSE}. +#' @keywords internal +#' @noRd +.is_auto <- function(x) + is.character(x) && length(x) == 1L && identical(as.character(unclass(x)), "auto") + + +#' Rows per cell, in the words of a message +#' +#' @param x The number of rows per cell. +#' @return \code{"3 rows per cell"}, \code{"1.03 rows per cell"}; \code{"1 row +#' per cell"} when the number prints as 1. +#' @keywords internal +#' @noRd +.per_cell_text <- function(x) { + v <- sprintf("%.3g", x) + paste(v, if (identical(v, "1")) "row" else "rows", "per cell") +} + + +#' The finest level of a ladder of sizes +#' +#' The count the finest size gives, held to the most centres k-means can +#' place. It needs the rows and the sizes alone, so the guards on the cost +#' of a ladder of sizes read it before anything is estimated; +#' \code{.size_ladder()} returns the same number as its \code{ceiling}. +#' +#' @param n The rows a size divides. +#' @param sizes Rows per cell. +#' @param cap The most centres k-means can place. +#' @return One integer, 2 or more. +#' @keywords internal +#' @noRd +.finest_level <- function(n, sizes, cap) + as.integer(min(.count_at(n, min(sizes)), max(2L, as.integer(cap)))) + + +#' The levels of a ladder of sizes, its verdict, and what is said of it +#' +#' The level of a size \code{s} is the count \code{.count_at()} gives for it, +#' held to the most centres k-means can place. The finest size takes the +#' part \code{min_cell_n} has on the automatic ladder: it sets the ceiling, +#' \code{supported} and the warning. One event raises one warning. +#' \describe{ +#' \item{Fewer than two cells of the finest size, or one distinct +#' location}{\code{spatialkit_not_supported}; the ladder is the one level +#' of 2 cells and \code{supported} is \code{FALSE}. Nothing else is +#' raised.} +#' \item{A coarser size gives fewer than two cells}{Given as a number: its +#' level is 2, with \code{spatialkit_size_not_reached}. From +#' \code{"auto"}: the size is dropped and nothing is said, since the +#' caller did not ask for it.} +#' \item{A size asks for more cells than can be placed}{Its level is the +#' most that can, with \code{spatialkit_size_not_reached}.} +#' \item{The range floor is above the finest level}{ +#' \code{spatialkit_not_supported}, as on the automatic ladder.} +#' } +#' +#' @param sizes Rows per cell, largest first, without repeats. +#' @param sizes_auto Whether they came from \code{obs_per_cell = "auto"}. +#' @param n The rows a size divides: those with a response, or every point. +#' @param n_points,n_distinct The layer's points and its distinct locations. +#' @param cap The most centres k-means can place on them. +#' @param floor_raw The range floor, a double (2 without a range). +#' @param range_eff The range it came from, for the message. +#' @param support_what,rows_carry What \code{n} counts and what a counted row +#' carries, in the words of the messages. +#' @return A list: \code{levels} (sorted, distinct), \code{size_levels} (the +#' level of each size, named by size; \code{NA} for a size dropped), +#' \code{ceiling} (the finest level), \code{ceiling_from}, \code{supported} +#' and \code{too_few}. +#' @keywords internal +#' @noRd +.size_ladder <- function(sizes, sizes_auto, n, n_points, n_distinct, cap, floor_raw, + range_eff, support_what, rows_carry) { + cap <- as.integer(cap) + wanted <- round(n / sizes) # the cells each size asks for + s_min <- sizes[length(sizes)] + want <- wanted[length(sizes)] # of the finest size + too_few <- min(want, cap) < 2 + supported <- !too_few && floor_raw <= max(2, min(want, cap)) + ceiling_from <- if (cap < 2L) "fewer than two distinct locations" + else if (want < 2) "fewer than two cells of the size" + else if (want > cap) "distinct locations" + else "obs_per_cell" + size_levels <- pmin(.count_at(n, sizes), max(2L, cap)) + if (!too_few && isTRUE(sizes_auto)) size_levels[wanted < 2] <- NA_integer_ + names(size_levels) <- as.character(sizes) + levels <- sort(unique(size_levels[!is.na(size_levels)])) + finest <- max(levels) + size_text <- function(s) format(s) + + if (too_few && cap < 2L) { + .warn_classed("spatialkit_not_supported", + paste0("resolution_profile(): the %d points sit on %d distinct location%s, ", + "so there is no ladder of cell counts to choose from. The profile ", + "scores 2 cells so that level is still visible, and `supported` is ", + "FALSE. A tessellation needs points at two locations or more."), + n_points, n_distinct, if (n_distinct == 1L) "" else "s", + data = list(reason = ceiling_from, n = n, min_cell_n = NA_integer_, + obs_per_cell = s_min)) + } else if (too_few) { + # The largest size that still gives two cells: round(n / s) is 2 from + # n / s = 1.5 up. Written to two decimals, rounded down. + most <- floor(n / 1.5 * 100) / 100 + .warn_classed("spatialkit_not_supported", + paste0("resolution_profile(): %d %s at obs_per_cell = %s make%s %d cell%s, and ", + "it takes two, so there is no cell count of that size. The profile ", + "scores 2 cells (%s) so that level is still visible, ", + "and `supported` is FALSE. %s"), + n, + if (n == 1L) sub("^rows", "row", sub("^points$", "point", support_what)) + else support_what, + size_text(s_min), if (n == 1L) "s" else "", as.integer(want), + if (want == 1) "" else "s", .per_cell_text(n / 2), + if (most < 1) + sprintf("Two cells take %s on at least two rows, whatever `obs_per_cell` is.", + rows_carry) + else sprintf("An `obs_per_cell` of at most %s gives two cells here.", + format(most)), + data = list(reason = ceiling_from, n = n, min_cell_n = NA_integer_, + obs_per_cell = s_min)) + } else { + for (j in seq_along(sizes)) { + if (wanted[j] < 2 && !isTRUE(sizes_auto)) + .warn_classed("spatialkit_size_not_reached", + paste0("resolution_profile(): obs_per_cell = %s on %d rows is fewer ", + "than two cells; two cells are used (%s)."), + size_text(sizes[j]), n, .per_cell_text(n / 2), + data = list(obs_per_cell = sizes[j], wanted = as.integer(wanted[j]), + used = 2L, reason = "fewer than two cells")) + else if (wanted[j] > cap) + .warn_classed("spatialkit_size_not_reached", + paste0("resolution_profile(): obs_per_cell = %s asks for %d cells, more ", + "than k-means can place on %s; %d cells are used (%s)."), + size_text(sizes[j]), as.integer(wanted[j]), + # With no location repeated the bound is one short of + # the points, which stats::kmeans() needs. + if (n_distinct < n_points) + sprintf("the layer's %d distinct locations", n_distinct) + else sprintf("%d points", n_points), + cap, .per_cell_text(n / cap), + data = list(obs_per_cell = sizes[j], wanted = as.integer(wanted[j]), + used = cap, reason = "more cells than can be placed")) + } + if (!supported) + .warn_classed("spatialkit_not_supported", + paste0("resolution_profile(): cells no wider than the autocorrelation ", + "range (%.0f) would need at least %.0f of them, but %d %s ", + "at obs_per_cell = %s support at most %d. The data cannot ", + "support a tessellation that respects their own ", + "correlation structure; the profile scores %s so ", + "the cost of each level is still visible."), + range_eff, floor_raw, n, support_what, size_text(s_min), finest, + if (length(levels) == 1L) sprintf("the %d cells that size gives", levels) + else sprintf("the %d to %d cells the sizes give", min(levels), max(levels)), + data = list(reason = "floor above ceiling", n = n, + min_cell_n = NA_integer_, obs_per_cell = s_min)) + } + list(levels = levels, size_levels = size_levels, ceiling = finest, + ceiling_from = ceiling_from, supported = supported, too_few = too_few) +} + + +#' The most point-to-centre comparisons a fit at a fixed size may make +#' +#' @return \code{getOption("spatialkit.fit_work_max")}, or +#' \code{.FIT_WORK_MAX} when the option is not set. A value that is not +#' one number is an error and not a silent return to the default. +#' @keywords internal +#' @noRd +.fit_work_max <- function() { + lim <- getOption("spatialkit.fit_work_max", .FIT_WORK_MAX) + if (!is.numeric(lim) || length(lim) != 1L || is.na(lim) || lim < 0) + stop("options(spatialkit.fit_work_max = ) must be a single number of comparisons, ", + "0 or more; got ", .got_text(lim), ".", call. = FALSE) + as.numeric(lim) +} + + +#' Stop before partition fits that compare too many points with centres +#' +#' On a ladder of sizes the count of cells grows with the rows, so a step +#' that compares every point with every centre is quadratic in the rows. +#' Which fits have such a step: +#' \describe{ +#' \item{kind \code{"kmeans"}, either starting rule}{\code{stats::kmeans()} +#' compares points with centres in every pass, and a k-means++ start +#' makes one pass over the points per centre.} +#' \item{kind \code{"density"} from k-means++ starts, with \pkg{FNN}}{The +#' passes use a kd-tree; the start makes one draw per centre over all the +#' locations.} +#' \item{kind \code{"density"} without \pkg{FNN}}{Every pass compares every +#' location with every centre, and a start takes up to \code{iter_max} +#' passes: the count is that worst case.} +#' \item{kind \code{"density"} from random starts, with \pkg{FNN}}{None, +#' and no work is counted.} +#' } +#' The work is the points times the cells of the finest level times the +#' starts, times \code{iter_max} in the third case. +#' +#' @param n_points The rows the centres are fitted to. +#' @param cells The finest level. +#' @param nstart Number of starts, as resolved. +#' @param part The partition record: \code{kind} and \code{init}. +#' @param iter_max The iteration limit of a start. +#' @param use_fnn Whether \pkg{FNN} is used. Evaluated for the kind +#' \code{"density"}, and for the kind \code{"kmeans"} only when the call +#' stops. +#' @return \code{NULL}, invisibly; an error of class +#' \code{spatialkit_work_limit} when the work is above +#' \code{.fit_work_max()}, with \code{work}, \code{limit}, \code{what} +#' (\code{"partition fit"}), \code{kind}, \code{init}, \code{nstart} and +#' \code{fnn}. +#' @keywords internal +#' @noRd +.fit_guard <- function(n_points, cells, nstart, part, iter_max, use_fnn) { + density <- identical(part$kind, "density") + # `use_fnn` is read here for the density kind alone, whose count depends on + # it. For the kind "kmeans" it is read only when the call stops, for the + # condition's `fnn`, so a k-means profile that passes has not asked. + slow <- density && !isTRUE(use_fnn) + if (density && !slow && identical(part$init, "random")) return(invisible(NULL)) + passes <- if (slow) as.numeric(iter_max) else 1 + work <- as.numeric(n_points) * as.numeric(cells) * as.numeric(nstart) * passes + limit <- .fit_work_max() + if (!(work > limit)) return(invisible(NULL)) + fnn <- isTRUE(use_fnn) + one <- identical(as.integer(nstart), 1L) + with <- if (density && !fnn) + sprintf("%d start%s of up to %d pass%s each", as.integer(nstart), if (one) "" else "s", + as.integer(iter_max), if (identical(as.integer(iter_max), 1L)) "" else "es") + else sprintf("%d %s%s start%s", as.integer(nstart), if (density) "density-weighted " else "", + if (identical(part$init, "random")) "random" else "k-means++", + if (one) "" else "s") + msg <- sprintf(paste0("resolution_profile(): fitting %d cells to %d rows with %s is %.2g ", + "point-to-centre comparisons, above the limit of %.2g ", + "(options(spatialkit.fit_work_max = )). Ways on: fewer starts ", + "(`nstart`), which keep the best of fewer; a coarser `obs_per_cell`; ", + "partition = \"density\" with init = \"random\" and the FNN package ", + "installed, which has no step that compares every point with every ", + "centre and leaves a cell without a point more often; or a higher ", + "limit."), + as.integer(cells), as.integer(n_points), with, work, limit) + stop(errorCondition(msg, class = "spatialkit_work_limit", call = NULL, + work = work, limit = limit, what = "partition fit", + kind = part$kind, init = part$init, nstart = as.integer(nstart), + fnn = fnn)) +} + + +#' The estimate's numbers at one level of a profile +#' +#' Each scored row of the layer goes to its nearest centre, which is the +#' Voronoi cell the seeding functions hand on and \code{build_tessellation()} +#' draws. Centres that hold no scored row are dropped and the rest numbered +#' in the order of their centres. Then the engine gives the numbers +#' (\code{.pool_fit()}). The cluster vector of the fit is not read: on a +#' subsample it covers the subsample only, and a start cut off at its +#' iteration limit can leave a row outside its nearest centre's cell. +#' +#' @param xy Two-column matrix of the scored rows' coordinates. +#' @param y Their values. +#' @param centres Two-column matrix of the level's centres. +#' @param estimate \code{"mean"} or \code{"pooled"}. +#' @param use_fnn Whether \pkg{FNN} is used. The numbers are the same +#' without it. +#' @param cache The environment the levels of one profile share for the +#' nearest other location of a location. +#' @return A list: \code{cells} (the cells that hold a scored row), +#' \code{scored_per_cell} (rows over those cells), \code{loo} and +#' \code{loo_se} (the leave-one-out error of the estimate and its standard +#' error over rows), \code{share_alone} (the share of rows that are the +#' only scored row of their cell), \code{own_weight} (the median own weight +#' of a pooled value; \code{NA} under plain means and for a constant +#' column), \code{sigma2}, \code{tau2} (\code{NA} under plain means) and +#' \code{f_p}. +#' @keywords internal +#' @noRd +.estimate_at_level <- function(xy, y, centres, estimate, use_fnn, cache) { + N <- length(y) + g <- .nearest_centre(xy[, 1L], xy[, 2L], centres[, 1L], centres[, 2L], use_fnn) + u <- sort(unique(g)) + gi <- match(g, u) + K <- length(u) + fit <- .pool_fit(y, gi, K, xy, want = estimate, use_fnn = use_fnn, cache = cache, + caller = "resolution_profile") + pooled <- identical(estimate, "pooled") + list(cells = K, scored_per_cell = N / K, + loo = if (pooled) fit$loo_pooled else fit$loo_mean, + loo_se = if (pooled) fit$loo_pooled_se else fit$loo_mean_se, + share_alone = sum(fit$n == 1L) / N, + own_weight = if (pooled && !isTRUE(fit$constant)) stats::median(fit$w) else NA_real_, + sigma2 = fit$sigma2, tau2 = if (pooled) fit$tau2 else NA_real_, f_p = fit$f_p) +} + + #' Score every candidate number of cells on several criteria at once #' #' A tessellation's resolution is the number of cells the points are cut #' into, and no single number settles it: the within-cluster sum of squares #' of the coordinates has an elbow, a piecewise-constant approximation of the #' response has a Mallows \eqn{C_p}, the residual autocorrelation of the cell -#' means has a \eqn{z}, and the cell means have a reliability. This function -#' computes all of them at every level of a ladder the data bound, and -#' returns the table, so that the level chosen, by +#' means has a \eqn{z}, the cell means have a reliability, and a cell value +#' has a leave-one-out error. On a ladder of counts this function computes +#' all of them at every level the data bound, and returns the table, so that +#' the level chosen, by #' \code{\link{select_resolution}()} or by eye, can be defended with the #' whole profile in place of one criterion's argmin. Mallows (1973) presents #' \eqn{C_p} itself as a display of the bias-variance trade-off across #' candidates; he does not offer it as a rule that picks one. This is that #' display, with the other criteria alongside. #' +#' Called with a numeric response and no predictors and none of +#' \code{levels}, \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +#' \code{range_floor}, the profile is one level: 4.5 rows per cell +#' (\code{obs_per_cell = "auto"}), scored for pooled values +#' (\code{estimate = "auto"}) by the leave-one-out error \code{loo}, with +#' no variogram fitted (\code{sac = "auto"}), in regions of the density +#' kind (\code{partition = "density"}) kept from 3 k-means++ starts +#' (\code{nstart = NULL}). \code{cp} and \code{reliability} need the +#' variogram and \code{elbow} needs a curve, so the three are \code{NA} +#' there; \code{moran_z} is computed. \code{\link{select_resolution}()} +#' reads the count off it by the size. Any of those five ladder arguments +#' gives the +#' ladder of counts described below, scored for pooled values as well. +#' \code{estimate = NULL, obs_per_cell = NULL, sac = NULL, partition = +#' "kmeans"} gives the profile of earlier versions: the ladder, its columns +#' and its k-means regions from 25 starts. +#' +#' @section The partition: +#' The regions at every level are the Voronoi cells of a set of centres: a +#' point belongs to the centre nearest to it. \code{partition} says what the +#' centres minimise, and every level of the ladder is built with the same +#' kind. +#' \describe{ +#' \item{\code{"kmeans"}}{The sum, over the points, of the +#' squared distance to the nearest centre. The centres follow the square +#' root of the point density. The cells are compact, smaller where the +#' points are dense and larger where they are sparse, and a cell in a +#' dense place holds several times the points of a cell in a sparse +#' place.} +#' \item{\code{"density"} (default)}{The same sum with each point weighted +#' by its local density to the power \code{density_power}. The local +#' density at a point is the number of points in the disc that reaches +#' its \code{density_k}-th nearest neighbour, over the area of that disc. +#' With \code{density_power = 1} the centres follow the point density +#' itself. The cells are compact: many small ones where the points are +#' dense, a few large ones where they are sparse. They hold about the +#' same number of points each once there are more cells than dense +#' places (clusters of points). With fewer cells than dense places a +#' cell takes in whole clusters, large and small, and the counts are +#' about as uneven as under \code{"kmeans"}. \code{density_power = 0} +#' weights every point alike, which is the objective of +#' \code{"kmeans"}; a power above 1 goes past equal counts and gives the +#' cells of dense places fewer points than those of sparse places.} +#' } +#' Two simulations show both ends. The measure is the coefficient of +#' variation of the cell counts (their standard deviation over their mean, +#' 0 when every cell holds the same number), as medians over 20 layers. On +#' 1,200 points, 900 of them in four clusters over a sparse background, cut +#' into 60 cells, it was 1.2 under \code{"kmeans"}, where the fullest cell +#' held 42 times the points of the smallest, and 0.29 under +#' \code{"density"}, where it held 4 times. On 2,000 points with 28 dense +#' places (half of the points in 3 large clusters, 30 percent in 25 small +#' ones, the rest spread out) it was 0.90 under \code{"kmeans"} and 0.97 +#' under \code{"density"} at 10 cells and 1.08 and 1.01 at 20 cells; at 60 +#' cells it was 0.95 and 0.31, and at 130 cells 1.05 and 0.43. A ladder +#' starts at 2 cells, so its low levels are usually below the number of +#' dense places, and the counts in \code{cell_n_min} and +#' \code{cell_n_median} show where the two kinds part. +#' +#' The density kind is the default. The default size, 4.5 rows per cell, +#' puts the count above the number of dense places on a layer whose +#' clusters hold more than a few observations each, so the default kind and +#' the default count go together. A coarse ladder the caller sets (with +#' \code{levels}, large sizes, or the low levels of the automatic ladder) +#' may not, and at those levels the density kind does not even the counts. +#' \code{partition = "kmeans"} gives the k-means regions, with 25 +#' k-means++ starts, as earlier versions built them. +#' +#' \code{init} says how each of the \code{nstart} starts is drawn before it +#' is refined; the best start is kept. \code{"kmeans++"} draws the centres +#' one at a time, each a point taken in proportion to its squared distance +#' from the centres already drawn (times its weight, under +#' \code{"density"}), which spreads the start over the points. +#' \code{"random"} draws \code{k} distinct locations at random, as +#' \code{\link[stats]{kmeans}()} does. +#' +#' A start of the kind \code{"kmeans"} is refined by +#' \code{\link[stats]{kmeans}()} (Hartigan and Wong), for at most 50 +#' iterations from a k-means++ start and 100 from a random one. A start of +#' the kind \code{"density"} is refined by Lloyd's iteration, for at most 100 +#' steps: each point goes to its nearest centre, each centre moves to the +#' weighted mean of its points, and a centre left without a point stays +#' where it is. \code{iter_max} sets another limit. The start with the +#' lowest sum is kept, and a kept start that was cut off at the limit is +#' reported (see "Conditions"): its centres are those of the last step. +#' Large layers can need more than 100 steps: on a simulated layer of 30,000 +#' points no start of six at 100 and 300 cells took more than 68, and on one +#' of 60,000 points three of six took 102 to 152. +#' +#' The density kind depends on the points alone. It works on the distinct +#' locations in coordinate order, so the order of the rows does not matter. +#' Its two tolerances are fractions of the extent of the points (the diagonal +#' of their bounding box), so the unit of the coordinates does not matter: +#' the neighbour distance is not taken below a millionth of the extent, and +#' the iteration stops when no centre moves by \eqn{10^{-12}} of it. Points +#' at one location count as that many points at it and share a cell; the +#' neighbour distance is measured to the \code{density_k}-th nearest +#' \emph{other} location, so it is not zero where locations repeat. The +#' neighbour searches use \pkg{FNN} when it is installed. The result is the +#' same without it; the search then takes time that grows with the square of +#' the number of points, about thirty times as long for 10,000 points and +#' 2,000 centres. +#' +#' The columns keep their meaning under \code{"density"}, because each is +#' read off the cells and not off the way they were drawn. \code{wss} is the +#' within-cell sum of squares of the coordinates with every point counted +#' once, taken about each cell's mean, so \code{wss} and \code{elbow} +#' compare between kinds; the weighted sum the centres minimise is kept in +#' \code{attr(, "partition")$objective}, and \code{wss_spread} is its spread +#' over the starts. \code{cp}, \code{moran_z} and the test against one cell +#' need cells drawn without the response, which both kinds give. +#' \code{reliability} is computed for square cells of the level's average +#' area and count and never reads the cells, so it is the same number under +#' either kind. The \code{elbow} is found more readily under +#' \code{"density"} where the points cluster: once each cluster has its +#' centres, further centres go into the clusters, the sparse ground between +#' them keeps its sum of squares, and the curve flattens. On simulated +#' layers of 800 points in 3 to 8 clusters over a sparse background an elbow +#' was read on 24 of 30 under \code{"density"} and on 10 under +#' \code{"kmeans"}; on 100 uniform layers, on none under either. +#' +#' A profile of the density kind, or of either kind from random starts, +#' carries \code{attr(, "partition")}, and +#' \code{\link{select_resolution}()}, the seeding functions and +#' \code{\link{build_tessellation}()} hand that record on with the regions +#' (see "Value"). A result with no such record was built by plain k-means: +#' from k-means++ starts when it comes from a profile, and from random +#' starts when a seeding function fitted it. +#' #' @section The ladder and its bounds: -#' Cells are k-means clusters of the (projected) coordinates, fitted at each -#' level as the best of \code{nstart} k-means++ restarts (see -#' \code{\link{determine_optimal_levels}} for why). Levels are spaced +#' This is the ladder of a call that sets \code{levels}, \code{n_levels}, +#' \code{min_cell_n}, \code{sample_n} or \code{range_floor}, or passes +#' \code{obs_per_cell = NULL}, and of a call with no estimate: one without +#' a response, with \code{predictor_vars}, or with a logical or wholly +#' missing response. Cells are clusters of the (projected) +#' coordinates of the kind \code{partition} names, fitted at each level as +#' the best of \code{nstart} k-means++ starts (see +#' \code{\link{determine_optimal_levels}} for why) unless \code{init} says +#' otherwise (see "The partition"). Levels are spaced #' logarithmically, because cell diameter scales as \eqn{L^{-1/2}}: a unit #' step wastes fits at large \eqn{L} and starves resolution at small. The -#' ladder runs from a floor to a ceiling the data impose. The ceiling is -#' \code{floor(n / min_cell_n)}, with \eqn{n} every point of the layer (not -#' the subsample): cells with fewer than \code{min_cell_n} points -#' on average have too little support, and Moran's z is not computable at -#' nine cells or fewer in any case. It is also held to the number of -#' distinct locations, one cell on each, and to one short of the number of -#' points, which \code{stats::kmeans()} needs. The floor is -#' \code{ceiling(area / range^2)} when an autocorrelation range is available: -#' cells wider than the range average over more than one patch of the field. -#' When the floor exceeds the ceiling the data cannot support a tessellation +#' ladder runs from 2 to a ceiling the data impose. The ceiling is +#' \code{floor(n / min_cell_n)}: cells with fewer than \code{min_cell_n} +#' rows on average have too little support. With a \code{response_var}, +#' \eqn{n} is the number of rows of the layer (not of the subsample) that +#' are scored: those with a response and, with \code{predictor_vars}, every +#' predictor, since the cell means the criteria read are built from those +#' rows alone. \code{ceiling_from} is then \code{"min_cell_n (rows with a +#' response)"} when some rows are not scored (the label is the same when it +#' is a predictor they lack), and a warning of class +#' \code{spatialkit_response_ceiling} gives both counts and names the bound +#' in force. Without a +#' \code{response_var}, or when no row has a response, \eqn{n} is every +#' point. The ceiling is also held to the number of distinct locations, one +#' cell on each, and to one short of the number of points, which +#' \code{stats::kmeans()} needs. The count \eqn{n / L} is the rows per cell +#' only when the scored rows are spread over the whole extent. +#' Where they sit in one part of it, the cells elsewhere hold none and the +#' occupied cells hold more than \eqn{n / L}, so the ceiling is lower than +#' those cells need: \code{cells_resp} and \code{cell_resp_mean} give the +#' cells that hold a scored row and the scored rows per such cell at each +#' level (of the subsample, when the cells are fitted to one), and +#' profiling the scored rows alone bounds the ladder by the area they +#' cover. +#' +#' When fewer than two cells meet \code{min_cell_n} +#' (\code{floor(n / min_cell_n) < 2}), or the layer has one distinct +#' location, there is no ladder: the profile scores two cells so that level +#' is still visible (or the \code{levels} asked for, as given), +#' \code{supported} is \code{FALSE}, \code{ceiling_from} +#' is \code{"fewer than two supported cells"} (or \code{"fewer than two +#' distinct locations"}) and a warning of class +#' \code{spatialkit_not_supported} names both numbers. +#' +#' \code{min_cell_n} sets the ceiling of this ladder. It is a mean number +#' of rows per cell and not a minimum: a cell of a level at the ceiling can +#' hold fewer (\code{cell_n_min}). It is floored to a whole number, so 4.5 +#' is read as 4. With \code{levels} it does not choose the levels scored, +#' and it still sets \code{bounds$ceiling}, \code{supported} and the +#' \code{spatialkit_not_supported} warning. +#' +#' The range floor is \code{ceiling(area / range^2)} when an autocorrelation +#' range is available: cells wider than the range average over more than one +#' patch of the field. It is reported in the bounds and the print, and by +#' default it is not applied: the ladder starts at 2. When the layer +#' supports the floor and it lies between the ladder's ends, the floor is +#' one of the ladder's levels all the same (so the ladder can have one more +#' level than \code{n_levels}): \code{select_resolution(criterion = +#' "reliability")} reads from the floor up and returns the floor itself, not +#' the next level the spacing happened to put above it. The range is an +#' estimate, and a response with no spatial structure can still be given +#' one: over 100 simulated white-noise layers of 900 points the variogram +#' returned a range on 29, and started at the floor, 11 of those ladders +#' began at 11 to 98 cells of a ceiling of 100 and \eqn{C_p} took the floor +#' or a level beside it, where the best count was 2 to 8. +#' \code{range_floor = TRUE} starts the ladder at the floor, as the default +#' did up to version 2.0.0. When +#' the floor exceeds the ceiling the data cannot support a tessellation #' that respects their own correlation structure; that is reported as a -#' finding (a logged warning, and \code{attr(x, "bounds")$supported} is -#' \code{FALSE}) and the ladder runs from 2 to the ceiling anyway, so the -#' profile still shows what each level costs. On a layer larger than -#' \code{sample_n} the ceiling is also held to half the subsample (two -#' subsample points per cell, the least a fitted cell can be scored on); -#' \code{ceiling_from} is then \code{"sample_n"}, a floor above that is logged -#' with a request to raise \code{sample_n}, and it does not make -#' \code{supported} \code{FALSE}. -#' -#' The floor moves with the range estimate, and the ceiling with \eqn{n}, so -#' two profiles of similar data (the folds of a cross-validation, say) can -#' sit on either side of the point where the floor applies: one ladder then -#' starts at the floor and the other at 2, and the criteria that sit near -#' the bottom of the ladder (\code{reliability}, which routinely peaks at the -#' floor, and \code{elbow}) can differ between them by a factor of 10 or -#' more. To compare profiles, pass the same \code{levels} to each, or -#' \code{range_floor = FALSE} to start every ladder at 2 while the floor is -#' still reported. -#' -#' @section The criteria, and how each behaved when measured: +#' finding (a warning of class \code{spatialkit_not_supported}, and +#' \code{attr(x, "bounds")$supported} is \code{FALSE}) and the ladder runs +#' from 2 to the ceiling, so the profile still shows what each level costs. +#' A floor equal to the ceiling would leave one level and nothing to compare +#' it with, so that ladder starts at 2 as well. On a layer larger than +#' \code{sample_n} the ceiling is also held to half the subsample's scored +#' rows (two per cell, the least a fitted cell can be scored on; half the +#' subsample without a response); \code{ceiling_from} is then +#' \code{"sample_n"}, a floor above that is logged with a request to raise +#' \code{sample_n}, and it does not make \code{supported} \code{FALSE}. +#' +#' The floor moves with the range estimate, and the ceiling with \eqn{n}. +#' To compare profiles of similar data (the folds of a cross-validation, +#' say), pass the same \code{levels} to each. \code{reliability} is the one +#' criterion that still reads the floor: \code{\link{select_resolution}()} +#' holds it to the levels at or above the floor by default, so its pick can +#' differ between two such profiles by a factor of 10 or more when the floor +#' is supported on one and not on the other; pass \code{range_floor = FALSE} +#' there to read the whole ladder. +#' +#' A ladder that \code{obs_per_cell} sets is a ladder of sizes (see +#' "Observations per cell"). It has one level per size \eqn{s}, +#' \code{max(2, round(n / s))} cells, held to the most centres k-means can +#' place: the distinct locations, and one short of the points. Its centres +#' are fitted to every row. No subsample is drawn, and \code{n_levels}, +#' \code{min_cell_n}, \code{sample_n} and \code{range_floor} are not read. +#' The finest size takes the part \code{min_cell_n} has on the ladder above: +#' \code{bounds$ceiling} is the finest level, and \code{supported} is +#' \code{FALSE} when the finest size gives fewer than two cells or the range +#' floor is above the finest level. The range floor is reported and not +#' applied. +#' +#' A ladder of sizes under \code{sac = "auto"} fits no variogram, so +#' \code{cp} and \code{reliability} are \code{NA} at every level there, and +#' \code{attr(, "cp_noise")} says why. \code{sac = NULL}, or a \code{sac} of +#' the caller's own, gives them. \code{sac = "auto"} and +#' \code{obs_per_cell = "auto"} are the defaults, so the default profile +#' has neither column. +#' +#' @section Observations per cell: +#' \code{obs_per_cell} sets the ladder by a size: the mean number of rows a +#' cell is to hold. The level of a size \eqn{s} is +#' \code{max(2, round(n / s))} cells, with \eqn{n} the rows the size +#' divides (see the argument). A size says how many observations a cell +#' value is to stand on, and that is the caller's choice: no criterion makes +#' it. Under a size neither the cells, which are fitted to the coordinates, +#' nor their number, which is a count of rows, depend on the values of the +#' response. Under \code{select_resolution(criterion = "loo")} the count +#' does. +#' +#' For pooled values the leave-one-out error tends to keep falling as the +#' cells shrink, so its minimum tends to be the finest size offered, and the +#' end of the ladder would then choose the count. In a simulation +#' of 200 layers, each 1,500 clustered observations of a field with +#' covariance \code{exp(-d / 100)} plus noise on a square of side 1,000 +#' (\code{dev/sim-pooled-values.R} in the package's repository; +#' \code{\link{summarize_by_cell}} describes it), profiled at the sizes 18, +#' 12, 9, 6, 4.5, 3 and 2 with \code{partition = "density"}, the lowest +#' \code{loo} of the pooled value was at the size 2 on 176 layers, at 3 on +#' 22 and at 4.5 on 2. That of the plain mean was at 2 on none: it was at 6 +#' on 86 layers, at 4.5 on 51, at 9 on 49, at 12 on 12, and at 18 and at 3 +#' on one each. \code{select_resolution(criterion = "size")} therefore sets +#' the count of pooled values from a size, 4.5 unless another is given, and +#' \code{criterion = "loo"} reads the lowest error for plain means. These +#' figures are of those seven sizes and say nothing of another ladder. +#' +#' Two columns say what a size leaves a cell value to stand on. +#' \code{share_alone} is the share of the scored rows that are the only +#' scored row of their cell: the plain mean of such a cell is one +#' observation, and its pooled value has the smallest own weight a cell can +#' have. \code{own_weight} is the median weight a pooled value gives the +#' cell's own mean: at 1 the pooled values are the plain means, and at 0 +#' each is the mean of the cell's neighbours. +#' +#' \code{obs_per_cell = "auto"}, the default, is resolved against the other +#' ladder arguments, in this order. Whether the caller supplied an argument +#' is what counts, so a value a wrapper passes on counts as supplied. +#' \enumerate{ +#' \item With \code{levels}, \code{"auto"} is \code{NULL}: the levels are +#' scored as given. A numeric \code{obs_per_cell} beside \code{levels} +#' is an error, since each sets the ladder. +#' \item With \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +#' \code{range_floor} supplied, \code{"auto"} is \code{NULL}: those +#' arguments describe the ladder of "The ladder and its bounds", and the +#' caller gets it, with the estimate's columns when there is an +#' estimate. +#' \item Otherwise \code{"auto"} is 4.5 when the estimate is +#' \code{"pooled"}, the seven sizes 18, 12, 9, 6, 4.5, 3 and 2 when it +#' is \code{"mean"}, and \code{NULL} without an estimate. +#' \item A numeric \code{obs_per_cell} beside \code{n_levels}, +#' \code{min_cell_n}, \code{sample_n} or \code{range_floor = TRUE} sets +#' the ladder, with a warning of class \code{spatialkit_ladder_unused} +#' that names the arguments that are not read. +#' } +#' +#' On a ladder of sizes the centres are fitted to every row and the count of +#' cells grows with the rows, so a step that compares every point with every +#' centre grows with the square of the rows. \code{partition = "kmeans"} +#' has such a step in every pass and in a k-means++ start. \code{partition +#' = "density"} has it in a k-means++ start and, without \pkg{FNN}, in every +#' pass; with \pkg{FNN} and \code{init = "random"} it has none. The profile +#' stops before any fit, with an error of class +#' \code{spatialkit_work_limit}, when the points times the cells of the +#' finest level times \code{nstart} (times \code{iter_max} for the density +#' kind without \pkg{FNN}) is above +#' \code{getOption("spatialkit.fit_work_max", 1e10)}. The message names the +#' ways on: fewer starts, which keep the best of fewer; a coarser size; +#' \code{partition = "density"} with \code{init = "random"} and \pkg{FNN} +#' installed, which leaves a cell without a point more often (see +#' \code{spatialkit_empty_cells} under "Conditions"); or a higher limit. +#' The limit counts the finest level, and a ladder of several sizes fits +#' every one of its levels. At the default size the work grows with the +#' square of the rows, and the limit is set where the default call's fit +#' takes about a minute: a call just below it runs that long, and prints +#' nothing while it runs. +#' +#' Without \pkg{FNN} the density kind also finds its weights by comparing +#' every pair of distinct locations. A profile on a ladder of sizes stops, +#' with the same class, when the square of their number is above +#' \code{getOption("spatialkit.exact_pairs_max", 2e9)}, which is about +#' 44,700 locations. The result of every search is the same with and +#' without the package. \code{moran_i} and \code{moran_z} need \pkg{FNN} +#' and \pkg{Matrix} at a level where more than 5,000 cells hold a scored +#' row. Without them a ladder of sizes has \code{NA} in both columns +#' there, with a warning of class \code{spatialkit_moran_skipped}, and so +#' does a ladder set any other way (see "Conditions"). +#' At a level of up to 5,000 such cells, when either package is missing, the +#' neighbour weights of the cell means are held as a dense matrix of cells +#' by cells. +#' +#' @section The criteria, and what each returns in practice: +#' The four columns are not four interchangeable count rules. +#' \code{select_resolution()} reads \code{cp} by default on a profile +#' without an estimate; on one with an estimate it reads the size (pooled +#' values) or \code{loo} (plain means). \code{reliability} +#' needs a variogram range and is \code{NA} without one; \code{elbow} is +#' \code{NA} unless the points cluster; and \code{moran_z} is a diagnostic +#' and not a count rule. With an \code{estimate} the profile has a fifth +#' column, \code{loo}, which is the last entry. Each entry below says what +#' the column measures and what it returns in practice. #' \describe{ #' \item{\code{elbow}}{How far the WSS curve sags below a power law: on #' log-log axes, \eqn{\log} WSS below the straight line from \eqn{k = 1} @@ -202,13 +849,22 @@ #' no elbow, that fall to zero is the elbow, and its sag is measured with #' the WSS floored at \eqn{10^{-12}} of the total, which puts it far #' above any other level's. Geometry only; it knows nothing of the -#' response.} +#' response. \strong{In practice it is \code{NA} unless the points +#' cluster}, and where they do it names the number of clusters, which +#' is usually the first level or two of the ladder.} #' \item{\code{cp}}{Mallows' \eqn{C_p} of the piecewise-constant #' approximation of the response (or of its OLS residuals on #' \code{predictor_vars}) by cell means: \eqn{RSS(L)/n + 2 \tau^2 L / n}, #' with \eqn{\tau^2} the nugget of the fitted variogram (lower is better). -#' It estimates the error of predicting a new observation by the mean of -#' its cell. When the cells are fitted to a subsample of \eqn{m} of the +#' It estimates the error of re-measuring the sampled sites: each scored +#' row observed again at its own location, with fresh noise of variance +#' \eqn{\tau^2}, and predicted by the mean of its cell. For an +#' observation at a new location the penalty needs the spread of the +#' field inside a cell as well, which the nugget leaves out. This +#' \eqn{\tau^2} is the nugget, the noise of one measurement; it is not +#' the \code{tau2} of a pooled value, which is the mean squared distance +#' between a cell's level and its target. When the +#' cells are fitted to a subsample of \eqn{m} of the #' \eqn{N} points with a response, the penalty is split between the two: #' \eqn{RSS(L)/m + \tau^2 L_m / m + \tau^2 L / N}, where the first two #' terms estimate the approximation error from the subsample (adding back @@ -229,51 +885,278 @@ #' (under \eqn{10^{-4}} of the sill; usually a fit clipped at its lower #' bound) the penalty is 0 and \eqn{C_p} descends to the ceiling whatever #' the field; the profile warns. When the variogram gives no nugget (none -#' was fitted, its fit did not converge, its range is below the shortest -#' lag, or \code{sac} is a range alone), \eqn{\tau^2} is Mallows' own +#' was fitted, its fit has no minimum inside the ranges searched, its +#' range is below the shortest lag, it found no spatial structure, or +#' \code{sac} is a range alone), \eqn{\tau^2} is Mallows' own #' choice instead: the residual mean square \eqn{RSS / (m - L_m)} of the #' finest level whose cells hold at least two scored rows on average. It #' counts the structure within those cells as noise too, so on average it #' is no smaller than the nugget and errs towards fewer cells; the profile warns, #' and \code{attr(, "cp_noise")} records which was used. When no level's -#' cells hold that many, \code{cp} is \code{NA} at every level.} -#' \item{\code{moran_z}}{The standardised deviate of Moran's I on the -#' residuals of the cell means regressed on the cell-mean predictors (an -#' intercept alone when there are none): how much spatial structure the -#' tessellation has left unexplained (\eqn{|z|} smaller is better). -#' Calibrated and flat in \eqn{L} on a response with no structure (see -#' \code{\link{determine_optimal_levels}}), so it separates levels only -#' where structure remains. \code{NA} at nine cells or fewer.} +#' cells hold that many, \code{cp} is \code{NA} at every level, as it is +#' for a constant response, which the profile warns about. +#' \strong{In practice its minimum is often a bound}, the support +#' ceiling when the nugget is a small share of the sill, and +#' \code{select_resolution()} then names the bound in \code{edge}. The +#' same formula at one cell, +#' with the total sum of squares as its RSS, is kept in +#' \code{attr(, "one_cell")}, with the p-value at every level of the F +#' test of that level's cell means against one mean. A level has to +#' beat one cell: \code{select_resolution()} returns +#' \code{structured = FALSE} when \eqn{C_p} at one cell is within +#' \code{tol} of the optimum, or when the cell means at the optimum +#' differ from one mean by no more than chance allows, because one mean +#' for the whole layer then predicts as well as the cells and the count +#' is not identified (see \code{\link{select_resolution}} for the rule +#' and its measured error rates).} +#' \item{\code{moran_z}}{\strong{A diagnostic of the cell means, not a +#' count rule.} The standardised deviate of Moran's I on the cell +#' means, or with \code{predictor_vars} on the residuals of the cell +#' means regressed on the cell-mean predictors, over the 8 nearest +#' neighbours of each cell. It tests whether neighbouring cell means +#' are independent. It does not measure what the cells leave +#' unexplained, and it does not say how well they represent the +#' response. On any autocorrelated response it grows as the cells get +#' finer than the range, because neighbouring cells then resemble each +#' other, and it has almost no +#' power below about 20 cells, where the 8-neighbour graph between cells +#' is close to complete and Moran's I sits near \eqn{-1/(L - 1)} +#' whatever the data. The level with the smallest \eqn{|z|} is +#' therefore among the coarsest it is computed at on a structured +#' response, whatever the layer and its ceiling, and arbitrary on a +#' response with no structure, where +#' \eqn{z} is calibrated and flat in \eqn{L}. +#' \code{select_resolution()} refuses to read it as a criterion unless +#' asked with \code{diagnostic = TRUE}, and neither \code{summary()} nor +#' the functions that take a profile as a cell count read it by +#' default. \code{NA} at nine cells or fewer.} #' \item{\code{reliability}}{The between-cell signal's share of the spread #' in the cell means, from the fitted variogram alone via Krige's #' additivity relation (Cressie 1996), for square cells of the level's #' average area holding the level's average share of the layer's points #' with a response (larger is better). -#' This is the shrinkage factor of Fay and Herriot (1979). It has an -#' interior optimum, and a broad one: validated against the empirical -#' reliability of true block means on simulated fields, the analytic and -#' empirical optima agreed to within a level or two where the empirical -#' estimate was stable, and the band within 2 percent of the maximum -#' spanned a factor of 3--6 in \eqn{L}. Read the flat region, not the -#' argmax. The domain term is taken over the convex hull the area is -#' measured on, so rotating the layer does not move it. \code{NA} -#' without a usable variogram, and when the variogram's range was -#' rejected (see \code{sac}).} +#' This is the shrinkage factor of Fay and Herriot (1979). The curve +#' has an interior optimum, and a broad one: validated against the +#' empirical reliability of true block means on simulated fields, the +#' analytic and empirical optima agreed to within a level or two where +#' the empirical estimate was stable, and the band within 2 percent of +#' the maximum spanned a factor of 3--6 in \eqn{L}. \strong{That +#' optimum usually lies below the range floor}: on 20 simulated fields +#' of 900 points the curve read from the floor up was highest at the +#' floor on 19. +#' \code{select_resolution()} therefore reads it at the levels at or +#' above the floor (its \code{range_floor} argument), and what it +#' returns is then the floor, which is a level of every ladder the +#' profile builds: the coarsest +#' count the range allows, with the range choosing and not the curve. +#' Read the flat region, not the argmax. The domain term is taken over +#' the convex hull the area is measured on, so rotating the layer does +#' not move it. \code{NA} without a usable variogram, and when the +#' variogram's range was rejected (see \code{sac}).} +#' \item{\code{loo}}{With an \code{estimate}: the leave-one-out mean +#' squared error of that cell value (lower is better). It estimates the +#' squared error of predicting one further observation, at a location +#' drawn the way the data's locations were, by the value of the cell it +#' falls in. That error depends on the cell value, so the column is +#' computed for the estimate the profile is given and for no other. +#' Each scored row of the layer is predicted by the value of its cell +#' computed without it, in the cell of its nearest centre, which is the +#' cell the seeds will build. Under \code{"mean"} a row in a cell of +#' two or more is predicted by the mean of the others, and a row alone +#' in its cell by the mean of the cell of its nearest other scored row. +#' Under \code{"pooled"} the cell's mean and its own weight are computed +#' again without the row; the spread inside the cells, the spread +#' between a cell and its target and the targets are held; and a cell +#' left empty takes its target. It needs no variogram. It describes +#' locations among the observations and says nothing of a location away +#' from them: it is a criterion for comparing levels where data are +#' near, not an estimate of the error of a map. \code{loo_se} is the +#' standard error, over rows, of that level's mean squared error. It is +#' not the standard error of a difference between two levels, whose +#' errors come from the same rows. \code{scored_per_cell} counts the +#' rows \code{loo} read, every scored row of the layer, over the cells +#' that hold one; \code{cell_resp_mean} counts the rows the other +#' response criteria read, which are the subsample's when the cells are +#' fitted to one. \strong{In the simulation described under +#' "Observations per cell", on a ladder of the seven sizes 18 to 2, its +#' minimum was at the finest size on 176 of 200 layers for pooled values +#' and on none for plain means}: for pooled values a size sets the count, +#' and \code{select_resolution(criterion = "size")} reads it.} #' } #' \code{cp} and \code{reliability} answer different questions: how well the #' cells represent the field, and whether the cell values are distinguishable #' from noise. They can disagree, and both are shown so the choice between #' them is made knowingly. #' +#' @section Conditions: +#' What changes the meaning of a result is raised as an R warning with a +#' class, so \code{tryCatch()}, \code{withCallingHandlers()} and +#' \code{options(warn = 2)} see it without matching message text; the rest +#' is logged (see \code{\link{spatialkit_quiet}}). +#' \describe{ +#' \item{\code{spatialkit_not_supported}}{\code{resolution_profile()}: +#' \code{supported} is \code{FALSE}, because the range floor exceeds the +#' ceiling or because fewer than two cells meet \code{min_cell_n}.} +#' \item{\code{spatialkit_response_ceiling}}{\code{resolution_profile()}: +#' rows that are not scored (no response, or with \code{predictor_vars} +#' a predictor missing) lowered the ceiling. The message names the +#' bound in force, \code{min_cell_n} or, on a subsample, \code{sample_n}; +#' the condition carries \code{n}, \code{n_response}, \code{ceiling}, +#' \code{ceiling_from}, \code{n_sample} and \code{n_scored}.} +#' \item{\code{spatialkit_constant_response}}{\code{resolution_profile()}: +#' the scored variable is constant to within rounding (a response the +#' predictors fit exactly leaves such residuals), so \code{cp}, +#' \code{moran_i} and \code{moran_z} are \code{NA} at every level.} +#' \item{\code{spatialkit_empty_cells}}{\code{resolution_profile()}, +#' \code{\link{get_voronoi_seeds}()} and +#' \code{\link{voronoi_seeds_kmeans}()} under \code{partition = +#' "density"}: a centre holds no point, so there are fewer occupied cells +#' than the count. A centre that loses its points stays where it is, and +#' the start that is kept is the one with the lowest sum, whether or not +#' all its centres hold points. It happens at high counts, mostly from +#' \code{init = "random"}. On simulated layers of 800 points (in 4 +#' clusters, in 28, and uniform; 20 of each) no partition into 80 cells +#' or fewer had such a centre. At 400 cells, from random starts with +#' the best of 10 kept, 2, 5 and 1 of the 20 layers had one; from +#' k-means++ starts none of 840 partitions at 40 to 600 cells had one, +#' though it can happen. The condition carries \code{level}, the count, +#' and \code{empty}.} +#' \item{\code{spatialkit_not_converged}}{\code{resolution_profile()}, +#' \code{\link{get_voronoi_seeds}()} and +#' \code{\link{voronoi_seeds_kmeans}()}, for every call except the +#' plain k-means each has always run: the start that was kept was cut +#' off at the iteration limit, so its centres are those of the last step +#' and a longer run can still move points between cells. The condition +#' carries \code{level} (the count; for a profile every level it +#' happened at), \code{iter} and \code{iter_max}. Raise +#' \code{iter_max} (\code{kmeans_iter} in +#' \code{get_voronoi_seeds()}).} +#' \item{\code{spatialkit_partition_unused}}{\code{\link{get_voronoi_seeds}()} +#' and \code{\link{voronoi_seeds_kmeans}()}, given a profile or a +#' \code{select_resolution()} result together with a \code{partition}, +#' an \code{init} or density settings other than those the profile was +#' built with: the scored centres are returned, and what the call asked +#' for is not used. The +#' condition carries \code{kind} and \code{init}, those of the centres +#' returned.} +#' \item{\code{spatialkit_bound_chosen}}{\code{\link{get_voronoi_seeds}()}, +#' \code{\link{voronoi_seeds_kmeans}()} and +#' \code{\link{build_tessellation}()}, given a profile or a +#' \code{select_resolution()} result whose optimum sits on a bound of +#' the ladder: the bound chose the count. The condition carries +#' \code{edge}, \code{criterion} and \code{n}.} +#' \item{\code{spatialkit_no_structure}}{The same functions, given a count +#' whose \code{structured} is \code{FALSE}: one cell does as well, so +#' the count is not identified. A count set by a size stands, since no +#' criterion chose it, and the warning then says that the cell values +#' will say little that one mean for the layer does not. +#' \code{\link{summarize_by_cell}(estimate = "pooled")} raises the class +#' for its own cells.} +#' \item{\code{spatialkit_no_elbow}}{\code{\link{determine_optimal_levels}()}: +#' the WSS curve has no elbow, or the ladder is too short to show one, +#' so the count returned is the ladder's and not a finding. The +#' condition carries \code{k}, \code{sag} and \code{structured}.} +#' \item{\code{spatialkit_diagnostic_ranking}}{\code{\link{determine_optimal_levels}()} +#' under \code{criterion = "morans_i"} or \code{"combined"}: Moran's z +#' of the cell means, a diagnostic and not a count rule, ordered the +#' candidates returned. The condition carries \code{k}, +#' \code{criterion}, \code{first_computable}, \code{window} and +#' \code{upgraded}.} +#' \item{\code{spatialkit_ladder_unused}}{\code{resolution_profile()}: a +#' numeric \code{obs_per_cell} sets the ladder, and the caller also +#' supplied \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +#' \code{range_floor = TRUE}, which are then not read. The condition +#' carries \code{unused} (the argument names) and \code{obs_per_cell}.} +#' \item{\code{spatialkit_size_not_reached}}{\code{resolution_profile()} +#' on a ladder of sizes: a size does not give the count it asks for. +#' Either a size given as a number gives fewer than two cells while a +#' finer one does not, and its level is 2 (\code{reason} is +#' \code{"fewer than two cells"}); or a size asks for more cells than +#' k-means can place, and its level is the most that can (\code{reason} +#' is \code{"more cells than can be placed"}). The condition carries +#' \code{obs_per_cell}, +#' \code{wanted}, \code{used} and \code{reason}. When the finest size +#' gives fewer than two cells the warning is +#' \code{spatialkit_not_supported}, with \code{obs_per_cell} among its +#' fields and \code{min_cell_n} \code{NA}; and +#' \code{spatialkit_response_ceiling} is not raised on such a ladder, +#' since a size already counts the rows with a response.} +#' \item{\code{spatialkit_repeated_locations}}{\code{resolution_profile()} +#' with an \code{estimate}: scored rows share a location. Each row is +#' left out alone and the others at its location stay, so \code{loo} +#' then describes a further observation at a place already observed. +#' Raised once, after the levels are scored, and not when \code{loo} is +#' \code{NA} at every level. The condition carries \code{n} (the rows +#' that share a location), \code{total} (the rows \code{loo} read) and +#' \code{column}.} +#' \item{\code{spatialkit_moran_skipped}}{\code{resolution_profile()} +#' with a level of more than 5,000 cells, on any ladder, when +#' \pkg{FNN} or \pkg{Matrix} is not installed: \code{moran_i} and +#' \code{moran_z} are \code{NA} at a level where more than 5,000 cells +#' hold a scored row, and every other column is computed. Raised once, +#' before the first fit, when such a level can occur: the cells that +#' hold a scored row are counted after a level's fit, so where rows +#' without a response leave fewer of them the two columns are computed +#' after all. The condition carries \code{limit}, \code{levels} (the +#' levels above the limit) and \code{missing}.} +#' } +#' Two refusals are errors with a class: \code{spatialkit_diagnostic_criterion} +#' (\code{select_resolution(criterion = "moran_z")} without +#' \code{diagnostic = TRUE}) and \code{spatialkit_no_default_criterion} (a +#' profile passed as a cell count whose \code{cp} is \code{NA} at every +#' level while another criterion is finite). The remaining warnings of +#' these functions (points dropped, a variogram that gives \code{cp} no +#' nugget, a zero nugget, a variogram of another variable) are R warnings +#' without a class; rows left out for a missing response, a rising WSS +#' curve and a subsample too small to reach the floor are logged only. +#' +#' A third refusal is an error of class \code{spatialkit_work_limit}: +#' \code{resolution_profile()} stops before a step whose count of +#' comparisons is above a limit. The condition carries \code{work} (the +#' count), \code{limit} and \code{what} (the step). On a ladder that +#' \code{obs_per_cell} sets, the count of cells grows with the rows, so two +#' costs are bounded before the variogram is estimated and before any fit. +#' The fits: the points times the cells of +#' the finest level times \code{nstart} may not pass +#' \code{getOption("spatialkit.fit_work_max", 1e10)} +#' (\code{what = "partition fit"}; the condition also carries \code{kind}, +#' \code{init}, \code{nstart} and \code{fnn}). That product counts the +#' step in which every point is compared with every centre, which +#' \code{partition = "kmeans"} has in every pass and in a k-means++ start, +#' and \code{partition = "density"} has in a k-means++ start. Without +#' \pkg{FNN} the density kind compares every point with every centre in +#' every pass, and the product is multiplied by \code{iter_max}; with +#' \pkg{FNN} and \code{init = "random"} it has no such step and nothing is +#' counted. The density kind's weights: without \pkg{FNN} they come from a +#' search that compares every pair of distinct locations, and the square of +#' their number may not pass \code{getOption("spatialkit.exact_pairs_max", +#' 2e9)} (\code{what = "density weights"}); \code{density_power = 0} has no +#' weights and no such search. With an \code{estimate} and without +#' \pkg{FNN}, on any ladder, the same limit bounds the three exact searches +#' the estimate's columns make: each scored row's nearest centre, each cell's +#' nearest cells, and, under \code{"mean"}, the nearest other location of a +#' row alone in its cell. The result of every search is the same with and +#' without \pkg{FNN}. +#' +#' The warnings of the pooled values and of the count record, which +#' \code{\link{summarize_by_cell}()} raises, are listed under "Conditions" on +#' its page. +#' #' @param data_sf An sf object of points (other geometries are reduced to #' representative points). Features with empty or non-finite coordinates #' are dropped with a warning. #' @param response_var Optional response column name (numeric or logical). -#' Enables \code{cp} and \code{moran_z}. A variogram estimated from it also -#' sets the floor of the ladder and \code{reliability}. Rows where it, or a -#' predictor, is missing or non-finite stay in the geometry and are left out -#' of the OLS fit, the RSS, \code{cp} and \code{moran_z}; a logged warning -#' gives their number. +#' Enables \code{cp} and \code{moran_z}, and, when it is numeric, the +#' pooled estimate the default profile scores by \code{loo}. A variogram +#' estimated from it also gives the range floor the bounds report and +#' \code{reliability}; it is estimated on a ladder of counts or when +#' \code{sac} asks for it, and not on the default ladder of one size, so +#' \code{cp} and \code{reliability} are \code{NA} there. Rows +#' where it, or a predictor, is missing or non-finite stay in the geometry +#' and are left out of the OLS fit, the RSS, \code{cp}, \code{moran_z} and +#' the count the support ceiling divides by \code{min_cell_n}; a logged +#' warning gives their number, and an R warning says so when they lower +#' the ceiling. #' @param predictor_vars Optional predictor column names (numeric or #' logical). With them, \code{cp} scores the OLS residuals of the response #' on the predictors, the variogram is estimated from those residuals, and @@ -283,17 +1166,36 @@ #' at or above the number of points, are dropped (k-means cannot place more #' centres than there are distinct points, and \code{stats::kmeans()} #' refuses as many centres as points). -#' @param n_levels Number of levels on the ladder. Default 20. -#' @param min_cell_n Minimum average number of points per cell that a level -#' must keep; sets the ceiling. Default 9. +#' @param n_levels Number of levels on the ladder. Default 20. The ladder +#' has fewer when rounding puts two of them on one count, and one more +#' when the range floor is added as a level (see "The ladder and its +#' bounds"). Supplying it, or \code{min_cell_n}, \code{sample_n}, +#' \code{levels} or \code{range_floor}, gives that ladder in place of the +#' ladder of sizes \code{obs_per_cell = "auto"} would set. +#' @param min_cell_n Minimum average number of rows per cell that a level +#' must keep (scored rows when \code{response_var} is given: those with a +#' response and every predictor; points otherwise); sets the ceiling. +#' Default 9. A layer that cannot give two cells that many is profiled at +#' two cells, or at the \code{levels} asked for, with +#' \code{supported = FALSE} and a warning. It is floored to a whole +#' number, and it is not read on a ladder \code{obs_per_cell} sets (see +#' "The ladder and its bounds"). #' @param sample_n Points are subsampled to this many before the k-means -#' fits, as in \code{determine_optimal_levels()}. Default 1500. The -#' columns read off the fitted cells (\code{wss}, the \code{cell_} columns, -#' \code{rss}, \code{moran_i}, \code{moran_z}) describe the subsample; the -#' bounds, \code{supported}, the variance term of \code{cp} and -#' \code{reliability} describe every point of the layer, so the answer does -#' not change with \code{sample_n} except through the fits. -#' @param nstart k-means++ restarts per level. Default 25. +#' fits, as in \code{determine_optimal_levels()}, on the ladder of "The +#' ladder and its bounds"; on a ladder of sizes, the default, the centres +#' are fitted to every row. Default 1500. The +#' columns read off the fitted cells (\code{wss}, the \code{cell_} and +#' \code{cells_} columns, \code{rss}, \code{moran_i}, \code{moran_z}) +#' describe the subsample; the bounds, \code{supported}, the variance term +#' of \code{cp} and \code{reliability} describe the whole layer, so the +#' answer does not change with \code{sample_n} except through the fits. +#' @param nstart Starts per level; the best is kept. They are k-means++ +#' starts unless \code{init} says otherwise. \code{NULL} (default) is the +#' kind's own number: 3 for the kind \code{"density"} and 25 for the kind +#' \code{"kmeans"}, the number earlier versions ran. A number is run +#' under either \code{partition}: \code{nstart = 25} gives the density +#' kind the starts it had when 25 was the default. +#' \code{attr(, "nstart")} holds the number that was run. #' @param seed RNG seed for the subsample and the restarts; restored #' afterwards. Default 123. The rows are put in coordinate order before #' either, so the profile does not depend on the order they come in. @@ -308,16 +1210,19 @@ #' \code{cell_diam_median} are then in that CRS's units. A sac whose #' range was rejected (\code{NA} with a \code{rejected_reason}) gives #' \code{cp} its nugget, with a warning, and leaves \code{reliability} -#' \code{NA}, since that needs the range; one whose model did not converge, -#' or whose range is below the shortest lag fitted (a structure that -#' cannot be told from a nugget, so the nugget is not identified either), +#' \code{NA}, since that needs the range; one whose model did not converge +#' (its fit has no minimum inside the ranges searched, so its nugget and +#' sill are not fitted values), or whose range is below the shortest lag +#' fitted (a structure that cannot be told from a nugget, so the nugget is +#' not identified either), #' gives neither, and \code{cp} takes its noise variance from the finest #' level (see \code{cp} above). Whether the model converged is read from #' the model (\code{attr(attr(sac, "variogram_model"), "converged")}, which -#' \code{estimate_sac_range()} sets), not from the reason: the reason names -#' one ground for the refusal, and a fit that did not converge is most -#' often refused as past the largest lag. The warning then names both. A -#' sac that carries no such flag (one made by hand, say) is judged by its +#' \code{\link{estimate_sac_range}()} sets and describes), not from the +#' reason: the reason names one ground for the refusal, and such a fit is +#' refused as past the largest lag. The warning then names both. A +#' sac that carries no such flag (one made by hand, or built from REML +#' parameters) is judged by its #' reason. Under \code{select_on = "split"} the sac must come from #' the selection half alone: run the profile once without it, fit the sac #' on \code{data_sf[attr(p, "split")$selection, ]} and pass it to a second @@ -326,10 +1231,27 @@ #' (its selection half under \code{"split"}) with the same #' \code{predictor_vars}. A plain number is taken as the range alone, in #' the units of the CRS the profile is computed in (metres for lon/lat -#' input): it sets the floor, \code{reliability}, which needs a fitted -#' model, is \code{NA}, and \code{cp} takes its noise variance from the -#' finest level. A \code{units} object is refused +#' input): it gives the range floor, \code{reliability}, which needs a +#' fitted model, is \code{NA}, and \code{cp} takes its noise variance from +#' the finest level. A sac refused because the response shows no spatial +#' structure (either of the two \code{rejected_reason} values of +#' \code{\link{estimate_sac_range}()} that say so; the model it attaches +#' is a pure nugget) gives \code{cp} no +#' nugget either, and \code{select_resolution()} then returns +#' \code{structured = FALSE}. A \code{units} object is refused #' rather than read as a number in whatever unit it was written in. +#' The string \code{"auto"}, the default, is \code{NULL} on every ladder +#' but one that \code{obs_per_cell} sets. On that ladder no variogram is +#' estimated or +#' read: \code{cp} and \code{reliability} are \code{NA} at every level, +#' \code{cp} takes no noise variance from the finest level in its place, +#' \code{attr(, "cp_noise")} is a list whose \code{source} is +#' \code{"none"} and whose \code{reason} says why, and the +#' \code{variogram} and \code{sac} attributes are \code{NULL}. The +#' other columns do not read the variogram and are the numbers +#' \code{sac = NULL} gives. \code{sac = NULL}, the default of earlier +#' versions, estimates the variogram on a ladder of sizes too, and gives +#' \code{cp} and \code{reliability} there. #' @param select_on \code{"all"} (default) profiles every point; #' \code{"split"} reads the response on one spatially blocked half only #' (the OLS fit, the variogram, \code{rss}, \code{cp} and \code{moran_z}) @@ -342,25 +1264,134 @@ #' never touches them. See the "Post-selection inference" section of #' \code{\link{determine_optimal_levels}}; the profile reads the response #' whenever \code{response_var} is given. -#' @param range_floor \code{TRUE} (default) starts the ladder at the range -#' floor when the data support it; \code{FALSE} starts it at 2 whatever -#' the range, and the floor is only reported in the bounds and the print. -#' Use \code{FALSE} to compare profiles whose range estimates differ (see -#' "The ladder and its bounds"). +#' @param range_floor \code{FALSE} (default) starts the ladder at 2 whatever +#' the range, and the range floor is reported in the bounds and the print +#' without being applied. \code{TRUE} starts the ladder at the floor when +#' the data support it and the floor is below the ceiling, as the default +#' did up to version 2.0.0; an estimated range then sets the fewest cells +#' any criterion can choose (see "The ladder and its bounds"). +#' @param partition What the centres of the regions minimise, at every level +#' of the ladder. \code{"density"} (default): the sum of squared +#' distances from the points to their nearest centre, each point weighted +#' by its local density to the power \code{density_power}; compact cells +#' that, at the default power, hold about the same number of points each +#' once there are more cells than dense places, and counts about as uneven +#' as \code{"kmeans"} gives below that. \code{"kmeans"}: the same sum +#' unweighted; compact cells whose counts are several times higher in +#' dense places than in sparse ones. \code{"kmeans"} was the default of +#' earlier versions, and with \code{nstart = NULL} it runs their 25 +#' starts. See "The partition". +#' @param init How each start is drawn. \code{"kmeans++"} (default): the +#' centres one at a time, each in proportion to its squared distance from +#' those already drawn, times its weight under \code{partition = +#' "density"}. \code{"random"}: \code{k} distinct locations at random, as +#' \code{\link[stats]{kmeans}()} draws them. +#' @param density_power For \code{partition = "density"}: the power the local +#' density is raised to for a point's weight, a number from 0 to 2. +#' Default 1, which evens out the cell counts once the cells outnumber the +#' dense places (see "The partition"). \code{0} weights every +#' point alike, the objective of \code{"kmeans"} (reached by Lloyd's +#' iteration, so the centres are close to that kind's and not equal to +#' them); values between give counts between the two; values above 1 give +#' the cells of dense places fewer points than those of sparse places. +#' Setting it under \code{partition = "kmeans"}, which does not read it, +#' is a warning. +#' @param density_k For \code{partition = "density"}: the number of nearest +#' neighbours the local density is read from. Default 8. It is held to +#' one fewer than the distinct locations. A small number follows the +#' density closely and noisily; a large one smooths it. Setting it under +#' \code{partition = "kmeans"} is a warning. +#' @param iter_max The most iterations a start runs for: a single positive +#' whole number, or \code{NULL} (default) for the kind's own limit, 50 for +#' \code{partition = "kmeans"} from k-means++ starts and 100 for random +#' starts and for \code{partition = "density"}. A kept start that was cut +#' off at the limit is a warning of class +#' \code{"spatialkit_not_converged"}, except for the kind \code{"kmeans"} +#' from k-means++ starts under \code{iter_max = NULL}, which reports +#' nothing, as it always has. +#' @param estimate The cell value the profile scores, which is the one +#' \code{\link{summarize_by_cell}()} is to report: \code{"auto"} +#' (default; see below), \code{NULL} for none, \code{"mean"} for the +#' plain mean of a cell's rows, \code{"pooled"} for the mean pulled toward +#' the mean of the 8 nearest cells. With an estimate the profile gains +#' five columns and \code{attr(, "estimate")} (see "Value"), and every +#' column and attribute it has without one is unchanged. \code{loo} is +#' the leave-one-out mean squared error of that estimate: each row predicted +#' by the value of its cell computed without it. Under \code{"mean"} a +#' row in a cell of two or more is predicted by the mean of the others, +#' and a row alone in its cell by the mean of the cell of its nearest +#' other row. Under \code{"pooled"} the cell's mean and its own weight +#' are computed again without the row, and the spread inside the cells, +#' the spread between a cell and its target, and the targets are held. +#' It is computed on every row of the layer with a finite response (of the +#' selection half under \code{select_on = "split"}), not on the subsample +#' the centres were fitted to, and each row is scored in the cell of its +#' nearest centre, the cell \code{\link{get_voronoi_seeds}()} hands on. +#' It needs no variogram. Rows at one location are left out one at a +#' time. \code{"auto"} is \code{"pooled"} when there is a numeric +#' \code{response_var} with a finite value and no \code{predictor_vars}, +#' and \code{NULL} otherwise. \code{NULL}, the default of earlier +#' versions, scores none and gives the profile without the five columns. +#' \code{"mean"} and \code{"pooled"} are +#' errors without a \code{response_var}, with \code{predictor_vars} (the +#' profile would then score residuals, and the summary reports cell values +#' of the response), with a logical response, and with a response that has +#' no finite value. +#' @param obs_per_cell Rows per cell: \code{"auto"} (default; see below); +#' \code{NULL} for the ladder described under "The ladder and its +#' bounds", the default of earlier versions, whatever the other arguments +#' are; or one number or several, each at least 1 (fractions are +#' allowed), for a ladder of sizes. The level of a size \eqn{s} is +#' \code{max(2, round(n / s))} cells, with \eqn{n} the rows that have a +#' response (and, with \code{predictor_vars}, every predictor), or every +#' point when there is no \code{response_var} or no row has a response. +#' Under \code{select_on = "split"} \eqn{n} counts the rows of both +#' halves, since the cells are built on every point. On a ladder of sizes +#' the centres are fitted to every row, no subsample is drawn, and +#' \code{n_levels}, \code{min_cell_n}, \code{sample_n} and +#' \code{range_floor} are not read: supplying \code{n_levels}, +#' \code{min_cell_n}, \code{sample_n} or \code{range_floor = TRUE} beside +#' a numeric \code{obs_per_cell} is a warning of class +#' \code{spatialkit_ladder_unused}, and \code{levels} beside it is an +#' error. A level is held to the most centres k-means can place (the +#' distinct locations, and one short of the points). \code{"auto"} is +#' \code{NULL} when \code{levels} is given or the caller supplies any of +#' those four arguments; otherwise 4.5 when the estimate is +#' \code{"pooled"}, the seven sizes 18, 12, 9, 6, 4.5, 3 and 2 when it is +#' \code{"mean"}, and \code{NULL} without an estimate. The cost of a +#' ladder of sizes is bounded before any fit (see "Conditions"). #' @return A data.frame of class \code{resolution_profile} with one row per -#' level and columns \code{levels}, \code{wss}, \code{wss_spread} (relative -#' spread of WSS across the restarts), \code{elbow}, \code{cell_n_min}, +#' level and columns \code{levels}, \code{wss} (the within-cell sum of +#' squares of the coordinates, every point counted once, under either +#' \code{partition}), \code{wss_spread} (relative +#' spread of WSS across the restarts; under \code{partition = "density"}, +#' of the weighted sum the starts minimise), \code{elbow}, \code{cell_n_min}, #' \code{cell_n_median}, \code{cell_diam_median} (twice the median RMS #' radius of the cells, in coordinate units: about 0.8 of the side of a #' square cell of the same area, and less for finer cells, so a size to #' compare levels by rather than a width), \code{rss}, \code{cp}, -#' \code{moran_i}, \code{moran_z} and \code{reliability}; columns a missing -#' input leaves undefined are \code{NA}. Attributes: \code{bounds} (a list -#' with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"}, -#' \code{"distinct locations"} or \code{"sample_n"}, whichever bound it), -#' \code{supported}, \code{area}, \code{range}, \code{n} (the points in the -#' layer), \code{n_sample} (the points the k-means fits ran on), -#' \code{n_distinct}, \code{min_cell_n}, \code{range_floor}), +#' \code{moran_i}, \code{moran_z}, \code{reliability}, \code{cells_resp} +#' (the cells that hold at least one scored row) and \code{cell_resp_mean} +#' (the scored rows per such cell; compare it with \code{min_cell_n}). +#' Like the other columns read off the fitted cells, the last two count +#' rows of the subsample when the layer is larger than \code{sample_n}: +#' the cells of the layer then hold about \code{n_response / n_scored} +#' times as many scored rows as \code{cell_resp_mean} shows. +#' Columns a missing input leaves undefined are \code{NA}. Attributes: +#' \code{bounds} (a list with \code{floor}, \code{ceiling}, +#' \code{ceiling_from} (\code{"min_cell_n"}, \code{"min_cell_n (rows with a +#' response)"}, \code{"distinct locations"}, \code{"sample_n"}, +#' \code{"fewer than two supported cells"} or \code{"fewer than two +#' distinct locations"}, whichever bound it), \code{supported}, \code{area}, +#' \code{range}, \code{n} (the points in the layer), \code{n_sample} (the +#' points the k-means fits ran on), \code{n_distinct}, \code{min_cell_n}, +#' \code{range_floor}, \code{n_response} (the rows of the layer that carry +#' a response and, with \code{predictor_vars}, every predictor, which the +#' support ceiling counts; \code{NA} without a +#' \code{response_var}), \code{n_scored} (the rows of the subsample the +#' response criteria read; \code{NA} without a \code{response_var}), +#' \code{levels_given} (whether \code{levels} set the ladder) and +#' \code{predictors} (whether \code{predictor_vars} were given)), #' \code{variogram} (a list with \code{nugget}, \code{psill}, \code{range} #' (\code{NA} when rejected), \code{model} and \code{detrended} (whether #' the sac says it is a variogram of residuals; \code{NA} when it does not @@ -373,14 +1404,87 @@ #' list with \code{source}, \code{"variogram nugget"} or #' \code{"finest-level residual mean square"}, \code{value}, the #' \eqn{\tau^2} used, and \code{level}, the level it was read at or -#' \code{NA}; \code{NULL} when \code{cp} has neither), \code{centres} +#' \code{NA}; \code{NULL} when \code{cp} has neither), \code{one_cell} +#' (what one cell for the whole layer scores, the reference a level has to +#' beat: a list with \code{n}, the scored rows, \code{rss}, their total +#' sum of squares, \code{cp}, the same formula at one cell or \code{NA} +#' when \code{cp} has no noise variance, \code{constant}, whether the +#' scored variable is constant to within rounding, \code{cp_levels}, the +#' \code{cp} column it belongs to, and \code{f_p}, named by level, the +#' p-value of the F test of that level's cell means against one mean, +#' \eqn{(TSS - RSS) / (L - 1)} over \eqn{RSS / (m - L)} on the \eqn{L} +#' cells that hold a scored row and the \eqn{m} scored rows; \code{NULL} +#' without a response), \code{centres} #' (a list named by level of the two-column matrices of the scored -#' partitions' centres) and \code{centres_crs} (the CRS they are in). A +#' partitions' centres), \code{centres_crs} (the CRS they are in) and +#' \code{hull} (the convex hull of the points profiled, an \code{sfc} in +#' that CRS). A #' k-means partition is the Voronoi partition of its centres, so these #' seed the very cells each level was scored on: \code{select_resolution()} #' returns the chosen level's as \code{$seeds}, and #' \code{\link{get_voronoi_seeds}()} and \code{\link{voronoi_seeds_kmeans}()} -#' use them when given the selection or the profile. +#' use them when given the selection or the profile. The centres carry the +#' hull as their \code{"cover"} attribute, which those two functions hand on +#' so that Voronoi cells built on the seeds reach the edge of the points. +#' A profile built with \code{partition = "density"} or \code{init = +#' "random"} also carries \code{partition}: a list with \code{kind}, +#' \code{init}, \code{density_power} and \code{density_k} (both \code{NA} +#' for \code{kind = "kmeans"}); for \code{kind = "density"}, +#' \code{objective}, the weighted sum the centres minimise, named by +#' level; \code{iter_max}, the iteration limit; and \code{iter} and +#' \code{converged}, the iterations each level's kept start took and +#' whether it stopped before the limit, named by level. The selection +#' carries the first four as \code{$partition}, its +#' seeds and the seeds the seeding functions return as +#' \code{attr(, "partition")}, and a Voronoi tessellation built on them as +#' \code{params$partition}. A profile of the kind \code{"kmeans"} from +#' k-means++ starts has no such attribute, and neither has anything made +#' from it. +#' +#' With an \code{estimate} the frame has five more columns, after +#' \code{cell_resp_mean}: \code{scored_per_cell} (the rows \code{loo} +#' read over the cells that hold one; the layer's counterpart of +#' \code{cell_resp_mean}, which counts the subsample's rows), \code{loo} +#' (the leave-one-out mean squared error of the estimate; lower is +#' better), \code{loo_se} (the standard error over rows of that level's +#' mean squared error; it is not the standard error of a difference +#' between two levels, whose errors come from the same rows), +#' \code{share_alone} (the share of the scored rows that are the only +#' scored row of their cell) and \code{own_weight} (the median over cells +#' of the weight a pooled value gives the cell's own mean; \code{NA} +#' under \code{"mean"}). \code{loo}, \code{loo_se} and +#' \code{own_weight} are \code{NA} at a level where no cell holds two +#' scored rows, and at every level when the response is constant over the +#' rows \code{loo} reads. It also carries \code{estimate}: a list with +#' \code{value} (\code{"mean"} or \code{"pooled"}), \code{neighbours} +#' (8, or \code{NA} under \code{"mean"}), \code{response} (the column), +#' \code{n} (the rows \code{loo} read), \code{rows} (\code{"all"} or +#' \code{"selection half"}), \code{features} (\code{"points"}, or +#' \code{"other"} when the layer held features that were reduced to +#' points), \code{seed}, \code{constant} (whether the response is constant +#' over those rows; \code{FALSE} for fewer than two), \code{loo_one_cell} +#' and \code{loo_one_cell_se} (the same error with one mean for all those +#' rows, the reference a level has to beat), \code{loo_levels} (the +#' \code{loo} column those references belong to, named by level), and, +#' named by level, \code{sigma2} (the spread of the rows about their +#' cell's mean), \code{tau2} (the mean squared distance between a cell's +#' level and its target; \code{NA} under \code{"mean"}), \code{cells} +#' (the cells that hold a scored row) and \code{f_p} (the p-value of the F +#' test of those cells' means against one mean). +#' +#' On a ladder that \code{obs_per_cell} sets, \code{bounds} describes that +#' ladder: \code{ceiling} is the finest level; \code{ceiling_from} is +#' \code{"obs_per_cell"}, \code{"distinct locations"}, +#' \code{"fewer than two cells of the size"} or +#' \code{"fewer than two distinct locations"}; +#' \code{supported} is \code{FALSE} when the finest size gives fewer than +#' two cells or the range floor is above the finest level; +#' \code{levels_given} is \code{TRUE}; \code{n_sample} is every point; +#' \code{min_cell_n} holds the argument, which is not read; and two fields +#' are added, \code{obs_per_cell} (the sizes, largest first) and +#' \code{size_levels} (the level of each, named by size; \code{NA} for a +#' size of \code{"auto"} that gives fewer than two cells and was left +#' out). #' @references #' Cressie, N. (1996). Change of support and the modifiable areal unit #' problem. \emph{Geographical Systems}, 3(2--3), 159--180. @@ -403,27 +1507,52 @@ #' if (requireNamespace("gstat", quietly = TRUE)) { #' library(sf) #' # An exponential field with range parameter 200 (true effective range -#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough -#' # noise for Mallows' Cp to have an interior optimum rather than descend -#' # to the ceiling. +#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. #' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) #' D <- as.matrix(dist(xy)) #' xy$z <- as.numeric(t(chol(exp(-D / 200) + diag(0.6, n))) %*% rnorm(n)) #' pts <- st_as_sf(xy, coords = c("x", "y"), crs = 32632) +#' # n_levels asks for the ladder of counts. #' prof <- resolution_profile(pts, response_var = "z", n_levels = 12) #' print(prof) # one row per level; print() because only the #' # last value of a braced block is shown -#' select_resolution(prof, criterion = "cp") +#' attr(prof, "bounds")$floor # the range floor: reported, not applied +#' print(select_resolution(prof, criterion = "cp")) +#' +#' # The default profile: one level at 4.5 rows per cell, scored for +#' # pooled values, in density-weighted cells, with no variogram. +#' prof1 <- resolution_profile(pts, response_var = "z") +#' print(prof1) +#' select_resolution(prof1) # the count the size gives #' } #' @export resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NULL, levels = NULL, n_levels = 20L, min_cell_n = 9L, - sample_n = 1500L, nstart = 25L, seed = 123L, - sac = NULL, select_on = c("all", "split"), - range_floor = TRUE) { + sample_n = 1500L, nstart = NULL, seed = 123L, + sac = "auto", select_on = c("all", "split"), + range_floor = FALSE, + partition = c("density", "kmeans"), + init = c("kmeans++", "random"), + density_power = 1, density_k = 8L, + iter_max = NULL, + estimate = "auto", obs_per_cell = "auto") { + # Which of the arguments that describe the automatic ladder the caller + # supplied. Read first, before any of them is altered: `obs_per_cell` is + # resolved against them below. A value a wrapper passes on counts as + # supplied. + ladder_given <- c(n_levels = !missing(n_levels), min_cell_n = !missing(min_cell_n), + sample_n = !missing(sample_n), range_floor = !missing(range_floor)) select_on <- match.arg(select_on) + partition <- match.arg(partition) + # As match.arg() reads it, with a message that names this function when + # the value is not one of the two. + init <- if (identical(init, .partition_inits())) init[1L] + else .match_init(init, "resolution_profile") + # Whether the caller set the ladder: select_resolution() holds `reliability` + # to the range floor only on a ladder this function built. + levels_given <- !is.null(levels) if (!inherits(data_sf, "sf")) stop("resolution_profile(): `data_sf` must be an sf object.", call. = FALSE) if (!is.logical(range_floor) || length(range_floor) != 1L || is.na(range_floor)) @@ -431,9 +1560,33 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU if (!is.numeric(min_cell_n) || length(min_cell_n) != 1L || !is.finite(min_cell_n) || min_cell_n < 1) stop("resolution_profile(): `min_cell_n` must be a single number >= 1.", call. = FALSE) + # NULL is the kind's own number of starts: the 25 this function has always + # run for the kind "kmeans", .NSTART_DENSITY for the kind "density". The + # number it resolves to is the one the result records. + if (is.null(nstart)) + nstart <- if (identical(partition, "density")) .NSTART_DENSITY else 25L if (!is.numeric(nstart) || length(nstart) != 1L || !is.finite(nstart) || nstart < 1) - stop("resolution_profile(): `nstart` must be a single number >= 1.", call. = FALSE) + stop("resolution_profile(): `nstart` must be NULL or a single number >= 1.", call. = FALSE) nstart <- as.integer(nstart) + # The kind of partition every level of the ladder is built with, and how its + # starts are drawn (R/partition.R). `part` is the record the profile, its + # selections and the seeds made from them carry. + part <- .check_partition_args(partition, init, density_power, density_k, + "resolution_profile") + # The present kind, the best of `nstart` k-means++ starts, leaves no record: + # a profile made with it is the object it always was. + part_default <- identical(part$kind, "kmeans") && identical(part$init, "kmeans++") + # Iterations per start, unless `iter_max` sets them. 50 for k-means from + # k-means++ starts, as always. Random starts lie further from an optimum, + # and Lloyd's iteration of the density kind takes more steps than Hartigan + # and Wong's: 100 for both. Over 192 density runs on 300 to 6,000 points + # (uniform and clustered, 2 to 667 cells) the longest took 66 steps to stop + # moving, and 5 percent took more than 40. Larger layers take more: a + # start that is cut off is reported after the sweep. + if (!is.null(iter_max)) + iter_max <- .check_whole_count(iter_max, "iter_max", "resolution_profile", + "iterations", null_ok = TRUE) + part_iter <- if (!is.null(iter_max)) iter_max else if (part_default) 50L else 100L # These three used to fail deep inside seq() or an if() with R's own message, # and a fractional min_cell_n printed a ceiling that did not match it. if (!is.numeric(n_levels) || length(n_levels) != 1L || !is.finite(n_levels) || n_levels < 2) @@ -450,15 +1603,59 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # (metres): a floor of 41 million cells, with nothing said. Refused by # name, as fold_separation() and cv_block_size_sweep() refuse it; and a # character string, which as.numeric() also read, with it. - if (!is.null(sac) && (inherits(sac, "units") || !is.numeric(sac))) - stop("resolution_profile(): `sac` must be an estimate_sac_range() result, ", - "or a plain number in the units of the CRS the profile is computed ", + # "auto" is resolved once the ladder is known: no variogram on a ladder + # `obs_per_cell` sets, and NULL on every other. Until then it is NULL, so + # that nothing below reads it as a variogram the caller supplied. + sac_auto <- .is_auto(sac) + if (!is.null(sac) && !sac_auto && (inherits(sac, "units") || !is.numeric(sac))) + stop("resolution_profile(): `sac` must be NULL, \"auto\", an estimate_sac_range() ", + "result, or a plain number in the units of the CRS the profile is computed ", "in (metres for lon/lat input); got ", if (inherits(sac, "units")) format(sac) else sprintf("an object of class %s", class(sac)[1L]), ".", call. = FALSE) + if (sac_auto) sac <- NULL + # `estimate` and `obs_per_cell`: what the arguments alone decide is checked + # here, after every check above; what needs the response, once it is read. + # A string is read by its value alone, as match.arg() reads `partition`: + # one taken from a named vector (cfg["estimate"]) or carrying a class is + # the string it holds. Every comparison below is identical(), which a + # name or a class defeats, so both are dropped here, once. + if (is.character(estimate)) estimate <- as.character(unclass(estimate)) + if (!is.null(estimate) && + !(is.character(estimate) && length(estimate) == 1L && !is.na(estimate) && + estimate %in% c("mean", "pooled", "auto"))) + stop(sprintf(paste0("resolution_profile(): `estimate` must be NULL, \"mean\", ", + "\"pooled\" or \"auto\"; got %s."), .got_text(estimate)), + call. = FALSE) + est_named <- !is.null(estimate) && !identical(estimate, "auto") + if (est_named && !has_resp) + stop("resolution_profile(): `estimate` names the value of a response, so it needs ", + "a `response_var`.", call. = FALSE) + if (est_named && has_pred) + stop("resolution_profile(): `estimate` cannot be combined with `predictor_vars`. ", + "With predictors the profile scores the residuals of the response on them, ", + "and the summary reports region values of the response itself, so the ", + "criterion would be computed for a number nobody reports. Drop ", + "`predictor_vars`, or leave `estimate` NULL.", call. = FALSE) + obs_auto <- .is_auto(obs_per_cell) + # Plain numbers: a `units` object is numeric too, and comparing one with 1 + # stops in that package's words, which name neither argument nor function. + if (!is.null(obs_per_cell) && !obs_auto && + !(is.numeric(obs_per_cell) && !is.object(obs_per_cell) && + length(obs_per_cell) >= 1L && + all(is.finite(obs_per_cell)) && all(obs_per_cell >= 1))) + stop(sprintf(paste0("resolution_profile(): `obs_per_cell` must be NULL, \"auto\", or ", + "numbers of at least 1 (observations per cell; fractions are ", + "allowed); got %s."), .got_text(obs_per_cell)), call. = FALSE) + if (!is.null(obs_per_cell) && !obs_auto && levels_given) + stop("resolution_profile(): pass one of `obs_per_cell` and `levels`: each sets the ", + "ladder.", call. = FALSE) - if (!all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT")) + # Whether the layer came as points: a feature that is not one is scored at + # the point it is reduced to, and the record of an estimate says so. + was_points <- all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT") + if (!was_points) data_sf <- coerce_to_points(data_sf, "auto") data_sf <- ensure_projected(data_sf) xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] @@ -551,6 +1748,63 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU } } + # The estimate the profile scores, now that the response is read. "auto" + # is the pooled value wherever naming it would not be an error, and no + # estimate otherwise, so a call that runs without the argument runs with + # "auto". + est <- estimate + if (!is.null(est)) { + resp_logical <- has_resp && is.logical(df[[response_var]]) + resp_any <- has_resp && any(is.finite(resp)) + if (identical(est, "auto")) { + est <- if (has_resp && !has_pred && !resp_logical && resp_any) "pooled" else NULL + } else { + if (resp_logical) + stop(sprintf(paste0("resolution_profile(): `estimate` scores the cell value ", + "summarize_by_cell() reports, and that function summarises ", + "numeric columns only; '%s' is logical. Convert it with ", + "as.numeric() first, or leave `estimate` NULL."), response_var), + call. = FALSE) + if (!resp_any) + stop(sprintf(paste0("resolution_profile(): `estimate` needs rows with a value of ", + "'%s', and none has a finite one."), response_var), call. = FALSE) + } + } + # The ladder `obs_per_cell` sets: sizes, largest first, or none. "auto" + # gives way to a ladder the caller describes (`levels`, or any of the four + # arguments of the automatic ladder), and is otherwise the size that goes + # with the estimate: one for pooled values, seven for plain means, none + # without an estimate. + # (`ladder_sizes`, not `sizes`: the sweep below keeps the points per cell + # of a level under that name.) + ladder_sizes <- NULL + sizes_auto <- FALSE + if (obs_auto) { + if (!levels_given && !any(ladder_given)) { + ladder_sizes <- if (identical(est, "pooled")) .OBS_PER_CELL_DEFAULT + else if (identical(est, "mean")) .OBS_PER_CELL_LADDER + sizes_auto <- !is.null(ladder_sizes) + } + } else if (!is.null(obs_per_cell)) { + ladder_sizes <- sort(unique(as.numeric(obs_per_cell)), decreasing = TRUE) + # `range_floor = FALSE` asks for what a ladder of sizes does anyway. + unused <- names(ladder_given)[ladder_given & + (names(ladder_given) != "range_floor" | range_floor)] + if (length(unused)) + .warn_classed("spatialkit_ladder_unused", + paste0("resolution_profile(): %s %s not read when `obs_per_cell` sets ", + "the ladder: the levels are the sizes asked for, and the centres ", + "are fitted to every row. Leave `obs_per_cell` NULL for the ", + "ladder %s."), + .and_text(sprintf("`%s`", unused)), + if (length(unused) > 1L) "are" else "is", + if (length(unused) > 1L) "they describe" else "it describes", + data = list(unused = unused, obs_per_cell = ladder_sizes)) + } + size_ladder <- !is.null(ladder_sizes) + # No variogram is estimated or read on a ladder of sizes under sac = "auto". + no_vg <- sac_auto && size_ladder + cleanup <- .with_seed(seed) on.exit(cleanup(), add = TRUE) @@ -563,7 +1817,8 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU if (!all(resp_ok)) .log_warn(paste0("resolution_profile(): %d of %d row(s) have a missing or ", "non-finite %s; they stay in the geometry but are left out ", - "of the OLS fit, the RSS, Cp and Moran's z."), + "of the OLS fit, the RSS, Cp, Moran's z and the rows the ", + "support ceiling counts."), sum(!resp_ok), length(resp_ok), if (has_pred) "response or predictor" else "response") } @@ -575,8 +1830,17 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # verdict, Cp's penalty and the reliability used to take n from the # subsample, which capped every layer larger than sample_n at # floor(sample_n / min_cell_n) cells and made the answer depend on sample_n. + # The support ceiling counts the rows that carry a response (`n_support`), + # as Cp's variance term and the reliability do: a cell's mean is built from + # those rows. It used to count every point, so 900 points with a response + # on 225 got a ceiling of 100 "from min_cell_n = 9" at 2.25 scored rows per + # cell, and at a Cp pick of 84 cells summarize_by_cell() returned 4 cells + # with no mean and 21 with no interval. A geometry-only profile counts + # every point, and so does one in which no row has a response: nothing can + # be scored there, and the geometry columns keep their ladder. n_all <- nrow(xy) n_resp <- if (has_resp) sum(resp_ok) else n_all + n_support <- if (has_resp && n_resp > 0L) n_resp else n_all hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(data_sf))) area <- suppressWarnings(as.numeric(sf::st_area(hull))) bb <- sf::st_bbox(data_sf) @@ -597,7 +1861,20 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU ord <- do.call(order, c(list(xy[, 1], xy[, 2]), if (has_resp) list(resp), if (has_pred) lapply(seq_len(ncol(pred)), function(j) pred[, j]))) - idx <- if (n_all > sample_n) ord[sample(seq_len(n_all), sample_n)] else ord + # What the estimate's columns read: every row of the layer with a finite + # response (of the selection half under select_on = "split"), in that + # order. Kept here, before the subsample overwrites the layer's + # coordinates, response and flags with its own. + lay <- NULL + if (!is.null(est)) { + scored <- resp_ok[ord] + if (!is.null(in_sel)) scored <- scored & in_sel[ord] + lay <- list(xy = unname(xy[ord[scored], , drop = FALSE]), y = resp[ord[scored]]) + } + # A size is a number of rows of the layer, so the centres of a ladder of + # sizes are fitted to every row: no subsample is drawn, and `sample_n` is + # not read. + idx <- if (!size_ladder && n_all > sample_n) ord[sample(seq_len(n_all), sample_n)] else ord xy <- xy[idx, , drop = FALSE] data_sf <- data_sf[idx, , drop = FALSE] if (has_resp) { resp <- resp[idx]; resp_ok <- resp_ok[idx] } @@ -635,6 +1912,56 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU } } + # The distinct locations. `n_uniq_all` is the layer's (see above); + # `n_uniq` is the subsample's, the locations k-means can place centres on. + n_uniq <- nrow(unique(round(xy, 8))) + if (n == n_all) n_uniq_all <- n_uniq + # k-means can put a centre on every distinct location but no more, and + # stats::kmeans() refuses as many centres as points (see the present + # ladder's ceiling, below). + k_cap_all <- min(n_uniq_all, n_all - 1L) + + # The two optional backends. Each is asked for once, when a step first + # needs the answer, and every later step is handed that answer: the fits, + # each row's nearest centre, the estimate's fit, Moran's z and the guards. + # These are the answers each of those steps reads by default, and a step + # that never reads one never asks: a geometry-only profile of the kind + # "kmeans" loads neither package, as it never has. + backend <- local({ + known <- c(FNN = NA, Matrix = NA) + function(pkg) { + if (is.na(known[[pkg]])) known[[pkg]] <<- isTRUE(.has_backend(pkg)) + known[[pkg]] + } + }) + # Without FNN each scored row is compared with every centre of a level to + # find its own. The finest level is the largest such search. + centre_guard <- function(finest) + if (!is.null(est) && !backend("FNN")) + .work_guard(as.numeric(length(lay$y)) * finest, .exact_pairs_max(), + what = "nearest centre", caller = "resolution_profile", + search = sprintf("finding the nearest of %d centres for each of %d rows", + finest, length(lay$y))) + # On a ladder of sizes the count grows with the rows, so two costs that the + # subsample bounds on every other ladder are bounded here: the search + # behind the density kind's weights without FNN, which compares every pair + # of distinct locations, and the fits themselves. The finest level follows + # from the rows and the finest size alone (.size_ladder() gives the same + # number below), so the guards run before the variogram is estimated: a + # call one of them stops has fitted nothing and raised no warning about a + # column it never returns. + if (size_ladder) { + finest <- .finest_level(n_support, ladder_sizes, k_cap_all) + if (identical(part$kind, "density") && density_power > 0 && !backend("FNN")) + .work_guard(as.numeric(n_uniq_all)^2, .exact_pairs_max(), what = "density weights", + caller = "resolution_profile", + search = sprintf(paste0("the neighbour search behind the weights of ", + "partition = \"density\", over %d distinct locations,"), + n_uniq_all)) + .fit_guard(n_all, finest, nstart, part, part_iter, backend("FNN")) + centre_guard(finest) + } + # Variogram: supplied, or estimated on the subsample (its selection half # under select_on = "split": the range reads the response). vg <- NULL @@ -644,54 +1971,67 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU sac_given <- !is.null(sac) sac_what <- if (sac_given) "`sac`" else "the variogram estimated from `response_var` (attr(, \"sac\"))" - if (is.null(sac) && has_resp && requireNamespace("gstat", quietly = TRUE)) { - sac <- tryCatch( - suppressWarnings(estimate_sac_range(if (is.null(in_sel)) data_sf - else data_sf[in_sel, , drop = FALSE], - response_var, - predictor_vars = if (has_pred) predictor_vars else NULL, - seed = seed)), - error = function(e) { - .log_warn("resolution_profile(): estimate_sac_range() failed (%s); no variogram-based columns.", - conditionMessage(e)) - NULL - }) + if (!no_vg && is.null(sac) && has_resp && requireNamespace("gstat", quietly = TRUE)) { + # Whatever the estimate prints to standard output is held here and logged + # once: neither suppressWarnings() nor spatialkit_quiet() reaches a + # print(). estimate_sac_range() fits its model without gstat's iterative + # fit, whose "a possible solution MIGHT be to scale semivariances and/or + # distances" this was written for (nine times on one profile of 2,634 + # points), so nothing is expected here now. + printed <- character(0) + sac <- tryCatch({ + sac_est <- NULL + printed <- utils::capture.output( + sac_est <- suppressWarnings(estimate_sac_range( + if (is.null(in_sel)) data_sf else data_sf[in_sel, , drop = FALSE], + response_var, + predictor_vars = if (has_pred) predictor_vars else NULL, + seed = seed)), + type = "output") + sac_est + }, error = function(e) { + .log_warn("resolution_profile(): estimate_sac_range() failed (%s); no variogram-based columns.", + conditionMessage(e)) + NULL + }) + if (length(printed)) + .log_info("resolution_profile(): the variogram fit printed %d line(s) to the console, held back here: %s", + length(printed), paste(unique(printed), collapse = " | ")) } range_eff <- NA_real_ if (!is.null(sac)) { vm <- attr(sac, "variogram_model") r <- suppressWarnings(as.numeric(sac))[1L] if (is.finite(r) && r > 0) range_eff <- r - # A REJECTED range (NA with a `rejected_reason`) still carries its fitted - # model, as evidence for the rejection, and that model used to be read as - # if it had been accepted: reliability then took a correlation function - # whose range could be many times the extent, which pins its optimum to - # the first level, and nothing said so. summarize_by_cell() refuses such - # a model outright. Here the nugget, fitted at the short lags, still - # serves Cp; the correlation function, which is the unidentified range, - # does not. Two refusals are whole. A fit that did not converge: its - # nugget is where the optimiser stopped. A range below the shortest lag: - # the structure cannot be told from a nugget, so the split between the - # two is exactly what is not identified. On white noise detrended by - # REML that model's nugget was 6e-7 on a sill of 0.99, and Cp, with no - # penalty, ran to the support ceiling (7 cells with the nugget at 0.98). + # A REJECTED range (NA with a `rejected_reason`) still carries a model, + # as evidence for the rejection, and that model used to be read as if it + # had been accepted: reliability then took a correlation function whose + # range could be many times the extent, which pins its optimum to the + # first level, and nothing said so. Here the nugget, fitted at the short + # lags, still serves Cp; the correlation function, which is the + # unidentified range, does not. Three refusals are whole. A model + # marked as not converged: its nugget and sill are where the fit stopped + # without a minimum. A range below the shortest lag: the structure + # cannot be told from a nugget, so the split between the two is exactly + # what is not identified. On white noise detrended by REML that model's + # nugget was 6e-7 on a sill of 0.99, and Cp, with no penalty, ran to the + # support ceiling (7 cells with the nugget at 0.98). And a layer with no + # spatial structure, further down. rejected <- attr(sac, "rejected_reason") rejected <- if (!is.finite(r) && length(rejected)) as.character(rejected)[1L] else NULL # Whether the model converged is read off the model, not off the reason. - # estimate_sac_range() gives a refusal one reason, and a fit that stopped - # at its iteration limit with a range past the largest lag is "fitted - # range exceeds the largest lag fitted"; one whose variogram also falls - # with distance is "empirical variogram decreases with distance". Looking - # for "converge" in the reason alone took those fits' nuggets for Cp as - # fitted values, which is most of the fits that do not converge: with an - # east-west trend on an exponential field (300 points, 25 draws) every - # all-pairs fit stopped at the limit, every one was refused as past the - # lags, and Cp was given nuggets of 1.18-1.62 where the field's was 0.1. - # gstat's own verdict rides on every model estimate_sac_range() fits (see - # .vgm_converged()). A sac that carries none (made by hand, built from - # REML parameters, or saved before the flag existed) is judged by its - # reason, as every sac used to be; and a reason that says the fit did not - # converge is believed whatever the flag says. + # estimate_sac_range() gives a refusal one reason and marks the model + # besides: attr(model, "converged") is FALSE when the least-squares + # criterion is still falling at an edge of the ranges searched (a + # variogram with no sill inside four cutoffs), and such a fit is refused + # as "fitted range exceeds the largest lag fitted". Its nugget is then + # that edge and not a fitted value: with an east-west trend on an + # exponential field (300 points, 25 draws) Cp was given nuggets of + # 1.18-1.62 where the field's was 0.1. See .vgm_converged(). A sac that + # carries no flag (made by hand, built from REML parameters, or saved + # before the flag existed) is judged by its reason; and a reason that + # says the fit did not converge, which only a stored object carries, is + # believed whatever the flag says. not_converged <- !is.null(rejected) && (isFALSE(.vgm_converged(vm)) || grepl("converge", rejected, fixed = TRUE)) cor_fn <- if (is.data.frame(vm)) .vgm_correlation_fn(vm) else NULL @@ -718,7 +2058,8 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # refused as past the lags gave `cp` 0.82 and 0.87 from its nugget of # 0.5 at 200 and 250 cells of 300 points, and gives NA. .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s)%s; ", - "its nugget and sill are where the optimiser stopped, not ", + "its nugget and sill are where the fit stopped without ", + "reaching a minimum, not ", "fitted values, so neither is used: `reliability` is NA and ", "`cp` takes its noise variance from the finest level whose ", "cells hold at least two scored rows on average, and is NA ", @@ -735,6 +2076,25 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU "takes its noise variance from the finest level."), sac_what, rejected, vg$nugget) vg <- NULL + } else if (.sac_no_structure(sac)) { + # A variogram refused because the response shows no spatial structure + # (.sac_no_structure(), R/utils.R). estimate_sac_range() attaches a + # pure nugget to that refusal, which has no correlation function and + # does not reach this branch: it takes the log line below. This is + # for a sac that says so and still carries a model with a range (one + # built by hand, or stored by a version that attached the fitted + # model). On white noise such a model's nugget is whatever a + # spurious short range left of the variance: 0 to 0.65 against a true + # 1 on simulated layers, with which Cp ran to 24 to 100 cells of 100. + # Its nugget is no more identified than its range, so Cp takes its + # noise variance from the finest level, as for a range below the + # shortest lag. + .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s), ", + "so its nugget (%.3g) is not a fitted value either: ", + "`reliability` is NA and `cp` takes its noise variance ", + "from the finest level."), + sac_what, rejected, vg$nugget) + vg <- NULL } else { .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s). ", "`cp` still takes its nugget (%.3g), fitted at the short lags; ", @@ -743,10 +2103,17 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU vg$cor_fn <- NULL } } else if (is.null(vg)) { - .log_info("resolution_profile(): the variogram carries no usable model; `reliability` is NA and `cp` takes its noise variance from the finest level.") + if (.sac_no_structure(sac)) + .log_info(paste0("resolution_profile(): %s found no spatial structure (%s), ", + "and its model is a pure nugget; `reliability` is NA and ", + "`cp` takes its noise variance from the finest level."), + sac_what, rejected %||% "no reason recorded") + else + .log_info("resolution_profile(): the variogram carries no usable model; `reliability` is NA and `cp` takes its noise variance from the finest level.") } - # A nugget of 0 is usually the fit's lower bound, not an estimate (gstat - # does not warn when it clips there), and with it Cp's penalty is 0: Cp + # A nugget of 0 is usually the fit's lower bound, not an estimate + # (estimate_sac_range() marks it as `nugget_at_bound`), and with it Cp's + # penalty is 0: Cp # is the RSS alone and falls with every finer level to the ceiling, # whatever the field. Zero to within 1e-4 of the sill: a REML fit stops # short of its bound, and a nugget of 6e-7 on a sill of 0.99 slipped past @@ -781,74 +2148,228 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU else "the raw response (no predictor_vars)") } - # Bounds. `area`, `n_uniq_all` and `n_all` are the layer's (see above); - # `n_uniq` is the subsample's, the locations k-means can place centres on. - n_uniq <- nrow(unique(round(xy, 8))) - if (n == n_all) n_uniq_all <- n_uniq - by_support <- floor(n_all / min_cell_n) - # The ceiling is the smallest of what the layer's point count supports, - # what its distinct locations allow and, when the fits run on a subsample, - # what the subsample can fit: two of its points per cell. k-means can put - # a centre on every distinct location but no more, and stats::kmeans() - # refuses as many centres as points, so that bound is the distinct - # locations when some repeat and one short of the points when none do. It - # used to be one short of the distinct locations in every case, which - # dropped k = 5 on five stations visited thirty times each. Which bound - # holds is recorded, because the print and the "bound is choosing" notes - # name it. - k_cap_all <- min(n_uniq_all, n_all - 1L) - k_cap_fit <- min(n_uniq, n - 1L) - data_ceiling <- min(by_support, k_cap_all) - fit_cap <- if (n < n_all) min(floor(n / 2), k_cap_fit) else Inf - ceiling_L <- max(2L, as.integer(min(data_ceiling, fit_cap))) - ceiling_from <- if (fit_cap < data_ceiling) "sample_n" - else if (by_support <= k_cap_all) "min_cell_n" - else "distinct locations" + # Bounds. `area`, `n_uniq_all`, `n_all` and `k_cap_all` are the layer's + # and `n_uniq` the subsample's (see above). + # The rows of the subsample the response criteria read (under select_on = + # "split", those of the selection half): what a fitted cell is scored on. + n_scored <- if (has_resp) sum(is.finite(y)) else NA_integer_ + # What a row has to carry to be scored, in the words of the messages: with + # predictors a row with a response and no predictor is left out as well, + # and "450 of the 900 points carry a response" was said of a layer on + # which every point had one. + rows_carry <- if (has_pred) "a response and every predictor" else "a response" # Kept as a double until the comparison: a short range on a continental # extent puts area / range^2 past .Machine$integer.max, and as.integer() of # that is NA, which turned the "not supported" branch into an abort. floor_raw <- if (is.finite(range_eff) && range_eff > 0) max(2, ceiling(area / range_eff^2)) else 2 - # The verdict is about the data, so it is taken against the layer's - # ceiling; a subsample too small to reach the floor is a setting to change, - # and is said separately. - supported <- floor_raw <= max(2, data_ceiling) floor_L <- if (floor_raw <= .Machine$integer.max) as.integer(floor_raw) else NA_integer_ - if (!supported) - .log_warn(paste0("resolution_profile(): cells no wider than the autocorrelation ", - "range (%.0f) would need at least %.0f of them, but %d points ", - "at min_cell_n = %d support at most %d. The data cannot ", - "support a tessellation that respects their own ", - "correlation structure; the profile runs from 2 to %d so ", - "the cost of each level is still visible."), - range_eff, floor_raw, n_all, min_cell_n, - max(2L, as.integer(data_ceiling)), ceiling_L) - else if (floor_raw > ceiling_L) - .log_warn(paste0("resolution_profile(): cells no wider than the autocorrelation ", - "range (%.0f) need at least %.0f of them, which the %d points ", - "support, but k-means on the %d-point subsample can fit at ", - "most %d; raise `sample_n`. The profile runs from 2 to %d."), - range_eff, floor_raw, n_all, n, ceiling_L, ceiling_L) - # With range_floor = FALSE the ladder starts at 2 whatever the range, and the - # floor is only reported. The range is re-estimated on every subset, and a - # floor that applies on one fold and not on the next starts their ladders - # at 225 and at 2: reliability and the elbow, which sit near the bottom, - # then moved 10-15 times between folds of one benchmark while Cp did not. - lo <- if (range_floor && supported && floor_raw <= ceiling_L) floor_L else 2L - if (is.null(levels)) { - levels <- unique(as.integer(round(exp(seq(log(lo), log(ceiling_L), - length.out = max(2L, as.integer(n_levels))))))) - levels <- sort(unique(c(lo, levels, ceiling_L))) + support_what <- if (n_support < n_all) paste("rows with", rows_carry) else "points" + if (size_ladder) { + # A ladder of sizes: the levels are the counts the sizes give, scored as + # given, and the finest size takes the part `min_cell_n` has in the + # ceiling, the verdict and the warning (.size_ladder()). + sl <- .size_ladder(ladder_sizes, sizes_auto, n_support, n_all, n_uniq_all, k_cap_all, + floor_raw, range_eff, support_what, rows_carry) + levels <- sl$levels + supported <- sl$supported + ceiling_L <- sl$ceiling + ceiling_from <- sl$ceiling_from } else { - levels <- sort(unique(as.integer(levels))) - levels <- levels[levels >= 2L & levels <= k_cap_fit] - if (!length(levels)) - stop("resolution_profile(): no usable value in `levels`.", call. = FALSE) + by_support <- floor(n_support / min_cell_n) + # The ceiling is the smallest of what the layer's point count supports, + # what its distinct locations allow and, when the fits run on a subsample, + # what the subsample can fit: two of its points per cell. k-means can put + # a centre on every distinct location but no more, and stats::kmeans() + # refuses as many centres as points, so that bound is the distinct + # locations when some repeat and one short of the points when none do. It + # used to be one short of the distinct locations in every case, which + # dropped k = 5 on five stations visited thirty times each. Which bound + # holds is recorded, because the print and the "bound is choosing" notes + # name it. + k_cap_fit <- min(n_uniq, n - 1L) + data_ceiling <- min(by_support, k_cap_all) + # Two scored subsample rows per cell, not two subsample points: with 20,000 + # points, a response on 5,000 and sample_n = 1500, half the subsample left + # about 0.5 scored rows per cell at a ceiling of 750. + fit_rows <- if (has_resp && n_resp > 0L) n_scored else n + fit_cap <- if (n < n_all) min(floor(fit_rows / 2), k_cap_fit) else Inf + # A ladder the caller set is scored as given. Settled here, before the + # messages below, because they name it: with `levels = 2:4` on ten points + # the warning said "the profile scores 2 cells" over a table of three + # levels. + if (levels_given) { + levels <- sort(unique(as.integer(levels))) + levels <- levels[!is.na(levels) & levels >= 2L & levels <= k_cap_fit] + if (!length(levels)) + stop("resolution_profile(): no usable value in `levels`.", call. = FALSE) + } + # Fewer than two cells that meet min_cell_n, or one distinct location, is + # no ladder at all. The ceiling used to be raised to 2 without a word: + # ten points at min_cell_n = 9 came back as "ceiling 2 from min_cell_n", + # supported. + too_few <- data_ceiling < 2 + ceiling_L <- max(2L, as.integer(min(data_ceiling, fit_cap))) + ceiling_from <- if (k_cap_all < 2L) "fewer than two distinct locations" + else if (by_support < 2) "fewer than two supported cells" + else if (fit_cap < data_ceiling) "sample_n" + else if (by_support <= k_cap_all) + (if (n_support < n_all) "min_cell_n (rows with a response)" else "min_cell_n") + else "distinct locations" + # Said when the rows that are not scored moved the ceiling, in terms of + # the bound in force. It used to name min_cell_n whichever bound held: + # with 20,000 points, 5,000 scored and sample_n = 1500 it read "185 cells, + # not the 750 that every point at min_cell_n = 9 would give", where both + # numbers are sample_n's (half the 370 scored subsample rows, and half the + # subsample) and min_cell_n allows 555 and 2,222. + if (n_support < n_all && !too_few) { + all_fit_cap <- if (n < n_all) min(floor(n / 2), k_cap_fit) else Inf + all_by <- min(floor(n_all / min_cell_n), k_cap_all) + all_ceiling <- max(2L, as.integer(min(all_by, all_fit_cap))) + all_what <- if (all_fit_cap < all_by) "half the subsample" + else sprintf("every point at min_cell_n = %d", min_cell_n) + # On a subsample `cell_resp_mean` counts subsample rows, and the cells of + # the layer hold more by this factor (12.3 against 167 in the case above). + per_layer <- if (n < n_all && isTRUE(n_scored > 0L)) n_support / n_scored else NA_real_ + if (all_ceiling != ceiling_L) { + msg <- if (identical(ceiling_from, "sample_n")) + sprintf(paste0("resolution_profile(): %d of the %d points of the subsample carry %s ", + "(%d of the layer's %d), so the ceiling is %d cells, two scored ", + "subsample rows per cell, not the %d that %s would give. `sample_n` ", + "sets this ceiling, not `min_cell_n`: the layer's %d rows with %s ", + "support %d cells at min_cell_n = %d, and a larger `sample_n` raises ", + "the ceiling towards that. `cell_resp_mean` counts the scored rows ", + "of the subsample per occupied cell; the cells of the layer hold ", + "about %.3g times as many."), + n_scored, n, rows_carry, n_support, n_all, ceiling_L, all_ceiling, all_what, + n_support, rows_carry, as.integer(min(by_support, k_cap_all)), min_cell_n, + per_layer) + else + sprintf(paste0("resolution_profile(): %d of the %d points carry %s, so the ceiling ", + "is %d cells, not the %d that %s would give: the cell means the ", + "criteria score are built from the rows with %s. Where those rows ", + "sit in one part of the extent the cells elsewhere hold none, and ", + "this ceiling is lower than the occupied cells need; ", + "`cell_resp_mean` gives the scored rows per occupied cell at each ", + "level%s, and a profile of the rows with %s alone bounds the ladder ", + "by the area they cover."), + n_support, n_all, rows_carry, ceiling_L, all_ceiling, all_what, rows_carry, + if (is.finite(per_layer)) + sprintf(" (rows of the subsample; the cells of the layer hold about %.3g times as many)", + per_layer) + else "", + rows_carry) + .warn_classed("spatialkit_response_ceiling", "%s", msg, + data = list(n = n_all, n_response = n_support, ceiling = ceiling_L, + ceiling_from = ceiling_from, n_sample = n, + n_scored = as.integer(n_scored))) + } + } + # The verdict is about the data, so it is taken against the layer's + # ceiling; a subsample too small to reach the floor is a setting to change, + # and is said separately. + supported <- !too_few && floor_raw <= max(2, data_ceiling) + # R warnings with a class, not log lines: `supported = FALSE` changes what + # every count read off the profile means, and a log line reaches neither + # tryCatch() nor options(warn = 2). + if (too_few) { + # The largest min_cell_n that leaves two cells. Below one there is none: + # a single scored row was told to "lower `min_cell_n` (at most 0 here)". + half <- as.integer(floor(n_support / 2)) + .warn_classed("spatialkit_not_supported", + paste0("resolution_profile(): %s, so %s. %s, and `supported` is FALSE. %s"), + if (k_cap_all < 2L) + sprintf("the %d points sit on %d distinct location%s", n_all, n_uniq_all, + if (n_uniq_all == 1L) "" else "s") + else sprintf("%d %s at min_cell_n = %d support%s %d cell%s, and it takes two", + n_support, + if (n_support == 1L) sub("^rows", "row", sub("^points$", "point", support_what)) + else support_what, + min_cell_n, if (n_support == 1L) "s" else "", + as.integer(by_support), if (by_support == 1) "" else "s"), + if (levels_given) "no cell count meets `min_cell_n`" + else "there is no ladder of cell counts to choose from", + # A ladder the caller set is scored as given, and said to be. + if (levels_given) + sprintf("The %d level%s asked for in `levels` (%s) %s scored as given", + length(levels), if (length(levels) == 1L) "" else "s", + if (length(levels) == 1L) sprintf("%d cells", levels) + else sprintf("%d to %d cells", min(levels), max(levels)), + if (length(levels) == 1L) "is" else "are") + else "The profile scores 2 cells so that level is still visible", + if (k_cap_all < 2L) "A tessellation needs points at two locations or more." + else if (half < 1L) + sprintf("Two cells take %s on at least two rows, whatever `min_cell_n` is.", + rows_carry) + else sprintf("Lower `min_cell_n` (at most %d here), or add %s.", half, + support_what), + data = list(reason = ceiling_from, n = n_support, min_cell_n = min_cell_n)) + } else if (!supported) + .warn_classed("spatialkit_not_supported", + paste0("resolution_profile(): cells no wider than the autocorrelation ", + "range (%.0f) would need at least %.0f of them, but %d %s ", + "at min_cell_n = %d support at most %d. The data cannot ", + "support a tessellation that respects their own ", + "correlation structure; the profile runs from 2 to %d so ", + "the cost of each level is still visible."), + range_eff, floor_raw, n_support, support_what, min_cell_n, + max(2L, as.integer(data_ceiling)), ceiling_L, + data = list(reason = "floor above ceiling", n = n_support, + min_cell_n = min_cell_n)) + else if (floor_raw > ceiling_L) + .log_warn(paste0("resolution_profile(): cells no wider than the autocorrelation ", + "range (%.0f) need at least %.0f of them, which the %d %s ", + "support, but k-means on the %d-point subsample can fit at ", + "most %d; raise `sample_n`. The profile runs from 2 to %d."), + range_eff, floor_raw, n_support, support_what, n, ceiling_L, ceiling_L) + # With range_floor = FALSE, the default, the ladder starts at 2 whatever the + # range, and the floor is only reported. The range is an estimate. It is + # re-estimated on every subset, and a floor that applies on one fold and + # not on the next starts their ladders at different levels: reliability and + # the elbow, which sit near the bottom of a ladder, then move between folds + # with the ladder's start. And on a response with no structure a + # spurious range of 40 to 122 km started 11 of 100 white-noise ladders at + # 11 to 98 cells of 100, where Cp then took the floor or a level beside it. + # A floor equal to the ceiling is not applied either: it left a ladder of + # one level (3 cells at 30 points, 5 at 45), "the only level scored". + lo <- if (range_floor && supported && floor_raw < ceiling_L) floor_L else 2L + if (range_floor && supported && floor_raw == ceiling_L && ceiling_L > 2L && !levels_given) + .log_info(paste0("resolution_profile(): the range floor (%d cells) equals the ", + "ceiling, which would leave one level and nothing to compare ", + "it with; the ladder runs from 2 to %d."), ceiling_L, ceiling_L) + if (!levels_given) { + levels <- unique(as.integer(round(exp(seq(log(lo), log(ceiling_L), + length.out = max(2L, as.integer(n_levels))))))) + # The floor is a rung of the ladder whenever the layer supports it and it + # lies between the ladder's ends, applied or not. select_resolution() + # holds `reliability` to the levels at or above the floor, and without a + # rung on it the pick was the next rung up: 54 cells for a floor of 45, + # 81 for 68 at the default 20 levels, and a step of the ladder is a + # factor of 4.5 at 5 levels. One level more for the other criteria. + floor_rung <- if (supported && is.finite(range_eff) && !is.na(floor_L) && + floor_L > lo && floor_L < ceiling_L) floor_L else NULL + levels <- sort(unique(c(lo, levels, floor_rung, ceiling_L))) + } } bounds <- list(floor = floor_L, ceiling = ceiling_L, ceiling_from = ceiling_from, supported = supported, area = area, range = range_eff, n = n_all, n_sample = n, n_distinct = n_uniq_all, min_cell_n = min_cell_n, - range_floor = range_floor) + range_floor = range_floor, + n_response = if (has_resp) as.integer(n_resp) else NA_integer_, + n_scored = as.integer(n_scored), + levels_given = levels_given || size_ladder, + predictors = has_pred) + # The sizes, largest first, and the level each gives: NA for a size that + # was dropped. + if (size_ladder) { + bounds$obs_per_cell <- ladder_sizes + bounds$size_levels <- sl$size_levels + } + + # A ladder of sizes passed its guards before the variogram (above). On + # every other ladder the levels are known only now, and the one search to + # bound is the estimate's, of each scored row's nearest centre. + if (!size_ladder) centre_guard(max(levels)) # Over the hull the area is measured on, not its bounding box (see # .rbar_domain()); reliability needs an identified range. @@ -861,7 +2382,102 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU elbow = NA_real_, cell_n_min = NA_integer_, cell_n_median = NA_real_, cell_diam_median = NA_real_, rss = NA_real_, cp = NA_real_, moran_i = NA_real_, - moran_z = NA_real_, reliability = NA_real_) + moran_z = NA_real_, reliability = NA_real_, + cells_resp = NA_integer_, cell_resp_mean = NA_real_) + # One cell for the whole layer: the level every other has to beat. Its RSS + # is the total sum of squares of the scored rows, exact and free; its Cp is + # filled in below, once the noise variance is known. The ladder has no + # such level, so on a response with no spatial structure the argmin over + # it, which is noise, used to be reported with nothing to say that one + # mean does as well (picks of 2 to 750 cells over 29 white-noise layers). + one_cell <- NULL + is_const <- FALSE + if (!is.null(y) && sum(is.finite(y)) >= 2L) { + y1 <- y[is.finite(y)] + one_cell <- list(n = length(y1), rss = sum((y1 - mean(y1))^2), cp = NA_real_) + # Constant to within rounding: no level fits it better than another, the + # variogram has nothing to fit and the fallback noise variance is 0. + # Rounding is measured on the scale of the response: OLS residuals of a + # response the predictors fit exactly are all rounding error, of size + # 1e-15, and against their own sum of squares they never looked constant + # (Cp was then computed with a noise variance of 7.9e-31). + one_cell$constant <- one_cell$rss <= + 100 * .Machine$double.eps^2 * max(sum(y1^2), sum(resp[is.finite(y)]^2)) + is_const <- isTRUE(one_cell$constant) + # Nothing is scored on a constant: `cp`, `moran_i` and `moran_z` stay NA + # (see the sweep), which is what the message says. A response of + # 1e6 + 1e-9 x noise was called constant here and then given a finite + # `cp` computed from its rounding error, and a count of 2. + if (is_const) + .warn_classed("spatialkit_constant_response", + paste0("resolution_profile(): the %s is constant over the %d ", + "scored row(s) (its total sum of squares, %.3g, is ", + "rounding error at most), so no cell count fits it better ", + "than another: `cp`, `moran_i` and `moran_z` are NA at ", + "every level."), + if (identical(variable, "residuals")) "OLS residual of the response on `predictor_vars`" + else "response", one_cell$n, one_cell$rss, + data = list(n = one_cell$n)) + } + # Moran's z of the cell means needs FNN and Matrix above .KNN_DENSE_MAX + # cells. On a ladder of sizes that is 22,500 rows away at 4.5 per cell, so + # there the step is left out at such a level, with one warning here, before + # any fit. Every other ladder does the same while .moran_skip_any_ladder() + # is TRUE; with it FALSE such a ladder stops with the error of + # .build_knn_weights(). + # The step is left out by the cells that hold a scored row, which are known + # only after a level's fit, so the warning says what is known here: where + # that happens. It is raised when it can happen: the step runs at all (a + # response that is not constant), and both a level and the scored rows are + # above the limit. Only then are the two backends asked for here. + moran_off <- (size_ladder || .moran_skip_any_ladder()) && !is.null(y) && !is_const && + max(levels) > .KNN_DENSE_MAX && isTRUE(n_scored > .KNN_DENSE_MAX) && + !(backend("FNN") && backend("Matrix")) + if (moran_off) { + lacking <- c(if (!backend("FNN")) "FNN", if (!backend("Matrix")) "Matrix") + .warn_classed("spatialkit_moran_skipped", + paste0("resolution_profile(): `moran_i` and `moran_z` will be NA at a level ", + "where more than %d cells hold a scored row (this ladder reaches %d ", + "cells), because %s not ", + "installed: Moran's z of the cell means needs FNN to find each ", + "cell's neighbours and Matrix to hold them. Every other column is ", + "computed."), + .KNN_DENSE_MAX, max(levels), + if (length(lacking) > 1L) "FNN and Matrix are" else paste(lacking, "is"), + data = list(limit = .KNN_DENSE_MAX, + levels = as.integer(levels[levels > .KNN_DENSE_MAX]), + missing = lacking)) + } + # The estimate's columns, one value per level, and what every level is + # compared with: one mean for all the rows `loo` reads. + est_cols <- NULL + est_const <- FALSE + est_one <- c(NA_real_, NA_real_) + est_cache <- NULL + if (!is.null(est)) { + na_m <- rep(NA_real_, m) + est_cols <- list(scored_per_cell = na_m, loo = na_m, loo_se = na_m, share_alone = na_m, + own_weight = na_m, sigma2 = na_m, tau2 = na_m, + cells = rep(NA_integer_, m), f_p = na_m) + n_lay <- length(lay$y) + # The engine's test of a constant column, and its error of one mean. It + # takes two rows to be constant, as it does for `one_cell`: one scored + # row is too few rows, and the constant-response warning is not raised + # for it. + est_const <- n_lay >= 2L && .no_spread(sum((lay$y - mean(lay$y))^2), lay$y) + if (n_lay >= 2L && !est_const) { + e1 <- (lay$y - mean(lay$y)) * n_lay / (n_lay - 1) + est_one <- c(mean(e1^2), stats::sd(e1^2) / sqrt(n_lay)) + } + # A row alone in its region is predicted, under plain means, from the + # region of its nearest other row. The nearest other location of a + # location is the same at every level, so every level's fit shares one + # cache: filled here in one search with FNN, and on first need without. + est_cache <- new.env(parent = emptyenv()) + if (identical(est, "mean") && n_lay >= 2L && !est_const && backend("FNN")) + .nearest_other(lay$xy, rep.int(1L, n_lay), seq_len(n_lay), backend("FNN"), est_cache, + "resolution_profile") + } # The centres of the partition each level was scored on. A k-means # partition is the Voronoi partition of its centres, so these are the cells # the criteria judged; get_voronoi_seeds() and voronoi_seeds_kmeans() hand @@ -872,28 +2488,108 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # Rows and occupied cells behind each level's RSS, for Cp's fallback noise # estimate below. m_ok_v <- rep(NA_real_, m); L_ok_v <- rep(NA_real_, m) + # What the columns mean under partition = "density". The cells are then + # the Voronoi cells of centres that minimise a density-weighted sum, and + # each column is still read off those cells: + # wss, elbow The within-cell sum of squares of the coordinates, every + # point counted once, about each cell's own mean. That is + # what the kind "kmeans" reports (its centres are the cell + # means), so the column and the elbow read from it compare + # between kinds, and the curve still starts from the total + # sum of squares at one cell. The weighted sum the centres + # minimise is not a sum of squares of the layer: it weights + # a point by its density, and its one-cell value is not the + # total sum of squares. It is kept in attr(, "partition"). + # The elbow rule's threshold holds on points with no + # clusters: over 100 uniform layers of 400 to 1,500 points + # the largest sag was 0.006 under "kmeans" and 0.048 under + # "density", against the log(1.25) = 0.22 an elbow takes, + # and on 60 layers of 800 points whose density varies + # without clusters (a gradient, two plateaus, a radial + # fall) an elbow was read on 0 and on 2. Read off the + # weighted sum it was read on 10 of those 60, which is the + # other reason to read the unweighted one. Where the + # points do cluster the density kind's curve bends more + # sharply: past the number of clusters its centres go into + # the clusters, and the sparse ground keeps its sum of + # squares. On 30 layers of 3 to 8 clusters over a sparse + # background an elbow was read on 24 against 10. + # wss_spread The spread, over the starts, of what the starts minimise + # and are ranked by: the weighted sum. + # cell_n_*, cell_diam_median, cells_resp, cell_resp_mean + # Counts and sizes of the cells, whatever drew them. + # rss, cp The cells are drawn from the coordinates alone under + # either kind (the weights are a function of the + # coordinates), so the cell means are a linear fit with one + # parameter per occupied cell, which is all Mallows' Cp + # assumes. Its variance term, tau^2 times the cells over + # the rows, is the sum over the cells of (rows in the cell + # / rows) x tau^2 / (rows in the cell), and holds however + # the rows are shared out. + # moran_i, moran_z, the F test against one cell + # Statistics of the cell means under the hypothesis of no + # structure, valid for any cells drawn without the + # response. Moran's z assumes cell means of equal + # variance, which cells of about equal counts come closer + # to. + # reliability Not read off the cells at all: it is computed for square + # cells of the level's average area that hold the level's + # average count, so it is the same number under either + # kind. The cells of the density kind match its counts + # more closely and its areas less. + # Nothing here is undefined under the density kind, so no column is NA for + # the kind's sake. A level at which no start gives a partition is NA under + # either kind. + objective_v <- rep(NA_real_, m) + # Iterations the kept start of each level took, and whether it stopped + # before the limit. + iter_v <- rep(NA_integer_, m); converged_v <- rep(NA, m) + # Occupied cells per level. Every cell of the kind "kmeans" holds a point; + # a centre of the density kind that loses its points stays where it is, + # and its cell then adds no mean to Cp's variance term. + L_fit_v <- as.numeric(levels) for (i in seq_len(m)) { L <- levels[i] - kb <- .kmeans_best(xy, L, nstart = nstart) + kb <- .partition_centres(xy, L, partition = part$kind, init = part$init, + nstart = nstart, iter.max = part_iter, + density_power = density_power, density_k = density_k, + use_fnn = backend("FNN")) if (is.null(kb)) { - .log_warn("resolution_profile(): k-means failed at %d cells; that level is NA.", L) + .log_warn("resolution_profile(): %s failed at %d cells; that level is NA.", + if (identical(part$kind, "density")) "the density-weighted k-means" + else "k-means", L) next } - km <- kb$km - centres[[i]] <- unname(km$centers[, 1:2, drop = FALSE]) + cl <- kb$cluster + centres[[i]] <- kb$centers out$wss[i] <- kb$wss out$wss_spread[i] <- kb$spread - sizes <- tabulate(km$cluster, nbins = L) + objective_v[i] <- kb$objective + iter_v[i] <- as.integer(kb$iter) + converged_v[i] <- isTRUE(kb$converged) + sizes <- tabulate(cl, nbins = L) + L_fit <- sum(sizes > 0L) + L_fit_v[i] <- L_fit + if (L_fit < L) + .warn_classed("spatialkit_empty_cells", + paste0("resolution_profile(): at %d cells, %d of the centres hold no ", + "point (a centre that loses its points stays where it is), so ", + "the level has %d occupied cells: `cell_n_min` is 0 there, and ", + "`cp` counts the occupied cells."), + L, L - L_fit, L_fit, + data = list(level = as.integer(L), empty = as.integer(L - L_fit))) out$cell_n_min[i] <- as.integer(min(sizes)) out$cell_n_median[i] <- stats::median(sizes) - rad <- sqrt(km$withinss / pmax(sizes, 1L)) + rad <- sqrt(kb$withinss / pmax(sizes, 1L)) out$cell_diam_median[i] <- 2 * stats::median(rad[sizes >= 2L]) if (!is.null(y)) { okr <- is.finite(y) m_ok <- sum(okr) - L_ok <- length(unique(km$cluster[okr])) # cells holding a scored row + L_ok <- length(unique(cl[okr])) # cells holding a scored row + out$cells_resp[i] <- L_ok + if (L_ok > 0L) out$cell_resp_mean[i] <- m_ok / L_ok if (m_ok > L_ok) { - cm <- stats::ave(y[okr], km$cluster[okr]) + cm <- stats::ave(y[okr], cl[okr]) out$rss[i] <- sum((y[okr] - cm)^2) m_ok_v[i] <- m_ok; L_ok_v[i] <- L_ok # Cp for the cells of the whole layer, estimated from the subsample. @@ -902,19 +2598,55 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # tau^2 per cell); tau^2 L / N is the sampling variance of cell means # built from the layer's N rows with a response. With no subsample # (m = N, L_ok = L) it is Mallows' RSS / n + 2 tau^2 L / n. - if (!is.null(vg)) - out$cp[i] <- out$rss[i] / m_ok + vg$nugget * (L_ok / m_ok + L / n_resp) + if (!is.null(vg) && !is_const) + out$cp[i] <- out$rss[i] / m_ok + vg$nugget * (L_ok / m_ok + L_fit / n_resp) + } + # Moran's I of cell means that differ by rounding error alone is + # rounding error too. + # Left NA as well where the neighbour weights of more than + # .KNN_DENSE_MAX cell means cannot be built (`moran_off`, above). On a + # ladder of sizes the cell means come from grouped sums: the loop makes + # a pass over all the rows for every cell, which is quadratic in the + # rows at a fixed size. + if (!is_const && !(moran_off && L_ok > .KNN_DENSE_MAX)) { + mi <- .morans_i_for_k(xy[okr, , drop = FALSE], y[okr], + pred_for_moran[okr, , drop = FALSE], cl[okr], + grouped = size_ladder, use_fnn = backend("FNN"), + use_matrix = backend("Matrix")) + out$moran_i[i] <- mi[["I"]] + out$moran_z[i] <- mi[["z"]] } - mi <- .morans_i_for_k(xy[okr, , drop = FALSE], y[okr], - pred_for_moran[okr, , drop = FALSE], km$cluster[okr]) - out$moran_i[i] <- mi[["I"]] - out$moran_z[i] <- mi[["z"]] } # The layer's point count: the cell means are built from every point, # not from the subsample the partition was fitted on. if (!is.null(vg$cor_fn)) out$reliability[i] <- .reliability_at(L, area, n_resp, vg$nugget, vg$psill, vg$cor_fn, rbar_V) + # The estimate, last: on every scored row of the layer, each in the cell + # of its nearest centre. It draws no random number and changes nothing + # above, so the columns a profile has without an estimate are the same + # numbers with one. + if (!is.null(est) && length(lay$y)) { + lv <- .estimate_at_level(lay$xy, lay$y, kb$centers, est, backend("FNN"), est_cache) + for (nm in names(est_cols)) est_cols[[nm]][i] <- lv[[nm]] + } + } + # Each row is left out alone, and the other rows at its location stay. + # Said once, after the levels are scored and where one of them has a + # `loo`: on a constant response, and where no level could be scored, the + # sentence would describe a number the profile does not hold. + if (!is.null(est) && any(is.finite(est_cols$loo))) { + repeated <- .repeated_rows(lay$xy) + if (repeated > 0L) + .warn_classed("spatialkit_repeated_locations", + paste0("resolution_profile(): %d of the %d rows with a value of '%s' ", + "share a location with another row. The leave-one-out error ", + "leaves one row out and keeps the others at its location, so it, ", + "and an interval built from it, describes a further observation ", + "at a place already observed, not an observation at a new place."), + repeated, length(lay$y), response_var, + data = list(n = as.integer(repeated), total = length(lay$y), + column = response_var)) } # Cp's noise variance. From the variogram's nugget when it gives one; when @@ -926,10 +2658,18 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # level whose cells hold at least two scored rows on average. It counts # the structure within those cells as noise as well, so on average it is # no smaller than the nugget and errs towards fewer cells. - cp_noise <- if (!is.null(vg)) + cp_noise <- if (!is.null(vg) && !is_const) list(source = "variogram nugget", value = vg$nugget, level = NA_integer_) else NULL - if (is.null(vg) && !is.null(y)) { + # A ladder of sizes under sac = "auto" fits no variogram, and `cp` gets no + # noise variance from the finest level in its place: on such a ladder that + # level is one the caller chose, so the number would be set by the ladder + # asked for. The reason is recorded where the noise variance would be. + if (no_vg) + cp_noise <- list(source = "none", value = NA_real_, level = NA_integer_, + reason = paste0("no variogram: a size ladder fits one only when ", + "`sac` is given")) + if (is.null(vg) && !is.null(y) && !is_const && !no_vg) { dfree <- m_ok_v - L_ok_v cand <- which(is.finite(out$rss) & is.finite(dfree) & dfree >= L_ok_v) if (length(cand)) { @@ -938,13 +2678,20 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU if (is.finite(s2) && s2 > 0) { fin_cp <- is.finite(out$rss) & is.finite(m_ok_v) & m_ok_v > 0 out$cp[fin_cp] <- out$rss[fin_cp] / m_ok_v[fin_cp] + - s2 * (L_ok_v[fin_cp] / m_ok_v[fin_cp] + levels[fin_cp] / n_resp) + s2 * (L_ok_v[fin_cp] / m_ok_v[fin_cp] + L_fit_v[fin_cp] / n_resp) cp_noise <- list(source = "finest-level residual mean square", value = s2, level = as.integer(levels[j])) + # A variogram that found no spatial structure does carry a model, the + # pure nugget summarize_by_cell() and kriging_adequacy() use, so "no + # usable variogram model" was untrue of it and contradicted the line + # logged above. What it lacks is a nugget apart from the sill. why <- if (is.null(sac)) "no variogram was fitted (gstat is not installed, or estimate_sac_range() failed; see the log)" else if (!is.data.frame(attr(sac, "variogram_model"))) sprintf("%s carries no variogram model and so no nugget", sac_what) + else if (.sac_no_structure(sac)) + sprintf("%s found no spatial structure and gives no nugget that can be told from the sill", + sac_what) else sprintf("%s gives no usable variogram model", sac_what) .warn_and_log(paste0("resolution_profile(): %s, so `cp` takes its noise ", "variance from the residual mean square of the finest ", @@ -958,6 +2705,35 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU } } + # Cp at one cell, by the formula of the sweep (L = L_ok = 1) and with the + # noise variance the levels were given. `cp_levels` ties it to the column + # it belongs to: select_resolution() compares the two only while that + # column is the one computed here. + if (!is.null(one_cell)) { + if (!is.null(cp_noise) && is.finite(cp_noise$value)) + one_cell$cp <- one_cell$rss / one_cell$n + + cp_noise$value * (1 / one_cell$n + 1 / n_resp) + one_cell$cp_levels <- stats::setNames(out$cp, levels) + # Whether a level's cells differ from one mean by more than chance: the + # F test of the cell means, (TSS - RSS) / (cells - 1) over RSS / (rows - + # cells), on the cells that hold a scored row. The cells are fitted to + # the coordinates alone, so with no spatial structure in the scored + # variable the statistic has its F distribution at every level, and the + # test needs no noise variance. select_resolution() reads it at the Cp + # optimum: a comparison of Cp at one cell with Cp there has no sampling + # error in it, and none at all to work with when Cp's noise variance is + # 0 (Cp is then RSS / n, which falls with every finer level). + df1 <- L_ok_v - 1; df2 <- m_ok_v - L_ok_v + f_p <- rep(NA_real_, m) + f_ok <- !is_const & is.finite(out$rss) & is.finite(df1) & df1 >= 1 & is.finite(df2) & df2 >= 1 + if (any(f_ok)) { + f_stat <- ((one_cell$rss - out$rss[f_ok]) / df1[f_ok]) / (out$rss[f_ok] / df2[f_ok]) + f_p[f_ok] <- stats::pf(pmax(f_stat, 0), df1[f_ok], df2[f_ok], lower.tail = FALSE) + } + one_cell$f_p <- stats::setNames(f_p, levels) + } + attr(out, "one_cell") <- one_cell + # The elbow over the ladder, and the bumps on it. The sag of log WSS below # the straight line from k = 1 to the last level on log-log axes (see # .elbow_sag()); NA at every level when the curve has no elbow. On linear @@ -988,13 +2764,60 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU "no cluster structure); `elbow` is NA.")) } wss_bumps <- .wss_bumps(out$wss[fin]) - if (wss_bumps > 0L) + if (wss_bumps > 0L && part_default) .log_warn(paste0("resolution_profile(): the WSS curve rises at %d step(s) of ", "the ladder even with %d k-means++ restarts; the elbow and ", "the neighbouring levels' spread are partly optimisation noise."), wss_bumps, nstart) + else if (wss_bumps > 0L && identical(part$kind, "kmeans")) + .log_warn(paste0("resolution_profile(): the WSS curve rises at %d step(s) of ", + "the ladder even with %s per level; the elbow and the ", + "neighbouring levels' spread are partly optimisation noise."), + wss_bumps, .partition_label(part, nstart)) + else if (wss_bumps > 0L) + # The density kind minimises the weighted sum, so a rise of the + # unweighted one is not by itself a start that went wrong; a rise of the + # weighted sum is. + .log_warn(paste0("resolution_profile(): the WSS curve rises at %d step(s) of ", + "the ladder. The centres of partition = \"density\" minimise the ", + "density-weighted sum (attr(, \"partition\")$objective), ", + "which rises at %d step(s) with %s per level; the elbow is read ", + "off the unweighted curve and is that much less sure."), + wss_bumps, .wss_bumps(objective_v[is.finite(objective_v)]), + .partition_label(part, nstart)) + + # A level whose kept start was cut off at the iteration limit: its centres + # are those of the last step, and a longer run can still move points + # between cells. Said for every call but the one this function has always + # made (k-means from k-means++ starts with its own limit), whose result and + # conditions are unchanged. + cut_off <- which(converged_v %in% FALSE) + if (length(cut_off) && (!part_default || !is.null(iter_max))) + .warn_not_converged("resolution_profile", levels[cut_off], iter_v[cut_off], part_iter, + part$kind, "iter_max", of = m) + + # The record of the kind that built the regions. Absent for the present + # kind, so that a profile made with it is unchanged; .partition_record() + # reads either. The weighted sum each level's centres minimise goes with + # it under the density kind, since `wss` there is the unweighted one, and + # so do the iterations each level's kept start took and whether it stopped + # before the limit. + part_attr <- NULL + if (!part_default) { + part_attr <- part[.partition_fields()] + if (identical(part$kind, "density")) + part_attr$objective <- stats::setNames(objective_v, levels) + part_attr$iter_max <- as.integer(part_iter) + part_attr$iter <- stats::setNames(iter_v, levels) + part_attr$converged <- stats::setNames(converged_v, levels) + } - structure(out, + # The estimate's five columns, after the columns a profile has without one. + if (!is.null(est)) + for (nm in c("scored_per_cell", "loo", "loo_se", "share_alone", "own_weight")) + out[[nm]] <- est_cols[[nm]] + + out <- structure(out, class = c("resolution_profile", "data.frame"), bounds = bounds, variogram = if (is.null(vg)) NULL @@ -1006,7 +2829,33 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU split = split, cp_noise = cp_noise, centres = centres, - centres_crs = sf::st_crs(data_sf)) + centres_crs = sf::st_crs(data_sf), + # The convex hull of every point profiled, in that CRS: the ground + # the scored centres stand for. get_voronoi_seeds() hands it on as + # the seeds' cover when it is given the profile and neither points + # nor a boundary, so their Voronoi cells reach the points' hull and + # not only the centres'. + hull = hull) + if (!is.null(part_attr)) attr(out, "partition") <- part_attr + # What the estimate's columns were computed for and against. + if (!is.null(est)) { + attr(out, "estimate") <- list( + value = est, + neighbours = if (identical(est, "pooled")) .POOL_NEIGHBOURS else NA_integer_, + response = response_var, + n = length(lay$y), + rows = if (is.null(split)) "all" else "selection half", + features = if (was_points) "points" else "other", + seed = seed, + constant = est_const, + loo_one_cell = est_one[1L], loo_one_cell_se = est_one[2L], + loo_levels = stats::setNames(est_cols$loo, levels), + sigma2 = stats::setNames(est_cols$sigma2, levels), + tau2 = stats::setNames(est_cols$tau2, levels), + cells = stats::setNames(est_cols$cells, levels), + f_p = stats::setNames(est_cols$f_p, levels)) + } + out } @@ -1039,30 +2888,83 @@ print.resolution_profile <- function(x, digits = 3L, ...) { } # `n` is the layer; the k-means fits may have run on a subsample of it. n_fit <- b$n_sample %||% b$n + # The rows the support ceiling counts, when they are fewer than the points. + n_rsp <- b$n_response %||% NA_integer_ + some_missing <- isTRUE(n_rsp > 0L && n_rsp < b$n) + too_few <- b$ceiling_from %in% c("fewer than two supported cells", + "fewer than two distinct locations") + # What a row carries to be counted: with predictors, a predictor missing + # leaves it out as much as a response missing does. + carry <- if (isTRUE(b$predictors)) "with a response and every predictor" else "with a response" cat("Resolution profile:", nrow(x), "levels on", b$n, - if (isTRUE(n_fit < b$n)) sprintf("points (k-means fitted to a subsample of %d)\n", n_fit) + if (isTRUE(n_fit < b$n) && some_missing) + sprintf("points (%d %s; k-means fitted to a subsample of %d)\n", n_rsp, carry, n_fit) + else if (isTRUE(n_fit < b$n)) sprintf("points (k-means fitted to a subsample of %d)\n", n_fit) + else if (some_missing) sprintf("points (%d %s)\n", n_rsp, carry) else "points\n") - cat(sprintf(" ladder : %d to %d cells (floor %s, ceiling %d%s)%s\n", - min(x$levels), max(x$levels), - if (!is.finite(b$range)) "2 (no range)" - else paste0(if (is.na(b$floor)) sprintf("beyond integer range from range %.0f", b$range) - else sprintf("%d from range %.0f", b$floor, b$range), - if (isFALSE(b$range_floor)) ", not applied" else ""), - b$ceiling, - # With no location repeated the cap is one short of the points - # (stats::kmeans() needs fewer centres than points), and "from - # 30 distinct locations" named a number that did not bind. - if (identical(b$ceiling_from, "distinct locations") && - isTRUE(b$ceiling < (b$n_distinct %||% NA_integer_))) - sprintf(", one short of the %d points", b$n) - else if (identical(b$ceiling_from, "distinct locations")) - sprintf(" from %d distinct locations", b$n_distinct %||% NA_integer_) - else if (identical(b$ceiling_from, "sample_n")) - sprintf(" from the %d-point subsample", n_fit) - else sprintf(" from min_cell_n = %d", b$min_cell_n), - if (!isTRUE(b$supported)) " -- floor above ceiling: not supported" - else if (isTRUE(b$floor > b$ceiling)) " -- floor above ceiling: raise sample_n" - else "")) + # A ladder `obs_per_cell` set: its levels are the counts the sizes give, + # so the line names the sizes and the rows they divide, and no ceiling. + if (!is.null(b$obs_per_cell)) { + n_div <- if (isTRUE(n_rsp > 0L)) n_rsp else b$n + # The sizes that have a level: a size of "auto" that gave fewer than two + # cells was left out of the ladder, and is left out of its line. + built <- if (length(b$size_levels) == length(b$obs_per_cell)) + b$obs_per_cell[!is.na(b$size_levels)] else b$obs_per_cell + cat(sprintf(" ladder : %s cells (obs_per_cell = %s on the %d %s; centres fitted to every row; floor %s)%s\n", + if (min(x$levels) == max(x$levels)) sprintf("%d", max(x$levels)) + else sprintf("%d to %d", min(x$levels), max(x$levels)), + paste(vapply(built, function(s) format(s), ""), collapse = ", "), + n_div, + if (isTRUE(n_rsp > 0L)) paste(if (n_div == 1L) "row" else "rows", carry) + else "points", + if (!is.finite(b$range)) "2 (no range)" + else paste0(if (is.na(b$floor)) sprintf("beyond integer range from range %.0f", b$range) + else sprintf("%d from range %.0f", b$floor, b$range), + ", not applied"), + if (!isTRUE(b$supported) && identical(b$ceiling_from, "fewer than two distinct locations")) + " -- the points sit on one location: not supported" + else if (!isTRUE(b$supported) && identical(b$ceiling_from, "fewer than two cells of the size")) + " -- fewer than two cells of the size: not supported" + else if (!isTRUE(b$supported)) " -- floor above the finest level: not supported" + else "")) + } else { + cat(sprintf(" ladder : %d to %d cells (floor %s, ceiling %d%s)%s\n", + min(x$levels), max(x$levels), + if (!is.finite(b$range)) "2 (no range)" + else paste0(if (is.na(b$floor)) sprintf("beyond integer range from range %.0f", b$range) + else sprintf("%d from range %.0f", b$floor, b$range), + if (isFALSE(b$range_floor)) ", not applied" else ""), + b$ceiling, + # With no location repeated the cap is one short of the points + # (stats::kmeans() needs fewer centres than points), and "from + # 30 distinct locations" named a number that did not bind. + if (identical(b$ceiling_from, "distinct locations") && + isTRUE(b$ceiling < (b$n_distinct %||% NA_integer_))) + sprintf(", one short of the %d points", b$n) + else if (identical(b$ceiling_from, "distinct locations")) + sprintf(" from %d distinct locations", b$n_distinct %||% NA_integer_) + else if (identical(b$ceiling_from, "sample_n") && + isTRUE((b$n_scored %||% NA_integer_) < n_fit)) + sprintf(" from the %d scored rows of the %d-point subsample", b$n_scored, n_fit) + else if (identical(b$ceiling_from, "sample_n")) + sprintf(" from the %d-point subsample", n_fit) + else if (identical(b$ceiling_from, "min_cell_n (rows with a response)")) + sprintf(" from min_cell_n = %d on the %d rows %s", + b$min_cell_n, n_rsp, carry) + else if (identical(b$ceiling_from, "fewer than two supported cells")) + sprintf(": fewer than two cells meet min_cell_n = %d", b$min_cell_n) + else if (identical(b$ceiling_from, "fewer than two distinct locations")) + ": the points sit on one location" + else sprintf(" from min_cell_n = %d", b$min_cell_n), + # "no ladder" is said of a ladder the profile built, one level + # of 2 cells; levels the caller asked for are in the table. + if (!isTRUE(b$supported) && isTRUE(too_few) && isTRUE(b$levels_given)) + " -- levels as given: not supported" + else if (!isTRUE(b$supported) && isTRUE(too_few)) " -- no ladder: not supported" + else if (!isTRUE(b$supported)) " -- floor above ceiling: not supported" + else if (isTRUE(b$floor > b$ceiling)) " -- floor above ceiling: raise sample_n" + else "")) + } vg <- attr(x, "variogram", exact = TRUE) cn <- attr(x, "cp_noise", exact = TRUE) cat(sprintf(" variogram : %s\n", @@ -1071,13 +2973,45 @@ print.resolution_profile <- function(x, digits = 3L, ...) { sprintf(paste0("none usable (reliability is NA; cp's noise ", "variance %.3g is the residual mean square at %d cells)"), cn$value, cn$level) + # A ladder of sizes that was given no `sac` fits none. + else if (identical(cn$source, "none")) + paste0("none fitted: a size ladder fits one only when `sac` is given ", + "(cp and reliability are NA)") else "none usable (cp and reliability are NA)") else sprintf("nugget %.3g, partial sill %.3g, range %s", vg$nugget, vg$psill, if (is.finite(vg$range)) sprintf("%.0f", vg$range) else "unidentified"))) - cat(sprintf(" scored on : %s; %d k-means++ restarts per level; WSS rises at %d step(s)\n", + # The kind that built the cells: unrecorded for k-means from k-means++ + # starts, whose line is the one it always was. + part <- attr(x, "partition", exact = TRUE) + cat(sprintf(" scored on : %s; %s per level; WSS rises at %d step(s)\n", if (is.na(attr(x, "variable"))) "geometry only" else attr(x, "variable"), - attr(x, "nstart"), attr(x, "wss_bumps"))) + if (is.list(part) && !is.null(part$kind)) .partition_label(part, attr(x, "nstart")) + else sprintf("%d k-means++ restarts", attr(x, "nstart")), + attr(x, "wss_bumps"))) + # What one cell for the whole layer scores: the ladder starts at 2, so the + # level every other has to beat is not a row of the table. + one <- attr(x, "one_cell", exact = TRUE) + if (is.list(one) && is.finite(one$rss %||% NA_real_)) + cat(sprintf(" one cell : rss %s%s (one mean for the layer; a level has to beat it)\n", + format(signif(one$rss, digits)), + if (isTRUE(one$constant)) ", a constant" + else if (is.finite(one$cp %||% NA_real_)) + sprintf(", cp %s", format(signif(one$cp, digits))) + else "")) + # The estimate the profile scores, the rows its leave-one-out error reads, + # and that error with one mean for all of them. + est <- attr(x, "estimate", exact = TRUE) + if (is.list(est) && !is.null(est$value)) + cat(sprintf(" estimate : %s; loo on %d row%s of the %s; one cell: loo %s\n", + if (identical(est$value, "pooled")) + sprintf("pooled toward the %d nearest cells", est$neighbours) + else "plain means", + est$n, if (isTRUE(est$n == 1L)) "" else "s", + if (identical(est$rows, "selection half")) "selection half" else "layer", + if (isTRUE(est$constant)) "NA (the response is constant)" + else if (isTRUE(est$n < 2L)) "NA (fewer than two rows)" + else format(signif(est$loo_one_cell, digits)))) if (all(c("elbow", "wss") %in% names(x)) && !any(is.finite(x$elbow)) && sum(is.finite(x$wss)) >= 2L) cat(" elbow : none; the WSS curve falls as it does with no cluster structure\n") @@ -1166,7 +3100,11 @@ print.resolution_profile <- function(x, digits = 3L, ...) { #' Read a level, and the region over which it is not distinguishable, off a profile #' #' Picks the level a criterion prefers, together with the \emph{flat region}: -#' every level whose criterion value is within \code{tol} of the optimum. On +#' every level whose criterion value is within \code{tol} of the optimum. +#' On the default profile, one size scored for pooled values, the default +#' criterion is that size: it returns the count the size gives, with no +#' optimum and no flat region (see "A profile built with an estimate"); what +#' follows is about the criteria read on a ladder of counts. On #' the criteria this package computes the flat region is routinely wide: the #' reliability curve is flat to within 2 percent over a factor of 3--6 in the #' number of cells, and \eqn{C_p} on a smooth field descends to the support @@ -1174,42 +3112,323 @@ print.resolution_profile <- function(x, digits = 3L, ...) { #' When the optimum sits at an end of the levels the criterion was scored at, #' the result says so and names the bound, because a bound is then doing the #' choosing rather than the criterion (see -#' \code{\link{resolution_profile}} for what each criterion measures and how -#' it behaved on simulated fields). +#' \code{\link{resolution_profile}} for what each criterion measures and +#' what it returns in practice). The functions that take the result as a +#' cell count raise that as a warning of class +#' \code{spatialkit_bound_chosen}. +#' +#' @section What each criterion returns: +#' \describe{ +#' \item{\code{cp}}{The level that minimises Mallows' \eqn{C_p}: the count +#' at which re-measuring the sampled sites, each predicted by its cell's +#' mean, has the least estimated error (\code{\link{resolution_profile}} +#' says what that leaves out for a new location). On a smooth response +#' with little noise that is the support ceiling. The result also says whether the optimum beats one +#' cell for the whole layer (\code{attr(profile, "one_cell")}), in +#' \code{structured}. It is \code{TRUE} when two things hold: +#' \eqn{C_p} at one cell is above the optimum by more than \code{tol}, +#' and the cell means at the optimum differ from one mean by more than +#' chance allows. The second is the F test of the cells against one +#' mean, \eqn{(TSS - RSS) / (L - 1)} over \eqn{RSS / (m - L)}, at 5 +#' percent after a Bonferroni adjustment for the levels the optimum was +#' searched over (\code{structure_p} is the adjusted p-value). The +#' cells are fitted to the coordinates alone, so the test holds its +#' level on a response with no spatial structure whatever \eqn{C_p}'s +#' noise variance is, and it is what decides when that variance is 0: +#' \eqn{C_p} is then \eqn{RSS / n}, which falls with every finer level +#' by chance alone, and the first comparison says nothing. +#' When either fails, \code{structured} is \code{FALSE}: one mean for +#' the whole layer predicts as well as any level scored, so the +#' response shows no spatial structure the cells can use and the count +#' is not identified. \code{structured} is also \code{FALSE} when the +#' profile's variogram was refused for showing no spatial structure. +#' \code{best} is still the argmin. +#' \strong{Measured on white noise} (uniform points, the automatic +#' ladder of \code{obs_per_cell = NULL}), \code{structured} was +#' \code{TRUE} on 3 of 200 layers of 60 points, 7 of 200 of 120, 5 of +#' 150 of 300 and none of 80 of 600 or of +#' 40 of 1,500 with the noise variance taken from the finest level; and +#' with the package's own variogram, whose nugget was 0 on 27 of the +#' 180 layers, on none of 120 layers of 120 points and 3 of 60 of 300. +#' The first comparison alone gave 27, 20, 8, 0 and 0, and then 38 and +#' 11. The F distribution is exact for a Gaussian response, and the +#' test held its level on others: with no structure in a lognormal +#' response, a 0/1 response with mean 0.1 and a \eqn{t_3} response, +#' \code{structured} was \code{TRUE} on 2 to 10 of 200 layers at each +#' of 60, 120 and 300 points. A \code{FALSE} on a small layer is weak +#' evidence that there is +#' no structure: on exponential fields (range parameter 100 on a +#' 1000-unit extent, nugget 0.3 on a unit sill) \code{structured} was +#' \code{TRUE} on 12 of 40 layers of 60 points, 36 of 40 of 120 and 40 +#' of 40 of 300.} +#' \item{\code{reliability}}{The coarsest count the range allows. The +#' reliability curve peaks below the range floor, so it is read at the +#' levels at or above the floor the profile reports (when the layer +#' supports the floor and the profile built its own ladder). The floor +#' is a level of every such ladder, so the result is the floor, with +#' \code{edge} naming it (on a profile whose k-means failed at that +#' level, the first level above it). \code{range_floor = FALSE} reads +#' every level and returns the curve's own maximum, which is usually a +#' count below the floor.} +#' \item{\code{elbow}}{The number of clusters of the points, when they +#' cluster; an error otherwise, because the column is \code{NA} at every +#' level unless the WSS curve bends.} +#' \item{\code{moran_z}}{Refused unless \code{diagnostic = TRUE}. It is +#' the level at which neighbouring cell means (or, with predictors, +#' their regression residuals) are least autocorrelated. \eqn{|z|} is +#' near 0 at 10 to 20 cells whatever the data and grows as cells get +#' finer than the range, so its minimum is usually the first level it +#' can be computed at, or one near it, and it says nothing about how +#' well the cells represent the response.} +#' \item{\code{loo}}{The level with the lowest leave-one-out error of the +#' estimate the profile was built for +#' (\code{\link{resolution_profile}(estimate = )}); of levels with the +#' same error, the one with the fewest cells. The flat region is every +#' level whose error is within \code{tol} of the lowest. The column +#' needs no variogram. \code{structured} is read as for \code{cp}, with +#' the leave-one-out error in place of \eqn{C_p}: it is \code{TRUE} when +#' the error of one mean for all scored rows is above the optimum by +#' more than \code{tol} and the F test of the cells at the optimum +#' against one mean, adjusted for the levels searched, has +#' \eqn{p < 0.05}; \code{one_cell} then holds the error of one mean. +#' Under this criterion the count depends on the values of the response. +#' When the profile's estimate is the pooled value and the lowest error +#' is at the finest level scored, a note says that the end of the ladder +#' chose the count. For pooled values the error tends to keep falling to +#' the finest level: in the simulation described under "Observations per +#' cell" in \code{\link{resolution_profile}}, the lowest error of the +#' pooled value was at the finest of seven sizes on 176 of 200 layers, +#' and that of the plain mean on none. On a ladder \code{obs_per_cell} +#' set, an optimum at +#' an end has the \code{edge} \code{"the finest size offered +#' (obs_per_cell)"} or \code{"the coarsest size offered +#' (obs_per_cell)"}; a finest level the profile held to the most cells +#' k-means can place keeps the label of the support ceiling.} +#' \item{\code{size}}{The count a size gives, +#' \code{max(2, round(n / obs_per_cell))}, with \code{n} the rows the +#' size divides: the rows with a response, or every point for a profile +#' without one. No optimum is searched for. The level returned is the +#' first of three that applies: the level the profile built for that +#' size; the count itself, when the profile has a partition at it; +#' otherwise the built level nearest to the count on the log scale (of +#' two as near, the one with fewer cells), with a warning of class +#' \code{spatialkit_size_not_reached}, which says so when the count is +#' more than k-means can place on the layer. It reads any profile, one +#' built without a response or without an estimate included, but not a +#' column subset, which has lost the row count. \code{flat} is the level, +#' \code{value} the rows per cell it leaves (\code{n / best}), and +#' \code{at_ceiling}, \code{at_floor} and \code{edge} are \code{NA}: no +#' bound chose anything, so the functions that take the selection as a +#' count raise no \code{spatialkit_bound_chosen}. Under this rule +#' neither the cells, which are fitted to the coordinates, nor their +#' number, which is a count of rows, depend on the values of the +#' response. +#' A size does not ask whether the response has structure the cells can +#' use, so \code{structured} asks it separately, on a profile built with +#' an \code{estimate}. It is \code{FALSE} when the leave-one-out error +#' of one mean for all scored rows is within \code{tol} of the error at +#' the level, or below it, or when the F test of the cells at the level +#' against one mean has \eqn{p \ge 0.05}. The count stands either way, +#' since the caller set it: \code{structured = FALSE} says that the cell +#' values will say little that one mean for the layer does not. The +#' functions that take the selection as a count then raise +#' \code{spatialkit_no_structure}. On a profile without an estimate +#' \code{structured} is \code{NA}.} +#' \item{\code{auto}}{The rule that goes with the profile's estimate: +#' \code{"size"} for a profile built with \code{estimate = "pooled"}, +#' \code{"loo"} for \code{estimate = "mean"}, and \code{"cp"} for a +#' profile without an estimate. A column subset of a profile has lost +#' the record of its estimate and is read by \code{"cp"}. +#' \code{criterion} in the result is the criterion applied, never +#' \code{"auto"}.} +#' } +#' +#' @section A profile built with an estimate: +#' This function's default criterion is \code{"auto"}: \code{"size"} for a +#' profile of pooled values, \code{"loo"} for one of plain means and +#' \code{"cp"} for a profile without an estimate. A profile built with +#' \code{estimate} that is passed straight to +#' \code{\link{get_voronoi_seeds}()}, \code{\link{voronoi_seeds_kmeans}()} or +#' \code{\link{build_tessellation}()} as the count is read the same way, so +#' \code{select_resolution(profile)} and the profile itself give the same +#' count. A profile of pooled values built with a ladder argument +#' (\code{n_levels} and the others) is read by the size as well: the +#' default returns the level nearest the count the size gives, on the +#' automatic ladder its top level, with \code{spatialkit_size_not_reached}. +#' The default was \code{"cp"} in earlier versions, whatever the profile; +#' \code{criterion = "cp"} reads it as before on a profile that has it. \code{cp} is computed on such a profile as on any other and +#' scores plain means; when the profile's estimate is the pooled value the +#' result's note says so. +#' +#' \code{"cp"} and \code{"reliability"} cannot be read off a profile whose +#' ladder \code{obs_per_cell} set under \code{sac = "auto"}. Such a profile +#' fits no variogram, both columns are \code{NA} at every level, and the +#' call is an error that names the ways to get them: build the profile with +#' \code{sac = NULL}, with a \code{sac} of your own, or with +#' \code{obs_per_cell = NULL}. The default profile is such a profile. For +#' the count \code{"cp"} gave in earlier versions, build the profile with +#' \code{estimate = NULL, obs_per_cell = NULL}, and with \code{partition = +#' "kmeans"} for the same regions. On a ladder of one size that has a +#' variogram either criterion returns the one level, with \code{edge} +#' \code{"the only level scored"}. +#' +#' For a ladder of one size, \code{summary()} of the profile lists each +#' criterion that is finite at the level and says that the size set the +#' count, and \code{plot()} draws each as one point, with no selected level +#' and no band. When none is finite, as on a constant response, where +#' \code{loo} is \code{NA} too, \code{summary()} stops with an error that +#' says so. #' #' @param profile A \code{resolution_profile}. -#' @param criterion Which column decides: \code{"cp"} (minimised), -#' \code{"reliability"} (maximised), \code{"elbow"} (maximised) or -#' \code{"moran_z"} (\eqn{|z|} minimised). -#' @param tol Width of the flat region. For \code{cp} and \code{reliability} -#' it is relative to the optimum's value (\code{0.02} keeps levels within 2 -#' percent of it); for \code{elbow} and \code{moran_z}, whose optimum can -#' be zero, it is relative to the criterion's range over the ladder. +#' @param criterion Which rule sets the count: \code{"cp"} (minimised), +#' \code{"reliability"} (maximised at or above the range floor), +#' \code{"elbow"} (maximised), \code{"loo"} (the leave-one-out error of +#' the profile's estimate, minimised), \code{"size"} (the count +#' \code{obs_per_cell} gives), \code{"auto"} (\code{"size"} for a profile +#' of pooled values, \code{"loo"} for one of plain means, \code{"cp"} for +#' a profile without an estimate) or, with \code{diagnostic = TRUE}, +#' \code{"moran_z"} (\eqn{|z|} minimised). Default \code{"auto"}. +#' \code{"cp"} was the default of earlier versions; name it to read +#' \eqn{C_p} on a profile that has it. +#' @param tol Width of the flat region. For \code{cp}, \code{reliability} +#' and \code{loo} it is relative to the optimum's value (\code{0.02} keeps +#' levels within 2 percent of it); for \code{elbow} and \code{moran_z}, +#' whose optimum can be zero, it is relative to the criterion's range over +#' the ladder. Under \code{"size"} there is no flat region, and +#' \code{tol} is the margin by which the cells have to beat one mean for +#' \code{structured} and nothing else. +#' @param range_floor For \code{criterion = "reliability"} only. +#' \code{TRUE} (default) reads the criterion at the levels at or above +#' the range floor in \code{attr(profile, "bounds")}, which is where +#' \code{resolution_profile()} started the ladder by default up to version +#' 2.0.0. It applies when the layer supports the floor, some scored level +#' reaches it, and the profile built its own ladder (a ladder set with +#' \code{levels} is read as given). \code{FALSE} reads every level. +#' @param diagnostic \code{criterion = "moran_z"} is refused, with an error +#' of class \code{spatialkit_diagnostic_criterion} that says what the +#' column measures, unless this is \code{TRUE}: \code{moran_z} is a +#' diagnostic of the cell means, not a count rule. Default \code{FALSE}. +#' @param obs_per_cell For \code{criterion = "size"}: the mean number of +#' rows per cell wanted, a single number of at least 1 (fractions are +#' allowed). \code{NULL} (default) is the profile's own size when it was +#' built at exactly one (\code{\link{resolution_profile}(obs_per_cell = +#' )}), and 4.5 otherwise. Given with a criterion that is not +#' \code{"size"} it is an error. #' @return A list of class \code{resolution_selection} with \code{best} (the #' level), \code{flat} (the levels in the flat region, ascending; a set, #' which can skip a rung), \code{criterion}, \code{value} (the optimum), #' \code{at_ceiling} and \code{at_floor} (logical: the optimum is the last -#' or first of the levels this criterion was scored at, which for -#' \code{moran_z} starts above nine cells), \code{edge} (which bound that +#' or first of the levels this criterion was read at, which for +#' \code{moran_z} starts above nine cells and for \code{reliability} at +#' the range floor; both \code{NA} under \code{"size"}, which searches for +#' no optimum), \code{edge} (which bound that #' is, in words: the support ceiling, the subsample's ceiling, the range -#' floor, the ladder's own end, +#' floor, the ladder's own end, the finest or the coarsest size offered +#' on a ladder \code{obs_per_cell} set, the only level scored, #' or the first or last level the criterion is computable at; \code{NA} for -#' an interior optimum), \code{n_levels}, \code{values} (the criterion -#' at every level, \code{NA} where it could not be computed) and +#' an interior optimum and under \code{"size"}), \code{n_levels}, +#' \code{values} (the criterion +#' at every level, \code{NA} where it could not be computed), +#' \code{structured} (for \code{cp}: \code{FALSE} when \code{cp} at one +#' cell is within \code{tol} of the optimum, when the cell means at the +#' optimum differ from one mean by no more than chance allows, or when +#' the variogram found no spatial structure; \code{TRUE} when the optimum +#' beats one cell on both counts; see "What each criterion returns". +#' For \code{loo} and \code{size} on a profile built with +#' \code{estimate}: \code{FALSE} when the leave-one-out error of one mean +#' for all scored rows is within \code{tol} of the error at \code{best}, +#' or below it, or when the cell means at \code{best} differ from one +#' mean by no more than chance allows; \code{TRUE} when the cells beat +#' one mean on both counts. +#' \code{TRUE} for an \code{elbow}; \code{NA} for \code{reliability} +#' and \code{moran_z}, and for a profile that carries no one-cell value), +#' \code{one_cell} (\code{cp} at one cell under \code{cp}; the +#' leave-one-out error of one mean for all scored rows under \code{loo} +#' and \code{size}; \code{NA} otherwise), +#' \code{structure_p} (the p-value of the F test of the cells at +#' \code{best} against one mean, multiplied by the number of levels +#' searched and capped at 1; a size searches one level; \code{NA} where +#' \code{structured} is not read off \code{cp} or the leave-one-out +#' error), +#' \code{range_floor} (the floor \code{reliability} was held to, or +#' \code{NA}), \code{note} (what the flags mean, in words: a character +#' vector, one note an element; \code{NULL} when there is nothing to +#' say. The notes written under \code{"loo"} and \code{"size"}, and for +#' a profile built with \code{estimate} or with one size, carry names: +#' \code{size} (the size that set the count), \code{held} (a size the +#' profile held to the most cells k-means can place), \code{structure} +#' (why the count is not identified), \code{finest} (the lowest error of +#' pooled values is at the finest level scored), \code{estimate} +#' (\code{cp} scores plain means, on a profile of pooled values) and +#' \code{ladder} (the ladder is one size). A note of \code{cp} or +#' \code{moran_z} about the criterion itself has no name. The warning +#' of class \code{spatialkit_no_structure} that the functions taking the +#' selection as a count raise carries every note but those named +#' \code{size}, \code{held}, \code{finest}, \code{estimate} and +#' \code{ladder}) and #' \code{seeds} (an sf POINT layer, with \code{seed_id}, of the centres of #' the partition the profile scored at \code{best}, in the CRS it was #' computed in; \code{NULL} for a profile that does not carry them). Their #' Voronoi cells are the cells that were scored; #' \code{\link{get_voronoi_seeds}(method = "kmeans", n = )} and -#' \code{\link{voronoi_seeds_kmeans}(k = )} return them. +#' \code{\link{voronoi_seeds_kmeans}(k = )} return them. For a +#' profile built with \code{partition = "density"} or \code{init = +#' "random"} the list also has \code{partition} (\code{kind}, +#' \code{init}, \code{density_power}, \code{density_k}), and the seeds +#' carry it as \code{attr(, "partition")}; the regions are those the +#' profile built, whatever kind built them. +#' +#' For \code{"loo"} and \code{"size"}, and for any criterion on a profile +#' built with \code{estimate}, the list has these elements after +#' \code{seeds} (\code{partition}, when there is one, stays last): +#' \code{estimate} (the profile's, \code{"mean"} or \code{"pooled"}; +#' \code{NA} for a profile without one); +#' \code{obs_per_cell} (rows per cell at \code{best}: the rows a size +#' divides over \code{best}; \code{NA} for an object that keeps no row +#' count); +#' \code{obs_per_cell_asked} (the size asked for; \code{NA} unless the +#' criterion is \code{"size"}); +#' \code{scored_per_cell} (the profile's column at \code{best}: the rows +#' the leave-one-out error read over the cells that hold one. It is not +#' \code{obs_per_cell}: it leaves out rows the error did not read and +#' cells that hold none of them, as under \code{select_on = "split"}); +#' \code{loo} and \code{loo_one_cell} (the leave-one-out error at +#' \code{best} and that of one mean for all scored rows); +#' \code{share_alone} and \code{own_weight} (the profile's columns at +#' \code{best}); and \code{count_rule}, a list of class +#' \code{spatialkit_count_rule} that records how the count was set: +#' \code{rule} (the criterion applied), \code{estimate} (the estimate the +#' rule was computed for: the profile's for \code{"size"} and +#' \code{"loo"}, \code{"mean"} for \code{"cp"}, \code{NA} otherwise), +#' \code{cells}, \code{obs_per_cell}, \code{obs_per_cell_asked}, +#' \code{response}, \code{n} (the rows the size divides), \code{n_points}, +#' \code{n_fit} (the rows the centres were fitted to; fewer than +#' \code{n_points} for a subsample), \code{seed}, \code{features}, +#' \code{scored} (what the profile scored at \code{best} for its +#' estimate: \code{estimate}, \code{n}, \code{cells}, \code{loo}, +#' \code{loo_se}, \code{loo_one_cell}, \code{share_alone}, +#' \code{own_weight}, \code{structured}, \code{rows} and \code{centres}, +#' the matrix of the centres the rows were scored in, in \code{crs} and +#' in the profile's order; \code{NULL} without an estimate), +#' \code{partition}, \code{crs} and +#' \code{scored_cells} (\code{NA}: the record stands for a count). +#' \code{seeds} carries the same record as \code{attr(, "count_rule")} +#' with \code{scored_cells = TRUE}, since they are the centres that were +#' scored. The record travels on with the seeds, the cells and the +#' assigned layer to \code{\link{summarize_by_cell}()}, which warns when +#' it reports another cell value than the count was chosen for (class +#' \code{spatialkit_estimate_mismatch}) and when the cells or rows it is +#' given are not the ones the count was scored on +#' (\code{spatialkit_cells_differ}). Under \code{"loo"} and \code{"size"} \code{one_cell} holds +#' the leave-one-out error of one mean and \code{range_floor} is +#' \code{NA}. \code{criterion} is the criterion applied, never +#' \code{"auto"}. #' @family aggregation #' @examples #' if (requireNamespace("gstat", quietly = TRUE)) { #' library(sf) #' # An exponential field with range parameter 200 (true effective range -#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough -#' # noise for Mallows' Cp to have an interior optimum rather than descend -#' # to the ceiling. +#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. #' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) @@ -1221,24 +3440,61 @@ print.resolution_profile <- function(x, digits = 3L, ...) { #' sel <- select_resolution(prof, criterion = "cp") #' print(sel) # the level, and the flat region around it #' print(sel$flat) # every level within `tol` of the optimum -#' print(sel$edge) # NA here: the optimum is interior +#' print(sel$edge) # the bound the optimum sits on; NA when interior +#' print(sel$structured) # FALSE when one cell for the layer does as well #' -#' # Reliability prefers coarse cells and here runs into the floor the -#' # autocorrelation range sets, which the result says in words. +#' # Reliability prefers coarse cells: it is read at or above the floor the +#' # autocorrelation range sets, and the result says in words that the +#' # floor is choosing. #' rel <- select_resolution(prof, criterion = "reliability") #' print(rel) -#' c(at_floor = rel$at_floor, edge = rel$edge) +#' print(c(at_floor = rel$at_floor, edge = rel$edge)) +#' +#' # The default profile is one size scored for pooled values, and the +#' # default criterion, "auto", reads it by that size. +#' select_resolution(resolution_profile(pts, response_var = "z")) #' } #' @export select_resolution <- function(profile, - criterion = c("cp", "reliability", "elbow", "moran_z"), - tol = 0.02) { + criterion = c("auto", "cp", "reliability", "elbow", + "moran_z", "loo", "size"), + tol = 0.02, range_floor = TRUE, diagnostic = FALSE, + obs_per_cell = NULL) { if (!inherits(profile, "resolution_profile")) stop("select_resolution(): `profile` must come from resolution_profile().", call. = FALSE) criterion <- match.arg(criterion) if (!is.numeric(tol) || length(tol) != 1L || !is.finite(tol) || tol < 0) stop("select_resolution(): `tol` must be a single non-negative number.", call. = FALSE) + if (!is.logical(range_floor) || length(range_floor) != 1L || is.na(range_floor)) + stop("select_resolution(): `range_floor` must be TRUE or FALSE.", call. = FALSE) + if (!is.logical(diagnostic) || length(diagnostic) != 1L || is.na(diagnostic)) + stop("select_resolution(): `diagnostic` must be TRUE or FALSE.", call. = FALSE) + if (!is.null(obs_per_cell) && + !(is.numeric(obs_per_cell) && !is.object(obs_per_cell) && length(obs_per_cell) == 1L && + is.finite(obs_per_cell) && obs_per_cell >= 1)) + stop(sprintf(paste0("select_resolution(): `obs_per_cell` must be NULL or a single ", + "number of at least 1; got %s."), .got_text(obs_per_cell)), + call. = FALSE) + # The estimate the profile scores, when it names one. "auto" is the rule + # that goes with it: a size for pooled values, the leave-one-out minimum + # for plain means, and Cp for a profile that names none (one built without + # `estimate`, and a column subset, which has lost its attributes). + est <- attr(profile, "estimate", exact = TRUE) + est_value <- .profile_estimate(profile) + asked <- criterion + if (criterion == "auto") + criterion <- if (identical(est_value, "pooled")) "size" + else if (identical(est_value, "mean")) "loo" + else "cp" + if (!is.null(obs_per_cell) && criterion != "size") + stop(sprintf(paste0("select_resolution(): `obs_per_cell` is read by criterion = \"size\" ", + "only, and criterion = \"%s\" was asked for%s."), + asked, + if (asked == "auto") + sprintf(", which reads this profile by \"%s\"", criterion) + else ""), + call. = FALSE) # `[` keeps the class, so a subset arrives here looking like a profile. An # empty one or a column subset missing the criterion used to fall through to # the "NA at every level" error below, which sends the user off to add a @@ -1246,6 +3502,12 @@ select_resolution <- function(profile, if (nrow(profile) == 0L) stop("select_resolution(): `profile` has no levels; it is an empty subset ", "of a resolution profile.", call. = FALSE) + if (criterion == "size") + return(.select_size(profile, obs_per_cell, tol, est_value)) + if (criterion == "loo" && !"loo" %in% names(profile)) + stop(paste0("select_resolution(): `profile` has no `loo` column; build it with ", + "resolution_profile(estimate = \"mean\") or estimate = \"pooled\"."), + call. = FALSE) if (!criterion %in% names(profile) || !"levels" %in% names(profile)) stop(sprintf(paste0("select_resolution(): `profile` has no `%s` column%s; ", "it is a column subset of a resolution profile. Pass ", @@ -1257,6 +3519,43 @@ select_resolution <- function(profile, v <- as.numeric(profile[[criterion]]) if (criterion == "moran_z") v <- abs(v) ok <- is.finite(v) + one <- attr(profile, "one_cell", exact = TRUE) + # The sizes of a ladder `obs_per_cell` set, when the profile is on one. + ladder_sizes <- if (is.list(attr(profile, "bounds", exact = TRUE))) + attr(profile, "bounds", exact = TRUE)$obs_per_cell else NULL + # A constant response is its own case: Cp is NA because no level fits a + # constant better than another, and the message used to ask for "a level + # whose cells hold two scored rows", which every level of that profile had. + if (!any(ok) && criterion %in% c("cp", "moran_z") && is.list(one) && isTRUE(one$constant)) + stop(sprintf(paste0("select_resolution(): `%s` is NA at every level because the %s is ", + "constant: its total sum of squares is rounding error at most, ", + "so no cell count fits it better than another."), + criterion, + if (identical(attr(profile, "variable"), "residuals")) + "OLS residual of the response on the predictors" else "response"), + call. = FALSE) + # The same for the leave-one-out error, whose reference is the estimate's: + # the rows it read do not vary. + if (!any(ok) && criterion == "loo" && is.list(est) && isTRUE(est$constant)) + stop(sprintf(paste0("select_resolution(): `%s` is NA at every level because the %s is ", + "constant: its total sum of squares is rounding error at most, ", + "so no cell count fits it better than another."), + criterion, "response"), + call. = FALSE) + # A ladder of sizes that was given no `sac` fitted no variogram, so Cp has + # no noise variance and the reliability no range. Said here, with the + # ways to get the column, and not as a profile that lacks a response. + if (!any(ok) && criterion %in% c("cp", "reliability") && + identical(attr(profile, "cp_noise", exact = TRUE)$source, "none")) + stop(sprintf(paste0("select_resolution(): `%s` is NA at every level: this profile is on ", + "a size ladder (obs_per_cell = %s), which fits no variogram unless ", + "`sac` is given, and `%s` takes its %s from one. Build the profile ", + "with `sac = NULL` to have the variogram estimated, with a `sac` of ", + "your own, or with obs_per_cell = NULL for the automatic ladder; ", + "criterion = \"size\" reads this profile."), + criterion, .got_text(ladder_sizes), criterion, + if (criterion == "cp") "noise variance" else "range"), + call. = FALSE) if (!any(ok)) stop(sprintf(paste0("select_resolution(): `%s` is NA at every level%s."), criterion, @@ -1270,12 +3569,52 @@ select_resolution <- function(profile, "falls in a straight line, as it does for points ", "with no cluster structure, so the geometry names ", "no cell count)"), + loo = paste0(" (it needs a level at which some cell holds two ", + "rows with a response)"), "")), call. = FALSE) maximise <- criterion %in% c("reliability", "elbow") lv <- profile$levels + bounds <- attr(profile, "bounds") + with_pred <- identical(attr(profile, "variable"), "residuals") + # moran_z is Moran's z of the cell means. Its smallest |z| is where that + # test has least power, about 10 to 20 cells, whatever the layer, and it + # used to be handed over as a cell count like any other criterion's. + what_z <- if (with_pred) + "the residuals of the cell means regressed on the cell-mean predictors" + else "the cell means" + if (criterion == "moran_z" && !diagnostic) + stop(errorCondition( + sprintf(paste0("select_resolution(): `moran_z` is a diagnostic, not a count rule, ", + "and is read only when asked for with `diagnostic = TRUE`. It is ", + "Moran's z of %s over each cell's 8 nearest cells: a test of whether ", + "neighbouring cells are independent. It is near 0 at about 10 to 20 ", + "cells whatever the data, where that neighbour graph is close to ", + "complete, and grows as the cells get finer than the range, so its ", + "smallest |z| (here at %d cells; it is computable from %d and the ", + "ladder runs to %d) does not say how well the cells represent the ", + "response. `cp` does."), + what_z, as.integer(lv[ok][which.min(v[ok])]), as.integer(min(lv[ok])), + as.integer(max(lv))), + class = "spatialkit_diagnostic_criterion", call = NULL)) + # Reliability tends to peak at a few cells, below the range floor, so on a + # ladder from 2 its maximum is a count whose cells are wider than the + # range. It is read at or above the floor the profile reports, which is + # where the ladder itself used to start. A ladder the caller set with + # `levels` is read as given, as it always was. + held_floor <- NA_integer_ + if (criterion == "reliability" && range_floor && is.list(bounds) && + isTRUE(bounds$supported) && isFALSE(bounds$levels_given) && + is.finite(bounds$range %||% NA_real_) && is.finite(bounds$floor %||% NA_integer_) && + any(ok & lv >= bounds$floor)) { + ok <- ok & lv >= bounds$floor + held_floor <- as.integer(bounds$floor) + } opt <- if (maximise) max(v[ok]) else min(v[ok]) best <- lv[ok][if (maximise) which.max(v[ok]) else which.min(v[ok])] - flat <- if (criterion %in% c("cp", "reliability")) { + # Of levels with the same leave-one-out error, the one with the fewest + # cells, whatever order the rows of the profile are in. + if (criterion == "loo") best <- min(lv[ok][v[ok] == opt]) + flat <- if (criterion %in% c("cp", "reliability", "loo")) { if (maximise) lv[ok][v[ok] >= opt * (1 - tol)] else lv[ok][v[ok] <= opt * (1 + tol)] } else { band <- tol * diff(range(v[ok])) @@ -1294,18 +3633,411 @@ select_resolution <- function(profile, # the caller had set with `levels =`. scored <- lv[ok] at_ceiling <- best == max(scored); at_floor <- best == min(scored) - edge <- .ladder_edge(best, scored, lv, attr(profile, "bounds")) - structure(list(best = as.integer(best), flat = sort(as.integer(flat)), + edge <- .ladder_edge(best, scored, lv, bounds, held_floor = held_floor) + # Whether the criterion found anything to choose on. For Cp: does any + # level beat one cell for the whole layer by more than `tol`? When one + # cell is inside the flat region, one mean predicts as well as the cells + # and the argmin is a draw from the noise. Compared only while the `cp` + # column is the one the one-cell value was computed with (a profile whose + # column was edited has no such reference). + structured <- NA + one_cp <- NA_real_ + structure_p <- NA_real_ + note <- NULL + if (criterion == "cp") { + ref <- if (is.list(one)) one$cp_levels else NULL + same <- is.list(one) && is.finite(one$cp %||% NA_real_) && !is.null(ref) && + all(as.character(lv) %in% names(ref)) && + isTRUE(all.equal(unname(ref[as.character(lv)]), as.numeric(profile[["cp"]]))) + if (same) { + one_cp <- one$cp + # Two things have to hold for the count to be called identified. Cp at + # the optimum is below Cp at one cell by more than `tol`; and the cell + # means there differ from one mean by more than chance, by the F test + # the profile kept at every level, at 5 percent after a Bonferroni + # adjustment for the levels the optimum was searched over. The first + # alone has no sampling error in it: on white noise it called the count + # identified on 14 percent of layers of 60 points, 10 of 120 and 5 of + # 300 (both together: 2, 4 and 3), and on every layer whose Cp had a + # noise variance of 0, where Cp is RSS / n and a finer level beats one + # cell by more than `tol` by chance alone. + beats <- !(one_cp <= opt * (1 + tol)) + n_searched <- sum(ok) + p_raw <- if (is.null(one$f_p)) NA_real_ else unname(one$f_p[as.character(best)])[1L] + if (is.finite(p_raw)) structure_p <- min(1, p_raw * n_searched) + by_chance <- is.finite(structure_p) && structure_p >= 0.05 + structured <- if (!beats || by_chance) FALSE + else if (is.finite(structure_p)) TRUE + else NA + p_text <- if (is.finite(structure_p)) + sprintf("p = %s after adjusting for the %d level%s searched", + format(signif(structure_p, 2)), n_searched, if (n_searched == 1L) "" else "s") + else "" + # Cp's noise variance, when it is no penalty at all. + cn <- attr(profile, "cp_noise", exact = TRUE) + vgm <- attr(profile, "variogram", exact = TRUE) + no_penalty <- is.list(cn) && is.finite(cn$value %||% NA_real_) && + (cn$value <= 0 || + (is.list(vgm) && is.finite(vgm$psill %||% NA_real_) && + cn$value <= 1e-4 * (cn$value + vgm$psill))) + if (!beats) + note <- sprintf(paste0("Cp at one cell (%s) is within %s%% of the optimum (%s): one ", + "mean for the whole layer predicts as well as any level ", + "scored, so the response shows no spatial structure the ", + "cells can use and the count is not identified."), + format(signif(one_cp, 3)), format(100 * tol), format(signif(opt, 3))) + else if (by_chance) + note <- sprintf(paste0("the cell means at %d cells differ from one mean for the ", + "whole layer by no more than chance allows (F test of the ", + "cells against one mean, %s), so the response shows no ", + "spatial structure the cells can use and the count is not ", + "identified. %s"), + as.integer(best), p_text, + if (no_penalty) + paste0("Cp's noise variance is 0: Cp has no penalty and falls ", + "with every finer level whatever the response.") + else sprintf(paste0("Cp at one cell is %s against %s at the optimum, ", + "a gap that chance produces on a layer of this size."), + format(signif(one_cp, 3)), format(signif(opt, 3)))) + else if (isTRUE(structured) && no_penalty) + note <- sprintf(paste0("Cp's noise variance is 0, so Cp is RSS / n and falls with ", + "every finer level by chance alone: its comparison with one ", + "cell says nothing, and `structured` rests on the F test of ", + "the cells against one mean alone (%s)."), p_text) + else if (is.na(structured)) + note <- paste0("Cp at one cell is above the optimum by more than `tol`, but the ", + "profile carries no F test of the cells against one mean at this ", + "level, so whether that is more than chance is not known.") + } + sac_prof <- attr(profile, "sac", exact = TRUE) + why_sac <- attr(sac_prof, "rejected_reason") + if (.sac_no_structure(sac_prof)) { + structured <- FALSE + note <- c(note, sprintf(paste0("the profile's variogram found no spatial structure in ", + "the response (%s), so the count is not identified."), + as.character(why_sac)[1L])) + } + } else if (criterion == "elbow") { + structured <- TRUE + } else if (criterion == "moran_z") { + note <- sprintf(paste0("moran_z is a diagnostic, not a count rule: this is the level ", + "at which %s are least autocorrelated across neighbouring ", + "cells, not the level that represents the response best."), + what_z) + } else if (criterion == "loo") { + # The same two questions as for Cp, asked of the leave-one-out error of + # the profile's estimate: is it below that of one mean for every scored + # row by more than `tol`, and do the cell means at the optimum differ + # from one mean by more than chance, after the adjustment for the levels + # searched. Read only while the `loo` column is the one the references + # were recorded with. + n_searched <- sum(ok) + st <- .estimate_structure(profile, best, tol, n_searched = n_searched) + structured <- st$structured + one_cp <- st$one_cell + structure_p <- st$structure_p + p_text <- if (is.finite(structure_p)) + sprintf("p = %s after adjusting for the %d level%s searched", + format(signif(structure_p, 2)), n_searched, if (n_searched == 1L) "" else "s") + else "" + if (isFALSE(st$beats)) + note <- c(structure = sprintf( + paste0("the leave-one-out error at one cell (%s) is within %s%% of the optimum ", + "(%s): one mean for the whole layer predicts as well as any level scored, ", + "so the response shows no spatial structure the cells can use and the ", + "count is not identified."), + format(signif(one_cp, 3)), format(100 * tol), format(signif(opt, 3)))) + else if (isFALSE(structured)) + note <- c(structure = sprintf( + paste0("the cell means at %d cells differ from one mean for the whole layer by ", + "no more than chance allows (F test of the cells against one mean, %s), so ", + "the response shows no spatial structure the cells can use and the count ", + "is not identified. The leave-one-out error at one cell is %s against %s ", + "at the optimum, a gap that chance produces on a layer of this size."), + as.integer(best), p_text, format(signif(one_cp, 3)), format(signif(opt, 3)))) + else if (isTRUE(st$beats) && is.na(structured)) + note <- c(structure = paste0( + "the leave-one-out error at one cell is above the optimum by more than `tol`, ", + "but the profile carries no F test of the cells against one mean at this level, ", + "so whether that is more than chance is not known.")) + # For pooled values the error can keep falling to the end of the ladder. + # When it did, the ladder's end set the count. + if (identical(est_value, "pooled") && best == max(lv[ok])) + note <- c(note, finest = paste0( + "the lowest leave-one-out error of the pooled value is at the finest level ", + "scored, so the end of the ladder chose the count. criterion = \"size\" sets ", + "it by a size.")) + } + # Cp scores plain means whatever the profile's estimate is. + if (criterion == "cp" && identical(est_value, "pooled")) + note <- c(note, estimate = paste0( + "cp scores plain means, and this profile's estimate is the pooled value; ", + "criterion = \"size\" is the rule for it.")) + # A ladder of one size is one level, so the criterion had nothing to choose + # among. + if (criterion %in% c("cp", "reliability") && length(ladder_sizes) == 1L) + note <- c(note, ladder = sprintf( + paste0("the ladder is one size (obs_per_cell = %s), so %s had one level to choose ", + "from. Build the profile with obs_per_cell = NULL, or with several sizes, ", + "for a ladder %s can choose on."), + .got_text(ladder_sizes), criterion, criterion)) + sel <- structure(list(best = as.integer(best), flat = sort(as.integer(flat)), criterion = criterion, value = opt, at_ceiling = at_ceiling, at_floor = at_floor, edge = edge, n_levels = length(lv), values = stats::setNames(v, lv), + structured = structured, one_cell = one_cp, + structure_p = structure_p, + range_floor = held_floor, note = note, # The centres of the partition this level was scored on, for # get_voronoi_seeds() and voronoi_seeds_kmeans() to seed the # same cells from. NULL for a profile made before they were # kept. seeds = .profile_seeds(profile, best)), class = "resolution_selection") + .selection_close(sel, profile, est_value, tol) +} + + +#' The estimate a profile names, by value +#' +#' @param profile A \code{resolution_profile}, or a subset of one. +#' @return \code{"mean"} or \code{"pooled"}; \code{NA} for a profile built +#' without an estimate, for a column subset, which has lost the attribute, +#' and for an attribute that names neither. +#' @keywords internal +#' @noRd +.profile_estimate <- function(profile) { + est <- attr(profile, "estimate", exact = TRUE) + if (is.list(est) && is.character(est$value) && length(est$value) == 1L && + est$value %in% c("mean", "pooled")) + as.character(unclass(est$value)) else NA_character_ +} + + +#' Whether `loo` is read where no criterion is named +#' +#' \code{summary()} and \code{plot()} of a profile take \code{loo} into +#' their default set where it is the leave-one-out error +#' \code{resolution_profile()} wrote: the profile names an estimate, or the +#' object is a column subset that kept \code{loo} and none of \code{cp}, +#' \code{reliability} and \code{elbow}. A column called \code{loo} that a +#' caller added to a profile built without an estimate is read only when +#' \code{criteria} names it, so the table and the plot of such a profile are +#' the ones they were before the column had a meaning here. +#' +#' @param profile A \code{resolution_profile}, or a subset of one. +#' @return \code{TRUE} or \code{FALSE}. +#' @keywords internal +#' @noRd +.loo_by_default <- function(profile) + "loo" %in% names(profile) && + (is.list(attr(profile, "estimate", exact = TRUE)) || + !any(c("cp", "reliability", "elbow") %in% names(profile))) + + +# The names select_resolution() gives the notes it writes about something +# other than whether the count is identified: the size that set the count, a +# size the profile held, an optimum at the finest level of a pooled profile, +# the estimate `cp` scores, and a ladder of one size. The note that says why +# a count is not identified is named `structure` under "size" and "loo" and +# has no name under the criteria that wrote one before. The warning raised +# when the count becomes cells pastes every note but these five. +.NOTES_NOT_STRUCTURE <- c("size", "held", "finest", "estimate", "ladder") + + +#' What a selection carries beyond the criterion's own answer +#' +#' On the path that names an estimate (the profile carries one, or the +#' criterion is \code{"loo"} or \code{"size"}) the selection gains what the +#' profile scored at the chosen level and the record of how the count was +#' set, and its seeds carry that record. The kind that built the profile's +#' cells, when the profile records one, is the last element either way. A +#' selection from a profile without an estimate by \code{"cp"}, +#' \code{"reliability"}, \code{"elbow"} or \code{"moran_z"} gains nothing +#' but that kind, as before. +#' +#' @param sel The selection, with the elements every criterion returns. +#' @param profile The \code{resolution_profile} it was read off. +#' @param est_value The profile's estimate, \code{"mean"} or +#' \code{"pooled"}; \code{NA} for a profile that names none. +#' @param tol The tolerance of the call. +#' @param asked The size asked for; \code{NA} unless the criterion is +#' \code{"size"}. +#' @return The selection. +#' @keywords internal +#' @noRd +.selection_close <- function(sel, profile, est_value, tol, asked = NA_real_) { + if (!is.na(est_value) || sel$criterion %in% c("loo", "size")) { + best <- sel$best + n <- .count_rule_rows(attr(profile, "bounds", exact = TRUE)) + est <- attr(profile, "estimate", exact = TRUE) + sel$estimate <- est_value + # Rows per cell at the count chosen: the rows a size divides over the + # centres asked for. `scored_per_cell` is another number: the rows the + # leave-one-out error read, over the cells that hold one. + sel$obs_per_cell <- if (is.na(n)) NA_real_ else n / best + sel$obs_per_cell_asked <- as.numeric(asked) + sel$scored_per_cell <- .profile_at(profile, best, "scored_per_cell") + sel$loo <- .profile_at(profile, best, "loo") + sel$loo_one_cell <- if (!is.na(est_value) && "loo" %in% names(profile)) + as.numeric(est$loo_one_cell %||% NA_real_)[1L] else NA_real_ + sel$share_alone <- .profile_at(profile, best, "share_alone") + sel$own_weight <- .profile_at(profile, best, "own_weight") + # Whether the cells at this count beat one mean for the profile's + # estimate. "size" and "loo" asked that themselves; under another + # criterion it is asked here of the one level chosen. + scored_structured <- if (sel$criterion %in% c("loo", "size")) sel$structured + else .estimate_structure(profile, best, tol, n_searched = 1L)$structured + rec <- .count_rule_new(profile, rule = sel$criterion, cells = best, + obs_per_cell_asked = asked, structured = scored_structured, + scored_cells = NA) + sel$count_rule <- rec + # The seeds are the centres the profile scored at this count. + if (inherits(sel$seeds, "sf")) { + rec$scored_cells <- TRUE + attr(sel$seeds, "count_rule") <- rec + } + } + # The kind that built the profile's cells, when it is not the present one + # (see resolution_profile()): the selection names it, and its seeds carry + # it on. + part <- attr(profile, "partition", exact = TRUE) + if (is.list(part) && !is.null(part$kind)) + sel$partition <- part[.partition_fields()] + sel +} + + +#' The count a size gives, read off a profile +#' +#' \code{select_resolution(criterion = "size")}. The count is +#' \code{.count_at(n, obs_per_cell)}, with \code{n} the rows the size +#' divides, and the level returned is the first of three that applies: the +#' level the profile built for that size; the count itself, when the profile +#' has a partition at it; the built level nearest to the count on the log +#' scale, with a warning. No optimum is searched for, so no bound can +#' choose the count and the edge flags are \code{NA}. +#' +#' A size does not ask whether the response has structure the cells can +#' use, so that is asked separately, of the profile's estimate at the level +#' returned: \code{.estimate_structure()} with one level searched. +#' +#' @param profile A \code{resolution_profile}. +#' @param obs_per_cell The size asked for, or \code{NULL} for the profile's +#' own size when it was built at exactly one, and +#' \code{.OBS_PER_CELL_DEFAULT} otherwise. +#' @param tol The margin of the structure test. +#' @param est_value The profile's estimate, or \code{NA}. +#' @return A \code{resolution_selection}. +#' @keywords internal +#' @noRd +.select_size <- function(profile, obs_per_cell, tol, est_value) { + bounds <- attr(profile, "bounds", exact = TRUE) + n <- .count_rule_rows(bounds) + if (is.na(n)) + stop(paste0("select_resolution(): criterion = \"size\" needs the number of rows the ", + "size divides, which a profile keeps in attr(, \"bounds\"); this object ", + "has none (it is a column subset of a resolution profile). Pass the ", + "profile resolution_profile() returned."), call. = FALSE) + if (!"levels" %in% names(profile)) + stop(paste0("select_resolution(): `profile` has no `levels` column; it is a column ", + "subset of a resolution profile. Pass the profile resolution_profile() ", + "returned."), call. = FALSE) + sizes <- bounds$obs_per_cell + size <- if (!is.null(obs_per_cell)) as.numeric(obs_per_cell) + else if (length(sizes) == 1L) as.numeric(sizes) + else .OBS_PER_CELL_DEFAULT + k_star <- .count_at(n, size) + lv <- profile$levels + # The levels at which a partition was built. + built <- if ("wss" %in% names(profile)) is.finite(suppressWarnings(as.numeric(profile$wss))) + else rep(TRUE, length(lv)) + if (!any(built)) + stop(paste0("select_resolution(): no level of `profile` has a partition (`wss` is NA ", + "at every level), so no level can stand for a size."), call. = FALSE) + # (i) The level the profile built for this size. It is the count the size + # gives unless the profile held the size to the most cells k-means can + # place; the profile said so when it was built, so nothing is raised here. + at <- match(size, as.numeric(sizes)) + own <- if (!is.na(at) && length(bounds$size_levels) == length(sizes)) + as.integer(bounds$size_levels[[at]]) else NA_integer_ + held <- FALSE + if (!is.na(own) && own %in% lv[built]) { + best <- own + held <- best != k_star + } else if (k_star %in% lv[built]) { + # (ii) The count itself is a level. + best <- k_star + } else { + # (iii) The built level nearest to the count on the log scale; of two as + # near, the one with fewer cells. Ratios, not differences of logarithms: + # 2 and 8 are as near to 4 as each other, and their logarithms differ + # from log(4) by amounts that need not round alike. + cand <- sort(unique(lv[built])) + best <- cand[which.min(pmax(cand, k_star) / pmin(cand, k_star))] + # The most cells k-means can place on the layer: its distinct locations + # where some repeat, one short of the points where none does. A profile + # fitted to every point counted the locations; one fitted to a subsample + # counted the subsample's, and one short of the points is then still a + # bound. A count above it is one no profile scores, and the advice to + # build one at that size is left out. + one <- function(v) is.numeric(v) && length(v) == 1L && is.finite(v) + repeats <- one(bounds$n) && one(bounds$n_distinct) && one(bounds$n_sample) && + bounds$n_sample >= bounds$n && bounds$n_distinct < bounds$n + cap <- if (!one(bounds$n)) NA_integer_ + else if (repeats) as.integer(bounds$n_distinct) + else as.integer(bounds$n) - 1L + .warn_classed("spatialkit_size_not_reached", + paste0("select_resolution(): obs_per_cell = %s asks for %d cells, which ", + "is not a level of this profile; the nearest level, %d cells (%s), ", + "is used. %s"), + format(size), k_star, as.integer(best), .per_cell_text(n / best), + if (!is.na(cap) && k_star > cap) + sprintf(paste0("That count is more than k-means can place on %s (%d ", + "cells), so no profile scores it."), + if (repeats) + sprintf("the layer's %d distinct locations", + as.integer(bounds$n_distinct)) + else sprintf("%d points", as.integer(bounds$n)), cap) + else sprintf("Build the profile with obs_per_cell = %s to score that count.", + format(size)), + data = list(obs_per_cell = size, wanted = k_star, used = as.integer(best), + reason = "not a level")) + } + best <- as.integer(best) + note <- c(size = sprintf(paste0("the count is set by obs_per_cell = %s, the caller's ", + "choice; no criterion chose it."), format(size))) + if (held) + note <- c(note, held = sprintf( + paste0("the profile holds this size to %d cells, the most k-means can place on ", + "this layer; obs_per_cell = %s asks for %d."), best, format(size), k_star)) + # Whether cells of this size beat one mean for the whole layer. The count + # stands either way: the caller set it. + st <- .estimate_structure(profile, best, tol, n_searched = 1L) + if (isFALSE(st$structured)) + note <- c(note, structure = paste0( + if (isFALSE(st$beats)) + sprintf(paste0("at %d cells the leave-one-out error of the %s (%s) is not below ", + "that of one mean for the whole layer (%s) by more than %s%%"), + best, if (identical(est_value, "pooled")) "pooled value" else "plain mean", + format(signif(st$loo, 3)), format(signif(st$one_cell, 3)), format(100 * tol)) + else + sprintf(paste0("the cell means at %d cells differ from one mean for the whole ", + "layer by no more than chance allows (F test, p = %s)"), + best, format(signif(st$structure_p, 2))), + ": the response shows no spatial structure that cells of this size can use.")) + sel <- structure(list(best = best, flat = best, + criterion = "size", value = n / best, + at_ceiling = NA, at_floor = NA, edge = NA_character_, + n_levels = length(lv), + values = stats::setNames(n / lv, lv), + structured = st$structured, one_cell = st$one_cell, + structure_p = st$structure_p, + range_floor = NA_integer_, note = note, + seeds = .profile_seeds(profile, best)), + class = "resolution_selection") + .selection_close(sel, profile, est_value, tol, asked = size) } @@ -1326,31 +4058,65 @@ select_resolution <- function(profile, coords = c("x", "y"), crs = if (inherits(crs, "crs")) crs else sf::NA_crs_) attr(s, "nstart") <- attr(profile, "nstart", exact = TRUE) + # The ground the centres stand for: the hull of the points profiled. A + # select_resolution() result holds these centres and not the profile, so + # without it a selection given to get_voronoi_seeds() with neither points + # nor a boundary had no cover to hand on. + attr(s, "cover") <- attr(profile, "hull", exact = TRUE) + # The kind that built the cells these centres seed, when the profile + # records one. + part <- attr(profile, "partition", exact = TRUE) + if (is.list(part) && !is.null(part$kind)) + attr(s, "partition") <- part[.partition_fields()] s } # Which bound an optimum at the end of the scored levels is sitting on. NA # when it is interior. The wording is shared by the print methods, the # profile plot's caption and the tessellation builders' provenance note. -.ladder_edge <- function(best, scored, ladder, bounds) { - if (best == max(scored) && best == min(scored)) return("the only level scored") +.ladder_edge <- function(best, scored, ladder, bounds, held_floor = NA_integer_) { + if (best == max(scored) && best == min(scored) && + (!is.finite(held_floor) || length(unique(ladder)) < 2L)) + return("the only level scored") + # The first level at or above the range floor, for a criterion read from + # the floor up (reliability): the floor is the bound there, whether or not + # the ladder has a rung exactly on it. + if (is.finite(held_floor) && best == min(scored)) + return(if (best == held_floor) "the range floor (area / range^2)" + else "the first level at or above the range floor (area / range^2)") + # A ladder `obs_per_cell` set ends where the sizes asked for end: no + # ceiling of support and no range floor bounds it. One case apart: a + # finest size the profile held to the most cells k-means can place. That + # level is the layer's bound and not the caller's, and it keeps the label + # of the support ceiling. + size_ladder <- is.list(bounds) && !is.null(bounds$obs_per_cell) + size_held <- size_ladder && identical(bounds$ceiling_from, "distinct locations") if (best == max(scored)) { if (max(scored) < max(ladder)) return("the last level the criterion is computable at") + if (size_ladder && !size_held) return("the finest size offered (obs_per_cell)") if (is.list(bounds) && identical(as.integer(max(ladder)), as.integer(bounds$ceiling))) return(if (identical(bounds$ceiling_from, "distinct locations") && isTRUE(bounds$ceiling < (bounds$n_distinct %||% NA_integer_))) "the support ceiling (one short of the points, the most k-means can fit)" else if (identical(bounds$ceiling_from, "distinct locations")) "the support ceiling (as many cells as the distinct locations allow)" + else if (identical(bounds$ceiling_from, "sample_n") && + isTRUE((bounds$n_scored %||% NA_integer_) < (bounds$n_sample %||% NA_integer_))) + "the subsample's ceiling (two scored subsample rows per cell; raise sample_n)" else if (identical(bounds$ceiling_from, "sample_n")) "the subsample's ceiling (two subsample points per cell; raise sample_n)" + else if (identical(bounds$ceiling_from, "min_cell_n (rows with a response)")) + (if (isTRUE(bounds$predictors)) + "the support ceiling (rows with a response and every predictor / min_cell_n)" + else "the support ceiling (rows with a response / min_cell_n)") else "the support ceiling (n / min_cell_n)") return("the last level of the ladder") } if (best == min(scored)) { if (min(scored) > min(ladder)) return("the first level the criterion is computable at") + if (size_ladder) return("the coarsest size offered (obs_per_cell)") if (is.list(bounds) && isTRUE(bounds$supported) && is.finite(bounds$range %||% NA) && !isFALSE(bounds$range_floor) && identical(as.integer(min(ladder)), as.integer(bounds$floor))) @@ -1361,28 +4127,101 @@ select_resolution <- function(profile, } +# What to do about an optimum on a bound, by the bound. Shared by the print +# method and by the warning the functions that take the count raise. +.edge_hint <- function(edge) { + if (is.null(edge) || is.na(edge)) return("") + if (grepl("min_cell_n", edge, fixed = TRUE)) + " Lower min_cell_n to see whether the criterion keeps going." + else if (grepl("raise sample_n", edge, fixed = TRUE)) + " Raise sample_n to see whether the criterion keeps going." + else if (grepl("range floor", edge, fixed = TRUE)) + " Fewer cells would be wider than the range and average over more than one patch of the field." + else if (grepl("only level", edge, fixed = TRUE)) + " One level leaves nothing to compare it with." + else if (grepl("(obs_per_cell)", edge, fixed = TRUE)) + " `obs_per_cell` sets the sizes offered; how small a cell may be is the caller's choice." + else "" +} + + #' @export print.resolution_selection <- function(x, ...) { cat(sprintf("Resolution by %s: %d cells\n", x$criterion, x$best)) - cat(sprintf(" flat region : %s (%d of %d levels)\n", - .band_label(x$flat, .scored_levels(x$values)), - length(x$flat), x$n_levels)) - edge <- x$edge %||% NA_character_ - if (!is.na(edge)) { - hint <- if (grepl("min_cell_n", edge, fixed = TRUE)) - " Lower min_cell_n to see whether the criterion keeps going." - else if (grepl("raise sample_n", edge, fixed = TRUE)) - " Raise sample_n to see whether the criterion keeps going." - else if (grepl("range floor", edge, fixed = TRUE)) - " Fewer cells would be wider than the range and average over more than one patch of the field." - else "" - # strwrap() collapses runs of spaces, so the aligned label is put back - # after wrapping rather than wrapped with the sentence. - body <- strwrap(sprintf("the optimum is %s; the bound is choosing, not the criterion.%s", - edge, hint), width = 62) - cat(paste0(c(" note : ", rep(" ", length(body) - 1L)), body), + by_size <- identical(x$criterion, "size") + rec <- if (inherits(x$count_rule, "spatialkit_count_rule")) x$count_rule else NULL + # A size has no flat region: its line gives the size asked for and the + # rows per cell the count leaves. + if (by_size) { + asked <- x$obs_per_cell_asked %||% NA_real_ + n_div <- if (is.null(rec)) NA_integer_ else rec$n + cat(sprintf(" size : %s asked (obs_per_cell); %s rows / %d cells = %.2f\n", + paste(format(asked), if (isTRUE(asked == 1)) "row per cell" else "rows per cell"), + format(n_div), x$best, x$value)) + } else { + cat(sprintf(" flat region : %s (%d of %d levels)\n", + .band_label(x$flat, .scored_levels(x$values)), + length(x$flat), x$n_levels)) + } + # The kind that built the cells, when the profile recorded one; a selection + # from a k-means profile prints as it always did. + if (is.list(x$partition) && !is.null(x$partition$kind)) + cat(sprintf(" cells : %s\n", .partition_label(x$partition))) + # strwrap() collapses runs of spaces, so the aligned label is put back + # after wrapping rather than wrapped with the sentence. + say <- function(text, label = "note", width = 62) { + body <- strwrap(text, width = width) + cat(paste0(c(sprintf(" %-12s: ", label), rep(" ", length(body) - 1L)), body), sep = "\n") } + # What the profile scored at this count for its estimate, under the two + # criteria that read it. + est <- x$estimate %||% NA_character_ + if (x$criterion %in% c("size", "loo") && length(est) == 1L && !is.na(est)) { + cat(sprintf(" estimate : %s\n", + if (identical(est, "pooled")) + sprintf("pooled toward the %d nearest cells", .POOL_NEIGHBOURS) + else "plain means")) + alone <- x$share_alone %||% NA_real_ + # The rows the leave-one-out error read and the cells that hold one. The + # line says so where they are not every row and every cell: under the + # split the error read one half of the rows, and a centre with no scored + # row near it (rows without a response) is a cell the share says nothing + # of. + scored <- if (!is.null(rec) && is.list(rec$scored)) rec$scored else NULL + half <- identical(scored$rows, "selection half") + occupied <- scored$cells %||% NA_integer_ + fewer <- length(occupied) == 1L && is.finite(occupied) && occupied < x$best + per <- x$scored_per_cell %||% NA_real_ + if (is.finite(alone)) { + w <- x$own_weight %||% NA_real_ + say(paste0(if (half) + sprintf("in the selection half (%s rows%s, %.2f per cell): ", + format(scored$n), + if (fewer) sprintf(" in %d of the %d cells", occupied, x$best) else "", + per) + else if (fewer) + sprintf("in the %d of the %d cells that hold a scored row (%.2f per cell): ", + occupied, x$best, per) + else "", + sprintf("%.1f%% of the rows are alone in their cell", 100 * alone), + if (is.finite(w)) sprintf("; median own weight %.2f", w) else ""), + label = "at this size", width = 76) + } + # Left out when the profile has neither number: a constant response. + loo <- x$loo %||% NA_real_ + one <- x$loo_one_cell %||% NA_real_ + if (isTRUE(is.finite(loo)) || isTRUE(is.finite(one))) + cat(sprintf(" loo : %s (one cell for %s: %s)\n", + format(signif(loo, 3)), if (half) "that half" else "the layer", + format(signif(one, 3)))) + } + edge <- x$edge %||% NA_character_ + if (!is.na(edge)) + say(sprintf("the optimum is %s; the bound is choosing, not the criterion.%s", + edge, .edge_hint(edge))) + # What `structured = FALSE` and a diagnostic criterion mean, in words. + for (nt in x$note) say(nt) invisible(x) } @@ -1390,10 +4229,19 @@ print.resolution_selection <- function(x, ...) { #' Every criterion's pick, side by side #' #' \code{\link{select_resolution}()} reads one criterion at a time. This puts -#' all of them in one table: the level each prefers, the flat region around -#' it, and whether a ladder bound is doing the choosing rather than the -#' criterion. The closing line gives the levels that lie in \emph{every} flat -#' region, the cell counts no criterion objects to. +#' the count criteria in one table: the level each prefers, the flat region +#' around it, and whether a ladder bound is doing the choosing rather than +#' the criterion. The closing line gives the levels that lie in \emph{every} +#' flat region, the cell counts no criterion objects to. +#' +#' The criteria are not peers, and the table should be read with what each +#' returns in practice in mind (see \code{\link{resolution_profile}()}): +#' \code{reliability} is read at or above the range floor and usually +#' returns it, \code{elbow} is absent unless the points cluster, and +#' \code{cp}'s optimum is often the support ceiling. \code{moran_z} is a +#' diagnostic of the cell means and not a count rule, so it is not in the +#' default set; named in \code{criteria} it gets a row, and it is left out +#' of the closing comparison. #' #' A flat region is a set, not an interval. The criterion curves are not #' monotone, so a region can skip a rung of the ladder, and the table prints @@ -1404,21 +4252,34 @@ print.resolution_selection <- function(x, ...) { #' That set is often empty, and an empty one is a result rather than a #' failure. The criteria answer different questions: how well the cells #' represent the field (\eqn{C_p}), whether the cell values are -#' distinguishable from noise (\code{reliability}), where the within-cluster -#' sum of squares bends (\code{elbow}), and whether the cell means still carry -#' autocorrelation (\code{moran_z}). A field with no single right resolution -#' shows up here as disjoint bands, and the spread between the picks is -#' printed for the same reason. +#' distinguishable from noise (\code{reliability}), and where the +#' within-cluster sum of squares bends (\code{elbow}). A field with no +#' single right resolution shows up here as disjoint bands, and the spread +#' between the picks is printed for the same reason. #' #' Nothing in the table is a decision procedure. Each flat region is #' routinely wide, the choice within it belongs to the analyst, and #' \code{\link{plot.resolution_profile}()} draws the curves the bands were #' read from. #' +#' A profile whose ladder is one size (\code{obs_per_cell} set to one +#' number, or the default profile) has one level, and the size set it. The +#' table then has one row per criterion that is finite at that level, and +#' the line under it says +#' that the count is set by the size and that no criterion chooses among +#' levels. The result carries the size as \code{attr(, "obs_per_cell")}. +#' #' @param object A \code{\link{resolution_profile}()}. #' @param criteria Character vector, any of \code{"cp"}, -#' \code{"reliability"}, \code{"elbow"}, \code{"moran_z"}. Default: every -#' one of the four that is finite at some level. +#' \code{"reliability"}, \code{"elbow"}, \code{"moran_z"}, \code{"loo"}. +#' Default: every one of \code{"cp"}, \code{"reliability"}, +#' \code{"elbow"} and \code{"loo"} that is finite at some level +#' (\code{loo} is a column of a profile built with \code{estimate}; a +#' column of that name on a profile built without one is read only when +#' named here). +#' \code{"moran_z"}, a diagnostic, is read only when named here. +#' \code{"size"} and \code{"auto"} are not criteria of the table: a size +#' sets the count and has no flat region to compare. #' @param tol Passed to \code{\link{select_resolution}()} for the flat #' region. Default 0.02. #' @param ... Ignored. @@ -1427,12 +4288,15 @@ print.resolution_selection <- function(x, ...) { #' \code{best}, \code{flat_min}, \code{flat_max}, \code{n_flat}, #' \code{value} (the optimum itself, on that criterion's own scale and so #' not comparable across rows, which is why the print method leaves it out), -#' \code{at_floor}, \code{at_ceiling} and \code{edge} (which bound an +#' \code{at_floor}, \code{at_ceiling}, \code{edge} (which bound an #' edge optimum sits on, as \code{\link{select_resolution}()} reports it; -#' \code{NA} when interior). Attributes: \code{bands} (a named list holding each +#' \code{NA} when interior) and \code{structured} (as +#' \code{select_resolution()} reports it: \code{FALSE} for a \code{cp} +#' that one cell matches). Attributes: \code{bands} (a named list holding each #' criterion's flat region in full, since \code{flat_min} and #' \code{flat_max} are only its ends and the region can have holes in it), -#' \code{common} (the levels in every flat region, an integer vector that is +#' \code{common} (the levels in every flat region of the count criteria, +#' \code{moran_z} left out; an integer vector that is #' empty when the regions do not overlap), \code{scored} (the levels each #' criterion returned a finite value at, which is what decides whether a gap #' in a band is a rejection or a level nothing was computed at), @@ -1448,9 +4312,7 @@ print.resolution_selection <- function(x, ...) { #' if (requireNamespace("gstat", quietly = TRUE)) { #' library(sf) #' # An exponential field with range parameter 200 (true effective range -#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough -#' # noise for Mallows' Cp to have an interior optimum rather than descend -#' # to the ceiling. +#' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. #' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) @@ -1481,7 +4343,21 @@ summary.resolution_profile <- function(object, criteria = NULL, tol = 0.02, ...) if (!is.numeric(tol) || length(tol) != 1L || !is.finite(tol) || tol < 0) stop("summary.resolution_profile(): `tol` must be a single non-negative number.", call. = FALSE) - selectable <- c("cp", "reliability", "elbow", "moran_z") + # `loo` is the leave-one-out error of the estimate a profile was built for. + # A profile without one has no such column, and a column of that name a + # caller added to it is read only when named (.loo_by_default()), so its + # table is unchanged. + selectable <- c("cp", "reliability", "elbow", "moran_z", "loo") + # moran_z is a diagnostic of the cell means, not a count rule: its smallest + # |z| usually sits below Cp's flat region, which left the default table's + # "in every flat region" line empty. It is read when named, and then kept + # out of the closing comparison. + count_rules <- setdiff(selectable, "moran_z") + # A ladder of one size is one level: the size set the count, and no + # criterion has levels to choose among. + bounds <- attr(object, "bounds", exact = TRUE) + one_size <- if (is.list(bounds) && length(bounds$obs_per_cell) == 1L) + as.numeric(bounds$obs_per_cell) else NULL # A criterion the caller named is reported on by select_resolution() itself, # whose message says which input it is missing. Only the defaulted set is # filtered here, and then a failure is unexpected rather than informative. @@ -1502,31 +4378,71 @@ summary.resolution_profile <- function(object, criteria = NULL, tol = 0.02, ...) ". A criterion counted twice agrees with itself, which would make the ", "closing comparison meaningless.", call. = FALSE) } else { - criteria <- selectable[vapply(selectable, function(cn) + read <- if (.loo_by_default(object)) count_rules else setdiff(count_rules, "loo") + criteria <- read[vapply(read, function(cn) cn %in% names(object) && any(is.finite(suppressWarnings(as.numeric(object[[cn]])))), logical(1))] } bad <- setdiff(criteria, selectable) + # What select_resolution(criterion = "auto") reads this profile by. + est_value <- .profile_estimate(object) + auto_is <- if (identical(est_value, "pooled")) "size" + else if (identical(est_value, "mean")) "loo" + else "cp" if (length(bad)) stop("summary.resolution_profile(): unknown criteria: ", paste(bad, collapse = ", "), - ". Choose from ", paste(selectable, collapse = ", "), ".", call. = FALSE) + ". Choose from ", paste(selectable, collapse = ", "), ".", + # "auto" names the rule that goes with the profile's estimate; said + # with what it is on this profile. + if ("auto" %in% bad) + sprintf(paste0(" \"auto\" names no criterion of the table; on this profile ", + "select_resolution() takes it as \"%s\"."), auto_is) + else "", + # A size sets the count; it has no optimum and no flat region to put + # beside the others'. + if ("size" %in% bad || ("auto" %in% bad && auto_is == "size")) + paste0(" A size sets the count and has no flat region to compare; ", + "select_resolution(criterion = \"size\") reads it.") + else "", + call. = FALSE) if (!length(criteria)) { # Two different faults reach here, and the wrong message sends the caller # off to fix the data when the object is what is wrong. - if (!any(selectable %in% names(object))) + if (!any(setdiff(selectable, "loo") %in% names(object))) stop("summary.resolution_profile(): `object` carries none of the ", - "criterion columns (", paste(selectable, collapse = ", "), + "criterion columns (", paste(setdiff(selectable, "loo"), collapse = ", "), "); it is a column subset of a resolution profile. Pass the ", "profile resolution_profile() returned.", call. = FALSE) - stop("summary.resolution_profile(): no criterion is finite at any level. ", - "cp needs a response, reliability a usable variogram, moran_z a ", - "response and more than nine cells; a geometry-only profile carries elbow alone, ", + stop("summary.resolution_profile(): no count criterion is finite at any level. ", + "cp needs a response, reliability a usable variogram; a geometry-only ", + "profile carries elbow alone, ", "and elbow is NA when the WSS curve has no elbow.", + if ("moran_z" %in% names(object) && + any(is.finite(suppressWarnings(as.numeric(object[["moran_z"]]))))) + " moran_z is finite, and is a diagnostic: name it in `criteria` to see it." + else "", + if (!is.null(one_size)) + sprintf(paste0(" The ladder is one size (obs_per_cell = %s); the count is set ", + "by the size, and select_resolution(criterion = \"size\") reads it."), + format(one_size)) + else if (is.list(bounds) && length(bounds$obs_per_cell)) + # Several sizes: the three criteria can all be NA for a reason the + # sentences above do not give. + sprintf(paste0(" The profile is on a ladder of sizes (obs_per_cell = %s)%s; ", + "select_resolution(criterion = \"size\") reads it."), + .got_text(bounds$obs_per_cell), + if (identical(attr(object, "cp_noise", exact = TRUE)$source, "none")) + paste0(", which fits no variogram unless `sac` is given, so it has no ", + "cp and no reliability") + else "") + else "", call. = FALSE) } sels <- if (explicit) - lapply(criteria, function(cn) select_resolution(object, criterion = cn, tol = tol)) + # Naming moran_z in `criteria` is the request select_resolution() asks for. + lapply(criteria, function(cn) select_resolution(object, criterion = cn, tol = tol, + diagnostic = TRUE)) else { got <- lapply(criteria, function(cn) try(select_resolution(object, criterion = cn, tol = tol), silent = TRUE)) @@ -1547,6 +4463,7 @@ summary.resolution_profile <- function(object, criteria = NULL, tol = 0.02, ...) at_floor = vapply(sels, function(s) isTRUE(s$at_floor), logical(1)), at_ceiling = vapply(sels, function(s) isTRUE(s$at_ceiling), logical(1)), edge = vapply(sels, function(s) s$edge %||% NA_character_, character(1)), + structured = vapply(sels, function(s) as.logical(s$structured %||% NA)[1L], logical(1)), stringsAsFactors = FALSE) # The levels no criterion objects to. Intersecting the regions rather than @@ -1555,15 +4472,27 @@ summary.resolution_profile <- function(object, criteria = NULL, tol = 0.02, ...) cnames <- vapply(sels, function(s) s$criterion, character(1)) bands <- stats::setNames(lapply(sels, function(s) s$flat), cnames) scored <- stats::setNames(lapply(sels, function(s) .scored_levels(s$values)), cnames) - common <- Reduce(intersect, bands) + # Over the count criteria: a diagnostic has no say in which counts they + # agree on (its own band when it is the only row). + common <- Reduce(intersect, bands[if (any(cnames %in% count_rules)) cnames %in% count_rules + else TRUE]) lv <- as.integer(object$levels) # The whole ladder, not its ends: the print method needs it to tell a band # with a hole in it from a solid run, and `[` on the result keeps it, so a # subset can still be read honestly. - structure(out, class = c("resolution_summary", "data.frame"), + out <- structure(out, class = c("resolution_summary", "data.frame"), common = sort(unique(as.integer(common))), bands = bands, scored = scored, ladder = lv, n_levels = nrow(object), tol = tol, variable = attr(object, "variable")) + # The kind that built the cells, when the profile recorded one; the summary + # of a k-means profile is the object it always was. + part <- attr(object, "partition", exact = TRUE) + if (is.list(part) && !is.null(part$kind)) + attr(out, "partition") <- part[.partition_fields()] + # The one size of the ladder, for the print method's line; absent on every + # other ladder. + if (!is.null(one_size)) attr(out, "obs_per_cell") <- one_size + out } @@ -1584,9 +4513,12 @@ print.resolution_summary <- function(x, ...) { } lad <- attr(x, "ladder"); bands <- attr(x, "bands"); scored <- attr(x, "scored") n_lv <- attr(x, "n_levels") %||% length(lad) - rungs_of <- function(cn) if (!is.null(scored[[cn]])) scored[[cn]] else lad + rungs_of <- function(cn) if (!is.na(cn) && !is.null(scored[[cn]])) scored[[cn]] else lad band_of <- function(i) { cn <- x$criterion[i] + # A row index past the last row (`s[2, ]` of a one-row table) is a row of + # NA, which seq() refuses. + if (is.na(cn) || !is.finite(x$flat_min[i]) || !is.finite(x$flat_max[i])) return("none") b <- if (!is.null(bands[[cn]])) bands[[cn]] else seq(x$flat_min[i], x$flat_max[i]) .band_label(b, rungs_of(cn)) } @@ -1594,6 +4526,10 @@ print.resolution_summary <- function(x, ...) { nrow(x), if (nrow(x) == 1L) "on" else "a", n_lv, if (n_lv == 1L) "" else "s", min(lad), max(lad))) + # The kind that built the cells, when the profile recorded one. + part <- attr(x, "partition", exact = TRUE) + if (is.list(part) && !is.null(part$kind)) + cat(sprintf(" cells: %s\n\n", .partition_label(part))) tab <- data.frame( criterion = x$criterion, best = x$best, @@ -1611,34 +4547,66 @@ print.resolution_summary <- function(x, ...) { else ifelse(x$at_ceiling, "the last level of the ladder", ifelse(x$at_floor, "the first level of the ladder", NA_character_)) on_edge <- !is.na(edge) - if (any(on_edge)) { + # One blank line between the table and the first note, whichever it is. + gap <- FALSE + open_notes <- function() if (!gap) { cat("\n"); gap <<- TRUE } + # A ladder of one size has one level, and it is the size that set it: said + # in place of "the optimum is the only level scored". + one_size <- attr(x, "obs_per_cell", exact = TRUE) + if (is.numeric(one_size) && length(one_size) == 1L) { + open_notes() + cat(strwrap(sprintf(paste0("the ladder is one size (obs_per_cell = %s); the count is ", + "set by the size, and no criterion chooses among levels."), + format(one_size)), + width = 78, prefix = " ", exdent = 2), sep = "\n") + } else if (any(on_edge)) { # Wrapped, because with four criteria named one line reached 87 # columns, which is the wrapping this block was moved here to avoid. - cat("\n") + open_notes() for (e in unique(edge[on_edge])) cat(strwrap(sprintf("%s: the optimum is %s.", paste(x$criterion[on_edge & edge == e], collapse = ", "), e), width = 78, prefix = " ", exdent = 2), sep = "\n") cat(" There the bound is choosing, not the criterion.\n") } + # A count one cell matches is not identified, whatever the table shows. + if ("structured" %in% names(x) && any(x$structured %in% FALSE)) { + open_notes() + cat(strwrap(sprintf(paste0("%s: one cell for the whole layer does as well, so the ", + "response shows no spatial structure the cells can use ", + "and this count is not identified."), + paste(x$criterion[x$structured %in% FALSE], collapse = ", ")), + width = 78, prefix = " ", exdent = 2), sep = "\n") + } + # moran_z gets its row when asked for, and no part in the comparison: it is + # a diagnostic of the cell means, and its band says nothing about which + # counts represent the response. + rule <- !is.na(x$criterion) & x$criterion != "moran_z" + if (any(x$criterion %in% "moran_z")) { + open_notes() + cat(strwrap(paste0("moran_z is a diagnostic of the cell means, not a count rule", + if (sum(rule) > 1L) "; it is left out of the comparison below." else "."), + width = 78, prefix = " ", exdent = 2), sep = "\n") + } # With one criterion there is nothing to compare: the spread is zero and the # intersection is that criterion's own band, so the closing block is skipped. - if (nrow(x) > 1L) { + if (sum(rule) > 1L) { + crit <- x$criterion[rule] # Recomputed from the rows in hand rather than read off the attribute. # `[` carries `common` through a row subset unchanged, so a two-criterion # slice of a four-criterion table used to print the parent's verdict: on # 25 simulated fields that was wrong for 39 of 250 subsets, denying an # overlap the two rows above it plainly showed. - cm <- if (!is.null(bands) && all(x$criterion %in% names(bands))) - sort(unique(Reduce(intersect, bands[x$criterion]))) + cm <- if (!is.null(bands) && all(crit %in% names(bands))) + sort(unique(Reduce(intersect, bands[crit]))) else sort(unique(attr(x, "common"))) cat("\n") - rng <- range(x$best) + rng <- range(x$best[rule]) cat(sprintf(" picks span %d to %d cells (%.1fx)\n", rng[1L], rng[2L], rng[2L] / max(rng[1L], 1L))) if (length(cm)) cat(sprintf(" in every flat region: %s (%d level%s)\n", - .band_label(cm, Reduce(intersect, lapply(x$criterion, rungs_of))), + .band_label(cm, Reduce(intersect, lapply(crit, rungs_of))), length(cm), if (length(cm) == 1L) "" else "s")) else cat(" no level is in every flat region: the criteria disagree over the\n", @@ -1655,53 +4623,170 @@ print.resolution_summary <- function(x, ...) { #' besides a number, the object the level-selection step produced: #' \code{determine_optimal_levels()}'s integer vector of ranked candidates #' (the first is used), a \code{resolution_selection} (its \code{$best}), or a -#' \code{resolution_profile} (read with \code{select_resolution()} at its -#' default criterion). The count and where it came from are returned so the -#' caller can record both on its output. +#' \code{resolution_profile} (read with \code{select_resolution()}: by +#' \code{cp} when it names no estimate, by \code{criterion = "auto"} when it +#' names one). The count and where it came from are +#' returned so the caller can record both on its output. +#' +#' Whether the profile carries an \code{"estimate"} attribute is tested +#' first, and a profile that has one goes straight to +#' \code{select_resolution(x, criterion = "auto")}: a size for pooled +#' values, the leave-one-out minimum for plain means. The test that some +#' criterion is finite, below, is not applied to it: a profile of one size +#' that fitted no variogram has no \code{cp}, \code{reliability} or +#' \code{elbow} and still has a count. An error \code{select_resolution()} +#' raises on the way is passed on as it is. +#' +#' A profile without an estimate is read by \code{cp} or not at all, with +#' one exception: a +#' geometry-only profile whose one finite criterion is \code{elbow} is read +#' by that, since it is the only thing such a profile can mean. A profile +#' whose \code{cp} is \code{NA} at every level while \code{reliability} (or +#' \code{elbow} beside a response) is finite stops with an error of class +#' \code{spatialkit_no_default_criterion} naming what is available, as +#' \code{select_resolution()} on the same object does. \code{moran_z} is a +#' diagnostic and is never read here. +#' +#' A count that a bound of the ladder chose is raised as a warning of class +#' \code{spatialkit_bound_chosen} (fields \code{edge}, \code{criterion}, +#' \code{n}), and a count that one cell matches as one of class +#' \code{spatialkit_no_structure}: the caller of the tessellation functions +#' is then told by an R condition, where there used to be a log line and a +#' free-text attribute. #' #' @param x \code{NULL}, a number, a numeric vector, a #' \code{resolution_selection} or a \code{resolution_profile}. #' @param arg,caller Names for the messages. #' @return \code{NULL} when \code{x} is \code{NULL}; otherwise a list with #' \code{n} (a single number), \code{from} (a character description, or -#' \code{NULL} when \code{x} was a plain number) and \code{seeds} (the +#' \code{NULL} when \code{x} was a plain number), \code{seeds} (the #' centres of the partition the profile scored at \code{n} cells, from -#' \code{.profile_seeds()}, or \code{NULL} when \code{x} carries none). +#' \code{.profile_seeds()}, or \code{NULL} when \code{x} carries none) and, +#' for a selection or a profile, \code{criterion}, \code{edge}, +#' \code{at_floor}, \code{at_ceiling} and \code{structured} as +#' \code{select_resolution()} reports them (\code{NULL} otherwise), and +#' \code{count_rule}, the selection's record of how the count was set +#' (\code{NULL} for a number, and for a selection that carries none). #' @keywords internal #' @noRd .resolve_cell_count <- function(x, arg, caller) { if (is.null(x)) return(NULL) from <- NULL seeds <- NULL + sel <- NULL edge_note <- function(sel) { e <- sel$edge %||% NA_character_ if (is.na(e)) "" else sprintf(", an optimum at %s", e) } + # Whether a selection's count was set by a size. The size is then part of + # the rule, and the provenance note names it with the criterion. + by_size <- function(sel) { + asked <- sel$obs_per_cell_asked %||% NA_real_ + identical(sel$criterion, "size") && is.numeric(asked) && length(asked) == 1L && + is.finite(asked) + } + # The call that made a selection, as the provenance note writes it. + call_text <- function(sel) { + if (by_size(sel)) + sprintf("select_resolution(criterion = \"size\", obs_per_cell = %s)", + format(sel$obs_per_cell_asked)) + else sprintf("select_resolution(criterion = \"%s\")", sel$criterion) + } if (inherits(x, "resolution_selection")) { n <- x$best - from <- sprintf("select_resolution(criterion = \"%s\")%s", x$criterion, edge_note(x)) + sel <- x + # For every criterion but a size this is the line it always was, whatever + # the selection holds as its `criterion`. + from <- if (by_size(x)) paste0(call_text(x), edge_note(x)) + else sprintf("select_resolution(criterion = \"%s\")%s", x$criterion, edge_note(x)) seeds <- x$seeds + } else if (inherits(x, "resolution_profile") && + !is.null(attr(x, "estimate", exact = TRUE))) { + # A profile that names an estimate is read by the rule that goes with + # it: a size for pooled values, the leave-one-out minimum for plain + # means (criterion = "auto"). Tested first, before any criterion is + # asked to be finite: a profile of one size that fitted no variogram has + # no `cp`, `reliability` or `elbow` and still has a count, and so does a + # pooled profile of a constant response. An error select_resolution() + # raises on the way is passed on as it is. + sel <- select_resolution(x, criterion = "auto") + n <- sel$best + seeds <- sel$seeds + from <- sprintf("resolution_profile() read with %s%s", call_text(sel), edge_note(sel)) + .log_info("%s(): `%s` is a resolution profile; read with %s: %d cells.", + caller, arg, call_text(sel), n) } else if (inherits(x, "resolution_profile")) { - # The default criterion is cp, which a geometry-only profile cannot score; - # fall through to the first criterion that is finite somewhere rather - # than fail with cp's own message, which names neither this function - # nor the way round it. - usable <- Filter(function(cn) cn %in% names(x) && - any(is.finite(suppressWarnings(as.numeric(x[[cn]])))), - c("cp", "reliability", "elbow", "moran_z")) + # A profile without an estimate is read by cp, as the default criterion + # of select_resolution() reads one. It + # used to fall through cp, reliability, elbow, moran_z to the first that + # was finite somewhere, with an INFO log line the console does not show: + # a geometry-only profile given a variogram was read by reliability and + # handed on 13 cells where the response profile of the same layer gives + # 100, and a response profile with no cp was read by moran_z. + # select_resolution() on either object is an error, and so is this. + finite_in <- function(cn) cn %in% names(x) && + any(is.finite(suppressWarnings(as.numeric(x[[cn]])))) + usable <- Filter(finite_in, c("cp", "reliability", "elbow")) + geometry_only <- is.na(attr(x, "variable") %||% NA_character_) + # The sizes of a ladder `obs_per_cell` set. Such a profile has a count, + # the one a size gives, though none of the three criteria may be finite + # on it: a ladder of sizes fits no variogram unless `sac` is given, and + # one size is one level, which has no WSS curve. + ladder_sizes <- if (is.list(attr(x, "bounds", exact = TRUE))) + attr(x, "bounds", exact = TRUE)$obs_per_cell else NULL # A geometry-only profile of a layer with no cluster structure lands here # too: its elbow is NA rather than the sqrt(first x last level) the # linear chord rule used to hand on as if the data had chosen it. if (!length(usable)) stop(sprintf(paste0("%s(): `%s` is a resolution profile with no criterion finite at ", - "any level, so no cell count can be read off it.%s"), + "any level, so no cell count can be read off it.%s%s"), caller, arg, - if (is.na(attr(x, "variable") %||% NA_character_)) + if (length(ladder_sizes)) + sprintf(paste0(" It is on a ladder of sizes (obs_per_cell = %s) and was ", + "built without an `estimate`, so it is read by `cp`, or by ", + "`elbow` when it has no `response_var`, and neither is ", + "finite on it%s. A size reads it: pass ", + "select_resolution(, criterion = \"size\") as ", + "`%s`, or pass a number."), + .got_text(ladder_sizes), + if (!geometry_only && + identical(attr(x, "cp_noise", exact = TRUE)$source, "none")) + paste0(" (a ladder of sizes fits no variogram unless `sac` is ", + "given, and `cp` takes its noise variance from one)") + else "", + arg) + else if (geometry_only) paste0(" It is geometry-only, and its WSS curve has no elbow: the ", "points have no cluster structure to choose a count. Pass a ", "number, or profile with a `response_var`.") + else "", + if (finite_in("moran_z")) + paste0(" (`moran_z` is finite on it, but it is a diagnostic of the ", + "cell means and is not read as a count.)") else ""), call. = FALSE) - sel <- select_resolution(x, criterion = usable[[1L]]) + # The one fall-through kept: a geometry-only profile whose only finite + # criterion is the elbow can mean nothing else. + crit <- if ("cp" %in% usable) "cp" + else if (geometry_only && identical(usable, "elbow")) "elbow" + else NULL + if (is.null(crit)) + stop(errorCondition( + sprintf(paste0("%s(): `%s` is a resolution profile whose `cp`, the criterion a ", + "profile is read by, is NA at every level%s, so no cell count is ", + "read off it. Finite on it: %s. To use one, pass ", + "select_resolution(, criterion = \"%s\") as `%s`; or ", + "pass a number.%s"), + caller, arg, + if (geometry_only) " (the profile has no `response_var`)" else "", + paste(usable, collapse = ", "), usable[[1L]], arg, + # A ladder of sizes has one more reader. + if (length(ladder_sizes)) + sprintf(paste0(" The profile is on a ladder of sizes (obs_per_cell = %s): ", + "criterion = \"size\" reads it by a size."), + .got_text(ladder_sizes)) + else ""), + class = "spatialkit_no_default_criterion", call = NULL)) + sel <- select_resolution(x, criterion = crit) n <- sel$best seeds <- sel$seeds from <- sprintf("resolution_profile() read with select_resolution(criterion = \"%s\")%s", @@ -1732,10 +4817,76 @@ print.resolution_summary <- function(x, ...) { caller, arg, format(.Machine$integer.max), format(n)), call. = FALSE) if (!is.numeric(n) || length(n) != 1L || !is.finite(n) || n < 1) - stop(sprintf("%s(): `%s` must resolve to a positive number of cells; got %s.", - caller, arg, paste(format(n), collapse = ", ")), call. = FALSE) + stop(sprintf("%s(): `%s` must resolve to a positive number of cells; got %s.%s", + caller, arg, paste(format(n), collapse = ", "), + # determine_optimal_levels(on_no_elbow = "na") hands this on. + if (isFALSE(attr(x, "structured", exact = TRUE))) + paste0(" It is what determine_optimal_levels(on_no_elbow = \"na\") ", + "returns when the WSS curve has no elbow: the points name no ", + "count. Pass a number.") + else ""), call. = FALSE) # Seeds only when they are the partition at exactly this count; a selection # edited by hand, or one whose level had no successful k-means, has none. if (!inherits(seeds, "sf") || nrow(seeds) != n) seeds <- NULL - list(n = as.numeric(n), from = from, seeds = seeds) + # The count is about to become cells. When a bound of the ladder chose + # it, or one cell does as well, the caller is told by an R warning with a + # class: a count that sat at the ceiling used to be marked by nothing but + # the text of attr(, "n_from"). + if (!is.null(sel)) { + e <- sel$edge %||% NA_character_ + if (length(e) == 1L && !is.na(e)) + .warn_classed("spatialkit_bound_chosen", + paste0("%s(): `%s` is %d cells, the optimum of `%s`, and that optimum is ", + "%s: the bound chose the count, not the criterion.%s Pass a ", + "number as `%s` to set the count yourself."), + caller, arg, as.integer(n), sel$criterion %||% "the criterion", e, + .edge_hint(e), arg, + data = list(edge = e, criterion = sel$criterion, n = as.integer(n))) + # The notes that say why the count is not identified: every note of the + # selection, as before, but the ones select_resolution() writes about + # something else (which rule set the count, a size the profile held, the + # end of the ladder, which estimate the criterion scores, a ladder of one + # size). Those carry one of five names and are left out here. A note + # without a name, or with any other, is pasted as it always was, so a + # selection whose notes the caller wrote is told in the caller's words. + why <- sel$note + other <- names(why) %in% .NOTES_NOT_STRUCTURE + if (any(other)) { + why <- why[!other] + if (!length(why)) why <- NULL + } + if (isFALSE(sel$structured) && by_size(sel)) + # A size set this count and no criterion, so the count stands; what + # the caller is told is that the cells will say little. A selection + # that names "size" and no size asked for is not one this function + # wrote, and is told in the present words. + .warn_classed("spatialkit_no_structure", + paste0("%s(): `%s` is %d cells, set by obs_per_cell = %s, and %s The ", + "count stands, since a size set it and no criterion; the cell ", + "values will say little that one mean for the layer does not."), + caller, arg, as.integer(n), format(sel$obs_per_cell_asked %||% NA_real_), + paste(why %||% paste0("one mean for the whole layer predicts a left-out ", + "observation as well as cells of this size do."), + collapse = " "), + data = list(criterion = sel$criterion, n = as.integer(n), + one_cell = sel$one_cell)) + else if (isFALSE(sel$structured)) + .warn_classed("spatialkit_no_structure", + paste0("%s(): `%s` is %d cells, the optimum of `%s`, but %s Pass a ", + "number as `%s` if a count is wanted on other grounds."), + caller, arg, as.integer(n), sel$criterion %||% "the criterion", + paste(why %||% paste0("one cell for the whole layer does as well, ", + "so the count is not identified."), + collapse = " "), + arg, + data = list(criterion = sel$criterion, n = as.integer(n), + one_cell = sel$one_cell)) + } + list(n = as.numeric(n), from = from, seeds = seeds, + criterion = sel$criterion, edge = sel$edge, at_floor = sel$at_floor, + at_ceiling = sel$at_ceiling, structured = sel$structured, + # How the count was set, for the functions that turn it into cells: + # NULL for a number, and for a count a present criterion read off a + # profile without an estimate. + count_rule = sel$count_rule) } diff --git a/R/seeding.R b/R/seeding.R index 5611bf0f..3377a27e 100644 --- a/R/seeding.R +++ b/R/seeding.R @@ -4,6 +4,33 @@ #' supported: user-provided points, uniform random sampling within a boundary, #' or k-means clustering of a sampling cloud. #' +#' Seeds lie inside the ground they stand for (k-means seeds inside the +#' hull of the points they were fitted to, random seeds inside the +#' boundary), so Voronoi cells clipped to the seeds' own hull would leave +#' its edge uncovered. The result therefore +#' carries that ground as `attr(, "cover")`: the `boundary` when one was +#' given, otherwise the convex hull of `sample_points`, otherwise (for the +#' scored centres of a [resolution_profile()] or a [select_resolution()] +#' result passed as `n`) the hull of the points the profile was computed on. +#' [build_tessellation()] and +#' [create_voronoi_polygons()] derive their default boundary from it, so +#' `build_tessellation(seeds, method = "voronoi")` holds every observation +#' without a `boundary`. Seeds with no cover are tessellated over their own +#' hull unless a `boundary` or `cover` is passed then: `method = "provided"` +#' seeds given with neither `boundary` nor `sample_points` have none, and no +#' warning is raised for them, since they may be the observation sites +#' themselves. The attribute survives +#' `sf::st_transform()` and row subsetting; `rbind()` drops it. +#' +#' A k-means seed is a mean of the points of its cluster, weighted under the +#' density kind, so it can lie outside a `boundary` that is not convex, in a +#' bay or a bend of a coast, even when every point lies inside. Tessellated +#' within that boundary, its cell is built if any of it lies inside, but the +#' seed itself lies in no cell: [build_tessellation()] warns that it falls +#' in no cell (class `spatialkit_unassigned`) and gives it `NA` in `index`. +#' `seeds` in [cell_values_at()] says how to give such a seed its cell's +#' ID. +#' #' @param boundary Optional polygonal sf object defining the sampling area. #' @param method One of "kmeans", "random", "provided". #' @param n Integer; number of seeds to return. Required for @@ -22,17 +49,49 @@ #' Besides a number, `n` accepts what the level-selection step returned: #' the integer vector of ranked candidates from [determine_optimal_levels()] #' (its first element is used), a [select_resolution()] result (its -#' `$best`), or a [resolution_profile()] (read with `select_resolution()` at -#' its default criterion). The result then carries `attr(, "n_from")` -#' saying which. +#' `$best`), or a [resolution_profile()]. A profile built without an +#' `estimate` is read with `select_resolution()` by `cp`. A profile built +#' with `estimate` is read by `criterion = "auto"`, the rule that goes +#' with its estimate: a size for pooled values and the lowest +#' leave-one-out error for plain means. The size is the profile's own when +#' it was built at one, and 4.5 rows per cell otherwise, and the count is +#' the profile's level for that size, or the built level nearest to +#' `max(2, round(n / obs_per_cell))` when the profile has none for it +#' (with a warning of class `"spatialkit_size_not_reached"`). +#' `select_resolution(profile)` with no `criterion` reads such a profile +#' the same way, since its default criterion is `"auto"`. A profile built +#' with `obs_per_cell` and without an `estimate` is read by `cp` like any +#' profile without one; pass `select_resolution(profile, criterion = +#' "size")` for the count its size gives. The result then +#' carries `attr(, "n_from")` +#' saying which. A count read off a selection or a profile comes with what +#' the selection found: a warning of class `"spatialkit_bound_chosen"` when +#' the optimum sits on a bound of the ladder, so the bound chose the count, +#' and one of class `"spatialkit_no_structure"` when one cell for the whole +#' layer scores as well. A count set by a size has no optimum, so no bound +#' can choose it; its `"spatialkit_no_structure"` warning says that the +#' count stands and that the cell values will say little that one mean +#' does not. A profile without an estimate and with no `cp` to read is an +#' error (class `"spatialkit_no_default_criterion"` when another criterion +#' is finite); see [resolution_profile()]. #' #' With `method = "kmeans"`, a selection or profile also carries the #' centres of the partition the profile scored at that count, and those -#' are returned instead of a new k-means: a k-means partition is the -#' Voronoi partition of its centres, so their cells are the cells the -#' criteria judged. `sample_points`, when given, is then only assigned to -#' them (for `attr(, "kmeans")`), and `boundary` only sets the CRS; -#' `kmeans_nstart`, `kmeans_iter` and `set_seed` are not used. Pass the +#' are returned instead of a new k-means: a k-means partition, weighted or +#' not, is the Voronoi partition of its centres, so their cells are the +#' cells the criteria judged. `sample_points`, when given, is then only +#' assigned to them (for `attr(, "kmeans")`) and gives the cover, and +#' `boundary` only +#' sets the CRS and the cover (see "Details"); +#' `kmeans_nstart`, `kmeans_iter` and `set_seed` are not used, and neither +#' are `partition`, `init` and the density settings: the centres are of +#' the kind the profile was built with, and naming another here is a +#' warning of class `"spatialkit_partition_unused"`. A call names what it +#' supplies: a `partition` or an `init` passed in the call; with +#' `partition = "density"` passed, both density settings at their values, +#' defaults included; without it, a density setting other than its +#' default. A call that supplies none of the four is told nothing, +#' whichever kind and settings the profile was built with. Pass the #' count as a number (`n = sel$best`) for a fresh k-means instead. #' @param seeds sf POINT object of user-provided seeds (method = "provided"). #' @param sample_points Optional sf POINT cloud for k-means clustering. Only @@ -43,12 +102,63 @@ #' cloud, or one with no CRS whose coordinates look like lon/lat (the #' heuristic [ensure_projected()] applies, with its warning), is projected #' before clustering. -#' @param kmeans_nstart Integer; nstart for kmeans(). Default 10. The -#' partition is [stats::kmeans()], not the best-of-25 k-means++ run that -#' [resolution_profile()] scored a count on, so it is not that partition; -#' pass the selection or profile itself as `n` for that one (see `n`). -#' @param kmeans_iter Integer; iter.max for kmeans(). Default 100. +#' @param kmeans_nstart The number of starts, of which the best is kept. +#' `NULL` (default) is the kind's own number: 3 for `partition = +#' "density"` and 10 for `partition = "kmeans"`, the default of earlier +#' versions. `kmeans_nstart = 10` gives the density kind the starts it had +#' when 10 was the default. Under `partition = "kmeans"` from random starts +#' it is `nstart` of [stats::kmeans()]. A fresh partition is not the one +#' [resolution_profile()] scored a count on; pass the selection or profile +#' itself as `n` for that one (see `n`). Under `partition = "density"`, +#' and with `init = "kmeans++"`, it has to be `NULL` or a positive whole +#' number, so a number that is not whole, which `partition = "kmeans"` +#' takes, stops a call that names no kind. It is not read by `method = +#' "random"` or `"provided"`. +#' @param kmeans_iter Integer; iter.max for kmeans(). Default 100. Under +#' `partition = "density"` it is the most steps of Lloyd's iteration a +#' start takes. Under `partition = "density"`, and with `init = +#' "kmeans++"`, it has to be a positive whole number, and a kept start that +#' was cut off at it is a warning of class `"spatialkit_not_converged"` +#' (`partition = "kmeans"` from random starts keeps the warning +#' [stats::kmeans()] gives). #' @param set_seed Optional integer RNG seed. +#' @param partition For `method = "kmeans"`: what the seeds minimise. +#' `"density"` (default) is the sum of squared distances from the points +#' of the cloud to their nearest seed, each point weighted by its local +#' density to the power `density_power`: compact cells, many small ones +#' where the points are dense and a few large ones where they are sparse. +#' At the default power they hold about the same number of points each +#' once `n` is above the number of dense places (clusters) in the cloud; +#' below that the counts are about as uneven as under `"kmeans"`. +#' `"kmeans"` is the same sum unweighted: compact cells, with several +#' times the points in a cell of a dense place that a cell of a sparse +#' place holds. It is the run of earlier versions, whose default it was: +#' [stats::kmeans()] from 10 random starts on the rows as they come. The +#' density kind follows the +#' density of `sample_points`; a cloud this function draws inside +#' `boundary` is uniform and has none to follow. Without the 'FNN' package +#' the density kind finds its weights by comparing every pair of distinct +#' locations, so its time grows with the square of their number; the seeds +#' are the same, and nothing stops the call. See "The partition" in +#' [resolution_profile()] for what each kind does and how. +#' @param init For `method = "kmeans"`: how each start is drawn, `"random"` +#' (`n` distinct locations at random, as [stats::kmeans()] draws them) or +#' `"kmeans++"` (the seeds one at a time, each in proportion to its squared +#' distance from those already drawn, times its weight under `partition = +#' "density"`). `NULL` (default) is each kind's own rule: `"random"` for +#' `partition = "kmeans"`, the run this function has always made, and +#' `"kmeans++"` for `partition = "density"`. Under `partition = "kmeans"` +#' from random starts the cloud is clustered in the order its rows come +#' in; with `init = "kmeans++"`, and under `partition = "density"`, the +#' rows are put in coordinate order first, so the seeds do not depend on +#' their order. +#' @param density_power For `partition = "density"`: the power the local +#' density is raised to for a point's weight, from 0 to 2. Default 1, which +#' evens out the cell counts once the cells outnumber the dense places; 0 +#' weights every point alike. Setting it under `partition = "kmeans"` is a +#' warning. +#' @param density_k For `partition = "density"`: the number of nearest +#' neighbours the local density is read from. Default 8. #' @return An sf POINT object with seed_id and method columns. With #' `method = "kmeans"` it also carries `attr(, "kmeans")`, the run behind #' the seeds: `cluster` (the `seed_id` each clustered cloud point was @@ -58,7 +168,41 @@ #' `iter` and `nstart`. For the scored centres of a selection or profile #' (see `n`) it describes `sample_points` assigned to them, each point to #' its nearest seed, with `iter` `NA` and `nstart` the profile's restarts, -#' and is absent when no `sample_points` were given. +#' and is absent when no `sample_points` were given. Under `partition = +#' "density"` `withinss` and `tot_withinss` count every point once, about +#' its cell's mean. A run this call makes with `partition = "density"` or +#' `init = "kmeans++"` also records `converged`, whether the kept start +#' stopped before `kmeans_iter`, and under `partition = "density"` +#' `objective`, the weighted sum the seeds minimise; scored centres have +#' neither. Seeds placed with `partition = "density"` or `init = +#' "kmeans++"`, and the scored centres of a profile of the density kind or +#' from random starts, carry `attr(, "partition")`: a +#' list with `kind`, `init`, `density_power` and `density_k`, and for +#' seeds this call placed `iter`, `iter_max` and `converged` (the +#' iterations the kept start took, the limit, and whether it stopped +#' before the limit). [build_tessellation()] returns the list as +#' `params$partition`. Seeds with no such +#' record are plain k-means: from random starts when this call placed +#' them, or the scored centres of a k-means profile from k-means++ starts. +#' Every method also +#' attaches `attr(, "cover")` when the call says what ground the seeds stand +#' for (see "Details"): an sfc holding the boundary's polygons or the hull +#' of the clustered points, in its own CRS. +#' +#' When `n` is a [select_resolution()] result that carries `count_rule`, +#' or a profile built with an `estimate`, the seeds carry that record as +#' `attr(, "count_rule")`: how the count was set, for which cell value, and +#' what the profile scored at it. Its `scored_cells` is `TRUE` for the +#' scored centres `method = "kmeans"` hands on, and `FALSE` for seeds this +#' call places itself at that count: a k-means of its own when the +#' selection holds no centres at the count, and every `method = "random"` +#' seeding. `method = "provided"` does not read `n` and writes no record; +#' seeds that already carry one (`sel$seeds`) keep it, marked `FALSE` when +#' their number is not the record's count. [build_tessellation()] and +#' [assign_features_to_polygons()] hand the record on, and +#' [summarize_by_cell()] checks its result against it. A count given as a +#' number, or read off a profile without an estimate by `cp` or `elbow`, +#' has no record. #' @family tessellation #' @examples #' library(sf) @@ -66,20 +210,75 @@ #' c(0, 0), c(100, 0), c(100, 100), c(0, 100), c(0, 0) #' ))), crs = 32632)) #' get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 1) +#' +#' # Seeds from a cloud with one dense place: density-weighted k-means by +#' # default, from 3 starts; partition = "kmeans" gives the k-means run of +#' # earlier versions. The points each seed's cell holds, under each kind, +#' # with more seeds than dense places: +#' set.seed(2) +#' cloud <- st_as_sf(data.frame(x = c(rnorm(150, 30, 5), runif(50, 0, 100)), +#' y = c(rnorm(150, 30, 5), runif(50, 0, 100))), +#' coords = c("x", "y"), crs = 32632) +#' dens <- get_voronoi_seeds(bnd, method = "kmeans", n = 20, +#' sample_points = cloud, set_seed = 1) +#' km <- get_voronoi_seeds(bnd, method = "kmeans", n = 20, +#' sample_points = cloud, set_seed = 1, +#' partition = "kmeans") +#' rbind(density = sort(attr(dens, "kmeans")$size), +#' kmeans = sort(attr(km, "kmeans")$size)) # points per seed #' @export get_voronoi_seeds <- function(boundary = NULL, method = c("kmeans", "random", "provided"), n = NULL, seeds = NULL, sample_points = NULL, - kmeans_nstart = 10, + kmeans_nstart = NULL, kmeans_iter = 100, - set_seed = NULL) { + set_seed = NULL, + partition = c("density", "kmeans"), + init = NULL, + density_power = 1, + density_k = 8) { method <- match.arg(method) + partition_given <- !missing(partition) + # The density settings the caller supplied, as against those left at + # their defaults: read where the kind in force is this function's own + # and not one the call named. + density_given <- c(if (!missing(density_power)) "density_power", + if (!missing(density_k)) "density_k") + partition <- match.arg(partition) # --- validation --- + # The kind of partition the k-means route builds and how its starts are + # drawn (R/partition.R). A density setting given where no density + # partition is built is reported below, once it is known what the call + # returns: scored centres passed as `n` may be density ones. + part <- .seed_partition_args(partition, init, density_power, density_k, + "get_voronoi_seeds") + # Said of a kind the call named, not of the function's own: a random or + # provided seeding that names no kind has asked for nothing it does not get. + if (!identical(method, "kmeans") && + ((partition_given && identical(partition, "density")) || !is.null(init))) + .warn_and_log(paste0("get_voronoi_seeds(): `partition` and `init` are read by ", + "method = \"kmeans\" only; method = \"%s\" ignores them."), method) + # The other paths, which are not the run this function has always made, + # check the two counts before the engine reads them: a start count of 0 + # ran one start and recorded none, and NA stopped inside rep(). A NULL + # number of starts is the kind's own, and is replaced where the argument is + # read, here and at the fit below, and nowhere before. method = "random" + # and "provided" never read it, and neither do scored centres passed beside + # this function's own run (k-means from random starts), so a call on those + # paths does not evaluate the argument. + if (identical(method, "kmeans") && !part$present) { + kmeans_nstart <- .check_whole_count(.seed_nstart(kmeans_nstart, part$kind), + "kmeans_nstart", "get_voronoi_seeds", + "starts", null_ok = TRUE) + kmeans_iter <- .check_whole_count(kmeans_iter, "kmeans_iter", "get_voronoi_seeds", + "iterations") + } if (!is.null(boundary)) .assert_sf(boundary, c("POLYGON", "MULTIPOLYGON"), "boundary") # The level-selection step's own answer is accepted as `n`. + n_arg <- n n_res <- .resolve_cell_count(n, "n", "get_voronoi_seeds") n <- if (is.null(n_res)) NULL else n_res$n n_from <- if (is.null(n_res)) NULL else n_res$from @@ -107,14 +306,46 @@ get_voronoi_seeds <- function(boundary = NULL, # algorithm, different starts, a different cloud) gave other cells, and # the count was then defended on a partition nobody built. if (identical(method, "kmeans") && !is.null(n_res$seeds)) { + # The ground these centres stand for: the boundary, else the points they + # are for, else the hull of the points the profile was computed on, which + # a profile keeps and a selection's centres carry as their cover. + scored_cover <- if (!is.null(boundary)) boundary + else if (!is.null(sample_points)) sample_points + else if (inherits(n_arg, "resolution_profile")) + attr(n_arg, "hull", exact = TRUE) + else NULL + .scored_partition_unused(n_res$seeds, part, part$init_given, partition_given, + arg = "n", caller = "get_voronoi_seeds", + density_given = density_given) out <- .use_scored_seeds(n_res$seeds, like = if (!is.null(boundary)) boundary else sample_points, - cloud = sample_points, caller = "get_voronoi_seeds") + cloud = sample_points, caller = "get_voronoi_seeds", + cover = scored_cover, count_rule = n_res$count_rule) + cov <- attr(out, "cover", exact = TRUE) + rec <- attr(out, "partition", exact = TRUE) + rule <- .count_rule_get(out) out <- .align_crs(out, boundary) + # Kept across the CRS alignment whatever sf does with custom attributes. + attr(out, "cover") <- cov + if (!is.null(rec)) attr(out, "partition") <- rec attr(out, "n_from") <- n_from - return(out) + return(.count_rule_put(out, rule)) } + # No scored centres: `density_power` or `density_k` set under partition = + # "kmeans" is read by nothing in this call. + .warn_density_unused(part, "get_voronoi_seeds") + # The same for a random or provided seeding with the density kind in force + # as this function's own: the warning above speaks of a kind the call did + # not get, and cannot fire here. + if (!identical(method, "kmeans") && identical(part$kind, "density") && + !partition_given && length(density_given)) + .warn_and_log(paste0("get_voronoi_seeds(): %s %s read by method = \"kmeans\" only; ", + "method = \"%s\" ignores %s."), + paste(sprintf("`%s`", density_given), collapse = " and "), + if (length(density_given) > 1L) "are" else "is", method, + if (length(density_given) > 1L) "them" else "it") + # --- RNG handling (always restored) --- cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) @@ -134,6 +365,13 @@ get_voronoi_seeds <- function(boundary = NULL, s <- seeds s$seed_id <- seq_len(nrow(s)) s$method <- "provided" + # Seeds that carry the record of a count are handed on with it (the + # scored centres of a selection, `sel$seeds`). Fewer or more of them + # than the count are not the centres the profile scored, and the + # record says so. + carried <- .count_rule_get(s) + if (!is.null(carried) && !identical(nrow(s), as.integer(carried$cells))) + s <- .count_rule_put(s, carried, scored_cells = FALSE) s }, @@ -213,9 +451,32 @@ get_voronoi_seeds <- function(boundary = NULL, as.integer(n), k_use, n_uniq, nrow(xy)) } - km <- stats::kmeans(x = xy, centers = k_use, iter.max = kmeans_iter, - nstart = kmeans_nstart) - centers <- km$centers + # One engine for every kind (.partition_centres()). The default is + # the run this function has always made, stats::kmeans() from + # `kmeans_nstart` random starts on the cloud's rows as they come; any + # other kind or starting rule works on the rows in coordinate order, + # so its seeds do not depend on the order of the cloud. + # `kmeans_nstart` is read by the fit when it first needs it, as it + # always was; NULL is then the kind's own number. + fit <- .partition_centres(xy, k_use, partition = part$kind, init = part$init, + nstart = .seed_nstart(kmeans_nstart, part$kind), + iter.max = kmeans_iter, + density_power = density_power, density_k = density_k, + sort_rows = !part$present, one_call = part$present) + if (is.null(fit)) + stop(sprintf(paste0("get_voronoi_seeds(kmeans): no start gave a partition of ", + "the %d point(s) into %d cells."), nrow(xy), k_use), + call. = FALSE) + if (identical(part$kind, "density")) + .warn_empty_seeds(fit$size, "get_voronoi_seeds") + # The default run's own warning from stats::kmeans() stands as it is; + # the other paths say it with a class. + if (!part$present && isFALSE(fit$converged)) + .warn_not_converged("get_voronoi_seeds", k_use, fit$iter, kmeans_iter, + part$kind, "kmeans_iter") + run_record <- list(iter = as.integer(fit$iter), iter_max = as.integer(kmeans_iter), + converged = isTRUE(fit$converged)) + centers <- .seed_centre_matrix(fit, xy) centers_sfc <- sf::st_sfc( lapply(seq_len(nrow(centers)), function(i) sf::st_point(centers[i, ])), crs = sf::st_crs(cloud_for_km) @@ -231,14 +492,20 @@ get_voronoi_seeds <- function(boundary = NULL, # `cluster` is one seed_id per clustered cloud row (`rows` gives those # rows' positions in the cloud, since unusable rows were dropped). km_record <- list( - cluster = as.integer(km$cluster), + cluster = as.integer(fit$cluster), rows = which(!bad_xy), - size = as.integer(km$size), - withinss = as.numeric(km$withinss), - tot_withinss = as.numeric(km$tot.withinss), - iter = as.integer(km$iter), - nstart = as.integer(kmeans_nstart) + size = as.integer(fit$size), + withinss = as.numeric(fit$withinss), + tot_withinss = as.numeric(fit$wss), + iter = as.integer(fit$iter), + nstart = as.integer(.seed_nstart(kmeans_nstart, part$kind)) ) + # The density kind minimises a weighted sum, which `tot_withinss` (every + # point counted once, about its cell's mean) is not. + if (identical(part$kind, "density")) km_record$objective <- fit$objective + # Whether the kept start stopped before `kmeans_iter`. Not added to + # the default run's record, which is the list it always was. + if (!part$present) km_record$converged <- run_record$converged s } ) @@ -252,7 +519,43 @@ get_voronoi_seeds <- function(boundary = NULL, if (!is.null(n_from)) attr(out, "n_from") <- n_from # The k-means run behind the seeds, on the kmeans path only. if (identical(method, "kmeans")) attr(out, "kmeans") <- km_record - out + # The kind that built the regions, when it is not this function's own + # default (see `partition`); seeds with no record are plain k-means. + if (identical(method, "kmeans") && !part$present) + attr(out, "partition") <- c(part[.partition_fields()], run_record) + # How the count was set, when a selection or a profile gave it: these + # seeds were placed here, at that count, and are not the centres the + # profile scored. `method = "provided"` does not read `n`, and writes none. + if (!identical(method, "provided")) + out <- .count_rule_put(out, n_res$count_rule, scored_cells = FALSE) + # The ground the seeds stand for, set after the alignment so it is kept + # whatever a transform does with custom attributes: the boundary when one + # was given (random seeds, a cloud sampled in it, and a cloud the caller + # placed in it), otherwise the hull of the clustered cloud. + .set_cover(out, if (!is.null(boundary)) boundary else sample_points) +} + + +#' Attach the cover of the ground a layer of seeds stands for +#' +#' Seeds lie inside the data, or inside the boundary they were drawn in, so +#' the hull of the seeds is smaller than the ground their Voronoi cells have +#' to hold. The cover is that ground: the polygons of a boundary, or the +#' convex hull of the points that were clustered (see \code{.cover_of()}), +#' in its own CRS. \code{create_voronoi_polygons()} reads it when no +#' boundary is passed. +#' +#' @param seeds The sf POINT layer of seeds. +#' @param src An sf/sfc layer of polygons or points, or \code{NULL} when the +#' call does not say what ground the seeds stand for. +#' @return \code{seeds}, with \code{attr(, "cover")} set when \code{src} +#' gives one. +#' @keywords internal +#' @noRd +.set_cover <- function(seeds, src) { + cov <- tryCatch(.cover_of(src), error = function(e) NULL) + if (!is.null(cov)) attr(seeds, "cover") <- cov + seeds } @@ -311,8 +614,10 @@ get_voronoi_seeds <- function(boundary = NULL, #' sampling density: clusters of observations attract seeds, empty ground gets #' none. Reach for this when you want cells that follow the data, so that #' counts per cell vary far less than on a fixed grid over clustered points -#' (k-means does not equalise them, it minimises the spread of points around -#' each centre), which is what keeps per-cell aggregates in +#' (the density kind, the default, evens them out once there are more cells +#' than clusters of points; plain k-means, `partition = "kmeans"`, minimises +#' the spread of points around each centre and does not equalise them), +#' which is what keeps per-cell aggregates in #' [summarize_by_cell()] from resting on one or two observations. Use #' [voronoi_seeds_random()] instead when you want coverage of the study area #' rather than of the data, and [get_voronoi_seeds()] to pick between them by @@ -325,15 +630,47 @@ get_voronoi_seeds <- function(boundary = NULL, #' coordinates are dropped with a warning, and `k` is clamped to the number of #' distinct positions. #' -#' The partition is [stats::kmeans()] (Hartigan-Wong) with `nstart` random -#' starts. [resolution_profile()] and [determine_optimal_levels()] score each -#' count on a different run, by default the best of 25 k-means++ restarts, -#' which usually reaches a lower within-cluster sum of squares; the seeds for -#' a count passed as a number are therefore not the partition that count was -#' scored on. Raising `nstart` narrows the gap but does not close it. Pass -#' the [select_resolution()] result or the profile itself as `k` to close -#' it: the centres of the scored partition are then returned (in the CRS of -#' `points_sf`, with `attr(, "n_from")`), and no k-means is run. +#' A count given as a number gets a fresh partition, which is not the +#' partition [resolution_profile()] or [determine_optimal_levels()] scored +#' that count on: those fit their own run, the profile to every row or to a +#' subsample, and keep the best of their own starts. Pass the +#' [select_resolution()] result or the profile itself as `k` to get the +#' scored one: the centres of the scored partition are then returned (in +#' the CRS of `points_sf`, with `attr(, "n_from")`), and no k-means is run. +#' +#' `partition` says what the seeds minimise. `"kmeans"` is the sum of +#' squared distances from the points to their nearest seed, from `nstart` +#' random starts by [stats::kmeans()] (Hartigan-Wong) unless `init` says +#' otherwise; it was the default of earlier versions. The seeds +#' follow the square root of the point density, so the cells are compact, +#' smaller where the points are dense, and a cell in a dense place still +#' holds several times the points of a cell in a sparse place. `"density"` +#' weights each point by its local density (the number of points in the disc +#' that reaches its `density_k`-th nearest neighbour, over the disc's area) +#' to the power `density_power`, and is the default. At the default power +#' of 1 the seeds follow the point density itself, and the cells are +#' compact: many small cells where the points are dense, a few large ones +#' where they are sparse. They +#' hold about the same number of points each once `k` is above the number +#' of dense places (clusters of points). With fewer cells than that a cell +#' takes in whole clusters, large and small, and the counts are about as +#' uneven as under `"kmeans"`. The density kind is the best of +#' `nstart` starts, each refined by at most 100 steps of Lloyd's iteration +#' (`iter_max` sets another limit, and a kept start that was cut off at the +#' limit is a warning of class `"spatialkit_not_converged"`); +#' it does not depend on the order of the rows or on the unit of the +#' coordinates, and points at one location share a cell. A seed can end +#' with no point at counts from about a fifth of the points up, mostly from +#' `init = "random"`; that is a warning of class `"spatialkit_empty_cells"`. +#' "The partition" in +#' [resolution_profile()] gives the details and a simulated comparison of +#' the two kinds. +#' +#' The centres lie inside the points, so their own hull is smaller than the +#' data's. The result carries the convex hull of `points_sf` as +#' `attr(, "cover")`, and [build_tessellation()] clips the cells to that hull +#' (grown by 2 percent of its diagonal) when no `boundary` is passed, so every +#' point of `points_sf` falls in a cell. #' #' @param points_sf An sf object with POINT geometries. #' @param k Integer; requested number of clusters, treated as an upper bound @@ -342,18 +679,85 @@ get_voronoi_seeds <- function(boundary = NULL, #' produce neither more centres than there are distinct points nor as many #' centres as there are rows. Check `nrow()` on the result. A #' [select_resolution()] result or a [resolution_profile()] is also -#' accepted: its scored centres are returned when it carries them, and -#' otherwise its count is used. +#' accepted: its scored centres are returned when it carries them, +#' whatever `partition`, `init` and density settings the call names (see +#' `n` in [get_voronoi_seeds()] for which arguments a call is taken to +#' name), and +#' otherwise its count is used. A profile is read as [get_voronoi_seeds()] +#' reads one passed as `n`: by `cp` when it was built without an +#' `estimate`, and by `select_resolution(criterion = "auto")` when it was +#' built with one (a size for pooled values, the lowest leave-one-out +#' error for plain means). Such a count raises the warnings and the +#' error described under `n` in [get_voronoi_seeds()] (classes +#' `"spatialkit_bound_chosen"`, `"spatialkit_no_structure"` and +#' `"spatialkit_no_default_criterion"`). #' @param set_seed Optional integer RNG seed. Default 456, so a call gives the #' same seeds every time whatever the session's random-number state; an #' outer [set.seed()] does not change them, and the caller's random-number #' stream is left as it was. Pass `NULL` to draw the k-means starts from #' the session's stream instead (the default of [get_voronoi_seeds()]). -#' @param nstart Number of random starts for [stats::kmeans()]; the best is -#' kept. Default 10. +#' @param nstart The number of starts, of which the best is kept. `NULL` +#' (default) is the kind's own number: 3 for `partition = "density"` and +#' 10 for `partition = "kmeans"`, the default of earlier versions. A number +#' is run under either kind and either `init`: `nstart = 10` gives the +#' density kind the starts it had when 10 was the default. +#' @param partition What the seeds minimise. `"density"` (default): the sum +#' of squared distances from the points to their nearest seed, each point +#' weighted by its local density to the power `density_power`; compact +#' cells that, at the default power, hold about the same number of points +#' each once `k` is above the number of dense places, and counts about as +#' uneven as `"kmeans"` gives below that. `"kmeans"`: the same sum +#' unweighted; compact cells whose counts are several times higher in +#' dense places than in sparse ones. It is the run of earlier versions, +#' whose default it was: [stats::kmeans()] from 10 random starts on the +#' rows as they come. Without the 'FNN' package the density kind +#' finds its weights by comparing every pair of distinct locations, so its +#' time grows with the square of their number; the seeds are the same, and +#' nothing stops the call. See "Details". +#' @param init How each start is drawn: `"random"` (`k` distinct locations +#' at random, as [stats::kmeans()] draws them) or `"kmeans++"` (the seeds +#' one at a time, each in proportion to its squared distance from those +#' already drawn, times its weight under `partition = "density"`). `NULL` +#' (default) is each kind's own rule: `"random"` for `partition = +#' "kmeans"`, the run this function has always made, and `"kmeans++"` for +#' `partition = "density"`. Under `partition = "kmeans"` from random +#' starts the points are clustered in the order their rows come in; with +#' `init = "kmeans++"`, and under `partition = "density"`, the rows are put +#' in coordinate order first, so the seeds do not depend on their order. +#' @param density_power For `partition = "density"`: the power the local +#' density is raised to for a point's weight, from 0 to 2. Default 1, which +#' evens out the cell counts once the cells outnumber the dense places; 0 +#' weights every point alike, and values +#' above 1 give the cells of dense places fewer points than those of +#' sparse places. Setting it under `partition = "kmeans"` is a warning. +#' @param density_k For `partition = "density"`: the number of nearest +#' neighbours the local density is read from. Default 8. +#' @param iter_max The most iterations a start runs for: a single positive +#' whole number, or `NULL` (default) for the kind's own limit, 50 for +#' `partition = "kmeans"` and 100 steps of Lloyd's iteration for +#' `partition = "density"`. Under `partition = "density"`, and with `init = +#' "kmeans++"`, a kept start that was cut off at the limit is a warning of +#' class `"spatialkit_not_converged"`; `partition = "kmeans"` from random +#' starts keeps the warning [stats::kmeans()] gives. #' @return An sf object of **at most** `k` cluster-centre POINTs (fewer when #' `k` exceeds the number of distinct positions), with `seed_id` and -#' `method = "kmeans"` columns matching [get_voronoi_seeds()]. +#' `method = "kmeans"` columns matching [get_voronoi_seeds()], and +#' `attr(, "cover")`, the convex hull of `points_sf` (an sfc in its CRS). +#' Seeds placed with `partition = "density"` or `init = "kmeans++"`, and +#' the scored centres of a profile of the density kind or from random +#' starts, also carry `attr(, "partition")`: a list with +#' `kind`, `init`, `density_power` and `density_k`, and for seeds this +#' call placed `iter`, `iter_max` and `converged` (the iterations the kept +#' start took, the limit, and whether it stopped before the limit). +#' [build_tessellation()] returns the list as `params$partition`. Seeds +#' with no such record are plain k-means: from random starts when this call +#' placed them, or the scored centres of a k-means profile from k-means++ +#' starts. When `k` is a +#' [select_resolution()] result that carries `count_rule`, or a profile +#' built with an `estimate`, the seeds carry that record as +#' `attr(, "count_rule")`, with `scored_cells` `TRUE` for the scored +#' centres and `FALSE` for centres this call fits itself at that count +#' (see [get_voronoi_seeds()]). #' @family tessellation #' @examples #' library(sf) @@ -362,25 +766,53 @@ get_voronoi_seeds <- function(boundary = NULL, #' data.frame(x = 5e5 + runif(100, 0, 1000), y = 5e6 + runif(100, 0, 1000)), #' coords = c("x", "y"), crs = 32632 #' ) -#' seeds <- voronoi_seeds_kmeans(pts, k = 8) +#' seeds <- voronoi_seeds_kmeans(pts, k = 8) # density-weighted, 3 starts #' nrow(seeds) # at most 8: one seed per non-empty cluster #' seeds # the cluster centres, as an sf POINT layer in the points' CRS +#' # The k-means seeds of earlier versions: 10 random starts. +#' voronoi_seeds_kmeans(pts, k = 8, partition = "kmeans") #' @export -voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { +voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = NULL, + partition = c("density", "kmeans"), init = NULL, + density_power = 1, density_k = 8, iter_max = NULL) { .assert_sf(points_sf, "POINT", "points_sf") + partition_given <- !missing(partition) + # The density settings the caller supplied (see get_voronoi_seeds()). + density_given <- c(if (!missing(density_power)) "density_power", + if (!missing(density_k)) "density_k") + partition <- match.arg(partition) + # How the count was set, when a selection or a profile gives it. + count_rule <- NULL + # The kind of partition and how its starts are drawn (R/partition.R). A + # density setting given where no density partition is built is reported + # below, once it is known what the call returns: scored centres passed as + # `k` may be density ones. + part <- .seed_partition_args(partition, init, density_power, density_k, + "voronoi_seeds_kmeans") + if (!is.null(iter_max)) + iter_max <- .check_whole_count(iter_max, "iter_max", "voronoi_seeds_kmeans", + "iterations", null_ok = TRUE) # A select_resolution() result or a resolution_profile() as `k`: the # centres of the partition it scored at the chosen count when it carries # them (as get_voronoi_seeds() does), otherwise the count alone. if (inherits(k, c("resolution_selection", "resolution_profile"))) { k_res <- .resolve_cell_count(k, "k", "voronoi_seeds_kmeans") if (!is.null(k_res$seeds)) { + .scored_partition_unused(k_res$seeds, part, part$init_given, partition_given, + arg = "k", caller = "voronoi_seeds_kmeans", + density_given = density_given) out <- .use_scored_seeds(k_res$seeds, like = points_sf, cloud = NULL, - caller = "voronoi_seeds_kmeans") + caller = "voronoi_seeds_kmeans", cover = points_sf, + count_rule = k_res$count_rule) attr(out, "n_from") <- k_res$from return(out) } k <- k_res$n + count_rule <- k_res$count_rule } + # No scored centres: `density_power` or `density_k` set under partition = + # "kmeans" is read by nothing in this call. + .warn_density_unused(part, "voronoi_seeds_kmeans") # `k` was never validated here, unlike get_voronoi_seeds(), which routes # `n` through .resolve_cell_count(): k = NA or a length-2 vector aborted on # the clamp below, k above .Machine$integer.max became NA through @@ -390,9 +822,13 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { max = .Machine$integer.max, what = "a single positive number of seeds") + # NULL is the kind's own number of starts. It is replaced here, where the + # argument is first read: a call that returned scored centres above never + # read it, and does not evaluate it. + nstart <- .seed_nstart(nstart, part$kind) .check_scalar(nstart, "nstart", "voronoi_seeds_kmeans", min = 1, max = .Machine$integer.max, - what = "a single positive number of k-means restarts") + what = "NULL or a single positive number of k-means restarts") # Project to metric CRS if lon/lat to make k-means distance-faithful. A # CRS-less layer gets the lon/lat heuristic ensure_projected() applies @@ -437,9 +873,30 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) - km <- stats::kmeans(coords, centers = k_use, iter.max = 50, - nstart = as.integer(nstart)) - cent <- as.data.frame(km$centers); names(cent) <- c("x", "y") + # One engine for every kind (.partition_centres()). The default is the run + # this function has always made, stats::kmeans() from `nstart` random + # starts on the rows as they come; any other kind or starting rule works on + # the rows in coordinate order, so its seeds do not depend on the order of + # `points_sf`. Iterations per start, unless `iter_max` sets them: 50 for + # k-means, as always, and 100 Lloyd steps for the density kind (see + # resolution_profile()). + limit <- if (!is.null(iter_max)) iter_max + else if (identical(part$kind, "density")) 100L else 50 + fit <- .partition_centres(coords, k_use, partition = part$kind, init = part$init, + nstart = as.integer(nstart), iter.max = limit, + density_power = density_power, density_k = density_k, + sort_rows = !part$present, one_call = part$present) + if (is.null(fit)) + stop(sprintf(paste0("voronoi_seeds_kmeans(): no start gave a partition of the %d ", + "point(s) into %d cells."), n, k_use), call. = FALSE) + if (identical(part$kind, "density")) + .warn_empty_seeds(fit$size, "voronoi_seeds_kmeans") + # The default run's own warning from stats::kmeans() stands as it is; the + # other paths say it with a class. + if (!part$present && isFALSE(fit$converged)) + .warn_not_converged("voronoi_seeds_kmeans", k_use, fit$iter, limit, part$kind, + "iter_max") + cent <- as.data.frame(.seed_centre_matrix(fit, coords)); names(cent) <- c("x", "y") result <- sf::st_as_sf(cent, coords = c("x", "y"), crs = sf::st_crs(pts_for_km)) # Back to the input's own coordinates if we projected: its CRS, or for a # CRS-less layer the degrees it was given in, CRS-less again @@ -452,7 +909,18 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { # functions are drop-in interchangeable. result$seed_id <- seq_len(nrow(result)) result$method <- "kmeans" - result + # The kind that built the regions, when it is not this function's own + # default (see `partition`); seeds with no record are plain k-means. + if (!part$present) + attr(result, "partition") <- c(part[.partition_fields()], + list(iter = as.integer(fit$iter), + iter_max = as.integer(limit), + converged = isTRUE(fit$converged))) + # How the count was set, when a selection or a profile gave it and its + # scored centres were not at hand: these centres were fitted here. + result <- .count_rule_put(result, count_rule, scored_cells = FALSE) + # The ground the centres stand for: the hull of the points clustered. + .set_cover(result, points_sf) } @@ -483,7 +951,10 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { #' loop over [set.seed()]. #' @return An sf object of `k` random POINTs (fewer only in the degenerate #' case above), with `seed_id` and `method = "random"` columns matching -#' [get_voronoi_seeds()]. +#' [get_voronoi_seeds()], and `attr(, "cover")`, the polygons of `boundary`: +#' [build_tessellation()] clips the cells to it (grown by 2 percent of its +#' diagonal) when no `boundary` is passed there, so the cells fill the area +#' the seeds were drawn in and not only the seeds' own hull. #' @family tessellation #' @examples #' library(sf) @@ -523,7 +994,8 @@ voronoi_seeds_random <- function(boundary, k, set_seed = NULL) { # functions are drop-in interchangeable. out$seed_id <- seq_len(nrow(out)) out$method <- "random" - out + # The ground the seeds stand for: the area they were drawn in. + .set_cover(out, boundary) } @@ -559,22 +1031,197 @@ voronoi_seeds_random <- function(boundary, k, set_seed = NULL) { #' @param cloud Optional sf POINT layer to assign to the seeds for #' \code{attr(, "kmeans")}; \code{NULL} for none. #' @param caller Name for the log line. +#' @param cover The ground the centres stand for, as \code{.set_cover()} +#' takes it: the boundary, the points being seeded, or the hull the profile +#' kept of the points it was computed on. \code{NULL} falls back to a +#' cover the centres themselves carry (\code{attr(seeds, "cover")}), and +#' to none when there is none. +#' @param count_rule The record of how the count was set +#' (\code{.resolve_cell_count()}'s \code{count_rule}), or \code{NULL} for a +#' count that has none. #' @return An sf POINT layer with \code{seed_id} and \code{method = "kmeans"} -#' columns, and \code{attr(, "kmeans")} when \code{cloud} is given. +#' columns, \code{attr(, "kmeans")} when \code{cloud} is given, +#' \code{attr(, "cover")} when a cover is known, and +#' \code{attr(, "count_rule")}, marked \code{scored_cells = TRUE}, when +#' \code{count_rule} is a record: these are the centres the profile scored. #' @keywords internal #' @noRd -.use_scored_seeds <- function(seeds, like, cloud, caller) { +.use_scored_seeds <- function(seeds, like, cloud, caller, cover = NULL, count_rule = NULL) { nstart <- attr(seeds, "nstart", exact = TRUE) + # The kind that built the scored partition, when the profile recorded one. + rec <- attr(seeds, "partition", exact = TRUE) + if (is.null(cover)) cover <- attr(seeds, "cover", exact = TRUE) moved <- .seeds_in_crs_of(seeds, like) out <- sf::st_sf(seed_id = seq_len(nrow(moved)), method = "kmeans", geometry = sf::st_geometry(moved)) - .log_info(paste0("%s(): returning the %d centres of the partition resolution_profile() ", - "scored at that count (the best of %s k-means++ restarts) rather than ", - "running a new k-means, so their Voronoi cells are the cells the ", - "criteria judged. Pass the count as a number for a fresh k-means."), - caller, nrow(out), if (is.null(nstart)) "its" else format(nstart)) + if (is.null(rec)) + .log_info(paste0("%s(): returning the %d centres of the partition resolution_profile() ", + "scored at that count (the best of %s k-means++ restarts) rather than ", + "running a new k-means, so their Voronoi cells are the cells the ", + "criteria judged. Pass the count as a number for a fresh k-means."), + caller, nrow(out), if (is.null(nstart)) "its" else format(nstart)) + else + .log_info(paste0("%s(): returning the %d centres of the partition resolution_profile() ", + "scored at that count (partition = \"%s\", the best of %s) rather ", + "than running a new one, so their Voronoi cells are the cells the ", + "criteria judged. Pass the count as a number for a fresh run."), + caller, nrow(out), rec$kind, .partition_label(rec, nstart)) if (!is.null(cloud)) attr(out, "kmeans") <- .scored_seeds_record(cloud, seeds, nstart) - out + if (!is.null(rec)) attr(out, "partition") <- rec + # These are the centres the profile scored at the count, so their Voronoi + # cells are the cells its numbers describe, and the record says so. + out <- .count_rule_put(out, count_rule, scored_cells = TRUE) + # The centres lie inside the points they were fitted to; their cells have + # to reach the points' own hull, not the centres'. + .set_cover(out, cover) +} + + +#' The number of starts a seeding function runs +#' +#' \code{NULL} is the kind's own number: the 10 the seeding functions have +#' always run for \code{partition = "kmeans"}, whichever starting rule, and +#' \code{.NSTART_DENSITY} for \code{partition = "density"}. Anything else +#' is returned as it is, for the caller's check. It is called where the +#' argument is first read, so that a call on a path that never reads the +#' number of starts does not evaluate it. +#' +#' @param nstart The argument: \code{kmeans_nstart} of +#' \code{get_voronoi_seeds()}, \code{nstart} of +#' \code{voronoi_seeds_kmeans()}. +#' @param kind The kind in force, \code{"kmeans"} or \code{"density"}. +#' @return \code{nstart}, or the kind's own number when it is \code{NULL}. +#' @keywords internal +#' @noRd +.seed_nstart <- function(nstart, kind) { + if (!is.null(nstart)) return(nstart) + if (identical(kind, "density")) .NSTART_DENSITY else 10 +} + + +#' The partition arguments of a seeding function, resolved +#' +#' The seeding functions have always run \code{stats::kmeans()} from random +#' starts, so \code{init = NULL}, their default, means each kind's own rule: +#' random starts for \code{partition = "kmeans"}, which leaves every existing +#' call as it was, and k-means++ for \code{partition = "density"}. +#' +#' @param partition The kind, already matched. +#' @param init \code{NULL}, \code{"kmeans++"} or \code{"random"}. +#' @param density_power,density_k,caller See \code{.check_partition_args()}. +#' @return The list of \code{.check_partition_args()}, with \code{present} +#' (whether this is the run the function has always made) and +#' \code{init_given} (\code{init} as matched, \code{NULL} when it was not +#' set). A density setting that \code{partition = "kmeans"} does not read +#' is not reported here: the caller does that with +#' \code{.warn_density_unused()} once it knows the call runs a k-means, +#' since scored centres passed as the count may be density ones. +#' @keywords internal +#' @noRd +.seed_partition_args <- function(partition, init, density_power, density_k, caller) { + init <- .match_init(init, caller, null_ok = TRUE) + rule <- if (!is.null(init)) init + else if (identical(partition, "density")) "kmeans++" else "random" + part <- .check_partition_args(partition, rule, density_power, density_k, caller, + warn_unused = FALSE) + part$init_given <- init + part$present <- identical(part$kind, "kmeans") && identical(rule, "random") + part +} + + +#' Say that scored centres are returned in place of the kind asked for +#' +#' A selection or a profile passed as the count carries the centres of the +#' partition it scored, and those are what the seeding functions return. A +#' \code{partition}, an \code{init} or a density setting the same call names +#' is then not used; when it differs from what built the scored partition, +#' the caller would otherwise get regions of one kind having asked for +#' another. +#' +#' The kind in force in a call is the one its \code{partition} resolves to: +#' the kind the caller supplied, or else the function's own. The density +#' settings a call names follow from it. With the density kind supplied, +#' both, at the values in force: naming the kind names its settings. With +#' the density kind in force as the function's own, those the caller supplied +#' (\code{density_given}). With the k-means kind, those not at their +#' defaults. So a call that names no partition argument is told nothing, +#' whichever kind and settings the profile was built with. +#' +#' @param seeds The scored centres. +#' @param part The call's partition arguments, as +#' \code{.seed_partition_args()} resolved them. +#' @param init The call's \code{init}, which may be \code{NULL}. +#' @param partition_given Whether \code{partition} was set in the call. +#' @param arg,caller Names for the message. +#' @param density_given Which of \code{density_power} and \code{density_k} +#' the caller supplied, by name. +#' @return \code{NULL}, invisibly; a warning of class +#' \code{spatialkit_partition_unused} when the two differ. +#' @keywords internal +#' @noRd +.scored_partition_unused <- function(seeds, part, init, partition_given, arg, caller, + density_given = character(0)) { + rec <- attr(seeds, "partition", exact = TRUE) + # A profile with no record is k-means from k-means++ starts. + kind <- if (is.null(rec)) "kmeans" else rec$kind + rule <- if (is.null(rec)) "kmeans++" else rec$init + # The density kind in force as the function's own, and not as a kind the + # call named. + own_density <- identical(part$kind, "density") && !isTRUE(partition_given) + # The density settings the call names. + named <- if (own_density) density_given + else if (identical(part$kind, "density")) c("density_power", "density_k") + else part$unused + differs <- (isTRUE(partition_given) && !identical(part$kind, kind)) || + (!is.null(init) && !identical(init, rule)) || + # Scored density centres, with another power or neighbour count named. + (identical(kind, "density") && + (("density_power" %in% named && + !isTRUE(all.equal(part$asked$density_power, rec$density_power))) || + ("density_k" %in% named && + !identical(as.integer(part$asked$density_k), as.integer(rec$density_k))))) || + # Scored k-means centres, with a density setting supplied to a function + # whose own kind is the density kind: the setting is read by nothing. + (!identical(kind, "density") && own_density && length(density_given) > 0L) + if (differs) + .warn_classed("spatialkit_partition_unused", + paste0("%s(): `%s` carries the centres of the partition the profile ", + "scored, built with partition = \"%s\" from %s starts%s, and ", + "those are returned: the `partition`, `init` and density ", + "settings of this call are not used. Build the profile with ", + "them, or pass the count as a number for a fresh run."), + caller, arg, kind, if (identical(rule, "random")) "random" else "k-means++", + if (identical(kind, "density")) + sprintf(" (power %s, %d neighbours)", format(rec$density_power), + as.integer(rec$density_k)) + else "", + data = list(kind = kind, init = rule)) + # Scored k-means centres with a density setting named and no kind: the + # setting is read by nothing, as in a fresh k-means run. + else if (!identical(kind, "density")) + .warn_density_unused(part, caller) + invisible(NULL) +} + + +#' The centres of an engine fit as the matrix the seeds are built from +#' +#' A \code{stats::kmeans()} fit hands over its own \code{centers}, row and +#' column names included, as the seeding functions always read it. The +#' density kind's centres get the same names, so the layers of seeds have one +#' structure whatever built them. +#' +#' @param fit A \code{.partition_centres()} result. +#' @param xy The coordinate matrix that was clustered. +#' @return A matrix of centres with \code{1..k} as row names. +#' @keywords internal +#' @noRd +.seed_centre_matrix <- function(fit, xy) { + if (!is.null(fit$km)) return(fit$km$centers) + cen <- fit$centers + dimnames(cen) <- list(as.character(seq_len(nrow(cen))), colnames(xy)[1:2]) + cen } @@ -632,6 +1279,15 @@ voronoi_seeds_random <- function(boundary, k, set_seed = NULL) { cl <- as.integer(sf::st_nearest_feature(cloud[ok, ], seeds)) d2 <- rowSums((xy[ok, , drop = FALSE] - sxy[cl, , drop = FALSE])^2) } + # Seeds of the density kind are weighted means, which do not sit at the + # mean of their cell's points; the within-cell sum of squares is then taken + # about that mean, as the profile and a fresh run report it. A k-means + # seed is the mean of the cell it was fitted to. + if (identical(attr(seeds, "partition", exact = TRUE)$kind, "density") && length(cl)) { + xo <- xy[ok, , drop = FALSE] + mu <- rowsum(xo, cl) / as.numeric(table(cl)) + d2 <- rowSums((xo - mu[as.character(cl), , drop = FALSE])^2) + } withinss <- as.numeric(tapply(d2, factor(cl, levels = seq_len(k)), sum, default = 0)) list( cluster = cl, diff --git a/R/spatialkit-package.R b/R/spatialkit-package.R index e1a4cd2a..d46e68e4 100644 --- a/R/spatialkit-package.R +++ b/R/spatialkit-package.R @@ -56,6 +56,31 @@ #' seen; this is what tells you where the map should not be believed. #' } #' +#' Two choices are the user's, one in choosing a resolution (step 1) and one +#' in aggregating (step 4), and each has an argument. They are arguments of +#' \code{\link{resolution_profile}()} and \code{\link{select_resolution}()}, +#' which choose a count for a cell value, and of +#' \code{\link{summarize_by_cell}()}; \code{determine_optimal_levels()} +#' takes neither. +#' The first is the cell value to report, \code{estimate}: the plain mean of +#' a cell's observations, or the pooled value, which is that mean pulled +#' toward the mean of the cells around it. +#' \code{\link{resolution_profile}()} scores a count for the value it is +#' given, and \code{\link{summarize_by_cell}()} reports the value it is +#' given and warns when the count was chosen for the other one. The second +#' is the size, \code{obs_per_cell}: how many observations a cell is to hold +#' on average. For pooled values the size sets the count +#' (\code{\link{select_resolution}(criterion = "size")}); for plain means the +#' lowest leave-one-out error can set it (\code{criterion = "loo"}). Each +#' has a default: the pooled value, and a size of 4.5, from which +#' \code{select_resolution()}'s default criterion, \code{"auto"}, sets the +#' count. \code{estimate = "mean"} in the summary gives the frame it +#' returned before the argument existed. \code{estimate = NULL, +#' obs_per_cell = NULL} in the profile gives the earlier ladder and its +#' columns, and with \code{partition = "kmeans"} the earlier regions as +#' well: the profile it returned before. The seeding functions take +#' \code{partition = "kmeans"} for their earlier seeds. +#' #' Supporting these throughout, \code{\link{ensure_projected}()} and #' \code{\link{coerce_to_points}()} handle coordinate reference systems and #' geometry coercion, and \code{\link{estimate_sac_range}()} estimates the @@ -124,6 +149,44 @@ #' Kish's exchangeable-correlation model, not taken from a reference. #' The derivation and its measured coverage are in the section "Spatial #' autocorrelation and standard-error bias" of that help page. +#' \item The size of 4.5 observations per cell that +#' \code{select_resolution(criterion = "size")} and +#' \code{resolution_profile(obs_per_cell = "auto")} take when none is +#' given: a convention, a size at which most cells hold several +#' observations. +#' \item The density kind of partition, kept from the best of 3 +#' k-means++ starts, in \code{resolution_profile()}, +#' \code{get_voronoi_seeds()} and \code{voronoi_seeds_kmeans()}: a +#' convention, a kind that puts small cells where observations are dense +#' and holds the counts per cell close once the cells outnumber the +#' dense places, from a number of starts that keeps the cost of a fit +#' to every row down. \code{partition = "kmeans"} gives plain k-means. +#' \item The 8 nearest cells a pooled value is pulled toward in +#' \code{summarize_by_cell(estimate = "pooled")}: a convention, a count +#' large enough to give a cell a stable target. It is not an argument. +#' \item The 5 residuals expected beyond each end of the interval of +#' \code{summarize_by_cell(obs_level = )}, below which the warning +#' \code{spatialkit_few_residuals} is raised: a convention for when the +#' ends of an interval read from quantiles are unstable. +#' \item The 30 values beyond one per cell below which +#' \code{spatialkit_pool_few_df} is raised: a convention for when the +#' spread inside the cells, which every own weight rests on, is estimated +#' from little. +#' \item The 2 percent by which the cells have to beat one mean for the +#' whole layer, in leave-one-out error, for a response to be called +#' \code{structured} by \code{summarize_by_cell(estimate = "pooled")}: +#' a convention, and the default of \code{tol} in +#' \code{select_resolution()}, which sets the same margin there. +#' \item The two work limits, +#' \code{getOption("spatialkit.exact_pairs_max", 2e9)} pairs for a search +#' made without the \pkg{FNN} package and +#' \code{getOption("spatialkit.fit_work_max", 1e10)} point-to-centre +#' comparisons for the fits of a ladder that \code{obs_per_cell} sets: +#' conventions that keep a search or a fit whose cost grows with the +#' square of the rows or of the cells from starting. Above one, +#' \code{resolution_profile()} and \code{cell_values_at()} stop with an +#' error, and \code{summarize_by_cell()} returns \code{NA} pooled columns +#' with a warning. #' } #' #' @section Where to start: diff --git a/R/tessellation.R b/R/tessellation.R index 83003e67..2ceb4a0e 100644 --- a/R/tessellation.R +++ b/R/tessellation.R @@ -112,11 +112,13 @@ #' @param boundary The argument (may be \code{NULL}). #' @param caller Function name for the message. #' @param label Argument name for the message. +#' @param what The kind of layer, for the message. #' @keywords internal #' @noRd -.check_boundary_arg <- function(boundary, caller, label = "boundary") { +.check_boundary_arg <- function(boundary, caller, label = "boundary", + what = "polygon") { if (is.null(boundary) || inherits(boundary, c("sf", "sfc"))) return(invisible()) - stop(sprintf("%s(): `%s` must be an sf or sfc polygon layer%s.", caller, label, + stop(sprintf("%s(): `%s` must be an sf or sfc %s layer%s.", caller, label, what, .tess_hint(boundary, "$boundary")), call. = FALSE) } @@ -164,6 +166,42 @@ } +#' Seeds moved onto the centres they stand for +#' +#' Seeds whose record sits beside the centres a profile scored +#' (\code{.scored_centres()}), in the record's CRS (or both without one), +#' and that are those centres (\code{.seeds_as_centres()}): each seed is +#' given the coordinates of its centre as the record holds them. Seeds that +#' went through another CRS and back differ from them by the rounding of the +#' two transformations, a few millimetres at most, and the cells drawn on +#' them would put a point the same distance from two centres that far +#' inside one cell. +#' +#' @param pts The seeds, in the working CRS. +#' @param rec Their record of the count, or \code{NULL}. +#' @return \code{pts}, its rows, columns and order unchanged, with the +#' centres' coordinates when the seeds are the centres; \code{pts} as it +#' is otherwise. +#' @keywords internal +#' @noRd +.seeds_at_centres <- function(pts, rec) { + cen <- .scored_centres(rec) + if (is.null(cen) || nrow(pts) != nrow(cen)) return(pts) + crs <- sf::st_crs(pts) + if (is.na(crs) != is.na(rec$crs) || (!is.na(crs) && !isTRUE(crs == rec$crs))) return(pts) + if (!all(sf::st_geometry_type(pts, by_geometry = TRUE) == "POINT")) return(pts) + xy <- unname(sf::st_coordinates(pts)[, 1:2, drop = FALSE]) + of <- .seeds_as_centres(xy, cen) + if (is.null(of)) return(pts) + at <- integer(nrow(cen)) + at[of] <- seq_len(nrow(cen)) + if (identical(xy, cen[at, , drop = FALSE])) return(pts) + geom <- sf::st_geometry(sf::st_as_sf(data.frame(x = cen[at, 1L], y = cen[at, 2L]), + coords = c("x", "y"), crs = crs)) + sf::st_set_geometry(pts, geom) +} + + #' Keep the polygonal part of each clipped cell #' #' \code{st_intersection()} returns a GEOMETRYCOLLECTION for a cell whose @@ -205,6 +243,251 @@ } +# ----------------------------------------------------------------------------- +# Cover: the ground the cells of a seeded tessellation have to hold +# ----------------------------------------------------------------------------- +# +# Voronoi cells built with no boundary are clipped to the convex hull of their +# generators, grown by 2% of its diagonal. That is right when the generators +# are the observations. When they are seeds (k-means centres, random points in +# a boundary, the centres a resolution profile scored) the seeds lie inside +# the data, so the cells stopped short of it: 3,000 uniform points lost 72% of +# their rows to assign_features_to_polygons() at 4 seeds, 25% at 25 and 4% at +# 100, and the route build_tessellation()'s own warnings prescribe (profile, +# selection, seeds, cells) lost 15% at 41 cells, with no condition raised. +# The rows lost are the edge of the study area, so the cell means moved too. +# +# The seeders therefore attach the ground the seeds stand for as +# attr(seeds, "cover"): the boundary they were drawn in, or the convex hull of +# the points they were clustered from. create_voronoi_polygons() derives its +# default boundary from that (or from a `cover` argument) instead of from the +# seeds' own hull. + +#' The cover of a layer, as geometry in the layer's own CRS +#' +#' For a polygon layer, its polygons as they are; for anything else (points), +#' the planar convex hull of the coordinates as given, which is a POINT or a +#' LINESTRING when they have no area. The hull is taken on the bare numbers, +#' CRS set aside: the question is which coordinates it has to hold, and sf +#' would otherwise build a spherical hull for lon/lat. +#' +#' @param x An sf or sfc layer, or \code{NULL}. +#' @return An sfc in the CRS of \code{x}, or \code{NULL} when \code{x} is not +#' a layer or holds no usable geometry. +#' @keywords internal +#' @noRd +.cover_of <- function(x) { + if (is.null(x) || !inherits(x, c("sf", "sfc"))) return(NULL) + g <- sf::st_geometry(x) + g <- g[!sf::st_is_empty(g)] + if (!length(g)) return(NULL) + types <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) + if (all(types %in% c("POLYGON", "MULTIPOLYGON"))) return(g) + xy <- sf::st_coordinates(g) + if (ncol(xy) < 2L) return(NULL) + xy <- xy[is.finite(xy[, 1L]) & is.finite(xy[, 2L]), 1:2, drop = FALSE] + if (!nrow(xy)) return(NULL) + sf::st_convex_hull(sf::st_sfc(sf::st_multipoint(unname(xy)), crs = sf::st_crs(g))) +} + + +#' Put a cover in the CRS its generators are now in +#' +#' The cover came with the generators (as an attribute of the seeds, or as +#' the `cover` argument), and the builders then project, stamp or transform +#' the generators. This moves the cover the same way. +#' \itemize{ +#' \item A cover with no CRS is read in the coordinates of the generators +#' as they arrived: a cover the seeders attached was built there, and a +#' `cover` argument is documented so. When the generators had no CRS +#' either and have one now, they were either stamped as they were or +#' taken as lon/lat and projected; which, is read off whether their +#' coordinates moved, and the cover is given the same reading. +#' \item When the generators are still in an unnamed planar space, so is +#' the cover, whatever CRS it carried. +#' \item When both have a CRS and they differ, the cover is transformed. A +#' polygon or hull gets vertices along its edges first (in its own +#' coordinates, a two-hundredth of its extent apart), because a straight +#' edge in one CRS is not straight in another: across the conterminous +#' United States the middle of a lon/lat hull's northern edge would +#' otherwise sit hundreds of kilometres inside the points it was drawn +#' round, once projected. +#' } +#' +#' @param cover sfc geometry of the cover. +#' @param pts_in The generators as the calling function received them. +#' @param pts_now The generators in the working CRS. +#' @return The cover as an sfc in the CRS of \code{pts_now}. +#' @keywords internal +#' @noRd +.cover_follow <- function(cover, pts_in, pts_now) { + g <- sf::st_geometry(cover) + crs_in <- sf::st_crs(pts_in); crs_now <- sf::st_crs(pts_now) + if (is.na(sf::st_crs(g))) { + if (!is.na(crs_in)) { + g <- sf::st_set_crs(g, crs_in) + } else if (!is.na(crs_now)) { + b0 <- unname(as.numeric(sf::st_bbox(pts_in))) + b1 <- unname(as.numeric(sf::st_bbox(pts_now))) + moved <- !isTRUE(all.equal(b0, b1)) + g <- sf::st_set_crs(g, if (moved) sf::st_crs(4326) else crs_now) + } + } + if (is.na(crs_now)) return(sf::st_set_crs(g, NA)) + if (sf::st_crs(g) == crs_now) return(g) + types <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) + if (!all(types %in% c("POINT", "MULTIPOINT"))) { + bb <- sf::st_bbox(g) + ext <- max(as.numeric(bb[["xmax"]] - bb[["xmin"]]), + as.numeric(bb[["ymax"]] - bb[["ymin"]])) + if (is.finite(ext) && ext > 0) { + crs_g <- sf::st_crs(g) + g <- sf::st_set_crs(sf::st_segmentize(sf::st_set_crs(g, NA), + dfMaxLength = ext / 200), crs_g) + } + } + sf::st_transform(g, crs_now) +} + + +#' The boundary a cover gives, in the working CRS +#' +#' The cover's convex hull (points) or its polygons, grown by 2 percent of +#' its diagonal, the margin a hull of the generators themselves gets. The +#' margin is what keeps every observation inside after the cover has been +#' through a CRS change: an unbuffered hull of 2,628 North Carolina tracts, +#' built in their CRS and used in the seeds', left 5 of them outside at 10 +#' seeds. Generators the cover does not hold keep their ground: their hull +#' is added, so the cells are never smaller than the ones the generators' +#' own hull gave. +#' +#' @param cover The cover as an sfc in the CRS of \code{pts}. +#' @param pts The generators in the working CRS. +#' @return A one-row sf polygon layer, or \code{NULL} when the cover gives no +#' usable polygon; \code{attr(, "none_inside")} is \code{TRUE} when the +#' cover held none of the generators and was set aside for that. +#' @keywords internal +#' @noRd +.cover_boundary <- function(cover, pts) { + build <- function() { + g <- cover[!sf::st_is_empty(cover)] + if (!length(g)) return(NULL) + types <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) + u <- if (all(types %in% c("POLYGON", "MULTIPOLYGON"))) + sf::st_union(.safe_make_valid(g)) + else sf::st_convex_hull(sf::st_combine(g)) + grow_of <- function(x) { + bb <- sf::st_bbox(x) + 0.02 * max(sqrt(as.numeric(bb[["xmax"]] - bb[["xmin"]])^2 + + as.numeric(bb[["ymax"]] - bb[["ymin"]])^2), 1) + } + grow <- grow_of(u) + if (!is.finite(grow)) return(NULL) + gp <- sf::st_geometry(pts) + gp <- gp[!sf::st_is_empty(gp)] + # Judged against the grown cover, so a generator on its edge is inside. + inside <- lengths(sf::st_intersects( + gp, suppressWarnings(sf::st_buffer(u, dist = grow)))) > 0L + if (length(gp) && !any(inside)) return(structure(list(), none_inside = TRUE)) + if (!all(inside)) { + u <- sf::st_union(c(u, sf::st_convex_hull(sf::st_combine(gp)))) + grow <- grow_of(u) + } + b <- .safe_make_valid(suppressWarnings(sf::st_buffer(u, dist = grow))) + b <- sf::st_sf(geometry = sf::st_sfc(sf::st_union(b)[[1L]], crs = sf::st_crs(pts))) + ok <- nrow(b) == 1L && !sf::st_is_empty(b) && + as.character(sf::st_geometry_type(b)) %in% c("POLYGON", "MULTIPOLYGON") && + isTRUE(suppressWarnings(as.numeric(sf::st_area(sf::st_set_crs(b, NA)))) > 0) + if (ok) b else NULL + } + tryCatch(build(), error = function(e) NULL) +} + + +#' Does this layer look like seeds placed inside some other data? +#' +#' \code{get_voronoi_seeds()}, \code{voronoi_seeds_kmeans()} and +#' \code{voronoi_seeds_random()} return \code{seed_id} and \code{method} +#' columns, and the k-means route adds \code{attr(, "kmeans")} or +#' \code{attr(, "n_from")}. Only k-means and random seeds count: they are +#' placed inside a cloud or a boundary by construction. Seeds a caller +#' provided (\code{method = "provided"}) may be the observation sites +#' themselves, whose own hull is the right boundary. +#' @keywords internal +#' @noRd +.looks_like_seeds <- function(x) { + if (!is.null(attr(x, "kmeans", exact = TRUE)) || + !is.null(attr(x, "n_from", exact = TRUE))) return(TRUE) + if (!inherits(x, "sf") || !all(c("seed_id", "method") %in% names(x))) return(FALSE) + m <- x[["method"]] + is.character(m) && length(m) > 0L && all(m %in% c("kmeans", "random")) +} + + +#' Count the points of a `cover` argument that the cells do not hold +#' +#' Wherever `cover` does not size the cells it is only checked against them: +#' Voronoi cells built in a `boundary`, a grid (laid over the boundary) and +#' Delaunay triangles (which span the hull of the generators). Polygon covers +#' are not checked. The warning says what set the cells for the method that +#' ran, and what to change: the advice to leave `boundary` out so the cells +#' are built to hold `cover` is true of Voronoi cells only, and was given for +#' a grid, and for triangles built with no boundary at all. +#' +#' @param cover The `cover` argument (or \code{NULL}). +#' @param cells The cells, in the working CRS. +#' @param pts_in,pts_now The generators as received and in the working CRS. +#' @param caller Function name for the warning. +#' @param method The tessellation method the cells were built with. +#' @param clipped For \code{method = "triangles"}: were the triangles clipped +#' to a boundary? +#' @return \code{NULL} when there is nothing to check, else the count. +#' @keywords internal +#' @noRd +.cover_points_outside <- function(cover, cells, pts_in, pts_now, caller, + method = "voronoi", clipped = FALSE) { + if (is.null(cover) || !inherits(cover, c("sf", "sfc"))) return(NULL) + g <- sf::st_geometry(cover) + types <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) + if (!length(g) || !all(types %in% c("POINT", "MULTIPOINT"))) return(NULL) + g <- tryCatch(.cover_follow(g, pts_in, pts_now), error = function(e) NULL) + if (is.null(g)) return(NULL) + cells_cmp <- cells + if (is.na(sf::st_crs(g)) != is.na(sf::st_crs(cells_cmp))) + cells_cmp <- sf::st_set_crs(cells_cmp, sf::st_crs(g)) + idx <- .build_point_cell_index(sf::st_sf(geometry = g), cells_cmp, warn = FALSE) + n_out <- sum(is.na(idx) & !sf::st_is_empty(g)) + if (n_out > 0L) { + # What set the cells, and what would make them hold the cover, by method. + why <- switch( + method, + voronoi = "`boundary` sets the cells, and it does not hold them", + triangles = if (isTRUE(clipped)) + paste0("the triangles span the convex hull of `points_sf`, clipped to ", + "`boundary`, and that does not hold them") + else "the triangles span the convex hull of `points_sf`, and it does not hold them", + "the grid is laid over `boundary`, and it does not hold them") + fix <- switch( + method, + voronoi = paste0("Pass a boundary that holds the observations, or leave ", + "`boundary` out so the cells are built to hold `cover`"), + triangles = paste0("`cover` sizes nothing for method = \"triangles\": use ", + "method = \"voronoi\" with no `boundary`, whose cells are ", + "built to hold `cover`, or triangulate points whose hull ", + "holds the observations"), + paste0("`cover` sizes nothing for a grid: pass a boundary that holds the ", + "observations")) + .warn_classed("spatialkit_unassigned", paste0( + "%s(): %d of the %d `cover` point(s) (%.1f%%) fall outside every cell: ", + "%s. They will be left out by assign_features_to_polygons(). %s; ", + "`params$cover_outside` records the count."), + caller, n_out, length(g), 100 * n_out / length(g), why, fix, + data = list(n = n_out, total = length(g))) + } + n_out +} + + #' Project a lon/lat boundary for a grid of equal-area cells #' #' The CRS ensure_projected() picks for distances, unless that CRS distorts @@ -278,7 +561,8 @@ #' #' It is not the target [build_tessellation()] derives on its own: #' `method = "voronoi"` without a boundary clips to the convex hull of the -#' points buffered by 2 percent of its diagonal, and there `expand` is always +#' points (or of their `cover`, for seeds) buffered by 2 percent of its +#' diagonal, and there `expand` is always #' a distance. A bounding box over a non-rectangular point cloud includes #' corners with no data, so a hex or square grid laid over it has cells that #' hold no points; pass the study-area polygon when there is one. @@ -419,13 +703,15 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' #' @param pts An sf POINT object. #' @param cells_sf An sf polygon object with a `cell_id` column. +#' @param warn Raise the classed warning when points fall outside every cell. +#' \code{FALSE} for a caller that reports the count in its own words. #' @return Integer vector of cell_id values, one per row of `pts`, with #' \code{NA} for points that fall outside every cell, carrying the #' nearest-cell repairs as \code{attr(, "snapped")} (\code{n}, \code{which}, #' \code{distance}); the callers move that record into \code{params}. #' @keywords internal #' @noRd -.build_point_cell_index <- function(pts, cells_sf) { +.build_point_cell_index <- function(pts, cells_sf, warn = TRUE) { n <- nrow(pts) if (n == 0L || nrow(cells_sf) == 0L) return(structure(rep(NA_integer_, n), @@ -484,11 +770,28 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS snapped$n, max(snapped$distance)) } } + # A point in no cell is a point every summary built from `index` leaves + # out, so it is a warning the caller can catch, with the count; it was an + # INFO line in the temp log, and nothing on the result held the number. n_out <- sum(is.na(index)) - if (n_out > 0L) - .log_info(paste0("build_tessellation(): %d of %d point(s) fall outside every ", - "cell and are recorded as NA in `index`."), - n_out, length(index)) + if (n_out > 0L && isTRUE(warn)) { + # A point with empty geometry is in no cell either, but for want of a + # location, not for lying outside the study area. + n_empty <- sum(is.na(index) & sf::st_is_empty(sf::st_geometry(pts))) + .warn_classed("spatialkit_unassigned", paste0( + "build_tessellation(): %d of %d point(s) (%.1f%%) fall in no cell and ", + "are NA in `index`; `params$n_outside` holds the count. %s"), + n_out, length(index), 100 * n_out / length(index), + if (n_empty == n_out) + "They have empty geometry, so there is no location to index." + else paste0( + if (n_empty > 0L) sprintf("%d of them have empty geometry; the rest lie ", n_empty) + else "They lie ", + "outside the ground the cells cover (the boundary, grown by `expand`). ", + "Pass a boundary that holds them, or a larger `expand`, if they belong ", + "to the study area."), + data = list(n = n_out, total = length(index))) + } attr(index, "snapped") <- snapped index @@ -523,6 +826,20 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' centroid instead, so cast to POINT, or take centroids, first if one cell #' per feature is what you want. #' +#' With no `boundary` the cells are clipped to a boundary derived from the +#' data. For observations that is their own convex hull grown by 2 percent of +#' its diagonal, so every observation has a cell. Seeds are different: k-means +#' centres, random points in a study area and the centres a resolution +#' profile scored all lie inside the ground they stand for, and cells clipped +#' to the hull of the seeds leave the edge of that ground uncovered (on 3,000 +#' uniform points, 72 percent of them at 4 seeds, 25 percent at 25 and 4 +#' percent at 100). The boundary is therefore derived from the `cover` when +#' there is one: the argument, or the cover the seeding functions attach to +#' their result. A layer that looks like seeds and has neither a boundary nor +#' a cover (seeds bound with `rbind()`, which drops the attribute, or built +#' by hand) gets the seeds' own hull and a warning of class +#' `"spatialkit_no_cover"`. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometries. Points with #' no CRS whose coordinates look like lon/lat (the heuristic #' [ensure_projected()] applies, with its warning) are taken as EPSG:4326 @@ -537,6 +854,23 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' with CRS-less points taken as lon/lat) is read as lon/lat when its #' coordinates fit the lon/lat envelope, and refused with an error #' otherwise. +#' @param cover Optional sf or sfc layer the cells have to hold, read when +#' there is no `boundary`: the observations (points), or a polygon. The +#' boundary is then derived from it instead of from `points_sf`: the convex +#' hull of the cover's points, or its polygons, grown by 2 percent of the +#' diagonal. This is what seeds need, because seeds lie inside the data they +#' stand for and their own hull stops short of it (see "Details"). +#' When `NULL`, the cover the seeding functions attach is used +#' (`attr(points_sf, "cover")`, set by [get_voronoi_seeds()], +#' [voronoi_seeds_kmeans()] and [voronoi_seeds_random()]). A cover with no +#' CRS is read in the coordinates of `points_sf`, and one in another CRS is +#' transformed. A generator outside the cover keeps its ground (the hull of +#' the generators is added); a cover that holds none of the generators is +#' set aside with a warning. With a `boundary`, the boundary sets the cells +#' and `cover` is only checked against them: the number of its points that +#' fall outside every cell is returned as `params$cover_outside`, with a +#' warning of class `"spatialkit_unassigned"` when it is not 0 (a polygon +#' cover is not checked). #' @param expand Numeric; absolute distance, in the working CRS's units, by #' which the boundary (or the hull derived from the points) is grown before #' the diagram is built. With `clip = TRUE` the cells are clipped to the @@ -552,18 +886,56 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned #' in: the cells are built in the local projected CRS [ensure_projected()] #' picks for the points, so they are nearest-point cells on the ground, and -#' are then transformed, with long edges densified. +#' are then transformed, with long edges densified. Seeds that are the +#' centres a profile scored are built in the CRS the profile worked in +#' instead (see "Seeds a profile scored"). #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. +#' @section Seeds a profile scored: +#' The seeds of a [select_resolution()] result, and the seeds +#' [get_voronoi_seeds()] or [voronoi_seeds_kmeans()] return for one, are the +#' centres [resolution_profile()] scored, and their record of the count +#' (`attr(, "count_rule")`) says so (`scored_cells = TRUE`) and holds the +#' centres in the CRS the profile worked in. Unless a projected `crs` is +#' given, their cells are built in that CRS, whatever CRS the seeds arrive +#' in (degrees, or the CRS of a boundary they were placed in), and returned +#' in it, or in a geographic `crs` when one is given. When the seeds are +#' those centres (as many, each at a different centre, within a thousandth +#' of its distance from the next nearest), each is first put at its centre +#' as the record holds it, so rounding the seeds took on in another CRS +#' does not move an edge. The cells are then the cells each row was scored +#' in, and [assign_features_to_polygons()] gives a point on an edge between +#' two of them the cell the profile scored it in. #' @return A list with \code{cells}, \code{index}, \code{boundary}, #' \code{method} and \code{params}. \code{index} holds one \code{cell_id} #' per row of \code{points_sf}, and \code{NA} for a point that falls outside #' every cell, which means outside the study area (grown by \code{expand} #' when it is positive), so a summary built from it counts only the points -#' the tessellation actually covers. \code{boundary} is the boundary the -#' cells were built in: the one supplied or derived, grown by -#' \code{expand}. +#' the tessellation actually covers. Such points are counted in +#' \code{params$n_outside}, and a warning of class +#' \code{"spatialkit_unassigned"} gives their number. \code{boundary} is +#' the boundary the cells were built in: the one supplied or derived, grown +#' by \code{expand}. \code{params$boundary_source} says where it came +#' from: \code{"boundary"} (the argument), \code{"cover"} (the +#' \code{cover} argument), \code{"seeds' cover"} (the cover attached to +#' \code{points_sf}) or \code{"points"} (the hull of \code{points_sf} +#' itself). \code{params$cover_outside} is the number of \code{cover} +#' points outside every cell when a point \code{cover} was given with a +#' \code{boundary}, and \code{NULL} otherwise. \code{params$partition} is +#' present when \code{points_sf} is a layer of seeds that records the kind +#' of partition that placed it (\code{attr(points_sf, "partition")}, see +#' \code{\link{get_voronoi_seeds}()}): the same list, so the cells say what +#' built them. Seeds of plain k-means record nothing, and \code{params} +#' then has no such element; neither has it for points that are not seeds. +#' \code{params$count_rule} is present when \code{points_sf} carries the +#' record of how its count was set (\code{attr(points_sf, "count_rule")}: +#' the seeds of a \code{\link{select_resolution}()} result, or seeds a +#' seeding function placed from one): the same list, which the cells carry +#' too as \code{attr(cells, "count_rule")}. +#' \code{\link{assign_features_to_polygons}()} copies it to the rows it +#' assigns, and \code{\link{summarize_by_cell}()} checks its result +#' against it. #' @family tessellation #' @examples #' library(sf) @@ -578,16 +950,48 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' @export create_voronoi_polygons <- function( points_sf, boundary = NULL, expand = 0, clip = TRUE, - keep_duplicates = FALSE, crs = NULL, quiet = FALSE + keep_duplicates = FALSE, crs = NULL, quiet = FALSE, cover = NULL ) { .assert_sf(points_sf, c("POINT", "MULTIPOINT"), "points_sf") .check_boundary_arg(boundary, "create_voronoi_polygons") + .check_boundary_arg(cover, "create_voronoi_polygons", label = "cover", + what = "point or polygon") if (nrow(points_sf) < 1) stop("create_voronoi_polygons(): `points_sf` has no rows.") .msg <- function(...) if (!quiet) message(...) + # The ground the cells have to hold, when there is no boundary: the `cover` + # argument, else the cover a seeding function attached. Read before the + # points are moved; it is put in the working CRS where it is used. + pts_in <- points_sf + cover_geom <- NULL + cover_from <- NULL + if (!is.null(cover)) { + cover_geom <- sf::st_geometry(cover) + cover_from <- "cover" + } else if (inherits(attr(points_sf, "cover", exact = TRUE), c("sf", "sfc"))) { + cover_geom <- sf::st_geometry(attr(points_sf, "cover", exact = TRUE)) + cover_from <- "seeds' cover" + } + seed_like <- .looks_like_seeds(points_sf) + # The kind of partition that placed the seeds, when they record one (see + # get_voronoi_seeds()): handed on in `params`, so the cells say what built + # them. Read before the points are moved, as the cover is. + seed_partition <- attr(points_sf, "partition", exact = TRUE) + # The record of how the seeds' count was set, when they carry one (a + # selection's seeds, or seeds placed from a selection or a profile): handed + # on in `params` and on the cells, so the summary can check that it is + # given the cells and rows the count was scored on. + seed_rule <- .count_rule_get(points_sf) # A layer as `crs` means its CRS (as ensure_projected(target_crs =) reads # it); passed on as it was, it stopped with "the condition has length > 1". if (inherits(crs, c("sf", "sfc"))) crs <- sf::st_crs(crs) + # Seeds that are the centres a profile scored are drawn in the CRS it + # scored them in (the record's), unless a projected `crs` names another: + # their cells are then the cells each row was scored in. Drawn in a CRS + # ensure_projected() picked for the seeds' own extent, or in the CRS of a + # boundary in another projection, a row near an edge could sit in the + # neighbouring cell. + scored_crs <- .scored_crs(seed_rule) pts <- points_sf crs_out <- NULL if (!is.null(crs)) { @@ -600,7 +1004,7 @@ create_voronoi_polygons <- function( # the degree-sized hull buffer below as metres. if (.is_geographic_crs(crs)) { crs_out <- sf::st_crs(pts) - pts <- ensure_projected(pts) + pts <- if (is.null(scored_crs)) ensure_projected(pts) else sf::st_transform(pts, scored_crs) if (!is.null(boundary)) boundary <- .align_crs(boundary, pts) } } else { @@ -614,7 +1018,11 @@ create_voronoi_polygons <- function( # were tessellated as planar, silently (18% of locations at 55N in a # cell that was not their nearest point's), while build_tessellation() # projected the very same points. - if (.is_longlat(pts) || is.na(sf::st_crs(pts))) pts <- ensure_projected(pts) + if (!is.null(scored_crs) && !is.na(sf::st_crs(pts))) { + if (!isTRUE(sf::st_crs(pts) == scored_crs)) pts <- sf::st_transform(pts, scored_crs) + } else if (.is_longlat(pts) || is.na(sf::st_crs(pts))) { + pts <- ensure_projected(pts) + } if (!is.null(boundary)) { # A CRS-less boundary with points just taken as lon/lat gets the same # assumption, when its coordinates allow it, as in build_tessellation(). @@ -632,7 +1040,38 @@ create_voronoi_polygons <- function( boundary <- .align_crs(boundary, pts) } } - + # In the record's CRS, seeds that are its centres stand where the record + # holds them, so the edges between their cells are where the profile drew + # them, whatever rounding a trip through another CRS left on the seeds. + pts <- .seeds_at_centres(pts, seed_rule) + + boundary_source <- "boundary" + if (is.null(boundary) && !is.null(cover_geom)) { + # From the cover: its hull or polygons, in the working CRS, grown by 2% of + # the diagonal (see .cover_boundary()). + from_cover <- .cover_boundary( + tryCatch(.cover_follow(cover_geom, pts_in, pts), + error = function(e) sf::st_sfc(crs = sf::st_crs(pts))), + pts) + if (inherits(from_cover, "sf")) { + .msg(sprintf(paste0("create_voronoi_polygons(): deriving boundary from %s ", + "(its hull or polygons, grown by 2%% of the diagonal)."), + if (identical(cover_from, "cover")) "`cover`" + else "the cover the seeds carry")) + boundary <- from_cover + boundary_source <- cover_from + } else { + .warn_classed("spatialkit_no_cover", paste0( + "create_voronoi_polygons(): %s %s, so it is set aside and the boundary ", + "is derived from `points_sf` itself. Pass the observations, or the ", + "study area, as `cover` or `boundary`."), + if (identical(cover_from, "cover")) "`cover`" else "the cover the seeds carry", + if (isTRUE(attr(from_cover, "none_inside"))) + "holds none of the points in `points_sf` (the two are in different places)" + else "gives no polygon in the working CRS") + seed_like <- FALSE # said already; not twice + } + } if (is.null(boundary)) { .msg("create_voronoi_polygons(): deriving boundary via convex hull of points.") hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(pts))) @@ -640,9 +1079,27 @@ create_voronoi_polygons <- function( # degenerate slivers along the convex hull boundary. bb <- sf::st_bbox(hull) diag <- sqrt((bb$xmax - bb$xmin)^2 + (bb$ymax - bb$ymin)^2) + # Seeds with nothing to say what ground they stand for: the cells stop + # at the seeds' own hull, which is inside the data. This is the case the + # cover exists to prevent, so it is said when it still happens. + if (seed_like) { + flat <- !isTRUE(suppressWarnings( + as.numeric(sf::st_area(sf::st_set_crs(hull, NA)))) > 0) + .warn_classed("spatialkit_no_cover", paste0( + "create_voronoi_polygons(): `points_sf` is a layer of seeds (%d) with ", + "no `boundary` and no cover, so the cells are clipped to the seeds' own ", + "convex hull grown by 2%% of its diagonal%s. Seeds lie inside the data ", + "they stand for, so observations near its edge will fall in no cell. ", + "Pass the study area as `boundary`, or the observations as `cover`."), + nrow(pts), + if (flat) paste0(", and that hull has no area (one seed, two, or seeds ", + "on a line): the cells are a sliver") + else "") + } hull <- suppressWarnings(sf::st_buffer(hull, dist = 0.02 * max(diag, 1))) hull_sfc <- sf::st_sfc(hull, crs = sf::st_crs(pts)) boundary <- sf::st_sf(geometry = hull_sfc) + boundary_source <- "points" } else { if (!any(sf::st_geometry_type(boundary) %in% c("POLYGON", "MULTIPOLYGON"))) stop("create_voronoi_polygons(): `boundary` must be polygonal.") @@ -697,8 +1154,13 @@ create_voronoi_polygons <- function( index <- .build_point_cell_index(pts, cells) snapped <- attr(index, "snapped") attr(index, "snapped") <- NULL + # With a boundary given, a point `cover` is checked against the cells. + cover_outside <- if (identical(boundary_source, "boundary")) + .cover_points_outside(cover, cells, pts_in, pts, "create_voronoi_polygons", + method = "voronoi") + else NULL - list( + res <- list( cells = .to_output_crs(cells, crs_out), index = index, # The boundary the cells were built in and clipped to. With expand > 0 @@ -708,8 +1170,25 @@ create_voronoi_polygons <- function( boundary = .to_output_crs(boundary_expanded, crs_out), method = "voronoi", params = list(clip = clip, expand = expand, keep_duplicates = keep_duplicates, - snapped = snapped) + snapped = snapped, + # Points of `points_sf` in no cell, where the boundary came + # from, and (with a boundary and a point cover) the cover + # points in no cell. + n_outside = sum(is.na(index)), + boundary_source = boundary_source, + cover_outside = cover_outside) ) + # Present only for seeds that record their kind; `params` is otherwise the + # list it always was. + if (is.list(seed_partition) && !is.null(seed_partition$kind)) + res$params$partition <- seed_partition + # The same for the record of the count, which the cells carry as well: set + # on them here, after they are in the CRS they are returned in. + if (!is.null(seed_rule)) { + res$params$count_rule <- seed_rule + res$cells <- .count_rule_put(res$cells, seed_rule) + } + res } # ----------------------------------------------------------------------------- @@ -1092,8 +1571,12 @@ create_grid_polygons <- function( #' own to lay a grid over and error without it; supply the study-area polygon, #' or build one from the points with [clip_target_for()]. **Optional** for #' `method = "voronoi"` and `method = "triangles"`, which derive their extent -#' from the points themselves and use `boundary` only to clip the result when -#' `clip = TRUE`. When exactly one of `points_sf` and `boundary` has a CRS, +#' from the points themselves (for `"voronoi"`, from `cover` when there is +#' one) and use `boundary` only to clip the result when +#' `clip = TRUE`. When `points_sf` holds seeds and not the observations, +#' pass the study area here or the observations as `cover`: seeds lie +#' inside the data, and cells clipped to the seeds' own hull leave its edge +#' uncovered. When exactly one of `points_sf` and `boundary` has a CRS, #' the other is interpreted in it, with a warning. CRS-less points, and a #' CRS-less boundary given with projected points, are read as #' [harmonize_crs()] does; CRS-less points that do not look like lon/lat @@ -1111,16 +1594,31 @@ create_grid_polygons <- function( #' one cell per input point and \code{"triangles"} one triangle per #' neighbouring triple, so neither has a count to set, and both warn that the #' argument was ignored. For a Voronoi cell count, place the seeds with -#' \code{\link{get_voronoi_seeds}()} and tessellate those. For hex +#' \code{\link{get_voronoi_seeds}()} and tessellate those, passing the +#' study area as \code{boundary} or the observations as \code{cover} +#' (seeds made from a boundary or from \code{sample_points} carry their +#' cover with them). For hex #' grids the target is adjusted for packing density; the actual count after #' clipping to an irregular boundary may differ noticeably. Besides a #' number, this accepts what the level-selection step returned: the integer #' vector of ranked candidates from \code{\link{determine_optimal_levels}()} #' (its first element is used), a \code{\link{select_resolution}()} result -#' (its \code{$best}), or a \code{\link{resolution_profile}()} (read with -#' \code{select_resolution()} at its default criterion). The count used +#' (its \code{$best}), or a \code{\link{resolution_profile}()}. A profile +#' built without an \code{estimate} is read with +#' \code{select_resolution()} by \code{cp}; one built with +#' \code{estimate} is read by \code{criterion = "auto"}, the rule that +#' goes with its estimate: a size for pooled values, the lowest +#' leave-one-out error for plain means. The count used #' is returned as \code{params$approx_n_cells} and where it came from as #' \code{params$approx_n_cells_from} (\code{NULL} for a plain number). +#' A count read off a selection or a profile raises a warning of class +#' \code{"spatialkit_bound_chosen"} when its optimum sits on a bound of the +#' ladder and one of class \code{"spatialkit_no_structure"} when one cell +#' for the whole layer scores as well (for a count set by a size: when +#' cells of that size predict no better than one mean; the count stands); +#' a profile without an estimate and with no \code{cp} to read +#' is an error (class \code{"spatialkit_no_default_criterion"} when another +#' criterion is finite). See \code{\link{resolution_profile}()}. #' A count read off a profile or selection is a number of k-means cells: #' every one occupied, and small where the points are dense. A lattice #' lays that many equal cells over the whole boundary, so on clustered @@ -1133,13 +1631,34 @@ create_grid_polygons <- function( #' \code{get_voronoi_seeds(method = "kmeans", n = , sample_points = )}: #' given the \code{select_resolution()} result or the profile itself, it #' returns the centres of the partition the profile scored, whose Voronoi -#' cells are the cells the criteria judged. +#' cells are the cells the criteria judged. Seeds made that way carry the +#' hull of \code{sample_points} as their cover, so the cells built on them +#' hold every point; made with neither \code{sample_points} nor a boundary, +#' they carry the hull of the points the profile was computed on. #' @param cellsize Numeric cell size, in the units of the working CRS. Read by #' \code{method = "hex"} and \code{"square"} only; the other two methods warn #' that it was ignored. When both \code{cellsize} and \code{approx_n_cells} #' are given, \code{cellsize} wins and \code{approx_n_cells} is ignored with #' a logged warning; supply one or the other. With a geographic \code{crs} #' it is in that CRS's degrees, and the grid is laid in degrees. +#' @param cover Optional sf or sfc layer the cells have to hold: the +#' observations (points), or a polygon. Read by `method = "voronoi"` when +#' there is no `boundary`: the boundary is then derived from the cover (the +#' convex hull of its points, or its polygons, grown by 2 percent of the +#' diagonal) instead of from the hull of `points_sf`. Pass it when +#' `points_sf` holds seeds. When `NULL`, the cover the seeding functions +#' attach to their result is used (`attr(points_sf, "cover")`: the boundary +#' the seeds were drawn in, or the hull of the points they were clustered +#' from), so `build_tessellation(voronoi_seeds_kmeans(obs, k))` holds every +#' observation without it; `rbind()` of seed layers drops that attribute. +#' Seeds with neither a boundary nor a cover are tessellated over their own +#' hull, with a warning of class `"spatialkit_no_cover"`. A cover with no +#' CRS is read in the coordinates of `points_sf`; one in another CRS is +#' transformed. With a `boundary` (and for the other methods) the cover +#' sizes nothing: when it is a point layer, the number of its points that +#' fall outside every cell is returned as `params$cover_outside`, with a +#' warning of class `"spatialkit_unassigned"` when it is not 0. See +#' [create_voronoi_polygons()]. #' @param expand Buffer distance, in the working CRS's units, by which the #' Voronoi boundary is grown before the diagram is built. Applied by #' `method = "voronoi"` only; the `"hex"`, `"square"` and `"triangles"` @@ -1167,7 +1686,19 @@ create_grid_polygons <- function( #' over a near-global extent, say); the grid is then laid, and the points #' indexed, in the equal-area CRS `ensure_projected(purpose = "area")` picks #' for the boundary, with a logged warning, as [create_grid_polygons()] -#' does, so the cells stay equal-area. +#' does, so the cells stay equal-area. Seeds that carry the record of how +#' their count was set (`attr(, "count_rule")`) were scored in the CRS the +#' profile worked in, each row in the cell of its nearest centre. When the +#' record says they are the centres it scored and holds them (the seeds of +#' a [select_resolution()] result, or those a seeding function returns for +#' one), `method = "voronoi"` builds their cells in that CRS, with no +#' `crs` or a geographic one, whatever CRS the seeds arrive in, and +#' returns them there or in the geographic `crs`; see +#' [create_voronoi_polygons()], section "Seeds a profile scored". Voronoi +#' cells built in another projected CRS, named here, are the nearest-seed +#' cells of that CRS, so a row near a boundary can fall in the +#' neighbouring cell, and [summarize_by_cell()] then reports that the +#' cells are not the ones scored. #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. @@ -1182,16 +1713,45 @@ create_grid_polygons <- function( #' median cell width of a cell is snapped to it. That covers points #' sitting exactly on a shared edge, and leaves points outside the study #' area as `NA`. A summary built from `index` therefore counts only the -#' points the tessellation actually covers.} +#' points the tessellation actually covers. When any point is `NA`, a +#' warning of class `"spatialkit_unassigned"` gives the number +#' (`tryCatch(spatialkit_unassigned = )` catches it; the condition +#' carries `n` and `total`).} #' \item{`boundary`}{The boundary used (possibly derived and/or #' reprojected, and for `"voronoi"` grown by `expand`).} #' \item{`method`}{The method actually used.} #' \item{`params`}{The parameters the tessellation was built with, plus #' `snapped`, the record of that nearest-cell repair: a list with `n`, #' `which` (row positions in `points_sf`) and `distance` (how far -#' outside every cell each sat, in CRS units). For `"hex"` and +#' outside every cell each sat, in CRS units); `n_outside`, the number +#' of points of `points_sf` that fall in no cell (the `NA`s of +#' `index`); and `cover_outside`, the number of `cover` points in no +#' cell when a point `cover` was checked against the cells (`NULL` +#' otherwise). For `"voronoi"` also `boundary_source`, where the +#' boundary came from: `"boundary"`, `"cover"`, `"seeds' cover"` or +#' `"points"`, and, when `points_sf` is a layer of seeds that records +#' the kind of partition that placed it (see [get_voronoi_seeds()]), +#' `partition`: that record, a list with `kind`, `init`, +#' `density_power` and `density_k` and, for seeds a seeding function +#' placed itself, `iter`, `iter_max` and `converged`. The cells are +#' the Voronoi cells of the seeds whatever kind placed them. For +#' `"hex"` and #' `"square"` also `cells_occupied` and `cells_empty`, the number of -#' cells that hold at least one point and that hold none.} +#' cells that hold at least one point and that hold none. +#' `count_rule`, the record of how the count was set, is present on +#' two paths, and the cells then carry it too as +#' `attr(cells, "count_rule")`. For `"voronoi"`, when `points_sf` +#' carries one (`attr(points_sf, "count_rule")`: the seeds of a +#' [select_resolution()] result, or seeds [get_voronoi_seeds()] or +#' [voronoi_seeds_kmeans()] placed from one): the record as the seeds +#' carry it, whose `scored_cells` says whether these are the cells the +#' profile scored. For `"hex"` and `"square"`, when `approx_n_cells` +#' is a selection that carries a record, or a profile built with an +#' `estimate`, and no `cellsize` is given: that record with +#' `scored_cells` `FALSE`, since a lattice at that count is not the +#' partition the profile scored. [assign_features_to_polygons()] +#' copies the record to the rows it assigns, and [summarize_by_cell()] +#' checks its result against it.} #' } #' @family tessellation #' @examples @@ -1208,7 +1768,8 @@ build_tessellation <- function( points_sf, boundary = NULL, method = c("voronoi", "triangles", "hex", "square"), approx_n_cells = NULL, cellsize = NULL, expand = 0, - clip = TRUE, keep_duplicates = FALSE, crs = NULL, quiet = FALSE + clip = TRUE, keep_duplicates = FALSE, crs = NULL, quiet = FALSE, + cover = NULL ) { .msg <- function(...) if (!quiet) message(...) method <- match.arg(method) @@ -1229,9 +1790,20 @@ build_tessellation <- function( stop(paste0(conditionMessage(e), hint), call. = FALSE) }) .check_boundary_arg(boundary, "build_tessellation") + .check_boundary_arg(cover, "build_tessellation", label = "cover", + what = "point or polygon") # A layer as `crs` means its CRS (as ensure_projected(target_crs =) reads # it); passed on as it was, it stopped with "the condition has length > 1". if (inherits(crs, c("sf", "sfc"))) crs <- sf::st_crs(crs) + # The points as they arrived, and the cover that came with them: the + # `cover` argument, else the one a seeding function attached. Both are + # read before the points are moved, and the cover is moved the same way + # where it is used (see .cover_follow()). + points_in <- points_sf + cover_attr <- attr(points_sf, "cover", exact = TRUE) + cover_geom <- if (!is.null(cover)) sf::st_geometry(cover) + else if (inherits(cover_attr, c("sf", "sfc"))) sf::st_geometry(cover_attr) + else NULL # The level-selection step's own answer is accepted here, so the count # need not be carried between the two calls by hand. @@ -1266,7 +1838,9 @@ build_tessellation <- function( "one cell per input point: to control the cell count, place", "seeds with get_voronoi_seeds() and tessellate those (given a", "select_resolution() result or a profile as `n`, it returns the", - "centres of the partition that was scored), or use", + "centres of the partition that was scored), passing the study", + "area as `boundary` or the observations as `cover` so the cells", + "hold every observation, or use", "method = \"hex\" or \"square\".") else paste("Delaunay produces one triangle per neighbouring triple, so", @@ -1282,6 +1856,14 @@ build_tessellation <- function( boundary_ll <- NULL # the boundary before alignment, for that check pts_out <- NULL # the points in `crs_out`, for the triangles projected_msg <- FALSE + # Seeds that are the centres a profile scored are tessellated in the CRS + # it scored them in (the record's), unless a projected `crs` names + # another, so their Voronoi cells are the cells each row was scored in. + # ensure_projected() picks a CRS for the seeds' own extent, which on a + # wide lon/lat layer is not the one it picked for the points profiled, and + # seeds placed in a boundary's CRS arrive in that one. + scored_crs <- if (identical(method, "voronoi")) .scored_crs(.count_rule_get(points_sf)) + else NULL if (!is.null(crs)) { points_sf <- .transform_or_stamp(points_sf, crs, "points_sf", "build_tessellation") if (!is.null(boundary)) @@ -1301,7 +1883,8 @@ build_tessellation <- function( crs_out <- sf::st_crs(points_sf) pts_out <- points_sf boundary_ll <- boundary - points_sf <- ensure_projected(points_sf) + points_sf <- if (is.null(scored_crs)) ensure_projected(points_sf) + else sf::st_transform(points_sf, scored_crs) lonlat_work <- TRUE if (!is.null(boundary)) boundary <- .align_crs(boundary, points_sf) } @@ -1324,12 +1907,24 @@ build_tessellation <- function( if (!is.null(boundary) && lonlat_in && is.na(sf::st_crs(boundary))) boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(points_sf), "build_tessellation") - if (lonlat_in || is.na(sf::st_crs(points_sf))) + # Seeds that are the centres a profile scored, in a CRS: the record's. + to_scored <- !is.null(scored_crs) && !is.na(sf::st_crs(points_sf)) + if (!to_scored && (lonlat_in || is.na(sf::st_crs(points_sf)))) points_sf <- ensure_projected(points_sf) projected_msg <- lonlat_in assumed <- attr(points_sf, "crs_assumed") lonlat_work <- lonlat_in || identical(assumed, "EPSG:4326") - if (!is.null(boundary)) { + if (to_scored && !isTRUE(sf::st_crs(points_sf) == scored_crs)) { + # A boundary without a CRS is read in the CRS the seeds arrived in, and + # then moved to the record's with them. + seeds_in <- points_sf + points_sf <- sf::st_transform(points_sf, scored_crs) + projected_msg <- TRUE + if (!is.null(boundary)) { + boundary <- .resolve_crsless_pair(seeds_in, boundary, "build_tessellation")$boundary + boundary <- .align_crs(boundary, points_sf) + } + } else if (!is.null(boundary)) { # Only a POSITIVE assumption is a CRS. ensure_projected() records # "none" for CRS-less points it left planar, and st_crs("none") is an # error ("invalid crs: none"), so every method failed on CRS-less @@ -1352,9 +1947,13 @@ build_tessellation <- function( } } finish <- function(res) { - if (is.null(crs_out)) return(res) - res$cells <- .to_output_crs(res$cells, crs_out) - res$boundary <- .to_output_crs(res$boundary, crs_out) + if (!is.null(crs_out)) { + res$cells <- .to_output_crs(res$cells, crs_out) + res$boundary <- .to_output_crs(res$boundary, crs_out) + } + # The record of how the count was set, on the cells as they are returned. + if (!is.null(res$params$count_rule)) + res$cells <- .count_rule_put(res$cells, res$params$count_rule) res } if (!is.null(boundary)) { @@ -1395,11 +1994,40 @@ build_tessellation <- function( # ---- Voronoi ---- if (identical(method, "voronoi")) { - return(finish(create_voronoi_polygons( - points_sf = points_sf, boundary = boundary, expand = expand, + # The cover goes down already in the working CRS: read there against the + # projected points, a CRS-less cover would be stamped with the working + # CRS, degrees and all. A point `cover` goes as points, so its hull is + # taken in the working CRS and holds them exactly. + cover_now <- if (is.null(cover_geom)) NULL else + tryCatch(.cover_follow(cover_geom, points_in, points_sf), + error = function(e) NULL) + if (!is.null(cover_geom) && is.null(cover_now) && is.null(boundary)) + .warn_classed("spatialkit_no_cover", paste0( + "build_tessellation(): %s could not be put in the working CRS (%s), so ", + "it is set aside and the boundary is derived from `points_sf` itself. ", + "Pass the study area as `boundary`."), + if (!is.null(cover)) "`cover`" else "the cover the seeds carry", + .fold_crs_label(points_sf)) + # The cover goes down the way it came: a `cover` the caller passed as the + # argument, a cover the seeds carry as their attribute (now in the working + # CRS). Both used to go as the argument, so create_voronoi_polygons() + # named a `cover` nobody had passed, in its message ("deriving boundary + # from `cover`") and in its warning that the cover holds none of the + # points. + pts_v <- points_sf + attr(pts_v, "cover") <- if (is.null(cover)) cover_now else NULL + # The record of the kind that placed the seeds (attr(, "partition")) goes + # down on the points themselves: the projections above keep it. So does + # the record of how their count was set; it is put back here as the + # points arrived with it, whatever a projection did with it. + pts_v <- .count_rule_put(pts_v, .count_rule_get(points_in)) + res <- create_voronoi_polygons( + points_sf = pts_v, boundary = boundary, expand = expand, clip = clip, keep_duplicates = keep_duplicates, - crs = crs_arg, quiet = quiet - ))) + crs = crs_arg, quiet = quiet, + cover = if (is.null(cover)) NULL else cover_now + ) + return(finish(res)) } # ---- Hex / Square ---- @@ -1454,10 +2082,12 @@ build_tessellation <- function( "points, place seeds with get_voronoi_seeds(method = \"kmeans\", n = ", ", sample_points = ) and ", "use method = \"voronoi\": from a profile or selection those seeds are ", - "the centres of the partition it scored."), + "the centres of the partition it scored. Seeds made with `sample_points` ", + "carry the points' hull as their cover; otherwise pass the study area ", + "as `boundary`, or the observations as `cover`."), method, occupied, nrow(grid), format(approx_n_cells), approx_n_cells_from) - return(finish(list( + res <- list( cells = grid, index = index, boundary = boundary, method = method, params = list(approx_n_cells = approx_n_cells, approx_n_cells_from = approx_n_cells_from, @@ -1465,8 +2095,22 @@ build_tessellation <- function( clip = clip, keep_duplicates = keep_duplicates, expand = expand, snapped = snapped, cells_occupied = occupied, - cells_empty = nrow(grid) - occupied) - ))) + cells_empty = nrow(grid) - occupied, + n_outside = sum(is.na(index)), + cover_outside = .cover_points_outside( + cover, grid, points_in, points_sf, "build_tessellation", + method = method)) + ) + # A lattice sized by a selection or a profile carries the record of how + # that count was set, marked as not the cells the profile scored: a grid + # at that count is another partition. A `cellsize` sizes the lattice + # itself, and the count then sized nothing. + if (!is.null(n_cells$count_rule) && is.null(cellsize)) { + rule <- n_cells$count_rule + rule$scored_cells <- FALSE + res$params$count_rule <- rule + } + return(finish(res)) } # ---- Delaunay triangles ---- @@ -1576,7 +2220,12 @@ build_tessellation <- function( res <- finish(list( cells = tri_sf, index = index, boundary = boundary, method = "triangles", params = list(clip = clip, keep_duplicates = keep_duplicates, - expand = expand, snapped = snapped) + expand = expand, snapped = snapped, + n_outside = sum(is.na(index)), + cover_outside = .cover_points_outside( + cover, tri_sf, points_in, points_sf, "build_tessellation", + method = "triangles", + clipped = !is.null(boundary) && isTRUE(clip))) )) # The corners of a triangle are the points themselves. After the round # trip through the working projection they sit ~1e-14 degrees off the diff --git a/R/utils.R b/R/utils.R index 29153664..45bda03e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -668,6 +668,35 @@ # Row-indexed record attributes # --------------------------------------------------------------------------- +# --------------------------------------------------------------------------- +# estimate_sac_range()'s verdict "no spatial structure" +# --------------------------------------------------------------------------- +# estimate_sac_range() refuses a range in two ways that both say the modelled +# variable has no spatial structure: its test on the nearest neighbours finds +# none, or the variogram is flat at the lags it resolves. Either way the +# model it attaches is a pure nugget. resolution_profile(), +# select_resolution(), summarize_by_cell(deff = "variogram"), +# kriging_adequacy() and plot.sac_range() each act on that verdict, so the +# wording lives here and they ask .sac_no_structure() instead of matching a +# string of their own. +.sac_reason_no_structure <- + "no spatial structure detected at the nearest-neighbour scale" +.sac_reason_flat <- + "the empirical variogram is flat: no spatial structure at the lags resolved" + +# TRUE when `sac` is a range estimate refused because the variable shows no +# spatial structure. A reason that was not written by estimate_sac_range() +# (a stored object, a `sac` built by hand) counts when it says "no spatial +# structure", which both of the reasons above do. +.sac_no_structure <- function(sac) { + if (is.null(sac)) return(FALSE) + if (is.finite(suppressWarnings(as.numeric(sac))[1L])) return(FALSE) + why <- attr(sac, "rejected_reason", exact = TRUE) + is.character(why) && length(why) >= 1L && !is.na(why[1L]) && + grepl("no spatial structure", why[1L], fixed = TRUE) +} + + # Two functions hand back a layer with a record of what happened to its rows: # prep_model_data() records the rows it dropped, assign_features_to_polygons() # records the features that matched more than one polygon and had the tie-break @@ -699,7 +728,7 @@ # inconsistent with that. setOldClass(c("spatialkit_rows", "sf")) -.row_record_attrs <- c("dropped", "ties") +.row_record_attrs <- c("dropped", "ties", "unassigned") # Attach `value` as the `which` record of `x`, stamped and classed. # @@ -742,8 +771,9 @@ setOldClass(c("spatialkit_rows", "sf")) #' #' \code{\link{prep_model_data}()} and #' \code{\link{assign_features_to_polygons}()} return a layer with an -#' attribute recording what happened to its rows (\code{"dropped"} and -#' \code{"ties"} respectively). Those records describe the rows the layer was +#' attribute recording what happened to its rows (\code{"dropped"} for the +#' first; \code{"ties"} and \code{"unassigned"} for the second). Those +#' records describe the rows the layer was #' built with, and \code{[} on an \code{sf} object copies attributes through #' unchanged, which would leave a subset reporting its parent's numbers for a #' different set of rows. Subsetting therefore returns a plain layer with the @@ -761,8 +791,9 @@ setOldClass(c("spatialkit_rows", "sf")) #' and class, so the record then describes only the first input's rows: its #' \code{n_rows} no longer equals \code{nrow()} of the result. The #' package's own readers ignore a record whose \code{n_rows} does not match; -#' when reading \code{attr(x, "dropped")} or \code{attr(x, "ties")} yourself -#' from a layer that has been through such steps, check it the same way. +#' when reading \code{attr(x, "dropped")}, \code{attr(x, "ties")} or +#' \code{attr(x, "unassigned")} yourself from a layer that has been through +#' such steps, check it the same way. #' #' @param x A layer returned by \code{\link{prep_model_data}()} or #' \code{\link{assign_features_to_polygons}()}. @@ -777,7 +808,7 @@ setOldClass(c("spatialkit_rows", "sf")) #' resp = c(1, 2, NA, 4, 5), pred = c(1, 2, 3, 4, Inf)), #' coords = c("x", "y"), crs = 32632 #' ) -#' clean <- prep_model_data(dat, "resp", "pred") +#' clean <- prep_model_data(dat, "resp", "pred") # warns: 2 of 5 rows dropped #' attr(clean, "dropped")$n # 2 #' attr(clean[1:2, ], "dropped") # NULL -- the record does not follow #' @seealso \code{\link{prep_model_data}()} and @@ -891,3 +922,130 @@ setOldClass(c("spatialkit_rows", "sf")) else if (identical(msg, diag)) msg else paste0(msg, " (", diag, ")") } + + +#' Log a warning and raise it with a condition class +#' +#' \code{.warn_and_log()} with a condition class, so that a caller can catch +#' exactly this case with \code{tryCatch( = )} or +#' \code{withCallingHandlers()}, rather than by matching message text. Used +#' where code running many calls has to tell one outcome from another, and +#' for a warning that changes what a result means. Every classed warning of +#' the package is raised here: the helpers that fix a class +#' (\code{.warn_deff_fallback()}, \code{.warn_k_reduced()}, +#' \code{.aoa_warn_zero_threshold()} and the like) and \code{.gwr_warn()} +#' call it, so each is logged once and raised the same way. The classes are +#' named \code{spatialkit_}. +#' +#' @param class Character vector of condition classes, most specific first +#' (\code{"spatialkit_..."}). +#' @param fmt,... Passed to \code{sprintf()}. +#' @param data Named list of fields to carry on the condition (counts a +#' handler can read without parsing the message). +#' @keywords internal +#' @noRd +.warn_classed <- function(class, fmt, ..., data = list()) { + msg <- sprintf(fmt, ...) + # Taken over by the caller for the length of this call (see + # .answer_for_classed()): neither logged nor raised. + if (any(class %in% .answered_state$classes)) return(invisible(msg)) + # Already said, in these words, by an earlier call of the same run (see + # .once_per_run()): neither logged nor raised again. + if (.said_in_run(class, msg)) return(invisible(msg)) + # raising = TRUE: the warning below shows it, so a knitted document must + # not repeat the line as a message (see .sk_console_appender()). + .sk_log(logger::WARN, msg, raising = TRUE) + warning(do.call(warningCondition, + c(list(message = msg, class = class, call = NULL), data))) + invisible(msg) +} + + +# --------------------------------------------------------------------------- +# A classed warning the caller answers for itself +# --------------------------------------------------------------------------- +# cell_values_at() places its locations with assign_features_to_polygons() +# and reports a location in no polygon row by row, so that function's +# warning that no feature falls in any polygon says nothing new there. A +# calling handler can muffle the warning, but not the line .warn_classed() +# logs before it raises it, which reaches the console. A function that +# answers for a class itself opens a span here around the one call. While +# the span is open a warning of that class is neither logged nor raised; +# every other warning is logged and raised as usual. + +# The classes taken over by the open spans. +.answered_state <- new.env(parent = emptyenv()) + +#' Open a span in which a classed warning is neither logged nor raised +#' +#' @param classes Condition classes the caller answers for itself. +#' @return A function that closes the span; call it when the call the span +#' was opened for returns or stops (\code{tryCatch(, finally = )}). A span +#' opened inside another adds its classes to the outer one's, and closing +#' it leaves the outer one's. +#' @keywords internal +#' @noRd +.answer_for_classed <- function(classes) { + outer <- .answered_state$classes + .answered_state$classes <- union(outer, classes) + function() { + .answered_state$classes <- outer + invisible(NULL) + } +} + + +# --------------------------------------------------------------------------- +# One warning for a run of calls on the same rows +# --------------------------------------------------------------------------- +# compare_models_cv() runs one cv_*() per model and cv_block_size_sweep() one +# cv_spatial() per block size. Each of those prepares the layer for itself, +# so each found the same incomplete rows and raised the same +# "spatialkit_rows_dropped" warning: two for two models, eight for the default +# ladder. A function that makes such a run opens it here with the classes it +# wants said once. While the run is open, a warning of one of those classes +# whose text has been raised before is neither logged nor raised again; one +# with other text (other rows, another layer) is raised as usual. + +# The open run: `classes`, and `said`, the class and text of what was raised. +.once_state <- new.env(parent = emptyenv()) + +#' Open a run in which a classed warning is raised once per text +#' +#' @param classes Condition classes to raise once per distinct message. +#' @return A function that closes the run; register it with \code{on.exit()}. +#' A run opened inside another adds its classes to the outer one's and +#' shares its record, so the text is still raised once. +#' @keywords internal +#' @noRd +.once_per_run <- function(classes) { + outer <- .once_state$run + .once_state$run <- list(classes = union(outer$classes, classes), + said = outer$said %||% character(0)) + function() { + if (is.null(outer)) { + .once_state$run <- NULL + } else { + outer$said <- .once_state$run$said %||% outer$said + .once_state$run <- outer + } + invisible(NULL) + } +} + +# TRUE when a warning of this class and text was already raised in the open +# run; records it otherwise. FALSE with no run open or a class it does not +# cover. +.said_in_run <- function(class, msg) { + run <- .once_state$run + if (is.null(run) || !any(class %in% run$classes)) return(FALSE) + key <- paste(class[1L], msg, sep = "\r") + if (key %in% run$said) return(TRUE) + .once_state$run$said <- c(run$said, key) + FALSE +} + +# The two classed warnings prep_model_data() raises about a layer. A function +# that prepares one layer several times raises each once (.once_per_run()). +.prep_warning_classes <- c("spatialkit_rows_dropped", + "spatialkit_constant_predictor") diff --git a/README.Rmd b/README.Rmd index 7b54848a..3a553e55 100644 --- a/README.Rmd +++ b/README.Rmd @@ -52,16 +52,21 @@ error: the same observations can support materially different conclusions under different boundaries. `spatialkit` lets the data draw the boundaries. `get_voronoi_seeds()` places -seeds by k-means on the point cloud, so cell density follows sampling density. -`resolution_profile()` scores every candidate cell count against the spatial -structure of the observations, and `determine_optimal_levels()` reads one off -their clustering when they have any. `build_tessellation()` produces -Voronoi, hex, square or Delaunay cells clipped to your study area, with IDs that -stay stable when the input row order changes. `summarize_by_cell()` aggregates -onto them with a count and a standard error for every cell mean. When the cell -means stand in for a population mean, it corrects those standard errors for -within-cell autocorrelation, which on a correlated field can double them or -more. +seeds by density-weighted k-means on the point cloud, so cells are small where +observations are dense, and hold about the same number of observations each +once there are more cells than dense places. `resolution_profile()` scores the +cell count a number of observations per cell gives, 4.5 by default, by the +leave-one-out error of the cell values, and `select_resolution()` sets it; given +a ladder of counts the profile scores every one against the spatial structure +of the observations, and +`determine_optimal_levels()` reads one off their clustering when they have +any. `build_tessellation()` produces Voronoi, hex, square or Delaunay cells +clipped to your study area, with IDs that stay stable when the input row order +changes. `summarize_by_cell()` aggregates onto them with a count and a standard +error for every cell mean, and beside each mean a pooled value, the mean pulled +toward the cells around it. When the cell means stand in for a population mean, +it corrects those standard errors for within-cell autocorrelation, which on a +correlated field can double them or more. Redrawing boundaries is easy. Knowing whether the result means anything is the hard part, so the second half of the package is the evidence layer. Three model @@ -76,15 +81,16 @@ metres to a function expecting degrees. How many cells is a decision with visible consequences. The same field below is cut at three resolutions beside the raw observations: too coarse blurs the -hotspot, too fine chases noise with near-empty cells, and the middle count, the -one `resolution_profile()` rates most reliable, keeps the trend without tracing -the sampling pattern. It is a reading, not a verdict: the reliability of the -cell means stays within 2 percent of its best from 3 to 25 cells here, and the -sites are spread evenly, so there is no elbow for `determine_optimal_levels()` -to find. `vignette("resolution")` covers how that number is chosen and the four -criteria that disagree about it. +hotspot, too fine chases noise with cells of a handful of observations, and the +middle count, the one a ladder of counts from `resolution_profile(n_levels = )` +rates most reliable, keeps the trend without tracing the sampling pattern. It +is a reading, not a verdict: the reliability of the cell means stays within 2 +percent of its best from 2 to 15 cells here, and the sites are spread evenly, +so there is no elbow for `determine_optimal_levels()` to find. +`vignette("resolution")` covers how that number is chosen and the criteria that +disagree about it. -![Raw observations and the same spatial field tessellated at three resolutions, including the count resolution_profile() rates most reliable](https://raw.githubusercontent.com/elkronos/gis_modeling_toolkit/main/man/figures/readme-resolution.png) +![Raw observations and the same spatial field tessellated at three resolutions, including the count a ladder of counts from resolution_profile() rates most reliable](https://raw.githubusercontent.com/elkronos/gis_modeling_toolkit/main/man/figures/readme-resolution.png) The number a random fold reports on autocorrelated data is the reason the evidence layer exists. Random folds put a test point's neighbours in the @@ -120,20 +126,20 @@ remotes::install_github("elkronos/gis_modeling_toolkit") remotes::install_github("elkronos/gis_modeling_toolkit", build_vignettes = TRUE) ``` -`sf`, `dplyr`, `logger` and `digest` install with it. Everything below is -optional and needed only for the feature that uses it. A missing one produces a -message naming it. +`sf`, `dplyr`, `logger`, `digest` and `FNN` install with it. Everything below +is optional and needed only for the feature that uses it. A missing one +produces a message naming it. | install | for | |---|---| | `gstat` | variogram fitting: `estimate_sac_range()`, design effects, kriging checks | | `ranger` | `fit_rf_model()`, `cv_rf()` | -| `sp`, `GWmodel` | `fit_gwr_model()`, `cv_gwr()` | +| `sp` | `fit_gwr_model()`, `cv_gwr()` | | `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()`, `cv_bayes()` | | `geometry` | Delaunay triangle tessellations | | `ggplot2` | every `plot_*()` function and `plot()` method | | `patchwork` | the combined panels in `vignette("spatialkit_nc_demo")` and its script | -| `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers | +| `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers | | `loo` | PSIS-LOO for the Bayesian backend | | `nlme` | REML detrending in `estimate_sac_range()` | | `spdep` | cross-checks in the test suite only | @@ -170,10 +176,14 @@ asg <- assign_features_to_polygons(site, tess$cells) cells <- summarize_by_cell(asg, "z", cells_sf = tess$cells, deff = "kish") populated <- st_drop_geometry(cells)[cells$n > 1 & !is.na(cells$n), ] -head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z")], 4) +head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z", + "..pooled_resp_z")], 4) ``` -Every aggregate arrives with a count and a standard error. `deff = "kish"` makes +Every aggregate arrives with a count and a standard error, and beside each +mean a pooled value, `..pooled_resp_z`: the cell's mean pulled toward the mean +of the 8 cells around it, by a weight that grows with the cell's count +(`?summarize_by_cell`, "Pooled values"). `deff = "kish"` makes that the standard error of each cell mean as an estimate of the population mean, widened by the design effect of the within-cell correlation. For a map of the cells' own values leave `deff` at 1: the uncorrected standard error is the right @@ -182,6 +192,18 @@ one for a cell's own mean when its points are spread through it point cloud leaves some cells with one observation or none, which is why `n` travels with every row. +These are the package's defaults for cell values: pooled values beside the +plain means, and, when the data draw the cells, 4.5 observations per cell in +density-weighted cells. Each earlier default is one argument away. +`summarize_by_cell(estimate = "mean")` leaves the pooled columns out. +`resolution_profile(estimate = NULL, obs_per_cell = NULL)` gives the ladder of +cell counts and its columns, and `sac = NULL` fits the variogram on a ladder of +sizes too. `select_resolution(criterion = "cp")` reads Mallows' Cp off a +profile that has it. `partition = "kmeans"` in `resolution_profile()`, +`get_voronoi_seeds()` and `voronoi_seeds_kmeans()` gives the k-means cells, +from their earlier numbers of starts. `NEWS.md` says what each of these changes +in a result. + Now score a model. The learner below is a cubic trend surface in the coordinates, which is a realistic thing to fit and also the leakage mechanism this package warns about: given `x` and `y`, a flexible model can reproduce the @@ -250,12 +272,14 @@ null, reporting itself as approximate. | cut my study area into cells | `build_tessellation()` (`"voronoi"`, `"hex"`, `"square"`, `"triangles"`) | | place the seeds a Voronoi grows from | `get_voronoi_seeds()` | | choose how many cells, quickly (coordinates only, no optional packages) | `determine_optimal_levels()` | -| see what every cell count costs | `resolution_profile()`, then `summary()` on it for every criterion's pick, or `select_resolution()` for one | +| set the cell count from a number of observations per cell | `resolution_profile()`, then `select_resolution()` (by default 4.5 per cell, for pooled values) | +| see what every cell count costs | `resolution_profile(n_levels = )`, then `summary()` on it for every criterion's pick, or `select_resolution(criterion = )` for one criterion's pick | +| read a cell's value and interval at other locations | `cell_values_at()` | | put points into cells and aggregate | `assign_features_to_polygons()` → `summarize_by_cell()` | | check whether a cell mean is the best estimate of that cell | `kriging_adequacy()` | | draw the result | `plot_tessellation_map()` | | know how far spatial correlation reaches | `estimate_sac_range()`, and `sac_nugget()` for its nugget | -| build honest CV folds | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`) | +| build honest CV folds | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`, `knndm`) | | see whether my folds actually separate | `plot_folds()` | | size the blocks by measurement | `cv_block_size_sweep()`, and `plot()` on the result | | fit a model | `fit_gwr_model()`, `fit_bayesian_spatial_model()`, `fit_rf_model()` | @@ -292,8 +316,8 @@ an afternoon comparing them: | Backend | Reach for it when you want | Cost | |---|---|---| -| **GWR** (`fit_gwr_model()`, `GWmodel` + `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers "the elevation effect is strong in the west and absent in the east" | moderate; grows quickly with n | -| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | +| **GWR** (`fit_gwr_model()`, `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers "the elevation effect is strong in the west and absent in the east" | moderate; grows quickly with n | +| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | **uncertainty**: posterior predictive intervals (check their coverage with `cv_bayes()`), `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | | **Random forest** (`fit_rf_model()`, `ranger`) | **nonlinearity and interactions** without specifying them, and no inference: you get permutation importance in place of coefficients | far the lowest; the one to prototype with | Two things that are not backend choices. First, none of them fixes bad folds. @@ -311,8 +335,8 @@ them is computed on the spot. | vignette | covers | |---|---| | `vignette("getting-started")` | installing, getting your data in, what the coordinates are in, and the pipeline from points to a scored model and a map | -| `vignette("resolution")` | choosing a cell count, the four criteria, and why they disagree | -| `vignette("spatial-cross-validation")` | the five fold schemes, block sizing, and reading a CV result down to the last row | +| `vignette("resolution")` | choosing a cell count, the criteria, and why they disagree | +| `vignette("spatial-cross-validation")` | the six fold schemes, block sizing, and reading a CV result down to the last row | | `vignette("diagnostics")` | residual autocorrelation, aggregation standard errors, kriging adequacy, area of applicability, and two ways to leak | | `vignette("spatialkit_nc_demo")` | the whole pipeline end to end on real boundaries, with maps | | `vignette("reporting")` | grouping an existing layer, membership lookups, exporting the regions, and which six numbers to report | @@ -342,14 +366,14 @@ source(file.path(dir, "00-run-all.R")) # all ten, seven minutes or so | script | topic | needs, beyond ggplot2 | |---|---|---| | `01-tessellations.R` | Voronoi, hex, square and Delaunay cells, and what seeding changes | geometry for the Delaunay part | -| `02-resolution.R` | the range, the ladder, four criteria that disagree, and the leak | gstat | +| `02-resolution.R` | the range, the ladder, the criteria that disagree, the leak, and the default size | gstat | | `03-folds.R` | random against blocked folds, plus buffered leave-one-out and NNDM | | | `04-block-size.R` | sweeping the block size, and the two shapes the curve takes | gstat, for the range marker | | `05-fit-diagnose.R` | wrapping your own model, residual autocorrelation, cell means | gstat, for the residual variogram and the kriging check | -| `06-cv-compare.R` | comparing models fold by fold on one set of folds | ranger and GWmodel, for the backend comparison | +| `06-cv-compare.R` | comparing models fold by fold on one set of folds | ranger and sp, for the backend comparison | | `07-surface-aoa.R` | predicting onto a grid, and where the map stops meaning anything | stars for the raster part | | `08-feature-select.R` | forward selection, and measuring the selection effect | | -| `09-gwr.R` | coefficients that vary over space | GWmodel | +| `09-gwr.R` | coefficients that vary over space | sp | | `10-bayes.R` | a Bayesian GP, and whether its intervals are calibrated | brms and a Stan toolchain; slow | Every script draws with ggplot2. When a package a script needs is absent it @@ -372,7 +396,7 @@ The handful you are most likely to meet, and what each is actually telling you. A lattice has no extent of its own. Pass `boundary =` a polygon; dissolving your source polygons with `st_union()` is the usual way to get one. Voronoi and `"triangles"` do not need it; Voronoi falls back to the convex hull of the -points. +points, or of their cover for seeds. **`prep_model_data(): missing required column(s): X`** A `response_var` or `predictor_vars` name that is not in the data. Usually a @@ -420,8 +444,8 @@ same reason. **`n = 6000 requires FNN for k-NN weights, and Matrix to hold them sparsely`** `residual_morans_i()` above n = 5,000. The fallback allocates a dense n x n -matrix, which is why it stops here. -`install.packages(c("FNN", "Matrix"))`, both of them. +matrix, which is why it stops here. FNN installs with spatialkit, so the +missing one is Matrix: `install.packages("Matrix")`. **`compare_models_cv(): no recognised model requested.`** None of the names in `models` is `"GWR"`, `"Bayesian"` or `"RF"`, which are @@ -444,7 +468,7 @@ score computed from fewer folds than you asked for. **`estimate_sac_range()` returned `NA`.** The range was not identified, so nothing is reported. `attr(x, "rejected_reason")` -names which of the six refusals it was, `?estimate_sac_range` says what each +names which of the seven refusals it was, `?estimate_sac_range` says what each one means, and `plot()` on the returned object draws the variogram behind it. `vignette("spatial-cross-validation")` covers what an `NA` there leaves you to decide about the block size. @@ -482,10 +506,8 @@ the package is doing. `cv_bayes()`, `cv_rf()` and `cv_spatial()` accept a `parallel` argument for fold-level parallelism via `parallel::mclapply()` (macOS/Linux; falls back to sequential on Windows with a message). `cv_gwr()` accepts it too but always -runs its folds one after another, with a warning if you ask for more: GWmodel -runs OpenMP code, which deadlocks forked workers once a GWR has been fitted in -the session. Parallel folds matter most for `cv_bayes()`, where every fold is a -full MCMC run: +runs its folds one after another, with a warning if you ask for more. Parallel +folds matter most for `cv_bayes()`, where every fold is a full MCMC run: ```r # cv_bayes() needs `brms`. Without it every fold fails and you get an empty @@ -581,8 +603,9 @@ used is recorded in `DESCRIPTION`); `devtools::document()` reproduces them. The README figures are generated from actual package output; regenerate them with `Rscript dev/make_readme_figures.R`. `readme-resolution.png` labels the -cell count `resolution_profile()` rates most reliable on that data, so it goes -stale whenever that criterion's answer changes and must be rebuilt alongside it. +cell count a ladder of counts from `resolution_profile()` rates most reliable on +that data, so it goes stale whenever that criterion's answer changes and must be +rebuilt alongside it. The test suite covers the geometry/tessellation pipeline, every exported function, and targeted regression tests for the statistical internals (Moran's @@ -626,8 +649,8 @@ method references you should cite alongside it if you rely on `area_of_applicability()` (Meyer & Pebesma 2021), `make_folds(method = "nndm")` (Milà et al. 2022), the Bayesian GP basis (Riutort-Mayol et al. 2023), permutation importance in `fit_rf_model()` (Strobl et al. 2007), coordinate -predictors and blocked validation (Meyer et al. 2019), or GWR via `GWmodel` -(Lu et al. 2014). +predictors and blocked validation (Meyer et al. 2019), or GWR, whose kernels +and diagnostics follow `GWmodel` (Lu et al. 2014). ### Maintainer diff --git a/README.md b/README.md index c97ebd68..8eb5bb54 100644 --- a/README.md +++ b/README.md @@ -38,17 +38,22 @@ unit problem, and it is not a rounding error: the same observations can support materially different conclusions under different boundaries. `spatialkit` lets the data draw the boundaries. `get_voronoi_seeds()` -places seeds by k-means on the point cloud, so cell density follows -sampling density. `resolution_profile()` scores every candidate cell -count against the spatial structure of the observations, and -`determine_optimal_levels()` reads one off their clustering when they -have any. `build_tessellation()` produces Voronoi, hex, square -or Delaunay cells clipped to your study area, with IDs that stay stable -when the input row order changes. `summarize_by_cell()` aggregates onto -them with a count and a standard error for every cell mean. When the -cell means stand in for a population mean, it corrects those standard -errors for within-cell autocorrelation, which on a correlated field can -double them or more. +places seeds by density-weighted k-means on the point cloud, so cells +are small where observations are dense, and hold about the same number +of observations each once there are more cells than dense places. +`resolution_profile()` scores the cell count a number of observations +per cell gives, 4.5 by default, by the leave-one-out error of the cell +values, and `select_resolution()` sets it; given a ladder of counts the +profile scores every one against the spatial structure of the +observations, and `determine_optimal_levels()` reads one off their +clustering when they have any. `build_tessellation()` produces Voronoi, +hex, square or Delaunay cells clipped to your study area, with IDs that +stay stable when the input row order changes. `summarize_by_cell()` +aggregates onto them with a count and a standard error for every cell +mean, and beside each mean a pooled value, the mean pulled toward the +cells around it. When the cell means stand in for a population mean, it +corrects those standard errors for within-cell autocorrelation, which on +a correlated field can double them or more. Redrawing boundaries is easy. Knowing whether the result means anything is the hard part, so the second half of the package is the evidence @@ -69,22 +74,23 @@ methods aggregating it over North Carolina How many cells is a decision with visible consequences. The same field below is cut at three resolutions beside the raw observations: too -coarse blurs the hotspot, too fine chases noise with near-empty cells, -and the middle count, the one `resolution_profile()` rates most -reliable, keeps the trend without tracing the sampling pattern. It is a -reading, not a verdict: the reliability of the cell means stays within 2 -percent of its best from 3 to 25 cells here, and the sites are spread -evenly, so there is no elbow for `determine_optimal_levels()` to find. -`vignette("resolution")` covers how that number is chosen and the four -criteria that disagree about it. +coarse blurs the hotspot, too fine chases noise with cells of a handful +of observations, and the middle count, the one a ladder of counts from +`resolution_profile(n_levels = )` rates most reliable, keeps the trend +without tracing the sampling pattern. It is a reading, not a verdict: +the reliability of the cell means stays within 2 percent of its best +from 2 to 15 cells here, and the sites are spread evenly, so there is no +elbow for `determine_optimal_levels()` to find. `vignette("resolution")` +covers how that number is chosen and the criteria that disagree about +it.
+alt="Raw observations and the same spatial field tessellated at three resolutions, including the count a ladder of counts from resolution_profile() rates most reliable" /> +field tessellated at three resolutions, including the count a ladder of +counts from resolution_profile() rates most reliable
The number a random fold reports on autocorrelated data is the reason @@ -128,20 +134,20 @@ remotes::install_github("elkronos/gis_modeling_toolkit") remotes::install_github("elkronos/gis_modeling_toolkit", build_vignettes = TRUE) ``` -`sf`, `dplyr`, `logger` and `digest` install with it. Everything below -is optional and needed only for the feature that uses it. A missing one -produces a message naming it. +`sf`, `dplyr`, `logger`, `digest` and `FNN` install with it. Everything +below is optional and needed only for the feature that uses it. A +missing one produces a message naming it. | install | for | |--------------------------------|---------------------------------------------------------------------------| | `gstat` | variogram fitting: `estimate_sac_range()`, design effects, kriging checks | | `ranger` | `fit_rf_model()`, `cv_rf()` | -| `sp`, `GWmodel` | `fit_gwr_model()`, `cv_gwr()` | +| `sp` | `fit_gwr_model()`, `cv_gwr()` | | `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()`, `cv_bayes()` | | `geometry` | Delaunay triangle tessellations | | `ggplot2` | every `plot_*()` function and `plot()` method | | `patchwork` | the combined panels in `vignette("spatialkit_nc_demo")` and its script | -| `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran’s I on large layers | +| `Matrix` | sparse k-nearest-neighbour weights for Moran’s I on large layers | | `loo` | PSIS-LOO for the Bayesian backend | | `nlme` | REML detrending in `estimate_sac_range()` | | `spdep` | cross-checks in the test suite only | @@ -177,15 +183,19 @@ asg <- assign_features_to_polygons(site, tess$cells) cells <- summarize_by_cell(asg, "z", cells_sf = tess$cells, deff = "kish") populated <- st_drop_geometry(cells)[cells$n > 1 & !is.na(cells$n), ] -head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z")], 4) -#> poly_id n resp_mean_z ..se_resp_z -#> 2 2 12 -0.3553720 0.3840250 -#> 3 3 6 -0.7977035 0.6491918 -#> 4 4 2 -1.8546732 0.1801251 -#> 5 5 14 0.0554452 0.7258217 +head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z", + "..pooled_resp_z")], 4) +#> poly_id n resp_mean_z ..se_resp_z ..pooled_resp_z +#> 2 2 12 -0.3553720 0.3840250 -0.32153305 +#> 3 3 6 -0.7977035 0.6491918 -0.54245922 +#> 4 4 2 -1.8546732 0.1801251 -0.82499383 +#> 5 5 14 0.0554452 0.7258217 0.04565301 ``` -Every aggregate arrives with a count and a standard error. +Every aggregate arrives with a count and a standard error, and beside +each mean a pooled value, `..pooled_resp_z`: the cell’s mean pulled +toward the mean of the 8 cells around it, by a weight that grows with +the cell’s count (`?summarize_by_cell`, “Pooled values”). `deff = "kish"` makes that the standard error of each cell mean as an estimate of the population mean, widened by the design effect of the within-cell correlation. For a map of the cells’ own values leave `deff` @@ -195,6 +205,19 @@ which to use when). A lattice laid over an irregular point cloud leaves some cells with one observation or none, which is why `n` travels with every row. +These are the package’s defaults for cell values: pooled values beside +the plain means, and, when the data draw the cells, 4.5 observations per +cell in density-weighted cells. Each earlier default is one argument +away. `summarize_by_cell(estimate = "mean")` leaves the pooled columns +out. `resolution_profile(estimate = NULL, obs_per_cell = NULL)` gives +the ladder of cell counts and its columns, and `sac = NULL` fits the +variogram on a ladder of sizes too. +`select_resolution(criterion = "cp")` reads Mallows’ Cp off a profile +that has it. `partition = "kmeans"` in `resolution_profile()`, +`get_voronoi_seeds()` and `voronoi_seeds_kmeans()` gives the k-means +cells, from their earlier numbers of starts. `NEWS.md` says what each of +these changes in a result. + Now score a model. The learner below is a cubic trend surface in the coordinates, which is a realistic thing to fit and also the leakage mechanism this package warns about: given `x` and `y`, a flexible model @@ -271,12 +294,14 @@ approximate. | cut my study area into cells | `build_tessellation()` (`"voronoi"`, `"hex"`, `"square"`, `"triangles"`) | | place the seeds a Voronoi grows from | `get_voronoi_seeds()` | | choose how many cells, quickly (coordinates only, no optional packages) | `determine_optimal_levels()` | -| see what every cell count costs | `resolution_profile()`, then `summary()` on it for every criterion’s pick, or `select_resolution()` for one | +| set the cell count from a number of observations per cell | `resolution_profile()`, then `select_resolution()` (by default 4.5 per cell, for pooled values) | +| see what every cell count costs | `resolution_profile(n_levels = )`, then `summary()` on it for every criterion’s pick, or `select_resolution(criterion = )` for one criterion’s pick | +| read a cell’s value and interval at other locations | `cell_values_at()` | | put points into cells and aggregate | `assign_features_to_polygons()` → `summarize_by_cell()` | | check whether a cell mean is the best estimate of that cell | `kriging_adequacy()` | | draw the result | `plot_tessellation_map()` | | know how far spatial correlation reaches | `estimate_sac_range()`, and `sac_nugget()` for its nugget | -| build honest CV folds | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`) | +| build honest CV folds | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`, `knndm`) | | see whether my folds actually separate | `plot_folds()` | | size the blocks by measurement | `cv_block_size_sweep()`, and `plot()` on the result | | fit a model | `fit_gwr_model()`, `fit_bayesian_spatial_model()`, `fit_rf_model()` | @@ -313,8 +338,8 @@ afternoon comparing them: | Backend | Reach for it when you want | Cost | |------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------------------------------------------------| -| **GWR** (`fit_gwr_model()`, `GWmodel` + `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers “the elevation effect is strong in the west and absent in the east” | moderate; grows quickly with n | -| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | +| **GWR** (`fit_gwr_model()`, `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers “the elevation effect is strong in the west and absent in the east” | moderate; grows quickly with n | +| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | **uncertainty**: posterior predictive intervals (check their coverage with `cv_bayes()`), `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | | **Random forest** (`fit_rf_model()`, `ranger`) | **nonlinearity and interactions** without specifying them, and no inference: you get permutation importance in place of coefficients | far the lowest; the one to prototype with | Two things that are not backend choices. First, none of them fixes bad @@ -333,8 +358,8 @@ in them is computed on the spot. | vignette | covers | |----------------------------------------|-------------------------------------------------------------------------------------------------------------------------| | `vignette("getting-started")` | installing, getting your data in, what the coordinates are in, and the pipeline from points to a scored model and a map | -| `vignette("resolution")` | choosing a cell count, the four criteria, and why they disagree | -| `vignette("spatial-cross-validation")` | the five fold schemes, block sizing, and reading a CV result down to the last row | +| `vignette("resolution")` | choosing a cell count, the criteria, and why they disagree | +| `vignette("spatial-cross-validation")` | the six fold schemes, block sizing, and reading a CV result down to the last row | | `vignette("diagnostics")` | residual autocorrelation, aggregation standard errors, kriging adequacy, area of applicability, and two ways to leak | | `vignette("spatialkit_nc_demo")` | the whole pipeline end to end on real boundaries, with maps | | `vignette("reporting")` | grouping an existing layer, membership lookups, exporting the regions, and which six numbers to report | @@ -365,14 +390,14 @@ source(file.path(dir, "00-run-all.R")) # all ten, seven minutes or so | script | topic | needs, beyond ggplot2 | |-----------------------|--------------------------------------------------------------------|---------------------------------------------------------| | `01-tessellations.R` | Voronoi, hex, square and Delaunay cells, and what seeding changes | geometry for the Delaunay part | -| `02-resolution.R` | the range, the ladder, four criteria that disagree, and the leak | gstat | +| `02-resolution.R` | the range, the ladder, the criteria that disagree, the leak, and the default size | gstat | | `03-folds.R` | random against blocked folds, plus buffered leave-one-out and NNDM | | | `04-block-size.R` | sweeping the block size, and the two shapes the curve takes | gstat, for the range marker | | `05-fit-diagnose.R` | wrapping your own model, residual autocorrelation, cell means | gstat, for the residual variogram and the kriging check | -| `06-cv-compare.R` | comparing models fold by fold on one set of folds | ranger and GWmodel, for the backend comparison | +| `06-cv-compare.R` | comparing models fold by fold on one set of folds | ranger and sp, for the backend comparison | | `07-surface-aoa.R` | predicting onto a grid, and where the map stops meaning anything | stars for the raster part | | `08-feature-select.R` | forward selection, and measuring the selection effect | | -| `09-gwr.R` | coefficients that vary over space | GWmodel | +| `09-gwr.R` | coefficients that vary over space | sp | | `10-bayes.R` | a Bayesian GP, and whether its intervals are calibrated | brms and a Stan toolchain; slow | Every script draws with ggplot2. When a package a script needs is absent @@ -395,7 +420,7 @@ telling you. lattice has no extent of its own. Pass `boundary =` a polygon; dissolving your source polygons with `st_union()` is the usual way to get one. Voronoi and `"triangles"` do not need it; Voronoi falls back to -the convex hull of the points. +the convex hull of the points, or of their cover for seeds. **`prep_model_data(): missing required column(s): X`** A `response_var` or `predictor_vars` name that is not in the data. Usually a typo, a case @@ -441,8 +466,8 @@ above 5,000,000 grid cells for the same reason. **`n = 6000 requires FNN for k-NN weights, and Matrix to hold them sparsely`** `residual_morans_i()` above n = 5,000. The fallback allocates a dense n -x n matrix, which is why it stops here. -`install.packages(c("FNN", "Matrix"))`, both of them. +x n matrix, which is why it stops here. FNN installs with spatialkit, so +the missing one is Matrix: `install.packages("Matrix")`. **`compare_models_cv(): no recognised model requested.`** None of the names in `models` is `"GWR"`, `"Bayesian"` or `"RF"`, which are matched @@ -466,7 +491,7 @@ asked for. **`estimate_sac_range()` returned `NA`.** The range was not identified, so nothing is reported. `attr(x, "rejected_reason")` names which of the -six refusals it was, `?estimate_sac_range` says what each one means, +seven refusals it was, `?estimate_sac_range` says what each one means, and `plot()` on the returned object draws the variogram behind it. `vignette("spatial-cross-validation")` covers what an `NA` there leaves you to decide about the block size. @@ -503,9 +528,8 @@ changed, and seeing what the package is doing. for fold-level parallelism via `parallel::mclapply()` (macOS/Linux; falls back to sequential on Windows with a message). `cv_gwr()` accepts it too but always runs its folds one after another, with a warning if you ask -for more: GWmodel runs OpenMP code, which deadlocks forked workers once a -GWR has been fitted in the session. Parallel folds matter most for -`cv_bayes()`, where every fold is a full MCMC run: +for more. Parallel folds matter most for `cv_bayes()`, where every fold +is a full MCMC run: ``` r # cv_bayes() needs `brms`. Without it every fold fails and you get an empty @@ -609,9 +633,9 @@ reproduces them. The README figures are generated from actual package output; regenerate them with `Rscript dev/make_readme_figures.R`. `readme-resolution.png` -labels the cell count `resolution_profile()` rates most reliable on that -data, so it goes stale whenever that criterion’s answer changes and must -be rebuilt alongside it. +labels the cell count a ladder of counts from `resolution_profile()` +rates most reliable on that data, so it goes stale whenever that +criterion’s answer changes and must be rebuilt alongside it. The test suite covers the geometry/tessellation pipeline, every exported function, and targeted regression tests for the statistical internals @@ -657,7 +681,8 @@ the method references you should cite alongside it if you rely on `make_folds(method = "nndm")` (Milà et al. 2022), the Bayesian GP basis (Riutort-Mayol et al. 2023), permutation importance in `fit_rf_model()` (Strobl et al. 2007), coordinate predictors and blocked validation -(Meyer et al. 2019), or GWR via `GWmodel` (Lu et al. 2014). +(Meyer et al. 2019), or GWR, whose kernels and diagnostics follow +`GWmodel` (Lu et al. 2014). ### Maintainer diff --git a/_pkgdown.yml b/_pkgdown.yml index 950f7b04..40fa84c6 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -95,11 +95,13 @@ reference: - title: Assign and aggregate desc: > One row per cell, with a count and a standard error for every aggregate, - the record of which rows were dropped or tied on the way, and whether a - block-kriging estimate would have beaten the plain cell mean. + the record of which rows were dropped or tied on the way, the value of a + cell at other locations, and whether a block-kriging estimate would have + beaten the plain cell mean. contents: - assign_features_to_polygons - summarize_by_cell + - cell_values_at - kriging_adequacy - "[.spatialkit_rows" diff --git a/dev/baseline-core-frozen.R b/dev/baseline-core-frozen.R new file mode 100644 index 00000000..a87003d3 --- /dev/null +++ b/dev/baseline-core-frozen.R @@ -0,0 +1,288 @@ +# dev/baseline-core-frozen.R +# --------------------------------------------------------------------------- +# The frozen baseline of the cell pipeline. +# +# Runs the calls of tests/testthat/helper-core-frozen.R on the baseline code +# and saves what each returns, prints, raises and logs, and where it leaves +# the random-number stream, as tests/testthat/fixtures/core-frozen.rds. +# tests/testthat/test-core-frozen.R runs the same calls on the code under +# test and compares, so a change to what a default call returns fails that +# test. +# +# THE BASELINE is the package code with the two partition kinds +# (partition = "kmeans" | "density", R/partition.R) and nothing built on top +# of them. It is named by a git TREE, not by a commit: when the baseline was +# taken that code was staged and not yet committed, and BASELINE_TREE is the +# tree of the index then (`git write-tree`), on top of commit c7a2a10. The +# commit that records this tree (`git rev-parse ^{tree}` prints +# BASELINE_TREE) is the baseline commit. +# +# The script refuses to run on any other code: it hashes R/, DESCRIPTION and +# NAMESPACE of the package directory as git does and compares them with the +# entries of BASELINE_TREE (`git ls-tree R DESCRIPTION +# NAMESPACE` prints the three hashes below). +# +# Usage, from the root of the working tree: +# Rscript --vanilla dev/baseline-core-frozen.R [ []] +# is a directory holding the baseline code, "." by default. +# Once the working tree has moved on, export the baseline first, by its tree +# or by the commit that records it: +# mkdir +# git archive c64fcac7be7ae3c83027198e1176d25368727633 | tar -x -C +# The calls and the recorder are always read from the working tree +# (tests/testthat/helper-core-frozen.R): they are what the test replays. +# When a fixture is already at , the script says how many of +# its records the new run gives again, so that a call added to the list, or +# a fixture taken again on another machine, can be seen to move no record. +# +# The test holds a run to identical() only on the platform the fixture was +# recorded on. When R, sf, GEOS, PROJ or one of the packages the fixture +# names changes on the machine the work is done on, take the fixture again +# from an export of the baseline; do not take it from code that has moved. +# +# The fixture stores the text of every call, and the test compares it with +# the helper's list. When the calls are rewritten to name the defaults they +# were recorded under (the step that changes those defaults), the records +# stay and only the stored text is replaced: +# Rscript --vanilla dev/baseline-core-frozen.R --calls-only [] +# That mode runs nothing and needs no baseline code. It refuses a list with +# other names than the fixture's records, prints every call whose text +# changed, for the commit to list, and keeps the text the records were taken +# with as `calls_recorded`. After it the records can no longer be taken +# again from this list: the baseline code does not know the arguments the +# rewritten calls name. +# +# `dev/` is in .Rbuildignore, so nothing here ships. +# --------------------------------------------------------------------------- + +BASELINE_TREE <- "c64fcac7be7ae3c83027198e1176d25368727633" +BASELINE_CODE <- c(R = "2df204570e3e0378e1919c6bd1f9a1c5be24d8ca", # tree + DESCRIPTION = "645da4e0c2ef52c044b40e7885104ab1a17ce45b", # blob + NAMESPACE = "43ea3214d0eebda8f3a1b2792075b4d61d909ef1") # blob + +args <- commandArgs(trailingOnly = TRUE) +calls_only <- length(args) >= 1L && identical(args[[1L]], "--calls-only") +if (calls_only) args <- c(".", args[-1L]) +base_dir <- if (length(args) >= 1L) args[[1L]] else "." +fixture <- if (length(args) >= 2L) args[[2L]] else + file.path("tests", "testthat", "fixtures", "core-frozen.rds") +helper <- file.path("tests", "testthat", "helper-core-frozen.R") +if (!file.exists(helper)) + stop("Run from the root of the working tree: ", helper, " not found.") +if (!file.exists(file.path(base_dir, "DESCRIPTION"))) + stop("No package in '", base_dir, "'.") + +# ---- The stored text of the calls alone -------------------------------------------- + +if (calls_only) { + source(helper, local = FALSE) + if (!file.exists(fixture)) stop("No fixture at '", fixture, "'.") + baseline <- readRDS(fixture) + now <- core_frozen_call_text() + if (!identical(names(now), names(baseline$records))) + stop("The helper's calls are not the fixture's records by name: only in the helper, ", + paste(setdiff(names(now), names(baseline$records)), collapse = ", "), + "; only in the fixture, ", + paste(setdiff(names(baseline$records), names(now)), collapse = ", "), + "; or their order differs. A call is added or removed on the baseline code only.") + changed <- names(now)[!mapply(identical, now, baseline$calls[names(now)])] + for (nm in changed) + cat(sprintf("%s\n was: %s\n now: %s\n", nm, baseline$calls[[nm]], now[[nm]])) + if (is.null(baseline$calls_recorded)) baseline$calls_recorded <- baseline$calls + baseline$calls <- now + saveRDS(baseline, fixture, compress = "xz") + cat(sprintf("\n%d of %d calls have another text; %s holds the new text and the records it had.\n", + length(changed), length(now), fixture)) + quit(save = "no", status = 0L) +} + +# ---- The code is the baseline's ------------------------------------------------ + +# The hash git gives a file, and the one it gives a directory of plain files. +git_blob <- function(path) { + bytes <- readBin(path, "raw", n = file.size(path)) + digest::digest(c(charToRaw(sprintf("blob %d", length(bytes))), as.raw(0L), bytes), + algo = "sha1", serialize = FALSE) +} +git_tree <- function(dir) { + files <- sort(list.files(dir, all.files = TRUE, no.. = TRUE), method = "radix") + if (any(dir.exists(file.path(dir, files)))) + stop("git_tree(): '", dir, "' holds a directory; only plain files are hashed.") + entry <- function(f) { + sha <- git_blob(file.path(dir, f)) + c(charToRaw(paste("100644", f)), as.raw(0L), + as.raw(strtoi(substring(sha, seq(1L, 39L, 2L), seq(2L, 40L, 2L)), 16L))) + } + body <- unlist(lapply(files, entry)) + digest::digest(c(charToRaw(sprintf("tree %d", length(body))), as.raw(0L), body), + algo = "sha1", serialize = FALSE) +} +found <- c(R = git_tree(file.path(base_dir, "R")), + DESCRIPTION = git_blob(file.path(base_dir, "DESCRIPTION")), + NAMESPACE = git_blob(file.path(base_dir, "NAMESPACE"))) +if (!identical(found, BASELINE_CODE)) { + off <- names(found)[found != BASELINE_CODE] + stop("The code in '", base_dir, "' is not the baseline's: ", + paste(sprintf("%s is %s, the baseline's is %s", off, found[off], BASELINE_CODE[off]), + collapse = "; "), + ". Export the baseline (see the header) and pass its directory.") +} + +# ---- Load it, and the calls ----------------------------------------------------- + +suppressPackageStartupMessages(library(sf)) +pkgload::load_all(base_dir, quiet = TRUE) +loaded_from <- normalizePath(getNamespaceInfo(asNamespace("spatialkit"), "path")) +if (!identical(loaded_from, normalizePath(base_dir))) + stop("spatialkit is loaded from ", loaded_from, ", not from ", normalizePath(base_dir), ".") +message("spatialkit loaded from : ", loaded_from) +source(helper, local = FALSE) + +# ---- The data -------------------------------------------------------------------- + +# The layers, as data frames of coordinates and columns. The first three are +# in EPSG:32632. +# pts 400 points spread over a 1 km square. `z` is a Gaussian field with +# an exponential covariance (range parameter 90 m) and a nugget; +# `z_na` is `z` with 50 values missing; `z_bad` is `z` with missing +# and infinite values; `flag` is logical; `none` has no value; +# `x1` and `x2` are predictors with 20 values missing each; `noise` +# has no spatial structure. +# clus 500 points, 470 of them in four tight clusters, with a response `w`. +# big 1,800 points over a 3 km square, more than resolution_profile()'s +# `sample_n`, with a smooth response `z` plus noise. +# Three more were added after the first list of calls. They are drawn after +# the three above, so those are the numbers they were. +# ll `pts` with its coordinates in longitude and latitude (EPSG:4326). +# twice the first 150 locations of `pts`, each held by two rows, with a +# response `z` that differs between the two. +# lattice a 12 x 12 lattice at 80 m, with a smooth response `z` plus +# noise, a constant column `const` and an integer column `count`. +core_frozen_data <- function() { + set.seed(20261012, kind = "Mersenne-Twister", normal.kind = "Inversion", + sample.kind = "Rejection") + n <- 400L + x <- 5e5 + runif(n, 0, 1000) + y <- 5e6 + runif(n, 0, 1000) + D <- as.matrix(dist(cbind(x, y))) + z <- 10 + as.numeric(t(chol(exp(-D / 90) + diag(0.3, n))) %*% rnorm(n)) + z_na <- z + z_na[sample.int(n, 50L)] <- NA + z_bad <- z + z_bad[sample.int(n, 12L)] <- c(NA, NaN, Inf, -Inf) + x1 <- rnorm(n) + x2 <- 0.5 * z + rnorm(n) + x1[sample.int(n, 20L)] <- NA + x2[sample.int(n, 20L)] <- NA + pts <- data.frame(x = x, y = y, z = z, z_na = z_na, z_bad = z_bad, + flag = z > stats::median(z), none = NA_real_, x1 = x1, x2 = x2, + noise = rnorm(n)) + + n_bg <- 30L; n_cl <- 470L; k <- 4L + bg <- cbind(runif(n_bg, 0, 1000), runif(n_bg, 0, 1000)) + ctr <- cbind(runif(k, 150, 850), runif(k, 150, 850)) + who <- sample.int(k, n_cl, replace = TRUE) + cl <- ctr[who, , drop = FALSE] + matrix(rnorm(2L * n_cl, sd = 20), n_cl, 2L) + xy <- rbind(bg, cl) + xy <- xy[sample.int(nrow(xy)), , drop = FALSE] + clus <- data.frame(x = 5e5 + xy[, 1L], y = 5e6 + xy[, 2L]) + clus$w <- 5 + xy[, 1L] / 500 + sin(xy[, 2L] / 150) + rnorm(nrow(xy), sd = 0.4) + + m <- 1800L + bx <- runif(m, 0, 3000) + by <- runif(m, 0, 3000) + big <- data.frame(x = 5e5 + bx, y = 5e6 + by, + z = sin(bx / 400) + cos(by / 300) + rnorm(m, sd = 0.5)) + + lonlat <- sf::st_coordinates(sf::st_transform( + sf::st_as_sf(pts[, c("x", "y")], coords = c("x", "y"), crs = 32632), 4326)) + ll <- pts + ll$x <- unname(lonlat[, 1L]) + ll$y <- unname(lonlat[, 2L]) + + both <- c(1:150, 1:150) + twice <- data.frame(x = pts$x[both], y = pts$y[both], + z = pts$z[both] + rnorm(length(both), sd = 0.2)) + + g <- expand.grid(gx = seq(40, 920, by = 80), gy = seq(40, 920, by = 80)) + lattice <- data.frame(x = 5e5 + g$gx, y = 5e6 + g$gy, + z = sin(g$gx / 200) + cos(g$gy / 150) + rnorm(nrow(g), sd = 0.3), + const = 7) + lattice$count <- as.integer(round(10 * lattice$z)) + list(pts = pts, clus = clus, big = big, ll = ll, twice = twice, lattice = lattice) +} + +# ---- Record ------------------------------------------------------------------------ + +data <- core_frozen_data() +calls <- core_frozen_calls() +t0 <- proc.time()[[3L]] +records <- core_frozen_run(data, calls) +message(sprintf("%d calls recorded in %.1f s", length(records), proc.time()[[3L]] - t0)) +# A second run in the same session has to give the same records: a call +# whose result moved with the session's state could not be replayed. +again <- core_frozen_run(data, calls) +moved <- names(records)[!mapply(identical, records, again)] +if (length(moved)) + stop("These calls do not return the same record twice: ", paste(moved, collapse = ", ")) +# The same calls where FNN and Matrix are not installed. The test replays +# the list that way too. A call whose record is another without them has +# that record saved beside the first, and the replay is held to it. +bare <- core_frozen_run(data, calls, without = c("FNN", "Matrix")) +bare_again <- core_frozen_run(data, calls, without = c("FNN", "Matrix")) +moved <- names(bare)[!mapply(identical, bare, bare_again)] +if (length(moved)) + stop("These calls do not return the same record twice without FNN and Matrix: ", + paste(moved, collapse = ", ")) +other <- names(records)[!mapply(identical, records, bare)] +message(sprintf("without FNN and Matrix %d of %d records are another%s", length(other), + length(records), + if (length(other)) paste0(": ", paste(other, collapse = ", ")) else "")) + +# What a fixture already there holds of these calls. +if (file.exists(fixture)) { + had <- readRDS(fixture)$records + old_parts <- c("value", "output", "printed", "log") + same <- function(nm) { + a <- had[[nm]]; b <- records[[nm]] + said <- function(r) lapply(r$conditions, function(c) c[c("when", "kind", "class", "message")]) + identical(a[old_parts], b[old_parts]) && identical(said(a), said(b)) + } + both <- intersect(names(had), names(records)) + off <- both[!vapply(both, same, logical(1))] + message(sprintf("%s held %d records: %d are also in this list, %d of them with another value, condition, output, print or log%s", + fixture, length(had), length(both), length(off), + if (length(off)) paste0(" (", paste(off, collapse = ", "), ")") else "")) +} + +baseline <- list( + info = c(list(tree = BASELINE_TREE, + tree_is = paste("a git tree (`git write-tree` of the index), not a commit:", + "the code was staged on top of commit c7a2a10"), + code = BASELINE_CODE, + recorded = format(Sys.Date())), + core_frozen_platform()), + data = data, + calls = core_frozen_call_text(calls), + records = records, + # What the calls return where FNN and Matrix are not installed: the records + # above, but for these. + without = list(packages = c("FNN", "Matrix"), records = bare[other])) +dir.create(dirname(fixture), recursive = TRUE, showWarnings = FALSE) +saveRDS(baseline, fixture, compress = "xz") + +n_cond <- function(kind) sum(vapply(records, function(r) + sum(vapply(r$conditions, function(c) identical(c$kind, kind), logical(1))), numeric(1))) +cat(sprintf("\nWrote %s (%.0f kB)\n", fixture, file.size(fixture) / 1024)) +cat(sprintf(" %d calls; %d with a value, %d that stop\n", length(records), + sum(!vapply(records, function(r) is.null(r$value), logical(1))), + n_cond("error"))) +cat(sprintf(" %d warnings, %d messages, %d logged lines, %d prints\n", + n_cond("warning"), n_cond("message"), + sum(lengths(lapply(records, `[[`, "log"))), + sum(!vapply(records, function(r) is.null(r$printed), logical(1))))) +cat(sprintf(" %d calls leave the random-number stream moved\n", + sum(!vapply(records, function(r) r$rng$untouched, logical(1))))) +cat(sprintf(" %d records are another without FNN and Matrix\n", length(other))) +p <- baseline$info +cat(sprintf(" %s, %s; sf %s, GEOS %s, PROJ %s\n", p$platform, p$r, p$sf, p$geos, p$proj)) diff --git a/dev/make_readme_figures.R b/dev/make_readme_figures.R index dc2f24fc..64ac4f05 100644 --- a/dev/make_readme_figures.R +++ b/dev/make_readme_figures.R @@ -53,11 +53,13 @@ pts$val <- 10 - 6 * xs + rnorm(nrow(pts), sd = 0.3) pts$west <- xs # predictor used by the model-aware resolution selection -# Aggregate the point values per cell with the package's own workflow. +# Aggregate the point values per cell with the package's own workflow. The +# panels show the plain mean of each cell, so the summary leaves out the +# pooled values it adds by default (estimate = "mean"). cell_means <- function(cells, label) { assigned <- assign_features_to_polygons(pts, cells) summ <- summarize_by_cell(assigned, response_var = "val", - cells_sf = cells) + cells_sf = cells, estimate = "mean") st_sf(method = label, mean_val = summ$resp_mean_val, geometry = st_geometry(summ)) @@ -89,17 +91,18 @@ panel_plot <- function(cells_sf, lvls) { } # --- Figure 1: raw field + three tessellations (2 x 2) ---------------------- +# The seeds are the default kind: density-weighted k-means from 3 starts. seeds <- voronoi_seeds_kmeans(pts, k = 30) vor <- create_voronoi_polygons(seeds, boundary = state, quiet = TRUE) hexg <- create_grid_polygons(state, target_cells = 30, type = "hex") sqg <- create_grid_polygons(state, target_cells = 30, type = "square") tess_cells <- rbind( - cell_means(vor$cells, "Voronoi (k-means seeds)"), + cell_means(vor$cells, "Voronoi (density-weighted seeds)"), cell_means(hexg, "Hex grid"), cell_means(sqg, "Square grid") ) -lvls1 <- c("Raw observations", "Voronoi (k-means seeds)", +lvls1 <- c("Raw observations", "Voronoi (density-weighted seeds)", "Hex grid", "Square grid") ggsave("man/figures/readme-tessellations.png", @@ -145,13 +148,21 @@ ggsave("man/figures/readme-spatial-cv.png", p2, # used to supply it, but these sites are spread evenly: its WSS curve has no # elbow, and it warns that the count it returns (4 at max_levels = 15) was set # by the ladder rather than by the data. Reliability's flat region on this -# field is wide (within 2 percent of the optimum from 3 to 25 cells), and the +# field is wide (within 2 percent of the optimum from 2 to 15 cells), and the # README says so rather than presenting the count as the answer. The # profile's warning about a zero nugget concerns Cp, which is not read here. +# With a predictor the profile scores no cell value, so n_levels gives the +# ladder of counts whatever obs_per_cell would; its cells, and the seeds +# below, are the default kind, density-weighted k-means, and reliability +# does not read the cells. The band printed below is the one the README +# quotes. prof_res <- suppressWarnings(resolution_profile(pts, response_var = "val", predictor_vars = "west", n_levels = 12)) -k_sel <- select_resolution(prof_res, criterion = "reliability")$best +sel_res <- select_resolution(prof_res, criterion = "reliability") +k_sel <- sel_res$best +cat(sprintf("reliability: %d cells; within %s of its best at %s cells\n", k_sel, + "2 percent", paste(range(sel_res$flat), collapse = " to "))) ks <- sort(unique(c(max(2, k_sel - 3), k_sel, 60))) if (length(ks) < 3) ks <- sort(unique(c(ks, 12))) diff --git a/dev/sim-pooled-values-run.dcf b/dev/sim-pooled-values-run.dcf new file mode 100644 index 00000000..9641fe6c --- /dev/null +++ b/dev/sim-pooled-values-run.dcf @@ -0,0 +1,11 @@ +script: dev/sim-pooled-values.R +script_md5: 038636f8e1df87dc54d5d9e4e0bbace5 +csv_md5: f7ba879982e0c6116dc4005a344795e1 +layers: 200 +date: 2026-10-14 +seconds: 194 +R: 4.6.1 +platform: aarch64-apple-darwin23 +sf: 1.1.2 +FNN: 1.1.4.1 +spatialkit: 2.0.0.9000 diff --git a/dev/sim-pooled-values.R b/dev/sim-pooled-values.R new file mode 100644 index 00000000..7efea32f --- /dev/null +++ b/dev/sim-pooled-values.R @@ -0,0 +1,524 @@ +# dev/sim-pooled-values.R +# --------------------------------------------------------------------------- +# The simulation behind the figures the help, the vignettes and NEWS quote +# for the pooled cell values, the interval for one observation and the +# leave-one-out error (summarize_by_cell(estimate = "pooled", obs_level = ), +# cell_values_at(), resolution_profile(estimate = , obs_per_cell = )). +# +# It simulates 200 layers, takes each through the package's exported calls, +# and writes six outputs, a to f, to dev/sim-pooled-values.csv. Every figure +# those pages quote, and every statement they make about how the new numbers +# behave, is a row of that file. A statement the file does not bear out is +# not in the pages. +# +# Usage, from the root of the working tree: +# Rscript --vanilla dev/sim-pooled-values.R +# The run takes about four minutes, needs the FNN package (the script +# computes nothing with it; the package's searches use it) and prints one +# line per layer. A trial of fewer layers has to write elsewhere: +# Rscript --vanilla dev/sim-pooled-values.R [] +# keeps the per-row and per-layer tables the outputs are made of. +# +# Beside the CSV a run writes its record, dev/sim-pooled-values-run.dcf (for +# a trial, with "-run.dcf" for ".csv"): the MD5 sums of this +# script and of the CSV, each read as lines of text, the layers, the date, +# the seconds and the versions of R, sf, FNN and the package. +# tests/testthat/test-core-docs.R compares both sums with the files, so the +# figures the pages quote are those of this script as it stands: after an +# edit here, or of the CSV, that test fails until the script is run again. +# +# SETTINGS. Everything about layer f (1 to 200) is drawn under +# set.seed(20261012 + f), R's default generators, in the order of this list. +# +# 1. The square is 1000 by 1000. The parents are 25 points: 25 x +# coordinates, then 25 y coordinates, uniform on it. +# 2. A clustered draw of n locations. Candidates are drawn 2n at a time and +# those inside the square kept, until n are in hand; the first n are +# used. A candidate is, with probability 0.8, a parent drawn at random +# with replacement plus a normal displacement of standard deviation 40 in +# each coordinate, and otherwise uniform on the square. One batch draws, +# in this order: 2n uniforms (below 0.8: at a parent), 2n parents +# (sample.int), 2n x displacements, 2n y displacements, 2n uniform x, 2n +# uniform y. The rows are a clustered draw of 2,100, and the further +# locations a second clustered draw of 20,000 round the same parents. +# 3. The field is a sum of 1,000 cosine waves, +# Z(s) = sqrt(2 / 1000) * sum(cos(s . om_j + ph_j)), +# with the frequencies +# om <- cbind(rnorm(1000), rnorm(1000)) / (100 * abs(rnorm(1000))) +# (a bivariate Cauchy distribution of scale 1/100) and the phases +# ph <- runif(1000, 0, 2 * pi). +# Its covariance is exp(-d / 100): unit sill, range parameter 100, an +# effective range of about 300. It is evaluated at the rows and at the +# further locations; that is the noise-free field. The form gives the +# same field at any number of locations in time proportional to their +# number. +# 4. The response at a row is the field plus normal noise of variance 0.3. +# 5. The block: a centre uniform on the middle square, 250 to 750 in each +# coordinate (x, then y); the 300 rows nearest it are held out, and the +# block's radius is the distance of the furthest of them. Held out among +# the others: 300 of the other 1,800 rows, by sample(). The other 1,500 +# rows are the layer. Last, 1,500 standard normal values: the white-noise +# response of output d, on the layer's rows. +# 6. The package's calls, on the layer: +# resolution_profile(, "y", estimate = "pooled", obs_per_cell = 4.5, +# partition = "density", nstart = 3, sac = "auto", +# seed = 123) +# select_resolution(criterion = "size") +# get_voronoi_seeds(method = "kmeans", n = , sample_points = ) +# build_tessellation(, method = "voronoi") +# assign_features_to_polygons(, polygon_id_col = "cell_id") +# summarize_by_cell(, estimate = "pooled", obs_level = 0.90, +# conf_level = 0.90) +# cell_values_at(, seeds = ) for the 600 held-out rows and for the +# 20,000 further locations +# For output d the same calls, without cell_values_at(), on the +# white-noise response, which gives the same cells. For output f a +# profile at the seven sizes, obs_per_cell = c(18, 12, 9, 6, 4.5, 3, 2), +# for each estimate, with the other settings of the profile above. +# +# The layer is an sf layer in EPSG:32632 with the square's corner at +# (500000, 5000000), so that its coordinates are metres in a projected CRS +# and no call transforms them. The field is evaluated on the square's own +# coordinates, 0 to 1000. +# +# OUTPUTS, one row of the file per figure. `value` is taken over the rows +# (or cells, or layers) of all layers together; `n` is how many; `layer_min` +# and `layer_max` are the least and the greatest of the 200 single-layer +# values, where a single layer has one. +# +# a The root mean squared error of the pooled value over that of the plain +# mean, at the rows held out among the others: in all, and by the number +# of the layer's rows in the cell the value came from (1, 2 to 4, 5 to 9, +# 10 or more). The same in the block. +# b Coverage of the interval for one observation (..obs_lo_, ..obs_hi_) at +# 0.90: at the rows held out among the others, in the block, and over +# both by dist_ratio (below 1, 1 to 2, 2 to 4, 4 to 8, above 8; a class +# holds its upper end). +# c Coverage of the t interval of the plain mean (..ci_lo_, ..ci_hi_) at +# 0.90, read as a range for one observation, over the held-out rows whose +# cell has that interval: among the others, and in the block. +# d On the white-noise responses: the median own weight (the median over +# layers of a layer's median); the share of layers with tau2 = 0; the +# share on which spatialkit_no_structure is raised, by the summary and by +# the seeding; the correlation between a cell's pooled value and the mean +# of the pooled values of its 8 nearest cells, beside the same for plain +# means (the mean over layers of a layer's correlation). +# e The realised squared error of the pooled value over (1 - w) tau2, +# n-weighted over cells. Among the rows: a cell's level is the mean of +# the noise-free field over the further locations outside the block that +# take the cell's value (cells with at least 10). In the block: the mean +# over the further locations of the cell that lie within the block's +# radius of its centre (cells with at least 10 of those). +# f Over the profiles at the seven sizes: the share of layers on which +# `loo` is lowest at the finest size, for the pooled value and for the +# plain mean (of equal errors, the coarser level), and the share at each +# size. +# +# A held-out row or a further location takes the value of the cell +# cell_values_at() gives it: its own cell, or, when that cell has no value, +# the cell the value was filled from. +# +# `dev/` is in .Rbuildignore, so nothing here ships. +# --------------------------------------------------------------------------- + +suppressPackageStartupMessages(library(sf)) + +# Load the working tree, never the installed package. +if (!file.exists("DESCRIPTION") || !requireNamespace("pkgload", quietly = TRUE)) + stop("Run from the root of the working tree, with pkgload installed.") +pkgload::load_all(".", quiet = TRUE, helpers = FALSE, export_all = FALSE) +if (!requireNamespace("FNN", quietly = TRUE)) + stop("The simulation needs the FNN package: without it the searches of the ", + "20,000 further locations compare every pair.") +spatialkit_quiet(TRUE) +RNGkind("Mersenne-Twister", "Inversion", "Rejection") + +# ---- Settings ---------------------------------------------------------------------- + +LAYERS <- 200L +SEED <- 20261012L +SIDE <- 1000 +PARENTS <- 25L +NEAR <- 0.8 +SPREAD <- 40 +N_ROWS <- 2100L +N_FURTHER <- 20000L +WAVES <- 1000L +RANGE <- 100 +NOISE_VAR <- 0.3 +N_BLOCK <- 300L +N_AMONG <- 300L +SIZE <- 4.5 +SIZES <- c(18, 12, 9, 6, 4.5, 3, 2) +LEVEL <- 0.90 +FIT_SEED <- 123 +MIN_FURTHER <- 10L +ORIGIN <- c(5e5, 5e6) +CRS <- 32632 + +OUT_DEFAULT <- file.path("dev", "sim-pooled-values.csv") +args <- commandArgs(trailingOnly = TRUE) +layers <- if (length(args) >= 1L) suppressWarnings(as.numeric(args[[1L]])) else LAYERS +out_csv <- if (length(args) >= 2L) args[[2L]] else OUT_DEFAULT +out_rds <- if (length(args) >= 3L) args[[3L]] else NULL +if (is.na(layers) || layers != round(layers) || layers < 1 || layers > LAYERS) + stop(" is a whole number from 1 to ", LAYERS, ".") +layers <- as.integer(layers) +if (layers != LAYERS && normalizePath(out_csv, mustWork = FALSE) == + normalizePath(OUT_DEFAULT, mustWork = FALSE)) + stop("A trial of ", layers, " layers has to name another file than ", OUT_DEFAULT, ".") +out_run <- paste0(sub("\\.csv$", "", out_csv), "-run.dcf") + +# This file, as the run was started on it, and the MD5 sum of a file read as +# lines of text, which is the same whatever the line endings of a checkout. +this_file <- sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)) +if (length(this_file) != 1L || !file.exists(this_file)) + this_file <- file.path("dev", "sim-pooled-values.R") +text_md5 <- function(file) { + tmp <- tempfile() + on.exit(unlink(tmp)) + con <- file(tmp, "wb") + writeLines(readLines(file, warn = FALSE), con, sep = "\n", useBytes = TRUE) + close(con) + unname(tools::md5sum(tmp)) +} +script_md5 <- text_md5(this_file) + +# ---- The draws --------------------------------------------------------------------- + +clustered_draw <- function(n, parents) { + out <- matrix(numeric(0), 0L, 2L) + while (nrow(out) < n) { + m <- 2L * n + near <- stats::runif(m) < NEAR + p <- sample.int(nrow(parents), m, replace = TRUE) + dx <- stats::rnorm(m, 0, SPREAD) + dy <- stats::rnorm(m, 0, SPREAD) + ux <- stats::runif(m, 0, SIDE) + uy <- stats::runif(m, 0, SIDE) + x <- ifelse(near, parents[p, 1L] + dx, ux) + y <- ifelse(near, parents[p, 2L] + dy, uy) + keep <- x >= 0 & x <= SIDE & y >= 0 & y <= SIDE + out <- rbind(out, cbind(x, y)[keep, , drop = FALSE]) + } + unname(out[seq_len(n), , drop = FALSE]) +} + +wave_field <- function(xy, om, ph) { + out <- numeric(nrow(xy)) + for (from in seq.int(1L, nrow(xy), by = 4000L)) { + at <- from:min(from + 3999L, nrow(xy)) + out[at] <- sqrt(2 / WAVES) * + rowSums(cos(xy[at, , drop = FALSE] %*% t(om) + rep(ph, each = length(at)))) + } + out +} + +draw_layer <- function(f) { + set.seed(SEED + f) + parents <- cbind(stats::runif(PARENTS, 0, SIDE), stats::runif(PARENTS, 0, SIDE)) + rows <- clustered_draw(N_ROWS, parents) + further <- clustered_draw(N_FURTHER, parents) + om <- cbind(stats::rnorm(WAVES), stats::rnorm(WAVES)) / (RANGE * abs(stats::rnorm(WAVES))) + ph <- stats::runif(WAVES, 0, 2 * pi) + z_rows <- wave_field(rows, om, ph) + z_further <- wave_field(further, om, ph) + y <- z_rows + stats::rnorm(N_ROWS, 0, sqrt(NOISE_VAR)) + ctr <- stats::runif(2L, SIDE / 4, 3 * SIDE / 4) + d <- sqrt((rows[, 1L] - ctr[1L])^2 + (rows[, 2L] - ctr[2L])^2) + block <- rank(d, ties.method = "first") <= N_BLOCK + radius <- max(d[block]) + among <- seq_len(N_ROWS) %in% sample(which(!block), N_AMONG) + layer <- !block & !among + white <- stats::rnorm(sum(layer)) + list(rows = rows, further = further, y = y, z_further = z_further, ctr = ctr, + radius = radius, block = block, among = among, layer = layer, white = white) +} + +as_layer <- function(xy, ...) { + d <- data.frame(x = ORIGIN[1L] + xy[, 1L], y_coord = ORIGIN[2L] + xy[, 2L], ...) + sf::st_as_sf(d, coords = c("x", "y_coord"), crs = CRS) +} + +# ---- The package's calls ----------------------------------------------------------- + +# Runs one call, keeps the class of every warning it raises and lets none +# through; messages are not shown. +seen <- new.env() +watch <- function(step, expr) { + withCallingHandlers( + suppressMessages(expr), + warning = function(w) { + cls <- class(w)[1L] + key <- paste(step, cls, sep = ": ") + seen[[key]] <- c(seen[[key]], conditionMessage(w)) + step_classes <<- c(step_classes, key) + invokeRestart("muffleWarning") + }) +} +step_classes <- character(0) + +cells_of <- function(lay) { + step_classes <<- character(0) + prof <- watch("resolution_profile", resolution_profile( + lay, "y", estimate = "pooled", obs_per_cell = SIZE, partition = "density", + nstart = 3, sac = "auto", seed = FIT_SEED)) + sel <- watch("select_resolution", select_resolution(prof, criterion = "size")) + seeds <- watch("get_voronoi_seeds", + get_voronoi_seeds(method = "kmeans", n = sel, sample_points = lay)) + tess <- watch("build_tessellation", build_tessellation(seeds, method = "voronoi")) + asg <- watch("assign_features_to_polygons", + assign_features_to_polygons(lay, tess$cells, polygon_id_col = "cell_id")) + out <- watch("summarize_by_cell", summarize_by_cell( + asg, "y", id_col = "cell_id", cells_sf = tess$cells, estimate = "pooled", + obs_level = LEVEL, conf_level = LEVEL)) + seeds$cell_id <- tess$index + list(sel = sel, seeds = seeds, tess = tess, asg = asg, out = out, + raised = step_classes) +} + +values_at <- function(new, fit) { + at <- watch("cell_values_at", + cell_values_at(new, fit$out, fit$asg, "y", id_col = "cell_id", + seeds = fit$seeds)) + # The row of the summary the value came from. + at$from <- match(ifelse(at$filled, at$filled_from, at$cell_id), fit$out$cell_id) + at +} + +# The 8 nearest other cells of every cell, by the centroids of their rows. +neighbour_means <- function(fit) { + xy <- sf::st_coordinates(fit$asg) + row <- match(fit$asg$cell_id, fit$out$cell_id) + n <- tabulate(row, nrow(fit$out)) + has <- which(n > 0L) + cen <- rowsum(xy, row) / n[has] + d2 <- as.matrix(stats::dist(cen))^2 + diag(d2) <- Inf + k <- min(8L, length(has) - 1L) + nb <- t(apply(d2, 1L, function(d) order(d)[seq_len(k)])) + list(has = has, nb = nb, n = n[has]) +} + +# ---- The layers -------------------------------------------------------------------- + +size_class <- function(n) cut(n, c(0, 1, 4, 9, Inf), + labels = c("1 row", "2 to 4 rows", "5 to 9 rows", + "10 rows or more")) +ratio_class <- function(r) cut(r, c(-Inf, 1, 2, 4, 8, Inf), + labels = c("below 1", "1 to 2", "2 to 4", "4 to 8", "above 8")) + +held <- level <- white <- sizes <- info <- vector("list", layers) +t0 <- proc.time()[[3L]] +for (f in seq_len(layers)) { + L <- draw_layer(f) + lay <- as_layer(L$rows[L$layer, , drop = FALSE], y = L$y[L$layer]) + fit <- cells_of(lay) + out <- fit$out + rec <- attr(out, "pooled")$columns$resp_y + + # a, b, c: the held-out rows + hsel <- L$among | L$block + at <- values_at(as_layer(L$rows[hsel, , drop = FALSE]), fit) + yh <- L$y[hsel] + stopifnot(isTRUE(all.equal(at$value, out$..pooled_resp_y[at$from]))) + held[[f]] <- data.frame( + layer = f, + where = ifelse(L$block[hsel], "block", "among"), + n_cell = out$n[at$from], + e_pooled = yh - at$value, + e_mean = yh - out$resp_mean_y[at$from], + in_obs = yh >= at$obs_lo & yh <= at$obs_hi, + in_ci = yh >= out$..ci_lo_resp_y[at$from] & yh <= out$..ci_hi_resp_y[at$from], + ratio = at$dist_ratio, + filled = at$filled) + + # e: the level of a cell from the noise-free field at the further locations + atf <- values_at(as_layer(L$further), fit) + inb <- sqrt((L$further[, 1L] - L$ctr[1L])^2 + (L$further[, 2L] - L$ctr[2L])^2) <= L$radius + g1 <- (1 - out$..pooled_w_resp_y) * rec$tau2 + one <- function(sel, where) { + sel <- sel & !is.na(atf$from) + cnt <- tabulate(atf$from[sel], nrow(out)) + ok <- cnt >= MIN_FURTHER & !is.na(out$..pooled_resp_y) + sums <- rowsum(L$z_further[sel], atf$from[sel]) + lev <- rep(NA_real_, nrow(out)) + lev[as.integer(rownames(sums))] <- sums[, 1L] / cnt[as.integer(rownames(sums))] + data.frame(layer = f, where = where, cells = sum(ok), + realised = sum(out$n[ok] * (out$..pooled_resp_y[ok] - lev[ok])^2), + stated = sum(out$n[ok] * g1[ok])) + } + level[[f]] <- rbind(one(!inb, "among"), one(inb, "block")) + # Every warning of the field's calls: the six of item 6 and cell_values_at(). + raised_field <- step_classes + + # d: white noise on the same rows, which gives the same cells + lay_w <- lay + lay_w$y <- L$white + fw <- cells_of(lay_w) + stopifnot(identical(sf::st_coordinates(fw$seeds), sf::st_coordinates(fit$seeds))) + ow <- fw$out + recw <- attr(ow, "pooled")$columns$resp_y + nbw <- neighbour_means(fw) + with_nb <- function(v) stats::cor(v, rowMeans(matrix(v[nbw$nb], nrow(nbw$nb)))) + # The neighbours found here are the summary's: its target is their mean. + mw <- ow$resp_mean_y[nbw$has] + tg <- rowSums(matrix((nbw$n * mw)[nbw$nb], nrow(nbw$nb))) / + rowSums(matrix(nbw$n[nbw$nb], nrow(nbw$nb))) + stopifnot(isTRUE(all.equal(tg, ow$..pooled_target_resp_y[nbw$has]))) + white[[f]] <- data.frame( + layer = f, own_weight = recw$own_weight, tau2_zero = recw$tau2 == 0, + structured = recw$structured, + raised_summary = "summarize_by_cell: spatialkit_no_structure" %in% fw$raised, + raised_seeding = "get_voronoi_seeds: spatialkit_no_structure" %in% fw$raised, + cor_pooled = with_nb(ow$..pooled_resp_y[nbw$has]), cor_mean = with_nb(mw)) + + # f: the seven sizes, for each estimate + lowest <- function(estimate) { + p <- watch("resolution_profile (seven sizes)", resolution_profile( + lay, "y", estimate = estimate, obs_per_cell = SIZES, partition = "density", + nstart = 3, sac = "auto", seed = FIT_SEED)) + lev <- attr(p, "bounds")$size_levels + p <- p[order(p$levels), ] + at <- p$levels[which.min(p$loo)] + as.numeric(names(lev)[match(at, lev)]) + } + step_classes <- character(0) + sizes[[f]] <- data.frame(layer = f, pooled = lowest("pooled"), mean = lowest("mean")) + raised_sizes <- step_classes + + info[[f]] <- data.frame( + layer = f, cells = nrow(fit$tess$cells), occupied = rec$cells, rows = rec$n, + share_alone = rec$share_alone, own_weight = rec$own_weight, tau2 = rec$tau2, + structured = rec$structured, check = attr(out, "count_rule")$check$cells, + filled_held = sum(at$filled), filled_further = sum(atf$filled), + warnings = paste(unique(raised_field), collapse = "; "), + warnings_white = paste(unique(fw$raised), collapse = "; "), + warnings_sizes = paste(unique(raised_sizes), collapse = "; ")) + # The line names every warning of the layer but the one output d counts, + # spatialkit_no_structure on the white-noise response. + other_white <- unique(grep("spatialkit_no_structure$", fw$raised, value = TRUE, invert = TRUE)) + said <- c(if (nzchar(info[[f]]$warnings)) paste0("raised: ", info[[f]]$warnings), + if (length(other_white)) + paste0("on white noise: ", paste(other_white, collapse = "; ")), + if (nzchar(info[[f]]$warnings_sizes)) + paste0("at the seven sizes: ", info[[f]]$warnings_sizes)) + cat(sprintf("layer %3d: %d cells, %d occupied, %.1f%% of rows alone, check %s, %d s%s\n", + f, info[[f]]$cells, info[[f]]$occupied, 100 * info[[f]]$share_alone, + info[[f]]$check, round(proc.time()[[3L]] - t0), + if (length(said)) paste0("; ", said, collapse = "") else "")) +} +held <- do.call(rbind, held) +level <- do.call(rbind, level) +white <- do.call(rbind, white) +sizes <- do.call(rbind, sizes) +info <- do.call(rbind, info) + +# ---- The six outputs --------------------------------------------------------------- + +rows <- list() +add <- function(output, quantity, where, class, value, n, by_layer = NULL) { + rows[[length(rows) + 1L]] <<- data.frame( + output = output, quantity = quantity, where = where, class = class, + value = value, n = n, + layer_min = if (length(by_layer)) min(by_layer, na.rm = TRUE) else NA_real_, + layer_max = if (length(by_layer)) max(by_layer, na.rm = TRUE) else NA_real_) +} +rmse_ratio <- function(x) if (nrow(x)) sqrt(sum(x$e_pooled^2) / sum(x$e_mean^2)) else NA_real_ +per_layer <- function(x, fun) vapply(split(x, x$layer), fun, numeric(1)) + +for (w in c("among", "block")) { + x <- held[held$where == w, ] + add("a", "RMSE of the pooled value over RMSE of the plain mean", w, "all rows", + rmse_ratio(x), nrow(x), per_layer(x, rmse_ratio)) + for (cl in levels(size_class(1))) { + xc <- x[size_class(x$n_cell) == cl, ] + add("a", "RMSE of the pooled value over RMSE of the plain mean", w, + paste(cl, "of the layer in the cell"), rmse_ratio(xc), nrow(xc)) + } +} +for (w in c("among", "block")) { + x <- held[held$where == w, ] + add("b", "coverage of the 0.90 interval for one observation", w, "all rows", + mean(x$in_obs), nrow(x), per_layer(x, function(v) mean(v$in_obs))) +} +for (cl in levels(ratio_class(1))) { + x <- held[ratio_class(held$ratio) == cl, ] + add("b", "coverage of the 0.90 interval for one observation", "among and block", + paste("dist_ratio", cl), mean(x$in_obs), nrow(x)) +} +for (w in c("among", "block")) { + x <- held[held$where == w & !is.na(held$in_ci), ] + add("c", "coverage of the 0.90 t interval of the plain mean, read as a range for one observation", + w, "rows whose cell has the interval", mean(x$in_ci), nrow(x), + per_layer(x, function(v) mean(v$in_ci))) +} +add("d", "median own weight", "white noise", "layers", + stats::median(white$own_weight), nrow(white), white$own_weight) +add("d", "share of layers with tau2 = 0", "white noise", "layers", + mean(white$tau2_zero), nrow(white)) +add("d", "share of layers on which summarize_by_cell() raises spatialkit_no_structure", + "white noise", "layers", mean(white$raised_summary), nrow(white)) +add("d", "share of layers on which get_voronoi_seeds() raises spatialkit_no_structure", + "white noise", "layers", mean(white$raised_seeding), nrow(white)) +add("d", "correlation of a cell's pooled value with the mean of its 8 nearest cells'", + "white noise", "layers", mean(white$cor_pooled), nrow(white), white$cor_pooled) +add("d", "correlation of a cell's plain mean with the mean of its 8 nearest cells'", + "white noise", "layers", mean(white$cor_mean), nrow(white), white$cor_mean) +for (w in c("among", "block")) { + x <- level[level$where == w, ] + add("e", "realised squared error of the pooled value over (1 - w) tau2", w, + sprintf("cells with at least %d further locations", MIN_FURTHER), + sum(x$realised) / sum(x$stated), sum(x$cells), x$realised / x$stated) +} +for (est in c("pooled", "mean")) { + what <- if (est == "pooled") "pooled value" else "plain mean" + add("f", "share of layers with the lowest loo at the finest size", what, + sprintf("obs_per_cell = %s", min(SIZES)), mean(sizes[[est]] == min(SIZES)), nrow(sizes)) + for (s in SIZES) + add("f", "share of layers with the lowest loo at this size", what, + sprintf("obs_per_cell = %s", s), mean(sizes[[est]] == s), nrow(sizes)) +} +result <- do.call(rbind, rows) +result$value <- signif(result$value, 6) +result$layer_min <- signif(result$layer_min, 6) +result$layer_max <- signif(result$layer_max, 6) +utils::write.csv(result, out_csv, row.names = FALSE) +if (!is.null(out_rds)) + saveRDS(list(held = held, level = level, white = white, sizes = sizes, info = info, + result = result, warnings = as.list(seen)), out_rds) + +# The record of the run. The script is read again: a file edited while the +# run was under way is not the file the figures came from. +if (!identical(text_md5(this_file), script_md5)) + stop(this_file, " changed during the run: run it again.") +seconds <- round(proc.time()[[3L]] - t0) +write.dcf(data.frame( + script = "dev/sim-pooled-values.R", script_md5 = script_md5, + csv_md5 = text_md5(out_csv), layers = layers, date = format(Sys.Date()), + seconds = seconds, R = as.character(getRversion()), platform = R.version$platform, + sf = as.character(utils::packageVersion("sf")), + FNN = as.character(utils::packageVersion("FNN")), + spatialkit = unname(read.dcf("DESCRIPTION", "Version")[1L, 1L]), + stringsAsFactors = FALSE), out_run) + +# ---- What the run was -------------------------------------------------------------- + +cat(sprintf("\n%d layers in %.0f s; R %s, sf %s, FNN %s\n", layers, seconds, + getRversion(), utils::packageVersion("sf"), utils::packageVersion("FNN"))) +cat(sprintf("cells per layer %d to %d; occupied %d to %d; rows alone in their cell %.2f%% (mean)\n", + min(info$cells), max(info$cells), min(info$occupied), max(info$occupied), + 100 * mean(info$share_alone))) +cat(sprintf("held-out rows filled from another cell: %d; further locations filled: %d\n", + sum(info$filled_held), sum(info$filled_further))) +cat("the summary's check of the cells, by layer:\n") +print(table(info$check, useNA = "ifany")) +cat("structured, field layers / white-noise layers:\n") +print(table(field = info$structured, useNA = "ifany")) +print(table(white = white$structured, useNA = "ifany")) +cat("warnings raised, by call and class (times raised):\n") +for (k in sort(ls(seen))) cat(sprintf(" %s: %d\n", k, length(seen[[k]]))) +cat("\n") +options(width = 250) +print(result, row.names = FALSE) +cat(sprintf("\nwritten: %s and %s\n", out_csv, out_run)) diff --git a/dev/sim-pooled-values.csv b/dev/sim-pooled-values.csv new file mode 100644 index 00000000..fb979ad9 --- /dev/null +++ b/dev/sim-pooled-values.csv @@ -0,0 +1,44 @@ +"output","quantity","where","class","value","n","layer_min","layer_max" +"a","RMSE of the pooled value over RMSE of the plain mean","among","all rows",0.962294,60000,0.918136,1.02014 +"a","RMSE of the pooled value over RMSE of the plain mean","among","1 row of the layer in the cell",0.840612,1284,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","among","2 to 4 rows of the layer in the cell",0.948905,26089,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","among","5 to 9 rows of the layer in the cell",0.980529,31460,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","among","10 rows or more of the layer in the cell",0.99473,1167,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","block","all rows",0.945755,60000,0.785164,1.11279 +"a","RMSE of the pooled value over RMSE of the plain mean","block","1 row of the layer in the cell",0.836845,3087,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","block","2 to 4 rows of the layer in the cell",0.938174,28927,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","block","5 to 9 rows of the layer in the cell",0.970385,27043,NA,NA +"a","RMSE of the pooled value over RMSE of the plain mean","block","10 rows or more of the layer in the cell",0.989279,943,NA,NA +"b","coverage of the 0.90 interval for one observation","among","all rows",0.896233,60000,0.836667,0.94 +"b","coverage of the 0.90 interval for one observation","block","all rows",0.7513,60000,0.52,0.906667 +"b","coverage of the 0.90 interval for one observation","among and block","dist_ratio below 1",0.915404,31089,NA,NA +"b","coverage of the 0.90 interval for one observation","among and block","dist_ratio 1 to 2",0.8918,23355,NA,NA +"b","coverage of the 0.90 interval for one observation","among and block","dist_ratio 2 to 4",0.839461,17080,NA,NA +"b","coverage of the 0.90 interval for one observation","among and block","dist_ratio 4 to 8",0.778957,18286,NA,NA +"b","coverage of the 0.90 interval for one observation","among and block","dist_ratio above 8",0.695031,30190,NA,NA +"c","coverage of the 0.90 t interval of the plain mean, read as a range for one observation","among","rows whose cell has the interval",0.58863,58716,0.501706,0.686007 +"c","coverage of the 0.90 t interval of the plain mean, read as a range for one observation","block","rows whose cell has the interval",0.492225,56913,0.268382,0.751678 +"d","median own weight","white noise","layers",0.105451,200,0,0.279866 +"d","share of layers with tau2 = 0","white noise","layers",0.1,200,NA,NA +"d","share of layers on which summarize_by_cell() raises spatialkit_no_structure","white noise","layers",1,200,NA,NA +"d","share of layers on which get_voronoi_seeds() raises spatialkit_no_structure","white noise","layers",1,200,NA,NA +"d","correlation of a cell's pooled value with the mean of its 8 nearest cells'","white noise","layers",0.7939,200,0.590014,0.889456 +"d","correlation of a cell's plain mean with the mean of its 8 nearest cells'","white noise","layers",-0.0193026,200,-0.215616,0.173319 +"e","realised squared error of the pooled value over (1 - w) tau2","among","cells with at least 10 further locations",0.979804,66502,0.765017,1.23565 +"e","realised squared error of the pooled value over (1 - w) tau2","block","cells with at least 10 further locations",6.91133,3860,0.961802,22.3327 +"f","share of layers with the lowest loo at the finest size","pooled value","obs_per_cell = 2",0.88,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 18",0,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 12",0,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 9",0,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 6",0,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 4.5",0.01,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 3",0.11,200,NA,NA +"f","share of layers with the lowest loo at this size","pooled value","obs_per_cell = 2",0.88,200,NA,NA +"f","share of layers with the lowest loo at the finest size","plain mean","obs_per_cell = 2",0,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 18",0.005,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 12",0.06,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 9",0.245,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 6",0.43,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 4.5",0.255,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 3",0.005,200,NA,NA +"f","share of layers with the lowest loo at this size","plain mean","obs_per_cell = 2",0,200,NA,NA diff --git a/inst/scripts/00-run-all.R b/inst/scripts/00-run-all.R index f630f030..552de7c5 100644 --- a/inst/scripts/00-run-all.R +++ b/inst/scripts/00-run-all.R @@ -5,7 +5,7 @@ # # Runs scripts 01 to 10 in order, reporting how long each took and what it # skipped. Scripts 02 (resolution), 09 (GWR) and 10 (Bayesian) need optional -# packages -- gstat, GWmodel, brms -- and skip themselves cleanly when those +# packages -- gstat, sp, brms -- and skip themselves cleanly when those # are missing; the others skip only the part that needs one. # # Scripts 01 to 09 run in about a minute between them. Script 10 takes several diff --git a/inst/scripts/01-tessellations.R b/inst/scripts/01-tessellations.R index 80f6cee1..a98641f5 100644 --- a/inst/scripts/01-tessellations.R +++ b/inst/scripts/01-tessellations.R @@ -12,10 +12,12 @@ source(file.path(.tour_dir, "_common.R")) pts <- tour_points() bnd <- tour_boundary(pts) -step("01.1", "Voronoi cells grown from k-means seeds") +step("01.1", "Voronoi cells grown from density-weighted k-means seeds") # Voronoi cells grow from SEEDS, so place the seeds first and tessellate those. # Hand build_tessellation() the observations instead and you get one cell per -# observation, which is section 01.5. +# observation, which is section 01.5. The seeds are density-weighted k-means +# from 3 starts, the default; partition = "kmeans" gives the plain k-means +# seeds of earlier versions. seeds <- get_voronoi_seeds(boundary = bnd, method = "kmeans", n = 25, sample_points = pts, set_seed = 1) vor <- build_tessellation(seeds, boundary = bnd, method = "voronoi", @@ -50,7 +52,10 @@ if (!skip_without("ggplot2", "the maps")) { list(voronoi = vor, hex = hex, square = sqr, triangles = tri)))) { t_ <- list(voronoi = vor, hex = hex, square = sqr, triangles = tri)[[nm]] asg <- assign_features_to_polygons(pts, t_$cells) - cel <- summarize_by_cell(asg, "z", cells_sf = t_$cells, deff = 1) + # The maps show the plain mean of each cell, so the summary leaves out + # the pooled values it adds by default. + cel <- summarize_by_cell(asg, "z", cells_sf = t_$cells, deff = 1, + estimate = "mean") look_for(sprintf("%s -- %s", nm, notes[[nm]])) show_plot(plot_tessellation_map(cel, boundary = bnd, features_sf = pts, fill_col = "resp_mean_z", @@ -69,7 +74,8 @@ step("01.5", "Voronoi over the observations themselves") trap <- build_tessellation(pts, boundary = bnd, method = "voronoi", approx_n_cells = 25, quiet = TRUE) asg1 <- assign_features_to_polygons(pts, trap$cells) -cel1 <- summarize_by_cell(asg1, "z", cells_sf = trap$cells, deff = 1) +cel1 <- summarize_by_cell(asg1, "z", cells_sf = trap$cells, deff = 1, + estimate = "mean") cat(sprintf(" asked for 25 cells, got %d; %d hold one point or none, %d SEs are NA\n", nrow(cel1), sum(cel1$n <= 1, na.rm = TRUE), sum(is.na(cel1$..se_resp_z)))) diff --git a/inst/scripts/02-resolution.R b/inst/scripts/02-resolution.R index 9b205835..86dc8a5e 100644 --- a/inst/scripts/02-resolution.R +++ b/inst/scripts/02-resolution.R @@ -37,8 +37,10 @@ step("02.2", "Candidate cell counts, cheapest first") lv <- determine_optimal_levels(pts, max_levels = 40) cat(" geometric candidates:", paste(lv, collapse = ", "), "\n") -# With a response and predictors it can also score levels on residual spatial -# autocorrelation. `criterion = "combined"` REQUIRES both. +# With a response it can also rank the counts around the elbow by Moran's z of +# the cell means (of their residuals on the predictors when those are given). +# That statistic is a diagnostic and not a count rule, and the call says so in +# a warning of class "spatialkit_diagnostic_ranking". lv2 <- determine_optimal_levels(pts, max_levels = 40, criterion = "combined", response_var = "z", predictor_vars = "elev") cat(" combined candidates:", paste(lv2, collapse = ", "), "\n") @@ -46,7 +48,11 @@ cat(" combined candidates:", paste(lv2, collapse = ", "), "\n") step("02.3", "The full ladder") # resolution_profile() actually builds each level and reports what it costs: # how many points land in the smallest cell, how much of the variance survives, -# and whether the residuals are still autocorrelated. +# whether the residuals are still autocorrelated, and the leave-one-out error +# of the pooled cell value. n_levels asks for the ladder; with nothing named +# but the response the profile is one size instead (02.7). The cells are +# density-weighted k-means, the default; partition = "kmeans" gives the +# k-means cells of earlier versions. prof <- resolution_profile(pts, response_var = "z", n_levels = 16) print(prof) @@ -54,18 +60,22 @@ step("02.4", "Four criteria, four answers") # Each criterion also reports the band of levels it cannot tell apart from its # own pick. The spread BETWEEN criteria is usually wider than any one of those # bands, and it is the more honest measure of how much the data pins this down. -for (cr in c("cp", "reliability", "elbow", "moran_z")) { +# loo is the leave-one-out error of the pooled value. A pick at the finest +# level is the end of the ladder choosing, and the selection says so. The +# profile's fifth column, moran_z, is a diagnostic of the cell means and not a +# count rule: select_resolution() refuses it unless asked with +# diagnostic = TRUE, so it is not read here. +for (cr in c("cp", "reliability", "elbow", "loo")) { s <- try(select_resolution(prof, criterion = cr), silent = TRUE) if (inherits(s, "try-error")) { cat(sprintf(" %-12s not available on this profile\n", cr)) next } - # `edge` names the bound an optimum sits on: the range floor, the support - # ceiling, or the first level the criterion can be computed at (above nine - # cells for moran_z). There the bound chose and the criterion did not. + # `edge` names the bound an optimum sits on: the range floor or the support + # ceiling. There the bound chose and the criterion did not. # n_levels only sets how many rungs fall between the ends, so it cannot move - # them: lower min_cell_n to move the ceiling, or set range_floor = FALSE (or - # pass `levels`) to move the floor, and run it again. + # them: lower min_cell_n to move the ceiling, or pass range_floor = FALSE to + # select_resolution() to read reliability below the floor, and run it again. edge <- if (!is.na(s$edge)) paste0(" <- at ", s$edge) else "" # The flat region is a SET: it can skip a rung, so printing its first two # members as "a to b" both truncated it and implied the levels between were @@ -83,7 +93,8 @@ if (!skip_without("ggplot2", "the profile plot")) { look_for("where the curves stop moving. A criterion whose optimum sits at ", "the first or last level it was scored at did not choose: the bound ", "did, and the caption says which. Lower min_cell_n to move the ", - "ceiling, or set range_floor = FALSE to move the floor, and run it again.") + "ceiling, or pass range_floor = FALSE to select_resolution() to read ", + "reliability below the floor, and run it again.") show_plot(plot(prof), "02-profile.png", height = 7) } @@ -124,8 +135,8 @@ cat(" What the split buys: the estimation half's response never enters the\n", step("02.6", "What the chosen resolution looks like") if (!skip_without("ggplot2", "the maps")) { bnd <- tour_boundary(pts) - # Cp, the default criterion: these evenly spread points have no elbow (see - # 02.2), so the elbow names no count to draw. + # Cp, the criterion a ladder of counts has been read by: these evenly spread + # points have no elbow (see 02.2), so the elbow names no count to draw. s_cp <- select_resolution(prof, "cp") chosen <- s_cp$best for (k in sort(unique(c(min(prof$levels), chosen, max(prof$levels))))) { @@ -133,8 +144,11 @@ if (!skip_without("ggplot2", "the maps")) { sample_points = pts, set_seed = 1) tess <- build_tessellation(seeds, boundary = bnd, method = "voronoi", quiet = TRUE) + # The maps show the plain mean of each cell: estimate = "mean" leaves out + # the pooled values the summary adds by default. cel <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), - "z", cells_sf = tess$cells, deff = 1) + "z", cells_sf = tess$cells, deff = 1, + estimate = "mean") note <- if (k == chosen) paste0("the Cp pick", if (!is.na(s_cp$edge)) paste0(" (at ", s_cp$edge, ")") else "", ": enough cells to show the field, few enough to fill.") @@ -150,4 +164,15 @@ if (!skip_without("ggplot2", "the maps")) { } } +step("02.7", "The default: a size, not a criterion") +# Called with the response alone, resolution_profile() scores one level: 4.5 +# observations per cell, for the pooled value summarize_by_cell() reports by +# default. select_resolution() reads the count off that size, which neither a +# criterion nor the response chose: round(n / 4.5) cells. share_alone and +# own_weight say what a cell value stands on at that size. The earlier +# defaults are estimate = NULL, obs_per_cell = NULL in the profile and +# criterion = "cp" in the selection. +prof_size <- resolution_profile(pts, response_var = "z") +print(select_resolution(prof_size)) + } diff --git a/inst/scripts/05-fit-diagnose.R b/inst/scripts/05-fit-diagnose.R index a5fde7af..2cd76fb6 100644 --- a/inst/scripts/05-fit-diagnose.R +++ b/inst/scripts/05-fit-diagnose.R @@ -93,6 +93,7 @@ step("05.6", "Is aggregating to cells even worth it?") # 'should I report cell means or a surface'. if (!skip_without("gstat", "the adequacy check")) { bnd <- tour_boundary(pts) + # Twenty density-weighted k-means cells, the default kind of seeds. seeds <- get_voronoi_seeds(boundary = bnd, method = "kmeans", n = 20, sample_points = pts, set_seed = 1) tess <- build_tessellation(seeds, boundary = bnd, method = "voronoi", quiet = TRUE) @@ -108,12 +109,14 @@ if (!skip_without("gstat", "the adequacy check")) { if (zv > 0.7 && zv < 1.4) "yes, near 1: the standard errors mean what they say" else if (zv >= 1.4) "no, above 1: the model understates its own error" else "no, below 1: the model overstates its own error")) - cat(sprintf(" would kriging move the cell means? %d of %d cells by > 1 SE\n", - moved, nrow(ka))) - cat(sprintf(" %s\n", if (moved == 0) - "no: report the plain cell means, kriging buys nothing here" else - "yes: the plain means are biased by where the samples fell inside each cell")) - cat(" The interesting case is honest uncertainties AND large shifts: that is\n", + cat(sprintf(paste0(" would kriging move the cell means? %d of %d cells by more than 1\n", + " standard deviation of the difference under the variogram (about a\n", + " third when the variogram is right)\n"), + moved, sum(is.finite(ka$kr_shift)))) + cat(sprintf(paste0(" what would it buy? median kr_gain %.2f, the share of\n", + " the plain mean's error variance that kriging removes in a cell\n"), + stats::median(ka$kr_gain, na.rm = TRUE))) + cat(" The interesting case is honest uncertainties AND a large gain: that is\n", " when the extra machinery earns its place in the methods section.\n", sep = "") } diff --git a/inst/scripts/06-cv-compare.R b/inst/scripts/06-cv-compare.R index 91a1f51f..3863b24f 100644 --- a/inst/scripts/06-cv-compare.R +++ b/inst/scripts/06-cv-compare.R @@ -88,7 +88,7 @@ if (!skip_without("ggplot2", "the metric plot")) { step("06.4", "The built-in backends") # compare_models_cv() drives the package's own model families (RF, GWR, # Bayesian) through one interface and one set of folds. -avail <- c(RF = have("ranger"), GWR = have("GWmodel"), Bayesian = have("brms")) +avail <- c(RF = have("ranger"), GWR = have("sp"), Bayesian = have("brms")) cat(" backends available here:", paste(names(avail)[avail], collapse = ", "), "\n") if (any(avail[c("RF", "GWR")])) { @@ -105,7 +105,7 @@ if (any(avail[c("RF", "GWR")])) { cat(" Bayesian is left out here because it is slow; script 10 runs it and\n", " shows what its extra output buys.\n", sep = "") } else { - cat(" SKIPPED: install.packages(c(\"ranger\", \"GWmodel\"))\n") + cat(" SKIPPED: install.packages(c(\"ranger\", \"sp\"))\n") } step("06.5", "The score that picked the winner cannot also grade it") diff --git a/inst/scripts/09-gwr.R b/inst/scripts/09-gwr.R index 978e2043..6b4b6ce8 100644 --- a/inst/scripts/09-gwr.R +++ b/inst/scripts/09-gwr.R @@ -7,8 +7,8 @@ system.file("scripts", package = "spatialkit") else "." source(file.path(.tour_dir, "_common.R")) -if (skip_without(c("GWmodel", "sp"), "the whole of script 09")) { - cat(" GWR needs GWmodel, which needs sp. Nothing else in the tour does.\n") +if (skip_without("sp", "the whole of script 09")) { + cat(" GWR needs sp, which holds a fit's local estimates. Nothing else in the tour does.\n") } else { pts <- tour_points() diff --git a/inst/scripts/example_nc_demo.R b/inst/scripts/example_nc_demo.R index a831fe56..b1b17427 100644 --- a/inst/scripts/example_nc_demo.R +++ b/inst/scripts/example_nc_demo.R @@ -27,7 +27,7 @@ # install.packages("ranger") # random forest backend # install.packages("gstat") # autocorrelation range # install.packages("geometry") # Delaunay triangulation -# install.packages(c("sp", "GWmodel")) # GWR backend (optional) +# install.packages("sp") # GWR backend (optional) # Anything missing is skipped with a message rather than failing. # # 3. Run it: @@ -52,8 +52,7 @@ has_ggplot <- requireNamespace("ggplot2", quietly = TRUE) has_ranger <- requireNamespace("ranger", quietly = TRUE) has_gstat <- requireNamespace("gstat", quietly = TRUE) has_geom <- requireNamespace("geometry", quietly = TRUE) -has_gwmodel <- requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE) +has_gwr <- requireNamespace("sp", quietly = TRUE) if (!has_ggplot) stop("This demo draws maps and needs ggplot2. install.packages(\"ggplot2\")", @@ -141,10 +140,15 @@ predictor_vars <- c("elevation", "pop_density") cat("\n--- Building tessellations ---\n") -# 3a. Voronoi from ~40 k-means seeds. Cells are built around the SEEDS, not -# the observations: one cell per observation is a nearest-neighbour -# interpolation rather than an aggregation, and leaves no within-cell -# variation to compute a standard error from. +# 3a. Voronoi from ~40 density-weighted k-means seeds, the default +# (partition = "kmeans" gives the plain k-means seeds of earlier versions). +# Cells are built around the SEEDS, not the observations: one cell per +# observation is a nearest-neighbour interpolation rather than an +# aggregation, and leaves no within-cell variation to compute a standard +# error from. A density-weighted centre can lie just outside the state +# outline, over a sound that coastal observations surround; build_tessellation() +# then warns that one seed falls in no cell. Its cell is still built inside +# the outline, and every observation falls in a cell. seeds <- get_voronoi_seeds( boundary = nc_boundary, sample_points = points_sf, @@ -156,6 +160,12 @@ tess_voronoi <- build_tessellation( method = "voronoi", clip = TRUE, quiet = TRUE ) cat(sprintf(" Voronoi: %d cells\n", nrow(tess_voronoi$cells))) +n_out <- sum(is.na(tess_voronoi$index)) +if (n_out > 0) + cat(sprintf(paste0(" %d of %d seeds lie just outside the state outline, so the ", + "warning above says\n they fall in no cell; their cells are ", + "built inside the outline, and every\n observation falls in ", + "a cell.\n"), n_out, nrow(seeds))) # 3b / 3c. Hex and square grids (~50 cells). Both keep `cell_id`. tess_hex <- build_tessellation( @@ -188,9 +198,10 @@ if (has_geom) { # 4. CELL-LEVEL AGGREGATION AND CHOROPLETHS # ============================================================================= # summarize_by_cell() does the aggregation: mean, sd and se for the response -# and every predictor, plus n and cell_weight. There is no need to write the -# group_by()/summarise() by hand, and doing so loses the design-effect -# machinery shown below. +# and every predictor, plus n and cell_weight, and by default a pooled value +# beside each mean (estimate = "mean" leaves it out). There is no need to +# write the group_by()/summarise() by hand, and doing so loses the +# design-effect machinery shown below. make_choropleth <- function(tess, boundary, points, title = NULL, fill_col = "resp_mean_y", @@ -312,9 +323,9 @@ if (requireNamespace("patchwork", quietly = TRUE)) { } if (has_ranger) { - # include_coords = TRUE hands the forest the coordinates, so it can memorise - # the training surface. That is the failure mode the default (FALSE) exists - # to prevent, and the one random folds cannot see. + # include_coords = TRUE hands the forest the coordinates, so it can fit the + # training surface by location. A random hold-out then overstates its + # accuracy, which random folds cannot show. rf_args <- list(include_coords = TRUE, num_trees = 300, seed = 1) cv_random <- do.call(cv_rf, c(list(points_sf, response_var, predictor_vars, folds = folds_random), rf_args)) @@ -354,7 +365,7 @@ if (has_ranger) { } gwr_fit <- NULL -if (has_gwmodel) { +if (has_gwr) { gwr_fit <- tryCatch( fit_gwr_model(data_sf = points_sf, response_var = response_var, predictor_vars = predictor_vars, @@ -369,7 +380,7 @@ if (has_gwmodel) { gwr_fit$info$bandwidth, met$R2, met$RMSE)) } } else { - cat(" Skipping GWR: install.packages(c(\"sp\", \"GWmodel\"))\n") + cat(" Skipping GWR: install.packages(\"sp\")\n") } # Aggregate absolute model error onto each tessellation. diff --git a/man/area_of_applicability.Rd b/man/area_of_applicability.Rd index 9ea5d43d..ed58a559 100644 --- a/man/area_of_applicability.Rd +++ b/man/area_of_applicability.Rd @@ -9,32 +9,44 @@ area_of_applicability( model = NULL, train_sf = NULL, predictor_vars = NULL, - weights = NULL, + weights = "auto", folds = NULL, threshold = NULL, normalizer_max_n = 5000L, seed = 123L, chunk_size = NULL, - use_fnn = requireNamespace("FNN", quietly = TRUE) + use_fnn = requireNamespace("FNN", quietly = TRUE), + coords = c("auto", "yes", "no"), + categorical = c("refuse", "indicator", "drop") ) } \arguments{ \item{newdata}{Prediction locations: an \code{sf} object (typically from \code{\link{predict_surface}}) or a data.frame, carrying the predictor -columns. For a model fitted with \code{include_coords = TRUE} an -\code{sf} object is required, non-\code{POINT} geometry is reduced to -representative points, and a CRS mismatch with the training data is -reconciled; see \emph{Models fitted with the coordinates as predictors}.} +columns. When location is measured (a \code{gwr_fit}, a +\code{bayesian_fit}, a forest fitted with \code{include_coords = TRUE}, +or \code{coords = "yes"}) an \code{sf} object is required, +non-\code{POINT} geometry is reduced to representative points, and a CRS +mismatch with the training data is reconciled; see \emph{Models whose +predictions depend on location}.} \item{model}{A fitted \code{spatial_fit}, supplying the training data and -predictor names. Optional if \code{train_sf} and \code{predictor_vars} are -given directly, which lets this be used with any model.} +predictor names, the importance \code{weights = "auto"} reads, and +whether its predictions depend on location. Optional if \code{train_sf} +and \code{predictor_vars} are given directly, which lets this be used +with any model.} \item{train_sf}{Training data, if not taken from \code{model}.} \item{predictor_vars}{Predictor names, if not taken from \code{model}.} -\item{weights}{Optional named numeric vector of predictor importances. Any +\item{weights}{\code{"auto"} (default), \code{NULL}, or a named numeric +vector of predictor importances. \code{"auto"} uses +\code{pmax(model$info$importance, 0)} when \code{model} carries a finite +importance with at least one positive value, naming every predictor in +use, from a model with out-of-bag skill; otherwise every predictor counts +equally and a logged note says why (see \emph{Weights}). \code{NULL} is +the explicit request for equal weights. For a vector of your own, any positive scale works. When \code{model} was fitted with \code{include_coords = TRUE}, the coordinates \code{"..x"} and \code{"..y"} are measured as predictors too (see below), and you are not @@ -46,10 +58,10 @@ coordinate columns. Weights must be finite and non-negative, so pass permutation importance as \code{pmax(importance, 0)}. (A forest with no out-of-bag rows, \code{replace = FALSE} with \code{sample_fraction = 1}, has \code{NaN} importance, which \code{pmax()} keeps and which is -refused; refit it with out-of-bag rows or use \code{weights = NULL}.) +refused when passed by hand; \code{"auto"} uses equal weights for it.) \code{pmax(importance, 0)} is all zero when the model found no -predictor useful, and then the weights cannot say -anything: with a single predictor any weight gives the same index and zero +predictor useful, and then the weights cannot say anything: with a +single predictor any weight gives the same index and zero is accepted; with several, all of them are weighted equally, as with \code{weights = NULL}, and a warning says so. The coordinate default above is the mean of the supplied weights, so a zero weight on the only @@ -69,7 +81,9 @@ another layer, or these rows in another order -- is refused. That check is skipped when the folds were built on polygons and the training data are the points a fit reduced them to.} -\item{threshold}{Optional numeric override for the DI threshold.} +\item{threshold}{Optional numeric override for the DI threshold of the +predictor index. The location index, when there is one, always takes its +threshold from the rule.} \item{normalizer_max_n}{Subsample the training data to this many points when computing the mean pairwise distance, which is quadratic. Default 5000.} @@ -81,46 +95,97 @@ computing the mean pairwise distance, which is quadratic. Default 5000.} at least 1; a fractional value is truncated to a whole number of rows.} \item{use_fnn}{Use \pkg{FNN} for nearest-neighbour search when available. -Exposed so the dense fallback can be tested.} +Exposed so the dense fallback can be tested. The two paths return the +same distances: the dense one searches with a fast formula and then +recomputes the nearest distance exactly, so an exact copy of a training +row is at distance 0 on both.} + +\item{coords}{Whether location is measured: \code{"auto"} (default) +measures it for a model whose predictions depend on it (a +\code{gwr_fit}, a \code{bayesian_fit}, a forest fitted with +\code{include_coords = TRUE}) and not otherwise; \code{"yes"} measures +it whatever the model, and with no \code{model}; \code{"no"} never +does, and logs a caution for a model that depends on it. See +\emph{Models whose predictions depend on location}.} + +\item{categorical}{What to do with factor and character predictors: +\code{"refuse"} (default) stops with a message naming them and the two +alternatives; \code{"indicator"} codes each level as a 0/1 column and +marks a prediction row on a level no training row has as outside +(\code{DI = Inf}); \code{"drop"} computes the index on the other +predictors and logs which were left out. See \emph{Limitations} for the +scaling \code{"indicator"} uses.} } \value{ An object of class \code{aoa}: a list with \itemize{ \item \code{aoa}: \code{newdata} with a numeric \code{DI} column -and a logical \code{AOA} column added. This is the object the -computation ran on, which for a coordinate-using model is -\code{newdata} after pointizing, CRS reconciliation and the addition -of the \code{"..x"} and \code{"..y"} columns. A row whose predictors -are not all finite gets \code{NA} in both columns, and a row outside -the training range of a predictor in \code{dropped_vars} gets +and a logical \code{AOA} column added, and between them a numeric +\code{DI_location} column when location has an index of its own. +For a forest fitted with \code{include_coords = TRUE} it is the +object the computation ran on: \code{newdata} after pointizing, CRS +reconciliation and the addition of the \code{"..x"} and \code{"..y"} +columns. With a location index it is \code{newdata} as passed. A +row whose predictors are not all finite gets \code{NA} in \code{DI}, +and a row outside the training range of a predictor in +\code{dropped_vars}, or on a level no training row has, gets \code{DI = Inf} and \code{AOA = FALSE} (see \emph{Limitations}). +\code{AOA} is \code{DI <= threshold}, and with a location index +also \code{DI_location <= location$threshold}: a row outside on +either index is \code{FALSE}, and a row with one index missing and +the other inside is \code{NA}. \item \code{threshold}: the DI cut-off used. \item \code{train_DI}: the training points' own DI values. \item \code{normalizer}: the mean pairwise training distance. \item \code{weights}: the weight vector actually applied, named by \code{predictor_vars}. \item \code{predictor_vars}: the predictors used, including -\code{"..x"}/\code{"..y"} when the model uses coordinates and -excluding \code{dropped_vars}. +\code{"..x"}/\code{"..y"} when a forest uses the coordinates and +excluding \code{dropped_vars} and, under +\code{categorical = "drop"}, \code{categorical_vars}. \item \code{dropped_vars}: predictors dropped for negligible variance. \item \code{scaling}: a list with \code{center} and \code{scale}, each named by \code{predictor_vars}: the training means and standard deviations the index is computed in, so a location's DI can be -traced to the predictor that put it outside. +traced to the predictor that put it outside. A predictor coded as +indicators has one entry per level, named +\code{"="}. \item \code{n_outliers}: the number of training DI values above the \code{Q3 + 1.5 * IQR} fence, which the default threshold rule sets aside (the "outlier-removed" in its name); computed whether or not \code{threshold} was supplied. +\item \code{n_duplicates}: with \code{folds = NULL}, the number of +training rows that repeat an earlier row's predictor values exactly +and so share its reference distance; \code{NA} when folds were +supplied (see \emph{Training rows with identical predictor values}). +\item \code{location}: \code{NULL}, or for a location index a list +with \code{threshold}, \code{train_DI}, \code{normalizer} (the mean +distance between training points, in map units, so +\code{threshold * normalizer} is the cut-off as a distance), +\code{n_duplicates} (training rows at an earlier row's location; +\code{NA} when folds were supplied) and \code{n_outside} (prediction +rows beyond the location threshold). +\item \code{categorical_vars}: the factor and character predictors +found, coded or left out as \code{params$categorical} says. \item \code{n_train}, \code{n_new}, \code{n_inside}, \code{n_outside}, \code{n_na}: row counts. \code{n_train} counts the training rows that survived the finite-value filter; \code{n_new} is every row of \code{newdata}, so -\code{n_new = n_inside + n_outside + n_na}. +\code{n_new = n_inside + n_outside + n_na}, with \code{n_na} the +rows whose \code{AOA} is \code{NA}. +\code{n_outside_predictors} counts the rows beyond the predictor +threshold, which is \code{n_outside} unless there is a location +index. \item \code{params} records the call: \code{folds_supplied}, \code{n_folds}, \code{folds_method}, \code{threshold_supplied}, \code{normalizer_max_n}, \code{normalizer_n_used}, -\code{normalizer_subsampled}, \code{weights_supplied} and +\code{normalizer_subsampled}, \code{weights_supplied} (the caller +passed a vector), \code{weights_source} (\code{"model importance"}, +\code{"supplied"} or \code{"equal"}), \code{weights_note} (the kind +of importance, or why the weights are equal), \code{coords} +(\code{"location index"}, \code{"predictors"} or \code{"none"}), +\code{categorical} and \code{seed}. \code{folds_method} is the \code{method} of a \code{\link{make_folds}()} result (\code{"block_kfold"}, \code{"random_kfold"}, ...), \code{"labels"} for a vector of fold @@ -152,14 +217,17 @@ AOA marks where the score applies. \section{How it is computed}{ Predictors are centred and scaled using the training data's own means and -standard deviations, then optionally weighted by variable importance. For a +standard deviations, then weighted by variable importance when the model +carries one (see \emph{Weights}). For a prediction point \eqn{p}, the DI is the distance to its nearest training point in that space, divided by the mean pairwise distance among training points. The same quantity is computed for the training data itself, using each point's nearest neighbour \emph{among the training rows of the fold that holds it out}. That means everything outside its own fold for random and block folds, and the smaller training set that buffered and NNDM folds -actually leave (see the next section). The threshold is then the largest +actually leave (see \emph{The fold scheme changes the answer}); without +folds it is the nearest training row with different predictor values. The +threshold is then the largest training DI that is not an upper outlier, i.e. not above the fence \code{Q3 + 1.5 * IQR} of the training DI, with the quartiles of \code{stats::quantile()}'s default type 7. Prediction points at or below @@ -180,15 +248,36 @@ max(res$train_DI))} for an earlier result \code{res}. The DI is invariant to the overall scale of \code{weights}: the numerator and the normaliser carry the same factor. Importance values can be passed as-is. +} + +\section{Training rows with identical predictor values}{ -Each training point's reference is its nearest \emph{other} training row, so -an exact duplicate in predictor space (repeat visits to a site with static -covariates, or covariates read off a raster coarser than the sampling) has a -training DI of 0. Once about three quarters of the rows have a twin among -their reference rows the threshold is 0, and only exact copies of a -training row count as inside. That is logged as a caution; folds that keep -the duplicates together (\code{make_folds(method = "leave_location_out", -group_var = ...)}), or removing them, give the threshold its meaning back. +Repeat visits to a site with static covariates, or covariates read off a +raster coarser than the sampling, give training rows that are exact copies +of each other in predictor space. A copy is the same point of that space, +not a neighbour. Counted as a neighbour it gives a training DI of 0, and +once about three quarters of the rows have one the threshold is 0 and only +exact copies of a training row count as inside (60 sites visited 4 times +put 30 of 200 new points inside; the same sites counted once put 188). + +With \code{folds = NULL} each training row's reference is therefore its +nearest row with \emph{different} values: the search runs on the distinct +rows and every row takes its point's distance. \code{n_duplicates} counts +the rows that repeat an earlier one, and a layer with none is computed +exactly as before. The normaliser stays the mean pairwise distance over +all the training rows, so a prediction point's DI is the same with and +without folds. + +With \code{folds} supplied the definition is applied as it stands: a +held-out row whose copy is on the training side of its fold has a DI of 0, +because that hold-out did have an identical row to learn from. If the +threshold comes out 0 that way, a warning of class +\code{spatialkit_aoa_zero_threshold} gives the count, so a script or a +cross-validation loop can catch it with +\code{tryCatch(..., spatialkit_aoa_zero_threshold = )}. Folds that keep +the copies together (\code{make_folds(method = "leave_location_out", +group_var = ...)}) give the threshold its meaning back. The same applies +to the location index when training rows share a location. } \section{The fold scheme changes the answer, and should}{ @@ -204,10 +293,54 @@ to \code{\link{cv_spatial}}. Buffered and NNDM folds use the training set they actually left available, not merely "everything outside the fold". } +\section{Weights}{ + +Meyer and Pebesma weight the predictors by the model's variable +importance, and with the default \code{weights = "auto"} so does this +function whenever \code{model} carries an importance that means +something: \code{pmax(model$info$importance, 0)}, which a forest from +\code{\link{fit_rf_model}} has. Equal weights are used, with a logged +note, when it does not: no \code{model}; a model with no importance +(\code{importance = "none"}, a GWR, a Bayesian fit); an importance that is +not finite (\code{NaN} for a forest with no out-of-bag rows); one that +names fewer predictors than are in use; no positive value; or a forest +with no out-of-bag skill (\code{oob_r_squared} missing or at most 0), +whose positive importances are noise. \code{print()} says which it was. +\code{weights = NULL} asks for equal weights whatever the model carries. + +What the weights buy: with 2 predictors the forest uses and 8 it does not, +equal weights put about 70\\% of rows shifted 3 SD along a used predictor +(4 times the in-sample RMSE) inside the AOA and importance weights about +26\\%; of rows shifted 4 SD along an unused predictor (error unchanged), +43\\% against 93\\%. What they cost: a weight multiplies the scaled column, +so its square enters the distance, and a weak but real predictor is +down-weighted by the square of its relative importance. A shift along one +can then go unseen (94\\% inside at 1.9 times the in-sample RMSE in one +test, against 19\\% with equal weights). +\code{weights = sqrt(pmax(importance, 0))} is the gentler alternative: it +kept most of the gain on used predictors and put 46\\% of that weak-predictor +shift inside, at the cost of 77\\% in place of 93\\% inside for harmless +shifts. +} + \section{Limitations}{ -Predictors must be numeric; categorical variables are refused and never -silently dummy-coded. Predictors whose variance is negligible \emph{relative +Categorical predictors (factor or character columns) have no distance of +their own, and by default they are refused and never silently +dummy-coded. \code{categorical = "indicator"} codes each level that +occurs in the training rows as a 0/1 column. The columns of one predictor +share one scale, \code{sqrt(1 - sum(p^2))} with \code{p} the levels' +shares of the training rows, so two rows on different levels are the same +distance apart whichever levels they are, two on the same level are 0 +apart, and the predictor adds as much to the mean squared distance between +training rows as one standardised numeric predictor. That scaling is a +choice, not a result, which is why it is not the default. A prediction row +on a level no training row has gets \code{DI = Inf}, is outside the AOA, +and a warning gives the count. \code{categorical = "drop"} leaves the +categorical predictors out and computes the index on the others; a level +the training data never has then goes unseen. + +Predictors whose variance is negligible \emph{relative to their own magnitude} (the test is \code{sd < sqrt(.Machine$double.eps) * max(abs(x))}, so the same variable in metres and in gigametres is treated identically) are dropped from the @@ -216,21 +349,67 @@ range (with the same relative tolerance) is extrapolation along a direction the training data never varied in: its scaled distance along it is infinite, so it gets \code{DI = Inf}, is outside the AOA, and a warning gives the count. A point missing that value is judged on the other -predictors. Without \code{weights} every predictor counts equally, which -overstates dissimilarity along directions the model barely uses. +predictors. With equal weights every predictor counts the same, which +overstates dissimilarity along directions the model barely uses; see +\emph{Weights}. } -\section{Models fitted with the coordinates as predictors}{ +\section{Models whose predictions depend on location}{ + +For three kinds of model the prediction is a function of where the point +is, not only of its covariates, so the index has to measure location too. +Without that a prediction point far outside the training extent but with +ordinary covariate values reads as \emph{inside} the area of +applicability, which is exactly the extrapolation this index exists to +catch. \code{coords = "auto"} (the default) measures location for all +three; \code{coords = "no"} turns it off, with a logged caution; +\code{coords = "yes"} measures it for any model, or for none. -When \code{model} was fitted with \code{include_coords = TRUE} the model -splits on location, so the dissimilarity index has to measure location too: -the coordinates are added to both sides as the predictors \code{"..x"} and -\code{"..y"} and are then centred, scaled and weighted like any other -column. Without this a prediction point far outside the training extent but -with ordinary covariate values reads as \emph{inside} the area of -applicability. That is exactly the extrapolation this index exists to catch. +\strong{A geographically weighted regression} (\code{gwr_fit}) has +coefficients that vary over the map, and \strong{a Bayesian spatial model} +(\code{bayesian_fit}) has a Gaussian-process term in the coordinates. For +these, and under \code{coords = "yes"}, location gets an index of its own, +built like the predictor index but in map space: \code{DI_location} is the +distance to the nearest training point over the mean distance between +training points; the training points' own values use the same folds; and +the threshold is the same outlier-removed maximum. A prediction point is +inside the AOA only if it is inside on both indices, and both DI columns +are returned so the cause can be read off. Location is kept apart from the +covariates because, as two more equally weighted columns, it is diluted as +covariates are added: with 12 of them, 89\\% of points 200 to 500 units +beyond a 1000-unit training extent still read as inside, against none with +the separate index. In a test with a GWR whose slope rises eastward, points +one half to one and a half extents beyond the data had 13 times the +in-extent RMSE; 84\\% of them were inside on the covariates alone and none +with location measured. -This path needs geometry on both sides, so \code{train_sf} and +Inside the extent the index marks an unsampled gap only where the gap is +wider than the distance its threshold allows, and that distance depends +on \code{folds}. With \code{folds = NULL} it is the spacing of the +training points (the outlier-removed largest nearest-neighbour distance). +With blocked folds it is the largest distance from a held-out point to +the nearest row its fold trained on, outliers removed, which grows with +the block size; a gap narrower than about twice that distance has no +cell beyond it and reads as inside. In a test with 400 training points +in two strips 400 units apart, the cut-off without folds was 46 to 54 +units and no grid cell in the middle half of the gap, 100 units or more +from either strip, was inside. That held although the prediction grid +took its covariates from the nearest observation, so that every cell's +covariate DI was 0. With five block folds the cut-off was 199 to 251 +units and 76 to 100\\% of the same cells were inside (87\\% on average over +three draws). This follows from the definition and is not a fault of the +index: the cross-validated error it is paired with was earned on +hold-outs that far from their training rows. It does mean that with +blocked folds the location index says nothing about a gap narrower than +about twice the cut-off; \code{location$threshold * location$normalizer} +is the cut-off in map units, and \code{print()} shows it. + +\strong{A forest fitted with \code{include_coords = TRUE}} splits on the +coordinates like on any other column, so there they join the predictor +index as \code{"..x"} and \code{"..y"} and are centred, scaled and weighted +with the rest. + +Either way geometry is needed on both sides, so \code{train_sf} and \code{newdata} must both be \code{sf} objects; a data.frame is refused rather than quietly measured without location. Non-\code{POINT} \code{newdata} (grid polygons, say) is reduced to representative points @@ -238,7 +417,8 @@ first, as \code{\link{coerce_to_points}} would. If exactly one side carries a CRS the other is brought into it: reprojected when its coordinates look like longitude/latitude, stamped otherwise, with a warning either way. This is done because degrees fed into a metre-space index silently understate the -distances. +distances. The location index is a map distance and refuses training data +in a geographic CRS. } \examples{ @@ -273,21 +453,21 @@ Ecology and Evolution} 12(9), 1620--1633. \doi{10.1111/2041-210X.13650} \code{\link{predict_surface}} to build the grid, \code{\link{make_folds}} for the fold scheme. -Other cross-validation: -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} - -Other prediction: -\code{\link{predict_surface}()} +Other cross-validation: +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} + +Other prediction: +\code{\link[=predict_surface]{predict_surface()}} } \concept{cross-validation} \concept{prediction} diff --git a/man/assign_features_to_polygons.Rd b/man/assign_features_to_polygons.Rd index 7cbeb8d0..fbe4ce3f 100644 --- a/man/assign_features_to_polygons.Rd +++ b/man/assign_features_to_polygons.Rd @@ -11,7 +11,8 @@ assign_features_to_polygons( keep_unassigned = FALSE, predicate = sf::st_intersects, largest = TRUE, - tie_break = c("smallest_area", "first") + tie_break = c("smallest_area", "first"), + quiet = FALSE ) } \arguments{ @@ -19,11 +20,26 @@ assign_features_to_polygons( \item{polygons_sf}{An sf or sfc polygonal layer.} -\item{polygon_id_col}{Name of the polygon identifier column. Default "poly_id".} +\item{polygon_id_col}{Name of the polygon identifier column: the column of +\code{polygons_sf} the IDs are read from, and the name they are returned +under. Default "poly_id". When \code{polygons_sf} has no column of that name, +the IDs are read from the first of \code{"poly_id"}, \code{"polygon_id"}, \code{"id"}, +\code{"cell_id"} and \code{"grid_id"} it carries, and a message names the column +that was used; when it has none of them, the polygons are numbered +\verb{1, 2, ...} in row order, and a message says so. The column the IDs are +read from must hold one distinct, non-missing value per polygon: a +duplicated or missing ID is an error, because features in different +polygons would come back under one ID. That includes a unit stored as +several rows that share its ID (a region split into \code{POLYGON} parts): +merge the parts into one row per ID first, for example with +\verb{dplyr::summarise(dplyr::group_by(polygons_sf, ))}, which +keeps the unit one cell. Numbering the rows would make each part a cell +of its own.} \item{keep_unassigned}{Logical; retain features that fall inside no polygon, carrying \code{NA} in the ID column. Default FALSE, which drops -them.} +them with a warning of class \code{"spatialkit_unassigned"} that gives +their number.} \item{predicate}{Binary spatial predicate function. Default sf::st_intersects. Not used when \code{largest} applies: sf then assigns polygon features by @@ -53,7 +69,13 @@ smallest area and, among polygons of equal area (a point on the shared edge of two grid cells), the one whose bounding-box centre is lowest, then leftmost, so the choice does not depend on the order of the rows; \code{"first"} keeps the first match (original order-dependent -behavior).} +behavior). On cells built from the centres a profile scored, a point on +the edge between two of them is placed by the profile's rule whichever +is given (see Value).} + +\item{quiet}{Logical; suppress this function's \code{message()}s (the one +naming a fallback ID column). It does not silence R warnings. Default +\code{FALSE}.} } \value{ An sf object with \code{polygon_id_col} attached, one row per input @@ -67,10 +89,26 @@ the polygons' own ID column when that is read from a fallback such as falls inside any polygon the result is empty (or all-\code{NA} with \code{keep_unassigned = TRUE}) and a warning is raised, since the usual cause is two layers in different -places (a CRS that could only be stamped, not reprojected). The +places (a CRS that could only be stamped, not reprojected). + +Features that fall inside no polygon are counted on the attribute +\code{"unassigned"}: a list with \code{n}, \code{which} (their row positions in +\code{features_sf}) and \code{n_rows}. With \code{keep_unassigned = FALSE} they are not +in the result, and a warning of class \code{"spatialkit_unassigned"} gives +their number (\code{tryCatch(spatialkit_unassigned = )} catches it without +matching the message; the condition carries \code{n} and \code{total}). The usual +causes are a polygon layer that stops short of the data (a coastline +drawn at another scale, a tessellation of seeds built without a +\code{boundary} or \code{cover}; see \code{\link[=build_tessellation]{build_tessellation()}}) and points outside +the study area. With \code{keep_unassigned = TRUE} they are kept with an +\code{NA} ID and no warning is raised, unless every feature is unassigned. + +The attribute \code{"ties"} records how many features matched more than one polygon (with \code{largest}, overlapped several by exactly the same area) -and had the \code{tie_break} rule decide for them: a list with \code{n}, +and had the \code{tie_break} rule decide for them (on cells built from the +centres a profile scored, the profile's rule then places the points +among them, as the last paragraph says): a list with \code{n}, \code{which} (their row positions in \code{features_sf}), \code{rule} and \code{n_rows} (the number of rows returned, which the record was made for). A large \code{n} means the polygon layer overlaps, and per-cell counts built from the @@ -80,7 +118,56 @@ returned and does not survive subsetting: \code{joined[i, ]}, like with no \code{"ties"} attribute, so nothing reports the parent's count for a different set of rows. \code{sf::st_drop_geometry()} keeps the record, since the rows are the same; see \code{\link{[.spatialkit_rows}} for -what binding such data frames does. +what binding such data frames does. The \code{"unassigned"} record is +stamped and removed the same way. + +When \code{polygons_sf} carries \code{attr(, "count_rule")}, the record of how +its cell count was set (cells from \code{\link[=build_tessellation]{build_tessellation()}} on seeds +placed from a \code{\link[=select_resolution]{select_resolution()}} result or from a profile built with +an \code{estimate}), the result carries the same record. +\code{\link[=summarize_by_cell]{summarize_by_cell()}} reads it and checks that the rows and cells it is +given are the ones the count was scored on. It is a plain attribute: a +row subset keeps it and \code{dplyr::mutate()}, \code{dplyr::select()} and +\code{dplyr::arrange()} drop it, which is why the summary also looks for it +on its \code{cells_sf}. The profile scores a feature that is not a point at +one point of it (\code{coerce_to_points(, "auto")}), in the cell of the +nearest centre; this function gives a polygon feature to the cell it +overlaps most. A feature that straddles a cell boundary can therefore +be assigned to another cell than the one it was scored in, and the +summary does not compare the two for such a layer. To assign the +features as they were scored, assign their points: +\code{assign_features_to_polygons(coerce_to_points(features_sf, "auto"), polygons_sf)}. + +When that record says the cells are the ones the profile scored +(\code{scored_cells} is \code{TRUE}: the cells \code{\link[=build_tessellation]{build_tessellation()}} builds on a +selection's seeds, or on the seeds a seeding function returns for one) +and holds the centres it scored (\code{count_rule$scored$centres}), a point +on the edge between two or more of those cells is given the cell +\code{\link[=resolution_profile]{resolution_profile()}} scored it in: that of its nearest centre, +measured in the CRS the record names, and of centres the same distance +away the lower-numbered one. Such points occur on gridded locations +(raster cell centres, a regular sampling grid), where a row can lie the +same distance from two centres and the polygons hold it in either cell +or in both. The rows each cell holds are then the rows its count was +scored on, and \code{\link[=summarize_by_cell]{summarize_by_cell()}}'s check of them reads \code{"match"}. +A point counts as on the edge when it lies within a margin of both +cells: one part in 1e10 of the largest coordinate of the cells, 0.44 mm +at a UTM northing of 4,400 km. \code{\link[=build_tessellation]{build_tessellation()}} draws such cells +in the CRS the record names, around the centres as the record holds +them, whatever CRS the seeds came back in (unless its \code{crs} names +another projected CRS), so their corners carry only the rounding of +that computation, far less than the margin. A point +farther from its nearest centre's cell keeps the polygon that holds it, +and so do features that are not points, points without a CRS beside a +record with one, and a join in longitude and latitude. A centre's cell +is the one cell that holds it and no other centre; a centre outside a +boundary that clipped its cell away from it has the cell, among those +that hold no centre, whose inside is nearest it. Cells built from other +seeds leave most centres without a cell, and their points to the +polygons. Polygons without the record, such as polygons +the caller brings, and cells whose record says \code{scored_cells} is +\code{FALSE} or \code{NA} (other cells built from the count, such as a lattice +sized by it) are placed by the polygons alone. } \description{ Joins an sf layer of input features to a polygon layer via spatial join. @@ -121,12 +208,13 @@ table(assigned$poly_id) \code{\link[=build_tessellation]{build_tessellation()}} to build the polygon layer; \code{\link[=summarize_by_cell]{summarize_by_cell()}} for the aggregation step that consumes the result. -Other aggregation: -\code{\link{determine_optimal_levels}()}, -\code{\link{kriging_adequacy}()}, -\code{\link{resolution_profile}()}, -\code{\link{select_resolution}()}, -\code{\link{summarize_by_cell}()}, -\code{\link{summary.resolution_profile}()} +Other aggregation: +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} } \concept{aggregation} diff --git a/man/build_tessellation.Rd b/man/build_tessellation.Rd index ed6cc9ae..37e4a2ba 100644 --- a/man/build_tessellation.Rd +++ b/man/build_tessellation.Rd @@ -14,7 +14,8 @@ build_tessellation( clip = TRUE, keep_duplicates = FALSE, crs = NULL, - quiet = FALSE + quiet = FALSE, + cover = NULL ) } \arguments{ @@ -25,8 +26,12 @@ build_tessellation( own to lay a grid over and error without it; supply the study-area polygon, or build one from the points with \code{\link[=clip_target_for]{clip_target_for()}}. \strong{Optional} for \code{method = "voronoi"} and \code{method = "triangles"}, which derive their extent -from the points themselves and use \code{boundary} only to clip the result when -\code{clip = TRUE}. When exactly one of \code{points_sf} and \code{boundary} has a CRS, +from the points themselves (for \code{"voronoi"}, from \code{cover} when there is +one) and use \code{boundary} only to clip the result when +\code{clip = TRUE}. When \code{points_sf} holds seeds and not the observations, +pass the study area here or the observations as \code{cover}: seeds lie +inside the data, and cells clipped to the seeds' own hull leave its edge +uncovered. When exactly one of \code{points_sf} and \code{boundary} has a CRS, the other is interpreted in it, with a warning. CRS-less points, and a CRS-less boundary given with projected points, are read as \code{\link[=harmonize_crs]{harmonize_crs()}} does; CRS-less points that do not look like lon/lat @@ -46,16 +51,31 @@ unnamed planar space.} one cell per input point and \code{"triangles"} one triangle per neighbouring triple, so neither has a count to set, and both warn that the argument was ignored. For a Voronoi cell count, place the seeds with -\code{\link{get_voronoi_seeds}()} and tessellate those. For hex +\code{\link{get_voronoi_seeds}()} and tessellate those, passing the +study area as \code{boundary} or the observations as \code{cover} +(seeds made from a boundary or from \code{sample_points} carry their +cover with them). For hex grids the target is adjusted for packing density; the actual count after clipping to an irregular boundary may differ noticeably. Besides a number, this accepts what the level-selection step returned: the integer vector of ranked candidates from \code{\link{determine_optimal_levels}()} (its first element is used), a \code{\link{select_resolution}()} result -(its \code{$best}), or a \code{\link{resolution_profile}()} (read with -\code{select_resolution()} at its default criterion). The count used +(its \code{$best}), or a \code{\link{resolution_profile}()}. A profile +built without an \code{estimate} is read with +\code{select_resolution()} by \code{cp}; one built with +\code{estimate} is read by \code{criterion = "auto"}, the rule that +goes with its estimate: a size for pooled values, the lowest +leave-one-out error for plain means. The count used is returned as \code{params$approx_n_cells} and where it came from as \code{params$approx_n_cells_from} (\code{NULL} for a plain number). +A count read off a selection or a profile raises a warning of class +\code{"spatialkit_bound_chosen"} when its optimum sits on a bound of the +ladder and one of class \code{"spatialkit_no_structure"} when one cell +for the whole layer scores as well (for a count set by a size: when +cells of that size predict no better than one mean; the count stands); +a profile without an estimate and with no \code{cp} to read +is an error (class \code{"spatialkit_no_default_criterion"} when another +criterion is finite). See \code{\link{resolution_profile}()}. A count read off a profile or selection is a number of k-means cells: every one occupied, and small where the points are dense. A lattice lays that many equal cells over the whole boundary, so on clustered @@ -68,7 +88,10 @@ seed a Voronoi tessellation with \code{get_voronoi_seeds(method = "kmeans", n = , sample_points = )}: given the \code{select_resolution()} result or the profile itself, it returns the centres of the partition the profile scored, whose Voronoi -cells are the cells the criteria judged.} +cells are the cells the criteria judged. Seeds made that way carry the +hull of \code{sample_points} as their cover, so the cells built on them +hold every point; made with neither \code{sample_points} nor a boundary, +they carry the hull of the points the profile was computed on.} \item{cellsize}{Numeric cell size, in the units of the working CRS. Read by \code{method = "hex"} and \code{"square"} only; the other two methods warn @@ -107,11 +130,42 @@ distorts areas across the boundary by more than 1 percent (Web Mercator over a near-global extent, say); the grid is then laid, and the points indexed, in the equal-area CRS \code{ensure_projected(purpose = "area")} picks for the boundary, with a logged warning, as \code{\link[=create_grid_polygons]{create_grid_polygons()}} -does, so the cells stay equal-area.} +does, so the cells stay equal-area. Seeds that carry the record of how +their count was set (\code{attr(, "count_rule")}) were scored in the CRS the +profile worked in, each row in the cell of its nearest centre. When the +record says they are the centres it scored and holds them (the seeds of +a \code{\link[=select_resolution]{select_resolution()}} result, or those a seeding function returns for +one), \code{method = "voronoi"} builds their cells in that CRS, with no +\code{crs} or a geographic one, whatever CRS the seeds arrive in, and +returns them there or in the geographic \code{crs}; see +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, section "Seeds a profile scored". Voronoi +cells built in another projected CRS, named here, are the nearest-seed +cells of that CRS, so a row near a boundary can fall in the +neighbouring cell, and \code{\link[=summarize_by_cell]{summarize_by_cell()}} then reports that the +cells are not the ones scored.} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}.} + +\item{cover}{Optional sf or sfc layer the cells have to hold: the +observations (points), or a polygon. Read by \code{method = "voronoi"} when +there is no \code{boundary}: the boundary is then derived from the cover (the +convex hull of its points, or its polygons, grown by 2 percent of the +diagonal) instead of from the hull of \code{points_sf}. Pass it when +\code{points_sf} holds seeds. When \code{NULL}, the cover the seeding functions +attach to their result is used (\code{attr(points_sf, "cover")}: the boundary +the seeds were drawn in, or the hull of the points they were clustered +from), so \code{build_tessellation(voronoi_seeds_kmeans(obs, k))} holds every +observation without it; \code{rbind()} of seed layers drops that attribute. +Seeds with neither a boundary nor a cover are tessellated over their own +hull, with a warning of class \code{"spatialkit_no_cover"}. A cover with no +CRS is read in the coordinates of \code{points_sf}; one in another CRS is +transformed. With a \code{boundary} (and for the other methods) the cover +sizes nothing: when it is a point layer, the number of its points that +fall outside every cell is returned as \code{params$cover_outside}, with a +warning of class \code{"spatialkit_unassigned"} when it is not 0. See +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}.} } \value{ A list with components: @@ -125,16 +179,45 @@ one outside the study area. Only a point within a thousandth of the median cell width of a cell is snapped to it. That covers points sitting exactly on a shared edge, and leaves points outside the study area as \code{NA}. A summary built from \code{index} therefore counts only the -points the tessellation actually covers.} +points the tessellation actually covers. When any point is \code{NA}, a +warning of class \code{"spatialkit_unassigned"} gives the number +(\code{tryCatch(spatialkit_unassigned = )} catches it; the condition +carries \code{n} and \code{total}).} \item{\code{boundary}}{The boundary used (possibly derived and/or reprojected, and for \code{"voronoi"} grown by \code{expand}).} \item{\code{method}}{The method actually used.} \item{\code{params}}{The parameters the tessellation was built with, plus \code{snapped}, the record of that nearest-cell repair: a list with \code{n}, \code{which} (row positions in \code{points_sf}) and \code{distance} (how far -outside every cell each sat, in CRS units). For \code{"hex"} and +outside every cell each sat, in CRS units); \code{n_outside}, the number +of points of \code{points_sf} that fall in no cell (the \code{NA}s of +\code{index}); and \code{cover_outside}, the number of \code{cover} points in no +cell when a point \code{cover} was checked against the cells (\code{NULL} +otherwise). For \code{"voronoi"} also \code{boundary_source}, where the +boundary came from: \code{"boundary"}, \code{"cover"}, \code{"seeds' cover"} or +\code{"points"}, and, when \code{points_sf} is a layer of seeds that records +the kind of partition that placed it (see \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}), +\code{partition}: that record, a list with \code{kind}, \code{init}, +\code{density_power} and \code{density_k} and, for seeds a seeding function +placed itself, \code{iter}, \code{iter_max} and \code{converged}. The cells are +the Voronoi cells of the seeds whatever kind placed them. For +\code{"hex"} and \code{"square"} also \code{cells_occupied} and \code{cells_empty}, the number of -cells that hold at least one point and that hold none.} +cells that hold at least one point and that hold none. +\code{count_rule}, the record of how the count was set, is present on +two paths, and the cells then carry it too as +\code{attr(cells, "count_rule")}. For \code{"voronoi"}, when \code{points_sf} +carries one (\code{attr(points_sf, "count_rule")}: the seeds of a +\code{\link[=select_resolution]{select_resolution()}} result, or seeds \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} or +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}} placed from one): the record as the seeds +carry it, whose \code{scored_cells} says whether these are the cells the +profile scored. For \code{"hex"} and \code{"square"}, when \code{approx_n_cells} +is a selection that carries a record, or a profile built with an +\code{estimate}, and no \code{cellsize} is given: that record with +\code{scored_cells} \code{FALSE}, since a lattice at that count is not the +partition the profile scored. \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} +copies the record to the rows it assigns, and \code{\link[=summarize_by_cell]{summarize_by_cell()}} +checks its result against it.} } } \description{ @@ -177,14 +260,14 @@ tess <- build_tessellation(pts, method = "voronoi", quiet = TRUE) tess$cells } \seealso{ -Other tessellation: -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/cell_values_at.Rd b/man/cell_values_at.Rd new file mode 100644 index 00000000..0316b21d --- /dev/null +++ b/man/cell_values_at.Rd @@ -0,0 +1,320 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cell-values-at.R +\name{cell_values_at} +\alias{cell_values_at} +\title{Cell values at other locations} +\usage{ +cell_values_at( + newdata, + values, + points, + response_var, + id_col = "poly_id", + seeds = NULL +) +} +\arguments{ +\item{newdata}{The locations: an sf layer. A feature that is not a point +is reduced to one with \code{\link[=coerce_to_points]{coerce_to_points(, "auto")}}. +No column of it is read. With no CRS while \code{points} has one, the call +stops.} + +\item{values}{The \code{\link[=summarize_by_cell]{summarize_by_cell()}} result for \code{points}. It must hold +the ID column and a cell value of \code{response_var}: the pooled value +(\code{estimate = "pooled"}) or the mean (the default \code{agg_funs}). With +\code{seeds = NULL} it must also carry the cell polygons, which it does when +it was made with \code{cells_sf}.} + +\item{points}{The assigned layer \code{values} was computed from: an sf layer +with the ID column and \code{response_var}, and at least one scored row.} + +\item{response_var}{Name of the summarised column wanted: the response, +or a predictor.} + +\item{id_col}{Name of the ID column, found as \code{\link[=summarize_by_cell]{summarize_by_cell()}} finds +it: when \code{points} has no column of that name, the first of \code{"poly_id"}, +\code{"polygon_id"} and \code{"cell_id"} it has. It cannot have the name of +another column of the result (\code{value}, \code{estimate}, \code{obs_lo}, \code{obs_hi}, +\code{filled}, \code{filled_from}, \code{dist_nearest}, \code{dist_ratio}).} + +\item{seeds}{\code{NULL}, or the seeds the cells were built on: an sf POINT +layer with a column named as the ID column that gives each seed's cell. +For cells from \code{tess <- build_tessellation(seeds)} that is +\code{seeds$cell_id <- tess$index} when the ID column is \code{"cell_id"}, after +which a seed outside a boundary that is not convex needs its cell's ID +(see "Seeds outside the boundary"). Two +seeds at different locations with one ID are an error; seeds that share +a location share its cell, as \code{index} gives them. \code{NA} marks a seed +without a cell.} +} +\value{ +A data frame with one row per row of \code{newdata}, in its order: +\describe{ +\item{the ID column}{The cell the location lies in, under the name of +the ID column; \code{NA} for a location in no cell.} +\item{\code{value}}{The cell's value, or for a filled row the value of the +cell in \code{filled_from}.} +\item{\code{estimate}}{\code{"pooled"} or \code{"mean"}: which value of the summary +\code{value} is.} +\item{\code{obs_lo}, \code{obs_hi}}{The interval for one observation, when +\code{values} holds it.} +\item{\code{filled}}{\code{TRUE} when the location has no cell, or its cell +neither a scored row nor a value, and the value is that of the cell +of the nearest scored row.} +\item{\code{filled_from}}{For a filled row, the ID of the cell the value +came from; \code{NA} otherwise.} +\item{\code{dist_nearest}}{Distance to the nearest location of a scored +row, in the units of the working CRS.} +\item{\code{dist_ratio}}{\code{dist_nearest} over the spacing; \code{NA} when the +scored rows sit on one location.} +} +A row of \code{newdata} with an empty geometry, or with a coordinate that is +not finite or lies beyond 1e150, has \code{NA} in every column. The two ID +columns have the class of the ID column of \code{values}; when a cell that +\code{values} has no row for has an ID that class cannot hold (a string +beside numbers), both are character. + +What produced the frame is in \code{attr(, "values_at")}, a list of class +\code{"spatialkit_values_at"} with a print method: \code{assignment} (\code{"seeds"} +or \code{"polygons"}), \code{crs} (the working CRS), \code{column} (\code{response_var}), +\code{estimate}, \code{obs_level} (the level of the interval columns; \code{NULL} +without them, and \code{NA} when \code{values} holds them and no longer says at +what level), \code{n} (the scored rows), \code{locations} (their distinct +locations), \code{spacing} (what \code{dist_ratio} divides by; \code{NA} with one +location), +\code{filled} (how many rows of \code{newdata} were filled) and \code{count_rule} (the +summary's record of how the cell count was set, or \code{NULL}). It describes +the call: a subset of the frame's rows keeps it as it is. + +The function raises no classed warning of its own. It passes on what +\code{\link[=coerce_to_points]{coerce_to_points()}}, a CRS transformation and +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} raise, but for one warning: the one +that function raises when no location at all falls in a polygon is +neither raised nor logged, since every such row has \code{filled = TRUE}, +which says the same row by row. +} +\description{ +Gives each location of \code{newdata} the value of the cell it lies in, read +from a \code{\link[=summarize_by_cell]{summarize_by_cell()}} result: the pooled value when the summary +holds one, the plain mean otherwise, with the interval for one +observation when the summary holds it. Beside each value it returns the +location's distance from the nearest observation, since a cell's value +describes the part of the cell where its observations lie. +} +\details{ +The function works in six steps. +\enumerate{ +\item \emph{The working CRS.} The CRS the summary measured in: the one in +\code{attr(values, "count_rule")} when that record names a projected CRS, +else the one in \code{attr(values, "pooled")}, else the CRS of \code{points} +when it is projected and the one \code{\link[=ensure_projected]{ensure_projected()}} picks for it +when it is not. \code{points}, \code{newdata} and \code{seeds} are transformed to it. +When neither \code{points} nor \code{newdata} has a CRS the coordinates are used +as they are, unless those of \code{points} look like longitude and latitude: +both are then read as EPSG:4326, as \code{\link[=summarize_by_cell]{summarize_by_cell()}} reads +\code{points}, with \code{\link[=ensure_projected]{ensure_projected()}}'s warning. +\item \emph{The scored rows.} The rows of \code{points} with a finite \code{response_var}, +a cell ID and finite coordinates. Their distinct locations are the +observations every distance below is taken from. +\item \emph{The cell of a location.} With \code{seeds}, the cell of the nearest seed. +That is the Voronoi cell before its clip to the cover, so every +location has one, unless its nearest seed has an \code{NA} ID. A location +nearest such a seed has no cell, even where the polygon that holds it +has scored rows. \code{\link[=build_tessellation]{build_tessellation()}} gives \code{NA} in \code{index} to a +seed that lies in no cell: one whose cell the clip removed, and one +outside a boundary that is not convex, whose clipped cell exists +(see "Seeds outside the boundary"). Without \code{seeds}, the polygon of +\code{values} that holds the +location, by \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} with its default +\code{tie_break} and the summary's record of the count, so a location on +the edge between two cells the profile scored is placed as that +function places such a row (see "Ties"); a location in no polygon has +no cell. Polygons without a +CRS are read as that function read them for the rows of \code{points}: the +locations are handed to it in the CRS of \code{points}, whatever CRS +\code{newdata} arrived in. +\item \emph{The value.} The cell's pooled value of \code{response_var}, +\verb{..pooled_} with the prefix \code{resp_} or \code{pred_}, +when \code{values} has that column; otherwise its mean, +\verb{mean_}. The column \code{estimate} says which. For a +column summarised as response and as predictor the response's columns +are read. The interval is the cell's \verb{..obs_lo_} +and \verb{..obs_hi_} when \code{values} has them. +\item \emph{The fill.} A location with no cell, or whose cell holds no scored row +and has no value in \code{values}, takes the value and interval of the cell +of its nearest scored row. \code{filled} is then \code{TRUE} and \code{filled_from} is +that cell's ID. The ID column still holds the location's own cell, as +step 3 finds it, so the two columns together say where a location lies +and where its value came from. A cell that holds a scored row is not +filled. Where \code{values} +has no value for such a cell (the summary could not compute the pooled +columns, or has no row for the cell), its locations have \code{value = NA} +and \code{filled = FALSE}; a filled value is \code{NA} in the same case, when +the cell it is taken from has none. +\item \emph{The distance.} \code{dist_nearest} is the distance from the location to +the nearest location of a scored row, in the units of the working CRS. +\code{dist_ratio} is that distance over the layer's spacing: the median, +over the distinct locations of the scored rows, of the distance to the +nearest other one. +} + +Cell IDs are matched as text. The ID column of \code{values} is character when +the summary joined a \code{cells_sf} whose IDs were of another class than the +assigned layer's, while \code{points} and \code{seeds} keep the class they had; the +IDs of all three are written out as text before any match, and both ID +columns returned have the class of the ID column of \code{values} wherever +that class can hold every ID (see Value). +} +\section{Seeds outside the boundary}{ + +A k-means seed can lie outside a boundary that is not convex, in a bay or +a bend of a coast (see \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}). Its cell, clipped to the +boundary, holds ground and observations, but the seed lies in no cell, so +\code{seeds$cell_id <- tess$index} gives it \code{NA}. The locations nearest it then +have \code{NA} in the ID column and are filled from the cell of their nearest +scored row, which can be another cell than the one that holds them. +Every point of a Voronoi cell is nearer its own seed than any other, so a +point inside each cell that no seed lies in finds that cell's seed. In a +projected CRS: + +\if{html}{\out{
}}\preformatted{seeds$cell_id <- tess$index +own <- tess$cells[!tess$cells$cell_id \%in\% tess$index, ] +near <- sf::st_nearest_feature(sf::st_point_on_surface(sf::st_geometry(own)), + seeds) +seeds$cell_id[near] <- own$cell_id +}\if{html}{\out{
}} + +Each location inside the boundary then has the cell that holds it, and +none is filled for want of a seed. A seed whose cell the clip removed +keeps \code{NA}. +} + +\section{Ties}{ + +A location the same distance from two seeds takes the one that comes +first in \code{seeds}. For the seeds of a \code{\link[=select_resolution]{select_resolution()}} result that is +the lower-numbered centre, the rule \code{\link[=resolution_profile]{resolution_profile()}} scores with. +When the summary's record of the count holds the centres the profile +scored and \code{seeds} are those centres (the seeds a selection carries, or +those a seeding function returns for it), in any order and any CRS, the +distances are taken to the centres as the record holds them, a tie goes +to the lower-numbered centre, and each centre gives the ID of the seed +that stands at it. Seeds count as the centres when they are as many and +each lies at a different centre, within a thousandth of its distance from +the next nearest one, so a seed that came back from another CRS with its +coordinates rounded, or seeds sorted by their cell, do not settle a tie +another way. A location on the edge between two such cells then takes +the cell \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} gives a row there, with \code{seeds} +and without. Other seeds, among them a subset of the centres, are +searched as given. A +location the same distance from two locations of scored rows takes the +one with the lower x coordinate, then the lower y; among scored rows at +one location that lie in different cells, the cell that comes first in +the order of the IDs (ascending for numbers, the C-locale order for +strings, the order of the levels for a factor). Neither rule depends on +the order of the rows of \code{points}, or on whether the \pkg{FNN} package is +installed. A tie is a tie between distances computed from the coordinates +in the working CRS, so on gridded locations the same layer in another CRS +or unit can put a location on a boundary in the other cell. +} + +\section{Away from the observations}{ + +The value and the interval describe locations among the observations. +The interval's two ends are quantiles of leave-one-out errors, each the +error of predicting an observation from the others around it, so it says +nothing of a location far from every observation: a gap in the layer, or +ground beyond its edge. Away from the observations no interval here is +calibrated. \code{dist_nearest} and \code{dist_ratio} say how far each location is +from the data. No threshold is applied to either and no location is +flagged or left out. \code{\link[=area_of_applicability]{area_of_applicability()}} and \code{\link[=fold_separation]{fold_separation()}} +are the tools for deciding where a prediction applies. + +A simulation shows how the interval's coverage falls with \code{dist_ratio} +(\code{dev/sim-pooled-values.R} in the package's repository; "Pooled values" in +\code{\link[=summarize_by_cell]{summarize_by_cell()}} describes it). Each of 200 layers has 1,500 +clustered observations in 333 cells, 300 further observations held out +at random among them and 300 held out as a block, which leaves a gap in +the layer. Over the held-out observations of all layers, the interval at +\code{obs_level = 0.90} held 91.5 percent of those with a \code{dist_ratio} below +1, 89.2 percent from 1 to 2, 83.9 percent from 2 to 4, 77.9 percent from +4 to 8 and 69.5 percent above 8. It held 89.6 percent of the observations +held out at random and 75.1 percent of those in the block. A second +simulation, on fields whose level jumps at boundaries, gave this +function's interval to held-out observations; "Intervals: which one +answers which question" in \code{\link[=summarize_by_cell]{summarize_by_cell()}} gives its coverage, which +in cells of one training observation fell short of \code{obs_level} on one kind +of field. +} + +\section{Without the FNN package}{ + +The function makes three nearest-neighbour searches: each location's +nearest scored location, each location's nearest seed, and each scored +location's nearest other one (for the spacing). With \pkg{FNN} each uses +a kd-tree. Without it each compares every pair, and a search that would +compare more than \code{getOption("spatialkit.exact_pairs_max", 2e9)} pairs +stops the call first, with an error of class \code{spatialkit_work_limit} +that names the search (the fields \code{work}, \code{limit} and \code{what}). The search +for the spacing does not depend on the number of locations asked for: +above about 44,700 distinct scored locations the call stops without +\pkg{FNN} however few they are. The result is the same with and without +the package. +} + +\examples{ +library(sf) +set.seed(1) +n <- 400 +east <- runif(n, 0, 1e4) +north <- runif(n, 0, 1e4) +all_pts <- st_as_sf( + data.frame(x = 5e5 + east, y = 5e6 + north, + income = 30 + 5 * sin(east / 2000) + 5 * cos(north / 1500) + + rnorm(n)), + coords = c("x", "y"), crs = 32632 +) +pts <- all_pts[1:350, ] +newpts <- all_pts[351:400, ] + +# The count from a size, the cells, the observations in them, the values, +# all at the defaults: pooled values at 4.5 observations per cell. +prof <- resolution_profile(pts, "income") +sel <- select_resolution(prof) +seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts) +tess <- build_tessellation(seeds, method = "voronoi") +asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id") +out <- summarize_by_cell(asg, "income", id_col = "cell_id", + cells_sf = tess$cells, obs_level = 0.90) + +# The value at other locations, each placed in the cell of its nearest +# seed. `tess$index` gives the cell of each seed. +seeds$cell_id <- tess$index +at <- cell_values_at(newpts, out, asg, "income", id_col = "cell_id", + seeds = seeds) +head(at) +attr(at, "values_at") + +# Without the seeds a location is placed in the polygon that holds it. One +# beyond the layer's edge lies in no polygon: it is filled from the cell of +# the nearest observation, and `dist_ratio` says how far that is. +beyond <- st_sf(geometry = st_sfc(st_point(c(5e5 + 2e4, 5e6 + 5e3)), crs = 32632)) +cell_values_at(rbind(st_sf(geometry = st_geometry(newpts[1:2, ])), beyond), + out, asg, "income", id_col = "cell_id") +} +\seealso{ +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, which computes \code{values}; +\code{\link[=build_tessellation]{build_tessellation()}}, whose \code{index} gives each seed's cell; +\code{\link[=area_of_applicability]{area_of_applicability()}} and \code{\link[=fold_separation]{fold_separation()}} for where a +prediction applies. + +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} +} +\concept{aggregation} diff --git a/man/clear_fitted_cache.Rd b/man/clear_fitted_cache.Rd index 07696b35..0c924b20 100644 --- a/man/clear_fitted_cache.Rd +++ b/man/clear_fitted_cache.Rd @@ -41,9 +41,9 @@ if (requireNamespace("ranger", quietly = TRUE)) { } } \seealso{ -Other package options and caches: -\code{\link{clear_grid_cache}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{spatialkit_quiet}()} +Other package options and caches: +\code{\link[=clear_grid_cache]{clear_grid_cache()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=spatialkit_quiet]{spatialkit_quiet()}} } \concept{package options and caches} diff --git a/man/clear_grid_cache.Rd b/man/clear_grid_cache.Rd index ad849593..43a08fd7 100644 --- a/man/clear_grid_cache.Rd +++ b/man/clear_grid_cache.Rd @@ -26,9 +26,9 @@ clear_grid_cache() # returns the number of entries removed, invisibly print(clear_grid_cache()) # 0: already empty } \seealso{ -Other package options and caches: -\code{\link{clear_fitted_cache}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{spatialkit_quiet}()} +Other package options and caches: +\code{\link[=clear_fitted_cache]{clear_fitted_cache()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=spatialkit_quiet]{spatialkit_quiet()}} } \concept{package options and caches} diff --git a/man/clip_target_for.Rd b/man/clip_target_for.Rd index d80327bf..150106d3 100644 --- a/man/clip_target_for.Rd +++ b/man/clip_target_for.Rd @@ -19,7 +19,7 @@ envelope, and refused with an error otherwise.} \item{expand}{Numeric expansion distance or fraction (0–1 = fraction of extent). Absolute values are expressed in the units of the CRS the clip -target is built in. Because \code{\link[sf:geos_unary]{sf::st_buffer()}} interprets \code{dist} as +target is built in. Because \code{\link[sf:st_buffer]{sf::st_buffer()}} interprets \code{dist} as \strong{metres} for lon/lat data while the fraction-of-extent form is derived from a bounding box measured in \strong{degrees}, lon/lat input is projected to a local projected CRS first (see \verb{@return}), so both forms agree.} @@ -50,7 +50,8 @@ identical ground. \details{ It is not the target \code{\link[=build_tessellation]{build_tessellation()}} derives on its own: \code{method = "voronoi"} without a boundary clips to the convex hull of the -points buffered by 2 percent of its diagonal, and there \code{expand} is always +points (or of their \code{cover}, for seeds) buffered by 2 percent of its +diagonal, and there \code{expand} is always a distance. A bounding box over a non-rectangular point cloud includes corners with no data, so a hex or square grid laid over it has cells that hold no points; pass the study-area polygon when there is one. @@ -67,10 +68,10 @@ box <- clip_target_for(pts, expand = 0.1, quiet = TRUE) st_area(box) } \seealso{ -Other spatial data preparation: -\code{\link{coerce_to_points}()}, -\code{\link{ensure_projected}()}, -\code{\link{harmonize_crs}()}, -\code{\link{prep_model_data}()} +Other spatial data preparation: +\code{\link[=coerce_to_points]{coerce_to_points()}}, +\code{\link[=ensure_projected]{ensure_projected()}}, +\code{\link[=harmonize_crs]{harmonize_crs()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{spatial data preparation} diff --git a/man/coef.bayesian_fit.Rd b/man/coef.bayesian_fit.Rd index 2d5b45a5..76c51dd6 100644 --- a/man/coef.bayesian_fit.Rd +++ b/man/coef.bayesian_fit.Rd @@ -48,21 +48,21 @@ standardising. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/coef.gwr_fit.Rd b/man/coef.gwr_fit.Rd index 5773bf57..d3efdc03 100644 --- a/man/coef.gwr_fit.Rd +++ b/man/coef.gwr_fit.Rd @@ -4,16 +4,21 @@ \alias{coef.gwr_fit} \title{Extract GWR local coefficients} \usage{ -\method{coef}{gwr_fit}(object, ...) +\method{coef}{gwr_fit}(object, se = FALSE, ...) } \arguments{ \item{object}{A \code{gwr_fit} object.} +\item{se}{Logical; also return the standard errors and t values. Default +\code{FALSE}.} + \item{...}{Ignored.} } \value{ -A data.frame of local coefficient estimates: one row per -observation, one column per model term. +With \code{se = FALSE}, a data.frame of local coefficient +estimates: one row per observation, one column per model term. With +\code{se = TRUE}, a list of three such data.frames: \code{estimate}, +\code{se} and \code{t}. Never \code{NULL}: when the engine carries no \code{SDF} component this errors, following the \code{coef()} contract described in \code{\link{new_spatial_fit}}. @@ -30,37 +35,64 @@ it back to \code{object$data_sf} to map it. Use \section{What is and is not returned}{ Only the model terms: the intercept and one column per predictor. -GWmodel's \code{SDF} data slot carries a good deal more alongside them +The engine's \code{SDF} data slot carries a good deal more alongside them (standard errors, t-values, the observed response, the fitted values, the residuals, \code{Local_R2}): 15 columns for a two-predictor fit, of which 3 are coefficients. Returning the whole slot would have made \code{coef(fit)$Local_R2} and \code{coef(fit)$a_SE} read like coefficients -and \code{ncol(coef(fit))} a meaningless number. Reach for -\code{object$engine$SDF} when you want the rest; it is the unmodified -GWmodel object. +and \code{ncol(coef(fit))} a meaningless number. Ask for the standard +errors and t values with \code{se = TRUE}; reach for +\code{object$engine$SDF} when you want the rest. + +A coefficient is \code{NA} at a location whose local window cannot +estimate it: a predictor that does not vary among the observations that +carry weight there has no slope, and the intercept is then not identified +either unless the predictor is 0 there. \code{object$info$nonfinite_coef} +is the mask, and \code{\link{fit_gwr_model}} raises a warning that counts +them. -If the model terms cannot be located in the \code{SDF} (a GWmodel that +If the model terms cannot be located in the \code{SDF} (an engine that names its coefficient columns differently), the whole slot is returned with a warning saying so. The call neither errors nor returns a silently short table. } +\section{Standard errors}{ + +With \code{se = TRUE} the local standard errors and t values come with the +estimates. A standard error is +\eqn{\hat\sigma\sqrt{(C C^\top)_{jj}}}{sigma * sqrt(diag(C C'))}, with +\eqn{C = (X^\top W X)^{-1} X^\top W} the weights the local regression puts +on the responses and \eqn{\hat\sigma^2} the residual sum of squares over +the fit's effective degrees of freedom: the definition +\code{GWmodel::gwr.basic()} uses, computed from the QR decomposition that +gave the estimate. They treat the bandwidth as known. The t values are +one test per term and location, tens to thousands of them and strongly +dependent, so a map of \eqn{|t| > 2} overstates what is significant; no +p-value, adjusted or not, is returned. What an adjustment for the number +of tests needs is on the fit: the t values here, the effective number of +parameters \code{object$info$enp} and the residual degrees of freedom +\code{object$info$edf}. When observations share a location the standard +errors are too small as well (see \code{\link{fit_gwr_model}}, +\strong{Observations that share a location}). +} + \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/coef.rf_fit.Rd b/man/coef.rf_fit.Rd index 59e9eb26..6d32d1b4 100644 --- a/man/coef.rf_fit.Rd +++ b/man/coef.rf_fit.Rd @@ -21,21 +21,21 @@ coefficients. See the \code{coef()} contract in \code{\link{new_spatial_fit}}. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/coerce_to_points.Rd b/man/coerce_to_points.Rd index 373e9a96..c7b34f27 100644 --- a/man/coerce_to_points.Rd +++ b/man/coerce_to_points.Rd @@ -58,10 +58,10 @@ poly <- st_sf( coerce_to_points(poly, "auto") # interior representative point } \seealso{ -Other spatial data preparation: -\code{\link{clip_target_for}()}, -\code{\link{ensure_projected}()}, -\code{\link{harmonize_crs}()}, -\code{\link{prep_model_data}()} +Other spatial data preparation: +\code{\link[=clip_target_for]{clip_target_for()}}, +\code{\link[=ensure_projected]{ensure_projected()}}, +\code{\link[=harmonize_crs]{harmonize_crs()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{spatial data preparation} diff --git a/man/compare_models.Rd b/man/compare_models.Rd index 270a18f7..a6dbfe68 100644 --- a/man/compare_models.Rd +++ b/man/compare_models.Rd @@ -28,12 +28,27 @@ same rows), and the warning says which. \code{convergence_ok} is \code{TRUE} or \code{FALSE} for a Bayesian fit whose convergence was checked (see \code{\link{fit_bayesian_spatial_model}}) and \code{NA} otherwise; a fit that did not converge is ranked like the others, so it -also raises a warning. Alongside the metrics it +also raises a warning. \code{gp_adequacy} is what the posterior of a +Bayesian fit said about its Gaussian-process basis (\code{"ok"}, +\code{"below_resolution"}, \code{"unresolved_short_range"}, +\code{"no_signal_above_floor"} or \code{"not_checked"}; see "What the +basis resolves" in \code{\link{fit_bayesian_spatial_model}}) and +\code{NA} for the other backends. A basis found too coarse scores like +one that was adequate, so read the column beside the metrics. Alongside +the metrics it carries -\code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and -\code{resid_morans_null}, the last of which names the null +\code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p}, +\code{resid_morans_null} and \code{resid_morans_basis}. +\code{resid_morans_null} names the null \code{\link{residual_morans_i}} scored each model against, since that -choice is per-fit and governs how much the p-value is worth. A +choice is per-fit and governs how much the p-value is worth. +\code{resid_morans_basis} says which residuals the statistic was +computed on. They are always the residuals of the rows the model was +fitted to, also when \code{newdata} is given, so the column reads +\code{"in-sample"}, or \code{"out-of-bag"} for a forest, and never +\code{"newdata"}: beside \code{metric_basis = "newdata"} the Moran +columns describe the training residuals, not the prediction errors on +\code{newdata}, and the two can differ in sign. A significant p-value is noted in the log (not raised as an R warning): positive autocorrelation as structure the model may have missed, negative (\code{resid_morans_z < 0}) as the alternating residuals of a @@ -121,10 +136,10 @@ if (requireNamespace("ranger", quietly = TRUE)) { } } \seealso{ -Other model evaluation: -\code{\link{compare_models_cv}()}, -\code{\link{evaluate_insample}()}, -\code{\link{model_metrics}()}, -\code{\link{residual_morans_i}()} +Other model evaluation: +\code{\link[=compare_models_cv]{compare_models_cv()}}, +\code{\link[=evaluate_insample]{evaluate_insample()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=residual_morans_i]{residual_morans_i()}} } \concept{model evaluation} diff --git a/man/compare_models_cv.Rd b/man/compare_models_cv.Rd index 1de290a2..6dee5917 100644 --- a/man/compare_models_cv.Rd +++ b/man/compare_models_cv.Rd @@ -32,7 +32,7 @@ compare_models_cv( \item{predictor_vars}{Predictor column names.} \item{models}{Character vector: any subset of \code{c("GWR", "Bayesian", - "RF")}, in any order. Each is cross-validated on the same \code{folds}. +"RF")}, in any order. Each is cross-validated on the same \code{folds}. Names outside that set raise a warning and are dropped; if nothing recognised remains, this is an error. There is no silent fallback. A recognised model whose backend package is not installed is dropped with @@ -41,7 +41,8 @@ a message so the call still returns the models that could run. But if compare and the call errors with \code{"no viable models."}. Guard with \code{requireNamespace()} when the model set is not known in advance.} -\item{k}{Number of folds. Default 5.} +\item{k}{Number of folds to build when \code{folds} is \code{NULL}; not +read when \code{folds} is supplied. Default 5.} \item{seed}{RNG seed. Default 123.} @@ -83,7 +84,10 @@ It does not silence R warnings, nor the package's console log echo \item{block_size}{Optional minimum block edge length for the shared spatial CV blocks (projected CRS units), passed to \code{\link{make_folds}()} -when \code{folds} is \code{NULL}. Default \code{NULL}.} +when \code{folds} is \code{NULL}. Default \code{NULL}. Beside +supplied \code{folds} it has nothing to size and raises a warning +(class \code{spatialkit_fold_args_ignored}); so does +\code{auto_range = TRUE}.} \item{auto_range}{Logical. If \code{TRUE} and \code{folds} is \code{NULL}, the autocorrelation range of the response (detrended on @@ -122,6 +126,11 @@ an \code{NA} row. Each model's metrics over all the rows it predicted stay in its \code{*_cv} element and in \code{attr(overall, "all_rows")}, a table of the same shape. \code{by_fold} and the Bayesian coverage and CRPS columns are per fold and are not recomputed. +Every model is cross-validated on the layer as passed, so the warnings +\code{\link{prep_model_data}()} raises about that layer (class +\code{spatialkit_rows_dropped}, counting the incomplete rows dropped, +and \code{spatialkit_constant_predictor}) are raised once for the +comparison, not once per model. Only the models that actually ran appear, so check which names are present; there is not always one entry per requested model, because a backend whose package is missing is dropped with a message. When \strong{no} requested backend @@ -218,11 +227,10 @@ if (requireNamespace("ranger", quietly = TRUE)) { ) dat$price <- 10 + 0.01 * (st_coordinates(dat)[, 1] - 5e5) + 2 * dat$elev + rnorm(n) - # The random forest, and GWR beside it when GWmodel is installed, on the + # The random forest, and GWR beside it when sp is installed, on the # same folds. "Bayesian" is left out here because a Stan fit per fold # takes minutes; add it to `models` for a run to report. - models <- c("RF", if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) "GWR") + models <- c("RF", if (requireNamespace("sp", quietly = TRUE)) "GWR") cmp <- compare_models_cv(dat, "price", "elev", models = models, k = 3, rf_args = list(num_trees = 100), gwr_args = list(bandwidth = 30)) @@ -238,10 +246,10 @@ study competition among methods for analyzing large spatial data. 24(3), 398--425. \doi{10.1007/s13253-018-00348-w} } \seealso{ -Other model evaluation: -\code{\link{compare_models}()}, -\code{\link{evaluate_insample}()}, -\code{\link{model_metrics}()}, -\code{\link{residual_morans_i}()} +Other model evaluation: +\code{\link[=compare_models]{compare_models()}}, +\code{\link[=evaluate_insample]{evaluate_insample()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=residual_morans_i]{residual_morans_i()}} } \concept{model evaluation} diff --git a/man/create_grid_polygons.Rd b/man/create_grid_polygons.Rd index b9754c6b..dd5c86f3 100644 --- a/man/create_grid_polygons.Rd +++ b/man/create_grid_polygons.Rd @@ -115,14 +115,14 @@ nrow(grid_sq) nrow(grid_hex) } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/create_grid_polygons_cached.Rd b/man/create_grid_polygons_cached.Rd index 07081995..3b935155 100644 --- a/man/create_grid_polygons_cached.Rd +++ b/man/create_grid_polygons_cached.Rd @@ -64,20 +64,20 @@ same_cell <- match(st_as_text(st_geometry(g2)), st_as_text(st_geometry(g))) all(g2$poly_id == g$poly_id[same_cell]) } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} -Other package options and caches: -\code{\link{clear_fitted_cache}()}, -\code{\link{clear_grid_cache}()}, -\code{\link{spatialkit_quiet}()} +Other package options and caches: +\code{\link[=clear_fitted_cache]{clear_fitted_cache()}}, +\code{\link[=clear_grid_cache]{clear_grid_cache()}}, +\code{\link[=spatialkit_quiet]{spatialkit_quiet()}} } \concept{package options and caches} \concept{tessellation} diff --git a/man/create_voronoi_polygons.Rd b/man/create_voronoi_polygons.Rd index b48d7924..d2f53495 100644 --- a/man/create_voronoi_polygons.Rd +++ b/man/create_voronoi_polygons.Rd @@ -11,7 +11,8 @@ create_voronoi_polygons( clip = TRUE, keep_duplicates = FALSE, crs = NULL, - quiet = FALSE + quiet = FALSE, + cover = NULL ) } \arguments{ @@ -47,14 +48,33 @@ one cell and all of them are indexed to it.} \item{crs}{Optional target CRS: anything \code{\link[sf:st_crs]{sf::st_crs()}} accepts, including an sf or sfc layer, whose CRS is used. A projected CRS is the working CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned -in: -the cells are built in the local projected CRS \code{\link[=ensure_projected]{ensure_projected()}} +in: the cells are built in the local projected CRS \code{\link[=ensure_projected]{ensure_projected()}} picks for the points, so they are nearest-point cells on the ground, and -are then transformed, with long edges densified.} +are then transformed, with long edges densified. Seeds that are the +centres a profile scored are built in the CRS the profile worked in +instead (see "Seeds a profile scored").} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}.} + +\item{cover}{Optional sf or sfc layer the cells have to hold, read when +there is no \code{boundary}: the observations (points), or a polygon. The +boundary is then derived from it instead of from \code{points_sf}: the convex +hull of the cover's points, or its polygons, grown by 2 percent of the +diagonal. This is what seeds need, because seeds lie inside the data they +stand for and their own hull stops short of it (see "Details"). +When \code{NULL}, the cover the seeding functions attach is used +(\code{attr(points_sf, "cover")}, set by \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}} and \code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}}). A cover with no +CRS is read in the coordinates of \code{points_sf}, and one in another CRS is +transformed. A generator outside the cover keeps its ground (the hull of +the generators is added); a cover that holds none of the generators is +set aside with a warning. With a \code{boundary}, the boundary sets the cells +and \code{cover} is only checked against them: the number of its points that +fall outside every cell is returned as \code{params$cover_outside}, with a +warning of class \code{"spatialkit_unassigned"} when it is not 0 (a polygon +cover is not checked).} } \value{ A list with \code{cells}, \code{index}, \code{boundary}, @@ -62,9 +82,30 @@ A list with \code{cells}, \code{index}, \code{boundary}, per row of \code{points_sf}, and \code{NA} for a point that falls outside every cell, which means outside the study area (grown by \code{expand} when it is positive), so a summary built from it counts only the points -the tessellation actually covers. \code{boundary} is the boundary the -cells were built in: the one supplied or derived, grown by -\code{expand}. +the tessellation actually covers. Such points are counted in +\code{params$n_outside}, and a warning of class +\code{"spatialkit_unassigned"} gives their number. \code{boundary} is +the boundary the cells were built in: the one supplied or derived, grown +by \code{expand}. \code{params$boundary_source} says where it came +from: \code{"boundary"} (the argument), \code{"cover"} (the +\code{cover} argument), \code{"seeds' cover"} (the cover attached to +\code{points_sf}) or \code{"points"} (the hull of \code{points_sf} +itself). \code{params$cover_outside} is the number of \code{cover} +points outside every cell when a point \code{cover} was given with a +\code{boundary}, and \code{NULL} otherwise. \code{params$partition} is +present when \code{points_sf} is a layer of seeds that records the kind +of partition that placed it (\code{attr(points_sf, "partition")}, see +\code{\link{get_voronoi_seeds}()}): the same list, so the cells say what +built them. Seeds of plain k-means record nothing, and \code{params} +then has no such element; neither has it for points that are not seeds. +\code{params$count_rule} is present when \code{points_sf} carries the +record of how its count was set (\code{attr(points_sf, "count_rule")}: +the seeds of a \code{\link{select_resolution}()} result, or seeds a +seeding function placed from one): the same list, which the cells carry +too as \code{attr(cells, "count_rule")}. +\code{\link{assign_features_to_polygons}()} copies it to the rows it +assigns, and \code{\link{summarize_by_cell}()} checks its result +against it. } \description{ Assigns every location in the study area to its nearest input point, giving @@ -77,7 +118,7 @@ instead when you need equal-area cells or a resolution independent of where the data happen to be. } \details{ -The heavy lifting is \code{\link[sf:geos_unary]{sf::st_voronoi()}}. What this adds is the surrounding +The heavy lifting is \code{\link[sf:st_voronoi]{sf::st_voronoi()}}. What this adds is the surrounding bookkeeping: projecting lon/lat input, building and buffering an envelope so edge cells are bounded, clipping to \code{boundary}, restoring the point-to-cell correspondence that \code{st_voronoi()} scrambles, and stamping @@ -90,7 +131,39 @@ others are referenced by no feature. Other functions in the package (\code{\link[=prep_model_data]{prep_model_data()}}, \code{\link[=make_folds]{make_folds()}}) reduce such a feature to its centroid instead, so cast to POINT, or take centroids, first if one cell per feature is what you want. + +With no \code{boundary} the cells are clipped to a boundary derived from the +data. For observations that is their own convex hull grown by 2 percent of +its diagonal, so every observation has a cell. Seeds are different: k-means +centres, random points in a study area and the centres a resolution +profile scored all lie inside the ground they stand for, and cells clipped +to the hull of the seeds leave the edge of that ground uncovered (on 3,000 +uniform points, 72 percent of them at 4 seeds, 25 percent at 25 and 4 +percent at 100). The boundary is therefore derived from the \code{cover} when +there is one: the argument, or the cover the seeding functions attach to +their result. A layer that looks like seeds and has neither a boundary nor +a cover (seeds bound with \code{rbind()}, which drops the attribute, or built +by hand) gets the seeds' own hull and a warning of class +\code{"spatialkit_no_cover"}. } +\section{Seeds a profile scored}{ + +The seeds of a \code{\link[=select_resolution]{select_resolution()}} result, and the seeds +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} or \code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}} return for one, are the +centres \code{\link[=resolution_profile]{resolution_profile()}} scored, and their record of the count +(\code{attr(, "count_rule")}) says so (\code{scored_cells = TRUE}) and holds the +centres in the CRS the profile worked in. Unless a projected \code{crs} is +given, their cells are built in that CRS, whatever CRS the seeds arrive +in (degrees, or the CRS of a boundary they were placed in), and returned +in it, or in a geographic \code{crs} when one is given. When the seeds are +those centres (as many, each at a different centre, within a thousandth +of its distance from the next nearest), each is first put at its centre +as the record holds it, so rounding the seeds took on in another CRS +does not move an edge. The cells are then the cells each row was scored +in, and \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} gives a point on an edge between +two of them the cell the profile scored it in. +} + \examples{ library(sf) set.seed(1) @@ -103,14 +176,14 @@ res$cells # one polygon per unique point, with stable cell_id res$index # cell_id assignment for each input point } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/cv_bayes.Rd b/man/cv_bayes.Rd index 5801f835..c0faeb19 100644 --- a/man/cv_bayes.Rd +++ b/man/cv_bayes.Rd @@ -43,7 +43,8 @@ error. IDs naming no row in the prepared data are dropped with a logged count (expected when rows were removed for missing values; a sign the folds came from other data when they were not).} -\item{k}{Number of folds. Default 5.} +\item{k}{Number of folds to build when \code{folds} is \code{NULL}; not +read when \code{folds} is supplied. Default 5.} \item{seed}{RNG seed. Default 123. It seeds fold construction \strong{and}, through a per-fold draw, each fold's Stan sampler, so two seeds give @@ -74,12 +75,16 @@ score, as proportions strictly between 0 and 1 (\code{0.95}, not column \code{coverage_} of \code{fold_metrics}, named at full precision (\code{0.975} gives \code{coverage_97.5}).} -\item{block_size}{Optional minimum block edge length for spatial CV blocks -(projected CRS units).} +\item{block_size}{Optional minimum block edge length (projected CRS +units) for the blocks built when \code{folds} is \code{NULL}; see +\code{\link{make_folds}()}. Beside supplied \code{folds} it has +nothing to size and raises a warning (class +\code{spatialkit_fold_args_ignored}).} \item{auto_range}{Logical. If \code{TRUE} and \code{folds} is \code{NULL}, estimate the autocorrelation range and use it as the minimum block size. -Default \code{FALSE}.} +Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +the same warning as \code{block_size}.} \item{parallel}{Logical or positive integer. If \code{TRUE}, auto-detect the number of cores and fit folds in parallel via @@ -124,12 +129,22 @@ that give the coverage below (\code{NA} when see \code{\link{cv_spatial}}. \code{fold_metrics} carries, beyond the columns its siblings share, \code{gp_k}, \code{gp_n_basis}, \code{n_draws}, \code{CRPS}, the -\code{coverage_*} columns and \code{convergence_ok}: \code{TRUE} or +\code{coverage_*} columns, \code{convergence_ok} and +\code{gp_adequacy}. \code{convergence_ok} is \code{TRUE} or \code{FALSE} as \code{\link{fit_bayesian_spatial_model}()} judged that -fold's sampler (R-hat, effective sample size, divergences), \code{NA} +fold's sampler (divergent transitions, R-hat, effective sample size and +E-BFMI; see its \code{check_convergence}), \code{NA} when \code{fit_args} sets \code{check_convergence = FALSE}. A fold that did not converge is scored like the others, so a run with any -\code{FALSE} raises one warning naming those folds. +\code{FALSE} raises one warning of class \code{spatialkit_convergence} +naming those folds and the checks each failed. +\code{gp_adequacy} is what that fold's posterior said about its +Gaussian-process basis (\code{"ok"}, \code{"below_resolution"}, +\code{"unresolved_short_range"}, \code{"no_signal_above_floor"} or +\code{"not_checked"}; see "What the basis resolves" in +\code{\link{fit_bayesian_spatial_model}}). A fold whose basis was +found too coarse is scored like the others too. See \strong{Warnings +from the folds}. The \code{predictive_coverage} entries (one per \code{coverage_levels} value, plus \code{mean_CRPS}) are averages across folds \strong{weighted by each fold's \code{n_pred}}, because the per-fold @@ -155,6 +170,24 @@ the cores. For a cheap first pass on the same question, cross-validate a forest with \code{\link{cv_rf}()} and come back here once the predictor set has settled. } +\section{Warnings from the folds}{ + +\code{\link{fit_bayesian_spatial_model}()} warns about a fit under four +condition classes: \code{spatialkit_gp_basis_size}, +\code{spatialkit_gp_resolution}, \code{spatialkit_convergence} and +\code{spatialkit_gp_adequacy} (see its \strong{Warnings}). Each fold is +a fit, and none of those warnings says which fold it came from, so they +are collected as the folds run and each class is raised once after the +last fold, under this function's name and with the same class. Each +warning names the folds and carries \code{folds} (their labels) and +\code{fold_messages} (every fold's own text, named by fold) as fields of +the condition. The convergence warning covers the folds that were +scored and gives the checks each failed, also as the field +\code{failed}; the other three quote the first fold's own text. Each +fold's own line is in the log. Warnings that Stan or \pkg{brms} raise +themselves are not collected and are passed on. +} + \section{Percentage errors on responses with zeros}{ \code{MAPE} divides by the observed value and \code{SMAPE} by @@ -235,17 +268,17 @@ if (requireNamespace("brms", quietly = TRUE)) { } } \seealso{ -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/cv_block_size_sweep.Rd b/man/cv_block_size_sweep.Rd index 17a43af0..55c32268 100644 --- a/man/cv_block_size_sweep.Rd +++ b/man/cv_block_size_sweep.Rd @@ -72,7 +72,9 @@ cross-validation: \code{block_size} (\code{NA} for the random reference), \code{method}, \code{blocks_used}, \code{k} (the folds actually built), \code{n_folds_succeeded}, \code{value} (the pooled metric), \code{fold_min}, \code{fold_max} and \code{fold_sd} (its spread -across folds). Attributes: \code{metric}, \code{sac_range} (the +across folds), and \code{block_width} and \code{block_height} (the +width and height of the grid cells built at that size, \code{NA} for +the random reference). Attributes: \code{metric}, \code{sac_range} (the effective range, or \code{NA}), \code{crs}, \code{k} (the folds requested, which \code{print()} and \code{plot()} report), \code{n_fits}, \code{response_var}, and \code{results}, the full @@ -117,7 +119,7 @@ grid would hold more than the 1,000,000 \code{make_folds()} will build is dropped. The count is of grid cells: on clustered data a grid of \code{k} or more cells can have fewer than \code{k} that hold points, and \code{make_folds()} then lowers \code{k} at that size, which the -\code{k} column shows. On an extent much longer than it is wide every +\code{k} column shows; the sweep warns once, naming the sizes. On an extent much longer than it is wide every rung can fall below the autocorrelation range while longer blocks would still fit \code{k} times along the longer side; the sweep warns when that happens, and \code{block_sizes} is then the way to reach past the @@ -125,8 +127,27 @@ range. Sizes are in the units of the CRS the folds are built in (\code{make_folds()}'s \code{params$crs}, metres for geographic input), and the returned table records that CRS. Each is the \emph{minimum} block edge handed to \code{make_folds()}, which fits a whole number of cells -across the extent, so the cells are somewhat longer than the size on the -axis (up to twice as long). +across each axis of the extent, so on an axis at least as long as the +size the cells are somewhat longer than it (up to just under twice as +long). An axis shorter than the size is spanned by one row or column of +cells, which are then shorter than the size there. The +\code{block_width} and \code{block_height} columns give the cells built +at each size. +} + +\section{Warnings raised once for the sweep}{ + +Every size is a \code{\link{cv_spatial}()} on the same layer. The +warnings \code{\link{prep_model_data}()} raises about that layer (class +\code{spatialkit_rows_dropped}, counting the incomplete rows dropped, and +\code{spatialkit_constant_predictor}) are raised once, not once per +size. With a GWR learner, the two warnings in +which \code{predict()} counts held-out locations +(\code{"spatialkit_gwr_not_estimable"} and +\code{"spatialkit_gwr_extrapolation"}) are raised once each, under this +function's name, with the totals over every size; the same rows are +predicted at every size, so a location can be counted once per size (see +\code{\link{predict.gwr_fit}}). } \examples{ @@ -152,17 +173,17 @@ if (requireNamespace("ranger", quietly = TRUE) && \seealso{ \code{\link{plot.block_size_sweep}()}. -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/cv_gwr.Rd b/man/cv_gwr.Rd index f3de553a..3195d4cb 100644 --- a/man/cv_gwr.Rd +++ b/man/cv_gwr.Rd @@ -42,7 +42,8 @@ error. IDs naming no row in the prepared data are dropped with a logged count (expected when rows were removed for missing values; a sign the folds came from other data when they were not).} -\item{k}{Number of folds. Default 5.} +\item{k}{Number of folds to build when \code{folds} is \code{NULL}; not +read when \code{folds} is supplied. Default 5.} \item{seed}{RNG seed. Default 123.} @@ -53,8 +54,10 @@ the folds came from other data when they were not).} \code{adaptive = FALSE} a distance in the units of the \strong{projected} CRS the folds are fitted in (geographic input is projected first, so a value in degrees is read as metres). \code{NULL} (default) selects a -bandwidth per fold with \code{GWmodel::bw.gwr()}, which is reported in -\code{fold_metrics$bandwidth}. See \code{\link{fit_gwr_model}}.} +bandwidth per fold from that fold's training rows, by the search +\code{\link{fit_gwr_model}()} runs (its section Bandwidth selection: +AICc, or the leave-one-location-out sum of squares when observations +share a location), and reports it in \code{fold_metrics$bandwidth}.} \item{kernel}{Kernel function type.} @@ -62,20 +65,23 @@ bandwidth per fold with \code{GWmodel::bw.gwr()}, which is reported in \item{pointize}{Geometry coercion strategy.} -\item{block_size}{Optional minimum block edge length for spatial CV blocks -(projected CRS units). Blocks are then at least as large as the -spatial autocorrelation range.} +\item{block_size}{Optional minimum block edge length (projected CRS +units) for the blocks built when \code{folds} is \code{NULL}; see +\code{\link{make_folds}()}. It is a size you choose and is not +compared with the autocorrelation range unless one can be estimated, in +which case a smaller size is warned about. Beside supplied +\code{folds} it has nothing to size and raises a warning (class +\code{spatialkit_fold_args_ignored}).} \item{auto_range}{Logical. If \code{TRUE} and \code{folds} is \code{NULL}, estimate the autocorrelation range and use it as the minimum block size. -Default \code{FALSE}.} +Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +the same warning as \code{block_size}.} \item{parallel}{Accepted so that every \code{cv_*()} function takes the same arguments, but the GWR folds always run one after another in this -R process. GWmodel is built with OpenMP, and OpenMP (GNU libgomp) -deadlocks \code{parallel::mclapply()}'s forked workers once a GWR has -been fitted in the session, for example by \code{fit_gwr_model()}, so -forking would hang the call. A value asking for more than one core +R process, where the warnings \code{predict()} raises for each fold are +collected into one. A value asking for more than one core raises a warning saying so. Default \code{FALSE}.} \item{metrics}{Optional scoring function of your own, a @@ -98,7 +104,13 @@ missing fold is missing. See \code{\link{cv_spatial}} for the five statuses and for \code{orphan_rows}. \code{Adj_R2} is \code{NA} in both \code{overall} and \code{fold_metrics}: the pooled predictions have no single parameter count, and a GWR's effective parameter count is -not its predictor count (see \code{\link{cv_spatial}}). +not its predictor count (see \code{\link{cv_spatial}}). A held-out +location whose local regression cannot be estimated has \code{yhat} +\code{NA}, and one beyond the reach of its fold's fit is predicted and +scored; each case raises one warning for the whole run (classes +\code{"spatialkit_gwr_not_estimable"} and +\code{"spatialkit_gwr_extrapolation"}), with the totals over the folds +that had any. See \code{\link{predict.gwr_fit}}. } \description{ Refits a geographically weighted regression from scratch on each training @@ -151,8 +163,7 @@ coverage, which are proper scoring rules and have no such failure mode. } \examples{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +if (requireNamespace("sp", quietly = TRUE)) { library(sf) set.seed(1) n <- 60 @@ -169,17 +180,17 @@ if (requireNamespace("GWmodel", quietly = TRUE) && } } \seealso{ -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/cv_rf.Rd b/man/cv_rf.Rd index 23462683..09b36334 100644 --- a/man/cv_rf.Rd +++ b/man/cv_rf.Rd @@ -53,7 +53,11 @@ Under forked workers each fold's forest runs single-threaded unless four threads in total, where it would otherwise mean four times the session's \code{mc.cores}.} -\item{block_size, auto_range, boundary}{Passed to \code{\link{cv_spatial}}.} +\item{block_size, auto_range, boundary}{Passed to \code{\link{cv_spatial}}. +\code{block_size} and \code{auto_range = TRUE} size the blocks built +when \code{folds} is \code{NULL}; beside supplied \code{folds} they +have nothing to size and raise a warning of class +\code{spatialkit_fold_args_ignored}.} \item{pointize}{How non-POINT geometry is reduced to a point before fitting; passed to \code{\link{cv_spatial}}. Default \code{"auto"}.} @@ -79,6 +83,24 @@ forest on each training fold. Unlike the out-of-bag error, this holds out whole spatial blocks, so neighbours of a held-out point are not sitting in the training set. } +\section{Comparing the forest with and without coordinates}{ + +Whether \code{include_coords = TRUE} lowers the error depends on how far +from the training data the predictions are (see \emph{Coordinates as +predictors} in \code{\link{fit_rf_model}}), so it is a comparison to make +on your own data, at the block size the map will be used at. Score the +two forests on the same folds: build the folds once with +\code{\link{make_folds}} and pass the result as \code{folds} to two +calls, one with \code{include_coords = TRUE} and one without. Each fold +then holds out the same rows in both, so the two \code{overall} rows +compare like with like and the two \code{fold_metrics} tables pair up +fold by fold. A difference in \code{overall} that is small beside the +spread of the per-fold differences is not evidence for either forest. +The example below runs the comparison. \code{\link{compare_models_cv}} +takes one set of forest arguments (\code{rf_args}) per call, so it scores +one of the two forests, not both. +} + \section{Percentage errors on responses with zeros}{ \code{MAPE} divides by the observed value and \code{SMAPE} by @@ -121,20 +143,32 @@ if (requireNamespace("ranger", quietly = TRUE)) { ) dat$z <- 2 * dat$a + rnorm(n, 0, 0.3) cv_rf(dat, "z", "a", k = 4)$overall + + # The forest with and without the coordinates, on the same blocked + # folds. (The second call logs the include_coords caution, once per + # session; this comparison is what it asks for.) This response has no + # spatial structure, so here the coordinates can only cost accuracy. + folds <- make_folds(dat, k = 4, method = "block_kfold", seed = 1) + plain <- cv_rf(dat, "z", "a", folds = folds, num_trees = 200) + with_xy <- cv_rf(dat, "z", "a", folds = folds, num_trees = 200, + include_coords = TRUE) + c(plain = plain$overall$RMSE, with_xy = with_xy$overall$RMSE) + # Fold by fold: positive where the coordinates lowered the error. + plain$fold_metrics$RMSE - with_xy$fold_metrics$RMSE } } \seealso{ -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/cv_spatial.Rd b/man/cv_spatial.Rd index 323e2813..02a1fe7e 100644 --- a/man/cv_spatial.Rd +++ b/man/cv_spatial.Rd @@ -52,7 +52,8 @@ error. IDs naming no row in the prepared data are dropped with a logged count. Built via \code{block_kfold} when \code{NULL}.} -\item{k}{Number of folds.} +\item{k}{Number of folds to build when \code{folds} is \code{NULL}; not +read when \code{folds} is supplied.} \item{seed}{RNG seed.} @@ -84,21 +85,25 @@ is logged, its columns are \code{NA} for that fold, and for models with a fixed global parameter count; pass NULL for models with spatially varying coefficients (e.g. GWR).} -\item{block_size}{Optional minimum block edge length for spatial CV blocks -(projected CRS units).} +\item{block_size}{Optional minimum block edge length (projected CRS +units) for the blocks built when \code{folds} is \code{NULL}; see +\code{\link{make_folds}()}. Beside supplied \code{folds} it has +nothing to size and raises a warning (class +\code{spatialkit_fold_args_ignored}).} \item{auto_range}{Logical. If \code{TRUE} and \code{folds} is \code{NULL}, estimate the autocorrelation range and use it as the minimum block size. -Default \code{FALSE}.} +Default \code{FALSE}. \code{TRUE} beside supplied \code{folds} raises +the same warning as \code{block_size}.} \item{parallel}{Logical or positive integer. If \code{TRUE}, auto-detect the number of cores and fit folds in parallel via \code{parallel::mclapply()} (macOS / Linux; falls back to sequential on Windows). If an integer > 1, use that many cores. Default -\code{FALSE} (sequential). A learner that runs OpenMP code (GWmodel, -or an xgboost built with GNU libgomp) can hang the forked workers once -it has run in the session; keep such a \code{fit_fn} sequential, as -\code{\link{cv_gwr}()} does.} +\code{FALSE} (sequential). A learner that runs OpenMP code (a +function of GWmodel, or an xgboost built with GNU libgomp) can hang the +forked workers once it has run in the session; keep such a +\code{fit_fn} sequential.} \item{metrics}{Optional scoring function of your own; see \strong{Your own metrics} below. Default \code{NULL}: the built-in metrics only.} @@ -228,6 +233,28 @@ hands one \code{metrics} to every backend, so the columns are comparable across the rows of its \code{overall}. } +\section{Warnings a learner raises in every fold}{ + +A warning from a fold's fit or from its \code{predict()} reaches the +caller as it is raised, so a learner that warns in every fold warns once +per fold. Two groups of the package's own warnings are collected over the +folds instead and raised once per call, under this function's name and +with the class they had: +\itemize{ +\item the two in which \code{predict()} on a GWR counts locations +(\code{"spatialkit_gwr_not_estimable"} and +\code{"spatialkit_gwr_extrapolation"}), with the totals over the folds +that had any, as \code{\link{cv_gwr}()} raises them (see +\code{\link{predict.gwr_fit}}); +\item the four \code{\link{fit_bayesian_spatial_model}()} raises about +a fit, naming the folds, as \code{\link{cv_bayes}()} raises them (see +\strong{Warnings from the folds} there). +} +With \code{parallel} above one core a fold's warnings are raised after +the folds have run, once per distinct text; one of the package's own +classes keeps its class and its fields. +} + \section{Percentage errors on responses with zeros}{ \code{MAPE} divides by the observed value and \code{SMAPE} by @@ -310,17 +337,17 @@ must use; \code{\link{cv_gwr}()}, \code{\link{cv_bayes}()} and \code{\link{cv_rf}()} for the built-in backends, which are thin wrappers over this function. -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/determine_optimal_levels.Rd b/man/determine_optimal_levels.Rd index 29449c8e..805fd278 100644 --- a/man/determine_optimal_levels.Rd +++ b/man/determine_optimal_levels.Rd @@ -13,7 +13,8 @@ determine_optimal_levels( response_var = NULL, predictor_vars = NULL, criterion = c("geometric", "morans_i", "combined"), - select_on = c("all", "split") + select_on = c("all", "split"), + on_no_elbow = c("warn", "na", "error") ) } \arguments{ @@ -37,8 +38,9 @@ coordinate order before either, so the answer does not depend on the order they come in.} \item{response_var}{Optional response column name. When provided alongside -\code{predictor_vars}, enables model-aware level selection via Moran's I -on OLS residuals. Must be numeric or logical (logicals are read as 0/1); +\code{predictor_vars}, or with \code{criterion = "morans_i"} or +\code{"combined"}, enables model-aware level selection via Moran's I +of the cell means. Must be numeric or logical (logicals are read as 0/1); a factor or character response raises an error and is never coerced, because the residuals of an OLS fit to arbitrary level codes carry no meaning to test for autocorrelation. Rows where it, or a predictor, is @@ -47,21 +49,34 @@ out of Moran's I; a logged warning gives their number.} \item{predictor_vars}{Optional predictor column names. Must be numeric or logical (logicals are read as 0/1); factor/character columns raise an -error.} +error. Without them the model-aware criteria regress the cell means on +an intercept alone, as \code{\link{resolution_profile}()} does.} \item{criterion}{One of \code{"geometric"} (default when no response given), -\code{"morans_i"} (select the k whose residual Moran's I is least -\emph{significant}), or \code{"combined"} (rank-average of the WSS +\code{"morans_i"} (among the candidates around the elbow, the k at which +Moran's I of the cell means, or of their regression residuals, is least +\emph{significant}: the count at which neighbouring cells stop +resembling each other, not the count that represents the response +best), or \code{"combined"} (rank-average of the WSS curve's log-log sag, the quantity the elbow is read from, and that same -significance). Falls back to \code{"geometric"}, -with a warning, when \code{response_var} or \code{predictor_vars} is not +significance). Whenever Moran's z orders the candidates returned, +under either, a warning of class +\code{spatialkit_diagnostic_ranking} says that the ranking is by a +diagnostic of the cell means; its condition carries \code{k} (the +count ranked first), \code{criterion}, \code{first_computable} (the +first count at which the statistic is finite), \code{window} +(the first and last count tried) and \code{upgraded} (whether +\code{"combined"} was taken because both model variables were +supplied). Falls back to \code{"geometric"}, +with a warning, when \code{response_var} is not given, and with a logged warning when no candidate clears the nine-cell resolution floor described in \strong{Details}. A \code{response_var} or \code{predictor_vars} naming a column that is not in \code{data_sf} is an error. Supplying both \code{response_var} and \code{predictor_vars} upgrades \code{"geometric"} to \code{"combined"}: the selection then depends on -the response (see "Post-selection inference").} +the response (see "Post-selection inference"). A \code{response_var} +alone leaves \code{"geometric"} as it is.} \item{select_on}{\code{"all"} (default) selects on every point; \code{"split"} reads the response on one spatially blocked half of the @@ -69,13 +84,38 @@ points only and returns the other half as the set to estimate on, so that the standard errors computed downstream on the chosen cells are not post-selection. The count is still chosen for the whole layer. See "Post-selection inference".} + +\item{on_no_elbow}{What to do when the count is not a finding about the +data: the WSS curve has no elbow, the ladder is too short to show one, +or there are too few points or locations for a ladder at all. +\code{"warn"} (default) returns the count the chord rule or the ladder +gives, with a warning of class \code{spatialkit_no_elbow} whose +condition carries \code{k} (that count), \code{sag} (the largest +log-log sag of the curve; an elbow needs \eqn{\log 1.25}) and +\code{structured = FALSE}, so a caller can catch it without matching +the message. \code{"na"} returns \code{NA_integer_} there and logs the +reason, and every result under \code{"na"} carries the attributes +\code{structured} (\code{FALSE} with the \code{NA}, \code{TRUE} with a +count the elbow chose) and \code{sag}, so one test of +\code{attr(k, "structured")} covers both outcomes; +\code{"error"} stops with an error of that class. Under the +model-aware criteria the candidates are scored around the elbow, so +with no elbow the ladder places that window and the same applies.} } \value{ An integer vector of candidate level counts, \strong{best first}: under the geometric criterion the elbow, then its lower and upper -neighbours (with a warning when the WSS curve has no elbow and the first -is the ladder's choice; see Details); under the model-aware criteria the -candidates in rank order. +neighbours (with a warning of class \code{spatialkit_no_elbow} when the +WSS curve has no elbow and the first is the ladder's choice, or +\code{NA_integer_} under \code{on_no_elbow = "na"}, where the result +also carries the attributes \code{structured} and \code{sag}; see +Details); under the model-aware +criteria the candidates in rank order, with a warning of class +\code{spatialkit_diagnostic_ranking} when Moran's z took part in the +ranking. A layer with no points is an +error, and one with fewer than three points, or with every point on +one location, has no ladder: it returns 1 under the same +\code{on_no_elbow} rule. \code{k[1]} is therefore the top-ranked count on every path, and \code{top_n = 1} returns it alone. When \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is @@ -84,7 +124,9 @@ standardised deviates (\code{moran_z}), the WSS curve (\code{wss}) with the relative between-restart spread at each \code{k} (\code{wss_spread}), the number of rising steps on it (\code{wss_bumps}), the restart budget (\code{nstart}), the geometric elbow the evaluated -neighbourhood was drawn around (\code{knee_k}), the \code{k} at which +neighbourhood was drawn around (\code{knee_k}), whether the WSS curve +has an elbow (\code{structured}) and its largest log-log sag +(\code{sag}), the \code{k} at which k-means failed (\code{failed_k}; their \code{wss} entries are interpolated from the neighbours, not measured) and the \code{k} the model-aware pass actually scored (\code{eval_ks}, the elbow's @@ -127,8 +169,14 @@ points with ladders to 3--40, uniform layouts over squares, discs, triangles, an L-shape, density gradients and jittered lattices sagged at most 0.16, and two to ten separated clusters at least 0.6 once \code{max_levels} passed the cluster count. With no elbow the function -warns and returns the linear-axis answer, which the ladder chose, not the -data. An elongated extent also bends, at about its aspect ratio, because +warns (a warning of class \code{spatialkit_no_elbow}, which carries the +count as \code{k} and the largest sag as \code{sag}) and returns the +linear-axis answer, which the ladder chose, not the data: about +\eqn{\sqrt{K_{max}}}, 3 or 4 cells at the default, close to one mean for +the whole layer. \code{on_no_elbow = "na"} returns \code{NA} there and +\code{"error"} stops, so that a count which is not a finding is not +passed on as one. An elongated extent also bends, at about its aspect +ratio, because the first cuts go across its long axis (0.2--0.45 for a 4:1 rectangle); past the threshold that bend is reported as an elbow, and it describes the extent's shape rather than clusters in it. When locations repeat @@ -139,13 +187,35 @@ the fall to zero is the sharpest bend there is: when the rest of the curve has no elbow, the number of distinct locations is the elbow. When \code{response_var} and \code{predictor_vars} are provided, the -geometric WSS elbow is supplemented with Moran's I computed on OLS -residuals at each candidate k. The Moran's I profile measures how much -spatial autocorrelation in the response remains \emph{unexplained} at a given -tessellation resolution. It is a direct reflection of the spatial process -being modeled instead of the mere geometric compactness of coordinates. -The combined criterion selects the k that best balances geometric parsimony -and residual spatial independence. +geometric WSS elbow is supplemented with Moran's I of the cell means at +each candidate k: the cell means are regressed on the cell-mean +predictors (on an intercept alone when \code{criterion = "morans_i"} or +\code{"combined"} is asked for with a response and no predictors) and +Moran's I is computed on the residuals over each cell's 8 nearest cells. +That statistic tests whether \emph{neighbouring cells} are independent. +It does not measure the autocorrelation the cells leave unexplained in +the response, and it does not say how well they represent it: on an +autocorrelated response it grows as the cells get finer than the range, +because neighbouring cells then resemble each other, and it is close to 0 +at about 10 to 20 cells whatever the data, where the neighbour graph is +nearly complete. The model-aware criteria prefer the candidate with the +smallest \eqn{|z|}, which is the count at which neighbouring cell means +stop resembling each other, cells about as wide as the range. Only the +elbow's neighbourhood is scored, so the response moves the answer by at +most a few cells either side of the geometric elbow. \strong{A ranking +that Moran's z took part in is a ranking by a diagnostic, not by a count +rule}, and it is returned with a warning of class +\code{spatialkit_diagnostic_ranking} that says so and gives the count +ranked first, the first count the statistic could be computed at and the +counts scored. Measured on 500 points with a response alone and +\code{criterion = "morans_i"}: the first-ranked count was 10 to 13 on 16 +of 16 white-noise layers and on 16 of 16 exponential fields +(\code{max_levels} 40 and 80), and 10 was the first count the statistic +could be computed at on all 32. \code{\link{select_resolution}()} +refuses the same statistic unless asked with \code{diagnostic = TRUE}; +here the criterion is asked for by name, or taken when both model +variables are supplied, so the count is returned and the warning carries +the caveat. To keep memory use and runtime bounded for large \code{max_levels}, the initial k-means sweep records only within-cluster sum-of-squares (WSS) @@ -174,6 +244,14 @@ names the number of rising steps, and the model-aware paths return it as version on a curve that had such a bump can differ from the one made now; where the earlier curve was clean, the selection is the same. +\strong{The sweep is plain k-means, whatever the regions are built with +afterwards.} This function has no \code{partition} argument: the elbow is +a reading of the sum of squares that plain k-means minimises, and the +cells behind Moran's z are that partition's. A count returned here says +nothing about density-weighted regions; +\code{\link{resolution_profile}()}, whose regions are of that kind by +default, scores counts of those. + \strong{The model-aware criteria rank on the standardised deviate, not on |Moran's I|.} Both \eqn{E[I]} and \eqn{Var[I]} depend on the number of cells, so \eqn{|I|} falls as \code{k} grows whether or not the finer @@ -240,8 +318,10 @@ response should drive it. } \section{Post-selection inference}{ -When the selection reads the response (here, whenever both -\code{response_var} and \code{predictor_vars} are supplied), everything +When the selection reads the response (here, whenever a model-aware +criterion runs: both \code{response_var} and \code{predictor_vars} +supplied, or \code{"morans_i"} or \code{"combined"} asked for with a +response), everything estimated afterwards on the chosen cells is estimated on data that already influenced the choice, and its standard errors are post-selection ones: descriptive, not at nominal coverage (Gao, Bien and Witten 2022; Chen and @@ -342,12 +422,13 @@ candidate is used, and the output records that it came from here); \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} and \code{\link[=summarize_by_cell]{summarize_by_cell()}} for the steps that follow. -Other aggregation: -\code{\link{assign_features_to_polygons}()}, -\code{\link{kriging_adequacy}()}, -\code{\link{resolution_profile}()}, -\code{\link{select_resolution}()}, -\code{\link{summarize_by_cell}()}, -\code{\link{summary.resolution_profile}()} +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} } \concept{aggregation} diff --git a/man/ensure_projected.Rd b/man/ensure_projected.Rd index dbd58a59..0a0098c4 100644 --- a/man/ensure_projected.Rd +++ b/man/ensure_projected.Rd @@ -71,7 +71,7 @@ extent of the data. It is \strong{not} always UTM: (EPSG:326xx north of the equator, EPSG:327xx south). Distances and areas are close to true over a few degrees of longitude, which is the case this package is usually in. The centre is the centroid on the sphere, -computed with s2 whatever \code{\link[sf:s2]{sf::sf_use_s2()}} is set to, so data near a +computed with s2 whatever \code{\link[sf:sf_use_s2]{sf::sf_use_s2()}} is set to, so data near a zone edge get the same zone in every session.} \item{Wide extents}{Once the data reach well beyond the roughly 3 degrees a UTM zone is designed for, a single zone can distort distances by @@ -148,10 +148,10 @@ st_crs(ensure_projected(pts_ll, target_crs = 3035))$epsg # 3035 st_crs(ensure_projected(pts_ll, purpose = "area"))$proj4string } \seealso{ -Other spatial data preparation: -\code{\link{clip_target_for}()}, -\code{\link{coerce_to_points}()}, -\code{\link{harmonize_crs}()}, -\code{\link{prep_model_data}()} +Other spatial data preparation: +\code{\link[=clip_target_for]{clip_target_for()}}, +\code{\link[=coerce_to_points]{coerce_to_points()}}, +\code{\link[=harmonize_crs]{harmonize_crs()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{spatial data preparation} diff --git a/man/estimate_sac_range.Rd b/man/estimate_sac_range.Rd index b1ca8d38..2a01443d 100644 --- a/man/estimate_sac_range.Rd +++ b/man/estimate_sac_range.Rd @@ -14,7 +14,10 @@ estimate_sac_range( seed = 123L, detrend = c("ols", "reml"), reml_max_n = 400L, - keep_directional_fits = FALSE + keep_directional_fits = FALSE, + lags = c("adaptive", "equal"), + n_lags = 15L, + structure_alpha = 0.05 ) } \arguments{ @@ -26,7 +29,10 @@ would otherwise return a range in 3-D while every consumer of it works in 2-D map distance; and rows with empty or non-finite coordinates are dropped with a logged count.} -\item{response_var}{Character(1) name of the response column. For a +\item{response_var}{Character(1) name of the response column. Rows where +it is missing or infinite are left out before anything else is done, so +they neither take part in the choice of projection for lon/lat input +nor use up the \code{n_max} subsample. For a count or other response whose variance tracks its mean, see the section on non-Gaussian responses: the range is still estimated, but it is a less reliable number than for a Gaussian response.} @@ -38,21 +44,32 @@ once the covariates have done their work. How the trend is removed is set by \code{detrend}, and it matters: see "Detrending and the residual-variogram bias". Rows whose response or predictor is missing or infinite are left out of that fit, and so of the variogram, with a -logged count.} +logged count. When that leaves fewer than 30 rows the result is the +unclassed \code{NA} that says how many were left (see Value). One +case differs, as it always has: when no row at all has every predictor +(one is missing on every row) no trend can be fitted, and the variogram +is of the raw response, with an R warning and \code{detrended} set to +\code{FALSE}.} -\item{n_max}{Maximum number of points to subsample before fitting. -Variogram estimation is O(n²) so this keeps runtime bounded.} +\item{n_max}{Maximum number of points the variogram is computed on, at +least 30; \code{Inf} for no limit. Variogram estimation is O(n²) so +this keeps runtime bounded. A layer with more rows that carry a value +is cut to a seeded random subsample of this size, drawn after rows with +nothing to model have been left out and with the rows in a fixed order, +so the subsample does not depend on how the layer is sorted. The +counts are returned as the attributes \code{n_used}, \code{n_missing} +and \code{n_subsampled}.} \item{cutoff}{Fraction of the maximum inter-point distance to use as the -variogram lag cutoff. That distance is the farthest pair, found on the -convex hull, and not the bounding-box diagonal, which depends on how the -axes are oriented. Default 0.5.} +variogram lag cutoff, above 0 and at most 1. That distance is the +farthest pair, found on the convex hull, and not the bounding-box +diagonal, which depends on how the axes are oriented. Default 0.5.} \item{range_frac}{Positive numeric. A fitted range exceeding \code{range_frac * cutoff * max_dist} (that is, beyond the longest lag the empirical variogram was actually fitted over) is treated as unidentified and \code{NA_real_} is returned. -\code{gstat::fit.variogram()} yields a finite number even when the +A model fit yields a finite number even when the variogram never reaches a sill, and such a value extrapolates past the observed lags instead of measuring a long autocorrelation range. Passing it to \code{make_folds(auto_range = TRUE)} would collapse the block grid to @@ -63,49 +80,69 @@ blocks: at the defaults it is half the farthest-pair distance, about half the width of the bounding box in one direction or the other. An accepted range between the two leaves \code{make_folds(auto_range = TRUE)} room for a single block of that -size (see its \code{auto_range} argument for what it does then). On a -1000 m square with an exponential field of effective range 570 (n = 300), -9 of 30 draws were accepted in that band. Lowering \code{range_frac} to fit the +size (see its \code{auto_range} argument for what it does then). +Lowering \code{range_frac} to fit the grid would turn those estimates into \code{NA} and the blocks into geometric ones smaller than the range.} \item{seed}{RNG seed for the \code{n_max} subsample, restored afterwards so the caller's random stream is untouched. Default \code{123L}: the subsample is an internal approximation and no part of the answer, and -leaving it unseeded made the returned range differ between runs on -identical input (19531, 19589, 19605 on three calls) and silently advanced -the caller's RNG. Pass \code{NULL} for the old unseeded behaviour, or a +leaving it unseeded would make the returned range differ between runs on +identical input and silently advance the caller's RNG. Pass \code{NULL} +for an unseeded subsample, or a different number to check how sensitive the estimate is to the subsample. -Ignored when \code{nrow(points_sf) <= n_max}, where nothing is sampled. -The \code{reml_max_n} subsample uses the same seed.} +Ignored when no more than \code{n_max} rows carry a value, where nothing +is sampled. The \code{reml_max_n} subsample uses the same seed, and so +does the draw of one row a location that \code{detrend = "reml"} makes +on a layer with repeat visits.} \item{detrend}{How the trend on \code{predictor_vars} is removed; ignored when there are none. \code{"ols"} (default) fits it by ordinary -least squares and fits the variogram to the residuals. This is the -long-standing behaviour, which underestimates the range (see the section +least squares and fits the variogram to the residuals, which +underestimates the range (see the section below). \code{"reml"} fits the trend and an exponential-plus-nugget covariance together by residual maximum likelihood with \code{nlme::gls()}, returns the REML range, and attaches the empirical variogram of the REML residuals for inspection. It needs \pkg{nlme}, -costs \eqn{O(n^3)} (about 2 s at 300 points, 12 s at 500, 45 s at 800), -and so runs on at most \code{reml_max_n} points; when it does not -converge the \code{"ols"} path runs instead with an R warning saying so.} +costs \eqn{O(n^3)}, and so runs on at most \code{reml_max_n} points; +when it does not converge the \code{"ols"} path runs instead with an R +warning saying so. The start of the fit is chosen from the profile +REML likelihood on a grid of ranges and nugget proportions, and when +more than one start is fitted the fit with the largest log-likelihood +is kept.} \item{reml_max_n}{Positive integer, at least 30. With \code{detrend = "reml"}, the trend and covariance are fitted on a seeded random subsample -of this many points when the layer has more (exact duplicate locations -are dropped first); the fitted trend is then removed from every point. -Default 400. Raise it for a better-determined fit at the cost above.} +of this many points when the layer has more; the fitted trend is then +removed from every point. The fit takes one row a location: where a +location has several rows (repeat visits), one of them is drawn at +random under \code{seed}, so that the nugget fitted is the variance +between visits and not that of their minimum or of their mean. +Default 400. Raise it for a better-determined fit at a cubic cost.} -\item{keep_directional_fits}{Logical. Attach each direction's empirical +\item{keep_directional_fits}{\code{TRUE} or \code{FALSE}. Attach each +direction's empirical variogram and fitted model as \code{directional_fits}? Defaults to -\code{FALSE}: the four variograms are most of the object's size (42.1 KB -of 59.3 KB at \eqn{n = 400}, and the difference between a 52.4 KB and a -94.6 KB \code{make_folds(auto_range = TRUE)} result), while the numbers +\code{FALSE}: the four variograms are most of the object's size, while +the numbers read from them (\code{directional}, \code{directional_fitted}, \code{directional_status}, \code{anisotropy}) are attached either way, and \code{plot()} draws the effective variogram from its own attribute. Set \code{TRUE} to inspect the directional curves.} + +\item{lags}{How the lags are binned: \code{"adaptive"} (default) or +\code{"equal"}; see "The lags" above.} + +\item{n_lags}{A whole number from 5 to 100, default 15. With +\code{lags = "equal"}, the number of bins. With +\code{lags = "adaptive"}, the most bins spaced geometrically past the +first; fewer are used when that many would hold under 30 pairs each.} + +\item{structure_alpha}{The level of the test for spatial structure, above +0 and at most 1; default 0.05. A layer whose adjusted p-value is not +below it gets no range. \code{1} switches the refusal off; the test +is still computed and attached.} } \value{ A single number, of class \code{sac_range} in the first two of the @@ -116,13 +153,15 @@ behave as an ordinary number. The shapes carry different attributes: with the fit attached as attributes \code{directional} (the 0°, 45°, 90° and 135° ranges, named by azimuth; \code{NA} where that direction's fit was unusable), \code{anisotropy} (largest -over smallest), \code{anisotropy_used} (logical: \code{TRUE} only when -the all-pairs fit was singular or did not converge and the -directional maximum stands in for it), \code{directional_status} +over smallest), \code{anisotropy_used} (always \code{FALSE}: the +all-pairs fit is the estimate; kept for code that reads it), +\code{directional_status} (per azimuth, why a direction is \code{NA} in \code{directional}: \code{"ok"}, \code{"over_cutoff"} (its range ran past the largest lag fitted), \code{"not_converged"} -or \code{"no_fit"}), \code{directional_fitted} (the range each +(its fit has no minimum inside the ranges searched) +or \code{"no_fit"} (a flat variogram, or too few bins)), +\code{directional_fitted} (the range each direction's fit reported whether or not it was usable, so a refused directional range stays recoverable) and \code{directional_fits} (a list by azimuth of each direction's empirical \code{variogram} and @@ -135,91 +174,121 @@ warns and falls back to the raw response with this set to \code{FALSE}), \code{detrend_method} (\code{"ols"} or \code{"reml"} when detrended, \code{NA} otherwise), \code{reml} (with \code{detrend = "reml"}: a list with \code{n_used}, -\code{subsampled}, \code{nugget_prop} and \code{sigma2} from the -REML fit; \code{NULL} otherwise), +\code{subsampled}, \code{nugget_prop}, \code{sigma2}, +\code{logLik} (the REML log-likelihood of the fit kept), +\code{logLik_gain} (its gain over the same trend with independent +errors) and \code{n_fits} (the starts fitted); \code{NULL} +otherwise), \code{crs} (the projected CRS the variogram was fitted in: the unit of the range), \code{max_dist}, -\code{cutoff_dist}, \code{variogram} (the empirical variogram), -\code{variogram_model} (the fitted \code{gstat} model, or with -\code{detrend = "reml"} a \code{gstat} model built from the REML -parameters) and \code{nugget} (that model's nugget variance; see -\code{\link{sac_nugget}}), so the fit can be inspected and need not +\code{cutoff_dist}, \code{variogram} (the empirical variogram, in +the units of the response's variance), +\code{variogram_model} (the fitted model, in \pkg{gstat}'s layout, +or with \code{detrend = "reml"} one built from the REML +parameters), \code{nugget} (that model's nugget variance; see +\code{\link{sac_nugget}}), \code{nugget_at_bound} (\code{TRUE} when +the nugget is at its lower bound, within 1e-4 of the sill, and so +is not an estimate), \code{first_lag} (the mean separation in the +first bin: the shortest lag resolved, from which the nugget is +extrapolated), \code{bins_below_range} (how many bins lie inside +the fitted range; with fewer than three the split between nugget +and structure rests on very little), +\code{short_lag_semivariance}, \code{short_lag_pairs} and +\code{short_lag_dist} (the semivariance of nearest-neighbour pairs +of locations with no model, their number and their median +separation: an upper bound on the nugget), +\code{zero_lag_semivariance} and \code{zero_lag_pairs} (the +semivariance of the pairs of rows that share a location, which is +the variance between visits to one place and a lower bound on the +nugget, and their number; \code{NA} and 0 when no location has two +rows), \code{nugget_floor} (the value the fitted nugget was not let +under: \code{zero_lag_semivariance} when the rows outnumber the +locations by 30 or more, else 0, and always 0 with +\code{detrend = "reml"}), \code{structure_p}, +\code{morans_i} and +\code{structure_test} (the adjusted p-value of the test for +spatial structure, Moran's I on the 8 nearest neighbours, and the +statistic, z and p for each neighbourhood size), +\code{structures} and \code{short_range} (how many structures the +model has besides the nugget, and the effective range of the short +one when there are two, \code{NA} otherwise), \code{lags}, +\code{lag_boundaries} and \code{lag_fallback} (the binning behind +the result, its upper bin edges, and \code{TRUE} when adaptive lags +were asked for and the equal-lag result is returned; see "The +lags"), and +\code{n_used}, \code{n_missing} and \code{n_subsampled} (the points +the variogram was computed on, the rows left out for a missing +response or predictor, and the rows left out by the \code{n_max} +subsample), so the fit can be inspected and need not be taken on trust.} -\item{Rejected range}{\code{NA_real_} when a range was fitted but is -not identified: it exceeds \code{range_frac * cutoff * max_dist} (see -\code{range_frac}), which applies to the all-pairs fit even when some -directions reached a sill; or too few pairs of points lie inside -it to identify it, because it is shorter than the shortest lag the -empirical variogram resolves (the mean separation in its first -bin) or, with \code{detrend = "reml"}, than the distance within +\item{Rejected range}{\code{NA_real_} when no range is identified. +It is classed \code{sac_range} as well, so it prints as \code{NA} +without dumping its attributes, and it carries every attribute of +a success (the evidence for the rejection), plus +\code{rejected_range} (the value that was refused, \code{NA} when +none was fitted) and \code{rejected_reason}, one of: +\itemize{ +\item \code{"no spatial structure detected at the + nearest-neighbour scale"}: the test above. The model attached +is a pure nugget at the variance of the modelled variable, and +nothing fitted is handed on. +\item \code{"the empirical variogram is flat: no spatial + structure at the lags resolved"}: no model with a range fits +the variogram better than a constant. The model attached is +that constant, a pure nugget. +\item \code{"empirical variogram decreases with distance"}: the +semivariance falls over the shorter lags (a net fall of more +than 15 percent of the mean semivariance there, weighted by +pairs), which is the shape of a periodic, hole-effect +structure or of a variance that differs between a dense +cluster and the rest of the layer. Sampling noise in the +short-lag bins of a small sample can make that fall too. +\item \code{"fitted range exceeds the largest lag fitted"}: the +range is past \code{range_frac * cutoff * max_dist} (see +\code{range_frac}). An unremoved trend ends here when the +variogram rises past the fitted lags; a milder trend only +lengthens the fitted range and passes, which is what +\code{predictor_vars} is for. +\item \code{"fitted range is below the shortest lag fitted"}: +too few pairs of points lie inside the range to identify it, +because it is shorter than the shortest lag the +empirical variogram resolves (\code{first_lag}) or, with +\code{detrend = "reml"}, than the distance within which 30 pairs of the points the REML fit used lie, when that is shorter (the REML range is fitted to the point pairs, not to the -bins). A structure that short cannot be told from a nugget, and -the bound is about identification, not a test for spatial -structure (see above). Or the -model did not converge; or the empirical -variogram \emph{decreases} with distance over its shorter lags (a -net fall of more than 15 percent of the mean semivariance there, -weighted by pairs), which is the shape of a periodic, hole-effect -structure or of a variance that differs between a dense cluster and -the rest of the layer. Sampling noise in the short-lag bins of a -small sample can make that fall too: on exponential fields it -refused 7--9 of 60 draws at n = 30, 3--6 at n = 50 and 0--1 at -n = 100 (effective range 300 on a 1000 m square), and 15--16 of 60 -at n = 30 with a range of 150. An unremoved trend makes the -variogram rise instead; when it rises past the fitted lags the first -test catches it, but a milder trend only lengthens the fitted range -and passes, which is what \code{predictor_vars} is for. Last, the -fitted range can be non-positive. It is classed \code{sac_range} as -well, so it prints as \code{NA} without dumping its -attributes, and it carries \code{max_dist}, \code{cutoff_dist}, -\code{variogram}, \code{variogram_model} and \code{nugget} (the -evidence for the rejection), plus \code{rejected_range} (the value -that was refused), \code{rejected_reason} (one of -\code{"fitted range exceeds the largest lag fitted"}, -\code{"fitted range is below the shortest lag fitted"}, -\code{"variogram model did not converge"}, -\code{"empirical variogram decreases with distance"}, -\code{"fitted range is non-positive or non-finite"}, -\code{"no variogram model could be fitted (singular fits)"}), \code{crs} -(so the units the rejected number was in stay recoverable, which is -what \code{plot()} labels its axis from), -\code{detrend_method}, \code{reml} (as on success) and, for -\code{"fitted range is below the shortest lag fitted"}, -\code{range_floor} (the distance the refused range fell short of). -The reason names one ground for the refusal: a falling variogram -first, then a range past the largest lag, and the fit not having -converged only when neither holds. A fit that did not converge is -therefore most often recorded as past the largest lag, and the count -of \code{"variogram model did not converge"} understates how many -did not. The model itself says: -\code{attr(attr(range, "variogram_model"), "converged")} is -\code{FALSE} when no start of either model family converged -(\pkg{gstat} stopped at its iteration limit), whatever the reason, -and its nugget and sill are then where the optimiser halted, as its -range is. A model built from REML parameters carries no such -attribute. \code{\link{resolution_profile}()} reads it. -The refused range carries \code{directional}, -\code{anisotropy}, \code{anisotropy_used}, \code{directional_status}, -\code{directional_fitted} and, with -\code{keep_directional_fits = TRUE}, \code{directional_fits} as well: -the directional sweep runs whatever becomes of the all-pairs fit, and -its per-azimuth outcome is what says whether any direction reached -a sill the pooled variogram did not, or whether every direction ran -past the fitted lags alike. The same shape, with -\code{rejected_range = NA}, \code{variogram_model = NULL} and -\code{nugget = NA}, is returned when no variogram model could be -fitted at all (both the exponential and the spherical fit singular, -which a flat, nugget-only variogram can produce, though on white -noise it was the outcome in only 1 of 30 draws: see above); -\code{rejected_reason} says so and the empirical variogram is still -attached.} +bins). A structure that short cannot be told from a nugget. +\code{range_floor} holds the distance the refused range fell +short of. +\item \code{"fitted range is non-positive or non-finite"}. +\item \code{"no variogram model could be fitted (singular + fits)"}: fewer than three lag bins hold point pairs. +\code{variogram_model} is \code{NULL} and \code{nugget} is +\code{NA}. +} +The reason names one ground for the refusal, in the order above. +\code{attr(attr(range, "variogram_model"), "converged")} says one +thing more about the model: it is \code{FALSE} when the +least-squares criterion is still falling at an edge of the ranges +searched (a variogram with no sill inside four cutoffs), and the +nugget and sill of such a model are that edge and not fitted +values. For a model with two structures the flag is that of the +equal-lag fit the long range came from: when that fit has no +minimum, the long structure's range and partial sill are the edge +of its search and the flag is \code{FALSE}, although the nugget +and the short structure were fitted at the adaptive lags. A model +built from REML parameters carries no such +attribute. \code{\link{resolution_profile}()} reads it, and takes +no nugget from a model marked \code{FALSE}. Results +stored by earlier versions can carry +\code{"variogram model did not converge"} as their reason and +\code{anisotropy_used = TRUE}; neither is produced any more.} \item{No fit}{An unclassed \code{NA_real_} when estimation could not be attempted at all, whose one attribute, \code{rejected_reason}, says why: \code{"package 'gstat', which the variogram needs, is not installed"}, \code{" points, fewer than the 30 a variogram range is estimated from"}, \code{" point(s) with a finite value to - model, fewer than the 30 a variogram range is estimated from"}, + model, fewer than the 30 a variogram range is estimated from"} +(the count is of the whole layer's rows with a value), \code{"the response is constant"}, \code{"the residuals on predictor_vars are constant: the predictors explain the response exactly"} or \code{"the points have no extent (the largest distance @@ -233,43 +302,142 @@ Attributes and the class do not affect \code{is.na()} or way it always did. } \description{ -Fits exponential (or spherical) variogram models and returns the -\emph{effective range}: for the exponential model, three times the fitted -range parameter, which is where the semivariance reaches ~95 \% of the -sill; for the spherical model (fitted only when the exponential fit is -singular or does not converge) the fitted range itself, which is where the -spherical semivariance reaches its sill exactly. Both are the distance -beyond which two observations are (near) uncorrelated, which is what a -block or a buffer has to exceed. +Fits an exponential variogram model with a nugget and returns the +\emph{effective range}: three times the fitted range parameter, which is +where the semivariance reaches about 95 percent of the sill. It is the +distance beyond which two observations are (near) uncorrelated, which is +what a block or a buffer has to exceed. } \details{ -The exponential model is kept whenever it converges, without comparing it -with the spherical fit, and on fields smoother than exponential that makes -the range long. Measured on simulated fields (n = 300 on a 1000 m square, -30 draws each): about 1.8--2.1 times the practical range of a Gaussian -covariance, and 1.3--1.4 times the range of a spherical one, while an -exponential field came back at 0.97 of its effective range. The error is -on the safe side (blocks too large, cross-validation pessimistic), and it -is kept on purpose: choosing the family by the smaller weighted sum of -squares corrects the spherical case but sends exponential fields low, to -about 0.82 of the truth, which is the direction that leaks. +The result is a function of the data alone. The same layer gives the +same answer whatever the unit of the response or of the coordinates and +whatever the order of its rows, and a change in the last bits of the +values changes the answer by about as much. Three things make it so. +The rows are sorted by their coordinates as supplied, then by the +response and the predictors, before anything else, so the projection +chosen for lon/lat input, the \code{n_max} subsample and the pair sums +do not depend on their order. (Rows that share a location are therefore +in the order of their values, and no step treats the first of them as +special.) The variogram is computed on the standardised variable, and a +response is called constant only when its standard deviation is under +1e-12 of its largest absolute value, which no change of unit alters. +And the model is fitted without iteration: the criterion is \pkg{gstat}'s weighted least +squares (weights \eqn{N / h^2}) on lags divided by the cutoff; for each +trial range the nugget and the partial sill are solved exactly, with both +kept at or above zero; and the range is found by a search over a +logarithmic grid from a quarter of the first lag to four cutoffs, refined +in one dimension. There is no start value, no iteration limit and no +fit that fails to converge. + +Only the exponential family is fitted. On fields smoother than +exponential that makes the range long, which is the safe side (blocks too +large, cross-validation pessimistic). Choosing the family by the smaller +weighted sum of squares would correct a spherical field but send +exponential fields low, the direction that leaks. + +\strong{Spatial structure is tested first.} A variogram model can be +fitted to anything, and on a layer with no structure the fit returns a +finite range for a large share of draws. So Moran's I of the modelled +variable is computed on its 2, 4, 8 and 16 nearest neighbours, each +standardised with the moments that fit the variable (those of regression +residuals when \code{predictor_vars} are given), and the smallest +one-sided p-value is multiplied by four. When that adjusted p-value is +not below \code{structure_alpha}, the result is \code{NA} with +\code{rejected_reason} \code{"no spatial structure detected at the +nearest-neighbour scale"}, a pure-nugget model and no fitted range. The +test uses no random numbers. \code{structure_p}, \code{morans_i} and +\code{structure_test} are attached to every classed result. Measured on +a 1000 m square with 300 points, the test refuses 388 of 400 white-noise +layers and 8 get a finite range, against 196 with the test off. +Its power is limited where few neighbours lie inside the range. With a +nugget of a fifth of the sill it finds structure in 88 percent of fields +of effective range 60 on 300 points, and in 21 percent at range 30, which +is about the spacing of those points. A short range on a sparse layer +can therefore be refused; \code{structure_alpha = 1} switches the +refusal off. Rows that share a location (repeat visits) are one place +and not each other's neighbours, so on such a layer the test is made on +the means of the locations: what it asks is whether locations near each +other are alike, which a location's own effect, however large, does not +answer. With very unequal numbers of visits the p-value is approximate. + +\strong{The lags.} With \code{lags = "adaptive"} (the default) the first +bin runs from zero to the distance within which the closest +\code{max(50, n / 4)} pairs of distinct locations lie, and up to +\code{n_lags} further bins are spaced geometrically from there to the +cutoff; a bin holding fewer than 30 pairs is merged with the next. The +short lags are then resolved at the spacing of the points, which is what +the nugget and a short range are read from. With \code{lags = "equal"} +there are \code{n_lags} bins of equal width out to the cutoff, as +\pkg{gstat} bins by default; each is \code{cutoff * max_dist / n_lags} +wide, a structure shorter than the first of them is invisible and is +counted as nugget, and the range fitted is that of whatever longer +structure the layer has. Below about a hundred points neither binning +resolves much and the adaptive bins bring no gain. + +Two rows at one location are a pair at zero separation, and are in no +bin, whichever the binning: the variogram and the model describe positive +separations. Their semivariance, the variance between visits to a +location, is returned on its own as \code{zero_lag_semivariance}, and +the nugget fitted to the variogram is not let under it when the layer has +30 or more rows beyond one a location to estimate it from (a model from +\code{detrend = "reml"} takes no such floor); see +\code{\link{sac_nugget}}. + +The adaptive lags put little weight on the long ones, and a weak, long +structure under much noise can be clear at equal lags while the adaptive +fit runs past the largest lag. So when the adaptive range is refused as +past the fitted lags and the equal-lag fit has a range it would itself +return, the result is the equal-lag one, whole, exactly as +\code{lags = "equal"} gives it, with \code{lags} saying \code{"equal"} +and \code{lag_fallback} set to \code{TRUE}. Its nugget is then the +equal-lag nugget. No other refusal falls back. + +\strong{Structure at two scales.} One structure fitted to lags that +resolve the spacing of the points follows the shortest structure of the +layer. A layer can have a weaker structure several times longer as well, +and blocks sized from the short one would leave the long one across +folds. So with \code{lags = "adaptive"} the equal-lag fit is made too, +and when its range is at least twice the adaptive one, a model with a +nugget and both structures, at those two ranges, is fitted to the +adaptive variogram. That model is returned (\code{structures} is 2 and +\code{short_range} holds the range of the short structure) and the range +is the long one, unless the long structure carries under 3 percent of +the model's semivariance at the largest lag: then the lags that resolve +the layer give the equal-lag range nothing, and the single structure +stands. The bar is low because the two mistakes are not alike. A long +structure that is missed sizes blocks too small, which leaks. One that +is believed in error returns the equal-lag range, which is too long and +makes a validation pessimistic, and \code{short_range} still holds the +short one. When the equal-lag range is one that \code{lags = "equal"} +would itself refuse (past the fitted lags, as under an unremoved trend), +the model with it is refused as well, the answer is taken away and not +lengthened, and the long structure has to carry 10 percent. + +Measured on a clustered layer of 1200 points over a 1000 m square, 30 +draws each. With structures of range 20 and 200 both are kept in 20 +draws, and the range returned is under half the equal-lag one in 1; with +40 and 400, in 18 and 1; with 30 and 300, in 21 and 0; with 15 and 450, +in 28 and 1. With one structure of range 40 a second is kept in 4, and +the range is within a factor 2 of the truth in 27 draws (19 with equal +lags); with one of range 30, in 7 and 25 (14). The nugget comes from the +adaptive lags either way: where it is 0.3, the median is 0.32 to 0.35, +and 0.49 to 0.65 with equal lags. A long structure whose equal-lag +range is under twice the adaptive one is not separated: the range is +then that of the single fit, which lies between the two. The estimate is the \strong{omnidirectional} (all-pairs) fit. Directional variograms are fitted as well, at 0° (N–S), 45°, 90° (E–W) and 135° azimuths with a ±22.5° tolerance. Those four windows tile all 180 distinct azimuths exactly once, and their ranges are returned in the \code{directional} attribute, with their largest-over-smallest ratio in -\code{anisotropy}. They are a diagnostic, not the answer, for two reasons. -Each direction sees about a quarter of the point pairs, and the maximum of -four quarter-sample fits is biased upward: on simulated \emph{isotropic} -fields it came in about 40\% above the truth, and no hurdle placed in -front of it (all four directions fitted, ratio above 1.5, maximum above -1.5× the all-pairs fit) kept it out. One isotropic field rotated in 10° -steps "established" anisotropy in 14 of 18 orientations. And the windows +\code{anisotropy}. They are a diagnostic and never the answer, for two +reasons. Each direction sees about a quarter of the point pairs, and the +maximum of four quarter-sample fits is biased upward. And the windows are fixed to the coordinate axes, so any answer built from them changes -when the layer is rotated, which a property of the field must not do. The -all-pairs fit is the best-powered estimate available and is invariant to -rotation. +when the layer is rotated, which a property of the field must not do. +The all-pairs fit is the best-powered estimate available and is invariant +to rotation. When it identifies no range, no range is returned: the +largest directional range does not stand in for it. Where a field is \emph{known} to be anisotropic, blocks must be at least as large as the longest autocorrelation range to avoid leakage, and the @@ -285,59 +453,19 @@ has no identified range at all, and a longer \code{cutoff} or 1.5 is written to the package log at INFO level with that advice, which reaches the session log file but not the console (the ratio passes 1.5 on most isotropic fields too); \code{print()} shows the directional ranges -and the ratio, and \code{attr(range, "anisotropy")} holds it. Only when -the omnidirectional fit is singular or did not converge is the directional -maximum returned in its place, and \code{anisotropy_used} is \code{TRUE} -in that case alone. An omnidirectional fit that converged to a range past -the fitted lags is refused (see the Value section) whatever the directions -found: the directions that reached a sill are the shorter ones, so their -maximum is a lower bound, not an estimate. - -A direction whose fit fails, does not converge, or reports a range beyond -the longest fitted lag is excluded and recorded as \code{NA} in the +and the ratio, and \code{attr(range, "anisotropy")} holds it. + +A direction whose variogram is flat or has too few bins, whose range runs +beyond the longest fitted lag, or whose fit has no minimum inside the +ranges searched is excluded and recorded as \code{NA} in the \code{directional} attribute. -Every variogram model is fitted \strong{with a nugget}. A nugget-free model -forces the curve through the origin, and on any real measurement (which has -one) \pkg{gstat}'s default N/h² weights buy that constraint by collapsing -the range: with a 50\% nugget the fitted range came back at about 0.45 of the -truth, so \code{make_folds(auto_range = TRUE)} built blocks less than half -the correlation length it reported. - -The lags are binned the way \pkg{gstat} bins them by default, 15 bins out -to the cutoff, each \code{cutoff * max_dist / 15} wide (about 47 m on a -1000 m square at the defaults). A range spanning only one or two bins is -resolved coarsely and comes out long: exponential fields with an effective -range of 60 m (n = 300 on a 1000 m square, 30 draws) returned a median of -89--102 m, where the same fields binned over a 200 m cutoff gave 65--68, -and at a range of 300 m there was no bias. A range shorter than the -first bin cannot be resolved at all and can come back several times too -long: an effective range of 24 m (n = 1500 on a 1000 m square, 8 draws) -returned 93--479 m, five of them as the directional maximum, against -19--32 m at \code{cutoff = 0.1}; the first bin's semivariance was 92--99 -percent of the fitted sill in all eight. So whenever the empirical -variogram is already at its sill in the first one or two bins -(\code{plot()} the result), run it again with a smaller \code{cutoff}, -whatever range was fitted. - -Nothing tests whether the layer has spatial structure at all. On white -noise (n = 300 on a 1000 m square, 30 draws) the estimate was a finite, -spurious range (57--533 m) in 8 draws and a refusal in the rest, mostly -as past the fitted lags or not converged, and only once as no model -fitted; with \code{detrend = "reml"} it was finite in 13 of 30 (21--453 -m), and 16 of the refusals were ranges of 0.18--12.5 m, too short for 30 -pairs of points to lie inside them. A -spurious range errs towards larger blocks, so the harm is mostly lost -training data, but a caller who needs to know whether there is any -structure should look at the variogram (\code{plot()} on the result) -rather than at whether the answer is \code{NA}. - -When the all-pairs fit is singular or did not converge and two or more -directions reached a sill, the directional maximum is returned in its -place (\code{anisotropy_used = TRUE}), and a log warning names the -directional ranges when their ratio exceeds 1.5. When the all-pairs -estimate is used and the directional ranges vary by more than 1.5, a log -note (INFO) names them instead. +The model is fitted \strong{with a nugget}. A nugget-free model forces +the curve through the origin, and on any real measurement (which has one) +the \eqn{N / h^2} weights buy that constraint by collapsing the range. +The fitted nugget can sit at its lower bound of zero; the result then +carries \code{nugget_at_bound = TRUE}, and \code{\link{sac_nugget}} says +what else is attached to judge a nugget by. The returned range is in the coordinate units of the (projected) data and can be passed directly to \code{make_folds(block_size = ...)} so that CV @@ -351,29 +479,18 @@ part of the long-wavelength spatial variation (Lark, Cullis and Welham 2006). Blocks sized from that range are then too small and a blocked validation is less conservative than it claims. How large the effect is depends on how smooth the trend terms are in space, and on how many there -are. Measured for this estimator on simulated exponential fields (n = -300, true effective range 300, nugget 0.2, 40--60 draws), as the median -ratio of the estimate from the trend-removed data to the estimate from -the true field: -\itemize{ -\item a white-noise covariate: OLS 1.00, REML 0.99 (no bias to speak of); -\item a spatially smooth covariate (a random field with range 300 or -1000): OLS 0.97, REML 0.95--0.98; -\item a linear trend in the coordinates: OLS 0.92, REML 1.04; -\item a quadratic trend in the coordinates (five terms): OLS 0.75, -REML 1.06. -} -So for ordinary covariates the OLS bias is a few percent, and for trend -surfaces in the coordinates it is large. Iterating between a GLS trend +are: for ordinary covariates it is a few percent, and for trend surfaces +in the coordinates it is large. Iterating between a GLS trend fit and a variogram refit (Neuman and Jacobson 1984) recovers only part of -it (0.80 in the quadratic case), because the variogram of GLS residuals +it, because the variogram of GLS residuals is biased too; REML does not fit a variogram to residuals at all, which is why \code{detrend = "reml"} returns its own range estimate. Its price is a single family (exponential with nugget), a cubic cost in \code{n}, and a somewhat wider sampling spread. The default stays \code{"ols"} so that -existing scripts return what they did; a script that detrends on smooth +existing scripts keep their method; a script that detrends on smooth or coordinate-based terms should pass \code{detrend = "reml"}, or size its -blocks with a margin. +blocks with a margin. Detrending removes a trend the predictors explain. +It does not make an unidentified range identified. } \section{Count and other non-Gaussian responses}{ @@ -394,7 +511,7 @@ part of the mean the covariates explain, but it does not fix the variance structure: the residuals of an OLS fit to a count still have a variance that tracks the fitted mean. The principled remedy is a variogram of Pearson residuals from a model in the right family, which this function -does not compute. Until it does, treat the range from a count response as no +does not compute. Treat the range from a count response as no more than an order of magnitude, size blocks conservatively from it, and prefer \code{\link{make_folds}(method = "nndm")}, which does not depend on a fitted range at all. @@ -417,7 +534,8 @@ if (requireNamespace("gstat", quietly = TRUE)) { # shown on its own, and every one of these is worth reading. print(r) # the effective range, in metres print(attr(r, "directional")) # the four directional ranges - print(attr(r, "variogram_model")) # the fitted gstat model behind it + print(attr(r, "variogram_model")) # the fitted model behind it + print(attr(r, "structure_p")) # the test for spatial structure # A field whose range the data cannot pin down: the variogram never # reaches a sill within the lags fitted, so the answer is NA with the @@ -426,10 +544,20 @@ if (requireNamespace("gstat", quietly = TRUE)) { r2 <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), response_var = "trend") print(r2) + attr(r2, "rejected_reason") attr(r2, "rejected_range") + + # White noise: no structure, so no range. + xy$noise <- rnorm(n) + r3 <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), + response_var = "noise") + attr(r3, "rejected_reason") } } \references{ +Cliff, A. D. and Ord, J. K. (1981). \emph{Spatial Processes: Models and +Applications}. Pion, London. + Lark, R. M., Cullis, B. R. and Welham, S. J. (2006). On spatial prediction of soil properties in the presence of a spatial trend: the empirical best linear unbiased predictor (E-BLUP) with REML. \emph{European Journal of diff --git a/man/evaluate_insample.Rd b/man/evaluate_insample.Rd index c0c5c5a1..33f4d90e 100644 --- a/man/evaluate_insample.Rd +++ b/man/evaluate_insample.Rd @@ -108,10 +108,10 @@ if (requireNamespace("ranger", quietly = TRUE)) { } } \seealso{ -Other model evaluation: -\code{\link{compare_models}()}, -\code{\link{compare_models_cv}()}, -\code{\link{model_metrics}()}, -\code{\link{residual_morans_i}()} +Other model evaluation: +\code{\link[=compare_models]{compare_models()}}, +\code{\link[=compare_models_cv]{compare_models_cv()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=residual_morans_i]{residual_morans_i()}} } \concept{model evaluation} diff --git a/man/figures/readme-resolution.png b/man/figures/readme-resolution.png index 2c458a03..75beef02 100644 Binary files a/man/figures/readme-resolution.png and b/man/figures/readme-resolution.png differ diff --git a/man/figures/readme-spatial-cv.png b/man/figures/readme-spatial-cv.png index 432ca7fc..7bed47e3 100644 Binary files a/man/figures/readme-spatial-cv.png and b/man/figures/readme-spatial-cv.png differ diff --git a/man/figures/readme-tessellations.png b/man/figures/readme-tessellations.png index 63fb2c76..20c8adb0 100644 Binary files a/man/figures/readme-tessellations.png and b/man/figures/readme-tessellations.png differ diff --git a/man/fit_bayesian_spatial_model.Rd b/man/fit_bayesian_spatial_model.Rd index 1102c489..79a08a60 100644 --- a/man/fit_bayesian_spatial_model.Rd +++ b/man/fit_bayesian_spatial_model.Rd @@ -25,6 +25,7 @@ fit_bayesian_spatial_model( check_convergence = TRUE, pointize = "auto", boundary = NULL, + gp_resolution = NULL, .already_prepped = FALSE ) } @@ -55,7 +56,15 @@ what each family supports, and the count example below.} \item{gp_k}{Positive integer giving the number of GP basis functions \emph{per dimension}, or NULL (default) to derive it from the length-scale/domain ratio. The fitted model carries -\code{gp_k^2} basis functions, not \code{gp_k} (see Details).} +\code{gp_k^2} basis functions, not \code{gp_k} (see Details). A value +above the derived one makes the basis finer, and the length-scale +prior's lower tail moves down to the length-scale that basis resolves, +because a finer basis under the default prior gains almost nothing. A +value below the derived one leaves the prior where it was, mostly below +what the basis resolves; that share is stored as +\code{$info$gp_adequacy$prior_mass_below}, logged when it passes 10 +percent and flagged by \code{print()}. To ask for a resolution in map +units, use \code{gp_resolution} and leave this \code{NULL}.} \item{gp_c}{Positive numeric boundary factor for the approximate GP, or NULL (default) to derive it alongside \code{gp_k}. The boundary must be @@ -75,8 +84,19 @@ original CRS by whatever ratio \code{sd(X)/sd(Y)} happens to take, because the coordinates are standardised per axis beforehand. See Details.} \item{prior}{Optional brms prior specification. When NULL and -\code{standardize_predictors = TRUE}, weakly informative -\code{normal(0, 5)} priors are set on regression coefficients. +\code{standardize_predictors = TRUE}, a weakly informative prior is set on +the regression coefficients, on the scale of the linear predictor: +\code{normal(0, 2.5 * sd(y))} under an identity link (gaussian, student, +skew-normal and mixtures of them), \code{normal(0, 2.5 * sd(log(y)))} for +the lognormal families, whose location is on the log scale, and the fixed +\code{normal(0, 5)} under any other link (log, logit and so on), where the +linear predictor has a scale of its own. \code{sd()} is taken over the +training rows. The result therefore does not depend on the units of the +response: a fixed \code{normal(0, 5)} under an identity link, which is +what earlier versions set, left a slope alone when income was in +thousands of dollars and shrank the same slope to nothing when it was in +dollars. The prior brms used is stored as \code{$info$b_prior} and shown +by \code{print()}. When \code{prior} is given, no slope prior is added. A data-informed GP length-scale prior is always appended automatically unless \code{prior} already contains an entry with \code{class = "lscale"}.} @@ -121,31 +141,83 @@ predictors, so \code{coef()} reports a slope per standard deviation of each predictor and an intercept at the predictor means, not the raw-unit values \code{stats::lm()} would give; see \code{\link{coef.bayesian_fit}}.} -\item{check_convergence}{Logical; after fitting, check for divergent -transitions, R-hat above 1.05 and an effective-sample-size ratio below -0.1. Each problem found is written to the log as a WARN line (shown on -the console unless \code{\link{spatialkit_quiet}()} is on), sets -\code{$info$convergence_ok} to \code{FALSE}, and is detailed in -\code{$info$convergence_diagnostics}; \code{print()} on the fit flags it. -The GP basis is also checked against the posterior length-scale (see -Details): a basis too coarse for it is logged as a WARN line, and the -share of draws it cannot resolve is recorded as -\code{$info$convergence_diagnostics$gp_lscale_below_resolution}, but it -does not change \code{convergence_ok} and \code{print()} does not flag -it. None of these are raised as R warnings by the fit itself; the -functions that score fits do raise one: \code{\link{cv_bayes}()} names -the folds whose sampler did not converge (and marks them in -\code{fold_metrics$convergence_ok}), and -\code{\link{compare_models}()} names such a model (column -\code{convergence_ok}). Under \pkg{rstan} the sampler raises its own -R-hat and ESS warnings; under \pkg{cmdstanr} nothing does, so read -\code{$info$convergence_ok}. \code{FALSE} skips -the checks and leaves \code{convergence_ok} \code{NA} (not checked). +\item{check_convergence}{Logical; after fitting, read the sampler's +diagnostics and set \code{$info$convergence_ok}. The verdict follows +Stan's own diagnostics, with these thresholds: +\itemize{ +\item any divergent transition after warmup; +\item bulk or tail effective sample size below 100 per chain for any +parameter (Vehtari et al. 2021; the rule \pkg{rstan} warns on). It +is an absolute count: a share of the draws, which earlier versions +used, asks for 100 in all at \code{chains = 2, iter = 1000}; +\item rank-normalised split R-hat, in two tiers. Above 1.05, the +value \pkg{rstan}'s own sampler warning uses, for any parameter. +Above 1.01, the value Vehtari et al. (2021) recommend, for a +parameter whose effective sample size is also below the count in +the previous item, or cannot be read; +\item E-BFMI below 0.3 in any chain (Betancourt 2016). +} +An R-hat between 1.01 and 1.05 on a parameter with enough effective +draws is a caution, not a failure: it is stored by name in +\code{$info$convergence_diagnostics$rhat_caution}, logged, and counted +by \code{print()}. The reason is the number of parameters. This model +has one weight per basis function, about 540 parameters at the usual +basis, and the largest of that many R-hat values sits near 1.01 in a +fit that has converged: four fits at the default four chains of 2,000 +iterations had largest values of 1.005, 1.009, 1.009 and 1.011, with +every effective sample size at least 1,086 against the 400 required. +Chains that have converged by construction (540 independent +parameters, four chains of 1,000 draws) had a largest value of 1.008 to +1.011 at an effective sample size near 1,300, and 130 to 160 values +above 1.01, none above 1.05, at an effective sample size near 450. +Vehtari et al. give 1.01 beside an effective sample size above 400, and +an R-hat of 1.01 is about what an effective sample size of 400 gives +(1.009 on average in the same chains), so the two are read together +here. + +Transitions that stop at \code{max_treedepth} are counted and logged but +do not change the verdict: Stan treats them as a cost, not as invalid +draws. A failed verdict sets \code{convergence_ok} to \code{FALSE}, +raises one R warning of class \code{spatialkit_convergence} naming each +failed check with its count and its first five parameters, and +\code{print()} flags it; \code{$info$convergence_diagnostics} holds every +value. The warning closes with the remedy for the checks that failed: a +higher \code{adapt_delta} for divergent transitions, which more +iterations do not remove, and more iterations for R-hat and effective +sample size. \code{\link{cv_bayes}()} marks such folds in +\code{fold_metrics$convergence_ok} and \code{\link{compare_models}()} +names such a model. A short run usually fails, on effective sample +size: two fits of two chains and 300 post-warmup draws each had two or +three parameters below 100 effective draws per chain, and 66 and 76 of +their 537 parameters above R-hat 1.01. + +The same step checks the GP basis against the posterior and the +residuals (see "What the basis resolves") and stores the result as +\code{$info$gp_adequacy}. The residuals need the fitted values, one +pass over the posterior that \code{fitted()} caches for later calls. +That check is about the approximation, not the sampler, so it does not +change \code{convergence_ok}; \code{print()} and \code{summary()} show +its status, and two of its states raise a warning of class +\code{spatialkit_gp_adequacy}. \code{FALSE} skips +all of these and leaves \code{convergence_ok} \code{NA} (not checked) +and the adequacy status \code{"not_checked"}. Default TRUE.} \item{pointize}{Strategy for non-point geometry coercion.} -\item{boundary}{Optional polygonal sf/sfc for CRS harmonization.} +\item{boundary}{Optional polygonal sf/sfc whose CRS the data are projected +to. It is not a clip: rows outside it are kept.} + +\item{gp_resolution}{The shortest effective range the basis should resolve, +as a single positive number in the units of the data's CRS (metres for a +UTM layer), or NULL (default) for the percentile rule described under +Details. \code{gp_k} is derived from it, and the length-scale prior's +lower tail moves with the basis. It can only refine: a value the default +basis already resolves leaves the default basis in place. It is an error +when the basis it needs exceeds the cap of 50 functions per dimension +(2,500 in all); the message gives the basis size needed and the shortest +range the cap reaches on this layout. Cost grows with +\code{gp_k^2}. Give \code{gp_resolution} or \code{gp_k}, not both.} \item{.already_prepped}{Logical (internal). If \code{TRUE}, skip the \code{prep_model_data()} call because the caller has already projected, @@ -161,6 +233,40 @@ Supports \code{predict()}, \code{fitted()}, \code{residuals()}, Model-specific metadata lives in \code{$info} (coords: the names of the scaled coordinate columns handed to \code{brms::gp()}; coord_scaling, predictor_scaling, gp_k, gp_c, gp_iso, gp_n_basis, gp_ell_min, +gp_resolution: the smallest effective range the basis resolves, as +\code{c(x, y)} in map units; gp_resolution_requested: the +\code{gp_resolution} argument, or \code{NULL}; +gp_prefit: the check made before sampling, a list with \code{status} +(\code{"ok"}; \code{"below_floor"}, the one that warns; +\code{"below_floor_no_autocorrelation"} and +\code{"below_floor_long_range"}, a range below the floor that the +short-lag or the floor-distance test did not bear out; +\code{"not_estimated"} or \code{"not_run"}), \code{range} (the +estimated range in map units), \code{floor}, \code{k_needed}, +\code{moran} and \code{moran_floor} (the two Moran's I tests, each with +\code{I}, \code{z} and a one-sided \code{p}), \code{reason} and +\code{unit}; +gp_adequacy: a list with \code{status} (see Details), \code{frac_below} +(the share of length-scale draws below \code{gp_ell_min}), +\code{identified} and \code{identified_by} (\code{"spatial_share"} or +\code{"length_scale"}, the rule that decided it; see Details), +\code{contraction} (one minus the ratio of posterior to prior variance, +per length-scale, negative when the posterior is the wider of the two) +and \code{prior_gap} (the largest gap between the posterior's and the +prior's distribution functions, per length-scale; both \code{NA} for a +length-scale prior this function did not set), \code{spatial_share} and +\code{sdgp} (2.5, +50 and 97.5 percent quantiles; the share only for a gaussian or lognormal +family), \code{effective_range} (the posterior effective range per axis +in map units, same quantiles), \code{residual_moran} (the test on the +residuals the status rests on: \code{I}, \code{z}, a one-sided \code{p} +and \code{k}, the number of neighbours; absent when it could not be +run, and \code{residual_untested} then says why), \code{resolution}, +\code{unit} and \code{prior_mass_below}; +b_prior: the slope prior brms used (\code{"(flat)"} for its default, +\code{NA} for a model with no slopes), and b_prior_source: where it came +from; predictor_levels: the levels each factor or character predictor +has in the training rows, which \code{predict()} holds new data to; gp_S: the pooled centred range \code{brms::gp(c = )} multiplies; gp_cmeans: the column means brms centred the scaled coordinates on; gp_xy_range: the training extrema of the scaled coordinates, which @@ -173,11 +279,17 @@ which is not necessarily the one this function requested (several entries, semicolon-separated, if brms resolved the axes differently); loo, looic, convergence_ok (\code{TRUE} or \code{FALSE}, and \code{NA} when nothing was checked, as under \code{check_convergence = FALSE}), -convergence_diagnostics: \code{n_divergent}, -\code{max_rhat}, \code{min_neff_ratio}, and \code{rhat_failed} / -\code{neff_failed}, the parameters that failed each check by name with -their values (empty when none failed), which is what makes a failed -check actionable; and n_dropped: the rows +convergence_diagnostics: \code{n_divergent}, \code{n_max_treedepth}, +\code{ebfmi} (per chain), \code{max_rhat}, \code{min_neff_ratio}, +\code{min_ess} (the smallest bulk or tail effective sample size) and +\code{ess_required} (100 per chain), and \code{rhat_failed} / +\code{neff_failed} / \code{ess_failed}, the parameters that failed each +check by name with their values (R-hat, ESS ratio and ESS; empty when +none failed), which is what makes a failed check actionable, +\code{rhat_caution}, the parameters whose R-hat is between 1.01 and 1.05 +with enough effective draws, which do not fail the verdict, plus +\code{gp_lscale_below_resolution} and \code{gp_adequacy}, the share and +status described under Details; and n_dropped: the rows \code{prep_model_data()} removed for missing or non-finite values or a bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}). The raw brmsfit is in \code{$engine}. @@ -186,13 +298,29 @@ The raw brmsfit is in \code{$engine}. Fits a regression whose residual spatial structure is modelled explicitly, as a Gaussian process over the coordinates, and so kept out of the errors. Two things follow, and they are the reasons to reach for this backend. First, -every quantity comes with a posterior, so predictions carry calibrated -intervals instead of point estimates. Score them with +every quantity comes with a posterior, so predictions carry intervals +instead of point estimates. Whether those intervals are calibrated is +something to measure, not assume: score them with \code{\link{cv_bayes}()}, which reports held-out interval coverage and CRPS. -Second, the fitted length-scale is itself an estimate of how far the spatial -dependence reaches, a number you can read and report. +Second, the spatial term is a smooth regional surface at a stated +resolution. The Gaussian process is fitted through a reduced-rank basis, +and that basis has a floor: an effective range below which it cannot +represent structure, reported in map units as \code{$info$gp_resolution} +and by \code{print()}. With the defaults the floor is 14 to 33 percent of +the extent along each axis (about 32 km on a uniform 100 km square, 155 km +east-west and 63 km north-south on the census tracts of North Carolina). +Structure shorter than the floor is counted as noise: the fitted range comes +out too long, the residual standard deviation too large, and the intervals +too narrow where the structure is. See "What the basis resolves" below. } \details{ +The fitted length-scale is an estimate of how far the spatial dependence +reaches only when its posterior sits clear of both that floor and its +prior. \code{$info$gp_adequacy} says whether it does, and when it does +\code{$info$gp_adequacy$effective_range} holds the posterior effective range +per axis in map units (the raw \code{lscale} draws are in per-axis +standardised units and are not a distance). + Choose it over \code{\link{fit_gwr_model}()} when you want one global relationship plus an explicit spatial random field, and uncertainty you can defend; choose GWR instead when the question is how a coefficient @@ -211,8 +339,9 @@ Both \code{gp_k} and \code{gp_c} are therefore chosen from the ratio of the estimated length-scale to the domain extent, following Riutort-Mayol et al. (2023): \code{gp_c} is set large enough to contain the upper length-scale bound, and \code{gp_k} large enough to resolve the lower -one. The derived value is typically 21-25 per dimension and is largely -independent of \code{n}. +one. The derived value depends on the layout, not on \code{n}: 23 on a +uniform square, 27 to 38 on the census tracts of Iowa, North Carolina and +Texas, and the cap of 50 on California's, whose tracts are clustered. The domain extent used is the one \code{brms::gp(c = )} itself multiplies: the full pooled range of the column-centred coordinates @@ -235,14 +364,160 @@ standardises the coordinates, and the length-scale prior, \code{gp_c} and the adequacy check below are all expressed in those standardised units, a second normalisation would leave every length-scale quantity in the wrong units. -After fitting, the posterior length-scale is compared against the smallest -scale the chosen basis can resolve -(\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); when -more than 10\% of the posterior mass falls below it a WARN line is logged -and the share is recorded as -\code{$info$convergence_diagnostics$gp_lscale_below_resolution}, which is -the signal that \code{gp_k} should be raised. This runs with the other -checks, so only under \code{check_convergence = TRUE}. +\strong{What the basis resolves.} +The smallest length-scale the chosen basis can resolve is +\code{1.75 * gp_c * S / gp_k}, stored in standardised units as +\code{$info$gp_ell_min}. As an effective range (the distance at which the +squared-exponential correlation has fallen to 5 percent, 2.45 length-scales) +and in map units it is \code{$info$gp_resolution}, one value per axis +because each coordinate is divided by its own standard deviation. The +floor is soft: the basis keeps 99 percent of a process's variance at the +floor, 69 percent at half of it and 41 percent at a third. The default +length-scale prior is what makes it bind, with 1 percent of its mass below +the floor and about one part in a hundred million below half of it. + +Three checks hold the basis against the data. +\enumerate{ +\item Before anything is compiled, the autocorrelation range of the +response (of its OLS residuals when there are predictors) is estimated +with \code{\link{estimate_sac_range}()} and compared with the coarser +axis's floor. That range is a variogram estimate and can be wrong in +both directions, so a range below the floor raises a warning only when +two other things agree with it. The same variable is autocorrelated +at short range (Moran's I over 4 nearest neighbours, one-sided, at 5 +percent): a variogram fitted to a response with no spatial structure +can still return a short range (in 3 of 60 white-noise draws; +\code{estimate_sac_range()} refuses most such layers itself). And it is +no longer autocorrelated at the floor's distance (Moran's I over the +pairs 0.75 to 1.25 floors apart is not both above 0.05, the +correlation that defines an effective range, and significant at 5 +percent): a variogram can also return a short range for a surface +that is smooth over long distances. The warning has class +\code{spatialkit_gp_resolution}, gives both numbers and the basis size +that would resolve the range, says that it is an estimate which the +check after sampling tests against the residuals of the fitted model, +and says when the basis size is past the +cap or past the number of rows, where kriging is the better tool if +the range is right. A short range the floor-distance test contradicts +is logged and shown by \code{print()} without a warning: it can still +mean short-range structure beside a longer one, which the basis counts +as noise. Nothing before sampling separates the two; the residuals +after it do (the third check). A range that cannot be +estimated is logged with the reason and shown by \code{print()}; the +result is in \code{$info$gp_prefit}. In 60 simulated draws each +(400 points on a 100 km square, floor 33 km) the warning was raised +for 59 fields with a range of 8 to 15 km; for 0 or 1 fields +that were squared-exponential with a range of 60 or 90 km, a sine or +a plane; for 2 of white noise; and for 5 exponential fields with a +60 km range. An exponential field has structure at every scale, and +a fit of one with a 50 km range had 62 percent of its length-scale +draws below the floor, so those 5 are not plainly wrong. +\item Also before sampling, the share of the length-scale prior below +the floor is computed (\code{$info$gp_adequacy$prior_mass_below}). A +derived basis keeps it near 0.01; a small \code{gp_k} does not (0.98 +at \code{gp_k = 6} where the derived value is 23), and a share above +0.10 is logged and flagged by \code{print()}. +\item After sampling, under \code{check_convergence = TRUE}, the +posterior and the residuals are read. The posterior says whether the +Gaussian process carries a share of the variance and where its +length-scale sits against the floor. It cannot say what the surface +left behind, so the residuals are tested for autocorrelation at short +range in every fit (Moran's I over 4 nearest neighbours, one-sided, +at 5 percent; \code{$info$gp_adequacy$residual_moran}). +\code{$info$gp_adequacy$status} is one of: +\describe{ +\item{\code{"ok"}}{The Gaussian process carries a share of the +variance, its length-scale is clear of the floor, and the +residuals show no autocorrelation at short range. A surface +smoother than the prior expects (a plane, a range longer than the +extent) is \code{"ok"}: its length-scale posterior sits on the +long side of the prior and is wider than it.} +\item{\code{"below_resolution"}}{The Gaussian process carries a +share of the variance and more than 10 percent of the +length-scale draws fall below the floor. The 10 percent trigger +is this package's operationalisation of the check Riutort-Mayol +et al. recommend, not a figure from the paper.} +\item{\code{"unresolved_short_range"}}{The residuals are +autocorrelated at short range: the signature of structure finer +than the basis, counted as noise. It is reached two ways, and +\code{$info$gp_adequacy$identified} says which. The Gaussian +process carries no variance that can be told from zero +(\code{FALSE}): all of the structure is below the floor. Or it +carries a share and its length-scale is clear of the floor +(\code{TRUE}): it fitted a surface, and finer structure sits +beside it, as with a regional trend plus short-range structure.} +\item{\code{"no_signal_above_floor"}}{The Gaussian process carries +no variance that can be told from zero, and the residuals show +nothing left over. A response with no spatial structure gives +this, so it is not a failure by itself.} +\item{\code{"not_checked"}}{\code{check_convergence = FALSE}.} +} +The second and third raise a warning of class +\code{spatialkit_gp_adequacy}; the fourth is logged. When the +residuals cannot be tested (an ordinal or categorical family has no +residual per row; a posterior that cannot be drawn), the status rests +on the posterior alone, a line is logged, the reason is in +\code{$info$gp_adequacy$residual_untested}, and \code{print()} keeps +its flag on a variogram range that was below the floor. + +\if{html}{\out{
}}\preformatted{The residual test rests on fits of points on a 100 km square whose +floor is 32 to 33 km. Sampled fits: ten of a response with a +component below the floor (a field with an 8 or 12 km range, alone or +beside a plane or a field with a 90 km range) had p of 5.3e-10 to +0.014, and five of the ten had a posterior that reads \code{"ok"}; +twelve of a response with none (planes, bowls, a sine, fields with +ranges of 45 to 200 km) had p of 0.66 to 0.97. At the posterior mode +of the same model, computed without sampling, the test was +significant in 0 of 160 fits of fields with ranges of 45 to 200 km +and in 3 of 120 fits of a plane, a bowl and a sine (one noise draw of +the 40, shared by the three, whose own Moran's I has p = 0.003); +and in 16 to 18 of 20 fits of each of four responses with an 8 km +field in them, where the length-scale at the mode was below the floor +in 0 or 1 of the 20. On a fit with nothing left over the test is +conservative, because the surface takes up part of the noise and +leaves the residuals slightly negatively autocorrelated (median I of +-0.03 to -0.07). It is not sharp just below the floor: a field with +a 20 km range was significant in 8 of 20 fits, and there it is the +length-scale draws that report it (\code{"below_resolution"}). An +exponential field has structure at every scale and can be reported +with a range above the floor (8 of 20 fits at 60 km). The 5 percent +level is the usual one and is not tuned; with many rows a small +leftover autocorrelation is significant, so read the size of I +beside its p. + +"No variance +that can be told from zero" is decided on the Gaussian process's share +of the variance, \code{sdgp^2 / (sdgp^2 + sigma^2)}: its 2.5 percent +quantile is under 0.01. On nine fits that quantile was 0.000 to 0.003 +for the three with nothing for the process to find and 0.17 to 0.94 +for the six with a surface; the threshold rests on those nine. It +does not mark off a response whose structure is all below the floor: +on five fits of a field with an 8 km range under a 33 km floor the +quantile was 0.000, 0.000, 0.001, 0.015 and 0.019, so two of the five +count as carrying a share, and it is the residual test that reports +them. The +share exists for a gaussian or lognormal family. For any other +family the length-scales decide instead: the process is not identified +when on every axis the posterior kept more than three quarters of its +prior's variance and the largest gap between its distribution function +and the prior's is under 0.30. That second rule has been checked on +the length-scale draws of the same nine gaussian fits, where it agrees +with the share on eight, and on no fit of another family. +\code{$info$gp_adequacy$identified_by} says which rule was used. The width of the length-scale posterior does not +decide by itself, because a posterior that moved to longer +length-scales is wider than its prior; and the share of draws below +the floor cannot detect an unidentified process, because a posterior +the data did not move puts 1 percent below the floor, the same as the +prior. +}\if{html}{\out{
}} + +} +A response whose range is below the floor needs a finer basis and a prior +that allows the shorter length-scale, both of which \code{gp_resolution} +sets, up to the cap. Past the cap this model is the wrong tool: resolving +a 30 km range on the North Carolina tracts would take 156 functions per +dimension, 24,336 in all for 2,672 points. Kriging has no such floor; see +\code{\link{kriging_adequacy}()} for cell means. \strong{Coordinate scaling and anisotropy.} Before fitting the GP, X and Y coordinates are each centred and divided by @@ -267,6 +542,36 @@ tensor grid either way, so the model carries \code{gp_k^2} basis functions regardless. The stored \code{$info$coord_scaling} list records the scaling strategy, and \code{$info$gp_iso} records which kernel was used. } +\section{Warnings}{ + +Every warning this function raises carries a condition class, so a caller +can catch or muffle exactly one of them by name: +\describe{ +\item{\code{spatialkit_rows_dropped}, +\code{spatialkit_constant_predictor}}{From +\code{\link{prep_model_data}()}: incomplete rows were dropped, with the +counts; a predictor takes one value in every row kept.} +\item{\code{spatialkit_gp_basis_size}}{Fewer than one row per ten basis +functions.} +\item{\code{spatialkit_gp_resolution}}{A variogram fitted before +compiling puts the response's range below what the basis resolves, and +the autocorrelation of the response agrees. An estimate; the check +after sampling tests it against the residuals of the fitted model.} +\item{\code{spatialkit_convergence}}{The sampler's diagnostics fail.} +\item{\code{spatialkit_gp_adequacy}}{The basis is too coarse for the +data: the posterior asks for a shorter length-scale than it resolves +(\code{"below_resolution"}), or the residuals are autocorrelated at +short range (\code{"unresolved_short_range"}).} +} +A response that takes a single value is an error, raised before anything +is compiled. The convergence warning carries the checks that failed as +\code{failed} (\code{"divergent"}, \code{"ebfmi"}, \code{"rhat"}, +\code{"ess"}). \code{\link{cv_bayes}()} fits once per fold; it collects +the last four classes from its folds and raises each once for the run, +naming the folds, and \code{\link{cv_spatial}()} does the same for a +\code{fit_fn} that calls this function. +} + \section{Non-Gaussian responses}{ Nothing in this function is Gaussian-specific except its default. A @@ -385,6 +690,14 @@ if (requireNamespace("brms", quietly = TRUE)) { } } \references{ +Betancourt, M. (2016). Diagnosing suboptimal cotangent disintegrations in +Hamiltonian Monte Carlo. arXiv:1604.00695. + +Vehtari, A., Gelman, A., Simpson, D., Carpenter, B. and Burkner, P.-C. +(2021). Rank-normalization, folding, and localization: an improved R-hat +for assessing convergence of MCMC (with discussion). \emph{Bayesian +Analysis} \strong{16}, 667--718. \doi{10.1214/20-BA1221} + Riutort-Mayol, G., Burkner, P.-C., Andersen, M. R., Solin, A. and Vehtari, A. (2023). Practical Hilbert space approximate Bayesian Gaussian processes for probabilistic programming. @@ -422,11 +735,11 @@ confounding in linear models. \emph{The American Statistician} \strong{76}, 159--167. \doi{10.1080/00031305.2021.1946149} } \seealso{ -Other model fitting: -\code{\link{fit_gwr_model}()}, -\code{\link{fit_rf_model}()}, -\code{\link{gp_lengthscale_bounds}()}, -\code{\link{new_spatial_fit}()}, -\code{\link{prep_model_data}()} +Other model fitting: +\code{\link[=fit_gwr_model]{fit_gwr_model()}}, +\code{\link[=fit_rf_model]{fit_rf_model()}}, +\code{\link[=gp_lengthscale_bounds]{gp_lengthscale_bounds()}}, +\code{\link[=new_spatial_fit]{new_spatial_fit()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{model fitting} diff --git a/man/fit_gwr_model.Rd b/man/fit_gwr_model.Rd index 7187108d..7b1a6648 100644 --- a/man/fit_gwr_model.Rd +++ b/man/fit_gwr_model.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/model-gwr.R \name{fit_gwr_model} \alias{fit_gwr_model} -\title{Fit a Geographically Weighted Regression (GWR) via GWmodel} +\title{Fit a Geographically Weighted Regression (GWR)} \usage{ fit_gwr_model( data_sf, @@ -20,7 +20,12 @@ fit_gwr_model( \item{response_var}{Response column name.} \item{predictor_vars}{Predictor column names (numeric columns; a name given -twice counts once).} +twice counts once). \code{character(0)} fits the model with a local +intercept alone: the fitted value at a location is the kernel-weighted +mean of the response around it. That is the baseline a GWR with +predictors has to beat, since any GWR beats a global mean through its +local intercept, and \code{\link{select_features_forward}()} fits it as +the null model of a GWR sweep.} \item{adaptive}{Logical; use adaptive bandwidth. Default TRUE. When TRUE, bandwidth is an integer number of nearest neighbours. When FALSE, @@ -33,12 +38,12 @@ projects geographic input before the bandwidth is used, so 0.2 supplied for lon/lat data is 0.2 metres, not 0.2 degrees. Read the CRS off \code{sf::st_crs(fit$data_sf)}, or pass \code{target_crs} to \code{\link{ensure_projected}} beforehand to fix the units yourself. -If NULL (default), bandwidth is selected automatically via -\code{GWmodel::bw.gwr()}. With \code{adaptive = FALSE}, a bandwidth -smaller than a ten-thousandth of the data's extent raises a warning naming -the extent and the CRS the fit runs in: every local window is then likely -to be empty, which used to produce a fit whose coefficients were all -\code{NaN} with nothing raised anywhere. With \code{adaptive = TRUE} +If NULL (default), the bandwidth with the lowest AICc is searched for +(the lowest leave-one-location-out error when observations share a +location); see \strong{Bandwidth selection}. With \code{adaptive = FALSE}, a +bandwidth smaller than a ten-thousandth of the data's extent raises a +warning naming the extent and the CRS the fit runs in: every local +window then holds its own observation alone. With \code{adaptive = TRUE} the count is rounded, and one too small for the model is raised, with a warning, to the smallest that gives every local regression more points of non-zero weight than parameters: the number of predictors plus 3 for @@ -48,9 +53,7 @@ several neighbours tie at the kernel's edge (a regular grid), which leaves a window fewer weighted points; then use a larger bandwidth. A count above the number of observations is capped at it, with a warning (a distance meant for -\code{adaptive = FALSE}, most often). \code{bw.gwr()} searches adaptive -bandwidths from 20 neighbours up, so below 20 observations its choice is -capped the same way, with a warning, and is not an optimised bandwidth.} +\code{adaptive = FALSE}, most often).} \item{kernel}{Kernel function type. One of "bisquare" (default), "gaussian", "tricube", "boxcar", "exponential".} @@ -66,30 +69,234 @@ A \code{gwr_fit} object (inherits from \code{spatial_fit}). Supports \code{predict()}, \code{fitted()}, \code{residuals()}, \code{coef()}, \code{summary()}, and \code{model_metrics()}. Model-specific metadata lives in \code{$info}: bandwidth, adaptive, -kernel, AICc (\code{NA}, with a warning, where GWmodel's AICc is +kernel, AICc (\code{NA}, with a warning, where AICc is undefined: its effective number of parameters \eqn{tr(S)} is not below \eqn{n - 2}, the local regressions all but interpolate the data, and the -large negative value GWmodel reports would rank the fit above any -other), \code{bandwidth_is_fallback} (\code{TRUE} when automatic -selection failed and the arbitrary fallback was used), +large negative value the formula gives would rank the fit above any +other; also where the fit reproduces the mean of the observations at +each location, see \strong{Observations that share a location}), +\code{bandwidth_is_fallback} (\code{TRUE} when no bandwidth could +be selected: the search failed and the arbitrary fallback was used, or +no bandwidth has a defined criterion and the widest was used), \code{condition_index} (the global index), \code{local_collinearity} (one row per observation: \code{row}, \code{x}, \code{y}, -\code{n_window}, \code{cn} and \code{cn_slopes}; see -\strong{Collinearity diagnostics}), \code{n_local_collinear} (the +\code{n_window}, \code{cn} and \code{cn_slopes}, see +\strong{Collinearity diagnostics}, then \code{rank}, the rank the local +solve found, and \code{leverage}, the observation's diagonal of the hat +matrix), \code{n_local_collinear} (the locations whose slopes count as collinear), \code{n_local_singular} -(the locations whose local coefficients came back non-finite), +(the locations with a local coefficient that is \code{NA}), +\code{n_rank_deficient} (the windows whose rank is below the number of +parameters), \code{n_saturated} (the windows whose fitted value is their +own observation: leverage 1), \code{nonfinite_coef} (a logical matrix, one row per observation and one column per term, with \code{Intercept} first, \code{TRUE} where the -local coefficient came back non-finite, so the count in -\code{n_local_singular} can be placed) and \code{n_dropped} (the rows +local coefficient is \code{NA}, so the count in +\code{n_local_singular} can be placed), \code{n_dropped} (the rows \code{prep_model_data()} removed for missing or non-finite values or a -bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}). -The raw GWmodel result is in \code{$engine}. +bad geometry, so \code{$n} can be read against \code{nrow(data_sf)}), +\code{n_locations} (the distinct locations of the rows fitted; see +\strong{Observations that share a location}), +\code{tr_S}, \code{enp}, \code{edf} and \code{sigma2} (the trace of the +hat matrix, the effective number of parameters +\eqn{2\,tr(S) - tr(S^\top S)}, the effective residual degrees of freedom +and the residual variance, as GWmodel defines them), +\code{global_ols} (\code{RSS}, \code{RMSE} and \code{AICc} of one +least-squares regression on the same rows, the AICc by the same formula +with the regression's rank as its trace; a GWR whose AICc is no lower +has not shown that its coefficients vary, and \code{summary()} prints +the two side by side), +\code{rank_tolerance}, \code{max_kernel_width} (the widest kernel at any +observation, which \code{predict()} measures new locations against) and +\code{bandwidth_search} (see \strong{Bandwidth selection}; \code{NULL} +when a bandwidth was supplied). + +\code{$engine} holds the fit in the layout of the object +\code{GWmodel::gwr.basic()} returns, under the same names: \code{SDF} (a +\code{SpatialPointsDataFrame} of the local coefficients, \code{y}, +\code{yhat}, \code{residual}, \code{CV_Score}, \code{Stud_residual}, the +standard errors \code{_SE}, the t values \code{_TV} and +\code{Local_R2}), \code{GW.diagnostic}, \code{GW.arguments} and +\code{lm} (the global least-squares fit). It is a plain list, not a +\code{gwrm} object. } \description{ -Fits a GWR using GWmodel on an sf dataset with either adaptive or fixed -bandwidth. +Fits a Gaussian GWR on an sf dataset with an adaptive or a fixed +bandwidth. The kernels, the bandwidth conventions and the diagnostics are +those of the GWmodel package. The local regressions are solved by this +package, each as a weighted least squares by pivoted QR, so a window whose +design is rank deficient neither stops the fit nor returns coefficients +made of rounding error. +} +\section{The local solve}{ + +At every observation the model is a weighted least squares on the +observations whose kernel weight is above zero. It is solved by a +Householder QR with column pivoting of the window's weighted design, never +by inverting \eqn{X^\top W X}{X'WX}. Before the factorisation each row is +multiplied by the square root of its weight over the window's largest +weight, and each predictor is divided by its standard deviation over the +whole data and centred in the window, so nothing below depends on a +predictor's origin or units: an indicator coded 0/1 and one coded +288.7/289.3 give the same fit. + +One tolerance, \code{1e-7}, decides what a window can estimate: +\itemize{ +\item \strong{Rank.} A predictor is aliased in a window when the part +of it that the terms entered before it do not explain varies there by +less than \code{1e-7} of its standard deviation over the study area +(the length of that part over the weighted rows). A predictor that is +constant among the weighted observations, two predictors that are +exactly collinear there, and a window with fewer weighted observations +than parameters are the cases. No weight is cut off: under a Gaussian +or exponential kernel every observation enters, and distant ones stop +counting only through this rule. +\item \strong{Coefficients.} A coefficient is returned when it has one +value over all least-squares solutions of the window, and is \code{NA} +otherwise. The slope of an aliased predictor is \code{NA}. So is the +intercept when a predictor is constant in the window at a value other +than 0, because it would absorb that value times the slope; when the +constant is 0 the intercept is identified and returned. The slopes of +the other predictors are returned. +\item \strong{Fitted values.} The fitted value at an observation is +always estimable (its own row is in its window) and is returned, also +where a coefficient is \code{NA}. +} +A window of deficient rank does not stop the fit. A warning of class +\code{"spatialkit_gwr_rank_deficient"} says how many windows are affected +and how many coefficients of each term are \code{NA}; +\code{info$n_rank_deficient}, \code{info$n_local_singular}, +\code{info$nonfinite_coef} and the \code{rank} column of +\code{info$local_collinearity} locate them. When many windows hold a +predictor constant, a local coefficient is the wrong model for it: its +effect is identified only as one global coefficient (a mixed GWR, as +\code{GWmodel::gwr.mixed()} fits). + +The leverage of each observation, the trace of the hat matrix, the +residual sum of squares, AICc and the coefficients' standard errors come +from the same decomposition. On a window of full rank every one of them +equals what \code{GWmodel::gwr.basic()} returns, to rounding error: the +largest relative difference in any cell of the six fits the package's +tests compare is \code{3e-12}. They are not bit-identical, since GWmodel +inverts the normal equations. } + +\section{Bandwidth selection}{ + +With \code{bandwidth = NULL} the AICc is scored on 16 bandwidths spaced +evenly in the logarithm over the whole range, and then refined by a +golden-section search between the grid points either side of the best +(and, for a count of neighbours, at the counts next to the one it ends +on). That is about 20 to 35 fits of the model in all. +The range runs, for an adaptive bandwidth, from the smallest count the +model's parameters allow to every observation; for a fixed one, from the +distance at which half of the windows hold one observation more than the +model has parameters (a third of it for the Gaussian and exponential +kernels) to the largest distance between two observations. The bandwidth +returned is the best of all those scored. + +A golden-section search over the whole range, which +\code{GWmodel::bw.gwr()} runs, assumes the criterion has one minimum. It +has several when the coefficients vary at a range that only a few dozen +observations resolve, and that search then returns a bandwidth near the +top of the range, a nearly global regression, as the selected one. + +A candidate bandwidth with windows of deficient rank is scored on its +fitted values, which those windows do estimate. One at which AICc is +undefined (\eqn{tr(S)} not below \eqn{n - 2}) cannot be selected, and +neither can one at which a term of the model is estimable at no location: +the fit would have no coefficient for it anywhere. + +The criterion at a candidate comes from the local solve. Under a Gaussian +or an exponential kernel, which weight every observation at every +location, the fitted value and leverage of a window that is far from rank +deficient are computed from its centred cross-products, many windows to +one matrix product, and the windows that are not are left to the QR; the +two routes agree to rounding error (\code{1e-9} relative in the package's +tests) and take the same rank decisions. A default-bandwidth fit with one +of those kernels and two predictors then takes 1.1 to 1.6 times as long +as \code{GWmodel::bw.gwr()} followed by \code{gwr.basic()} (2.0 s +against 1.6 s at 1,000 observations and 7.4 s against 5.7 s at 2,000, +fixed Gaussian, on one machine), and 3 to 5 times as long by the QR +alone. With several strongly correlated predictors more windows are +left to the QR and the fit is slower than that. The fit at the selected +bandwidth is always the QR's. + +Everything scored is kept in \code{info$bandwidth_search}: +\code{approach} (the criterion minimised, \code{"AICc"} or \code{"CV"}), +\code{by_location} and \code{n_locations} (see \strong{Observations +that share a location}), \code{curve} +(bandwidth, criterion, trace of the hat matrix, windows of deficient rank, +and whether the point belongs to the grid or the refinement), +\code{undefined} (how many of the bandwidths scored have no criterion, +by reason), +\code{n_local_minima} and \code{multimodal} (local minima on the grid), +\code{within} and \code{flat} (the range of bandwidths whose AICc is +within 2 of the minimum, and whether half the grid is), +\code{near_global} (the widest bandwidth of the range is within 2 of the +minimum), \code{at_upper} and \code{at_lower} (the minimum is at an end +of the range). When any of these holds, one logged line says so (on the +console, unless \code{\link{spatialkit_quiet}()} is on; in the trace only +for the folds of a cross-validation); it is a +message, not a warning, because a minimum at or near the top of the range +is the ordinary outcome for a process whose coefficients do not vary. +Read \code{near_global} as "AICc does not tell this fit from one global +regression". + +AICc is an in-sample criterion and rewards interpolation between +neighbours. The bandwidth it selects can score worse than a wider one on +held-out spatial blocks; \code{\link{cv_gwr}} with a supplied +\code{bandwidth} is the check. +} + +\section{Observations that share a location}{ + +Rows with the same coordinates (several years at one station, replicate +samples of one plot, records geocoded to one address) get one kernel +weight at every regression point. \code{info$n_locations} is the number +of distinct locations, and when it is below \code{n} a warning of class +\code{"spatialkit_gwr_repeated_locations"} gives the counts. Three things +follow. + +\strong{The bandwidth is not selected by AICc.} AICc counts the rows at +one location as independent observations. When a location has an effect +of its own, which is the usual case, a window that holds little but the +location reproduces its mean, the residual sum of squares falls to the +spread within locations, and AICc is lowest where the windows +interpolate: on 100 simulated sites with 3 observations each it is 58 at +5 to 10 neighbours, 90 at 13 and 221 at 58, while the error of prediction +at new sites is 46 at 10 neighbours, 1.35 at 13 and 0.15 at 150. A floor on +the bandwidth does not repair that, because the criterion keeps falling +towards the floor. With \code{bandwidth = NULL} the search therefore +minimises the +\strong{leave-one-location-out} sum of squares: each location's +observations are predicted by the local regression there without any of +them, the kernel keeping its width, and the squared errors are summed. +It is computed from the hat matrix of the fit at each bandwidth, without +refitting. A bandwidth at which some location cannot be predicted from +the others cannot be selected. \code{info$bandwidth_search$approach} is +then \code{"CV"} and \code{by_location} is \code{TRUE}. On a layer +without repeat locations nothing changes: the criterion is AICc. + +\strong{The range of an adaptive search counts locations.} It starts at +the smallest count that gives every window one location more than the +model has parameters, and for a fixed bandwidth at the distance at which +half the windows hold that many locations. + +\strong{AICc and the standard errors still assume independence.} +\code{info$AICc}, the comparison with the global regression in +\code{summary()} and the standard errors of \code{coef(se = TRUE)} and +\code{predict(se.fit = TRUE)} treat every row as an independent +observation. With an effect shared by the rows of a location the standard +errors are too small, and AICc compared across bandwidths favours the +small ones. \code{info$AICc} is \code{NA}, with a warning, when the fit +(nearly) reproduces the mean of the observations at each location: +\eqn{tr(S)} is then not below the number of rows that differ in location +or in a predictor, minus 2, and the value the formula gives measures only +the spread among observations that share a location. If the repeats are +replicates of one measurement, fit their means, one row per location. +} + \section{Collinearity diagnostics}{ The function computes \strong{scaled condition indices} of the design and @@ -109,19 +316,19 @@ collinear with one another over the whole study area; it is 1 for a single predictor, and a change of origin (degrees C or kelvin, a year or years since 2000) does not move it. -\strong{Local} indices are then computed at \strong{every} location, on the design -the local regression there inverts: each row weighted by the square root +\strong{Local} indices are then computed at \strong{every} location, on the weighted +design of the local regression there: each row weighted by the square root of its kernel weight at the bandwidth the model is fitted with (supplied or -selected), with rows of negligible weight dropped. A window left with -fewer rows than columns counts as singular. Two indices are kept for each -window, as columns of \code{info$local_collinearity}: +selected), with rows of negligible weight (below 1e-8) dropped. A window +left with fewer rows than columns counts as singular. Two indices are +kept for each window, as columns of \code{info$local_collinearity}: \describe{ \item{\code{cn}}{Belsley's index of the intercept plus the predictors, scaled to unit length but not centred. A predictor whose values in the window are far from 0 against their spread (a year, a temperature in kelvin) is collinear with the intercept and raises it: the local intercept is then an extrapolation to 0 and is ill-determined, but the -slopes are not. It is what GWmodel's own solve sees.} +slopes are not.} \item{\code{cn_slopes}}{The index for the slopes: the predictors centred at their weighted mean in the window and each divided by its standard deviation over the whole study area. It is 1 when the predictors vary @@ -131,27 +338,33 @@ window (a regional covariate) or two predictors move together there. It does not depend on the predictors' origin or units.} } A window's slopes count as collinear when \code{cn_slopes} is above 30 or -singular, or when \code{cn} is above 1e6, where GWmodel's uncentred solve starts -to lose precision in the slopes too. Those windows are counted in -\code{info$n_local_collinear}. A predictor that is constant, or nearly so, -inside a window is caught this way whether it is alone or has company, so a -single predictor is surveyed too. +singular. Those windows are counted in \code{info$n_local_collinear}. A +predictor that is constant, or nearly so, inside a window is caught this +way whether it is alone or has company, so a single predictor is surveyed +too. \code{cn} does not enter: the local solve centres each predictor in its +window, so a predictor far from zero (a year, a temperature in kelvin, a +coordinate) has the slopes it would have at any other origin, and is not +flagged, however large \code{cn} is. The one exception is a \code{cn} that is +singular to machine precision, where the predictor's spread is lost in the +rounding of its own values. A warning is issued whenever \strong{any} location has collinear slopes; the wording reports a percentage when more than 25\% of locations are affected and a count otherwise. Both are real R warnings, not log lines. -Coefficients at a near-singular window are unstable and can be implausibly -large. An \strong{exactly} singular window (an indicator that is constant -inside it, or fewer observations than parameters) makes GWmodel stop, so -the fit fails with an error that says so; the window is not returned as -\code{NaN}. A window with only \code{cn} above 30 raises no warning: +Coefficients at a near-singular window are least-squares estimates with +little to rest on, and can be implausibly large. An \strong{exactly} singular +window (an indicator that is constant inside it, or fewer observations +than parameters) is of deficient rank: the coefficients it cannot estimate +are \code{NA} and the fit is returned (see \strong{The local solve}). +A window with only \code{cn} above 30 raises no warning: \code{plot(fit, type = "coefficients", term = "Intercept")} masks it, and slope maps do not. Centre such a predictor if you want an interpretable local -intercept. +intercept. The survey is a caution about how well a coefficient is +determined, on rows whose weight is not negligible; the solve's rank is +the statement about whether it is determined at all. -After the fit, the local coefficient surfaces are scanned and a further -warning counts local regressions that came back non-finite. GWmodel -returns those where the kernel weights are undefined: with an adaptive +A further warning counts local regressions that have no fitted value. +That happens where the kernel weights are undefined: with an adaptive bandwidth of \code{k}, a location where \code{k} or more observations share the same coordinates has a kernel of zero width, and every kernel but the boxcar divides 0 by 0 there. The warning names that cause when it applies. @@ -161,8 +374,7 @@ study area that fitted. } \examples{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +if (requireNamespace("sp", quietly = TRUE)) { library(sf) set.seed(1) n <- 60 @@ -176,14 +388,15 @@ if (requireNamespace("GWmodel", quietly = TRUE) && fit <- fit_gwr_model(dat, "price", "elev", bandwidth = 30) print(summary(fit)) # print(): only a block's last value shows on its own head(predict(fit, newdata = dat)) # newdata is re-projected if needed + head(coef(fit, se = TRUE)$se) # local standard errors } } \seealso{ -Other model fitting: -\code{\link{fit_bayesian_spatial_model}()}, -\code{\link{fit_rf_model}()}, -\code{\link{gp_lengthscale_bounds}()}, -\code{\link{new_spatial_fit}()}, -\code{\link{prep_model_data}()} +Other model fitting: +\code{\link[=fit_bayesian_spatial_model]{fit_bayesian_spatial_model()}}, +\code{\link[=fit_rf_model]{fit_rf_model()}}, +\code{\link[=gp_lengthscale_bounds]{gp_lengthscale_bounds()}}, +\code{\link[=new_spatial_fit]{new_spatial_fit()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{model fitting} diff --git a/man/fit_rf_model.Rd b/man/fit_rf_model.Rd index a4363976..dd34430e 100644 --- a/man/fit_rf_model.Rd +++ b/man/fit_rf_model.Rd @@ -40,7 +40,8 @@ high-cardinality predictors (Strobl et al. 2007), which is why permutation is the default despite costing more.} \item{include_coords}{Add the coordinates as predictors. Default -\code{FALSE}; see above.} +\code{FALSE}, which leaves the forest with no spatial information; see +\emph{Coordinates as predictors}.} \item{replace}{Logical; grow each tree on a bootstrap sample drawn \emph{with} replacement (\code{TRUE}, ranger's default and this one) or @@ -80,13 +81,20 @@ the arguments this function already sets (\code{num.trees}, \code{importance}, \code{seed}, \code{replace}, \code{sample.fraction}, \code{x}, \code{y}) are rejected with a message naming the wrapper argument to use instead. Passing them here -would reach \code{ranger()} twice and fail the call.} +would reach \code{ranger()} twice and fail the call. +\code{respect.unordered.factors} passed here overrides the +\code{"order"} this function sets when a predictor is categorical; see +\emph{Categorical predictors}.} } \value{ An \code{rf_fit} object (inherits from \code{spatial_fit}). \code{$info} carries \code{num_trees}, \code{mtry}, \code{min_node_size}, \code{importance_type}, \code{importance} (a named numeric, or \code{NULL} when \code{importance = "none"}), \code{include_coords}, +\code{categorical_predictors} (the unordered factor and character +predictors, possibly none) and \code{respect_unordered_factors} (how +ranger was told to split them: \code{"order"} unless overridden through +\code{...}, and \code{NA} when there is none and nothing was passed), \code{replace} and \code{sample_fraction} (the sampling each tree was grown on, with \code{sample_fraction} resolved to the number ranger used), \code{oob_rmse} and \code{oob_r_squared} (each \code{NA_real_} when @@ -104,19 +112,68 @@ Fits a regression random forest on an \code{sf} dataset and returns it as a \code{\link{predict_surface}}, \code{\link{area_of_applicability}} and the \code{plot()} method like any other backend. } -\section{Coordinates are not predictors by default}{ - -Handing a random forest the x and y coordinates lets it reproduce the -training surface almost exactly by memorising location, and then fail badly -anywhere it has not seen. Random cross-validation will not catch this: -nearby points leak between folds, so the memorised surface scores well. -That is how the practice became common. Meyer et al. (2019) show the -collapse directly. \code{include_coords} therefore defaults to -\code{FALSE}, and setting it to \code{TRUE} logs a caution, once per -session (it is a deliberate choice, so it is not raised as an R warning, -and it is not repeated for every fold of a cross-validation). If you do use it, -score the model with \code{\link{cv_spatial}} and blocked folds, never with -the out-of-bag error. +\section{Coordinates as predictors}{ + +\code{include_coords = TRUE} adds the x and y coordinates to the +predictors. They are the only spatial information a forest can be given: +without them it sees the covariates alone, and \code{print()} says "no +spatial information used". The default is \code{FALSE}. + +What the coordinates buy depends on where the predictions are wanted. A +forest splits on location as on any column, so it follows the training +surface closely between sampled points, and has nothing but the nearest +edge of the data to go on beyond them. Between sampled points the +coordinates can lower the error, most where the covariates carry little +of the spatial structure themselves, and the gain fades with distance +from the training data. +Beyond the autocorrelation range, or in a region the data never visited, +it can reverse: in a simulated hold-out of an unvisited strip the forest +with coordinates was 5.2\\% worse on average and 31\\% worse in the worst +run. Meyer et al. (2019) report larger failures of the same kind. With +covariates that carry the spatial structure themselves, expect less from +the coordinates. + +What does not change is how such a forest has to be scored. It fits +location closely, nearby points leak between random folds, and the +out-of-bag error is a random hold-out too, so both overstate its +accuracy. Score it with \code{\link{cv_rf}} and +blocked folds (\code{make_folds(method = "block_kfold")}) or folds +matched to the prediction distance (\code{method = "nndm"}), at the +distances the map will be used at, never with the out-of-bag error, and +compare the two forests on the same folds. That comparison is two calls: +build the folds once and hand them to \code{cv_rf()} with and without +the coordinates. +\preformatted{ +folds <- make_folds(dat, k = 5, method = "block_kfold") +plain <- cv_rf(dat, "z", c("a", "b"), folds = folds) +with_xy <- cv_rf(dat, "z", c("a", "b"), folds = folds, + include_coords = TRUE) +c(plain = plain$overall$RMSE, with_xy = with_xy$overall$RMSE) +} +\code{\link{cv_rf}} runs the same comparison in its example and reads it +fold by fold. Setting +\code{include_coords = TRUE} logs that advice, once per session (it is a +deliberate choice, so it is not raised as an R warning, and it is not +repeated for every fold of a cross-validation). +} + +\section{Categorical predictors}{ + +A predictor that is an unordered factor or a character column is split +with \code{respect.unordered.factors = "order"}: ranger orders its levels +by mean response once, before growing, and splits on that order. That is +the handling ranger's own help recommends. ranger's default for a +regression forest, \code{"ignore"}, splits on the order the levels happen +to be stored in (alphabetical, for most data), which for a nominal +variable is arbitrary: with a 40-level factor carrying random level +effects, the test RMSE was 1.05 by level order against 0.57 by response +order, lower in 10 draws of 10. Pass \code{respect.unordered.factors} +through \code{...} to choose otherwise (\code{"ignore"}, or +\code{"partition"} for every two-way split of the levels, which is slow +beyond a few levels). Ordered factors are left alone and split on their +own order, and with \code{splitrule = "extratrees"} ranger's own default +for that rule, \code{"partition"}, is kept. The setting is recorded in +\code{$info$respect_unordered_factors} and printed with the fit. } \section{The out-of-bag error is a random hold-out}{ @@ -181,16 +238,18 @@ solution. \emph{BMC Bioinformatics} 8, 25. \doi{10.1186/1471-2105-8-25} } \seealso{ \code{\link{cv_rf}} for a spatially blocked performance estimate, -\code{\link{area_of_applicability}}, which can take -\code{weights = pmax(fit$info$importance, 0)} when that importance is -finite (it is \code{NaN} when no row is out of bag; see "What -fitted() returns"). - -Other model fitting: -\code{\link{fit_bayesian_spatial_model}()}, -\code{\link{fit_gwr_model}()}, -\code{\link{gp_lengthscale_bounds}()}, -\code{\link{new_spatial_fit}()}, -\code{\link{prep_model_data}()} +\code{\link{area_of_applicability}}, which weights the predictors by +\code{pmax(fit$info$importance, 0)} by default when that importance is +finite and the forest has out-of-bag skill (it is \code{NaN} when no row +is out of bag; see "What fitted() returns"), and which needs +\code{categorical = "indicator"} or \code{"drop"} for a forest with a +factor predictor. + +Other model fitting: +\code{\link[=fit_bayesian_spatial_model]{fit_bayesian_spatial_model()}}, +\code{\link[=fit_gwr_model]{fit_gwr_model()}}, +\code{\link[=gp_lengthscale_bounds]{gp_lengthscale_bounds()}}, +\code{\link[=new_spatial_fit]{new_spatial_fit()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{model fitting} diff --git a/man/fitted.bayesian_fit.Rd b/man/fitted.bayesian_fit.Rd index 05cb2a74..da943b3a 100644 --- a/man/fitted.bayesian_fit.Rd +++ b/man/fitted.bayesian_fit.Rd @@ -58,21 +58,21 @@ values and a small identifier of the sampling run, so a fit saved with } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/fitted.gwr_fit.Rd b/man/fitted.gwr_fit.Rd index ff3f175c..4a131cf7 100644 --- a/man/fitted.gwr_fit.Rd +++ b/man/fitted.gwr_fit.Rd @@ -25,21 +25,21 @@ was inside its own bandwidth window), so \code{summary()} on a spatially blocked estimate. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/fitted.rf_fit.Rd b/man/fitted.rf_fit.Rd index f28a4182..d54be2da 100644 --- a/man/fitted.rf_fit.Rd +++ b/man/fitted.rf_fit.Rd @@ -20,21 +20,21 @@ Returns out-of-bag predictions rather than in-sample ones. See \code{summary()}. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/fold_separation.Rd b/man/fold_separation.Rd index 116a64e7..07d07502 100644 --- a/man/fold_separation.Rd +++ b/man/fold_separation.Rd @@ -2,9 +2,9 @@ % Please edit documentation in R/fold-separation.R \name{fold_separation} \alias{fold_separation} -\title{How far the held-out points actually sit from the training data} +\title{How far the held-out points sit from the training data} \usage{ -fold_separation(folds, data_sf, sac = NULL) +fold_separation(folds, data_sf, sac = NULL, prediction_points = NULL) } \arguments{ \item{folds}{A \code{\link{make_folds}()} result, or its \code{$folds} @@ -22,7 +22,8 @@ the other is not.} \item{sac}{Optional: an \code{\link{estimate_sac_range}()} result or a single number. Defaults to the range the folds carry, if any. Supplying -one adds the \code{within_range} column and the closing verdict. A +one adds the \code{mean_cor} column and, with a prediction target, +the gap on the correlation scale. A range that records its CRS (the folds' own, or an \code{estimate_sac_range()} result) is compared with distances measured in that CRS, whatever CRS \code{data_sf} is in. A bare number is taken @@ -31,6 +32,23 @@ to be in the units the distances are otherwise measured in: those of metres, in the CRS \code{\link{ensure_projected}()} chooses (as for \code{make_folds()}'s \code{block_size}), not degrees. A \code{units} object is refused.} + +\item{prediction_points}{Optional \code{sf} or \code{sfc} layer of the +locations the model will predict at: the grid from +\code{\link{predict_surface}()}, or a grid over the region of interest +(\code{sf::st_make_grid(region, what = "centers")}). A non-POINT layer +is reduced to one representative point per feature, as in +\code{make_folds(method = "nndm")}, so pass grid cells or points, not +one polygon of the region. It is brought into the CRS the distances are +measured in. Default \code{NULL}: no target and no reading, except for +NNDM and kNNDM folds (\code{method = "nndm"} and \code{"knndm"}), which +carry the distances from the prediction points they were built for and +are compared against those, measured to all sites. The carried +distances are lengths in the CRS the folds were built in +(\code{folds$params$crs}). When the distances here are measured in +another CRS (\code{data_sf} is in another projected CRS, or \code{sac} +records another), the two are not compared, \code{print()} says so, and +passing \code{prediction_points} has the target measured here.} } \value{ A data.frame of class \code{fold_separation}, one row per fold: @@ -40,34 +58,130 @@ which differs from the list position once a fold has been dropped), \code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} for a scheme with no blocks), \code{min_dist} and \code{median_dist} (distance from a held-out point to its nearest training point, in the -units of the CRS the \code{crs} attribute names), and -\code{within_range} (the share of held-out points closer to -training data than \code{sac}; \code{NA} without one). Attributes: -\code{method}, \code{sac_range}, \code{crs} (the CRS the distances were -measured in) and \code{n_unknown_ids}. +units of the CRS the \code{crs} attribute names), \code{mean_cor}, +\code{target_median_dist} (the median distance from the prediction +points to the fold's training data) and \code{dist_gap} (the fold's mean +held-out distance minus its mean prediction distance); the last two are +\code{NA} without a target, and \code{print()} shows them under the +headings \code{target} and \code{gap}. + +\code{mean_cor} is a mean correlation, \code{NA} without a +range: the mean over the fold's held-out points of \eqn{\rho(d)}, the +correlation the range leaves between a point and its nearest training +point at distance \eqn{d}. It is 1 for a point on top of training data +and falls towards 0 beyond the range, so a point at a twentieth of the +range counts for more than one at nine tenths of it. \eqn{\rho(d)} is +\eqn{\exp(-3 d / range)}, the exponential model whose effective range is +the range given (0.05 at the range), or the spherical model when the +range comes from an \code{estimate_sac_range()} fit that was spherical; +the \code{range_model} attribute says which. Earlier development +versions had a column \code{within_range} in its place: the share of +held-out points closer than the range, which counted every such point +the same. + +Attributes: \code{method}, \code{sac_range}, \code{range_model}, +\code{crs} (the CRS the distances were measured in), +\code{n_unknown_ids} (the number of distinct rows the folds name that +\code{data_sf} does not have, each counted once however many folds +mention it, as in the \code{cv_*()} field of the same name), +\code{pooled} (a list with the number, minimum, median and mean of the +held-out distances over all folds, and the pooled \code{mean_cor}) +and \code{target}: \code{NULL} without a prediction target, otherwise a +list with \code{n_prediction_points}, \code{source}, \code{basis} +(\code{"each fold's training data"} or \code{"all sites"}), +\code{held_out_mean}, \code{held_out_median}, \code{target_mean}, +\code{target_median}, \code{target_all_mean}, \code{target_all_median} +(the prediction distances to all sites), \code{mean_diff}, \code{w1}, +\code{cor_gap}, \code{cor_w1} (\code{NA} without a range), \code{scale} +(\code{"correlation"} or \code{"distance"}), \code{tolerance}, +\code{reading} (see \strong{Reading the gap}) and +\code{nndm_out_of_reach} (for NNDM and kNNDM folds, the +\code{params$target_out_of_reach} that \code{make_folds()} recorded; +\code{NA} for other schemes). \code{not_compared} is \code{NULL}, or, +for NNDM or kNNDM folds whose carried target was not compared because the +distances here are measured in another CRS, one sentence naming the two +CRSs; \code{target} is then \code{NULL} and \code{print()} gives the +sentence where it would otherwise say that no target is given. } \description{ Blocked cross-validation exists to put distance between a test point and the training points that could tell you its value. Whether it succeeded is -a measurement, and until now the package only offered a proxy for it: the -block size compared against the estimated autocorrelation range, reported -by \code{\link{make_folds}()} as a warning. That comparison is about the -\emph{design}. This is about the \emph{result}: for every held-out point, -the distance to its nearest training point, summarised per fold. +a measurement, and \code{\link{make_folds}()} only offers a proxy for it: +the block size compared against the estimated autocorrelation range, +reported as a warning. That comparison is about the \emph{design}. This +is about the \emph{result}: for every held-out point, the distance to its +nearest training point, summarised per fold. } \details{ -The two can disagree, and the direction is not obvious. Blocks wider than -the range still leak wherever a test point sits near a block edge with -training data just across it, which is most of the points in a fine block -grid; conversely a fold whose blocks are narrower than the range can still -separate well if the points inside them are clustered. The share of -held-out points closer to training data than the correlation range is the -number that settles it, and it is the last column here. +The distances do not say by themselves which way a score errs. A +cross-validated error reads low when the held-out points sit closer to +their training data than the locations the model will predict at, and high +when they sit farther, so the same held-out distances can go with either, +depending on the target. Random folds on evenly sited data, scored for a +map of the sampled area, are close to unbiased although nearly every +held-out point has a training neighbour inside the range; range-sized +blocks on the same data read high; random folds on clustered data scored +for a map of the whole region read low. So without a prediction target +the function reports the distances and draws no conclusion. Give it +\code{prediction_points} and it sets the held-out distances beside the +distances from those points to the same training data, and words its +reading by the signed gap between the two. Nothing is estimated: the distances come from the geometry, and the range, when one is shown, is the one the folds already carry (\code{make_folds( auto_range = TRUE)} records it) or the one you pass as \code{sac}. } +\section{Reading the gap}{ + +With a target, the held-out distances and the prediction distances are +compared as two distributions. Each fold's prediction distances are +measured to that fold's own training rows, so that a five-fold design is +not read as too far only because each fold trains on four fifths of the +sites; the distances to all sites are reported beside them. (With more +than 50 folds, the leave-one-out schemes, every training set is nearly the +whole sample and the prediction points are measured against all sites +once.) Folds count by their share of the held-out points. + +Two numbers summarise the comparison: the signed difference of the means, +held-out minus prediction (the signed area between the two cumulative +distributions), and the Wasserstein distance \eqn{W_1} (the unsigned +area). When a range is available both are also given on the correlation +scale, after each distance \eqn{d} is replaced by \eqn{1 - \rho(d)}, with +\eqn{\rho} the correlation the range implies (see \code{mean_cor} +under Value). That scale counts a difference between two distances well +inside the range and ignores one between two distances beyond it. + +The reading is taken on the correlation scale when there is a range, with +a tolerance of 0.1, and otherwise on the mean distance, with a tolerance +of a quarter of the prediction mean. (When the prediction points are +measured to all sites and every one lies on a site, as when the sites +themselves are passed as \code{prediction_points} to a leave-one-out +design, the prediction mean and with it that tolerance +are 0: held-out distances above 0 then read \code{"farther"}, and +held-out distances that are all 0 as well read \code{"matched"}. With +50 folds or fewer the points are measured to each fold's own training +rows, which leave out that fold's held-out sites, so the mean is above 0 +and the quarter rule gives the reading.) +\describe{ +\item{\code{"closer"}}{The gap is below minus the tolerance and at least +half of \eqn{W_1} in size: the held-out points sit closer to their +training data than the prediction points do, and the cross-validated +error tends to read low for that target.} +\item{\code{"farther"}}{The gap is above the tolerance and at least +half of \eqn{W_1}: the held-out points sit farther, and the error +tends to read high.} +\item{\code{"matched"}}{The gap is within the tolerance and +\eqn{W_1} within twice the tolerance.} +\item{\code{"mixed"}}{The two distributions cross, closer at some +distances and farther at others (the gap is under half of +\eqn{W_1}, or it is within the tolerance while \eqn{W_1} is not), so +the distances give no single direction.} +} +The reading is a statement about nearest-neighbour distances, not a +measured bias. A learner that draws on several neighbours can still score +low on clustered samples whose nearest-neighbour distances match. +} + \examples{ library(sf) set.seed(1) @@ -77,7 +191,7 @@ pts <- st_as_sf( coords = c("x", "y"), crs = 32632 ) -# Random folds put a training point almost on top of every held-out one. +# Random folds put a training point close to every held-out one. random <- make_folds(pts, k = 4, method = "random_kfold", seed = 1) print(fold_separation(random, pts, sac = 200)) @@ -85,23 +199,29 @@ print(fold_separation(random, pts, sac = 200)) blocked <- make_folds(pts, k = 4, method = "block_kfold", block_size = 250, seed = 1) print(fold_separation(blocked, pts, sac = 200)) + +# Which of the two suits a map of the sampled square? Compare each with +# the distances from the cells of that map to the training data. +cells <- st_make_grid(pts, n = c(20, 20), what = "centers") +print(fold_separation(random, pts, sac = 200, prediction_points = cells)) +print(fold_separation(blocked, pts, sac = 200, prediction_points = cells)) } \seealso{ \code{\link{make_folds}()} for the fold schemes and the block sizing this measures the outcome of; \code{\link{cv_block_size_sweep}()} for choosing a block size by cross-validated error instead. -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/get_voronoi_seeds.Rd b/man/get_voronoi_seeds.Rd index 1dd4bdf5..bef5d63e 100644 --- a/man/get_voronoi_seeds.Rd +++ b/man/get_voronoi_seeds.Rd @@ -10,9 +10,13 @@ get_voronoi_seeds( n = NULL, seeds = NULL, sample_points = NULL, - kmeans_nstart = 10, + kmeans_nstart = NULL, kmeans_iter = 100, - set_seed = NULL + set_seed = NULL, + partition = c("density", "kmeans"), + init = NULL, + density_power = 1, + density_k = 8 ) } \arguments{ @@ -36,17 +40,48 @@ assume \code{n}. Besides a number, \code{n} accepts what the level-selection step returned: the integer vector of ranked candidates from \code{\link[=determine_optimal_levels]{determine_optimal_levels()}} (its first element is used), a \code{\link[=select_resolution]{select_resolution()}} result (its -\verb{$best}), or a \code{\link[=resolution_profile]{resolution_profile()}} (read with \code{select_resolution()} at -its default criterion). The result then carries \code{attr(, "n_from")} -saying which. +\verb{$best}), or a \code{\link[=resolution_profile]{resolution_profile()}}. A profile built without an +\code{estimate} is read with \code{select_resolution()} by \code{cp}. A profile built +with \code{estimate} is read by \code{criterion = "auto"}, the rule that goes +with its estimate: a size for pooled values and the lowest +leave-one-out error for plain means. The size is the profile's own when +it was built at one, and 4.5 rows per cell otherwise, and the count is +the profile's level for that size, or the built level nearest to +\code{max(2, round(n / obs_per_cell))} when the profile has none for it +(with a warning of class \code{"spatialkit_size_not_reached"}). +\code{select_resolution(profile)} with no \code{criterion} reads such a profile +the same way, since its default criterion is \code{"auto"}. A profile built +with \code{obs_per_cell} and without an \code{estimate} is read by \code{cp} like any +profile without one; pass \code{select_resolution(profile, criterion = "size")} for the count its size gives. The result then +carries \code{attr(, "n_from")} +saying which. A count read off a selection or a profile comes with what +the selection found: a warning of class \code{"spatialkit_bound_chosen"} when +the optimum sits on a bound of the ladder, so the bound chose the count, +and one of class \code{"spatialkit_no_structure"} when one cell for the whole +layer scores as well. A count set by a size has no optimum, so no bound +can choose it; its \code{"spatialkit_no_structure"} warning says that the +count stands and that the cell values will say little that one mean +does not. A profile without an estimate and with no \code{cp} to read is an +error (class \code{"spatialkit_no_default_criterion"} when another criterion +is finite); see \code{\link[=resolution_profile]{resolution_profile()}}. With \code{method = "kmeans"}, a selection or profile also carries the centres of the partition the profile scored at that count, and those -are returned instead of a new k-means: a k-means partition is the -Voronoi partition of its centres, so their cells are the cells the -criteria judged. \code{sample_points}, when given, is then only assigned to -them (for \code{attr(, "kmeans")}), and \code{boundary} only sets the CRS; -\code{kmeans_nstart}, \code{kmeans_iter} and \code{set_seed} are not used. Pass the +are returned instead of a new k-means: a k-means partition, weighted or +not, is the Voronoi partition of its centres, so their cells are the +cells the criteria judged. \code{sample_points}, when given, is then only +assigned to them (for \code{attr(, "kmeans")}) and gives the cover, and +\code{boundary} only +sets the CRS and the cover (see "Details"); +\code{kmeans_nstart}, \code{kmeans_iter} and \code{set_seed} are not used, and neither +are \code{partition}, \code{init} and the density settings: the centres are of +the kind the profile was built with, and naming another here is a +warning of class \code{"spatialkit_partition_unused"}. A call names what it +supplies: a \code{partition} or an \code{init} passed in the call; with +\code{partition = "density"} passed, both density settings at their values, +defaults included; without it, a density setting other than its +default. A call that supplies none of the four is told nothing, +whichever kind and settings the profile was built with. Pass the count as a number (\code{n = sel$best}) for a fresh k-means instead.} \item{seeds}{sf POINT object of user-provided seeds (method = "provided").} @@ -60,14 +95,65 @@ cloud, or one with no CRS whose coordinates look like lon/lat (the heuristic \code{\link[=ensure_projected]{ensure_projected()}} applies, with its warning), is projected before clustering.} -\item{kmeans_nstart}{Integer; nstart for kmeans(). Default 10. The -partition is \code{\link[stats:kmeans]{stats::kmeans()}}, not the best-of-25 k-means++ run that -\code{\link[=resolution_profile]{resolution_profile()}} scored a count on, so it is not that partition; -pass the selection or profile itself as \code{n} for that one (see \code{n}).} +\item{kmeans_nstart}{The number of starts, of which the best is kept. +\code{NULL} (default) is the kind's own number: 3 for \code{partition = "density"} and 10 for \code{partition = "kmeans"}, the default of earlier +versions. \code{kmeans_nstart = 10} gives the density kind the starts it had +when 10 was the default. Under \code{partition = "kmeans"} from random starts +it is \code{nstart} of \code{\link[stats:kmeans]{stats::kmeans()}}. A fresh partition is not the one +\code{\link[=resolution_profile]{resolution_profile()}} scored a count on; pass the selection or profile +itself as \code{n} for that one (see \code{n}). Under \code{partition = "density"}, +and with \code{init = "kmeans++"}, it has to be \code{NULL} or a positive whole +number, so a number that is not whole, which \code{partition = "kmeans"} +takes, stops a call that names no kind. It is not read by \code{method = "random"} or \code{"provided"}.} -\item{kmeans_iter}{Integer; iter.max for kmeans(). Default 100.} +\item{kmeans_iter}{Integer; iter.max for kmeans(). Default 100. Under +\code{partition = "density"} it is the most steps of Lloyd's iteration a +start takes. Under \code{partition = "density"}, and with \code{init = "kmeans++"}, it has to be a positive whole number, and a kept start that +was cut off at it is a warning of class \code{"spatialkit_not_converged"} +(\code{partition = "kmeans"} from random starts keeps the warning +\code{\link[stats:kmeans]{stats::kmeans()}} gives).} \item{set_seed}{Optional integer RNG seed.} + +\item{partition}{For \code{method = "kmeans"}: what the seeds minimise. +\code{"density"} (default) is the sum of squared distances from the points +of the cloud to their nearest seed, each point weighted by its local +density to the power \code{density_power}: compact cells, many small ones +where the points are dense and a few large ones where they are sparse. +At the default power they hold about the same number of points each +once \code{n} is above the number of dense places (clusters) in the cloud; +below that the counts are about as uneven as under \code{"kmeans"}. +\code{"kmeans"} is the same sum unweighted: compact cells, with several +times the points in a cell of a dense place that a cell of a sparse +place holds. It is the run of earlier versions, whose default it was: +\code{\link[stats:kmeans]{stats::kmeans()}} from 10 random starts on the rows as they come. The +density kind follows the +density of \code{sample_points}; a cloud this function draws inside +\code{boundary} is uniform and has none to follow. Without the 'FNN' package +the density kind finds its weights by comparing every pair of distinct +locations, so its time grows with the square of their number; the seeds +are the same, and nothing stops the call. See "The partition" in +\code{\link[=resolution_profile]{resolution_profile()}} for what each kind does and how.} + +\item{init}{For \code{method = "kmeans"}: how each start is drawn, \code{"random"} +(\code{n} distinct locations at random, as \code{\link[stats:kmeans]{stats::kmeans()}} draws them) or +\code{"kmeans++"} (the seeds one at a time, each in proportion to its squared +distance from those already drawn, times its weight under \code{partition = "density"}). \code{NULL} (default) is each kind's own rule: \code{"random"} for +\code{partition = "kmeans"}, the run this function has always made, and +\code{"kmeans++"} for \code{partition = "density"}. Under \code{partition = "kmeans"} +from random starts the cloud is clustered in the order its rows come +in; with \code{init = "kmeans++"}, and under \code{partition = "density"}, the +rows are put in coordinate order first, so the seeds do not depend on +their order.} + +\item{density_power}{For \code{partition = "density"}: the power the local +density is raised to for a point's weight, from 0 to 2. Default 1, which +evens out the cell counts once the cells outnumber the dense places; 0 +weights every point alike. Setting it under \code{partition = "kmeans"} is a +warning.} + +\item{density_k}{For \code{partition = "density"}: the number of nearest +neighbours the local density is read from. Default 8.} } \value{ An sf POINT object with seed_id and method columns. With @@ -79,29 +165,105 @@ with unusable coordinates are dropped first), \code{size} (points per seed), \code{iter} and \code{nstart}. For the scored centres of a selection or profile (see \code{n}) it describes \code{sample_points} assigned to them, each point to its nearest seed, with \code{iter} \code{NA} and \code{nstart} the profile's restarts, -and is absent when no \code{sample_points} were given. +and is absent when no \code{sample_points} were given. Under \code{partition = "density"} \code{withinss} and \code{tot_withinss} count every point once, about +its cell's mean. A run this call makes with \code{partition = "density"} or +\code{init = "kmeans++"} also records \code{converged}, whether the kept start +stopped before \code{kmeans_iter}, and under \code{partition = "density"} +\code{objective}, the weighted sum the seeds minimise; scored centres have +neither. Seeds placed with \code{partition = "density"} or \code{init = "kmeans++"}, and the scored centres of a profile of the density kind or +from random starts, carry \code{attr(, "partition")}: a +list with \code{kind}, \code{init}, \code{density_power} and \code{density_k}, and for +seeds this call placed \code{iter}, \code{iter_max} and \code{converged} (the +iterations the kept start took, the limit, and whether it stopped +before the limit). \code{\link[=build_tessellation]{build_tessellation()}} returns the list as +\code{params$partition}. Seeds with no such +record are plain k-means: from random starts when this call placed +them, or the scored centres of a k-means profile from k-means++ starts. +Every method also +attaches \code{attr(, "cover")} when the call says what ground the seeds stand +for (see "Details"): an sfc holding the boundary's polygons or the hull +of the clustered points, in its own CRS. + +When \code{n} is a \code{\link[=select_resolution]{select_resolution()}} result that carries \code{count_rule}, +or a profile built with an \code{estimate}, the seeds carry that record as +\code{attr(, "count_rule")}: how the count was set, for which cell value, and +what the profile scored at it. Its \code{scored_cells} is \code{TRUE} for the +scored centres \code{method = "kmeans"} hands on, and \code{FALSE} for seeds this +call places itself at that count: a k-means of its own when the +selection holds no centres at the count, and every \code{method = "random"} +seeding. \code{method = "provided"} does not read \code{n} and writes no record; +seeds that already carry one (\code{sel$seeds}) keep it, marked \code{FALSE} when +their number is not the record's count. \code{\link[=build_tessellation]{build_tessellation()}} and +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} hand the record on, and +\code{\link[=summarize_by_cell]{summarize_by_cell()}} checks its result against it. A count given as a +number, or read off a profile without an estimate by \code{cp} or \code{elbow}, +has no record. } \description{ Creates an sf POINT layer of "seed" locations. Multiple strategies are supported: user-provided points, uniform random sampling within a boundary, or k-means clustering of a sampling cloud. } +\details{ +Seeds lie inside the ground they stand for (k-means seeds inside the +hull of the points they were fitted to, random seeds inside the +boundary), so Voronoi cells clipped to the seeds' own hull would leave +its edge uncovered. The result therefore +carries that ground as \code{attr(, "cover")}: the \code{boundary} when one was +given, otherwise the convex hull of \code{sample_points}, otherwise (for the +scored centres of a \code{\link[=resolution_profile]{resolution_profile()}} or a \code{\link[=select_resolution]{select_resolution()}} +result passed as \code{n}) the hull of the points the profile was computed on. +\code{\link[=build_tessellation]{build_tessellation()}} and +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}} derive their default boundary from it, so +\code{build_tessellation(seeds, method = "voronoi")} holds every observation +without a \code{boundary}. Seeds with no cover are tessellated over their own +hull unless a \code{boundary} or \code{cover} is passed then: \code{method = "provided"} +seeds given with neither \code{boundary} nor \code{sample_points} have none, and no +warning is raised for them, since they may be the observation sites +themselves. The attribute survives +\code{sf::st_transform()} and row subsetting; \code{rbind()} drops it. + +A k-means seed is a mean of the points of its cluster, weighted under the +density kind, so it can lie outside a \code{boundary} that is not convex, in a +bay or a bend of a coast, even when every point lies inside. Tessellated +within that boundary, its cell is built if any of it lies inside, but the +seed itself lies in no cell: \code{\link[=build_tessellation]{build_tessellation()}} warns that it falls +in no cell (class \code{spatialkit_unassigned}) and gives it \code{NA} in \code{index}. +\code{seeds} in \code{\link[=cell_values_at]{cell_values_at()}} says how to give such a seed its cell's +ID. +} \examples{ library(sf) bnd <- st_sf(geometry = st_sfc(st_polygon(list(rbind( c(0, 0), c(100, 0), c(100, 100), c(0, 100), c(0, 0) ))), crs = 32632)) get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 1) + +# Seeds from a cloud with one dense place: density-weighted k-means by +# default, from 3 starts; partition = "kmeans" gives the k-means run of +# earlier versions. The points each seed's cell holds, under each kind, +# with more seeds than dense places: +set.seed(2) +cloud <- st_as_sf(data.frame(x = c(rnorm(150, 30, 5), runif(50, 0, 100)), + y = c(rnorm(150, 30, 5), runif(50, 0, 100))), + coords = c("x", "y"), crs = 32632) +dens <- get_voronoi_seeds(bnd, method = "kmeans", n = 20, + sample_points = cloud, set_seed = 1) +km <- get_voronoi_seeds(bnd, method = "kmeans", n = 20, + sample_points = cloud, set_seed = 1, + partition = "kmeans") +rbind(density = sort(attr(dens, "kmeans")$size), + kmeans = sort(attr(km, "kmeans")$size)) # points per seed } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/gp_lengthscale_bounds.Rd b/man/gp_lengthscale_bounds.Rd index e9c7c5c0..23882108 100644 --- a/man/gp_lengthscale_bounds.Rd +++ b/man/gp_lengthscale_bounds.Rd @@ -41,11 +41,23 @@ Subsamples large datasets to avoid O(n^2) memory and time cost. These are the bounds a length-scale \emph{prior} is calibrated over, not the scales a fitted model can resolve: that depends on the basis size (\code{gp_k} in \code{\link{fit_bayesian_spatial_model}()}, which reports -it as \code{$info$gp_ell_min}). Both bounds are fixed fractions of the +it as \code{$info$gp_ell_min}, and in map units as +\code{$info$gp_resolution}). Both bounds are fixed fractions of the spread of pairwise distances, so they do not shrink as points are added to -the same area. A surface whose range sits below what the basis resolves -needs a larger \code{gp_k}: more points help the data identify a short -range, but they make neither these bounds nor the derived basis finer. +the same area: more points help the data identify a short range, but they +make neither these bounds nor the derived basis finer. + +The lower bound is the 25th percentile of the pairwise distances, as an +effective range. On real layouts that is 14 to 33 percent of the extent +along each axis (about 32 km on a uniform 100 km square), and the prior +built on it puts 1 percent of its mass below it. A surface whose range +is shorter needs two things, not one: a basis fine enough to represent it +and a prior that allows it. A larger \code{gp_k} under the prior +calibrated here changes almost nothing, because the prior still holds the +length-scale above this bound. \code{fit_bayesian_spatial_model()} +therefore moves the prior's lower tail down to the length-scale the basis +resolves whenever \code{gp_resolution} or an explicit \code{gp_k} asks +for a finer basis than the one derived from these bounds. } \examples{ set.seed(1) @@ -53,11 +65,11 @@ xy <- cbind(runif(50), runif(50)) gp_lengthscale_bounds(xy) } \seealso{ -Other model fitting: -\code{\link{fit_bayesian_spatial_model}()}, -\code{\link{fit_gwr_model}()}, -\code{\link{fit_rf_model}()}, -\code{\link{new_spatial_fit}()}, -\code{\link{prep_model_data}()} +Other model fitting: +\code{\link[=fit_bayesian_spatial_model]{fit_bayesian_spatial_model()}}, +\code{\link[=fit_gwr_model]{fit_gwr_model()}}, +\code{\link[=fit_rf_model]{fit_rf_model()}}, +\code{\link[=new_spatial_fit]{new_spatial_fit()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{model fitting} diff --git a/man/gwr_model_selection.Rd b/man/gwr_model_selection.Rd index 2cec1eca..c5dc3347 100644 --- a/man/gwr_model_selection.Rd +++ b/man/gwr_model_selection.Rd @@ -25,14 +25,17 @@ gwr_model_selection( \item{candidate_vars}{Character vector naming at least two \strong{numeric} predictors to choose among. Factor, character and logical candidates are -refused: GWmodel fits a factor as several model-matrix columns while this +refused: a factor is several model-matrix columns while this sweep counts it as one variable, so the criteria would not be comparable, and \code{\link{fit_gwr_model}()}, the documented next step, takes only numerics. Encode them as numeric indicators first.} \item{bandwidth}{Bandwidth held fixed across all candidate models. If -\code{NULL} (default) it is selected with \code{GWmodel::bw.gwr()} on the -model containing every candidate. Integer neighbour count when +\code{NULL} (default) it is searched for on the model containing every +candidate, by the grid-then-refine search of +\code{\link{fit_gwr_model}()} (see its \strong{Bandwidth selection}); +what the search scored is returned in \code{bandwidth_search}. Integer +neighbour count when \code{adaptive = TRUE}; otherwise a distance in the units of the \strong{projected} CRS the sweep runs in, which \code{prep_model_data()} may have chosen for you. Geographic input is projected before the bandwidth @@ -46,9 +49,7 @@ That floor is enough unless several neighbours tie at the kernel's edge (a regular grid), which leaves a window fewer weighted points; then use a larger bandwidth. An adaptive count below 1 or above R's largest integer is refused, as in \code{\link{fit_gwr_model}()}. -One above the number of observations is capped at it, with a warning; -below 20 observations that includes \code{bw.gwr()}'s choice, since its -adaptive search starts at 20 neighbours.} +One above the number of observations is capped at it, with a warning.} \item{adaptive}{Logical; adaptive (nearest-neighbour) bandwidth. Default \code{TRUE}.} @@ -58,32 +59,42 @@ adaptive search starts at 20 neighbours.} \code{"exponential"}.} \item{bw_approach}{Criterion for the bandwidth search: \code{"AICc"} -(default) or \code{"CV"}. Matches \code{\link{fit_gwr_model}}'s default.} +(default) or \code{"CV"}, the leave-one-out sum of squared prediction +errors. Matches \code{\link{fit_gwr_model}}'s default. When +observations share a location the search leaves out whole locations +whichever is asked for; see \strong{Observations that share a +location}.} \item{max_models}{Refuse the call if the sweep would exceed this many model fits. Default 200, which admits up to 19 candidates.} -\item{dmat_max_n}{Precompute and reuse an \code{n} x \code{n} distance -matrix when \code{n} is at most this. Default 2000 (about 32 MB). Set to 0 -to disable.} +\item{dmat_max_n}{Not used. The sweep takes its distances window by +window and builds no \code{n} x \code{n} distance matrix, so a fixed +bandwidth works at any \code{n}. The argument is accepted so that calls +written with it run.} -\item{quiet}{Discard GWmodel's progress output. Default \code{TRUE}, because -GWmodel writes it with bare \code{cat()} that no \code{suppressMessages()} -can silence, and emits one block per candidate model, so it scales with the -square of the candidate count. Set \code{FALSE} to watch a long sweep -progress.} +\item{quiet}{Print no progress. Default \code{TRUE}. With \code{FALSE} one +line is written (with \code{cat()}) as each model is fitted, to watch a +long sweep progress.} \item{.engine}{Internal; injectable backend used for testing.} } \value{ An object of class \code{gwr_model_selection}, a list with: -\code{best} (character vector of the selected predictors); +\code{best} (character vector of the selected predictors, the model with +the lowest criterion; \code{character(0)} when that is the model without +predictors); \code{table} (ranked data.frame of every model evaluated, with columns -\code{rank}, \code{n_vars}, \code{variables} and \code{criterion}; -\code{criterion} is \code{NA}, and the model ranked last, where GWmodel -could not evaluate it or where AICc is undefined because the model's +\code{rank}, \code{n_vars}, \code{variables}, \code{criterion} and +\code{delta}, the criterion minus the best model's; the model without +predictors is the row \code{}; +\code{criterion} is \code{NA}, and the model ranked last, where it +could not be evaluated or where AICc is undefined because the model's effective number of parameters \eqn{tr(S)} is not below \eqn{n - 2}, which raises a warning); +\code{within_2} (the rows of \code{table} whose \code{delta} is at most +2) and \code{smallest_within_2} (the predictors of the smallest model +among them); \code{criterion} (label for the criterion actually read, noting when it had to be located positionally); \code{criterion_by_name} (logical: whether that column was found by @@ -97,16 +108,28 @@ a script on this field instead of on the label); candidate set the sweep ran over, both echoed by \code{print()}); \code{bandwidth}, \code{bandwidth_source}, \code{adaptive} and \code{kernel} (the smoothing held fixed across the sweep, and where it -came from); -\code{n_obs}, \code{n_models}, \code{used_dmat}; and \code{raw} -(GWmodel's unmodified return: the two-element list of its model list and -its diagnostic table). +came from: \code{"supplied"}, or the criterion's name followed by +\code{"search on the full model"}, the criterion being +\code{"leave-one-location-out CV"} when observations share a location); +\code{bandwidth_search} (what the search scored, as +\code{\link{fit_gwr_model}} keeps it; \code{NULL} when the bandwidth was +supplied); +\code{n_obs}, \code{n_models} (the rows of \code{table}), +\code{used_dmat} (always \code{FALSE}); and \code{raw} +(the forward sweep in the layout \code{GWmodel::gwr.model.selection()} +returns: the two-element list of its model list and its diagnostic +table, without the model that has no predictors). } \description{ -Wraps \code{GWmodel::gwr.model.selection()}, which grows a GWR model one -predictor at a time and scores every intermediate model with a corrected -Akaike information criterion. GWmodel returns two loosely-coupled lists; -this function returns a ranked table. +Grows a GWR model one predictor at a time and scores every intermediate +model with a corrected Akaike information criterion, the sweep +\code{GWmodel::gwr.model.selection()} defines, and returns a ranked table +with each model's distance from the best. The model without predictors is +scored too. Every model is fitted by the package's own local solve (see +\code{\link{fit_gwr_model}}, \strong{The local solve}), so a candidate +that is constant inside some windows, a regional indicator say, is scored +on what those windows do estimate and neither stops the sweep nor scores +as rounding error. } \section{What this optimises, and what it does not}{ @@ -121,7 +144,7 @@ the one to trust when the answer matters. When the two disagree, the disagreement is itself informative. It usually means a candidate is predictive only locally. -Two further limitations follow from the method itself: +One further limitation follows from the method itself: \itemize{ \item \strong{One bandwidth for every model.} Comparing criteria across @@ -131,37 +154,68 @@ optimal for a one-predictor model. This is how the method is defined (Lu et al. 2014); it is not an implementation shortcut. Refit the selected model with \code{bandwidth = NULL} to re-optimise once the variable set is settled. -\item \strong{The null model is never evaluated.} The sweep starts from -one predictor, so the result always names at least one. It cannot tell -you that none of the candidates help. } } +\section{The model without predictors, and the gaps}{ + +The forward sweep starts from one predictor, so by itself it always names +at least one, whether or not any candidate helps. The model without +predictors, a local mean at the sweep's bandwidth, is therefore scored as +well and ranked with the others as \code{}. When it ranks first, +\code{best} is \code{character(0)}: no candidate improves on it. + +The \code{delta} column of \code{table} is each model's criterion minus +the best one's. Differences of AICc below about 2 do not separate two +models (Burnham and Anderson 2002), so \code{within_2} lists the models +that close to the best and \code{smallest_within_2} names the one among +them with the fewest predictors, which is the one to prefer when several +are that close. \code{best} is still the model with the lowest criterion. +} + +\section{Observations that share a location}{ + +When rows of \code{data_sf} have the same coordinates, the bandwidth +search leaves out whole locations, for either \code{bw_approach} (see +\code{\link{fit_gwr_model}}, \strong{Observations that share a +location}); \code{bandwidth_source} then reads +\code{"leave-one-location-out CV search on the full model"}. The models +are still ranked by AICc, which counts the rows at one location as +independent, so the gaps overstate what a predictor adds when a location +has an effect of its own; a warning of class +\code{"spatialkit_gwr_repeated_locations"} says so with the counts. A +model whose fit reproduces the mean of the observations at each location +(every such model scores the same, whatever its predictors) has criterion +\code{NA} and is listed last, as is one with a term that no local window +can estimate; a warning names them. +} + \section{Cost}{ The sweep fits \code{p * (p + 1) / 2} GWR models for \code{p} candidates -(55 at p = 10, 210 at p = 20), each over all \code{n} locations. +(55 at p = 10, 210 at p = 20), and the one without predictors, each over +all \code{n} locations. \code{max_models} stops the call before it runs for hours. } \section{Using $raw with GWmodel directly}{ -\code{raw} is GWmodel's own \code{list(model.list, GWR.df)}, so its two -elements have to be unpacked before GWmodel's own helpers will take them: -\code{GWmodel::gwr.model.view()} takes \code{(DeVar, InDeVars, model.list)}, -so the call is +\code{raw} has the layout of GWmodel's own \code{list(model.list, GWR.df)}, +so its two elements have to be unpacked before GWmodel's helpers will take +them: \code{GWmodel::gwr.model.view()} takes +\code{(DeVar, InDeVars, model.list)}, so the call is \preformatted{ GWmodel::gwr.model.view(sel$response_var, sel$candidate_vars, sel$raw[[1]]) } Pass \code{sel$raw[[1]]}, not \code{sel$raw}. The diagnostic table is -\code{sel$raw[[2]]}, an unlabelled numeric matrix whose columns are -\code{bandwidth}, \code{AIC}, \code{AICc}, \code{RSS} in that order; the -\code{criterion} column of \code{$table} is its third column. +\code{sel$raw[[2]]}, a numeric matrix whose columns are +\code{bandwidth}, \code{AIC}, \code{AICc}, \code{RSS} in that order (and +are named so); the \code{criterion} column of \code{$table} is its third +column. } \examples{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +if (requireNamespace("sp", quietly = TRUE)) { library(sf) set.seed(1) n <- 80 @@ -172,13 +226,17 @@ if (requireNamespace("GWmodel", quietly = TRUE) && ) dat$z <- 2 * dat$a - dat$b + rnorm(n, 0, 0.5) sel <- gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 30) - print(sel) # every model tried, by AICc + print(sel) # every model tried, by AICc, with the gaps print(sel$best) # the winning predictor set: a and b, not noise fit <- fit_gwr_model(dat, "z", sel$best) fit } } \references{ +Burnham, K. P. and Anderson, D. R. (2002). \emph{Model Selection and +Multimodel Inference: A Practical Information-Theoretic Approach}, 2nd +edition. Springer. + Lu, B., Harris, P., Charlton, M. and Brunsdon, C. (2014). The GWmodel R package: further topics for exploring spatial heterogeneity using geographically weighted models. \emph{Geo-spatial Information Science} @@ -189,17 +247,17 @@ geographically weighted models. \emph{Geo-spatial Information Science} cross-validated counterpart, \code{\link{fit_gwr_model}} to fit the selected model. -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/harmonize_crs.Rd b/man/harmonize_crs.Rd index 92916113..cb3de5a9 100644 --- a/man/harmonize_crs.Rd +++ b/man/harmonize_crs.Rd @@ -39,7 +39,7 @@ When one input carries no CRS, the same lon/lat heuristic identical data in the same place: coordinates that look like degrees are taken as EPSG:4326 and \strong{reprojected} to the other object's CRS (or \code{target_crs}); coordinates that do not are \emph{stamped} with -\code{\link[sf:st_crs]{sf::st_set_crs()}}, which relabels without moving them. Either way the +\code{\link[sf:st_set_crs]{sf::st_set_crs()}}, which relabels without moving them. Either way the assumption is announced with a warning. } \examples{ @@ -52,10 +52,10 @@ c(a = st_crs(h$a)$epsg, b = st_crs(h$b)$epsg) st_crs(h$a) == st_crs(h$b) } \seealso{ -Other spatial data preparation: -\code{\link{clip_target_for}()}, -\code{\link{coerce_to_points}()}, -\code{\link{ensure_projected}()}, -\code{\link{prep_model_data}()} +Other spatial data preparation: +\code{\link[=clip_target_for]{clip_target_for()}}, +\code{\link[=coerce_to_points]{coerce_to_points()}}, +\code{\link[=ensure_projected]{ensure_projected()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{spatial data preparation} diff --git a/man/kriging_adequacy.Rd b/man/kriging_adequacy.Rd index a7223303..8371ac08 100644 --- a/man/kriging_adequacy.Rd +++ b/man/kriging_adequacy.Rd @@ -23,7 +23,13 @@ kriging_adequacy( \item{assigned_points_sf}{Points with a cell identifier column, as \code{\link{assign_features_to_polygons}()} returns.} -\item{response_var}{The response column.} +\item{response_var}{The response column: numeric or logical. A logical +column is kriged as 0/1, so its cell mean is a share. Any other class +(a factor, an ordered factor, character, a date) is an error naming the +column and its class, and is never converted: a factor's level codes are +an arbitrary relabelling, and kriging them gave a variogram, kriged +estimates and plain means that all changed with the order of the +levels. For a category, pass an indicator (\code{x == "level"}).} \item{cells_sf}{The cell polygons, with the matching ID column. A layer with no CRS is taken to be in the points' CRS (and points with none in @@ -74,8 +80,9 @@ proportion. Default 1000.} An \code{sf} object of class \code{"kriging_adequacy"}, one row per cell with the cell geometry and: the ID column, \code{n} (points in the cell), \code{mean} (the plain mean), \code{se} (its naive standard -error), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, -\code{kr_exceeds_design}, \code{kr_shift} and \code{kr_n_used} (how many +error), \code{plain_var} (the plain mean's error variance under the +variogram), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, +\code{kr_gain}, \code{kr_shift} and \code{kr_n_used} (how many locations the cell was kriged from; \code{NA} for a cell left out). Attributes: \code{variogram} (the model frame), \code{sill}, \code{nugget}, @@ -85,9 +92,16 @@ range was refused, from \code{sac}; \code{NA} when it was identified), \code{zscore_var}, \code{zscore_mean}, \code{rmse}, \code{n_pred}, \code{k}, \code{method}), \code{nmax}, \code{n_points} (the points used), \code{n_locations} (the distinct locations among them, which -the kriging used) and \code{cells_left_out} (counts of cells left out, +the kriging used), \code{cells_left_out} (counts of cells left out, named \code{shape} for \code{max_box_ratio} and \code{size} for -\code{max_neighbours}). +\code{max_neighbours}) and \code{replicates} (\code{NULL} when no two +points share a location; otherwise a list with \code{n_points}, the +points that share one, \code{within_var}, their pooled within-location +variance, \code{df}, its degrees of freedom, \code{nugget}, the +variogram's, \code{nugget_used}, the larger of the two, which is the +error variance a location seen once is kriged with, and +\code{above_nugget}, \code{TRUE} when the replicate variance exceeds +the variogram's nugget). } \description{ \code{\link{summarize_by_cell}()} aggregates by plain means inside cell @@ -98,10 +112,9 @@ having on a given layer is a question with a measurable answer, and this function measures it, changing no cell value: for every cell it reports the block-kriging estimate and variance implied by a fitted variogram, that variance as a share of the variance the cell's mean would have with -no data at all, and, where the cell has points, -whether it exceeds the design-based variance of the plain mean, -\eqn{s^2/n}; and it scores the variogram itself by blocked -cross-validation. +no data at all, and, where the cell has points, the error variance of its +plain mean under the same variogram and the share of that variance kriging +removes; and it scores the variogram itself by blocked cross-validation. } \section{Reading the columns}{ @@ -123,15 +136,55 @@ not reach comes out at or above its prior variance and reads 1. A cell at 0.05 is well determined; a cell at 0.8 is mostly prior. \code{NA} when the model is a pure nugget, where a cell mean has no prior variance to be a share of.} -\item{\code{kr_exceeds_design}}{\code{TRUE} where the kriging variance is -larger than \eqn{s^2/n} from the cell's own points: kriging is not -earning its keep there, and that is said per cell instead of -globally. \code{NA} for cells with fewer than two points, where -\eqn{s^2} does not exist.} -\item{\code{kr_shift}}{The kriged estimate minus the plain mean, in -units of the plain mean's standard error (\code{NA} where that is not -defined). How much the aggregator would move the value, against the -precision the value has.} +\item{\code{plain_var}}{The error variance of the cell's plain mean as +an estimate of the cell's average, under the same variogram and the +same discretisation of the cell as \code{kr_var}: +\eqn{a' C a - 2 a' \bar c(B) + \bar C(B,B)}, with \eqn{a} the plain +mean's weights on the cell's observations, \eqn{C} their covariances +(the nugget on the diagonal), \eqn{\bar c(B)} their covariances with +the cell and \eqn{\bar C(B,B)} the covariance within it. It is the +model's counterpart of \code{se^2}. \eqn{s^2/n} is the variance the +plain mean would have if the cell's points were independent draws; +under spatial correlation it understates the error, most where a +cell's points sit close together, so \code{se^2 / plain_var} below 1 +says the naive standard error is too small if the variogram is right. +Defined from one point up. \code{NA} for a cell with no point and for +a cell left out of the kriging.} +\item{\code{kr_gain}}{\code{1 - kr_var / plain_var}: the share of the +plain mean's error variance that kriging removes in the cell. Both +variances come from the one variogram, so the gain does not move when +sill and nugget are multiplied by a constant (unless locations are +repeated, whose replicate variance is read off the data and does not +scale with the model). It is at least 0: the +kriging neighbourhood always holds the cell's own points, the plain +mean is one unbiased combination of them, and kriging is the best +such combination. It is what the variogram expects, not what +happened: read it beside \code{attr(, "cv")$zscore_var}, which says +whether the variogram's variances are the right size. \code{NA} +where \code{plain_var} is. \code{kr_var} is not compared with +\eqn{s^2/n}. That comparison +sets a variance from the model against one from the cell's own +spread, so it moves with the fitted sill: the same data with the same +kriged estimates put 4, 27 and 67 of 70 cells above as sill and +nugget were multiplied by 1/3, 1 and 3. And it does not mark cells +where kriging fails to pay: against known cell averages on simulated +fields (eight runs, clustered and uniform layouts, estimated and true +variograms) kriging cut the plain mean's error by 20--53 percent in +the cells above and by 27--60 percent in the rest.} +\item{\code{kr_shift}}{The kriged estimate minus the plain mean, over +the standard deviation the variogram gives that difference, +\code{sqrt(plain_var - kr_var)} (the kriging error is uncorrelated +with the difference, so the two variances subtract). Under the right +variogram it has variance 1: about 32 percent of cells beyond 1 and 5 +percent beyond 2. More than that says the plain means and the +variogram disagree, so the counts \code{print()} gives are a check of +the variogram on the cells themselves, beside the cross-validation +statistic. In units of the naive standard error \eqn{s/\sqrt{n}} +the same shift has a variance of 1.4--8.4 on clustered layouts, so +counts beyond 1 and 2 in that unit overstate the disagreement. +\code{NA} for a cell with no point, and where the two variances agree +to within a ten-thousandth, which is where kriging returns the plain +mean.} } } @@ -166,18 +219,32 @@ kriged from all the others. \section{What it said about block kriging as an aggregator}{ -On the same simulated fields, with 16, 36 and 64 square cells: under -uniform sampling the kriged and plain cell means differed by more than -one standard error in 11--24 percent of cells and by more than two in -0--7 percent, the kriging variance exceeded \eqn{s^2/n} in 10--26 percent -of populated cells, and at most one cell was empty. Under clustered -sampling (eight clusters of 60-unit spread) the two aggregators parted: -shifts above one standard error in 34--63 percent of cells and above two -in 9--25 percent, the kriging variance below \eqn{s^2/n} in only -13--52 percent of populated cells, and 3--27 of the cells empty, each with -a kriged estimate and variance where the plain mean has nothing. -So a block-kriging aggregator earns its place on clustered layers and -rarely on uniform ones, and this function says which kind a layer is. +On the same simulated fields, with 16, 36 and 64 square cells, under +uniform sampling and under clustered sampling (eight clusters of 60-unit +spread), eight draws each, with the true variogram and with the estimated +one (96 runs, 2,978 cells with points among them). \code{kr_var} was +below \code{plain_var} in every such cell, and \code{kr_gain} ran from +0.14 to 0.86 (median 0.48 uniform, 0.52 clustered). Against the true +cell averages kriging cut the plain mean's squared error by 54--56 +percent (its RMSE by 33 percent) on both layouts, where mean +\code{kr_var} over mean \code{plain_var} predicted 55--58 percent. In +the third of cells with the lowest \code{kr_gain} the cut in squared +error was 39--49 percent and in the third with the highest 59--66 +percent, in all four combinations of layout and variogram, so the column +ranks cells by what kriging buys. \code{kr_shift} had a mean square of +0.99--1.10, with 33--36 percent of cells beyond 1 and 4--6 percent beyond +2. + +What the layout changed was the naive standard error and the empty cells. +Under uniform sampling \eqn{s^2/n} was below \code{plain_var} in 52--57 +percent of cells with two or more points (median ratio 0.88--0.96), and at +most two cells were empty. Under clustered sampling it was below in +76--98 percent (median ratio 0.19--0.58), and 1--5 of 16 cells, 8--17 of +36 and 23--36 of 64 were empty, each with a kriged estimate and variance +where the plain mean has nothing. So on these fields kriging removed +about half of the plain mean's error variance on either layout; +clustering decides how far the naive standard error can be trusted and +how many cells have no plain mean at all. } \section{What this needs}{ @@ -191,9 +258,10 @@ model whose range was not identified (an \code{NA} estimate with the model attached) is used with a warning that says why it was refused, and the reason is kept as \code{attr(, "rejected_reason")}: a range past the fitted lags means the sill was never reached and the ratios rest on an -extrapolation; a fit that did not converge stopped wherever the optimiser -halted; a variogram that falls with distance, or a range below the -shortest lag, describes the data poorly at some lags. +extrapolation; a variogram that falls with distance, or a range below the +shortest lag, describes the data poorly at some lags; and a response in +which \code{estimate_sac_range()} found no spatial structure comes with a +pure-nugget model, which gives kriging no correlation to use. The model has to be of the response itself. A variogram of residuals (\code{estimate_sac_range(predictor_vars = ...)}, \code{attr(, @@ -243,18 +311,37 @@ cross-validation therefore use one observation per location, the mean of its replicates, with a warning; \code{n} and \code{mean} still count every point. How much of the nugget \eqn{c_0} a mean of \eqn{m} replicates keeps is read off the replicates: their pooled within-location variance -\eqn{s_w^2}, capped at \eqn{c_0}, is the part that differs from visit to -visit and averages down, and the rest is micro-scale variation the visits -share, so the mean carries error variance \eqn{c_0 - s_w^2 + s_w^2/m}. -That goes to \pkg{gstat} as a known measurement error (its -\code{weights}) on the model with the nugget set to zero. For replicates -that differ only by measurement error this is exactly the kriging of every -observation, and for identical replicates it is the kriging of one; a -location seen once is kriged as before. In the cross-validation a -location is held out whole, under the fold of its first row, and its -error variance is part of its standardised error. A cell or held-out -location \pkg{gstat} still cannot krige is reported \code{NA} with a -warning, and \code{print()} says how many. +\eqn{s_w^2} is the part that differs from visit to visit and averages +down, and what the nugget holds beyond it is micro-scale variation the +visits share, so the mean carries error variance +\eqn{\max(c_0 - s_w^2, 0) + s_w^2/m}. That goes to \pkg{gstat} as a known +measurement error (its \code{weights}) on the model with the nugget set +to zero. For replicates that differ only by measurement error this is +exactly the kriging of every observation, and for identical replicates it +is the kriging of one. \code{plain_var} uses the same error variances: +the observations a cell has at one location share the micro-scale part +and average the rest. + +When \eqn{s_w^2} is above \eqn{c_0} the replicates show more variation +between visits than the model has room for (with a zero nugget, any at +all). The replicate variance is then used as it is: a mean of \eqn{m} is +kriged with error variance \eqn{s_w^2/m}, and a location seen once with +\eqn{s_w^2} where the model gives it \eqn{c_0}. Capping it at +\eqn{c_0} would krige the means as more exact than their replicates show +them to be: on ten simulated layers of 200 stations visited twice with a +measurement variance of 0.5, under the field's own variogram with no +nugget, the cross-validation statistic reads 2.96--4.42 with the cap and +0.84--1.15 without it. The warning then carries the class +\code{"spatialkit_replicate_var_above_nugget"} and both numbers, which +\code{attr(, "replicates")} records and \code{print()} repeats. The +replicate variance is an estimate (its degrees of freedom are in the +warning and the record), and the variogram still says \eqn{c_0}: refit +it with a nugget of at least \eqn{s_w^2}. + +In the cross-validation a location is held out whole, under the fold of +its first row, and its error variance is part of its standardised error. +A cell or held-out location \pkg{gstat} still cannot krige is reported +\code{NA} with a warning, and \code{print()} says how many. } \examples{ @@ -281,12 +368,13 @@ Wiley. (Block kriging, chapter 3; cross-validation of the kriging variance, section 2.6.4.) } \seealso{ -Other aggregation: -\code{\link{assign_features_to_polygons}()}, -\code{\link{determine_optimal_levels}()}, -\code{\link{resolution_profile}()}, -\code{\link{select_resolution}()}, -\code{\link{summarize_by_cell}()}, -\code{\link{summary.resolution_profile}()} +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} } \concept{aggregation} diff --git a/man/make_folds.Rd b/man/make_folds.Rd index 41df84f0..2990677a 100644 --- a/man/make_folds.Rd +++ b/man/make_folds.Rd @@ -7,7 +7,8 @@ make_folds( points_sf, k, - method = c("random_kfold", "block_kfold", "buffered_loo", "leave_location_out", "nndm"), + method = c("random_kfold", "block_kfold", "buffered_loo", "leave_location_out", "nndm", + "knndm"), seed = NULL, block_nx = NULL, block_ny = NULL, @@ -25,7 +26,8 @@ make_folds( phi = NULL, drop_empty_blocks = TRUE, blocks = NULL, - balance_tol = 3 + balance_tol = 3, + max_test = NULL ) } \arguments{ @@ -42,23 +44,36 @@ and is required except for the two leave-one-out methods. A fraction, \code{NA} or a vector is an error, because a non-integer used to truncate silently and leave the last rows in no test set at all. Not every method honours it. \code{"buffered_loo"} and \code{"nndm"} are -leave-one-out schemes and always return \code{k = n} regardless of what +leave-one-out schemes and always return one fold per held-out point +(\code{k = n}, or \code{max_test} when that is given) regardless of what was asked for; \code{"block_kfold"} lowers it when the grid yields fewer than \code{k} non-empty blocks, and \code{"leave_location_out"} lowers it -when there are fewer than \code{k} distinct groups. \code{k = 1} is -raised to 2 by \code{"random_kfold"}, \code{"block_kfold"} and -\code{"leave_location_out"}, since one fold has no training set. Read +when there are fewer than \code{k} distinct groups. \code{"random_kfold"} +and \code{"knndm"} lower it only when the layer has fewer than \code{k} +rows. \code{k = 1} is +raised to 2 by \code{"random_kfold"}, \code{"block_kfold"}, +\code{"leave_location_out"} and \code{"knndm"}, since one fold has no +training set. Read the \code{k} element of the returned list, and do not assume the -requested value. A -reduction is written to the package log and raises no R warning, so -\code{tryCatch(warning = )} will not see it and \code{suppressWarnings()} -will not hide it.} +requested value; \code{params$k_requested} keeps the value asked for. +Returning fewer folds than asked raises a warning of class +\code{"spatialkit_k_reduced"}, whose message gives both counts, the +reason and a setting that works; the condition carries them as +\code{k_requested} and \code{k}, so +\code{tryCatch(spatialkit_k_reduced = )} or +\code{withCallingHandlers()} can act on it without reading the text. +(Before this version a reduction was a log line only.)} \item{method}{One of \code{"random_kfold"}, \code{"block_kfold"}, -\code{"buffered_loo"}, \code{"leave_location_out"} or \code{"nndm"}. See -\strong{Details} for what each one does and when it is appropriate.} +\code{"buffered_loo"}, \code{"leave_location_out"}, \code{"nndm"} or +\code{"knndm"}. See \strong{Details} for what each one does and when it +is appropriate.} -\item{seed}{Optional integer RNG seed.} +\item{seed}{Optional integer RNG seed. \code{"nndm"} is deterministic and +reads it only to draw the \code{max_test} subset; \code{"buffered_loo"} +likewise. \code{"knndm"} uses it for the random partition among its +candidates, for ties in the packing, and above 4,000 points for the +k-means starts, so its folds are reproducible only with a seed.} \item{block_nx, block_ny}{Optional grid dimensions for block_kfold, each a single whole number >= 1. Give both, or give one and the other is @@ -82,10 +97,21 @@ block size that matters for leakage is the autocorrelation range, which is what \code{block_size} and \code{auto_range} control.} \item{block_size}{Optional positive numeric minimum block edge length, -\strong{in the units of the CRS the folds are built in}. When supplied, -grid dimensions are clamped so that every block is at least this wide and -tall. Takes precedence over \code{block_nx}/\code{block_ny} and -\code{block_multiplier}. +\strong{in the units of the CRS the folds are built in}. Takes +precedence over \code{block_nx}/\code{block_ny} and +\code{block_multiplier}. When supplied, a whole number of blocks is +fitted across each axis of the extent: as many as leave every block at +least this long on that axis. On an axis at least as long as +\code{block_size} the blocks built are therefore from one to just under +two times this size. An axis shorter than \code{block_size} cannot +hold a block that long: a single row or column spans it, and its blocks +are as long as the extent on that axis, which is less than the size +asked (a 39.8 km by 5 km extent with \code{block_size = 10000} gets +three blocks 13.3 km wide and 5 km tall). \code{params$block_width} and +\code{params$block_height} record what was built. A size that leaves +fewer than \code{k} blocks holding points returns that many folds, +with a warning (see \code{k}); one that leaves a single block is an +error. Both name the largest size that still gives \code{k} folds. Which CRS that is depends on the input. Projected input is used as it stands, so \code{block_size} is in your own CRS's units. Geographic @@ -118,11 +144,17 @@ et al. (2017) and what \pkg{blockCV} (Valavi et al. 2019) automates. times that parameter for an exponential fit), so its blocks are larger than \pkg{blockCV}'s from the same variogram. When no range is identified, the geometric grid is used instead, with a warning that -gives the reason. An identified range above half the extent in both -directions leaves room for a single block, and \code{make_folds()} then -stops with an error naming the size, rather than return one fold with -an empty training set: pass a smaller \code{block_size}, or use -\code{method = "nndm"}.} +gives the reason. Range-sized blocks do not fit every layout. On a +square extent at \code{k = 5} a range up to a third of the side gives +five folds; up to half, a 2 x 2 grid and four folds, returned with the +\code{"spatialkit_k_reduced"} warning; and above half the extent in +both directions there is room for a single block, and +\code{make_folds()} stops with an error naming the size, rather than +return one fold with an empty training set. The warning and the error +name the largest block size that still gives \code{k} folds on this +layout and how far below the range it is; \code{method = "nndm"} is the +design that does not depend on a block size. The message printed when +the range is used states the grid and the block size built.} \item{range_frac}{Passed through to \code{estimate_sac_range()} when \code{auto_range = TRUE}. A fitted range beyond the longest lag the @@ -146,7 +178,8 @@ sites it has already seen, which random k-fold reports as excellent performance.} \item{prediction_points}{Optional \code{sf} layer of the locations you -actually intend to predict onto. Required for \code{method = "nndm"}. +actually intend to predict onto. Required for \code{method = "nndm"} and +\code{method = "knndm"}. The grid from \code{\link{predict_surface}()} is the natural choice; a non-POINT layer (grid cells, polygons) is reduced to representative points first, so the target distances are point-to-point. A point-to-polygon @@ -177,7 +210,12 @@ warned about.} data any fold's training set may be reduced to by neighbour exclusion. Default \code{0.5}, as in \code{CAST::nndm()}. Where it binds, the distance matching stops short and the cross-validation stays optimistic; -see \strong{Details}.} +see \strong{Details}. For \code{method = "knndm"}: the smallest fraction +of the data a fold may leave for training, so a candidate whose largest +fold holds more than \code{1 - min_train} of the rows is set aside (the +\code{maxp = 0.5} of \code{CAST::knndm()} is \code{min_train = 0.5}). +Equal folds leave \code{1 - 1/k} of the data, so a value above that is +an error.} \item{phi}{For \code{method = "nndm"}: the distance up to which the two nearest-neighbour distance distributions are matched, in the CRS the @@ -216,7 +254,28 @@ which the folds are reported as imbalanced, with a warning (an R condition, also logged) that names both counts. \code{Inf} disables the check. The value is the tolerance of a check, not a target the packing aims for: see \strong{Fold balance} below for what the packing can and -cannot do. \code{params$balance_ratio} carries the ratio achieved.} +cannot do. \code{params$balance_ratio} carries the ratio achieved. +For \code{"knndm"} it is a limit and not a check: a candidate whose +largest fold holds more than \code{balance_tol} times the points of its +smallest is set aside, so the folds returned are always within it.} + +\item{max_test}{For \code{"buffered_loo"} and \code{"nndm"}: optional +whole number of at least 2. Folds are built for a random subset of that +many held-out points (drawn under \code{seed}), and every row stays +available for training, so each fold returned is the fold the full +design has for that point. The model is then refitted \code{max_test} +times and not \code{n} times, and the folds hold +\code{4 * n * max_test} bytes of row indices in place of +\code{4 * n^2}, which lets \code{"buffered_loo"} run on layers its +storage limit otherwise refuses. It does not lift the 5,000-row limit of +\code{"nndm"}, whose cost is the matching itself; for that there is +\code{"knndm"}. Rows that are not held out have \code{NA} in +\code{assignment$fold}. For \code{"nndm"} the matching still runs over +all \code{n} points and \code{params} describes all of them. +\code{\link{area_of_applicability}()} needs every training row in a +test fold and refuses a subset. Default +\code{NULL}: every point is held out once. An error for the k-fold +methods, whose number of folds is \code{k}.} } \value{ A list with method, k, folds, assignment, params. The @@ -261,12 +320,45 @@ For \code{"block_kfold"}, \code{params} carries a \code{params$blocks_supplied} that says whether the blocks came from \code{blocks} or from a grid built here, and \code{params$boundary_supplied} whether a \code{boundary} was given. -Every method's \code{params} carries +\code{params$block_width} and \code{params$block_height} are the width +and height of the grid cells built, before any clipping to a +\code{boundary} (\code{NA} for supplied \code{blocks}); they are what +\code{block_size} turned into: at least that size on an axis long +enough to hold it, and the whole extent on an axis that is not (see +\code{block_size}). +Every method's \code{params} carries \code{params$k_requested}, the +\code{k} that was asked for (\code{NA} when none was given), beside +the \code{k} returned, and \code{params$row_probe}, a small sample of row IDs and coordinates that every \code{cv_*()} compares against the data it is handed, so folds built from a different layer of the same size are refused, never applied silently. +For \code{"knndm"}, \code{params} carries \code{chosen} +(\code{"random"} or \code{"clusters"}), \code{n_clusters} (the number of +clusters packed into the folds; \code{NA} for the random partition), +\code{clustering} (\code{"ward"} or \code{"kmeans+ward"}; \code{NA} when +no cluster count was tried), \code{candidates} (a data frame with one row +per candidate, the random partition first: \code{candidate}, +\code{n_clusters}, \code{largest_fold}, \code{balance_ratio}, +\code{admissible} and \code{W}, which is \code{NA} for a candidate set +aside), \code{wasserstein}, \code{wasserstein_random} and +\code{wasserstein_loo} (the Wasserstein distance to the target of the +folds returned, of the random partition among the candidates and of +plain leave-one-out, in distance units), \code{fold_sizes}, +\code{balance_ratio}, \code{target_distances} and +\code{realised_distances} (one per prediction point, and one per row: +its distance to the nearest point of another fold) with their medians +and means, and the diagnostics \code{"nndm"} reports under the same +names: \code{max_ecdf_excess}, \code{max_ecdf_deficit}, +\code{loo_ecdf_deficit}, \code{ecdf_deficit_tol}, +\code{target_separated} and \code{target_out_of_reach}, with +\code{short_of_target} for the opposite case (see \strong{Details}). + +With \code{max_test}, \code{"buffered_loo"} and \code{"nndm"} return +that many folds, \code{assignment$fold} is \code{NA} for the rows not +held out, and \code{params$max_test} records the value. + For the methods that work in projected space, \code{params} also carries a \code{crs} element naming the CRS the folds were built in (an \code{"EPSG:code"} string where there is one, otherwise the CRS's input @@ -281,8 +373,8 @@ fold and in no \code{assignment} row. } \description{ Builds train/test splits by random k-fold, spatial block k-fold, -leave-location-out, buffered leave-one-out or nearest-neighbour distance -matching (NNDM) leave-one-out. +leave-location-out, buffered leave-one-out, nearest-neighbour distance +matching (NNDM) leave-one-out or its k-fold version (kNNDM). } \details{ For \code{block_kfold}, the default grid sizing is purely geometric and @@ -291,7 +383,13 @@ smaller than the autocorrelation range, spatially correlated observations leak across folds and CV metrics become optimistic. Use \code{block_size} to set a minimum block edge length (in CRS units), or set \code{auto_range = TRUE} to estimate the range from an empirical -variogram and enforce it automatically. +variogram and enforce it automatically. When a response is given and the +blocks come out smaller than the estimated range, the warning says what +range-sized blocks would yield on this layout before recommending them: +the setting and the grid it builds when that gives \code{k} folds, and +otherwise how many folds it gives (or that it leaves a single block), the +largest block size that still gives \code{k} folds, and +\code{method = "nndm"} as the design that needs no block size. \strong{Fold methods.} \code{"random_kfold"} ignores geography entirely and will overstate @@ -334,21 +432,165 @@ And ties in \eqn{G_j^*} are broken by the points' coordinates, not by their row index as in CAST, so the folds do not depend on the order of the rows. -Where neither limit binds, the realised distribution is then never -\emph{more optimistic} than the target: \eqn{G_j^*(r) \le G_{ij}(r)} up to -the granularity of the neighbour distances, which is the property the -method exists to deliver. Beyond \code{phi} no matching is attempted, by +Where neither limit binds, the realised distribution of +\emph{nearest-neighbour distances} is then never shorter than the target: +\eqn{G_j^*(r) \le G_{ij}(r)} up to the granularity of the neighbour +distances, which is the property the method exists to deliver. It is a +statement about the distance to the one nearest training point. A learner +that draws on several neighbours (a forest, a k-nearest-neighbour mean, a +kriging neighbourhood) also depends on how far the second and later +neighbours are, which NNDM does not match, so on clustered samples its +cross-validated error can still read low with the nearest-neighbour +distances matched exactly. Beyond \code{phi} no matching is attempted, by design. \code{min_train} is different: when the prediction locations lie further from the samples than a fold can be made to hold out (clustered samples and a prediction domain well beyond them, the layout NNDM is meant for), it stops the matching early and the realised distances stay -optimistic. \code{params$n_at_min_train} counts the folds that were held +too short. \code{params$n_at_min_train} counts the folds that were held at the floor while still closer than the target allows, and \code{make_folds()} warns when that leaves more than one point's worth of excess at or below \code{phi}. Lower \code{min_train} to match further, or read the cross-validated score as an upper bound on performance at the prediction locations. +The match has a second side. \code{params$max_ecdf_deficit} is the +largest amount by which the target distribution runs above the realised +one, the mirror of \code{params$max_ecdf_excess}: the share of prediction +points within some distance of the data that the folds do not reproduce. +Part of it is the granularity of the matching. Excluding a neighbour +moves a held-out point out to its next remaining neighbour, and on +clustered samples that can be the next cluster, well past the prediction +distances. + +The other part no setting reaches. Excluding neighbours can only lengthen +a held-out distance, so when the prediction points sit \emph{nearer} to +the data than the samples sit to each other (prediction points among the +samples, or a regular sample predicted between its nodes) the folds +returned are plain leave-one-out and are still farther from their +training data than the prediction points are. The cross-validated error +is then pessimistic for those locations: an upper bound on the error +there. \code{params$loo_ecdf_deficit} is the largest amount by which +the target distribution runs above that of plain leave-one-out. When it +exceeds \code{params$ecdf_deficit_tol}, three times +\eqn{\sqrt{1/n + 1/m}} for \eqn{n} folds and \eqn{m} prediction points +(about three times the chance difference between two samples of one +distribution), \code{make_folds()} raises a warning of class +\code{"spatialkit_nndm_out_of_reach"} and sets +\code{params$target_out_of_reach} to \code{TRUE}. + +On small samples no deficit can exceed that tolerance. A deficit is a +difference of two shares, so it is at most 1, and the tolerance is 1 or +more whenever \eqn{nm/(n+m) \le 9}: for nine folds or fewer whatever the +number of prediction points, and for up to eighteen folds with as many +prediction points. There the same warning is raised in one case only, +complete separation: every prediction point nearer to the data than any +sample is to its nearest other sample (a deficit of exactly 1), provided +the two sets are large enough for that ordering to mean something, which +is taken as \code{choose(n + m, n) >= 1000} ways of interleaving them (17 +prediction points for 3 folds, 7 for 6 folds, 4 for 12 folds). +\code{params$target_separated} records the ordering whether or not it +was enough to warn, and the warning's condition carries it as +\code{separated}. With very few samples it can hold for a grid over the +samples' own extent, because a few points hug the box they span; the +folds are then farther than the grid all the same. A partial shortfall +on such a sample (most prediction points nearer than leave-one-out +reaches, not all) is not warned about: the tolerance is 1 or more at +these sizes, which no difference of shares exceeds, so only complete +separation can be reported. Compare +\code{params$target_median} with \code{params$realised_median}. + +\code{params$wasserstein} is the Wasserstein distance between the target +and realised distributions, in distance units, and +\code{params$wasserstein_loo} the same for plain leave-one-out: equal +when nothing was excluded, smaller when the matching helped. + +\strong{kNNDM.} \code{"knndm"} is the k-fold version of that idea +(Linnenbrink et al. 2024): \code{k} folds, and so \code{k} model fits, +whose held-out distances are as close to the same target as a set of +candidates allows. It has no row limit, and is the method to use above +the 5,000 rows \code{"nndm"} takes or when a model is too costly to refit +once per point. It is not an equal of NNDM below that: a fold design has +far fewer degrees of freedom than one exclusion set per point, so the +match is coarser. + +The candidates are a random k-fold partition (the one +\code{"random_kfold"} builds with the same \code{seed}) and, for each of +up to 50 cluster counts spaced evenly on the log scale from \code{k} to +one fewer than the number of distinct locations, the samples clustered on +their coordinates and the clusters merged into \code{k} folds. Few large +clusters give folds that are whole regions, far from their training data; +many small ones approach the random partition. Up to 4,000 points the +clustering is Ward's (\code{stats::hclust(method = "ward.D2")}), cut at +each count. Above that, where the n by n distance matrix it needs is no +longer affordable, k-means first reduces the samples to 4,000 groups +(Lloyd's algorithm from random sample locations, at most ten passes) and +Ward's method is continued from those groups; a count above 4,000 is a +k-means run of its own. \code{params$clustering} says which +(\code{"ward"} or \code{"kmeans+ward"}). Clusters are merged by the packing +\code{"block_kfold"} uses for its blocks, largest first and each to the +fold with the fewest points so far (see \strong{Fold balance}). +\code{CAST::knndm()} merges clusters by a rule of its own, which this was +\emph{not} checked against, so the folds are not expected to equal CAST's. + +Each candidate is scored by the Wasserstein distance \eqn{W} between its +held-out distances (each point's distance to the nearest point of another +fold) and the target distances, and the smallest \eqn{W} is returned. A +candidate is set aside without being scored when its largest fold leaves +less than \code{min_train} of the rows for training or holds more than +\code{balance_tol} times the points of its smallest; the random partition +is always kept. So \code{params$wasserstein} is never above +\code{params$wasserstein_random}, the \eqn{W} of that random partition, +and \code{params$candidates} lists every candidate with its cluster count, +fold sizes and \eqn{W}. \code{params$chosen} is \code{"random"} when no +clustering came closer, which is the right answer for samples spread +evenly over the prediction area. + +Read \eqn{W} against the mean target distance. On 400 points in 12 +clusters predicted onto a grid over their extent (12 draws, 5 and 10 +folds) the folds returned had \eqn{W} at 0.32 of the mean target distance, +against 0.70 to 0.72 for a random partition and 0.01 for \code{"nndm"}. +A 5-nearest-neighbour learner scored 9 to 11 percent high on them, where +random folds scored 23 to 25 percent low and \code{"nndm"} 6 percent low. +On 2,000 points in 40 clusters of unequal size the ratio was 0.07 to +0.10, against 0.56 to 0.59 for a random partition and 0.003 to 0.006 for +\code{"nndm"}; on 30,000 points of that layout it was 0.11 to 0.15, and +on 100,000 points 0.27. So the method removes most of the mismatch of a +random partition and leaves more of it than NNDM does, in either +direction: \eqn{W} has no sign. On 400 evenly spread points the random +partition or one close to it came back and the two scored alike (3.3 and +3.5 percent high). With few folds a random partition is itself farther +than the target, since each fold trains on \code{1 - 1/k} of the points: +at \code{k = 2} on evenly spread points the mean held-out distance was 9 +to 53 percent above the target mean (60 draws of 100 to 1,000 points), +and no candidate is nearer. + +Construction took 2 s at 8,000 points and 10 s at 30,000 with ten folds +(37 s at 100,000) with \pkg{FNN} installed, and three to four times that +without it; it grows with the number of folds. + +Two cases are warned about, each with a condition class. When the +prediction points sit nearer to the data than a sample is to its nearest +other sample, no fold design reaches them, since a held-out point is never +nearer to its training data than that; the test is the one +\code{"nndm"} applies, the warning has the same class, +\code{"spatialkit_nndm_out_of_reach"}, and what comes back is the random +partition or a candidate as fine as one. In the other direction, the +closest candidate can still be +short of the target: prediction points well beyond the samples lie farther +from the data than \code{k} folds of those samples can be held apart. +When the mean held-out distance of the folds returned is below the mean +target distance by more than a quarter of it and by at least half of +\eqn{W} (the test \code{\link{fold_separation}()} words as +\code{"closer"}), \code{make_folds()} raises a warning of class +\code{"spatialkit_knndm_short_of_target"} and sets +\code{params$short_of_target}: the cross-validated error then tends to +read low for those locations. Fewer folds hold out larger regions. +Short of either warning the folds can still differ from the target at +some distances; \code{params$max_ecdf_excess} and +\code{params$max_ecdf_deficit} give the largest difference each way, and +\code{\link{fold_separation}()} reads the folds against the same +prediction points fold by fold. + An earlier version of this package drew one random radius per point from \eqn{G_{ij}} and excluded up to the order statistic \emph{closest} to it, which rounds down half the time: on a two-cluster layout the realised @@ -393,8 +635,9 @@ density of the points. \section{Fold balance}{ -Only \code{"block_kfold"} balances the number of points per fold, and it -does so by packing: blocks are taken largest first and each goes to the +\code{"block_kfold"} and \code{"knndm"} balance the number of points per +fold, and they do so by packing: blocks (for \code{"knndm"}, clusters of +the samples) are taken largest first and each goes to the fold with the fewest points so far, ties broken at random. This is the longest-processing-time rule for multiway partitioning. Measured against the optimum by enumeration (two folds, up to ten blocks, heavy-tailed block @@ -412,6 +655,11 @@ where the geometric grid exceeded 3:1 in 22 percent of cases (median ratio dense, so check \code{params$block_scale} against the autocorrelation range as you would a grid. +\code{"knndm"} chooses its clusters, so for it \code{balance_tol} is a +limit: a clustering whose packing exceeds it is not a candidate, and the +folds returned are within it (\code{params$fold_sizes}, +\code{params$balance_ratio}). + The other methods do not balance point counts. \code{"random_kfold"} is balanced by construction (fold sizes differ by at most one); \code{"buffered_loo"} and \code{"nndm"} hold out one point per fold; @@ -434,8 +682,19 @@ folds$params$block_sizes # points per block; params$fold_blocks packs them # Buffered leave-one-out: neighbours within 100 units excluded from training loo <- make_folds(pts, k = 1, method = "buffered_loo", buffer = 100) + +# Three folds matched to the distances from a prediction grid to the data +grid <- st_make_grid(pts, n = c(10, 10), what = "centers") +km <- make_folds(pts, k = 3, method = "knndm", prediction_points = grid, + seed = 42) +km$params[c("chosen", "n_clusters", "wasserstein", "wasserstein_random")] } \references{ +Linnenbrink, J., Mila, C., Ludwig, M. and Meyer, H. (2024). kNNDM CV: +k-fold nearest-neighbour distance matching cross-validation for map +accuracy estimation. \emph{Geoscientific Model Development} \strong{17}, +5897-5912. \doi{10.5194/gmd-17-5897-2024} + Mila, C., Mateu, J., Pebesma, E. and Meyer, H. (2022). Nearest neighbour distance matching Leave-One-Out Cross-Validation for map validation. \emph{Methods in Ecology and Evolution} \strong{13}, 1304-1316. @@ -455,17 +714,17 @@ folds for k-fold cross-validation of species distribution models. \doi{10.1111/2041-210X.13107} } \seealso{ -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{sac_nugget}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=sac_nugget]{sac_nugget()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/model_metrics.Rd b/man/model_metrics.Rd index e75dbf84..5dd8245f 100644 --- a/man/model_metrics.Rd +++ b/man/model_metrics.Rd @@ -12,7 +12,10 @@ model_metrics(object, ...) \arguments{ \item{object}{A \code{spatial_fit} object.} -\item{...}{Additional arguments passed to predict().} +\item{...}{Additional arguments passed to predict(). The metrics are +computed from one predicted value per row, so \code{draws = TRUE} (a +Bayesian fit) and \code{se.fit = TRUE} (a GWR), with which +\code{predict()} returns a matrix or a list, are refused.} \item{newdata}{Optional sf object for out-of-sample evaluation. If NULL, fitted values are used (in-sample, or out-of-bag for an \code{rf_fit}; @@ -141,28 +144,28 @@ if (requireNamespace("ranger", quietly = TRUE)) { } } \seealso{ -Other model evaluation: -\code{\link{compare_models}()}, -\code{\link{compare_models_cv}()}, -\code{\link{evaluate_insample}()}, -\code{\link{residual_morans_i}()} +Other model evaluation: +\code{\link[=compare_models]{compare_models()}}, +\code{\link[=compare_models_cv]{compare_models_cv()}}, +\code{\link[=evaluate_insample]{evaluate_insample()}}, +\code{\link[=residual_morans_i]{residual_morans_i()}} -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} \concept{model evaluation} diff --git a/man/new_spatial_fit.Rd b/man/new_spatial_fit.Rd index babb5c43..0068aa07 100644 --- a/man/new_spatial_fit.Rd +++ b/man/new_spatial_fit.Rd @@ -123,11 +123,11 @@ c(attempted = cv$n_folds_attempted, succeeded = cv$n_folds_succeeded) \code{\link{cv_spatial}()}, which consumes a custom \code{fit_fn}; \code{\link{fit_rf_model}()} for a worked built-in fitter. -Other model fitting: -\code{\link{fit_bayesian_spatial_model}()}, -\code{\link{fit_gwr_model}()}, -\code{\link{fit_rf_model}()}, -\code{\link{gp_lengthscale_bounds}()}, -\code{\link{prep_model_data}()} +Other model fitting: +\code{\link[=fit_bayesian_spatial_model]{fit_bayesian_spatial_model()}}, +\code{\link[=fit_gwr_model]{fit_gwr_model()}}, +\code{\link[=fit_rf_model]{fit_rf_model()}}, +\code{\link[=gp_lengthscale_bounds]{gp_lengthscale_bounds()}}, +\code{\link[=prep_model_data]{prep_model_data()}} } \concept{model fitting} diff --git a/man/plot.aoa.Rd b/man/plot.aoa.Rd index 2972cef0..69cce270 100644 --- a/man/plot.aoa.Rd +++ b/man/plot.aoa.Rd @@ -33,11 +33,20 @@ derived from: the threshold is the largest training DI inside an outlier fence, so the curve reaches it exactly when no training value was fenced off and runs past it, by the tail the fence removed, when some were. A prediction location outside on a predictor dropped for having no -training variance has \code{DI = Inf}: it counts in the prediction curve, +training variance, or under \code{categorical = "indicator"} on a level no +training row has, has \code{DI = Inf}: it counts in the prediction curve, which then tops out below 1, and the caption says how many are off the axis. A location with a missing predictor (\code{DI = NA}) is neither inside nor outside; it is left out of the curve and the caption counts it. } +\details{ +When location has an index of its own (a \code{gwr_fit}, a +\code{bayesian_fit}, or \code{coords = "yes"}; see +\code{\link{area_of_applicability}()}), the curves and the dashed line are +the predictor index alone. The subtitle then counts three things: the +locations beyond the predictor threshold, those beyond the location +threshold, and those outside the area of applicability, which is either. +} \examples{ if (requireNamespace("ggplot2", quietly = TRUE)) { library(sf) @@ -60,15 +69,15 @@ if (requireNamespace("ggplot2", quietly = TRUE)) { } } \seealso{ -Other plotting: -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.block_size_sweep.Rd b/man/plot.block_size_sweep.Rd index 34d4fa60..9becee88 100644 --- a/man/plot.block_size_sweep.Rd +++ b/man/plot.block_size_sweep.Rd @@ -52,15 +52,15 @@ if (requireNamespace("ranger", quietly = TRUE) && } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.feature_selection.Rd b/man/plot.feature_selection.Rd index 80b3df8b..0b2659a5 100644 --- a/man/plot.feature_selection.Rd +++ b/man/plot.feature_selection.Rd @@ -30,6 +30,13 @@ selection (see the help page's section on that); when a hold-out score was computed (\code{select_on = "split"}) it is drawn as a separate mark at the final step and named in the caption. } +\details{ +With a learner that cannot fit an empty predictor set the first variable +is added without a test and can be dropped at the end +(\code{baseline$first$dropped}). The path drawn is then the one the sweep +walked, with that variable hollow and labelled "dropped at the end", and +the red mark is the selected set, scored without it. +} \examples{ if (requireNamespace("ranger", quietly = TRUE) && requireNamespace("ggplot2", quietly = TRUE)) { @@ -49,15 +56,15 @@ if (requireNamespace("ranger", quietly = TRUE) && } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.gwr_model_selection.Rd b/man/plot.gwr_model_selection.Rd index 8abce81e..8caaba48 100644 --- a/man/plot.gwr_model_selection.Rd +++ b/man/plot.gwr_model_selection.Rd @@ -26,8 +26,7 @@ tie-break. The criterion is in-sample and the caption carries the label was read positionally. } \examples{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE) && +if (requireNamespace("sp", quietly = TRUE) && requireNamespace("ggplot2", quietly = TRUE)) { library(sf) set.seed(1) @@ -43,15 +42,15 @@ if (requireNamespace("GWmodel", quietly = TRUE) && } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.resolution_profile.Rd b/man/plot.resolution_profile.Rd index ae641aba..8406cd24 100644 --- a/man/plot.resolution_profile.Rd +++ b/man/plot.resolution_profile.Rd @@ -10,10 +10,17 @@ \item{x}{A \code{resolution_profile}.} \item{criteria}{Character vector of criteria to draw, any of -\code{"cp"}, \code{"reliability"}, \code{"elbow"}, \code{"moran_z"}, -\code{"wss"}. Default: every one of the four selectable criteria that -is finite at some level. \code{"wss"} is the raw curve behind -\code{"elbow"} and has no selected point.} +\code{"cp"}, \code{"reliability"}, \code{"elbow"}, \code{"loo"}, +\code{"moran_z"}, \code{"wss"}. Default: the first five, each where it +is finite at some level. \code{"cp"}, \code{"reliability"}, +\code{"elbow"} and \code{"loo"} (the leave-one-out error of the +estimate the profile was built for; a profile built without +\code{estimate} has no such column, and a column of that name added +to one is drawn only when named here) are count criteria and get a +selected level and a shaded band. \code{"moran_z"} +is a diagnostic of the cell means and not a count rule (see +\code{\link{select_resolution}()}), and \code{"wss"} is the raw curve +behind \code{"elbow"}: both are drawn as curves with no selected point.} \item{tol}{Passed to \code{\link{select_resolution}()} for the flat region.} @@ -34,6 +41,13 @@ first level the criterion is computable at), because there the bound is choosing, not the criterion. A criterion that is \code{NA} at every level is left out with a log line rather than drawn empty. } +\details{ +A profile whose ladder is one size (\code{obs_per_cell} set to one +number, or the default profile) has one level, set by the size. Each +criterion that is finite there is drawn as one point in its panel, with +no selected level and no band, and the caption says that the size set +the count. +} \examples{ if (requireNamespace("gstat", quietly = TRUE) && requireNamespace("ggplot2", quietly = TRUE)) { @@ -53,15 +67,15 @@ if (requireNamespace("gstat", quietly = TRUE) && } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.sac_range.Rd b/man/plot.sac_range.Rd index 3a61acea..a0e899da 100644 --- a/man/plot.sac_range.Rd +++ b/man/plot.sac_range.Rd @@ -26,8 +26,11 @@ rather than refused. } \details{ Nothing is recomputed: the plot reads the \code{variogram}, -\code{variogram_model}, \code{crs}, \code{directional} and -\code{anisotropy_used} attributes the estimate already carries. The +\code{variogram_model}, \code{crs} and \code{rejected_reason} +attributes the estimate already carries. The variogram is the one over +all point pairs; a result stored by an earlier version, whose range could +be that of the widest of four directions (\code{anisotropy_used} +\code{TRUE}), is titled with its azimuth. The distance axis is in the units of the CRS the variogram was actually fitted in, which \code{estimate_sac_range()} may have chosen itself for lon/lat input. @@ -60,15 +63,15 @@ if (requireNamespace("gstat", quietly = TRUE) && \code{\link{plot.spatial_fit}(type = "variogram")}, which draws the same picture for a fitted model's residuals. -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot.spatial_fit.Rd b/man/plot.spatial_fit.Rd index a5a3647a..59acca2c 100644 --- a/man/plot.spatial_fit.Rd +++ b/man/plot.spatial_fit.Rd @@ -36,10 +36,10 @@ the model absorbed: a residual sill well below the response sill means most of it, two curves that coincide mean none. When both effective ranges were identified over the same point pairs the caption gives the residual sill as a share of the response sill and the two -ranges; when either variogram has no identified range, or the two are -not over the same pairs, the caption says so and compares nothing: a sill the -data never reached is not a number to divide by, and one direction's -sill is not comparable with all directions'. +ranges; when either variogram has no identified range, or the two +are not over the same pairs, the caption says so and compares +nothing: a sill the data never reached is not a number to divide by, +and one direction's sill is not comparable with all directions'. The residual range is expected to come out shorter and the residual sill lower even when the model is right, because residuals of a fitted trend understate the variogram (see @@ -48,10 +48,8 @@ residual-variogram bias"). The distance axis is labelled in the units of the CRS the variogram was actually fitted in, which is not necessarily the fit's own CRS (lon/lat data are projected first). Each curve is the variogram -\code{estimate_sac_range()} returns for its variable: all point pairs, -or, when the all-pairs fit was unusable, the widest of four directions, -which is named with its azimuth (in the title for the residuals, in the -caption for the response). A fit that identified no range says why in +\code{estimate_sac_range()} returns for its variable, which is over +all point pairs. A fit that identified no range says why in the subtitle, since the overlaid model line is then not a fit to believe. Requires 'gstat'.} \item{\code{"coefficients"}}{For a GWR fit only: the local coefficient @@ -60,8 +58,10 @@ reason to fit GWR at all. Locations where the local design is collinear for that term are drawn hollow and grey (\code{mask = TRUE}): for a slope, where the kernel-weighted window's slope condition index (\code{cn_slopes}, predictors -centred in the window) is above 30 or the window is singular, or -where the index with the intercept (\code{cn}) is above 1e6; for +centred in the window) is above 30 or the window is singular; a +predictor far from zero is not masked, because the local solve +centres each window and the index with the intercept (\code{cn}) +does not enter; for the Intercept, where \code{cn} is above 30 (a predictor far from 0 against its local spread makes the local intercept an extrapolation). They are masked because the smooth surface a naive map draws @@ -74,7 +74,7 @@ sequential one.} }} \item{response}{Logical, default \code{TRUE}: for \code{type = - "variogram"}, overlay the response's own variogram. Ignored by the +"variogram"}, overlay the response's own variogram. Ignored by the other types.} \item{term}{For \code{type = "coefficients"}: which local coefficient to @@ -127,15 +127,15 @@ if (requireNamespace("ranger", quietly = TRUE) && \seealso{ \code{\link{coef.gwr_fit}()} for the coefficients themselves. -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot_calibration.Rd b/man/plot_calibration.Rd index fb67c319..aa58b4e8 100644 --- a/man/plot_calibration.Rd +++ b/man/plot_calibration.Rd @@ -50,15 +50,15 @@ plot_calibration(cv) } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_cv_metrics}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot_cv_metrics.Rd b/man/plot_cv_metrics.Rd index 82b4b264..4e98907e 100644 --- a/man/plot_cv_metrics.Rd +++ b/man/plot_cv_metrics.Rd @@ -64,15 +64,15 @@ if (requireNamespace("ranger", quietly = TRUE) && } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_folds}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_folds]{plot_folds()}} } \concept{plotting} diff --git a/man/plot_folds.Rd b/man/plot_folds.Rd index 231deb49..211c37fc 100644 --- a/man/plot_folds.Rd +++ b/man/plot_folds.Rd @@ -29,7 +29,8 @@ several and an empty block can be seen to be empty. The subtitle states the parameter that decides whether the scheme leaks, read from \code{folds$params}: the block size (and the estimated range when \code{auto_range} found one), the buffer, the number of location groups, -or the median NNDM exclusion. +the median NNDM exclusion, or, for kNNDM folds, that they are matched to +the prediction distances. } \examples{ if (requireNamespace("ggplot2", quietly = TRUE)) { @@ -45,15 +46,15 @@ if (requireNamespace("ggplot2", quietly = TRUE)) { } } \seealso{ -Other plotting: -\code{\link{plot.aoa}()}, -\code{\link{plot.block_size_sweep}()}, -\code{\link{plot.feature_selection}()}, -\code{\link{plot.gwr_model_selection}()}, -\code{\link{plot.resolution_profile}()}, -\code{\link{plot.sac_range}()}, -\code{\link{plot.spatial_fit}()}, -\code{\link{plot_calibration}()}, -\code{\link{plot_cv_metrics}()} +Other plotting: +\code{\link[=plot.aoa]{plot.aoa()}}, +\code{\link[=plot.block_size_sweep]{plot.block_size_sweep()}}, +\code{\link[=plot.feature_selection]{plot.feature_selection()}}, +\code{\link[=plot.gwr_model_selection]{plot.gwr_model_selection()}}, +\code{\link[=plot.resolution_profile]{plot.resolution_profile()}}, +\code{\link[=plot.sac_range]{plot.sac_range()}}, +\code{\link[=plot.spatial_fit]{plot.spatial_fit()}}, +\code{\link[=plot_calibration]{plot_calibration()}}, +\code{\link[=plot_cv_metrics]{plot_cv_metrics()}} } \concept{plotting} diff --git a/man/plot_tessellation_map.Rd b/man/plot_tessellation_map.Rd index 03254db1..1914c453 100644 --- a/man/plot_tessellation_map.Rd +++ b/man/plot_tessellation_map.Rd @@ -126,23 +126,25 @@ if (requireNamespace("ggplot2", quietly = TRUE)) { coords = c("x", "y"), crs = 32632 ) # Cells from the points, the response aggregated onto them, and the map - # shaded by the cell mean rather than by an arbitrary ID. + # shaded by the cell mean rather than by an arbitrary ID. Each cell + # holds one point, so there is nothing to pool: estimate = "mean". tess <- build_tessellation(pts, method = "voronoi", quiet = TRUE) cells <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), - response_var = "z", cells_sf = tess$cells) + response_var = "z", cells_sf = tess$cells, + estimate = "mean") plot_tessellation_map(cells, features_sf = pts, fill_col = "resp_mean_z", legend_title = "mean z") } } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{voronoi_seeds_kmeans}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/predict.bayesian_fit.Rd b/man/predict.bayesian_fit.Rd index 4a5105a8..05abd0ea 100644 --- a/man/predict.bayesian_fit.Rd +++ b/man/predict.bayesian_fit.Rd @@ -32,19 +32,24 @@ point summary. Default FALSE.} } \value{ Numeric vector of length \code{nrow(newdata)}, or a -\code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. If the +\code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. Rows +with a missing or non-finite predictor or coordinate, and rows carrying +a level of a categorical predictor the model was not fitted with, are +\code{NA} (an \code{NA} column with \code{draws = TRUE}); the other +rows are unaffected. If the posterior draw fails the result is all \code{NA} (a 1-row matrix for -\code{draws = TRUE}) and the cause is logged. An ordinal or categorical +\code{draws = TRUE}) with a warning of class +\code{spatialkit_predict_failed} that gives the cause. An ordinal or categorical family is not a failed draw and is an error under \code{type = "epred"}: its expected value is a probability per response category, not one number per row. Use \code{type = "predict", -draws = TRUE} for posterior draws of the predicted category, as category + draws = TRUE} for posterior draws of the predicted category, as category indices; the share of draws in each category estimates its probability. Without \code{draws = TRUE}, \code{type = "predict"} returns the mean (or median) category index, an expected rank for an ordinal family and an error for \code{brms::categorical()}, whose categories have no order. -With \code{newdata = NULL} the cached \code{fitted()} values are returned only -for the default \code{summary = "mean"}, \code{type = "epred"}, +With \code{newdata = NULL} the cached \code{fitted()} values are returned +only for the default \code{summary = "mean"}, \code{type = "epred"}, \code{draws = FALSE} combination; any other combination is recomputed against the training data, because the cache holds epred column means and nothing else. @@ -84,22 +89,38 @@ factor puts that edge well outside the training data, so only \code{newdata} reaching far past it is affected. } +\section{Levels of a categorical predictor}{ + +A factor or character predictor is handed to brms with the levels the model +was fitted with: the values that occur in the training rows +(\code{object$info$predictor_levels}). brms compares the level \emph{set} +of a \code{newdata} factor with those, so without this a factor that only +listed an extra level, or a model fitted on a subset whose factor kept an +unused level, was refused outright. A row whose value is not among the +fitted levels has no prediction: it is returned as \code{NA}, the other +rows are predicted, and one warning of class \code{spatialkit_new_levels} +names the predictor, the levels and the number of rows. A prediction +therefore does not depend on which other rows share the call, and +\code{\link{predict_surface}()} returns the same surface at any +\code{chunk_size}. +} + \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/predict.gwr_fit.Rd b/man/predict.gwr_fit.Rd index 9008481a..a2cdd6ee 100644 --- a/man/predict.gwr_fit.Rd +++ b/man/predict.gwr_fit.Rd @@ -4,7 +4,7 @@ \alias{predict.gwr_fit} \title{Predict from a GWR spatial model} \usage{ -\method{predict}{gwr_fit}(object, newdata = NULL, ...) +\method{predict}{gwr_fit}(object, newdata = NULL, se.fit = FALSE, ...) } \arguments{ \item{object}{A \code{gwr_fit} object.} @@ -13,48 +13,127 @@ The response variable need not be present (true out-of-sample prediction is supported). NULL = fitted values.} +\item{se.fit}{Logical; also return standard errors. Default \code{FALSE}.} + \item{...}{Ignored.} } \value{ -Numeric vector aligned to \code{nrow(newdata)}, with \code{NA} for -rows dropped as missing or non-finite, and for locations whose local -regression cannot be estimated (too few training points within a fixed -bandwidth, or a singular local design); a warning counts those. If the -design matrix for \code{newdata} cannot be built, every value is -\code{NA} and a warning says why. CRS-less +With \code{se.fit = FALSE}, a numeric vector aligned to +\code{nrow(newdata)}, with \code{NA} for rows dropped as missing or +non-finite, and for locations whose local regression cannot be +estimated (see \strong{When a prediction is NA}); a warning counts +those. If the design matrix for \code{newdata} cannot be built, every +value is \code{NA} and a warning says why. CRS-less \code{newdata} first receives the interpretation the training data got, so the same rows land where they did at fit time. + +With \code{se.fit = TRUE}, a list: \code{fit} (that vector), +\code{se.fit} (the standard error of the fitted value, +\eqn{\hat\sigma\sqrt{s^\top s}} with \eqn{s} the weights the local +regression puts on the training responses), \code{se.pred} (the standard +error of a new observation there, \eqn{\hat\sigma\sqrt{1 + s^\top s}}, +the square root of \code{GWmodel::gwr.predict()}'s prediction variance), +\code{residual.scale} (\eqn{\hat\sigma}, from the fit's residual sum of +squares over its effective degrees of freedom) and \code{df} (those +degrees of freedom). The standard errors treat the bandwidth as known +and the local model as true at each location; they do not measure the +bias of a local fit and are \code{NA} where the prediction is. } \description{ When \code{newdata} is NULL, returns the in-sample fitted values. -Otherwise estimates the local coefficients at each new location with -\code{GWmodel::gwr.basic(regression.points = )}, with the fit's kernel and -bandwidth (an adaptive bandwidth counts neighbours among the training -points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. These are the -values \code{GWmodel::gwr.predict()} returns, without its prediction -variance, which this method never returned and which costs time cubic in -the number of training points. Each location stands alone: one that cannot -be estimated does not affect the others. +Otherwise solves one local regression at each new location, with the +fit's kernel and bandwidth (an adaptive bandwidth counts neighbours among +the training points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. +The local regressions are weighted least squares solved by a pivoted QR, +the solve \code{\link{fit_gwr_model}()} uses; on a window of full rank the +values equal those of \code{GWmodel::gwr.predict()} to rounding error, and +at a training location with that row's own predictors they equal +\code{fitted()}. Each location stands alone: one that cannot be +estimated does not affect the others. \code{newdata} is first transformed to the CRS used during fitting (via \code{ensure_projected()}), so predictions are computed in a single coordinate system regardless of the CRS newdata arrives in. } +\section{When a prediction is NA}{ + +A prediction is returned when it is estimable from the training points +that carry weight at the new location, and is \code{NA} otherwise: +\itemize{ +\item no training point carries weight there (a location beyond a fixed +bisquare, tricube or boxcar bandwidth); +\item the training points in the window cannot place the new row: a +predictor is constant among them at a value other than the new row's +(a regional indicator, at a location whose window lies wholly in +another region), or fewer of them carry weight than the new row needs. +} +Where a predictor is constant in the window at the new row's own value, +its coefficient is not needed and the prediction is returned. The +decision uses the rule and the tolerance of the fit (see +\code{\link{fit_gwr_model}}, \strong{The local solve}). A warning of +class \code{"spatialkit_gwr_not_estimable"} counts the \code{NA} +predictions. +} + +\section{Locations beyond the reach of the fit}{ + +An adaptive bandwidth always finds its neighbours, and a Gaussian or an +exponential kernel weights every training point, so a location far from +the data still gets a number: the local regression of training points +that are all far away, extrapolated. When a new location's nearest +training point is farther than the widest kernel used at any training +location reaches, the prediction is returned and a warning of class +\code{"spatialkit_gwr_extrapolation"} counts those locations and gives +the range of their distances. The widest kernel is the largest distance +from a training point to its \code{bandwidth}-th nearest neighbour +(\code{object$info$max_kernel_width}), or the bandwidth itself when it is +fixed. A bisquare, tricube or boxcar kernel reaches as far as its width; +a Gaussian or exponential kernel has no edge, and its reach is taken as +three widths. The check is on distance alone and is lenient: a location +just outside the data is not flagged. + +The warning is raised once per call, with that call's counts. +\code{\link{predict_surface}()}, which predicts a grid in chunks, and +\code{\link{cv_gwr}()} and \code{\link{cv_spatial}()}, which predict +fold by fold, collect the warnings of their pieces and raise one under +their own name, with the totals and the number of calls they are over +(\code{calls}). The folds of a cross-validation are separate fits, so +a cross-validation gives the smallest and the largest reach among them. +\code{\link{cv_block_size_sweep}()} and +\code{\link{select_features_forward}()} run many cross-validations of +one learner and raise one warning for the sweep. A sweep predicts the +same rows from several fits, so its totals count a location once for each +fit that put it out of reach, and the message says so. +\code{model_metrics(fit, newdata)} is +one call and raises the warning once. A loop of your own over +\code{predict()} gets one warning per call; the condition carries its +numbers as fields (\code{n_far}, +\code{n}, \code{reach}, and \code{nearest}, the smallest and largest +distance to a nearest training point), so a handler can total them: +\code{withCallingHandlers(..., spatialkit_gwr_extrapolation = function(w) +\{ total <<- total + w$n_far; invokeRestart("muffleWarning") \})}. To +drop it where extrapolation is intended, use +\code{suppressWarnings(predict(fit, newdata), classes = +"spatialkit_gwr_extrapolation")}. The warning that counts \code{NA} +predictions (class \code{"spatialkit_gwr_not_estimable"}) carries +\code{n_na}, \code{n} and \code{n_empty} and is collected the same way. +} + \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/predict.rf_fit.Rd b/man/predict.rf_fit.Rd index 85ee58fa..33c79675 100644 --- a/man/predict.rf_fit.Rd +++ b/man/predict.rf_fit.Rd @@ -50,21 +50,21 @@ With \code{newdata = NULL} this returns \strong{out-of-bag} predictions, not in-sample ones. See \code{\link{fit_rf_model}}. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/predict_surface.Rd b/man/predict_surface.Rd index 5b7ba9f2..f3c8d83e 100644 --- a/man/predict_surface.Rd +++ b/man/predict_surface.Rd @@ -64,7 +64,11 @@ CRS.} \item{chunk_size}{Rows per prediction call. Default 5000. A pure performance knob: rows do not interact, and for a \code{bayesian_fit} the GP boundary is held at its fitted value whatever the chunk holds; see -\code{\link{predict.bayesian_fit}}.} +\code{\link{predict.bayesian_fit}}. The two warnings in which +\code{\link{predict.gwr_fit}()} counts locations (classes +\code{"spatialkit_gwr_extrapolation"} and +\code{"spatialkit_gwr_not_estimable"}) are raised once for the grid, +with its totals, whatever the number of chunks.} \item{se}{Logical; also return a standard-error/posterior-SD column where the backend supports it. Default FALSE. For a \code{bayesian_fit} this is @@ -131,7 +135,7 @@ if (requireNamespace("ranger", quietly = TRUE)) { } } \seealso{ -Other prediction: -\code{\link{area_of_applicability}()} +Other prediction: +\code{\link[=area_of_applicability]{area_of_applicability()}} } \concept{prediction} diff --git a/man/prep_model_data.Rd b/man/prep_model_data.Rd index 635c547e..ecebddf2 100644 --- a/man/prep_model_data.Rd +++ b/man/prep_model_data.Rd @@ -23,7 +23,10 @@ prep_model_data( for an intercept-only model (\code{fit_bayesian_spatial_model()} supports one; the GWR and random-forest backends do not and reject it themselves).} -\item{boundary}{Optional sf/sfc for CRS alignment.} +\item{boundary}{Optional sf/sfc whose CRS the data are projected to. It +is not a clip: rows that fall outside it are kept. Subset +\code{data_sf} yourself (for example with \code{sf::st_filter()}) to +restrict the rows.} \item{pointize}{Strategy for non-point geometry coercion, passed to \code{\link{coerce_to_points}}. One of \code{"auto"} (default), @@ -46,14 +49,25 @@ empty or non-finite geometry), \code{which} (their positions in layer carries that column, else \code{NULL}) and \code{reason} (one per dropped row: \code{"geometry"}, \code{"missing"} or \code{"non_finite"}, in that order of precedence when several apply), +\code{by_column} (for each modelling column, and for +\code{"(geometry)"}, how many of the dropped rows it is missing or +non-finite in; a row can count under several), +\code{response_std_diff} (the mean response of the dropped rows minus +that of the kept rows, in standard deviations of the response over both; +\code{NA} when the response is not numeric, or is itself missing in +every dropped row), plus \code{n_rows}, the number of rows returned, which the record was -made for. +made for. The same record carries two marks on the rows that were +kept: \code{constant_predictors}, the names of the predictors that take +one value in every returned row (\code{character(0)} when none does), +and \code{n_duplicate_locations}, the number of returned rows whose +coordinates repeat those of an earlier row. Every fit stores \code{n} as \code{$info$n_dropped}. The record describes the rows this call returned and does not survive subsetting: \code{clean[i, ]}, like \code{dplyr::filter()}, \code{slice()} or \code{arrange()} of it, is a plain layer with no \code{"dropped"} attribute, and a fit given such a subset with \code{.already_prepped = -TRUE} reports \code{n_dropped = 0} even when the parent layer dropped + TRUE} reports \code{n_dropped = 0} even when the parent layer dropped rows. \code{sf::st_drop_geometry()} keeps the record, since the rows are the same; see \code{\link{[.spatialkit_rows}} for what binding such data frames does. The CRS is @@ -90,6 +104,40 @@ fit object still recorded the name you asked for: \code{"B5-B4"} is \code{B5 - B4}, and \code{"log(a)"} is a function call. Rename the column (for example with \code{make.names()}) before fitting. } +\section{Warnings}{ + +When preparing data for a fit (\code{require_response = TRUE}) two +conditions are raised as R warnings, each with a class so it can be caught +by name with \code{tryCatch()} or \code{withCallingHandlers()}: +\describe{ +\item{\code{spatialkit_rows_dropped}}{Rows were dropped. The message +gives the number and share of rows, the count by reason and by +column, and, for a numeric response, how far the mean response of +the dropped rows sits from that of the kept rows. A fit on the rows +that remain describes those rows only; when the difference is large +the rows are not missing at random and the fit is biased towards the +complete ones.} +\item{\code{spatialkit_constant_predictor}}{A predictor takes a single +value in every row that remains. Its coefficient cannot be told from +the intercept: a GWR window is rank-deficient, a Bayesian slope is +its prior, and a forest ignores it. The predictor is kept; drop it +from \code{predictor_vars}.} +} +Every fitter and every \code{cv_*()} function prepares its data here and +passes these on. \code{\link{compare_models_cv}()}, +\code{\link{cv_block_size_sweep}()} and +\code{\link{select_features_forward}()} run several cross-validations +of one layer, each of which prepares it, and raise a warning of either +class once per distinct text for the run. + +With \code{require_response = FALSE} (how every \code{predict()} method +prepares \code{newdata}) neither is raised: the dropped rows are written +to the log and to the record, and the prediction for each comes back +\code{NA}, so nothing is lost without a trace. Repeated locations are +legitimate (repeat visits to one site) and are counted in the record and +the log, never warned about. +} + \examples{ library(sf) dat <- st_as_sf( @@ -98,22 +146,23 @@ dat <- st_as_sf( pred = c(1, 2, 3, 4, Inf)), coords = c("x", "y"), crs = 32632 ) -clean <- prep_model_data(dat, "resp", "pred") # drops rows 3 (NA) and 5 (Inf) +# Drops rows 3 (NA) and 5 (Inf), and warns that it did, with the counts. +clean <- suppressWarnings(prep_model_data(dat, "resp", "pred")) attr(clean, "dropped") } \seealso{ -Other model fitting: -\code{\link{fit_bayesian_spatial_model}()}, -\code{\link{fit_gwr_model}()}, -\code{\link{fit_rf_model}()}, -\code{\link{gp_lengthscale_bounds}()}, -\code{\link{new_spatial_fit}()} +Other model fitting: +\code{\link[=fit_bayesian_spatial_model]{fit_bayesian_spatial_model()}}, +\code{\link[=fit_gwr_model]{fit_gwr_model()}}, +\code{\link[=fit_rf_model]{fit_rf_model()}}, +\code{\link[=gp_lengthscale_bounds]{gp_lengthscale_bounds()}}, +\code{\link[=new_spatial_fit]{new_spatial_fit()}} -Other spatial data preparation: -\code{\link{clip_target_for}()}, -\code{\link{coerce_to_points}()}, -\code{\link{ensure_projected}()}, -\code{\link{harmonize_crs}()} +Other spatial data preparation: +\code{\link[=clip_target_for]{clip_target_for()}}, +\code{\link[=coerce_to_points]{coerce_to_points()}}, +\code{\link[=ensure_projected]{ensure_projected()}}, +\code{\link[=harmonize_crs]{harmonize_crs()}} } \concept{model fitting} \concept{spatial data preparation} diff --git a/man/print.aoa.Rd b/man/print.aoa.Rd index e277d334..793991ae 100644 --- a/man/print.aoa.Rd +++ b/man/print.aoa.Rd @@ -18,16 +18,22 @@ Summarises where the model may be trusted: how many prediction locations fall inside the area of applicability and how many outside, the dissimilarity threshold that separated them, and the predictors the index -was computed over (naming any dropped for having no usable variance). The +was computed over (naming any dropped for having no usable variance). It +also says where the weights came from (the model's importance, a vector +the caller supplied, or equal weights and why), whether location was +measured and how, how categorical predictors were handled, and how many +training rows repeat another's predictor values. With a location index +the rows outside are split into those outside on the predictors and those +outside on location. The proportion outside is the headline number. A map that extrapolates over much of its extent is reporting predictions its training data cannot support, whatever the cross-validation score said. } \seealso{ -Other print methods: -\code{\link{print.gwr_model_selection}()}, -\code{\link{print.morans_i}()}, -\code{\link{print.resolution_profile}()}, -\code{\link{print.sac_range}()} +Other print methods: +\code{\link[=print.gwr_model_selection]{print.gwr_model_selection()}}, +\code{\link[=print.morans_i]{print.morans_i()}}, +\code{\link[=print.resolution_profile]{print.resolution_profile()}}, +\code{\link[=print.sac_range]{print.sac_range()}} } \concept{print methods} diff --git a/man/print.gwr_model_selection.Rd b/man/print.gwr_model_selection.Rd index 1e3396d9..e1539e88 100644 --- a/man/print.gwr_model_selection.Rd +++ b/man/print.gwr_model_selection.Rd @@ -18,17 +18,25 @@ } \description{ Shows the forward-selection trail: the response, the candidate predictors, -and the top-ranked models with their criterion values, so you can see both -which model won and by how much. A shallow gap between the first few rows -means the ranking is not well identified and the choice of predictors should -not be treated as settled. Check the gap before reporting one model as the -selected one. +and the top-ranked models with their criterion values and, in the +\code{delta} column, how far each is from the best. Below the table it +lists the models within 2 of the best, which a difference in AICc does not +separate (Burnham and Anderson 2002), and names the smallest of them. When +several models are that close the ranking is not well identified and the +choice of predictors should not be treated as settled; when the model +without predictors (\code{}) is among them, no candidate has been +shown to help. +} +\references{ +Burnham, K. P. and Anderson, D. R. (2002). \emph{Model Selection and +Multimodel Inference: A Practical Information-Theoretic Approach}, 2nd +edition. Springer. } \seealso{ -Other print methods: -\code{\link{print.aoa}()}, -\code{\link{print.morans_i}()}, -\code{\link{print.resolution_profile}()}, -\code{\link{print.sac_range}()} +Other print methods: +\code{\link[=print.aoa]{print.aoa()}}, +\code{\link[=print.morans_i]{print.morans_i()}}, +\code{\link[=print.resolution_profile]{print.resolution_profile()}}, +\code{\link[=print.sac_range]{print.sac_range()}} } \concept{print methods} diff --git a/man/print.morans_i.Rd b/man/print.morans_i.Rd index 33ad5f75..7d29d53b 100644 --- a/man/print.morans_i.Rd +++ b/man/print.morans_i.Rd @@ -22,10 +22,10 @@ description in place of the matrix: it is \eqn{n \times n}, and autoprinting it buried the statistic under a thousand lines of matrix. } \seealso{ -Other print methods: -\code{\link{print.aoa}()}, -\code{\link{print.gwr_model_selection}()}, -\code{\link{print.resolution_profile}()}, -\code{\link{print.sac_range}()} +Other print methods: +\code{\link[=print.aoa]{print.aoa()}}, +\code{\link[=print.gwr_model_selection]{print.gwr_model_selection()}}, +\code{\link[=print.resolution_profile]{print.resolution_profile()}}, +\code{\link[=print.sac_range]{print.sac_range()}} } \concept{print methods} diff --git a/man/print.resolution_profile.Rd b/man/print.resolution_profile.Rd index c09aa966..94797a2f 100644 --- a/man/print.resolution_profile.Rd +++ b/man/print.resolution_profile.Rd @@ -20,10 +20,10 @@ Print a resolution profile } \seealso{ -Other print methods: -\code{\link{print.aoa}()}, -\code{\link{print.gwr_model_selection}()}, -\code{\link{print.morans_i}()}, -\code{\link{print.sac_range}()} +Other print methods: +\code{\link[=print.aoa]{print.aoa()}}, +\code{\link[=print.gwr_model_selection]{print.gwr_model_selection()}}, +\code{\link[=print.morans_i]{print.morans_i()}}, +\code{\link[=print.sac_range]{print.sac_range()}} } \concept{print methods} diff --git a/man/print.rf_fit.Rd b/man/print.rf_fit.Rd index 5e781509..5fd68542 100644 --- a/man/print.rf_fit.Rd +++ b/man/print.rf_fit.Rd @@ -17,26 +17,31 @@ \description{ Shows the forest's shape (formula, n, number of trees, \code{mtry}, node size) along with the out-of-bag error and, prominently, whether the -coordinates were used as predictors. That last line is the one to check: -a forest fitted with \code{include_coords = TRUE} can memorise location and -score well out-of-bag while failing everywhere it has not been. +coordinates were used as predictors. That line is the one to check. A +forest fitted without them prints "no spatial information used": it sees +the covariates alone. One fitted with \code{include_coords = TRUE} fits +location closely, so its out-of-bag error overstates its accuracy and it +has to be scored with blocked or distance-matched folds; see +\emph{Coordinates as predictors} in \code{\link{fit_rf_model}}. When a +predictor is an unordered factor or a character column, a line says how +ranger was told to split it. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/print.sac_range.Rd b/man/print.sac_range.Rd index 77b48d6f..84dab517 100644 --- a/man/print.sac_range.Rd +++ b/man/print.sac_range.Rd @@ -27,10 +27,10 @@ whether the variogram is of the response or of its residuals on \code{predictor_vars} (\code{detrended}, \code{detrend_method}). } \seealso{ -Other print methods: -\code{\link{print.aoa}()}, -\code{\link{print.gwr_model_selection}()}, -\code{\link{print.morans_i}()}, -\code{\link{print.resolution_profile}()} +Other print methods: +\code{\link[=print.aoa]{print.aoa()}}, +\code{\link[=print.gwr_model_selection]{print.gwr_model_selection()}}, +\code{\link[=print.morans_i]{print.morans_i()}}, +\code{\link[=print.resolution_profile]{print.resolution_profile()}} } \concept{print methods} diff --git a/man/print.spatial_fit.Rd b/man/print.spatial_fit.Rd index 58d9e0ce..02bc3e9b 100644 --- a/man/print.spatial_fit.Rd +++ b/man/print.spatial_fit.Rd @@ -17,30 +17,38 @@ \description{ Shows the one-screen summary of a \code{gwr_fit}, a \code{bayesian_fit} or a custom subclass: backend, formula, number of observations, CRS, and the few -backend-specific numbers worth seeing immediately (GWR bandwidth, GP basis -size). An \code{rf_fit} has its own method (see +backend-specific numbers worth seeing immediately (GWR bandwidth; for a +\code{bayesian_fit} the GP basis size, the smallest effective range that +basis resolves in map units, the slope prior, and a flagged line when the +sampler's diagnostics or the basis-adequacy check failed). An +\code{rf_fit} has its own method (see \code{\link{print.rf_fit}}), which shows the same header plus the forest settings. It is what you get by typing the object's name, and the quickest way to confirm a fit used the data, predictors and CRS you meant. For fit quality use \code{\link{model_metrics}()} or \code{\link{summary}()} instead. Nothing printed here is an out-of-sample score. } +\details{ +For a \code{gwr_fit} the bandwidth and AICc are followed by the effective +number of parameters and, when any local window is of deficient rank, by +the number of such windows. +} \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/residual_morans_i.Rd b/man/residual_morans_i.Rd index 02d0520a..7d799f3d 100644 --- a/man/residual_morans_i.Rd +++ b/man/residual_morans_i.Rd @@ -241,10 +241,10 @@ Cliff, A. D. and Ord, J. K. (1981) \emph{Spatial Processes: Models and Applications}. Pion, London. Section 8.3. } \seealso{ -Other model evaluation: -\code{\link{compare_models}()}, -\code{\link{compare_models_cv}()}, -\code{\link{evaluate_insample}()}, -\code{\link{model_metrics}()} +Other model evaluation: +\code{\link[=compare_models]{compare_models()}}, +\code{\link[=compare_models_cv]{compare_models_cv()}}, +\code{\link[=evaluate_insample]{evaluate_insample()}}, +\code{\link[=model_metrics]{model_metrics()}} } \concept{model evaluation} diff --git a/man/residuals.bayesian_fit.Rd b/man/residuals.bayesian_fit.Rd index 95a3c048..e2cb3ac2 100644 --- a/man/residuals.bayesian_fit.Rd +++ b/man/residuals.bayesian_fit.Rd @@ -19,21 +19,21 @@ Observed response minus \code{\link{fitted.bayesian_fit}} (the cached posterior expectation), so these are \strong{in-sample} residuals. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/residuals.gwr_fit.Rd b/man/residuals.gwr_fit.Rd index 2b598393..af40987a 100644 --- a/man/residuals.gwr_fit.Rd +++ b/man/residuals.gwr_fit.Rd @@ -19,21 +19,21 @@ Observed response minus \code{\link{fitted.gwr_fit}}, so these are \strong{in-sample} residuals. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.rf_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/residuals.rf_fit.Rd b/man/residuals.rf_fit.Rd index 2310a3f5..886d5e67 100644 --- a/man/residuals.rf_fit.Rd +++ b/man/residuals.rf_fit.Rd @@ -25,21 +25,21 @@ the residuals. Out-of-bag is not a substitute for spatial CV: use \code{\link{cv_rf}()} for an honest map-accuracy figure. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{summary.spatial_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=summary.spatial_fit]{summary.spatial_fit()}} } \concept{methods on a fitted model} diff --git a/man/resolution_profile.Rd b/man/resolution_profile.Rd index c822194a..5029475d 100644 --- a/man/resolution_profile.Rd +++ b/man/resolution_profile.Rd @@ -12,11 +12,18 @@ resolution_profile( n_levels = 20L, min_cell_n = 9L, sample_n = 1500L, - nstart = 25L, + nstart = NULL, seed = 123L, - sac = NULL, + sac = "auto", select_on = c("all", "split"), - range_floor = TRUE + range_floor = FALSE, + partition = c("density", "kmeans"), + init = c("kmeans++", "random"), + density_power = 1, + density_k = 8L, + iter_max = NULL, + estimate = "auto", + obs_per_cell = "auto" ) } \arguments{ @@ -25,11 +32,17 @@ representative points). Features with empty or non-finite coordinates are dropped with a warning.} \item{response_var}{Optional response column name (numeric or logical). -Enables \code{cp} and \code{moran_z}. A variogram estimated from it also -sets the floor of the ladder and \code{reliability}. Rows where it, or a -predictor, is missing or non-finite stay in the geometry and are left out -of the OLS fit, the RSS, \code{cp} and \code{moran_z}; a logged warning -gives their number.} +Enables \code{cp} and \code{moran_z}, and, when it is numeric, the +pooled estimate the default profile scores by \code{loo}. A variogram +estimated from it also gives the range floor the bounds report and +\code{reliability}; it is estimated on a ladder of counts or when +\code{sac} asks for it, and not on the default ladder of one size, so +\code{cp} and \code{reliability} are \code{NA} there. Rows +where it, or a predictor, is missing or non-finite stay in the geometry +and are left out of the OLS fit, the RSS, \code{cp}, \code{moran_z} and +the count the support ceiling divides by \code{min_cell_n}; a logged +warning gives their number, and an R warning says so when they lower +the ceiling.} \item{predictor_vars}{Optional predictor column names (numeric or logical). With them, \code{cp} scores the OLS residuals of the response @@ -42,20 +55,39 @@ at or above the number of points, are dropped (k-means cannot place more centres than there are distinct points, and \code{stats::kmeans()} refuses as many centres as points).} -\item{n_levels}{Number of levels on the ladder. Default 20.} +\item{n_levels}{Number of levels on the ladder. Default 20. The ladder +has fewer when rounding puts two of them on one count, and one more +when the range floor is added as a level (see "The ladder and its +bounds"). Supplying it, or \code{min_cell_n}, \code{sample_n}, +\code{levels} or \code{range_floor}, gives that ladder in place of the +ladder of sizes \code{obs_per_cell = "auto"} would set.} -\item{min_cell_n}{Minimum average number of points per cell that a level -must keep; sets the ceiling. Default 9.} +\item{min_cell_n}{Minimum average number of rows per cell that a level +must keep (scored rows when \code{response_var} is given: those with a +response and every predictor; points otherwise); sets the ceiling. +Default 9. A layer that cannot give two cells that many is profiled at +two cells, or at the \code{levels} asked for, with +\code{supported = FALSE} and a warning. It is floored to a whole +number, and it is not read on a ladder \code{obs_per_cell} sets (see +"The ladder and its bounds").} \item{sample_n}{Points are subsampled to this many before the k-means -fits, as in \code{determine_optimal_levels()}. Default 1500. The -columns read off the fitted cells (\code{wss}, the \code{cell_} columns, -\code{rss}, \code{moran_i}, \code{moran_z}) describe the subsample; the -bounds, \code{supported}, the variance term of \code{cp} and -\code{reliability} describe every point of the layer, so the answer does -not change with \code{sample_n} except through the fits.} +fits, as in \code{determine_optimal_levels()}, on the ladder of "The +ladder and its bounds"; on a ladder of sizes, the default, the centres +are fitted to every row. Default 1500. The +columns read off the fitted cells (\code{wss}, the \code{cell_} and +\code{cells_} columns, \code{rss}, \code{moran_i}, \code{moran_z}) +describe the subsample; the bounds, \code{supported}, the variance term +of \code{cp} and \code{reliability} describe the whole layer, so the +answer does not change with \code{sample_n} except through the fits.} -\item{nstart}{k-means++ restarts per level. Default 25.} +\item{nstart}{Starts per level; the best is kept. They are k-means++ +starts unless \code{init} says otherwise. \code{NULL} (default) is the +kind's own number: 3 for the kind \code{"density"} and 25 for the kind +\code{"kmeans"}, the number earlier versions ran. A number is run +under either \code{partition}: \code{nstart = 25} gives the density +kind the starts it had when 25 was the default. +\code{attr(, "nstart")} holds the number that was run.} \item{seed}{RNG seed for the subsample and the restarts; restored afterwards. Default 123. The rows are put in coordinate order before @@ -72,16 +104,19 @@ to which the points are transformed first, so the area, the floor and \code{cell_diam_median} are then in that CRS's units. A sac whose range was rejected (\code{NA} with a \code{rejected_reason}) gives \code{cp} its nugget, with a warning, and leaves \code{reliability} -\code{NA}, since that needs the range; one whose model did not converge, -or whose range is below the shortest lag fitted (a structure that -cannot be told from a nugget, so the nugget is not identified either), +\code{NA}, since that needs the range; one whose model did not converge +(its fit has no minimum inside the ranges searched, so its nugget and +sill are not fitted values), or whose range is below the shortest lag +fitted (a structure that cannot be told from a nugget, so the nugget is +not identified either), gives neither, and \code{cp} takes its noise variance from the finest level (see \code{cp} above). Whether the model converged is read from the model (\code{attr(attr(sac, "variogram_model"), "converged")}, which -\code{estimate_sac_range()} sets), not from the reason: the reason names -one ground for the refusal, and a fit that did not converge is most -often refused as past the largest lag. The warning then names both. A -sac that carries no such flag (one made by hand, say) is judged by its +\code{\link{estimate_sac_range}()} sets and describes), not from the +reason: the reason names one ground for the refusal, and such a fit is +refused as past the largest lag. The warning then names both. A +sac that carries no such flag (one made by hand, or built from REML +parameters) is judged by its reason. Under \code{select_on = "split"} the sac must come from the selection half alone: run the profile once without it, fit the sac on \code{data_sf[attr(p, "split")$selection, ]} and pass it to a second @@ -90,10 +125,27 @@ call with the same \code{seed}, which makes the same split. When (its selection half under \code{"split"}) with the same \code{predictor_vars}. A plain number is taken as the range alone, in the units of the CRS the profile is computed in (metres for lon/lat -input): it sets the floor, \code{reliability}, which needs a fitted -model, is \code{NA}, and \code{cp} takes its noise variance from the -finest level. A \code{units} object is refused -rather than read as a number in whatever unit it was written in.} +input): it gives the range floor, \code{reliability}, which needs a +fitted model, is \code{NA}, and \code{cp} takes its noise variance from +the finest level. A sac refused because the response shows no spatial +structure (either of the two \code{rejected_reason} values of +\code{\link{estimate_sac_range}()} that say so; the model it attaches +is a pure nugget) gives \code{cp} no +nugget either, and \code{select_resolution()} then returns +\code{structured = FALSE}. A \code{units} object is refused +rather than read as a number in whatever unit it was written in. +The string \code{"auto"}, the default, is \code{NULL} on every ladder +but one that \code{obs_per_cell} sets. On that ladder no variogram is +estimated or +read: \code{cp} and \code{reliability} are \code{NA} at every level, +\code{cp} takes no noise variance from the finest level in its place, +\code{attr(, "cp_noise")} is a list whose \code{source} is +\code{"none"} and whose \code{reason} says why, and the +\code{variogram} and \code{sac} attributes are \code{NULL}. The +other columns do not read the variogram and are the numbers +\code{sac = NULL} gives. \code{sac = NULL}, the default of earlier +versions, estimates the variogram on a ladder of sizes too, and gives +\code{cp} and \code{reliability} there.} \item{select_on}{\code{"all"} (default) profiles every point; \code{"split"} reads the response on one spatially blocked half only @@ -108,27 +160,143 @@ never touches them. See the "Post-selection inference" section of \code{\link{determine_optimal_levels}}; the profile reads the response whenever \code{response_var} is given.} -\item{range_floor}{\code{TRUE} (default) starts the ladder at the range -floor when the data support it; \code{FALSE} starts it at 2 whatever -the range, and the floor is only reported in the bounds and the print. -Use \code{FALSE} to compare profiles whose range estimates differ (see -"The ladder and its bounds").} +\item{range_floor}{\code{FALSE} (default) starts the ladder at 2 whatever +the range, and the range floor is reported in the bounds and the print +without being applied. \code{TRUE} starts the ladder at the floor when +the data support it and the floor is below the ceiling, as the default +did up to version 2.0.0; an estimated range then sets the fewest cells +any criterion can choose (see "The ladder and its bounds").} + +\item{partition}{What the centres of the regions minimise, at every level +of the ladder. \code{"density"} (default): the sum of squared +distances from the points to their nearest centre, each point weighted +by its local density to the power \code{density_power}; compact cells +that, at the default power, hold about the same number of points each +once there are more cells than dense places, and counts about as uneven +as \code{"kmeans"} gives below that. \code{"kmeans"}: the same sum +unweighted; compact cells whose counts are several times higher in +dense places than in sparse ones. \code{"kmeans"} was the default of +earlier versions, and with \code{nstart = NULL} it runs their 25 +starts. See "The partition".} + +\item{init}{How each start is drawn. \code{"kmeans++"} (default): the +centres one at a time, each in proportion to its squared distance from +those already drawn, times its weight under \code{partition = +"density"}. \code{"random"}: \code{k} distinct locations at random, as +\code{\link[stats]{kmeans}()} draws them.} + +\item{density_power}{For \code{partition = "density"}: the power the local +density is raised to for a point's weight, a number from 0 to 2. +Default 1, which evens out the cell counts once the cells outnumber the +dense places (see "The partition"). \code{0} weights every +point alike, the objective of \code{"kmeans"} (reached by Lloyd's +iteration, so the centres are close to that kind's and not equal to +them); values between give counts between the two; values above 1 give +the cells of dense places fewer points than those of sparse places. +Setting it under \code{partition = "kmeans"}, which does not read it, +is a warning.} + +\item{density_k}{For \code{partition = "density"}: the number of nearest +neighbours the local density is read from. Default 8. It is held to +one fewer than the distinct locations. A small number follows the +density closely and noisily; a large one smooths it. Setting it under +\code{partition = "kmeans"} is a warning.} + +\item{iter_max}{The most iterations a start runs for: a single positive +whole number, or \code{NULL} (default) for the kind's own limit, 50 for +\code{partition = "kmeans"} from k-means++ starts and 100 for random +starts and for \code{partition = "density"}. A kept start that was cut +off at the limit is a warning of class +\code{"spatialkit_not_converged"}, except for the kind \code{"kmeans"} +from k-means++ starts under \code{iter_max = NULL}, which reports +nothing, as it always has.} + +\item{estimate}{The cell value the profile scores, which is the one +\code{\link{summarize_by_cell}()} is to report: \code{"auto"} +(default; see below), \code{NULL} for none, \code{"mean"} for the +plain mean of a cell's rows, \code{"pooled"} for the mean pulled toward +the mean of the 8 nearest cells. With an estimate the profile gains +five columns and \code{attr(, "estimate")} (see "Value"), and every +column and attribute it has without one is unchanged. \code{loo} is +the leave-one-out mean squared error of that estimate: each row predicted +by the value of its cell computed without it. Under \code{"mean"} a +row in a cell of two or more is predicted by the mean of the others, +and a row alone in its cell by the mean of the cell of its nearest +other row. Under \code{"pooled"} the cell's mean and its own weight +are computed again without the row, and the spread inside the cells, +the spread between a cell and its target, and the targets are held. +It is computed on every row of the layer with a finite response (of the +selection half under \code{select_on = "split"}), not on the subsample +the centres were fitted to, and each row is scored in the cell of its +nearest centre, the cell \code{\link{get_voronoi_seeds}()} hands on. +It needs no variogram. Rows at one location are left out one at a +time. \code{"auto"} is \code{"pooled"} when there is a numeric +\code{response_var} with a finite value and no \code{predictor_vars}, +and \code{NULL} otherwise. \code{NULL}, the default of earlier +versions, scores none and gives the profile without the five columns. +\code{"mean"} and \code{"pooled"} are +errors without a \code{response_var}, with \code{predictor_vars} (the +profile would then score residuals, and the summary reports cell values +of the response), with a logical response, and with a response that has +no finite value.} + +\item{obs_per_cell}{Rows per cell: \code{"auto"} (default; see below); +\code{NULL} for the ladder described under "The ladder and its +bounds", the default of earlier versions, whatever the other arguments +are; or one number or several, each at least 1 (fractions are +allowed), for a ladder of sizes. The level of a size \eqn{s} is +\code{max(2, round(n / s))} cells, with \eqn{n} the rows that have a +response (and, with \code{predictor_vars}, every predictor), or every +point when there is no \code{response_var} or no row has a response. +Under \code{select_on = "split"} \eqn{n} counts the rows of both +halves, since the cells are built on every point. On a ladder of sizes +the centres are fitted to every row, no subsample is drawn, and +\code{n_levels}, \code{min_cell_n}, \code{sample_n} and +\code{range_floor} are not read: supplying \code{n_levels}, +\code{min_cell_n}, \code{sample_n} or \code{range_floor = TRUE} beside +a numeric \code{obs_per_cell} is a warning of class +\code{spatialkit_ladder_unused}, and \code{levels} beside it is an +error. A level is held to the most centres k-means can place (the +distinct locations, and one short of the points). \code{"auto"} is +\code{NULL} when \code{levels} is given or the caller supplies any of +those four arguments; otherwise 4.5 when the estimate is +\code{"pooled"}, the seven sizes 18, 12, 9, 6, 4.5, 3 and 2 when it is +\code{"mean"}, and \code{NULL} without an estimate. The cost of a +ladder of sizes is bounded before any fit (see "Conditions").} } \value{ A data.frame of class \code{resolution_profile} with one row per -level and columns \code{levels}, \code{wss}, \code{wss_spread} (relative -spread of WSS across the restarts), \code{elbow}, \code{cell_n_min}, +level and columns \code{levels}, \code{wss} (the within-cell sum of +squares of the coordinates, every point counted once, under either +\code{partition}), \code{wss_spread} (relative +spread of WSS across the restarts; under \code{partition = "density"}, +of the weighted sum the starts minimise), \code{elbow}, \code{cell_n_min}, \code{cell_n_median}, \code{cell_diam_median} (twice the median RMS radius of the cells, in coordinate units: about 0.8 of the side of a square cell of the same area, and less for finer cells, so a size to compare levels by rather than a width), \code{rss}, \code{cp}, -\code{moran_i}, \code{moran_z} and \code{reliability}; columns a missing -input leaves undefined are \code{NA}. Attributes: \code{bounds} (a list -with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"}, -\code{"distinct locations"} or \code{"sample_n"}, whichever bound it), -\code{supported}, \code{area}, \code{range}, \code{n} (the points in the -layer), \code{n_sample} (the points the k-means fits ran on), -\code{n_distinct}, \code{min_cell_n}, \code{range_floor}), +\code{moran_i}, \code{moran_z}, \code{reliability}, \code{cells_resp} +(the cells that hold at least one scored row) and \code{cell_resp_mean} +(the scored rows per such cell; compare it with \code{min_cell_n}). +Like the other columns read off the fitted cells, the last two count +rows of the subsample when the layer is larger than \code{sample_n}: +the cells of the layer then hold about \code{n_response / n_scored} +times as many scored rows as \code{cell_resp_mean} shows. +Columns a missing input leaves undefined are \code{NA}. Attributes: +\code{bounds} (a list with \code{floor}, \code{ceiling}, +\code{ceiling_from} (\code{"min_cell_n"}, \code{"min_cell_n (rows with a + response)"}, \code{"distinct locations"}, \code{"sample_n"}, +\code{"fewer than two supported cells"} or \code{"fewer than two + distinct locations"}, whichever bound it), \code{supported}, \code{area}, +\code{range}, \code{n} (the points in the layer), \code{n_sample} (the +points the k-means fits ran on), \code{n_distinct}, \code{min_cell_n}, +\code{range_floor}, \code{n_response} (the rows of the layer that carry +a response and, with \code{predictor_vars}, every predictor, which the +support ceiling counts; \code{NA} without a +\code{response_var}), \code{n_scored} (the rows of the subsample the +response criteria read; \code{NA} without a \code{response_var}), +\code{levels_given} (whether \code{levels} set the ladder) and +\code{predictors} (whether \code{predictor_vars} were given)), \code{variogram} (a list with \code{nugget}, \code{psill}, \code{range} (\code{NA} when rejected), \code{model} and \code{detrended} (whether the sac says it is a variogram of residuals; \code{NA} when it does not @@ -141,69 +309,450 @@ the \code{method} and \code{seed} that made them), \code{cp_noise} (a list with \code{source}, \code{"variogram nugget"} or \code{"finest-level residual mean square"}, \code{value}, the \eqn{\tau^2} used, and \code{level}, the level it was read at or -\code{NA}; \code{NULL} when \code{cp} has neither), \code{centres} +\code{NA}; \code{NULL} when \code{cp} has neither), \code{one_cell} +(what one cell for the whole layer scores, the reference a level has to +beat: a list with \code{n}, the scored rows, \code{rss}, their total +sum of squares, \code{cp}, the same formula at one cell or \code{NA} +when \code{cp} has no noise variance, \code{constant}, whether the +scored variable is constant to within rounding, \code{cp_levels}, the +\code{cp} column it belongs to, and \code{f_p}, named by level, the +p-value of the F test of that level's cell means against one mean, +\eqn{(TSS - RSS) / (L - 1)} over \eqn{RSS / (m - L)} on the \eqn{L} +cells that hold a scored row and the \eqn{m} scored rows; \code{NULL} +without a response), \code{centres} (a list named by level of the two-column matrices of the scored -partitions' centres) and \code{centres_crs} (the CRS they are in). A +partitions' centres), \code{centres_crs} (the CRS they are in) and +\code{hull} (the convex hull of the points profiled, an \code{sfc} in +that CRS). A k-means partition is the Voronoi partition of its centres, so these seed the very cells each level was scored on: \code{select_resolution()} returns the chosen level's as \code{$seeds}, and \code{\link{get_voronoi_seeds}()} and \code{\link{voronoi_seeds_kmeans}()} -use them when given the selection or the profile. +use them when given the selection or the profile. The centres carry the +hull as their \code{"cover"} attribute, which those two functions hand on +so that Voronoi cells built on the seeds reach the edge of the points. +A profile built with \code{partition = "density"} or \code{init = + "random"} also carries \code{partition}: a list with \code{kind}, +\code{init}, \code{density_power} and \code{density_k} (both \code{NA} +for \code{kind = "kmeans"}); for \code{kind = "density"}, +\code{objective}, the weighted sum the centres minimise, named by +level; \code{iter_max}, the iteration limit; and \code{iter} and +\code{converged}, the iterations each level's kept start took and +whether it stopped before the limit, named by level. The selection +carries the first four as \code{$partition}, its +seeds and the seeds the seeding functions return as +\code{attr(, "partition")}, and a Voronoi tessellation built on them as +\code{params$partition}. A profile of the kind \code{"kmeans"} from +k-means++ starts has no such attribute, and neither has anything made +from it. + +With an \code{estimate} the frame has five more columns, after +\code{cell_resp_mean}: \code{scored_per_cell} (the rows \code{loo} +read over the cells that hold one; the layer's counterpart of +\code{cell_resp_mean}, which counts the subsample's rows), \code{loo} +(the leave-one-out mean squared error of the estimate; lower is +better), \code{loo_se} (the standard error over rows of that level's +mean squared error; it is not the standard error of a difference +between two levels, whose errors come from the same rows), +\code{share_alone} (the share of the scored rows that are the only +scored row of their cell) and \code{own_weight} (the median over cells +of the weight a pooled value gives the cell's own mean; \code{NA} +under \code{"mean"}). \code{loo}, \code{loo_se} and +\code{own_weight} are \code{NA} at a level where no cell holds two +scored rows, and at every level when the response is constant over the +rows \code{loo} reads. It also carries \code{estimate}: a list with +\code{value} (\code{"mean"} or \code{"pooled"}), \code{neighbours} +(8, or \code{NA} under \code{"mean"}), \code{response} (the column), +\code{n} (the rows \code{loo} read), \code{rows} (\code{"all"} or +\code{"selection half"}), \code{features} (\code{"points"}, or +\code{"other"} when the layer held features that were reduced to +points), \code{seed}, \code{constant} (whether the response is constant +over those rows; \code{FALSE} for fewer than two), \code{loo_one_cell} +and \code{loo_one_cell_se} (the same error with one mean for all those +rows, the reference a level has to beat), \code{loo_levels} (the +\code{loo} column those references belong to, named by level), and, +named by level, \code{sigma2} (the spread of the rows about their +cell's mean), \code{tau2} (the mean squared distance between a cell's +level and its target; \code{NA} under \code{"mean"}), \code{cells} +(the cells that hold a scored row) and \code{f_p} (the p-value of the F +test of those cells' means against one mean). + +On a ladder that \code{obs_per_cell} sets, \code{bounds} describes that +ladder: \code{ceiling} is the finest level; \code{ceiling_from} is +\code{"obs_per_cell"}, \code{"distinct locations"}, +\code{"fewer than two cells of the size"} or +\code{"fewer than two distinct locations"}; +\code{supported} is \code{FALSE} when the finest size gives fewer than +two cells or the range floor is above the finest level; +\code{levels_given} is \code{TRUE}; \code{n_sample} is every point; +\code{min_cell_n} holds the argument, which is not read; and two fields +are added, \code{obs_per_cell} (the sizes, largest first) and +\code{size_levels} (the level of each, named by size; \code{NA} for a +size of \code{"auto"} that gives fewer than two cells and was left +out). } \description{ A tessellation's resolution is the number of cells the points are cut into, and no single number settles it: the within-cluster sum of squares of the coordinates has an elbow, a piecewise-constant approximation of the response has a Mallows \eqn{C_p}, the residual autocorrelation of the cell -means has a \eqn{z}, and the cell means have a reliability. This function -computes all of them at every level of a ladder the data bound, and -returns the table, so that the level chosen, by +means has a \eqn{z}, the cell means have a reliability, and a cell value +has a leave-one-out error. On a ladder of counts this function computes +all of them at every level the data bound, and returns the table, so that +the level chosen, by \code{\link{select_resolution}()} or by eye, can be defended with the whole profile in place of one criterion's argmin. Mallows (1973) presents \eqn{C_p} itself as a display of the bias-variance trade-off across candidates; he does not offer it as a rule that picks one. This is that display, with the other criteria alongside. } +\details{ +Called with a numeric response and no predictors and none of +\code{levels}, \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +\code{range_floor}, the profile is one level: 4.5 rows per cell +(\code{obs_per_cell = "auto"}), scored for pooled values +(\code{estimate = "auto"}) by the leave-one-out error \code{loo}, with +no variogram fitted (\code{sac = "auto"}), in regions of the density +kind (\code{partition = "density"}) kept from 3 k-means++ starts +(\code{nstart = NULL}). \code{cp} and \code{reliability} need the +variogram and \code{elbow} needs a curve, so the three are \code{NA} +there; \code{moran_z} is computed. \code{\link{select_resolution}()} +reads the count off it by the size. Any of those five ladder arguments +gives the +ladder of counts described below, scored for pooled values as well. +\code{estimate = NULL, obs_per_cell = NULL, sac = NULL, partition = +"kmeans"} gives the profile of earlier versions: the ladder, its columns +and its k-means regions from 25 starts. +} +\section{The partition}{ + +The regions at every level are the Voronoi cells of a set of centres: a +point belongs to the centre nearest to it. \code{partition} says what the +centres minimise, and every level of the ladder is built with the same +kind. +\describe{ +\item{\code{"kmeans"}}{The sum, over the points, of the +squared distance to the nearest centre. The centres follow the square +root of the point density. The cells are compact, smaller where the +points are dense and larger where they are sparse, and a cell in a +dense place holds several times the points of a cell in a sparse +place.} +\item{\code{"density"} (default)}{The same sum with each point weighted +by its local density to the power \code{density_power}. The local +density at a point is the number of points in the disc that reaches +its \code{density_k}-th nearest neighbour, over the area of that disc. +With \code{density_power = 1} the centres follow the point density +itself. The cells are compact: many small ones where the points are +dense, a few large ones where they are sparse. They hold about the +same number of points each once there are more cells than dense +places (clusters of points). With fewer cells than dense places a +cell takes in whole clusters, large and small, and the counts are +about as uneven as under \code{"kmeans"}. \code{density_power = 0} +weights every point alike, which is the objective of +\code{"kmeans"}; a power above 1 goes past equal counts and gives the +cells of dense places fewer points than those of sparse places.} +} +Two simulations show both ends. The measure is the coefficient of +variation of the cell counts (their standard deviation over their mean, +0 when every cell holds the same number), as medians over 20 layers. On +1,200 points, 900 of them in four clusters over a sparse background, cut +into 60 cells, it was 1.2 under \code{"kmeans"}, where the fullest cell +held 42 times the points of the smallest, and 0.29 under +\code{"density"}, where it held 4 times. On 2,000 points with 28 dense +places (half of the points in 3 large clusters, 30 percent in 25 small +ones, the rest spread out) it was 0.90 under \code{"kmeans"} and 0.97 +under \code{"density"} at 10 cells and 1.08 and 1.01 at 20 cells; at 60 +cells it was 0.95 and 0.31, and at 130 cells 1.05 and 0.43. A ladder +starts at 2 cells, so its low levels are usually below the number of +dense places, and the counts in \code{cell_n_min} and +\code{cell_n_median} show where the two kinds part. + +The density kind is the default. The default size, 4.5 rows per cell, +puts the count above the number of dense places on a layer whose +clusters hold more than a few observations each, so the default kind and +the default count go together. A coarse ladder the caller sets (with +\code{levels}, large sizes, or the low levels of the automatic ladder) +may not, and at those levels the density kind does not even the counts. +\code{partition = "kmeans"} gives the k-means regions, with 25 +k-means++ starts, as earlier versions built them. + +\code{init} says how each of the \code{nstart} starts is drawn before it +is refined; the best start is kept. \code{"kmeans++"} draws the centres +one at a time, each a point taken in proportion to its squared distance +from the centres already drawn (times its weight, under +\code{"density"}), which spreads the start over the points. +\code{"random"} draws \code{k} distinct locations at random, as +\code{\link[stats]{kmeans}()} does. + +A start of the kind \code{"kmeans"} is refined by +\code{\link[stats]{kmeans}()} (Hartigan and Wong), for at most 50 +iterations from a k-means++ start and 100 from a random one. A start of +the kind \code{"density"} is refined by Lloyd's iteration, for at most 100 +steps: each point goes to its nearest centre, each centre moves to the +weighted mean of its points, and a centre left without a point stays +where it is. \code{iter_max} sets another limit. The start with the +lowest sum is kept, and a kept start that was cut off at the limit is +reported (see "Conditions"): its centres are those of the last step. +Large layers can need more than 100 steps: on a simulated layer of 30,000 +points no start of six at 100 and 300 cells took more than 68, and on one +of 60,000 points three of six took 102 to 152. + +The density kind depends on the points alone. It works on the distinct +locations in coordinate order, so the order of the rows does not matter. +Its two tolerances are fractions of the extent of the points (the diagonal +of their bounding box), so the unit of the coordinates does not matter: +the neighbour distance is not taken below a millionth of the extent, and +the iteration stops when no centre moves by \eqn{10^{-12}} of it. Points +at one location count as that many points at it and share a cell; the +neighbour distance is measured to the \code{density_k}-th nearest +\emph{other} location, so it is not zero where locations repeat. The +neighbour searches use \pkg{FNN} when it is installed. The result is the +same without it; the search then takes time that grows with the square of +the number of points, about thirty times as long for 10,000 points and +2,000 centres. + +The columns keep their meaning under \code{"density"}, because each is +read off the cells and not off the way they were drawn. \code{wss} is the +within-cell sum of squares of the coordinates with every point counted +once, taken about each cell's mean, so \code{wss} and \code{elbow} +compare between kinds; the weighted sum the centres minimise is kept in +\code{attr(, "partition")$objective}, and \code{wss_spread} is its spread +over the starts. \code{cp}, \code{moran_z} and the test against one cell +need cells drawn without the response, which both kinds give. +\code{reliability} is computed for square cells of the level's average +area and count and never reads the cells, so it is the same number under +either kind. The \code{elbow} is found more readily under +\code{"density"} where the points cluster: once each cluster has its +centres, further centres go into the clusters, the sparse ground between +them keeps its sum of squares, and the curve flattens. On simulated +layers of 800 points in 3 to 8 clusters over a sparse background an elbow +was read on 24 of 30 under \code{"density"} and on 10 under +\code{"kmeans"}; on 100 uniform layers, on none under either. + +A profile of the density kind, or of either kind from random starts, +carries \code{attr(, "partition")}, and +\code{\link{select_resolution}()}, the seeding functions and +\code{\link{build_tessellation}()} hand that record on with the regions +(see "Value"). A result with no such record was built by plain k-means: +from k-means++ starts when it comes from a profile, and from random +starts when a seeding function fitted it. +} + \section{The ladder and its bounds}{ -Cells are k-means clusters of the (projected) coordinates, fitted at each -level as the best of \code{nstart} k-means++ restarts (see -\code{\link{determine_optimal_levels}} for why). Levels are spaced +This is the ladder of a call that sets \code{levels}, \code{n_levels}, +\code{min_cell_n}, \code{sample_n} or \code{range_floor}, or passes +\code{obs_per_cell = NULL}, and of a call with no estimate: one without +a response, with \code{predictor_vars}, or with a logical or wholly +missing response. Cells are clusters of the (projected) +coordinates of the kind \code{partition} names, fitted at each level as +the best of \code{nstart} k-means++ starts (see +\code{\link{determine_optimal_levels}} for why) unless \code{init} says +otherwise (see "The partition"). Levels are spaced logarithmically, because cell diameter scales as \eqn{L^{-1/2}}: a unit step wastes fits at large \eqn{L} and starves resolution at small. The -ladder runs from a floor to a ceiling the data impose. The ceiling is -\code{floor(n / min_cell_n)}, with \eqn{n} every point of the layer (not -the subsample): cells with fewer than \code{min_cell_n} points -on average have too little support, and Moran's z is not computable at -nine cells or fewer in any case. It is also held to the number of -distinct locations, one cell on each, and to one short of the number of -points, which \code{stats::kmeans()} needs. The floor is -\code{ceiling(area / range^2)} when an autocorrelation range is available: -cells wider than the range average over more than one patch of the field. -When the floor exceeds the ceiling the data cannot support a tessellation +ladder runs from 2 to a ceiling the data impose. The ceiling is +\code{floor(n / min_cell_n)}: cells with fewer than \code{min_cell_n} +rows on average have too little support. With a \code{response_var}, +\eqn{n} is the number of rows of the layer (not of the subsample) that +are scored: those with a response and, with \code{predictor_vars}, every +predictor, since the cell means the criteria read are built from those +rows alone. \code{ceiling_from} is then \code{"min_cell_n (rows with a +response)"} when some rows are not scored (the label is the same when it +is a predictor they lack), and a warning of class +\code{spatialkit_response_ceiling} gives both counts and names the bound +in force. Without a +\code{response_var}, or when no row has a response, \eqn{n} is every +point. The ceiling is also held to the number of distinct locations, one +cell on each, and to one short of the number of points, which +\code{stats::kmeans()} needs. The count \eqn{n / L} is the rows per cell +only when the scored rows are spread over the whole extent. +Where they sit in one part of it, the cells elsewhere hold none and the +occupied cells hold more than \eqn{n / L}, so the ceiling is lower than +those cells need: \code{cells_resp} and \code{cell_resp_mean} give the +cells that hold a scored row and the scored rows per such cell at each +level (of the subsample, when the cells are fitted to one), and +profiling the scored rows alone bounds the ladder by the area they +cover. + +When fewer than two cells meet \code{min_cell_n} +(\code{floor(n / min_cell_n) < 2}), or the layer has one distinct +location, there is no ladder: the profile scores two cells so that level +is still visible (or the \code{levels} asked for, as given), +\code{supported} is \code{FALSE}, \code{ceiling_from} +is \code{"fewer than two supported cells"} (or \code{"fewer than two +distinct locations"}) and a warning of class +\code{spatialkit_not_supported} names both numbers. + +\code{min_cell_n} sets the ceiling of this ladder. It is a mean number +of rows per cell and not a minimum: a cell of a level at the ceiling can +hold fewer (\code{cell_n_min}). It is floored to a whole number, so 4.5 +is read as 4. With \code{levels} it does not choose the levels scored, +and it still sets \code{bounds$ceiling}, \code{supported} and the +\code{spatialkit_not_supported} warning. + +The range floor is \code{ceiling(area / range^2)} when an autocorrelation +range is available: cells wider than the range average over more than one +patch of the field. It is reported in the bounds and the print, and by +default it is not applied: the ladder starts at 2. When the layer +supports the floor and it lies between the ladder's ends, the floor is +one of the ladder's levels all the same (so the ladder can have one more +level than \code{n_levels}): \code{select_resolution(criterion = +"reliability")} reads from the floor up and returns the floor itself, not +the next level the spacing happened to put above it. The range is an +estimate, and a response with no spatial structure can still be given +one: over 100 simulated white-noise layers of 900 points the variogram +returned a range on 29, and started at the floor, 11 of those ladders +began at 11 to 98 cells of a ceiling of 100 and \eqn{C_p} took the floor +or a level beside it, where the best count was 2 to 8. +\code{range_floor = TRUE} starts the ladder at the floor, as the default +did up to version 2.0.0. When +the floor exceeds the ceiling the data cannot support a tessellation that respects their own correlation structure; that is reported as a -finding (a logged warning, and \code{attr(x, "bounds")$supported} is -\code{FALSE}) and the ladder runs from 2 to the ceiling anyway, so the -profile still shows what each level costs. On a layer larger than -\code{sample_n} the ceiling is also held to half the subsample (two -subsample points per cell, the least a fitted cell can be scored on); -\code{ceiling_from} is then \code{"sample_n"}, a floor above that is logged -with a request to raise \code{sample_n}, and it does not make -\code{supported} \code{FALSE}. - -The floor moves with the range estimate, and the ceiling with \eqn{n}, so -two profiles of similar data (the folds of a cross-validation, say) can -sit on either side of the point where the floor applies: one ladder then -starts at the floor and the other at 2, and the criteria that sit near -the bottom of the ladder (\code{reliability}, which routinely peaks at the -floor, and \code{elbow}) can differ between them by a factor of 10 or -more. To compare profiles, pass the same \code{levels} to each, or -\code{range_floor = FALSE} to start every ladder at 2 while the floor is -still reported. +finding (a warning of class \code{spatialkit_not_supported}, and +\code{attr(x, "bounds")$supported} is \code{FALSE}) and the ladder runs +from 2 to the ceiling, so the profile still shows what each level costs. +A floor equal to the ceiling would leave one level and nothing to compare +it with, so that ladder starts at 2 as well. On a layer larger than +\code{sample_n} the ceiling is also held to half the subsample's scored +rows (two per cell, the least a fitted cell can be scored on; half the +subsample without a response); \code{ceiling_from} is then +\code{"sample_n"}, a floor above that is logged with a request to raise +\code{sample_n}, and it does not make \code{supported} \code{FALSE}. + +The floor moves with the range estimate, and the ceiling with \eqn{n}. +To compare profiles of similar data (the folds of a cross-validation, +say), pass the same \code{levels} to each. \code{reliability} is the one +criterion that still reads the floor: \code{\link{select_resolution}()} +holds it to the levels at or above the floor by default, so its pick can +differ between two such profiles by a factor of 10 or more when the floor +is supported on one and not on the other; pass \code{range_floor = FALSE} +there to read the whole ladder. + +A ladder that \code{obs_per_cell} sets is a ladder of sizes (see +"Observations per cell"). It has one level per size \eqn{s}, +\code{max(2, round(n / s))} cells, held to the most centres k-means can +place: the distinct locations, and one short of the points. Its centres +are fitted to every row. No subsample is drawn, and \code{n_levels}, +\code{min_cell_n}, \code{sample_n} and \code{range_floor} are not read. +The finest size takes the part \code{min_cell_n} has on the ladder above: +\code{bounds$ceiling} is the finest level, and \code{supported} is +\code{FALSE} when the finest size gives fewer than two cells or the range +floor is above the finest level. The range floor is reported and not +applied. + +A ladder of sizes under \code{sac = "auto"} fits no variogram, so +\code{cp} and \code{reliability} are \code{NA} at every level there, and +\code{attr(, "cp_noise")} says why. \code{sac = NULL}, or a \code{sac} of +the caller's own, gives them. \code{sac = "auto"} and +\code{obs_per_cell = "auto"} are the defaults, so the default profile +has neither column. +} + +\section{Observations per cell}{ + +\code{obs_per_cell} sets the ladder by a size: the mean number of rows a +cell is to hold. The level of a size \eqn{s} is +\code{max(2, round(n / s))} cells, with \eqn{n} the rows the size +divides (see the argument). A size says how many observations a cell +value is to stand on, and that is the caller's choice: no criterion makes +it. Under a size neither the cells, which are fitted to the coordinates, +nor their number, which is a count of rows, depend on the values of the +response. Under \code{select_resolution(criterion = "loo")} the count +does. + +For pooled values the leave-one-out error tends to keep falling as the +cells shrink, so its minimum tends to be the finest size offered, and the +end of the ladder would then choose the count. In a simulation +of 200 layers, each 1,500 clustered observations of a field with +covariance \code{exp(-d / 100)} plus noise on a square of side 1,000 +(\code{dev/sim-pooled-values.R} in the package's repository; +\code{\link{summarize_by_cell}} describes it), profiled at the sizes 18, +12, 9, 6, 4.5, 3 and 2 with \code{partition = "density"}, the lowest +\code{loo} of the pooled value was at the size 2 on 176 layers, at 3 on +22 and at 4.5 on 2. That of the plain mean was at 2 on none: it was at 6 +on 86 layers, at 4.5 on 51, at 9 on 49, at 12 on 12, and at 18 and at 3 +on one each. \code{select_resolution(criterion = "size")} therefore sets +the count of pooled values from a size, 4.5 unless another is given, and +\code{criterion = "loo"} reads the lowest error for plain means. These +figures are of those seven sizes and say nothing of another ladder. + +Two columns say what a size leaves a cell value to stand on. +\code{share_alone} is the share of the scored rows that are the only +scored row of their cell: the plain mean of such a cell is one +observation, and its pooled value has the smallest own weight a cell can +have. \code{own_weight} is the median weight a pooled value gives the +cell's own mean: at 1 the pooled values are the plain means, and at 0 +each is the mean of the cell's neighbours. + +\code{obs_per_cell = "auto"}, the default, is resolved against the other +ladder arguments, in this order. Whether the caller supplied an argument +is what counts, so a value a wrapper passes on counts as supplied. +\enumerate{ +\item With \code{levels}, \code{"auto"} is \code{NULL}: the levels are +scored as given. A numeric \code{obs_per_cell} beside \code{levels} +is an error, since each sets the ladder. +\item With \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +\code{range_floor} supplied, \code{"auto"} is \code{NULL}: those +arguments describe the ladder of "The ladder and its bounds", and the +caller gets it, with the estimate's columns when there is an +estimate. +\item Otherwise \code{"auto"} is 4.5 when the estimate is +\code{"pooled"}, the seven sizes 18, 12, 9, 6, 4.5, 3 and 2 when it +is \code{"mean"}, and \code{NULL} without an estimate. +\item A numeric \code{obs_per_cell} beside \code{n_levels}, +\code{min_cell_n}, \code{sample_n} or \code{range_floor = TRUE} sets +the ladder, with a warning of class \code{spatialkit_ladder_unused} +that names the arguments that are not read. } -\section{The criteria, and how each behaved when measured}{ +On a ladder of sizes the centres are fitted to every row and the count of +cells grows with the rows, so a step that compares every point with every +centre grows with the square of the rows. \code{partition = "kmeans"} +has such a step in every pass and in a k-means++ start. \code{partition += "density"} has it in a k-means++ start and, without \pkg{FNN}, in every +pass; with \pkg{FNN} and \code{init = "random"} it has none. The profile +stops before any fit, with an error of class +\code{spatialkit_work_limit}, when the points times the cells of the +finest level times \code{nstart} (times \code{iter_max} for the density +kind without \pkg{FNN}) is above +\code{getOption("spatialkit.fit_work_max", 1e10)}. The message names the +ways on: fewer starts, which keep the best of fewer; a coarser size; +\code{partition = "density"} with \code{init = "random"} and \pkg{FNN} +installed, which leaves a cell without a point more often (see +\code{spatialkit_empty_cells} under "Conditions"); or a higher limit. +The limit counts the finest level, and a ladder of several sizes fits +every one of its levels. At the default size the work grows with the +square of the rows, and the limit is set where the default call's fit +takes about a minute: a call just below it runs that long, and prints +nothing while it runs. +Without \pkg{FNN} the density kind also finds its weights by comparing +every pair of distinct locations. A profile on a ladder of sizes stops, +with the same class, when the square of their number is above +\code{getOption("spatialkit.exact_pairs_max", 2e9)}, which is about +44,700 locations. The result of every search is the same with and +without the package. \code{moran_i} and \code{moran_z} need \pkg{FNN} +and \pkg{Matrix} at a level where more than 5,000 cells hold a scored +row. Without them a ladder of sizes has \code{NA} in both columns +there, with a warning of class \code{spatialkit_moran_skipped}, and so +does a ladder set any other way (see "Conditions"). +At a level of up to 5,000 such cells, when either package is missing, the +neighbour weights of the cell means are held as a dense matrix of cells +by cells. +} + +\section{The criteria, and what each returns in practice}{ + +The four columns are not four interchangeable count rules. +\code{select_resolution()} reads \code{cp} by default on a profile +without an estimate; on one with an estimate it reads the size (pooled +values) or \code{loo} (plain means). \code{reliability} +needs a variogram range and is \code{NA} without one; \code{elbow} is +\code{NA} unless the points cluster; and \code{moran_z} is a diagnostic +and not a count rule. With an \code{estimate} the profile has a fifth +column, \code{loo}, which is the last entry. Each entry below says what +the column measures and what it returns in practice. \describe{ \item{\code{elbow}}{How far the WSS curve sags below a power law: on log-log axes, \eqn{\log} WSS below the straight line from \eqn{k = 1} @@ -221,13 +770,22 @@ locations repeat, is left out of the line; when the other levels have no elbow, that fall to zero is the elbow, and its sag is measured with the WSS floored at \eqn{10^{-12}} of the total, which puts it far above any other level's. Geometry only; it knows nothing of the -response.} +response. \strong{In practice it is \code{NA} unless the points +cluster}, and where they do it names the number of clusters, which +is usually the first level or two of the ladder.} \item{\code{cp}}{Mallows' \eqn{C_p} of the piecewise-constant approximation of the response (or of its OLS residuals on \code{predictor_vars}) by cell means: \eqn{RSS(L)/n + 2 \tau^2 L / n}, with \eqn{\tau^2} the nugget of the fitted variogram (lower is better). -It estimates the error of predicting a new observation by the mean of -its cell. When the cells are fitted to a subsample of \eqn{m} of the +It estimates the error of re-measuring the sampled sites: each scored +row observed again at its own location, with fresh noise of variance +\eqn{\tau^2}, and predicted by the mean of its cell. For an +observation at a new location the penalty needs the spread of the +field inside a cell as well, which the nugget leaves out. This +\eqn{\tau^2} is the nugget, the noise of one measurement; it is not +the \code{tau2} of a pooled value, which is the mean squared distance +between a cell's level and its target. When the +cells are fitted to a subsample of \eqn{m} of the \eqn{N} points with a response, the penalty is split between the two: \eqn{RSS(L)/m + \tau^2 L_m / m + \tau^2 L / N}, where the first two terms estimate the approximation error from the subsample (adding back @@ -248,36 +806,103 @@ only when the nugget is a large share of the sill. With a nugget of 0 (under \eqn{10^{-4}} of the sill; usually a fit clipped at its lower bound) the penalty is 0 and \eqn{C_p} descends to the ceiling whatever the field; the profile warns. When the variogram gives no nugget (none -was fitted, its fit did not converge, its range is below the shortest -lag, or \code{sac} is a range alone), \eqn{\tau^2} is Mallows' own +was fitted, its fit has no minimum inside the ranges searched, its +range is below the shortest lag, it found no spatial structure, or +\code{sac} is a range alone), \eqn{\tau^2} is Mallows' own choice instead: the residual mean square \eqn{RSS / (m - L_m)} of the finest level whose cells hold at least two scored rows on average. It counts the structure within those cells as noise too, so on average it is no smaller than the nugget and errs towards fewer cells; the profile warns, and \code{attr(, "cp_noise")} records which was used. When no level's -cells hold that many, \code{cp} is \code{NA} at every level.} -\item{\code{moran_z}}{The standardised deviate of Moran's I on the -residuals of the cell means regressed on the cell-mean predictors (an -intercept alone when there are none): how much spatial structure the -tessellation has left unexplained (\eqn{|z|} smaller is better). -Calibrated and flat in \eqn{L} on a response with no structure (see -\code{\link{determine_optimal_levels}}), so it separates levels only -where structure remains. \code{NA} at nine cells or fewer.} +cells hold that many, \code{cp} is \code{NA} at every level, as it is +for a constant response, which the profile warns about. +\strong{In practice its minimum is often a bound}, the support +ceiling when the nugget is a small share of the sill, and +\code{select_resolution()} then names the bound in \code{edge}. The +same formula at one cell, +with the total sum of squares as its RSS, is kept in +\code{attr(, "one_cell")}, with the p-value at every level of the F +test of that level's cell means against one mean. A level has to +beat one cell: \code{select_resolution()} returns +\code{structured = FALSE} when \eqn{C_p} at one cell is within +\code{tol} of the optimum, or when the cell means at the optimum +differ from one mean by no more than chance allows, because one mean +for the whole layer then predicts as well as the cells and the count +is not identified (see \code{\link{select_resolution}} for the rule +and its measured error rates).} +\item{\code{moran_z}}{\strong{A diagnostic of the cell means, not a +count rule.} The standardised deviate of Moran's I on the cell +means, or with \code{predictor_vars} on the residuals of the cell +means regressed on the cell-mean predictors, over the 8 nearest +neighbours of each cell. It tests whether neighbouring cell means +are independent. It does not measure what the cells leave +unexplained, and it does not say how well they represent the +response. On any autocorrelated response it grows as the cells get +finer than the range, because neighbouring cells then resemble each +other, and it has almost no +power below about 20 cells, where the 8-neighbour graph between cells +is close to complete and Moran's I sits near \eqn{-1/(L - 1)} +whatever the data. The level with the smallest \eqn{|z|} is +therefore among the coarsest it is computed at on a structured +response, whatever the layer and its ceiling, and arbitrary on a +response with no structure, where +\eqn{z} is calibrated and flat in \eqn{L}. +\code{select_resolution()} refuses to read it as a criterion unless +asked with \code{diagnostic = TRUE}, and neither \code{summary()} nor +the functions that take a profile as a cell count read it by +default. \code{NA} at nine cells or fewer.} \item{\code{reliability}}{The between-cell signal's share of the spread in the cell means, from the fitted variogram alone via Krige's additivity relation (Cressie 1996), for square cells of the level's average area holding the level's average share of the layer's points with a response (larger is better). -This is the shrinkage factor of Fay and Herriot (1979). It has an -interior optimum, and a broad one: validated against the empirical -reliability of true block means on simulated fields, the analytic and -empirical optima agreed to within a level or two where the empirical -estimate was stable, and the band within 2 percent of the maximum -spanned a factor of 3--6 in \eqn{L}. Read the flat region, not the -argmax. The domain term is taken over the convex hull the area is -measured on, so rotating the layer does not move it. \code{NA} -without a usable variogram, and when the variogram's range was -rejected (see \code{sac}).} +This is the shrinkage factor of Fay and Herriot (1979). The curve +has an interior optimum, and a broad one: validated against the +empirical reliability of true block means on simulated fields, the +analytic and empirical optima agreed to within a level or two where +the empirical estimate was stable, and the band within 2 percent of +the maximum spanned a factor of 3--6 in \eqn{L}. \strong{That +optimum usually lies below the range floor}: on 20 simulated fields +of 900 points the curve read from the floor up was highest at the +floor on 19. +\code{select_resolution()} therefore reads it at the levels at or +above the floor (its \code{range_floor} argument), and what it +returns is then the floor, which is a level of every ladder the +profile builds: the coarsest +count the range allows, with the range choosing and not the curve. +Read the flat region, not the argmax. The domain term is taken over +the convex hull the area is measured on, so rotating the layer does +not move it. \code{NA} without a usable variogram, and when the +variogram's range was rejected (see \code{sac}).} +\item{\code{loo}}{With an \code{estimate}: the leave-one-out mean +squared error of that cell value (lower is better). It estimates the +squared error of predicting one further observation, at a location +drawn the way the data's locations were, by the value of the cell it +falls in. That error depends on the cell value, so the column is +computed for the estimate the profile is given and for no other. +Each scored row of the layer is predicted by the value of its cell +computed without it, in the cell of its nearest centre, which is the +cell the seeds will build. Under \code{"mean"} a row in a cell of +two or more is predicted by the mean of the others, and a row alone +in its cell by the mean of the cell of its nearest other scored row. +Under \code{"pooled"} the cell's mean and its own weight are computed +again without the row; the spread inside the cells, the spread +between a cell and its target and the targets are held; and a cell +left empty takes its target. It needs no variogram. It describes +locations among the observations and says nothing of a location away +from them: it is a criterion for comparing levels where data are +near, not an estimate of the error of a map. \code{loo_se} is the +standard error, over rows, of that level's mean squared error. It is +not the standard error of a difference between two levels, whose +errors come from the same rows. \code{scored_per_cell} counts the +rows \code{loo} read, every scored row of the layer, over the cells +that hold one; \code{cell_resp_mean} counts the rows the other +response criteria read, which are the subsample's when the cells are +fitted to one. \strong{In the simulation described under +"Observations per cell", on a ladder of the seven sizes 18 to 2, its +minimum was at the finest size on 176 of 200 layers for pooled values +and on none for plain means}: for pooled values a size sets the count, +and \code{select_resolution(criterion = "size")} reads it.} } \code{cp} and \code{reliability} answer different questions: how well the cells represent the field, and whether the cell values are distinguishable @@ -285,23 +910,185 @@ from noise. They can disagree, and both are shown so the choice between them is made knowingly. } +\section{Conditions}{ + +What changes the meaning of a result is raised as an R warning with a +class, so \code{tryCatch()}, \code{withCallingHandlers()} and +\code{options(warn = 2)} see it without matching message text; the rest +is logged (see \code{\link{spatialkit_quiet}}). +\describe{ +\item{\code{spatialkit_not_supported}}{\code{resolution_profile()}: +\code{supported} is \code{FALSE}, because the range floor exceeds the +ceiling or because fewer than two cells meet \code{min_cell_n}.} +\item{\code{spatialkit_response_ceiling}}{\code{resolution_profile()}: +rows that are not scored (no response, or with \code{predictor_vars} +a predictor missing) lowered the ceiling. The message names the +bound in force, \code{min_cell_n} or, on a subsample, \code{sample_n}; +the condition carries \code{n}, \code{n_response}, \code{ceiling}, +\code{ceiling_from}, \code{n_sample} and \code{n_scored}.} +\item{\code{spatialkit_constant_response}}{\code{resolution_profile()}: +the scored variable is constant to within rounding (a response the +predictors fit exactly leaves such residuals), so \code{cp}, +\code{moran_i} and \code{moran_z} are \code{NA} at every level.} +\item{\code{spatialkit_empty_cells}}{\code{resolution_profile()}, +\code{\link{get_voronoi_seeds}()} and +\code{\link{voronoi_seeds_kmeans}()} under \code{partition = + "density"}: a centre holds no point, so there are fewer occupied cells +than the count. A centre that loses its points stays where it is, and +the start that is kept is the one with the lowest sum, whether or not +all its centres hold points. It happens at high counts, mostly from +\code{init = "random"}. On simulated layers of 800 points (in 4 +clusters, in 28, and uniform; 20 of each) no partition into 80 cells +or fewer had such a centre. At 400 cells, from random starts with +the best of 10 kept, 2, 5 and 1 of the 20 layers had one; from +k-means++ starts none of 840 partitions at 40 to 600 cells had one, +though it can happen. The condition carries \code{level}, the count, +and \code{empty}.} +\item{\code{spatialkit_not_converged}}{\code{resolution_profile()}, +\code{\link{get_voronoi_seeds}()} and +\code{\link{voronoi_seeds_kmeans}()}, for every call except the +plain k-means each has always run: the start that was kept was cut +off at the iteration limit, so its centres are those of the last step +and a longer run can still move points between cells. The condition +carries \code{level} (the count; for a profile every level it +happened at), \code{iter} and \code{iter_max}. Raise +\code{iter_max} (\code{kmeans_iter} in +\code{get_voronoi_seeds()}).} +\item{\code{spatialkit_partition_unused}}{\code{\link{get_voronoi_seeds}()} +and \code{\link{voronoi_seeds_kmeans}()}, given a profile or a +\code{select_resolution()} result together with a \code{partition}, +an \code{init} or density settings other than those the profile was +built with: the scored centres are returned, and what the call asked +for is not used. The +condition carries \code{kind} and \code{init}, those of the centres +returned.} +\item{\code{spatialkit_bound_chosen}}{\code{\link{get_voronoi_seeds}()}, +\code{\link{voronoi_seeds_kmeans}()} and +\code{\link{build_tessellation}()}, given a profile or a +\code{select_resolution()} result whose optimum sits on a bound of +the ladder: the bound chose the count. The condition carries +\code{edge}, \code{criterion} and \code{n}.} +\item{\code{spatialkit_no_structure}}{The same functions, given a count +whose \code{structured} is \code{FALSE}: one cell does as well, so +the count is not identified. A count set by a size stands, since no +criterion chose it, and the warning then says that the cell values +will say little that one mean for the layer does not. +\code{\link{summarize_by_cell}(estimate = "pooled")} raises the class +for its own cells.} +\item{\code{spatialkit_no_elbow}}{\code{\link{determine_optimal_levels}()}: +the WSS curve has no elbow, or the ladder is too short to show one, +so the count returned is the ladder's and not a finding. The +condition carries \code{k}, \code{sag} and \code{structured}.} +\item{\code{spatialkit_diagnostic_ranking}}{\code{\link{determine_optimal_levels}()} +under \code{criterion = "morans_i"} or \code{"combined"}: Moran's z +of the cell means, a diagnostic and not a count rule, ordered the +candidates returned. The condition carries \code{k}, +\code{criterion}, \code{first_computable}, \code{window} and +\code{upgraded}.} +\item{\code{spatialkit_ladder_unused}}{\code{resolution_profile()}: a +numeric \code{obs_per_cell} sets the ladder, and the caller also +supplied \code{n_levels}, \code{min_cell_n}, \code{sample_n} or +\code{range_floor = TRUE}, which are then not read. The condition +carries \code{unused} (the argument names) and \code{obs_per_cell}.} +\item{\code{spatialkit_size_not_reached}}{\code{resolution_profile()} +on a ladder of sizes: a size does not give the count it asks for. +Either a size given as a number gives fewer than two cells while a +finer one does not, and its level is 2 (\code{reason} is +\code{"fewer than two cells"}); or a size asks for more cells than +k-means can place, and its level is the most that can (\code{reason} +is \code{"more cells than can be placed"}). The condition carries +\code{obs_per_cell}, +\code{wanted}, \code{used} and \code{reason}. When the finest size +gives fewer than two cells the warning is +\code{spatialkit_not_supported}, with \code{obs_per_cell} among its +fields and \code{min_cell_n} \code{NA}; and +\code{spatialkit_response_ceiling} is not raised on such a ladder, +since a size already counts the rows with a response.} +\item{\code{spatialkit_repeated_locations}}{\code{resolution_profile()} +with an \code{estimate}: scored rows share a location. Each row is +left out alone and the others at its location stay, so \code{loo} +then describes a further observation at a place already observed. +Raised once, after the levels are scored, and not when \code{loo} is +\code{NA} at every level. The condition carries \code{n} (the rows +that share a location), \code{total} (the rows \code{loo} read) and +\code{column}.} +\item{\code{spatialkit_moran_skipped}}{\code{resolution_profile()} +with a level of more than 5,000 cells, on any ladder, when +\pkg{FNN} or \pkg{Matrix} is not installed: \code{moran_i} and +\code{moran_z} are \code{NA} at a level where more than 5,000 cells +hold a scored row, and every other column is computed. Raised once, +before the first fit, when such a level can occur: the cells that +hold a scored row are counted after a level's fit, so where rows +without a response leave fewer of them the two columns are computed +after all. The condition carries \code{limit}, \code{levels} (the +levels above the limit) and \code{missing}.} +} +Two refusals are errors with a class: \code{spatialkit_diagnostic_criterion} +(\code{select_resolution(criterion = "moran_z")} without +\code{diagnostic = TRUE}) and \code{spatialkit_no_default_criterion} (a +profile passed as a cell count whose \code{cp} is \code{NA} at every +level while another criterion is finite). The remaining warnings of +these functions (points dropped, a variogram that gives \code{cp} no +nugget, a zero nugget, a variogram of another variable) are R warnings +without a class; rows left out for a missing response, a rising WSS +curve and a subsample too small to reach the floor are logged only. + +A third refusal is an error of class \code{spatialkit_work_limit}: +\code{resolution_profile()} stops before a step whose count of +comparisons is above a limit. The condition carries \code{work} (the +count), \code{limit} and \code{what} (the step). On a ladder that +\code{obs_per_cell} sets, the count of cells grows with the rows, so two +costs are bounded before the variogram is estimated and before any fit. +The fits: the points times the cells of +the finest level times \code{nstart} may not pass +\code{getOption("spatialkit.fit_work_max", 1e10)} +(\code{what = "partition fit"}; the condition also carries \code{kind}, +\code{init}, \code{nstart} and \code{fnn}). That product counts the +step in which every point is compared with every centre, which +\code{partition = "kmeans"} has in every pass and in a k-means++ start, +and \code{partition = "density"} has in a k-means++ start. Without +\pkg{FNN} the density kind compares every point with every centre in +every pass, and the product is multiplied by \code{iter_max}; with +\pkg{FNN} and \code{init = "random"} it has no such step and nothing is +counted. The density kind's weights: without \pkg{FNN} they come from a +search that compares every pair of distinct locations, and the square of +their number may not pass \code{getOption("spatialkit.exact_pairs_max", +2e9)} (\code{what = "density weights"}); \code{density_power = 0} has no +weights and no such search. With an \code{estimate} and without +\pkg{FNN}, on any ladder, the same limit bounds the three exact searches +the estimate's columns make: each scored row's nearest centre, each cell's +nearest cells, and, under \code{"mean"}, the nearest other location of a +row alone in its cell. The result of every search is the same with and +without \pkg{FNN}. + +The warnings of the pooled values and of the count record, which +\code{\link{summarize_by_cell}()} raises, are listed under "Conditions" on +its page. +} + \examples{ if (requireNamespace("gstat", quietly = TRUE)) { library(sf) # An exponential field with range parameter 200 (true effective range - # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough - # noise for Mallows' Cp to have an interior optimum rather than descend - # to the ceiling. + # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$z <- as.numeric(t(chol(exp(-D / 200) + diag(0.6, n))) \%*\% rnorm(n)) pts <- st_as_sf(xy, coords = c("x", "y"), crs = 32632) + # n_levels asks for the ladder of counts. prof <- resolution_profile(pts, response_var = "z", n_levels = 12) print(prof) # one row per level; print() because only the # last value of a braced block is shown - select_resolution(prof, criterion = "cp") + attr(prof, "bounds")$floor # the range floor: reported, not applied + print(select_resolution(prof, criterion = "cp")) + + # The default profile: one level at 4.5 rows per cell, scored for + # pooled values, in density-weighted cells, with no variogram. + prof1 <- resolution_profile(pts, response_var = "z") + print(prof1) + select_resolution(prof1) # the count the size gives } } \references{ @@ -326,6 +1113,7 @@ and \code{n}. Other aggregation: \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, \code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, \code{\link[=kriging_adequacy]{kriging_adequacy()}}, \code{\link[=select_resolution]{select_resolution()}}, diff --git a/man/sac_nugget.Rd b/man/sac_nugget.Rd index a0cb03c4..7ec69e99 100644 --- a/man/sac_nugget.Rd +++ b/man/sac_nugget.Rd @@ -12,21 +12,63 @@ sac_nugget(x) \value{ A single number: the nugget in the units of the response's variance; \code{NA_real_} when \code{x} carries no fitted model (a bare -\code{NA} from a run that could not fit anything, a rejected result whose -fits were all singular, or an object that is not a \code{sac_range}). +\code{NA} from a run that could not fit anything, a rejected result with +too few lag bins to fit, or an object that is not a \code{sac_range}). } \description{ The nugget variance of the variogram model behind a -\code{\link{estimate_sac_range}()} result: the semivariance at zero -separation, i.e. measurement error plus variation at scales shorter than -the first lag bin of the empirical variogram (gstat's bins are -\code{cutoff / 15} wide, about \code{max_dist / 30} at the default -\code{cutoff}), which can be far wider than the spacing of close pairs. -It is extrapolated to zero from that bin, not observed, and a fit that -runs into its lower bound reports exactly 0. It is carried as the -\code{nugget} attribute of every classed result, identified or rejected, -because it is the number a resolution criterion for a tessellation needs -(the short-lag variance that no cell can average away). +\code{\link{estimate_sac_range}()} result: the model's semivariance as +the separation shrinks to zero, i.e. measurement error plus variation at +scales shorter than the first lag of the empirical variogram. It is +extrapolated to zero from that lag, not observed, so it is only as good +as the first lag is short: \code{attr(x, "first_lag")} says where the +extrapolation starts. +With \code{lags = "adaptive"} (the default) that is the separation of the +closest pairs of points; with \code{lags = "equal"} it is the middle of a +bin \code{cutoff * max_dist / n_lags} wide, which on a dense layer can be +many times the spacing of close pairs, and structure shorter than that +bin is then counted as nugget. +} +\details{ +Three more attributes say how far to trust it. +\code{attr(x, "nugget_at_bound")} is \code{TRUE} when the fit put the +nugget at its lower bound (0, or within 1e-4 of the sill): that is the +bound and not an estimate, and a criterion that uses it as a noise +variance has no penalty left. \code{attr(x, "short_lag_semivariance")} +is the semivariance of nearest-neighbour pairs, computed with no model: +each location is paired with the nearest other location +(\code{short_lag_pairs} and \code{short_lag_dist} give the number of +such pairs and their median separation). A semivariance does not fall +as the lag shrinks, so this value bounds the nugget from above, up to its +sampling error; a fitted nugget well above it is contradicted by the +closest pairs. \code{attr(x, "zero_lag_semivariance")} exists where +locations were visited more than once (\code{zero_lag_pairs} is not 0): +it is the semivariance of every pair of rows that share a location, that +is, the variance between visits to one place. That is the measurement +part of the nugget, observed and not extrapolated, without the variation +at scales below the spacing of the locations, so it bounds the nugget +from below. Such pairs are at no lag and are in no bin of the +variogram: the model, and so the nugget, describe positive separations. +The variogram fit uses the bound, though: where it rests on 30 degrees +of freedom or more (rows less locations) the nugget is not let under it, +and \code{attr(x, "nugget_floor")} holds the value (0 when there is no +floor). With \code{detrend = "reml"} the model is built from the REML +parameters and takes no floor: its nugget can come out below the +variance between visits, and \code{nugget_floor} is 0. +A nugget equal to its floor is the variance between visits, a +measurement, and \code{nugget_at_bound} stays \code{FALSE} for it. + +When \code{attr(x, "lag_fallback")} is \code{TRUE} the result is the +equal-lag one although adaptive lags were asked for (see "The lags" in +\code{\link{estimate_sac_range}}), and its nugget is extrapolated from +the first equal bin. + +The nugget is carried as the \code{nugget} attribute of every classed +result, identified or rejected, because it is the number a resolution +criterion for a tessellation needs (the short-lag variance that no cell +can average away). On a result refused for want of spatial structure it +is the variance of the modelled variable, which is the nugget of the +model that refusal supports. } \examples{ if (requireNamespace("gstat", quietly = TRUE)) { @@ -39,23 +81,26 @@ if (requireNamespace("gstat", quietly = TRUE)) { xy$z <- as.numeric(t(chol(exp(-D / 150) + diag(0.5, n))) \%*\% rnorm(n)) r <- estimate_sac_range(st_as_sf(xy, coords = c("x", "y"), crs = 32632), "z") print(sac_nugget(r)) # the fitted nugget variance, on the sill's scale + attr(r, "nugget_at_bound") # FALSE: an estimate, not the bound + attr(r, "short_lag_semivariance") # what the closest pairs say, no model + attr(r, "zero_lag_pairs") # 0: no location was visited twice sac_nugget(NA) # nothing fitted: NA } } \seealso{ \code{\link{estimate_sac_range}}, which produces the object. -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{select_features_forward}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=select_features_forward]{select_features_forward()}} } \concept{cross-validation} diff --git a/man/select_features_forward.Rd b/man/select_features_forward.Rd index 191f2f70..22a9d5bb 100644 --- a/man/select_features_forward.Rd +++ b/man/select_features_forward.Rd @@ -19,7 +19,10 @@ select_features_forward( seed = 123, quiet = FALSE, auto_range = FALSE, - select_on = c("all", "split") + select_on = c("all", "split"), + rule = c("se", "tol"), + se_mult = 1, + null_fn = NULL ) } \arguments{ @@ -43,13 +46,14 @@ size so inner and outer blocks are on the same spatial scale.} \item{metric}{Score to optimise: \code{"RMSE"}, \code{"MAE"} (minimised) or \code{"R2"} (maximised). Default \code{"RMSE"}.} -\item{tol}{Minimum improvement required to accept a variable. Default 0, -meaning any improvement is accepted. The first variable is judged against -the null (intercept-only) model, so \code{tol} bites from step 1, but -only when that null model can be scored. Backends that refuse a -zero-length \code{predictor_vars} (\code{\link{fit_rf_model}} and -\code{\link{fit_gwr_model}} both do) have no null score, and there the -first variable is accepted unconditionally.} +\item{tol}{Minimum improvement of the pooled score required to accept a +variable, in the units of \code{metric}. Default 0. It is a floor +under both rules: with \code{rule = "tol"} it is the whole test, and +with \code{rule = "se"} the per-fold test applies as well. The first +variable is judged against a baseline with every learner; see \emph{The +baseline for the first variable}. Any single number is accepted: +\code{Inf} leaves nothing selected, and \code{-Inf} puts no floor under +a step.} \item{max_vars}{Optional cap on how many predictors to select.} @@ -88,25 +92,66 @@ rows near it are still correlated with the selection half. Both halves come back in \code{$split}. See the "Post-selection inference" section of \code{\link{determine_optimal_levels}} for the trade: coverage for half the sample.} + +\item{rule}{How a step is judged. \code{"se"} (default) accepts the best +candidate when its pooled gain exceeds \code{tol} and its mean per-fold +gain exceeds \code{se_mult} standard errors of that mean; +\code{"tol"} accepts any pooled gain above \code{tol}, the behaviour +before this argument existed. See \emph{When a variable is accepted}.} + +\item{se_mult}{Number of standard errors the mean per-fold gain must +exceed under \code{rule = "se"}. Default 1; 0 asks only that the mean +per-fold gain be positive.} + +\item{null_fn}{Optional function \code{(train_sf)} returning a fitted +model with no predictors, used as the baseline for the first variable +when \code{fit_fn} cannot fit an empty predictor set. Default +\code{NULL}: \code{fit_fn(train_sf, character(0))} is tried, and the +training-fold mean is used when that fails. The example builds one.} } \value{ A list of class \code{"feature_selection"} (so that \code{\link{plot.feature_selection}()} draws the selection path) with -\code{selected} (the chosen predictors, in the order they were added), -\code{score}, \code{score_holdout}, \code{history}, \code{params} and -\code{split}. +\code{selected} (the chosen predictors, in the order they were added; +possibly none), \code{score}, \code{score_holdout}, \code{history}, +\code{params}, \code{split}, \code{baseline} and \code{fold_scores}. \code{score} is the winning set's cross-validated \code{metric} at the final step: the \strong{selection-internal} optimum, optimistically biased because it was chosen as the best of many (see the section above), and \code{NA} when nothing was selected. \code{history} is a data.frame -with \code{step}, \code{variable}, \code{score} and \code{n_pred}, -holding every candidate evaluated at every step; when the null model -could be scored it also carries a \code{step = 0} row named -\code{""} giving that baseline, so the first variable's gain can be -read off directly. Every set is scored on the same rows: those the null -model's cross-validation predicted or, when there is no null model, -those any step-1 set predicted; \code{params$n_scored} counts them (a -warning says so when that is fewer than all). \code{n_pred} is how many +with \code{step}, \code{variable}, \code{score}, \code{n_pred}, +\code{gain}, \code{fold_gain} and \code{fold_gain_se}, +holding every candidate evaluated at every step, and a \code{step = 0} +row named \code{""} giving the baseline, so the first variable's +gain can be read off directly. \code{gain} is the candidate set's +improvement in the pooled score over the set it was added to (the +baseline at step 1), \code{fold_gain} the mean of the per-fold +improvements and \code{fold_gain_se} its standard error: the three +numbers the rule reads. \code{fold_scores} is a data.frame with +\code{step}, \code{variable}, \code{fold} and \code{score}: the metric +of every set in every fold. \code{baseline} is a list with +\code{type} (\code{"null model"}, \code{"null_fn"} or +\code{"fold mean"}), \code{score}, \code{path} (the set the sweep +reached), \code{gain}, \code{fold_gain} and \code{fold_gain_se} (that +set against the baseline), \code{kept} (\code{FALSE} when the path +did not beat a fold-mean baseline and \code{selected} is empty for that +reason; \code{NA} when the path is empty) and \code{first}. +\code{first} is \code{NULL} unless the baseline is the fold mean and a +path of two or more variables was kept; it is then the test of the +first variable, a list with \code{variable}; \code{gain}, +\code{fold_gain} and \code{fold_gain_se} (the path against the path +without that variable); \code{rest}, a list with \code{vars}, +\code{score}, \code{gain}, \code{fold_gain} and \code{fold_gain_se} +(the path without it, and that set against the baseline); +\code{dropped} (\code{TRUE} when the variable was taken out: +\code{selected} is then \code{path[-1]} and \code{score} is +\code{rest$score}); and \code{note}, the verdict in words. The set +scored for that test is not a step of the sweep, so it is not in +\code{history} or \code{fold_scores}. Every set is scored on the +same rows: those the null model's cross-validation predicted or, when +the baseline is the fold mean, those any step-1 set predicted; +\code{params$n_scored} counts them (a warning says so when that is +fewer than all). \code{n_pred} is how many rows the set's cross-validation predicted. A set that left some of the scored rows unpredicted, because a fold failed for it, has \code{score} \code{NA}, with a warning naming it: scored on the rows it did predict @@ -123,12 +168,16 @@ in \code{train_sf} as passed; rows the completeness filter above dropped are in neither. \code{params} records \code{metric}, \code{method}, \code{k}, \code{tol}, \code{seed}, \code{auto_range}, \code{select_on}, -\code{n_candidates}, \code{estimated_fits} and \code{n_scored}. +\code{n_candidates}, \code{estimated_fits}, \code{n_scored}, +\code{rule}, \code{se_mult} and \code{baseline} (its type). } \description{ Selects predictors by repeatedly adding whichever candidate most improves a -cross-validated score, stopping when no candidate improves it by more than -\code{tol}. +cross-validated score, stopping when the best candidate's improvement is +no larger than the fold-to-fold noise in it (\code{rule = "se"}, the +default) or no larger than \code{tol} (\code{rule = "tol"}). The first +variable has a baseline to beat with every learner, so the selection can +be empty. } \details{ \strong{The inner folds must be spatial, and that is the entire point.} @@ -150,6 +199,166 @@ leak-free; no extra plumbing is needed. The cost grows fast: a sweep over that inside \code{n} outer leave-one-out folds multiplies it by \code{n}. \code{max_fits} guards against that. } +\section{When a variable is accepted}{ + +Each candidate set is scored by cross-validation on the same inner folds, +and the candidate with the best pooled score is the one considered. Under +\code{rule = "se"} it is accepted when two things hold: the pooled score +improves by more than \code{tol}, and the mean of the per-fold +improvements (the metric computed in each fold for the set with and +without the candidate, and differenced) exceeds \code{se_mult} times the +standard error of that mean across the folds. This is the +one-standard-error idea of Breiman et al. (1984) applied to a step: a gain +the folds do not agree on is not evidence that the variable predicts. The +fold is the unit because under spatially blocked folds the errors within a +block are correlated, so a standard error over rows would understate the +noise. With \code{tol = 0} and any gain accepted (the previous default, +still available as \code{rule = "tol"}), a GWR sweep over one real +predictor and six noise candidates added a noise variable in 11 runs of +20; the default rule added one in 4 of 20 and kept the real predictor in +all 20. The rule costs power on weak predictors: a second real predictor +with a coefficient of 0.3 against 1 was kept in 14 runs of 20, against 18 +of 20 when any gain was accepted. With few folds the standard error is +itself noisy, so raise \code{k} before lowering \code{se_mult}. +\code{history} records each candidate's pooled gain, mean per-fold gain +and its standard error, and \code{fold_scores} the per-fold scores +themselves, so every decision can be checked. +} + +\section{The baseline for the first variable}{ + +The first variable is compared with a model that has no predictors, which +is recorded as step 0 of \code{history}. Which model that is depends on +the learner, and \code{baseline$type} says which was used: +\describe{ +\item{\code{"null model"}}{\code{fit_fn(train_sf, character(0))}, when +the learner can fit it. Step 1 is tested against it like any other +step.} +\item{\code{"null_fn"}}{the model \code{null_fn(train_sf)} returns, for +a learner that cannot fit an empty set but has a natural +no-predictor model. Step 1 is tested against it.} +\item{\code{"fold mean"}}{the mean response of each fold's training +rows, when neither is available; \code{\link{fit_rf_model}} refuses +an empty predictor set. Here +the first variable is \emph{provisional}: it is added without a test, +the sweep continues by the rule, and the finished set is kept only if +it beats the fold mean by the same rule; otherwise nothing is +selected, and \code{baseline$path} holds the set that was reached. +The test is at the end of the path, not at step 1, because a forest +on a single variable can lose to the mean when two variables together +beat it clearly (at a true \eqn{R^2} of 0.33 the best single-variable +forest had RMSE 1.276 against 1.206 for the mean and 1.101 for the +pair), so a test at step 1 would select nothing there. The first +variable of a kept path then gets a test of its own; see \emph{The +first variable under a fold-mean baseline}.} +} +Without a baseline, as before, at least one variable was always selected: +with a forest, in 10 draws of 10 on a response unrelated to every +candidate. +} + +\section{The first variable under a fold-mean baseline}{ + +The test at the end of the path is of the whole set, so it does not show +that the first variable belongs in it: two real predictors and an +unrelated candidate that happened to score best alone beat the mean as +the two real ones do. A kept path of two or more variables is therefore +scored once more without its first variable (one more set, \code{k} more +fits). That variable is dropped from \code{selected} when the set is no +better with it by the rule and the rest of the path still beats the fold +mean by the rule. \code{baseline$first} records the test and +\code{baseline$path} keeps the set as the sweep reached it, so +\code{selected} is \code{baseline$path[-1]} after a drop. A path of one +variable needs no second test: the test against the fold mean was the +test of that variable. + +This test is the one every later variable passed, an improvement of the +set by the rule, and it has the same limit. In 20 forest sweeps at a true +\eqn{R^2} of 0.33, with two real predictors and three unrelated +candidates, the path began with an unrelated candidate in 3: it was +dropped in 2 and kept in 1, where the forest scored better with it than +without (\emph{Selection with a random forest} says why it can). At a +true \eqn{R^2} of 0.15, 9 selections of 20 were kept, 3 of them began +with an unrelated candidate, and all 3 kept it for that reason. So in a +selection of two or more variables from a learner that falls back to the +fold mean, \code{selected[1]} has been shown to improve the set, not to +predict on its own. The test also costs power on a weak first predictor, +as the rule does at every step: with one real predictor of coefficient +0.3 and five unrelated candidates, a linear learner that refuses the +empty set kept the real predictor in 77 sweeps of 100, against 80 before +this test existed and 77 for the same learner fitting its own null model +(in the 3 sweeps that differ it was the first variable, its gain was +within one standard error, and the learner with a null model selected +nothing). When the set is no better with the first variable but +the rest of the path does not beat the fold mean by the rule either, the +two cannot be told apart: the set is kept whole, a caution is logged, and +\code{baseline$first$note} says the variable is unproven. A learner that +fits its own null model gets no such test: its first variable passed one +at step 1. +} + +\section{The baseline for a GWR}{ + +For a GWR the fold mean is a weak baseline, because every GWR carries a +local intercept and beats a global mean on any smooth response whatever +its predictors are: on a smooth response unrelated to six candidates, a +GWR sweep against the fold mean selected one of them in 20 runs of 20. +Each of those paths had one variable, which the test of the first +variable above does not reach. The comparison that matters there is with +the kernel-weighted local mean at the same bandwidth, a GWR with a local +intercept and no predictors: against it the same sweeps selected a +variable in 4 runs of 20. \code{\link{fit_gwr_model}} fits that model +when its \code{predictor_vars} is \code{character(0)}, so a +\code{fit_fn} that hands its variables to \code{fit_gwr_model()} gets it +as the null model, and the first variable is tested against it at step 1 +(\code{baseline$type} is \code{"null model"}). Give such a \code{fit_fn} +a fixed \code{bandwidth}, so that every set is fitted under the kernel +the baseline has; with \code{bandwidth = NULL} each set, the empty one +included, searches for its own. A \code{fit_fn} that refuses an empty +set falls back to the fold mean, and the sweep logs a caution: read a GWR +selection of one variable made that way as unproven, or supply the local +mean as \code{null_fn}, as the second half of the example at the end of +this page does for a learner written by hand. + +\code{predict()} on a GWR warns about held-out locations it cannot +estimate and about those beyond the reach of a fold's fit (classes +\code{"spatialkit_gwr_not_estimable"} and +\code{"spatialkit_gwr_extrapolation"}; see +\code{\link{predict.gwr_fit}}). The sweep raises each once, under this +function's name, with the totals over the candidate sets it scored; every +set is predicted on the same rows, so a location can be counted once per +set. +} + +\section{Selection with a random forest}{ + +A forest confounds selection with tuning. Adding a predictor that carries +no signal still changes how the trees split, and with ranger's default +node size that regularises the forest: in one test the cross-validated +RMSE was 1.458 with the real predictor alone, 1.340 with a noise variable +added, and 1.341 with the real predictor alone and +\code{min_node_size = 20}. The noise variable bought what tuning the node +size buys. That gain is real, so no acceptance rule refuses it: with one +real predictor and six noise candidates a forest sweep kept the real one +in 20 runs of 20 and added 1.35 noise variables per run under the default +rule (2.4 per run, over 10 runs, when any gain was accepted). Setting the +node size in +\code{fit_fn} reduces this without removing it (0.8 per run at +\code{min_node_size = 20}). So a variable in a forest selection may be +there as a tuning effect wherever in the order it was added: later +additions with small gains are the usual case, and the first variable is +another, because a forest sweep starts from the fold mean and its first +variable is tested as an addition to the others (see \emph{The first +variable under a fold-mean baseline}). Compare the selected set with a +tuned forest on the variables you have other reasons to believe in: +\preformatted{ +fit_fn <- function(train_sf, vars) + fit_rf_model(train_sf, "z", vars, min_node_size = 20) +} +On a response unrelated to every candidate the same sweeps selected +nothing in 20 runs of 20 (19 of 20 with the larger node size). +} + \section{The score is not a performance estimate}{ \code{$score} is the cross-validated \code{metric} of the winning set at @@ -168,8 +377,7 @@ or pass \code{select_on = "split"}, which selects on one spatial half of } \examples{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +if (requireNamespace("sp", quietly = TRUE)) { library(sf) set.seed(1) n <- 120 @@ -180,30 +388,72 @@ if (requireNamespace("GWmodel", quietly = TRUE) && ) pts$resp <- 3 * pts$a + 2 * pts$b + rnorm(n, 0, 0.3) + # The learner: a GWR with an adaptive bisquare kernel reaching the 30th + # nearest training point. With no variables it is the kernel-weighted + # local mean, which is the baseline: a GWR's local intercept beats a + # global mean on any smooth response, so the first variable has to beat + # the local mean under the same kernel. fit_fn <- function(tr, vars) fit_gwr_model(tr, "resp", vars, bandwidth = 30) sel <- select_features_forward(pts, "resp", c("a", "b", "noise"), fit_fn, k = 3, quiet = TRUE) sel$selected + sel$baseline$type # "null model": step 1 was tested against it + sel$history[sel$history$step <= 1, c("step", "variable", "score", "gain")] + + # A learner that cannot fit an empty set takes its no-predictor model + # through `null_fn`. Here the same local mean, written as a spatial_fit + # of its own with a predict() method, for a learner that insists on a + # variable. Without `null_fn` that sweep would start from the mean of + # each training fold. + needs_one <- function(tr, vars) { + if (!length(vars)) stop("this learner needs a predictor") + fit_gwr_model(tr, "resp", vars, bandwidth = 30) + } + local_mean <- function(tr, bandwidth = 30) { + new_spatial_fit("local_mean_fit", + engine = list(xy = st_coordinates(tr), y = tr$resp, + bandwidth = bandwidth), + formula = resp ~ 1, response_var = "resp", + predictor_vars = character(0), data_sf = tr) + } + predict.local_mean_fit <- function(object, newdata = NULL, ...) { + e <- object$engine + at <- if (is.null(newdata)) e$xy else st_coordinates(newdata) + vapply(seq_len(nrow(at)), function(i) { + d <- sqrt((e$xy[, 1] - at[i, 1])^2 + (e$xy[, 2] - at[i, 2])^2) + h <- sort(d)[min(e$bandwidth, length(d))] # the kernel's reach here + w <- ifelse(d > h, 0, (1 - d^2 / h^2)^2) # bisquare weights + sum(w * e$y) / sum(w) + }, numeric(1)) + } + registerS3method("predict", "local_mean_fit", predict.local_mean_fit) + sel2 <- select_features_forward(pts, "resp", c("a", "b", "noise"), needs_one, + k = 3, quiet = TRUE, null_fn = local_mean) + sel2$baseline$type # "null_fn" + all.equal(sel2$baseline$score, sel$baseline$score) # the same baseline } } \references{ +Breiman, L., Friedman, J. H., Olshen, R. A. and Stone, C. J. (1984). +\emph{Classification and Regression Trees}. Wadsworth. + Cawley, G. C. and Talbot, N. L. C. (2010). On over-fitting in model selection and subsequent selection bias in performance evaluation. \emph{Journal of Machine Learning Research}, 11, 2079--2107. \url{https://jmlr.org/papers/v11/cawley10a.html} } \seealso{ -Other cross-validation: -\code{\link{area_of_applicability}()}, -\code{\link{cv_bayes}()}, -\code{\link{cv_block_size_sweep}()}, -\code{\link{cv_gwr}()}, -\code{\link{cv_rf}()}, -\code{\link{cv_spatial}()}, -\code{\link{estimate_sac_range}()}, -\code{\link{fold_separation}()}, -\code{\link{gwr_model_selection}()}, -\code{\link{make_folds}()}, -\code{\link{sac_nugget}()} +Other cross-validation: +\code{\link[=area_of_applicability]{area_of_applicability()}}, +\code{\link[=cv_bayes]{cv_bayes()}}, +\code{\link[=cv_block_size_sweep]{cv_block_size_sweep()}}, +\code{\link[=cv_gwr]{cv_gwr()}}, +\code{\link[=cv_rf]{cv_rf()}}, +\code{\link[=cv_spatial]{cv_spatial()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}}, +\code{\link[=fold_separation]{fold_separation()}}, +\code{\link[=gwr_model_selection]{gwr_model_selection()}}, +\code{\link[=make_folds]{make_folds()}}, +\code{\link[=sac_nugget]{sac_nugget()}} } \concept{cross-validation} diff --git a/man/select_resolution.Rd b/man/select_resolution.Rd index 25f5cb0b..564f0b16 100644 --- a/man/select_resolution.Rd +++ b/man/select_resolution.Rd @@ -6,44 +6,173 @@ \usage{ select_resolution( profile, - criterion = c("cp", "reliability", "elbow", "moran_z"), - tol = 0.02 + criterion = c("auto", "cp", "reliability", "elbow", "moran_z", "loo", "size"), + tol = 0.02, + range_floor = TRUE, + diagnostic = FALSE, + obs_per_cell = NULL ) } \arguments{ \item{profile}{A \code{resolution_profile}.} -\item{criterion}{Which column decides: \code{"cp"} (minimised), -\code{"reliability"} (maximised), \code{"elbow"} (maximised) or -\code{"moran_z"} (\eqn{|z|} minimised).} +\item{criterion}{Which rule sets the count: \code{"cp"} (minimised), +\code{"reliability"} (maximised at or above the range floor), +\code{"elbow"} (maximised), \code{"loo"} (the leave-one-out error of +the profile's estimate, minimised), \code{"size"} (the count +\code{obs_per_cell} gives), \code{"auto"} (\code{"size"} for a profile +of pooled values, \code{"loo"} for one of plain means, \code{"cp"} for +a profile without an estimate) or, with \code{diagnostic = TRUE}, +\code{"moran_z"} (\eqn{|z|} minimised). Default \code{"auto"}. +\code{"cp"} was the default of earlier versions; name it to read +\eqn{C_p} on a profile that has it.} -\item{tol}{Width of the flat region. For \code{cp} and \code{reliability} -it is relative to the optimum's value (\code{0.02} keeps levels within 2 -percent of it); for \code{elbow} and \code{moran_z}, whose optimum can -be zero, it is relative to the criterion's range over the ladder.} +\item{tol}{Width of the flat region. For \code{cp}, \code{reliability} +and \code{loo} it is relative to the optimum's value (\code{0.02} keeps +levels within 2 percent of it); for \code{elbow} and \code{moran_z}, +whose optimum can be zero, it is relative to the criterion's range over +the ladder. Under \code{"size"} there is no flat region, and +\code{tol} is the margin by which the cells have to beat one mean for +\code{structured} and nothing else.} + +\item{range_floor}{For \code{criterion = "reliability"} only. +\code{TRUE} (default) reads the criterion at the levels at or above +the range floor in \code{attr(profile, "bounds")}, which is where +\code{resolution_profile()} started the ladder by default up to version +2.0.0. It applies when the layer supports the floor, some scored level +reaches it, and the profile built its own ladder (a ladder set with +\code{levels} is read as given). \code{FALSE} reads every level.} + +\item{diagnostic}{\code{criterion = "moran_z"} is refused, with an error +of class \code{spatialkit_diagnostic_criterion} that says what the +column measures, unless this is \code{TRUE}: \code{moran_z} is a +diagnostic of the cell means, not a count rule. Default \code{FALSE}.} + +\item{obs_per_cell}{For \code{criterion = "size"}: the mean number of +rows per cell wanted, a single number of at least 1 (fractions are +allowed). \code{NULL} (default) is the profile's own size when it was +built at exactly one (\code{\link{resolution_profile}(obs_per_cell = +)}), and 4.5 otherwise. Given with a criterion that is not +\code{"size"} it is an error.} } \value{ A list of class \code{resolution_selection} with \code{best} (the level), \code{flat} (the levels in the flat region, ascending; a set, which can skip a rung), \code{criterion}, \code{value} (the optimum), \code{at_ceiling} and \code{at_floor} (logical: the optimum is the last -or first of the levels this criterion was scored at, which for -\code{moran_z} starts above nine cells), \code{edge} (which bound that +or first of the levels this criterion was read at, which for +\code{moran_z} starts above nine cells and for \code{reliability} at +the range floor; both \code{NA} under \code{"size"}, which searches for +no optimum), \code{edge} (which bound that is, in words: the support ceiling, the subsample's ceiling, the range -floor, the ladder's own end, +floor, the ladder's own end, the finest or the coarsest size offered +on a ladder \code{obs_per_cell} set, the only level scored, or the first or last level the criterion is computable at; \code{NA} for -an interior optimum), \code{n_levels}, \code{values} (the criterion -at every level, \code{NA} where it could not be computed) and +an interior optimum and under \code{"size"}), \code{n_levels}, +\code{values} (the criterion +at every level, \code{NA} where it could not be computed), +\code{structured} (for \code{cp}: \code{FALSE} when \code{cp} at one +cell is within \code{tol} of the optimum, when the cell means at the +optimum differ from one mean by no more than chance allows, or when +the variogram found no spatial structure; \code{TRUE} when the optimum +beats one cell on both counts; see "What each criterion returns". +For \code{loo} and \code{size} on a profile built with +\code{estimate}: \code{FALSE} when the leave-one-out error of one mean +for all scored rows is within \code{tol} of the error at \code{best}, +or below it, or when the cell means at \code{best} differ from one +mean by no more than chance allows; \code{TRUE} when the cells beat +one mean on both counts. +\code{TRUE} for an \code{elbow}; \code{NA} for \code{reliability} +and \code{moran_z}, and for a profile that carries no one-cell value), +\code{one_cell} (\code{cp} at one cell under \code{cp}; the +leave-one-out error of one mean for all scored rows under \code{loo} +and \code{size}; \code{NA} otherwise), +\code{structure_p} (the p-value of the F test of the cells at +\code{best} against one mean, multiplied by the number of levels +searched and capped at 1; a size searches one level; \code{NA} where +\code{structured} is not read off \code{cp} or the leave-one-out +error), +\code{range_floor} (the floor \code{reliability} was held to, or +\code{NA}), \code{note} (what the flags mean, in words: a character +vector, one note an element; \code{NULL} when there is nothing to +say. The notes written under \code{"loo"} and \code{"size"}, and for +a profile built with \code{estimate} or with one size, carry names: +\code{size} (the size that set the count), \code{held} (a size the +profile held to the most cells k-means can place), \code{structure} +(why the count is not identified), \code{finest} (the lowest error of +pooled values is at the finest level scored), \code{estimate} +(\code{cp} scores plain means, on a profile of pooled values) and +\code{ladder} (the ladder is one size). A note of \code{cp} or +\code{moran_z} about the criterion itself has no name. The warning +of class \code{spatialkit_no_structure} that the functions taking the +selection as a count raise carries every note but those named +\code{size}, \code{held}, \code{finest}, \code{estimate} and +\code{ladder}) and \code{seeds} (an sf POINT layer, with \code{seed_id}, of the centres of the partition the profile scored at \code{best}, in the CRS it was computed in; \code{NULL} for a profile that does not carry them). Their Voronoi cells are the cells that were scored; \code{\link{get_voronoi_seeds}(method = "kmeans", n = )} and -\code{\link{voronoi_seeds_kmeans}(k = )} return them. +\code{\link{voronoi_seeds_kmeans}(k = )} return them. For a +profile built with \code{partition = "density"} or \code{init = + "random"} the list also has \code{partition} (\code{kind}, +\code{init}, \code{density_power}, \code{density_k}), and the seeds +carry it as \code{attr(, "partition")}; the regions are those the +profile built, whatever kind built them. + +For \code{"loo"} and \code{"size"}, and for any criterion on a profile +built with \code{estimate}, the list has these elements after +\code{seeds} (\code{partition}, when there is one, stays last): +\code{estimate} (the profile's, \code{"mean"} or \code{"pooled"}; +\code{NA} for a profile without one); +\code{obs_per_cell} (rows per cell at \code{best}: the rows a size +divides over \code{best}; \code{NA} for an object that keeps no row +count); +\code{obs_per_cell_asked} (the size asked for; \code{NA} unless the +criterion is \code{"size"}); +\code{scored_per_cell} (the profile's column at \code{best}: the rows +the leave-one-out error read over the cells that hold one. It is not +\code{obs_per_cell}: it leaves out rows the error did not read and +cells that hold none of them, as under \code{select_on = "split"}); +\code{loo} and \code{loo_one_cell} (the leave-one-out error at +\code{best} and that of one mean for all scored rows); +\code{share_alone} and \code{own_weight} (the profile's columns at +\code{best}); and \code{count_rule}, a list of class +\code{spatialkit_count_rule} that records how the count was set: +\code{rule} (the criterion applied), \code{estimate} (the estimate the +rule was computed for: the profile's for \code{"size"} and +\code{"loo"}, \code{"mean"} for \code{"cp"}, \code{NA} otherwise), +\code{cells}, \code{obs_per_cell}, \code{obs_per_cell_asked}, +\code{response}, \code{n} (the rows the size divides), \code{n_points}, +\code{n_fit} (the rows the centres were fitted to; fewer than +\code{n_points} for a subsample), \code{seed}, \code{features}, +\code{scored} (what the profile scored at \code{best} for its +estimate: \code{estimate}, \code{n}, \code{cells}, \code{loo}, +\code{loo_se}, \code{loo_one_cell}, \code{share_alone}, +\code{own_weight}, \code{structured}, \code{rows} and \code{centres}, +the matrix of the centres the rows were scored in, in \code{crs} and +in the profile's order; \code{NULL} without an estimate), +\code{partition}, \code{crs} and +\code{scored_cells} (\code{NA}: the record stands for a count). +\code{seeds} carries the same record as \code{attr(, "count_rule")} +with \code{scored_cells = TRUE}, since they are the centres that were +scored. The record travels on with the seeds, the cells and the +assigned layer to \code{\link{summarize_by_cell}()}, which warns when +it reports another cell value than the count was chosen for (class +\code{spatialkit_estimate_mismatch}) and when the cells or rows it is +given are not the ones the count was scored on +(\code{spatialkit_cells_differ}). Under \code{"loo"} and \code{"size"} \code{one_cell} holds +the leave-one-out error of one mean and \code{range_floor} is +\code{NA}. \code{criterion} is the criterion applied, never +\code{"auto"}. } \description{ Picks the level a criterion prefers, together with the \emph{flat region}: -every level whose criterion value is within \code{tol} of the optimum. On +every level whose criterion value is within \code{tol} of the optimum. +On the default profile, one size scored for pooled values, the default +criterion is that size: it returns the count the size gives, with no +optimum and no flat region (see "A profile built with an estimate"); what +follows is about the criteria read on a ladder of counts. On the criteria this package computes the flat region is routinely wide: the reliability curve is flat to within 2 percent over a factor of 3--6 in the number of cells, and \eqn{C_p} on a smooth field descends to the support @@ -51,16 +180,182 @@ ceiling. The region is the answer, and the argmin only a point in it. When the optimum sits at an end of the levels the criterion was scored at, the result says so and names the bound, because a bound is then doing the choosing rather than the criterion (see -\code{\link{resolution_profile}} for what each criterion measures and how -it behaved on simulated fields). +\code{\link{resolution_profile}} for what each criterion measures and +what it returns in practice). The functions that take the result as a +cell count raise that as a warning of class +\code{spatialkit_bound_chosen}. +} +\section{What each criterion returns}{ + +\describe{ +\item{\code{cp}}{The level that minimises Mallows' \eqn{C_p}: the count +at which re-measuring the sampled sites, each predicted by its cell's +mean, has the least estimated error (\code{\link{resolution_profile}} +says what that leaves out for a new location). On a smooth response +with little noise that is the support ceiling. The result also says whether the optimum beats one +cell for the whole layer (\code{attr(profile, "one_cell")}), in +\code{structured}. It is \code{TRUE} when two things hold: +\eqn{C_p} at one cell is above the optimum by more than \code{tol}, +and the cell means at the optimum differ from one mean by more than +chance allows. The second is the F test of the cells against one +mean, \eqn{(TSS - RSS) / (L - 1)} over \eqn{RSS / (m - L)}, at 5 +percent after a Bonferroni adjustment for the levels the optimum was +searched over (\code{structure_p} is the adjusted p-value). The +cells are fitted to the coordinates alone, so the test holds its +level on a response with no spatial structure whatever \eqn{C_p}'s +noise variance is, and it is what decides when that variance is 0: +\eqn{C_p} is then \eqn{RSS / n}, which falls with every finer level +by chance alone, and the first comparison says nothing. +When either fails, \code{structured} is \code{FALSE}: one mean for +the whole layer predicts as well as any level scored, so the +response shows no spatial structure the cells can use and the count +is not identified. \code{structured} is also \code{FALSE} when the +profile's variogram was refused for showing no spatial structure. +\code{best} is still the argmin. +\strong{Measured on white noise} (uniform points, the automatic +ladder of \code{obs_per_cell = NULL}), \code{structured} was +\code{TRUE} on 3 of 200 layers of 60 points, 7 of 200 of 120, 5 of +150 of 300 and none of 80 of 600 or of +40 of 1,500 with the noise variance taken from the finest level; and +with the package's own variogram, whose nugget was 0 on 27 of the +180 layers, on none of 120 layers of 120 points and 3 of 60 of 300. +The first comparison alone gave 27, 20, 8, 0 and 0, and then 38 and +11. The F distribution is exact for a Gaussian response, and the +test held its level on others: with no structure in a lognormal +response, a 0/1 response with mean 0.1 and a \eqn{t_3} response, +\code{structured} was \code{TRUE} on 2 to 10 of 200 layers at each +of 60, 120 and 300 points. A \code{FALSE} on a small layer is weak +evidence that there is +no structure: on exponential fields (range parameter 100 on a +1000-unit extent, nugget 0.3 on a unit sill) \code{structured} was +\code{TRUE} on 12 of 40 layers of 60 points, 36 of 40 of 120 and 40 +of 40 of 300.} +\item{\code{reliability}}{The coarsest count the range allows. The +reliability curve peaks below the range floor, so it is read at the +levels at or above the floor the profile reports (when the layer +supports the floor and the profile built its own ladder). The floor +is a level of every such ladder, so the result is the floor, with +\code{edge} naming it (on a profile whose k-means failed at that +level, the first level above it). \code{range_floor = FALSE} reads +every level and returns the curve's own maximum, which is usually a +count below the floor.} +\item{\code{elbow}}{The number of clusters of the points, when they +cluster; an error otherwise, because the column is \code{NA} at every +level unless the WSS curve bends.} +\item{\code{moran_z}}{Refused unless \code{diagnostic = TRUE}. It is +the level at which neighbouring cell means (or, with predictors, +their regression residuals) are least autocorrelated. \eqn{|z|} is +near 0 at 10 to 20 cells whatever the data and grows as cells get +finer than the range, so its minimum is usually the first level it +can be computed at, or one near it, and it says nothing about how +well the cells represent the response.} +\item{\code{loo}}{The level with the lowest leave-one-out error of the +estimate the profile was built for +(\code{\link{resolution_profile}(estimate = )}); of levels with the +same error, the one with the fewest cells. The flat region is every +level whose error is within \code{tol} of the lowest. The column +needs no variogram. \code{structured} is read as for \code{cp}, with +the leave-one-out error in place of \eqn{C_p}: it is \code{TRUE} when +the error of one mean for all scored rows is above the optimum by +more than \code{tol} and the F test of the cells at the optimum +against one mean, adjusted for the levels searched, has +\eqn{p < 0.05}; \code{one_cell} then holds the error of one mean. +Under this criterion the count depends on the values of the response. +When the profile's estimate is the pooled value and the lowest error +is at the finest level scored, a note says that the end of the ladder +chose the count. For pooled values the error tends to keep falling to +the finest level: in the simulation described under "Observations per +cell" in \code{\link{resolution_profile}}, the lowest error of the +pooled value was at the finest of seven sizes on 176 of 200 layers, +and that of the plain mean on none. On a ladder \code{obs_per_cell} +set, an optimum at +an end has the \code{edge} \code{"the finest size offered + (obs_per_cell)"} or \code{"the coarsest size offered + (obs_per_cell)"}; a finest level the profile held to the most cells +k-means can place keeps the label of the support ceiling.} +\item{\code{size}}{The count a size gives, +\code{max(2, round(n / obs_per_cell))}, with \code{n} the rows the +size divides: the rows with a response, or every point for a profile +without one. No optimum is searched for. The level returned is the +first of three that applies: the level the profile built for that +size; the count itself, when the profile has a partition at it; +otherwise the built level nearest to the count on the log scale (of +two as near, the one with fewer cells), with a warning of class +\code{spatialkit_size_not_reached}, which says so when the count is +more than k-means can place on the layer. It reads any profile, one +built without a response or without an estimate included, but not a +column subset, which has lost the row count. \code{flat} is the level, +\code{value} the rows per cell it leaves (\code{n / best}), and +\code{at_ceiling}, \code{at_floor} and \code{edge} are \code{NA}: no +bound chose anything, so the functions that take the selection as a +count raise no \code{spatialkit_bound_chosen}. Under this rule +neither the cells, which are fitted to the coordinates, nor their +number, which is a count of rows, depend on the values of the +response. +A size does not ask whether the response has structure the cells can +use, so \code{structured} asks it separately, on a profile built with +an \code{estimate}. It is \code{FALSE} when the leave-one-out error +of one mean for all scored rows is within \code{tol} of the error at +the level, or below it, or when the F test of the cells at the level +against one mean has \eqn{p \ge 0.05}. The count stands either way, +since the caller set it: \code{structured = FALSE} says that the cell +values will say little that one mean for the layer does not. The +functions that take the selection as a count then raise +\code{spatialkit_no_structure}. On a profile without an estimate +\code{structured} is \code{NA}.} +\item{\code{auto}}{The rule that goes with the profile's estimate: +\code{"size"} for a profile built with \code{estimate = "pooled"}, +\code{"loo"} for \code{estimate = "mean"}, and \code{"cp"} for a +profile without an estimate. A column subset of a profile has lost +the record of its estimate and is read by \code{"cp"}. +\code{criterion} in the result is the criterion applied, never +\code{"auto"}.} +} } + +\section{A profile built with an estimate}{ + +This function's default criterion is \code{"auto"}: \code{"size"} for a +profile of pooled values, \code{"loo"} for one of plain means and +\code{"cp"} for a profile without an estimate. A profile built with +\code{estimate} that is passed straight to +\code{\link{get_voronoi_seeds}()}, \code{\link{voronoi_seeds_kmeans}()} or +\code{\link{build_tessellation}()} as the count is read the same way, so +\code{select_resolution(profile)} and the profile itself give the same +count. A profile of pooled values built with a ladder argument +(\code{n_levels} and the others) is read by the size as well: the +default returns the level nearest the count the size gives, on the +automatic ladder its top level, with \code{spatialkit_size_not_reached}. +The default was \code{"cp"} in earlier versions, whatever the profile; +\code{criterion = "cp"} reads it as before on a profile that has it. \code{cp} is computed on such a profile as on any other and +scores plain means; when the profile's estimate is the pooled value the +result's note says so. + +\code{"cp"} and \code{"reliability"} cannot be read off a profile whose +ladder \code{obs_per_cell} set under \code{sac = "auto"}. Such a profile +fits no variogram, both columns are \code{NA} at every level, and the +call is an error that names the ways to get them: build the profile with +\code{sac = NULL}, with a \code{sac} of your own, or with +\code{obs_per_cell = NULL}. The default profile is such a profile. For +the count \code{"cp"} gave in earlier versions, build the profile with +\code{estimate = NULL, obs_per_cell = NULL}, and with \code{partition = +"kmeans"} for the same regions. On a ladder of one size that has a +variogram either criterion returns the one level, with \code{edge} +\code{"the only level scored"}. + +For a ladder of one size, \code{summary()} of the profile lists each +criterion that is finite at the level and says that the size set the +count, and \code{plot()} draws each as one point, with no selected level +and no band. When none is finite, as on a constant response, where +\code{loo} is \code{NA} too, \code{summary()} stops with an error that +says so. +} + \examples{ if (requireNamespace("gstat", quietly = TRUE)) { library(sf) # An exponential field with range parameter 200 (true effective range - # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough - # noise for Mallows' Cp to have an interior optimum rather than descend - # to the ceiling. + # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) @@ -72,22 +367,29 @@ if (requireNamespace("gstat", quietly = TRUE)) { sel <- select_resolution(prof, criterion = "cp") print(sel) # the level, and the flat region around it print(sel$flat) # every level within `tol` of the optimum - print(sel$edge) # NA here: the optimum is interior + print(sel$edge) # the bound the optimum sits on; NA when interior + print(sel$structured) # FALSE when one cell for the layer does as well - # Reliability prefers coarse cells and here runs into the floor the - # autocorrelation range sets, which the result says in words. + # Reliability prefers coarse cells: it is read at or above the floor the + # autocorrelation range sets, and the result says in words that the + # floor is choosing. rel <- select_resolution(prof, criterion = "reliability") print(rel) - c(at_floor = rel$at_floor, edge = rel$edge) + print(c(at_floor = rel$at_floor, edge = rel$edge)) + + # The default profile is one size scored for pooled values, and the + # default criterion, "auto", reads it by that size. + select_resolution(resolution_profile(pts, response_var = "z")) } } \seealso{ -Other aggregation: -\code{\link{assign_features_to_polygons}()}, -\code{\link{determine_optimal_levels}()}, -\code{\link{kriging_adequacy}()}, -\code{\link{resolution_profile}()}, -\code{\link{summarize_by_cell}()}, -\code{\link{summary.resolution_profile}()} +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} } \concept{aggregation} diff --git a/man/spatialkit-package.Rd b/man/spatialkit-package.Rd index c701d1a0..8320ba4e 100644 --- a/man/spatialkit-package.Rd +++ b/man/spatialkit-package.Rd @@ -6,7 +6,7 @@ \alias{spatialkit-package} \title{spatialkit: Spatial Tessellation, Modeling, and Cross-Validation Toolkit} \description{ -Constructs analysis regions from the distribution of the data itself, as an alternative to aggregating onto administrative boundaries that were drawn for unrelated purposes. Seeds and builds Voronoi, Delaunay, hexagonal and square tessellations with reproducible identifiers, selects a cell count from the spatial structure of the observations, assigns features to cells, and aggregates to cell level with optional design-effect corrections so that standard errors account for within-cell autocorrelation. Also manages coordinate reference systems. Fits geographically weighted regression (via 'GWmodel'; Lu et al. (2014) \doi{10.1080/10095020.2014.917453}), Bayesian spatial Gaussian process regression (via 'brms', using the Hilbert space approximation of Riutort-Mayol et al. (2023) \doi{10.1007/s11222-022-10167-2}) and random forests (via 'ranger', with the permutation importance of Strobl et al. (2007) \doi{10.1186/1471-2105-8-25}), each behind one S3 class with consistent predict, fitted, residuals and plot methods. Provides spatial cross-validation with random, block, buffered, leave-location-out and nearest-neighbour distance-matched folds (Mila et al. (2022) \doi{10.1111/2041-210X.13851}), forward variable selection, model comparison, prediction onto a regular surface, and the area of applicability of Meyer and Pebesma (2021) \doi{10.1111/2041-210X.13650} to flag where a fitted model extrapolates beyond its training data. +Constructs analysis regions from the distribution of the data itself, as an alternative to aggregating onto administrative boundaries that were drawn for unrelated purposes. Seeds and builds Voronoi, Delaunay, hexagonal and square tessellations with reproducible identifiers, selects a cell count from the spatial structure of the observations, assigns features to cells, and aggregates to cell level with optional design-effect corrections so that standard errors account for within-cell autocorrelation. Also manages coordinate reference systems. Fits geographically weighted regression (with the kernels, diagnostics and forward selection of 'GWmodel'; Lu et al. (2014) \doi{10.1080/10095020.2014.917453}), Bayesian spatial Gaussian process regression (via 'brms', using the Hilbert space approximation of Riutort-Mayol et al. (2023) \doi{10.1007/s11222-022-10167-2}) and random forests (via 'ranger', with the permutation importance of Strobl et al. (2007) \doi{10.1186/1471-2105-8-25}), each behind one S3 class with consistent predict, fitted, residuals and plot methods. Provides spatial cross-validation with random, block, buffered, leave-location-out and nearest-neighbour distance-matched folds (Mila et al. (2022) \doi{10.1111/2041-210X.13851}), forward variable selection, model comparison, prediction onto a regular surface, and the area of applicability of Meyer and Pebesma (2021) \doi{10.1111/2041-210X.13650} to flag where a fitted model extrapolates beyond its training data. } \section{The pipeline, in order}{ @@ -67,6 +67,31 @@ cross-validation score says nothing about ground the model has never seen; this is what tells you where the map should not be believed. } +Two choices are the user's, one in choosing a resolution (step 1) and one +in aggregating (step 4), and each has an argument. They are arguments of +\code{\link{resolution_profile}()} and \code{\link{select_resolution}()}, +which choose a count for a cell value, and of +\code{\link{summarize_by_cell}()}; \code{determine_optimal_levels()} +takes neither. +The first is the cell value to report, \code{estimate}: the plain mean of +a cell's observations, or the pooled value, which is that mean pulled +toward the mean of the cells around it. +\code{\link{resolution_profile}()} scores a count for the value it is +given, and \code{\link{summarize_by_cell}()} reports the value it is +given and warns when the count was chosen for the other one. The second +is the size, \code{obs_per_cell}: how many observations a cell is to hold +on average. For pooled values the size sets the count +(\code{\link{select_resolution}(criterion = "size")}); for plain means the +lowest leave-one-out error can set it (\code{criterion = "loo"}). Each +has a default: the pooled value, and a size of 4.5, from which +\code{select_resolution()}'s default criterion, \code{"auto"}, sets the +count. \code{estimate = "mean"} in the summary gives the frame it +returned before the argument existed. \code{estimate = NULL, +obs_per_cell = NULL} in the profile gives the earlier ladder and its +columns, and with \code{partition = "kmeans"} the earlier regions as +well: the profile it returned before. The seeding functions take +\code{partition = "kmeans"} for their earlier seeds. + Supporting these throughout, \code{\link{ensure_projected}()} and \code{\link{coerce_to_points}()} handle coordinate reference systems and geometry coercion, and \code{\link{estimate_sac_range}()} estimates the @@ -137,6 +162,44 @@ effect in \code{summarize_by_cell()}: the package's own derivation from Kish's exchangeable-correlation model, not taken from a reference. The derivation and its measured coverage are in the section "Spatial autocorrelation and standard-error bias" of that help page. +\item The size of 4.5 observations per cell that +\code{select_resolution(criterion = "size")} and +\code{resolution_profile(obs_per_cell = "auto")} take when none is +given: a convention, a size at which most cells hold several +observations. +\item The density kind of partition, kept from the best of 3 +k-means++ starts, in \code{resolution_profile()}, +\code{get_voronoi_seeds()} and \code{voronoi_seeds_kmeans()}: a +convention, a kind that puts small cells where observations are dense +and holds the counts per cell close once the cells outnumber the +dense places, from a number of starts that keeps the cost of a fit +to every row down. \code{partition = "kmeans"} gives plain k-means. +\item The 8 nearest cells a pooled value is pulled toward in +\code{summarize_by_cell(estimate = "pooled")}: a convention, a count +large enough to give a cell a stable target. It is not an argument. +\item The 5 residuals expected beyond each end of the interval of +\code{summarize_by_cell(obs_level = )}, below which the warning +\code{spatialkit_few_residuals} is raised: a convention for when the +ends of an interval read from quantiles are unstable. +\item The 30 values beyond one per cell below which +\code{spatialkit_pool_few_df} is raised: a convention for when the +spread inside the cells, which every own weight rests on, is estimated +from little. +\item The 2 percent by which the cells have to beat one mean for the +whole layer, in leave-one-out error, for a response to be called +\code{structured} by \code{summarize_by_cell(estimate = "pooled")}: +a convention, and the default of \code{tol} in +\code{select_resolution()}, which sets the same margin there. +\item The two work limits, +\code{getOption("spatialkit.exact_pairs_max", 2e9)} pairs for a search +made without the \pkg{FNN} package and +\code{getOption("spatialkit.fit_work_max", 1e10)} point-to-centre +comparisons for the fits of a ladder that \code{obs_per_cell} sets: +conventions that keep a search or a fit whose cost grows with the +square of the rows or of the cells from starting. Above one, +\code{resolution_profile()} and \code{cell_values_at()} stop with an +error, and \code{summarize_by_cell()} returns \code{NA} pooled columns +with a warning. } } @@ -183,5 +246,10 @@ Useful entry points by task: \author{ \strong{Maintainer}: Justin Chase \email{jchase.msu@gmail.com} [copyright holder] +Authors: +\itemize{ + \item Justin Chase \email{jchase.msu@gmail.com} [copyright holder] +} + } \keyword{internal} diff --git a/man/spatialkit_quiet.Rd b/man/spatialkit_quiet.Rd index 16f324d0..a7116f5a 100644 --- a/man/spatialkit_quiet.Rd +++ b/man/spatialkit_quiet.Rd @@ -12,7 +12,7 @@ spatialkit_quiet(quiet = TRUE) threshold (\code{logger::ERROR}, or the value a previous call returned) sets that level instead, which is how to put back exactly what was in force rather than the default: \code{old <- spatialkit_quiet(); - spatialkit_quiet(old)}.} +spatialkit_quiet(old)}.} } \value{ Invisibly, the threshold that was in force before the change, a @@ -46,9 +46,9 @@ spatialkit_quiet(old) # back to whatever it was spatialkit_quiet(FALSE) # or back to the WARN+ default } \seealso{ -Other package options and caches: -\code{\link{clear_fitted_cache}()}, -\code{\link{clear_grid_cache}()}, -\code{\link{create_grid_polygons_cached}()} +Other package options and caches: +\code{\link[=clear_fitted_cache]{clear_fitted_cache()}}, +\code{\link[=clear_grid_cache]{clear_grid_cache()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}} } \concept{package options and caches} diff --git a/man/sub-.spatialkit_rows.Rd b/man/sub-.spatialkit_rows.Rd index 21c087bc..d723d8b2 100644 --- a/man/sub-.spatialkit_rows.Rd +++ b/man/sub-.spatialkit_rows.Rd @@ -20,8 +20,9 @@ subset that is not a data frame (a single column taken with \description{ \code{\link{prep_model_data}()} and \code{\link{assign_features_to_polygons}()} return a layer with an -attribute recording what happened to its rows (\code{"dropped"} and -\code{"ties"} respectively). Those records describe the rows the layer was +attribute recording what happened to its rows (\code{"dropped"} for the +first; \code{"ties"} and \code{"unassigned"} for the second). Those +records describe the rows the layer was built with, and \code{[} on an \code{sf} object copies attributes through unchanged, which would leave a subset reporting its parent's numbers for a different set of rows. Subsetting therefore returns a plain layer with the @@ -40,8 +41,9 @@ Binding such data frames with and class, so the record then describes only the first input's rows: its \code{n_rows} no longer equals \code{nrow()} of the result. The package's own readers ignore a record whose \code{n_rows} does not match; -when reading \code{attr(x, "dropped")} or \code{attr(x, "ties")} yourself -from a layer that has been through such steps, check it the same way. +when reading \code{attr(x, "dropped")}, \code{attr(x, "ties")} or +\code{attr(x, "unassigned")} yourself from a layer that has been through +such steps, check it the same way. } \examples{ library(sf) @@ -50,7 +52,7 @@ dat <- st_as_sf( resp = c(1, 2, NA, 4, 5), pred = c(1, 2, 3, 4, Inf)), coords = c("x", "y"), crs = 32632 ) -clean <- prep_model_data(dat, "resp", "pred") +clean <- prep_model_data(dat, "resp", "pred") # warns: 2 of 5 rows dropped attr(clean, "dropped")$n # 2 attr(clean[1:2, ], "dropped") # NULL -- the record does not follow } diff --git a/man/summarize_by_cell.Rd b/man/summarize_by_cell.Rd index 5c0fb819..69c8cf08 100644 --- a/man/summarize_by_cell.Rd +++ b/man/summarize_by_cell.Rd @@ -16,7 +16,9 @@ summarize_by_cell( deff_max_n = 500L, quiet = TRUE, conf_level = NULL, - area = FALSE + area = FALSE, + estimate = c("pooled", "mean"), + obs_level = NULL ) } \arguments{ @@ -41,7 +43,10 @@ after the expression passed: a name gives that name (\code{median}, or \code{f} for a variable \code{f} holding a function), \code{stats::median} gives \code{median}, and any other expression gives \code{agg1}; pass a named list to choose the name. Anything else falls -back to the default mean with a warning.} +back to the default mean with a warning. The functions receive each +column with its infinite values already set to \code{NA} (see +"Details"), so they need \code{na.rm = TRUE} as they do for missing +values.} \item{cells_sf}{Optional polygon sf layer to join cell geometries onto the output. When supplied, the return value is an sf object with @@ -75,40 +80,46 @@ the fit via \code{sac}, or it is estimated when \code{response_var} is given and supported, with a nugget and with several structured components (each weighted by its partial sill) and with gstat's 2-D geometric anisotropy (\code{vgm(..., anis = c(angle, ratio))}), applied as gstat -applies it. A model of any other family falls back to \code{deff = 1} -with a warning naming it, and so does a request with no usable -model (none supplied and none could be estimated, or a rejected -fit that could not be replaced by an estimate); see "Value" for how -to detect a fallback. A model with no structured component (a pure +applies it. A request that cannot be met falls back to \code{"kish"}, +with a warning of class \code{"spatialkit_deff_fallback"} that gives the +reason and the ICCs: a model of any other family (named in the +warning), or no usable model (none supplied and none could be +estimated, or a rejected fit that could not be replaced by an +estimate). The standard errors, intervals and \code{cell_weight} are then +Kish's, and the uncorrected ones only where Kish's own ICC is 0; the +\code{deff_method} column says which on every row (see "Value"). The +variogram route needs an identified range, which a layer does not +always have, so read \code{deff_method} for the fallback. A model with +no structured component (a pure nugget) implies that distinct observations are uncorrelated, so it is applied as a design effect of 1 in every cell, not treated as a -fallback. Points with empty +fallback. That includes the model \code{\link[=estimate_sac_range]{estimate_sac_range()}} returns +when it finds no spatial structure (an \code{NA} range whose +\code{rejected_reason} says so): the answer is then a design effect of +1, \code{deff_method} reads \code{"variogram"}, and no fallback warning is +raised. Points with empty geometry count towards their cells' values but not towards the correlation, with a warning.} -\item{\code{"kish"}}{Estimate per-variable-type intra-class correlations -(ICCs) from the grouped data using a one-way random-effects ANOVA -decomposition (one ICC for the response variable and a separate -ICC for the predictor variables), then apply Kish's formula per +\item{\code{"kish"}}{Estimate an intra-class correlation (ICC) for each +summarised column from the grouped data using a one-way +random-effects ANOVA decomposition (one ICC for the response and one +for each predictor), then apply Kish's formula per cell: \code{deff_i = 1 + (n_i - 1) * rho}. The ICC is the ANOVA (method-of-moments) estimator with Donner's \code{n0} for unequal cell sizes, not the REML estimate a mixed model returns: on a single unbalanced draw the two can differ by 0.1--0.2 (one check with cell sizes 3 to 77 and a true ICC of 0.5 gave 0.33 against REML's 0.51), while balanced designs agree to about 0.01. Neither is wrong, so do -not read the difference as a defect. When multiple columns are -pooled for a single ICC estimate (e.g. several predictor variables), -each column is z-scored before pooling so that variables with -different scales contribute equally to the variance decomposition. -The response-specific ICC -is used for response SEs and the predictor-specific ICC for -predictor SEs. The response's ICC is never applied to predictor -columns or vice versa, and it is the response's ICC (not the -predictors') that sets \code{cell_weight} whenever a response was given. +not read the difference as a defect. Each column's ICC is used +for that column's SEs and for no other: the response's ICC is never +applied to a predictor, nor one predictor's to another. It is the +response's ICC that sets \code{cell_weight} whenever a response was +given, and the first predictor's own ICC otherwise. Requires at least 2 cells with 2+ observations and at least 2 residual degrees of freedom (\code{N - k >= 2}); the ICC is taken as 0 (no -correction for that variable type) otherwise, and likewise when the +correction for that column) otherwise, and likewise when the estimate itself comes out at or below 0. The \code{"deff_applied"} -attribute is attached when either ICC is positive, so when both are +attribute is attached when any ICC is positive, so when all are 0 there is none.} \item{A positive number}{Applied as a uniform design effect to every cell, as \code{sd * sqrt(deff / n)}, exactly \code{sqrt(deff)} times the @@ -127,8 +138,10 @@ whose fit was \emph{rejected} (its value is \code{NA} and it carries a it is set aside rather than correcting by a shape that was not trusted enough to report a range: the variogram is then estimated as if no \code{sac} had been given, with a plain warning saying so, or, where that is not -possible, \code{deff} falls back to 1 with the fallback warning, which names -the rejection. A \code{sac} with no \code{variogram_model} attribute -- a plain +possible, \code{deff} falls back to \code{"kish"} with the fallback warning, which +names the rejection. The exception is a \code{sac} refused because no spatial +structure was found, whose model is a pure nugget: it is used, and gives +a design effect of 1. A \code{sac} with no \code{variogram_model} attribute -- a plain number or a \code{units} object, say -- is a range without a correlation function, and is set aside the same way. A \code{sac} fitted to residuals (\code{attr(sac, "detrended")} \code{TRUE}) is used as given, with a warning when @@ -147,8 +160,7 @@ unlike the tessellation functions, whose default is \code{FALSE}.} \item{conf_level}{Optional confidence level in (0, 1), such as \code{0.95}. When given, every numeric response and predictor column also gets \verb{..neff_*}, \verb{..df_*}, \verb{..ci_lo_*} and \verb{..ci_hi_*} (see "Confidence -intervals"). Default \code{NULL}: no interval columns, and the frame is -exactly what it was before this argument existed.} +intervals"). Default \code{NULL}: no such columns.} \item{area}{Logical, default \code{FALSE}. With \code{TRUE}, and \code{cells_sf} supplied, the result gains \code{cell_area} (each cell's planar area in the @@ -170,6 +182,47 @@ with s2, sf's default), not a planar area in squared degrees, and the distortion check passes by construction; with s2 switched off, sf needs the lwgeom package for that area and the request is refused without it. The measured spread is attached as \code{attr(, "area_error")}.} + +\item{estimate}{Which value of a cell the frame reports: \code{"pooled"} +(default) or \code{"mean"}. With \code{"mean"} the frame is the one described +above, the frame of earlier versions, whose default this was. With +\code{"pooled"} every numeric response and predictor column also +gets a pooled value, \code{w * m + (1 - w) * t}: the cell's own mean \code{m} and a +target \code{t}, the mean of the rows of the 8 cells whose observations' +centroids are nearest (all the other cells when there are fewer than 10; +the polygons are not read). The own weight is +\code{w = tau2 / (tau2 + sigma2 / n)}, where \code{n} is the cell's count, +\code{sigma2} the spread of the observations about their cell's mean and +\code{tau2} the mean squared distance between a cell's level and its target. +Each column is pooled on its own rows: those with a value, a cell and a +location. \code{agg_funs}, \code{deff}, \code{sac} and \code{conf_level} do not enter the +pooled columns, and every other column is computed as with \code{"mean"}. +Lon/lat coordinates, and coordinates without a CRS that look like +degrees, are projected for the distances between centroids, as +\code{\link[=resolution_profile]{resolution_profile()}} projects them. The projection is chosen from +every row of the layer, those without a value or a cell included, so on +such input the rows a column does not use can still decide the CRS its +distances are measured in; a layer projected beforehand is used in its +own CRS. When the input carries the record of its cells' count (see +"Value") and that record names a projected CRS, the one the profile +worked in, the distances are measured in it, whatever CRS the layer is +in. The value is matched as \code{\link[=match.arg]{match.arg()}} matches a choice, so an +abbreviation (\code{"m"}) is accepted and \code{NULL} is the default. See "Pooled +values" for what the pooled value estimates and what its numbers rest +on, "Value" for the columns and the attributes, and "Conditions" for +the warnings.} + +\item{obs_level}{Optional level in (0, 1), such as \code{0.90}, of an interval +for one further observation in a cell, located like the data. It needs +\code{estimate = "pooled"}: the interval is the pooled value plus the +\code{(1 - obs_level) / 2} and \code{(1 + obs_level) / 2} quantiles of the +leave-one-out residuals of the pooled values, so its two offsets are the +same in every cell. It is a statement about observations on average, +not about each cell. It is a separate argument from \code{conf_level}, whose +interval is for a mean and is not a range for an observation. Any level +strictly between 0 and 1 is computed the same way; only 0.90 has been +checked (see "Intervals: which one answers which question"). Default +\code{NULL}: no such interval.} } \value{ A tibble/data.frame (or sf if cells_sf given) with per-cell @@ -177,30 +230,41 @@ summaries: the ID column, \code{n} (rows in the cell), one column per \code{agg_funs} entry per variable, \verb{..sd_*} / \verb{..se_*} for every numeric response and predictor, \verb{..neff_*} / \verb{..df_*} / \verb{..ci_lo_*} / \verb{..ci_hi_*} for the same columns when \code{conf_level} is given, -\code{cell_weight}, \code{deff_applied} when a design effect was requested (any -\code{deff} other than 1), and \code{cell_area} / \code{n_per_area} when -\code{area = TRUE}. An input column also called \code{n} is not allowed to shadow -the count. - -\code{deff_applied} is \code{TRUE} on every row when the requested correction was -applied (exactly when the \code{"deff_applied"} attribute below is attached; -under \code{"kish"}, when any standard-error column was corrected) -and \code{FALSE} when it fell back to the uncorrected standard errors: a -refused \code{deff}, a \code{"variogram"} request with no usable model, or -\code{"kish"} ICCs of 0 for every variable type (and \code{NA} on a \code{cells_sf} -row no point fell in). -Unlike the attribute it survives \code{rbind()} and +\code{cell_weight}, \code{deff_applied} and \code{deff_method} when a design effect +was requested (any \code{deff} other than 1), and \code{cell_area} / \code{n_per_area} +when \code{area = TRUE}. An input column also called \code{n} is not allowed to +shadow the count. + +\code{deff_applied} is \code{TRUE} on every row when a design-effect correction +was applied (exactly when the \code{"deff_applied"} attribute below is +attached; under \code{"kish"}, when any standard-error column was corrected) +and \code{FALSE} when the standard errors are the uncorrected ones: a +refused \code{deff}, or \code{"kish"} ICCs of 0 for every column (and \code{NA} on a +\code{cells_sf} row no point fell in). \code{deff_method} names the correction +the standard errors carry, since their column names do not change with +it: \code{"variogram"}, \code{"kish"} or \code{"fixed"} when the one requested was +applied, \code{"none"} when none was, and \code{"kish (variogram fallback)"} or +\code{"none (variogram fallback)"} when a \code{"variogram"} request could not be +met and Kish stood in for it (the second when Kish's ICCs were 0 too). +So \code{deff_applied} is \code{TRUE} on a Kish fallback row: test +\code{deff_method == "variogram"} to keep only rows the variogram corrected. +Unlike the attribute, both columns survive \code{rbind()} and \code{dplyr::bind_rows()} of many results. A fallback is also signalled by a -warning of class \code{"spatialkit_deff_fallback"} (a Kish ICC of 0 is -reported on \code{attr(, "icc")} instead), which +warning of class \code{"spatialkit_deff_fallback"} (a Kish ICC of 0 under a +\code{"kish"} request is reported on \code{attr(, "icc")} instead), which \code{tryCatch(spatialkit_deff_fallback = )} catches without matching the -message; it is raised only when the standard errors really are the -uncorrected ones. +message. It is raised when the correction requested was not the one +applied: a refused number (the standard errors are then the uncorrected +ones) or a \code{"variogram"} request that fell back to Kish; the condition +of the second carries \code{requested} and \code{used}. When a correction was actually applied, an attribute \code{"deff_applied"} is attached recording it: \code{method} plus \code{icc_resp}/\code{icc_pred} and \code{deff} -for \code{"kish"} (\code{deff} is the primary variable's per-cell design effect, -all 1 when only the predictor ICC was positive), +for \code{"kish"} (\code{icc_pred} is a vector named by predictor column, one ICC +each; \code{deff} is the primary variable's per-cell design effect, +all 1 when only a predictor's ICC was positive; \code{requested} and +\code{fallback_reason} are added when a \code{"variogram"} request fell back to +it), \code{deff}/\code{deff_rows}/\code{rbar}/\code{crs}/\code{max_n} for \code{"variogram"} (\code{deff} is the design effect at the primary variable's non-missing count per cell, \code{deff_rows} at the cell's row count, which is the vector the log line @@ -209,12 +273,14 @@ When \code{cells_sf} is supplied, \emph{every} per-cell vector in that attribute (\code{deff}, \code{deff_rows} and \code{rbar} alike) is realigned to the joined row order, so \code{deff[i]} and \code{rbar[i]} still describe row \code{i}; cells with no observations carry \code{NA}. No attribute is attached when no correction was -applied: \code{deff = 1}, a \code{deff = "kish"} request whose ICCs are all 0, or -a \code{"variogram"} request that could not be fitted. A \code{deff = "kish"} request always -records the ICCs it estimated on an attribute \code{"icc"} (\code{resp} and -\code{pred}, \code{NA} for a variable type with no numeric column), whether or not +applied: \code{deff = 1}, or a \code{deff = "kish"} request (or Kish fallback) +whose ICCs are all 0. A \code{deff = "kish"} request, and a \code{"variogram"} +request that fell back to it, always +records the ICCs it estimated on an attribute \code{"icc"} (\code{resp}, and +\code{pred}, a vector named by predictor column; \code{NA} for a variable type +with no numeric column), whether or not they were positive enough to apply, so a result with no \code{"deff_applied"} -still says what the ICC came out as. +still says what the ICCs came out as. The ID column keeps its input type when \code{cells_sf}'s ID column and the summarised IDs already have the same class. When the classes differ, both @@ -222,10 +288,113 @@ are coerced to character in order to join (logged as a warning), and the returned ID column is therefore character. Whole numbers are written out in full for that (\code{"100000"}, never \code{"1e+05"}), so an integer and a double ID of the same cell still match. + +With \code{estimate = "pooled"}, each numeric column \code{v} with its prefix +(\code{resp_} or \code{pred_}) gains \verb{..pooled_} (the pooled value), +\verb{..pooled_w_} (the own weight, 0 to 1; it is not a regression +weight) and \verb{..pooled_target_} (the target), and with +\code{obs_level} also \verb{..obs_lo_} and \verb{..obs_hi_}. +They follow every column listed above and precede \code{cell_area} and +\code{n_per_area}, the response's first, then each predictor's. A cell with +no row that has a value, a cell and a location gets \code{NA}, never a value +made from its neighbours. Two attributes are attached. +\code{attr(, "pooled")}, of class \code{"spatialkit_pooled"}, records what was +fitted: \code{toward}, \code{neighbours}, \code{crs} (the CRS the centroid distances +were measured in), \code{obs_level}, \code{conf_level}, \code{intervals} and \code{columns}, +a list with one entry per pooled column holding \code{column}, \code{role} +(\code{"response"} or \code{"predictor"}), \code{n} (rows used), \code{cells}, \code{df} (values +beyond one per cell, which \code{sigma2} rests on), \code{neighbours} (the cells +in each target), \code{sigma2}, \code{tau2}, \code{own_weight} (the median weight), +\code{share_alone} (the share of rows that are the only one in their cell), +\code{loo} and \code{loo_se} (the leave-one-out mean squared error of the pooled +value, and its standard error over rows), \code{loo_one_cell} (the same error +with one mean for all rows), \code{structured} and \code{structure_p} (whether the +cells predict a left-out observation better than one mean, and the +p-value of the F test of the cell means against one mean, which has to +be below 0.05 as well), \code{offsets} (the two offsets of the interval), +\code{repeated}, \code{skipped}, \code{constant} and \code{status}. \code{attr(, "intervals")} is +the same data frame as \code{attr(, "pooled")$intervals}: one row per family +of interval columns in the frame, saying what it covers, what it is +centred on, its level and its method. Away from the observations no +interval here is calibrated. + +Where the pooled columns of a column cannot be computed they are \code{NA}, +with a warning of class \code{"spatialkit_pool_unavailable"} and not an +error, and the plain columns are returned. "Conditions" lists that +class and the other warnings of the pooled columns, with what each +condition carries. + +When \code{assigned_points_sf} carries \code{attr(, "count_rule")}, or \code{cells_sf} +does (the assigned layer's is read first), the result carries that +record with one more element, \code{check}, whatever \code{estimate} is. The +record is the one \code{\link[=select_resolution]{select_resolution()}} wrote: \code{rule}, \code{estimate} (the +cell value the count was chosen for), \code{cells}, \code{obs_per_cell}, +\code{response}, \code{scored} (what the profile scored at the count: the rows, +the cells that hold one, the leave-one-out error among them, and the +centres the rows were given to), +\code{partition}, \code{crs} and \code{scored_cells}. It has class +\code{"spatialkit_count_rule"} and a print method. \code{check$estimate} is +\code{"match"} or \code{"mismatch"}: whether the summary reports the estimate the +count was chosen for (\code{NA} for a count chosen for neither). A mismatch +is a warning of class \code{"spatialkit_estimate_mismatch"} (fields +\code{chosen_for}, \code{reported}, \code{rule}, \code{cells}), and the summary is returned +as asked. \code{check$cells} is \code{"match"}, \code{"differ"} or \code{"not checked: "}: the response is fitted again on the rows and cells given, +with the estimate the profile scored, and its scored rows, its occupied +cells and its leave-one-out error are compared with the record's, the +error to a relative tolerance of 1e-8. The first that differs is a +warning of class \code{"spatialkit_cells_differ"} (fields \code{what}: \code{"n"}, +\code{"cells"} or \code{"loo"}; \code{scored}; \code{found}): rows were dropped or moved +between cells, or the layer is another one. The same class with \code{what = "record"} (fields \code{field}, \code{scored}, \code{found}) is raised when the +assigned layer and \code{cells_sf} carry different records, so the rows were +assigned to other cells than the \code{cells_sf} given: the cells of another +selection, or the scored cells of a selection beside other cells built +from its count, such as a lattice sized by it. \code{check$cells} is then +\code{"differ"}, whatever the comparison of the rows finds. The comparison +is not made, and \code{check$cells} says why, when the response is another +column or was not summarised, the profile read the selection half +(\code{select_on = "split"}), the cells are not the ones the profile scored +(\code{scored_cells} is \code{FALSE} or \code{NA}), the profile scored no estimate, the +input has no coordinates, the features are not points (see +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}), or the fit was stopped by the limit on +an exact search without the 'FNN' package. Cells and rows without a +record, such as polygons the caller brings, are not checked and raise +neither warning. + +A row that is the same distance from two centres lies on the boundary +between their cells, which happens on gridded locations. +\code{\link[=resolution_profile]{resolution_profile()}} scores such a row in the cell of the +lower-numbered centre, and \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, on cells +built from the centres the profile scored, gives a point on that +boundary the same cell, measured in the CRS the record names, so the +comparison reads \code{"match"} on gridded locations too. +\code{\link[=build_tessellation]{build_tessellation()}} draws those cells in the CRS the record names, +whatever CRS the seeds arrive in, unless its \code{crs} names another +projected CRS. Cells built in another projected CRS are the +nearest-centre cells of that CRS, so a row near a boundary, on it or +not, can sit in another cell than the profile put it in. So can a row +joined in longitude and latitude (rows and cells both in degrees), and +a row that reached the record's CRS by another transformation than the +profile's, which can settle a tie the other way. The comparison then +reports \code{"differ"}, with \code{what = "loo"} when it finds the same rows in +the same number of cells with another leave-one-out error. The +summary's own numbers describe the cells as assigned. + +The comparison uses the fit of the pooled columns when that is a fit of +the estimate the profile scored, and fits the response once more +otherwise. Without the 'FNN' package that fit compares every pair of +cell centroids (pooled values) or, for each row alone in its cell, +every other location (plain means), and above +\code{options(spatialkit.exact_pairs_max = )} pairs it is not made +(\code{"not checked: work limit"}). A summary is not compared when neither +layer carries the record: \code{attr(x, "count_rule") <- NULL} on the +assigned layer and on \code{cells_sf} removes it. } \description{ Aggregates an sf point dataset into one row per cell. By default computes -counts and means, but the aggregation function is configurable. +counts and means, but the aggregation function is configurable. It also +returns a pooled value for each cell, its mean pulled toward the mean of +the cells around it (\code{estimate = "pooled"}, the default; \code{estimate = "mean"} leaves it out), and can return a range for one further +observation. } \details{ This is the third step of the package's pipeline, taking the labelled layer @@ -253,9 +422,20 @@ finite responses carries 3 observations' worth of information about the response, not 10), and it is divided by that cell's design effect when \code{deff} applied one. With \code{deff = 1} and no missing values it equals \code{n}. Pass it as the \code{weights} argument of a downstream regression. + +An infinite value (\code{Inf}, \code{-Inf}) in a response or predictor column is +treated as missing, as \code{NA} and \code{NaN} are, in every statistic of that +column: the \code{agg_funs} results, \verb{..sd_*}, \verb{..se_*}, the interval columns, +\verb{..neff_*}, \code{cell_weight} and the design effect. \code{n} still counts the row. +A warning of class \code{"spatialkit_nonfinite"} names the columns and gives the +number of rows and cells affected (the condition carries \code{n} and +\code{columns}). \code{\link[=kriging_adequacy]{kriging_adequacy()}}, \code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=estimate_sac_range]{estimate_sac_range()}} and \code{\link[=prep_model_data]{prep_model_data()}} leave such rows out too, so +the steps of one pipeline agree on a cell's mean. A function in \code{agg_funs} +therefore never sees an infinite value: \code{max} returns the largest finite +value, and infinities cannot be counted through \code{agg_funs}. } \section{Spatial autocorrelation and standard-error bias}{ - By default (\code{deff = 1}), the \verb{..se_*} columns are computed as \code{sd / sqrt(n)}, which treats the observations within each cell as independent. When data are spatially autocorrelated (the common case for the @@ -271,13 +451,13 @@ one when the cell's points are spread through it, and the corrected SE is too wide; see "What the standard error estimates" before setting \code{deff}. Setting \code{deff = "kish"} applies an approximate correction using Kish's -design effect. Separate intra-class correlations (ICCs) are estimated for -response and predictor variables via a one-way random-effects decomposition -across all cells. Each variable type's ICC is used for its own SE -adjustment, and each cell's effective sample size is reduced to -\code{n_i / (1 + (n_i - 1) * rho)}. This is a first-order correction that -does not require a full spatial covariance model but does require enough -cells and observations for a stable ICC estimate. +design effect. An intra-class correlation (ICC) is estimated for every +summarised column on its own, the response and each predictor, via a +one-way random-effects decomposition across all cells. Each column's ICC +is used for that column's SE adjustment, and each cell's effective sample +size is reduced to \code{n_i / (1 + (n_i - 1) * rho)}. This is a first-order +correction that does not require a full spatial covariance model but does +require enough cells and observations for a stable ICC estimate. A design effect estimated from the data (\code{"kish"} or \code{"variogram"}) comes with a second, small-sample correction. The within-cell correlation that @@ -308,19 +488,24 @@ explicit spatial covariance model (e.g. via \code{\link{fit_bayesian_spatial_mod } \section{What the standard error estimates}{ - -The \verb{..se_*} columns are the standard error of the cell mean \strong{as an -estimate of the population (grand) mean}: the unconditional quantity, in -which the cell's own realised deviation is part of the error. That is the -right quantity when cells are treated as samples from a common population, -and the design-effect correction is calibrated for it: measured 95\% interval -coverage of the grand mean is 0.95 with \code{deff = "kish"} (and 0.29 with the -naive SE) on exchangeable within-cell correlation, and 0.93 with -\code{deff = "variogram"} on a simulated Gaussian field. - -It is \strong{not} the standard error of the cell's own mean (the block average -over that cell), which is what a cell-level map or a regression on cell -values usually wants. For that quantity the naive \code{sd / sqrt(n)} is the +What the \verb{..se_*} columns estimate follows \code{deff}. At the default, +\code{deff = 1}, \code{sd / sqrt(n)} is the standard error of \strong{the cell's own +mean}, the mean of the units the cell holds, and it is the right one when +the cell's observations are spread through the cell. Under +\code{deff = "kish"}, \code{"variogram"} or a number other than 1 the columns are the +standard error of the cell mean \strong{as an estimate of the population (grand) +mean}: the unconditional quantity, in which the cell's own realised +deviation is part of the error, widened for the correlation inside the +cell. That is the right quantity when cells are treated as samples from a +common population: measured 95\% interval coverage of the grand mean is +0.95 with \code{deff = "kish"} (and 0.29 with the naive SE) on exchangeable +within-cell correlation, and 0.93 with \code{deff = "variogram"} on a simulated +Gaussian field. + +The corrected standard error is \strong{not} that of the cell's own mean (the +block average over that cell), which is what a cell-level map or a +regression on cell values usually wants. For that quantity the naive +\code{sd / sqrt(n)} is the better of the two on offer: measured coverage 0.95 under exchangeable within-cell correlation, against very nearly 1.00 for the design-effect-corrected SE, which is too wide by the factor @@ -336,9 +521,13 @@ is reasonably uniform. } \section{Design effects and variable types}{ - -\code{deff = "kish"} estimates a separate ICC for response and predictor -variables and applies each to its own columns. \code{deff = "variogram"} fits or +\code{deff = "kish"} estimates a separate ICC for each summarised column, the +response and every predictor, and applies each to that column alone: +listing or removing a predictor leaves every other column's standard error, +effective n and interval as they were. (One ICC used to be pooled over all +the predictors, which was right for a column only when they all shared it: +beside a predictor with an ICC of 0.87, one with an ICC of 0 had its +standard error multiplied by 3.1.) \code{deff = "variogram"} fits or accepts \strong{one} correlation function and applies it to every numeric column, because a variogram is a property of the field being modelled rather than of a variable type; a predictor whose spatial structure differs markedly from @@ -357,15 +546,17 @@ understated, as \code{\link[=kriging_adequacy]{kriging_adequacy()}} warns about } \section{Confidence intervals}{ - With \code{conf_level} set, every numeric response and predictor column gains four more columns: \verb{..neff_*}, that column's effective sample size in the cell (its non-missing count over its design effect, the per-column version of \code{cell_weight}); \verb{..df_*}, the degrees of freedom the interval uses; and -\verb{..ci_lo_*} / \verb{..ci_hi_*}, a t interval for the \strong{cell mean as an estimate -of the grand mean}. The estimand is the same as \verb{..se_*}'s, so everything -in "What the standard error estimates" applies to it, including that it is -not an interval for the cell's own block average. The interval is +\verb{..ci_lo_*} / \verb{..ci_hi_*}, a t interval for a mean. Which mean follows +\code{deff}, as for \verb{..se_*}: at the default, \code{deff = 1}, \strong{the cell's own +mean}, when its observations are spread through the cell; under +\code{deff = "kish"}, \code{"variogram"} or a number other than 1, the \strong{cell mean as +an estimate of the population (grand) mean}. Everything in "What the +standard error estimates" applies to it, including that the corrected +interval is not one for the cell's own block average. The interval is \verb{mean +/- qt((1 + conf_level) / 2, df) * se}, centred on the plain mean of the column's non-missing values whatever \code{agg_funs} computes, and is \code{NA} wherever the standard error is (a single observation; complete redundancy @@ -374,6 +565,17 @@ non-missing value or none, like the standard error; \code{cell_weight} still counts such a cell (1, or \code{1 / deff} for a numeric \code{deff}), so the two differ there. +At no setting is \verb{..ci_*} a range for one observation: it is an interval +for a mean, and it narrows as a cell's count grows where the spread of +single observations does not. The interval for one further observation in +a cell has its own argument and columns, \code{obs_level} with +\code{estimate = "pooled"} and \verb{..obs_lo_*} / \verb{..obs_hi_*} (see "Intervals: +which one answers which question"). In the simulation described there, +\verb{..ci_*} at \code{conf_level = 0.90} held 58.9 percent of the observations held +out among the others, and the interval for one observation at +\code{obs_level = 0.90} held 89.6 percent. Away from the observations no +interval here is calibrated. + The degrees of freedom are \strong{not} \code{neff - 1}. The interval's spread comes from the within-cell sample variance, and under exchangeable correlation (\code{deff = "kish"}) that variance keeps its \code{n - 1} degrees of freedom @@ -400,6 +602,278 @@ under it: a mis-specified variogram, or an ICC estimated from too few cells, moves the coverage with it. } +\section{Pooled values}{ +With \code{estimate = "pooled"} every numeric column also gets a pooled value. +That is the default; \code{estimate = "mean"} leaves the pooled columns out +and returns the frame of earlier versions. +A cell's value, plain or pooled, estimates the cell's \emph{level}: the +expected value of one further observation located in the cell the way its +observations were. It is not the average of a surface over the cell's +area, which would give weight to ground that holds no observation. + +For one column, write \code{n}, \code{S} and \code{m = S / n} for the count, the sum and +the mean of a cell's rows, \code{N} for the rows in all and \code{K} for the cells +that hold one. Then +\itemize{ +\item \code{sigma2 = sum((y - m)^2) / (N - K)} is the spread of the observed values +about their cell's mean; +\item the target \code{t} of a cell is the mean of the rows of its neighbours, +\code{sum(S) / sum(n)} over them. The neighbours are the 8 cells whose +centroids are nearest, the centroid of a cell being the mean of the +coordinates of its rows. The polygons are not read, so two cells are +neighbours whether or not they touch, and a cell is never its own +neighbour; +\item \code{tau2 = max(0, (sum(n * (m - t)^2) - K * sigma2) / N)} is the mean +squared distance between a cell's level and its target, the target's own +error included; +\item the own weight is \code{w = tau2 / (tau2 + sigma2 / n)}; +\item the pooled value is \code{w * m + (1 - w) * t}. +} + +The own weight is the share of the pooled value that is the cell's own +mean. It grows with the cell's count and with \code{tau2}. At 1 the pooled +value is the plain mean; at 0 it is the target and holds none of the +cell's own values. Pooled values are for maps and for predicting +observations. \verb{..pooled_w_*} is not a regression weight. The plain +columns are the same under either \code{estimate}, and they are the ones to +use, with \code{cell_weight}, in a regression on cell values: each column is +pulled toward its neighbours by its own amount, so a regression of pooled +responses on pooled predictors is not a regression of the levels. + +The cells can be any polygons the rows were assigned to, the package's +own or ones the caller brings, with IDs of any type: only each row's cell +and location are read. Each column is pooled on its own rows, those with +a value, a cell and a location, with its own centroids, neighbours, +\code{sigma2} and \code{tau2}; a +missing value in one column changes nothing in another. A cell with one +such row gets a value. A cell with none gets \code{NA}, never a value made from +its neighbours. The pooled columns do not read \code{agg_funs} or \code{deff}: the +mean that is pooled is the arithmetic mean whatever \code{agg_funs} computes, +and no design effect enters \code{sigma2}, \code{tau2}, the weights or the interval +of \code{obs_level}. + +Three cases change what the numbers rest on, and each is a warning (see +"Conditions"). With 2 to 9 cells the neighbours of a cell are all the +others, so its target is the mean of every row outside it, and the overall +mean lies between that target and the cell's own mean. A cell whose own +weight is below its share of the rows, \code{n / N}, then gets a pooled value +on the far side of the overall mean from its plain mean, and two cells can +change order. When few cells hold two rows, \code{sigma2} is estimated from few +values and every weight rests on it: \code{df} in \code{attr(, "pooled")} is the +number of values beyond one per cell. And when \code{tau2} comes out at 0, +every own weight is 0 and each pooled value is its target; with two +cells that is the other cell's mean, so the two values change places. + +A tie between two candidate neighbours goes to the centroid with the +lower x, then the lower y, and the centroids are summed with the rows in +coordinate order, so a cell's neighbours do not depend on the order of the +rows. The values then agree to rounding: a cell's sums are taken in the +order of its rows. +The tie is between distances computed from the coordinates in the CRS the +distances are measured in (see \code{estimate}), so on gridded locations the +same layer in another CRS or unit can give a cell another neighbour. + +The figures on this page that describe pooled values and the two +intervals come from one simulation, \code{dev/sim-pooled-values.R} in the +package's repository, whose header holds its settings and seeds. It draws 200 +layers on a square of side 1,000. Each has 2,100 clustered locations +(four fifths of them round 25 parent points with a standard deviation of +40, the rest uniform) and a response that is a field with covariance +\code{exp(-d / 100)} plus noise of variance 0.3. The 300 locations nearest a +random centre are held out as a block, 300 of the others are held out at +random, and the 1,500 left are the layer: 333 cells at 4.5 observations a +cell from \code{\link[=resolution_profile]{resolution_profile()}} with \code{partition = "density"}, +\code{select_resolution(criterion = "size")}, \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=build_tessellation]{build_tessellation()}} and \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, summarised +with \code{estimate = "pooled"}. A held-out observation is given the value of +its cell by \code{\link[=cell_values_at]{cell_values_at()}}. At the observations held out at random +the root mean squared error of the pooled value was 0.96 of the plain +mean's: 0.84 in cells that hold one of the layer's observations, 0.95 in +cells of 2 to 4, 0.98 in cells of 5 to 9 and 0.99 in cells of 10 or +more. In the held-out block it was 0.95. + +\code{structured} in \code{attr(, "pooled")} says whether these cells predict a +left-out observation better than one mean for all rows. It is \code{FALSE} +when the leave-one-out error of one mean (\code{loo_one_cell}) is within 2 +percent of that of the pooled values (\code{loo}) or below it, or when the F +test of the cell means against one mean has \code{p >= 0.05} +(\code{structure_p}). \code{FALSE} raises a warning of class +\code{"spatialkit_no_structure"}, and the values are returned. On a response +without spatial structure they still make a smooth map, because each is +mostly the mean of its neighbours. With white noise as the response on +the simulation's 200 layers the median own weight was 0.11, \code{tau2} was 0 +on 20 layers, the warning was raised on all 200, and a cell's pooled +value had a correlation of 0.79 with the mean of the pooled values of its +8 nearest cells, where the plain means had one of -0.02. + +The pooling model implies an error variance for a pooled value as an +estimate of the cell's level, \code{(1 - w) * tau2}. It is not returned, and +neither is an interval for the level, because no check has confirmed an +interval built from it; \code{sigma2}, \code{tau2} and \verb{..pooled_w_*} are in the +result for a reader who wants to form it. In the simulation, with a +cell's level taken as the mean of the noise-free field over further +locations drawn in it like the data's, the squared error of the pooled +value was 0.98 of \code{(1 - w) * tau2} among the observations and 6.9 times +it in the held-out block: away from the observations it is too small. + +Beside a sharp boundary the pooled value can be further from a cell's +level than the plain mean, because its target takes in cells across the +boundary. A second simulation measured this on fields whose level jumps +at county boundaries: one level for each county, alone and with a smooth +field added, on two layouts of real locations (892 and 2,634 points, each +in a county), with noise of 5, 20 or 50 percent of an observation's +variance, 200 layers of each, five random folds, and on each fold the +cells the package's defaults build from the training observations. A +held-out observation is a boundary row when every training observation +of its cell lies in its own county and more than half of those of the +cell's neighbours lie in other counties. Boundary rows were 21.75 to +28.04 percent of the held-out observations. Over them the root mean +squared error of the pooled value against the noise-free field, as a +geometric mean over the layers of its ratio to the plain mean's, was +from 9.16 percent lower to 56.36 percent higher. On county levels alone +it was 43.21 and 56.36 percent higher with 5 percent noise, 11.23 and +20.58 percent higher with 20 percent, and from 3.79 percent lower to 1.47 +percent higher with 50 percent; with the smooth field added it was from +9.16 percent lower to 1.59 percent higher. Over all held-out observations +the pooled value's error was the lower of the two in every setting, by +1.75 to 18.73 percent. +} + +\section{Intervals: which one answers which question}{ +Two families of interval columns can be in the frame. Each has its own +argument, and neither changes the other.\tabular{lllll}{ + Family \tab Columns \tab Target \tab Centre \tab Asked for by \cr + observation \tab \verb{..obs_lo_*}, \verb{..obs_hi_*} \tab one further observation in the cell \tab pooled value \tab \code{obs_level} \cr + mean \tab \verb{..ci_lo_*}, \verb{..ci_hi_*} \tab a mean, never one observation \tab plain mean \tab \code{conf_level} \cr +} + + +The observation of the first is one located in the cell the way the +data's were. \code{obs_level} needs \code{estimate = "pooled"}: without it the call +is an error, not an interval round the plain mean. The mean the second +covers follows \code{deff}: at \code{deff = 1} the cell's own mean, when its +observations are spread through the cell; under \code{deff = "kish"}, +\code{"variogram"} or a number other than 1 the cell mean as an estimate of +the population mean (see "Confidence intervals", which also describes +\verb{..neff_*} and \verb{..df_*}). No interval and no standard error is returned +for a cell's level as the pooled value estimates it. +\code{attr(, "intervals")} says the same of the frame in hand, one row per +family present. + +The interval for one observation is the pooled value plus two quantiles +of the leave-one-out residuals of the pooled values. The residual \code{e} of +a row is its value minus the pooled value of its cell computed without +it: the cell's mean and own weight are computed again without the row, +and \code{sigma2}, \code{tau2} and the targets are held. With +\code{p = (1 - obs_level) / 2}, +\code{..obs_lo = pooled + quantile(e, p)} and +\code{..obs_hi = pooled + quantile(e, 1 - p)}. +\itemize{ +\item It is a statement about observations on average: of further +observations located like the data, about \code{obs_level} of them fall +inside the interval of their cell. It does not hold cell by cell (the +second simulation below gives the coverage in cells of one +observation). +\item The two offsets are the same in every cell. The interval's centre +varies over the map and its width does not. It does not narrow where a +cell holds more rows: the offsets are quantiles of the errors of +predicting single observations, and the spread of observations inside a +cell is in every one of them. +\item It is wide. One observation is uncertain. +\item Only the level 0.90 has been checked. Another level is computed the +same way. +\item Each residual is the error of predicting an observation from the other +rows of its cell and from the cells around it, so the interval +describes locations among the observations. A cell's value and interval +describe the part of the cell where its observations lie, and a Voronoi +cell can reach far past them toward the edge of the study area. The +interval is too narrow for a cell with no observation, a gap in the +layer or ground beyond the layer's edge. +} + +In the simulation described under "Pooled values", the interval at +\code{obs_level = 0.90} held 89.6 percent of the observations held out at +random among the others (83.7 to 94.0 percent in single layers) and 75.1 +percent of those in the held-out block. \verb{..ci_*} at \code{conf_level = 0.90}, +read as a range for one observation, held 58.9 and 49.2 percent of them, +over the held-out observations whose cell has that interval. +\code{\link[=cell_values_at]{cell_values_at()}} returns each location's distance from the nearest +observation, and its help gives the coverage by that distance. + +The second simulation described under "Pooled values" read the +interval at \code{obs_level = 0.90} on smooth fields of two ranges and on +county levels with a smooth field, with 20 or 50 percent noise, on both +layouts: twelve settings. Setting by setting it held 89.38 to 89.79 +percent of the held-out observations. Counted by the training +observations in an observation's cell (1, 2 to 4, 5 to 9, 10 or more), it +held at least 85.65 percent in every class but one: on county levels with +a smooth field, on the layout of 892 points with 20 percent noise, it +held 83.74 percent of the 4,878 observations whose cell held one training +observation. On fields of that kind it is not a 90 percent interval in +such cells: there it held 83.74 to 87.83 percent with 20 or 50 percent +noise, and 82.64 and 82.94 percent with 5 percent. + +Away from the observations no interval here is calibrated. +} + +\section{Conditions}{ +What the pooled columns and the count record have to say is raised as R +warnings with a class, so \verb{tryCatch( = )} and +\code{withCallingHandlers()} catch each without matching its text. A warning +of the pooled columns is raised once per call and reason, for all the +columns it applies to: its text names them and the condition carries them +in \code{columns}, in the order of the pooled columns. A field said to be by +column is a vector named by those columns, and the numbers of each column +are in \code{attr(, "pooled")}. +\itemize{ +\item \code{"spatialkit_pool_unavailable"}: the pooled columns of a column are +\code{NA}. The plain columns are returned, and this is never an error. +\code{reason} is \code{"no coordinates"} (a layer without geometry), +\code{"no located value"} (no row with a value, a cell and a location), +\code{"no cell holds two values"} (the condition also carries \code{n} and +\code{cells} by column) or \code{"work limit"}. The last is the case of many +cells without the 'FNN' package: the neighbour search then compares +every pair of cells and is not made above +\code{getOption("spatialkit.exact_pairs_max", 2e9)} pairs, which is about +44,700 cells (the condition also carries \code{work}, \code{limit}, and \code{cells} +by column). With 'FNN' there is no such limit, and the result is the +same. +\item \code{"spatialkit_pool_degenerate"}: the pooled values were computed and +carry no pooling. \code{reason} is \code{"one cell"} (the pooled value is the +plain mean; also \code{n} by column), \code{"no spread inside any cell"} (every +own weight is 1; also \code{constant} by column) or \code{"no signal between cells"} (\code{tau2} is 0 and every own weight is 0; also \code{sigma2} by +column). +\item \code{"spatialkit_pool_few_cells"}: 2 to 9 cells, so each target is the mean +of all the other cells (\code{cells}, and \code{own_weight}, the smallest, by +column). +\item \code{"spatialkit_pool_few_df"}: \code{sigma2} rests on fewer than 30 values +beyond one per cell (\code{needed}, and \code{df}, \code{n} and \code{cells} by column). +\item \code{"spatialkit_no_structure"}: \code{structured} is \code{FALSE} (see "Pooled +values"). The text says which of the two tests failed, and \code{beats} is +\code{TRUE} for a column whose pooled values beat one mean while the F test +does not tell the cell means from one mean (also \code{criterion = "loo"}, +\code{estimate = "pooled"}, and by column \code{n}, the cells, \code{one_cell}, \code{loo} +and \code{structure_p}). +\item \code{"spatialkit_pool_rows_skipped"}: rows with a value and a cell have +empty or non-finite coordinates. They count in \code{n} and the plain +columns and take no part in the pooled ones (\code{n}, \code{cells}). +\item \code{"spatialkit_repeated_locations"}, with \code{obs_level}: rows with a value +share a location. A residual leaves one row out and keeps the others at +its location, so the interval then describes a further observation at a +place already observed (\code{n} and \code{total} by column). +\item \code{"spatialkit_few_residuals"}, with \code{obs_level}: fewer than five +residuals are expected beyond each end of the interval, which at 0.90 +is fewer than 100 residuals (\code{needed}, \code{level}, and \code{n} by column). +\item \code{"spatialkit_estimate_mismatch"} and \code{"spatialkit_cells_differ"}: the +two checks of the count record, described under "Value". +} + +The two about few cells and few values are raised for columns whose +weights were estimated, and the two of \code{obs_level} for columns whose +interval is read from residuals, so a constant column raises +\code{"spatialkit_pool_degenerate"} and no other. +} + \examples{ library(sf) set.seed(1) @@ -419,12 +893,16 @@ bnd <- st_sf(geometry = st_sfc(st_polygon(list(rbind( grid <- create_grid_polygons(bnd, target_cells = 9, type = "square") assigned <- assign_features_to_polygons(pts, grid) +# Nine cells are too few for pooled values (each would be pulled toward +# all the other cells), so these summaries report plain means alone: +# estimate = "mean". # IID standard errors (default) vs Kish design-effect adjustment. The # correction is large here, and meant to be: about 22 points per cell that # all share the cell's part of the trend carry far fewer than 22 # independent pieces of information about the cell mean. -naive <- summarize_by_cell(assigned, response_var = "val") -kish <- summarize_by_cell(assigned, response_var = "val", deff = "kish") +naive <- summarize_by_cell(assigned, response_var = "val", estimate = "mean") +kish <- summarize_by_cell(assigned, response_var = "val", deff = "kish", + estimate = "mean") data.frame(n = naive$n, se_naive = naive$..se_resp_val, se_kish = kish$..se_resp_val) @@ -433,9 +911,35 @@ attr(kish, "deff_applied") # method, icc_resp, icc_pred, per-cell deff # A 95\% interval for each cell mean as an estimate of the grand mean, on # the Kish-corrected standard error and n - 1 degrees of freedom. ci <- summarize_by_cell(assigned, response_var = "val", deff = "kish", - conf_level = 0.95) + conf_level = 0.95, estimate = "mean") ci[, c("poly_id", "n", "resp_mean_val", "..neff_resp_val", "..df_resp_val", "..ci_lo_resp_val", "..ci_hi_resp_val")] + +# Pooled values, and a range for one observation: a smooth field plus +# noise at 400 points, on an 8 x 8 grid, so that a cell holds about six. +set.seed(2) +east <- runif(400, 0, 8000) +north <- runif(400, 0, 8000) +pts2 <- st_as_sf( + data.frame(x = 5e5 + east, y = 5e6 + north, + val = 10 + 3 * sin(east / 1500) + 3 * cos(north / 1200) + + rnorm(400)), + coords = c("x", "y"), crs = 32632 +) +bnd2 <- st_sf(geometry = st_sfc(st_polygon(list(rbind( + c(5e5, 5e6), c(5e5 + 8000, 5e6), c(5e5 + 8000, 5e6 + 8000), + c(5e5, 5e6 + 8000), c(5e5, 5e6) +))), crs = 32632)) +grid2 <- create_grid_polygons(bnd2, target_cells = 64, type = "square") +assigned2 <- assign_features_to_polygons(pts2, grid2) +# estimate = "pooled" is the default. +pooled <- summarize_by_cell(assigned2, response_var = "val", obs_level = 0.90) +# The plain mean, the pooled value and the weight on the cell's own mean. +head(pooled[, c("poly_id", "n", "resp_mean_val", "..pooled_resp_val", + "..pooled_w_resp_val")]) +# The range for one further observation in a cell. +head(pooled[, c("poly_id", "..obs_lo_resp_val", "..obs_hi_resp_val")]) +attr(pooled, "pooled") # what was fitted, and what the interval covers } \references{ Faes, C., Molenberghs, G., Aerts, M., Verbeke, G. and Kenward, M. G. (2009). @@ -451,12 +955,13 @@ variance components. \emph{Biometrics Bulletin}, 2(6), 110--114. \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, which produces the input layer; \code{\link[=build_tessellation]{build_tessellation()}} for the cells themselves. -Other aggregation: -\code{\link{assign_features_to_polygons}()}, -\code{\link{determine_optimal_levels}()}, -\code{\link{kriging_adequacy}()}, -\code{\link{resolution_profile}()}, -\code{\link{select_resolution}()}, -\code{\link{summary.resolution_profile}()} +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summary.resolution_profile]{summary.resolution_profile()}} } \concept{aggregation} diff --git a/man/summary.resolution_profile.Rd b/man/summary.resolution_profile.Rd index 7ee66aa2..d26d6e80 100644 --- a/man/summary.resolution_profile.Rd +++ b/man/summary.resolution_profile.Rd @@ -10,8 +10,15 @@ \item{object}{A \code{\link{resolution_profile}()}.} \item{criteria}{Character vector, any of \code{"cp"}, -\code{"reliability"}, \code{"elbow"}, \code{"moran_z"}. Default: every -one of the four that is finite at some level.} +\code{"reliability"}, \code{"elbow"}, \code{"moran_z"}, \code{"loo"}. +Default: every one of \code{"cp"}, \code{"reliability"}, +\code{"elbow"} and \code{"loo"} that is finite at some level +(\code{loo} is a column of a profile built with \code{estimate}; a +column of that name on a profile built without one is read only when +named here). +\code{"moran_z"}, a diagnostic, is read only when named here. +\code{"size"} and \code{"auto"} are not criteria of the table: a size +sets the count and has no flat region to compare.} \item{tol}{Passed to \code{\link{select_resolution}()} for the flat region. Default 0.02.} @@ -24,12 +31,15 @@ criterion in the order given, with columns \code{criterion}, \code{best}, \code{flat_min}, \code{flat_max}, \code{n_flat}, \code{value} (the optimum itself, on that criterion's own scale and so not comparable across rows, which is why the print method leaves it out), -\code{at_floor}, \code{at_ceiling} and \code{edge} (which bound an +\code{at_floor}, \code{at_ceiling}, \code{edge} (which bound an edge optimum sits on, as \code{\link{select_resolution}()} reports it; -\code{NA} when interior). Attributes: \code{bands} (a named list holding each +\code{NA} when interior) and \code{structured} (as +\code{select_resolution()} reports it: \code{FALSE} for a \code{cp} +that one cell matches). Attributes: \code{bands} (a named list holding each criterion's flat region in full, since \code{flat_min} and \code{flat_max} are only its ends and the region can have holes in it), -\code{common} (the levels in every flat region, an integer vector that is +\code{common} (the levels in every flat region of the count criteria, +\code{moran_z} left out; an integer vector that is empty when the regions do not overlap), \code{scored} (the levels each criterion returned a finite value at, which is what decides whether a gap in a band is a rejection or a level nothing was computed at), @@ -40,12 +50,21 @@ honestly. } \description{ \code{\link{select_resolution}()} reads one criterion at a time. This puts -all of them in one table: the level each prefers, the flat region around -it, and whether a ladder bound is doing the choosing rather than the -criterion. The closing line gives the levels that lie in \emph{every} flat -region, the cell counts no criterion objects to. +the count criteria in one table: the level each prefers, the flat region +around it, and whether a ladder bound is doing the choosing rather than +the criterion. The closing line gives the levels that lie in \emph{every} +flat region, the cell counts no criterion objects to. } \details{ +The criteria are not peers, and the table should be read with what each +returns in practice in mind (see \code{\link{resolution_profile}()}): +\code{reliability} is read at or above the range floor and usually +returns it, \code{elbow} is absent unless the points cluster, and +\code{cp}'s optimum is often the support ceiling. \code{moran_z} is a +diagnostic of the cell means and not a count rule, so it is not in the +default set; named in \code{criteria} it gets a row, and it is left out +of the closing comparison. + A flat region is a set, not an interval. The criterion curves are not monotone, so a region can skip a rung of the ladder, and the table prints what the criterion actually accepts (\code{"26, 31"}, not \code{"26 to @@ -55,24 +74,28 @@ rejected. That set is often empty, and an empty one is a result rather than a failure. The criteria answer different questions: how well the cells represent the field (\eqn{C_p}), whether the cell values are -distinguishable from noise (\code{reliability}), where the within-cluster -sum of squares bends (\code{elbow}), and whether the cell means still carry -autocorrelation (\code{moran_z}). A field with no single right resolution -shows up here as disjoint bands, and the spread between the picks is -printed for the same reason. +distinguishable from noise (\code{reliability}), and where the +within-cluster sum of squares bends (\code{elbow}). A field with no +single right resolution shows up here as disjoint bands, and the spread +between the picks is printed for the same reason. Nothing in the table is a decision procedure. Each flat region is routinely wide, the choice within it belongs to the analyst, and \code{\link{plot.resolution_profile}()} draws the curves the bands were read from. + +A profile whose ladder is one size (\code{obs_per_cell} set to one +number, or the default profile) has one level, and the size set it. The +table then has one row per criterion that is finite at that level, and +the line under it says +that the count is set by the size and that no criterion chooses among +levels. The result carries the size as \code{attr(, "obs_per_cell")}. } \examples{ if (requireNamespace("gstat", quietly = TRUE)) { library(sf) # An exponential field with range parameter 200 (true effective range - # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough - # noise for Mallows' Cp to have an interior optimum rather than descend - # to the ceiling. + # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill. set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) @@ -93,12 +116,13 @@ if (requireNamespace("gstat", quietly = TRUE)) { per-level values attached; \code{\link{plot.resolution_profile}()} for the curves behind these bands. -Other aggregation: -\code{\link{assign_features_to_polygons}()}, -\code{\link{determine_optimal_levels}()}, -\code{\link{kriging_adequacy}()}, -\code{\link{resolution_profile}()}, -\code{\link{select_resolution}()}, -\code{\link{summarize_by_cell}()} +Other aggregation: +\code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}}, +\code{\link[=cell_values_at]{cell_values_at()}}, +\code{\link[=determine_optimal_levels]{determine_optimal_levels()}}, +\code{\link[=kriging_adequacy]{kriging_adequacy()}}, +\code{\link[=resolution_profile]{resolution_profile()}}, +\code{\link[=select_resolution]{select_resolution()}}, +\code{\link[=summarize_by_cell]{summarize_by_cell()}} } \concept{aggregation} diff --git a/man/summary.spatial_fit.Rd b/man/summary.spatial_fit.Rd index 16b84da3..55acf112 100644 --- a/man/summary.spatial_fit.Rd +++ b/man/summary.spatial_fit.Rd @@ -36,6 +36,14 @@ one it is holding, driven by \code{$info$fitted_are_oob}. Use Adjusted R-squared is suppressed: GWR's effective parameter count far exceeds the global predictor count, and a GP model has no simple \code{p}. + +For a \code{gwr_fit}, \code{print()} on the result adds what the +in-sample metrics are to be read against: the effective number of +parameters and residual degrees of freedom, the number of local windows +of deficient rank, the number of locations when observations share one, +and the AICc and RMSE of one global least-squares +regression on the same rows beside the fit's own AICc +(\code{$info$global_ols}; see \code{\link{fit_gwr_model}}). } \section{Percentage errors on responses with zeros}{ @@ -69,21 +77,21 @@ coverage, which are proper scoring rules and have no such failure mode. } \seealso{ -Other methods on a fitted model: -\code{\link{coef.bayesian_fit}()}, -\code{\link{coef.gwr_fit}()}, -\code{\link{coef.rf_fit}()}, -\code{\link{fitted.bayesian_fit}()}, -\code{\link{fitted.gwr_fit}()}, -\code{\link{fitted.rf_fit}()}, -\code{\link{model_metrics}()}, -\code{\link{predict.bayesian_fit}()}, -\code{\link{predict.gwr_fit}()}, -\code{\link{predict.rf_fit}()}, -\code{\link{print.rf_fit}()}, -\code{\link{print.spatial_fit}()}, -\code{\link{residuals.bayesian_fit}()}, -\code{\link{residuals.gwr_fit}()}, -\code{\link{residuals.rf_fit}()} +Other methods on a fitted model: +\code{\link[=coef.bayesian_fit]{coef.bayesian_fit()}}, +\code{\link[=coef.gwr_fit]{coef.gwr_fit()}}, +\code{\link[=coef.rf_fit]{coef.rf_fit()}}, +\code{\link[=fitted.bayesian_fit]{fitted.bayesian_fit()}}, +\code{\link[=fitted.gwr_fit]{fitted.gwr_fit()}}, +\code{\link[=fitted.rf_fit]{fitted.rf_fit()}}, +\code{\link[=model_metrics]{model_metrics()}}, +\code{\link[=predict.bayesian_fit]{predict.bayesian_fit()}}, +\code{\link[=predict.gwr_fit]{predict.gwr_fit()}}, +\code{\link[=predict.rf_fit]{predict.rf_fit()}}, +\code{\link[=print.rf_fit]{print.rf_fit()}}, +\code{\link[=print.spatial_fit]{print.spatial_fit()}}, +\code{\link[=residuals.bayesian_fit]{residuals.bayesian_fit()}}, +\code{\link[=residuals.gwr_fit]{residuals.gwr_fit()}}, +\code{\link[=residuals.rf_fit]{residuals.rf_fit()}} } \concept{methods on a fitted model} diff --git a/man/voronoi_seeds_kmeans.Rd b/man/voronoi_seeds_kmeans.Rd index 3ab0121e..74ca5a97 100644 --- a/man/voronoi_seeds_kmeans.Rd +++ b/man/voronoi_seeds_kmeans.Rd @@ -4,7 +4,17 @@ \alias{voronoi_seeds_kmeans} \title{K-means seed generation from point coordinates} \usage{ -voronoi_seeds_kmeans(points_sf, k, set_seed = 456, nstart = 10) +voronoi_seeds_kmeans( + points_sf, + k, + set_seed = 456, + nstart = NULL, + partition = c("density", "kmeans"), + init = NULL, + density_power = 1, + density_k = 8, + iter_max = NULL +) } \arguments{ \item{points_sf}{An sf object with POINT geometries.} @@ -15,8 +25,18 @@ of distinct point positions and \code{nrow(points_sf) - 1}, because k-means can produce neither more centres than there are distinct points nor as many centres as there are rows. Check \code{nrow()} on the result. A \code{\link[=select_resolution]{select_resolution()}} result or a \code{\link[=resolution_profile]{resolution_profile()}} is also -accepted: its scored centres are returned when it carries them, and -otherwise its count is used.} +accepted: its scored centres are returned when it carries them, +whatever \code{partition}, \code{init} and density settings the call names (see +\code{n} in \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} for which arguments a call is taken to +name), and +otherwise its count is used. A profile is read as \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} +reads one passed as \code{n}: by \code{cp} when it was built without an +\code{estimate}, and by \code{select_resolution(criterion = "auto")} when it was +built with one (a size for pooled values, the lowest leave-one-out +error for plain means). Such a count raises the warnings and the +error described under \code{n} in \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} (classes +\code{"spatialkit_bound_chosen"}, \code{"spatialkit_no_structure"} and +\code{"spatialkit_no_default_criterion"}).} \item{set_seed}{Optional integer RNG seed. Default 456, so a call gives the same seeds every time whatever the session's random-number state; an @@ -24,13 +44,73 @@ outer \code{\link[=set.seed]{set.seed()}} does not change them, and the caller's stream is left as it was. Pass \code{NULL} to draw the k-means starts from the session's stream instead (the default of \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}).} -\item{nstart}{Number of random starts for \code{\link[stats:kmeans]{stats::kmeans()}}; the best is -kept. Default 10.} +\item{nstart}{The number of starts, of which the best is kept. \code{NULL} +(default) is the kind's own number: 3 for \code{partition = "density"} and +10 for \code{partition = "kmeans"}, the default of earlier versions. A number +is run under either kind and either \code{init}: \code{nstart = 10} gives the +density kind the starts it had when 10 was the default.} + +\item{partition}{What the seeds minimise. \code{"density"} (default): the sum +of squared distances from the points to their nearest seed, each point +weighted by its local density to the power \code{density_power}; compact +cells that, at the default power, hold about the same number of points +each once \code{k} is above the number of dense places, and counts about as +uneven as \code{"kmeans"} gives below that. \code{"kmeans"}: the same sum +unweighted; compact cells whose counts are several times higher in +dense places than in sparse ones. It is the run of earlier versions, +whose default it was: \code{\link[stats:kmeans]{stats::kmeans()}} from 10 random starts on the +rows as they come. Without the 'FNN' package the density kind +finds its weights by comparing every pair of distinct locations, so its +time grows with the square of their number; the seeds are the same, and +nothing stops the call. See "Details".} + +\item{init}{How each start is drawn: \code{"random"} (\code{k} distinct locations +at random, as \code{\link[stats:kmeans]{stats::kmeans()}} draws them) or \code{"kmeans++"} (the seeds +one at a time, each in proportion to its squared distance from those +already drawn, times its weight under \code{partition = "density"}). \code{NULL} +(default) is each kind's own rule: \code{"random"} for \code{partition = "kmeans"}, the run this function has always made, and \code{"kmeans++"} for +\code{partition = "density"}. Under \code{partition = "kmeans"} from random +starts the points are clustered in the order their rows come in; with +\code{init = "kmeans++"}, and under \code{partition = "density"}, the rows are put +in coordinate order first, so the seeds do not depend on their order.} + +\item{density_power}{For \code{partition = "density"}: the power the local +density is raised to for a point's weight, from 0 to 2. Default 1, which +evens out the cell counts once the cells outnumber the dense places; 0 +weights every point alike, and values +above 1 give the cells of dense places fewer points than those of +sparse places. Setting it under \code{partition = "kmeans"} is a warning.} + +\item{density_k}{For \code{partition = "density"}: the number of nearest +neighbours the local density is read from. Default 8.} + +\item{iter_max}{The most iterations a start runs for: a single positive +whole number, or \code{NULL} (default) for the kind's own limit, 50 for +\code{partition = "kmeans"} and 100 steps of Lloyd's iteration for +\code{partition = "density"}. Under \code{partition = "density"}, and with \code{init = "kmeans++"}, a kept start that was cut off at the limit is a warning of +class \code{"spatialkit_not_converged"}; \code{partition = "kmeans"} from random +starts keeps the warning \code{\link[stats:kmeans]{stats::kmeans()}} gives.} } \value{ An sf object of \strong{at most} \code{k} cluster-centre POINTs (fewer when \code{k} exceeds the number of distinct positions), with \code{seed_id} and -\code{method = "kmeans"} columns matching \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}. +\code{method = "kmeans"} columns matching \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, and +\code{attr(, "cover")}, the convex hull of \code{points_sf} (an sfc in its CRS). +Seeds placed with \code{partition = "density"} or \code{init = "kmeans++"}, and +the scored centres of a profile of the density kind or from random +starts, also carry \code{attr(, "partition")}: a list with +\code{kind}, \code{init}, \code{density_power} and \code{density_k}, and for seeds this +call placed \code{iter}, \code{iter_max} and \code{converged} (the iterations the kept +start took, the limit, and whether it stopped before the limit). +\code{\link[=build_tessellation]{build_tessellation()}} returns the list as \code{params$partition}. Seeds +with no such record are plain k-means: from random starts when this call +placed them, or the scored centres of a k-means profile from k-means++ +starts. When \code{k} is a +\code{\link[=select_resolution]{select_resolution()}} result that carries \code{count_rule}, or a profile +built with an \code{estimate}, the seeds carry that record as +\code{attr(, "count_rule")}, with \code{scored_cells} \code{TRUE} for the scored +centres and \code{FALSE} for centres this call fits itself at that count +(see \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}). } \description{ Places \code{k} seed points at k-means cluster centres of the observed @@ -38,8 +118,10 @@ coordinates, so seeds (and the Voronoi cells built from them) follow the sampling density: clusters of observations attract seeds, empty ground gets none. Reach for this when you want cells that follow the data, so that counts per cell vary far less than on a fixed grid over clustered points -(k-means does not equalise them, it minimises the spread of points around -each centre), which is what keeps per-cell aggregates in +(the density kind, the default, evens them out once there are more cells +than clusters of points; plain k-means, \code{partition = "kmeans"}, minimises +the spread of points around each centre and does not equalise them), +which is what keeps per-cell aggregates in \code{\link[=summarize_by_cell]{summarize_by_cell()}} from resting on one or two observations. Use \code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} instead when you want coverage of the study area rather than of the data, and \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} to pick between them by @@ -53,15 +135,47 @@ come back in the input's own coordinates. Rows with empty or non-finite coordinates are dropped with a warning, and \code{k} is clamped to the number of distinct positions. -The partition is \code{\link[stats:kmeans]{stats::kmeans()}} (Hartigan-Wong) with \code{nstart} random -starts. \code{\link[=resolution_profile]{resolution_profile()}} and \code{\link[=determine_optimal_levels]{determine_optimal_levels()}} score each -count on a different run, by default the best of 25 k-means++ restarts, -which usually reaches a lower within-cluster sum of squares; the seeds for -a count passed as a number are therefore not the partition that count was -scored on. Raising \code{nstart} narrows the gap but does not close it. Pass -the \code{\link[=select_resolution]{select_resolution()}} result or the profile itself as \code{k} to close -it: the centres of the scored partition are then returned (in the CRS of -\code{points_sf}, with \code{attr(, "n_from")}), and no k-means is run. +A count given as a number gets a fresh partition, which is not the +partition \code{\link[=resolution_profile]{resolution_profile()}} or \code{\link[=determine_optimal_levels]{determine_optimal_levels()}} scored +that count on: those fit their own run, the profile to every row or to a +subsample, and keep the best of their own starts. Pass the +\code{\link[=select_resolution]{select_resolution()}} result or the profile itself as \code{k} to get the +scored one: the centres of the scored partition are then returned (in +the CRS of \code{points_sf}, with \code{attr(, "n_from")}), and no k-means is run. + +\code{partition} says what the seeds minimise. \code{"kmeans"} is the sum of +squared distances from the points to their nearest seed, from \code{nstart} +random starts by \code{\link[stats:kmeans]{stats::kmeans()}} (Hartigan-Wong) unless \code{init} says +otherwise; it was the default of earlier versions. The seeds +follow the square root of the point density, so the cells are compact, +smaller where the points are dense, and a cell in a dense place still +holds several times the points of a cell in a sparse place. \code{"density"} +weights each point by its local density (the number of points in the disc +that reaches its \code{density_k}-th nearest neighbour, over the disc's area) +to the power \code{density_power}, and is the default. At the default power +of 1 the seeds follow the point density itself, and the cells are +compact: many small cells where the points are dense, a few large ones +where they are sparse. They +hold about the same number of points each once \code{k} is above the number +of dense places (clusters of points). With fewer cells than that a cell +takes in whole clusters, large and small, and the counts are about as +uneven as under \code{"kmeans"}. The density kind is the best of +\code{nstart} starts, each refined by at most 100 steps of Lloyd's iteration +(\code{iter_max} sets another limit, and a kept start that was cut off at the +limit is a warning of class \code{"spatialkit_not_converged"}); +it does not depend on the order of the rows or on the unit of the +coordinates, and points at one location share a cell. A seed can end +with no point at counts from about a fifth of the points up, mostly from +\code{init = "random"}; that is a warning of class \code{"spatialkit_empty_cells"}. +"The partition" in +\code{\link[=resolution_profile]{resolution_profile()}} gives the details and a simulated comparison of +the two kinds. + +The centres lie inside the points, so their own hull is smaller than the +data's. The result carries the convex hull of \code{points_sf} as +\code{attr(, "cover")}, and \code{\link[=build_tessellation]{build_tessellation()}} clips the cells to that hull +(grown by 2 percent of its diagonal) when no \code{boundary} is passed, so every +point of \code{points_sf} falls in a cell. } \examples{ library(sf) @@ -70,19 +184,21 @@ pts <- st_as_sf( data.frame(x = 5e5 + runif(100, 0, 1000), y = 5e6 + runif(100, 0, 1000)), coords = c("x", "y"), crs = 32632 ) -seeds <- voronoi_seeds_kmeans(pts, k = 8) +seeds <- voronoi_seeds_kmeans(pts, k = 8) # density-weighted, 3 starts nrow(seeds) # at most 8: one seed per non-empty cluster seeds # the cluster centres, as an sf POINT layer in the points' CRS +# The k-means seeds of earlier versions: 10 random starts. +voronoi_seeds_kmeans(pts, k = 8, partition = "kmeans") } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_random}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} } \concept{tessellation} diff --git a/man/voronoi_seeds_random.Rd b/man/voronoi_seeds_random.Rd index d76d1f8d..769c7d39 100644 --- a/man/voronoi_seeds_random.Rd +++ b/man/voronoi_seeds_random.Rd @@ -22,7 +22,10 @@ loop over \code{\link[=set.seed]{set.seed()}}.} \value{ An sf object of \code{k} random POINTs (fewer only in the degenerate case above), with \code{seed_id} and \code{method = "random"} columns matching -\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}. +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, and \code{attr(, "cover")}, the polygons of \code{boundary}: +\code{\link[=build_tessellation]{build_tessellation()}} clips the cells to it (grown by 2 percent of its +diagonal) when no \code{boundary} is passed there, so the cells fill the area +the seeds were drawn in and not only the seeds' own hull. } \description{ Draws \code{k} seed points uniformly at random inside \code{boundary}, ignoring where @@ -54,14 +57,14 @@ identical(st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7)), st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7))) } \seealso{ -Other tessellation: -\code{\link{build_tessellation}()}, -\code{\link{create_grid_polygons}()}, -\code{\link{create_grid_polygons_cached}()}, -\code{\link{create_voronoi_polygons}()}, -\code{\link{ensure_stable_poly_id}()}, -\code{\link{get_voronoi_seeds}()}, -\code{\link{plot_tessellation_map}()}, -\code{\link{voronoi_seeds_kmeans}()} +Other tessellation: +\code{\link[=build_tessellation]{build_tessellation()}}, +\code{\link[=create_grid_polygons]{create_grid_polygons()}}, +\code{\link[=create_grid_polygons_cached]{create_grid_polygons_cached()}}, +\code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}}, +\code{\link[=ensure_stable_poly_id]{ensure_stable_poly_id()}}, +\code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}, +\code{\link[=plot_tessellation_map]{plot_tessellation_map()}}, +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}} } \concept{tessellation} diff --git a/tests/testthat/fixtures/core-frozen.rds b/tests/testthat/fixtures/core-frozen.rds new file mode 100644 index 00000000..8ea5d726 Binary files /dev/null and b/tests/testthat/fixtures/core-frozen.rds differ diff --git a/tests/testthat/helper-core-frozen.R b/tests/testthat/helper-core-frozen.R new file mode 100644 index 00000000..08774127 --- /dev/null +++ b/tests/testthat/helper-core-frozen.R @@ -0,0 +1,1045 @@ +# tests/testthat/helper-core-frozen.R +# --------------------------------------------------------------------------- +# The frozen baseline of the cell pipeline, for test-core-frozen.R and +# dev/baseline-core-frozen.R. +# +# core_frozen_calls() is a fixed list of calls to resolution_profile(), +# select_resolution(), summary() of a profile, determine_optimal_levels(), +# the seeding functions, build_tessellation(), create_voronoi_polygons(), +# assign_features_to_polygons() and summarize_by_cell(). +# dev/baseline-core-frozen.R runs the list on the baseline code and saves, +# for every call, what it returns, prints, raises and logs, and where it +# leaves the random-number stream (tests/testthat/fixtures/core-frozen.rds). +# The test runs the list again on the code under test and compares. +# +# A call names the arguments it is about and leaves every other one to its +# default, so the list pins what the defaults return. When a default +# changes, the calls written for the old value have to name it. The fixture +# stores the text of every call and the test compares it with this list, so +# a call cannot be edited without the fixture saying so. +# +# The defaults of five functions were switched together after the baseline +# was taken, and each call of them names the default it was recorded under: +# estimate = NULL, obs_per_cell = NULL, sac = NULL and partition = "kmeans" +# in resolution_profile(); criterion = "cp" in select_resolution(); +# partition = "kmeans" in get_voronoi_seeds() and voronoi_seeds_kmeans(); +# estimate = "mean" in summarize_by_cell(). A call that names the density +# kind names its old number of starts instead (nstart = 25L in the profile, +# 10 in a fresh seeding fit). A call that names `sac` or a criterion keeps +# its own. Four calls name no partition: each passes a selection or a +# profile of the density kind as the count, where partition = "kmeans" named +# raises spatialkit_partition_unused and nothing named returns the scored +# centres, as on the baseline (seeds_density_selection, +# seeds_density_profile, kmeans_density_selection, kmeans_density_profile). +# The text the records were taken with is the fixture's `calls_recorded`. +# --------------------------------------------------------------------------- + +# The layers the calls read, from the data frames the fixture stores. The +# data are stored and not drawn again, so they are the same numbers on every +# platform. +core_frozen_layers <- function(data) { + as_points <- function(d, crs = 32632) sf::st_as_sf(d, coords = c("x", "y"), crs = crs) + box <- function(layer) sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(layer))) + pts <- as_points(data$pts) + bnd <- box(pts) + ll <- as_points(data$ll, 4326) + # Regions a caller brings: the boundary cut into 4 x 4 squares, with an ID + # of each class a caller's polygons carry. + bb <- sf::st_bbox(pts) + xs <- bb[["xmin"]] + (0:4) * (bb[["xmax"]] - bb[["xmin"]]) / 4 + ys <- bb[["ymin"]] + (0:4) * (bb[["ymax"]] - bb[["ymin"]]) / 4 + at <- expand.grid(i = 1:4, j = 1:4) + squares <- sf::st_sfc(lapply(seq_len(nrow(at)), function(r) { + i <- at$i[r]; j <- at$j[r] + sf::st_polygon(list(rbind(c(xs[i], ys[j]), c(xs[i + 1L], ys[j]), c(xs[i + 1L], ys[j + 1L]), + c(xs[i], ys[j + 1L]), c(xs[i], ys[j])))) + }), crs = 32632) + units <- sf::st_sf(GEOID = sprintf("U%02d", 1:16), id_int = 1:16, id_dbl = (1:16) * 1e5, + id_fac = factor(sprintf("f%02d", 1:16)), geometry = squares) + list(pts = pts, # 400 points, a response with spatial structure + clus = as_points(data$clus), # 500 points, most of them in four clusters + big = as_points(data$big), # 1,800 points: more than `sample_n` + bnd = bnd, + ll = ll, # `pts` in longitude and latitude + bnd_ll = box(ll), + twice = as_points(data$twice), # 150 locations, each held by two rows + lattice = as_points(data$lattice), # a 12 x 12 lattice; a constant and an integer column + units = units) +} + +# The calls, in the order they run. A call reads the layers and the results +# of the calls before it by name. The first 154 are the list the baseline +# was first taken with; the rest were added after it and are appended, so +# that the names and the order of the first are what they were. +core_frozen_calls <- function() { + calls <- list() + add <- function(name, expr) { + if (!is.null(calls[[name]])) stop("core_frozen_calls(): two calls are named ", name) + calls[[name]] <<- expr + } + q <- function(name, expr) add(name, substitute(expr)) + # A profile read by every criterion, and summarised. + readings <- function(p) { + short <- sub("^profile_", "", p) + prof <- as.name(p) + for (cr in c("cp", "reliability", "elbow", "moran_z")) + add(sprintf("select_%s_%s", short, cr), + bquote(select_resolution(.(prof), criterion = .(cr)))) + add(sprintf("select_%s_moran_z_diagnostic", short), + bquote(select_resolution(.(prof), criterion = "moran_z", diagnostic = TRUE))) + add(sprintf("summary_%s", short), bquote(summary(.(prof)))) + } + + # ---- resolution_profile() ------------------------------------------------ + q("profile_default", resolution_profile(pts, "z", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_geometry", resolution_profile(clus, estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_levels", resolution_profile(pts, "z", levels = c(4, 8, 16, 32), + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_split", resolution_profile(pts, "z", select_on = "split", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_missing", resolution_profile(pts, "z_na", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_min_cell_n", resolution_profile(pts, "z", min_cell_n = 5, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_n_levels", resolution_profile(pts, "z", n_levels = 16, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_density", resolution_profile(pts, "z", partition = "density", estimate = NULL, + obs_per_cell = NULL, sac = NULL, nstart = 25L)) + q("profile_sampled", resolution_profile(big, "z", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_logical", resolution_profile(pts, "flag", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_no_value", resolution_profile(pts, "none", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_predictors", resolution_profile(pts, "z", predictor_vars = c("x1", "x2"), + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_noise", resolution_profile(pts, "noise", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_density_clustered", + resolution_profile(clus, "w", partition = "density", estimate = NULL, obs_per_cell = NULL, + sac = NULL, nstart = 25L)) + + # ---- select_resolution() and summary(), on every profile ----------------- + for (p in names(calls)) readings(p) + q("select_default_unnamed", select_resolution(profile_default, criterion = "cp")) + q("select_column_subset", + select_resolution(profile_default[, c("levels", "wss", "cp")], criterion = "cp")) + q("select_column_subset_without", + select_resolution(profile_default[, c("levels", "wss")], criterion = "cp")) + q("select_row_subset", select_resolution(profile_default[3:9, ], criterion = "cp")) + + # ---- get_voronoi_seeds() --------------------------------------------------- + q("seeds_number", get_voronoi_seeds(method = "kmeans", n = 30, sample_points = pts, + partition = "kmeans")) + q("seeds_number_seeded", + get_voronoi_seeds(method = "kmeans", n = 30, sample_points = pts, set_seed = 11, + partition = "kmeans")) + q("seeds_selection", + get_voronoi_seeds(method = "kmeans", n = select_default_cp, sample_points = pts, + partition = "kmeans")) + q("seeds_profile", + get_voronoi_seeds(method = "kmeans", n = profile_default, sample_points = pts, + partition = "kmeans")) + q("seeds_density", + get_voronoi_seeds(method = "kmeans", n = 30, sample_points = clus, + partition = "density", kmeans_nstart = 10)) + q("seeds_density_selection", + get_voronoi_seeds(method = "kmeans", n = select_density_cp, sample_points = pts)) + q("seeds_density_profile", + get_voronoi_seeds(method = "kmeans", n = profile_density_clustered, + sample_points = clus)) + q("seeds_noise_selection", + get_voronoi_seeds(method = "kmeans", n = select_noise_cp, sample_points = pts, + partition = "kmeans")) + q("seeds_boundary", get_voronoi_seeds(boundary = bnd, method = "kmeans", n = 20, + partition = "kmeans")) + q("seeds_random", get_voronoi_seeds(boundary = bnd, method = "random", n = 25, + partition = "kmeans")) + q("seeds_provided", get_voronoi_seeds(method = "provided", seeds = pts[1:20, ], + partition = "kmeans")) + + # ---- voronoi_seeds_kmeans() ------------------------------------------------ + q("kmeans_number", voronoi_seeds_kmeans(pts, 30, partition = "kmeans")) + q("kmeans_selection", voronoi_seeds_kmeans(pts, select_default_cp, partition = "kmeans")) + q("kmeans_profile", voronoi_seeds_kmeans(pts, profile_default, partition = "kmeans")) + q("kmeans_density", voronoi_seeds_kmeans(clus, 30, partition = "density", nstart = 10)) + q("kmeans_density_selection", voronoi_seeds_kmeans(pts, select_density_cp)) + q("kmeans_density_profile", + voronoi_seeds_kmeans(clus, profile_density_clustered)) + + # ---- build_tessellation() -------------------------------------------------- + q("cells_number", build_tessellation(seeds_number, method = "voronoi")) + q("cells_selection", build_tessellation(seeds_selection, method = "voronoi")) + q("cells_profile", build_tessellation(seeds_profile, method = "voronoi")) + q("cells_density", build_tessellation(seeds_density, method = "voronoi")) + q("cells_random", build_tessellation(seeds_random, boundary = bnd, method = "voronoi")) + q("cells_provided", build_tessellation(seeds_provided, method = "voronoi")) + q("cells_kmeans_number", build_tessellation(kmeans_number, method = "voronoi")) + q("cells_kmeans_selection", build_tessellation(kmeans_selection, method = "voronoi")) + q("cells_kmeans_density", build_tessellation(kmeans_density, method = "voronoi")) + q("cells_hex_number", + build_tessellation(pts, boundary = bnd, method = "hex", approx_n_cells = 12)) + q("cells_hex_profile", + build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = profile_default)) + + # ---- assign_features_to_polygons() ----------------------------------------- + q("assigned_number", + assign_features_to_polygons(pts, cells_number$cells, polygon_id_col = "cell_id")) + q("assigned_selection", + assign_features_to_polygons(pts, cells_selection$cells, polygon_id_col = "cell_id")) + q("assigned_density", + assign_features_to_polygons(clus, cells_density$cells, polygon_id_col = "cell_id")) + q("assigned_dropped", + assign_features_to_polygons(pts, cells_number$cells[1:20, ], + polygon_id_col = "cell_id")) + q("assigned_kept", + assign_features_to_polygons(pts, cells_number$cells[1:20, ], + polygon_id_col = "cell_id", keep_unassigned = TRUE)) + # One cell left with a single row and one with none. + q("assigned_sparse", { + id <- assigned_number$cell_id + ids <- sort(unique(id)) + drop <- id == ids[2L] | (id == ids[1L] & duplicated(id)) + assigned_number[!drop, ] + }) + + # ---- summarize_by_cell() --------------------------------------------------- + q("values_default", summarize_by_cell(assigned_number, "z", id_col = "cell_id", + estimate = "mean")) + q("values_no_response", summarize_by_cell(assigned_number, id_col = "cell_id", + estimate = "mean")) + q("values_kish", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "kish", + estimate = "mean")) + q("sac_z", estimate_sac_range(pts, "z")) + q("values_sac", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "variogram", + sac = sac_z, estimate = "mean")) + q("values_variogram", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "variogram", + estimate = "mean")) + q("values_deff_2", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = 2, estimate = "mean")) + q("values_conf_level", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", conf_level = 0.90, + estimate = "mean")) + q("values_cells_sf", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", + cells_sf = cells_number$cells, estimate = "mean")) + q("values_area", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", + cells_sf = cells_number$cells, area = TRUE, estimate = "mean")) + q("values_median", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", agg_funs = median, + estimate = "mean")) + q("values_predictors", + summarize_by_cell(assigned_number, "z", predictor_vars = c("x1", "x2"), + id_col = "cell_id", conf_level = 0.95, estimate = "mean")) + q("values_nonfinite", + summarize_by_cell(assigned_number, "z_bad", id_col = "cell_id", conf_level = 0.95, + estimate = "mean")) + q("values_sparse", + summarize_by_cell(assigned_sparse, "z", id_col = "cell_id", + cells_sf = cells_number$cells, conf_level = 0.95, estimate = "mean")) + q("values_unassigned", summarize_by_cell(assigned_kept, "z", id_col = "cell_id", + estimate = "mean")) + q("values_data_frame", + summarize_by_cell(sf::st_drop_geometry(assigned_number), "z", id_col = "cell_id", + estimate = "mean")) + q("values_selection", + summarize_by_cell(assigned_selection, "z", id_col = "cell_id", + cells_sf = cells_selection$cells, deff = "kish", + conf_level = 0.95, estimate = "mean")) + q("values_density", + summarize_by_cell(assigned_density, "w", id_col = "cell_id", + cells_sf = cells_density$cells, estimate = "mean")) + + # =========================================================================== + # Added after the first list. Present calls on the paths the later work + # rewrites and on inputs the first list does not read. + # =========================================================================== + + # ---- more profiles: other present arguments, other inputs ------------------ + first <- names(calls) + q("profile_geometry_sac", resolution_profile(clus, sac = sac_z, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans")) + q("profile_sac", resolution_profile(pts, "z", sac = sac_z, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans")) + q("profile_range_floor", resolution_profile(pts, "z", range_floor = TRUE, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_arguments", + resolution_profile(pts, "z", sample_n = 200, nstart = 5, seed = 9, init = "random", + iter_max = 30, estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_density_arguments", + resolution_profile(pts, "z", partition = "density", density_power = 0.5, + density_k = 4, nstart = 3, estimate = NULL, obs_per_cell = NULL, + sac = NULL)) + q("profile_lonlat", resolution_profile(ll, "z", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("profile_lonlat_density", resolution_profile(ll, "z", partition = "density", + estimate = NULL, obs_per_cell = NULL, + sac = NULL, nstart = 25L)) + q("profile_twice", resolution_profile(twice, "z", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_twice_density", resolution_profile(twice, "z", partition = "density", + estimate = NULL, obs_per_cell = NULL, + sac = NULL, nstart = 25L)) + q("profile_lattice", resolution_profile(lattice, "z", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_lattice_density", resolution_profile(lattice, "z", partition = "density", + estimate = NULL, obs_per_cell = NULL, + sac = NULL, nstart = 25L)) + q("profile_constant", resolution_profile(lattice, "const", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("profile_integer", resolution_profile(lattice, "count", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + for (p in setdiff(names(calls), first)) readings(p) + # Layers too small for a ladder, and what is not a layer. + q("small_five_rows", resolution_profile(pts[1:5, ], "z", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + q("small_five_rows_selected", select_resolution(small_five_rows, criterion = "cp")) + q("small_five_rows_count", + get_voronoi_seeds(method = "kmeans", n = small_five_rows, sample_points = pts[1:5, ], + partition = "kmeans")) + q("small_one_row", resolution_profile(pts[1L, ], "z", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("small_no_rows", resolution_profile(pts[0L, ], "z", estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + q("small_data_frame", resolution_profile(sf::st_drop_geometry(pts), "z", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + # Other present arguments of the readers. + q("select_default_tol", select_resolution(profile_default, tol = 0.1, range_floor = FALSE, + criterion = "cp")) + q("select_column_subset_cp", + select_resolution(profile_default[, c("levels", "cp")], criterion = "cp")) + q("summary_default_criteria", + summary(profile_default, criteria = c("cp", "elbow"), tol = 0.1)) + q("print_default_digits", utils::capture.output(print(profile_default, digits = 5))) + q("levels_default", determine_optimal_levels(pts, max_levels = 8L)) + q("levels_clustered", determine_optimal_levels(clus, max_levels = 8L)) + q("levels_morans", + determine_optimal_levels(pts, max_levels = 8L, response_var = "z", + criterion = "morans_i")) + q("levels_combined", + determine_optimal_levels(pts, max_levels = 8L, response_var = "z", + criterion = "combined")) + + # ---- a count read off a profile, a selection or a vector -------------------- + q("count_seeds_no_value", + get_voronoi_seeds(method = "kmeans", n = profile_no_value, sample_points = pts, + partition = "kmeans")) + q("count_kmeans_no_value", voronoi_seeds_kmeans(pts, profile_no_value, partition = "kmeans")) + q("count_hex_no_value", + build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = profile_no_value)) + q("count_seeds_geometry", + get_voronoi_seeds(method = "kmeans", n = profile_geometry, sample_points = clus, + partition = "kmeans")) + q("count_kmeans_geometry", voronoi_seeds_kmeans(clus, profile_geometry, partition = "kmeans")) + q("count_hex_geometry", + build_tessellation(clus, boundary = bnd, method = "hex", + approx_n_cells = profile_geometry)) + q("count_seeds_no_cp", + get_voronoi_seeds(method = "kmeans", n = profile_geometry_sac, sample_points = clus, + partition = "kmeans")) + q("count_kmeans_no_cp", voronoi_seeds_kmeans(clus, profile_geometry_sac, + partition = "kmeans")) + q("count_hex_no_cp", + build_tessellation(clus, boundary = bnd, method = "hex", + approx_n_cells = profile_geometry_sac)) + q("count_seeds_noise", + get_voronoi_seeds(method = "kmeans", n = profile_noise, sample_points = pts, + partition = "kmeans")) + q("count_kmeans_noise", voronoi_seeds_kmeans(pts, profile_noise, partition = "kmeans")) + q("count_hex_noise", + build_tessellation(pts, boundary = bnd, method = "hex", approx_n_cells = profile_noise)) + q("count_seeds_levels", + get_voronoi_seeds(method = "kmeans", n = profile_levels, sample_points = pts, + partition = "kmeans")) + q("count_kmeans_levels_selection", voronoi_seeds_kmeans(pts, select_levels_cp, + partition = "kmeans")) + q("count_hex_selection", + build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = select_default_cp)) + q("count_seeds_vector", + get_voronoi_seeds(method = "kmeans", n = c(12, 20, 8), sample_points = pts, + set_seed = 3, partition = "kmeans")) + q("count_kmeans_vector", voronoi_seeds_kmeans(pts, c(12, 20), partition = "kmeans")) + q("count_seeds_candidates", + get_voronoi_seeds(method = "kmeans", n = levels_default, sample_points = pts, + set_seed = 3, partition = "kmeans")) + q("count_seeds_other_layer", + get_voronoi_seeds(method = "kmeans", n = select_default_cp, sample_points = clus, + partition = "kmeans")) + q("count_seeds_selection_density_named", + get_voronoi_seeds(method = "kmeans", n = select_default_cp, sample_points = pts, + partition = "density")) + q("count_kmeans_selection_kmeans_named", + voronoi_seeds_kmeans(pts, select_density_cp, partition = "kmeans")) + + # ---- seeds: other present arguments, other inputs --------------------------- + q("seeds_arguments", + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, set_seed = 3, + kmeans_nstart = 2, kmeans_iter = 5, init = "kmeans++", + partition = "kmeans")) + q("seeds_one", get_voronoi_seeds(method = "kmeans", n = 1, sample_points = pts, set_seed = 3, + partition = "kmeans")) + q("seeds_lonlat", + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = ll, set_seed = 3, + partition = "kmeans")) + q("seeds_lonlat_density", + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = ll, set_seed = 3, + partition = "density", kmeans_nstart = 10)) + q("seeds_lonlat_selection", + get_voronoi_seeds(method = "kmeans", n = select_lonlat_cp, sample_points = ll, + partition = "kmeans")) + q("seeds_boundary_lonlat", + get_voronoi_seeds(boundary = bnd_ll, method = "kmeans", n = 15, set_seed = 3, + partition = "kmeans")) + q("seeds_random_lonlat", + get_voronoi_seeds(boundary = bnd_ll, method = "random", n = 15, set_seed = 3, + partition = "kmeans")) + q("seeds_twice", + get_voronoi_seeds(method = "kmeans", n = 20, sample_points = twice, set_seed = 3, + partition = "kmeans")) + q("seeds_twice_density", + get_voronoi_seeds(method = "kmeans", n = 20, sample_points = twice, set_seed = 3, + partition = "density", kmeans_nstart = 10)) + q("seeds_more_than_locations", + get_voronoi_seeds(method = "kmeans", n = 400, sample_points = twice, set_seed = 3, + partition = "kmeans")) + q("seeds_lattice", + get_voronoi_seeds(method = "kmeans", n = 16, sample_points = lattice, set_seed = 3, + partition = "kmeans")) + q("seeds_lattice_density", + get_voronoi_seeds(method = "kmeans", n = 16, sample_points = lattice, set_seed = 3, + partition = "density", kmeans_nstart = 10)) + q("seeds_random_density_named", + get_voronoi_seeds(boundary = bnd, method = "random", n = 5, set_seed = 3, + partition = "density")) + q("seeds_random_init_named", + get_voronoi_seeds(boundary = bnd, method = "random", n = 5, set_seed = 3, + init = "kmeans++", partition = "kmeans")) + q("seeds_random_power_named", + get_voronoi_seeds(boundary = bnd, method = "random", n = 5, set_seed = 3, + density_power = 0.5, partition = "kmeans")) + q("seeds_provided_density_named", + get_voronoi_seeds(method = "provided", seeds = pts[1:20, ], partition = "density")) + q("seeds_kmeans_power_named", + get_voronoi_seeds(method = "kmeans", n = 30, sample_points = pts, set_seed = 3, + density_power = 0.5, partition = "kmeans")) + q("kmeans_arguments", + voronoi_seeds_kmeans(pts, 25, set_seed = 1, nstart = 2, init = "kmeans++", iter_max = 8, + partition = "kmeans")) + q("kmeans_unseeded", voronoi_seeds_kmeans(pts, 30, set_seed = NULL, + partition = "kmeans")) + q("kmeans_lonlat", voronoi_seeds_kmeans(ll, 25, partition = "kmeans")) + q("kmeans_lonlat_density", voronoi_seeds_kmeans(ll, 25, partition = "density", nstart = 10)) + q("kmeans_more_than_locations", voronoi_seeds_kmeans(twice, 200, partition = "kmeans")) + q("kmeans_lattice_density", voronoi_seeds_kmeans(lattice, 16, partition = "density", + nstart = 10)) + q("random_number", voronoi_seeds_random(bnd, 12)) + q("random_seeded", voronoi_seeds_random(bnd, 12, set_seed = 5)) + + # ---- cells on those seeds --------------------------------------------------- + q("cells_lonlat", build_tessellation(seeds_lonlat, method = "voronoi")) + q("cells_lonlat_selection", build_tessellation(seeds_lonlat_selection, method = "voronoi")) + q("cells_twice", build_tessellation(seeds_twice, method = "voronoi")) + q("cells_lattice", build_tessellation(seeds_lattice, method = "voronoi")) + q("cells_one", build_tessellation(seeds_one, method = "voronoi")) + q("cells_boundary", build_tessellation(seeds_boundary, boundary = bnd, method = "voronoi")) + q("cells_kmeans_profile", build_tessellation(kmeans_profile, method = "voronoi")) + q("cells_density_selection", + build_tessellation(seeds_density_selection, method = "voronoi")) + q("cells_points", build_tessellation(pts[1:40, ], method = "voronoi")) + q("cells_quiet", build_tessellation(seeds_number, method = "voronoi", quiet = TRUE)) + q("cells_square", + build_tessellation(pts, boundary = bnd, method = "square", cellsize = 250)) + q("polygons_number", create_voronoi_polygons(seeds_number)) + + # ---- assignments ------------------------------------------------------------ + q("assigned_default_id", assign_features_to_polygons(pts, cells_number$cells)) + q("assigned_lonlat", + assign_features_to_polygons(ll, cells_lonlat$cells, polygon_id_col = "cell_id")) + q("assigned_twice", + assign_features_to_polygons(twice, cells_twice$cells, polygon_id_col = "cell_id")) + q("assigned_lattice", + assign_features_to_polygons(lattice, cells_lattice$cells, polygon_id_col = "cell_id")) + q("assigned_units_character", + assign_features_to_polygons(pts, units, polygon_id_col = "GEOID")) + q("assigned_units_integer", + assign_features_to_polygons(pts, units, polygon_id_col = "id_int")) + q("assigned_units_double", + assign_features_to_polygons(pts, units, polygon_id_col = "id_dbl")) + q("assigned_units_factor", + assign_features_to_polygons(pts, units, polygon_id_col = "id_fac")) + q("assigned_units_lonlat", + assign_features_to_polygons(ll, units, polygon_id_col = "GEOID")) + q("assigned_lattice_units", + assign_features_to_polygons(lattice, units, polygon_id_col = "GEOID", + tie_break = "first")) + q("assigned_one_region", { a <- assigned_number; a$cell_id <- 1L; a }) + q("assigned_one_row_regions", assigned_number[!duplicated(assigned_number$cell_id), ]) + q("assigned_one_row", assigned_number[1L, ]) + q("assigned_no_rows", assigned_number[0L, ]) + + # ---- summaries: other present arguments -------------------------------------- + q("values_id_found", summarize_by_cell(assigned_number, "z", estimate = "mean")) + q("values_not_quiet", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", quiet = FALSE, + estimate = "mean")) + q("values_not_quiet_variogram", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "variogram", + quiet = FALSE, estimate = "mean")) + q("values_other_cells", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", + cells_sf = cells_number$cells[1:20, ], estimate = "mean")) + q("values_area_missing", + summarize_by_cell(assigned_number, "z_na", id_col = "cell_id", + cells_sf = cells_number$cells, area = TRUE, estimate = "mean")) + q("values_variogram_cells_reversed", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "variogram", + sac = sac_z, cells_sf = cells_number$cells[30:1, ], estimate = "mean")) + q("values_variogram_max_n", + summarize_by_cell(assigned_number, "z", id_col = "cell_id", deff = "variogram", + sac = sac_z, cells_sf = cells_number$cells, deff_max_n = 5, + estimate = "mean")) + q("values_kish_predictors_area", + summarize_by_cell(assigned_number, "z_na", c("x1", "x2"), id_col = "cell_id", + deff = "kish", cells_sf = cells_number$cells, conf_level = 0.95, + area = TRUE, estimate = "mean")) + q("values_predictors_only", + summarize_by_cell(assigned_number, predictor_vars = c("x1", "x2"), id_col = "cell_id", + estimate = "mean")) + q("values_logical", summarize_by_cell(assigned_number, "flag", id_col = "cell_id", + estimate = "mean")) + q("values_functions", + summarize_by_cell(assigned_number, "z_na", id_col = "cell_id", + agg_funs = list(mean = function(x) mean(x, na.rm = TRUE), + top = function(x) max(x, na.rm = TRUE)), + estimate = "mean")) + q("values_function_names", + summarize_by_cell(assigned_number, "z_na", id_col = "cell_id", + agg_funs = c("median", "max"), estimate = "mean")) + q("values_data_frame_variogram", + summarize_by_cell(sf::st_drop_geometry(assigned_number), "z", id_col = "cell_id", + deff = "variogram", estimate = "mean")) + # The cells carry the ID as text and the rows as a number. + q("values_id_number_text", { + rows <- assigned_number + rows$cell_dbl <- rows$cell_id * 1e5 + cells <- cells_number$cells + cells$cell_dbl <- sprintf("%.0f", cells$cell_id * 1e5) + summarize_by_cell(rows, "z", id_col = "cell_dbl", cells_sf = cells, estimate = "mean") + }) + + # ---- summaries: other inputs -------------------------------------------------- + q("values_lonlat", + summarize_by_cell(assigned_lonlat, "z", id_col = "cell_id", + cells_sf = cells_lonlat$cells, estimate = "mean")) + q("values_lonlat_variogram", + summarize_by_cell(assigned_lonlat, "z", id_col = "cell_id", + cells_sf = cells_lonlat$cells, deff = "variogram", estimate = "mean")) + q("values_lonlat_area", + summarize_by_cell(assigned_lonlat, "z", id_col = "cell_id", + cells_sf = cells_lonlat$cells, area = TRUE, estimate = "mean")) + q("values_twice", + summarize_by_cell(assigned_twice, "z", id_col = "cell_id", deff = "variogram", + conf_level = 0.90, estimate = "mean")) + q("values_lattice", + summarize_by_cell(assigned_lattice, "z", id_col = "cell_id", + cells_sf = cells_lattice$cells, conf_level = 0.90, estimate = "mean")) + q("values_constant", + summarize_by_cell(assigned_lattice, "const", id_col = "cell_id", deff = "kish", + conf_level = 0.90, estimate = "mean")) + q("values_integer", summarize_by_cell(assigned_lattice, "count", id_col = "cell_id", + estimate = "mean")) + q("values_units_character", + summarize_by_cell(assigned_units_character, "z", id_col = "GEOID", cells_sf = units, + estimate = "mean")) + q("values_units_integer", + summarize_by_cell(assigned_units_integer, "z", id_col = "id_int", cells_sf = units, + area = TRUE, estimate = "mean")) + q("values_units_double", + summarize_by_cell(assigned_units_double, "z", id_col = "id_dbl", cells_sf = units, + estimate = "mean")) + q("values_units_factor", + summarize_by_cell(assigned_units_factor, "z", id_col = "id_fac", cells_sf = units, + deff = "kish", estimate = "mean")) + q("values_units_lonlat", + summarize_by_cell(assigned_units_lonlat, "z", id_col = "GEOID", cells_sf = units, + conf_level = 0.90, estimate = "mean")) + q("values_one_region", + summarize_by_cell(assigned_one_region, "z", id_col = "cell_id", deff = "kish", + conf_level = 0.90, estimate = "mean")) + q("values_one_row_regions", + summarize_by_cell(assigned_one_row_regions, "z", id_col = "cell_id", + cells_sf = cells_number$cells, deff = "kish", conf_level = 0.90, + estimate = "mean")) + q("values_one_row", + summarize_by_cell(assigned_one_row, "z", id_col = "cell_id", + cells_sf = cells_number$cells, estimate = "mean")) + q("values_no_rows", + summarize_by_cell(assigned_no_rows, "z", id_col = "cell_id", + cells_sf = cells_number$cells, estimate = "mean")) + calls +} + +# The text of the calls, as the fixture stores it. +core_frozen_call_text <- function(calls = core_frozen_calls()) + lapply(calls, function(e) paste(deparse(e, width.cutoff = 500L), collapse = " ")) + +# What decides the last bits of a result: the platform, R, sf and the +# libraries behind it, the optional packages a call reads, and the linear +# algebra library. +core_frozen_platform <- function() { + ext <- sf::sf_extSoftVersion() + ver <- function(p) if (requireNamespace(p, quietly = TRUE)) + as.character(utils::packageVersion(p)) else NA_character_ + list(platform = R.version$platform, + r = R.version.string, + sf = ver("sf"), + geos = ext[["GEOS"]], + proj = ext[["PROJ"]], + gdal = ext[["GDAL"]], + packages = vapply(c("gstat", "FNN", "Matrix", "dplyr", "s2"), ver, character(1)), + blas = unname(extSoftVersion()[["BLAS"]]), + lapack = La_library()) +} + +# The entries of a platform record that two runs have to share for their +# results to be held to identical(). +core_frozen_platform_keys <- function() + c("platform", "r", "sf", "geos", "proj", "packages", "blas", "lapack") + +# TRUE when two platform records agree on everything that can move a last +# bit, so that results can be held to identical(). +core_frozen_same_platform <- function(a, b) { + keys <- core_frozen_platform_keys() + identical(a[keys], b[keys]) +} + +# The package's functions as they run where the packages in `pkgs` are not +# installed: a copy of every function that asks requireNamespace() for one +# of them, with the question answered FALSE, as a named list for +# testthat::local_mocked_bindings(). .has_backend(), once the package has +# it, answers FALSE for them too. The copies keep their environment, so +# every call from one package function to another meets them. +core_frozen_without <- function(pkgs = c("FNN", "Matrix")) { + ns <- asNamespace("spatialkit") + asks <- function(e) is.call(e) && identical(e[[1L]], quote(requireNamespace)) && + length(e) >= 2L && is.character(e[[2L]]) && length(e[[2L]]) == 1L && e[[2L]] %in% pkgs + found <- FALSE + swap <- function(e) { + if (asks(e)) { found <<- TRUE; return(FALSE) } + if (is.call(e) || is.pairlist(e)) { + for (i in seq_along(e)) { + # An argument left empty, as in x[, 1], or one that is NULL. + if (is.null(e[[i]]) || (is.symbol(e[[i]]) && !nzchar(as.character(e[[i]])))) next + e[[i]] <- swap(e[[i]]) + } + } + e + } + out <- list() + for (nm in ls(ns, all.names = TRUE)) { + f <- get(nm, envir = ns) + if (!is.function(f) || is.primitive(f)) next + if (!("requireNamespace" %in% all.names(body(f))) && + !any(grepl("requireNamespace", deparse(args(f)), fixed = TRUE))) next + found <- FALSE + args <- swap(formals(f)) + code <- swap(body(f)) + if (!found) next + g <- f + if (!is.null(args)) formals(g) <- args + body(g) <- code + out[[nm]] <- g + } + if (exists(".has_backend", envir = ns, inherits = FALSE)) { + has <- get(".has_backend", envir = ns) + out[[".has_backend"]] <- function(pkg, ...) if (pkg %in% pkgs) FALSE else has(pkg, ...) + } + out +} + +# Run the calls on `data` and return one record per call: +# value what the call returned (NULL after an error) +# conditions every warning, message and error, in order: when it was +# raised ("call" or "print"), its kind, its class, its text, +# the function its call names (NA when it carries none) and +# the fields it carries besides +# output what the call wrote to standard output +# printed the print of a profile, a selection or a profile summary +# log the lines the package logged at WARN or above, the level its +# console echo shows, without their time stamps +# rng where the call left the random-number stream: `untouched` +# when it is the state the call started from, the state itself +# otherwise +# Everything a result can depend on besides the code is fixed for the run and +# put back afterwards: the random-number generator (seeded anew before every +# call), the options and the locale that printing and sorting read, sf's use +# of s2, the package's record of what it has logged once in this session, and +# its console log. +# +# `without` names optional packages the run is to do without, although they +# are installed (core_frozen_without()). +core_frozen_run <- function(data, calls = core_frozen_calls(), without = NULL) { + ns <- asNamespace("spatialkit") + # Optional packages are loaded before anything is recorded, so that what + # loading one says is no part of a call's record. + for (p in names(core_frozen_platform()$packages)) + suppressWarnings(suppressMessages(requireNamespace(p, quietly = TRUE))) + if (length(without)) + testthat::local_mocked_bindings(!!!core_frozen_without(without), .package = "spatialkit") + + old_opt <- options(width = 80, digits = 7, scipen = 0, OutDec = ".", + useFancyQuotes = FALSE, warn = 0) + on.exit(options(old_opt), add = TRUE) + old_collate <- Sys.getlocale("LC_COLLATE") + Sys.setlocale("LC_COLLATE", "C") + on.exit(Sys.setlocale("LC_COLLATE", old_collate), add = TRUE) + old_lang <- Sys.getenv("LANGUAGE", unset = NA) + Sys.setenv(LANGUAGE = "en") + on.exit(if (is.na(old_lang)) Sys.unsetenv("LANGUAGE") else Sys.setenv(LANGUAGE = old_lang), + add = TRUE) + + old_s2 <- suppressMessages(sf::sf_use_s2(TRUE)) + on.exit(suppressMessages(sf::sf_use_s2(old_s2)), add = TRUE) + + stream <- function() if (exists(".Random.seed", envir = globalenv(), inherits = FALSE)) + get(".Random.seed", envir = globalenv()) + had_seed <- exists(".Random.seed", envir = globalenv(), inherits = FALSE) + old_seed <- stream() + old_kind <- RNGkind() + on.exit({ + suppressWarnings(do.call(RNGkind, as.list(old_kind))) + if (had_seed) assign(".Random.seed", old_seed, envir = globalenv()) + else if (exists(".Random.seed", envir = globalenv(), inherits = FALSE)) + rm(".Random.seed", envir = globalenv()) + }, add = TRUE) + + once <- get(".warned_once", envir = ns) + old_once <- as.list(once, all.names = TRUE) + clear_once <- function() rm(list = ls(once, all.names = TRUE), envir = once) + on.exit({ clear_once(); list2env(old_once, envir = once) }, add = TRUE) + + logged <- character(0) + old_threshold <- tryCatch(logger::log_threshold(namespace = "spatialkit", index = 2), + error = function(e) logger::WARN) + on.exit({ + logger::log_appender(get(".sk_console_appender", envir = ns), + namespace = "spatialkit", index = 2) + logger::log_threshold(old_threshold, namespace = "spatialkit", index = 2) + }, add = TRUE) + logger::log_appender(function(lines) logged <<- c(logged, lines), + namespace = "spatialkit", index = 2) + logger::log_threshold(logger::WARN, namespace = "spatialkit", index = 2) + + env <- list2env(core_frozen_layers(data), envir = new.env(parent = ns)) + out <- stats::setNames(vector("list", length(calls)), names(calls)) + for (nm in names(calls)) { + clear_once() + logged <- character(0) + set.seed(20261012, kind = "Mersenne-Twister", normal.kind = "Inversion", + sample.kind = "Rejection") + start <- stream() + rec <- core_frozen_record(calls[[nm]], env) + end <- stream() + rec$log <- sub("^([A-Z]+) \\[[^]]*\\] ", "\\1 ", logged) + rec$rng <- list(untouched = identical(end, start), + state = if (!identical(end, start)) end) + assign(nm, rec$value, envir = env) + out[[nm]] <- rec + } + out +} + +# One call: its value, conditions, output and print. +core_frozen_record <- function(expr, env) { + conditions <- list() + # The fields a condition carries besides its text and its call: what a + # handler reads. A field that is not plain data (the backtrace or the + # parent a condition of another package may hold) is kept by its class. + plain <- function(v) is.null(v) || is.atomic(v) || + (is.list(v) && !is.object(v) && all(vapply(v, plain, logical(1)))) + fields <- function(cond) { + f <- unclass(cond) + f <- f[setdiff(names(f), c("message", "call"))] + lapply(f, function(v) if (plain(v)) v else list(not_recorded = class(v))) + } + from <- function(cond) { + cl <- conditionCall(cond) + if (is.null(cl)) NA_character_ + else paste(deparse(if (is.call(cl)) cl[[1L]] else cl), collapse = " ") + } + note <- function(when, kind, cond) + conditions[[length(conditions) + 1L]] <<- + list(when = when, kind = kind, class = class(cond), message = conditionMessage(cond), + call = from(cond), fields = fields(cond)) + watch <- function(code, when) withCallingHandlers( + tryCatch(code, error = function(e) { note(when, "error", e); NULL }), + warning = function(w) { note(when, "warning", w); invokeRestart("muffleWarning") }, + message = function(m) { note(when, "message", m); invokeRestart("muffleMessage") }) + value <- NULL + output <- utils::capture.output(value <- watch(eval(expr, env), "call"), type = "output") + printed <- NULL + if (inherits(value, c("resolution_profile", "resolution_selection", "resolution_summary"))) + printed <- utils::capture.output(invisible(watch(print(value), "print")), type = "output") + list(value = value, conditions = conditions, output = output, printed = printed) +} + +# ---- Comparing two records --------------------------------------------------- + +# The coordinates of a geometry set: for each geometry, its pieces (a point, +# a line, or one ring of a polygon) as two-column matrices. +core_frozen_coords <- function(g) { + pieces <- function(x) { + if (is.matrix(x)) list(unname(x[, 1:2, drop = FALSE])) + else if (is.list(x)) unlist(lapply(x, pieces), recursive = FALSE) + else if (is.numeric(x) && length(x) >= 2L) list(matrix(as.numeric(x)[1:2], 1L, 2L)) + else list() + } + lapply(g, function(x) { p <- pieces(x); if (is.null(p)) list() else p }) +} + +# The largest gap between two pieces with the same number of vertices. A +# ring is the same polygon wherever it starts and whichever way it runs, and +# GEOS versions differ in both, so two rings are compared at the start and +# the direction that bring them closest. The start is not taken from one +# ring alone (its smallest vertex, say): two vertices can tie for it, and a +# last bit then decides which one starts. +core_frozen_gap <- function(a, b) { + n <- nrow(b) + far <- function(u, v) { + d <- abs(u - v) + if (all(is.na(d))) 0 else max(d, na.rm = TRUE) + } + ring <- function(m) nrow(m) >= 4L && !anyNA(m) && all(m[1L, ] == m[nrow(m), ]) + if (!ring(a) || !ring(b)) return(far(a, b)) + a <- a[-n, , drop = FALSE] + b <- b[-n, , drop = FALSE] + n <- n - 1L + best <- Inf + for (turned in c(FALSE, TRUE)) { + u <- if (turned) a[n:1, , drop = FALSE] else a + for (s in seq_len(n)) { + best <- min(best, far(u[c(s:n, seq_len(s - 1L)), , drop = FALSE], b)) + if (best == 0) return(0) + } + } + best +} + +# An object in three parts. `shape` is the object with every number and +# every geometry taken out: names, classes, attribute names, types, lengths, +# and the values that are not numbers. `numbers` are the numeric vectors and +# `coords` the geometries' coordinates, both named by where they sit. A +# coordinate reference system is its name alone: its text changes with PROJ. +core_frozen_parts <- function(x, root = "value") { + numbers <- list() + coords <- list() + structural <- c("names", "class", "row.names", "dim", "dimnames", "levels", + "sf_column", "agr") + walk <- function(x, path) { + if (inherits(x, "crs")) return(list(crs = x$input)) + if (inherits(x, "sfg")) x <- sf::st_sfc(x) + if (inherits(x, "sfc")) { + coords[[path]] <<- core_frozen_coords(x) + return(list(class = class(x), length = length(x), + crs = sf::st_crs(x)$input, + empty = which(sf::st_is_empty(x)))) + } + a <- attributes(x) + # In name order: assigning to a column moves `class` to the end. + shape <- list(type = typeof(x), length = length(x), attributes = sort(names(a)), + structural = a[sort(intersect(names(a), structural))]) + for (nm in sort(setdiff(names(a), structural))) + shape[[paste0("@", nm)]] <- walk(a[[nm]], paste0(path, "@", nm)) + if (is.function(x) || is.language(x)) { + shape$value <- deparse(x) + } else if (is.list(x)) { + labels <- make.unique(if (is.null(names(x))) as.character(seq_along(x)) else names(x)) + shape$elements <- stats::setNames(lapply(seq_along(x), function(i) + walk(x[[i]], paste0(path, "$", labels[i]))), labels) + } else if (is.numeric(x) && !is.factor(x)) { + numbers[[path]] <<- as.vector(unclass(x)) + } else { + shape$value <- tryCatch(as.vector(unclass(x)), + error = function(e) paste(class(x), collapse = "/")) + } + shape + } + shape <- walk(x, root) + list(shape = shape, numbers = numbers, coords = coords) +} + +# The differences between two objects under the rule for another platform, +# as lines of text. `root` names the object in them. +core_frozen_compare <- function(got, want, root = "value") { + out <- character(0) + g <- core_frozen_parts(got, root) + w <- core_frozen_parts(want, root) + # Where two shapes that are not identical differ: the parts only one of + # them has, and the parts that hold other values. + where <- function(a, b) { + fa <- unlist(a); fb <- unlist(b) + both <- intersect(names(fa), names(fb)) + moved <- both[!mapply(identical, as.character(fa[both]), as.character(fb[both]))] + few <- function(x) paste(c(utils::head(x, 6L), if (length(x) > 6L) "..."), collapse = ", ") + d <- c(if (length(setdiff(names(fa), names(fb)))) + paste(" only now:", few(setdiff(names(fa), names(fb)))), + if (length(setdiff(names(fb), names(fa)))) + paste(" only on the baseline:", few(setdiff(names(fb), names(fa)))), + if (length(moved)) + paste(" other values:", few(sprintf("%s (now %s, baseline %s)", moved, + fa[moved], fb[moved])))) + if (length(d)) d else " identical() is FALSE, and no part by name differs" + } + if (!identical(g$shape, w$shape)) + return(c(sprintf("%s: names, classes, attributes or values that are not numbers differ:", + root), + where(g$shape, w$shape))) + for (nm in names(w$numbers)) { + d <- all.equal(g$numbers[[nm]], w$numbers[[nm]], tolerance = 1e-12) + if (!isTRUE(d)) out <- c(out, sprintf("%s: %s", nm, paste(d, collapse = "; "))) + } + for (nm in names(w$coords)) { + a <- g$coords[[nm]]; b <- w$coords[[nm]] + rows <- function(p) lapply(p, function(q) vapply(q, nrow, integer(1))) + if (!identical(rows(a), rows(b))) { + out <- c(out, sprintf("%s: the geometries have other numbers of vertices", nm)) + next + } + a <- unlist(a, recursive = FALSE); b <- unlist(b, recursive = FALSE) + if (!identical(lapply(a, is.na), lapply(b, is.na))) { + out <- c(out, sprintf("%s: other geometries are empty", nm)) + next + } + if (!length(b)) next + all_b <- do.call(rbind, b) + if (!any(is.finite(all_b))) next + extent <- max(diff(range(all_b[, 1L], na.rm = TRUE)), diff(range(all_b[, 2L], na.rm = TRUE))) + gap <- max(mapply(core_frozen_gap, a, b)) + if (!is.finite(gap) || gap > 1e-8 * max(extent, 1)) + out <- c(out, sprintf("%s: a coordinate differs by %.3g, more than 1e-8 of the extent (%.3g)", + nm, gap, extent)) + } + out +} + +# The differences between two records that hold on any platform, as lines of +# text; none when they agree. On another platform than the fixture's the +# numbers do not carry over: stats::kmeans() can stop at other centres +# (on a structureless layer at another solution), and the distortion PROJ +# measures moves with its version, so the counts of a profile, the warnings +# a fit raises and the printed numbers can all differ. What carries over +# is compared: whether the call stopped, and the class, names and +# attribute names of what it returned. +core_frozen_portable_differences <- function(got, want) { + stopped <- function(r) any(vapply(r$conditions, function(c) identical(c$kind, "error"), + logical(1))) + out <- character(0) + if (!identical(stopped(got), stopped(want))) + return(sprintf("the call %s; on the baseline it %s", + if (stopped(got)) "stops" else "returns", + if (stopped(want)) "stopped" else "returned")) + a <- got$value; b <- want$value + if (!identical(class(a), class(b))) + out <- c(out, sprintf("class: now %s; on the baseline %s", + paste(class(a), collapse = "/"), paste(class(b), collapse = "/"))) + if (!identical(names(a), names(b))) + out <- c(out, "the names of the value differ") + keep <- function(x) setdiff(sort(names(attributes(x))), c("row.names", "names")) + if (!identical(keep(a), keep(b))) + out <- c(out, sprintf("attributes: now %s; on the baseline %s", + paste(keep(a), collapse = ", "), paste(keep(b), collapse = ", "))) + out +} + +# The comparison a test applies: on the fixture's platform every part by the +# rule above (core_frozen_differences(), beside which the tests also ask for +# identical()), elsewhere what holds on any platform. +core_frozen_check <- function(got, want, same_platform) { + if (isTRUE(same_platform)) core_frozen_differences(got, want) + else core_frozen_portable_differences(got, want) +} + +# Text with what a platform can move taken out: every number is `#`, NaN is +# NA (R does not say which of the two a computation on missing values +# returns), and runs of blanks are one. A changed word, a line more or a +# line fewer is left to see. +core_frozen_mask <- function(x) { + if (is.null(x)) return(NULL) + x <- gsub("[-+]?[0-9][0-9.,]*(?:[eE][-+]?[0-9]+)?", "#", x, perl = TRUE) + x <- gsub("\\bNaN\\b", "NA", x, perl = TRUE) + gsub("[[:space:]]+", " ", trimws(x)) +} + +# The differences between two records under the rule for another platform, +# as lines of text; none when they agree. Identical: names, classes, +# attribute names and values that are not numbers; when each condition was +# raised, its kind, its class and the names of its fields; the number of +# lines logged, written and printed, and their text with the numbers taken +# out (core_frozen_mask()); whether the call left the random-number stream +# as it found it. Numbers, in the value and in a condition's fields, equal +# to 1e-12 as all.equal() measures it (the mean difference over the mean +# size). Coordinates equal to 1e-8 of the extent of the geometry set. +# Not compared: NA against NaN among the numbers, the function a condition's +# call names, and how far a call that draws moves the stream. +core_frozen_differences <- function(got, want) { + out <- core_frozen_compare(got$value, want$value, "value") + sig <- function(r) lapply(r$conditions, function(c) c[c("when", "kind", "class")]) + if (!identical(sig(got), sig(want))) { + said <- function(r) paste(vapply(r$conditions, function(c) + sprintf("%s (%s, in the %s)", c$class[1L], c$kind, c$when), character(1)), collapse = ", ") + out <- c(out, sprintf("the conditions differ: now %s; on the baseline %s", + if (length(got$conditions)) said(got) else "none", + if (length(want$conditions)) said(want) else "none")) + } else { + for (i in seq_along(want$conditions)) { + a <- got$conditions[[i]]; b <- want$conditions[[i]] + label <- sprintf("condition %d (%s)", i, b$class[1L]) + out <- c(out, core_frozen_compare(a$fields, b$fields, paste("the fields of", label))) + if (!identical(core_frozen_mask(a$message), core_frozen_mask(b$message))) + out <- c(out, sprintf("the text of %s differs beyond its numbers: now \"%s\"; on the baseline \"%s\"", + label, a$message, b$message)) + } + } + texts <- c(log = "logged lines", output = "lines written to standard output", + printed = "printed lines") + for (part in names(texts)) { + a <- core_frozen_mask(got[[part]]); b <- core_frozen_mask(want[[part]]) + if (identical(a, b)) next + if (is.null(a) || is.null(b)) { + out <- c(out, "one of the two has a print and the other none") + } else if (length(a) != length(b)) { + out <- c(out, sprintf("%d %s; on the baseline %d", length(a), texts[[part]], length(b))) + } else { + i <- which(a != b)[1L] + out <- c(out, sprintf("the %s differ beyond their numbers, first at line %d: now \"%s\"; on the baseline \"%s\"", + texts[[part]], i, got[[part]][i], want[[part]][i])) + } + } + if (!identical(got$rng$untouched, want$rng$untouched)) + out <- c(out, sprintf("the random-number stream: now %s; on the baseline %s", + if (isTRUE(got$rng$untouched)) "left as it was" else "moved", + if (isTRUE(want$rng$untouched)) "left as it was" else "moved")) + out +} diff --git a/tests/testthat/helper-partition-reference.R b/tests/testthat/helper-partition-reference.R new file mode 100644 index 00000000..c4ee2b07 --- /dev/null +++ b/tests/testthat/helper-partition-reference.R @@ -0,0 +1,181 @@ +# tests/testthat/helper-partition-reference.R +# --------------------------------------------------------------------------- +# Reference implementations of two partition kinds, for +# test-core-partition-reference.R. +# +# local_density(), wkmeanspp(), den_centres() and rnd_centres() are copied +# unchanged from the experiment that tested the kinds +# (local-outputs/core-factorial/10_partitions.R), with the constants they +# read. They are what the package's density kind and its random starts have +# to reproduce. +# +# The density functions call FNN: a test that uses them skips without it. +# --------------------------------------------------------------------------- + +RND_NSTART <- 5L +RND_ITER <- 100L +DEN_NSTART <- 3L +DEN_ITER <- 40L +DEN_NN <- 8L +DEN_POWER <- 1 + +# ---- RND ------------------------------------------------------------------ + +rnd_centres <- function(xy_tr, k, seed) { + warned <- 0L + one <- function(alg) { + set.seed(seed) + withCallingHandlers( + tryCatch(stats::kmeans(xy_tr, centers = k, nstart = RND_NSTART, iter.max = RND_ITER, algorithm = alg), + error = function(e) e), + warning = function(w) { warned <<- warned + 1L; invokeRestart("muffleWarning") }) + } + km <- one("Hartigan-Wong") + fell <- inherits(km, "error") + if (fell) km <- one("Lloyd") # only if Hartigan-Wong stops; noted + if (inherits(km, "error")) stop("k-means failed under both algorithms: ", conditionMessage(km)) + cen <- unname(km$centers) + attr(cen, "warned") <- warned + attr(cen, "fell") <- fell + cen +} + +# ---- DEN ------------------------------------------------------------------ + +# Points per unit area around each point, from the distance to its 8th +# nearest neighbour (not below 1 m). +local_density <- function(xy, k = DEN_NN) { + k <- min(k, nrow(xy) - 1L) + d <- FNN::get.knn(xy, k = k)$nn.dist[, k] + k / (pi * pmax(d, 1)^2) +} + +wkmeanspp <- function(xy, k, w) { + n <- nrow(xy) + idx <- integer(k) + idx[1L] <- sample.int(n, 1L, prob = w) + x1 <- xy[, 1]; x2 <- xy[, 2] + d2 <- (x1 - x1[idx[1L]])^2 + (x2 - x2[idx[1L]])^2 + if (k > 1L) for (j in 2:k) { + cs <- cumsum(w * d2) + tot <- cs[n] + idx[j] <- if (is.finite(tot) && tot > 0) min(n, findInterval(stats::runif(1L) * tot, cs) + 1L) + else sample.int(n, 1L) + d2 <- pmin(d2, (x1 - x1[idx[j]])^2 + (x2 - x2[idx[j]])^2) + } + xy[idx, , drop = FALSE] +} + +# Weighted Lloyd: lowers sum_i w_i |x_i - c_a(i)|^2; a centre is the weighted +# mean of its points, and a centre left without a point stays where it is. +den_centres <- function(xy_tr, k, seed) { + set.seed(seed) + w <- local_density(xy_tr)^DEN_POWER + w <- w / mean(w) + best <- NULL + for (r in seq_len(DEN_NSTART)) { + cen <- wkmeanspp(xy_tr, k, w) + for (it in seq_len(DEN_ITER)) { + a <- FNN::get.knnx(cen, xy_tr, k = 1L)$nn.index[, 1] + sw <- rowsum(w, a, reorder = TRUE) + sx <- rowsum(xy_tr * w, a, reorder = TRUE) + ids <- as.integer(rownames(sw)) + new <- cen + new[ids, ] <- sx / as.numeric(sw) + moved <- max(abs(new - cen)) + cen <- new + if (moved < 1e-6) break + } + nn <- FNN::get.knnx(cen, xy_tr, k = 1L) + obj <- sum(w * nn$nn.dist[, 1]^2) + if (is.null(best) || obj < best$obj) best <- list(cen = cen, obj = obj) + } + unname(best$cen) +} + +# ---- Point sets and measures ---------------------------------------------- + +# A clustered layout: `n_bg` points spread over a square of side `side` and +# `n_cl` more in Gaussian clusters, so that the point density varies by a +# factor of a hundred or so across the layer. The rows come out shuffled. +# The caller's random-number stream is left as it was. +partition_clustered_xy <- function(n_bg = 300L, n_cl = 900L, clusters = 4L, side = 1000, + origin = c(0, 0), seed = 11L) { + cleanup <- spatialkit:::.with_seed(seed) + on.exit(cleanup(), add = TRUE) + bg <- cbind(stats::runif(n_bg, 0, side), stats::runif(n_bg, 0, side)) + ctr <- cbind(stats::runif(clusters, 0.2, 0.8) * side, stats::runif(clusters, 0.2, 0.8) * side) + who <- sample.int(clusters, n_cl, replace = TRUE) + cl <- ctr[who, , drop = FALSE] + matrix(stats::rnorm(2L * n_cl, sd = side / 40), n_cl, 2L) + xy <- rbind(bg, cl) + xy <- xy[sample.int(nrow(xy)), , drop = FALSE] + unname(sweep(xy, 2L, origin, "+")) +} + +# A layout with more dense places than a coarse partition has cells, of two +# sizes: `cities` large Gaussian clusters hold half of the points (in +# decreasing shares), `towns` small tight ones hold 30 percent, and the rest +# are spread over the square. The rows come out shuffled, and the caller's +# random-number stream is left as it was. +partition_towns_xy <- function(n = 2000L, cities = 3L, towns = 25L, side = 1000, seed = 1L) { + cleanup <- spatialkit:::.with_seed(seed) + on.exit(cleanup(), add = TRUE) + n_city <- round(0.5 * n); n_town <- round(0.3 * n); n_bg <- n - n_city - n_town + cc <- cbind(stats::runif(cities, 0.2, 0.8), stats::runif(cities, 0.2, 0.8)) * side + wc <- sample.int(cities, n_city, replace = TRUE, prob = cities:1) + city <- cc[wc, , drop = FALSE] + matrix(stats::rnorm(2L * n_city, sd = side / 40), n_city, 2L) + tc <- cbind(stats::runif(towns), stats::runif(towns)) * side + wt <- sample.int(towns, n_town, replace = TRUE) + town <- tc[wt, , drop = FALSE] + matrix(stats::rnorm(2L * n_town, sd = side / 250), n_town, 2L) + xy <- rbind(city, town, cbind(stats::runif(n_bg), stats::runif(n_bg)) * side) + unname(xy[sample.int(nrow(xy)), , drop = FALSE]) +} + +# `n` points spread evenly over a square of side `side`. The caller's +# random-number stream is left as it was. +partition_uniform_xy <- function(n = 1200L, side = 1000, seed = 41L) { + cleanup <- spatialkit:::.with_seed(seed) + on.exit(cleanup(), add = TRUE) + cbind(stats::runif(n), stats::runif(n)) * side +} + +# A coordinate matrix as an sf POINT layer, with any further columns. +partition_points_sf <- function(xy, crs = 32632, ...) { + d <- data.frame(x = xy[, 1L], y = xy[, 2L], ...) + sf::st_as_sf(d, coords = c("x", "y"), crs = crs) +} + +# The coordinates of an sf POINT layer as a bare two-column matrix. +partition_xy <- function(x) unname(sf::st_coordinates(x)[, 1:2, drop = FALSE]) + +# The rows in coordinate order: the order the package's density kind works in. +partition_sorted <- function(xy) xy[order(xy[, 1L], xy[, 2L]), , drop = FALSE] + +# The nearest centre of every point, by brute force; the lower centre number +# wins a tie. +partition_nearest <- function(xy, cen) { + d2 <- outer(xy[, 1L], cen[, 1L], "-")^2 + outer(xy[, 2L], cen[, 2L], "-")^2 + apply(d2, 1L, which.min) +} + +# The coefficient of variation of the cell counts: 0 when every cell holds +# the same number of points. +partition_count_cv <- function(sizes) stats::sd(sizes) / mean(sizes) + +# Run a call whose warnings are not what the test is about. +partition_quietly <- function(expr) suppressWarnings(suppressMessages(expr)) + +# Run a call and keep the warnings it raises: list(value, warnings), the +# warnings as condition objects. +partition_warnings <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} + +# Those of a partition_warnings() result that have a class. +partition_of_class <- function(res, class) + Filter(function(w) inherits(w, class), res$warnings) diff --git a/tests/testthat/helper-pool-reference.R b/tests/testthat/helper-pool-reference.R new file mode 100644 index 00000000..d4e6eff0 --- /dev/null +++ b/tests/testthat/helper-pool-reference.R @@ -0,0 +1,354 @@ +# tests/testthat/helper-pool-reference.R +# --------------------------------------------------------------------------- +# Reference implementations of the region values, their leave-one-out errors +# and the size rule, for the tests of R/pool.R. +# +# Everything above the line "Layouts" is copied unchanged, comments and all, +# from the experiments that tested the estimates, with the constants the +# functions read. It is what the package's pooled value, its own-data +# weight, its two leave-one-out errors and its count at a size have to +# reproduce. The comments are the experiments' own: a "tract" there is a +# row, and a "training" row is a row with a value. +# +# local-outputs/core-factorial/20_estimates.R +# EST, NEIGHBOURS, PAR_DIV, PAR_NSTART, PAR_SEED, oneway(), reml_oneway(), +# weight(), reldiff(), parent_of(), region_estimates(), +# predict_partition() +# local-outputs/core-factorial/30_count_rules.R +# loo_plain(), pick_rung() +# local-outputs/core-factorial/10_partitions.R +# rung_k() +# local-outputs/estimate-design/20_lib.R +# wfun(), reml_means(), fit_regions(), loo_int() +# +# region_estimates(want = "L") is the pooled value and want = "P" the plain +# mean; fit_regions() returns the parts of the pooled value (sigma2, tau2, w, +# t, Q, nb) and the leave-one-out residuals of both estimates (eL, eP). +# +# parent_of() calls kpp_centres(), which is not copied: it runs only for the +# estimate "PAR", and fit_regions() asks for "P", "R" and "L". +# +# The functions call FNN: a test that uses them skips without it. +# --------------------------------------------------------------------------- + +# ---- core-factorial/20_estimates.R --------------------------------------------- + +EST <- c("P", "R", "L", "PAR") +NEIGHBOURS <- 8L +PAR_DIV <- 6 +PAR_NSTART <- 5L +PAR_SEED <- 123L + +# ---- copied from the prototype ----------------------------------------------------- + +oneway <- function(y, gi, K) { + n <- tabulate(gi, K) + stopifnot(all(n > 0L)) + S <- as.numeric(rowsum(y, gi)) + m <- S / n + N <- length(y) + mu <- sum(y) / N + if (N <= K) stop("no group holds two training tracts: no within-group variance") + sigma2 <- sum((y - m[gi])^2) / (N - K) + raw <- if (K > 1L) { + (sum(n * (m - mu)^2) / (K - 1L) - sigma2) / ((N - sum(n^2) / N) / (K - 1L)) + } else NA_real_ + tau2 <- if (K > 1L) max(0, raw) else 0 + list(n = n, S = S, m = m, N = N, K = K, mu = mu, sigma2 = sigma2, tau2 = tau2, tau2_raw = raw) +} + +reml_oneway <- function(a) { + ssw <- a$sigma2 * (a$N - a$K) + at <- function(r) { + w <- a$n / (1 + a$n * r) + mu <- sum(w * a$m) / sum(w) + s2 <- (ssw + sum(w * (a$m - mu)^2)) / (a$N - 1) + list(dev = (a$N - 1) * log(s2) + sum(log1p(a$n * r)) + log(sum(w)), mu = mu, sigma2 = s2, + tau2 = r * s2) + } + o <- stats::optimize(function(lr) at(exp(lr))$dev, c(-25, 15), tol = 1e-10) + b <- at(exp(o$minimum)) + z <- at(0) + if (z$dev <= b$dev) z else b +} + +weight <- function(tau2, sigma2, n) { + v <- sigma2 / n + ifelse(tau2 + v > 0, tau2 / (tau2 + v), 1) +} + +reldiff <- function(a, b) ifelse(a == b, 0, abs(a - b) / pmax(abs(a), abs(b))) + +# ---- the four estimates of every region -------------------------------------------- + +# The parent of each region: k-means of the regions' centroids at Kp parents. +parent_of <- function(cen, Kp, seed = PAR_SEED) { + K <- nrow(cen) + if (Kp < 2L || K < 3L) return(rep(1L, K)) + Kp <- min(Kp, K - 1L) + pc <- kpp_centres(cen, Kp, seed, nstart = PAR_NSTART) + p <- FNN::get.knnx(pc, cen, k = 1L)$nn.index[, 1] + match(p, sort(unique(p))) +} + +# Training values `y` in regions `gi` (1..K, none empty), training +# coordinates `xy`. Returns a K x length(want) matrix of estimates. +region_estimates <- function(y, gi, K, xy, want = EST) { + a <- oneway(y, gi, K) + out <- matrix(NA_real_, K, length(want), dimnames = list(NULL, want)) + secs <- stats::setNames(numeric(length(want)), want) + cen <- if (any(c("L", "PAR") %in% want)) rowsum(xy, gi) / a$n else NULL + for (e in want) { + t0 <- proc.time()[[3]] + if (e == "P") { + out[, e] <- a$m + } else if (e == "R") { + r <- reml_oneway(a) + wr <- weight(r$tau2, r$sigma2, a$n) + out[, e] <- wr * a$m + (1 - wr) * r$mu + } else if (e == "L") { + if (K > 1L) { + nb <- FNN::get.knn(cen, k = min(NEIGHBOURS, K - 1L))$nn.index + t3 <- rowSums(matrix(a$S[nb], K)) / rowSums(matrix(a$n[nb], K)) + tau3 <- max(0, (sum(a$n * (a$m - t3)^2) - K * a$sigma2) / a$N) + w3 <- weight(tau3, a$sigma2, a$n) + out[, e] <- w3 * a$m + (1 - w3) * t3 + } else out[, e] <- a$m + } else if (e == "PAR") { + parent <- parent_of(cen, as.integer(round(K / PAR_DIV))) + P <- max(parent) + np <- as.numeric(rowsum(a$n, parent)) + pm <- as.numeric(rowsum(a$S, parent)) / np + ssb <- sum(a$n * (a$m - pm[parent])^2) + dfb <- K - P + s2b <- 0 + if (dfb > 0L) { + n0 <- (a$N - sum(as.numeric(rowsum(a$n^2, parent)) / np)) / dfb + s2b <- max(0, (ssb / dfb - a$sigma2) / n0) + } + B <- weight(s2b, a$sigma2, a$n) + if (s2b > 0) { + w <- 1 / (s2b + a$sigma2 / a$n) + pm <- as.numeric(rowsum(w * a$m, parent)) / as.numeric(rowsum(w, parent)) + } else B <- rep(0, K) + out[, e] <- pm[parent] + B * (a$m - pm[parent]) + } else stop("unknown estimate ", e) + secs[e] <- proc.time()[[3]] - t0 + } + list(est = out, a = a, secs = secs) +} + +# One fold, one grouping: g_tr and g_te are the group ids of the training and +# the held-out tracts (any type). `p_empty`: the study's saved prediction, +# used under P for a held-out tract of an empty group (NULL: the rule itself). +predict_partition <- function(g_tr, g_te, y_tr, xy_tr, xy_te, want = EST, p_empty = NULL) { + u <- sort(unique(g_tr)) + K <- length(u) + gi <- match(g_tr, u) + ti <- match(g_te, u) + empty <- is.na(ti) + fi <- ti + if (any(empty)) { + fi[empty] <- gi[FNN::get.knnx(xy_tr, xy_te[empty, , drop = FALSE], k = 1L)$nn.index[, 1]] + } + r <- region_estimates(y_tr, gi, K, xy_tr, want) + pred <- r$est[fi, , drop = FALSE] + fill_gap <- 0 + if (any(empty) && !is.null(p_empty) && "P" %in% want) { + fill_gap <- max(reldiff(pred[empty, "P"], p_empty[empty])) + pred[empty, "P"] <- p_empty[empty] + } + list(pred = pred, n_own = ifelse(empty, 0L, r$a$n[ti]), K = K, a = r$a, gi = gi, secs = r$secs, + fill_gap = fill_gap, n_empty = sum(empty)) +} + +# ---- core-factorial/30_count_rules.R ------------------------------------------- + +# Mean squared closed-form leave-one-out error of plain averages. `a` is +# oneway() of the training values in the regions `gi`; `nn1` the index of +# each training tract's nearest other training tract. +loo_plain <- function(y_tr, gi, a, nn1) { + nj <- a$n[gi] + lr <- (y_tr - a$m[gi]) * nj / pmax(nj - 1L, 1L) + s <- nj == 1L + if (any(s)) lr[s] <- y_tr[s] - a$m[gi[nn1[s]]] + mean(lr^2) +} + +# The rung a criterion chooses (lower is better; the first of equals). +pick_rung <- function(crit) which.min(crit) + +# ---- core-factorial/10_partitions.R -------------------------------------------- + +# The count of a rung: m training tracts per region. +rung_k <- function(n_train, m) max(2L, as.integer(round(n_train / m))) + +# ---- estimate-design/20_lib.R -------------------------------------------------- + +wfun <- function(tau2, v) ifelse(tau2 + v > 0, tau2 / (tau2 + v), 1) + +# REML of tau2 for K means with known variances v (see the header, Rv). +reml_means <- function(m, v) { + at <- function(t2) { + w <- 1 / (t2 + v) + mu <- sum(w * m) / sum(w) + list(dev = sum(log(t2 + v)) + log(sum(w)) + sum(w * (m - mu)^2), mu = mu, tau2 = t2) + } + s <- stats::var(m) + if (!is.finite(s) || s <= 0) return(at(0)) + o <- stats::optimize(function(lt) at(exp(lt))$dev, c(log(s) - 25, log(s) + 5), tol = 1e-10) + b <- at(exp(o$minimum)) + z <- at(0) + if (z$dev <= b$dev) z else b +} + +# Everything about one fold and one grouping. g_tr, g_te: the group of every +# training and held-out tract. nn1: each training tract's nearest other +# training tract. s2_tr: the training tracts' sampling variances (NULL: the +# dataset has none). p_empty: the study's saved prediction, used under P for +# a held-out tract of an empty group (NULL: the fill rule itself). +fit_regions <- function(g_tr, g_te, y_tr, xy_tr, xy_te, nn1, s2_tr = NULL, p_empty = NULL) { + stopifnot(all(is.finite(y_tr)), is.null(s2_tr) || all(is.finite(s2_tr) & s2_tr > 0)) + u <- sort(unique(g_tr)) + K <- length(u) + gi <- match(g_tr, u) + ti <- match(g_te, u) + empty <- is.na(ti) + fi <- ti + if (any(empty)) fi[empty] <- gi[FNN::get.knnx(xy_tr, xy_te[empty, , drop = FALSE], k = 1L)$nn.index[, 1]] + r <- region_estimates(y_tr, gi, K, xy_tr, want = c("P", "R", "L")) # the factorial's P, R, L + a <- r$a + n <- a$n; N <- a$N + # L's parts once more (the expressions of region_estimates()), kept for what follows + cen <- rowsum(xy_tr, gi) / n + nb <- FNN::get.knn(cen, k = min(NEIGHBOURS, K - 1L))$nn.index + Sn <- rowSums(matrix(a$S[nb], K)) + Nn <- rowSums(matrix(n[nb], K)) + t3 <- Sn / Nn + Q <- sum(n * (a$m - t3)^2) + tau2 <- max(0, (Q - K * a$sigma2) / N) + w <- weight(tau2, a$sigma2, n) + L <- w * a$m + (1 - w) * t3 + stopifnot(identical(L, unname(r$est[, "L"]))) + # leave one training tract out + nj <- n[gi] + n1 <- nj - 1L + d1 <- pmax(n1, 1L) + res <- y_tr - a$m[gi] + ssw <- as.numeric(rowsum(res^2, gi)) + sng <- nj == 1L + kP <- gi + kP[sng] <- gi[nn1[sng]] # the region whose mean predicts a tract alone in its own + eP <- res * nj / d1 + eP[sng] <- y_tr[sng] - a$m[kP[sng]] + m1 <- (a$S[gi] - y_tr) / d1 + w1 <- ifelse(n1 >= 1L, weight(tau2, a$sigma2, d1), 0) + eL <- y_tr - (w1 * m1 + (1 - w1) * t3[gi]) + est <- cbind(P = a$m, R = unname(r$est[, "R"]), L = L, Pv = NA_real_, Rv = NA_real_, Lv = NA_real_) + out <- list(K = K, gi = gi, ti = ti, fi = fi, empty = empty, n = n, S = a$S, m = a$m, N = N, sigma2 = a$sigma2, + ssw = ssw, nb = nb, Sn = Sn, Nn = Nn, t = t3, Q = Q, tau2 = tau2, w = w, nj = nj, n1 = n1, kP = kP, + eP = eP, eL = eL, w1 = w1, loo_P = loo_plain(y_tr, gi, a, nn1), loo_L = mean(eL^2), + loo_L_se = stats::sd(eL^2) / sqrt(N), has_v = !is.null(s2_tr)) + if (!is.null(s2_tr)) { + A <- sum(s2_tr * (1 - 1 / nj)) + su2 <- max(0, (sum(ssw) - A) / (N - K)) + om <- 1 / (su2 + s2_tr) + s2sum <- as.numeric(rowsum(s2_tr, gi)) + sbar <- s2sum / n + v <- (su2 + sbar) / n + tauv <- max(0, (Q - sum(n * v)) / N) + wv <- wfun(tauv, v) + rm <- reml_means(a$m, v) + Bv <- wfun(rm$tau2, v) + est[, "Pv"] <- as.numeric(rowsum(om * y_tr, gi)) / as.numeric(rowsum(om, gi)) + est[, "Lv"] <- wv * a$m + (1 - wv) * t3 + est[, "Rv"] <- Bv * a$m + (1 - Bv) * rm$mu + sb1 <- (s2sum[gi] - s2_tr) / d1 + wv1 <- ifelse(n1 >= 1L, wfun(tauv, (su2 + sb1) / d1), 0) + out <- c(out, list(su2 = su2, sbar = sbar, v = v, tauv = tauv, wv = wv, taur = rm$tau2, wv1 = wv1, + v1 = (su2 + sb1) / d1, # the plain mean's variance with tract i left out (repair) + eLv = y_tr - (wv1 * m1 + (1 - wv1) * t3[gi]))) + } + out$est <- est + pred <- est[fi, , drop = FALSE] + if (any(empty) && !is.null(p_empty)) pred[empty, "P"] <- p_empty[empty] + out$pred <- pred + out$n_own <- ifelse(empty, 0L, n[fi]) + out +} + +loo_int <- function(centre, r_tr, c_tr, c_te) { + q <- stats::quantile(r_tr / c_tr, c(0.05, 0.95), names = FALSE, type = 7) + cbind(centre + c_te * q[1], centre + c_te * q[2]) +} + +# ---- Layouts ----------------------------------------------------------------------- + +# The layouts the engine is checked on. Ten by size, as (rows, rows per +# region, clustered), and three with the number of regions set: 2 and 3 +# regions on 60 rows, 4 on 90 clustered rows. +POOL_LAYOUTS <- list( + list(N = 600L, per = 18, clustered = FALSE), list(N = 600L, per = 4.5, clustered = FALSE), + list(N = 600L, per = 2, clustered = TRUE), list(N = 3000L, per = 4.5, clustered = TRUE), + list(N = 3000L, per = 9, clustered = FALSE), list(N = 3000L, per = 3, clustered = TRUE), + list(N = 3000L, per = 2, clustered = FALSE), list(N = 40L, per = 4.5, clustered = FALSE), + list(N = 12L, per = 4.5, clustered = FALSE), list(N = 9L, per = 4.5, clustered = TRUE), + list(N = 60L, clustered = FALSE, K = 2L, seed = 5L), + list(N = 60L, clustered = FALSE, K = 3L, seed = 6L), + list(N = 90L, clustered = TRUE, K = 4L, seed = 7L)) + +# Seed the generator R starts with, whatever kind the session has set, and +# return the function that puts the session's kind and stream back. +pool_seed <- function(seed) { + had <- exists(".Random.seed", envir = globalenv(), inherits = FALSE) + old <- if (had) get(".Random.seed", envir = globalenv()) + kind <- RNGkind() + set.seed(seed, kind = "Mersenne-Twister", normal.kind = "Inversion", + sample.kind = "Rejection") + function() { + suppressWarnings(do.call(RNGkind, as.list(kind))) + if (had) assign(".Random.seed", old, envir = globalenv()) + else if (exists(".Random.seed", envir = globalenv(), inherits = FALSE)) + rm(".Random.seed", envir = globalenv()) + } +} + +# One layout: `N` locations on a 100 km square, spread evenly or in twelve +# Gaussian clusters, a response with a smooth trend and noise, and the +# regions of a k-means fit at rung_k(N, per) centres (or `K`): each row is in +# the region of its nearest centre, and the regions that hold a row are +# numbered 1 to K. The seed is the one the layouts were first run with, +# 100 + N + 7 * per. The draws are R's default generator's whatever kind +# the session has set, and the caller's random-number stream is left as it +# was. +pool_layout <- function(N, per = NA, clustered = FALSE, K = NULL, + seed = 100 + N + 7 * per) { + cleanup <- pool_seed(seed) + on.exit(cleanup(), add = TRUE) + xy <- if (clustered) { + c0 <- cbind(stats::runif(12, 0, 1e5), stats::runif(12, 0, 1e5)) + i <- sample(12, N, replace = TRUE) + cbind(c0[i, 1] + stats::rnorm(N, 0, 4000), c0[i, 2] + stats::rnorm(N, 0, 4000)) + } else cbind(stats::runif(N, 0, 1e5), stats::runif(N, 0, 1e5)) + y <- sin(xy[, 1] / 2e4) + cos(xy[, 2] / 1.5e4) + stats::rnorm(N, 0, 0.6) + if (is.null(K)) K <- rung_k(N, per) + km <- suppressWarnings(stats::kmeans(xy, centers = K, nstart = 2, iter.max = 100)) + a <- spatialkit:::.nearest_centre(xy[, 1], xy[, 2], km$centers[, 1], km$centers[, 2]) + gi <- match(a, sort(unique(a))) + list(xy = xy, y = y, gi = gi, K = max(gi)) +} + +# Each row's nearest other row, as the reference functions take it: the +# experiments' own expression. It serves layouts without repeated locations +# only. Where a location repeats, FNN can return a row as its own +# neighbour, and which of several rows at one distance it returns is not +# fixed; such a layout is refused. +pool_nearest_other <- function(xy) { + if (anyDuplicated(xy)) + stop("pool_nearest_other(): two rows share a location; the reference serves ", + "layouts without repeated locations.") + nn <- FNN::get.knn(xy, k = 1L)$nn.index[, 1] + if (any(nn == seq_len(nrow(xy)))) + stop("pool_nearest_other(): a row came back as its own neighbour.") + nn +} diff --git a/tests/testthat/test-assignment.R b/tests/testthat/test-assignment.R index eaee6816..20f8888b 100644 --- a/tests/testthat/test-assignment.R +++ b/tests/testthat/test-assignment.R @@ -35,8 +35,23 @@ } +# The fixture's third point lies in neither polygon, so every default call on +# it leaves one feature out, with a warning of class "spatialkit_unassigned" +# that gives the count (it was one INFO line in the log). This asserts the +# warning and hands back the assigned layer. +.assign_dropping_one <- function(...) { + expect_warning(out <- assign_features_to_polygons(...), + "1 of 3 feature\\(s\\) \\(33.3%\\) fall inside no polygon", + class = "spatialkit_unassigned") + out +} + + test_that("assign_features_to_polygons attaches the polygon id and drops misses", { - out <- assign_features_to_polygons(.three_points(), .nested()) + out <- .assign_dropping_one(.three_points(), .nested()) + # The feature left out is on the result too, by its row in the input. + expect_identical(attr(out, "unassigned")$n, 1L) + expect_identical(attr(out, "unassigned")$which, 3L) expect_s3_class(out, "sf") # The unassigned point is dropped by default. @@ -48,9 +63,10 @@ test_that("assign_features_to_polygons attaches the polygon id and drops misses" expect_false(any(grepl("^\\.\\.", names(out)))) expect_equal(sf::st_crs(out), sf::st_crs(32632)) - # keep_unassigned retains the miss, with an NA id. - kept <- assign_features_to_polygons(.three_points(), .nested(), - keep_unassigned = TRUE) + # keep_unassigned retains the miss, with an NA id, and nothing is left + # out, so nothing is warned about. + expect_no_warning(kept <- assign_features_to_polygons(.three_points(), .nested(), + keep_unassigned = TRUE)) expect_equal(nrow(kept), 3L) expect_true(is.na(kept$poly_id[3])) }) @@ -60,13 +76,13 @@ test_that("tie_break = 'smallest_area' is independent of polygon order", { # The point at (6, 6) is inside BOTH nested polygons. The smallest-area # rule must pick the 9-unit polygon whichever row it occupies -- the previous # keep-the-first-duplicate behaviour depended on the join order. - fwd <- assign_features_to_polygons(.three_points(), .nested(c(1L, 2L))) - rev <- assign_features_to_polygons(.three_points(), - sf::st_sf(poly_id = c(2L, 1L), - geometry = sf::st_sfc( - .sq(5, 5, 8, 8), - .sq(0, 0, 10, 10), - crs = 32632))) + fwd <- .assign_dropping_one(.three_points(), .nested(c(1L, 2L))) + rev <- .assign_dropping_one(.three_points(), + sf::st_sf(poly_id = c(2L, 1L), + geometry = sf::st_sfc( + .sq(5, 5, 8, 8), + .sq(0, 0, 10, 10), + crs = 32632))) # In both layers the SMALL polygon carries id 2 and the big one id 1. expect_equal(fwd$poly_id[fwd$v == 1L], 2L) @@ -86,16 +102,14 @@ test_that("tie_break = 'first' keeps the first match, which is order-dependent", .sq(0, 0, 10, 10), crs = 32632)) - a <- assign_features_to_polygons(.three_points(), big_first, - tie_break = "first") - b <- assign_features_to_polygons(.three_points(), small_first, - tie_break = "first") + a <- .assign_dropping_one(.three_points(), big_first, tie_break = "first") + b <- .assign_dropping_one(.three_points(), small_first, tie_break = "first") expect_equal(a$poly_id[a$v == 1L], 1L) # big listed first -> big wins expect_equal(b$poly_id[b$v == 1L], 1L) # small listed first -> small wins # The two strategies genuinely differ on this input. - smallest <- assign_features_to_polygons(.three_points(), big_first) + smallest <- .assign_dropping_one(.three_points(), big_first) expect_false(identical(a$poly_id[a$v == 1L], smallest$poly_id[smallest$v == 1L])) expect_error(assign_features_to_polygons(.three_points(), big_first, @@ -131,8 +145,7 @@ test_that("largest = TRUE resolves a straddling polygon by overlap area", { # `largest` is only applicable to polygon features; point input must not # error on it (st_join rejects largest= for some predicates). - expect_equal(nrow(assign_features_to_polygons(.three_points(), cells, - largest = TRUE)), 2L) + expect_equal(nrow(.assign_dropping_one(.three_points(), cells, largest = TRUE)), 2L) }) @@ -141,7 +154,7 @@ test_that("re-assigning an already-assigned layer drops the colliding column", { # (poly_id.x / poly_id.y), so the rename below it never found `poly_id` and # the function returned ZERO ROWS -- silently, for the completely ordinary # case of re-assigning points that came out of a previous call. - first <- assign_features_to_polygons(.three_points(), .nested()) + first <- .assign_dropping_one(.three_points(), .nested()) expect_true("poly_id" %in% names(first)) # A real warning as well as the log line: a user column is being dropped. @@ -175,7 +188,7 @@ test_that("re-assigning an already-assigned layer drops the colliding column", { test_that("assign_features_to_polygons invents ids when the layer has none", { bare <- sf::st_sf(geometry = sf::st_sfc(.sq(0, 0, 10, 10), .sq(10, 0, 20, 10), crs = 32632)) - out <- assign_features_to_polygons(.three_points(), bare) + out <- suppressMessages(.assign_dropping_one(.three_points(), bare)) expect_true("poly_id" %in% names(out)) expect_equal(out$poly_id, c(1L, 1L)) # both surviving points in cell 1 @@ -187,12 +200,12 @@ test_that("assign_features_to_polygons harmonises CRS and restores the input's", cells <- .two_cells() # EPSG:32632 pts_ll <- sf::st_transform(.three_points(), 4326) - out <- assign_features_to_polygons(pts_ll, cells) + out <- .assign_dropping_one(pts_ll, cells) # Result comes back in the CRS the features arrived in, not the polygons'. expect_equal(sf::st_crs(out), sf::st_crs(4326)) # The assignment itself is the same one the projected input gets. - ref <- assign_features_to_polygons(.three_points(), cells) + ref <- .assign_dropping_one(.three_points(), cells) expect_equal(out$poly_id, ref$poly_id) expect_equal(out$v, ref$v) }) @@ -210,7 +223,7 @@ test_that("assign_features_to_polygons rejects unusable input", { # An sfc polygon layer is accepted and given sequential ids. sfc_cells <- sf::st_geometry(.two_cells()) - out <- assign_features_to_polygons(.three_points(), sfc_cells) + out <- suppressMessages(.assign_dropping_one(.three_points(), sfc_cells)) expect_equal(nrow(out), 2L) expect_true("poly_id" %in% names(out)) }) @@ -226,7 +239,7 @@ test_that("summarize_by_cell consumes the ids assign_features_to_polygons emits" coords = c("x", "y"), crs = 32632 ) assigned <- assign_features_to_polygons(pts, .two_cells()) - cells <- summarize_by_cell(assigned, response_var = "val") + cells <- summarize_by_cell(assigned, response_var = "val", estimate = "mean") expect_equal(sum(cells$n), nrow(assigned)) expect_equal(sort(cells$poly_id), sort(unique(assigned$poly_id))) diff --git a/tests/testthat/test-audit-pass5.R b/tests/testthat/test-audit-pass5.R index 6ef4da61..3926a5a6 100644 --- a/tests/testthat/test-audit-pass5.R +++ b/tests/testthat/test-audit-pass5.R @@ -468,7 +468,7 @@ test_that("a variable named `n` is not replaced by the row count", { set.seed(9) pts <- .p5_assigned(nc = 3, np = 5) pts$n <- rnorm(nrow(pts), 100, 5) - out <- summarize_by_cell(pts, response_var = "n") + out <- summarize_by_cell(pts, response_var = "n", estimate = "mean") truth <- tapply(pts$n, pts$poly_id, mean) expect_equal(out[["resp_mean_n"]], as.numeric(truth[as.character(out$poly_id)]), @@ -506,16 +506,49 @@ test_that("a rejected sac cannot size a design effect", { nugget = 0), crs = sf::st_crs(32632)) - # The supplied `sac` is refused, and the internal re-estimate on this small - # fixture is refused too: one fallback, so one warning, naming both. + # With a trend across the cells the internal re-estimate is refused too + # (its variogram has no sill inside the lags): one fallback, so one + # warning, naming both. + trended <- pts + trended$resp <- trended$resp + 0.05 * sf::st_coordinates(trended)[, 1] expect_warning( - out <- summarize_by_cell(pts, response_var = "resp", - deff = "variogram", sac = fake), + out <- summarize_by_cell(trended, response_var = "resp", + deff = "variogram", sac = fake, estimate = "mean"), "supplied `sac` reports no usable range.*estimated from `response_var` reports no usable range", class = "spatialkit_deff_fallback") - expect_null(attr(out, "deff_applied")) - iid <- summarize_by_cell(pts, response_var = "resp", deff = 1) - expect_equal(out[["..se_resp_resp"]], iid[["..se_resp_resp"]], tolerance = 1e-10) + # The fallback is Kish, not the uncorrected SE (this used to assert no + # `deff_applied` attribute and SEs equal to deff = 1): the refused model + # sizes nothing, and the result is the deff = "kish" one, labelled. + kish <- summarize_by_cell(trended, response_var = "resp", deff = "kish", estimate = "mean") + expect_identical(attr(out, "deff_applied")$method, "kish") + expect_identical(attr(out, "deff_applied")$requested, "variogram") + expect_equal(out[["..se_resp_resp"]], kish[["..se_resp_resp"]], tolerance = 1e-10) + expect_equal(out$cell_weight, kish$cell_weight, tolerance = 1e-10) + expect_identical(unique(out$deff_method), "kish (variogram fallback)") + # Not the refused model's design effect, which equalled n in every cell. + expect_true(all(out$cell_weight > 1)) + + # The fixture's own response is white noise. The supplied `sac` is still + # set aside, with a plain warning, and the re-estimate answers: it finds no + # spatial structure, whose model is a pure nugget, so the design effect is + # 1 by the variogram route. That is not a fallback (this branch asserted + # the Kish fallback while every refusal was set aside; on four cells of + # white noise Kish's ICC came out positive by chance and widened the + # standard errors by 38 percent). + w <- list() + out0 <- withCallingHandlers( + summarize_by_cell(pts, response_var = "resp", deff = "variogram", sac = fake, + estimate = "mean"), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }) + expect_length(w, 1L) + expect_false(inherits(w[[1L]], "spatialkit_deff_fallback")) + expect_match(conditionMessage(w[[1L]]), + "supplied `sac` reports no usable range.*It was set aside, and the design effect uses the variogram estimated from `response_var`") + expect_identical(attr(out0, "deff_applied")$method, "variogram") + expect_identical(unique(out0$deff_method), "variogram") + iid <- summarize_by_cell(pts, response_var = "resp", deff = 1, estimate = "mean") + expect_equal(out0[["..se_resp_resp"]], iid[["..se_resp_resp"]], tolerance = 1e-10) + expect_equal(out0$cell_weight, rep(25, 4)) }) @@ -541,7 +574,8 @@ test_that("duplicate cell IDs are reported", { # Renumbering cell 3 as 2 also leaves the points summarised under ID 3 # with no cell, which is reported too. expect_warning( - expect_warning(summarize_by_cell(pts, response_var = "resp", cells_sf = cells), + expect_warning(summarize_by_cell(pts, response_var = "resp", cells_sf = cells, + estimate = "mean"), "duplicated value"), "match no `cells_sf\\$poly_id`") }) @@ -599,10 +633,16 @@ test_that("a point outside every cell gets NA, not the nearest cell", { all_pts <- rbind(inner, outer) bnd <- sf::st_as_sfc(sf::st_bbox(inner)) - tess <- suppressMessages(build_tessellation(all_pts, boundary = bnd, - method = "square", - approx_n_cells = 4, clip = TRUE)) + # The NAs are counted and warned about, with a class (they were one INFO + # line in the log). + expect_warning( + tess <- suppressMessages(build_tessellation(all_pts, boundary = bnd, + method = "square", + approx_n_cells = 4, clip = TRUE)), + "30 of 40 point\\(s\\) \\(75.0%\\) fall in no cell", + class = "spatialkit_unassigned") expect_equal(sum(is.na(tess$index)), 30L) + expect_identical(tess$params$n_outside, 30L) assigned <- suppressWarnings(assign_features_to_polygons( all_pts, tess$cells, polygon_id_col = "cell_id", keep_unassigned = TRUE)) expect_equal(sum(is.na(assigned$cell_id)), sum(is.na(tess$index))) @@ -689,7 +729,7 @@ test_that("assign_features_to_polygons says so when nothing is assigned", { # -------------------------------------------------------------------------- test_that("the local collinearity check sees the intercept and singular windows", { - skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") # local_xmat omitted the intercept column, so an indicator constant INSIDE a # window was not detected as collinear with it; and is.finite(cn) && cn > 1e6 # discarded kappa = Inf, the worst case there is. The check also ran before @@ -784,7 +824,7 @@ test_that("the collinearity diagnostic is the scaled condition index, thresholde test_that("fitted.gwr_fit is not fooled by a predictor named yhat", { - skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") # has_coef_suffix inferred which GWmodel call produced the SDF from the # column names, so a PREDICTOR ending in "_coef" made a gwr.basic() SDF look # like a gwr.predict() one and switched off the model-term exclusion -- @@ -804,7 +844,7 @@ test_that("fitted.gwr_fit is not fooled by a predictor named yhat", { test_that("an implausible fixed bandwidth is called out", { - skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") # prep_model_data() projects geographic input before the bandwidth is used, # so 0.2 "degrees" became 0.2 metres: every local window empty, all # coefficients NaN, summary() reporting n = 0, and nothing raised. @@ -845,7 +885,6 @@ test_that("an implausible fixed bandwidth is called out", { test_that("non-finite local coefficients are counted and reported", { - skip_if_not_installed("GWmodel") # The post-fit half of the same story, asserted without depending on how a # given GWmodel version fails: build the count from an SDF directly. Nothing # used to report this at all -- fitted(), residuals(), summary() and @@ -916,7 +955,6 @@ test_that("cv_rf's seed reaches the forest", { test_that("gwr_model_selection refuses candidates fit_gwr_model would reject", { - skip_if_not_installed("GWmodel") set.seed(59); n <- 60 d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), a = rnorm(n), @@ -979,7 +1017,6 @@ test_that("weights with a non-zero diagonal are corrected, not accepted", { test_that("compare_models_cv scores every model on identical folds", { skip_if_not_installed("ranger") - skip_if_not_installed("GWmodel") # With folds = NULL each cv_*() built its own from k/seed/block_size/..., so # a per-model block_size (or seed = NULL) silently gave the models different # splits and the table ranked models scored on different data. diff --git a/tests/testthat/test-audit-pass6-low.R b/tests/testthat/test-audit-pass6-low.R index e5ea971b..6befbe87 100644 --- a/tests/testthat/test-audit-pass6-low.R +++ b/tests/testthat/test-audit-pass6-low.R @@ -59,7 +59,6 @@ test_that("cv_bayes() fills yhat_sd from the posterior predictive draws", { # -------------------------------------------------------------------------- test_that("fit_gwr_model() refuses n <= p + 1 observations with a single error", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") d <- .p6l_pts(n = 3, seed = 3) d$z <- c(1, 2, 4) diff --git a/tests/testthat/test-audit-pass6.R b/tests/testthat/test-audit-pass6.R index dc043dfc..9b0dc100 100644 --- a/tests/testthat/test-audit-pass6.R +++ b/tests/testthat/test-audit-pass6.R @@ -135,7 +135,9 @@ test_that("select_features_forward() does not echo the fold failures of its null expect_false(log_has(lines, "fit failed; skipping")) expect_false(log_has(lines, "all 3 folds failed")) # The probe's fallback is still announced (as a message, not a log line) - # when quiet = FALSE. + # when quiet = FALSE. The fallback is now a baseline (the training-fold + # mean) where it used to be "the first variable is accepted + # unconditionally", so the message this asserted has changed with it. msgs <- character(0) withCallingHandlers( suppressWarnings(select_features_forward(d, "z", c("w", "a"), @@ -144,7 +146,8 @@ test_that("select_features_forward() does not echo the fold failures of its null message = function(m) { msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") }) - expect_true(any(grepl("null \\(intercept-only\\) model could not be scored", msgs))) + expect_true(any(grepl("cannot fit a model with no predictors, so the baseline is the training-fold mean", msgs))) + expect_false(any(grepl("accepted unconditionally", msgs))) }) @@ -730,24 +733,29 @@ test_that("summarize_by_cell(deff = 'variogram') corrects the response SE with t pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z, p = p, poly_id = 1L + (x > 500) + 2L * (y > 500)), coords = c("x", "y"), crs = 32632) - resp_only <- suppressWarnings(summarize_by_cell(pts, "z", deff = "variogram")) + resp_only <- suppressWarnings(summarize_by_cell(pts, "z", deff = "variogram", estimate = "mean")) with_pred <- suppressWarnings(summarize_by_cell(pts, "z", predictor_vars = "p", - deff = "variogram")) + deff = "variogram", estimate = "mean")) expect_equal(with_pred[["..se_resp_z"]], resp_only[["..se_resp_z"]], tolerance = 1e-10) expect_equal(attr(with_pred, "deff_applied")$deff, attr(resp_only, "deff_applied")$deff, tolerance = 1e-10) # ... which is what passing the response variogram explicitly gives, and # NOT what the residual variogram gives. sac_resp <- suppressWarnings(estimate_sac_range(pts, "z")) - sac_resid <- suppressWarnings(estimate_sac_range(pts, "z", predictor_vars = "p")) + # structure_alpha = 1: the residual field's range (45) is hardly longer than + # the spacing of these points (about 32), which the test for spatial + # structure does not detect, so at the default the residuals get no range. + # A residual variogram is needed here to show that using one is warned of. + sac_resid <- suppressWarnings(estimate_sac_range(pts, "z", predictor_vars = "p", + structure_alpha = 1)) skip_if(is.na(sac_resp) || is.na(sac_resid), "the variograms did not fit on this draw") explicit <- summarize_by_cell(pts, "z", predictor_vars = "p", deff = "variogram", - sac = sac_resp) + sac = sac_resp, estimate = "mean") expect_equal(with_pred[["..se_resp_z"]], explicit[["..se_resp_z"]], tolerance = 1e-10) # Used as given, but with a warning that the response SEs are understated. expect_warning( residual <- summarize_by_cell(pts, "z", predictor_vars = "p", deff = "variogram", - sac = sac_resid), + sac = sac_resid, estimate = "mean"), "residuals on predictors") expect_false(isTRUE(all.equal(with_pred[["..se_resp_z"]], residual[["..se_resp_z"]], tolerance = 1e-6))) diff --git a/tests/testthat/test-blocks-balance.R b/tests/testthat/test-blocks-balance.R index d3c36f66..ee6245d7 100644 --- a/tests/testthat/test-blocks-balance.R +++ b/tests/testthat/test-blocks-balance.R @@ -255,16 +255,24 @@ test_that("k is lowered to the number of blocks that hold points", { rect_poly(700, 1000, 0, 1000), rect_poly(3000, 4000, 0, 1000)), crs = 32632) + # The reduction was a log line only ("blocks < k; reducing k"), which this + # test pinned. It is now a warning of class spatialkit_k_reduced, logged + # as well. lines <- capture_spatialkit_log( - f <- make_folds(pts, k = 5, method = "block_kfold", seed = 1, blocks = three)) + expect_warning( + f <- make_folds(pts, k = 5, method = "block_kfold", seed = 1, blocks = three), + "returning 3 folds, not the k = 5 asked for: 3 of the 4 supplied blocks hold points", + class = "spatialkit_k_reduced")) expect_equal(f$k, 3L) expect_equal(f$params$blocks_used, 3L) expect_equal(f$params$n_blocks, 4L) - expect_true(log_has(lines, "blocks < k; reducing k")) + expect_true(log_has(lines, "returning 3 folds, not the k = 5 asked for")) # Without dropping empties the fourth (empty) block is still absent from # every fold, and the folds are the same. - f2 <- make_folds(pts, k = 5, method = "block_kfold", seed = 1, blocks = three, - drop_empty_blocks = FALSE) + expect_warning( + f2 <- make_folds(pts, k = 5, method = "block_kfold", seed = 1, blocks = three, + drop_empty_blocks = FALSE), + class = "spatialkit_k_reduced") expect_identical(f2$assignment, f$assignment) }) diff --git a/tests/testthat/test-build-tessellation.R b/tests/testthat/test-build-tessellation.R index 910ea1b3..d0695727 100644 --- a/tests/testthat/test-build-tessellation.R +++ b/tests/testthat/test-build-tessellation.R @@ -290,14 +290,22 @@ test_that("clip = FALSE leaves cells extending past the boundary", { # A boundary covering only the lower-left quadrant, so clipping visibly bites. small <- sf::st_sf(geometry = sf::st_sfc(.bt_sq(0, 0, 50, 50), crs = 32632)) - clipped <- suppressMessages(build_tessellation(pts, boundary = small, + # The boundary holds a quarter of the ground, so most points fall in no + # cell either way: counted, and warned about with a class. + expect_warning( + clipped <- suppressMessages(build_tessellation(pts, boundary = small, + method = "square", + approx_n_cells = 16, + quiet = TRUE)), + "point\\(s\\) \\([0-9.]+%\\) fall in no cell", class = "spatialkit_unassigned") + expect_warning( + whole <- suppressMessages(build_tessellation(pts, boundary = small, method = "square", - approx_n_cells = 16, - quiet = TRUE)) - whole <- suppressMessages(build_tessellation(pts, boundary = small, - method = "square", - approx_n_cells = 16, clip = FALSE, - quiet = TRUE)) + approx_n_cells = 16, clip = FALSE, + quiet = TRUE)), + "point\\(s\\) \\([0-9.]+%\\) fall in no cell", class = "spatialkit_unassigned") + expect_identical(clipped$params$n_outside, sum(is.na(clipped$index))) + expect_gt(clipped$params$n_outside, 0L) expect_equal(sum(as.numeric(sf::st_area(clipped$cells))), as.numeric(sf::st_area(small)), tolerance = 1e-6) diff --git a/tests/testthat/test-cell-count.R b/tests/testthat/test-cell-count.R index 718aeedc..52924a5d 100644 --- a/tests/testthat/test-cell-count.R +++ b/tests/testthat/test-cell-count.R @@ -42,16 +42,22 @@ test_that("a determine_optimal_levels() vector is read at its first candidate", test_that("a select_resolution() result and a profile are read at their best level", { skip_if_not_installed("gstat") pts <- cc_points() - prof <- suppressWarnings(resolution_profile(pts, response_var = "z", n_levels = 8, seed = 1)) + prof <- suppressWarnings(resolution_profile(pts, response_var = "z", n_levels = 8, seed = 1, + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) sel <- select_resolution(prof, criterion = "elbow") r1 <- resolve(sel, "n", "get_voronoi_seeds") expect_equal(r1$n, as.numeric(sel$best)) expect_match(r1$from, "select_resolution\\(criterion = \"elbow\"\\)") # The profile itself goes through select_resolution()'s default criterion # (cp needs a response -- present here -- and a usable variogram). - r2 <- tryCatch(resolve(prof, "n", "get_voronoi_seeds"), error = function(e) e) + # (The response here is white noise, so the count comes with a warning + # that one cell does as well, or that a bound chose it: not what is under + # test.) + r2 <- tryCatch(suppressWarnings(resolve(prof, "n", "get_voronoi_seeds")), + error = function(e) e) if (!inherits(r2, "error")) { - expect_equal(r2$n, as.numeric(select_resolution(prof)$best)) + expect_equal(r2$n, as.numeric(select_resolution(prof, criterion = "cp")$best)) expect_match(r2$from, "resolution_profile\\(\\) read with select_resolution") } else { expect_match(conditionMessage(r2), "NA at every level") diff --git a/tests/testthat/test-core-count-ladder.R b/tests/testthat/test-core-count-ladder.R new file mode 100644 index 00000000..19c43337 --- /dev/null +++ b/tests/testthat/test-core-count-ladder.R @@ -0,0 +1,1742 @@ +# tests/testthat/test-core-count-ladder.R +# --------------------------------------------------------------------------- +# resolution_profile(obs_per_cell = ): the ladder a size sets, its bounds and +# its warnings; how "auto" gives way to a ladder the caller describes; +# nstart = NULL and sac = "auto"; Moran's z on such a ladder; and the two +# bounds on its cost. +# +# Every call names `partition`, `nstart`, `estimate`, `obs_per_cell` and +# `sac`. Unless a test says otherwise the regions are of the density kind +# from 3 k-means++ starts. A layer is drawn under the seed its test states: +# the locations (x, then y), then the response. A backend is switched off by +# replacing .has_backend(), the one function resolution_profile() asks. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.cl_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +# `n` locations uniform on a square of side `side`, with the field of the +# engine's tests: sin(x / 2e4) + cos(y / 1.5e4) plus normal noise of standard +# deviation 1.5. +.cl_layer <- function(n, seed, side = 1e5) { + d <- local({ + .cl_seed(seed) + x <- stats::runif(n, 0, side); y <- stats::runif(n, 0, side) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(n, 0, 1.5)) + }) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32617) +} + +# A profile of the density kind from 3 k-means++ starts, every setting that +# has a default the switch moves written out. What a test varies it names. +.cl_profile <- function(pts, ..., response = "z", partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = 4.5) + resolution_profile(pts, response, ..., partition = partition, nstart = nstart, sac = sac, + estimate = estimate, obs_per_cell = obs_per_cell) + +# A call with its warnings kept and muffled. +.cl_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.cl_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.cl_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.cl_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] + +# The error a call stops with. +.cl_error <- function(expr) tryCatch({ suppressWarnings(expr); NULL }, error = function(e) e) + +# The columns of a profile, without its attributes. +.cl_cols <- function(p) stats::setNames(lapply(seq_along(p), function(j) p[[j]]), names(p)) + +.cl_without <- function(pkg, env = parent.frame()) + testthat::local_mocked_bindings( + .has_backend = function(p) + if (p %in% pkg) FALSE else requireNamespace(p, quietly = TRUE), + .env = env) + +.cl_store <- new.env(parent = emptyenv()) +.cl_keep <- function(key, expr) { + if (is.null(.cl_store[[key]])) .cl_store[[key]] <- expr + .cl_store[[key]] +} +.cl_3000 <- function() .cl_keep("l3000", .cl_layer(3000, 301)) +.cl_600 <- function() .cl_keep("l600", .cl_layer(600, 302)) + + +# ---- The levels of a size ---------------------------------------------------- + +test_that("obs_per_cell gives the levels rung_k() gives", { + pts <- .cl_3000() + sizes <- c(18, 12, 9, 6, 4.5, 3, 2) + want <- vapply(sizes, function(s) rung_k(3000L, s), integer(1)) + expect_identical(want, c(167L, 250L, 333L, 500L, 667L, 1000L, 1500L)) + + r <- .cl_catch(.cl_profile(pts, estimate = "mean", obs_per_cell = sizes)) + expect_length(r$warnings, 0L) + expect_identical(r$value$levels, want) + expect_identical(attr(r$value, "bounds")$obs_per_cell, sizes) + expect_identical(attr(r$value, "bounds")$size_levels, + stats::setNames(want, c("18", "12", "9", "6", "4.5", "3", "2"))) + # Every partition was built, on every row. + expect_true(all(is.finite(r$value$wss))) + expect_identical(vapply(attr(r$value, "centres"), nrow, integer(1), USE.NAMES = FALSE), want) + + # The order the sizes are given in, and a size given twice, change nothing. + expect_identical(.cl_profile(pts, estimate = "mean", obs_per_cell = c(4.5, 18, 4.5)), + .cl_profile(pts, estimate = "mean", obs_per_cell = c(18, 4.5))) + + # Two sizes that give one count are one level. + two <- .cl_profile(pts, obs_per_cell = c(4.5, 4.501)) + expect_identical(two$levels, 667L) + expect_identical(unname(attr(two, "bounds")$size_levels), c(667L, 667L)) +}) + +test_that("a size divides the rows with a response, and every point without one", { + pts <- .cl_3000() + # A response on 2,000 of the rows. + part <- pts + part$z[seq(3, 3000, by = 3)] <- NA + expect_identical(sum(is.finite(part$z)), 2000L) + p <- suppressWarnings(.cl_profile(part, obs_per_cell = 9)) + expect_identical(p$levels, rung_k(2000L, 9)) + expect_identical(p$levels, 222L) + expect_identical(attr(p, "estimate")$n, 2000L) + expect_identical(attr(p, "bounds")$n_response, 2000L) + expect_identical(attr(p, "bounds")$n_scored, 2000L) + # The centres are fitted to every point, with a response or without. + expect_identical(attr(p, "bounds")$n_sample, 3000L) + expect_identical(attr(p, "bounds")$n, 3000L) + + # No response: the points. + geo <- .cl_profile(pts, response = NULL, estimate = NULL, obs_per_cell = 9) + expect_identical(geo$levels, rung_k(3000L, 9)) + expect_identical(attr(geo, "bounds")$n_response, NA_integer_) + expect_null(attr(geo, "estimate")) + expect_false("loo" %in% names(geo)) + + # A response with no finite value: the points, as the support ceiling counts. + none <- pts + none$z <- NA_real_ + empty <- suppressWarnings(.cl_profile(none, estimate = NULL, obs_per_cell = 9)) + expect_identical(empty$levels, rung_k(3000L, 9)) + expect_identical(attr(empty, "bounds")$n_response, 0L) +}) + +test_that("sample_n changes no number under a numeric obs_per_cell", { + pts <- .cl_layer(1200, 303) + base <- .cl_catch(.cl_profile(pts, obs_per_cell = c(9, 4.5))) + expect_length(base$warnings, 0L) + expect_identical(attr(base$value, "bounds")$n_sample, 1200L) + for (sn in c(3, 100, 400, 1199, 1e6)) { + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(9, 4.5), sample_n = sn)) + expect_identical(r$value, base$value, info = paste("sample_n", sn)) + expect_identical(.cl_classes(r), "spatialkit_ladder_unused", info = paste("sample_n", sn)) + } + # Nor without an estimate: no subsample is drawn on a ladder of sizes. + plain <- .cl_profile(pts, estimate = NULL, obs_per_cell = c(9, 4.5)) + expect_identical(attr(plain, "bounds")$n_sample, 1200L) + for (sn in c(100, 400)) { + r <- .cl_catch(.cl_profile(pts, estimate = NULL, obs_per_cell = c(9, 4.5), sample_n = sn)) + expect_identical(r$value, plain, info = paste("no estimate, sample_n", sn)) + expect_identical(attr(r$value, "bounds")$n_sample, 1200L) + expect_identical(attr(r$value, "bounds")$n_scored, 1200L) + } + # The same number draws a subsample on the ladder the function builds. + sub <- suppressWarnings(.cl_profile(pts, obs_per_cell = NULL, sample_n = 400, n_levels = 4)) + expect_identical(attr(sub, "bounds")$n_sample, 400L) +}) + + +# ---- How "auto" is resolved -------------------------------------------------- + +test_that("obs_per_cell = \"auto\" is one size for pooled values and seven for plain means", { + pts <- .cl_600() + pooled <- .cl_catch(.cl_profile(pts, estimate = "pooled", obs_per_cell = "auto")) + expect_length(pooled$warnings, 0L) + expect_identical(pooled$value$levels, 133L) + expect_identical(attr(pooled$value, "bounds")$obs_per_cell, 4.5) + expect_identical(pooled$value, .cl_profile(pts, estimate = "pooled", obs_per_cell = 4.5)) + + plain <- .cl_catch(.cl_profile(pts, estimate = "mean", obs_per_cell = "auto")) + expect_length(plain$warnings, 0L) + expect_identical(nrow(plain$value), 7L) + expect_identical(plain$value$levels, c(33L, 50L, 67L, 100L, 133L, 200L, 300L)) + expect_identical(attr(plain$value, "bounds")$obs_per_cell, c(18, 12, 9, 6, 4.5, 3, 2)) + expect_identical(plain$value, + .cl_profile(pts, estimate = "mean", obs_per_cell = c(18, 12, 9, 6, 4.5, 3, 2))) + + # estimate = "auto" is the pooled value on this layer, so its ladder is one size. + expect_identical(.cl_profile(pts, estimate = "auto", obs_per_cell = "auto"), pooled$value) +}) + +test_that("obs_per_cell = \"auto\" gives way to `levels` and to the automatic ladder's arguments", { + skip_if_not_installed("gstat") + pts <- .cl_600() + for (est in c("pooled", "mean")) { + # `levels`: scored as given, on the present path. + lv <- c(10L, 40L) + a <- suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = "auto", levels = lv)) + b <- suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = NULL, levels = lv)) + expect_identical(a$levels, lv, info = est) + expect_identical(attr(a, "bounds"), attr(b, "bounds"), info = est) + expect_identical(a, b, info = est) + expect_null(attr(a, "bounds")$obs_per_cell) + expect_true(all(is.finite(a$loo)), info = est) + + # Each of the four arguments that describe the automatic ladder. + for (arg in list(list(n_levels = 5L), list(min_cell_n = 12L), list(sample_n = 300L), + list(range_floor = TRUE), list(range_floor = FALSE))) { + what <- paste(est, names(arg), format(arg[[1L]])) + a <- suppressWarnings(do.call(.cl_profile, + c(list(pts, estimate = est, obs_per_cell = "auto"), arg))) + b <- suppressWarnings(do.call(.cl_profile, + c(list(pts, estimate = est, obs_per_cell = NULL), arg))) + expect_identical(a, b, info = what) + expect_null(attr(a, "bounds")$obs_per_cell, info = what) + expect_false(attr(a, "bounds")$levels_given, info = what) + expect_gt(nrow(a), 2L) + expect_true("loo" %in% names(a), info = what) + } + } +}) + +test_that("a wrapper that passes n_levels on counts as supplying it", { + skip_if_not_installed("gstat") + pts <- .cl_600() + wrapper <- function(layer, n_levels = 6L) + resolution_profile(layer, "z", n_levels = n_levels, partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = "auto") + w <- suppressWarnings(wrapper(pts)) + expect_null(attr(w, "bounds")$obs_per_cell) + expect_gt(nrow(w), 2L) + expect_identical(w, suppressWarnings(.cl_profile(pts, obs_per_cell = NULL, n_levels = 6L))) + # Beside a size it is the argument that is not read. + sized <- function(layer, n_levels = 6L) + resolution_profile(layer, "z", n_levels = n_levels, partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = 4.5) + r <- .cl_catch(sized(pts)) + expect_identical(.cl_classes(r), "spatialkit_ladder_unused") + expect_identical(r$value$levels, 133L) +}) + +test_that("a numeric obs_per_cell refuses `levels` and names the ladder arguments it does not read", { + pts <- .cl_600() + base <- .cl_profile(pts, obs_per_cell = 4.5) + e <- .cl_error(.cl_profile(pts, obs_per_cell = 4.5, levels = 20L)) + expect_identical(conditionMessage(e), + "resolution_profile(): pass one of `obs_per_cell` and `levels`: each sets the ladder.") + expect_null(conditionCall(e)) + + args <- list(n_levels = 5L, min_cell_n = 12L, sample_n = 300L, range_floor = TRUE) + for (nm in names(args)) { + r <- .cl_catch(do.call(.cl_profile, c(list(pts, obs_per_cell = 4.5), args[nm]))) + expect_identical(.cl_classes(r), "spatialkit_ladder_unused", info = nm) + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + sprintf(paste0("resolution_profile(): `%s` is not read when `obs_per_cell` ", + "sets the ladder: the levels are the sizes asked for, and the ", + "centres are fitted to every row. Leave `obs_per_cell` NULL for ", + "the ladder it describes."), nm)) + expect_identical(.cl_fields(w), list(unused = nm, obs_per_cell = 4.5), info = nm) + expect_null(conditionCall(w)) + # The ladder is the size's, whatever the argument holds. + expect_identical(.cl_cols(r$value), .cl_cols(base), info = nm) + expect_identical(attr(r$value, "bounds")$size_levels, c("4.5" = 133L), info = nm) + } + # The four together are one warning. + r <- .cl_catch(do.call(.cl_profile, c(list(pts, obs_per_cell = c(9, 4.5)), args))) + expect_identical(.cl_classes(r), "spatialkit_ladder_unused") + expect_identical(conditionMessage(r$warnings[[1L]]), + paste0("resolution_profile(): `n_levels`, `min_cell_n`, `sample_n` and ", + "`range_floor` are not read when `obs_per_cell` sets the ladder: the ", + "levels are the sizes asked for, and the centres are fitted to every ", + "row. Leave `obs_per_cell` NULL for the ladder they describe.")) + expect_identical(.cl_fields(r$warnings[[1L]]), + list(unused = names(args), obs_per_cell = c(9, 4.5))) + # The condition carries the sizes of the ladder, largest first and each + # once, whatever order they were given in. + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(4.5, 9, 4.5), n_levels = 5L)) + expect_identical(.cl_fields(r$warnings[[1L]]), + list(unused = "n_levels", obs_per_cell = c(9, 4.5))) + r <- .cl_catch(do.call(.cl_profile, c(list(pts, obs_per_cell = c(9, 4.5)), args))) + # `min_cell_n` is kept in the bounds, and is not read. + expect_identical(attr(r$value, "bounds")$min_cell_n, 12L) + expect_identical(attr(r$value, "bounds")$range_floor, TRUE) + # range_floor = FALSE asks for what a ladder of sizes does anyway. + r <- .cl_catch(.cl_profile(pts, obs_per_cell = 4.5, range_floor = FALSE)) + expect_length(r$warnings, 0L) + expect_identical(r$value, base) +}) + +test_that("without an estimate obs_per_cell = \"auto\" is NULL", { + skip_if_not_installed("gstat") + pts <- .cl_600() + a <- suppressWarnings(.cl_profile(pts, estimate = NULL, obs_per_cell = "auto")) + b <- suppressWarnings(.cl_profile(pts, estimate = NULL, obs_per_cell = NULL)) + expect_identical(a, b) + expect_null(attr(a, "bounds")$obs_per_cell) + expect_null(attr(a, "estimate")) + expect_identical(names(attr(a, "bounds")), + c("floor", "ceiling", "ceiling_from", "supported", "area", "range", "n", + "n_sample", "n_distinct", "min_cell_n", "range_floor", "n_response", + "n_scored", "levels_given", "predictors")) + # And without a response. + expect_identical(.cl_profile(pts, response = NULL, estimate = NULL, obs_per_cell = "auto"), + .cl_profile(pts, response = NULL, estimate = NULL, obs_per_cell = NULL)) + expect_identical(.cl_profile(pts, response = NULL, estimate = "auto", obs_per_cell = "auto"), + .cl_profile(pts, response = NULL, estimate = NULL, obs_per_cell = NULL)) +}) + + +# ---- The bounds of a ladder of sizes ----------------------------------------- + +test_that("the bounds of a ladder of sizes follow the finest size", { + skip_if_not_installed("gstat") + pts <- .cl_3000() + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5), min_cell_n = 7)) + expect_identical(.cl_classes(r), "spatialkit_ladder_unused") + b <- attr(r$value, "bounds") + + # The formulas, written again. + n <- 3000; s_min <- 4.5 + cap <- min(b$n_distinct, b$n - 1L) + want <- round(n / s_min) + too_few <- min(want, cap) < 2 + expect_identical(cap, 2999L) + expect_identical(want, 667) + expect_false(too_few) + expect_identical(b$ceiling, as.integer(max(2, min(want, cap)))) + expect_identical(b$ceiling, 667L) + expect_identical(b$ceiling_from, "obs_per_cell") + expect_identical(b$supported, !too_few && 2 <= max(2, min(want, cap))) + expect_true(b$supported) + expect_identical(b$obs_per_cell, c(18, 4.5)) + expect_identical(b$size_levels, c("18" = 167L, "4.5" = 667L)) + expect_identical(r$value$levels, c(167L, 667L)) + + # The other fields. + expect_identical(b$n_sample, 3000L) + expect_identical(b$n_scored, 3000L) + expect_true(b$levels_given) + expect_identical(b$min_cell_n, 7L) + expect_identical(b$floor, 2L) + expect_identical(b$range, NA_real_) + expect_identical(b$range_floor, FALSE) + expect_identical(names(b), + c("floor", "ceiling", "ceiling_from", "supported", "area", "range", "n", + "n_sample", "n_distinct", "min_cell_n", "range_floor", "n_response", + "n_scored", "levels_given", "predictors", "obs_per_cell", "size_levels")) + present <- attr(suppressWarnings(.cl_profile(pts, estimate = NULL, obs_per_cell = NULL, + sac = NULL, n_levels = 3)), "bounds") + for (f in c("area", "n", "n_distinct", "n_response", "predictors")) + expect_identical(b[[f]], present[[f]], info = f) + # The present ladder of the same layer fits a subsample and has no size. + expect_identical(present$n_sample, 1500L) + expect_false(present$levels_given) +}) + +test_that("rows without a response lower a size's count and raise no warning about a ceiling", { + skip_if_not_installed("gstat") + pts <- .cl_layer(900, 304) + pts$z[1:450] <- NA + # The present ladder says that the rows without a response moved its ceiling. + present <- .cl_catch(.cl_profile(pts, estimate = NULL, obs_per_cell = NULL, sac = NULL, + n_levels = 3)) + expect_true("spatialkit_response_ceiling" %in% .cl_classes(present)) + # A ladder of sizes counts those rows already. + for (sac in list("auto", NULL)) { + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(9, 4.5), sac = sac)) + expect_false("spatialkit_response_ceiling" %in% .cl_classes(r)) + expect_false(any(grepl("spatialkit_", .cl_classes(r)))) + expect_identical(r$value$levels, c(50L, 100L)) + expect_identical(attr(r$value, "bounds")$n_response, 450L) + expect_identical(attr(r$value, "bounds")$n_sample, 900L) + expect_identical(attr(r$value, "bounds")$ceiling_from, "obs_per_cell") + } +}) + +test_that("fewer than two cells of the finest size is not supported, and says so once", { + pts <- .cl_layer(6, 305) + r <- .cl_catch(.cl_profile(pts, obs_per_cell = 4.5)) + expect_identical(.cl_classes(r), "spatialkit_not_supported") + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + paste0("resolution_profile(): 6 points at obs_per_cell = 4.5 make 1 cell, and it ", + "takes two, so there is no cell count of that size. The profile scores 2 ", + "cells (3 rows per cell) so that level is still visible, and `supported` ", + "is FALSE. An `obs_per_cell` of at most 4 gives two cells here.")) + expect_identical(.cl_fields(w), + list(reason = "fewer than two cells of the size", n = 6L, + min_cell_n = NA_integer_, obs_per_cell = 4.5)) + b <- attr(r$value, "bounds") + expect_false(b$supported) + expect_identical(r$value$levels, 2L) + expect_identical(b$ceiling, 2L) + expect_identical(b$ceiling_from, "fewer than two cells of the size") + expect_identical(b$size_levels, c("4.5" = 2L)) + expect_true(is.finite(r$value$wss)) + # The size the message offers does give two cells, and is supported. + ok <- .cl_catch(.cl_profile(pts, obs_per_cell = 4)) + expect_length(ok$warnings, 0L) + expect_true(attr(ok$value, "bounds")$supported) + expect_identical(ok$value$levels, 2L) + # Every size of several too coarse: still one warning, about the finest. + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5))) + expect_identical(.cl_classes(r), "spatialkit_not_supported") + expect_identical(r$warnings[[1L]]$obs_per_cell, 4.5) + expect_identical(attr(r$value, "bounds")$size_levels, c("18" = 2L, "4.5" = 2L)) + # The seven sizes of "auto" on rows too few for any of them: none is + # dropped. Two rows with a response among five points. + two <- .cl_layer(5, 305) + two$z[3:5] <- NA + r <- .cl_catch(.cl_profile(two, estimate = "mean", obs_per_cell = "auto")) + expect_identical(.cl_classes(r), "spatialkit_not_supported") + expect_identical(conditionMessage(r$warnings[[1L]]), + paste0("resolution_profile(): 2 rows with a response at obs_per_cell = 2 make 1 ", + "cell, and it takes two, so there is no cell count of that size. The ", + "profile scores 2 cells (1 row per cell) so that level is still visible, ", + "and `supported` is FALSE. An `obs_per_cell` of at most 1.33 gives two ", + "cells here.")) + expect_identical(unname(attr(r$value, "bounds")$size_levels), rep(2L, 7L)) + expect_identical(r$value$levels, 2L) + # One row with a response: no size gives two cells, and the words are for one row. + one <- .cl_layer(5, 305) + one$z[2:5] <- NA + r <- .cl_catch(.cl_profile(one, obs_per_cell = 4.5)) + expect_identical(.cl_classes(r), "spatialkit_not_supported") + expect_identical(conditionMessage(r$warnings[[1L]]), + paste0("resolution_profile(): 1 row with a response at obs_per_cell = 4.5 makes 0 ", + "cells, and it takes two, so there is no cell count of that size. The ", + "profile scores 2 cells (0.5 rows per cell) so that level is still ", + "visible, and `supported` is FALSE. Two cells take a response on at least ", + "two rows, whatever `obs_per_cell` is.")) + # One row is too few rows, not a constant response: the profile says so. + e <- attr(r$value, "estimate") + expect_identical(e$n, 1L) + expect_false(e$constant) + expect_identical(e$loo_one_cell, NA_real_) + expect_identical(r$value$loo, NA_real_) + out <- utils::capture.output(print(r$value)) + expect_identical(out[2L], + paste0(" ladder : 2 cells (obs_per_cell = 4.5 on the 1 row with a response; ", + "centres fitted to every row; floor 2 (no range)) -- fewer than two cells ", + "of the size: not supported")) + expect_true(paste0(" estimate : pooled toward the 8 nearest cells; loo on 1 row of the layer; ", + "one cell: loo NA (fewer than two rows)") %in% out) +}) + +test_that("the words for rows per cell are singular for one", { + expect_identical(.per_cell_text(3), "3 rows per cell") + expect_identical(.per_cell_text(1), "1 row per cell") + expect_identical(.per_cell_text(1.0004), "1 row per cell") + expect_identical(.per_cell_text(1.03), "1.03 rows per cell") + expect_identical(.per_cell_text(0.5), "0.5 rows per cell") + expect_identical(.per_cell_text(1234.5), "1.23e+03 rows per cell") +}) + +test_that("the finest level the guards read is the ceiling the ladder reports", { + # The guards run before the ladder is built, on the count the finest size + # gives; .size_ladder() must build that count as its finest level. + for (n in c(1L, 2L, 3L, 6L, 20L, 26L, 27L, 100L, 3000L)) + for (cap in c(1L, 2L, 5L, 99L, 2999L)) + for (sizes in list(4.5, c(18, 4.5), c(18, 12, 9, 6, 4.5, 3, 2), 1, c(400, 50), 2.5)) + for (auto in c(TRUE, FALSE)) { + what <- paste(n, cap, paste(sizes, collapse = "/"), auto) + sl <- suppressWarnings(.size_ladder(sizes, auto, n, max(n, 3L), cap, cap, 2, NA_real_, + "points", "a response")) + expect_identical(sl$ceiling, .finest_level(n, sizes, cap), info = what) + expect_identical(max(sl$levels), sl$ceiling, info = what) + expect_gte(sl$ceiling, 2L) + } + expect_identical(.finest_level(3000L, c(18, 4.5), 2999L), 667L) + expect_identical(.finest_level(3000L, 4.5, 100L), 100L) + expect_identical(.finest_level(6L, 4.5, 5L), 2L) + expect_identical(.finest_level(40L, 1, 39L), 39L) +}) + +test_that("a coarser size of fewer than two cells is held to two when asked for, and dropped from \"auto\"", { + pts <- .cl_layer(20, 306) + r <- .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5))) + expect_identical(.cl_classes(r), "spatialkit_size_not_reached") + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + paste0("resolution_profile(): obs_per_cell = 18 on 20 rows is fewer than two ", + "cells; two cells are used (10 rows per cell).")) + expect_identical(.cl_fields(w), list(obs_per_cell = 18, wanted = 1L, used = 2L, + reason = "fewer than two cells")) + expect_identical(r$value$levels, c(2L, 4L)) + expect_identical(attr(r$value, "bounds")$size_levels, c("18" = 2L, "4.5" = 4L)) + expect_true(attr(r$value, "bounds")$supported) + + # From "auto" the size is left out, and nothing is said. + r <- .cl_catch(.cl_profile(pts, estimate = "mean", obs_per_cell = "auto")) + expect_length(r$warnings, 0L) + expect_identical(r$value$levels, c(2L, 3L, 4L, 7L, 10L)) + b <- attr(r$value, "bounds") + expect_identical(b$obs_per_cell, c(18, 12, 9, 6, 4.5, 3, 2)) + expect_identical(b$size_levels, + c("18" = NA, "12" = 2L, "9" = 2L, "6" = 3L, "4.5" = 4L, "3" = 7L, "2" = 10L)) + expect_true(b$supported) + expect_identical(b$ceiling, 10L) + # The same sizes given as numbers keep the coarsest, at two cells, with the warning. + r <- .cl_catch(.cl_profile(pts, estimate = "mean", obs_per_cell = c(18, 12, 9, 6, 4.5, 3, 2))) + expect_identical(.cl_classes(r), "spatialkit_size_not_reached") + expect_identical(attr(r$value, "bounds")$size_levels[["18"]], 2L) + expect_identical(r$value$levels, c(2L, 3L, 4L, 7L, 10L)) +}) + +test_that("a size that asks for more cells than can be placed is held to that many", { + # 3,000 rows at 100 stations. + pts <- .cl_3000() + at <- local({ .cl_seed(307); sample.int(100L, 3000L, replace = TRUE) }) + expect_identical(length(unique(at)), 100L) + sf::st_geometry(pts) <- sf::st_geometry(pts)[at] + r <- .cl_catch(.cl_profile(pts, obs_per_cell = 4.5)) + expect_identical(.cl_classes(r), + c("spatialkit_size_not_reached", "spatialkit_repeated_locations")) + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + paste0("resolution_profile(): obs_per_cell = 4.5 asks for 667 cells, more than ", + "k-means can place on the layer's 100 distinct locations; 100 cells are ", + "used (30 rows per cell).")) + expect_identical(.cl_fields(w), list(obs_per_cell = 4.5, wanted = 667L, used = 100L, + reason = "more cells than can be placed")) + expect_identical(r$value$levels, 100L) + b <- attr(r$value, "bounds") + expect_identical(b$ceiling, 100L) + expect_identical(b$ceiling_from, "distinct locations") + expect_true(b$supported) + expect_identical(b$size_levels, c("4.5" = 100L)) + expect_identical(r$value$cells_resp, 100L) + # The sizes of "auto" are held the same way, each with its warning. + r <- .cl_catch(.cl_profile(pts, estimate = "mean", obs_per_cell = "auto")) + held <- .cl_of(r, "spatialkit_size_not_reached") + expect_identical(vapply(held, function(w) w$obs_per_cell, numeric(1)), c(18, 12, 9, 6, 4.5, 3, 2)) + expect_true(all(vapply(held, function(w) w$reason, "") == "more cells than can be placed")) + expect_identical(r$value$levels, 100L) + + # A size that asks for exactly as many cells as can be placed is reached, + # and nothing is said of it: 50 stations visited six times, at six rows a + # cell. One row a cell more and it is held. + st <- .cl_layer(300, 325) + sf::st_geometry(st) <- sf::st_geometry(st)[rep(1:50, 6)] + r <- .cl_catch(.cl_profile(st, obs_per_cell = 6)) + expect_length(.cl_of(r, "spatialkit_size_not_reached"), 0L) + expect_identical(r$value$levels, 50L) + expect_identical(attr(r$value, "bounds")$ceiling_from, "obs_per_cell") + expect_identical(attr(r$value, "bounds")$size_levels, c("6" = 50L)) + r <- .cl_catch(.cl_profile(st, obs_per_cell = 5)) + expect_length(.cl_of(r, "spatialkit_size_not_reached"), 1L) + expect_identical(r$value$levels, 50L) + expect_identical(attr(r$value, "bounds")$ceiling_from, "distinct locations") + + # No location repeated: one short of the points, which stats::kmeans() needs. + few <- .cl_layer(40, 308) + r <- .cl_catch(.cl_profile(few, estimate = NULL, response = NULL, obs_per_cell = 1, + partition = "kmeans", nstart = 2)) + expect_identical(.cl_classes(r), "spatialkit_size_not_reached") + expect_identical(conditionMessage(r$warnings[[1L]]), + paste0("resolution_profile(): obs_per_cell = 1 asks for 40 cells, more than ", + "k-means can place on 40 points; 39 cells are used (1.03 rows per cell).")) + expect_identical(r$value$levels, 39L) +}) + +test_that("a range floor above the finest level of a ladder of sizes is not supported", { + pts <- .cl_3000() + # A range of 2,000 on a 1e5 square: about 2,500 cells no wider than it, + # against the 667 of the size. + r <- .cl_catch(.cl_profile(pts, obs_per_cell = 4.5, sac = 2000)) + w <- .cl_of(r, "spatialkit_not_supported") + expect_length(w, 1L) + expect_false("spatialkit_size_not_reached" %in% .cl_classes(r)) + b <- attr(r$value, "bounds") + expect_false(b$supported) + expect_identical(b$ceiling_from, "obs_per_cell") + expect_identical(b$floor, as.integer(ceiling(b$area / 2000^2))) + expect_gt(b$floor, 667L) + expect_identical(b$range, 2000) + expect_identical(conditionMessage(w[[1L]]), + sprintf(paste0("resolution_profile(): cells no wider than the autocorrelation ", + "range (2000) would need at least %d of them, but 3000 points at ", + "obs_per_cell = 4.5 support at most 667. The data cannot support a ", + "tessellation that respects their own correlation structure; the ", + "profile scores the 667 cells that size gives so the cost of each ", + "level is still visible."), b$floor)) + expect_false(grepl("min_cell_n", conditionMessage(w[[1L]]), fixed = TRUE)) + expect_identical(.cl_fields(w[[1L]]), + list(reason = "floor above ceiling", n = 3000L, min_cell_n = NA_integer_, + obs_per_cell = 4.5)) + # The floor is reported and not applied: the level is the size's. + expect_identical(r$value$levels, 667L) + # A range the size's cells are narrower than is supported. + ok <- .cl_catch(.cl_profile(pts, obs_per_cell = 4.5, sac = 20000)) + expect_length(.cl_of(ok, "spatialkit_not_supported"), 0L) + expect_true(attr(ok$value, "bounds")$supported) + expect_identical(attr(ok$value, "bounds")$floor, as.integer(ceiling(b$area / 20000^2))) +}) + +test_that("points on one location are not supported on a ladder of sizes", { + pts <- .cl_layer(12, 309) + sf::st_geometry(pts) <- sf::st_geometry(pts)[rep(1L, 12L)] + r <- .cl_catch(.cl_profile(pts, estimate = NULL, obs_per_cell = 4.5, partition = "kmeans", + nstart = 2)) + w <- .cl_of(r, "spatialkit_not_supported") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), + paste0("resolution_profile(): the 12 points sit on 1 distinct location, so there ", + "is no ladder of cell counts to choose from. The profile scores 2 cells so ", + "that level is still visible, and `supported` is FALSE. A tessellation ", + "needs points at two locations or more.")) + expect_identical(.cl_fields(w[[1L]]), + list(reason = "fewer than two distinct locations", n = 12L, + min_cell_n = NA_integer_, obs_per_cell = 4.5)) + expect_false("spatialkit_size_not_reached" %in% .cl_classes(r)) + expect_false(attr(r$value, "bounds")$supported) + expect_identical(r$value$levels, 2L) + # With an estimate: no level can be fitted, so `loo` is NA, and nothing is + # said of what a leave-one-out error describes where rows share a location. + r <- .cl_catch(.cl_profile(pts, estimate = "pooled", obs_per_cell = 4.5, partition = "kmeans", + nstart = 2)) + expect_identical(.cl_classes(r), "spatialkit_not_supported") + expect_identical(r$value$loo, NA_real_) + expect_false(attr(r$value, "estimate")$constant) +}) + + +# ---- Strings are read by their value ----------------------------------------- + +test_that("\"mean\", \"pooled\" and \"auto\" are read by value, whatever name or class the string carries", { + pts <- .cl_layer(300, 322) + # One configuration vector, as a caller keeps one: each element carries its name. + cfg <- c(estimate = "pooled", size = "auto", sac = "auto") + bare <- .cl_profile(pts, estimate = "pooled", obs_per_cell = "auto", sac = "auto") + expect_identical(bare$levels, 67L) + expect_true(is.finite(bare$loo)) + expect_true(is.finite(bare$own_weight)) + got <- .cl_catch(.cl_profile(pts, estimate = cfg["estimate"], obs_per_cell = cfg["size"], + sac = cfg["sac"])) + expect_length(got$warnings, 0L) + expect_identical(got$value, bare) + expect_identical(attr(got$value, "estimate")$value, "pooled") + expect_identical(attr(got$value, "estimate")$neighbours, 8L) + expect_identical(attr(got$value, "cp_noise")$source, "none") + expect_true(any(grepl("pooled toward the 8 nearest cells", utils::capture.output(print(got$value)), + fixed = TRUE))) + + # Each argument alone, a name and a class. + glue <- function(s) structure(s, class = c("glue", "character")) + for (est in c("pooled", "mean", "auto")) { + want <- .cl_profile(pts, estimate = est, obs_per_cell = "auto") + for (given in list(stats::setNames(est, "a"), glue(est), unlist(list(e = est)))) { + p <- .cl_profile(pts, estimate = given, obs_per_cell = "auto") + expect_identical(p, want, info = est) + expect_identical(attr(p, "estimate")$value, if (est == "auto") "pooled" else est, info = est) + expect_null(attributes(attr(p, "estimate")$value), info = est) + } + # The automatic ladder of the estimate: one size for pooled values, seven for plain means. + expect_identical(nrow(want), if (est == "mean") 7L else 1L, info = est) + expect_true(all(is.finite(want$loo)), info = est) + } + for (auto in list(c(a = "auto"), glue("auto"))) { + expect_identical(.cl_profile(pts, estimate = "pooled", obs_per_cell = auto), bare) + expect_identical(.cl_profile(pts, estimate = "pooled", obs_per_cell = 4.5, sac = auto), bare) + } + # A size that carries a name is the size. + expect_identical(.cl_profile(pts, estimate = "pooled", obs_per_cell = c(fine = 4.5)), bare) + expect_null(names(attr(bare, "bounds")$obs_per_cell)) + + # A value that is not one of the strings is refused as before, name or none. + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, estimate = c(a = "x")))), + "resolution_profile(): `estimate` must be NULL, \"mean\", \"pooled\" or \"auto\"; got \"x\".") + expect_s3_class(.cl_error(.cl_profile(pts, obs_per_cell = c(a = "Auto"))), "error") + expect_s3_class(.cl_error(.cl_profile(pts, sac = c(a = "none"))), "error") + expect_s3_class(.cl_error(.cl_profile(pts, estimate = factor("pooled"))), "error") + expect_true(.is_auto("auto")) + expect_true(.is_auto(c(a = "auto"))) + expect_false(.is_auto(c("auto", "auto"))) + expect_false(.is_auto(NA_character_)) + expect_false(.is_auto("Auto")) + expect_false(.is_auto(NULL)) + expect_false(.is_auto(1)) +}) + + +# ---- Values the arguments refuse --------------------------------------------- + +test_that("obs_per_cell and estimate refuse what they cannot read, in the words of the design", { + pts <- .cl_600() + size_text <- function(got) + sprintf(paste0("resolution_profile(): `obs_per_cell` must be NULL, \"auto\", or numbers of at ", + "least 1 (observations per cell; fractions are allowed); got %s."), got) + bad <- list(list(NA, "NA"), list(NA_real_, "NA"), list(0.5, "0.5"), list(numeric(0), "numeric(0)"), + list("big", "\"big\""), list(c(4.5, 0.9), "c(4.5, 0.9)"), list(Inf, "Inf"), + list(c(9, NA), "c(9, NA)"), list(TRUE, "TRUE"), list(list(4.5), "an object of class list")) + # A `units` object is numeric too; it is refused in the argument's own words + # and not in those of a comparison inside that package. + if (requireNamespace("units", quietly = TRUE)) + bad <- c(bad, list(list(units::set_units(4.5, "1"), "an object of class units"))) + for (b in bad) { + e <- .cl_error(.cl_profile(pts, obs_per_cell = b[[1L]])) + expect_identical(conditionMessage(e), size_text(b[[2L]]), info = b[[2L]]) + expect_null(conditionCall(e)) + } + + e <- .cl_error(.cl_profile(pts, estimate = "x")) + expect_identical(conditionMessage(e), + "resolution_profile(): `estimate` must be NULL, \"mean\", \"pooled\" or \"auto\"; got \"x\".") + # No partial matching, and one value. + for (bad_est in list("pool", "Pooled", c("mean", "pooled"), NA_character_, 1, TRUE)) + expect_match(conditionMessage(.cl_error(.cl_profile(pts, estimate = bad_est))), + "`estimate` must be NULL, \"mean\", \"pooled\" or \"auto\"; got ", fixed = TRUE) + + pts$w <- pts$z + 1 + pts$flag <- pts$z > 0 + pts$none <- NA_real_ + for (est in c("pooled", "mean")) { + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, predictor_vars = "w", estimate = est, + obs_per_cell = NULL))), + paste0("resolution_profile(): `estimate` cannot be combined with `predictor_vars`. With ", + "predictors the profile scores the residuals of the response on them, and the ", + "summary reports region values of the response itself, so the criterion would be ", + "computed for a number nobody reports. Drop `predictor_vars`, or leave `estimate` ", + "NULL.")) + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, response = NULL, estimate = est, + obs_per_cell = NULL))), + "resolution_profile(): `estimate` names the value of a response, so it needs a `response_var`.") + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, response = "flag", estimate = est, + obs_per_cell = NULL))), + paste0("resolution_profile(): `estimate` scores the cell value summarize_by_cell() reports, ", + "and that function summarises numeric columns only; 'flag' is logical. Convert it ", + "with as.numeric() first, or leave `estimate` NULL.")) + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, response = "none", estimate = est, + obs_per_cell = NULL))), + "resolution_profile(): `estimate` needs rows with a value of 'none', and none has a finite one.") + } + # The checks come in the design's order: a logical column with no value at + # all is refused as logical, and a numeric one whose only values are + # infinite as having no finite value. + pts$lna <- NA + pts$inf <- rep(c(Inf, NA, -Inf), 200) + expect_true(is.logical(pts$lna)) + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, response = "lna", estimate = "pooled", + obs_per_cell = NULL))), + paste0("resolution_profile(): `estimate` scores the cell value summarize_by_cell() reports, ", + "and that function summarises numeric columns only; 'lna' is logical. Convert it ", + "with as.numeric() first, or leave `estimate` NULL.")) + expect_identical( + conditionMessage(.cl_error(.cl_profile(pts, response = "inf", estimate = "pooled", + obs_per_cell = NULL))), + "resolution_profile(): `estimate` needs rows with a value of 'inf', and none has a finite one.") +}) + +test_that("estimate = \"auto\" is NULL wherever naming an estimate is an error", { + skip_if_not_installed("gstat") + pts <- .cl_600() + pts$w <- pts$z + sin(seq_len(600)) + pts$flag <- pts$z > 0 + pts$none <- NA_real_ + pts$inf <- rep(c(Inf, NA, -Inf), 200) + same <- function(...) { + a <- suppressWarnings(.cl_profile(pts, ..., estimate = "auto", obs_per_cell = NULL, + sac = NULL, n_levels = 4)) + b <- suppressWarnings(.cl_profile(pts, ..., estimate = NULL, obs_per_cell = NULL, + sac = NULL, n_levels = 4)) + expect_identical(a, b) + expect_null(attr(a, "estimate")) + expect_false("loo" %in% names(a)) + } + same(predictor_vars = "w") + same(response = NULL) + same(response = "flag") + same(response = "none") + # A column whose only values are infinite has no finite value either. + same(response = "inf") + # And where it is not an error, "auto" is the pooled value. + a <- suppressWarnings(.cl_profile(pts, estimate = "auto", obs_per_cell = NULL, sac = NULL, + n_levels = 4)) + expect_identical(attr(a, "estimate")$value, "pooled") + expect_identical(a, suppressWarnings(.cl_profile(pts, estimate = "pooled", obs_per_cell = NULL, + sac = NULL, n_levels = 4))) +}) + +test_that("the present checks of the ladder's arguments run beside a size", { + pts <- .cl_600() + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, obs_per_cell = 4.5, n_levels = 1))), + "resolution_profile(): `n_levels` must be a single number >= 2.") + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, obs_per_cell = 4.5, sample_n = 2))), + "resolution_profile(): `sample_n` must be a single number >= 3.") + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, obs_per_cell = 4.5, min_cell_n = 0))), + "resolution_profile(): `min_cell_n` must be a single number >= 1.") + # They come before the checks of the new arguments. + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, obs_per_cell = "big", estimate = "x", + n_levels = 1))), + "resolution_profile(): `n_levels` must be a single number >= 2.") +}) + + +# ---- nstart = NULL ----------------------------------------------------------- + +test_that("nstart = NULL is the kind's own number of starts", { + skip_if_not_installed("gstat") + pts <- .cl_layer(300, 310) + for (kind in c("kmeans", "density")) { + own <- if (kind == "kmeans") 25L else 3L + a <- suppressWarnings(.cl_profile(pts, partition = kind, nstart = NULL, estimate = NULL, + obs_per_cell = NULL, sac = NULL, levels = c(6L, 30L))) + b <- suppressWarnings(.cl_profile(pts, partition = kind, nstart = own, estimate = NULL, + obs_per_cell = NULL, sac = NULL, levels = c(6L, 30L))) + expect_identical(a, b, info = kind) + expect_identical(attr(a, "nstart"), own, info = kind) + # Another number is another profile, so the comparison can fail. + other <- suppressWarnings(.cl_profile(pts, partition = kind, nstart = 1, estimate = NULL, + obs_per_cell = NULL, sac = NULL, levels = c(6L, 30L))) + expect_false(identical(a$wss_spread, other$wss_spread), info = kind) + # And on a ladder of sizes. + s <- .cl_profile(pts, partition = kind, nstart = NULL, obs_per_cell = 9) + expect_identical(attr(s, "nstart"), own, info = kind) + expect_identical(s, .cl_profile(pts, partition = kind, nstart = own, obs_per_cell = 9), info = kind) + } + expect_identical(.NSTART_DENSITY, 3L) + for (bad in list(0, "many", NA_real_, c(2, 3), Inf)) + expect_identical(conditionMessage(.cl_error(.cl_profile(pts, nstart = bad))), + "resolution_profile(): `nstart` must be NULL or a single number >= 1.") +}) + +test_that("the two present errors whose argument gains a value name that value, and say nothing else new", { + # `nstart` gains NULL and `sac` gains "auto", and the error of each for a + # value it cannot read lists what it can: the present text with the new + # value added. These are the only two texts of a call that names no new + # argument that are not the baseline's, and the frozen fixture holds no + # failing call, so they are held here in full, each beside the sentence it + # was before. + pts <- .cl_600() + nstart_text <- "resolution_profile(): `nstart` must be NULL or a single number >= 1." + for (bad in list(0, "many", c(1, 2), NA, NA_real_, Inf, -3, TRUE, list(5))) { + e <- .cl_error(.cl_profile(pts, nstart = bad)) + expect_identical(conditionMessage(e), nstart_text) + expect_identical(class(e), c("simpleError", "error", "condition")) + expect_null(conditionCall(e)) + } + expect_identical(sub("NULL or ", "", nstart_text, fixed = TRUE), + "resolution_profile(): `nstart` must be a single number >= 1.") + + sac_text <- function(got) + paste0("resolution_profile(): `sac` must be NULL, \"auto\", an estimate_sac_range() result, ", + "or a plain number in the units of the CRS the profile is computed in (metres for ", + "lon/lat input); got ", got, ".") + bad <- list(list("none", "an object of class character"), + list(TRUE, "an object of class logical"), + list(list(1), "an object of class list"), + list(c("auto", "auto"), "an object of class character"), + list(factor("auto"), "an object of class factor")) + if (requireNamespace("units", quietly = TRUE)) + bad <- c(bad, list(list(units::set_units(1.5, "km"), "1.5 [km]"))) + for (b in bad) { + e <- .cl_error(.cl_profile(pts, sac = b[[1L]])) + expect_identical(conditionMessage(e), sac_text(b[[2L]]), info = b[[2L]]) + expect_identical(class(e), c("simpleError", "error", "condition")) + expect_null(conditionCall(e)) + } + expect_identical(sub("NULL, \"auto\", ", "", sac_text("an object of class list"), fixed = TRUE), + paste0("resolution_profile(): `sac` must be an estimate_sac_range() result, or a ", + "plain number in the units of the CRS the profile is computed in (metres ", + "for lon/lat input); got an object of class list.")) +}) + + +# ---- sac = "auto" ------------------------------------------------------------ + +test_that("sac = \"auto\" is NULL on the automatic ladder and on a `levels` ladder", { + skip_if_not_installed("gstat") + pts <- .cl_layer(400, 311) + for (est in list(NULL, "pooled")) { + expect_identical(suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = NULL, + sac = "auto", n_levels = 5)), + suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = NULL, + sac = NULL, n_levels = 5))) + expect_identical(suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = NULL, + sac = "auto", levels = c(5L, 25L))), + suppressWarnings(.cl_profile(pts, estimate = est, obs_per_cell = NULL, + sac = NULL, levels = c(5L, 25L)))) + } + # The variogram was estimated there. + a <- suppressWarnings(.cl_profile(pts, estimate = NULL, obs_per_cell = NULL, sac = "auto", + n_levels = 5)) + expect_s3_class(attr(a, "sac"), "sac_range") + expect_true(all(is.finite(a$cp))) +}) + +test_that("sac = \"auto\" fits no variogram on a ladder of sizes", { + skip_if_not_installed("gstat") + pts <- .cl_layer(900, 312) + with <- suppressWarnings(.cl_profile(pts, obs_per_cell = c(18, 4.5), sac = NULL)) + own <- suppressWarnings(.cl_profile(pts, obs_per_cell = c(18, 4.5), sac = 20000)) + + called <- 0L + logged <- NULL + r <- NULL + local({ + testthat::local_mocked_bindings(estimate_sac_range = function(...) { + called <<- called + 1L + stop("estimate_sac_range() was reached") + }) + logged <<- capture_spatialkit_log( + r <<- .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5), sac = "auto"))) + }) + expect_identical(called, 0L) + expect_length(r$warnings, 0L) + expect_false(any(grepl("variogram|estimate_sac_range|`sac`", logged))) + none <- r$value + + expect_identical(none$levels, c(50L, 200L)) + expect_true(all(is.na(none$cp))) + expect_true(all(is.na(none$reliability))) + expect_identical(attr(none, "cp_noise"), + list(source = "none", value = NA_real_, level = NA_integer_, + reason = "no variogram: a size ladder fits one only when `sac` is given")) + expect_null(attr(none, "variogram")) + expect_null(attr(none, "sac")) + expect_identical(attr(none, "bounds")$range, NA_real_) + expect_identical(attr(none, "bounds")$floor, 2L) + one <- attr(none, "one_cell") + expect_identical(one$cp, NA_real_) + expect_identical(unname(one$cp_levels), c(NA_real_, NA_real_)) + expect_identical(names(one$cp_levels), c("50", "200")) + expect_true(all(is.finite(one$f_p))) + expect_identical(one[c("n", "rss", "constant", "f_p")], + attr(with, "one_cell")[c("n", "rss", "constant", "f_p")]) + + # No other column reads the variogram, and the variogram step leaves the + # random-number stream where it found it, so the fits draw the same starts. + for (col in c("levels", "wss", "wss_spread", "elbow", "cell_n_min", "cell_n_median", + "cell_diam_median", "rss", "moran_i", "moran_z", "cells_resp", "cell_resp_mean", + "scored_per_cell", "loo", "loo_se", "share_alone", "own_weight")) + expect_identical(none[[col]], with[[col]], info = col) + expect_identical(attr(none, "centres"), attr(with, "centres")) + expect_identical(attr(none, "estimate"), attr(with, "estimate")) + + # With sac = NULL, and with a `sac` of the caller's, `cp` is there. + expect_true(all(is.finite(with$cp))) + expect_true(all(is.finite(own$cp))) + expect_false(identical(attr(with, "cp_noise")$source, "none")) + expect_false(identical(attr(own, "cp_noise")$source, "none")) + expect_identical(attr(own, "bounds")$range, 20000) + + out <- utils::capture.output(print(none)) + expect_true(paste0(" variogram : none fitted: a size ladder fits one only when `sac` is given ", + "(cp and reliability are NA)") %in% out) + expect_false(any(grepl("none fitted", utils::capture.output(print(with)), fixed = TRUE))) +}) + +test_that("sac = \"auto\" is not a variogram the caller supplied", { + pts <- .cl_layer(400, 313) + line <- "select_on = \"split\" with a supplied `sac`" + auto <- capture_spatialkit_log( + p <- suppressWarnings(.cl_profile(pts, obs_per_cell = 4.5, sac = "auto", select_on = "split"))) + expect_false(any(grepl(line, auto, fixed = TRUE))) + expect_identical(attr(p, "cp_noise")$source, "none") + expect_null(attr(p, "sac")) + # A number is one, and the line is written for it. + given <- capture_spatialkit_log( + suppressWarnings(.cl_profile(pts, obs_per_cell = 4.5, sac = 20000, select_on = "split"))) + expect_true(any(grepl(line, given, fixed = TRUE))) +}) + +test_that("a `sac` that is another string is refused, and the message names \"auto\"", { + pts <- .cl_600() + e <- .cl_error(.cl_profile(pts, sac = "none")) + expect_identical(conditionMessage(e), + paste0("resolution_profile(): `sac` must be NULL, \"auto\", an ", + "estimate_sac_range() result, or a plain number in the units of the CRS ", + "the profile is computed in (metres for lon/lat input); got an object of ", + "class character.")) + expect_null(conditionCall(e)) + expect_s3_class(.cl_error(.cl_profile(pts, sac = c("auto", "auto"))), "error") + expect_s3_class(.cl_error(.cl_profile(pts, sac = "Auto")), "error") +}) + + +# ---- Moran's z --------------------------------------------------------------- + +test_that("grouped sums give the cell means of the loop", { + d <- local({ + .cl_seed(314) + n <- 2000L + xy <- cbind(stats::runif(n, 0, 1e5), stats::runif(n, 0, 1e5)) + list(xy = xy, y = sin(xy[, 1] / 2e4) + stats::rnorm(n), + p = cbind(stats::rnorm(n), xy[, 2] / 1e5 + stats::rnorm(n)), + cl = sample(c(3L, 7L, 11L:160L), n, replace = TRUE)) + }) + none <- matrix(numeric(0), nrow(d$xy), 0L) + for (pred in list(none, d$p)) { + loop <- .morans_i_for_k(d$xy, d$y, pred, d$cl) + grouped <- .morans_i_for_k(d$xy, d$y, pred, d$cl, grouped = TRUE) + expect_true(all(is.finite(loop))) + expect_equal(grouped, loop, tolerance = 1e-10) + expect_identical(names(grouped), c("I", "z")) + } + # A missing response is left out of its cell's mean by both. + y <- d$y + y[c(5L, 90L, 91L, 1500L)] <- NA + expect_equal(.morans_i_for_k(d$xy, y, none, d$cl, grouped = TRUE), + .morans_i_for_k(d$xy, y, none, d$cl), tolerance = 1e-10) + # Fewer than four cells: not computable, either way. + expect_identical(.morans_i_for_k(d$xy, d$y, none, rep(1:3, length.out = 2000), grouped = TRUE), + c(I = NA_real_, z = NA_real_)) + # The default is the loop, whose numbers the present ladder keeps. + expect_identical(formals(.morans_i_for_k)$grouped, FALSE) +}) + +test_that("on a ladder of sizes Moran's z is the present loop's on the same cells", { + skip_if_not_installed("gstat") + pts <- .cl_layer(1200, 315) + for (kind in c("density", "kmeans")) { + size <- suppressWarnings(.cl_profile(pts, partition = kind, obs_per_cell = c(18, 4.5), + sac = NULL)) + # The same counts as `levels`: the same fits, from the same stream, scored + # by the loop. + present <- suppressWarnings(.cl_profile(pts, partition = kind, estimate = NULL, + obs_per_cell = NULL, sac = NULL, sample_n = 1500, + levels = size$levels)) + expect_identical(size$wss, present$wss, info = kind) + expect_identical(attr(size, "centres"), attr(present, "centres"), info = kind) + expect_true(all(is.finite(size$moran_z)), info = kind) + expect_equal(size$moran_i, present$moran_i, tolerance = 1e-10, info = kind) + expect_equal(size$moran_z, present$moran_z, tolerance = 1e-10, info = kind) + } +}) + +test_that("the profile hands its two backends and the grouped form to the Moran step", { + skip_if_not_installed("gstat") + pts <- .cl_layer(300, 316) + real <- .morans_i_for_k + force(real) + seen <- list() + spy <- function(xy, response, predictors, cluster_ids, grouped = FALSE, use_fnn = NA, + use_matrix = NA) { + seen[[length(seen) + 1L]] <<- list(grouped = grouped, use_fnn = use_fnn, + use_matrix = use_matrix) + real(xy, response, predictors, cluster_ids, grouped = grouped) + } + local({ + testthat::local_mocked_bindings(.morans_i_for_k = spy) + .cl_profile(pts, obs_per_cell = c(18, 4.5)) + }) + expect_length(seen, 2L) + expect_true(all(vapply(seen, function(s) isTRUE(s$grouped), NA))) + expect_identical(seen[[1L]]$use_fnn, requireNamespace("FNN", quietly = TRUE)) + expect_identical(seen[[1L]]$use_matrix, requireNamespace("Matrix", quietly = TRUE)) + # The form goes with the ladder and not with the estimate: a ladder of + # sizes without one takes the grouped sums too. + seen <- list() + local({ + testthat::local_mocked_bindings(.morans_i_for_k = spy) + .cl_profile(pts, estimate = NULL, obs_per_cell = c(18, 4.5)) + }) + expect_length(seen, 2L) + expect_true(all(vapply(seen, function(s) isTRUE(s$grouped), NA))) + + # A ladder the function builds, and one given as `levels`: the loop. + seen <- list() + local({ + testthat::local_mocked_bindings(.morans_i_for_k = spy) + suppressWarnings(.cl_profile(pts, obs_per_cell = NULL, sac = NULL, levels = c(12L, 30L))) + }) + expect_length(seen, 2L) + expect_true(all(vapply(seen, function(s) isFALSE(s$grouped), NA))) + + # With a backend switched off the step is told so, on either ladder. + for (pkg in c("FNN", "Matrix")) { + seen <- list() + local({ + testthat::local_mocked_bindings(.morans_i_for_k = spy) + .cl_without(pkg) + suppressWarnings(.cl_profile(pts, partition = "kmeans", obs_per_cell = NULL, sac = NULL, + levels = c(12L, 30L))) + }) + expect_identical(seen[[1L]]$use_fnn, pkg != "FNN" && requireNamespace("FNN", quietly = TRUE), + info = pkg) + expect_identical(seen[[1L]]$use_matrix, + pkg != "Matrix" && requireNamespace("Matrix", quietly = TRUE), info = pkg) + } + expect_identical(.KNN_DENSE_MAX, 5000L) +}) + +# The limit of 5,000 cells lowered to a number a small layer reaches, so that +# the rule runs wherever the tests do. The 23,000-row test below holds it at +# the limit itself. +test_that("Moran's z is left out above the limit and not at it, and the warning says where", { + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + # 720 rows at 4.5 a cell: 160 cells, from one random k-means start. + pts <- .cl_layer(720, 323) + size <- function(limit, ..., layer = pts, off = "FNN", obs_per_cell = 4.5) { + testthat::local_mocked_bindings(.KNN_DENSE_MAX = limit) + if (length(off)) .cl_without(off) + .cl_catch(.cl_profile(layer, ..., obs_per_cell = obs_per_cell, partition = "kmeans", + init = "random", nstart = 1)) + } + text <- function(limit, reach, lacking) + sprintf(paste0("resolution_profile(): `moran_i` and `moran_z` will be NA at a level where more ", + "than %d cells hold a scored row (this ladder reaches %d cells), because %s not ", + "installed: Moran's z of the cell means needs FNN to find each cell's neighbours ", + "and Matrix to hold them. Every other column is computed."), limit, reach, lacking) + both <- size(159L, off = character(0)) + expect_length(both$warnings, 0L) + expect_identical(both$value$levels, 160L) + expect_identical(both$value$cells_resp, 160L) + expect_true(is.finite(both$value$moran_z)) + + # At the limit the step runs and nothing is said; one cell above it the two + # columns are NA, with one warning that names the package that is missing. + at <- size(160L) + expect_length(at$warnings, 0L) + expect_equal(at$value$moran_z, both$value$moran_z, tolerance = 1e-10) + for (pkg in c("FNN", "Matrix")) { + above <- size(159L, off = pkg) + expect_identical(.cl_classes(above), "spatialkit_moran_skipped", info = pkg) + w <- above$warnings[[1L]] + expect_identical(conditionMessage(w), text(159L, 160L, paste(pkg, "is")), info = pkg) + expect_identical(.cl_fields(w), list(limit = 159L, levels = 160L, missing = pkg), info = pkg) + expect_null(conditionCall(w)) + expect_identical(above$value$moran_i, NA_real_, info = pkg) + expect_identical(above$value$moran_z, NA_real_, info = pkg) + for (col in setdiff(names(both$value), c("moran_i", "moran_z"))) + expect_identical(above$value[[col]], both$value[[col]], info = paste(pkg, col)) + } + above <- size(159L, off = c("FNN", "Matrix")) + expect_identical(conditionMessage(above$warnings[[1L]]), text(159L, 160L, "FNN and Matrix are")) + expect_identical(above$warnings[[1L]]$missing, c("FNN", "Matrix")) + + # Three levels, two of them above the limit: the condition lists those two, + # and the level under it keeps its Moran's z. + r <- size(100L, obs_per_cell = c(18, 6, 4.5)) + expect_identical(r$value$levels, c(40L, 120L, 160L)) + expect_identical(.cl_classes(r), "spatialkit_moran_skipped") + expect_identical(r$warnings[[1L]]$levels, c(120L, 160L)) + expect_identical(is.finite(r$value$moran_z), c(TRUE, FALSE, FALSE)) + expect_identical(is.finite(r$value$moran_i), c(TRUE, FALSE, FALSE)) + expect_true(all(is.finite(r$value$loo))) + # A level at the limit beside one above it keeps its Moran's z as well. + r <- size(160L, obs_per_cell = c(4.5, 3)) + expect_identical(r$value$levels, c(160L, 240L)) + expect_identical(r$value$cells_resp[1L], 160L) + expect_identical(.cl_classes(r), "spatialkit_moran_skipped") + expect_identical(r$warnings[[1L]]$levels, 240L) + expect_identical(is.finite(r$value$moran_z), c(TRUE, FALSE)) + + # The rule goes with the ladder and not with the estimate. + r <- size(159L, estimate = NULL) + expect_identical(.cl_classes(r), "spatialkit_moran_skipped") + expect_identical(r$value$moran_z, NA_real_) + + # Where the step never runs nothing is said: no response, and a constant one. + r <- size(100L, response = NULL, estimate = NULL) + expect_length(r$warnings, 0L) + flat <- pts + flat$z <- 0.1 + r <- size(100L, layer = flat) + expect_identical(.cl_classes(r), "spatialkit_constant_response") + + # The step is left out by the cells that hold a scored row, which are known + # after a level's fit. A response on the western half alone, at 2.25 rows a + # cell: 160 centres over every point, about half of them with a scored row. + # The warning is raised, since such a level can occur, and the two columns + # are computed, since it did not. + west <- pts + west$z[sf::st_coordinates(pts)[, 1] > 5e4] <- NA + n_west <- sum(is.finite(west$z)) + r <- suppressWarnings(size(1e6L, layer = west, obs_per_cell = n_west / 160)) + expect_identical(r$value$levels, 160L) + expect_lt(r$value$cells_resp, 120L) + r <- size(120L, layer = west, obs_per_cell = n_west / 160) + w <- .cl_of(r, "spatialkit_moran_skipped") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), text(120L, 160L, "FNN is")) + expect_true(is.finite(r$value$moran_z)) + expect_true(is.finite(r$value$moran_i)) + + # Fewer scored rows than the limit: no level can hold that many cells with + # one, so nothing is said. Under the split the selection half alone is + # scored, and at 1.5 rows a cell the ladder has more cells than that half + # has rows. + half <- suppressWarnings(size(1e6L, select_on = "split", obs_per_cell = 1.5)) + rows <- attr(half$value, "bounds")$n_scored + expect_identical(half$value$levels, 480L) + expect_lt(rows, 480L) + expect_gt(rows, 200L) + r <- size(rows, select_on = "split", obs_per_cell = 1.5) + expect_length(.cl_of(r, "spatialkit_moran_skipped"), 0L) + expect_true(is.finite(r$value$moran_z)) + r <- size(rows - 1L, select_on = "split", obs_per_cell = 1.5) + expect_length(.cl_of(r, "spatialkit_moran_skipped"), 1L) + + # A call a guard stops says nothing of a column it never computes. + r <- local({ + withr::local_options(spatialkit.fit_work_max = 1) + testthat::local_mocked_bindings(.KNN_DENSE_MAX = 100L) + .cl_without("FNN") + got <- list() + e <- tryCatch(withCallingHandlers( + .cl_profile(pts, obs_per_cell = 4.5, partition = "kmeans", init = "random", nstart = 1), + warning = function(w) { got[[length(got) + 1L]] <<- w; invokeRestart("muffleWarning") }), + error = function(e) e) + list(error = e, warnings = got) + }) + expect_s3_class(r$error, "spatialkit_work_limit") + expect_identical(r$error$what, "partition fit") + expect_length(r$warnings, 0L) +}) + +test_that("a present ladder above the limit stops as it always has, until the rule holds on every ladder", { + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + skip_if_not_installed("gstat") + pts <- .cl_layer(720, 323) + present <- function(any_ladder, pkg) { + testthat::local_mocked_bindings(.KNN_DENSE_MAX = 159L, + .moran_skip_any_ladder = function() any_ladder) + .cl_without(pkg) + got <- list() + value <- tryCatch(withCallingHandlers( + .cl_profile(pts, levels = 160, sample_n = 720, estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans", init = "random", nstart = 1), + warning = function(w) { got[[length(got) + 1L]] <<- w; invokeRestart("muffleWarning") }), + error = function(e) e) + list(value = value, warnings = got) + } + for (pkg in c("FNN", "Matrix")) { + # The rule not applied: the unclassed error of .build_knn_weights(). + r <- present(FALSE, pkg) + expect_identical(class(r$value), c("simpleError", "error", "condition"), info = pkg) + expect_match(conditionMessage(r$value), "n = 160 requires FNN for k-NN weights", fixed = TRUE) + expect_length(.cl_of(r, "spatialkit_moran_skipped"), 0L) + # The rule applied: the profile returns, with the warning and the two columns NA. + r <- present(TRUE, pkg) + expect_s3_class(r$value, "resolution_profile") + w <- .cl_of(r, "spatialkit_moran_skipped") + expect_length(w, 1L) + expect_identical(.cl_fields(w[[1L]]), list(limit = 159L, levels = 160L, missing = pkg), info = pkg) + expect_identical(r$value$levels, 160L) + expect_identical(r$value$moran_i, NA_real_, info = pkg) + expect_identical(r$value$moran_z, NA_real_, info = pkg) + expect_true(is.finite(r$value$wss)) + expect_true(is.finite(r$value$rss)) + } +}) + +test_that("above 5,000 cells Moran's z is left out without FNN or Matrix, and the profile returns", { + skip_on_cran() + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + skip_if_not_installed("gstat") + # 23,000 rows at 4.5 a cell: 5,111 cells. The kind is k-means from one + # random start, which the fit guard lets through without FNN. + big <- .cl_layer(23000, 31) + size <- function() .cl_profile(big, estimate = "pooled", obs_per_cell = 4.5, partition = "kmeans", + init = "random", nstart = 1, sac = "auto", seed = 123) + both <- .cl_catch(size()) + expect_length(.cl_of(both, "spatialkit_moran_skipped"), 0L) + expect_identical(both$value$levels, 5111L) + expect_gt(both$value$cells_resp, 5000L) + expect_true(is.finite(both$value$moran_i)) + expect_true(is.finite(both$value$moran_z)) + expect_true(is.finite(both$value$loo)) + + real <- .partition_centres + force(real) + for (pkg in c("FNN", "Matrix")) { + # The warnings and the fits, in the order they come. + events <- character(0) + r <- NULL + local({ + .cl_without(pkg) + testthat::local_mocked_bindings(.partition_centres = function(...) { + events <<- c(events, "fit") + real(...) + }) + got <- list() + value <- withCallingHandlers(size(), warning = function(w) { + events <<- c(events, class(w)[1L]) + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + r <<- list(value = value, warnings = got) + }) + w <- .cl_of(r, "spatialkit_moran_skipped") + expect_length(w, 1L) + expect_identical(.cl_classes(r), "spatialkit_moran_skipped", info = pkg) + # Said once, before the first fit. + expect_identical(events, c("spatialkit_moran_skipped", "fit"), info = pkg) + expect_identical(conditionMessage(w[[1L]]), + sprintf(paste0("resolution_profile(): `moran_i` and `moran_z` will be NA at a ", + "level where more than 5000 cells hold a scored row (this ladder ", + "reaches 5111 cells), because %s is not installed: Moran's z of ", + "the cell means needs FNN to find each cell's neighbours and ", + "Matrix to hold them. Every other column is computed."), pkg)) + expect_identical(.cl_fields(w[[1L]]), list(limit = 5000L, levels = 5111L, missing = pkg)) + expect_identical(r$value$moran_i, NA_real_, info = pkg) + expect_identical(r$value$moran_z, NA_real_, info = pkg) + expect_true(is.finite(r$value$loo), info = pkg) + expect_identical(r$value$loo, both$value$loo, info = pkg) + # Every other column is the run's with both. + for (col in setdiff(names(both$value), c("moran_i", "moran_z"))) + expect_identical(r$value[[col]], both$value[[col]], info = paste(pkg, col)) + } + # Both missing: one warning that names both. + r <- local({ .cl_without(c("FNN", "Matrix")); .cl_catch(size()) }) + w <- .cl_of(r, "spatialkit_moran_skipped") + expect_length(w, 1L) + expect_match(conditionMessage(w[[1L]]), "because FNN and Matrix are not installed", fixed = TRUE) + expect_identical(w[[1L]]$missing, c("FNN", "Matrix")) + expect_identical(r$value$loo, both$value$loo) + + # The step is left out by the cells that hold a scored row, not by the + # centres. A response on the western half alone, at 2.25 rows a cell: more + # than 5,000 centres over every point, about half of them with a scored row. + # The warning says where the columns will be NA, which is all that is known + # before the fits; here no level is such a level, and they are computed. + west <- big + west$z[sf::st_coordinates(big)[, 1] > 5e4] <- NA + r <- local({ + .cl_without("FNN") + .cl_catch(.cl_profile(west, estimate = "pooled", obs_per_cell = 2.25, partition = "kmeans", + init = "random", nstart = 1, sac = "auto", seed = 123)) + }) + expect_gt(r$value$levels, 5000L) + expect_lt(r$value$cells_resp, 4000L) + expect_length(.cl_of(r, "spatialkit_moran_skipped"), 1L) + expect_true(is.finite(r$value$moran_i)) + expect_true(is.finite(r$value$moran_z)) + + # A present ladder at such a level stops with the error it has always had + # while .moran_skip_any_ladder() is FALSE ... Both values are set here, so + # the test does not read the one the function holds. + present <- function() .cl_profile(big, levels = 5200, sample_n = 23000, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans", + init = "random", nstart = 1, seed = 123) + for (pkg in c("FNN", "Matrix")) { + e <- local({ + .cl_without(pkg) + testthat::local_mocked_bindings(.moran_skip_any_ladder = function() FALSE) + .cl_error(present()) + }) + expect_identical(class(e), c("simpleError", "error", "condition"), info = pkg) + expect_match(conditionMessage(e), "n = 5200 requires FNN for k-NN weights", fixed = TRUE) + } + # ... and, once it says the rule holds on every ladder, returns. + r <- local({ + .cl_without("FNN") + testthat::local_mocked_bindings(.moran_skip_any_ladder = function() TRUE) + .cl_catch(present()) + }) + expect_length(.cl_of(r, "spatialkit_moran_skipped"), 1L) + expect_identical(.cl_of(r, "spatialkit_moran_skipped")[[1L]]$levels, 5200L) + expect_identical(r$value$levels, 5200L) + expect_identical(r$value$moran_i, NA_real_) + expect_identical(r$value$moran_z, NA_real_) + expect_true(is.finite(r$value$wss)) + expect_true(is.finite(r$value$rss)) +}) + +test_that("Moran's z is computed below 5,001 cells whatever is installed, and nothing is said", { + pts <- .cl_layer(600, 317) + with <- .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5))) + for (pkg in list("FNN", "Matrix", c("FNN", "Matrix"))) { + r <- local({ .cl_without(pkg); .cl_catch(.cl_profile(pts, obs_per_cell = c(18, 4.5))) }) + expect_length(r$warnings, 0L) + expect_true(all(is.finite(r$value$moran_z))) + expect_equal(r$value$moran_i, with$value$moran_i, tolerance = 1e-10) + expect_equal(r$value$moran_z, with$value$moran_z, tolerance = 1e-10) + } +}) + + +# ---- The fit guard ----------------------------------------------------------- + +# 1,000 points with a response on 500: at 4.5 rows a cell, 111 cells. +.cl_half <- function() .cl_keep("half", { + pts <- .cl_layer(1000, 318) + pts$z[seq(2, 1000, by = 2)] <- NA + pts +}) + +test_that("the fit guard stops a ladder of sizes whose fits compare too many points with centres", { + skip_if_not_installed("FNN") + pts <- .cl_half() + stop_fit <- function(...) stop("a fit was reached") + guard <- function(limit, ..., obs_per_cell = 4.5) { + withr::local_options(spatialkit.fit_work_max = limit) + testthat::local_mocked_bindings(.partition_centres = stop_fit) + .cl_error(.cl_profile(pts, obs_per_cell = obs_per_cell, ...)) + } + cases <- list(list(kind = "kmeans", init = "kmeans++", nstart = 25L, with = "25 k-means++ starts"), + list(kind = "kmeans", init = "random", nstart = 25L, with = "25 random starts"), + list(kind = "density", init = "kmeans++", nstart = 3L, + with = "3 density-weighted k-means++ starts")) + for (cs in cases) { + what <- paste(cs$kind, cs$init) + # The work is the points, with a response or without, times the cells of + # the finest level, times the starts: `nstart = NULL` is the kind's own. + work <- 1000 * 111 * cs$nstart + e <- guard(work - 1, partition = cs$kind, init = cs$init, nstart = NULL) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(class(e), c("spatialkit_work_limit", "error", "condition"), info = what) + expect_null(conditionCall(e)) + expect_identical(.cl_fields(e), + list(work = work, limit = work - 1, what = "partition fit", kind = cs$kind, + init = cs$init, nstart = cs$nstart, fnn = TRUE), info = what) + expect_identical(conditionMessage(e), + sprintf(paste0("resolution_profile(): fitting 111 cells to 1000 rows with %s is ", + "%.2g point-to-centre comparisons, above the limit of %.2g ", + "(options(spatialkit.fit_work_max = )). Ways on: fewer starts ", + "(`nstart`), which keep the best of fewer; a coarser ", + "`obs_per_cell`; partition = \"density\" with init = \"random\" and ", + "the FNN package installed, which has no step that compares every ", + "point with every centre and leaves a cell without a point more ", + "often; or a higher limit."), cs$with, work, work - 1), + info = what) + # At the limit the fits run: the stand-in for the fit is what stops the call. + e <- guard(work, partition = cs$kind, init = cs$init, nstart = NULL) + expect_identical(conditionMessage(e), "a fit was reached", info = what) + # A number of starts the caller gives is the number counted. + e <- guard(1000 * 111 * 2 - 1, partition = cs$kind, init = cs$init, nstart = 2) + expect_identical(e$work, 1000 * 111 * 2, info = what) + expect_identical(e$nstart, 2L, info = what) + } + # One start is written in the singular. + e <- guard(1, partition = "kmeans", init = "random", nstart = 1) + expect_match(conditionMessage(e), "with 1 random start is", fixed = TRUE) + + # The finest level of several is the one counted. + e <- guard(1, partition = "density", init = "kmeans++", nstart = 3, obs_per_cell = c(18, 9, 2)) + expect_identical(e$work, 1000 * 250 * 3) + + # The density kind from random starts has no such step with FNN: nothing + # is counted at any limit. + e <- guard(0, partition = "density", init = "random", nstart = 3) + expect_identical(conditionMessage(e), "a fit was reached") + + # The guard bounds the fits, whatever is scored on them: without an + # estimate, and without a response, where the size divides every point. + e <- guard(1000 * 111 * 2 - 1, partition = "kmeans", init = "kmeans++", nstart = 2, + estimate = NULL) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, 1000 * 111 * 2) + e <- guard(1000 * 222 * 3 - 1, partition = "density", init = "kmeans++", nstart = 3, + response = NULL, estimate = NULL) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, 1000 * 222 * 3) + expect_identical(conditionMessage(guard(1000 * 222 * 3, partition = "density", init = "kmeans++", + nstart = 3, response = NULL, estimate = NULL)), + "a fit was reached") +}) + +test_that("a call a guard stops has estimated no variogram and raised no warning", { + skip_if_not_installed("gstat") + pts <- .cl_layer(300, 326) + # With sac = NULL a ladder of sizes estimates the variogram, whose warnings + # are about `cp` and `reliability`: columns of a profile that a stopped + # call never returns. The guards come first. + stopped <- function(..., fit_max = 1, pairs_max = NULL, off = character(0)) { + reached <- 0L + withr::local_options(spatialkit.fit_work_max = fit_max, spatialkit.exact_pairs_max = pairs_max) + testthat::local_mocked_bindings( + estimate_sac_range = function(...) { reached <<- reached + 1L; stop("the variogram was reached") }, + .partition_centres = function(...) stop("a fit was reached")) + if (length(off)) .cl_without(off) + got <- list() + e <- tryCatch(withCallingHandlers( + .cl_profile(pts, ..., sac = NULL), + warning = function(w) { got[[length(got) + 1L]] <<- w; invokeRestart("muffleWarning") }), + error = function(e) e) + list(error = e, warnings = got, variogram = reached) + } + # The fit guard, with and without an estimate. + for (est in list("pooled", NULL)) { + r <- stopped(estimate = est, obs_per_cell = 4.5, partition = "kmeans") + expect_s3_class(r$error, "spatialkit_work_limit") + expect_identical(r$error$what, "partition fit") + expect_identical(r$variogram, 0L) + expect_length(r$warnings, 0L) + } + # A size that would be held to two cells is not reported either. + r <- stopped(obs_per_cell = c(400, 4.5), partition = "kmeans") + expect_s3_class(r$error, "spatialkit_work_limit") + expect_length(r$warnings, 0L) + # The guard on the density weights' search, and the one on each row's nearest centre. + r <- stopped(obs_per_cell = 4.5, partition = "density", fit_max = 1e10, pairs_max = 10, off = "FNN") + expect_identical(r$error$what, "density weights") + expect_identical(r$variogram, 0L) + expect_length(r$warnings, 0L) + r <- stopped(obs_per_cell = 4.5, partition = "kmeans", fit_max = 1e10, pairs_max = 10, off = "FNN") + expect_identical(r$error$what, "nearest centre") + expect_identical(r$error$work, 300 * 67) + expect_identical(r$variogram, 0L) + expect_length(r$warnings, 0L) + # The order of the three: the weights' search, the fits, each row's nearest centre. + r <- stopped(obs_per_cell = 4.5, partition = "density", fit_max = 1, pairs_max = 10, off = "FNN") + expect_identical(r$error$what, "density weights") + r <- stopped(obs_per_cell = 4.5, partition = "kmeans", fit_max = 1, pairs_max = 10, off = "FNN") + expect_identical(r$error$what, "partition fit") + # Under the limits the variogram is estimated, as on every ladder under sac = NULL. + r <- stopped(obs_per_cell = 4.5, partition = "kmeans", fit_max = 1e10) + expect_identical(conditionMessage(r$error), "a fit was reached") + expect_identical(r$variogram, 1L) +}) + +test_that("without FNN the fit guard counts every pass of the density kind", { + pts <- .cl_half() + guard <- function(limit, ...) { + withr::local_options(spatialkit.fit_work_max = limit) + testthat::local_mocked_bindings(.partition_centres = function(...) stop("a fit was reached")) + .cl_without("FNN") + .cl_error(.cl_profile(pts, obs_per_cell = 4.5, ...)) + } + for (init in c("kmeans++", "random")) { + # Up to 100 passes a start, each of which compares every point with every centre. + work <- 1000 * 111 * 3 * 100 + e <- guard(work - 1, partition = "density", init = init, nstart = NULL) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(.cl_fields(e), + list(work = work, limit = work - 1, what = "partition fit", kind = "density", + init = init, nstart = 3L, fnn = FALSE), info = init) + expect_match(conditionMessage(e), + "fitting 111 cells to 1000 rows with 3 starts of up to 100 passes each is 3.3e+07", + fixed = TRUE) + expect_identical(conditionMessage(guard(work, partition = "density", init = init, + nstart = NULL)), + "a fit was reached", info = init) + # `iter_max` is the number of passes counted. + e <- guard(1, partition = "density", init = init, nstart = 2, iter_max = 7) + expect_identical(e$work, 1000 * 111 * 2 * 7, info = init) + expect_match(conditionMessage(e), "with 2 starts of up to 7 passes each", fixed = TRUE) + } + # The k-means kind has no kd-tree to lose: its count is the same. + e <- guard(1, partition = "kmeans", init = "kmeans++", nstart = NULL) + expect_identical(e$work, 1000 * 111 * 25) + expect_false(e$fnn) +}) + +test_that("the fit guard is not applied to a ladder the subsample bounds", { + skip_if_not_installed("gstat") + pts <- .cl_layer(300, 319) + withr::local_options(spatialkit.fit_work_max = 0) + for (kind in c("kmeans", "density")) { + expect_s3_class(suppressWarnings(.cl_profile(pts, partition = kind, estimate = NULL, + obs_per_cell = NULL, sac = NULL, n_levels = 3)), + "resolution_profile") + expect_s3_class(suppressWarnings(.cl_profile(pts, partition = kind, obs_per_cell = NULL, + sac = NULL, levels = c(5L, 20L))), + "resolution_profile") + } + # On a ladder of sizes the same limit stops the call. + expect_s3_class(.cl_error(.cl_profile(pts, partition = "kmeans", obs_per_cell = 4.5)), + "spatialkit_work_limit") +}) + +test_that("the limit on a fit is 1e10 comparisons unless the option says otherwise", { + expect_identical(.FIT_WORK_MAX, 1e10) + withr::local_options(spatialkit.fit_work_max = NULL) + expect_identical(.fit_work_max(), 1e10) + part <- list(kind = "kmeans", init = "kmeans++") + # 100,000 points into 22,222 cells from 5 starts is past it; from 4 it is not. + expect_s3_class(tryCatch(.fit_guard(100000L, 22222L, 5L, part, 50L, TRUE), error = identity), + "spatialkit_work_limit") + expect_null(.fit_guard(100000L, 22222L, 4L, part, 50L, TRUE)) + # Counts past the largest integer are counted as doubles. + e <- tryCatch(.fit_guard(3e6L, 7e5L, 25L, part, 50L, TRUE), error = identity) + expect_identical(e$work, 3e6 * 7e5 * 25) + withr::local_options(spatialkit.fit_work_max = 5e11) + expect_identical(.fit_work_max(), 5e11) + expect_null(.fit_guard(100000L, 22222L, 25L, part, 50L, TRUE)) + for (bad in list("many", c(1, 2), NA_real_, -1)) { + withr::local_options(spatialkit.fit_work_max = bad) + expect_error(.fit_work_max(), "options(spatialkit.fit_work_max = ) must be a single number", + fixed = TRUE) + } +}) + +test_that("one density start from k-means++ takes more than twice as long on twice the rows", { + skip_on_cran() + skip_if_not_installed("FNN") + one <- function(n, seed) { + xy <- local({ + .cl_seed(seed) + cbind(stats::runif(n, 0, 1e5), stats::runif(n, 0, 1e5)) + }) + .cl_seed(123) + system.time(.partition_centres(xy, as.integer(round(n / 4.5)), partition = "density", + init = "kmeans++", nstart = 1L, iter.max = 100L, + use_fnn = TRUE))[["elapsed"]] + } + t20 <- one(20000L, 201) + t40 <- one(40000L, 301) + expect_gt(t40, 2 * t20) +}) + + +# ---- The guard on the density weights' search -------------------------------- + +test_that("without FNN a ladder of sizes bounds the search behind the density kind's weights", { + # 60 points at 50 distinct locations. + pts <- local({ + d <- sf::st_drop_geometry(.cl_layer(60, 320)) + g <- sf::st_geometry(.cl_layer(60, 320)) + sf::st_sf(d, geometry = g[c(1:50, 1:10)]) + }) + expect_identical(nrow(unique(sf::st_coordinates(pts))), 50L) + call <- function(...) { + testthat::local_mocked_bindings(.partition_centres = function(...) stop("a fit was reached")) + .cl_error(suppressWarnings(.cl_profile(pts, obs_per_cell = 4.5, ...))) + } + withr::local_options(spatialkit.exact_pairs_max = 100) + e <- local({ .cl_without("FNN"); call() }) + expect_identical(class(e), c("spatialkit_work_limit", "error", "condition")) + # The distinct locations squared, not the points squared. + expect_identical(.cl_fields(e), list(work = 2500, limit = 100, what = "density weights")) + expect_identical(conditionMessage(e), + paste0("resolution_profile(): the neighbour search behind the weights of ", + "partition = \"density\", over 50 distinct locations, would compare ", + "2.5e+03 pairs without the FNN package, above the limit of 1e+02 ", + "(options(spatialkit.exact_pairs_max = )). Install FNN: the result is the ", + "same.")) + expect_null(conditionCall(e)) + # At the limit the search runs. + local({ + withr::local_options(spatialkit.exact_pairs_max = 2500) + .cl_without("FNN") + expect_identical(conditionMessage(call()), "a fit was reached") + }) + # The search belongs to the fit and not to the estimate: it is bounded + # without one, and without a response. + for (extra in list(list(estimate = NULL), list(response = NULL, estimate = NULL))) { + e <- local({ .cl_without("FNN"); do.call(call, extra) }) + expect_identical(.cl_fields(e), list(work = 2500, limit = 100, what = "density weights")) + } + # It is bounded before the fits are: a call both guards would stop names the search. + e <- local({ + .cl_without("FNN") + withr::local_options(spatialkit.fit_work_max = 1) + call() + }) + expect_identical(e$what, "density weights") + # With no weights there is no such search: another search stops the call. + e <- local({ .cl_without("FNN"); call(density_power = 0) }) + expect_s3_class(e, "spatialkit_work_limit") + expect_false(identical(e$what, "density weights")) + # The k-means kind has no weights either. + e <- local({ .cl_without("FNN"); call(partition = "kmeans") }) + expect_false(identical(e$what, "density weights")) + # With FNN the weights come from a kd-tree, at any limit. + skip_if_not_installed("FNN") + withr::local_options(spatialkit.exact_pairs_max = 0) + expect_identical(conditionMessage(call()), "a fit was reached") +}) + +test_that("the search behind the density weights is not bounded on a ladder the subsample bounds", { + skip_if_not_installed("gstat") + pts <- .cl_layer(120, 321) + withr::local_options(spatialkit.exact_pairs_max = 0) + .cl_without("FNN") + # No estimate, so no search of the estimate's is made either. The ladder + # the function builds, and one given as `levels`. + for (ladder in list(list(n_levels = 3), list(levels = c(4L, 10L)))) { + p <- suppressWarnings(do.call(.cl_profile, c(list(pts, estimate = NULL, obs_per_cell = NULL, + sac = NULL), ladder))) + expect_s3_class(p, "resolution_profile") + expect_true(all(is.finite(p$wss))) + expect_null(attr(p, "bounds")$obs_per_cell) + } +}) + + +# ---- The print --------------------------------------------------------------- + +test_that("a ladder of sizes prints its sizes, the rows they divide and no ceiling", { + pts <- .cl_600() + one <- .cl_profile(pts, obs_per_cell = 4.5) + out <- utils::capture.output(print(one)) + expect_identical(out[1L], "Resolution profile: 1 levels on 600 points") + expect_identical(out[2L], + paste0(" ladder : 133 cells (obs_per_cell = 4.5 on the 600 rows with a ", + "response; centres fitted to every row; floor 2 (no range))")) + expect_identical(out[3L], + paste0(" variogram : none fitted: a size ladder fits one only when `sac` is ", + "given (cp and reliability are NA)")) + expect_identical(out[4L], + paste0(" scored on : response; 3 density-weighted k-means++ starts (power 1, 8 ", + "neighbours) per level; WSS rises at 0 step(s)")) + expect_match(out[5L], "^ one cell : rss ") + expect_identical(out[6L], + sprintf(paste0(" estimate : pooled toward the 8 nearest cells; loo on 600 rows ", + "of the layer; one cell: loo %s"), + format(signif(attr(one, "estimate")$loo_one_cell, 3)))) + # The table shows the new columns like the others. + for (col in c("scored_per_cell", "loo", "loo_se", "share_alone", "own_weight")) + expect_true(any(grepl(paste0("\\b", col, "\\b"), out)), info = col) + + several <- .cl_profile(pts, estimate = "mean", obs_per_cell = "auto") + out <- utils::capture.output(print(several)) + expect_identical(out[2L], + paste0(" ladder : 33 to 300 cells (obs_per_cell = 18, 12, 9, 6, 4.5, 3, 2 ", + "on the 600 rows with a response; centres fitted to every row; floor 2 ", + "(no range))")) + expect_match(out[6L], "^ estimate : plain means; loo on 600 rows of the layer; one cell: loo ") + + # A size of "auto" that gave fewer than two cells was left out of the + # ladder, and is left out of its line: 18 rows a cell on 20 rows. + few <- .cl_profile(.cl_layer(20, 306), estimate = "mean", obs_per_cell = "auto") + expect_identical(attr(few, "bounds")$obs_per_cell, c(18, 12, 9, 6, 4.5, 3, 2)) + out <- utils::capture.output(print(few)) + expect_identical(out[2L], + paste0(" ladder : 2 to 10 cells (obs_per_cell = 12, 9, 6, 4.5, 3, 2 on the ", + "20 rows with a response; centres fitted to every row; floor 2 (no ", + "range))")) + + # Rows without a response, a range, and no response at all. + part <- pts + part$z[1:150] <- NA + out <- utils::capture.output(print(suppressWarnings(.cl_profile(part, obs_per_cell = 9, sac = 20000)))) + expect_identical(out[1L], "Resolution profile: 1 levels on 600 points (450 with a response)") + expect_match(out[2L], paste0("^ ladder : 50 cells \\(obs_per_cell = 9 on the 450 rows with a ", + "response; centres fitted to every row; floor [0-9]+ from range 20000, ", + "not applied\\)$")) + out <- utils::capture.output(print(.cl_profile(pts, response = NULL, estimate = NULL, + obs_per_cell = 9))) + expect_identical(out[2L], + paste0(" ladder : 67 cells (obs_per_cell = 9 on the 600 points; centres ", + "fitted to every row; floor 2 (no range))")) + expect_false(any(grepl("^ estimate", out))) + + # Not supported. + out <- utils::capture.output(print(suppressWarnings(.cl_profile(.cl_layer(6, 305), + obs_per_cell = 4.5)))) + expect_match(out[2L], " -- fewer than two cells of the size: not supported$") + out <- utils::capture.output(print(suppressWarnings(.cl_profile(.cl_3000(), obs_per_cell = 4.5, + sac = 2000)))) + expect_match(out[2L], "not applied\\) -- floor above the finest level: not supported$") +}) + +test_that("a profile without an estimate and without a size prints no new line", { + skip_if_not_installed("gstat") + pts <- .cl_600() + out <- utils::capture.output(print(suppressWarnings(.cl_profile(pts, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + n_levels = 4)))) + expect_false(any(grepl("^ estimate|obs_per_cell|none fitted|scored_per_cell", out))) + expect_match(out[2L], "^ ladder : 2 to 66 cells \\(floor ") +}) diff --git a/tests/testthat/test-core-count-loo.R b/tests/testthat/test-core-count-loo.R new file mode 100644 index 00000000..02b0cc1f --- /dev/null +++ b/tests/testthat/test-core-count-loo.R @@ -0,0 +1,870 @@ +# tests/testthat/test-core-count-loo.R +# --------------------------------------------------------------------------- +# resolution_profile(estimate = ): the leave-one-out error of the estimate the +# summary reports, on every scored row of the layer, in the cells the seeds +# will build. +# +# What a profile has without an estimate is held identical() to the same call +# with one, conditions included. The five columns are held to the reference +# functions of helper-pool-reference.R on the regions .nearest_centre() gives +# from the profile's centres. +# +# Every call names `partition`, `nstart`, `estimate`, `obs_per_cell` and +# `sac`. Unless a test says otherwise the regions are of the density kind +# from 3 k-means++ starts. A layer is drawn under the seed its test states: +# the locations (x, then y), then the response. A backend is switched off by +# replacing .has_backend(). +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.co_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.co_points <- function(x, y, z, crs = 32617) + sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = crs) + +# `n` locations uniform on a square of side `side`, with the field of the +# engine's tests: sin(x / 2e4) + cos(y / 1.5e4) plus normal noise of standard +# deviation 1.5. +.co_layer <- function(n, seed, side = 1e5) { + d <- local({ + .co_seed(seed) + x <- stats::runif(n, 0, side); y <- stats::runif(n, 0, side) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(n, 0, 1.5)) + }) + .co_points(d$x, d$y, d$z) +} + +# The lattice of the engine's property tests: 60 x 50 locations at a spacing +# of 0.7 from (0.1, 0.3). None of its coordinates is exact in binary and +# every location has neighbours at exactly equal distances. +.co_lattice <- function() { + xy <- as.matrix(expand.grid(x = seq(0.1, by = 0.7, length.out = 60), + y = seq(0.3, by = 0.7, length.out = 50))) + z <- local({ + .co_seed(31) + sin(xy[, 1] / 9) + cos(xy[, 2] / 7) + stats::rnorm(nrow(xy), 0, 0.5) + }) + .co_points(xy[, 1], xy[, 2], z) +} + +.co_profile <- function(pts, ..., response = "z", partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = 4.5) + resolution_profile(pts, response, ..., partition = partition, nstart = nstart, sac = sac, + estimate = estimate, obs_per_cell = obs_per_cell) + +# A call with its warnings kept and muffled. +.co_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.co_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.co_texts <- function(r) vapply(r$warnings, conditionMessage, character(1)) +.co_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.co_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] +.co_error <- function(expr) tryCatch({ suppressWarnings(expr); NULL }, error = function(e) e) + +.co_without_fnn <- function(env = parent.frame()) + testthat::local_mocked_bindings( + .has_backend = function(p) + if (identical(p, "FNN")) FALSE else requireNamespace(p, quietly = TRUE), + .env = env) + +.co_new <- c("scored_per_cell", "loo", "loo_se", "share_alone", "own_weight") +.co_xy <- function(pts) unname(sf::st_coordinates(pts)[, 1:2, drop = FALSE]) + +# The regions of a level as the profile scores them: each scored row in the +# cell of its nearest centre, the centres that hold none dropped and the rest +# numbered in the order of their centres. +.co_regions <- function(xy, centres) { + g <- .nearest_centre(xy[, 1], xy[, 2], centres[, 1], centres[, 2]) + u <- sort(unique(g)) + list(gi = match(g, u), K = length(u), u = u) +} + +# What the reference functions give on those regions, with the rows in the +# order the layer has them. +.co_reference <- function(xy, y, centres) { + rg <- .co_regions(xy, centres) + nn1 <- pool_nearest_other(xy) + fr <- fit_regions(rg$gi, rg$gi, y, xy, xy, nn1) + N <- length(y) + list(K = fr$K, N = N, + loo_mean = loo_plain(y, rg$gi, oneway(y, rg$gi, rg$K), nn1), + loo_mean_se = stats::sd(fr$eP^2) / sqrt(N), + loo_pooled = fr$loo_L, loo_pooled_se = fr$loo_L_se, + own_weight = stats::median(fr$w), share_alone = sum(fr$n == 1L) / N, + one_row = mean(fr$n == 1L), sigma2 = fr$sigma2, tau2 = fr$tau2) +} + +# Hold a profile's five columns and its record to the reference, level by +# level, to a relative 1e-10: the profile's rows are in coordinate order, so +# its sums run in another order than the reference's. +.co_expect_reference <- function(p, xy, y, estimate, what = "") { + est <- attr(p, "estimate") + cen <- attr(p, "centres") + for (i in seq_len(nrow(p))) { + at <- paste(what, estimate, p$levels[i], "cells") + ref <- .co_reference(xy, y, cen[[as.character(p$levels[i])]]) + expect_equal(p$loo[i], if (estimate == "mean") ref$loo_mean else ref$loo_pooled, + tolerance = 1e-10, info = at) + expect_equal(p$loo_se[i], if (estimate == "mean") ref$loo_mean_se else ref$loo_pooled_se, + tolerance = 1e-10, info = at) + if (estimate == "pooled") + expect_equal(p$own_weight[i], ref$own_weight, tolerance = 1e-10, info = at) + else expect_identical(p$own_weight[i], NA_real_, info = at) + expect_identical(p$share_alone[i], ref$share_alone, info = at) + expect_identical(p$scored_per_cell[i], ref$N / ref$K, info = at) + # The share of regions with one row, which the experiment's summary keeps. + expect_equal(p$share_alone[i] * ref$N / ref$K, ref$one_row, tolerance = 1e-12, info = at) + expect_identical(est$cells[[i]], ref$K, info = at) + expect_equal(est$sigma2[[i]], ref$sigma2, tolerance = 1e-10, info = at) + if (estimate == "pooled") expect_equal(est$tau2[[i]], ref$tau2, tolerance = 1e-8, info = at) + else expect_identical(est$tau2[[i]], NA_real_, info = at) + } + invisible(NULL) +} + +.co_store <- new.env(parent = emptyenv()) +.co_keep <- function(key, expr) { + if (is.null(.co_store[[key]])) .co_store[[key]] <- expr + .co_store[[key]] +} +.co_600 <- function() .co_keep("l600", .co_layer(600, 401)) +.co_1200 <- function() .co_keep("l1200", .co_layer(1200, 402)) + + +# ---- An estimate changes nothing a profile has without one -------------------- + +# The same call with and without an estimate: every column and attribute of +# the call without is in the call with, identical; every condition of the +# call without is raised again, same class and text, same order; and what the +# estimate adds is five columns, one attribute and conditions of `extra`. +.co_expect_unchanged <- function(call, what, extra = character(0)) { + base <- .co_catch(call(NULL)) + cols <- names(base$value) + at <- attributes(base$value) + for (est in c("pooled", "mean")) { + info <- paste(what, est) + r <- .co_catch(call(est)) + expect_identical(names(r$value), c(cols, .co_new), info = info) + for (col in cols) expect_identical(r$value[[col]], base$value[[col]], info = paste(info, col)) + expect_identical(setdiff(names(attributes(r$value)), names(at)), "estimate", info = info) + for (a in setdiff(names(at), "names")) + expect_identical(attr(r$value, a, exact = TRUE), at[[a]], info = paste(info, a)) + added <- .co_classes(r) %in% extra + expect_identical(.co_classes(r)[!added], .co_classes(base), info = info) + expect_identical(.co_texts(r)[!added], .co_texts(base), info = info) + expect_identical(sort(unique(.co_classes(r)[added])), sort(extra), info = info) + expect_identical(attr(r$value, "estimate")$value, est, info = info) + } + invisible(base) +} + +test_that("an estimate adds five columns and one attribute, and changes nothing else", { + skip_if_not_installed("gstat") + below <- .co_layer(400, 403) + above <- .co_1200() + for (kind in c("kmeans", "density")) { + # 5 starts for the kind "kmeans", to keep the test short; the number is + # named either way. + ns <- if (kind == "kmeans") 5 else 3 + # The ladder the function builds, on a layer below `sample_n` and on one above it. + .co_expect_unchanged(function(est) + .co_profile(below, partition = kind, nstart = ns, estimate = est, obs_per_cell = NULL, + sac = NULL, n_levels = 6, sample_n = 1500), + paste(kind, "automatic, below sample_n")) + .co_expect_unchanged(function(est) + .co_profile(above, partition = kind, nstart = ns, estimate = est, obs_per_cell = NULL, + sac = NULL, n_levels = 6, sample_n = 400), + paste(kind, "automatic, above sample_n")) + # A ladder given as `levels`. + .co_expect_unchanged(function(est) + .co_profile(below, partition = kind, nstart = ns, estimate = est, obs_per_cell = NULL, + sac = NULL, levels = c(8L, 30L, 120L), sample_n = 1500), + paste(kind, "levels, below sample_n")) + .co_expect_unchanged(function(est) + .co_profile(above, partition = kind, nstart = ns, estimate = est, obs_per_cell = NULL, + sac = NULL, levels = c(8L, 30L, 120L), sample_n = 400), + paste(kind, "levels, above sample_n")) + # The response read on one half. + .co_expect_unchanged(function(est) + .co_profile(above, partition = kind, nstart = ns, estimate = est, obs_per_cell = NULL, + sac = NULL, n_levels = 5, sample_n = 400, select_on = "split"), + paste(kind, "split")) + } +}) + +test_that("an estimate changes nothing on a constant response, a supplied sac or missing values", { + skip_if_not_installed("gstat") + pts <- .co_layer(400, 403) + flat <- pts + flat$z <- 0.1 + base <- .co_expect_unchanged(function(est) + .co_profile(flat, estimate = est, obs_per_cell = NULL, sac = NULL, n_levels = 5), + "constant") + expect_true("spatialkit_constant_response" %in% .co_classes(base)) + + .co_expect_unchanged(function(est) + .co_profile(pts, estimate = est, obs_per_cell = NULL, sac = 20000, n_levels = 5, + range_floor = TRUE), + "a range as sac") + + holes <- pts + holes$z[c(3, 40, 41, 200:260)] <- NA + base <- .co_expect_unchanged(function(est) + .co_profile(holes, estimate = est, obs_per_cell = NULL, sac = NULL, n_levels = 5, + min_cell_n = 5), + "missing values") + expect_true("spatialkit_response_ceiling" %in% .co_classes(base)) + + # Rows that share locations: one further condition, of a new class. + twice <- pts + sf::st_geometry(twice) <- sf::st_geometry(pts)[rep(1:200, 2)] + .co_expect_unchanged(function(est) + .co_profile(twice, estimate = est, obs_per_cell = NULL, sac = NULL, n_levels = 5), + "repeated locations", extra = "spatialkit_repeated_locations") +}) + +test_that("the estimate leaves the caller's random-number stream as the call without it does", { + pts <- .co_600() + after <- function(est) { + .co_seed(77) + suppressWarnings(.co_profile(pts, estimate = est, obs_per_cell = 9)) + stats::runif(3) + } + expect_identical(after("pooled"), after(NULL)) + expect_identical(after("mean"), after(NULL)) + expect_identical(after(NULL), local({ .co_seed(77); stats::runif(3) })) +}) + + +# ---- The five columns, against the reference functions ------------------------ + +test_that("loo, its standard error and the weights are the reference functions' at each level", { + skip_if_not_installed("FNN") + pts <- .co_600() + xy <- .co_xy(pts) + for (est in c("mean", "pooled")) { + for (kind in c("density", "kmeans")) { + p <- .co_profile(pts, partition = kind, estimate = est, obs_per_cell = c(18, 9, 4.5, 2)) + expect_identical(p$levels, c(33L, 67L, 133L, 300L)) + expect_true(all(is.finite(p$loo))) + .co_expect_reference(p, xy, pts$z, est, kind) + # On a ladder of sizes without a split the layer's count is the fit's. + expect_equal(p$scored_per_cell, p$cell_resp_mean, tolerance = 1e-12) + # There are rows alone in their cell at the finest size, so the rule for them is reached. + expect_gt(p$share_alone[4L], 0.05) + # The record. + e <- attr(p, "estimate") + expect_identical(names(e), + c("value", "neighbours", "response", "n", "rows", "features", "seed", + "constant", "loo_one_cell", "loo_one_cell_se", "loo_levels", "sigma2", + "tau2", "cells", "f_p")) + expect_identical(e$value, est) + expect_identical(e$neighbours, if (est == "pooled") 8L else NA_integer_) + expect_identical(e$response, "z") + expect_identical(e$n, 600L) + expect_identical(e$rows, "all") + expect_identical(e$features, "points") + expect_identical(e$seed, 123L) + expect_false(e$constant) + expect_identical(e$loo_levels, stats::setNames(p$loo, p$levels)) + # One mean for all rows: each row predicted by the mean of the others. + e1 <- (pts$z - mean(pts$z)) * 600 / 599 + expect_equal(e$loo_one_cell, mean(e1^2), tolerance = 1e-12) + expect_equal(e$loo_one_cell_se, stats::sd(e1^2) / sqrt(600), tolerance = 1e-12) + expect_identical(names(e$f_p), as.character(p$levels)) + expect_true(all(is.finite(e$f_p) & e$f_p >= 0 & e$f_p <= 1)) + } + } + # The same centres, so the same cells, whichever estimate is scored. + expect_identical(attr(.co_profile(pts, estimate = "mean", obs_per_cell = 9), "centres"), + attr(.co_profile(pts, estimate = "pooled", obs_per_cell = 9), "centres")) +}) + +test_that("on the automatic ladder loo is the reference's on the ladder's cells", { + skip_if_not_installed("FNN") + skip_if_not_installed("gstat") + pts <- .co_600() + xy <- .co_xy(pts) + for (est in c("mean", "pooled")) { + p <- suppressWarnings(.co_profile(pts, partition = "kmeans", nstart = 5, estimate = est, + obs_per_cell = NULL, sac = NULL, n_levels = 6)) + expect_identical(p$levels[1L], 2L) + .co_expect_reference(p, xy, pts$z, est, "automatic") + } +}) + +test_that("on a layer above sample_n loo reads every scored row of the layer", { + skip_if_not_installed("FNN") + skip_if_not_installed("gstat") + pts <- .co_1200() + xy <- .co_xy(pts) + for (est in c("mean", "pooled")) { + p <- suppressWarnings(.co_profile(pts, estimate = est, obs_per_cell = NULL, sac = NULL, + n_levels = 5, sample_n = 300)) + b <- attr(p, "bounds") + expect_identical(b$n_sample, 300L) + expect_identical(attr(p, "estimate")$n, 1200L) + expect_identical(attr(p, "estimate")$rows, "all") + # The reference on all 1,200 rows, in the cells of the centres fitted to 300. + .co_expect_reference(p, xy, pts$z, est, "above sample_n") + # `cell_resp_mean` counts the subsample's rows and `scored_per_cell` the layer's. + expect_equal(p$scored_per_cell[1L], 600, tolerance = 0.2) + expect_equal(p$cell_resp_mean[1L], 150, tolerance = 0.2) + expect_true(all(p$scored_per_cell > 2.5 * p$cell_resp_mean)) + # The record is the layer's as well. One mean for all 1,200 rows, where + # `one_cell` holds the subsample's 300. + e <- attr(p, "estimate") + one <- attr(p, "one_cell") + expect_identical(one$n, 300L) + e1 <- (pts$z - mean(pts$z)) * 1200 / 1199 + expect_equal(e$loo_one_cell, mean(e1^2), tolerance = 1e-12) + expect_equal(e$loo_one_cell_se, stats::sd(e1^2) / sqrt(1200), tolerance = 1e-12) + expect_false(isTRUE(all.equal(e$loo_one_cell, one$rss / 300 * (300 / 299)^2, tolerance = 1e-6))) + # The F test of each level's cells against one mean: the cells of the + # nearest centres on every row, where `one_cell$f_p` reads the fit's + # clusters on the subsample. + f_p <- vapply(seq_len(nrow(p)), function(i) { + rg <- .co_regions(xy, attr(p, "centres")[[i]]) + rss <- sum((pts$z - stats::ave(pts$z, rg$gi))^2) + tss <- sum((pts$z - mean(pts$z))^2) + stats::pf(((tss - rss) / (rg$K - 1)) / (rss / (1200 - rg$K)), rg$K - 1, 1200 - rg$K, + lower.tail = FALSE) + }, numeric(1)) + expect_equal(unname(e$f_p), f_p, tolerance = 1e-8) + expect_identical(names(e$f_p), as.character(p$levels)) + expect_false(isTRUE(all.equal(unname(e$f_p), unname(one$f_p), tolerance = 1e-6))) + expect_false(e$constant) + } +}) + +test_that("the estimate's reference is constant when the layer is, not when the subsample is", { + skip_if_not_installed("gstat") + # 2,000 rows, a response of 0 on all but six: a subsample of 300 that holds + # none of the six is constant, and the layer is not. + pts <- .co_layer(2000, 408) + pts$z <- 0 + pts$z[local({ .co_seed(409); sample.int(2000L, 6L) })] <- c(1, 2, 3, 1, 2, 3) + call <- function(seed, est = "pooled") + .co_catch(.co_profile(pts, partition = "kmeans", nstart = 2, estimate = est, + obs_per_cell = NULL, sac = NULL, n_levels = 4, sample_n = 300, + seed = seed)) + found <- NA_integer_ + for (seed in 1:30) { + r <- call(seed) + if ("spatialkit_constant_response" %in% .co_classes(r)) { found <- seed; break } + } + expect_false(is.na(found)) + expect_false(identical(found, 123L)) + p <- r$value + # The present columns follow the subsample: `cp` is NA at every level. + expect_true(attr(p, "one_cell")$constant) + expect_true(all(is.na(p$cp))) + # The estimate's follow the layer. + e <- attr(p, "estimate") + expect_false(e$constant) + expect_identical(e$n, 2000L) + expect_true(all(is.finite(p$loo))) + expect_true(is.finite(e$loo_one_cell)) + e1 <- (pts$z - mean(pts$z)) * 2000 / 1999 + expect_equal(e$loo_one_cell, mean(e1^2), tolerance = 1e-12) + expect_false(any(grepl("the response is constant", grep("^ estimate", utils::capture.output(print(p)), + value = TRUE), fixed = TRUE))) + # The record holds the seed the profile was built under, whatever it is. + expect_identical(e$seed, found) + expect_identical(attr(call(77L)$value, "estimate")$seed, 77L) + none <- local({ .co_seed(410); attr(call(NULL)$value, "estimate") }) + expect_true("seed" %in% names(none)) + expect_null(none$seed) +}) + +test_that("a level where no cell holds two scored rows has no loo", { + pts <- .co_layer(40, 404) + xy <- .co_xy(pts) + # Every row its own centre. + for (est in c("mean", "pooled")) { + lv <- .estimate_at_level(xy, pts$z, xy, est, use_fnn = FALSE, cache = new.env()) + expect_identical(lv$cells, 40L) + expect_identical(lv$scored_per_cell, 1) + expect_identical(lv$share_alone, 1) + expect_identical(lv$loo, NA_real_) + expect_identical(lv$loo_se, NA_real_) + expect_identical(lv$own_weight, NA_real_) + } + # One centre: both estimates give the error of one mean. + one <- matrix(c(5e4, 5e4, 9e9, 9e9), 2, 2, byrow = TRUE) + e1 <- (pts$z - mean(pts$z)) * 40 / 39 + for (est in c("mean", "pooled")) { + lv <- .estimate_at_level(xy, pts$z, one, est, use_fnn = FALSE, cache = new.env()) + expect_identical(lv$cells, 1L) + expect_equal(lv$loo, mean(e1^2), tolerance = 1e-12) + expect_identical(lv$share_alone, 0) + expect_identical(lv$own_weight, if (est == "pooled") 1 else NA_real_) + } +}) + + +# ---- The rows loo reads -------------------------------------------------------- + +test_that("under select_on = \"split\" only the selection half is scored", { + skip_if_not_installed("FNN") + pts <- .co_1200() + xy <- .co_xy(pts) + for (est in c("mean", "pooled")) { + p <- suppressWarnings(.co_profile(pts, estimate = est, obs_per_cell = 4.5, + select_on = "split")) + sel <- attr(p, "split")$selection + e <- attr(p, "estimate") + expect_identical(e$rows, "selection half") + expect_identical(e$n, length(sel)) + expect_lt(e$n, 800L) + expect_gt(e$n, 400L) + # The size counts the rows of both halves: the cells are built on every point. + expect_identical(p$levels, 267L) + expect_identical(attr(p, "bounds")$n_scored, length(sel)) + expect_identical(attr(p, "bounds")$n_response, 1200L) + # The reference on the selection rows alone, in the cells of every point. + .co_expect_reference(p, xy[sel, , drop = FALSE], pts$z[sel], est, "split") + # The halves are spatial blocks, so the selection rows fill about half + # of the cells: fewer cells hold a scored row, at about the size each. + expect_lt(e$cells[[1L]], 0.7 * 267) + expect_gt(e$cells[[1L]], 0.3 * 267) + expect_identical(p$scored_per_cell, length(sel) / e$cells[[1L]]) + expect_gt(p$scored_per_cell, 2.25) + expect_lt(p$scored_per_cell, 6) + out <- utils::capture.output(print(p)) + expect_true(any(grepl(sprintf("loo on %d rows of the selection half; one cell: loo ", + length(sel)), out, fixed = TRUE))) + } +}) + +test_that("rows without a response stay in the geometry and out of loo", { + skip_if_not_installed("FNN") + pts <- .co_600() + pts$z[seq(1, 600, by = 4)] <- NA + ok <- is.finite(pts$z) + xy <- .co_xy(pts) + for (est in c("mean", "pooled")) { + p <- .co_profile(pts, estimate = est, obs_per_cell = c(9, 3)) + expect_identical(attr(p, "estimate")$n, 450L) + expect_identical(p$levels, c(50L, 150L)) + expect_identical(p$cell_n_median > 0, c(TRUE, TRUE)) + .co_expect_reference(p, xy[ok, , drop = FALSE], pts$z[ok], est, "missing") + } +}) + +test_that("the same layer with its rows permuted gives the same profile", { + skip_if_not_installed("gstat") + pts <- .co_1200() + perm <- local({ .co_seed(405); sample.int(1200L) }) + for (est in c("mean", "pooled")) { + expect_identical(.co_profile(pts[perm, ], estimate = est, obs_per_cell = c(9, 4.5, 2)), + .co_profile(pts, estimate = est, obs_per_cell = c(9, 4.5, 2)), info = est) + # A subsample is drawn from the rows in coordinate order. + expect_identical( + suppressWarnings(.co_profile(pts[perm, ], partition = "kmeans", nstart = 5, estimate = est, + obs_per_cell = NULL, sac = NULL, n_levels = 5, sample_n = 400)), + suppressWarnings(.co_profile(pts, partition = "kmeans", nstart = 5, estimate = est, + obs_per_cell = NULL, sac = NULL, n_levels = 5, sample_n = 400)), + info = est) + } +}) + +test_that("on a lattice the profile does not depend on the order of the rows", { + lat <- .co_lattice() + perm <- local({ .co_seed(406); sample.int(nrow(lat)) }) + for (est in c("mean", "pooled")) { + a <- .co_profile(lat, estimate = est, obs_per_cell = c(4.5, 2)) + expect_identical(a$levels, c(667L, 1500L)) + # Rows alone in their cell, whose nearest other row ties on a lattice. + expect_gt(a$share_alone[2L], 0.05) + expect_true(all(is.finite(a$loo))) + expect_identical(.co_profile(lat[perm, ], estimate = est, obs_per_cell = c(4.5, 2)), a, + info = est) + } +}) + +test_that("a lon/lat layer is scored as the same layer projected first", { + ll <- sf::st_transform(.co_600(), 4326) + a <- suppressWarnings(.co_profile(ll, estimate = "pooled", obs_per_cell = 9)) + b <- suppressWarnings(.co_profile(ensure_projected(ll), estimate = "pooled", obs_per_cell = 9)) + expect_identical(a, b) + expect_true(is.finite(a$loo)) +}) + +test_that("features that are not points are scored at the point each is reduced to", { + pts <- .co_layer(300, 407) + sq <- sf::st_buffer(pts, 50, endCapStyle = "SQUARE") + expect_false(any(sf::st_geometry_type(sq) == "POINT")) + p <- suppressWarnings(.co_profile(sq, estimate = "pooled", obs_per_cell = 9)) + expect_identical(attr(p, "estimate")$features, "other") + expect_identical(attr(p, "estimate")$n, 300L) + as_points <- suppressWarnings(.co_profile(coerce_to_points(sq, "auto"), estimate = "pooled", + obs_per_cell = 9)) + expect_identical(attr(as_points, "estimate")$features, "points") + expect_identical(p$loo, as_points$loo) + expect_identical(attr(p, "centres"), attr(as_points, "centres")) +}) + + +# ---- A constant response, and repeated locations ------------------------------ + +test_that("a constant response has no loo, and the present warning says so in its present words", { + pts <- .co_600() + pts$z <- 0.1 + for (est in c("mean", "pooled")) { + r <- .co_catch(.co_profile(pts, estimate = est, obs_per_cell = c(18, 4.5))) + expect_identical(.co_classes(r), "spatialkit_constant_response", info = est) + expect_identical(.co_texts(r), + sprintf(paste0("resolution_profile(): the response is constant over the 600 ", + "scored row(s) (its total sum of squares, %.3g, is rounding ", + "error at most), so no cell count fits it better than another: ", + "`cp`, `moran_i` and `moran_z` are NA at every level."), + attr(r$value, "one_cell")$rss), info = est) + p <- r$value + expect_identical(p$loo, c(NA_real_, NA_real_)) + expect_identical(p$loo_se, c(NA_real_, NA_real_)) + expect_identical(p$own_weight, c(NA_real_, NA_real_)) + e <- attr(p, "estimate") + expect_true(e$constant) + expect_identical(e$loo_one_cell, NA_real_) + expect_identical(e$loo_one_cell_se, NA_real_) + # What does not read the values is computed. + expect_true(all(is.finite(p$scored_per_cell))) + expect_true(all(is.finite(p$share_alone))) + out <- utils::capture.output(print(p)) + expect_true(any(grepl("one cell: loo NA (the response is constant)", out, fixed = TRUE))) + # The warning is the one the call raises without an estimate. + none <- .co_catch(.co_profile(pts, estimate = NULL, obs_per_cell = c(18, 4.5))) + expect_identical(.co_texts(none), .co_texts(r), info = est) + } + # A response that varies by rounding error alone is constant by the same rule. + pts$z <- 1e6 + 1e-9 * sin(seq_len(600)) + p <- suppressWarnings(.co_profile(pts, estimate = "pooled", obs_per_cell = 4.5)) + expect_true(attr(p, "estimate")$constant) + expect_identical(p$loo, NA_real_) +}) + +test_that("rows that share locations raise spatialkit_repeated_locations once", { + # 200 stations, three visits each. + pts <- .co_600() + sf::st_geometry(pts) <- sf::st_geometry(pts)[rep(1:200, 3)] + for (est in c("mean", "pooled")) { + r <- .co_catch(.co_profile(pts, estimate = est, obs_per_cell = c(18, 9))) + expect_identical(.co_classes(r), "spatialkit_repeated_locations", info = est) + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + paste0("resolution_profile(): 600 of the 600 rows with a value of 'z' share a ", + "location with another row. The leave-one-out error leaves one row out ", + "and keeps the others at its location, so it, and an interval built ", + "from it, describes a further observation at a place already observed, ", + "not an observation at a new place.")) + expect_identical(.co_fields(w), list(n = 600L, total = 600L, column = "z")) + expect_null(conditionCall(w)) + expect_true(all(is.finite(r$value$loo)), info = est) + } + # It is said after the levels are scored, of a `loo` the profile holds. + events <- character(0) + real <- .partition_centres + force(real) + local({ + testthat::local_mocked_bindings(.partition_centres = function(...) { + events <<- c(events, "fit") + real(...) + }) + withCallingHandlers(.co_profile(pts, estimate = "pooled", obs_per_cell = c(18, 9)), + warning = function(w) { + events <<- c(events, class(w)[1L]) + invokeRestart("muffleWarning") + }) + }) + expect_identical(events, c("fit", "fit", "spatialkit_repeated_locations")) + # Some rows share and some do not: the rows that share are counted. + part <- .co_600() + sf::st_geometry(part)[1:10] <- sf::st_geometry(part)[11:20] + r <- .co_catch(.co_profile(part, estimate = "pooled", obs_per_cell = 9)) + expect_identical(.co_of(r, "spatialkit_repeated_locations")[[1L]]$n, 20L) + expect_identical(.co_of(r, "spatialkit_repeated_locations")[[1L]]$total, 600L) + # `total` is the rows with a value, not the points of the layer. + holes <- part + holes$z[501:600] <- NA + r <- .co_catch(.co_profile(holes, estimate = "pooled", obs_per_cell = 9)) + w <- .co_of(r, "spatialkit_repeated_locations")[[1L]] + expect_identical(.co_fields(w), list(n = 20L, total = 500L, column = "z")) + expect_match(conditionMessage(w), "20 of the 500 rows with a value of 'z' share a location", + fixed = TRUE) + # A row that shares its location with a row without a response shares it + # with no scored row. + part$z[11:20] <- NA + r <- .co_catch(.co_profile(part, estimate = "pooled", obs_per_cell = 9)) + expect_length(.co_of(r, "spatialkit_repeated_locations"), 0L) + # Without an estimate nothing is left out, and nothing is said. + r <- .co_catch(.co_profile(pts, estimate = NULL, obs_per_cell = c(18, 9))) + expect_length(r$warnings, 0L) + # Nor on a constant response, whose loo is NA. + pts$z <- 3.7 + r <- .co_catch(.co_profile(pts, estimate = "pooled", obs_per_cell = 18)) + expect_identical(.co_classes(r), "spatialkit_constant_response") +}) + +test_that("with repeated locations each row is left out alone", { + skip_if_not_installed("FNN") + # Two visits to each of 300 stations: a row's nearest other row is the + # other visit, which pool_nearest_other() does not serve, so the pooled + # value, which needs no nearest row, is the one held to the reference. + pts <- .co_600() + sf::st_geometry(pts) <- sf::st_geometry(pts)[rep(1:300, 2)] + xy <- .co_xy(pts) + p <- suppressWarnings(.co_profile(pts, estimate = "pooled", obs_per_cell = c(9, 3))) + for (i in 1:2) { + rg <- .co_regions(xy, attr(p, "centres")[[i]]) + fr <- fit_regions(rg$gi, rg$gi, pts$z, xy, xy, nn1 = seq_len(600)) + expect_equal(p$loo[i], fr$loo_L, tolerance = 1e-10) + expect_equal(p$own_weight[i], stats::median(fr$w), tolerance = 1e-10) + # Both visits of a station are in one cell, so no row is alone in its cell. + expect_identical(p$share_alone[i], 0) + } +}) + + +# ---- Without FNN --------------------------------------------------------------- + +test_that("without FNN every column of the profile is the run's with it", { + skip_if_not_installed("FNN") + pts <- .co_1200() + for (kind in c("kmeans", "density")) for (est in c("mean", "pooled")) { + what <- paste(kind, est) + with <- .co_profile(pts, partition = kind, estimate = est, obs_per_cell = c(9, 4.5, 2)) + without <- local({ + .co_without_fnn() + # Nothing reaches the kd-tree: every step is told the answer. + testthat::local_mocked_bindings( + get.knn = function(...) stop("FNN::get.knn() was reached"), + get.knnx = function(...) stop("FNN::get.knnx() was reached"), .package = "FNN") + .co_profile(pts, partition = kind, estimate = est, obs_per_cell = c(9, 4.5, 2)) + }) + expect_lt(max(with$levels), 5000L) + for (col in setdiff(names(with), c("moran_i", "moran_z"))) + expect_identical(without[[col]], with[[col]], info = paste(what, col)) + # Their weights are then held as a dense matrix. + expect_equal(without$moran_i, with$moran_i, tolerance = 1e-10, info = what) + expect_equal(without$moran_z, with$moran_z, tolerance = 1e-10, info = what) + expect_identical(attr(without, "estimate"), attr(with, "estimate"), info = what) + expect_identical(attr(without, "centres"), attr(with, "centres"), info = what) + expect_identical(attr(without, "bounds"), attr(with, "bounds"), info = what) + expect_gt(with$share_alone[3L], 0) + } +}) + +test_that("a profile asks for each backend once and hands the answers down", { + pts <- .co_600() + asked <- character(0) + counting <- function(expr) { + asked <<- character(0) + testthat::local_mocked_bindings(.has_backend = function(pkg) { + asked <<- c(asked, pkg) + requireNamespace(pkg, quietly = TRUE) + }) + suppressWarnings(expr) + sort(asked) + } + for (est in list("mean", "pooled", NULL)) { + # A ladder of sizes, three levels. + expect_identical(counting(.co_profile(pts, estimate = est, obs_per_cell = c(9, 4.5, 2))), + c("FNN", "Matrix")) + # A ladder given as `levels`, of the kind "kmeans". + expect_identical(counting(.co_profile(pts, partition = "kmeans", nstart = 2, estimate = est, + obs_per_cell = NULL, sac = 20000, + levels = c(12L, 40L, 90L))), + c("FNN", "Matrix")) + } + # Each is asked for when a step first needs the answer, so a profile none + # of whose steps reads one asks for neither: a geometry-only profile of the + # kind "kmeans" loads no optional package, as it never has. + expect_identical(counting(.co_profile(pts, response = NULL, partition = "kmeans", nstart = 2, + estimate = NULL, obs_per_cell = NULL, sac = NULL, + n_levels = 3)), + character(0)) + expect_identical(counting(.co_profile(pts, response = NULL, partition = "kmeans", nstart = 2, + estimate = NULL, obs_per_cell = c(18, 9), sac = "auto")), + character(0)) + # The density kind reads FNN for its fits, and nothing reads Matrix. + expect_identical(counting(.co_profile(pts, response = NULL, estimate = NULL, + obs_per_cell = c(18, 9))), + "FNN") + # A response on three cells has no Moran step, which is what reads both. + expect_identical(counting(.co_profile(pts, partition = "kmeans", nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = 20000, levels = 3L)), + character(0)) + # An estimate reads FNN for each row's nearest centre. + expect_identical(counting(.co_profile(pts, partition = "kmeans", nstart = 2, estimate = "pooled", + obs_per_cell = NULL, sac = 20000, levels = 3L)), + "FNN") + # A call the fit guard stops has asked only what the guard reads: nothing + # for the kind "kmeans" that passes, and FNN for the condition it stops with. + withr::local_options(spatialkit.fit_work_max = 1) + expect_identical(counting(tryCatch(.co_profile(pts, response = NULL, partition = "kmeans", + nstart = 2, estimate = NULL, obs_per_cell = 9), + error = function(e) NULL)), + "FNN") +}) + +test_that("without FNN the present ladder's steps are told so as well", { + skip_if_not_installed("FNN") + skip_if_not_installed("gstat") + pts <- .co_600() + call <- function() suppressWarnings( + .co_profile(pts, estimate = "mean", obs_per_cell = NULL, sac = 20000, levels = c(20L, 90L))) + with <- call() + without <- local({ + .co_without_fnn() + testthat::local_mocked_bindings( + get.knn = function(...) stop("FNN::get.knn() was reached"), + get.knnx = function(...) stop("FNN::get.knnx() was reached"), .package = "FNN") + call() + }) + for (col in setdiff(names(with), c("moran_i", "moran_z"))) + expect_identical(without[[col]], with[[col]], info = col) + expect_equal(without$moran_z, with$moran_z, tolerance = 1e-10) +}) + +test_that("without FNN the search of each row's nearest centre is bounded", { + pts <- .co_600() + call <- function(...) { + .co_without_fnn() + testthat::local_mocked_bindings(.partition_centres = function(...) stop("a fit was reached")) + .co_error(.co_profile(pts, partition = "kmeans", nstart = 2, ...)) + } + withr::local_options(spatialkit.exact_pairs_max = 600 * 133 - 1) + e <- call(estimate = "pooled", obs_per_cell = c(18, 4.5)) + expect_identical(class(e), c("spatialkit_work_limit", "error", "condition")) + # The scored rows times the centres of the finest level, before any fit. + expect_identical(.co_fields(e), list(work = 600 * 133, limit = 600 * 133 - 1, + what = "nearest centre")) + expect_identical(conditionMessage(e), + paste0("resolution_profile(): finding the nearest of 133 centres for each of 600 ", + "rows would compare 8e+04 pairs without the FNN package, above the limit ", + "of 8e+04 (options(spatialkit.exact_pairs_max = )). Install FNN: the ", + "result is the same.")) + expect_null(conditionCall(e)) + # At the limit the search runs: the fit is reached. + withr::local_options(spatialkit.exact_pairs_max = 600 * 133) + expect_identical(conditionMessage(call(estimate = "pooled", obs_per_cell = c(18, 4.5))), + "a fit was reached") + # Without an estimate no row is sent to a centre. + withr::local_options(spatialkit.exact_pairs_max = 0) + expect_identical(conditionMessage(call(estimate = NULL, obs_per_cell = c(18, 4.5))), + "a fit was reached") + # On the ladder the function builds, the same search is bounded the same way. + e <- call(estimate = "pooled", obs_per_cell = NULL, sac = 20000, levels = c(10L, 40L)) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "nearest centre") + expect_identical(e$work, 600 * 40) + # The rows counted are the scored rows, not the points: a response on half + # of the rows, 300 rows in the 67 cells their size gives. + half <- pts + half$z[seq(2, 600, by = 2)] <- NA + e <- local({ + .co_without_fnn() + testthat::local_mocked_bindings(.partition_centres = function(...) stop("a fit was reached")) + .co_error(.co_profile(half, partition = "kmeans", nstart = 2, estimate = "pooled", + obs_per_cell = 4.5)) + }) + expect_identical(.co_fields(e), list(work = 300 * 67, limit = 0, what = "nearest centre")) + expect_match(conditionMessage(e), "finding the nearest of 67 centres for each of 300 rows", + fixed = TRUE) +}) + + +test_that("the nearest other location of a location is searched once for the whole profile", { + skip_if_not_installed("FNN") + pts <- .co_600() + real <- .nearest_location_search + force(real) + asked <- list() + spy <- function(u, q, ...) { + asked[[length(asked) + 1L]] <<- q + real(u, q, ...) + } + run <- function(est, fnn = TRUE) { + testthat::local_mocked_bindings(.nearest_location_search = spy) + if (!fnn) .co_without_fnn() + .co_profile(pts, estimate = est, obs_per_cell = c(9, 4.5, 2)) + } + # With FNN: one search, of every location, before the sweep. + with <- run("mean") + expect_length(asked, 1L) + expect_identical(sort(asked[[1L]]), 1:600) + expect_gt(with$share_alone[3L], 0.05) + # Without FNN: on first need, level by level, and no location twice. + asked <- list() + without <- run("mean", fnn = FALSE) + expect_gt(length(asked), 1L) + expect_identical(anyDuplicated(unlist(asked)), 0L) + expect_lt(length(unlist(asked)), 600L) + expect_identical(without$loo, with$loo) + # A pooled value is predicted from its target: no nearest row is looked for. + asked <- list() + run("pooled") + expect_length(asked, 0L) +}) + + +# ---- The criterion against the error at new locations --------------------------- + +test_that("loo tracks the squared error at new sites drawn like the data", { + skip_on_cran() + # Twenty fields. 1,600 sites uniform on a 1000 x 1000 square, x then y; an + # exponential covariance with range parameter 100 (an effective range of + # 300), sill 1 and nugget 0.1. The first 600 sites are the layer and the + # other 1,000 are new. + nearest_row <- function(from, to) + vapply(seq_len(nrow(from)), function(i) + which.min((to[, 1] - from[i, 1])^2 + (to[, 2] - from[i, 2])^2), integer(1)) + ratio <- array(NA_real_, c(20L, 2L, 2L), + dimnames = list(NULL, c("mean", "pooled"), c("4.5", "2"))) + for (r in 1:20) { + d <- local({ + .co_seed(1000 + r) + x <- stats::runif(1600, 0, 1000); y <- stats::runif(1600, 0, 1000) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- t(chol(exp(-D / 100) + diag(1e-10, 1600))) %*% stats::rnorm(1600) + + stats::rnorm(1600, 0, sqrt(0.1)) + list(xy = cbind(x, y), z = as.numeric(z)) + }) + tr <- 1:600; te <- 601:1600 + pts <- .co_points(d$xy[tr, 1], d$xy[tr, 2], d$z[tr]) + for (size in c(4.5, 2)) for (est in c("mean", "pooled")) { + p <- resolution_profile(pts, "z", estimate = est, obs_per_cell = size, + partition = "density", nstart = 3, sac = "auto", seed = 123) + cen <- attr(p, "centres")[[1L]] + rg <- .co_regions(d$xy[tr, ], cen) + fit <- .pool_fit(d$z[tr], rg$gi, rg$K, d$xy[tr, ], want = est) + val <- if (est == "mean") fit$m else fit$value + # A new site takes the value of the cell of its nearest centre; one + # whose cell holds no row, that of the cell of its nearest scored row. + at <- match(.nearest_centre(d$xy[te, 1], d$xy[te, 2], cen[, 1], cen[, 2]), rg$u) + if (anyNA(at)) { + empty <- which(is.na(at)) + at[empty] <- rg$gi[nearest_row(d$xy[te[empty], , drop = FALSE], d$xy[tr, ])] + } + ratio[r, est, as.character(size)] <- p$loo / mean((d$z[te] - val[at])^2) - 1 + } + } + expect_false(anyNA(ratio)) + mean_ratio <- apply(ratio, c(2, 3), mean) + # The run this band was set from gave -2.9 and +0.7 percent for plain means + # and -3.3 and -1.2 for pooled values, at 4.5 and 2 rows a cell. + expect_true(all(abs(mean_ratio) < 0.10), info = paste(format(mean_ratio, digits = 3), + collapse = " ")) + # Single fields vary by more than the band (-17 to +15 percent in that + # run), which is why the mean is asserted and no single field is. +}) diff --git a/tests/testthat/test-core-count-rule.R b/tests/testthat/test-core-count-rule.R new file mode 100644 index 00000000..d5a29e7d --- /dev/null +++ b/tests/testthat/test-core-count-rule.R @@ -0,0 +1,1257 @@ +# tests/testthat/test-core-count-rule.R +# --------------------------------------------------------------------------- +# The record of how a cell count was set, from the selection to the summary: +# where it sits, what `scored_cells` says beside each layer of seeds, and the +# two checks summarize_by_cell() runs against it (the estimate; the cells +# and the rows), with every case in which the second is skipped. +# +# Every profile names `partition`, `nstart`, `estimate`, `obs_per_cell` and +# `sac`, every selection its `criterion`, every summary its `estimate`, and +# every seeding that places seeds of its own its kind and its starts. +# Unless a test says otherwise the regions are of the density kind from 3 +# k-means++ starts under seed 123. A layer is drawn under the seed its test +# states: the locations (x, then y), then the response. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.cr_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +# `n` locations uniform on a square of side 1e5 with its corner at (5e5, +# 5e6) in EPSG:32617, with the field of the engine's tests, sin(x / 2e4) + +# cos(y / 1.5e4) plus normal noise of standard deviation 1.5. +.cr_layer <- function(n, seed) { + d <- local({ + .cr_seed(seed) + x <- stats::runif(n, 0, 1e5); y <- stats::runif(n, 0, 1e5) + data.frame(x = 5e5 + x, y = 5e6 + y, + z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(n, 0, 1.5)) + }) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32617) +} + +.cr_profile <- function(pts, ..., response = "z", partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = 4.5, seed = 123) + resolution_profile(pts, response, ..., partition = partition, nstart = nstart, sac = sac, + estimate = estimate, obs_per_cell = obs_per_cell, seed = seed) + +# A call with its warnings kept and muffled. +.cr_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.cr_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.cr_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.cr_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] +.cr_print <- function(x) utils::capture.output(print(x)) + +.cr_store <- new.env(parent = emptyenv()) +.cr_keep <- function(key, expr) { + if (is.null(.cr_store[[key]])) .cr_store[[key]] <- expr + .cr_store[[key]] +} +.cr_sizes <- c(18, 12, 9, 6, 4.5, 3, 2) +# The fields of the record, in order. +.cr_names <- c("version", "rule", "estimate", "cells", "obs_per_cell", "obs_per_cell_asked", + "response", "n", "n_points", "n_fit", "seed", "features", "scored", + "partition", "crs", "scored_cells") + +# 600 rows (seed 5101). Its pooled profile at 4.5 rows a cell has 133 +# cells; its profile of plain means on the seven sizes has its lowest +# leave-one-out error at 50 cells, a level inside the ladder. Neither path +# raises a warning from the profile to the summary. +.cr_600 <- function() .cr_keep("l600", .cr_layer(600, 5101)) +.cr_pooled <- function() .cr_keep("pooled", .cr_profile(.cr_600())) +.cr_mean7 <- function() + .cr_keep("mean7", .cr_profile(.cr_600(), estimate = "mean", obs_per_cell = .cr_sizes)) +.cr_size <- function() .cr_keep("size", select_resolution(.cr_pooled(), criterion = "size")) +.cr_loo <- function() .cr_keep("loo", select_resolution(.cr_mean7(), criterion = "loo")) + +# The calls from a count to the assigned layer. +.cr_cells <- function(pts, n, ...) { + seeds <- get_voronoi_seeds(method = "kmeans", n = n, sample_points = pts, ...) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + list(seeds = seeds, tess = tess, asg = asg) +} +.cr_A <- function() .cr_keep("A", .cr_cells(.cr_600(), .cr_size())) # sized for pooled values +.cr_B <- function() .cr_keep("B", .cr_cells(.cr_600(), .cr_loo())) # chosen for plain means +# The same layer with no response east of x = 550,000: the centres are fitted +# to all 600 points and the size divides the 299 rows with a response, so +# the count (66) is not the number of cells that hold a scored row (37 of +# them on the machine this was written on; about half on any). +.cr_gap <- function() .cr_keep("gap", { + pts <- .cr_600() + pts$z[sf::st_coordinates(pts)[, 1L] > 5.5e5] <- NA + sel <- select_resolution(suppressWarnings(.cr_profile(pts)), criterion = "size") + c(list(pts = pts, sel = sel), .cr_cells(pts, sel)) +}) +.cr_sum <- function(asg, cells, estimate, response = "z", ...) + .cr_catch(summarize_by_cell(asg, response, id_col = "cell_id", cells_sf = cells, + estimate = estimate, ...)) +.cr_check <- function(r) attr(r$value, "count_rule")$check +.cr_bnd <- function(pts) sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + + +# ---- Where no record is written ------------------------------------------------ + +test_that("a count given as a number, or read by a present criterion off a profile without an estimate, carries no record", { + pts <- .cr_600() + bare <- function(x) is.null(attr(x, "count_rule")) + none <- function(P) { + expect_true(bare(P$seeds)) + expect_false("count_rule" %in% names(P$tess$params)) + expect_true(bare(P$tess$cells)) + expect_true(bare(P$asg)) + for (est in c("mean", "pooled")) { + r <- suppressWarnings(.cr_sum(P$asg, P$tess$cells, est)) + expect_true(bare(r$value)) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) + expect_length(.cr_of(r, "spatialkit_estimate_mismatch"), 0L) + } + } + # A number. + none(.cr_cells(pts, 40, set_seed = 1, partition = "kmeans", kmeans_nstart = 10)) + expect_true(bare(voronoi_seeds_kmeans(pts, 40, partition = "kmeans", nstart = 10))) + expect_true(bare(get_voronoi_seeds(.cr_bnd(pts), method = "random", n = 40, set_seed = 1))) + hex <- build_tessellation(pts, boundary = .cr_bnd(pts), method = "hex", approx_n_cells = 40, + quiet = TRUE) + expect_false("count_rule" %in% names(hex$params)) + expect_true(bare(hex$cells)) + # A profile as it is built without the new arguments, read by cp: as a + # selection, and as the count itself. + plain <- suppressWarnings( + .cr_profile(pts, n_levels = 6L, partition = "kmeans", nstart = 5, sac = 3e4, + estimate = NULL, obs_per_cell = NULL)) + sel <- select_resolution(plain, criterion = "cp") + expect_null(sel$count_rule) + none(suppressWarnings(.cr_cells(pts, sel))) + none(suppressWarnings(.cr_cells(pts, plain))) + expect_true(bare(suppressWarnings(voronoi_seeds_kmeans(pts, sel)))) + hex <- suppressWarnings(build_tessellation(pts, boundary = .cr_bnd(pts), method = "hex", + approx_n_cells = sel, quiet = TRUE)) + expect_false("count_rule" %in% names(hex$params)) + expect_true(bare(hex$cells)) +}) + +test_that("cells the caller brings have no record and are not checked", { + pts <- .cr_600() + units <- sf::st_sf(GEOID = sprintf("u%02d", 1:16), + geometry = sf::st_make_grid(.cr_bnd(pts), n = c(4, 4))) + asg <- assign_features_to_polygons(pts, units, polygon_id_col = "GEOID", quiet = TRUE) + expect_null(attr(asg, "count_rule")) + for (est in c("mean", "pooled")) { + r <- .cr_catch(summarize_by_cell(asg, "z", id_col = "GEOID", cells_sf = units, + estimate = est)) + expect_null(attr(r$value, "count_rule")) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) + expect_length(.cr_of(r, "spatialkit_estimate_mismatch"), 0L) + } +}) + + +# ---- Where the record sits ------------------------------------------------------ + +test_that("the record travels from the selection to the summary, and says beside the seeds that they are the scored centres", { + pts <- .cr_600(); sel <- .cr_size(); A <- .cr_A() + rec <- sel$count_rule + expect_identical(names(rec), .cr_names) + expect_s3_class(rec, "spatialkit_count_rule") + # Beside no centres in the selection; beside the scored centres on its seeds. + expect_identical(rec$scored_cells, NA) + expect_identical(attr(sel$seeds, "count_rule")$scored_cells, TRUE) + on_seeds <- rec; on_seeds$scored_cells <- TRUE + expect_identical(attr(sel$seeds, "count_rule"), on_seeds) + + expect_identical(attr(A$seeds, "count_rule"), on_seeds) + expect_identical(A$tess$params$count_rule, on_seeds) + expect_identical(attr(A$tess$cells, "count_rule"), on_seeds) + expect_identical(attr(A$asg, "count_rule"), on_seeds) + # The seeds, the cells and the assigned rows are otherwise those of the + # same selection without a record. + no_rec <- sel; no_rec$count_rule <- NULL + attr(no_rec$seeds, "count_rule") <- NULL + N <- .cr_cells(pts, no_rec) + expect_null(attr(N$seeds, "count_rule")) + expect_false("count_rule" %in% names(N$tess$params)) + without <- function(x) { attr(x, "count_rule") <- NULL; x } + expect_identical(without(A$seeds), N$seeds) + expect_identical(without(A$tess$cells), N$tess$cells) + expect_identical(without(A$asg), N$asg) + expect_identical(A$tess$params[names(N$tess$params)], N$tess$params) + expect_identical(setdiff(names(A$tess$params), names(N$tess$params)), "count_rule") + expect_identical(utils::tail(names(A$tess$params), 2L), c("partition", "count_rule")) + + r <- .cr_sum(A$asg, A$tess$cells, "pooled") + expect_identical(.cr_classes(r), character(0)) + got <- attr(r$value, "count_rule") + expect_identical(names(got), c(.cr_names, "check")) + expect_s3_class(got, "spatialkit_count_rule") + expect_identical(got$check, list(estimate = "match", cells = "match")) + got$check <- NULL + expect_identical(got, on_seeds) + # A frame without `cells_sf` carries it too. + r <- .cr_catch(summarize_by_cell(A$asg, "z", id_col = "cell_id", estimate = "pooled")) + expect_identical(attr(r$value, "count_rule")$check, list(estimate = "match", cells = "match")) + expect_false(inherits(r$value, "sf")) + + # voronoi_seeds_kmeans() hands on the same centres with the same record. + vk <- voronoi_seeds_kmeans(pts, sel) + expect_identical(attr(vk, "count_rule"), on_seeds) + expect_identical(sf::st_geometry(vk), sf::st_geometry(A$seeds)) + # create_voronoi_polygons() writes it where build_tessellation() does. + vor <- create_voronoi_polygons(A$seeds, quiet = TRUE) + expect_identical(vor$params$count_rule, on_seeds) + expect_identical(attr(vor$cells, "count_rule"), on_seeds) + # A profile with an estimate passed as the count is read by "auto", and + # its seeds carry the record of that reading. + P <- .cr_cells(pts, .cr_pooled()) + expect_identical(attr(P$seeds, "count_rule"), on_seeds) + expect_identical(.cr_check(.cr_sum(P$asg, P$tess$cells, "pooled")), + list(estimate = "match", cells = "match")) +}) + +test_that("the record stays on the seeds and the cells through a boundary and a change of CRS", { + pts <- .cr_600(); sel <- .cr_size() + on_seeds <- attr(sel$seeds, "count_rule") + bnd <- .cr_bnd(pts) + # A boundary in another CRS: the seeds come back in it. + ll <- get_voronoi_seeds(sf::st_transform(bnd, 4326), method = "kmeans", n = sel) + expect_true(sf::st_is_longlat(ll)) + expect_identical(attr(ll, "count_rule"), on_seeds) + expect_identical(attr(voronoi_seeds_kmeans(sf::st_transform(pts, 4326), sel), "count_rule"), + on_seeds) + # Cells returned in a geographic CRS. + tess <- build_tessellation(.cr_A()$seeds, method = "voronoi", crs = 4326, quiet = TRUE) + expect_true(sf::st_is_longlat(tess$cells)) + expect_identical(attr(tess$cells, "count_rule"), on_seeds) + expect_identical(tess$params$count_rule, on_seeds) + # The record names the CRS the profile worked in, whatever the seeds are in. + expect_identical(attr(ll, "count_rule")$crs, sf::st_crs(pts)) +}) + + +# ---- scored_cells --------------------------------------------------------------- + +test_that("seeds a function places itself at the count are marked as not the scored centres", { + pts <- .cr_600(); sel <- .cr_size(); bnd <- .cr_bnd(pts) + rec_false <- sel$count_rule; rec_false$scored_cells <- FALSE + # A selection whose seeds were removed: a partition of the function's own. + bare_sel <- sel; bare_sel$seeds <- NULL + fresh <- get_voronoi_seeds(method = "kmeans", n = bare_sel, sample_points = pts, set_seed = 1, + partition = "kmeans", kmeans_nstart = 10) + expect_identical(nrow(fresh), 133L) + expect_identical(attr(fresh, "count_rule"), rec_false) + expect_identical(attr(voronoi_seeds_kmeans(pts, bare_sel, partition = "kmeans", nstart = 10), + "count_rule"), rec_false) + # Seeds that are not at the count are no more the scored centres. + short <- sel; short$seeds <- sel$seeds[1:50, ] + expect_identical(attr(get_voronoi_seeds(method = "kmeans", n = short, sample_points = pts, + set_seed = 1, partition = "kmeans", + kmeans_nstart = 10), "count_rule"), rec_false) + # method = "random" takes the count and places its own seeds. + rnd <- get_voronoi_seeds(bnd, method = "random", n = sel, set_seed = 3) + expect_identical(nrow(rnd), 133L) + expect_identical(attr(rnd, "count_rule"), rec_false) + # The cells built on such seeds say the same. + tess <- build_tessellation(fresh, method = "voronoi", quiet = TRUE) + expect_identical(tess$params$count_rule, rec_false) + expect_identical(attr(tess$cells, "count_rule"), rec_false) +}) + +test_that("method = \"provided\" writes no record, and hands on the one its seeds carry", { + pts <- .cr_600(); sel <- .cr_size() + r <- .cr_catch(get_voronoi_seeds(method = "provided", n = sel, seeds = pts[1:20, ])) + expect_null(attr(r$value, "count_rule")) + expect_match(conditionMessage(r$warnings[[1L]]), "method = 'provided' ignores 'n'", fixed = TRUE) + expect_null(attr(get_voronoi_seeds(method = "provided", seeds = pts[1:20, ]), "count_rule")) + # The selection's own seeds, whole: still the scored centres. + whole <- get_voronoi_seeds(method = "provided", seeds = sel$seeds) + expect_identical(attr(whole, "count_rule"), attr(sel$seeds, "count_rule")) + # Twenty of them carry a record of 133 cells, and are not those centres. + part <- get_voronoi_seeds(method = "provided", seeds = sel$seeds[1:20, ]) + expect_identical(attr(sel$seeds[1:20, ], "count_rule")$scored_cells, TRUE) + expect_identical(attr(part, "count_rule")$scored_cells, FALSE) + expect_identical(attr(part, "count_rule")$cells, 133L) + # More of them than the count are no more those centres than fewer are. + more <- rbind(sel$seeds, sel$seeds[1:5, ]) + attr(more, "count_rule") <- attr(sel$seeds, "count_rule") + expect_identical(nrow(more), 138L) + expect_identical(attr(get_voronoi_seeds(method = "provided", seeds = more), + "count_rule")$scored_cells, FALSE) + # The seeds are counted against the count, not against the cells that + # hold a scored row: all 66 centres of a layer on which about half hold one. + G <- .cr_gap() + expect_identical(nrow(G$sel$seeds), 66L) + expect_identical(attr(get_voronoi_seeds(method = "provided", seeds = G$sel$seeds), + "count_rule")$scored_cells, TRUE) +}) + +test_that("a lattice sized by a selection carries the record as not the scored cells; a cellsize sizes it alone", { + pts <- .cr_600(); sel <- .cr_size(); bnd <- .cr_bnd(pts) + rec_false <- sel$count_rule; rec_false$scored_cells <- FALSE + for (method in c("hex", "square")) { + grid <- suppressWarnings(build_tessellation(pts, boundary = bnd, method = method, + approx_n_cells = sel, quiet = TRUE)) + expect_identical(grid$params$count_rule, rec_false, info = method) + expect_identical(attr(grid$cells, "count_rule"), rec_false, info = method) + expect_identical(utils::tail(names(grid$params), 1L), "count_rule") + } + sized <- suppressWarnings(build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = sel, cellsize = 9000, + quiet = TRUE)) + expect_false("count_rule" %in% names(sized$params)) + expect_null(attr(sized$cells, "count_rule")) + # A Voronoi tessellation does not read the count, and takes no record from it. + vor <- suppressWarnings(build_tessellation(pts, method = "voronoi", approx_n_cells = sel, + quiet = TRUE)) + expect_false("count_rule" %in% names(vor$params)) + expect_null(attr(vor$cells, "count_rule")) +}) + +test_that("the selection's seeds, tessellated as they are, lead to a summary that is checked", { + pts <- .cr_600(); sel <- .cr_size() + expect_identical(sel$count_rule$scored_cells, NA) + expect_identical(attr(sel$seeds, "count_rule")$scored_cells, TRUE) + tess <- build_tessellation(sel$seeds, method = "voronoi", quiet = TRUE) + expect_identical(attr(tess$cells, "count_rule")$scored_cells, TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", quiet = TRUE) + r <- .cr_sum(asg, tess$cells, "pooled") + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + expect_identical(.cr_classes(r), character(0)) + # Twenty of them are other cells, and the check says so. + tess <- build_tessellation(sel$seeds[1:20, ], method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", quiet = TRUE) + r <- .cr_sum(asg, tess$cells, "pooled") + expect_identical(.cr_check(r)$cells, "differ") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + expect_identical(w[[1L]]$what, "cells") + expect_identical(w[[1L]]$found$cells, 20L) +}) + + +# ---- The estimate --------------------------------------------------------------- + +test_that("a summary of the estimate the count was chosen for is checked without a word", { + A <- .cr_A(); B <- .cr_B() + for (case in list(list(A, "pooled"), list(B, "mean"))) { + r <- .cr_sum(case[[1L]]$asg, case[[1L]]$tess$cells, case[[2L]]) + expect_identical(.cr_classes(r), character(0)) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + } + expect_identical(attr(B$asg, "count_rule")$rule, "loo") + expect_identical(attr(B$asg, "count_rule")$cells, 50L) +}) + +test_that("plain means on cells sized for pooled values are a mismatch, and the frame is the one asked for", { + A <- .cr_A() + r <- .cr_sum(A$asg, A$tess$cells, "mean") + expect_identical(.cr_classes(r), "spatialkit_estimate_mismatch") + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), paste0( + "summarize_by_cell(): the number of cells (133, set by size) was chosen for the pooled ", + "value, and this summary reports the plain mean. At this cell size plain means of small ", + "cells are noisy: pass estimate = \"pooled\", or choose the count for plain means ", + "(resolution_profile(estimate = \"mean\")).")) + expect_identical(.cr_fields(w), + list(chosen_for = "pooled", reported = "mean", rule = "size", cells = 133L)) + expect_null(conditionCall(w)) + # The cells and rows are still the ones scored: checked with a fit of the + # estimate the profile scored. + expect_identical(.cr_check(r), list(estimate = "mismatch", cells = "match")) + # The frame is the one the same call returns on the same cells and rows + # without a record. + asg <- A$asg; cells <- A$tess$cells + attr(asg, "count_rule") <- NULL; attr(cells, "count_rule") <- NULL + plain <- .cr_sum(asg, cells, "mean") + expect_identical(.cr_classes(plain), character(0)) + expect_null(attr(plain$value, "count_rule")) + got <- r$value + expect_identical(setdiff(names(attributes(got)), names(attributes(plain$value))), "count_rule") + attr(got, "count_rule") <- NULL + expect_identical(got, plain$value) + # With the pooled values asked for, the same holds of the pooled frame. + pooled <- .cr_sum(A$asg, A$tess$cells, "pooled") + bare <- .cr_sum(asg, cells, "pooled") + got <- pooled$value + attr(got, "count_rule") <- NULL + expect_identical(got, bare$value) +}) + +test_that("pooled values on cells chosen for plain means are a mismatch in the other words", { + B <- .cr_B() + r <- .cr_sum(B$asg, B$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_estimate_mismatch") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), paste0( + "summarize_by_cell(): the number of cells (50, set by loo) was chosen for the plain mean, ", + "and this summary reports the pooled value. Pooled values are valid on these cells; the ", + "count that suits them is set by a size (criterion = \"size\").")) + expect_identical(.cr_fields(w[[1L]]), + list(chosen_for = "mean", reported = "pooled", rule = "loo", cells = 50L)) + # The record scored plain means, so the check fits those, beside the + # pooled values the call asked for. + expect_identical(.cr_check(r), list(estimate = "mismatch", cells = "match")) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) +}) + +test_that("where centres hold no scored row the count is the centres, and the record keeps both numbers", { + G <- .cr_gap() + rec <- G$sel$count_rule + expect_identical(rec$cells, 66L) + occupied <- rec$scored$cells + expect_gt(occupied, 25L) + expect_lt(occupied, 50L) + expect_identical(c(rec$n, rec$scored$n, rec$n_points), c(299L, 299L, 600L)) + expect_identical(nrow(G$tess$cells), 66L) + # The path is the one scored, under either estimate. + r <- .cr_sum(G$asg, G$tess$cells, "pooled") + expect_identical(.cr_classes(r), character(0)) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + r <- .cr_sum(G$asg, G$tess$cells, "mean") + expect_identical(.cr_classes(r), "spatialkit_estimate_mismatch") + expect_identical(.cr_check(r), list(estimate = "mismatch", cells = "match")) + # The warning names the count, in its text and in its field. + w <- r$warnings[[1L]] + expect_match(conditionMessage(w), + "the number of cells (66, set by size) was chosen for the pooled value", + fixed = TRUE) + expect_identical(.cr_fields(w), + list(chosen_for = "pooled", reported = "mean", rule = "size", cells = 66L)) + # So does the print, with the cells that hold a scored row on their line. + out <- .cr_print(attr(r$value, "count_rule")) + expect_identical(out[1L], + "Count: 66 cells, set by size (4.5 rows per cell asked; 299 rows / 66 cells = 4.53)") + expect_match(out[6L], sprintf("on 299 rows in %d cells (one cell: ", occupied), fixed = TRUE) + # Rows removed are reported against the occupied cells and the rows scored. + r <- .cr_sum(G$asg[!is.na(G$asg$z), ][-(1:20), ], G$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ")[[1L]] + expect_identical(w$what, "n") + expect_identical(w$scored[c("n", "cells")], list(n = 299L, cells = occupied)) + expect_identical(w$found$n, 279L) +}) + +test_that("a count cp chose on a pooled profile was chosen for plain means", { + pts <- .cr_600() + prof <- suppressWarnings(.cr_profile(pts, levels = c(50, 133, 300), sac = 3e4, + obs_per_cell = NULL)) + sel <- select_resolution(prof, criterion = "cp") + expect_identical(sel$count_rule$rule, "cp") + expect_identical(sel$count_rule$estimate, "mean") + expect_identical(sel$count_rule$scored$estimate, "pooled") + C <- suppressWarnings(.cr_cells(pts, sel)) + r <- .cr_sum(C$asg, C$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_estimate_mismatch") + expect_length(w, 1L) + expect_identical(.cr_fields(w[[1L]]), + list(chosen_for = "mean", reported = "pooled", rule = "cp", + cells = as.integer(sel$best))) + expect_match(conditionMessage(w[[1L]]), + sprintf("the number of cells (%d, set by cp) was chosen for the plain mean", + sel$best), fixed = TRUE) + # The profile scored pooled values at that level, and those are compared. + expect_identical(.cr_check(r), list(estimate = "mismatch", cells = "match")) + r <- .cr_sum(C$asg, C$tess$cells, "mean") + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + expect_length(.cr_of(r, "spatialkit_estimate_mismatch"), 0L) +}) + +test_that("a count chosen for neither estimate has no estimate to match", { + pts <- .cr_600() + prof <- suppressWarnings(.cr_profile(pts, levels = c(50, 133, 300), sac = 3e4, + obs_per_cell = NULL)) + sel <- suppressWarnings(select_resolution(prof, criterion = "moran_z", diagnostic = TRUE)) + expect_identical(sel$count_rule$rule, "moran_z") + expect_identical(sel$count_rule$estimate, NA_character_) + C <- suppressWarnings(.cr_cells(pts, sel)) + for (est in c("mean", "pooled")) { + r <- .cr_sum(C$asg, C$tess$cells, est) + expect_length(.cr_of(r, "spatialkit_estimate_mismatch"), 0L) + expect_identical(.cr_check(r), list(estimate = NA_character_, cells = "match")) + } +}) + + +# ---- The cells and the rows ----------------------------------------------------- + +test_that("rows removed from the assigned layer are reported with what the profile scored and what was found", { + A <- .cr_A() + drop <- local({ .cr_seed(11); sample.int(600L, 30L) }) # 5 percent + r <- .cr_sum(A$asg[-drop, ], A$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + w <- w[[1L]] + rec <- attr(A$asg, "count_rule") + found <- attr(r$value, "pooled")$columns$resp_z + expect_identical(.cr_fields(w), + list(what = "n", + scored = list(n = 600L, cells = 133L, loo = rec$scored$loo), + found = list(n = 570L, cells = found$cells, loo = found$loo))) + expect_identical(conditionMessage(w), sprintf(paste0( + "summarize_by_cell(): these are not the cells and rows the count was scored on (the ", + "number of rows differs). The profile scored 600 rows of 'z' in 133 cells with a ", + "leave-one-out error of %s; here 570 rows in %d cells give %s. Rows were dropped or moved ", + "between cells: points outside every cell, a boundary that clips the cells, a subset of ", + "the rows, or another layer."), + format(rec$scored$loo, digits = 6), found$cells, format(found$loo, digits = 6))) + expect_null(conditionCall(w)) + expect_identical(.cr_check(r), list(estimate = "match", cells = "differ")) + # Under plain means too: one more fit of the response, and the same report. + r <- .cr_sum(A$asg[-drop, ], A$tess$cells, "mean") + expect_identical(.cr_classes(r), c("spatialkit_estimate_mismatch", "spatialkit_cells_differ")) + expect_identical(.cr_of(r, "spatialkit_cells_differ")[[1L]]$found, w$found) +}) + +test_that("a boundary that leaves points in no cell is reported, kept or dropped", { + pts <- .cr_600(); A <- .cr_A() + bb <- sf::st_bbox(pts) + small <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox( + c(xmin = bb[["xmin"]] + 5000, ymin = bb[["ymin"]], xmax = bb[["xmax"]], + ymax = bb[["ymax"]]), crs = sf::st_crs(pts)))) + tess <- suppressWarnings(build_tessellation(A$seeds, boundary = small, method = "voronoi", + quiet = TRUE)) + expect_identical(attr(tess$cells, "count_rule")$scored_cells, TRUE) + dropped <- .cr_catch(assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE)) + expect_identical(.cr_classes(dropped), "spatialkit_unassigned") + expect_lt(nrow(dropped$value), 600L) + kept <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE, keep_unassigned = TRUE) + expect_identical(nrow(kept), 600L) + for (asg in list(dropped$value, kept)) { + r <- .cr_sum(asg, tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + expect_identical(w[[1L]]$what, "n") + expect_identical(w[[1L]]$found$n, nrow(dropped$value)) + expect_identical(.cr_check(r)$cells, "differ") + } +}) + +test_that("another layer assigned to the cells is reported", { + A <- .cr_A() + other <- .cr_layer(600, 5102) + asg <- assign_features_to_polygons(other, A$tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + expect_identical(nrow(asg), 600L) + # The assigned layer takes the record of the cells it was assigned to. + expect_identical(attr(asg, "count_rule"), attr(A$tess$cells, "count_rule")) + r <- .cr_sum(asg, A$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + # As many rows; they fill other cells, or the same cells with other values. + expect_identical(w[[1L]]$found$n, 600L) + expect_true(w[[1L]]$what %in% c("cells", "loo")) + expect_identical(.cr_check(r)$cells, "differ") +}) + +test_that("two rows exchanged between neighbouring cells are told from rows dropped", { + A <- .cr_A() + asg <- A$asg + cells <- A$tess$cells + nb <- sf::st_touches(cells) + i <- which(asg$cell_id == cells$cell_id[1L])[1L] + j <- which(asg$cell_id == cells$cell_id[nb[[1L]][1L]])[1L] + swap <- asg$cell_id[c(j, i)] + asg$cell_id[c(i, j)] <- swap + expect_identical(sort(table(asg$cell_id)), sort(table(A$asg$cell_id))) # the counts stand + r <- .cr_sum(asg, cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + w <- w[[1L]] + expect_identical(w$what, "loo") + expect_identical(w$found[c("n", "cells")], w$scored[c("n", "cells")]) + expect_false(isTRUE(all.equal(w$found$loo, w$scored$loo, tolerance = 1e-8))) + text <- conditionMessage(w) + expect_match(text, "(the leave-one-out error differs)", fixed = TRUE) + expect_match(text, paste0( + "The same number of rows and cells was found, so rows sit in other cells than the ", + "profile put them in, or values changed: rows exactly on a boundary between two cells ", + "(gridded locations) can be assigned to the other cell, and coordinates that reached ", + "this CRS by another transformation can settle a tie between neighbouring cells the ", + "other way."), fixed = TRUE) + expect_false(grepl("Rows were dropped or moved between cells", text, fixed = TRUE)) + expect_identical(.cr_check(r)$cells, "differ") + # Values changed on the same rows and cells are the same finding. + asg <- A$asg; asg$z[1L] <- asg$z[1L] + 1 + expect_identical(.cr_of(.cr_sum(asg, cells, "pooled"), "spatialkit_cells_differ")[[1L]]$what, + "loo") +}) + +test_that("cells of another selection than the assigned layer's are named by the field that differs", { + pts <- .cr_600(); A <- .cr_A() + other <- select_resolution(.cr_profile(pts, obs_per_cell = 9), criterion = "size") + C <- .cr_cells(pts, other) + r <- .cr_sum(A$asg, C$tess$cells, "pooled") + w <- .cr_of(r, "spatialkit_cells_differ") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), paste0( + "summarize_by_cell(): `assigned_points_sf` and `cells_sf` carry different count records ", + "(cells: 133 against 67), so the rows were assigned to other cells than the `cells_sf` ", + "given. The record of the assigned layer is used.")) + expect_identical(.cr_fields(w[[1L]]), + list(what = "record", field = "cells", scored = "133", found = "67")) + # The record attached is the assigned layer's, and the cells are not its. + got <- attr(r$value, "count_rule") + expect_identical(got$cells, 133L) + expect_identical(got$check, list(estimate = "match", cells = "differ")) + # The same cells and the same record on both: nothing to say. + expect_length(.cr_of(.cr_sum(A$asg, A$tess$cells, "pooled"), "spatialkit_cells_differ"), 0L) + # Cells of a selection made for the other estimate differ in the rule first. + B <- .cr_B() + w <- .cr_of(.cr_sum(A$asg, B$tess$cells, "pooled"), "spatialkit_cells_differ")[[1L]] + expect_identical(.cr_fields(w), + list(what = "record", field = "rule", scored = "size", found = "loo")) + # A hex grid sized by the same selection is other cells of that selection: + # the two records agree in everything but whose cells they sit beside. + hex <- suppressWarnings(build_tessellation(pts, boundary = .cr_bnd(pts), method = "hex", + approx_n_cells = .cr_size(), quiet = TRUE)) + expect_true("cell_id" %in% names(hex$cells)) + expect_false(nrow(hex$cells) == 133L) + rec_hex <- attr(hex$cells, "count_rule") + rec_asg <- attr(A$asg, "count_rule") + expect_identical(rec_hex$scored_cells, FALSE) + rec_hex$scored_cells <- TRUE + expect_identical(rec_hex, rec_asg) + r <- .cr_sum(A$asg, hex$cells, "pooled") + expect_identical(.cr_classes(r), "spatialkit_cells_differ") + expect_identical(conditionMessage(r$warnings[[1L]]), paste0( + "summarize_by_cell(): `assigned_points_sf` and `cells_sf` carry different count records ", + "(scored_cells: TRUE against FALSE), so the rows were assigned to other cells than the ", + "`cells_sf` given. The record of the assigned layer is used.")) + expect_identical(.cr_fields(r$warnings[[1L]]), + list(what = "record", field = "scored_cells", scored = "TRUE", + found = "FALSE")) + expect_identical(.cr_check(r), list(estimate = "match", cells = "differ")) + # The other way round: rows assigned to the lattice, the scored cells given. + on_hex <- assign_features_to_polygons(pts, hex$cells, polygon_id_col = "cell_id", quiet = TRUE) + r <- .cr_sum(on_hex, A$tess$cells, "pooled") + expect_identical(.cr_fields(.cr_of(r, "spatialkit_cells_differ")[[1L]]), + list(what = "record", field = "scored_cells", scored = "FALSE", + found = "TRUE")) + expect_identical(.cr_check(r)$cells, "differ") +}) + +test_that("the warnings of the pooled columns come first, then the record's: the two records, the estimate, the cells", { + A <- .cr_A(); B <- .cr_B() + # Rows of the cells chosen for plain means, thirty of them removed, with a + # constant column beside the response; summarised as pooled values, with + # the cells of the other selection as `cells_sf`. + asg <- B$asg[-(1:30), ] + asg$k <- 1 + r <- .cr_catch(summarize_by_cell(asg, "z", predictor_vars = "k", id_col = "cell_id", + cells_sf = A$tess$cells, estimate = "pooled")) + expect_identical(.cr_classes(r), + c("spatialkit_pool_degenerate", "spatialkit_cells_differ", + "spatialkit_estimate_mismatch", "spatialkit_cells_differ")) + expect_identical(vapply(.cr_of(r, "spatialkit_cells_differ"), function(w) w$what, ""), + c("record", "n")) + expect_identical(.cr_check(r), list(estimate = "mismatch", cells = "differ")) +}) + +test_that("the check reads the cells from the ID column the summary found", { + B <- .cr_B() + # `id_col` names a column the layer lacks, and the summary falls back to + # `cell_id`; the check's own fit has to read that column too. + r <- .cr_catch(summarize_by_cell(B$asg, "z", id_col = "no_such_column", estimate = "mean")) + expect_identical(.cr_classes(r), character(0)) + expect_true("cell_id" %in% names(r$value)) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) +}) + +test_that("a constant response has no leave-one-out error at either end, and matches", { + pts <- .cr_600() + pts$z <- 3 + prof <- suppressWarnings(.cr_profile(pts)) + sel <- select_resolution(prof, criterion = "size") + expect_identical(sel$count_rule$scored$loo, NA_real_) + C <- suppressWarnings(.cr_cells(pts, sel)) + r <- .cr_sum(C$asg, C$tess$cells, "pooled") + expect_identical(attr(r$value, "pooled")$columns$resp_z$loo, NA_real_) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) + # With rows removed the counts differ, whatever the errors are. + r <- .cr_sum(C$asg[-(1:30), ], C$tess$cells, "pooled") + expect_identical(.cr_of(r, "spatialkit_cells_differ")[[1L]]$what, "n") +}) + + +# ---- Where the check is skipped ------------------------------------------------- + +test_that("the check of the cells is skipped, with its reason, where the record cannot speak for them", { + pts <- .cr_600(); sel <- .cr_size(); A <- .cr_A(); bnd <- .cr_bnd(pts) + skipped <- function(r, reason, estimate = "match") { + expect_identical(.cr_check(r), list(estimate = estimate, + cells = paste("not checked:", reason))) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) + } + + # Another response column. + two <- A$asg; two$z2 <- rev(two$z) + expect_false(is.null(attr(two, "count_rule"))) + skipped(.cr_sum(two, A$tess$cells, "pooled", response = "z2"), "the response is another column") + # A response that was not summarised: not numeric, not named, not there. + text <- A$asg; text$z <- as.character(text$z) + skipped(.cr_sum(text, A$tess$cells, "pooled"), "the response was not summarised") + r <- .cr_catch(summarize_by_cell(A$asg, NULL, predictor_vars = "z", id_col = "cell_id", + cells_sf = A$tess$cells, estimate = "pooled")) + skipped(r, "the response was not summarised") + gone <- A$asg; gone$z <- NULL + skipped(.cr_sum(gone, A$tess$cells, "pooled"), "the response was not summarised") + + # The profile read the selection half. + half <- suppressWarnings(.cr_profile(pts, select_on = "split")) + sel_half <- select_resolution(half, criterion = "size") + expect_identical(sel_half$count_rule$scored$rows, "selection half") + H <- suppressWarnings(.cr_cells(pts, sel_half)) + expect_identical(attr(H$asg, "count_rule")$scored_cells, TRUE) + skipped(.cr_sum(H$asg, H$tess$cells, "pooled"), "the profile read the selection half") + + # Other centres at the count: a lattice, a partition of the seeding + # function's own, random seeds. + other <- "other cells were built from this count" + hex <- suppressWarnings(build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = sel, quiet = TRUE)) + asg <- assign_features_to_polygons(pts, hex$cells, polygon_id_col = "cell_id", quiet = TRUE) + expect_identical(attr(asg, "count_rule")$scored_cells, FALSE) + skipped(.cr_sum(asg, hex$cells, "pooled"), other) + bare_sel <- sel; bare_sel$seeds <- NULL + own <- .cr_cells(pts, bare_sel, set_seed = 1, partition = "kmeans", kmeans_nstart = 10) + skipped(.cr_sum(own$asg, own$tess$cells, "pooled"), other) + rnd <- build_tessellation(get_voronoi_seeds(bnd, method = "random", n = sel, set_seed = 3), + method = "voronoi", quiet = TRUE) + asg <- suppressWarnings(assign_features_to_polygons(pts, rnd$cells, polygon_id_col = "cell_id", + quiet = TRUE)) + skipped(.cr_sum(asg, rnd$cells, "pooled"), other) + + # A record that stands for the count alone, attached by hand. + by_hand <- own$tess$cells + attr(by_hand, "count_rule") <- sel$count_rule + asg <- assign_features_to_polygons(pts, by_hand, polygon_id_col = "cell_id", quiet = TRUE) + expect_identical(attr(asg, "count_rule")$scored_cells, NA) + skipped(.cr_sum(asg, by_hand, "pooled"), "the record does not say whose centres these are") + + # An input with no coordinates. The pooled columns say so themselves. + frame <- sf::st_drop_geometry(A$asg) + expect_false(is.null(attr(frame, "count_rule"))) + r <- .cr_catch(summarize_by_cell(frame, "z", id_col = "cell_id", estimate = "pooled")) + expect_identical(.cr_classes(r), "spatialkit_pool_unavailable") + skipped(r, "the input has no coordinates") + r <- .cr_catch(summarize_by_cell(frame, "z", id_col = "cell_id", estimate = "mean")) + expect_identical(.cr_classes(r), "spatialkit_estimate_mismatch") + skipped(r, "the input has no coordinates", estimate = "mismatch") + + # A selection from a profile without an estimate, by a size: no scored level. + plain <- suppressWarnings( + .cr_profile(pts, n_levels = 6L, partition = "kmeans", nstart = 5, sac = 3e4, + estimate = NULL, obs_per_cell = NULL)) + sel_plain <- suppressWarnings(select_resolution(plain, criterion = "size")) + expect_null(sel_plain$count_rule$scored) + S <- suppressWarnings(.cr_cells(pts, sel_plain)) + expect_identical(attr(S$asg, "count_rule")$scored_cells, TRUE) + r <- .cr_sum(S$asg, S$tess$cells, "mean") + expect_identical(.cr_check(r), list(estimate = NA_character_, + cells = "not checked: the profile scored no estimate")) + expect_identical(.cr_classes(r), character(0)) +}) + +test_that("a check the limit on an exact search stops is recorded, and nothing is raised for it", { + A <- .cr_A(); B <- .cr_B() + testthat::local_mocked_bindings(.has_backend = function(pkg) FALSE) + withr::local_options(spatialkit.exact_pairs_max = 100) + # Plain means on cells chosen for plain means: the check's own fit. + r <- .cr_sum(B$asg, B$tess$cells, "mean") + expect_identical(.cr_classes(r), character(0)) + expect_identical(.cr_check(r), list(estimate = "match", cells = "not checked: work limit")) + # Pooled values on cells sized for them: the fit of the pooled columns, + # which says for itself that they are NA. + r <- .cr_sum(A$asg, A$tess$cells, "pooled") + expect_identical(.cr_classes(r), "spatialkit_pool_unavailable") + expect_identical(.cr_check(r), list(estimate = "match", cells = "not checked: work limit")) + # Under a limit the search passes, the same calls are checked without FNN. + withr::local_options(spatialkit.exact_pairs_max = 1e6) + expect_identical(.cr_check(.cr_sum(B$asg, B$tess$cells, "mean")), + list(estimate = "match", cells = "match")) + expect_identical(.cr_check(.cr_sum(A$asg, A$tess$cells, "pooled")), + list(estimate = "match", cells = "match")) +}) + + +# ---- A record that was lost ----------------------------------------------------- + +test_that("a record lost on the assigned layer is read from the cells, and one lost on both raises nothing", { + skip_if_not_installed("dplyr") + A <- .cr_A() + lost <- list(mutate = dplyr::mutate(A$asg, w = 1), + arrange = dplyr::arrange(A$asg, z), + select = dplyr::select(A$asg, z, cell_id)) + for (nm in names(lost)) { + expect_null(attr(lost[[nm]], "count_rule"), info = nm) + r <- .cr_sum(lost[[nm]], A$tess$cells, "pooled") + expect_identical(.cr_check(r), list(estimate = "match", cells = "match"), info = nm) + expect_identical(.cr_classes(r), character(0), info = nm) + # Read from the cells, a subset of the rows is still caught. + r <- .cr_sum(lost[[nm]][-(1:30), ], A$tess$cells, "pooled") + expect_identical(.cr_of(r, "spatialkit_cells_differ")[[1L]]$what, "n", info = nm) + } + # A record read from the cells names the working CRS as one read from the + # rows does: rows that lost theirs and sit in another projected CRS are + # measured in the record's. + moved <- dplyr::select(sf::st_transform(A$asg, 4087), z, cell_id) + expect_null(attr(moved, "count_rule")) + r <- .cr_sum(moved, A$tess$cells, "pooled") + expect_identical(attr(r$value, "pooled")$crs, attr(A$tess$cells, "count_rule")$crs) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + expect_identical(.cr_classes(r), character(0)) + # A row subset and a filter keep the record, which is then stale: the + # check is what says so. + expect_false(is.null(attr(A$asg[1:300, ], "count_rule"))) + expect_false(is.null(attr(dplyr::filter(A$asg, z > 0), "count_rule"))) + expect_identical(.cr_check(.cr_sum(A$asg[1:300, ], NULL, "pooled"))$cells, "differ") + + bare <- A$tess$cells + attr(bare, "count_rule") <- NULL + for (est in c("mean", "pooled")) { + r <- .cr_sum(lost$select, bare, est) + expect_identical(.cr_classes(r), character(0)) + expect_null(attr(r$value, "count_rule")) + } + # Without `cells_sf` there is no second place to look. + r <- .cr_catch(summarize_by_cell(lost$select, "z", id_col = "cell_id", estimate = "mean")) + expect_identical(.cr_classes(r), character(0)) + expect_null(attr(r$value, "count_rule")) +}) + + +# ---- The working CRS ------------------------------------------------------------ + +test_that("with a record the pooled values are measured in the CRS the profile worked in", { + A <- .cr_A(); B <- .cr_B() + rec_crs <- attr(A$asg, "count_rule")$crs + expect_identical(rec_crs, sf::st_crs(32617)) + base <- .cr_sum(A$asg, A$tess$cells, "pooled")$value + for (epsg in c(26917, 3857, 4326)) { + moved <- sf::st_transform(A$asg, epsg) + expect_false(is.null(attr(moved, "count_rule"))) + r <- .cr_sum(moved, A$tess$cells, "pooled") + expect_identical(attr(r$value, "pooled")$crs, rec_crs, info = epsg) + expect_identical(.cr_check(r), list(estimate = "match", cells = "match"), info = epsg) + expect_identical(.cr_classes(r), character(0), info = epsg) + # The same cells are neighbours, so the values are the ones of the + # layer in the profile's own CRS. + expect_equal(r$value$..pooled_resp_z, base$..pooled_resp_z, tolerance = 1e-9, info = epsg) + # The frame keeps the CRS of the cells it was joined to. + expect_identical(sf::st_crs(r$value), sf::st_crs(A$tess$cells), info = epsg) + # Without the record the layer is measured where it is, or where + # ensure_projected() puts it. + plain <- moved; attr(plain, "count_rule") <- NULL + cells <- A$tess$cells; attr(cells, "count_rule") <- NULL + own <- attr(suppressWarnings(.cr_sum(plain, cells, "pooled"))$value, "pooled")$crs + if (epsg != 4326) expect_identical(own, sf::st_crs(epsg), info = epsg) + } + # Under plain means the check's own fit is made there too. + r <- .cr_sum(sf::st_transform(B$asg, 3857), B$tess$cells, "mean") + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + # Plain means read the coordinates for one thing: the nearest other row of + # a row alone in its cell. At 2 rows a cell a sixth of the rows are alone, + # and in a CRS that stretches east against north (EPSG:4087) some of them + # have another nearest row. Measured there the error is another number; + # measured in the record's CRS it is the profile's. + fine <- select_resolution(.cr_profile(.cr_600(), estimate = "mean", obs_per_cell = 2), + criterion = "size") + expect_gt(fine$count_rule$scored$share_alone, 0.1) + C <- suppressWarnings(.cr_cells(.cr_600(), fine)) + stretched <- sf::st_transform(C$asg, 4087) + there <- .pool_column(stretched$z, stretched$cell_id, + unname(sf::st_coordinates(stretched)[, 1:2]), NULL, want = "mean", + use_fnn = .has_backend("FNN"))$fit$loo_mean + expect_false(.same_loo(there, fine$count_rule$scored$loo)) + r <- .cr_sum(stretched, C$tess$cells, "mean") + expect_identical(.cr_check(r), list(estimate = "match", cells = "match")) + expect_length(.cr_of(r, "spatialkit_cells_differ"), 0L) + # A record that names no CRS, or a geographic one, leaves the layer to be + # measured where it is. + for (crs in list(sf::NA_crs_, sf::st_crs(4326))) { + asg <- sf::st_transform(A$asg, 26917) + rec <- attr(asg, "count_rule"); rec$crs <- crs + attr(asg, "count_rule") <- rec + cells <- A$tess$cells; attr(cells, "count_rule") <- NULL + r <- suppressWarnings(.cr_sum(asg, cells, "pooled")) + expect_identical(attr(r$value, "pooled")$crs, sf::st_crs(26917)) + expect_identical(attr(r$value, "count_rule")$crs, crs) + } + # .pooled_xy() puts the points in the CRS it is handed. + at <- .pooled_xy(sf::st_transform(A$asg, 3857), rec_crs) + expect_identical(at$crs, rec_crs) + expect_equal(at$xy, unname(sf::st_coordinates(A$asg)), tolerance = 1e-9) + expect_identical(.pooled_xy(sf::st_transform(A$asg, 3857))$crs, sf::st_crs(3857)) +}) + + +# ---- The pieces ----------------------------------------------------------------- + +test_that(".count_rule_get() reads a record and nothing else; .count_rule_put() writes one", { + rec <- .cr_size()$count_rule + x <- .cr_600()[1:5, ] + expect_null(.count_rule_get(x)) + expect_identical(.count_rule_get(.count_rule_put(x, rec)), rec) + expect_identical(.count_rule_put(x, NULL), x) + expect_identical(.count_rule_get(.count_rule_put(x, rec, scored_cells = FALSE))$scored_cells, + FALSE) + expect_identical(.count_rule_get(.count_rule_put(x, rec, scored_cells = TRUE))$scored_cells, + TRUE) + # The other fields are not touched, `scored` of a record without one included. + marked <- .count_rule_get(.count_rule_put(x, rec, scored_cells = TRUE)) + marked$scored_cells <- NA + expect_identical(marked, rec) + none <- rec; none["scored"] <- list(NULL) + expect_identical(names(.count_rule_get(.count_rule_put(x, none, scored_cells = TRUE))), + .cr_names) + # A list that is not a record, and a record that is not a list, are not read. + attr(x, "count_rule") <- unclass(rec) + expect_null(.count_rule_get(x)) + attr(x, "count_rule") <- structure("size", class = "spatialkit_count_rule") + expect_null(.count_rule_get(x)) + expect_null(.count_rule_get(NULL)) + # Nor is a record of another version, or one without a rule, a count or + # an estimate: every reader takes those for granted. + unreadable <- function(edit) { + r <- edit(rec) + attr(x, "count_rule") <- r + .count_rule_get(x) + } + expect_null(unreadable(function(r) { r$version <- 2L; r })) + expect_null(unreadable(function(r) { r$version <- NULL; r })) + expect_null(unreadable(function(r) { r$cells <- NULL; r })) + expect_null(unreadable(function(r) { r["cells"] <- list(NULL); r })) + expect_null(unreadable(function(r) { r$cells <- NA_integer_; r })) + expect_null(unreadable(function(r) { r$rule <- NULL; r })) + expect_null(unreadable(function(r) { r$rule <- c("size", "loo"); r })) + expect_null(unreadable(function(r) { r$estimate <- NULL; r })) + # An estimate that is NA is a record's own: a rule that scores no cell value. + expect_false(is.null(unreadable(function(r) { r$estimate <- NA_character_; r }))) + expect_false(is.null(unreadable(function(r) { r["scored"] <- list(NULL); r }))) + # A summary of rows that carry such a record is a summary without one. + A <- .cr_A() + asg <- A$asg + cut <- attr(asg, "count_rule"); cut$cells <- NULL; cut$version <- 2L + attr(asg, "count_rule") <- cut + cells <- A$tess$cells; attr(cells, "count_rule") <- NULL + r <- .cr_sum(asg, cells, "mean") + expect_identical(.cr_classes(r), character(0)) + expect_null(attr(r$value, "count_rule")) + # It is not handed on either. + seeds <- A$seeds; attr(seeds, "count_rule") <- cut + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + expect_false("count_rule" %in% names(tess$params)) + expect_null(attr(tess$cells, "count_rule")) +}) + +test_that("the print method of a record is registered", { + expect_true(is.function(utils::getS3method("print", "spatialkit_count_rule", + envir = asNamespace("spatialkit")))) + registered <- getNamespaceInfo(asNamespace("spatialkit"), "S3methods") + expect_true(any(registered[, 1L] == "print" & registered[, 2L] == "spatialkit_count_rule")) +}) + +test_that(".count_rule_differs() names the first of six fields in which two records differ", { + a <- .cr_size()$count_rule + expect_null(.count_rule_differs(a, a)) + expect_identical(.count_rule_same_fields, + c("rule", "estimate", "cells", "crs", "scored$loo", "scored_cells")) + # Fields the comparison does not read. + b <- a; b$seed <- 9L; b$n <- 1L; b$partition$nstart <- 7L; b$features <- "other" + expect_null(.count_rule_differs(a, b)) + # Whose cells the record sits beside: the scored ones, others, or none. + b <- a; b$scored_cells <- TRUE + expect_identical(.count_rule_differs(a, b), + list(field = "scored_cells", a = "NA", b = "TRUE")) + f <- b; f$scored_cells <- FALSE + expect_identical(.count_rule_differs(b, f), + list(field = "scored_cells", a = "TRUE", b = "FALSE")) + expect_null(.count_rule_differs(f, f)) + # It is the last of the six: an error that differs is named before it. + f$scored$loo <- a$scored$loo * 2 + expect_identical(.count_rule_differs(b, f)$field, "scored$loo") + b <- a; b$rule <- "loo" + expect_identical(.count_rule_differs(a, b), list(field = "rule", a = "size", b = "loo")) + b <- a; b$estimate <- "mean" + expect_identical(.count_rule_differs(a, b), list(field = "estimate", a = "pooled", b = "mean")) + b <- a; b$estimate <- NA_character_ + expect_identical(.count_rule_differs(a, b)$b, "NA") + b <- a; b$cells <- 67L + expect_identical(.count_rule_differs(a, b), list(field = "cells", a = "133", b = "67")) + b <- a; b$crs <- sf::st_crs(26917) + expect_identical(.count_rule_differs(a, b), + list(field = "crs", a = "EPSG:32617", b = "EPSG:26917")) + b <- a; b$crs <- sf::NA_crs_ + expect_identical(.count_rule_differs(a, b)$b, "NA") + expect_null(.count_rule_differs(b, b)) + # The same CRS written another way is the same CRS. + b <- a; b$crs <- sf::st_crs("+proj=utm +zone=17 +datum=WGS84 +units=m +no_defs") + expect_identical(isTRUE(a$crs == b$crs), is.null(.count_rule_differs(a, b))) + # The error the profile scored: to the tolerance of the check. + b <- a; b$scored$loo <- a$scored$loo * (1 + 5e-9) + expect_null(.count_rule_differs(a, b)) + b$scored$loo <- a$scored$loo * (1 + 5e-8) + expect_identical(.count_rule_differs(a, b)$field, "scored$loo") + b <- a; b["scored"] <- list(NULL) + expect_identical(.count_rule_differs(a, b)[c("field", "b")], + list(field = "scored$loo", b = "none")) + expect_null(.count_rule_differs(b, b)) + # The first that differs is the one named. + b <- a; b$cells <- 67L; b$rule <- "loo"; b$scored$loo <- 1 + expect_identical(.count_rule_differs(a, b)$field, "rule") +}) + +test_that(".same_loo() takes two missing errors as one, and numbers to a relative 1e-8", { + expect_identical(.RECORD_TOL, 1e-8) + expect_true(.same_loo(NA_real_, NA_real_)) + expect_false(.same_loo(NA_real_, 2)) + expect_false(.same_loo(2, NA_real_)) + expect_true(.same_loo(2, 2)) + expect_true(.same_loo(0, 0)) + expect_true(.same_loo(2e8, 2e8 * (1 + 9e-9))) + expect_false(.same_loo(2e8, 2e8 * (1 + 2e-8))) + expect_true(.same_loo(2e-8, 2e-8 * (1 - 9e-9))) + expect_false(.same_loo(2e-8, 2e-8 * (1 - 2e-8))) + expect_false(.same_loo(0, 1e-300)) +}) + +test_that(".count_rule_check() compares the rows, then the cells, then the error, and asks for a fit only when it compares", { + rec <- attr(.cr_A()$asg, "count_rule") + layer <- .cr_600() + sc <- rec$scored + asked <- character(0) + check <- function(found = list(), ..., record = rec, estimate = "pooled", response = "z", + summarised = "z", lay = layer, other = NULL) { + asked <<- character(0) + got <- utils::modifyList(list(n = sc$n, cells = sc$cells, loo = sc$loo, status = "ok"), + found) + .cr_catch(.count_rule_check(record, other = other, estimate = estimate, + response_var = response, summarised = summarised, layer = lay, + found = function(est) { asked <<- c(asked, est); got })) + } + cells_of <- function(r) r$value$check$cells + what_of <- function(r) vapply(.cr_of(r, "spatialkit_cells_differ"), function(w) w$what, "") + + r <- check() + expect_identical(r$value$check, list(estimate = "match", cells = "match")) + expect_identical(asked, "pooled") # the estimate the profile scored + expect_identical(.cr_classes(r), character(0)) + # The record handed back is the record handed in, with `check` appended. + got <- r$value; got$check <- NULL + expect_identical(got, rec) + + # The first that differs is the one named. + expect_identical(what_of(check(list(n = 599L, cells = 1L, loo = 9))), "n") + expect_identical(what_of(check(list(cells = 132L, loo = 9))), "cells") + expect_identical(what_of(check(list(loo = sc$loo * (1 + 2e-8)))), "loo") + expect_identical(cells_of(check(list(loo = sc$loo * (1 + 9e-9)))), "match") + expect_identical(what_of(check(list(loo = NA_real_))), "loo") + expect_identical(what_of(check(list(n = 0L, cells = 0L, loo = NA_real_, + status = "no located value"))), "n") + na <- rec; na$scored$loo <- NA_real_ + expect_identical(cells_of(check(list(loo = NA_real_), record = na)), "match") + expect_identical(what_of(check(record = na)), "loo") + expect_match(conditionMessage(check(record = na)$warnings[[1L]]), + "with a leave-one-out error of NA; here 600 rows in 133 cells give 2.2", fixed = TRUE) + + # The estimate asked for is the one scored, whatever the summary reports. + mean_rec <- rec; mean_rec$scored$estimate <- "mean" + check(record = mean_rec) + expect_identical(asked, "mean") + r <- check(estimate = "mean") + expect_identical(asked, "pooled") + expect_identical(r$value$check, list(estimate = "mismatch", cells = "match")) + + # No fit is asked for where the check is skipped; the reasons in their order. + no_fit <- function(r, reason) { + expect_identical(cells_of(r), paste("not checked:", reason)) + expect_identical(asked, character(0)) + } + none <- rec; none["scored"] <- list(NULL) + no_fit(check(record = none), "the profile scored no estimate") + odd <- rec; odd$scored$estimate <- "median" + no_fit(check(record = odd), "the profile scored no estimate") + half <- rec; half$scored$rows <- "selection half"; half$scored_cells <- FALSE + no_fit(check(record = half), "the profile read the selection half") + placed <- rec; placed$scored_cells <- FALSE + no_fit(check(record = placed, response = "other"), "other cells were built from this count") + alone <- rec; alone$scored_cells <- NA + no_fit(check(record = alone, response = NULL), "the record does not say whose centres these are") + no_fit(check(response = NULL, lay = sf::st_drop_geometry(layer)), + "the response was not summarised") + no_fit(check(response = "other", summarised = "other"), "the response is another column") + no_fit(check(summarised = character(0), lay = sf::st_drop_geometry(layer)), + "the response was not summarised") + no_fit(check(lay = sf::st_drop_geometry(layer)), "the input has no coordinates") + squares <- sf::st_buffer(layer[1:5, ], 10) + no_fit(check(lay = squares), "the features are not points") + # One feature that is not a point is enough. + mixed <- rbind(layer[1:5, ], squares[1L, ]) + expect_identical(as.character(sf::st_geometry_type(mixed)), + c(rep("POINT", 5L), "POLYGON")) + no_fit(check(lay = mixed), "the features are not points") + # The record's own `features` does not stop the check of a layer of points. + from_polygons <- rec; from_polygons$features <- "other" + expect_identical(cells_of(check(record = from_polygons)), "match") + # A fit the limit stopped. + r <- check(list(n = 600L, cells = 133L, loo = NA_real_, status = "work limit")) + expect_identical(cells_of(r), "not checked: work limit") + expect_identical(asked, "pooled") + expect_identical(.cr_classes(r), character(0)) + + # Two records: the warning names the field, and the cells are not the ones + # scored whatever the rows say. + two <- rec; two$cells <- 67L + r <- check(other = two) + expect_identical(what_of(r), "record") + expect_identical(r$value$check, list(estimate = "match", cells = "differ")) + r <- check(list(n = 1L), other = two) + expect_identical(what_of(r), c("record", "n")) + r <- check(other = two, record = placed) + expect_identical(what_of(r), "record") + expect_identical(cells_of(r), "differ") + expect_identical(what_of(check(other = rec)), character(0)) +}) + + +# ---- The print method ----------------------------------------------------------- + +test_that("a record prints the count, the estimate, the cells and what the profile scored", { + sel <- .cr_size() + rec <- sel$count_rule + sc <- rec$scored + scored_line <- sprintf( + " scored : loo %s on 600 rows in 133 cells (one cell: %s); %.1f%% of rows alone", + sprintf("%.2e", sc$loo), sprintf("%.2e", sc$loo_one_cell), 100 * sc$share_alone) + # The errors are written as the record of the pooled columns writes them. + expect_match(scored_line, "loo [0-9]\\.[0-9]{2}e[+-][0-9]{2} on 600 rows in 133 cells \\(one cell: [0-9]\\.[0-9]{2}e[+-][0-9]{2}\\)") + head <- c( + "Count: 133 cells, set by size (4.5 rows per cell asked; 600 rows / 133 cells = 4.51)", + " chosen for : the pooled value", + " cells : density, 3 density-weighted k-means++ starts (power 1, 8", + " neighbours; seed 123), fitted to every row;") + expect_identical(.cr_print(rec), c( + head, " the record stands for the count and sits beside no centres", + scored_line)) + expect_identical(.cr_print(attr(sel$seeds, "count_rule")), c( + head, " these are the cells the profile scored", scored_line)) + A <- .cr_A() + out <- .cr_sum(A$asg, A$tess$cells, "pooled")$value + expect_identical(.cr_print(attr(out, "count_rule")), c( + head, " these are the cells the profile scored", scored_line, + " checked : the cells and rows summarised are the ones scored")) + expect_true(any(grepl(sprintf("loo : %s ", sprintf("%.2e", sc$loo)), + .cr_print(attr(out, "pooled")), fixed = TRUE))) + # print() returns its argument, unseen. + utils::capture.output(back <- withVisible(print(rec))) + expect_identical(back, list(value = rec, visible = FALSE)) + # Large errors and a large seed are written with their digits, both errors + # of a line one way. + big <- rec; big$seed <- 100000; big$scored$loo <- 71800000; big$scored$loo_one_cell <- 1.76e8 + expect_identical(.cr_print(big)[c(4L, 6L)], c( + " neighbours; seed 100000), fitted to every row;", + sprintf(" scored : loo 7.18e+07 on 600 rows in 133 cells (one cell: 1.76e+08); %.1f%% of rows alone", + 100 * sc$share_alone))) + # One row, one cell. + single <- rec; single$cells <- 1L; single$n <- 1L; single$scored$n <- 1L + single$scored$cells <- 1L + out1 <- .cr_print(single) + expect_identical(out1[1L], + "Count: 1 cell, set by size (4.5 rows per cell asked; 1 row / 1 cell = 1.00)") + expect_match(out1[6L], " on 1 row in 1 cell (one cell: ", fixed = TRUE) + + # A mismatch, rows that differ, a check that was skipped. + out <- suppressWarnings(.cr_sum(A$asg[-(1:30), ], A$tess$cells, "mean"))$value + expect_identical(utils::tail(.cr_print(attr(out, "count_rule")), 2L), c( + " checked : the cells and rows summarised are not the ones scored", + " the summary reports the plain mean, not the pooled value")) + placed <- rec; placed$scored_cells <- FALSE + placed$check <- list(estimate = "match", cells = "not checked: other cells were built from this count") + expect_identical(.cr_print(placed)[c(5L, 7L)], c( + " other cells were built from this count: not the cells the profile scored", + " not checked : other cells were built from this count")) +}) + +test_that("the print names the rule, the kind, the seed and the rows the centres were fitted to", { + B <- .cr_B() + rec <- attr(B$asg, "count_rule") + out <- .cr_print(rec) + expect_identical(out[1:2], c("Count: 50 cells, set by loo (600 rows / 50 cells = 12.00)", + " chosen for : the plain mean")) + # k-means from k-means++ starts, as a profile without a partition record is. + km <- suppressWarnings(.cr_profile(.cr_600(), partition = "kmeans", nstart = 25)) + rec_km <- select_resolution(km, criterion = "size")$count_rule + expect_identical(.cr_print(rec_km)[3:4], c( + " cells : k-means, 25 k-means++ starts (seed 123), fitted to every row;", + " the record stands for the count and sits beside no centres")) + # No seed kept, one start, random starts. + r <- rec_km; r$seed <- NA_integer_; r$partition$nstart <- 1L; r$partition$init <- "random" + expect_identical(.cr_print(r)[3L], + " cells : k-means, 1 random start, fitted to every row;") + r <- rec_km; r$partition$nstart <- NA_integer_ + expect_identical(.cr_print(r)[3L], + " cells : k-means, k-means++ starts (seed 123), fitted to every row;") + # A subsample, and row counts that are not known. + r <- rec_km; r$n_fit <- 1500L; r$n_points <- 8251L + expect_identical(.cr_print(r)[3:4], c( + " cells : k-means, 25 k-means++ starts (seed 123), fitted to a subsample", + " of 1500 of the 8251 points;")) + r <- rec_km; r$n_fit <- NA_integer_ + expect_identical(.cr_print(r)[3L], " cells : k-means, 25 k-means++ starts (seed 123);") + r <- rec_km; r$n <- NA_integer_; r$obs_per_cell <- NA_real_ + expect_identical(.cr_print(r)[1L], "Count: 133 cells, set by size (4.5 rows per cell asked)") + r$rule <- "loo" + expect_identical(.cr_print(r)[1L], "Count: 133 cells, set by loo") + + # The selection half. + half <- suppressWarnings(.cr_profile(.cr_600(), select_on = "split")) + s <- select_resolution(half, criterion = "size") + on <- attr(s$seeds, "count_rule") + out <- .cr_print(on) + expect_identical(out[5L], " these are the cells the profile scored, on half the rows") + expect_identical(out[6L], sprintf( + " scored : loo %s on the %d rows of the selection half in %d cells (one cell: %s); %.1f%% of rows alone", + sprintf("%.2e", on$scored$loo), on$scored$n, on$scored$cells, + sprintf("%.2e", on$scored$loo_one_cell), 100 * on$scored$share_alone)) + expect_lt(on$scored$n, 600L) + + # A count no cell value was scored for. + plain <- suppressWarnings( + .cr_profile(.cr_600(), n_levels = 6L, partition = "kmeans", nstart = 5, sac = 3e4, + estimate = NULL, obs_per_cell = NULL)) + r <- suppressWarnings(select_resolution(plain, criterion = "size"))$count_rule + out <- .cr_print(r) + expect_identical(out[2L], " chosen for : no cell value: the profile names no estimate") + expect_length(out, 4L) # no `scored` line + r$rule <- "elbow" + expect_identical(.cr_print(r)[2L], " chosen for : no cell value: elbow scores none") + # "loo" scores the profile's estimate as a size does; on a column subset, + # which keeps no estimate, the record names none. + subset_rec <- select_resolution(.cr_mean7()[, c("levels", "loo")], criterion = "loo")$count_rule + expect_identical(subset_rec$rule, "loo") + expect_identical(subset_rec$estimate, NA_character_) + expect_identical(.cr_print(subset_rec)[1:2], c( + "Count: 50 cells, set by loo", + " chosen for : no cell value: the profile names no estimate")) + for (rule in c("reliability", "moran_z")) { + r$rule <- rule + expect_identical(.cr_print(r)[2L], + sprintf(" chosen for : no cell value: %s scores none", rule)) + } + # A constant response: errors that are not numbers are written as NA. + r <- rec_km; r$scored$loo <- NA_real_; r$scored$loo_one_cell <- NA_real_ + r$scored$share_alone <- NA_real_ + expect_identical(.cr_print(r)[5L], + " scored : loo NA on 600 rows in 133 cells (one cell: NA)") +}) diff --git a/tests/testthat/test-core-count-size.R b/tests/testthat/test-core-count-size.R new file mode 100644 index 00000000..bbe51220 --- /dev/null +++ b/tests/testthat/test-core-count-size.R @@ -0,0 +1,2224 @@ +# tests/testthat/test-core-count-size.R +# --------------------------------------------------------------------------- +# select_resolution(criterion = "loo" | "size" | "auto"): the three rules, +# the record of how the count was set, what the present criteria say on a +# ladder of sizes, a profile passed straight as a count, and what summary() +# and plot() show for a ladder of one size. +# +# Every profile names `partition`, `nstart`, `estimate`, `obs_per_cell` and +# `sac`, and every selection its `criterion`. Unless a test says otherwise +# the regions are of the density kind from 3 k-means++ starts under seed 123. +# A layer is drawn under the seed its test states: the locations (x, then +# y), then the response. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.cs_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.cs_points <- function(x, y, z, crs = 32617) + sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = crs) + +# `n` locations uniform on a square of side `side`, with the field of the +# engine's tests, sin(x / 2e4) + cos(y / 1.5e4) plus normal noise of standard +# deviation 1.5, or with a standard normal response and no field. +.cs_layer <- function(n, seed, side = 1e5, field = TRUE) { + d <- local({ + .cs_seed(seed) + x <- stats::runif(n, 0, side); y <- stats::runif(n, 0, side) + z <- if (field) sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(n, 0, 1.5) + else stats::rnorm(n) + data.frame(x = x, y = y, z = z) + }) + .cs_points(d$x, d$y, d$z) +} + +# A profile with every setting that has a default the switch moves written +# out. What a test varies it names. +.cs_profile <- function(pts, ..., response = "z", partition = "density", nstart = 3, + sac = "auto", estimate = "pooled", obs_per_cell = 4.5, seed = 123) + resolution_profile(pts, response, ..., partition = partition, nstart = nstart, sac = sac, + estimate = estimate, obs_per_cell = obs_per_cell, seed = seed) + +# A call with its warnings kept and muffled. +.cs_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.cs_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.cs_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.cs_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] +.cs_error <- function(expr) tryCatch({ suppressWarnings(expr); NULL }, error = function(e) e) +.cs_print <- function(x) utils::capture.output(print(x)) + +.cs_store <- new.env(parent = emptyenv()) +.cs_keep <- function(key, expr) { + if (is.null(.cs_store[[key]])) .cs_store[[key]] <- expr + .cs_store[[key]] +} +.cs_sizes <- c(18, 12, 9, 6, 4.5, 3, 2) +# 600 rows of the field (seed 4401), and the profiles most tests read. +.cs_600 <- function() .cs_keep("l600", .cs_layer(600, 4401)) +.cs_pooled <- function() .cs_keep("pooled", .cs_profile(.cs_600())) +.cs_pooled7 <- function() .cs_keep("pooled7", .cs_profile(.cs_600(), obs_per_cell = .cs_sizes)) +.cs_mean7 <- function() + .cs_keep("mean7", .cs_profile(.cs_600(), estimate = "mean", obs_per_cell = .cs_sizes)) +# A profile without an estimate on the automatic ladder, as a profile is +# built today: k-means, a `sac` the caller supplies so that no variogram is +# fitted. +.cs_plain <- function() + .cs_keep("plain", suppressWarnings( + .cs_profile(.cs_600(), n_levels = 6L, partition = "kmeans", nstart = 5, sac = 3e4, + estimate = NULL, obs_per_cell = NULL))) +# Three levels the caller set, with an estimate. +.cs_levels <- function() + .cs_keep("levels", suppressWarnings( + .cs_profile(.cs_600(), levels = c(50, 133, 300), sac = 3e4, obs_per_cell = NULL))) + +# The stations layer of the ladder's tests: 3,000 rows (seed 301) at 100 +# stations (seed 307). +.cs_stations <- function() + .cs_keep("stations", { + pts <- .cs_layer(3000, 301) + at <- local({ .cs_seed(307); sample.int(100L, 3000L, replace = TRUE) }) + sf::st_geometry(pts) <- sf::st_geometry(pts)[at] + pts + }) +# White noise on 300 rows (seed 4001), and its profile as a profile is built +# today: k-means, the automatic ladder, a `sac` the caller supplies, no +# estimate. +.cs_noise <- function() .cs_keep("noise", .cs_layer(300, 4001, field = FALSE)) +.cs_noise_plain <- function() + .cs_keep("noise_plain", suppressWarnings( + .cs_profile(.cs_noise(), n_levels = 6L, partition = "kmeans", nstart = 5, sac = 3e4, + estimate = NULL, obs_per_cell = NULL))) +.cs_geoms <- function(g) unname(vapply(g$layers, function(l) class(l$geom)[1L], character(1))) +.cs_panels <- function(g) + as.character(unique(g$layers[[which(.cs_geoms(g) == "GeomPoint")[1L]]]$data$panel)) +# What ggplot2 says while a plot is drawn. +.cs_drawn <- function(g) { + said <- character(0) + grDevices::pdf(NULL) + on.exit(grDevices::dev.off()) + withCallingHandlers(print(g), message = function(m) { + said <<- c(said, conditionMessage(m)) + invokeRestart("muffleMessage") + }) + said +} + +.cs_present <- c("best", "flat", "criterion", "value", "at_ceiling", "at_floor", "edge", + "n_levels", "values", "structured", "one_cell", "structure_p", "range_floor", + "note", "seeds") +.cs_added <- c("estimate", "obs_per_cell", "obs_per_cell_asked", "scored_per_cell", "loo", + "loo_one_cell", "share_alone", "own_weight", "count_rule") +.cs_record <- c("version", "rule", "estimate", "cells", "obs_per_cell", "obs_per_cell_asked", + "response", "n", "n_points", "n_fit", "seed", "features", "scored", + "partition", "crs", "scored_cells") + + +# ---- What exists today is what it was ---------------------------------------- + +test_that("a selection by a present criterion from a profile without an estimate has today's names", { + p <- .cs_plain() + expect_null(attr(p, "estimate")) + for (cr in c("cp", "moran_z")) { + s <- select_resolution(p, criterion = cr, diagnostic = TRUE) + expect_identical(names(s), .cs_present, info = cr) + expect_null(s$count_rule, info = cr) + expect_null(attr(s$seeds, "count_rule"), info = cr) + expect_identical(s$criterion, cr) + } + # A profile of the density kind names its kind last, and nothing else. + d <- suppressWarnings(.cs_profile(.cs_600(), n_levels = 6L, sac = 3e4, estimate = NULL, + obs_per_cell = NULL)) + s <- select_resolution(d, criterion = "cp") + expect_identical(names(s), c(.cs_present, "partition")) + expect_null(attr(s$seeds, "count_rule")) + # The names the baseline's selections have. + base <- readRDS(test_path("fixtures", "core-frozen.rds")) + expect_identical(names(base$records$select_default_cp$value), .cs_present) + expect_identical(names(base$records$select_density_cp$value), c(.cs_present, "partition")) +}) + +test_that("a profile of today, read by cp, by \"auto\" or as a count, gives the baseline's results", { + skip_on_cran() + skip_if_not_installed("gstat") + skip_if_not_installed("dplyr") + base <- readRDS(test_path("fixtures", "core-frozen.rds")) + # The baseline's calls with the defaults of today written out, and the new + # readings of the same objects. Each is held to the baseline's record of + # the call named beside it. + prof <- function(response) + bquote(resolution_profile(pts, .(response), estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans", nstart = 25L)) + calls <- list( + profile_default = prof("z"), + select_default_cp = quote(select_resolution(profile_default, criterion = "cp")), + auto_default = quote(select_resolution(profile_default, criterion = "auto")), + subset_cp = quote(select_resolution(profile_default[, c("levels", "cp")], + criterion = "cp")), + subset_auto = quote(select_resolution(profile_default[, c("levels", "cp")], + criterion = "auto")), + seeds_profile = quote(get_voronoi_seeds(method = "kmeans", n = profile_default, + sample_points = pts)), + kmeans_profile = quote(voronoi_seeds_kmeans(pts, profile_default)), + cells_hex_profile = quote(build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = profile_default)), + profile_no_value = prof("none"), + count_seeds_no_value = quote(get_voronoi_seeds(method = "kmeans", n = profile_no_value, + sample_points = pts)), + profile_noise = prof("noise"), + count_seeds_noise = quote(get_voronoi_seeds(method = "kmeans", n = profile_noise, + sample_points = pts))) + against <- c(profile_default = "profile_default", select_default_cp = "select_default_cp", + auto_default = "select_default_cp", subset_cp = "select_column_subset_cp", + subset_auto = "select_column_subset_cp", seeds_profile = "seeds_profile", + kmeans_profile = "kmeans_profile", cells_hex_profile = "cells_hex_profile", + profile_no_value = "profile_no_value", + count_seeds_no_value = "count_seeds_no_value", profile_noise = "profile_noise", + count_seeds_noise = "count_seeds_noise") + expect_true(all(against %in% names(base$records))) + got <- core_frozen_run(base$data, calls) + same_platform <- core_frozen_same_platform(core_frozen_platform(), base$info) + for (nm in names(against)) { + want <- base$records[[against[[nm]]]] + d <- core_frozen_check(got[[nm]], want, same_platform) + expect(length(d) == 0L, + paste(c(sprintf("`%s` is not the baseline's `%s`.", nm, against[[nm]]), d), + collapse = "\n")) + if (same_platform) + for (part in c("value", "conditions", "printed", "log")) + expect_identical(got[[nm]][[part]], want[[part]], + label = sprintf("the %s of `%s`", part, nm)) + } + # What those records hold: the error of a profile with no finite + # criterion, and the two warnings of a count on a layer without structure. + expect_identical(got$count_seeds_no_value$conditions[[1L]]$kind, "error") + expect_match(got$count_seeds_no_value$conditions[[1L]]$message, + "is a resolution profile with no criterion finite at any level", fixed = TRUE) + expect_true("spatialkit_no_structure" %in% + unlist(lapply(got$count_seeds_noise$conditions, function(c) c$class))) + expect_false("count_rule" %in% names(got$select_default_cp$value)) + expect_null(attr(got$seeds_profile$value, "count_rule")) +}) + + +test_that("a column called loo on a profile without an estimate is read only when it is named", { + skip_if_not_installed("ggplot2") + label <- "Leave-one-out error (lower is better)" + # A column of the caller's own beside the criteria of a profile built as + # profiles are today: the table and the plot are the ones without it. + p <- .cs_plain() + q <- p; q$loo <- (q$levels - 30)^2 + expect_null(attr(q, "estimate")) + expect_false(.loo_by_default(q)) + expect_false(.loo_by_default(p)) + expect_identical(summary(q), summary(p)) + expect_identical(.cs_print(summary(q)), .cs_print(summary(p))) + gq <- plot(q); gp <- plot(p) + expect_identical(.cs_panels(gq), .cs_panels(gp)) + expect_false(label %in% .cs_panels(gq)) + expect_identical(.cs_geoms(gq), .cs_geoms(gp)) + expect_identical(gq$labels$caption, gp$labels$caption) + # Named, it is read as the column of that name is. + expect_identical(summary(q, criteria = "loo")$criterion, "loo") + expect_identical(.cs_panels(plot(q, criteria = "loo")), label) + # The column resolution_profile() wrote is read without being named: on the + # profile and its row subsets, which keep the estimate, and on the column + # subset that kept `loo` and no other count criterion. + l <- .cs_levels() + expect_true(.loo_by_default(l)) + expect_true(.loo_by_default(l[1:2, ])) + expect_true("loo" %in% summary(l)$criterion) + only <- l[, c("levels", "loo")] + expect_null(attr(only, "estimate")) + expect_true(.loo_by_default(only)) + expect_identical(summary(only)$criterion, "loo") + expect_identical(.cs_panels(plot(only)), label) + # A column subset that kept `cp` has lost the estimate, and is read as a + # profile without one is. + both <- l[, c("levels", "cp", "loo")] + expect_false(.loo_by_default(both)) + expect_identical(summary(both)$criterion, "cp") + expect_false(label %in% .cs_panels(plot(both))) + # A subset whose `loo` is NA at every level is told what a subset without + # a criterion column is told today. + none <- only; none$loo <- NA_real_ + expect_identical(conditionMessage(.cs_error(summary(none))), + paste0("summary.resolution_profile(): `object` carries none of the criterion ", + "columns (cp, reliability, elbow, moran_z); it is a column subset of a ", + "resolution profile. Pass the profile resolution_profile() returned.")) +}) + + +# ---- "loo" ------------------------------------------------------------------ + +test_that("\"loo\" returns the level pick_rung() picks, with the flat region around it", { + for (p in list(.cs_mean7(), .cs_pooled7())) { + what <- attr(p, "estimate")$value + expect_identical(p$levels, vapply(.cs_sizes, function(s) rung_k(600L, s), integer(1)), + info = what) + s <- select_resolution(p, criterion = "loo", tol = 0.02) + expect_identical(s$best, p$levels[pick_rung(p$loo)], info = what) + expect_identical(s$criterion, "loo") + expect_identical(s$value, min(p$loo)) + expect_identical(s$flat, p$levels[p$loo <= min(p$loo) * 1.02], info = what) + expect_identical(s$values, stats::setNames(p$loo, p$levels)) + expect_identical(s$n_levels, 7L) + expect_identical(s$range_floor, NA_integer_) + expect_identical(s$one_cell, attr(p, "estimate")$loo_one_cell) + expect_identical(s$estimate, what) + expect_identical(names(s), c(.cs_present, .cs_added, "partition")) + } +}) + +test_that("of levels with the same leave-one-out error \"loo\" takes the fewest cells", { + p <- .cs_mean7() + lv <- p$levels + q <- p + q$loo <- c(5, 3, 4, 3, 6, 7, 8) + s <- select_resolution(q, criterion = "loo") + expect_identical(s$best, lv[2L]) + expect_identical(s$best, lv[pick_rung(q$loo)]) + expect_identical(s$flat, lv[c(2L, 4L)]) + # Whatever order the rows of the profile are in: pick_rung() reads its + # rungs coarse first. + r <- q[order(-q$levels), ] + expect_identical(r$levels, rev(lv)) + expect_identical(select_resolution(r, criterion = "loo")$best, lv[2L]) + # The column is no longer the one the references were recorded with, so + # nothing is said about structure. + expect_identical(s$structured, NA) + expect_identical(s$one_cell, NA_real_) + expect_identical(s$structure_p, NA_real_) + expect_null(s$note) +}) + +test_that("the flat region and the edge of \"loo\" are the hand computation's", { + p <- .cs_mean7() + lv <- p$levels + q <- p + q$loo <- c(5, 4, 3, 2.99, 3.5, 4, 5) + s <- select_resolution(q, criterion = "loo", tol = 0.02) + expect_identical(s$best, lv[4L]) + expect_identical(s$flat, lv[3:4]) # 3 <= 2.99 * 1.02 = 3.0498 + expect_identical(c(s$at_ceiling, s$at_floor), c(FALSE, FALSE)) + expect_identical(s$edge, NA_character_) + expect_identical(select_resolution(q, criterion = "loo", tol = 0.2)$flat, lv[3:5]) + expect_identical(select_resolution(q, criterion = "loo", tol = 0)$flat, lv[4L]) + # The ends of a ladder of sizes are the sizes offered. + q$loo <- 7:1 + s <- select_resolution(q, criterion = "loo") + expect_identical(s$best, lv[7L]) + expect_true(s$at_ceiling); expect_false(s$at_floor) + expect_identical(s$edge, "the finest size offered (obs_per_cell)") + q$loo <- 1:7 + s <- select_resolution(q, criterion = "loo") + expect_identical(s$best, lv[1L]) + expect_true(s$at_floor); expect_false(s$at_ceiling) + expect_identical(s$edge, "the coarsest size offered (obs_per_cell)") + # Where the column stops short of the ladder's ends, that is the edge. + q$loo <- c(NA, 1, 2, 3, 4, 5, NA) + expect_identical(select_resolution(q, criterion = "loo")$edge, + "the first level the criterion is computable at") + q$loo <- c(NA, 5, 4, 3, 2, 1, NA) + expect_identical(select_resolution(q, criterion = "loo")$edge, + "the last level the criterion is computable at") + # On a ladder the caller set with `levels` the ends are that ladder's. + l <- .cs_levels() + l$loo <- c(1, 2, 3) + expect_identical(select_resolution(l, criterion = "loo")$edge, "the first level of the ladder") +}) + +test_that("the edge labels and their hints: a ladder of sizes has its own, every other keeps its own", { + sized <- list(obs_per_cell = c(9, 4.5), ceiling = 133L, floor = 2L, supported = TRUE, + range = NA_real_, range_floor = FALSE, ceiling_from = "obs_per_cell") + lv <- c(67L, 133L) + expect_identical(.ladder_edge(133L, lv, lv, sized), "the finest size offered (obs_per_cell)") + expect_identical(.ladder_edge(67L, lv, lv, sized), "the coarsest size offered (obs_per_cell)") + expect_identical(.ladder_edge(133L, 133L, 133L, sized), "the only level scored") + expect_identical(.ladder_edge(100L, c(67L, 100L, 133L), c(67L, 100L, 133L), sized), + NA_character_) + # A finest size the profile held to the cells k-means can place is the + # layer's bound, not the caller's: the label of the support ceiling, which + # has no hint about sizes. The coarsest size is still the caller's. + held <- utils::modifyList(sized, list(ceiling_from = "distinct locations", n_distinct = 133L)) + expect_identical(.ladder_edge(133L, lv, lv, held), + "the support ceiling (as many cells as the distinct locations allow)") + expect_identical(.ladder_edge(67L, lv, lv, held), "the coarsest size offered (obs_per_cell)") + short <- utils::modifyList(held, list(n_distinct = 134L)) + expect_identical(.ladder_edge(133L, lv, lv, short), + "the support ceiling (one short of the points, the most k-means can fit)") + expect_identical(.edge_hint("the support ceiling (as many cells as the distinct locations allow)"), + "") + # The same bounds without sizes: the labels of today. + auto <- utils::modifyList(sized, list(obs_per_cell = NULL, ceiling_from = "min_cell_n")) + expect_identical(.ladder_edge(133L, lv, lv, auto), "the support ceiling (n / min_cell_n)") + expect_identical(.ladder_edge(67L, lv, lv, auto), "the first level of the ladder") + expect_identical(.ladder_edge(133L, lv, lv, NULL), "the last level of the ladder") + hint <- " `obs_per_cell` sets the sizes offered; how small a cell may be is the caller's choice." + expect_identical(.edge_hint("the finest size offered (obs_per_cell)"), hint) + expect_identical(.edge_hint("the coarsest size offered (obs_per_cell)"), hint) + expect_identical(.edge_hint("the support ceiling (n / min_cell_n)"), + " Lower min_cell_n to see whether the criterion keeps going.") + expect_identical(.edge_hint("the only level scored"), + " One level leaves nothing to compare it with.") + expect_identical(.edge_hint(NA_character_), "") +}) + +test_that("the note for pooled values appears only at the finest level of a pooled profile", { + text <- paste0("the lowest leave-one-out error of the pooled value is at the finest level ", + "scored, so the end of the ladder chose the count. criterion = \"size\" sets ", + "it by a size.") + pp <- .cs_pooled7(); pm <- .cs_mean7() + finest <- pp; finest$loo <- 7:1 + s <- select_resolution(finest, criterion = "loo") + expect_identical(s$note[["finest"]], text) + # The finest level scored, where the column stops short of the ladder's end. + short <- pp; short$loo <- c(6, 5, 4, 3, 2, 1, NA) + expect_identical(select_resolution(short, criterion = "loo")$note[["finest"]], text) + # Not at another level, and not for plain means. + inner <- pp; inner$loo <- c(5, 4, 3, 2.99, 3.5, 4, 5) + expect_false("finest" %in% names(select_resolution(inner, criterion = "loo")$note)) + coarse <- pp; coarse$loo <- 1:7 + expect_false("finest" %in% names(select_resolution(coarse, criterion = "loo")$note)) + plain <- pm; plain$loo <- 7:1 + expect_false("finest" %in% names(select_resolution(plain, criterion = "loo")$note)) + # On the profile as it was built the note follows the level picked. + s <- select_resolution(pp, criterion = "loo") + expect_identical("finest" %in% names(s$note), s$best == max(pp$levels)) + # A ladder of one size: the level is the finest scored. + expect_identical(select_resolution(.cs_pooled(), criterion = "loo")$note[["finest"]], text) + # The finest level, whatever order the rows of the profile are in: with + # the rows fine first it is the first row, and the coarsest is the last. + turned <- finest[order(-finest$levels), ] + expect_identical(turned$levels[1L], max(pp$levels)) + expect_identical(select_resolution(turned, criterion = "loo")$note[["finest"]], text) + turned <- coarse[order(-coarse$levels), ] + s <- select_resolution(turned, criterion = "loo") + expect_identical(s$best, min(pp$levels)) + expect_false("finest" %in% names(s$note)) +}) + +test_that("\"loo\" runs on a column subset that keeps `levels` and `loo`", { + p <- .cs_pooled7() + sub <- p[, c("levels", "loo")] + expect_null(attr(sub, "estimate")) + s <- select_resolution(sub, criterion = "loo") + full <- select_resolution(p, criterion = "loo") + expect_identical(s$best, full$best) + expect_identical(s$flat, full$flat) + expect_identical(s$structured, NA) + expect_identical(s$estimate, NA_character_) + expect_identical(s$one_cell, NA_real_) + expect_identical(s$edge, .ladder_edge(s$best, sub$levels, sub$levels, NULL)) + expect_null(s$seeds) + expect_identical(s$loo, full$loo) + expect_identical(s$loo_one_cell, NA_real_) + expect_identical(c(s$obs_per_cell, s$obs_per_cell_asked, s$scored_per_cell, s$share_alone, + s$own_weight), rep(NA_real_, 5L)) + rec <- s$count_rule + expect_identical(names(rec), .cs_record) + expect_identical(rec$rule, "loo") + expect_identical(rec$estimate, NA_character_) + expect_identical(list(rec$n, rec$n_points, rec$n_fit), list(NA_integer_, NA_integer_, NA_integer_)) + expect_null(rec$scored) + # The ends of the column are the ladder's, with no bounds to name them. + sub$loo <- 7:1 + expect_identical(select_resolution(sub, criterion = "loo")$edge, "the last level of the ladder") + expect_null(select_resolution(sub, criterion = "loo")$note) +}) + +test_that("\"loo\" says what it lacks: the column, a response that varies, a scored level", { + e <- .cs_error(select_resolution(.cs_plain(), criterion = "loo")) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `profile` has no `loo` column; build it with ", + "resolution_profile(estimate = \"mean\") or estimate = \"pooled\".")) + expect_null(conditionCall(e)) + # A subset that kept the column and lost the levels is told so in the + # present words. + e <- .cs_error(select_resolution(.cs_mean7()[, "loo", drop = FALSE], criterion = "loo")) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `profile` has no `levels` column; it is a ", + "column subset of a resolution profile. Pass the profile ", + "resolution_profile() returned.")) + # A constant response: the present error, with `loo` named. + pts <- .cs_600(); pts$k <- 0.1 + k <- suppressWarnings(.cs_profile(pts, response = "k", estimate = "mean", + obs_per_cell = c(9, 4.5))) + expect_true(all(is.na(k$loo))) + e <- .cs_error(select_resolution(k, criterion = "loo")) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `loo` is NA at every level because the response ", + "is constant: its total sum of squares is rounding error at most, so ", + "no cell count fits it better than another.")) + # NA at every level for another reason. + q <- .cs_mean7(); q$loo <- NA_real_ + e <- .cs_error(select_resolution(q, criterion = "loo")) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `loo` is NA at every level (it needs a level at ", + "which some cell holds two rows with a response).")) +}) + +test_that("an optimum of \"loo\" on an end of the sizes raises spatialkit_bound_chosen downstream", { + pts <- .cs_600() + q <- .cs_mean7(); q$loo <- 1:7 + s <- select_resolution(q, criterion = "loo") + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + w <- .cs_of(r, "spatialkit_bound_chosen") + expect_length(w, 1L) + expect_identical(.cs_fields(w[[1L]]), + list(edge = "the coarsest size offered (obs_per_cell)", criterion = "loo", + n = 33L)) + expect_identical(conditionMessage(w[[1L]]), + paste0("get_voronoi_seeds(): `n` is 33 cells, the optimum of `loo`, and that ", + "optimum is the coarsest size offered (obs_per_cell): the bound chose ", + "the count, not the criterion. `obs_per_cell` sets the sizes offered; ", + "how small a cell may be is the caller's choice. Pass a number as `n` ", + "to set the count yourself.")) + expect_identical(nrow(r$value), 33L) + expect_identical(attr(r$value, "n_from"), + paste0("select_resolution(criterion = \"loo\"), an optimum at the coarsest ", + "size offered (obs_per_cell)")) +}) + + +# ---- "size" ----------------------------------------------------------------- + +test_that("\"size\" returns the count of the size when the profile has that level", { + p <- .cs_levels() + expect_null(attr(p, "bounds")$obs_per_cell) + r <- .cs_catch(select_resolution(p, criterion = "size", obs_per_cell = 4.5)) + expect_length(r$warnings, 0L) + s <- r$value + expect_identical(s$best, .count_at(600L, 4.5)) + expect_identical(s$best, rung_k(600L, 4.5)) + expect_identical(s$best, 133L) + expect_identical(s$criterion, "size") + expect_identical(s$flat, 133L) + expect_identical(s$value, 600 / 133) + expect_identical(s$values, stats::setNames(600 / p$levels, p$levels)) + expect_identical(s$n_levels, 3L) + expect_identical(list(s$at_ceiling, s$at_floor, s$edge), list(NA, NA, NA_character_)) + expect_identical(s$range_floor, NA_integer_) + expect_identical(s$obs_per_cell, 600 / 133) + expect_identical(s$obs_per_cell_asked, 4.5) + expect_identical(s$estimate, "pooled") + expect_identical(s$scored_per_cell, p$scored_per_cell[2L]) + expect_identical(s$loo, p$loo[2L]) + expect_identical(s$loo_one_cell, attr(p, "estimate")$loo_one_cell) + expect_identical(s$one_cell, attr(p, "estimate")$loo_one_cell) + expect_identical(s$share_alone, p$share_alone[2L]) + expect_identical(s$own_weight, p$own_weight[2L]) + expect_identical(s$note, c(size = paste0("the count is set by obs_per_cell = 4.5, the ", + "caller's choice; no criterion chose it."))) + expect_identical(nrow(s$seeds), 133L) + expect_identical(names(s), c(.cs_present, .cs_added, "partition")) + # Without a size of its own the profile is read at the default size. + expect_identical(.OBS_PER_CELL_DEFAULT, 4.5) + expect_identical(select_resolution(p, criterion = "size"), s) + # Each of the three levels is the count of a size. + for (size in c(12, 4.5, 2)) { + got <- .cs_catch(select_resolution(p, criterion = "size", obs_per_cell = size)) + expect_length(got$warnings, 0L) + expect_identical(got$value$best, rung_k(600L, size), info = format(size)) + } +}) + +test_that("a size the profile was not built at gets the nearest level on the log scale, and a warning", { + p <- .cs_levels() + r <- .cs_catch(select_resolution(p, criterion = "size", obs_per_cell = 6)) + expect_identical(.cs_classes(r), "spatialkit_size_not_reached") + w <- r$warnings[[1L]] + expect_identical(conditionMessage(w), + paste0("select_resolution(): obs_per_cell = 6 asks for 100 cells, which is not ", + "a level of this profile; the nearest level, 133 cells (4.51 rows per ", + "cell), is used. Build the profile with obs_per_cell = 6 to score that ", + "count.")) + expect_identical(.cs_fields(w), list(obs_per_cell = 6, wanted = 100L, used = 133L, + reason = "not a level")) + expect_null(conditionCall(w)) + s <- r$value + expect_identical(s$best, 133L) + expect_identical(s$obs_per_cell_asked, 6) + expect_identical(s$obs_per_cell, 600 / 133) + expect_identical(s$note[["size"]], + "the count is set by obs_per_cell = 6, the caller's choice; no criterion chose it.") + # Nearest on the log scale, not in cells: 40 cells lie 30 from 10 and 60 + # from 100, and a factor of 4 from 10 against 2.5 from 100. Of two levels + # as near, the one with fewer cells: 4 lies a factor of 2 from 2 and from 8. + q <- suppressWarnings(.cs_profile(.cs_600(), levels = c(2, 8, 10, 100), sac = 3e4, + obs_per_cell = NULL)) + expect_identical(.count_at(600L, 15), 40L) + expect_identical(suppressWarnings(select_resolution(q, criterion = "size", obs_per_cell = 15))$best, + 100L) + expect_identical(.count_at(600L, 150), 4L) + r <- .cs_catch(select_resolution(q, criterion = "size", obs_per_cell = 150)) + expect_identical(r$value$best, 2L) + expect_identical(.cs_fields(r$warnings[[1L]])[c("wanted", "used")], list(wanted = 4L, used = 2L)) + # A level whose partition was not built does not stand for a size: the + # count of 4.5 is 133, and with no partition there the nearest built level + # is 300 (a factor of 2.26, against 2.66 for 50). + failed <- p; failed$wss[2L] <- NA_real_ + r <- .cs_catch(select_resolution(failed, criterion = "size", obs_per_cell = 4.5)) + expect_identical(r$value$best, 300L) + expect_identical(.cs_fields(r$warnings[[1L]]), + list(obs_per_cell = 4.5, wanted = 133L, used = 300L, reason = "not a level")) + none <- p; none$wss <- NA_real_ + expect_error(suppressWarnings(select_resolution(none, criterion = "size")), + "no level of `profile` has a partition", fixed = TRUE) +}) + +test_that("the level a profile built for a size stands for it only while the profile has it", { + p <- .cs_pooled7() + expect_identical(attr(p, "bounds")$size_levels[["4.5"]], 133L) + words <- paste0("select_resolution(): obs_per_cell = 4.5 asks for 133 cells, which is not a ", + "level of this profile; the nearest level, 100 cells (6 rows per cell), is ", + "used. Build the profile with obs_per_cell = 4.5 to score that count.") + # The fit at that level failed. The nearest built level is 100 cells (a + # factor of 1.33, against 1.50 for 200), with the warning of a size the + # profile was not built at. + failed <- p; failed$wss[5L] <- NA_real_ + # A row subset that has lost the level. + cut <- p[-5L, ] + expect_false(133L %in% cut$levels) + expect_identical(attr(cut, "bounds")$size_levels[["4.5"]], 133L) + for (q in list(failed, cut)) { + r <- .cs_catch(select_resolution(q, criterion = "size", obs_per_cell = 4.5)) + expect_identical(.cs_classes(r), "spatialkit_size_not_reached") + expect_identical(conditionMessage(r$warnings[[1L]]), words) + expect_identical(.cs_fields(r$warnings[[1L]]), + list(obs_per_cell = 4.5, wanted = 133L, used = 100L, reason = "not a level")) + expect_identical(r$value$best, 100L) + expect_identical(names(r$value$note), "size") + expect_identical(nrow(r$value$seeds), 100L) + } + # The other sizes still stand for their levels, and raise nothing. + r <- .cs_catch(select_resolution(cut, criterion = "size", obs_per_cell = 6)) + expect_length(r$warnings, 0L) + expect_identical(r$value$best, 100L) +}) + +test_that("with obs_per_cell = NULL \"size\" takes the profile's own size when it has one", { + pts <- .cs_600() + six <- .cs_profile(pts, obs_per_cell = 6) + s <- select_resolution(six, criterion = "size") + expect_identical(s$obs_per_cell_asked, 6) + expect_identical(s$best, 100L) + expect_identical(s$obs_per_cell, 6) + expect_identical(select_resolution(six, criterion = "size", obs_per_cell = 6), s) + # Several sizes are not one: the default size, which is one of them here. + s <- select_resolution(.cs_pooled7(), criterion = "size") + expect_identical(s$obs_per_cell_asked, 4.5) + expect_identical(s$best, 133L) + # Any of the profile's sizes is the level built for it, with no warning. + for (size in .cs_sizes) { + r <- .cs_catch(select_resolution(.cs_pooled7(), criterion = "size", obs_per_cell = size)) + expect_length(r$warnings, 0L) + expect_identical(r$value$best, rung_k(600L, size), info = format(size)) + expect_length(r$value$note, 1L) + } +}) + +test_that("\"size\" divides the rows with a response, and every point without one", { + pts <- .cs_600() + some <- pts; some$z[1:200] <- NA + p <- .cs_profile(some, obs_per_cell = 4) + s <- select_resolution(p, criterion = "size") + expect_identical(s$best, rung_k(400L, 4)) + expect_identical(s$value, 4) + expect_identical(s$count_rule$n, 400L) + expect_identical(s$count_rule$n_points, 600L) + # A profile of the geometry alone: the size counts the points, and nothing + # is said of an estimate or of structure. + geo <- resolution_profile(pts, partition = "density", nstart = 3, sac = "auto", + estimate = NULL, obs_per_cell = 6, seed = 123) + s <- select_resolution(geo, criterion = "size") + expect_identical(s$best, 100L) + expect_identical(s$obs_per_cell_asked, 6) + expect_identical(s$structured, NA) + expect_identical(c(s$one_cell, s$structure_p, s$loo, s$loo_one_cell, s$scored_per_cell), + rep(NA_real_, 5L)) + expect_identical(s$estimate, NA_character_) + expect_identical(names(s), c(.cs_present, .cs_added, "partition")) + expect_identical(s$count_rule$estimate, NA_character_) + expect_identical(s$count_rule$response, NA_character_) + expect_null(s$count_rule$scored) + expect_identical(s$count_rule$n, 600L) + expect_identical(unname(s$note), "the count is set by obs_per_cell = 6, the caller's choice; no criterion chose it.") + # A profile built as profiles are today. + plain <- .cs_plain() + r <- .cs_catch(select_resolution(plain, criterion = "size", obs_per_cell = 6)) + s <- r$value + expect_identical(s$structured, NA) + expect_identical(s$estimate, NA_character_) + expect_true(s$best %in% plain$levels) + expect_identical(names(s), c(.cs_present, .cs_added)) + expect_identical(s$count_rule$partition$kind, "kmeans") + if (!(100L %in% plain$levels)) + expect_identical(.cs_classes(r), "spatialkit_size_not_reached") +}) + +test_that("\"size\" on a column subset is the error that names the row count", { + p <- .cs_pooled() + e <- .cs_error(select_resolution(p[, c("levels", "loo")], criterion = "size")) + expect_identical(conditionMessage(e), + paste0("select_resolution(): criterion = \"size\" needs the number of rows the ", + "size divides, which a profile keeps in attr(, \"bounds\"); this object ", + "has none (it is a column subset of a resolution profile). Pass the ", + "profile resolution_profile() returned.")) + expect_null(conditionCall(e)) + expect_error(select_resolution(p[, c("levels", "loo")], criterion = "auto"), "has no `cp` column") + # A present criterion still runs on the column subset that keeps its column. + l <- .cs_levels() + s <- select_resolution(l[, c("levels", "cp")], criterion = "cp") + expect_identical(s$best, select_resolution(l, criterion = "cp")$best) + expect_identical(names(s), .cs_present) +}) + +test_that("no bound chooses a size: no spatialkit_bound_chosen downstream", { + pts <- .cs_600() + p <- .cs_levels() + # The last level of the ladder, and the only level of a ladder of one size. + top <- select_resolution(p, criterion = "size", obs_per_cell = 2) + expect_identical(top$best, max(p$levels)) + one <- select_resolution(.cs_pooled(), criterion = "size") + for (s in list(top, one)) { + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + expect_false("spatialkit_bound_chosen" %in% .cs_classes(r)) + expect_identical(nrow(r$value), s$best) + r <- .cs_catch(voronoi_seeds_kmeans(pts, s)) + expect_false("spatialkit_bound_chosen" %in% .cs_classes(r)) + } + # The same level read by a criterion that searched is an optimum on a bound. + l <- p; l$loo <- c(3, 2, 1) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = select_resolution(l, criterion = "loo"), + sample_points = pts)) + expect_true("spatialkit_bound_chosen" %in% .cs_classes(r)) +}) + + +# ---- A size the profile held --------------------------------------------------- + +test_that("a size the profile held to the cells k-means can place is returned without a second warning", { + # The stations layer of the ladder's tests: 3,000 rows (seed 301) at 100 + # stations (seed 307). + pts <- .cs_layer(3000, 301) + at <- local({ .cs_seed(307); sample.int(100L, 3000L, replace = TRUE) }) + sf::st_geometry(pts) <- sf::st_geometry(pts)[at] + built <- .cs_catch(.cs_profile(pts)) + expect_identical(.cs_classes(built), + c("spatialkit_size_not_reached", "spatialkit_repeated_locations")) + p <- built$value + expect_identical(p$levels, 100L) + r <- .cs_catch(select_resolution(p, criterion = "size")) + expect_length(r$warnings, 0L) + s <- r$value + expect_identical(s$best, 100L) + expect_identical(s$obs_per_cell_asked, 4.5) + expect_identical(s$obs_per_cell, 30) + expect_identical(s$note[["held"]], + paste0("the profile holds this size to 100 cells, the most k-means can place ", + "on this layer; obs_per_cell = 4.5 asks for 667.")) + expect_identical(names(s$note)[1:2], c("size", "held")) + expect_identical(select_resolution(p, criterion = "size", obs_per_cell = 4.5), s) + # Neither the selection nor the profile, passed as the count, says it again. + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + expect_false("spatialkit_size_not_reached" %in% .cs_classes(r)) + expect_identical(nrow(r$value), 100L) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = p, sample_points = pts)) + expect_false("spatialkit_size_not_reached" %in% .cs_classes(r)) + expect_identical(nrow(r$value), 100L) + # A size it was not built at is the nearest level, with the warning. + r <- .cs_catch(select_resolution(p, criterion = "size", obs_per_cell = 9)) + expect_identical(.cs_classes(r), "spatialkit_size_not_reached") + expect_identical(r$value$best, 100L) + expect_identical(.cs_fields(r$warnings[[1L]]), + list(obs_per_cell = 9, wanted = 333L, used = 100L, reason = "not a level")) + expect_false("held" %in% names(r$value$note)) +}) + + +test_that("the seeds a size hands on are the centres of the level returned, held or nearest", { + pts <- .cs_stations() + p <- suppressWarnings(.cs_profile(pts)) + expect_identical(p$levels, 100L) + centres <- unname(attr(p, "centres")[["100"]]) + # The level the profile held the size to (rule i), and the nearest level + # for a size it was not built at (rule iii): 100 cells where 667 and 333 + # were asked for. + held <- select_resolution(p, criterion = "size") + near <- suppressWarnings(select_resolution(p, criterion = "size", obs_per_cell = 9)) + for (s in list(held, near)) { + expect_identical(s$best, 100L) + expect_identical(nrow(s$seeds), 100L) + expect_identical(unname(sf::st_coordinates(s$seeds)[, 1:2]), centres) + expect_identical(attr(s$seeds, "count_rule")$scored_cells, TRUE) + expect_identical(attr(s$seeds, "count_rule")$cells, 100L) + got <- suppressWarnings(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + expect_identical(unname(sf::st_coordinates(got)[, 1:2]), centres) + } + # The stations' response has no structure cells of 30 rows can use. The + # warning at the seeding says why, and leaves out the note about the size + # the profile held. + expect_identical(names(held$note), c("size", "held", "structure")) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = held, sample_points = pts)) + expect_identical(.cs_classes(r), "spatialkit_no_structure") + expect_identical(conditionMessage(r$warnings[[1L]]), + paste0("get_voronoi_seeds(): `n` is 100 cells, set by obs_per_cell = 4.5, and ", + held$note[["structure"]], + " The count stands, since a size set it and no criterion; the cell ", + "values will say little that one mean for the layer does not.")) +}) + +test_that("a count the layer cannot hold is said to be one, and no profile is advised for it", { + nearest <- function(size, wanted, used, per, ending) + sprintf(paste0("select_resolution(): obs_per_cell = %s asks for %d cells, which is not a ", + "level of this profile; the nearest level, %d cells (%s rows per cell), is ", + "used. %s"), size, wanted, used, per, ending) + build <- function(size) + sprintf("Build the profile with obs_per_cell = %s to score that count.", size) + said <- function(p, size) + conditionMessage(.cs_catch(select_resolution(p, criterion = "size", + obs_per_cell = size))$warnings[[1L]]) + # 3,000 rows at 100 stations: 9 rows a cell are 333 cells, and k-means + # places 100. + p <- suppressWarnings(.cs_profile(.cs_stations())) + expect_identical( + said(p, 9), + nearest("9", 333L, 100L, "30", + paste0("That count is more than k-means can place on the layer's 100 distinct ", + "locations (100 cells), so no profile scores it."))) + # A count the stations can hold keeps the advice: 60 rows a cell are 50. + expect_identical(said(p, 60), nearest("60", 50L, 100L, "30", build("60"))) + # No location repeated: one short of the points is the most. 600 cells + # cannot be placed on 600 points, and 599 can. + q <- .cs_pooled() + expect_identical( + said(q, 1), + nearest("1", 600L, 133L, "4.51", + paste0("That count is more than k-means can place on 600 points (599 cells), so ", + "no profile scores it."))) + expect_identical(.count_at(600L, 1.002), 599L) + expect_identical(said(q, 1.002), nearest("1.002", 599L, 133L, "4.51", build("1.002"))) + # A profile fitted to a subsample knows the points and not the layer's + # distinct locations: one short of the points is still a bound. + sub <- p; attr(sub, "bounds")$n_sample <- 1500L + expect_identical(said(sub, 9), nearest("9", 333L, 100L, "30", build("9"))) + expect_identical( + said(sub, 1), + nearest("1", 3000L, 100L, "30", + paste0("That count is more than k-means can place on 3000 points (2999 cells), ", + "so no profile scores it."))) +}) + +test_that("an optimum at a finest size the profile held is on the layer's bound, and is told so", { + pts <- .cs_stations() + # Four sizes, of which three ask for more cells than the 100 stations hold. + p <- suppressWarnings(.cs_profile(pts, obs_per_cell = c(60, 30, 9, 4.5))) + expect_identical(p$levels, c(50L, 100L)) + expect_identical(attr(p, "bounds")$ceiling_from, "distinct locations") + q <- p; q$loo <- c(2, 1) + s <- select_resolution(q, criterion = "loo") + expect_identical(s$best, 100L) + expect_identical(s$edge, "the support ceiling (as many cells as the distinct locations allow)") + w <- .cs_of(.cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)), + "spatialkit_bound_chosen") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), + paste0("get_voronoi_seeds(): `n` is 100 cells, the optimum of `loo`, and that ", + "optimum is the support ceiling (as many cells as the distinct ", + "locations allow): the bound chose the count, not the criterion. Pass ", + "a number as `n` to set the count yourself.")) + # The other end is the coarsest size the caller offered. + q$loo <- c(1, 2) + expect_identical(select_resolution(q, criterion = "loo")$edge, + "the coarsest size offered (obs_per_cell)") + # A size held one short of the points, where no location repeats. + one <- suppressWarnings(.cs_profile(.cs_600(), obs_per_cell = c(4.5, 1))) + expect_identical(one$levels, c(133L, 599L)) + one$loo <- c(2, 1) + expect_identical(select_resolution(one, criterion = "loo")$edge, + "the support ceiling (one short of the points, the most k-means can fit)") +}) + +# ---- The record ---------------------------------------------------------------- + +test_that("the record has the fields of the design and no other", { + pts <- .cs_600() + p <- .cs_pooled() + s <- select_resolution(p, criterion = "size") + rec <- s$count_rule + est <- attr(p, "estimate") + expect_identical(names(rec), .cs_record) + expect_identical(class(rec), "spatialkit_count_rule") + expect_identical( + unclass(rec), + list(version = 1L, rule = "size", estimate = "pooled", cells = 133L, + obs_per_cell = 600 / 133, obs_per_cell_asked = 4.5, response = "z", + n = 600L, n_points = 600L, n_fit = 600L, seed = 123, features = "points", + scored = list(estimate = "pooled", n = 600L, cells = unname(est$cells[["133"]]), + loo = p$loo, loo_se = p$loo_se, loo_one_cell = est$loo_one_cell, + share_alone = p$share_alone, own_weight = p$own_weight, + structured = s$structured, rows = "all", + centres = unname(attr(p, "centres")[["133"]])), + partition = list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L, nstart = attr(p, "nstart")), + crs = sf::st_crs(pts), scored_cells = NA)) + expect_identical(rec$partition$nstart, 3L) + expect_identical(rec$scored$cells, 133L) + expect_true(s$structured) + # Beside the scored centres the same list says whose centres they are. + on <- attr(s$seeds, "count_rule") + expect_identical(on$scored_cells, TRUE) + on$scored_cells <- NA + expect_identical(on, rec) + expect_identical(unname(sf::st_coordinates(s$seeds)[, 1:2]), unname(attr(p, "centres")[["133"]])) + # The other attributes of the seeds are those of today. + expect_setequal(setdiff(names(attributes(s$seeds)), "count_rule"), + names(attributes(.profile_seeds(p, 133L)))) +}) + +test_that("the record's row counts tell a subsample fit from a fit to every row", { + # A ladder of sizes is fitted to every row. + rec <- select_resolution(.cs_pooled7(), criterion = "loo")$count_rule + expect_identical(c(rec$n, rec$n_points, rec$n_fit), c(600L, 600L, 600L)) + # The automatic ladder of 3,000 points (seed 4402) is fitted to 1,500. + big <- .cs_layer(3000, 4402) + p <- suppressWarnings(.cs_profile(big, n_levels = 5L, sample_n = 1500L, sac = 3e4, + obs_per_cell = NULL)) + s <- select_resolution(p, criterion = "loo") + rec <- s$count_rule + expect_identical(c(rec$n, rec$n_points, rec$n_fit), c(3000L, 3000L, 1500L)) + expect_identical(rec$rule, "loo") + expect_identical(rec$estimate, "pooled") + expect_identical(rec$obs_per_cell, 3000 / s$best) + expect_identical(rec$obs_per_cell_asked, NA_real_) + expect_identical(rec$scored$n, 3000L) + expect_identical(rec$scored$structured, s$structured) + expect_identical(s$obs_per_cell, 3000 / s$best) + expect_identical(s$scored_per_cell, p$scored_per_cell[match(s$best, p$levels)]) + # This ladder has a range floor above its first level, which the + # reliability is read from. The leave-one-out error is read at every + # level, and no floor is held for it. + b <- attr(p, "bounds") + expect_true(b$supported && is.finite(b$range) && !b$levels_given) + expect_gt(b$floor, min(p$levels)) + expect_identical(s$range_floor, NA_integer_) + low <- p; low$loo <- as.numeric(seq_along(p$levels)) + s <- select_resolution(low, criterion = "loo", range_floor = TRUE) + expect_identical(s$best, min(p$levels)) + expect_identical(s$range_floor, NA_integer_) + expect_identical(s$edge, "the first level of the ladder") + # Half of the rows scored: the record says which. + half <- .cs_profile(.cs_600(), select_on = "split") + s <- select_resolution(half, criterion = "size") + expect_identical(s$count_rule$scored$rows, "selection half") + expect_identical(s$count_rule$scored$n, attr(half, "estimate")$n) + # The count chosen is the centres; the cells that hold a scored row are + # fewer, and are the record's of what was scored. + expect_identical(s$count_rule$cells, 133L) + expect_identical(s$count_rule$scored$cells, unname(attr(half, "estimate")$cells[["133"]])) + expect_lt(s$count_rule$scored$cells, 133L) + expect_lt(s$count_rule$scored$n, 600L) + expect_identical(s$count_rule$n, 600L) + expect_identical(s$obs_per_cell, 600 / 133) + expect_identical(s$scored_per_cell, half$scored_per_cell) + expect_false(isTRUE(all.equal(s$scored_per_cell, s$obs_per_cell))) +}) + +test_that("the record names the estimate its rule was computed for", { + p <- .cs_levels() + expect_identical(attr(p, "estimate")$value, "pooled") + # Cp scores plain means, whatever the profile's estimate; the leave-one-out + # error and a size are the profile's. + cp <- select_resolution(p, criterion = "cp") + expect_identical(cp$count_rule$rule, "cp") + expect_identical(cp$count_rule$estimate, "mean") + expect_identical(cp$count_rule$scored$estimate, "pooled") + expect_identical(cp$estimate, "pooled") + expect_identical(cp$obs_per_cell_asked, NA_real_) + expect_identical(names(cp), c(.cs_present, .cs_added, "partition")) + expect_identical(attr(cp$seeds, "count_rule")$scored_cells, TRUE) + # What the profile scored at Cp's level, for its own estimate. + expect_identical(cp$count_rule$scored$loo, p$loo[match(cp$best, p$levels)]) + expect_identical(cp$count_rule$scored$structured, + .estimate_structure(p, cp$best, 0.02, n_searched = 1L)$structured) + # It is the estimate's verdict, not Cp's: with Cp's own F test made to + # fail, `structured` of the selection is FALSE and the record's is as it + # was. + expect_true(cp$structured) + expect_true(cp$count_rule$scored$structured) + chance <- p; attr(chance, "one_cell")$f_p[] <- 0.5 + s <- select_resolution(chance, criterion = "cp") + expect_false(s$structured) + expect_true(s$count_rule$scored$structured) + # And it follows the estimate's own F test, at one level searched. + weak <- p; attr(weak, "estimate")$f_p[] <- 0.04 + expect_true(select_resolution(weak, criterion = "cp")$count_rule$scored$structured) + weak <- p; attr(weak, "estimate")$f_p[] <- 0.06 + expect_false(select_resolution(weak, criterion = "cp")$count_rule$scored$structured) + # Cp's own answer is the one a profile without the estimate gives. + bare <- suppressWarnings(.cs_profile(.cs_600(), levels = c(50, 133, 300), sac = 3e4, + estimate = NULL, obs_per_cell = NULL)) + expect_identical(cp[setdiff(.cs_present, c("note", "seeds"))], + select_resolution(bare, criterion = "cp")[setdiff(.cs_present, c("note", "seeds"))]) + expect_identical(.count_rule_new(p, "loo", 133L)$estimate, "pooled") + expect_identical(.count_rule_new(p, "size", 133L, 4.5)$estimate, "pooled") + for (rule in c("reliability", "elbow", "moran_z")) + expect_identical(.count_rule_new(p, rule, 133L)$estimate, NA_character_, info = rule) + mz <- select_resolution(p, criterion = "moran_z", diagnostic = TRUE) + expect_identical(mz$count_rule$rule, "moran_z") + expect_identical(mz$count_rule$estimate, NA_character_) + expect_identical(.count_rule_new(.cs_mean7(), "loo", 133L)$estimate, "mean") + # Without an estimate a size is computed for none, and nothing is known of + # the features the profile read. + expect_identical(.count_rule_new(.cs_plain(), "size", 50L, 4.5)$estimate, NA_character_) + expect_identical(.count_rule_new(.cs_plain(), "size", 50L, 4.5)$features, NA_character_) + # Features that are not points are recorded as such: 200 discs. + discs <- sf::st_buffer(.cs_600()[1:200, ], 50) + d <- suppressWarnings(.cs_profile(discs)) + expect_identical(attr(d, "estimate")$features, "other") + expect_identical(select_resolution(d, criterion = "size")$count_rule$features, "other") + # A profile that keeps no seed. + expect_identical(.count_rule_new(.cs_plain(), "size", 50L, 4.5)$seed, NA_integer_) + unseeded <- .cs_profile(.cs_600(), seed = NULL) + expect_identical(select_resolution(unseeded, criterion = "size")$count_rule$seed, NA_integer_) +}) + +test_that("the record of plain means on a layer where some rows lack a response", { + some <- .cs_600(); some$z[1:200] <- NA + m <- .cs_profile(some, estimate = "mean", obs_per_cell = 4) + s <- select_resolution(m, criterion = "size") + rec <- s$count_rule + expect_identical(s$best, 100L) + # The size divides the rows with a response, not the points. + expect_identical(c(rec$n, rec$n_points, rec$n_fit), c(400L, 600L, 600L)) + expect_identical(rec$obs_per_cell, 4) + expect_identical(s$obs_per_cell, 4) + expect_identical(rec$obs_per_cell_asked, 4) + # The estimate is the profile's, in the rule and in what was scored. + expect_identical(rec$estimate, "mean") + expect_identical(rec$scored$estimate, "mean") + expect_identical(rec$scored$n, 400L) + expect_identical(rec$scored$loo, m$loo) + expect_identical(rec$scored$own_weight, m$own_weight) + expect_identical(rec$response, "z") +}) + +test_that("the pieces the record is read from", { + b <- list(n = 600L, n_response = 400L) + expect_identical(.count_rule_rows(b), 400L) + expect_identical(.count_rule_rows(list(n = 600L, n_response = NA_integer_)), 600L) + expect_identical(.count_rule_rows(list(n = 600L, n_response = 0L)), 600L) + expect_identical(.count_rule_rows(NULL), NA_integer_) + expect_identical(.count_rule_rows(list()), NA_integer_) + p <- .cs_pooled7() + expect_identical(.profile_at(p, 133L, "loo"), p$loo[5L]) + expect_identical(.profile_at(p, 134L, "loo"), NA_real_) + expect_identical(.profile_at(p, 133L, "nothing"), NA_real_) + # The structure test reads the profile's own numbers, and nothing once the + # column is another. + est <- attr(p, "estimate") + st <- .estimate_structure(p, 133L, 0.02, n_searched = 7L) + want <- .no_structure(p$loo[5L], est$loo_one_cell, est$f_p[["133"]], 0.02, n_searched = 7L) + expect_identical(st[c("structured", "structure_p", "beats")], + want[c("structured", "structure_p", "beats")]) + expect_identical(st$loo, p$loo[5L]) + expect_identical(st$one_cell, est$loo_one_cell) + one <- .estimate_structure(p, 133L, 0.02, n_searched = 1L) + expect_identical(one$structure_p, min(1, est$f_p[["133"]])) + expect_identical(st$structure_p, min(1, 7 * est$f_p[["133"]])) + q <- p; q$loo[1L] <- q$loo[1L] + 1 + expect_identical(.estimate_structure(q, 133L, 0.02)$structured, NA) + # Without the error of one mean there is nothing to compare with. + none <- list(structured = NA, structure_p = NA_real_, beats = NA, loo = NA_real_, + one_cell = NA_real_) + q <- p; attr(q, "estimate")$loo_one_cell <- NA_real_ + expect_identical(.estimate_structure(q, 133L, 0.02), none) + expect_identical(.estimate_structure(.cs_plain(), 50L, 0.02), none) + expect_identical(.estimate_structure(p[, c("levels", "loo")], 133L, 0.02), none) + expect_identical(.estimate_structure(.cs_plain(), 50L, 0.02)$structured, NA) +}) + + +# ---- The arguments --------------------------------------------------------------- + +test_that("obs_per_cell is NULL or one number of at least 1, and is read by \"size\" alone", { + p <- .cs_pooled() + refused <- list(list(NA, "NA"), list(0.5, "0.5"), list(c(3, 4.5), "c(3, 4.5)"), + list("auto", "\"auto\""), list(numeric(0), "numeric(0)"), list(Inf, "Inf"), + list(TRUE, "TRUE")) + for (v in refused) { + e <- .cs_error(select_resolution(p, criterion = "size", obs_per_cell = v[[1L]])) + expect_identical(conditionMessage(e), + sprintf(paste0("select_resolution(): `obs_per_cell` must be NULL or a single ", + "number of at least 1; got %s."), v[[2L]])) + expect_null(conditionCall(e)) + } + # Refused whatever the criterion. + expect_error(select_resolution(p, criterion = "loo", obs_per_cell = 0.5), + "must be NULL or a single number of at least 1; got 0.5.", fixed = TRUE) + # A size beside a criterion that is not "size". + l <- .cs_levels() + for (cr in c("cp", "reliability", "elbow", "moran_z", "loo")) { + e <- .cs_error(select_resolution(l, criterion = cr, obs_per_cell = 4.5)) + expect_identical(conditionMessage(e), + sprintf(paste0("select_resolution(): `obs_per_cell` is read by criterion = ", + "\"size\" only, and criterion = \"%s\" was asked for."), cr)) + } + # "auto" that does not resolve to "size" says what it resolved to. + e <- .cs_error(select_resolution(.cs_mean7(), criterion = "auto", obs_per_cell = 4.5)) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `obs_per_cell` is read by criterion = \"size\" ", + "only, and criterion = \"auto\" was asked for, which reads this ", + "profile by \"loo\".")) + e <- .cs_error(select_resolution(.cs_plain(), criterion = "auto", obs_per_cell = 4.5)) + expect_match(conditionMessage(e), "which reads this profile by \"cp\".", fixed = TRUE) + # And one that does is read. + expect_identical(select_resolution(.cs_pooled7(), criterion = "auto", obs_per_cell = 9)$best, + rung_k(600L, 9)) + # 1 is a size; a whole number and a named one are read as numbers. + expect_identical(suppressWarnings( + select_resolution(p, criterion = "size", obs_per_cell = 1))$obs_per_cell_asked, 1) + expect_identical(suppressWarnings( + select_resolution(p, criterion = "size", obs_per_cell = c(a = 9L)))$obs_per_cell_asked, 9) + expect_error(select_resolution(p, criterion = "sizes"), "should be one of") +}) + + +test_that("what the selection reads before it applies a rule: the size, the subset, the estimate", { + p <- .cs_pooled() + # A number that carries a class is not a size. + e <- .cs_error(select_resolution(p, criterion = "size", + obs_per_cell = structure(4.5, class = "units"))) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `obs_per_cell` must be NULL or a single number of ", + "at least 1; got an object of class units.")) + # An empty subset is told so under every criterion, a size included. + for (cr in c("size", "loo", "cp", "auto")) + expect_identical(conditionMessage(.cs_error(select_resolution(p[0, ], criterion = cr))), + paste0("select_resolution(): `profile` has no levels; it is an empty subset ", + "of a resolution profile."), info = cr) + # The estimate is read by value. + expect_identical(.profile_estimate(p), "pooled") + expect_identical(.profile_estimate(.cs_mean7()), "mean") + expect_identical(.profile_estimate(.cs_plain()), NA_character_) + expect_identical(.profile_estimate(p[, c("levels", "loo")]), NA_character_) + # An "estimate" attribute that names neither estimate is no estimate: + # "auto" reads the profile by cp, and the selection is the one cp gives. + q <- .cs_plain(); attr(q, "estimate") <- list(value = "median") + expect_identical(.profile_estimate(q), NA_character_) + s <- select_resolution(q, criterion = "auto") + expect_identical(s$criterion, "cp") + expect_identical(s, select_resolution(q, criterion = "cp")) + expect_identical(names(s), .cs_present) + # A profile built as today whose column is NA at every level has the + # present error, not the one of a ladder of sizes. + na <- .cs_plain(); na$cp <- NA_real_; na$reliability <- NA_real_ + expect_identical(conditionMessage(.cs_error(select_resolution(na, criterion = "cp"))), + paste0("select_resolution(): `cp` is NA at every level (it needs a response, ", + "and a level whose cells hold two scored rows each on average for its ", + "noise variance when the variogram gives no nugget).")) + expect_identical(conditionMessage(.cs_error(select_resolution(na, criterion = "reliability"))), + paste0("select_resolution(): `reliability` is NA at every level (it needs a ", + "usable variogram with an identified range).")) +}) + + +# ---- Structure under a size ----------------------------------------------------- + +test_that("a size on white noise is called structureless, and the seeding says so in the size's words", { + skip_on_cran() + # The layers of the engine's test 15: 300 locations uniform on a 1e5 + # square, x then y, then the response; white noise under seeds 4001 to + # 4040, the field under 5001 to 5040. + one <- function(seed, field) { + pts <- .cs_layer(300, seed, field = field) + p <- .cs_profile(pts) + s <- select_resolution(p, criterion = "size") + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + tess <- build_tessellation(r$value, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id") + out <- suppressWarnings(summarize_by_cell(asg, "z", id_col = "cell_id", estimate = "pooled")) + list(sel = s, r = r, rows = nrow(asg), summary = attr(out, "pooled")$columns$resp_z) + } + noise <- lapply(1:40, function(r) one(4000 + r, FALSE)) + field <- lapply(1:40, function(r) one(5000 + r, TRUE)) + all80 <- c(noise, field) + expect_true(all(vapply(all80, function(x) x$sel$best, 1L) == 67L)) + expect_false(anyNA(vapply(all80, function(x) x$sel$structured, NA))) + # One run of these seeds: FALSE on 39 of the noise layers, TRUE on 40 of the + # field layers. + unstructured <- vapply(noise, function(x) isFALSE(x$sel$structured), NA) + expect_gte(sum(unstructured), 36L) + expect_gte(sum(vapply(field, function(x) isTRUE(x$sel$structured), NA)), 36L) + # The warning is raised exactly where `structured` is FALSE, once. + warned <- function(x) length(.cs_of(x$r, "spatialkit_no_structure")) + expect_identical(vapply(all80, warned, 1L), + as.integer(vapply(all80, function(x) isFALSE(x$sel$structured), NA))) + expect_false(any(vapply(all80, function(x) "spatialkit_bound_chosen" %in% .cs_classes(x$r), NA))) + # In the words of a size: the count stands. + for (x in noise[unstructured]) { + w <- .cs_of(x$r, "spatialkit_no_structure")[[1L]] + expect_identical( + conditionMessage(w), + paste0("get_voronoi_seeds(): `n` is 67 cells, set by obs_per_cell = 4.5, and ", + x$sel$note[["structure"]], + " The count stands, since a size set it and no criterion; the cell values will ", + "say little that one mean for the layer does not.")) + expect_identical(.cs_fields(w), list(criterion = "size", n = 67L, one_cell = x$sel$one_cell)) + expect_identical(nrow(x$r$value), 67L) + expect_identical(names(x$sel$note), c("size", "structure")) + } + # The two forms of the note: one mean does as well, or the F test does not + # tell the cells from one mean. + ends <- ": the response shows no spatial structure that cells of this size can use." + for (x in noise[unstructured]) { + s <- x$sel + nt <- s$note[["structure"]] + if (s$one_cell <= s$loo * 1.02) + expect_identical(nt, sprintf(paste0("at 67 cells the leave-one-out error of the pooled ", + "value (%s) is not below that of one mean for the ", + "whole layer (%s) by more than 2%%%s"), + format(signif(s$loo, 3)), format(signif(s$one_cell, 3)), ends)) + else + expect_identical(nt, sprintf(paste0("the cell means at 67 cells differ from one mean for ", + "the whole layer by no more than chance allows (F ", + "test, p = %s)%s"), + format(signif(s$structure_p, 2)), ends)) + } + # What the summary of the same cells and rows records. + expect_true(all(vapply(all80, function(x) x$rows, 1L) == 300L)) + for (x in all80) { + expect_identical(x$summary$structured, x$sel$structured) + expect_equal(x$summary$loo, x$sel$loo, tolerance = 1e-10) + expect_equal(x$summary$loo_one_cell, x$sel$loo_one_cell, tolerance = 1e-10) + } +}) + +test_that("a size without structure is said at the seeding, in every function that takes the count", { + # White noise on 300 rows (seed 4001). + pts <- .cs_layer(300, 4001, field = FALSE) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + p <- .cs_profile(pts) + s <- select_resolution(p, criterion = "size") + expect_false(s$structured) + expect_identical(names(s$note), c("size", "structure")) + text <- function(fn, arg) + paste0(fn, "(): `", arg, "` is 67 cells, set by obs_per_cell = 4.5, and ", + s$note[["structure"]], + " The count stands, since a size set it and no criterion; the cell values will ", + "say little that one mean for the layer does not.") + expect_match(s$note[["structure"]], + "^at 67 cells the leave-one-out error of the pooled value \\(") + calls <- list( + list("get_voronoi_seeds", "n", + function(n) get_voronoi_seeds(method = "kmeans", n = n, sample_points = pts)), + list("voronoi_seeds_kmeans", "k", function(n) voronoi_seeds_kmeans(pts, n)), + list("build_tessellation", "approx_n_cells", + function(n) build_tessellation(pts, boundary = bnd, method = "hex", approx_n_cells = n, + quiet = TRUE))) + for (cl in calls) for (count in list(s, p)) { + r <- .cs_catch(cl[[3L]](count)) + w <- .cs_of(r, "spatialkit_no_structure") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), text(cl[[1L]], cl[[2L]])) + expect_identical(.cs_fields(w[[1L]]), list(criterion = "size", n = 67L, one_cell = s$one_cell)) + expect_null(conditionCall(w[[1L]])) + expect_false("spatialkit_bound_chosen" %in% .cs_classes(r)) + } +}) + +test_that("under a size `tol` is the margin of the structure test and one level is searched", { + p <- .cs_pooled() + est <- attr(p, "estimate") + s <- select_resolution(p, criterion = "size") + expect_true(s$structured) + expect_identical(s$structure_p, min(1, est$f_p[["133"]])) + expect_identical(s$one_cell, est$loo_one_cell) + # One level, on a ladder of seven: the F test is not adjusted for the + # levels a size did not search. + p7 <- .cs_pooled7() + s7 <- select_resolution(p7, criterion = "size") + expect_identical(s7$structure_p, min(1, attr(p7, "estimate")$f_p[["133"]])) + weak <- p7; attr(weak, "estimate")$f_p[] <- 0.02 + s7 <- select_resolution(weak, criterion = "size") + expect_identical(s7$structure_p, 0.02) + expect_true(s7$structured) + # Where "loo" searched the seven, it is. + expect_identical(select_resolution(weak, criterion = "loo")$structure_p, 0.14) + expect_false(select_resolution(weak, criterion = "loo")$structured) + # The F test alone can say no: the second form of the note. + weak <- p7; attr(weak, "estimate")$f_p[] <- 0.2 + s7 <- select_resolution(weak, criterion = "size") + expect_false(s7$structured) + expect_identical(s7$note[["structure"]], + paste0("the cell means at 133 cells differ from one mean for the whole ", + "layer by no more than chance allows (F test, p = 0.2): the response ", + "shows no spatial structure that cells of this size can use.")) + # A margin the cells do not clear. + wide <- est$loo_one_cell / p$loo - 1 + 0.01 + t <- select_resolution(p, criterion = "size", tol = wide) + expect_false(t$structured) + expect_identical(t$best, s$best) + expect_identical(t$flat, s$flat) + expect_match(t$note[["structure"]], sprintf("by more than %s%%", format(100 * wide)), fixed = TRUE) + expect_true(select_resolution(p, criterion = "size", tol = wide - 0.02)$structured) + # One mean's error equal to the cells' is not below it: the plain mean is + # named for a profile of plain means. + m <- .cs_profile(.cs_600(), estimate = "mean", obs_per_cell = 4.5) + t <- select_resolution(m, criterion = "size", tol = 10) + expect_false(t$structured) + expect_match(t$note[["structure"]], "the leave-one-out error of the plain mean (", fixed = TRUE) + # A constant response has a count and no verdict. + pts <- .cs_600(); pts$k <- 0.1 + k <- suppressWarnings(.cs_profile(pts, response = "k")) + s <- select_resolution(k, criterion = "size") + expect_identical(s$best, 133L) + expect_identical(s$structured, NA) + expect_identical(names(s$note), "size") +}) + + +# ---- "auto" --------------------------------------------------------------------- + +test_that("\"auto\" is the rule that goes with the profile's estimate", { + pooled <- .cs_pooled7(); plain <- .cs_mean7(); none <- .cs_plain() + expect_identical(select_resolution(pooled, criterion = "auto"), + select_resolution(pooled, criterion = "size")) + expect_identical(select_resolution(plain, criterion = "auto"), + select_resolution(plain, criterion = "loo")) + expect_identical(select_resolution(none, criterion = "auto"), + select_resolution(none, criterion = "cp")) + # A column subset has lost its estimate and is read by cp. + l <- .cs_levels() + expect_identical(select_resolution(l[, c("levels", "cp", "loo")], criterion = "auto"), + select_resolution(l[, c("levels", "cp", "loo")], criterion = "cp")) + # `tol` goes with it. + expect_identical(select_resolution(plain, criterion = "auto", tol = 0.2), + select_resolution(plain, criterion = "loo", tol = 0.2)) + # The criterion in the result is the one applied, and the record's rule. + for (s in list(select_resolution(pooled, criterion = "auto"), + select_resolution(plain, criterion = "auto"))) { + expect_true(s$criterion %in% c("size", "loo")) + expect_identical(s$criterion, s$count_rule$rule) + expect_identical(s$range_floor, NA_integer_) + # On a density profile the kind is the last element, after the record. + expect_identical(utils::tail(names(s), 2L), c("count_rule", "partition")) + expect_identical(s$partition, list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L)) + } + expect_identical(select_resolution(none, criterion = "auto")$criterion, "cp") + expect_identical(select_resolution(pooled, criterion = "auto")$criterion, "size") + expect_identical(select_resolution(plain, criterion = "auto")$criterion, "loo") +}) + + +# ---- Structure under "loo" -------------------------------------------------------- + +test_that("\"loo\" calls white noise structureless and a field with a nugget structured", { + skip_on_cran() + # 300 locations uniform on a 1000 x 1000 square, x then y. White noise: a + # standard normal response, seeds 2001 to 2040. A field: seeds 3001 to + # 3020, an exponential covariance with range parameter 100, sill 1 and + # nugget 0.3, drawn as the profile's test of new sites draws its own. + one <- function(seed, field, estimate) { + d <- local({ + .cs_seed(seed) + x <- stats::runif(300, 0, 1000); y <- stats::runif(300, 0, 1000) + z <- if (field) { + D <- as.matrix(stats::dist(cbind(x, y))) + as.numeric(t(chol(exp(-D / 100) + diag(1e-10, 300))) %*% stats::rnorm(300) + + stats::rnorm(300, 0, sqrt(0.3))) + } else stats::rnorm(300) + list(x = x, y = y, z = z) + }) + p <- suppressWarnings(.cs_profile(.cs_points(d$x, d$y, d$z), estimate = estimate, + obs_per_cell = .cs_sizes)) + select_resolution(p, criterion = "loo", tol = 0.02)$structured + } + for (estimate in c("mean", "pooled")) { + noise <- vapply(1:40, function(r) one(2000 + r, FALSE, estimate), NA) + field <- vapply(1:20, function(r) one(3000 + r, TRUE, estimate), NA) + expect_false(anyNA(noise), info = estimate) + expect_false(anyNA(field), info = estimate) + # One run of these seeds: TRUE on 0 (plain means) and 1 (pooled values) + # of the noise layers, and on 20 of the field layers for each. + expect_lte(sum(noise), 6L) + expect_gte(sum(field), 16L) + } +}) + +test_that("the notes of \"loo\" on a response without structure are Cp's, for the leave-one-out error", { + # White noise on 300 rows (seed 2003), the seven sizes, plain means. + pts <- .cs_layer(300, 2003, side = 1000, field = FALSE) + p <- suppressWarnings(.cs_profile(pts, estimate = "mean", obs_per_cell = .cs_sizes)) + est <- attr(p, "estimate") + s <- select_resolution(p, criterion = "loo") + expect_false(s$structured) + expect_identical(s$one_cell, est$loo_one_cell) + finite <- sum(is.finite(p$loo)) + expect_identical(s$structure_p, min(1, finite * est$f_p[[as.character(s$best)]])) + # One mean does as well as any level. + expect_lte(s$one_cell, s$value * 1.02) + expect_identical( + s$note, + c(structure = sprintf( + paste0("the leave-one-out error at one cell (%s) is within 2%% of the optimum (%s): one ", + "mean for the whole layer predicts as well as any level scored, so the response ", + "shows no spatial structure the cells can use and the count is not identified."), + format(signif(s$one_cell, 3)), format(signif(s$value, 3))))) + # The other ground: the cells beat one mean by the margin, and by no more + # than chance. A margin of 0 on a column made to beat one mean barely. + q <- p + q$loo <- est$loo_one_cell * c(0.999, 1.1, 1.1, 1.1, 1.1, 1.1, 1.1) + attr(q, "estimate")$loo_levels <- stats::setNames(q$loo, q$levels) + attr(q, "estimate")$f_p[] <- 0.5 + t <- select_resolution(q, criterion = "loo", tol = 0) + expect_false(t$structured) + expect_identical(t$structure_p, 1) + expect_identical( + t$note[["structure"]], + sprintf(paste0("the cell means at %d cells differ from one mean for the whole layer by no ", + "more than chance allows (F test of the cells against one mean, p = 1 after ", + "adjusting for the 7 levels searched), so the response shows no spatial ", + "structure the cells can use and the count is not identified. The ", + "leave-one-out error at one cell is %s against %s at the optimum, a gap that ", + "chance produces on a layer of this size."), + q$levels[1L], format(signif(est$loo_one_cell, 3)), format(signif(q$loo[1L], 3)))) + # The adjustment is for the levels with a finite error. + attr(q, "estimate")$f_p[] <- 0.004 + expect_true(select_resolution(q, criterion = "loo", tol = 0)$structured) + attr(q, "estimate")$f_p[] <- 0.008 + expect_false(select_resolution(q, criterion = "loo", tol = 0)$structured) + # No F test at the level: not known. + attr(q, "estimate")$f_p[] <- NA_real_ + t <- select_resolution(q, criterion = "loo", tol = 0) + expect_identical(t$structured, NA) + expect_identical( + t$note[["structure"]], + paste0("the leave-one-out error at one cell is above the optimum by more than `tol`, but ", + "the profile carries no F test of the cells against one mean at this level, so ", + "whether that is more than chance is not known.")) + # Passed on as the count: the present warning, with `loo` as the criterion. + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + w <- .cs_of(r, "spatialkit_no_structure") + expect_length(w, 1L) + expect_identical(conditionMessage(w[[1L]]), + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `loo`, ", + "but %s Pass a number as `n` if a count is wanted on other ", + "grounds."), s$best, s$note[["structure"]])) + expect_identical(.cs_fields(w[[1L]]), + list(criterion = "loo", n = s$best, one_cell = s$one_cell)) +}) + +test_that("\"loo\" adjusts its F test for the levels that have an error, and the record holds its verdict", { + p <- .cs_pooled7() + full <- select_resolution(p, criterion = "loo") + expect_true(full$structured) + # Seven levels searched: 0.0075 at the level is 0.0525 after the + # adjustment, and the count is not identified. + weak <- p; attr(weak, "estimate")$f_p[] <- 0.0075 + s <- select_resolution(weak, criterion = "loo") + expect_identical(s$structure_p, 0.0075 * 7) + expect_false(s$structured) + # A level without an error was not searched. Six levels: 0.045. + drop <- which(p$levels != full$best)[1L] + six <- weak; six$loo[drop] <- NA_real_ + attr(six, "estimate")$loo_levels[drop] <- NA_real_ + s <- select_resolution(six, criterion = "loo") + expect_identical(s$best, full$best) + expect_identical(s$structure_p, 0.0075 * 6) + expect_true(s$structured) + # The record's verdict is the selection's, adjusted as it is: not the one + # the level would get had it been the only level searched. + two <- p; attr(two, "estimate")$f_p[] <- 0.02 + s <- select_resolution(two, criterion = "loo") + expect_identical(s$structure_p, 0.14) + expect_false(s$structured) + expect_false(s$count_rule$scored$structured) + expect_false(attr(s$seeds, "count_rule")$scored$structured) + expect_true(.estimate_structure(two, s$best, 0.02, n_searched = 1L)$structured) +}) + +test_that("a selection whose notes the caller wrote is told in the caller's words at the seeding", { + pts <- .cs_noise() + s <- select_resolution(.cs_noise_plain(), criterion = "cp") + expect_false(s$structured) + expect_null(names(s$note)) + warned <- function(sel) { + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + conditionMessage(.cs_of(r, "spatialkit_no_structure")[[1L]]) + } + text <- function(why) + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `cp`, but %s Pass a ", + "number as `n` if a count is wanted on other grounds."), s$best, why) + stock <- "one cell for the whole layer does as well, so the count is not identified." + # As select_resolution() returned it: every note. + expect_identical(warned(s), text(paste(s$note, collapse = " "))) + expect_match(s$note, "^Cp at one cell \\(") + # What the caller put there is pasted as it always was: a note with a name + # of the caller's, a note beside the selection's own, an emptied vector + # (pasted as nothing), and no note at all (the stock sentence). + named <- s; named$note <- c(remark = "the analyst's own remark.") + expect_identical(warned(named), text("the analyst's own remark.")) + beside <- s; beside$note <- c(s$note, remark = "the analyst's own remark.") + expect_identical(warned(beside), text(paste(s$note, "the analyst's own remark."))) + empty <- s; empty$note <- character(0) + expect_identical(warned(empty), text("")) + none <- s; none$note <- NULL + expect_identical(warned(none), text(stock)) + # The provenance of a selection is the line it always was, whatever the + # selection holds as its criterion. + seeds <- suppressWarnings(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + expect_identical(attr(seeds, "n_from"), + sprintf("select_resolution(criterion = \"cp\"), an optimum at %s", s$edge)) + bare <- s; bare$criterion <- NULL + expect_identical(suppressWarnings(.resolve_cell_count(bare, "n", "f"))$from, character(0)) + # Cp without structure on a profile of pooled values: Cp's own sentence has + # no name and is said; the note about the estimate has one and is not. + pooled <- suppressWarnings(.cs_profile(pts, levels = c(10, 30, 67), sac = 3e4, + obs_per_cell = NULL)) + sp <- select_resolution(pooled, criterion = "cp") + expect_false(sp$structured) + expect_identical(names(sp$note), c("", "estimate")) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = sp, sample_points = pts)) + expect_identical(conditionMessage(.cs_of(r, "spatialkit_no_structure")[[1L]]), + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `cp`, but ", + "%s Pass a number as `n` if a count is wanted on other grounds."), + sp$best, sp$note[[1L]])) + # The same on a ladder of one size, whose note has a name too. + one <- suppressWarnings(.cs_profile(pts, sac = 3e4)) + so <- select_resolution(one, criterion = "cp") + expect_false(so$structured) + expect_identical(names(so$note), c("", "estimate", "ladder")) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = so, sample_points = pts)) + expect_identical(conditionMessage(.cs_of(r, "spatialkit_no_structure")[[1L]]), + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `cp`, but ", + "%s Pass a number as `n` if a count is wanted on other grounds."), + so$best, so$note[[1L]])) + # A selection the caller relabelled is not one a size set: it carries no + # size asked for, and is told in the present words. + relabelled <- s; relabelled$criterion <- "size" + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = relabelled, sample_points = pts)) + expect_identical(conditionMessage(.cs_of(r, "spatialkit_no_structure")[[1L]]), + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `size`, ", + "but %s Pass a number as `n` if a count is wanted on other ", + "grounds."), s$best, paste(s$note, collapse = " "))) + expect_identical(attr(r$value, "n_from"), + sprintf("select_resolution(criterion = \"size\"), an optimum at %s", s$edge)) + # The five names the warning leaves out, and no other. + expect_identical(.NOTES_NOT_STRUCTURE, c("size", "held", "finest", "estimate", "ladder")) + # A size without structure whose note of it was taken away: the size's + # stock sentence, and nothing of the note that names the size. + sized <- select_resolution(.cs_profile(pts), criterion = "size") + expect_identical(names(sized$note), c("size", "structure")) + sized$note <- sized$note["size"] + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = sized, sample_points = pts)) + expect_identical(conditionMessage(.cs_of(r, "spatialkit_no_structure")[[1L]]), + paste0("get_voronoi_seeds(): `n` is 67 cells, set by obs_per_cell = 4.5, and ", + "one mean for the whole layer predicts a left-out observation as well ", + "as cells of this size do. The count stands, since a size set it and ", + "no criterion; the cell values will say little that one mean for the ", + "layer does not.")) +}) + +test_that("the warning about structure leaves out the notes that are about something else", { + # White noise on 300 rows (seed 2003), pooled values, the seven sizes with + # the column made to fall to the finest level. + pts <- .cs_layer(300, 2003, side = 1000, field = FALSE) + p <- suppressWarnings(.cs_profile(pts, obs_per_cell = .cs_sizes)) + est <- attr(p, "estimate") + q <- p + q$loo <- est$loo_one_cell * (1 + (7:1) / 1000) + attr(q, "estimate")$loo_levels <- stats::setNames(q$loo, q$levels) + s <- select_resolution(q, criterion = "loo") + expect_false(s$structured) + expect_identical(names(s$note), c("structure", "finest")) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)) + w <- .cs_of(r, "spatialkit_no_structure")[[1L]] + expect_identical(conditionMessage(w), + sprintf(paste0("get_voronoi_seeds(): `n` is %d cells, the optimum of `loo`, ", + "but %s Pass a number as `n` if a count is wanted on other ", + "grounds."), s$best, s$note[["structure"]])) + expect_false(grepl("finest level scored", conditionMessage(w), fixed = TRUE)) +}) + + +# ---- cp and reliability on a ladder of sizes --------------------------------------- + +test_that("cp and reliability on a ladder of sizes that fitted no variogram are an error that names the ways back", { + p <- .cs_pooled() + expect_identical(attr(p, "cp_noise")$source, "none") + text <- function(criterion, from, sizes = "4.5") + sprintf(paste0("select_resolution(): `%s` is NA at every level: this profile is on a size ", + "ladder (obs_per_cell = %s), which fits no variogram unless `sac` is given, ", + "and `%s` takes its %s from one. Build the profile with `sac = NULL` to have ", + "the variogram estimated, with a `sac` of your own, or with obs_per_cell = ", + "NULL for the automatic ladder; criterion = \"size\" reads this profile."), + criterion, sizes, criterion, from) + e <- .cs_error(select_resolution(p, criterion = "cp")) + expect_identical(conditionMessage(e), text("cp", "noise variance")) + expect_null(conditionCall(e)) + e <- .cs_error(select_resolution(p, criterion = "reliability")) + expect_identical(conditionMessage(e), text("reliability", "range")) + # Several sizes are named together. + e <- .cs_error(select_resolution(.cs_mean7(), criterion = "cp")) + expect_identical(conditionMessage(e), + text("cp", "noise variance", "c(18, 12, 9, 6, 4.5, 3, ...)")) + # The two rules that need no variogram run. + expect_identical(select_resolution(p, criterion = "size")$best, 133L) + expect_identical(select_resolution(p, criterion = "loo")$best, 133L) + # The other present criteria keep their own errors there. + expect_error(select_resolution(p, criterion = "elbow"), + "`elbow` is NA at every level (the WSS curve has no elbow", fixed = TRUE) + # A constant response is said first: no variogram would change it. + pts <- .cs_600(); pts$k <- 0.1 + k <- suppressWarnings(.cs_profile(pts, response = "k")) + expect_error(select_resolution(k, criterion = "cp"), + "`cp` is NA at every level because the response is constant", fixed = TRUE) +}) + +.cs_one_size_note <- function(criterion, sizes = "4.5") + sprintf(paste0("the ladder is one size (obs_per_cell = %s), so %s had one level to choose ", + "from. Build the profile with obs_per_cell = NULL, or with several sizes, for ", + "a ladder %s can choose on."), sizes, criterion, criterion) +.cs_pooled_note <- paste0("cp scores plain means, and this profile's estimate is the pooled ", + "value; criterion = \"size\" is the rule for it.") + +test_that("with sac = NULL a ladder of one size has a cp, which returns the level and says it had one", { + skip_if_not_installed("gstat") + # The variogram is estimated, as on any profile of today. + p <- suppressWarnings(.cs_profile(.cs_600(), sac = NULL)) + expect_false(identical(attr(p, "cp_noise")$source, "none")) + expect_true(is.finite(p$cp)) + s <- select_resolution(p, criterion = "cp") + expect_identical(s$best, 133L) + expect_identical(s$edge, "the only level scored") + expect_identical(s$note[["ladder"]], .cs_one_size_note("cp")) + expect_identical(s$note[["estimate"]], .cs_pooled_note) + expect_identical(s$count_rule$rule, "cp") + expect_identical(s$count_rule$estimate, "mean") +}) + +test_that("with a variogram cp on a ladder of one size returns the level, and says it had one", { + pts <- .cs_600() + note <- .cs_one_size_note + # A `sac` of the caller's own. + p <- suppressWarnings(.cs_profile(pts, sac = 3e4)) + expect_true(is.finite(p$cp)) + s <- select_resolution(p, criterion = "cp") + expect_identical(s$best, 133L) + expect_identical(s$edge, "the only level scored") + expect_identical(s$note[c("estimate", "ladder")], + c(estimate = .cs_pooled_note, ladder = note("cp"))) + # Without an estimate the list is today's, with the note in it. + bare <- suppressWarnings(.cs_profile(pts, sac = 3e4, estimate = NULL)) + s <- select_resolution(bare, criterion = "cp") + expect_identical(names(s), c(.cs_present, "partition")) + expect_identical(s$note[["ladder"]], note("cp")) + expect_false("estimate" %in% names(s$note)) + expect_identical(s$edge, "the only level scored") + # The reliability, where the profile has one, is told the same. + r <- bare; r$reliability <- 0.5 + expect_identical(select_resolution(r, criterion = "reliability")$note, + c(ladder = note("reliability"))) + # The other criteria are not. + expect_false("ladder" %in% + names(select_resolution(bare, criterion = "moran_z", diagnostic = TRUE)$note)) + # Several sizes are a ladder to choose on: no such note, and the edges are + # the sizes offered. + many <- suppressWarnings(.cs_profile(pts, sac = 3e4, obs_per_cell = c(9, 4.5, 3))) + s <- select_resolution(many, criterion = "cp") + expect_true("estimate" %in% names(s$note)) + expect_false("ladder" %in% names(s$note)) + expect_true(is.na(s$edge) || grepl("(obs_per_cell)", s$edge, fixed = TRUE)) + # Plain means are what cp scores: nothing is said of the estimate. + m <- suppressWarnings(.cs_profile(pts, sac = 3e4, estimate = "mean", obs_per_cell = c(9, 4.5, 3))) + expect_false("estimate" %in% names(select_resolution(m, criterion = "cp")$note)) +}) + + +test_that("the notes about the estimate and the numbers of the level are written where they apply", { + # The reliability on a profile of pooled values: the note about a ladder + # of one size, and nothing about the estimate cp scores. + v <- suppressWarnings(.cs_profile(.cs_600(), sac = 3e4)) + v$reliability <- 0.5 + s <- select_resolution(v, criterion = "reliability") + expect_identical(s$note, c(ladder = .cs_one_size_note("reliability"))) + l <- .cs_levels() + expect_false("estimate" %in% + names(select_resolution(l, criterion = "moran_z", diagnostic = TRUE)$note)) + # A profile whose `loo` column is gone has no error to report, at the level + # or for one cell. + q <- l; q$loo <- NULL + expect_identical(attr(q, "estimate")$value, "pooled") + s <- select_resolution(q, criterion = "cp") + expect_identical(s$estimate, "pooled") + expect_identical(c(s$loo, s$loo_one_cell), c(NA_real_, NA_real_)) + expect_identical(s$count_rule$scored$structured, NA) +}) + + +# ---- A profile as a count ----------------------------------------------------------- + +test_that("a profile with an estimate passed as a count is read by \"auto\"", { + pts <- .cs_600() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + p <- .cs_pooled() + # No criterion a profile is read by today is finite on it. + expect_true(all(is.na(p$cp)) && all(is.na(p$reliability)) && all(is.na(p$elbow))) + expect_identical(as.integer(round(600 / 4.5)), 133L) + from <- "resolution_profile() read with select_resolution(criterion = \"size\", obs_per_cell = 4.5)" + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = p, sample_points = pts)) + expect_length(r$warnings, 0L) + expect_identical(nrow(r$value), 133L) + expect_identical(attr(r$value, "n_from"), from) + expect_identical(unname(sf::st_coordinates(r$value)[, 1:2]), unname(attr(p, "centres")[["133"]])) + r <- .cs_catch(voronoi_seeds_kmeans(pts, p)) + expect_length(r$warnings, 0L) + expect_identical(nrow(r$value), 133L) + expect_identical(attr(r$value, "n_from"), from) + r <- .cs_catch(build_tessellation(pts, boundary = bnd, method = "hex", approx_n_cells = p, + quiet = TRUE)) + expect_false(any(c("spatialkit_bound_chosen", "spatialkit_no_structure") %in% .cs_classes(r))) + expect_identical(r$value$params$approx_n_cells, 133) + expect_identical(r$value$params$approx_n_cells_from, from) + # A profile of one size that has a cp is read by its size all the same. + # Read by cp the level would be an optimum on a bound, and the count one + # chosen for plain means. + v <- suppressWarnings(.cs_profile(pts, sac = 3e4)) + expect_true(is.finite(v$cp)) + expect_identical(select_resolution(v, criterion = "cp")$edge, "the only level scored") + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = v, sample_points = pts)) + expect_length(r$warnings, 0L) + expect_identical(nrow(r$value), 133L) + expect_identical(attr(r$value, "n_from"), from) + res <- .resolve_cell_count(v, "n", "get_voronoi_seeds") + expect_identical(res$count_rule[c("rule", "estimate", "cells")], + list(rule = "size", estimate = "pooled", cells = 133L)) + expect_identical(res$edge, NA_character_) + # The selection gives the same seeds, and names its size. + s <- select_resolution(p, criterion = "size") + viasel <- get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts) + expect_identical(sf::st_coordinates(viasel), + sf::st_coordinates(get_voronoi_seeds(method = "kmeans", n = p, + sample_points = pts))) + expect_identical(attr(viasel, "n_from"), + "select_resolution(criterion = \"size\", obs_per_cell = 4.5)") + # A profile of plain means is read by its leave-one-out error. + m <- .cs_mean7() + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = m, sample_points = pts)) + loo <- select_resolution(m, criterion = "loo") + expect_identical(nrow(r$value), loo$best) + expect_match(attr(r$value, "n_from"), + "resolution_profile() read with select_resolution(criterion = \"loo\")", fixed = TRUE) + expect_identical("spatialkit_bound_chosen" %in% .cs_classes(r), !is.na(loo$edge)) + # The provenance names the bound an optimum sits on: one size is one level. + m1 <- .cs_profile(pts, estimate = "mean", obs_per_cell = 4.5) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = m1, sample_points = pts)) + expect_identical(attr(r$value, "n_from"), + paste0("resolution_profile() read with select_resolution(criterion = ", + "\"loo\"), an optimum at the only level scored")) + expect_identical(.cs_classes(r), "spatialkit_bound_chosen") +}) + +test_that("a profile on a ladder of sizes without an estimate, passed as a count, is told what reads it", { + pts <- .cs_600() + text <- function(sizes, why = "", tail = "") + sprintf(paste0("get_voronoi_seeds(): `n` is a resolution profile with no criterion finite ", + "at any level, so no cell count can be read off it. It is on a ladder of ", + "sizes (obs_per_cell = %s) and was built without an `estimate`, so it is read ", + "by `cp`, or by `elbow` when it has no `response_var`, and neither is finite ", + "on it%s. A size reads it: pass select_resolution(, criterion = ", + "\"size\") as `n`, or pass a number.%s"), sizes, why, tail) + # The geometry alone at one size. A size reads it; as a count it is read + # as a profile without an estimate is, and has nothing such a profile is + # read by. + geo <- resolution_profile(pts, partition = "kmeans", nstart = 2, sac = "auto", estimate = NULL, + obs_per_cell = 6, seed = 123) + expect_identical(select_resolution(geo, criterion = "size")$best, 100L) + e <- .cs_error(get_voronoi_seeds(method = "kmeans", n = geo, sample_points = pts)) + expect_identical(conditionMessage(e), text("6")) + expect_null(conditionCall(e)) + expect_false(inherits(e, "spatialkit_no_default_criterion")) + # A response at two sizes, with no variogram fitted. + two <- resolution_profile(pts, "z", partition = "kmeans", nstart = 2, sac = "auto", + estimate = NULL, obs_per_cell = c(9, 4.5), seed = 123) + expect_true(all(is.na(two$cp)) && all(is.na(two$reliability)) && all(is.na(two$elbow))) + expect_true(all(is.finite(two$moran_z))) + e <- .cs_error(get_voronoi_seeds(method = "kmeans", n = two, sample_points = pts)) + expect_identical( + conditionMessage(e), + text("c(9, 4.5)", + paste0(" (a ladder of sizes fits no variogram unless `sac` is given, and `cp` takes ", + "its noise variance from one)"), + paste0(" (`moran_z` is finite on it, but it is a diagnostic of the cell means and is ", + "not read as a count.)"))) + # The selection the message names is a count. + s <- select_resolution(two, criterion = "size") + expect_identical(nrow(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts)), 133L) + # summary() of that profile says the same of the ladder. + present <- paste0("summary.resolution_profile(): no count criterion is finite at any level. ", + "cp needs a response, reliability a usable variogram; a geometry-only ", + "profile carries elbow alone, and elbow is NA when the WSS curve has no elbow.") + expect_identical( + conditionMessage(.cs_error(summary(two))), + paste0(present, " moran_z is finite, and is a diagnostic: name it in `criteria` to see it.", + " The profile is on a ladder of sizes (obs_per_cell = c(9, 4.5)), which fits no ", + "variogram unless `sac` is given, so it has no cp and no reliability; ", + "select_resolution(criterion = \"size\") reads it.")) + # With another criterion finite on it the refusal is the classed one, and + # it names the size as one more reader. + bent <- two; bent$elbow <- c(0.5, 0.3) + e <- .cs_error(get_voronoi_seeds(method = "kmeans", n = bent, sample_points = pts)) + expect_s3_class(e, "spatialkit_no_default_criterion") + expect_identical( + conditionMessage(e), + paste0("get_voronoi_seeds(): `n` is a resolution profile whose `cp`, the criterion a ", + "profile is read by, is NA at every level, so no cell count is read off it. Finite ", + "on it: elbow. To use one, pass select_resolution(, criterion = \"elbow\") ", + "as `n`; or pass a number. The profile is on a ladder of sizes (obs_per_cell = c(9, ", + "4.5)): criterion = \"size\" reads it by a size.")) + # On another ladder the classed refusal ends where it does today. + today <- .cs_plain(); today$cp <- NA_real_; today$elbow[1L] <- 0.5 + e <- .cs_error(get_voronoi_seeds(method = "kmeans", n = today, sample_points = pts)) + expect_s3_class(e, "spatialkit_no_default_criterion") + expect_match(conditionMessage(e), "as `n`; or pass a number\\.$") + # A profile of the geometry on the automatic ladder keeps today's words. + auto <- suppressWarnings(resolution_profile(pts, n_levels = 6L, partition = "kmeans", nstart = 2, + sac = NULL, estimate = NULL, obs_per_cell = NULL, + seed = 123)) + expect_true(all(is.na(auto$elbow))) + expect_identical( + conditionMessage(.cs_error(get_voronoi_seeds(method = "kmeans", n = auto, sample_points = pts))), + paste0("get_voronoi_seeds(): `n` is a resolution profile with no criterion finite at any ", + "level, so no cell count can be read off it. It is geometry-only, and its WSS curve ", + "has no elbow: the points have no cluster structure to choose a count. Pass a ", + "number, or profile with a `response_var`.")) + expect_identical(conditionMessage(.cs_error(summary(auto))), present) +}) + +test_that(".resolve_cell_count() returns the record with the count", { + p <- .cs_pooled() + res <- .resolve_cell_count(p, "n", "get_voronoi_seeds") + expect_identical(names(res), c("n", "from", "seeds", "criterion", "edge", "at_floor", + "at_ceiling", "structured", "count_rule")) + expect_identical(res$n, 133) + expect_identical(res$criterion, "size") + expect_identical(class(res$count_rule), "spatialkit_count_rule") + expect_identical(res$count_rule$rule, "size") + expect_identical(res$count_rule$estimate, "pooled") + expect_identical(res$count_rule$scored_cells, NA) + expect_identical(res$count_rule, select_resolution(p, criterion = "size")$count_rule) + expect_identical(attr(res$seeds, "count_rule")$scored_cells, TRUE) + # A selection passes through with its own. + s <- select_resolution(.cs_mean7(), criterion = "loo") + res <- suppressWarnings(.resolve_cell_count(s, "k", "voronoi_seeds_kmeans")) + expect_identical(res$count_rule, s$count_rule) + expect_identical(res$from, paste0("select_resolution(criterion = \"loo\")", + if (is.na(s$edge)) "" else sprintf(", an optimum at %s", s$edge))) + # A number, and a selection of today, carry none. + expect_null(.resolve_cell_count(12, "n", "f")$count_rule) + expect_identical(.resolve_cell_count(12, "n", "f")$n, 12) + plain <- select_resolution(.cs_plain(), criterion = "cp") + expect_null(suppressWarnings(.resolve_cell_count(plain, "n", "f"))$count_rule) + expect_null(suppressWarnings(.resolve_cell_count(.cs_plain(), "n", "f"))$count_rule) + expect_identical(suppressWarnings(.resolve_cell_count(.cs_plain(), "n", "f"))$criterion, "cp") +}) + +test_that("a profile of a constant response passed as a count: a size has one, a minimum has none", { + pts <- .cs_600(); pts$k <- 0.1 + pooled <- suppressWarnings(.cs_profile(pts, response = "k")) + expect_true(is.na(pooled$loo)) + r <- .cs_catch(get_voronoi_seeds(method = "kmeans", n = pooled, sample_points = pts)) + expect_identical(nrow(r$value), 133L) + expect_false(any(c("spatialkit_no_structure", "spatialkit_bound_chosen") %in% .cs_classes(r))) + res <- .resolve_cell_count(pooled, "n", "get_voronoi_seeds") + expect_identical(res$structured, NA) + expect_identical(res$count_rule$scored$structured, NA) + expect_identical(res$count_rule$scored$loo, NA_real_) + # Plain means: select_resolution()'s own error, passed on as it is. + plain <- suppressWarnings(.cs_profile(pts, response = "k", estimate = "mean", + obs_per_cell = c(9, 4.5))) + e <- .cs_error(get_voronoi_seeds(method = "kmeans", n = plain, sample_points = pts)) + expect_identical(conditionMessage(e), + paste0("select_resolution(): `loo` is NA at every level because the response ", + "is constant: its total sum of squares is rounding error at most, so ", + "no cell count fits it better than another.")) + expect_false(inherits(e, "spatialkit_no_default_criterion")) + e <- .cs_error(voronoi_seeds_kmeans(pts, plain)) + expect_match(conditionMessage(e), "^select_resolution\\(\\): `loo` is NA at every level") +}) + + +# ---- print() ---------------------------------------------------------------------- + +test_that("a selection by size prints its size, the estimate, the level's numbers and no flat region", { + p <- .cs_pooled() + s <- select_resolution(p, criterion = "size") + out <- .cs_print(s) + expect_identical(out[1:6], c( + "Resolution by size: 133 cells", + " size : 4.5 rows per cell asked (obs_per_cell); 600 rows / 133 cells = 4.51", + " cells : density-weighted k-means++ starts (power 1, 8 neighbours)", + " estimate : pooled toward the 8 nearest cells", + sprintf(" at this size: %.1f%% of the rows are alone in their cell; median own weight %.2f", + 100 * p$share_alone, p$own_weight), + sprintf(" loo : %s (one cell for the layer: %s)", format(signif(p$loo, 3)), + format(signif(attr(p, "estimate")$loo_one_cell, 3))))) + expect_identical(out[7:8], c( + " note : the count is set by obs_per_cell = 4.5, the caller's choice;", + " no criterion chose it.")) + expect_length(out, 8L) + expect_false(any(grepl("flat region", out, fixed = TRUE))) + expect_false(any(grepl("the bound is choosing", out, fixed = TRUE))) + utils::capture.output(shown <- withVisible(print(s))) + expect_false(shown$visible) + expect_identical(shown$value, s) + # Plain means have no own weight. + m <- .cs_profile(.cs_600(), estimate = "mean", obs_per_cell = 4.5) + out <- .cs_print(select_resolution(m, criterion = "size")) + expect_identical(out[4:5], c( + " estimate : plain means", + sprintf(" at this size: %.1f%% of the rows are alone in their cell", 100 * m$share_alone))) + # Without an estimate: the size and the note. + geo <- resolution_profile(.cs_600(), partition = "kmeans", nstart = 2, sac = "auto", + estimate = NULL, obs_per_cell = 6, seed = 123) + expect_identical(.cs_print(select_resolution(geo, criterion = "size")), c( + "Resolution by size: 100 cells", + " size : 6 rows per cell asked (obs_per_cell); 600 rows / 100 cells = 6.00", + " note : the count is set by obs_per_cell = 6, the caller's choice; no", + " criterion chose it.")) +}) + +test_that("under the split the print says which rows the level's numbers are of", { + half <- .cs_profile(.cs_600(), select_on = "split") + s <- select_resolution(half, criterion = "size") + out <- .cs_print(s) + n_half <- attr(half, "estimate")$n + # The size line counts the rows of both halves. + expect_identical(out[2L], + " size : 4.5 rows per cell asked (obs_per_cell); 600 rows / 133 cells = 4.51") + # The rows the error read, the cells that hold one of them, and the rows + # per such cell: 299 rows in 75 of the 133 cells. + occupied <- unname(attr(half, "estimate")$cells[["133"]]) + expect_lt(occupied, 133L) + expect_equal(n_half / occupied, half$scored_per_cell) + line <- paste(sub("^ +", "", sub("^ at this size: ", "", out[5:6])), collapse = " ") + expect_identical(line, + sprintf(paste0("in the selection half (%d rows in %d of the 133 cells, %.2f ", + "per cell): %.1f%% of the rows are alone in their cell; median ", + "own weight %.2f"), + n_half, occupied, half$scored_per_cell, 100 * half$share_alone, + half$own_weight)) + expect_match(out[5L], "^ at this size: in the selection half \\(") + expect_match(out[6L], "^ [0-9a-z]") + # Both numbers of the next line are of that half too. + expect_identical(out[7L], + sprintf(" loo : %s (one cell for that half: %s)", + format(signif(half$loo, 3)), + format(signif(attr(half, "estimate")$loo_one_cell, 3)))) +}) + +test_that("the print says where centres hold no scored row, and leaves out what the profile lacks", { + # One row in eight has a response: 75 rows at 1.2 a cell are 62 centres, + # fitted to all 600 points, and not every one has a scored row nearest it. + some <- .cs_600(); some$z[seq_len(600) %% 8 != 0] <- NA + p <- suppressWarnings(.cs_profile(some, obs_per_cell = 1.2)) + s <- select_resolution(p, criterion = "size") + expect_identical(s$best, 62L) + occupied <- s$count_rule$scored$cells + expect_lt(occupied, 62L) + out <- .cs_print(s) + expect_identical(out[2L], + " size : 1.2 rows per cell asked (obs_per_cell); 75 rows / 62 cells = 1.21") + line <- paste(sub("^ +", "", sub("^ at this size: ", "", out[5:6])), collapse = " ") + expect_identical(line, + sprintf(paste0("in the %d of the 62 cells that hold a scored row (%.2f per ", + "cell): %.1f%% of the rows are alone in their cell; median own ", + "weight %.2f"), + occupied, p$scored_per_cell, 100 * p$share_alone, p$own_weight)) + expect_match(out[7L], "^ loo : .* \\(one cell for the layer: ") + # Every centre holds a scored row: nothing is said of cells. + expect_false(any(grepl("that hold a scored row", .cs_print( + select_resolution(.cs_pooled(), criterion = "size")), fixed = TRUE))) + # A constant response has no leave-one-out error at the level and none for + # one mean: the line is left out, and the share of rows alone is kept. + pts <- .cs_600(); pts$k <- 0.1 + k <- suppressWarnings(.cs_profile(pts, response = "k")) + expect_true(is.na(k$loo) && is.na(attr(k, "estimate")$loo_one_cell)) + out <- .cs_print(select_resolution(k, criterion = "size")) + expect_identical(out[4:5], c( + " estimate : pooled toward the 8 nearest cells", + sprintf(" at this size: %.1f%% of the rows are alone in their cell", 100 * k$share_alone))) + expect_false(any(grepl("^ loo ", out))) + # Without the share of rows alone the line that carries it is left out. + q <- .cs_pooled(); q$share_alone <- NA_real_ + out <- .cs_print(select_resolution(q, criterion = "size")) + expect_false(any(grepl("at this size", out, fixed = TRUE))) + expect_true(any(grepl("^ loo : ", out))) + # With one of the two errors the line gives it, and NA for the other. + q <- .cs_pooled(); q$loo <- NA_real_ + out <- .cs_print(select_resolution(q, criterion = "size")) + expect_true(sprintf(" loo : NA (one cell for the layer: %s)", + format(signif(attr(q, "estimate")$loo_one_cell, 3))) %in% out) + # A size of 1 is one row per cell. The profile holds it to 599 cells. + one <- suppressWarnings(.cs_profile(.cs_600(), obs_per_cell = c(4.5, 1))) + out <- .cs_print(select_resolution(one, criterion = "size", obs_per_cell = 1)) + expect_identical(out[1:2], c( + "Resolution by size: 599 cells", + " size : 1 row per cell asked (obs_per_cell); 600 rows / 599 cells = 1.00")) +}) + +test_that("a selection by loo prints the present layout with the estimate's lines added", { + p <- .cs_mean7() + s <- select_resolution(p, criterion = "loo") + out <- .cs_print(s) + at <- match(s$best, p$levels) + expect_identical(out[1:6], c( + sprintf("Resolution by loo: %d cells", s$best), + sprintf(" flat region : %s (%d of 7 levels)", .band_label(s$flat, p$levels), length(s$flat)), + " cells : density-weighted k-means++ starts (power 1, 8 neighbours)", + " estimate : plain means", + sprintf(" at this size: %.1f%% of the rows are alone in their cell", 100 * p$share_alone[at]), + sprintf(" loo : %s (one cell for the layer: %s)", format(signif(p$loo[at], 3)), + format(signif(attr(p, "estimate")$loo_one_cell, 3))))) + # A column subset has no estimate to print. + out <- .cs_print(select_resolution(p[, c("levels", "loo")], criterion = "loo")) + expect_false(any(grepl("estimate :|at this size:|loo :", out))) + # A selection by cp on a profile with an estimate prints as it does today, + # with its note. + l <- .cs_levels() + out <- .cs_print(select_resolution(l, criterion = "cp")) + expect_false(any(grepl("estimate :|at this size:|loo :", out))) + expect_true(any(grepl("note : cp scores plain means", out, fixed = TRUE))) +}) + + +# ---- summary() and plot() ---------------------------------------------------------- + +test_that("summary() reads loo where the profile has it, and refuses a size", { + l <- .cs_levels() + sm <- summary(l) + expect_true(all(c("cp", "loo") %in% sm$criterion)) + expect_identical(sm$best[sm$criterion == "loo"], select_resolution(l, criterion = "loo")$best) + expect_identical(attr(sm, "bands")$loo, select_resolution(l, criterion = "loo")$flat) + expect_null(attr(sm, "obs_per_cell")) + # Named alone. + expect_identical(summary(l, criteria = "loo")$criterion, "loo") + # A profile without the column has the table it has today. + expect_false("loo" %in% summary(.cs_plain())$criterion) + expect_error(summary(.cs_plain(), criteria = "loo"), "has no `loo` column", fixed = TRUE) + unknown <- function(cr) + sprintf(paste0("summary.resolution_profile(): unknown criteria: %s. Choose from cp, ", + "reliability, elbow, moran_z, loo."), paste(cr, collapse = ", ")) + size_says <- paste0(" A size sets the count and has no flat region to compare; ", + "select_resolution(criterion = \"size\") reads it.") + auto_says <- function(is) + sprintf(paste0(" \"auto\" names no criterion of the table; on this profile ", + "select_resolution() takes it as \"%s\"."), is) + expect_identical(conditionMessage(.cs_error(summary(l, criteria = "size"))), + paste0(unknown("size"), size_says)) + # "auto" is told what it is on the profile in hand: a size for pooled + # values, the leave-one-out error for plain means, cp without an estimate. + expect_identical(conditionMessage(.cs_error(summary(l, criteria = "auto"))), + paste0(unknown("auto"), auto_says("size"), size_says)) + expect_identical(conditionMessage(.cs_error(summary(.cs_mean7(), criteria = "auto"))), + paste0(unknown("auto"), auto_says("loo"))) + expect_identical(conditionMessage(.cs_error(summary(.cs_plain(), criteria = "auto"))), + paste0(unknown("auto"), auto_says("cp"))) + expect_identical(conditionMessage(.cs_error(summary(.cs_mean7(), criteria = c("size", "auto")))), + paste0(unknown(c("size", "auto")), auto_says("loo"), size_says)) + expect_identical(conditionMessage(.cs_error(summary(l, criteria = "nope"))), + paste0("summary.resolution_profile(): unknown criteria: nope. Choose from cp, ", + "reliability, elbow, moran_z, loo.")) + # A ladder of several sizes names the end an optimum sits on, as any ladder. + m <- .cs_mean7(); m$loo <- 1:7 + out <- .cs_print(summary(m)) + expect_true(any(grepl("loo: the optimum is the coarsest size offered (obs_per_cell).", out, + fixed = TRUE))) + expect_true(any(grepl("There the bound is choosing, not the criterion.", out, fixed = TRUE))) +}) + +test_that("for a ladder of one size summary() says the size set the count", { + pts <- .cs_600() + line <- c(" the ladder is one size (obs_per_cell = 4.5); the count is set by the size,", + " and no criterion chooses among levels.") + # No variogram: the leave-one-out error is the one criterion finite there. + p <- .cs_pooled() + sm <- summary(p) + expect_identical(sm$criterion, "loo") + expect_identical(attr(sm, "obs_per_cell"), 4.5) + expect_identical(sm$edge, "the only level scored") + out <- .cs_print(sm) + expect_identical(utils::tail(out, 2L), line) + expect_false(any(grepl("bound is choosing|only level scored", out))) + # With a variogram: one row for each criterion finite at the level. + v <- suppressWarnings(.cs_profile(pts, sac = 3e4)) + finite <- c("cp", "reliability", "elbow", "loo")[ + vapply(c("cp", "reliability", "elbow", "loo"), function(cn) is.finite(v[[cn]]), NA)] + expect_true(all(c("cp", "loo") %in% finite)) + sm <- summary(v) + expect_identical(sm$criterion, finite) + out <- .cs_print(sm) + expect_identical(out[match(line[1L], out) + 0:1], line) + expect_false(any(grepl("bound is choosing|only level scored", out))) + # A count one cell matches is still said: white noise on 300 rows (seed + # 4001). + noise <- .cs_profile(.cs_layer(300, 4001, field = FALSE)) + sm <- summary(noise) + expect_identical(sm$structured, FALSE) + out <- .cs_print(sm) + expect_identical(utils::tail(out, 4L), c( + line, + " loo: one cell for the whole layer does as well, so the response shows no", + " spatial structure the cells can use and this count is not identified.")) + # A constant response: no criterion is finite, and the error ends with the + # line and names the reader of the profile. + pts$k <- 0.1 + k <- suppressWarnings(.cs_profile(pts, response = "k")) + e <- .cs_error(summary(k)) + expect_match(conditionMessage(e), + "^summary.resolution_profile\\(\\): no count criterion is finite at any level\\. ") + ending <- paste0(" The ladder is one size (obs_per_cell = 4.5); the count is set by the size, ", + "and select_resolution(criterion = \"size\") reads it.") + expect_identical(substring(conditionMessage(e), nchar(conditionMessage(e)) - nchar(ending) + 1L), + ending) + # Several sizes, and every other ladder: no such line, and the present error. + expect_null(attr(summary(.cs_mean7()), "obs_per_cell")) + expect_false(any(grepl("the ladder is one size", .cs_print(summary(.cs_mean7())), fixed = TRUE))) + k7 <- suppressWarnings(.cs_profile(pts, response = "k", obs_per_cell = c(9, 4.5))) + e <- .cs_error(summary(k7)) + expect_false(grepl("The ladder is one size", conditionMessage(e), fixed = TRUE)) + expect_match(conditionMessage(e), "no count criterion is finite at any level", fixed = TRUE) + # Several sizes are named as a ladder of sizes, with the missing variogram + # where the profile fitted none and without it where the caller gave one. + present <- paste0("summary.resolution_profile(): no count criterion is finite at any level. ", + "cp needs a response, reliability a usable variogram; a geometry-only ", + "profile carries elbow alone, and elbow is NA when the WSS curve has no elbow.") + expect_identical( + conditionMessage(e), + paste0(present, " The profile is on a ladder of sizes (obs_per_cell = c(9, 4.5)), which ", + "fits no variogram unless `sac` is given, so it has no cp and no reliability; ", + "select_resolution(criterion = \"size\") reads it.")) + kv <- suppressWarnings(.cs_profile(pts, response = "k", obs_per_cell = c(9, 4.5), sac = 3e4)) + expect_false(identical(attr(kv, "cp_noise")$source, "none")) + expect_identical( + conditionMessage(.cs_error(summary(kv))), + paste0(present, " The profile is on a ladder of sizes (obs_per_cell = c(9, 4.5)); ", + "select_resolution(criterion = \"size\") reads it.")) +}) + +test_that("plot() draws loo like a count criterion, and a ladder of one size as points", { + skip_if_not_installed("ggplot2") + geoms <- function(g) vapply(g$layers, function(l) class(l$geom)[1L], character(1)) + points_of <- function(g) g$layers[[which(geoms(g) == "GeomPoint")[1L]]]$data + label <- "Leave-one-out error (lower is better)" + # Several levels: the selected level and the band, as for cp. + l <- .cs_levels() + g <- plot(l, criteria = "loo") + expect_s3_class(g, "ggplot") + expect_true(all(c("GeomRect", "GeomVline") %in% geoms(g))) + d <- points_of(g) + expect_identical(as.character(unique(d$panel)), label) + expect_identical(d$x, as.numeric(l$levels)) + expect_identical(d$y, l$loo) + marked <- g$layers[[which(geoms(g) == "GeomVline")]]$data + expect_identical(marked$x, select_resolution(l, criterion = "loo")$best) + expect_match(g$labels$caption, "^Red: the level each criterion selects") + # Drawn by default where the column is finite, after the other count criteria. + panels <- as.character(unique(points_of(plot(l))$panel)) + expect_true(label %in% panels) + expect_lt(match("Mallows' Cp (lower is better)", panels), match(label, panels)) + expect_false(label %in% as.character(unique(points_of(plot(.cs_plain()))$panel))) + expect_error(plot(l, criteria = "size"), + "unknown criteria: size. Choose from cp, reliability, elbow, loo, moran_z, wss.", + fixed = TRUE) + # One size: one point for each finite column, no band, no selected level. + caption <- paste0("the ladder is one size (obs_per_cell = 4.5); the count is set by the size,", + "\nand no criterion chooses among levels.") + v <- suppressWarnings(.cs_profile(.cs_600(), sac = 3e4)) + g <- plot(v) + expect_false(any(c("GeomRect", "GeomVline") %in% geoms(g))) + expect_identical(sum(geoms(g) == "GeomPoint"), 1L) + d <- points_of(g) + shown <- c("cp", "reliability", "elbow", "loo", "moran_z") + shown <- shown[vapply(shown, function(cn) is.finite(v[[cn]]), NA)] + expect_true(all(c("cp", "loo", "moran_z") %in% shown)) + expect_identical(nrow(d), length(shown)) + expect_identical(d$x, rep(133, length(shown))) + expect_identical(d$y, vapply(shown, function(cn) abs(v[[cn]]), numeric(1), USE.NAMES = FALSE)) + expect_identical(g$labels$caption, caption) + p <- .cs_pooled() + g <- plot(p) + expect_false(any(c("GeomRect", "GeomVline") %in% geoms(g))) + expect_identical(g$labels$caption, caption) + expect_identical(nrow(points_of(g)), sum(is.finite(c(p$loo, p$moran_z)))) + g <- plot(p, criteria = "loo") + expect_identical(points_of(g)$y, p$loo) + expect_false("GeomVline" %in% geoms(g)) + expect_identical(g$labels$subtitle, "1 levels from 133 to 133 cells (floor 2, ceiling 133)") + # A size too coarse for the layer: the subtitle says why the profile is not + # supported. Six rows at 4.5 a cell. + few <- suppressWarnings(.cs_profile(.cs_600()[1:6, ])) + expect_false(attr(few, "bounds")$supported) + expect_identical(plot(few, criteria = "wss")$labels$subtitle, + paste0("1 levels from 2 to 2 cells (floor 2, ceiling 2); fewer than two ", + "cells of the size asked for")) +}) + +test_that("a profile of one level that is not a ladder of one size is summarised and drawn as today", { + skip_if_not_installed("ggplot2") + for (estimate in list(NULL, "pooled")) { + what <- if (is.null(estimate)) "no estimate" else estimate + o <- suppressWarnings(.cs_profile(.cs_600(), levels = 40, partition = "kmeans", nstart = 5, + sac = 3e4, estimate = estimate, obs_per_cell = NULL)) + expect_identical(o$levels, 40L, info = what) + expect_null(attr(o, "bounds")$obs_per_cell, info = what) + sm <- summary(o) + expect_null(attr(sm, "obs_per_cell"), info = what) + expect_true("cp" %in% sm$criterion, info = what) + expect_identical("loo" %in% sm$criterion, !is.null(estimate), info = what) + expect_true(all(sm$edge == "the only level scored"), info = what) + out <- .cs_print(sm) + expect_true(sprintf(" %s: the optimum is the only level scored.", + paste(sm$criterion, collapse = ", ")) %in% out, info = what) + expect_true(" There the bound is choosing, not the criterion." %in% out, info = what) + expect_false(any(grepl("the ladder is one size", out, fixed = TRUE)), info = what) + g <- plot(o) + expect_true(all(c("GeomRect", "GeomLine", "GeomVline") %in% .cs_geoms(g)), info = what) + expect_match(g$labels$caption, "^Red: the level each criterion selects", info = what) + expect_match(g$labels$caption, "cp: optimum at the only level scored (the bound is choosing)", + fixed = TRUE, info = what) + expect_false(grepl("the ladder is one size", g$labels$caption, fixed = TRUE), info = what) + } +}) + +test_that("plot() marks a level on a ladder of several sizes, and draws no line through one point", { + skip_if_not_installed("ggplot2") + # Seven sizes are a ladder to choose on, drawn as any other. + m <- .cs_mean7() + s <- select_resolution(m, criterion = "loo") + g <- plot(m, criteria = "loo") + expect_true(all(c("GeomRect", "GeomLine", "GeomVline") %in% .cs_geoms(g))) + expect_identical(g$layers[[which(.cs_geoms(g) == "GeomVline")]]$data$x, s$best) + expect_match(g$labels$caption, "^Red: the level each criterion selects") + expect_false(grepl("the ladder is one size", g$labels$caption, fixed = TRUE)) + # One size: points alone. A line through one observation draws nothing, + # and ggplot2 says so for each panel when the plot is printed. + one <- "Each group consists of only one observation" + for (p in list(.cs_pooled(), suppressWarnings(.cs_profile(.cs_600(), sac = 3e4)))) { + g <- plot(p) + expect_identical(.cs_geoms(g), "GeomPoint") + expect_false(any(grepl(one, .cs_drawn(g), fixed = TRUE))) + } +}) diff --git a/tests/testthat/test-core-defaults.R b/tests/testthat/test-core-defaults.R new file mode 100644 index 00000000..43b2e12f --- /dev/null +++ b/tests/testthat/test-core-defaults.R @@ -0,0 +1,119 @@ +# tests/testthat/test-core-defaults.R +# --------------------------------------------------------------------------- +# The defaults that were switched together, at their values after the +# switch: eleven formal defaults in five functions, and the value of one +# internal function. A call that names none of them has pooled values at +# 4.5 rows per cell, in cells of the density kind fitted from 3 k-means++ +# starts, with no variogram fitted for a ladder of sizes. The values they +# had before are the ways back, and test-core-switch.R holds each way back +# to the object it returned. +# --------------------------------------------------------------------------- + +test_that("the eleven defaults that switch together hold their switched values", { + profile <- formals(resolution_profile) + seeds <- formals(get_voronoi_seeds) + kmeans <- formals(voronoi_seeds_kmeans) + select <- formals(select_resolution) + values <- formals(summarize_by_cell) + + # 1 to 3: the estimate follows the response, the ladder follows the + # estimate, and a variogram is fitted on a present ladder only. + expect_true("estimate" %in% names(profile)) + expect_identical(profile$estimate, "auto") + expect_true("obs_per_cell" %in% names(profile)) + expect_identical(profile$obs_per_cell, "auto") + expect_true("sac" %in% names(profile)) + expect_identical(profile$sac, "auto") + + # 4: a profile is read by the rule that goes with its estimate. "auto" + # moved to the front and nothing else in the vector changed. + expect_identical(eval(select$criterion), + c("auto", "cp", "reliability", "elbow", "moran_z", "loo", "size")) + expect_identical(eval(select$criterion)[1L], "auto") + + # 5: the summary reports pooled values beside the plain mean. + expect_identical(eval(values$estimate), c("pooled", "mean")) + expect_identical(eval(values$estimate)[1L], "pooled") + + # 6 to 8: the cells are of the density kind in all three functions. + for (f in list(profile, seeds, kmeans)) { + expect_identical(eval(f$partition), c("density", "kmeans")) + expect_identical(eval(f$partition)[1L], "density") + } + + # 9 to 11: the number of starts is the kind's own. + expect_true("nstart" %in% names(profile)) + expect_null(profile$nstart) + expect_true("kmeans_nstart" %in% names(seeds)) + expect_null(seeds$kmeans_nstart) + expect_true("nstart" %in% names(kmeans)) + expect_null(kmeans$nstart) +}) + +test_that("Moran's z is left out without its packages on every ladder", { + expect_identical(.moran_skip_any_ladder(), TRUE) + expect_identical(formals(.moran_skip_any_ladder), NULL) +}) + +test_that("the formals around the switched ones are as they were", { + # The switch edits the eleven defaults and nothing else in a signature. + expect_identical( + names(formals(resolution_profile)), + c("data_sf", "response_var", "predictor_vars", "levels", "n_levels", "min_cell_n", + "sample_n", "nstart", "seed", "sac", "select_on", "range_floor", "partition", + "init", "density_power", "density_k", "iter_max", "estimate", "obs_per_cell")) + expect_identical( + names(formals(get_voronoi_seeds)), + c("boundary", "method", "n", "seeds", "sample_points", "kmeans_nstart", "kmeans_iter", + "set_seed", "partition", "init", "density_power", "density_k")) + expect_identical( + names(formals(voronoi_seeds_kmeans)), + c("points_sf", "k", "set_seed", "nstart", "partition", "init", "density_power", + "density_k", "iter_max")) + expect_identical( + names(formals(summarize_by_cell)), + c("assigned_points_sf", "response_var", "predictor_vars", "id_col", "agg_funs", + "cells_sf", "deff", "sac", "deff_max_n", "quiet", "conf_level", "area", "estimate", + "obs_level")) + # Not switched (section 6): the arguments an interval, the design effect, + # the present ladder and the density kind read keep their values. + p <- formals(resolution_profile) + expect_identical(p$n_levels, 20L) + expect_identical(p$min_cell_n, 9L) + expect_identical(p$sample_n, 1500L) + expect_identical(p$seed, 123L) + expect_identical(p$range_floor, FALSE) + expect_identical(eval(p$init), c("kmeans++", "random")) + expect_identical(p$density_power, 1) + expect_identical(p$density_k, 8L) + expect_null(p$iter_max) + v <- formals(summarize_by_cell) + expect_null(v$conf_level) + expect_null(v$obs_level) + expect_identical(v$deff, 1) + expect_null(v$sac) + expect_identical(formals(get_voronoi_seeds)$kmeans_iter, 100) + expect_null(formals(get_voronoi_seeds)$init) + expect_null(formals(voronoi_seeds_kmeans)$init) + expect_identical(formals(voronoi_seeds_kmeans)$set_seed, 456) + expect_identical(eval(formals(get_voronoi_seeds)$method), + c("kmeans", "random", "provided")) +}) + +test_that("the values the defaults switched to are values their arguments take", { + # Each value one of the eleven switched to is a value its argument took + # before the switch, so the switch edited defaults and nothing else. + expect_true("auto" %in% eval(formals(select_resolution)$criterion)) + expect_true("pooled" %in% eval(formals(summarize_by_cell)$estimate)) + for (f in list(resolution_profile, get_voronoi_seeds, voronoi_seeds_kmeans)) + expect_true("density" %in% eval(formals(f)$partition)) + expect_identical(.NSTART_DENSITY, 3L) + expect_identical(.OBS_PER_CELL_DEFAULT, 4.5) + # The arguments this stage's rules read sit after the present ones. + expect_identical(names(formals(select_resolution)), + c("profile", "criterion", "tol", "range_floor", "diagnostic", "obs_per_cell")) + expect_null(formals(select_resolution)$obs_per_cell) + expect_identical(formals(select_resolution)$tol, 0.02) + expect_identical(formals(select_resolution)$range_floor, TRUE) + expect_identical(formals(select_resolution)$diagnostic, FALSE) +}) diff --git a/tests/testthat/test-core-docs.R b/tests/testthat/test-core-docs.R new file mode 100644 index 00000000..1cec2969 --- /dev/null +++ b/tests/testthat/test-core-docs.R @@ -0,0 +1,1291 @@ +# tests/testthat/test-core-docs.R +# ----------------------------------------------------------------------------- +# What the help, the vignettes and NEWS written for pooled cell values may say +# ----------------------------------------------------------------------------- +# The help pages, the NEWS entries and the vignette sections that describe the +# pooled value, the interval for one observation, the size and the record of +# the count are read as text. Five rules are held: +# +# * none of them names existing units (counties, ZIP code areas, ZCTAs) or +# the pilot study: the pages do not say how the package's regions compare +# with any others; +# * "calibrated" stands in them only in the sentence that denies it for +# places away from the observations, and that sentence stands wherever +# the intervals are described; +# * every figure they quote is a row of dev/sim-pooled-values.csv, the +# output of the package's own simulation, and that file is the output of +# dev/sim-pooled-values.R as it stands; the one exception is the two +# disclosures of ?summarize_by_cell that the rules of the pre-registration +# checks require (check 3, rules 3a(ii) and 3c), whose figures are held +# below as that check reported them, and which alone may name counties, +# since the fields of that check are county levels; +# * no other number stands in them but the settings of that simulation and +# the constants of the code, each read from where it is set; +# * a text that says how a number tends to behave quotes a figure for it. +# +# The word rules read whole help pages, so a sentence added anywhere on a +# page this work wrote into is read. The parts of a page are found by their +# titles, labels or first words, and each is held to its opening words, so a +# reader that returns another part fails. +# +# From the source tree (devtools::test()) the pages are read from man/, +# vignettes/ and NEWS.md. Under R CMD check the tests run beside the +# installed package: the help is read from its Rd database, NEWS and the +# vignettes from the installed files; dev/ is not built, so the figures and +# the numbers are compared in the source tree only. + +# ---- The readers -------------------------------------------------------------------- + +# The root of the source tree, or NULL when the tests do not run from one. +.docs_source <- function() { + root <- testthat::test_path("..", "..") + if (file.exists(file.path(root, "DESCRIPTION")) && dir.exists(file.path(root, "man"))) + normalizePath(root) + else NULL +} + +# A help page as parsed Rd: the file in man/, or the installed page. +.docs_rd <- function(page) { + src <- .docs_source() + if (!is.null(src)) return(tools::parse_Rd(file.path(src, "man", paste0(page, ".Rd")))) + tools::Rd_db("spatialkit")[[paste0(page, ".Rd")]] +} + +# The text of a piece of parsed Rd, markup dropped. +.docs_flat <- function(x) + paste(unlist(lapply(x, function(el) if (is.character(el)) el else .docs_flat(el))), + collapse = "") + +# Text on one line: no backticks, runs of white space as one space. +.docs_squash <- function(s) trimws(gsub("[[:space:]]+", " ", gsub("`", "", s, fixed = TRUE))) + +.docs_tag <- function(node) attr(node, "Rd_tag") %||% "" + +# The \section{}s of a parsed page: their text, named by title. +.docs_rd_sections <- function(rd) { + tags <- vapply(rd, .docs_tag, character(1)) + secs <- rd[tags == "\\section"] + stats::setNames(vapply(secs, function(s) .docs_squash(.docs_flat(s[[2L]])), character(1)), + vapply(secs, function(s) .docs_squash(.docs_flat(s[[1L]])), character(1))) +} + +# The body of one \section{}, as parsed Rd; NULL when the page has none of +# that title. +.docs_rd_section <- function(rd, title) { + for (node in rd) + if (identical(.docs_tag(node), "\\section") && + identical(.docs_squash(.docs_flat(node[[1L]])), title)) return(node[[2L]]) + NULL +} + +# The text of the top-level parts of a page that carry one tag, such as +# "\\description", "\\value" or "\\examples". +.docs_rd_part <- function(rd, tag) { + parts <- rd[vapply(rd, .docs_tag, character(1)) == tag] + .docs_squash(paste(vapply(parts, .docs_flat, character(1)), collapse = " ")) +} + +# Every \item{label}{text} inside a piece of parsed Rd, which are the entries +# of its \describe lists and of \arguments: their text, named by label. +.docs_rd_entries <- function(x) { + out <- character(0) + walk <- function(node) { + if (!is.list(node)) return(invisible()) + if (identical(.docs_tag(node), "\\item") && length(node) == 2L) { + out[[.docs_squash(.docs_flat(node[[1L]]))]] <<- .docs_squash(.docs_flat(node[[2L]])) + return(invisible()) + } + for (el in node) walk(el) + } + walk(x) + out +} +.docs_rd_arguments <- function(rd) + .docs_rd_entries(rd[vapply(rd, .docs_tag, character(1)) == "\\arguments"]) + +# The bullets of every \itemize inside a piece of parsed Rd, in order. +.docs_rd_bullets <- function(x) { + out <- character(0) + walk <- function(node) { + if (!is.list(node)) return(invisible()) + if (identical(.docs_tag(node), "\\itemize")) { + group <- cumsum(vapply(node, .docs_tag, character(1)) == "\\item") + for (g in setdiff(unique(group), 0L)) + out[[length(out) + 1L]] <<- + .docs_squash(paste(vapply(node[group == g], .docs_flat, character(1)), collapse = "")) + return(invisible()) + } + for (el in node) walk(el) + } + walk(x) + out +} + +# The paragraphs of a piece of parsed Rd: its text cut at blank lines. +.docs_rd_paragraphs <- function(x) { + p <- strsplit(.docs_flat(x), "\n[ \t]*\n", perl = TRUE)[[1L]] + p <- vapply(p, .docs_squash, character(1), USE.NAMES = FALSE) + p[nzchar(p)] +} + +# The one text of several that starts with the words given; NA when none +# does or more than one. +.docs_starting <- function(texts, first) { + hit <- texts[startsWith(texts, first)] + if (length(hit) == 1L) unname(hit) else NA_character_ +} + +# How often a text holds a phrase. +.docs_count <- function(text, phrase) { + at <- gregexpr(phrase, text, fixed = TRUE)[[1L]] + if (at[1L] < 0L) 0L else length(at) +} + +# The lines of a vignette's source, or NULL when it is not there to read. +.docs_vignette <- function(name) { + src <- .docs_source() + file <- if (!is.null(src)) file.path(src, "vignettes", paste0(name, ".Rmd")) + else system.file("doc", paste0(name, ".Rmd"), package = "spatialkit") + if (!nzchar(file) || !file.exists(file)) return(NULL) + readLines(file, warn = FALSE, encoding = "UTF-8") +} + +# Which markdown lines belong to a fenced code chunk, the fences included. +.docs_md_in_chunk <- function(lines) { + fence <- grepl("^```", lines) + (cumsum(fence) %% 2L == 1L) | fence +} + +# The sections of markdown lines at one depth of heading ("## " is 2): their +# text, named by title. A section runs to the next heading of its depth or +# above and holds its code chunks, unless `code` is FALSE. +.docs_md_sections <- function(lines, depth = 2L, code = TRUE) { + inside <- .docs_md_in_chunk(lines) + level <- ifelse(!inside & grepl("^#{2,6} ", lines), nchar(sub(" .*$", "", lines)), NA_integer_) + at <- which(level == depth) + if (!length(at)) return(stats::setNames(character(0), character(0))) + stops <- which(level <= depth) + keep <- if (code) rep(TRUE, length(lines)) else !inside + text <- vapply(at, function(a) { + nxt <- stops[stops > a] + to <- if (length(nxt)) nxt[1L] - 1L else length(lines) + idx <- seq.int(a + 1L, length.out = to - a) + .docs_squash(paste(lines[idx][keep[idx]], collapse = " ")) + }, character(1)) + stats::setNames(text, trimws(sub("^#+ ", "", lines[at]))) +} + +# The front matter of a vignette: the lines between its first two "---". +.docs_md_front <- function(lines) { + at <- which(lines == "---") + if (length(at) < 2L) return(NA_character_) + .docs_squash(paste(lines[seq.int(at[1L] + 1L, length.out = at[2L] - at[1L] - 1L)], + collapse = " ")) +} + +# The lines of NEWS.md, or NULL when the file is not there to read. +.docs_news <- function() { + src <- .docs_source() + file <- if (!is.null(src)) file.path(src, "NEWS.md") + else system.file("NEWS.md", package = "spatialkit") + if (!nzchar(file) || !file.exists(file)) return(NULL) + readLines(file, warn = FALSE, encoding = "UTF-8") +} + +# The entries under the first "# " heading of NEWS lines, the development +# version: each "* " item up to the next blank line or heading. +.docs_news_entries <- function(lines) { + top <- grep("^# ", lines) + if (!length(top)) return(character(0)) + lines <- lines[seq.int(top[1L], if (length(top) >= 2L) top[2L] - 1L else length(lines))] + ends <- which(!nzchar(trimws(lines)) | grepl("^#", lines)) + vapply(grep("^\\* ", lines), function(a) { + nxt <- ends[ends > a] + to <- if (length(nxt)) nxt[1L] - 1L else length(lines) + .docs_squash(sub("^\\* ", "", paste(lines[a:to], collapse = " "))) + }, character(1)) +} + +# ---- The rules ---------------------------------------------------------------------- + +.DOCS_DENIAL <- "Away from the observations no interval here is calibrated." + +# The words of a text that name existing units or the pilot study. +.docs_barred <- function(text) + unlist(regmatches(text, gregexpr("(?i)\\b(county|counties|zip|zcta|pilot)\\w*", text, + perl = TRUE))) + +# The places a text says "calibrated" (or any word of that stem) outside the +# sentence that denies it: each with the words round it. +.docs_calibrated <- function(text) { + rest <- gsub(.DOCS_DENIAL, " ", text, fixed = TRUE) + at <- gregexpr("(?i)\\w*calibrat\\w*", rest, perl = TRUE)[[1L]] + if (at[1L] < 0L) return(character(0)) + substring(rest, pmax(1L, at - 40L), pmin(nchar(rest), at + attr(at, "match.length") + 39L)) +} + +# The numbers a text states: digits with their thousands commas, decimals +# and exponent. Digits inside a name (tau2, sigma2) and exponents written +# with "^" are not numbers of the text. +.docs_numbers <- function(text) + regmatches(text, gregexpr( + "(?"; NULL when NEWS is not there. +.docs_news_texts <- function() { + lines <- .docs_news() + if (is.null(lines)) return(NULL) + entries <- .docs_news_entries(lines) + out <- list() + for (first in .DOCS_NEWS) out[[paste0("NEWS: ", first)]] <- .docs_starting(entries, first) + out +} + +# The sections of the vignettes this work wrote, and the two older sections +# it added sentences to; with them the front matter, whose description line +# it edited. `code = FALSE` leaves the code chunks out, and the openings +# below are those of the prose. +.DOCS_VIGNETTES <- list( + resolution = list("2" = c("Setting a size", "Leave-one-out for plain means"), + "3" = "Four criteria and a diagnostic"), + reporting = list("2" = "Reporting a cell value"), + diagnostics = list("2" = c("Four questions a score does not answer", + "6. Warnings about pooled cell values"))) +.docs_vignette_texts <- function(code = TRUE) { + out <- list() + for (name in names(.DOCS_VIGNETTES)) { + lines <- .docs_vignette(name) + if (is.null(lines)) return(NULL) + out[[paste0("vignette ", name, ": front matter")]] <- .docs_md_front(lines) + for (depth in names(.DOCS_VIGNETTES[[name]])) { + secs <- .docs_md_sections(lines, depth = as.integer(depth), code = code) + for (title in .DOCS_VIGNETTES[[name]][[depth]]) + out[[paste0("vignette ", name, ": ", title)]] <- unname(secs[title]) + } + } + out +} +.DOCS_VIGNETTE_OPENINGS <- c( + "vignette resolution: front matter" = "title: \"Choosing a resolution\"", + "vignette resolution: Setting a size" = + "Of the criteria above, all but loo score the plain mean of a cell.", + "vignette resolution: Leave-one-out for plain means" = + "With plain means the leave-one-out error does choose a count.", + "vignette resolution: Four criteria and a diagnostic" = + "elbow sees the coordinates and knows nothing about what you measured.", + "vignette reporting: front matter" = "title: \"What to save, and what to report\"", + "vignette reporting: Reporting a cell value" = + "summarize_by_cell() returns by default, beside each cell's mean, a pooled value", + "vignette diagnostics: front matter" = "title: \"Diagnostics\"", + "vignette diagnostics: Four questions a score does not answer" = + "A cross-validated RMSE tells you how far the predictions fell from the held-out values.", + "vignette diagnostics: 6. Warnings about pooled cell values" = + "summarize_by_cell() returns by default, beside each cell's mean, a pooled value") + +# ---- The simulation's output --------------------------------------------------------- + +# The MD5 sum of a file read as lines of text, as dev/sim-pooled-values.R +# takes it: the same whatever the line endings of a checkout. +.docs_text_md5 <- function(file) { + tmp <- withr::local_tempfile() + con <- file(tmp, "wb") + writeLines(readLines(file, warn = FALSE), con, sep = "\n", useBytes = TRUE) + close(con) + unname(tools::md5sum(tmp)) +} + +# The simulation's files, read from the source tree: the script's lines and +# its settings (the constants it assigns between "# ---- Settings" and +# OUT_DEFAULT), the table of its outputs, and the record of the run. NULL +# beside an installed package, where dev/ is not. +.docs_sim <- function() { + src <- .docs_source() + if (is.null(src)) return(NULL) + files <- file.path(src, "dev", c("sim-pooled-values.R", "sim-pooled-values.csv", + "sim-pooled-values-run.dcf")) + if (!all(file.exists(files))) return(NULL) + script <- readLines(files[1L], warn = FALSE) + from <- grep("^# ---- Settings", script) + to <- grep("^OUT_DEFAULT <- ", script) + block <- script[seq.int(from[1L] + 1L, to[1L] - 1L)] + set <- new.env(parent = baseenv()) + eval(parse(text = block[grepl("^[A-Z_]+ +<- ", block)]), set) + list(files = files, set = as.list(set), + out = utils::read.csv(files[2L], stringsAsFactors = FALSE), + run = as.list(read.dcf(files[3L])[1L, ])) +} + +# One row of the output, by its output, where and class (and, where those +# three leave several, a part of its quantity). +.docs_row <- function(out, output, where, class, quantity = "") { + hit <- out[out$output == output & out$where == where & out$class == class & + grepl(quantity, out$quantity, fixed = TRUE), ] + if (nrow(hit) != 1L) + stop(sprintf("%d rows of the output for: %s, %s, %s, %s", nrow(hit), output, where, class, + quantity)) + hit +} + +# A count of layers as the pages write it, and a small count in words. +.docs_layers <- function(k) if (k == 0L) "none" else if (k == 1L) "one" else as.character(k) +.docs_word <- function(k) c("one", "two", "three", "four", "five", "six", "seven", "eight", + "nine", "ten")[k] + +# Every statement of the run the pages make, as (the text it stands in, its +# words), built from the rows of the output. +.docs_claims <- function(sim) { + out <- sim$out + set <- sim$set + row <- function(...) .docs_row(out, ...) + ratio <- function(...) sprintf("%.2f", row(...)$value) + percent <- function(...) sprintf("%.1f", 100 * row(...)$value) + layers <- function(...) { r <- row(...); as.integer(round(r$value * r$n)) } + + rows <- c("1 row", "2 to 4 rows", "5 to 9 rows", "10 rows or more") + a_cl <- vapply(paste(rows, "of the layer in the cell"), + function(cl) ratio("a", "among", cl), character(1)) + a_all <- ratio("a", "among", "all rows") + a_block <- ratio("a", "block", "all rows") + b_among <- percent("b", "among", "all rows") + b_block <- percent("b", "block", "all rows") + b_lo <- sprintf("%.1f", 100 * row("b", "among", "all rows")$layer_min) + b_hi <- sprintf("%.1f", 100 * row("b", "among", "all rows")$layer_max) + b_ratio <- vapply(c("below 1", "1 to 2", "2 to 4", "4 to 8", "above 8"), function(cl) + percent("b", "among and block", paste("dist_ratio", cl)), character(1)) + c_among <- percent("c", "among", "rows whose cell has the interval") + c_block <- percent("c", "block", "rows whose cell has the interval") + d_w <- ratio("d", "white noise", "layers", "median own weight") + d_tau0 <- layers("d", "white noise", "layers", "tau2 = 0") + d_n <- row("d", "white noise", "layers", "tau2 = 0")$n + d_cor <- ratio("d", "white noise", "layers", "pooled value with the mean") + d_corm <- ratio("d", "white noise", "layers", "plain mean with the mean") + e_among <- ratio("e", "among", "cells with at least 10 further locations") + e_block <- sprintf("%.1f", row("e", "block", "cells with at least 10 further locations")$value) + f_at <- function(what, size) + layers("f", what, sprintf("obs_per_cell = %s", size), "at this size") + f_n <- row("f", "pooled value", "obs_per_cell = 2", "at this size")$n + finest <- min(set$SIZES) + sizes <- .docs_word(length(set$SIZES)) + + # What the pages say in words has to hold of the rows. + stopifnot( + "the summary raises the warning on every white-noise layer" = + identical(layers("d", "white noise", "layers", "summarize_by_cell()"), d_n), + "the plain mean's lowest loo is at 18 and at 3 on the same number of layers" = + identical(f_at("plain mean", 18), f_at("plain mean", 3)), + "the finest size is the size 2" = finest == 2, + "the two rows of the finest size agree" = + identical(f_at("pooled value", finest), + layers("f", "pooled value", sprintf("obs_per_cell = %s", finest), + "finest size")), + "the pooled value's lowest loo is at 2, 3 or 4.5 on every layer" = + f_at("pooled value", 2) + f_at("pooled value", 3) + f_at("pooled value", 4.5) == f_n, + "the plain mean's lowest loo is at one of the six sizes named on every layer" = + f_at("plain mean", 6) + f_at("plain mean", 4.5) + f_at("plain mean", 9) + + f_at("plain mean", 12) + f_at("plain mean", 18) + f_at("plain mean", 3) + + f_at("plain mean", 2) == f_n) + + pv <- "?summarize_by_cell: Pooled values" + iv <- "?summarize_by_cell: Intervals: which one answers which question" + ci <- "?summarize_by_cell: Confidence intervals, the two intervals" + op <- "?resolution_profile: Observations per cell" + lo <- "?resolution_profile: The criteria, loo" + sr <- "?select_resolution: What each criterion returns, loo" + va <- "?cell_values_at: Away from the observations" + n1 <- "NEWS: summarize_by_cell() gains estimate = \"pooled\"." + n2 <- "NEWS: summarize_by_cell() gains obs_level:" + vs <- "vignette resolution: Setting a size" + vl <- "vignette resolution: Leave-one-out for plain means" + vr <- "vignette reporting: Reporting a cell value" + vd <- "vignette diagnostics: 6. Warnings about pooled cell values" + claim <- function(where, ...) list(where = where, phrase = sprintf(...)) + list( + claim(pv, "was %s of the plain mean's", a_all), + claim(pv, paste("%s in cells that hold one of the layer's observations, %s in", + "cells of 2 to 4, %s in cells of 5 to 9 and %s in cells of 10 or more"), + a_cl[1], a_cl[2], a_cl[3], a_cl[4]), + claim(pv, "In the held-out block it was %s.", a_block), + claim(pv, "the median own weight was %s", d_w), + claim(pv, "tau2 was 0 on %d layers", d_tau0), + claim(pv, "the warning was raised on all %d", d_n), + claim(pv, "a correlation of %s with", d_cor), + claim(pv, "where the plain means had one of %s", d_corm), + claim(pv, "was %s of (1 - w) * tau2 among the observations and %s times it", + e_among, e_block), + claim(iv, paste("held %s percent of the observations held out at random among the", + "others (%s to %s percent in single layers) and %s percent of those in", + "the held-out block"), b_among, b_lo, b_hi, b_block), + claim(iv, "held %s and %s percent of them", c_among, c_block), + claim(ci, "held %s percent of the observations held out among the others", c_among), + claim(ci, "at obs_level = 0.90 held %s percent", b_among), + claim(op, "was at the size 2 on %d layers, at 3 on %d and at 4.5 on %d", + f_at("pooled value", 2), f_at("pooled value", 3), f_at("pooled value", 4.5)), + claim(op, paste("That of the plain mean was at 2 on %s: it was at 6 on %d layers, at", + "4.5 on %d, at 9 on %d, at 12 on %d, and at 18 and at 3 on %s each."), + .docs_layers(f_at("plain mean", 2)), f_at("plain mean", 6), f_at("plain mean", 4.5), + f_at("plain mean", 9), f_at("plain mean", 12), .docs_layers(f_at("plain mean", 18))), + claim(lo, paste("on a ladder of the %s sizes %s to %s, its minimum was at the finest", + "size on %d of %d layers for pooled values and on %s for plain means"), + sizes, max(set$SIZES), finest, f_at("pooled value", finest), f_n, + .docs_layers(f_at("plain mean", finest))), + claim(sr, paste("was at the finest of %s sizes on %d of %d layers, and that of the", + "plain mean on %s"), sizes, f_at("pooled value", finest), f_n, + .docs_layers(f_at("plain mean", finest))), + claim(va, paste("held %s percent of those with a dist_ratio below 1, %s percent from 1", + "to 2, %s percent from 2 to 4, %s percent from 4 to 8 and %s percent", + "above 8"), b_ratio[1], b_ratio[2], b_ratio[3], b_ratio[4], b_ratio[5]), + claim(va, paste("It held %s percent of the observations held out at random and %s", + "percent of those in the block"), b_among, b_block), + claim(n1, "among the others was %s of the plain mean's", a_all), + claim(n2, paste("held %s percent of the observations held out among the others and %s", + "percent of those in a held-out block"), b_among, b_block), + claim(n2, "read that way held %s percent of the first", c_among), + claim(vs, "the lowest loo of the pooled value was at the size 2 on %d (", + f_at("pooled value", 2)), + claim(vl, paste("the lowest loo of the plain mean was at the finest size on %s of the", + "%d layers: it was at 6 observations per cell on %d of them, at 4.5 on", + "%d and at 9 on %d"), .docs_layers(f_at("plain mean", finest)), f_n, + f_at("plain mean", 6), f_at("plain mean", 4.5), f_at("plain mean", 9)), + claim(vr, paste("held %s percent of held-out observations with a dist_ratio below 1", + "and %s percent of those above 8"), b_ratio[1], b_ratio[5]), + claim(vd, "the median own weight was %s", d_w), + claim(vd, "a correlation of %s with", d_cor), + claim(vd, "where the plain means had one of %s", d_corm), + claim(vd, paste("it came on %d of the %d white-noise layers and", + "spatialkit_no_structure on all %d"), d_tau0, d_n, d_n)) +} + +# ---- The two disclosures of the pre-registration checks ---------------------------- + +# Check 3 of the pre-registration checks simulated fields with known levels +# on two layouts of real locations. Its rules put two disclosures into the +# help: rule 3a(ii), the loss of the pooled value at observations beside a +# sharp boundary, into the help of the pooled value; and rule 3c, the +# coverage of the interval for one observation on the kind of field where it +# held less than its floor in one class, into the help of that interval. +# The figures are that check's, from its report (the table of 3a, columns +# 3a(i) and 3a(ii), and the tables of 3c), held here as it reported them to +# two decimals; dev/ holds no file of them. The fields of that check are +# county levels, so these two paragraphs, and nothing else on the pages, +# name counties. +.DOCS_CHECK3 <- list( + layouts = c(892L, 2634L), # the points of the two layouts + noise = c(5L, 20L, 50L), # the noise, percent of an observation's variance + layers = 200L, # replicates of each setting + boundary = c(21.75, 28.04), # 3a(ii): boundary rows, percent of the held-out rows + loss = c(-9.16, 56.36), # 3a(ii): pooled against plain over them, 12 settings + loss_s3 = list(c(43.21, 56.36), # county levels alone, 5 percent noise + c(11.23, 20.58), # 20 percent noise + c(-3.79, 1.47)), # 50 percent noise + loss_s5 = c(-9.16, 1.59), # county levels with a smooth field, all three + all_rows = c(-18.73, -1.75), # 3a(i): over all held-out rows, 12 settings + cover = c(89.38, 89.79), # 3c: all rows, the 12 settings read + class_min = 85.65, # 3c: the lowest class read but the failing one + fail = 83.74, # 3c: the failing class (Iowa layout, 20 percent noise, + fail_rows = 4878L, # cells of one training row) and its rows + s5_class1 = c(83.74, 87.83), # 3c: that field, cells of one, 20 and 50 percent noise + s5_class1_5 = c(82.64, 82.94)) # 3c: the same at 5 percent noise + +# The two paragraphs, by the part they stand in and their first words. +.DOCS_CHECK3_PARAGRAPHS <- c( + "?summarize_by_cell: Pooled values" = + "Beside a sharp boundary the pooled value can be further from a cell's level", + "?summarize_by_cell: Intervals: which one answers which question" = + "The second simulation described under \"Pooled values\" read the interval") + +# Those paragraphs, named by their part; NA where one is not found once. +.docs_check3_paragraphs <- function() { + rd <- .docs_rd("summarize_by_cell") + vapply(names(.DOCS_CHECK3_PARAGRAPHS), function(part) { + body <- .docs_rd_section(rd, sub("^\\?summarize_by_cell: ", "", part)) + if (is.null(body)) NA_character_ + else .docs_starting(.docs_rd_paragraphs(body), .DOCS_CHECK3_PARAGRAPHS[[part]]) + }, character(1)) +} + +# Every statement of those figures, as (the text it stands in, its words). +.docs_check3_claims <- function() { + f <- .DOCS_CHECK3 + pc <- function(x) sprintf("%.2f", abs(x)) + num <- function(x) format(x, big.mark = ",", scientific = FALSE, trim = TRUE) + pv <- "?summarize_by_cell: Pooled values" + iv <- "?summarize_by_cell: Intervals: which one answers which question" + claim <- function(where, ...) list(where = where, phrase = sprintf(...)) + list( + claim(pv, paste("on two layouts of real locations (%s and %s points, each in a county),", + "with noise of %d, %d or %d percent of an observation's variance, %d", + "layers of each, five random folds"), + num(f$layouts[1]), num(f$layouts[2]), f$noise[1], f$noise[2], f$noise[3], + f$layers), + claim(pv, "Boundary rows were %s to %s percent of the held-out observations.", + pc(f$boundary[1]), pc(f$boundary[2])), + claim(pv, "was from %s percent lower to %s percent higher.", pc(f$loss[1]), pc(f$loss[2])), + claim(pv, paste("On county levels alone it was %s and %s percent higher with %d percent", + "noise, %s and %s percent higher with %d percent, and from %s percent", + "lower to %s percent higher with %d percent"), + pc(f$loss_s3[[1]][1]), pc(f$loss_s3[[1]][2]), f$noise[1], + pc(f$loss_s3[[2]][1]), pc(f$loss_s3[[2]][2]), f$noise[2], + pc(f$loss_s3[[3]][1]), pc(f$loss_s3[[3]][2]), f$noise[3]), + claim(pv, "with the smooth field added it was from %s percent lower to %s percent higher.", + pc(f$loss_s5[1]), pc(f$loss_s5[2])), + claim(pv, "the lower of the two in every setting, by %s to %s percent.", + pc(f$all_rows[2]), pc(f$all_rows[1])), + claim(iv, paste("read the interval at obs_level = 0.90 on smooth fields of two ranges and", + "on county levels with a smooth field, with %d or %d percent noise, on", + "both layouts: twelve settings."), f$noise[2], f$noise[3]), + claim(iv, "Setting by setting it held %s to %s percent of the held-out observations.", + pc(f$cover[1]), pc(f$cover[2])), + claim(iv, paste("(1, 2 to 4, 5 to 9, 10 or more), it held at least %s percent in every", + "class but one"), pc(f$class_min)), + claim(iv, paste("on the layout of %s points with %d percent noise, it held %s percent of", + "the %s observations whose cell held one training observation."), + num(f$layouts[1]), f$noise[2], pc(f$fail), num(f$fail_rows)), + claim(iv, paste("On fields of that kind it is not a 90 percent interval in such cells:", + "there it held %s to %s percent with %d or %d percent noise, and %s and", + "%s percent with %d percent."), + pc(f$s5_class1[1]), pc(f$s5_class1[2]), f$noise[2], f$noise[3], + pc(f$s5_class1_5[1]), pc(f$s5_class1_5[2]), f$noise[1])) +} + +# Every text a figure can stand in: the parts of the help, the NEWS entries +# and the prose of the vignette sections. +.docs_all_texts <- function() c(.docs_parts(), .docs_news_texts(), .docs_vignette_texts(FALSE)) + +# A text with the run's statements taken out: what is left holds the +# numbers that are not figures of the simulation. +.docs_rest <- function(text, claims, where) { + for (cl in claims) if (identical(cl$where, where)) text <- sub(cl$phrase, " ", text, fixed = TRUE) + text +} + +# The texts this work wrote whole: the ones whose numbers are all accounted +# for, and in which a statement of how a number tends to behave needs a +# figure. The older sections it added sentences to are read by the word +# rules only. +.DOCS_WRITTEN <- c( + "?summarize_by_cell: Pooled values", + "?summarize_by_cell: Intervals: which one answers which question", + "?summarize_by_cell: Conditions", + "?summarize_by_cell: Confidence intervals, the two intervals", + "?summarize_by_cell: argument estimate", + "?summarize_by_cell: argument obs_level", + "?resolution_profile: Observations per cell", + "?resolution_profile: The ladder and its bounds, min_cell_n", + "?resolution_profile: The ladder and its bounds, a ladder of sizes", + "?resolution_profile: The ladder and its bounds, no variogram", + "?resolution_profile: The criteria, loo", + "?select_resolution: What each criterion returns, loo", + "?select_resolution: What each criterion returns, size", + "?select_resolution: What each criterion returns, auto", + "?select_resolution: A profile built with an estimate", + "?cell_values_at: Away from the observations", + "?spatialkit: the two choices", + "?spatialkit: the conventions of pooled values", + paste0("NEWS: ", .DOCS_NEWS), + "vignette resolution: Setting a size", + "vignette resolution: Leave-one-out for plain means", + "vignette reporting: Reporting a cell value", + "vignette diagnostics: 6. Warnings about pooled cell values") + + +# ---- The readers and the rules themselves -------------------------------------------- + +test_that("a section is found by its title and read without its markup", { + rd_file <- withr::local_tempfile(fileext = ".Rd") + writeLines(c( + "\\name{x}", "\\alias{x}", "\\title{A page}", + "\\description{Counties are named in the \\code{description}.}", + "\\section{Intervals: which one}{", + "First \\code{a + b} line,", " and a second with \\emph{stress}.", + "\\itemize{", "\\item one", "\\item two \\verb{..ci_*}", "}", "}", + "\\section{Other}{Nothing here.}"), rd_file) + rd <- tools::parse_Rd(rd_file) + secs <- .docs_rd_sections(rd) + expect_identical(names(secs), c("Intervals: which one", "Other")) + expect_identical(secs[["Intervals: which one"]], + "First a + b line, and a second with stress. one two ..ci_*") + expect_identical(secs[["Other"]], "Nothing here.") + # A section's text holds no other part of the page; the page's text holds all. + expect_false(any(grepl("Counties", secs, fixed = TRUE))) + expect_match(.docs_squash(.docs_flat(rd)), "Counties are named in the description.", + fixed = TRUE) + expect_identical(.docs_rd_part(rd, "\\description"), "Counties are named in the description.") + expect_identical(.docs_squash(.docs_flat(.docs_rd_section(rd, "Other"))), "Nothing here.") + expect_null(.docs_rd_section(rd, "Intervals")) + expect_identical(.docs_rd_bullets(rd), c("one", "two ..ci_*")) + + md <- c("---", "title: t", "---", "", "Intro with a county.", "", "## First ", "", + "Text of `one`,", "wrapped.", "", "```{r}", "x <- 1 # zip", "## not a heading", + "```", "", "### A subsection", "stays inside.", "", "## 6. Second", "Last line.") + ms <- .docs_md_sections(md) + expect_identical(names(ms), c("First", "6. Second")) + expect_identical( + ms[["First"]], + "Text of one, wrapped. {r} x <- 1 # zip ## not a heading ### A subsection stays inside.") + expect_identical(ms[["6. Second"]], "Last line.") + expect_identical(.docs_md_sections(md, code = FALSE)[["First"]], + "Text of one, wrapped. ### A subsection stays inside.") + expect_identical(.docs_md_sections(md, depth = 3L), + c("A subsection" = "stays inside.")) + expect_identical(.docs_md_sections(c("no", "heading")), + stats::setNames(character(0), character(0))) + expect_identical(.docs_md_front(md), "title: t") + expect_identical(.docs_md_in_chunk(md)[12:15], rep(TRUE, 4L)) + expect_false(any(.docs_md_in_chunk(md)[-(12:15)])) +}) + +test_that("an entry, a bullet, a paragraph and a NEWS entry are found and read without their markup", { + rd_file <- withr::local_tempfile(fileext = ".Rd") + writeLines(c( + "\\name{x}", "\\alias{x}", "\\title{A page}", + "\\arguments{", "\\item{a}{The first, \\code{NULL} or a number.}", "", + "\\item{b}{The second.}", "}", + "\\section{The criteria}{", "Opening words of the first paragraph,", "on two lines.", "", + "\\describe{", "\\item{\\code{cp}}{An older entry, calibrated.}", + "\\item{\\code{loo}}{The new \\emph{entry}.}", "}", "", + "A last paragraph", "of the section.", "}", + "\\section{Defaults}{", "\\itemize{", "\\item The 8 nearest cells: a convention.", + "\\item The two limits,", " on two lines.", "}", "}"), rd_file) + rd <- tools::parse_Rd(rd_file) + expect_identical(.docs_rd_arguments(rd), + c(a = "The first, NULL or a number.", b = "The second.")) + body <- .docs_rd_section(rd, "The criteria") + expect_identical(.docs_rd_entries(body), + c(cp = "An older entry, calibrated.", loo = "The new entry.")) + expect_identical(.docs_rd_paragraphs(body)[c(1L, 3L)], + c("Opening words of the first paragraph, on two lines.", + "A last paragraph of the section.")) + expect_identical(.docs_rd_bullets(.docs_rd_section(rd, "Defaults")), + c("The 8 nearest cells: a convention.", "The two limits, on two lines.")) + # One text of several by its first words; none or two is no answer. + texts <- c("The two limits, on two lines.", "The 8 nearest cells.", "The 8 values.") + expect_identical(.docs_starting(texts, "The two"), "The two limits, on two lines.") + expect_identical(.docs_starting(texts, "The 8"), NA_character_) + expect_identical(.docs_starting(texts, "The 5"), NA_character_) + expect_identical(.docs_count("a figure, a figure and a number", "a figure"), 2L) + expect_identical(.docs_count("a figure", "another"), 0L) + + news <- c("# pkg (development version)", "", "## New features", "", + "* First `entry` of", " two lines.", "", "* Second entry.", " More.", "", + " A second paragraph.", "", "# pkg 1.0", "", "* An older entry.") + expect_identical(.docs_news_entries(news), + c("First entry of two lines.", "Second entry. More.")) + expect_identical(.docs_news_entries(c("no", "heading")), character(0)) +}) + +test_that("the rules find what they are for, and nothing else", { + expect_identical(.docs_barred("Tracts nest in a County; counties, ZIP codes and ZCTAs do not."), + c("County", "counties", "ZIP", "ZCTAs")) + expect_identical(.docs_barred("the pilot study; a Pilot; zip code areas; zcta5"), + c("pilot", "Pilot", "zip", "zcta5")) + # Letters inside another word are not the word. + expect_identical(.docs_barred("an unzipped archive, a copilot and a viscounty"), + character(0)) + expect_identical(.docs_barred("cells, regions and observations"), character(0)) + + expect_identical(.docs_calibrated(.DOCS_DENIAL), character(0)) + expect_identical( + .docs_calibrated(paste("An interval.", .DOCS_DENIAL, "A value.", .DOCS_DENIAL)), + character(0)) + expect_length(.docs_calibrated("The interval is calibrated among the observations."), 1L) + expect_length(.docs_calibrated(paste(.DOCS_DENIAL, "Its calibration was checked.")), 1L) + expect_length(.docs_calibrated("Miscalibrated here. Uncalibrated there, far apart from the first one by many words."), 2L) + # The denial with another word in it is not the denial. + expect_length(.docs_calibrated("Away from the observations every interval here is calibrated."), + 1L) + expect_identical(.docs_calibrated("No such word."), character(0)) + + expect_identical( + .docs_numbers("tau2 = max(0, x) / (1 - w); 1,500 rows at 4.5 a cell, 0.90, 2e9 and 1e10; at 18, 12 and 9."), + c("0", "1", "1,500", "4.5", "0.90", "2e9", "1e10", "18", "12", "9")) + expect_identical(.docs_numbers("held 89.6 percent; -0.02; the 8-nearest; about 44,700."), + c("89.6", "0.02", "8", "44,700")) + # Digits inside a name, and an exponent, are not numbers of the text. + expect_identical(.docs_numbers("sigma2, tau2, s^2, loo_se, ..ci_lo_* and k-means++"), + character(0)) + + expect_identical(.docs_hedges("It tends to fall; in practice often, and usually so. Mostly."), + c("tends", "in practice", "often", "usually", "Mostly")) + expect_identical(.docs_hedges("It extends the pretend, softened, usual cause."), character(0)) +}) + + +# ---- The help ------------------------------------------------------------------------- + +test_that("the parts of the help written for pooled cell values are where their titles, labels and first words say", { + expect_length(.DOCS_PAGES, 12L) + for (page in .DOCS_PAGES) expect_false(is.null(.docs_rd(page)), info = page) + parts <- .docs_parts() + expect_length(parts, 27L) + expect_identical(names(parts), names(.DOCS_OPENINGS)) + for (what in names(parts)) { + expect_false(is.na(parts[[what]]), info = what) + # A part read under a title is that part: it opens with its own words. + expect_identical(substr(parts[[what]], 1L, nchar(.DOCS_OPENINGS[[what]])), + .DOCS_OPENINGS[[what]], info = what) + # A part that is there has text to read beyond them: the rules cannot + # pass on an empty one. + expect_gt(nchar(parts[[what]]), nchar(.DOCS_OPENINGS[[what]]) + 100L, label = what) + } + # No two titles are answered with one text. + expect_identical(anyDuplicated(unlist(parts)), 0L) + # The lead sentence, and the six conventions. + expect_identical(.docs_count(parts[["?summarize_by_cell: Description"]], paste( + "It also returns a pooled value for each cell, its mean pulled toward the mean of", + "the cells around it (estimate = \"pooled\", the default; estimate = \"mean\" leaves", + "it out), and can return a range for one further observation.")), 1L) + expect_length(.DOCS_CONVENTIONS, 6L) + for (first in .DOCS_CONVENTIONS) + expect_identical(.docs_count(parts[["?spatialkit: the conventions of pooled values"]], first), + 1L, info = first) + # Every text held to its numbers is one of the parts, an entry of NEWS or + # a vignette section. + expect_true(all(.DOCS_WRITTEN %in% c(names(parts), paste0("NEWS: ", .DOCS_NEWS), + names(.DOCS_VIGNETTE_OPENINGS)))) +}) + +test_that("no help page this work wrote into names existing units or the pilot study", { + pages <- .docs_pages() + expect_identical(names(pages), paste0("?", .DOCS_PAGES)) + # The two disclosures of check 3 stand once on their page, name counties + # for the fields that check simulated and name nothing else, and are taken + # out before the rule reads the page. + disclosures <- .docs_check3_paragraphs() + expect_length(disclosures, 2L) + for (what in names(disclosures)) { + expect_false(is.na(disclosures[[what]]), info = what) + expect_identical(.docs_count(pages[["?summarize_by_cell"]], disclosures[[what]]), 1L, + info = what) + expect_true(all(tolower(.docs_barred(disclosures[[what]])) %in% c("county", "counties")), + info = what) + expect_gt(length(.docs_barred(disclosures[[what]])), 0L, label = what) + pages[["?summarize_by_cell"]] <- sub(disclosures[[what]], " ", pages[["?summarize_by_cell"]], + fixed = TRUE) + } + for (what in names(pages)) { + expect_false(is.na(pages[[what]]), info = what) + expect_gt(nchar(pages[[what]]), 2000L, label = what) + expect_identical(.docs_barred(pages[[what]]), character(0), info = what) + } + # A part is a piece of its page, so the rule reads every part too. + parts <- .docs_parts() + for (what in names(parts)) { + page <- pages[[sub("spatialkit$", "spatialkit-package", sub(":.*$", "", what))]] + expect_identical(.docs_count(page, substr(parts[[what]], 1L, 200L)), 1L, info = what) + } +}) + +test_that("on those pages \"calibrated\" stands only in the sentence that denies it away from the observations, and in what they said of other things before this work", { + pages <- .docs_pages() + expect_identical(names(.DOCS_OLDER), + c("resolution_profile", "spatialkit-package", "plot.resolution_profile")) + expect_identical(lengths(.DOCS_OLDER, use.names = FALSE), c(2L, 1L, 1L)) + for (what in names(pages)) { + text <- pages[[what]] + for (phrase in .DOCS_OLDER[[sub("^\\?", "", what)]]) { + expect_identical(.docs_count(text, phrase), 1L, info = paste(what, phrase)) + text <- sub(phrase, " ", text, fixed = TRUE) + } + expect_identical(.docs_calibrated(text), character(0), info = what) + } +}) + +test_that("the help says, wherever it describes the intervals, that none is calibrated away from the observations", { + expect_length(.DOCS_DENIED_IN, 5L) + parts <- .docs_parts() + for (what in grep("^\\?", .DOCS_DENIED_IN, value = TRUE)) { + expect_true(what %in% names(parts), info = what) + expect_identical(.docs_count(parts[[what]], .DOCS_DENIAL), 1L, info = what) + } + expect_length(grep("^\\?", .DOCS_DENIED_IN), 4L) +}) + +test_that("the help says of a level above the limit of Moran's z what the code does there", { + op <- .docs_parts()[["?resolution_profile: Observations per cell"]] + expect_identical(.docs_count(op, sprintf( + "moran_i and moran_z need FNN and Matrix at a level where more than %s cells hold a scored row.", + format(.KNN_DENSE_MAX, big.mark = ","))), 1L) + expect_identical(.docs_count(op, paste( + "Without them a ladder of sizes has NA in both columns there, with a warning of class", + "spatialkit_moran_skipped")), 1L) + # Until the rule of a ladder of sizes holds on every ladder, a ladder set + # another way stops at such a level, and the help says so. + expect_identical(.docs_count(op, "a ladder set any other way stops there with an error"), + if (.moran_skip_any_ladder()) 0L else 1L) +}) + + +# ---- NEWS ----------------------------------------------------------------------------- + +test_that("the NEWS entries of this work are found, name no existing units and claim no calibration", { + news <- .docs_news_texts() + if (is.null(news)) skip("NEWS.md is not there to read") + expect_length(.DOCS_NEWS, 12L) + expect_identical(names(news), paste0("NEWS: ", .DOCS_NEWS)) + for (what in names(news)) { + expect_false(is.na(news[[what]]), info = what) + expect_identical(.docs_barred(news[[what]]), character(0), info = what) + expect_identical(.docs_calibrated(news[[what]]), character(0), info = what) + } + expect_identical(anyDuplicated(unlist(news)), 0L) +}) + + +# ---- The vignettes --------------------------------------------------------------------- + +test_that("the vignette sections written for pooled cell values are where their titles say", { + prose <- .docs_vignette_texts(code = FALSE) + if (is.null(prose)) skip("the vignettes' sources are not installed") + whole <- .docs_vignette_texts() + expect_length(prose, 9L) + expect_identical(names(prose), names(.DOCS_VIGNETTE_OPENINGS)) + expect_identical(names(whole), names(prose)) + for (what in names(prose)) { + expect_false(is.na(prose[[what]]), info = what) + expect_identical(substr(prose[[what]], 1L, nchar(.DOCS_VIGNETTE_OPENINGS[[what]])), + .DOCS_VIGNETTE_OPENINGS[[what]], info = what) + expect_gt(nchar(prose[[what]]), nchar(.DOCS_VIGNETTE_OPENINGS[[what]]) + 100L, label = what) + # The text with its code holds no less than the prose. + expect_gte(nchar(whole[[what]]), nchar(prose[[what]]), label = what) + } + expect_identical(anyDuplicated(unlist(prose)), 0L) + # The sentences added to the two older sections are in the texts read. + expect_identical(.docs_count(prose[["vignette resolution: Four criteria and a diagnostic"]], + "What cp estimates is the error of re-measuring the sampled sites"), + 1L) + expect_identical(.docs_count(prose[["vignette diagnostics: Four questions a score does not answer"]], + "a sixth reads the warnings summarize_by_cell() raises about pooled cell values"), + 1L) +}) + +test_that("no vignette section written for pooled cell values names existing units or the pilot study", { + texts <- .docs_vignette_texts() + if (is.null(texts)) skip("the vignettes' sources are not installed") + for (what in names(texts)) + expect_identical(.docs_barred(texts[[what]]), character(0), info = what) +}) + +test_that("in those sections \"calibrated\" stands only in the sentence that denies it, and the sentence stands where an interval is reported", { + texts <- .docs_vignette_texts() + if (is.null(texts)) skip("the vignettes' sources are not installed") + for (what in names(texts)) + expect_identical(.docs_calibrated(texts[[what]]), character(0), info = what) + for (what in grep("^vignette ", .DOCS_DENIED_IN, value = TRUE)) { + expect_true(what %in% names(texts), info = what) + expect_identical(.docs_count(texts[[what]], .DOCS_DENIAL), 1L, info = what) + } + expect_length(grep("^vignette ", .DOCS_DENIED_IN), 1L) +}) + + +# ---- The figures ------------------------------------------------------------------------ + +test_that("the simulation's output is the output of the script as it stands", { + if (is.null(.docs_source())) skip("dev/ is in the source tree only") + sim <- .docs_sim() + expect_false(is.null(sim), label = "the script, its output and the record of its run are in dev/") + if (is.null(sim)) return(invisible()) + # The record of the run names the script and the table by the sums of + # their text: an edit of either fails here until the script is run again. + expect_identical(sim$run$script, "dev/sim-pooled-values.R") + expect_identical(sim$run$script_md5, .docs_text_md5(sim$files[1L])) + expect_identical(sim$run$csv_md5, .docs_text_md5(sim$files[2L])) + expect_identical(as.integer(sim$run$layers), sim$set$LAYERS) + + out <- sim$out + set <- sim$set + expect_identical(names(out), c("output", "quantity", "where", "class", "value", "n", + "layer_min", "layer_max")) + expect_identical(unique(out$output), c("a", "b", "c", "d", "e", "f")) + expect_false(anyNA(out$value)) + # How many rows and layers each figure is of. + held <- c(among = set$N_AMONG, block = set$N_BLOCK) * set$LAYERS + for (w in names(held)) { + expect_identical(.docs_row(out, "a", w, "all rows")$n, held[[w]], info = w) + expect_identical(.docs_row(out, "b", w, "all rows")$n, held[[w]], info = w) + expect_identical(sum(out$n[out$output == "a" & out$where == w & out$class != "all rows"]), + held[[w]], info = w) + expect_lte(.docs_row(out, "c", w, "rows whose cell has the interval")$n, held[[w]]) + } + expect_identical(sum(out$n[out$output == "b" & out$where == "among and block"]), sum(held)) + expect_true(all(out$n[out$output %in% c("d", "f")] == set$LAYERS)) + # A coverage and a share lie between 0 and 1. + share <- out$output %in% c("b", "c", "f") | (out$output == "d" & grepl("^share", out$quantity)) + expect_identical(sum(share), 28L) + expect_true(all(out$value[share] >= 0 & out$value[share] <= 1)) + # Output f has one row per size for each estimate, of whole layers, and + # every layer has its lowest loo at one of the sizes. + for (what in c("pooled value", "plain mean")) { + at <- out[out$output == "f" & out$where == what & + grepl("at this size", out$quantity, fixed = TRUE), ] + expect_identical(at$class, sprintf("obs_per_cell = %s", set$SIZES), info = what) + expect_equal(at$value * at$n, round(at$value * at$n), info = what) + expect_equal(sum(at$value), 1, info = what) + } + # The script profiles at the sizes and the default size the package has. + expect_identical(set$SIZES, .OBS_PER_CELL_LADDER) + expect_identical(set$SIZE, .OBS_PER_CELL_DEFAULT) +}) + +test_that("every figure the help, the vignettes and NEWS quote is a row of the simulation's output", { + sim <- .docs_sim() + if (is.null(sim)) skip("dev/sim-pooled-values.csv is in the source tree only") + claims <- .docs_claims(sim) + texts <- .docs_all_texts() + expect_length(claims, 29L) + for (cl in claims) { + expect_true(cl$where %in% names(texts), info = cl$where) + expect_identical(.docs_count(texts[[cl$where]], cl$phrase), 1L, + info = sprintf("%s does not say, once: %s", cl$where, cl$phrase)) + } + # A setting the page gives in words. + expect_identical(sim$set$NEAR, 0.8) + expect_identical(.docs_count(texts[["?summarize_by_cell: Pooled values"]], + "four fifths of them round"), 1L) +}) + +test_that("the two disclosures of the pre-registration checks stand in the help with that check's figures", { + claims <- .docs_check3_claims() + texts <- .docs_parts() + disclosures <- .docs_check3_paragraphs() + expect_length(claims, 11L) + for (cl in claims) { + expect_true(cl$where %in% names(texts), info = cl$where) + # In the paragraph, and once in the part that holds it. + expect_identical(.docs_count(disclosures[[cl$where]], cl$phrase), 1L, + info = sprintf("the disclosure in %s does not say: %s", cl$where, cl$phrase)) + expect_identical(.docs_count(texts[[cl$where]], cl$phrase), 1L, + info = sprintf("%s does not say, once: %s", cl$where, cl$phrase)) + } + # The interval's paragraph does not call it a 90 percent interval on the + # field where a class fell below the floor: it gives the coverage. + expect_identical(.docs_count(disclosures[[2L]], "about 90 percent"), 0L) + # The figures as the check reported them: the ranges are its least and + # most, the loss over boundary rows spans both fields. + f <- .DOCS_CHECK3 + expect_identical(f$loss, range(c(unlist(f$loss_s3), f$loss_s5))) + expect_identical(f$fail, f$s5_class1[1]) + expect_lt(f$fail, 85) + expect_gte(f$class_min, 85) +}) + +test_that("no number stands in those texts but the simulation's figures, its settings and the code's constants", { + sim <- .docs_sim() + if (is.null(sim)) skip("dev/sim-pooled-values.csv is in the source tree only") + set <- sim$set + claims <- c(.docs_claims(sim), .docs_check3_claims()) + texts <- .docs_all_texts() + num <- function(x) format(x, big.mark = ",", scientific = FALSE, trim = TRUE) + sci <- function(x) sub("e\\+0*", "e", format(x, scientific = TRUE)) + lev <- function(x) sprintf("%.2f", x) + + nb <- num(.POOL_NEIGHBOURS) # the neighbours of a cell + few <- c("2", num(.POOL_NEIGHBOURS + 1L)) # "2 to 9 cells": every other cell is one + size <- num(.OBS_PER_CELL_DEFAULT) + sizes <- vapply(.OBS_PER_CELL_LADDER, num, character(1)) + level <- lev(set$LEVEL) # the one level that was simulated + layers <- num(set$LAYERS) + layer <- set$N_ROWS - set$N_BLOCK - set$N_AMONG # the rows of a layer + cells <- num(.count_at(layer, set$SIZE)) + margin <- num(100 * .STRUCTURE_TOL) # "within 2 percent" + f_test <- "0.05" # the level of the F test of .no_structure() + pairs <- c(sci(.EXACT_PAIRS_MAX), num(100 * floor(sqrt(.EXACT_PAIRS_MAX) / 100))) + dense <- num(.KNN_DENSE_MAX) + # Residuals that leave .FEW_RESIDUALS beyond each end of an interval. + needed <- num(ceiling(.FEW_RESIDUALS / round((1 - set$LEVEL) / 2, 12))) + + expected <- list( + "?summarize_by_cell: Pooled values" = c( + nb, "0", "1", # the 8 neighbours; max(0, ); w * m + (1 - w) * t + "1", "0", # an own weight of 1, and of 0 + few, "0", "0", # 2 to 9 cells; tau2 at 0 and every own weight 0 + layers, num(set$SIDE), num(set$N_ROWS), num(set$PARENTS), num(set$SPREAD), + num(set$RANGE), num(set$NOISE_VAR), num(set$N_BLOCK), num(set$N_AMONG), num(layer), + cells, num(set$SIZE), + margin, f_test, # what `structured` asks + layers, nb, "1"), # the white-noise layers; (1 - w) * tau2 + "?summarize_by_cell: Intervals: which one answers which question" = c( + "1", "1", # deff = 1, and a number other than 1 + "1", "2", "1", # p = (1 - obs_level) / 2; quantile(e, 1 - p) + level, level, level), # the level checked; obs_level and conf_level in the run + "?summarize_by_cell: Conditions" = c( + pairs, "1", "0", "0", # the limit; own weights of 1 and of 0; tau2 is 0 + few, num(.POOL_MIN_DF), level, needed), + "?summarize_by_cell: Confidence intervals, the two intervals" = level, + "?summarize_by_cell: argument estimate" = c( + "1", nb, num(.POOL_NEIGHBOURS + 2L)), # fewer than 10 cells: all the others + "?summarize_by_cell: argument obs_level" = c( + "0", "1", level, # a level in (0, 1), such as 0.90 + "1", "2", "1", "2", # the (1 - obs_level) / 2 and (1 + obs_level) / 2 quantiles + "0", "1", level), # strictly between 0 and 1; only 0.90 checked + "?resolution_profile: Observations per cell" = c( + "2", # max(2, round(n / s)) + layers, num(layer), num(set$RANGE), num(set$SIDE), sizes, + size, "1", "0", # 4.5 unless given; an own weight of 1, and of 0 + size, sizes, # what "auto" is + sci(.FIT_WORK_MAX), pairs, dense, dense), + "?resolution_profile: The ladder and its bounds, min_cell_n" = + c(size, num(floor(.OBS_PER_CELL_DEFAULT))), # "4.5 is read as 4" + "?resolution_profile: The ladder and its bounds, a ladder of sizes" = "2", + "?resolution_profile: The ladder and its bounds, no variogram" = character(0), + "?resolution_profile: The criteria, loo" = character(0), + "?select_resolution: What each criterion returns, loo" = f_test, + "?select_resolution: What each criterion returns, size" = c("2", f_test), + "?select_resolution: What each criterion returns, auto" = character(0), + "?select_resolution: A profile built with an estimate" = character(0), + "?cell_values_at: Away from the observations" = c( + layers, num(layer), cells, num(set$N_AMONG), num(set$N_BLOCK), level), + "?spatialkit: the two choices" = c("1", "4", # the steps of the pipeline + size), # the default size + "?spatialkit: the conventions of pooled values" = c( + size, nb, num(.FEW_RESIDUALS), num(.POOL_MIN_DF), margin, sci(.EXACT_PAIRS_MAX), + sci(.FIT_WORK_MAX)), + "vignette resolution: Setting a size" = c( + nb, "2", "1", "0", # the 8 cells; max(2, ); an own weight of 1, and of 0 + size, # the default size + layers, num(layer), num(max(set$SIZES)), num(min(set$SIZES))), + "vignette resolution: Leave-one-out for plain means" = sizes, + "vignette reporting: Reporting a cell value" = c( + nb, "600", "20", # the section's own layer, as its chunk draws it + size, level), + "vignette diagnostics: 6. Warnings about pooled cell values" = c( + size, margin, f_test, layers, nb, + "1", "0", few)) # own weights of 1 and of 0; 2 to 9 cells + news <- stats::setNames(rep(list(character(0)), length(.DOCS_NEWS)), + paste0("NEWS: ", .DOCS_NEWS)) + news[[1L]] <- c(nb, layers, num(layer), num(set$SIZE)) + news[[2L]] <- c(level, level) + news[[5L]] <- num(.NSTART_DENSITY) # the density kind's own starts + news[[6L]] <- size + news[[12L]] <- "1" # deff = 1 + expected <- c(expected, news) + + expect_setequal(names(expected), .DOCS_WRITTEN) + for (what in names(expected)) { + expect_true(what %in% names(texts), info = what) + rest <- .docs_rest(texts[[what]], claims, what) + expect_identical(sort(.docs_numbers(rest)), sort(unname(expected[[what]])), info = what) + } + # A figure stands only in a text whose numbers are held. + expect_true(all(vapply(claims, function(cl) cl$where, character(1)) %in% .DOCS_WRITTEN)) + # The layer of the reporting vignette's section is the one its chunk draws. + code <- .docs_vignette_texts()[["vignette reporting: Reporting a cell value"]] + expect_identical(.docs_count(code, "sx <- runif(600, 0, 2e4)"), 1L) +}) + +test_that("a text that says how a number tends to behave quotes a figure of the simulation", { + sim <- .docs_sim() + if (is.null(sim)) skip("dev/sim-pooled-values.csv is in the source tree only") + texts <- .docs_all_texts() + quoted <- unique(vapply(.docs_claims(sim), function(cl) cl$where, character(1))) + hedges <- lapply(stats::setNames(nm = .DOCS_WRITTEN), function(what) + tolower(.docs_hedges(texts[[what]]))) + hedges <- hedges[lengths(hedges) > 0L] + for (what in names(hedges)) + expect_true(what %in% quoted, + info = sprintf("%s says '%s' and quotes no figure", what, + paste(hedges[[what]], collapse = "', '"))) + # The statements of that kind these texts make, by their words: the + # pooled values' error falling to the finest size (output f), a pooled + # value being mostly its neighbours' mean (output d), and an empty cell + # coming more often from random starts. One more is one more claim, to be + # written here beside the output that shows it. + expect_identical(hedges, list( + "?summarize_by_cell: Pooled values" = "mostly", + "?resolution_profile: Observations per cell" = c("tends", "tends", "often"), + "?select_resolution: What each criterion returns, loo" = "tends", + "vignette resolution: Setting a size" = c("tends", "tends"), + "vignette diagnostics: 6. Warnings about pooled cell values" = "mostly")) +}) diff --git a/tests/testthat/test-core-frozen.R b/tests/testthat/test-core-frozen.R new file mode 100644 index 00000000..1c553d43 --- /dev/null +++ b/tests/testthat/test-core-frozen.R @@ -0,0 +1,708 @@ +# tests/testthat/test-core-frozen.R +# --------------------------------------------------------------------------- +# The cell pipeline returns what it returned on the baseline. +# +# fixtures/core-frozen.rds holds, for a fixed list of calls +# (helper-core-frozen.R), what each returned, printed, raised and logged on +# the baseline code and where it left the random-number stream, with the +# data the calls read and the platform they ran on. +# dev/baseline-core-frozen.R wrote it. The calls are run again here, twice: +# as they are, and with FNN and Matrix switched off. +# +# On the platform of the fixture (the same R, sf, GEOS, PROJ, optional +# packages and linear algebra library) every record has to be identical(). +# Anywhere else k-means differs in its last bits and Voronoi polygons and the +# text of a CRS change with GEOS, PROJ and sf, so names, classes, attribute +# names, the classes of the conditions and every text with its numbers taken +# out have to be identical, numbers equal to 1e-12 and coordinates equal to +# 1e-8 of the extent. That second comparison is made on every platform: +# what is identical passes it. +# +# With the environment variable SPATIALKIT_FROZEN_STRICT set to "true" the +# identical() comparison fails where it would be skipped. Set it wherever +# the fixture's platform is the one at hand, so that a changed package +# cannot switch the comparison off unseen. +# --------------------------------------------------------------------------- + +.cf_baseline <- local({ + cache <- NULL + function() { + if (is.null(cache)) cache <<- readRDS(test_path("fixtures", "core-frozen.rds")) + cache + } +}) + +# The calls run once for the file. +.cf_replay <- local({ + cache <- NULL + function() { + if (is.null(cache)) cache <<- core_frozen_run(.cf_baseline()$data) + cache + } +}) + +# The calls once more, with FNN and Matrix switched off inside the package. +# FNN itself is made to stop when called, so a search that still reaches it +# shows as an error in the call's record. +.cf_replay_bare <- local({ + cache <- NULL + function() { + if (is.null(cache)) { + if (requireNamespace("FNN", quietly = TRUE)) { + reached <- function(...) stop("FNN was called with FNN switched off.", call. = FALSE) + local_mocked_bindings(get.knn = reached, get.knnx = reached, .package = "FNN") + } + cache <<- core_frozen_run(.cf_baseline()$data, + without = .cf_baseline()$without$packages) + } + cache + } +}) + +# What the replay without FNN and Matrix is held to: the records, but for the +# calls the baseline answers differently without the two. +.cf_baseline_bare <- function() { + b <- .cf_baseline() + rec <- b$records + rec[names(b$without$records)] <- b$without$records + rec +} + +.cf_strict <- function() + isTRUE(as.logical(Sys.getenv("SPATIALKIT_FROZEN_STRICT", unset = "false"))) + +# A comparison that cannot be made here: skipped, or failed when strict. +.cf_unmet <- function(why) { + if (.cf_strict()) + fail(paste(why, "SPATIALKIT_FROZEN_STRICT is set, so the comparison has to run.")) + else skip(why) +} + +# gstat decides what a call returns (without it a profile has no variogram), +# so without it there is nothing to compare. FNN and Matrix do not: the +# records are the same without them, but for those the fixture keeps apart. +.cf_packages_missing <- function() { + had <- .cf_baseline()$info$packages[c("gstat", "dplyr", "s2")] + have <- core_frozen_platform()$packages[names(had)] + names(had)[!is.na(had) & is.na(have)] +} + +# The parts of two runs that have to be identical on the baseline's platform. +.cf_expect_identical <- function(now, baseline) { + for (nm in names(baseline)) { + for (part in c("value", "conditions", "output", "printed", "log", "rng")) + expect_identical(now[[nm]][[part]], baseline[[nm]][[part]], + label = sprintf("the %s of `%s`", part, nm), + expected.label = "the baseline's") + } +} + +.cf_expect_no_differences <- function(now, baseline) { + expect_identical(names(now), names(baseline)) + same <- !nzchar(.cf_platform_differs()) + for (nm in names(baseline)) { + d <- core_frozen_check(now[[nm]], baseline[[nm]], same) + expect(length(d) == 0L, + paste(c(sprintf("`%s` is not what it was on the baseline.", nm), d), + collapse = "\n")) + } +} + +# The platform at hand against the fixture's, in words; "" when they agree. +.cf_platform_differs <- function() { + info <- .cf_baseline()$info + here <- core_frozen_platform() + if (core_frozen_same_platform(here, info)) return("") + keys <- core_frozen_platform_keys() + off <- keys[!mapply(identical, here[keys], info[keys])] + paste0("Not the platform the baseline was recorded on (", paste(off, collapse = ", "), + " differ).") +} + + +test_that("the fixture names its baseline, its platform and the calls of the helper", { + skip_on_cran() + base <- .cf_baseline() + info <- base$info + expect_match(info$tree, "^[0-9a-f]{40}$") + expect_identical(names(info$code), c("R", "DESCRIPTION", "NAMESPACE")) + for (field in c("platform", "r", "sf", "geos", "proj")) + expect_true(is.character(info[[field]]) && nzchar(info[[field]]), info = field) + expect_named(info$packages, c("gstat", "FNN", "Matrix", "dplyr", "s2")) + expect_named(base$data, c("pts", "clus", "big", "ll", "twice", "lattice")) + # The calls are the ones the records were taken with, word for word. A + # call that names an argument it did not name then no longer pins that + # argument's default. The text is replaced only where the defaults + # change, by dev/baseline-core-frozen.R --calls-only. + expect_identical(names(base$records), names(core_frozen_calls())) + expect_identical(core_frozen_call_text(), base$calls, + label = "the text of the helper's calls", + expected.label = "the text the fixture was recorded with") + for (nm in names(base$records)) + expect_named(base$records[[nm]], + c("value", "conditions", "output", "printed", "log", "rng"), info = nm) + # The records the baseline gives without FNN and Matrix, where they differ. + expect_identical(base$without$packages, c("FNN", "Matrix")) + expect_true(all(names(base$without$records) %in% names(base$records))) + for (nm in names(base$without$records)) + expect_false(identical(base$without$records[[nm]], base$records[[nm]]), info = nm) +}) + +# On the fixture's platform every call is compared in full; elsewhere by what +# holds on any platform (core_frozen_portable_differences()). +test_that("every call returns the baseline's names, classes, numbers, geometries and texts", { + skip_on_cran() + gone <- .cf_packages_missing() + if (length(gone)) { + .cf_unmet(paste("The baseline was recorded with", paste(gone, collapse = ", "), + "installed.")) + } else { + .cf_expect_no_differences(.cf_replay(), .cf_baseline()$records) + } +}) + +test_that("on the baseline's platform every value, condition, print, log line and stream is identical", { + skip_on_cran() + gone <- .cf_packages_missing() + off <- .cf_platform_differs() + if (length(gone)) { + .cf_unmet(paste("The baseline was recorded with", paste(gone, collapse = ", "), + "installed.")) + } else if (nzchar(off)) { + .cf_unmet(off) + } else { + .cf_expect_identical(.cf_replay(), .cf_baseline()$records) + } +}) + +test_that("without FNN and Matrix every call returns what the baseline returns without them", { + skip_on_cran() + gone <- .cf_packages_missing() + if (length(gone)) { + .cf_unmet(paste("The baseline was recorded with", paste(gone, collapse = ", "), + "installed.")) + } else { + now <- .cf_replay_bare() + baseline <- .cf_baseline_bare() + .cf_expect_no_differences(now, baseline) + # No call reached FNN: its error would be in the record. + reached <- vapply(now, function(r) any(vapply(r$conditions, function(c) + grepl("FNN was called", c$message, fixed = TRUE), logical(1))), logical(1)) + expect_identical(names(now)[reached], character(0)) + # The identical() comparison where the platform allows it; its absence + # elsewhere is reported by the test above. + if (!nzchar(.cf_platform_differs())) .cf_expect_identical(now, baseline) + } +}) + +test_that("the fixed list covers the calls the baseline is for", { + skip_on_cran() + rec <- .cf_baseline()$records + cls <- function(nm) class(rec[[nm]]$value)[1L] + raised <- function(nm) unlist(lapply(rec[[nm]]$conditions, function(c) c$class[1L])) + # Eleven kinds of profile and three more, each read by every criterion. + profiles <- grep("^profile_", names(rec), value = TRUE) + expect_true(all(c("profile_default", "profile_geometry", "profile_levels", "profile_split", + "profile_missing", "profile_min_cell_n", "profile_n_levels", + "profile_density", "profile_sampled", "profile_logical", + "profile_no_value") %in% profiles)) + for (p in profiles) { + expect_identical(cls(p), "resolution_profile", info = p) + expect_false(is.null(rec[[p]]$printed), info = p) + short <- sub("^profile_", "", p) + expect_true(all(sprintf("select_%s_%s", short, + c("cp", "reliability", "elbow", "moran_z")) %in% names(rec)), + info = p) + expect_true(sprintf("summary_%s", short) %in% names(rec), info = p) + } + # What makes each profile its own case. + b <- function(p) attr(rec[[p]]$value, "bounds") + expect_true(is.na(attr(rec$profile_geometry$value, "variable"))) + expect_true(b("profile_levels")$levels_given) + expect_false(is.null(attr(rec$profile_split$value, "split"))) + expect_lt(b("profile_missing")$n_response, b("profile_missing")$n) + expect_identical(b("profile_min_cell_n")$min_cell_n, 5L) + expect_identical(attr(rec$profile_density$value, "partition")$kind, "density") + expect_null(attr(rec$profile_default$value, "partition")) + expect_lt(b("profile_sampled")$n_sample, b("profile_sampled")$n) + expect_identical(b("profile_no_value")$n_response, 0L) + expect_true(b("profile_predictors")$predictors) + # Every criterion returns a selection on some profile and stops on another. + for (cr in c("cp", "reliability", "elbow", "moran_z_diagnostic")) { + got <- vapply(grep(sprintf("^select_.*_%s$", cr), names(rec), value = TRUE), cls, + character(1)) + expect_true("resolution_selection" %in% got, info = cr) + expect_true("NULL" %in% got, info = cr) + } + expect_identical(cls("select_column_subset"), "resolution_selection") + expect_identical(rec$select_column_subset_without$conditions[[1L]]$kind, "error") + expect_identical(cls("select_column_subset_cp"), "resolution_selection") + # Seeds from a number, a selection and a profile, of both kinds; the other + # two methods; cells; assignments. + for (nm in c("seeds_number", "seeds_selection", "seeds_profile", "seeds_density", + "seeds_random", "seeds_provided", "kmeans_number", "kmeans_selection", + "kmeans_profile", "kmeans_density")) + expect_identical(cls(nm), "sf", info = nm) + expect_identical(attr(rec$seeds_number$value, "kmeans")$nstart, 10L) + expect_identical(attr(rec$seeds_density$value, "kmeans")$nstart, 10L) + expect_identical(nrow(rec$seeds_selection$value), rec$select_default_cp$value$best) + expect_identical(nrow(rec$kmeans_profile$value), rec$select_default_cp$value$best) + for (nm in grep("^cells_", names(rec), value = TRUE)) + expect_s3_class(rec[[nm]]$value$cells, "sf") + expect_true(anyNA(rec$assigned_kept$value$cell_id)) + expect_lt(nrow(rec$assigned_dropped$value), nrow(rec$assigned_number$value)) + # The summaries. + v <- function(nm) rec[[nm]]$value + expect_false(inherits(v("values_default"), "sf")) + expect_identical(attr(v("values_kish"), "deff_applied")$method, "kish") + expect_true(all(v("values_sac")$deff_method == "variogram")) + expect_equal(v("values_deff_2")[["..se_resp_z"]], + sqrt(2) * v("values_default")[["..se_resp_z"]]) + expect_true(all(c("..ci_lo_resp_z", "..ci_hi_resp_z") %in% names(v("values_conf_level")))) + expect_s3_class(v("values_cells_sf"), "sf") + expect_true(all(c("cell_area", "n_per_area") %in% names(v("values_area")))) + expect_true("resp_median_z" %in% names(v("values_median"))) + expect_true(any(grepl("x1", names(v("values_predictors")))) && + any(grepl("x2", names(v("values_predictors"))))) + expect_true("spatialkit_nonfinite" %in% raised("values_nonfinite")) + expect_true(1L %in% v("values_sparse")$n) # a one-row region + expect_true(anyNA(v("values_sparse")$n)) # an empty cell + expect_true(anyNA(v("values_unassigned")$cell_id)) + expect_identical(v("values_data_frame")$resp_mean_z, v("values_default")$resp_mean_z) + # Conditions of every kind were recorded. + kinds <- unlist(lapply(rec, function(r) vapply(r$conditions, `[[`, character(1), "kind"))) + expect_true(all(c("warning", "message", "error") %in% kinds)) + expect_gt(sum(lengths(lapply(rec, `[[`, "log"))), 0L) + + # ---- The calls added after the first list ---------------------------------- + # A count read off a profile: by its elbow when it is geometry-only, the + # classed error when `cp` is missing beside another criterion, the plain + # error when nothing is finite, and the two classed warnings. + for (f in c("seeds", "kmeans", "hex")) { + expect_false(is.null(v(sprintf("count_%s_geometry", f))), info = f) + expect_identical(raised(sprintf("count_%s_no_cp", f)), "spatialkit_no_default_criterion", + info = f) + expect_identical(raised(sprintf("count_%s_no_value", f)), "simpleError", info = f) + expect_true("spatialkit_no_structure" %in% raised(sprintf("count_%s_noise", f)), info = f) + } + expect_equal(nrow(v("count_seeds_geometry")), v("select_geometry_elbow")$best) + expect_true("spatialkit_bound_chosen" %in% raised("count_seeds_levels")) + expect_identical(nrow(v("count_seeds_vector")), 12L) # the first of c(12, 20, 8) + expect_equal(nrow(v("count_seeds_candidates")), v("levels_default")[[1L]]) + expect_identical(nrow(v("count_hex_selection")$cells), nrow(v("cells_hex_profile")$cells)) + expect_true("spatialkit_partition_unused" %in% raised("count_seeds_selection_density_named")) + # The fields a classed condition carries are part of its record. + fields <- function(nm, class) Filter(function(c) c$class[1L] == class, + rec[[nm]]$conditions)[[1L]]$fields + expect_named(fields("count_seeds_levels", "spatialkit_bound_chosen"), + c("edge", "criterion", "n")) + expect_named(fields("count_seeds_noise", "spatialkit_no_structure"), + c("criterion", "n", "one_cell")) + expect_true(is.finite(fields("count_seeds_noise", "spatialkit_no_structure")$one_cell)) + # Where a call leaves the stream: only the calls that draw from the + # caller's stream by design move it. + moved <- names(rec)[!vapply(rec, function(r) r$rng$untouched, logical(1))] + expect_setequal(moved, c("seeds_number", "seeds_density", "seeds_boundary", "seeds_random", + "kmeans_unseeded", "random_number")) + for (nm in moved) expect_type(rec[[nm]]$rng$state, "integer") + # Longitude and latitude, repeated locations, a lattice, a constant column. + crs_of <- function(nm) sf::st_crs(v(nm))$input + for (nm in c("seeds_lonlat", "seeds_lonlat_density", "kmeans_lonlat", "kmeans_lonlat_density", + "assigned_lonlat")) + expect_identical(crs_of(nm), "EPSG:4326", info = nm) + # The cells of such seeds are drawn in a projected CRS, and the summary + # joined to them is in it. + expect_identical(sf::st_crs(v("cells_lonlat")$cells)$input, "EPSG:32632") + expect_identical(crs_of("values_lonlat"), "EPSG:32632") + expect_identical(nrow(v("seeds_more_than_locations")), 150L) + expect_identical(nrow(v("kmeans_more_than_locations")), 150L) + expect_match(rec$seeds_more_than_locations$conditions[[1L]]$message, "clamping") + expect_true("spatialkit_constant_response" %in% raised("profile_constant")) + expect_identical(cls("profile_lattice"), "resolution_profile") + # Regions the caller brings, with an ID of each class. + expect_type(v("values_units_character")$GEOID, "character") + expect_type(v("values_units_integer")$id_int, "integer") + expect_type(v("values_units_double")$id_dbl, "double") + expect_s3_class(v("values_units_factor")$id_fac, "factor") + expect_identical(sum(!is.na(v("values_id_number_text")$n)), 30L) + # The summary's other present paths. + expect_identical(v("values_id_found")$resp_mean_z, v("values_default")$resp_mean_z) + expect_identical(vapply(rec$values_not_quiet$conditions, `[[`, character(1), "kind"), + "message") + expect_match(rec$values_other_cells$conditions[[1L]]$message, "match no `cells_sf") + a <- v("values_area_missing") + expect_false(identical(a$n, a$cell_weight)) # rows against rows with a value + expect_equal(sum(a$n_per_area * a$cell_area), 400) + expect_identical(nrow(v("values_one_region")), 1L) + expect_true(all(v("values_one_row_regions")$n == 1L)) + expect_equal(sum(v("values_one_row")$n, na.rm = TRUE), 1) + expect_true(all(is.na(v("values_no_rows")$n))) +}) + +test_that("the comparison for another platform passes the last bits and nothing more", { + skip_on_cran() + rec <- .cf_baseline()$records + same <- function(a, b) length(core_frozen_differences(a, b)) == 0L + bare <- function(value) list(value = value, conditions = list(), output = character(0), + printed = NULL, log = character(0), + rng = list(untouched = TRUE, state = NULL)) + + # A number: a relative 1e-14 passes, 1e-9 does not. + prof <- rec$profile_default + near <- prof; near$value$wss <- near$value$wss * (1 + 1e-14) + far <- prof; far$value$wss[3L] <- far$value$wss[3L] * (1 + 1e-9) + expect_true(same(prof, prof)) + expect_true(same(near, prof)) + expect_false(same(far, prof)) + # The tolerance is 1e-12: every element moved by a relative 2e-13 passes, + # by 5e-12 it does not. + near <- prof; near$value$wss <- near$value$wss * (1 + 2e-13) + far <- prof; far$value$wss <- far$value$wss * (1 + 5e-12) + expect_true(same(near, prof)) + expect_false(same(far, prof)) + # A number inside an attribute, and an integer. + moved <- prof; attr(moved$value, "bounds")$area <- attr(moved$value, "bounds")$area * 1.001 + expect_false(same(moved, prof)) + moved <- prof; moved$value$levels[2L] <- moved$value$levels[2L] + 1L + expect_false(same(moved, prof)) + # A missing value where there was a number. + moved <- prof; moved$value$cp[4L] <- NA + expect_false(same(moved, prof)) + # Names, classes, attribute names and values that are not numbers. + moved <- prof; names(moved$value)[2L] <- "WSS" + expect_false(same(moved, prof)) + moved <- prof; class(moved$value) <- "data.frame" + expect_false(same(moved, prof)) + moved <- prof; attr(moved$value, "extra") <- 1 + expect_false(same(moved, prof)) + moved <- prof; attr(moved$value, "variable") <- "residuals" + expect_false(same(moved, prof)) + moved <- prof; moved$value$levels <- as.numeric(moved$value$levels) + expect_false(same(moved, prof)) + # The levels of a factor. + fac <- rec$values_units_factor + expect_s3_class(fac$value$id_fac, "factor") + moved <- fac; levels(moved$value$id_fac)[3L] <- "other" + expect_false(same(moved, fac)) + + # A geometry: the tolerance is 1e-8 of the extent. A vertex moved by + # 1e-10 or 2e-9 of it passes, by 5e-8 or 1e-6 it does not, and neither + # does a cell more or fewer. + cells <- rec$cells_number + shift <- function(r, by, cell = 1L, vertex = 2L) { + g <- sf::st_geometry(r$value$cells) + ring <- g[[cell]][[1L]] + ring[vertex, 1L] <- ring[vertex, 1L] + by + if (vertex == 1L) ring[nrow(ring), 1L] <- ring[1L, 1L] + g[[cell]] <- sf::st_polygon(list(ring)) + sf::st_geometry(r$value$cells) <- g + r + } + extent_of <- function(r) { + bb <- sf::st_bbox(r$value$cells) + max(bb[["xmax"]] - bb[["xmin"]], bb[["ymax"]] - bb[["ymin"]]) + } + extent <- extent_of(cells) + expect_true(same(shift(cells, 1e-10 * extent), cells)) + expect_true(same(shift(cells, 2e-9 * extent), cells)) + expect_false(same(shift(cells, 5e-8 * extent), cells)) + expect_false(same(shift(cells, 1e-6 * extent), cells)) + fewer <- cells; fewer$value$cells <- fewer$value$cells[-1L, ] + expect_false(same(fewer, cells)) + # A ring that starts at another vertex, or runs the other way, is the same + # polygon. + turned <- cells + g <- sf::st_geometry(turned$value$cells) + ring <- g[[1L]][[1L]] + open <- ring[-nrow(ring), , drop = FALSE] + open <- open[c(3:nrow(open), 1:2), , drop = FALSE] + g[[1L]] <- sf::st_polygon(list(rbind(open, open[1L, ]))) + sf::st_geometry(turned$value$cells) <- g + expect_true(same(turned, cells)) + g[[1L]] <- sf::st_polygon(list(ring[nrow(ring):1, , drop = FALSE])) + sf::st_geometry(turned$value$cells) <- g + expect_true(same(turned, cells)) + # Both at once, with every vertex moved inside the tolerance. + nudged <- ring[nrow(ring):1, , drop = FALSE] + nudged <- nudged[-nrow(nudged), , drop = FALSE] + nudged <- nudged[c(2:nrow(nudged), 1L), , drop = FALSE] + 1e-10 * extent + g[[1L]] <- sf::st_polygon(list(rbind(nudged, nudged[1L, ]))) + sf::st_geometry(turned$value$cells) <- g + expect_true(same(turned, cells)) + # Two vertices that share the smallest x, as every cell of a hexagon grid + # has and every cell cut by a rectangular boundary: a last bit on one of + # them must not put the two rings out of step. + hex <- rec$cells_hex_profile + ring <- sf::st_geometry(hex$value$cells)[[1L]][[1L]] + open <- ring[-nrow(ring), , drop = FALSE] + tied <- which(open[, 1L] == min(open[, 1L])) + expect_gte(length(tied), 2L) + lowest <- tied[which.min(open[tied, 2L])] + hex_extent <- extent_of(hex) + expect_true(same(shift(hex, 1e-10 * hex_extent, vertex = lowest), hex)) + expect_true(same(shift(hex, -1e-10 * hex_extent, vertex = lowest), hex)) + expect_false(same(shift(hex, 1e-6 * hex_extent, vertex = lowest), hex)) + # The text of a CRS is not compared, its name is. + other <- cells + crs <- sf::st_crs(other$value$cells) + crs$wkt <- paste(crs$wkt, " ") + attr(sf::st_geometry(other$value$cells), "crs") <- crs + expect_true(same(other, cells)) + crs$input <- "EPSG:32633" + attr(sf::st_geometry(other$value$cells), "crs") <- crs + expect_false(same(other, cells)) + # A CRS that is not on a geometry column: the one a profile keeps for its + # centres. + expect_s3_class(attr(prof$value, "centres_crs"), "crs") + moved <- prof + crs <- attr(moved$value, "centres_crs") + crs$wkt <- paste(crs$wkt, " ") + attr(moved$value, "centres_crs") <- crs + expect_true(same(moved, prof)) + crs$input <- "EPSG:32633" + attr(moved$value, "centres_crs") <- crs + expect_false(same(moved, prof)) + + # Empty geometries are compared as empty. + holes <- bare(sf::st_sfc(sf::st_point(), sf::st_polygon(), sf::st_point(c(1, 2)))) + expect_true(same(holes, holes)) + filled <- holes + filled$value[[1L]] <- sf::st_point(c(0, 0)) + expect_false(same(filled, holes)) + + # Conditions: when each was raised, its kind and its class count, and so + # does its text, but for the numbers in it. + warned <- rec$profile_missing + expect_gt(length(warned$conditions), 0L) + expect_match(warned$conditions[[1L]]$message, "[0-9]") + renumbered <- warned + renumbered$conditions[[1L]]$message <- gsub("[0-9]+", "7", warned$conditions[[1L]]$message) + expect_true(same(renumbered, warned)) + reworded <- warned; reworded$conditions[[1L]]$message <- "other words" + expect_false(same(reworded, warned)) + reclassed <- warned; reclassed$conditions[[1L]]$class <- c("simpleWarning", "warning", "condition") + expect_false(same(reclassed, warned)) + silent <- warned; silent$conditions <- list() + expect_false(same(silent, warned)) + later <- warned; later$conditions[[1L]]$when <- "print" + expect_false(same(later, warned)) + # The fields of a classed condition: their names, and their numbers to the + # tolerance. + bound <- rec$count_seeds_levels + i <- which(vapply(bound$conditions, function(c) c$class[1L], character(1)) == + "spatialkit_bound_chosen") + expect_length(i, 1L) + moved <- bound; moved$conditions[[i]]$fields$n <- moved$conditions[[i]]$fields$n + 1L + expect_false(same(moved, bound)) + moved <- bound; moved$conditions[[i]]$fields$edge <- "another edge" + expect_false(same(moved, bound)) + moved <- bound; moved$conditions[[i]]$fields$n <- NULL + expect_false(same(moved, bound)) + flat <- rec$count_seeds_noise + i <- which(vapply(flat$conditions, function(c) c$class[1L], character(1)) == + "spatialkit_no_structure") + near <- flat; near$conditions[[i]]$fields$one_cell <- near$conditions[[i]]$fields$one_cell * (1 + 1e-14) + far <- flat; far$conditions[[i]]$fields$one_cell <- far$conditions[[i]]$fields$one_cell * (1 + 1e-9) + expect_true(same(near, flat)) + expect_false(same(far, flat)) + # A call that stopped against one that returned. + stopped <- rec$select_default_elbow + expect_null(stopped$value) + expect_false(same(stopped, rec$select_default_cp)) + + # The lines logged, written and printed: their number and their text but + # for the numbers. + logged <- rec$count_seeds_noise + expect_gt(length(logged$log), 0L) + moved <- logged; moved$log <- c(moved$log, "WARN one more caution") + expect_false(same(moved, logged)) + moved <- logged; moved$log <- character(0) + expect_false(same(moved, logged)) + moved <- logged; moved$log[1L] <- sub("^WARN", "ERROR", moved$log[1L]) + expect_false(same(moved, logged)) + moved <- logged; moved$log[1L] <- gsub("[0-9]+", "7", moved$log[1L]) + expect_true(same(moved, logged)) + moved <- prof; moved$output <- "written by the call" + expect_false(same(moved, prof)) + moved <- prof; moved$printed <- c(moved$printed, " estimate : pooled") + expect_false(same(moved, prof)) + moved <- prof; moved$printed[1L] <- "Another heading" + expect_false(same(moved, prof)) + moved <- prof; moved$printed <- gsub("[0-9]+", "7", moved$printed) + expect_true(same(moved, prof)) + moved <- prof; moved$printed <- NULL + expect_false(same(moved, prof)) + expect_identical(core_frozen_mask(c("a 1,234.5e-3 b", "x = NaN, -2", " NA ")), + c("a # b", "x = NA, #", "NA")) + expect_null(core_frozen_mask(NULL)) + + # The stream: left as it was, or moved. + drew <- rec$seeds_number + expect_false(drew$rng$untouched) + moved <- drew; moved$rng <- list(untouched = TRUE, state = NULL) + expect_false(same(moved, drew)) + moved <- prof; moved$rng <- drew$rng + expect_false(same(moved, prof)) + # How far a drawing call moves it is held by the identical() comparison only. + moved <- drew; moved$rng$state[5L] <- moved$rng$state[5L] + 1L + expect_true(same(moved, drew)) +}) + +test_that("two platform records are the same platform only when every key agrees", { + here <- core_frozen_platform() + expect_true(core_frozen_same_platform(here, here)) + expect_identical(core_frozen_platform_keys(), + c("platform", "r", "sf", "geos", "proj", "packages", "blas", "lapack")) + for (key in core_frozen_platform_keys()) { + other <- here + other[[key]] <- if (key == "packages") replace(here$packages, "s2", "0.0.0") else "another" + expect_false(core_frozen_same_platform(other, here), info = key) + } + for (pkg in names(here$packages)) { + other <- here + other$packages[[pkg]] <- NA_character_ + expect_false(core_frozen_same_platform(other, here), info = pkg) + } + # GDAL reads and writes files; no call of the list does. + other <- here; other$gdal <- "another" + expect_true(core_frozen_same_platform(other, here)) + + # The switch that turns a skipped comparison into a failed one. + withr::with_envvar(c(SPATIALKIT_FROZEN_STRICT = "true"), { + expect_true(.cf_strict()) + expect_failure(.cf_unmet("Not the platform."), "SPATIALKIT_FROZEN_STRICT") + }) + withr::with_envvar(c(SPATIALKIT_FROZEN_STRICT = NA), { + expect_false(.cf_strict()) + expect_condition(.cf_unmet("Not the platform."), class = "skip") + }) +}) + +test_that("the recorder keeps what a call returns, prints, raises and logs, and puts the session back", { + skip_on_cran() + calls <- list( + warns = quote({ warning("w1"); 1 }), + says = quote({ message("m1"); 2 }), + stops = quote(stop("e1")), + writes = quote({ cat("out\n"); 3 }), + logs = quote({ .log_warn("caution %d", 5L); .log_info("a note"); 4 }), + once = quote({ .log_warn_once("core-frozen-test", "said once"); 5 }), + again = quote({ .log_warn_once("core-frozen-test", "said once"); warns + 5 }), + draws = quote(stats::runif(2)), + redraws = quote(stats::runif(2)), + seeded = quote({ cleanup <- .with_seed(4L); x <- stats::runif(1); cleanup(); x }), + classed = quote(.warn_classed("spatialkit_core_frozen_test", "classed %s", "text", + data = list(n = 3L, where = "here"))), + inside = quote((function() warning("from a function"))()), + quiet = quote(warning("no call", call. = FALSE)), + shown = quote(structure(list(best = 7L), class = "resolution_selection"))) + data <- .cf_baseline()$data + once <- get(".warned_once", envir = asNamespace("spatialkit")) + assign("core-frozen-sentinel", TRUE, envir = once) + withr::defer(rm(list = intersect(c("core-frozen-sentinel", "core-frozen-test"), + ls(once, all.names = TRUE)), envir = once)) + before <- list(options = options()[c("width", "digits", "scipen", "OutDec", + "useFancyQuotes", "warn")], + collate = Sys.getlocale("LC_COLLATE"), + language = Sys.getenv("LANGUAGE", unset = NA), + once = sort(ls(once, all.names = TRUE)), + threshold = logger::log_threshold(namespace = "spatialkit", index = 2), + appender = logger::log_appender(namespace = "spatialkit", index = 2), + kind = RNGkind()) + withr::local_seed(99) + expected_next <- stats::runif(1) + set.seed(99) + rec <- core_frozen_run(data, calls) + expect_identical(stats::runif(1), expected_next) # the stream was not touched + + after <- list(options = options()[c("width", "digits", "scipen", "OutDec", + "useFancyQuotes", "warn")], + collate = Sys.getlocale("LC_COLLATE"), + language = Sys.getenv("LANGUAGE", unset = NA), + once = sort(ls(once, all.names = TRUE)), + threshold = logger::log_threshold(namespace = "spatialkit", index = 2), + appender = logger::log_appender(namespace = "spatialkit", index = 2), + kind = RNGkind()) + expect_identical(after, before) + + cond <- function(nm) rec[[nm]]$conditions + for (nm in names(rec)) + expect_named(rec[[nm]], c("value", "conditions", "output", "printed", "log", "rng"), + info = nm) + expect_identical(rec$warns$value, 1) + expect_identical(cond("warns")[[1L]][c("when", "kind", "class", "message", "fields")], + list(when = "call", kind = "warning", + class = c("simpleWarning", "warning", "condition"), + message = "w1", fields = structure(list(), names = character(0)))) + expect_identical(cond("says")[[1L]][c("kind", "message")], + list(kind = "message", message = "m1\n")) + expect_null(rec$stops$value) + expect_identical(cond("stops")[[1L]][c("kind", "message")], + list(kind = "error", message = "e1")) + expect_identical(rec$writes$output, "out") + expect_identical(rec$writes$value, 3) + # WARN lines are kept without their time stamp; INFO lines are not kept. + expect_identical(rec$logs$log, "WARN caution 5") + # What is logged once per session is logged by every call that reaches it. + expect_length(rec$once$log, 1L) + expect_identical(rec$again$log, rec$once$log) + # A call reads the results before it; every call starts from the same seed. + expect_identical(rec$again$value, 6) + expect_identical(rec$redraws$value, rec$draws$value) + # Where each call left the stream: a call that draws moves it, and to the + # same state each time; one that draws under its own seed and puts the + # stream back does not. + expect_true(rec$warns$rng$untouched) + expect_null(rec$warns$rng$state) + expect_false(rec$draws$rng$untouched) + expect_type(rec$draws$rng$state, "integer") + expect_identical(rec$redraws$rng, rec$draws$rng) + expect_true(rec$seeded$rng$untouched) + # A classed warning keeps its class and its fields, and is logged as well + # as raised. + expect_identical(cond("classed")[[1L]]$class[1L], "spatialkit_core_frozen_test") + expect_identical(cond("classed")[[1L]]$fields, list(n = 3L, where = "here")) + expect_identical(rec$classed$log, "WARN classed text") + # The function a condition's call names, NA when it carries none. + expect_identical(cond("classed")[[1L]]$call, NA_character_) + expect_identical(cond("quiet")[[1L]]$call, NA_character_) + expect_match(cond("inside")[[1L]]$call, "^\\(?function") + expect_identical(cond("says")[[1L]]$call, "message") + # A selection is printed; a number is not. + expect_false(is.null(rec$shown$printed)) + expect_null(rec$draws$printed) +}) + +test_that("switching FNN and Matrix off reaches every function that asks for them", { + skip_on_cran() + off <- core_frozen_without(c("FNN", "Matrix")) + expect_true(all(c(".partition_centres", ".nearest_centre", ".knn_locations", ".sac_knn", + ".build_knn_weights") %in% names(off))) + asks <- function(f) any(grepl("requireNamespace\\(\"(FNN|Matrix)\"", deparse(f))) + ns <- asNamespace("spatialkit") + for (nm in names(off)) { + if (nm == ".has_backend") next + expect_true(asks(get(nm, envir = ns)), info = nm) + expect_false(asks(off[[nm]]), info = nm) + expect_identical(environment(off[[nm]]), environment(get(nm, envir = ns)), info = nm) + } + # No function that asks is left out. + every <- Filter(function(nm) { f <- get(nm, envir = ns); is.function(f) && asks(f) }, + ls(ns, all.names = TRUE)) + expect_setequal(setdiff(names(off), ".has_backend"), every) + expect_identical(formals(off$.nearest_centre)$use_fnn, FALSE) + expect_identical(formals(off$.build_knn_weights)$use_matrix, FALSE) + # Only the packages named: with FNN alone, Matrix is still asked for. + fnn_only <- core_frozen_without("FNN") + expect_identical(formals(fnn_only$.build_knn_weights)$use_fnn, FALSE) + expect_true(is.call(formals(fnn_only$.build_knn_weights)$use_matrix)) + # A run without them leaves the package's own functions in place. + before <- get(".sac_knn", envir = ns) + rec <- core_frozen_run(.cf_baseline()$data, + list(asked = quote(deparse(.sac_knn)), + three = quote(.sac_knn(cbind(c(0, 1, 5), c(0, 0, 0)), 1L)$index[, 1L])), + without = c("FNN", "Matrix")) + expect_false(any(grepl("requireNamespace", rec$asked$value))) + expect_identical(rec$three$value, c(2L, 1L, 2L)) + expect_identical(get(".sac_knn", envir = ns), before) +}) diff --git a/tests/testthat/test-core-gridded-ties.R b/tests/testthat/test-core-gridded-ties.R new file mode 100644 index 00000000..1d2bf632 --- /dev/null +++ b/tests/testthat/test-core-gridded-ties.R @@ -0,0 +1,914 @@ +# tests/testthat/test-core-gridded-ties.R +# --------------------------------------------------------------------------- +# Points on the edge between two cells, on gridded locations. +# resolution_profile() gives each scored row to its nearest centre in the CRS +# it works in, a row the same distance from two centres to the lower-numbered +# one. On cells built from the centres it scored (their record of the count +# says scored_cells = TRUE and holds the centres), assign_features_to_polygons() +# gives a point on the edge between two of those cells the cell the profile +# gave it, so the summary's check reads `match` on lattices too, and +# cell_values_at() places such a location in the same cell, with seeds and +# without. Everything else is placed by the polygons alone: polygons a +# caller brings, cells whose record says scored_cells = FALSE, features that +# are not points, a point farther from the edge than rounding. A real +# difference between the cells or rows and the ones scored is still reported. +# +# Every profile names `partition`, `nstart`, `estimate`, `obs_per_cell`, +# `sac` and `seed`, every selection its `criterion`, every summary its +# `estimate`. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.gt_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.gt_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.gt_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) + +.gt_store <- new.env(parent = emptyenv()) +.gt_keep <- function(key, expr) { + if (is.null(.gt_store[[key]])) .gt_store[[key]] <- expr + .gt_store[[key]] +} + +# A lattice: `nx` x `ny` locations at spacing `sp` from (x0, y0), and a +# smooth field plus normal noise of standard deviation 0.4 drawn under seed +# 9001. `row` numbers the locations. Sixteen of them, 20 x 15 to 50 x 40 at +# spacings of 1, 30, 250 and 1000, are the layers of the first test. +.gt_lattice <- function(nx, ny, sp, x0 = 4e5, y0 = 4.4e6, crs = 32615) { + g <- expand.grid(x = x0 + (seq_len(nx) - 1) * sp, y = y0 + (seq_len(ny) - 1) * sp) + z <- local({ + .gt_seed(9001) + sin(g$x / (sp * 6)) + cos(g$y / (sp * 5)) + stats::rnorm(nrow(g), 0, 0.4) + }) + sf::st_as_sf(data.frame(x = g$x, y = g$y, z = z, row = seq_len(nrow(g))), + coords = c("x", "y"), crs = crs) +} +.gt_dims <- list(c(20L, 15L), c(30L, 20L), c(40L, 30L), c(50L, 40L)) +.gt_spacing <- c(1, 30, 250, 1000) + +# The path from a profile to a summary, with its arguments written out: the +# profile, the count by size, the scored centres as seeds, their Voronoi +# cells, the assignment and the summary. +.gt_path <- function(pts, kind, obs_per_cell = 4.5, size = NULL, boundary = NULL, crs = NULL) { + prof <- suppressWarnings( + resolution_profile(pts, "z", partition = kind, nstart = 3, sac = "auto", seed = 123, + estimate = "pooled", obs_per_cell = obs_per_cell)) + sel <- select_resolution(prof, criterion = "size", obs_per_cell = size) + seeds <- suppressWarnings(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts, + boundary = boundary)) + tess <- build_tessellation(seeds, boundary = boundary, method = "voronoi", crs = crs, + quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + out <- .gt_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled")) + seeds$cell_id <- tess$index + list(prof = prof, sel = sel, seeds = seeds, tess = tess, asg = asg, out = out$value, + warnings = out$warnings) +} +.gt_lattice_path <- function(d, sp, kind) + .gt_keep(sprintf("%dx%d-%g-%s", d[1L], d[2L], sp, kind), + .gt_path(.gt_lattice(d[1L], d[2L], sp), kind)) + +.gt_bare <- function(x) { attr(x, "count_rule") <- NULL; x } +.gt_cell_of <- function(asg, pts, id = "cell_id") asg[[id]][match(pts$row, asg$row)] + +# The profile's rule, written out: each row to the centre the least squared +# distance away in the record's CRS, of two as near the lower-numbered one +# (.nearest_exact() replaces the best so far only when a centre is strictly +# nearer), and the cell build_tessellation() built around that centre. +.gt_profile_rule <- function(P, pts) { + rec <- P$sel$count_rule + cen <- rec$scored$centres + xy <- unname(sf::st_coordinates(sf::st_transform(pts, rec$crs))[, 1:2]) + list(cell = P$tess$index[.nearest_exact(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L])], + xy = xy, cen = cen) +} + +# What the polygons alone give: the same cells without the record. +.gt_polygon_rule <- function(P, pts) + .gt_cell_of(assign_features_to_polygons(pts, .gt_bare(P$tess$cells), + polygon_id_col = "cell_id", quiet = TRUE), pts) + +# Everything a lattice's path has to show. Returns how many rows the +# polygons alone would have placed in another cell than the profile's. +.gt_expect_scored <- function(P, pts, info) { + rule <- .gt_profile_rule(P, pts) + placed <- .gt_cell_of(P$asg, pts) + # Every row in the cell the profile scored it in. + expect_identical(nrow(P$asg), nrow(pts), info = info) + expect_false(anyNA(placed), info = info) + expect_identical(placed, rule$cell, info = info) + # The summary's check reads match, and its error is the profile's. + expect_identical(attr(P$out, "count_rule")$check, list(estimate = "match", cells = "match"), + info = info) + expect_length(.gt_of(P, "spatialkit_cells_differ"), 0L) + at_level <- P$sel$count_rule$scored$loo + own <- attr(P$out, "pooled")$columns$resp_z + expect_lt(abs(own$loo - at_level) / at_level, 1e-10) + # cell_values_at() at the rows themselves: their own cells, with seeds and without. + for (seeds in list(P$seeds, NULL)) { + at <- .gt_catch(cell_values_at(pts, P$out, P$asg, "z", id_col = "cell_id", seeds = seeds)) + expect_length(at$warnings, 0L) + expect_identical(at$value$cell_id, placed, info = paste(info, if (is.null(seeds)) "polygons")) + expect_identical(at$value$filled, rep(FALSE, nrow(pts)), info = info) + } + # A row the polygons alone place in another cell is a row on an edge: the + # centre of that cell is as near as the profile's, exactly or to the + # rounding of the coordinates. + old <- .gt_polygon_rule(P, pts) + expect_false(anyNA(old), info = info) + elsewhere <- which(old != rule$cell) + if (length(elsewhere)) { + d2 <- function(rows, centre) (rule$xy[rows, 1L] - rule$cen[centre, 1L])^2 + + (rule$xy[rows, 2L] - rule$cen[centre, 2L])^2 + nearest <- match(rule$cell[elsewhere], P$tess$index) + other <- match(old[elsewhere], P$tess$index) + gap <- abs(d2(elsewhere, other) - d2(elsewhere, nearest)) / d2(elsewhere, nearest) + expect_true(all(gap < 1e-6), info = info) + } + length(elsewhere) +} + +.gt_recorded <- function() readRDS(test_path("fixtures", "core-frozen.rds"))$info +.gt_same_platform <- function() core_frozen_same_platform(core_frozen_platform(), .gt_recorded()) + + +# ---- Sixteen lattices -------------------------------------------------------------- + +test_that("on lattices at spacings of 1, 30, 250 and 1000 every row is in the cell the profile scored it in, under either kind", { + moved <- list(density = integer(0), kmeans = integer(0)) + for (kind in c("density", "kmeans")) for (d in .gt_dims) for (sp in .gt_spacing) { + info <- sprintf("%d x %d at %g, %s", d[1L], d[2L], sp, kind) + pts <- .gt_lattice(d[1L], d[2L], sp) + P <- .gt_lattice_path(d, sp, kind) + expect_identical(P$sel$count_rule$partition$kind, kind) + expect_identical(P$sel$best, as.integer(round(nrow(pts) / 4.5)), info = info) + moved[[kind]] <- c(moved[[kind]], .gt_expect_scored(P, pts, info)) + } + expect_length(moved$density, 16L) + expect_length(moved$kmeans, 16L) + # Which rows lie on an edge rests on exact ties, which another GEOS or + # another arithmetic can settle the other way, so the counts are held only + # on the platform the frozen fixture was recorded on. There the polygons + # alone would place rows of 11 of the 16 lattices in another cell than the + # profile's under the density kind, and none under k-means, so on those 11 + # the profile's rule decides the rows on an edge. + if (.gt_same_platform()) { + expect_identical(moved$density, c(0L, 1L, 0L, 0L, 2L, 3L, 0L, 2L, + 3L, 1L, 0L, 1L, 1L, 3L, 3L, 3L)) + expect_identical(moved$kmeans, rep(0L, 16L)) + } +}) + + +# ---- Longitude and latitude, two units, two CRSs ---------------------------------- + +test_that("on a lattice in longitude and latitude the rows are placed as the profile placed them in its own CRS", { + layers <- list( + `30 m in EPSG:4326` = sf::st_transform(.gt_lattice(30L, 20L, 30), 4326), + `250 m in EPSG:4326` = sf::st_transform(.gt_lattice(50L, 40L, 250), 4326), + `degrees` = local({ + g <- expand.grid(i = 0:29, j = 0:19) + z <- local({ .gt_seed(9001); sin(g$i / 6) + cos(g$j / 5) + stats::rnorm(nrow(g), 0, 0.4) }) + sf::st_as_sf(data.frame(x = -93.6 + 0.003 * g$i, y = 41.1 + 0.003 * g$j, z = z, + row = seq_len(nrow(g))), coords = c("x", "y"), crs = 4326) + })) + for (nm in names(layers)) for (kind in c("density", "kmeans")) { + pts <- layers[[nm]] + info <- paste(nm, kind) + P <- .gt_path(pts, kind) + rec <- P$sel$count_rule + # The profile measured in a projected CRS, and the seeds came back in + # degrees; the cells are drawn in the profile's CRS. + expect_false(sf::st_is_longlat(rec$crs), info = info) + expect_true(sf::st_is_longlat(P$seeds), info = info) + expect_true(sf::st_crs(P$tess$cells) == rec$crs, info = info) + .gt_expect_scored(P, pts, info) + # The seeds, put back in the profile's CRS, are its centres to rounding, so + # cell_values_at() searches the centres as the record holds them. + seed_xy <- unname(sf::st_coordinates(sf::st_transform(P$seeds, rec$crs))[, 1:2]) + expect_identical(.values_at_centres(attr(P$out, "count_rule"), seed_xy, rec$crs), + list(centres = rec$scored$centres, seed = seq_len(nrow(seed_xy))), + info = info) + } +}) + +test_that("the same lattices in two units and two CRSs are placed as the profile placed them in each", { + base <- list(`30 m` = .gt_lattice(30L, 20L, 30, x0 = 4.5e5, y0 = 4.55e6, crs = 26915), + `250 m` = .gt_lattice(40L, 30L, 250, x0 = 4.5e5, y0 = 4.55e6, crs = 26915)) + crss <- list(`UTM 15N, metres` = sf::st_crs(26915), + `UTM 15N, US feet` = sf::st_crs("+proj=utm +zone=15 +datum=NAD83 +units=us-ft +no_defs"), + `Iowa South, metres` = sf::st_crs(26976), + `Iowa South, US feet` = sf::st_crs(3418)) + for (b in names(base)) for (cn in names(crss)) for (kind in c("density", "kmeans")) { + pts <- base[[b]] + if (!isTRUE(sf::st_crs(pts) == crss[[cn]])) pts <- sf::st_transform(pts, crss[[cn]]) + info <- paste(b, cn, kind) + P <- .gt_path(pts, kind) + # The profile worked in the layer's own CRS, in its units. + expect_true(P$sel$count_rule$crs == crss[[cn]], info = info) + expect_true(sf::st_crs(P$tess$cells) == crss[[cn]], info = info) + .gt_expect_scored(P, pts, info) + } +}) + +# Midpoints between each centre and its three nearest, in the record's CRS: +# each is the same distance from two centres. +.gt_midpoints <- function(rec) { + cen <- rec$scored$centres + m <- do.call(rbind, lapply(seq_len(nrow(cen)), function(i) { + d <- (cen[, 1L] - cen[i, 1L])^2 + (cen[, 2L] - cen[i, 2L])^2 + j <- order(d)[2:4] + cbind((cen[i, 1L] + cen[j, 1L]) / 2, (cen[i, 2L] + cen[j, 2L]) / 2) + })) + sf::st_as_sf(data.frame(x = m[, 1L], y = m[, 2L], row = seq_len(nrow(m))), + coords = c("x", "y"), crs = rec$crs) +} +# At those midpoints: the cell the profile's rule gives, the one the +# assignment gives, and the one cell_values_at() gives with the seeds in +# their own order, reversed, sorted by cell and shuffled. +.gt_expect_midpoints <- function(P, info) { + rec <- P$sel$count_rule + mids <- .gt_midpoints(rec) + want <- .gt_profile_rule(P, mids)$cell + expect_false(anyNA(want), info = info) + placed <- .gt_cell_of(assign_features_to_polygons(mids, P$tess$cells, polygon_id_col = "cell_id", + keep_unassigned = TRUE, quiet = TRUE), mids) + expect_identical(placed, want, info = info) + n <- nrow(P$seeds) + orders <- list(seq_len(n), rev(seq_len(n)), order(P$seeds$cell_id), + local({ .gt_seed(4); sample.int(n) })) + for (o in orders) { + at <- cell_values_at(mids, P$out, P$asg, "z", id_col = "cell_id", seeds = P$seeds[o, ]) + expect_identical(at$cell_id, want, info = info) + } +} + +test_that("a lattice in degrees wider than a UTM zone is drawn and placed in the profile's equal-area CRS", { + # 25 x 11 locations 2.4 degrees apart over the conterminous United States: + # the profile measures them in Lambert azimuthal equal-area and the seeds + # come back in degrees. Put back in that CRS they lie off the centres by + # what the round trip through degrees leaves, which depends on the PROJ + # build: about five times the margin of an edge on macOS, far less on + # Windows. Seeds moved by five times the margin are matched as well, so + # that case is tested on every platform. + g <- expand.grid(i = 0:24, j = 0:10) + z <- local({ .gt_seed(9001); sin(g$i / 6) + cos(g$j / 5) + stats::rnorm(nrow(g), 0, 0.4) }) + pts <- sf::st_as_sf(data.frame(x = -124 + 2.4 * g$i, y = 25 + 2.4 * g$j, z = z, + row = seq_len(nrow(g))), coords = c("x", "y"), crs = 4326) + for (kind in c("density", "kmeans")) { + P <- suppressWarnings(.gt_path(pts, kind)) + rec <- P$sel$count_rule + cen <- rec$scored$centres + expect_match(rec$crs$proj4string, "+proj=laea", fixed = TRUE, info = kind) + expect_true(sf::st_is_longlat(P$seeds), info = kind) + # The cells are drawn in the profile's CRS, around the centres as the + # record holds them: the same cells as seeds placed at the centres there. + expect_true(sf::st_crs(P$tess$cells) == rec$crs, info = kind) + at_centres <- sf::st_as_sf(data.frame(x = cen[, 1L], y = cen[, 2L]), coords = c("x", "y"), + crs = rec$crs) + attr(at_centres, "cover") <- attr(P$seeds, "cover") + at_centres <- .count_rule_put(at_centres, attr(P$seeds, "count_rule")) + own <- build_tessellation(at_centres, method = "voronoi", quiet = TRUE) + expect_identical(sf::st_geometry(P$tess$cells), sf::st_geometry(own$cells), info = kind) + seed_xy <- unname(sf::st_coordinates(sf::st_transform(P$seeds, rec$crs))[, 1:2]) + expect_identical(.values_at_centres(attr(P$out, "count_rule"), seed_xy, rec$crs)$seed, + seq_len(nrow(cen)), info = kind) + tol <- .edge_tol(c(range(cen[, 1L]), range(cen[, 2L]))) + off <- cbind(rep(c(1, -1), length.out = nrow(cen)), rep(c(-1, 1), length.out = nrow(cen))) + moved <- cen + 5 * tol * off + expect_gt(max(abs(moved - cen)), tol) + expect_identical(.values_at_centres(attr(P$out, "count_rule"), moved, rec$crs)$seed, + seq_len(nrow(cen)), info = kind) + .gt_expect_scored(P, pts, kind) + .gt_expect_midpoints(P, kind) + } + # create_voronoi_polygons() draws them there as well. + P <- suppressWarnings(.gt_path(pts, "density")) + direct <- create_voronoi_polygons(P$seeds, quiet = TRUE) + expect_true(sf::st_crs(direct$cells) == P$sel$count_rule$crs) + expect_identical(sf::st_geometry(direct$cells), sf::st_geometry(P$tess$cells)) +}) + +test_that("seeds placed in the CRS of a boundary are drawn in the profile's CRS; a `crs` the caller names is kept", { + pts <- .gt_lattice(40L, 30L, 250) + bbox <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(sf::st_buffer(sf::st_as_sfc(sf::st_bbox(pts)), + 250)))) + for (kind in c("density", "kmeans")) for (bc in c(5070, 4326)) { + info <- paste(kind, bc) + P <- suppressWarnings(.gt_path(pts, kind, boundary = sf::st_transform(bbox, bc))) + expect_true(sf::st_crs(P$seeds) == sf::st_crs(bc), info = info) + expect_true(sf::st_crs(P$tess$cells) == sf::st_crs(32615), info = info) + expect_true(sf::st_crs(P$tess$boundary) == sf::st_crs(32615), info = info) + .gt_expect_scored(P, pts, info) + .gt_expect_midpoints(P, info) + } + # Cells returned in degrees are drawn in the profile's CRS too, and rows in + # that CRS are joined there, where the profile's rule applies. + P <- suppressWarnings(.gt_path(pts, "density", crs = 4326)) + expect_true(sf::st_is_longlat(P$tess$cells)) + rule <- .gt_profile_rule(P, pts) + expect_identical(.gt_cell_of(P$asg, pts), rule$cell) + expect_identical(attr(P$out, "count_rule")$check, list(estimate = "match", cells = "match")) + # A projected `crs` is the CRS the cells are drawn in, as asked. + P <- suppressWarnings(.gt_path(pts, "density", crs = 26915)) + expect_true(sf::st_crs(P$tess$cells) == sf::st_crs(26915)) +}) + +test_that("on a ladder of sizes the record holds the centres of the level chosen, and the rows are placed by them", { + pts <- .gt_lattice(30L, 20L, 30) + for (kind in c("density", "kmeans")) for (size in c(18, 9)) { + info <- paste(kind, size) + P <- .gt_path(pts, kind, obs_per_cell = c(18, 9, 4.5), size = size) + levels <- P$prof$levels + expect_identical(levels, c(33L, 67L, 133L), info = info) + expect_identical(P$sel$best, as.integer(round(600 / size)), info = info) + cen <- P$sel$count_rule$scored$centres + expect_identical(cen, unname(attr(P$prof, "centres")[[as.character(P$sel$best)]]), info = info) + expect_identical(nrow(cen), P$sel$best, info = info) + expect_identical(.scored_centres(attr(P$tess$cells, "count_rule")), cen, info = info) + .gt_expect_scored(P, pts, info) + .gt_expect_midpoints(P, info) + } +}) + + +# ---- What the polygons place alone ----------------------------------------------- + +test_that("a layer on which no row lies on an edge gets the cells it gets without the record", { + layer <- local({ + .gt_seed(8101) + x <- stats::runif(600, 0, 1e5); y <- stats::runif(600, 0, 1e5) + sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, + z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(600, 0, 1.5), + row = seq_len(600)), + coords = c("x", "y"), crs = 32617) + }) + for (pts in list(layer, sf::st_transform(layer, 4326))) for (kind in c("density", "kmeans")) { + P <- .gt_path(pts, kind) + bare <- assign_features_to_polygons(pts, .gt_bare(P$tess$cells), polygon_id_col = "cell_id", + quiet = TRUE) + expect_identical(.gt_bare(P$asg), bare) + expect_identical(attr(P$out, "count_rule")$check$cells, "match") + expect_identical(.gt_cell_of(P$asg, pts), .gt_profile_rule(P, pts)$cell) + } + # The lattices on which the polygons and the profile agree: the same cells + # and the same layer, record apart. + for (d in .gt_dims[1:2]) for (sp in .gt_spacing) { + pts <- .gt_lattice(d[1L], d[2L], sp) + P <- .gt_lattice_path(d, sp, "kmeans") + if (identical(.gt_polygon_rule(P, pts), .gt_profile_rule(P, pts)$cell)) + expect_identical(.gt_bare(P$asg), + assign_features_to_polygons(pts, .gt_bare(P$tess$cells), + polygon_id_col = "cell_id", quiet = TRUE)) + } +}) + +test_that("polygons a caller brings keep their rule for points on shared edges", { + pts <- .gt_lattice(30L, 20L, 30) + # Squares of 120 m from the lattice's corner, 8 across and 5 up, numbered + # a row at a time from the lower left: every fourth row and column of the + # lattice lies on their edges, and their corners on lattice points. + sq <- list() + for (j in 0:4) for (i in 0:7) + sq[[length(sq) + 1L]] <- sf::st_polygon(list( + cbind(4e5 + 120 * c(i, i + 1, i + 1, i, i), 4.4e6 + 120 * c(j, j, j + 1, j + 1, j)))) + units <- sf::st_sf(GEOID = sprintf("u%03d", seq_along(sq)), + geometry = sf::st_sfc(sq, crs = 32615)) + asg <- assign_features_to_polygons(pts, units, polygon_id_col = "GEOID", quiet = TRUE) + expect_null(attr(asg, "count_rule")) + expect_identical(nrow(asg), nrow(pts)) + # The rule of `tie_break = "smallest_area"`: of the equal squares a point + # is on, the lowest, then the leftmost. + dx <- sf::st_coordinates(pts)[, 1L] - 4e5 + dy <- sf::st_coordinates(pts)[, 2L] - 4.4e6 + col <- floor(dx / 120) - (dx %% 120 == 0 & dx > 0) + row <- floor(dy / 120) - (dy %% 120 == 0 & dy > 0) + want <- units$GEOID[row * 8L + col + 1L] + expect_identical(.gt_cell_of(asg, pts, "GEOID"), want) + expect_gt(attr(asg, "ties")$n, 100L) + # The same whatever the order of the squares. + rev_units <- units[rev(seq_len(nrow(units))), ] + expect_identical(.gt_cell_of(assign_features_to_polygons(pts, rev_units, polygon_id_col = "GEOID", + quiet = TRUE), pts, "GEOID"), want) + # And the summary checks nothing. + r <- .gt_catch(summarize_by_cell(asg, "z", id_col = "GEOID", cells_sf = units, + estimate = "pooled")) + expect_null(attr(r$value, "count_rule")) + expect_length(.gt_of(r, "spatialkit_cells_differ"), 0L) +}) + +test_that("cells whose record says they are not the scored cells keep the polygons' rule", { + pts <- .gt_lattice(30L, 20L, 30) + P <- .gt_lattice_path(c(30L, 20L), 30, "density") + old <- .gt_polygon_rule(P, pts) + for (mark in list(FALSE, NA)) { + cells <- .count_rule_put(P$tess$cells, attr(P$tess$cells, "count_rule"), scored_cells = mark) + asg <- assign_features_to_polygons(pts, cells, polygon_id_col = "cell_id", quiet = TRUE) + expect_identical(.gt_cell_of(asg, pts), old) + expect_identical(attr(asg, "count_rule")$scored_cells, mark) + expect_identical(.gt_bare(asg), assign_features_to_polygons(pts, .gt_bare(P$tess$cells), + polygon_id_col = "cell_id", + quiet = TRUE)) + } + # Seeds a function placed itself at the count, and a lattice sized by the + # selection: their records say FALSE, and the polygons place every point. + own <- suppressWarnings(get_voronoi_seeds(method = "kmeans", + n = local({ s <- P$sel; s$seeds <- NULL; s }), + sample_points = pts, set_seed = 1, + partition = "kmeans", kmeans_nstart = 10)) + expect_identical(attr(own, "count_rule")$scored_cells, FALSE) + hexes <- suppressWarnings(build_tessellation(pts, boundary = sf::st_sf(geometry = sf::st_as_sfc( + sf::st_bbox(pts))), method = "hex", approx_n_cells = P$sel, + quiet = TRUE)) + for (cells in list(build_tessellation(own, method = "voronoi", quiet = TRUE)$cells, + hexes$cells)) { + expect_identical(attr(cells, "count_rule")$scored_cells, FALSE) + expect_identical(.gt_bare(assign_features_to_polygons(pts, cells, polygon_id_col = "cell_id", + quiet = TRUE)), + assign_features_to_polygons(pts, .gt_bare(cells), polygon_id_col = "cell_id", + quiet = TRUE)) + } + # The rule changed something on this lattice, so the record is what decided. + if (.gt_same_platform()) expect_identical(sum(old != .gt_cell_of(P$asg, pts)), 3L) +}) + + +# ---- The rule on cells made by hand --------------------------------------------------- + +# Four squares of side 10 from (5e5, 5e6) in EPSG:32617, numbered from the +# lower left a row at a time (1 LL, 2 LR, 3 UL, 4 UR), and a record whose +# centres are `centres` (square middles unless moved). The record is a real +# one with its centres, count and CRS replaced. +.gt_squares <- function(crs = 32617, x0 = 5e5, y0 = 5e6) { + sq <- function(i, j) sf::st_polygon(list(rbind(c(i, j), c(i + 10, j), c(i + 10, j + 10), + c(i, j + 10), c(i, j)) + rep(c(x0, y0), each = 5))) + sf::st_sf(cell_id = 1:4, geometry = sf::st_sfc(sq(0, 0), sq(10, 0), sq(0, 10), sq(10, 10), + crs = crs)) +} +.gt_middles <- function(x0 = 5e5, y0 = 5e6) cbind(x0 + c(5, 15, 5, 15), y0 + c(5, 5, 15, 15)) +.gt_record <- function(centres, crs = sf::st_crs(32617), scored_cells = TRUE) { + rec <- .gt_lattice_path(c(20L, 15L), 30, "density")$sel$count_rule + rec$cells <- nrow(centres) + rec$crs <- crs + rec$scored$centres <- centres + rec$scored_cells <- scored_cells + rec +} +.gt_points <- function(x, y, crs = 32617, x0 = 5e5, y0 = 5e6) + sf::st_as_sf(data.frame(x = x0 + x, y = y0 + y, row = seq_along(x)), coords = c("x", "y"), + crs = crs) +# On the edge LL|LR, on LL|UL, on the corner of all four, on LR|UR; inside LL; +# inside UR. +.gt_six <- function(...) .gt_points(c(10, 5, 10, 15, 5, 12), c(5, 10, 10, 10, 5, 17), ...) +.gt_assign <- function(pts, cells, ...) + assign_features_to_polygons(pts, cells, polygon_id_col = "cell_id", quiet = TRUE, ...) + +test_that("on the cells of scored centres a point on an edge goes to the lowest-numbered of the centres it is nearest", { + sq <- .gt_squares(); pts <- .gt_six() + # The centres numbered from the upper right: 1 UR, 2 UL, 3 LR, 4 LL. + cen <- .gt_middles()[c(4, 3, 2, 1), ] + cells <- .count_rule_put(sq, .gt_record(cen)) + got <- .gt_assign(pts, cells) + expect_identical(got$cell_id, c(2L, 3L, 4L, 4L, 1L, 4L)) + # The polygons alone: the lowest, then leftmost, of equal squares. + expect_identical(.gt_assign(pts, sq)$cell_id, c(1L, 1L, 1L, 2L, 1L, 4L)) + # Whatever `tie_break` says, and whatever the order of the squares. + expect_identical(.gt_assign(pts, cells, tie_break = "first")$cell_id, c(2L, 3L, 4L, 4L, 1L, 4L)) + rev_cells <- .count_rule_put(sq[4:1, ], .gt_record(cen)) + expect_identical(.gt_assign(pts, rev_cells)$cell_id, c(2L, 3L, 4L, 4L, 1L, 4L)) + # The record of the points that matched several polygons is the polygons' own. + expect_identical(attr(got, "ties")[c("n", "which", "rule")], + attr(.gt_assign(pts, sq), "ties")[c("n", "which", "rule")]) + expect_identical(attr(got, "ties")$which, 1:4) + # Numbered from the lower left the centres give what the polygons give. + expect_identical(.gt_assign(pts, .count_rule_put(sq, .gt_record(.gt_middles())))$cell_id, + c(1L, 1L, 1L, 2L, 1L, 4L)) + # The rows come back as they came, with the cells' record. + expect_identical(sf::st_geometry(got), sf::st_geometry(pts)) + expect_identical(attr(got, "count_rule"), .gt_record(cen)) +}) + +test_that("a point rounding put a hair inside a cell is on its edge; one a little farther is not", { + sq <- .gt_squares() + tol <- .edge_tol(sf::st_bbox(sq)) + expect_equal(tol, 1e-10 * (5e6 + 20)) + # Centres moved right by 2e-5: the edge between their cells lies 2e-5 east + # of the squares' edge, so a point 1e-5 east of it is nearer the left centre + # and inside the right square, within the margin of its edge. + near <- .gt_points(10 + 1e-5, 5) + moved <- .gt_middles(); moved[, 1L] <- moved[, 1L] + 2e-5 + expect_identical(.gt_assign(near, sq)$cell_id, 2L) + expect_identical(.gt_assign(near, .count_rule_put(sq, .gt_record(moved)))$cell_id, 1L) + # Moved 2e-2, with a point 1e-2 east of the edge: nearer the left centre + # too, and more than ten times the margin inside the right square, so it is + # not on the edge, and the polygon that holds it decides. + far <- .gt_points(10 + 1e-2, 5) + moved[, 1L] <- .gt_middles()[, 1L] + 2e-2 + expect_gt(1e-2, 10 * tol) + expect_identical(.gt_assign(far, .count_rule_put(sq, .gt_record(moved)))$cell_id, 2L) +}) + +test_that("a centre that is not alone in one cell gives no cell, and its points keep the polygons' rule", { + sq <- .gt_squares(); pts <- .gt_six() + # 1 UR, 2 UL, 3 LR, and 4 moved from LL into UR beside 1: LL holds no centre + # and UR holds two. + cen <- .gt_middles()[c(4, 3, 2, 1), ] + cen[4L, ] <- c(5e5 + 17, 5e6 + 17) + got <- .gt_assign(pts, .count_rule_put(sq, .gt_record(cen))) + # LL|LR goes to 3 (LR) and LL|UL to 2 (UL), each alone in its square; the + # corner and LR|UR are nearest 1, which shares UR, so the polygons decide. + expect_identical(got$cell_id, c(2L, 3L, 1L, 2L, 1L, 4L)) +}) + +test_that("each margin is the margin: a point a few margins from the other cell, or inside its own, keeps its cell", { + tol <- .edge_tol(sf::st_bbox(.gt_squares())) + box <- function(x0, x1) sf::st_polygon(list(cbind(5e5 + c(x0, x1, x1, x0, x0), + 5e6 + c(0, 0, 10, 10, 0)))) + cells <- function(right) sf::st_sf(cell_id = 1:2, geometry = sf::st_sfc(box(0, 10), right, + crs = 32617)) + # The left centre 5 from the point at (10, 5), the right one 4.9: the + # profile's rule gives the point the right cell. + cen <- cbind(5e5 + c(5, 14.9), 5e6 + c(5, 5)) + rec <- .gt_record(cen) + # On the edge of its own square, five margins short of the right square: + # not on the edge between the two. + gap <- cells(box(10 + 5 * tol, 20)) + pt <- .gt_points(10, 5) + expect_identical(.gt_assign(pt, gap)$cell_id, 1L) + expect_identical(.gt_assign(pt, .count_rule_put(gap, rec))$cell_id, 1L) + # Two margins inside its own square and inside the right one, which + # overlaps it by three: not on the edge of its own cell. + overlap <- cells(box(10 - 3 * tol, 20)) + inside <- .gt_points(10 - 2 * tol, 5) + expect_identical(.gt_assign(inside, overlap)$cell_id, 1L) + expect_identical(.gt_assign(inside, .count_rule_put(overlap, rec))$cell_id, 1L) + # Half a margin inside its own square and a quarter short of the right + # one: on the edge between them, and the profile's rule decides. + overlap <- cells(box(10 - tol / 4, 20)) + edge <- .gt_points(10 - tol / 2, 5) + expect_identical(.gt_assign(edge, overlap)$cell_id, 1L) + expect_identical(.gt_assign(edge, .count_rule_put(overlap, rec))$cell_id, 2L) +}) + +test_that("a centre on the edge of two cells has no cell, and its points keep the polygons' rule", { + # The squares with LR first: the first square a centre on the edge LL|LR + # touches is LR. + sq <- .gt_squares()[c(2L, 1L, 3L, 4L), ] + # 1 on the edge LL|LR, 2 inside LL, 3 UL, 4 UR. + cen <- cbind(5e5 + c(10, 2, 5, 15), 5e6 + c(5, 2, 15, 15)) + pt <- .gt_points(10, 2) + xy <- unname(sf::st_coordinates(pt)) + expect_identical(.nearest_exact(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L]), 1L) + expect_identical(.gt_assign(pt, sq)$cell_id, 1L) + expect_identical(.gt_assign(pt, .count_rule_put(sq, .gt_record(cen)))$cell_id, 1L) +}) + +test_that("a centre outside the boundary that clipped its cell gives that cell to its points on an edge", { + x0 <- 5e5; y0 <- 5e6 + # B (15, 5) numbered 1, A (5, 5) 2, C (5, 15) 3, D (15, 15) 4. The study + # area is the left column [0, 10] x [0, 20] and a strip [10, 12] x [-200, 10]: + # B and D lie outside it, B's cell is the strip, larger than A's square, + # and D has none. + cen <- cbind(x0 + c(15, 5, 5, 15), y0 + c(5, 5, 15, 15)) + bnd <- sf::st_sf(geometry = sf::st_union(sf::st_sfc( + sf::st_polygon(list(cbind(x0 + c(0, 10, 10, 0, 0), y0 + c(0, 0, 20, 20, 0)))), + sf::st_polygon(list(cbind(x0 + c(10, 12, 12, 10, 10), y0 + c(-200, -200, 10, 10, -200)))), + crs = 32617))) + seeds <- .count_rule_put(sf::st_as_sf(data.frame(seed_id = 1:4, x = cen[, 1L], y = cen[, 2L]), + coords = c("x", "y"), crs = 32617), .gt_record(cen)) + tess <- suppressWarnings(build_tessellation(seeds, boundary = bnd, method = "voronoi", + quiet = TRUE)) + expect_identical(tess$index, c(NA, 1L, 2L, NA)) + expect_equal(as.numeric(sf::st_area(tess$cells)), c(100, 100, 420)) + # (10, 5) and (10, 2) are as near B as A: B's cell, the strip. (11, 5) is + # in the strip. The polygons alone give the first two the smaller square. + pts <- .gt_points(c(10, 10, 11), c(5, 2, 5)) + expect_identical(.gt_assign(pts, tess$cells)$cell_id, c(3L, 3L, 3L)) + expect_identical(.gt_assign(pts, .gt_bare(tess$cells))$cell_id, c(1L, 1L, 3L)) + # Without the strip, B has no cell: a cell that holds a centre is that + # centre's, so the point keeps the polygons' rule. + cells_d <- .count_rule_put(.gt_bare(tess$cells)[c(1L, 2L), ], .gt_record(cen)) + expect_identical(.gt_assign(.gt_points(10, 5), cells_d)$cell_id, 1L) +}) + +test_that("a point on an edge whose nearest centre stands in a third cell keeps the polygons' rule", { + sq <- .gt_squares() + # One centre in each square, the one in UR near its lower-left corner, so + # that the point on the edge LL|LR is nearest it: its cell is 5 away. + cen <- cbind(5e5 + c(10.5, 2, 18, 2), 5e6 + c(10.5, 18, 2, 2)) + pt <- .gt_points(10, 5) + xy <- unname(sf::st_coordinates(pt)) + expect_identical(.nearest_exact(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L]), 1L) + got <- .gt_assign(pt, .count_rule_put(sq, .gt_record(cen))) + expect_identical(got$cell_id, .gt_assign(pt, sq)$cell_id) + expect_identical(got$cell_id, 1L) +}) + +test_that("only points on cells with the scored centres in a CRS the join can measure are placed by the profile's rule", { + sq <- .gt_squares(); pts <- .gt_six() + cen <- .gt_middles()[c(4, 3, 2, 1), ] + polygons <- c(1L, 1L, 1L, 2L, 1L, 4L) + profile <- c(2L, 3L, 4L, 4L, 1L, 4L) + with <- function(rec) .gt_assign(pts, .count_rule_put(sq, rec))$cell_id + expect_identical(with(.gt_record(cen)), profile) + # Not the scored cells, or not said to be. + expect_identical(with(.gt_record(cen, scored_cells = FALSE)), polygons) + expect_identical(with(.gt_record(cen, scored_cells = NA)), polygons) + # No centres, too few, or not finite; no scored list. + rec <- .gt_record(cen); rec$scored$centres <- NULL + expect_identical(with(rec), polygons) + rec <- .gt_record(cen); rec$scored$centres <- cen[1:3, ] + expect_identical(with(rec), polygons) + rec <- .gt_record(cen); rec$scored$centres[2L, 1L] <- NA + expect_identical(with(rec), polygons) + rec <- .gt_record(cen); rec["scored"] <- list(NULL) + expect_identical(with(rec), polygons) + # A record in longitude and latitude, or without a CRS beside cells with one. + expect_identical(with(.gt_record(cen, crs = sf::st_crs(4326))), polygons) + expect_identical(with(.gt_record(cen, crs = sf::NA_crs_)), polygons) + # Without a CRS on all three, the coordinates are compared as they are. + bare <- function(x) sf::st_set_crs(x, NA) + expect_identical(.gt_assign(bare(pts), .count_rule_put(bare(sq), + .gt_record(cen, crs = sf::NA_crs_)))$cell_id, + profile) + # Points without a CRS beside a record with one are left to the polygons. + r <- .gt_catch(.gt_assign(bare(pts), .count_rule_put(sq, .gt_record(cen)))) + expect_identical(r$value$cell_id, polygons) + # Features that are not points: squares split evenly by an edge, and + # multipoints, are placed as the polygons place them. + boxes <- sf::st_sf(row = 1:2, geometry = sf::st_buffer(sf::st_geometry(pts)[c(1L, 4L)], 1, + endCapStyle = "SQUARE")) + expect_identical(.gt_assign(boxes, .count_rule_put(sq, .gt_record(cen)))$cell_id, + .gt_assign(boxes, sq)$cell_id) + multi <- sf::st_sf(row = 1:2, geometry = sf::st_sfc( + sf::st_multipoint(rbind(c(5e5 + 10, 5e6 + 5))), sf::st_multipoint(rbind(c(5e5 + 15, 5e6 + 10))), + crs = 32617)) + expect_identical(.gt_assign(multi, .count_rule_put(sq, .gt_record(cen)))$cell_id, c(1L, 2L)) + # Cells and points in longitude and latitude: the join is on the sphere, and + # the polygons decide. + ll <- function(x) sf::st_transform(x, 4326) + expect_identical(.gt_assign(ll(pts), .count_rule_put(ll(sq), .gt_record(cen)))$cell_id, + .gt_assign(ll(pts), ll(sq))$cell_id) + # Two squares of 0.01 degree drawn in degrees on either side of the meridian + # 80 W, five points on it, and a record in EPSG:32617 whose centres stand + # near the meridian on one side or the other: the sphere decides each + # point, whichever centre is nearer. + deg <- function(x0) sf::st_polygon(list(cbind(x0 + c(0, 0.01, 0.01, 0, 0), + 45 + c(0, 0, 0.01, 0.01, 0)))) + cells_ll <- sf::st_sf(cell_id = 1:2, geometry = sf::st_sfc(deg(-80.01), deg(-80), crs = 4326)) + on_meridian <- sf::st_as_sf(data.frame(x = -80, y = 45 + 0.01 * (1:5) / 6, row = 1:5), + coords = c("x", "y"), crs = 4326) + sphere <- .gt_assign(on_meridian, cells_ll)$cell_id + for (at in list(c(-0.001, 0.009), c(-0.009, 0.001))) { + mid <- sf::st_as_sf(data.frame(x = -80 + at, y = 45.005), coords = c("x", "y"), crs = 4326) + centres <- unname(sf::st_coordinates(sf::st_transform(mid, 32617))[, 1:2]) + expect_identical(.gt_assign(on_meridian, .count_rule_put(cells_ll, .gt_record(centres)))$cell_id, + sphere) + } +}) + +test_that("points that arrive in another CRS are measured in the record's, as the profile measured them", { + sq <- .gt_squares() + cen <- .gt_middles()[c(4, 3, 2, 1), ] + cells <- .count_rule_put(sq, .gt_record(cen)) + # The six points and a lattice of 81 more inside the four squares, in degrees. + g <- expand.grid(x = seq(2, 18, by = 2), y = seq(2, 18, by = 2)) + pts_ll <- sf::st_transform(rbind(.gt_six(), .gt_points(g$x, g$y)), 4326) + got <- .gt_assign(pts_ll, cells) + # The profile's rule on their coordinates in EPSG:32617, and the square of + # the centre it gives. + xy <- unname(sf::st_coordinates(sf::st_transform(pts_ll, 32617))) + want <- c(4L, 3L, 2L, 1L)[.nearest_exact(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L])] + expect_identical(got$cell_id, want) + expect_identical(sf::st_geometry(got), sf::st_geometry(pts_ll)) +}) + + +# ---- cell_values_at() ------------------------------------------------------------ + +test_that("cell_values_at() with the seeds in any order places the rows and the points between centres where the assignment does", { + for (kind in c("density", "kmeans")) { + pts <- .gt_lattice(30L, 20L, 30) + P <- .gt_lattice_path(c(30L, 20L), 30, kind) + placed <- .gt_cell_of(P$asg, pts) + n <- nrow(P$seeds) + for (o in list(rev(seq_len(n)), order(P$seeds$cell_id), local({ .gt_seed(4); sample.int(n) }))) { + at <- cell_values_at(pts, P$out, P$asg, "z", id_col = "cell_id", seeds = P$seeds[o, ]) + expect_identical(at$cell_id, placed, info = kind) + } + .gt_expect_midpoints(P, kind) + } +}) + +test_that("seeds are matched to the centres they stand at, whatever their order, and nothing else is", { + .gt_seed(77) + cen <- cbind(5e5 + stats::runif(40, 0, 1000), 5e6 + stats::runif(40, 0, 1000)) + o <- sample.int(40) + for (fnn in unique(c(FALSE, .has_backend("FNN")))) { + expect_identical(.seeds_as_centres(cen, cen, use_fnn = fnn), 1:40) + expect_identical(.seeds_as_centres(cen[o, ], cen, use_fnn = fnn)[o], 1:40) + # Seeds moved by rounding are the centres; seeds a metre away, two seeds + # at one centre, a subset, or a seed that is not finite, are not. + expect_identical(.seeds_as_centres(cen + 1e-6, cen, use_fnn = fnn), 1:40) + moved <- cen; moved[7L, ] <- moved[7L, ] + 1 + expect_null(.seeds_as_centres(moved, cen, use_fnn = fnn)) + twice <- cen; twice[2L, ] <- cen[1L, ] + expect_null(.seeds_as_centres(twice, cen, use_fnn = fnn)) + expect_null(.seeds_as_centres(cen[-1L, ], cen, use_fnn = fnn)) + nf <- cen; nf[3L, 1L] <- NA + expect_null(.seeds_as_centres(nf, cen, use_fnn = fnn)) + } + # With and without FNN, the nearest and the next nearest are the same. + q <- cbind(5e5 + stats::runif(200, 0, 1000), 5e6 + stats::runif(200, 0, 1000)) + a <- .two_nearest(q[, 1L], q[, 2L], cen[, 1L], cen[, 2L], use_fnn = FALSE) + expect_identical(a$first, .nearest_exact(q[, 1L], q[, 2L], cen[, 1L], cen[, 2L])) + expect_true(all(a$d2 >= a$d1)) + if (.has_backend("FNN")) + expect_identical(.two_nearest(q[, 1L], q[, 2L], cen[, 1L], cen[, 2L], use_fnn = TRUE), a) +}) + +test_that("cell_values_at() places a location on an edge where the assignment placed such a row, whatever rounding moved the seeds", { + sq <- .gt_squares() + cen <- .gt_middles()[c(4, 3, 2, 1), ] + # Response "z" on the six points and on the middles; a record that speaks + # for no estimate and no response, so the summary checks nothing. + rec <- .gt_record(cen); rec$estimate <- NA_character_; rec$response <- NA_character_ + cells <- .count_rule_put(sq, rec) + rows <- .gt_six() + rows$z <- c(1, 2, 3, 4, 5, 6) + asg <- .gt_assign(rows, cells) + values <- summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = cells, estimate = "mean") + expect_identical(attr(values, "count_rule")$check$cells, + "not checked: the response is another column") + # The seeds as the centres, the first of them (UR) moved north by one step + # of the arithmetic (1e-9 rounds to 9.3e-10 there), so that the corner and + # the edge LR|UR are a little nearer other seeds than to it. + at_seeds <- cen + at_seeds[1L, 2L] <- at_seeds[1L, 2L] + 1e-9 + expect_gt(at_seeds[1L, 2L], cen[1L, 2L]) + seeds <- sf::st_as_sf(data.frame(x = at_seeds[, 1L], y = at_seeds[, 2L], + cell_id = c(4L, 3L, 2L, 1L)), + coords = c("x", "y"), crs = 32617) + newdata <- .gt_six() + at <- cell_values_at(newdata, values, asg, "z", id_col = "cell_id", seeds = seeds) + expect_identical(at$cell_id, asg$cell_id) + expect_identical(at$cell_id, c(2L, 3L, 4L, 4L, 1L, 4L)) + # The seeds are the centres to rounding, in the profile's order. + seed_xy <- unname(sf::st_coordinates(seeds)) + rule <- attr(values, "count_rule") + expect_identical(.values_at_centres(rule, seed_xy, sf::st_crs(32617)), + list(centres = cen, seed = 1:4)) + # Seeds in any other order are the centres too: the search is over the + # centres in the profile's order, and each gives the ID of its seed. + for (o in list(c(2L, 1L, 3L, 4L), 4:1, order(seeds$cell_id), c(3L, 1L, 4L, 2L))) { + got <- .values_at_centres(rule, seed_xy[o, ], sf::st_crs(32617)) + expect_identical(got$centres, cen) + expect_identical(o[got$seed], 1:4) + at_o <- cell_values_at(newdata, values, asg, "z", id_col = "cell_id", seeds = seeds[o, ]) + expect_identical(at_o$cell_id, asg$cell_id, info = paste(o, collapse = " ")) + } + # A seed farther from its centre than the margin of an edge, by a + # ten-thousandth of the distance between centres, is still that centre, + # as seeds that went through another CRS and back are. + tol <- .edge_tol(sf::st_bbox(sq)) + near <- seed_xy; near[1L, 1L] <- near[1L, 1L] + 1e-3 + expect_gt(1e-3, tol) + expect_identical(.values_at_centres(rule, near, sf::st_crs(32617))$seed, 1:4) + # A seed moved by a hundredth of that distance is not, nor are two seeds + # at one centre, another number of seeds, or seeds in another CRS. + far <- seed_xy; far[1L, 1L] <- far[1L, 1L] + 0.1 + expect_null(.values_at_centres(rule, far, sf::st_crs(32617))) + twice <- seed_xy; twice[2L, ] <- seed_xy[1L, ] + expect_null(.values_at_centres(rule, twice, sf::st_crs(32617))) + expect_null(.values_at_centres(rule, seed_xy[1:3, ], sf::st_crs(32617))) + expect_null(.values_at_centres(rule, seed_xy, sf::st_crs(32618))) + expect_null(.values_at_centres(NULL, seed_xy, sf::st_crs(32617))) + # Seeds that are not the centres are searched as given, and a tie goes to + # the seed that comes first. + far_seeds <- seeds; sf::st_geometry(far_seeds) <- sf::st_geometry(sf::st_as_sf( + data.frame(x = far[, 1L], y = far[, 2L]), coords = c("x", "y"), crs = 32617)) + o <- c(2L, 1L, 3L, 4L) + expect_identical(cell_values_at(newdata, values, asg, "z", id_col = "cell_id", + seeds = far_seeds[o, ])$cell_id, c(2L, 3L, 3L, 2L, 1L, 4L)) + # Without seeds the polygons of `values` place the locations with the record. + at_p <- cell_values_at(newdata, values, asg, "z", id_col = "cell_id") + expect_identical(at_p$cell_id, asg$cell_id) + # A summary without the record places them as the polygons alone do. + bare <- values; attr(bare, "count_rule") <- NULL + expect_identical(cell_values_at(newdata, bare, asg, "z", id_col = "cell_id")$cell_id, + c(1L, 1L, 1L, 2L, 1L, 4L)) + expect_identical(cell_values_at(newdata, bare, asg, "z", id_col = "cell_id", + seeds = seeds)$cell_id, c(2L, 3L, 3L, 2L, 1L, 4L)) +}) + + +# ---- The record ---------------------------------------------------------------------- + +test_that("the record holds the centres the profile scored, as the profile holds them", { + P <- .gt_lattice_path(c(30L, 20L), 30, "density") + rec <- P$sel$count_rule + cen <- rec$scored$centres + expect_identical(utils::tail(names(rec$scored), 1L), "centres") + expect_identical(cen, unname(attr(P$prof, "centres")[[as.character(P$sel$best)]])) + expect_identical(cen, unname(sf::st_coordinates(P$sel$seeds)[, 1:2])) + expect_identical(dim(cen), c(P$sel$best, 2L)) + # Every layer down the path carries them. + for (x in list(P$sel$seeds, P$tess$cells, P$asg, P$out)) + expect_identical(attr(x, "count_rule")$scored$centres, cen) + expect_identical(.scored_centres(attr(P$asg, "count_rule")), cen) + expect_null(.scored_centres(rec)) # beside no centres + # A profile that no longer holds its centres writes none, and the record + # keeps the field. + bare <- P$prof; attr(bare, "centres") <- NULL + r <- .count_rule_new(bare, "size", P$sel$best, scored_cells = TRUE) + expect_identical(names(r$scored), names(rec$scored)) + expect_null(r$scored$centres) + expect_null(.scored_centres(r)) + # The k-means kind's centres, as plain numbers. + K <- .gt_lattice_path(c(30L, 20L), 30, "kmeans")$sel$count_rule$scored$centres + expect_true(is.double(K) && is.null(dimnames(K)) && ncol(K) == 2L) +}) + + +# ---- A real difference is still reported ------------------------------------------------ + +test_that("rows dropped, a seed moved, another estimate's cells and a changed value are still reported", { + pts <- .gt_lattice(30L, 20L, 30) + P <- .gt_lattice_path(c(30L, 20L), 30, "density") + sum_of <- function(asg, cells = P$tess$cells, estimate = "pooled") + .gt_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = cells, + estimate = estimate)) + differ <- function(r) .gt_of(r, "spatialkit_cells_differ") + + # Rows dropped. + r <- sum_of(P$asg[-(1:30), ]) + expect_length(differ(r), 1L) + expect_identical(differ(r)[[1L]]$what, "n") + expect_identical(attr(r$value, "count_rule")$check$cells, "differ") + + # One seed moved one spacing east and one north: its cell is another, and + # rows nowhere near an edge of the scored cells lie in it. The record + # still says these are the scored centres. + xy <- unname(sf::st_coordinates(P$seeds)[, 1:2]) + k <- 60L + xy[k, ] <- xy[k, ] + c(30, 30) + seeds <- sf::st_as_sf(data.frame(seed_id = seq_len(nrow(xy)), x = xy[, 1L], y = xy[, 2L]), + coords = c("x", "y"), crs = sf::st_crs(P$seeds)) + attr(seeds, "cover") <- attr(P$seeds, "cover") + seeds <- .count_rule_put(seeds, attr(P$seeds, "count_rule")) + expect_true(isTRUE(attr(seeds, "count_rule")$scored_cells)) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", quiet = TRUE) + rule <- .gt_profile_rule(list(sel = P$sel, tess = tess), pts) + placed <- .gt_cell_of(asg, pts) + elsewhere <- which(placed != rule$cell) + expect_gt(length(elsewhere), 0L) + d2 <- function(rows, centre) (rule$xy[rows, 1L] - rule$cen[centre, 1L])^2 + + (rule$xy[rows, 2L] - rule$cen[centre, 2L])^2 + gap <- abs(d2(elsewhere, match(placed[elsewhere], tess$index)) - + d2(elsewhere, match(rule$cell[elsewhere], tess$index))) / + d2(elsewhere, match(rule$cell[elsewhere], tess$index)) + expect_true(any(gap > 1e-3)) + r <- sum_of(asg, tess$cells) + expect_length(differ(r), 1L) + expect_true(differ(r)[[1L]]$what %in% c("cells", "loo")) + expect_identical(attr(r$value, "count_rule")$check$cells, "differ") + + # Rows assigned to the cells of a count chosen for plain means, summarised + # with the cells of the count chosen for pooled values: the two records + # differ in the estimate. + plain <- suppressWarnings( + resolution_profile(pts, "z", partition = "density", nstart = 3, sac = "auto", seed = 123, + estimate = "mean", obs_per_cell = 4.5)) + sel_m <- select_resolution(plain, criterion = "size") + seeds_m <- suppressWarnings(get_voronoi_seeds(method = "kmeans", n = sel_m, sample_points = pts)) + asg_m <- assign_features_to_polygons(pts, build_tessellation(seeds_m, method = "voronoi", + quiet = TRUE)$cells, + polygon_id_col = "cell_id", quiet = TRUE) + r <- sum_of(asg_m, estimate = "mean") + expect_identical(differ(r)[[1L]]$what, "record") + expect_identical(differ(r)[[1L]]$field, "estimate") + # The pooled count's rows summarised as plain means: the estimate's warning. + r <- sum_of(P$asg, estimate = "mean") + expect_length(.gt_of(r, "spatialkit_estimate_mismatch"), 1L) + expect_length(differ(r), 0L) + + # One value changed. + changed <- P$asg + changed$z[100L] <- changed$z[100L] + 5 + r <- sum_of(changed) + expect_length(differ(r), 1L) + expect_identical(differ(r)[[1L]]$what, "loo") +}) diff --git a/tests/testthat/test-core-partition-arguments.R b/tests/testthat/test-core-partition-arguments.R new file mode 100644 index 00000000..90b8619e --- /dev/null +++ b/tests/testthat/test-core-partition-arguments.R @@ -0,0 +1,280 @@ +# tests/testthat/test-core-partition-arguments.R +# --------------------------------------------------------------------------- +# The partition arguments reach the engine. For each public function the +# centres at a power, a neighbour count and a starting rule other than the +# default are the engine's at those settings under the same seed, and are +# not the default's: an argument that is recorded and then dropped on the +# way down would pass every check of the record. +# Also here: what the functions say of an argument that nothing reads. +# --------------------------------------------------------------------------- + +.pa_xy <- function() partition_clustered_xy(n_bg = 200L, n_cl = 500L, seed = 17L) + +# The engine at the settings a public function is given, under its seed. +.pa_engine <- function(xy, k, seed, nstart, settings) { + set.seed(seed) + do.call(spatialkit:::.partition_centres, + c(list(xy, k, partition = "density", nstart = nstart, iter.max = 100L), settings)) +} + +# Settings other than the defaults (power 1, 8 neighbours, k-means++ starts), +# one at a time and together. +.pa_settings <- list( + power = list(density_power = 0.4), + k_nn = list(density_k = 3), + random = list(init = "random"), + all = list(density_power = 1.6, density_k = 20, init = "random")) + +# What the record of a call at those settings says. +.pa_record <- function(settings) { + rec <- list(kind = "density", init = "kmeans++", density_power = 1, density_k = 8L) + if (!is.null(settings$init)) rec$init <- settings$init + if (!is.null(settings$density_power)) rec$density_power <- settings$density_power + if (!is.null(settings$density_k)) rec$density_k <- as.integer(settings$density_k) + rec +} + + +test_that("the engine's settings change its centres", { + # The premise of the three tests below: each setting gives another + # partition than the default's, by far more than rounding. + xy <- .pa_xy() + base <- .pa_engine(xy, 25L, 6L, 3L, list()) + for (nm in names(.pa_settings)) { + other <- .pa_engine(xy, 25L, 6L, 3L, .pa_settings[[nm]]) + expect_gt(max(abs(other$centers - base$centers)), 1, label = nm) + expect_false(identical(other$cluster, base$cluster), label = nm) + } + # The power and the neighbour count act through the weights. + expect_false(isTRUE(all.equal(.pa_engine(xy, 25L, 6L, 3L, list(density_power = 0.4))$weights, + base$weights))) + expect_false(isTRUE(all.equal(.pa_engine(xy, 25L, 6L, 3L, list(density_k = 3))$weights, + base$weights))) +}) + +test_that("a random start of the density kind is k locations drawn in coordinate order", { + # One start, one step of Lloyd's iteration: the centres are then the + # weighted means of the Voronoi cells of the start, which pins the start to + # sample.int() over the distinct locations in coordinate order. + xy <- .pa_xy() + xs <- partition_sorted(xy) + for (k in c(4L, 30L)) for (seed in c(2L, 9L)) { + set.seed(seed) + got <- spatialkit:::.partition_centres(xy, k, partition = "density", init = "random", + nstart = 1L, iter.max = 1L) + set.seed(seed) + start <- xs[sample.int(nrow(xs), k), , drop = FALSE] + cl <- partition_nearest(xs, start) + w <- got$weights[order(xy[, 1L], xy[, 2L])] + ref <- rowsum(xs * w, cl) / as.numeric(rowsum(w, cl)) + expect_identical(sort(unique(cl)), seq_len(k)) # every start location has its own point + expect_equal(got$centers, ref, tolerance = 1e-10, ignore_attr = TRUE) + # A k-means++ start under the same seed is another start. + set.seed(seed) + pp <- spatialkit:::.partition_centres(xy, k, partition = "density", init = "kmeans++", + nstart = 1L, iter.max = 1L) + expect_gt(max(abs(pp$centers - got$centers)), 1) + } +}) + +test_that("voronoi_seeds_kmeans() hands density_power, density_k and init to the engine", { + xy <- .pa_xy() + pts <- partition_points_sf(xy) + k <- 25L + base <- voronoi_seeds_kmeans(pts, k, partition = "density", nstart = 3, set_seed = 6) + expect_identical(partition_xy(base), .pa_engine(xy, k, 6L, 3L, list())$centers) + for (nm in names(.pa_settings)) { + st <- .pa_settings[[nm]] + s <- do.call(voronoi_seeds_kmeans, + c(list(pts, k, partition = "density", nstart = 3, set_seed = 6), st)) + expect_identical(partition_xy(s), .pa_engine(xy, k, 6L, 3L, st)$centers, label = nm) + expect_gt(max(abs(partition_xy(s) - partition_xy(base))), 1, label = nm) + expect_identical(attr(s, "partition")[1:4], .pa_record(st), label = nm) + } + # The default number of starts is 10. + expect_identical(partition_xy(voronoi_seeds_kmeans(pts, k, partition = "density", set_seed = 6)), + .pa_engine(xy, k, 6L, 10L, list())$centers) +}) + +test_that("get_voronoi_seeds() hands density_power, density_k and init to the engine", { + xy <- .pa_xy() + pts <- partition_points_sf(xy) + k <- 25L + call <- function(...) get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", kmeans_nstart = 3, + set_seed = 6, ...) + base <- call() + expect_identical(partition_xy(base), .pa_engine(xy, k, 6L, 3L, list())$centers) + for (nm in names(.pa_settings)) { + st <- .pa_settings[[nm]] + s <- do.call(call, st) + eng <- .pa_engine(xy, k, 6L, 3L, st) + expect_identical(partition_xy(s), eng$centers, label = nm) + expect_gt(max(abs(partition_xy(s) - partition_xy(base))), 1, label = nm) + expect_identical(attr(s, "partition")[1:4], .pa_record(st), label = nm) + # The record of the run is the engine's at those settings as well. + expect_identical(attr(s, "kmeans")$cluster, eng$cluster, label = nm) + expect_identical(attr(s, "kmeans")$objective, eng$objective, label = nm) + expect_identical(attr(s, "kmeans")$iter, eng$iter, label = nm) + } + # The default number of starts is 10. + expect_identical(partition_xy(get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", set_seed = 6)), + .pa_engine(xy, k, 6L, 10L, list())$centers) +}) + +test_that("resolution_profile() hands density_power, density_k and init to the engine", { + # Geometry only, so nothing draws from the stream before the sweep. + xy <- .pa_xy() + pts <- partition_points_sf(xy) + k <- 25L + call <- function(...) resolution_profile(pts, levels = k, nstart = 3, seed = 6, + partition = "density", ...) + base <- call() + expect_identical(attr(base, "centres")[[as.character(k)]], + .pa_engine(xy, k, 6L, 3L, list())$centers) + for (nm in names(.pa_settings)) { + st <- .pa_settings[[nm]] + p <- do.call(call, st) + eng <- .pa_engine(xy, k, 6L, 3L, st) + cen <- attr(p, "centres")[[as.character(k)]] + expect_identical(cen, eng$centers, label = nm) + expect_gt(max(abs(cen - attr(base, "centres")[[as.character(k)]])), 1, label = nm) + expect_identical(attr(p, "partition")[1:4], .pa_record(st), label = nm) + expect_identical(p$wss, eng$wss, label = nm) + expect_identical(unname(attr(p, "partition")$objective), eng$objective, label = nm) + expect_identical(p$cell_n_min, min(eng$size), label = nm) + # The selection's seeds are those centres, with the record. + seeds <- spatialkit:::.profile_seeds(p, k) + expect_identical(partition_xy(seeds), eng$centers, label = nm) + expect_identical(attr(seeds, "partition"), .pa_record(st), label = nm) + } + # The second level of a ladder is built with the same settings: its starts + # follow the first level's in the stream. + st <- .pa_settings$all + p2 <- do.call(resolution_profile, c(list(pts, levels = c(8L, k), nstart = 2, seed = 6, + partition = "density"), st)) + set.seed(6) + e1 <- do.call(spatialkit:::.partition_centres, + c(list(xy, 8L, partition = "density", nstart = 2L, iter.max = 100L), st)) + e2 <- do.call(spatialkit:::.partition_centres, + c(list(xy, k, partition = "density", nstart = 2L, iter.max = 100L), st)) + expect_identical(attr(p2, "centres")[["8"]], e1$centers) + expect_identical(attr(p2, "centres")[[as.character(k)]], e2$centers) +}) + + +# ---- Arguments nothing reads ----------------------------------------------------- + +.pa_scored <- function() { + xy <- .pa_xy() + cleanup <- spatialkit:::.with_seed(18L) + z <- sin(xy[, 1L] / 150) + stats::rnorm(nrow(xy), sd = 0.5) + cleanup() + pts <- partition_points_sf(xy, z = z) + sel_of <- function(p, L) structure( + list(best = L, seeds = spatialkit:::.profile_seeds(p, L), criterion = "cp", + edge = NA_character_, structured = TRUE), class = "resolution_selection") + p_km <- partition_quietly(resolution_profile(pts, "z", levels = c(6L, 14L), nstart = 2, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + p_den <- partition_quietly(resolution_profile(pts, "z", levels = c(6L, 14L), nstart = 2, + partition = "density", density_power = 0.5)) + list(pts = pts, p_km = p_km, p_den = p_den, km = sel_of(p_km, 14L), den = sel_of(p_den, 14L)) +} + +test_that("a density setting named beside scored density centres is not called ignored", { + sc <- .pa_scored() + rec <- list(kind = "density", init = "kmeans++", density_power = 0.5, density_k = 8L) + # The power the profile was built with, named with no `partition`: the + # centres returned are density ones at that power, and nothing is wrong. + for (f in list(function(...) voronoi_seeds_kmeans(sc$pts, sc$den, ...), + function(...) get_voronoi_seeds(method = "kmeans", n = sc$den, + sample_points = sc$pts, ...))) { + r <- partition_warnings(f(density_power = 0.5)) + expect_length(r$warnings, 0L) + expect_identical(attr(r$value, "partition"), rec) + expect_equal(partition_xy(r$value), attr(sc$p_den, "centres")[["14"]], tolerance = 1e-12) + # Another power, or another neighbour count, than the profile's: the + # scored centres are returned and the call is told its setting is unused. + for (other in list(list(density_power = 0.7), list(density_k = 4))) { + r <- partition_warnings(do.call(f, other)) + expect_length(r$warnings, 1L) + expect_s3_class(r$warnings[[1L]], "spatialkit_partition_unused") + expect_match(conditionMessage(r$warnings[[1L]]), + "built with partition = \"density\" from k-means++ starts (power 0.5, 8 neighbours)", + fixed = TRUE) + expect_identical(attr(r$value, "partition"), rec) + } + # With `partition = "density"` named, the defaults of the two settings + # are named with it, and the power is not the profile's. + r <- partition_warnings(f(partition = "density")) + expect_length(partition_of_class(r, "spatialkit_partition_unused"), 1L) + expect_length(partition_warnings(f(partition = "density", density_power = 0.5))$warnings, 0L) + } +}) + +test_that("a density setting named beside k-means centres, scored or fresh, is said to be ignored", { + sc <- .pa_scored() + text <- "`density_power` is read by partition = \"density\" only, and partition = \"kmeans\" ignores it" + r <- partition_warnings(voronoi_seeds_kmeans(sc$pts, sc$km, density_power = 0.7, + partition = "kmeans")) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), paste0("voronoi_seeds_kmeans(): ", text), + fixed = TRUE) + expect_null(attr(r$value, "partition")) + r <- partition_warnings(get_voronoi_seeds(method = "kmeans", n = sc$km, sample_points = sc$pts, + density_power = 0.7, partition = "kmeans")) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), paste0("get_voronoi_seeds(): ", text), + fixed = TRUE) + # A fresh run: once, and the seeds are the k-means kind's without the setting. + r <- partition_warnings(voronoi_seeds_kmeans(sc$pts, 9, density_power = 0.7, + partition = "kmeans")) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), text, fixed = TRUE) + expect_identical(r$value, voronoi_seeds_kmeans(sc$pts, 9, partition = "kmeans")) +}) + +test_that("get_voronoi_seeds() checks its two counts before a new kind reads them", { + pts <- partition_points_sf(.pa_xy()) + for (extra in list(list(partition = "density"), list(init = "kmeans++"))) { + f <- function(...) do.call(get_voronoi_seeds, + c(list(method = "kmeans", n = 5, sample_points = pts, set_seed = 1), + extra, list(...))) + for (bad in list(0, NA, "a", 2.5, c(1, 2), Inf, -3)) { + expect_error(f(kmeans_nstart = bad), + "get_voronoi_seeds(): `kmeans_nstart` must be NULL or a single positive whole number of starts", + fixed = TRUE) + expect_error(f(kmeans_iter = bad), + "get_voronoi_seeds(): `kmeans_iter` must be a single positive whole number of iterations", + fixed = TRUE) + } + # What is recorded is what ran. + g <- f(kmeans_nstart = 2, kmeans_iter = 60) + expect_identical(attr(g, "kmeans")$nstart, 2L) + expect_identical(attr(g, "partition")$iter_max, 60L) + } + # The run the function has always made hands both to stats::kmeans() as + # they are, as it always did: a start count of 2.5 is that function's two + # starts, and is not refused here. + set.seed(1) + km <- stats::kmeans(x = partition_xy(pts), centers = 5, iter.max = 100, nstart = 2.5) + g <- get_voronoi_seeds(method = "kmeans", n = 5, sample_points = pts, set_seed = 1, + kmeans_nstart = 2.5, partition = "kmeans") + expect_identical(partition_xy(g), unname(km$centers)) + expect_identical(attr(g, "kmeans")$nstart, 2L) +}) + +test_that("summary() of a profile names the kind of its cells when the profile records one", { + sc <- .pa_scored() + sm <- suppressWarnings(summary(sc$p_den)) + expect_identical(attr(sm, "partition"), + list(kind = "density", init = "kmeans++", density_power = 0.5, density_k = 8L)) + expect_output(print(sm), " cells: density-weighted k-means++ starts (power 0.5, 8 neighbours)", + fixed = TRUE) + # A k-means profile's summary is the object it always was, and prints so. + sm_km <- suppressWarnings(summary(sc$p_km)) + expect_null(attr(sm_km, "partition")) + expect_false(any(grepl("cells:", capture.output(print(sm_km)), fixed = TRUE))) +}) diff --git a/tests/testthat/test-core-partition-convergence.R b/tests/testthat/test-core-partition-convergence.R new file mode 100644 index 00000000..47cdf31b --- /dev/null +++ b/tests/testthat/test-core-partition-convergence.R @@ -0,0 +1,325 @@ +# tests/testthat/test-core-partition-convergence.R +# --------------------------------------------------------------------------- +# The iteration limit. A start of the density kind runs for at most 100 +# steps of Lloyd's iteration in the profile and the seeding functions (the +# `iter_max` and `kmeans_iter` arguments set another limit). A start that +# was kept and had not converged at the limit is returned with the centres +# of its last step, and that is said: a warning of class +# "spatialkit_not_converged", and `converged` in the record. +# --------------------------------------------------------------------------- + +.pv_engine <- function(xy, k, seed, iter.max, init = "kmeans++", nstart = 1L) { + set.seed(seed) + spatialkit:::.partition_centres(xy, k, partition = "density", init = init, + nstart = nstart, iter.max = iter.max) +} + +# Two single starts on 1,200 uniform points that take more than 40 steps to +# stop moving and fewer than 100 (measured: 59 and 48), one from a random +# start and one from a k-means++ start. +.pv_cases <- list( + random = list(k = 20L, seed = 3L, init = "random"), + kmeanspp = list(k = 10L, seed = 20L, init = "kmeans++")) + + +test_that("the engine says whether the start it kept stopped before the limit", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + full <- .pv_engine(xy, 30L, 4L, 500L) + expect_true(full$converged) + expect_gt(full$iter, 3L) + # Stopped at exactly the step it needs: converged. One step fewer: not. + at <- .pv_engine(xy, 30L, 4L, full$iter) + expect_true(at$converged) + expect_identical(at$centers, full$centers) + short <- .pv_engine(xy, 30L, 4L, full$iter - 1L) + expect_false(short$converged) + expect_identical(short$iter, full$iter - 1L) + cut <- .pv_engine(xy, 30L, 4L, 3L) + expect_false(cut$converged) + expect_identical(cut$iter, 3L) + # The cut-off centres are those of the last step, with their own cells: a + # partition, of a higher weighted sum than the converged one. + expect_identical(cut$cluster, as.integer(partition_nearest(xy, cut$centers))) + expect_gt(cut$objective, full$objective) + # The k-means kind: stats::kmeans()'s own verdict, with the iterations held + # to the limit (it reports one more for a fit it cut off). + set.seed(4) + km <- spatialkit:::.partition_centres(partition_sorted(xy), 30L, partition = "kmeans", + init = "kmeans++", nstart = 2L, iter.max = 1L) + expect_false(km$converged) + expect_identical(km$iter, 1L) + expect_identical(km$km$ifault, 2L) + set.seed(4) + km <- spatialkit:::.partition_centres(partition_sorted(xy), 30L, partition = "kmeans", + init = "kmeans++", nstart = 2L) + expect_true(km$converged) + expect_identical(km$km$ifault, 0L) +}) + +test_that("the two test cases take more than 40 steps and fewer than 100", { + xy <- partition_uniform_xy(1200L, seed = 41L) + for (nm in names(.pv_cases)) { + cs <- .pv_cases[[nm]] + full <- .pv_engine(xy, cs$k, cs$seed, 100L, cs$init) + expect_true(full$converged, label = nm) + expect_gt(full$iter, 45L, label = nm) + expect_lt(full$iter, 100L, label = nm) + # Cut off at 40 or at 10 steps the centres are elsewhere, by tens of + # units on a square of side 1000, and points are in other cells. + for (lim in c(40L, 10L)) { + cut <- .pv_engine(xy, cs$k, cs$seed, lim, cs$init) + expect_false(cut$converged, label = nm) + expect_gt(max(abs(cut$centers - full$centers)), 10, label = nm) + expect_gt(sum(cut$cluster != full$cluster), 20L, label = nm) + } + } +}) + +test_that("voronoi_seeds_kmeans() runs a density start for up to 100 steps, or iter_max", { + xy <- partition_uniform_xy(1200L, seed = 41L) + pts <- partition_points_sf(xy) + for (nm in names(.pv_cases)) { + cs <- .pv_cases[[nm]] + full <- .pv_engine(xy, cs$k, cs$seed, 100L, cs$init) + r <- partition_warnings(voronoi_seeds_kmeans(pts, cs$k, partition = "density", init = cs$init, + nstart = 1, set_seed = cs$seed)) + expect_length(r$warnings, 0L) + expect_identical(partition_xy(r$value), full$centers, label = nm) + expect_identical(attr(r$value, "partition")[c("iter", "iter_max", "converged")], + list(iter = full$iter, iter_max = 100L, converged = TRUE), label = nm) + # A limit of 40: the engine's centres at 40 steps, and a warning. + cut <- .pv_engine(xy, cs$k, cs$seed, 40L, cs$init) + r <- partition_warnings(voronoi_seeds_kmeans(pts, cs$k, partition = "density", init = cs$init, + nstart = 1, set_seed = cs$seed, iter_max = 40)) + expect_identical(partition_xy(r$value), cut$centers, label = nm) + expect_length(r$warnings, 1L) + w <- r$warnings[[1L]] + expect_s3_class(w, "spatialkit_not_converged") + expect_identical(w[c("level", "iter", "iter_max")], + list(level = cs$k, iter = 40L, iter_max = 40L)) + expect_match(conditionMessage(w), sprintf( + "voronoi_seeds_kmeans(): at %d cells the start that was kept had not converged after 40 steps of Lloyd's iteration (partition = \"density\")", + cs$k), fixed = TRUE) + expect_match(conditionMessage(w), "Raise `iter_max`", fixed = TRUE) + expect_identical(attr(r$value, "partition")[c("iter", "iter_max", "converged")], + list(iter = 40L, iter_max = 40L, converged = FALSE), label = nm) + # A limit above the default changes nothing for a start that converges. + expect_identical(partition_xy(voronoi_seeds_kmeans(pts, cs$k, partition = "density", + init = cs$init, nstart = 1, + set_seed = cs$seed, iter_max = 400)), + full$centers, label = nm) + } +}) + +test_that("get_voronoi_seeds() runs a density start for kmeans_iter steps, 100 by default", { + xy <- partition_uniform_xy(1200L, seed = 41L) + pts <- partition_points_sf(xy) + for (nm in names(.pv_cases)) { + cs <- .pv_cases[[nm]] + call <- function(...) get_voronoi_seeds(method = "kmeans", n = cs$k, sample_points = pts, + partition = "density", init = cs$init, + kmeans_nstart = 1, set_seed = cs$seed, ...) + full <- .pv_engine(xy, cs$k, cs$seed, 100L, cs$init) + r <- partition_warnings(call()) + expect_length(r$warnings, 0L) + expect_identical(partition_xy(r$value), full$centers, label = nm) + expect_true(attr(r$value, "kmeans")$converged, label = nm) + expect_identical(attr(r$value, "kmeans")$iter, full$iter, label = nm) + cut <- .pv_engine(xy, cs$k, cs$seed, 40L, cs$init) + r <- partition_warnings(call(kmeans_iter = 40)) + expect_identical(partition_xy(r$value), cut$centers, label = nm) + expect_length(r$warnings, 1L) + w <- r$warnings[[1L]] + expect_s3_class(w, "spatialkit_not_converged") + expect_identical(w[c("level", "iter", "iter_max")], + list(level = cs$k, iter = 40L, iter_max = 40L)) + expect_match(conditionMessage(w), "get_voronoi_seeds(): at", fixed = TRUE) + expect_match(conditionMessage(w), "Raise `kmeans_iter`", fixed = TRUE) + expect_false(attr(r$value, "kmeans")$converged, label = nm) + expect_identical(attr(r$value, "kmeans")$iter, 40L, label = nm) + expect_identical(attr(r$value, "partition")[c("iter", "iter_max", "converged")], + list(iter = 40L, iter_max = 40L, converged = FALSE), label = nm) + } +}) + +test_that("resolution_profile() runs a density start for up to 100 steps, or iter_max", { + # Geometry only, so nothing draws from the stream before the sweep. + xy <- partition_uniform_xy(1200L, seed = 41L) + pts <- partition_points_sf(xy) + for (nm in names(.pv_cases)) { + cs <- .pv_cases[[nm]] + key <- as.character(cs$k) + call <- function(...) resolution_profile(pts, levels = cs$k, nstart = 1, seed = cs$seed, + partition = "density", init = cs$init, ...) + full <- .pv_engine(xy, cs$k, cs$seed, 100L, cs$init) + r <- partition_warnings(call()) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_identical(attr(r$value, "centres")[[key]], full$centers, label = nm) + rec <- attr(r$value, "partition") + expect_identical(rec$iter_max, 100L) + expect_identical(rec$iter, stats::setNames(full$iter, key)) + expect_identical(rec$converged, stats::setNames(TRUE, key)) + cut <- .pv_engine(xy, cs$k, cs$seed, 40L, cs$init) + r <- partition_warnings(call(iter_max = 40)) + expect_identical(attr(r$value, "centres")[[key]], cut$centers, label = nm) + w <- partition_of_class(r, "spatialkit_not_converged") + expect_length(w, 1L) + expect_identical(w[[1L]][c("level", "iter", "iter_max")], + list(level = cs$k, iter = 40L, iter_max = 40L)) + expect_match(conditionMessage(w[[1L]]), sprintf( + "resolution_profile(): at 1 of the 1 levels (%d cells) the start that was kept had not converged after 40 steps", + cs$k), fixed = TRUE) + rec <- attr(r$value, "partition") + expect_identical(rec$iter_max, 40L) + expect_identical(rec$iter, stats::setNames(40L, key)) + expect_identical(rec$converged, stats::setNames(FALSE, key)) + } +}) + +test_that("a profile names the levels that were cut off, in one warning", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + pts <- partition_points_sf(xy) + lv <- c(2L, 9L, 30L, 60L) + # The sweep, level after level in one stream, as the profile runs it. + sweep <- function(limit) { + set.seed(11) + lapply(lv, function(L) spatialkit:::.partition_centres(xy, L, partition = "density", + nstart = 2L, iter.max = limit)) + } + limit <- 9L + eng <- sweep(limit) + conv <- vapply(eng, function(e) e$converged, logical(1)) + # Some levels stop within 9 steps and some do not. + expect_true(any(conv) && any(!conv)) + r <- partition_warnings(resolution_profile(pts, levels = lv, nstart = 2, seed = 11, + partition = "density", iter_max = limit)) + w <- partition_of_class(r, "spatialkit_not_converged") + expect_length(w, 1L) + expect_identical(w[[1L]]$level, lv[!conv]) + expect_identical(w[[1L]]$iter, rep(limit, sum(!conv))) + expect_identical(w[[1L]]$iter_max, limit) + expect_match(conditionMessage(w[[1L]]), + sprintf("at %d of the 4 levels (%s cells)", sum(!conv), + paste(lv[!conv], collapse = ", ")), fixed = TRUE) + rec <- attr(r$value, "partition") + expect_identical(rec$converged, stats::setNames(conv, lv)) + expect_identical(rec$iter, stats::setNames(vapply(eng, function(e) e$iter, integer(1)), lv)) + # The centres are the engine's at that limit, cut off or not. + expect_identical(unname(attr(r$value, "centres")), lapply(eng, function(e) e$centers)) + # With room to finish there is nothing to say. + r <- partition_warnings(resolution_profile(pts, levels = lv, nstart = 2, seed = 11, + partition = "density")) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_true(all(attr(r$value, "partition")$converged)) +}) + +test_that("the k-means kind from a starting rule that is not the function's own says it too", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + pts <- partition_points_sf(xy) + # A seeding function from k-means++ starts. + r <- partition_warnings(voronoi_seeds_kmeans(pts, 40, init = "kmeans++", nstart = 2, + iter_max = 1, partition = "kmeans")) + expect_length(r$warnings, 1L) + w <- r$warnings[[1L]] + expect_s3_class(w, "spatialkit_not_converged") + expect_identical(w[c("level", "iter", "iter_max")], list(level = 40L, iter = 1L, iter_max = 1L)) + expect_match(conditionMessage(w), + "had not converged after 1 iteration of k-means (partition = \"kmeans\")", + fixed = TRUE) + expect_identical(attr(r$value, "partition")[c("iter", "iter_max", "converged")], + list(iter = 1L, iter_max = 1L, converged = FALSE)) + r <- partition_warnings(get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, + init = "kmeans++", kmeans_nstart = 2, + kmeans_iter = 1, set_seed = 2, partition = "kmeans")) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 1L) + expect_false(attr(r$value, "kmeans")$converged) + # A profile from random starts. + r <- partition_warnings(resolution_profile(pts, levels = c(10L, 40L), nstart = 2, + init = "random", iter_max = 1, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + w <- partition_of_class(r, "spatialkit_not_converged") + expect_length(w, 1L) + expect_identical(w[[1L]]$level, c(10L, 40L)) + expect_identical(attr(r$value, "partition")$converged, c("10" = FALSE, "40" = FALSE)) + expect_identical(attr(r$value, "partition")$iter_max, 1L) + # Left to their own limits these converge and say nothing. + expect_length(partition_warnings(voronoi_seeds_kmeans(pts, 40, init = "kmeans++", + partition = "kmeans"))$warnings, 0L) + r <- partition_warnings(resolution_profile(pts, levels = c(10L, 40L), nstart = 2, + init = "random", estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_identical(attr(r$value, "partition")$iter_max, 100L) +}) + +test_that("the runs the functions have always made report as they always did", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + pts <- partition_points_sf(xy) + # The seeding functions' k-means run is one stats::kmeans() call, and a limit + # that cuts it off gets that function's warning and no record. + r <- partition_warnings(voronoi_seeds_kmeans(pts, 40, nstart = 2, iter_max = 1, + partition = "kmeans")) + expect_gt(length(r$warnings), 0L) + expect_true(all(vapply(r$warnings, function(w) + grepl("did not converge in 1 iteration", conditionMessage(w), fixed = TRUE), logical(1)))) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_null(attr(r$value, "partition")) + set.seed(456) + km <- suppressWarnings(stats::kmeans(partition_xy(pts), centers = 40, iter.max = 1, nstart = 2L)) + expect_identical(partition_xy(r$value), unname(km$centers)) + r <- partition_warnings(get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, + kmeans_nstart = 2, kmeans_iter = 1, set_seed = 2, + partition = "kmeans")) + expect_gt(length(r$warnings), 0L) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_named(attr(r$value, "kmeans"), + c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart")) + + # The default profile has never reported a k-means start that ran out of + # iterations, and does not now: every start is stood in for by one marked + # as cut off, and nothing is raised or recorded. Naming a limit is asking, + # and is answered. + real <- spatialkit:::.partition_centres + local_mocked_bindings(.partition_centres = function(...) { + fit <- real(...) + fit$converged <- FALSE + fit + }) + r <- partition_warnings(resolution_profile(pts, levels = c(5L, 12L), nstart = 2, + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + expect_length(partition_of_class(r, "spatialkit_not_converged"), 0L) + expect_null(attr(r$value, "partition")) + r <- partition_warnings(resolution_profile(pts, levels = c(5L, 12L), nstart = 2, + iter_max = 50, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + w <- partition_of_class(r, "spatialkit_not_converged") + expect_length(w, 1L) + expect_identical(w[[1L]]$level, c(5L, 12L)) + expect_identical(w[[1L]]$iter_max, 50L) + expect_null(attr(r$value, "partition")) +}) + +test_that("iter_max is NULL or a positive whole number", { + pts <- partition_points_sf(partition_clustered_xy(n_bg = 40L, n_cl = 80L, seed = 28L)) + calls <- list( + resolution_profile = function(...) resolution_profile(pts, n_levels = 3, nstart = 2, ...), + voronoi_seeds_kmeans = function(...) voronoi_seeds_kmeans(pts, 5, ...)) + for (nm in names(calls)) { + f <- calls[[nm]] + for (bad in list(0, -1, 2.5, NA, "a", c(10, 20), Inf)) + expect_error(f(iter_max = bad), + sprintf("%s(): `iter_max` must be NULL or a single positive whole number of iterations", nm), + fixed = TRUE, info = nm) + expect_error(f(iter_max = 0), "and at least 1; got 0", fixed = TRUE, info = nm) + expect_no_error(f(iter_max = 200)) + expect_no_error(f(partition = "density", iter_max = 200)) + } + # The limit is used: a density start held to one step is not the full run. + one <- partition_quietly(voronoi_seeds_kmeans(pts, 8, partition = "density", iter_max = 1)) + full <- voronoi_seeds_kmeans(pts, 8, partition = "density") + expect_gt(max(abs(partition_xy(one) - partition_xy(full))), 1) +}) diff --git a/tests/testthat/test-core-partition-defaults.R b/tests/testthat/test-core-partition-defaults.R new file mode 100644 index 00000000..76c54e7c --- /dev/null +++ b/tests/testthat/test-core-partition-defaults.R @@ -0,0 +1,458 @@ +# tests/testthat/test-core-partition-defaults.R +# --------------------------------------------------------------------------- +# The density kind is each function's own kind, and partition = "kmeans" +# named gives the object a call without the partition arguments gave before +# the switch of defaults. +# +# resolution_profile(), get_voronoi_seeds(method = "kmeans") and +# voronoi_seeds_kmeans() build density-weighted k-means cells from 3 +# k-means++ starts when the call names no kind and no number of starts, and +# record the kind. Naming that kind and its starting rule returns the +# object a call without the arguments returns. Named, the k-means kind is +# the computation these functions made before: the profile the best of +# `nstart` k-means++ starts (25 when no number is named), the seeding +# functions stats::kmeans() from 10 random starts on the rows as they come, +# with nothing added to the object, not even a record of the kind. +# --------------------------------------------------------------------------- + +.pd_pts <- function(n = 240L, seed = 2L) { + xy <- partition_clustered_xy(n_bg = n %/% 3L, n_cl = n - n %/% 3L, clusters = 3L, + side = 2000, origin = c(5e5, 5e6), seed = seed) + cleanup <- spatialkit:::.with_seed(seed + 100L) + on.exit(cleanup(), add = TRUE) + z <- sin(xy[, 1L] / 300) + cos(xy[, 2L] / 400) + stats::rnorm(nrow(xy), sd = 0.5) + partition_points_sf(xy, z = z) +} + +# .kmeans_best() as it stood before the partition engine: the best of +# `nstart` runs of stats::kmeans(), each from k-means++ seeds. +.pd_old_best <- function(xy, k, nstart = 25L, iter.max = 50L) { + best <- NULL + for (r in seq_len(nstart)) { + km <- try(suppressWarnings(stats::kmeans(xy, centers = spatialkit:::.kmeanspp_centers(xy, k), + iter.max = iter.max, nstart = 1L)), + silent = TRUE) + if (inherits(km, "try-error")) next + if (is.null(best) || km$tot.withinss < best$tot.withinss) best <- km + } + best +} + + +test_that("the engine's k-means kind from k-means++ starts is .kmeans_best() bit for bit", { + xy <- partition_sorted(partition_clustered_xy(n_bg = 100L, n_cl = 200L, seed = 5L)) + for (k in c(2L, 9L, 40L)) { + set.seed(31); old <- .pd_old_best(xy, k, nstart = 6L) + set.seed(31); kb <- spatialkit:::.kmeans_best(xy, k, nstart = 6L) + set.seed(31); eng <- spatialkit:::.partition_centres(xy, k, partition = "kmeans", + init = "kmeans++", nstart = 6L) + expect_identical(kb$km, old) + expect_identical(eng$km, old) + expect_identical(eng$centers, unname(old$centers)) + expect_identical(eng$cluster, old$cluster) + expect_identical(eng$wss, old$tot.withinss) + expect_identical(eng$objective, old$tot.withinss) + expect_identical(eng$withinss, as.numeric(old$withinss)) + expect_identical(eng$spread, kb$spread) + } +}) + +test_that("resolution_profile() with its own kind named is the profile without the arguments", { + pts <- .pd_pts() + plain <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5)) + named <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + partition = "density", init = "kmeans++")) + expect_identical(named, plain) + # The density arguments at their defaults change nothing either. + expect_identical(partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + density_power = 1, density_k = 8L)), + plain) + # The record of the kind, and the print that names it. + expect_identical(attr(plain, "partition")[c("kind", "init", "density_power", "density_k")], + list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L)) + expect_identical(capture.output(print(named)), capture.output(print(plain))) + expect_match(capture.output(print(plain)), + "5 density-weighted k-means++ starts (power 1, 8 neighbours) per level", + fixed = TRUE, all = FALSE) + + geo <- resolution_profile(pts, n_levels = 5, nstart = 4) + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, + partition = "density", init = "kmeans++"), geo) + expect_identical(attr(geo, "partition")$kind, "density") + # `iter_max = NULL` is the kind's own limit, 100 Lloyd steps for this one, + # and the record holds it. + expect_identical(attr(geo, "partition")$iter_max, 100L) + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, iter_max = NULL), geo) + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, iter_max = 100), geo) + # The default vector of `init`, passed as it is written, is the default. + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, + init = c("kmeans++", "random")), geo) + # `nstart = NULL` is the kind's own number of starts: 3. + expect_identical(resolution_profile(pts, n_levels = 5), + resolution_profile(pts, n_levels = 5, nstart = 3)) +}) + +test_that("resolution_profile() with partition = \"kmeans\" named is the profile it always was", { + pts <- .pd_pts() + # The old defaults by name: no estimate, the automatic ladder, the + # variogram estimated from the response, and the k-means kind. + plain <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + named <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans", + init = "kmeans++")) + expect_identical(named, plain) + expect_identical(partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans", + density_power = 1, density_k = 8L)), + plain) + # No record of the kind: the profile is the object it always was. + expect_null(attr(plain, "partition")) + expect_identical(capture.output(print(named)), capture.output(print(plain))) + expect_match(capture.output(print(plain)), "5 k-means++ restarts per level", + fixed = TRUE, all = FALSE) + + geo <- resolution_profile(pts, n_levels = 5, nstart = 4, partition = "kmeans") + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, + partition = "kmeans", init = "kmeans++"), geo) + expect_null(attr(geo, "partition")) + # `iter_max = NULL` is the kind's own limit, 50 for this one; neither it + # nor the limit named leaves a record on the k-means kind. + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, partition = "kmeans", + iter_max = NULL), geo) + expect_identical(resolution_profile(pts, n_levels = 5, nstart = 4, partition = "kmeans", + iter_max = 50), geo) + # `nstart = NULL` is the kind's own number of starts: 25, as it always was. + expect_identical(resolution_profile(pts, n_levels = 5, partition = "kmeans"), + resolution_profile(pts, n_levels = 5, partition = "kmeans", nstart = 25L)) +}) + +test_that("the k-means profile's centres are those of the k-means++ run it always made", { + # Geometry only, so nothing draws from the stream before the sweep, and the + # first level's centres are the best of `nstart` k-means++ starts on the + # rows in coordinate order under the profile's seed. + pts <- .pd_pts(n = 150L, seed = 4L) + xs <- partition_sorted(partition_xy(pts)) + prof <- resolution_profile(pts, levels = 7L, nstart = 6, seed = 19, partition = "kmeans") + set.seed(19); old <- .pd_old_best(xs, 7L, nstart = 6L) + expect_identical(attr(prof, "centres")[["7"]], unname(old$centers)) + expect_identical(prof$wss, old$tot.withinss) + # The default profile's centres are the density kind's, from 3 k-means++ + # starts under the same seed: other centres. + dflt <- resolution_profile(pts, levels = 7L, seed = 19) + expect_identical(dflt, resolution_profile(pts, levels = 7L, seed = 19, + partition = "density", nstart = 3)) + expect_false(isTRUE(all.equal(attr(dflt, "centres")[["7"]], unname(old$centers)))) +}) + +test_that("select_resolution() and the scored seeds of a k-means profile carry no record", { + pts <- .pd_pts() + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + sel <- select_resolution(prof, criterion = "cp") + expect_false("partition" %in% names(sel)) + expect_null(attr(sel$seeds, "partition")) + s_plain <- partition_quietly(voronoi_seeds_kmeans(pts, sel)) + s_named <- partition_quietly(voronoi_seeds_kmeans(pts, sel, partition = "kmeans")) + expect_identical(s_named, s_plain) + expect_null(attr(s_plain, "partition")) + g_plain <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + g_named <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts, + partition = "kmeans", init = "kmeans++")) + expect_identical(g_named, g_plain) + expect_null(attr(g_plain, "partition")) + # Naming the kind the profile was built with is not a mismatch, and + # naming no kind is not one either. + expect_no_warning(withCallingHandlers( + get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts, partition = "kmeans"), + spatialkit_bound_chosen = function(w) invokeRestart("muffleWarning"), + spatialkit_no_structure = function(w) invokeRestart("muffleWarning"))) + expect_no_warning(withCallingHandlers( + get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts), + spatialkit_bound_chosen = function(w) invokeRestart("muffleWarning"), + spatialkit_no_structure = function(w) invokeRestart("muffleWarning"))) +}) + +test_that("select_resolution() and the scored seeds of a default profile carry its kind", { + pts <- .pd_pts() + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 5)) + sel <- partition_quietly(select_resolution(prof)) + expect_identical(sel$partition$kind, "density") + expect_identical(attr(sel$seeds, "partition")$kind, "density") + s_plain <- partition_quietly(voronoi_seeds_kmeans(pts, sel)) + s_named <- partition_quietly(voronoi_seeds_kmeans(pts, sel, partition = "density")) + expect_identical(s_named, s_plain) + expect_identical(attr(s_plain, "partition")$kind, "density") + g_plain <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + g_named <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts, + partition = "density", init = "kmeans++")) + expect_identical(g_named, g_plain) + expect_identical(attr(g_plain, "partition")$kind, "density") + # A call that names no partition argument is told nothing about the kind. + w <- partition_warnings(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + expect_length(partition_of_class(w, "spatialkit_partition_unused"), 0L) + w <- partition_warnings(voronoi_seeds_kmeans(pts, sel)) + expect_length(partition_of_class(w, "spatialkit_partition_unused"), 0L) +}) + +test_that("voronoi_seeds_kmeans() with its own kind named is the call without the arguments", { + pts <- .pd_pts() + plain <- voronoi_seeds_kmeans(pts, 11) + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "density"), plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "density", init = "kmeans++"), + plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, init = NULL, density_power = 1, density_k = 8), + plain) + # `nstart = NULL` is the kind's own number of starts: 3. + expect_identical(voronoi_seeds_kmeans(pts, 11, nstart = 3), plain) + expect_identical(attr(plain, "partition")[c("kind", "init", "density_power", "density_k", + "iter_max")], + list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L, iter_max = 100L)) + # `iter_max = NULL` is the kind's own limit, 100 Lloyd steps for this one. + expect_identical(voronoi_seeds_kmeans(pts, 11, iter_max = NULL), plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, iter_max = 100), plain) + # The run: the engine's density kind from 3 k-means++ starts under seed + # 456, on the rows in coordinate order. + set.seed(456) + fit <- spatialkit:::.partition_centres(sf::st_coordinates(pts)[, 1:2], 11L, + partition = "density", init = "kmeans++", + nstart = 3L, iter.max = 100L, density_power = 1, + density_k = 8, sort_rows = TRUE) + expect_identical(partition_xy(plain), unname(fit$centers)) +}) + +test_that("voronoi_seeds_kmeans() with partition = \"kmeans\" named is the run it always made", { + pts <- .pd_pts() + plain <- voronoi_seeds_kmeans(pts, 11, partition = "kmeans") + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "kmeans", init = "random"), plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "kmeans", init = NULL, + density_power = 1, density_k = 8), + plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "kmeans", nstart = 10), plain) + expect_null(attr(plain, "partition")) + # `iter_max = NULL` is the kind's own limit, 50 for this one. + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "kmeans", iter_max = NULL), plain) + expect_identical(voronoi_seeds_kmeans(pts, 11, partition = "kmeans", iter_max = 50), plain) + # The run it has always made: stats::kmeans() from 10 random starts under + # seed 456, on the rows as they come. + set.seed(456) + km <- stats::kmeans(sf::st_coordinates(pts)[, 1:2], centers = 11, iter.max = 50, nstart = 10L) + expect_identical(partition_xy(plain), unname(km$centers)) + # Other seeds and start counts as well. + set.seed(7) + km3 <- stats::kmeans(sf::st_coordinates(pts)[, 1:2], centers = 30, iter.max = 50, nstart = 3L) + expect_identical(partition_xy(voronoi_seeds_kmeans(pts, 30, set_seed = 7, nstart = 3, + partition = "kmeans")), + unname(km3$centers)) +}) + +test_that("for the seeding functions' k-means kind k-means++ starts are a new run, and say so", { + # The kind's own starting rule is random, so `init = "kmeans++"` is not + # that kind's run under another name: it gives other seeds and records the + # rule. + pts <- .pd_pts() + plain <- voronoi_seeds_kmeans(pts, 11, partition = "kmeans") + pp <- voronoi_seeds_kmeans(pts, 11, partition = "kmeans", init = "kmeans++") + expect_false(isTRUE(all.equal(partition_xy(pp), partition_xy(plain)))) + # The best of `nstart` k-means++ starts on the rows in coordinate order. + xs <- partition_sorted(sf::st_coordinates(pts)[, 1:2]) + set.seed(456); old <- .pd_old_best(xs, 11L, nstart = 10L, iter.max = 50) + expect_identical(partition_xy(pp), unname(old$centers)) + # The record: the kind and the rule, and how the kept start ended. + expect_identical(old$ifault, 0L) + expect_identical(attr(pp, "partition"), + list(kind = "kmeans", init = "kmeans++", + density_power = NA_real_, density_k = NA_integer_, + iter = as.integer(old$iter), iter_max = 50L, converged = TRUE)) +}) + +test_that("get_voronoi_seeds() with its own kind named is the call without the arguments", { + pts <- .pd_pts() + plain <- get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3) + expect_identical(get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + partition = "density"), plain) + expect_identical(get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + partition = "density", init = "kmeans++"), plain) + # `kmeans_nstart = NULL` is the kind's own number of starts: 3. + expect_identical(get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + kmeans_nstart = 3), plain) + expect_identical(attr(plain, "partition")$kind, "density") + expect_named(attr(plain, "kmeans"), + c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart", + "objective", "converged")) + expect_identical(attr(plain, "kmeans")$nstart, 3L) + # The run: the engine's density kind from 3 k-means++ starts under seed 3, + # on the rows in coordinate order. + set.seed(3) + fit <- spatialkit:::.partition_centres(sf::st_coordinates(pts)[, 1:2], 9L, + partition = "density", init = "kmeans++", + nstart = 3L, iter.max = 100L, density_power = 1, + density_k = 8, sort_rows = TRUE) + expect_identical(partition_xy(plain), unname(fit$centers)) + + # A cloud drawn inside a boundary, and the other two methods, which read + # no kind: a call that names none raises nothing. + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + expect_identical(get_voronoi_seeds(bnd, method = "kmeans", n = 5, set_seed = 8, + partition = "density"), + get_voronoi_seeds(bnd, method = "kmeans", n = 5, set_seed = 8)) + expect_no_warning(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 8)) + expect_no_warning(get_voronoi_seeds(method = "provided", seeds = pts[1:4, ])) +}) + +test_that("get_voronoi_seeds() with partition = \"kmeans\" named is the run it always made", { + pts <- .pd_pts() + plain <- get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + partition = "kmeans") + expect_identical(get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + partition = "kmeans", init = "random"), plain) + expect_identical(get_voronoi_seeds(method = "kmeans", n = 9, sample_points = pts, set_seed = 3, + partition = "kmeans", kmeans_nstart = 10), plain) + expect_null(attr(plain, "partition")) + expect_named(attr(plain, "kmeans"), + c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart")) + set.seed(3) + km <- stats::kmeans(x = sf::st_coordinates(pts)[, 1:2], centers = 9, iter.max = 100, + nstart = 10) + expect_identical(partition_xy(plain), unname(km$centers)) + expect_identical(attr(plain, "kmeans")$cluster, as.integer(km$cluster)) + expect_identical(attr(plain, "kmeans")$withinss, as.numeric(km$withinss)) + expect_identical(attr(plain, "kmeans")$tot_withinss, as.numeric(km$tot.withinss)) + expect_identical(attr(plain, "kmeans")$iter, as.integer(km$iter)) + + # A cloud drawn inside a boundary is clustered the same way, and the other + # two methods read no kind: naming the k-means kind there is the call + # without it. + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + bk <- get_voronoi_seeds(bnd, method = "kmeans", n = 5, set_seed = 8, partition = "kmeans") + expect_null(attr(bk, "partition")) + expect_named(attr(bk, "kmeans"), + c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart")) + expect_identical(attr(bk, "kmeans")$nstart, 10L) + expect_identical(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 8, + partition = "kmeans"), + get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 8)) + expect_identical(get_voronoi_seeds(method = "provided", seeds = pts[1:4, ], + partition = "kmeans"), + get_voronoi_seeds(method = "provided", seeds = pts[1:4, ])) +}) + +test_that("a tessellation of k-means seeds has the params it always had", { + pts <- .pd_pts() + km <- voronoi_seeds_kmeans(pts, 11, partition = "kmeans") + tess <- build_tessellation(km, method = "voronoi", quiet = TRUE) + expect_named(tess$params, c("clip", "expand", "keep_duplicates", "snapped", "n_outside", + "boundary_source", "cover_outside")) + cvp <- create_voronoi_polygons(km, quiet = TRUE) + expect_false("partition" %in% names(cvp$params)) + # The reader of the record says plain k-means of these seeds. Their + # cells carry nothing that tells them from the Voronoi cells of any other + # points, so of the tessellation it says nothing. + expect_identical(spatialkit:::.partition_record(km), + list(kind = "kmeans", init = NA_character_, + density_power = NA_real_, density_k = NA_integer_)) + expect_identical(spatialkit:::.partition_record(tess), + list(kind = NA_character_, init = NA_character_, + density_power = NA_real_, density_k = NA_integer_)) +}) + +test_that("a tessellation of default seeds carries their kind", { + pts <- .pd_pts() + dn <- voronoi_seeds_kmeans(pts, 11) + tess <- build_tessellation(dn, method = "voronoi", quiet = TRUE) + expect_named(tess$params, c("clip", "expand", "keep_duplicates", "snapped", "n_outside", + "boundary_source", "cover_outside", "partition")) + expect_identical(tess$params$partition, attr(dn, "partition")) + cvp <- create_voronoi_polygons(dn, quiet = TRUE) + expect_identical(cvp$params$partition, attr(dn, "partition")) + dens <- list(kind = "density", init = "kmeans++", density_power = 1, density_k = 8L) + expect_identical(spatialkit:::.partition_record(dn), dens) + expect_identical(spatialkit:::.partition_record(tess), dens) +}) + +test_that("the reader of the record gives no kind to what k-means did not build", { + pts <- .pd_pts() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + none <- list(kind = NA_character_, init = NA_character_, + density_power = NA_real_, density_k = NA_integer_) + rec <- spatialkit:::.partition_record + expect_identical(rec(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 1)), none) + expect_identical(rec(voronoi_seeds_random(bnd, 5, set_seed = 1)), none) + expect_identical(rec(get_voronoi_seeds(method = "provided", seeds = pts[1:4, ])), none) + expect_identical(rec(pts), none) + expect_identical(rec(partition_quietly(build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = 20, quiet = TRUE))), + none) + expect_identical(rec(partition_quietly(build_tessellation(pts, method = "voronoi", + quiet = TRUE))), none) + expect_identical(rec(NULL), none) + expect_identical(rec(list(a = 1)), none) + # What k-means built with no record is plain k-means: seeds, a profile and + # a selection. + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 4, nstart = 2, + estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans")) + expect_identical(rec(prof)$kind, "kmeans") + expect_identical(rec(select_resolution(prof, criterion = "cp"))$kind, "kmeans") + expect_identical(rec(get_voronoi_seeds(method = "kmeans", n = 5, sample_points = pts, + set_seed = 1, partition = "kmeans"))$kind, "kmeans") + # What the defaults build carries its kind. + dflt <- partition_quietly(resolution_profile(pts, "z", n_levels = 4, nstart = 2)) + expect_identical(rec(dflt)$kind, "density") + expect_identical(rec(partition_quietly(select_resolution(dflt)))$kind, "density") + expect_identical(rec(get_voronoi_seeds(method = "kmeans", n = 5, sample_points = pts, + set_seed = 1))$kind, "density") +}) + +test_that("determine_optimal_levels() takes no partition argument and keeps plain k-means", { + expect_false(any(c("partition", "init", "density_power", "density_k") %in% + names(formals(determine_optimal_levels)))) + # Its sweep is the best of 25 k-means++ starts at every k, one after the + # other under its seed, on the rows in coordinate order: the WSS curve it + # reports is that computation. + pts <- .pd_pts(n = 300L, seed = 6L) + out <- partition_quietly(determine_optimal_levels(pts, max_levels = 40L, set_seed = 5, + response_var = "z", + criterion = "morans_i")) + diag <- attr(out, "diagnostics") + expect_false(is.null(diag)) + xy <- partition_xy(pts) + xs <- xy[order(xy[, 1L], xy[, 2L], pts$z), , drop = FALSE] + set.seed(5) + wss <- c(sum(sweep(xs, 2L, colMeans(xs))^2), + vapply(2:length(diag$wss), function(k) .pd_old_best(xs, k)$tot.withinss, numeric(1))) + expect_equal(diag$wss, wss, tolerance = 1e-12) + expect_identical(diag$wss[-1L], wss[-1L]) +}) + +test_that("the argument order of the three functions is unchanged ahead of the new ones", { + new_args <- c("partition", "init", "density_power", "density_k") + # The five partition arguments of resolution_profile(), found by name: they + # stand together in this order, straight after the arguments the function + # had before them, and `estimate` and `obs_per_cell` follow `iter_max`. + prof_args <- names(formals(resolution_profile)) + at <- match(c(new_args, "iter_max"), prof_args) + expect_identical(at, at[1L] + 0:4) + expect_identical(prof_args[at[1L] - 1L], "range_floor") + expect_identical(prof_args[at[5L] + 1:2], c("estimate", "obs_per_cell")) + expect_identical(utils::tail(names(formals(get_voronoi_seeds)), 4L), new_args) + expect_identical(utils::tail(names(formals(voronoi_seeds_kmeans)), 5L), + c(new_args, "iter_max")) + expect_null(formals(resolution_profile)$iter_max) + expect_null(formals(voronoi_seeds_kmeans)$iter_max) + expect_identical(names(formals(voronoi_seeds_kmeans))[1:4], + c("points_sf", "k", "set_seed", "nstart")) + expect_identical(eval(formals(resolution_profile)$init), c("kmeans++", "random")) + # The density kind is first, and so each function's own. + expect_identical(eval(formals(resolution_profile)$partition), c("density", "kmeans")) + expect_identical(eval(formals(get_voronoi_seeds)$partition), c("density", "kmeans")) + expect_identical(eval(formals(voronoi_seeds_kmeans)$partition), c("density", "kmeans")) + expect_null(formals(voronoi_seeds_kmeans)$init) + expect_null(formals(get_voronoi_seeds)$init) +}) diff --git a/tests/testthat/test-core-partition-pipeline.R b/tests/testthat/test-core-partition-pipeline.R new file mode 100644 index 00000000..7641cee9 --- /dev/null +++ b/tests/testthat/test-core-partition-pipeline.R @@ -0,0 +1,645 @@ +# tests/testthat/test-core-partition-pipeline.R +# --------------------------------------------------------------------------- +# The density kind from end to end: resolution_profile() builds its ladder +# with it, select_resolution() picks a level, the seeding functions hand on +# that level's centres, build_tessellation() draws their Voronoi cells, +# assign_features_to_polygons() puts every observation in one of them and +# summarize_by_cell() counts them. The regions that come out are the ones +# the profile scored, and every result says what kind built them. +# Also here: the arguments' validation and the classed warnings for scored +# centres of another kind and for a centre that holds no point. +# --------------------------------------------------------------------------- + +.pl_pts <- function(n_bg = 150L, n_cl = 450L, seed = 21L, crs = 32632, + origin = c(5e5, 5e6), side = 4000) { + xy <- partition_clustered_xy(n_bg = n_bg, n_cl = n_cl, clusters = 4L, side = side, + origin = origin, seed = seed) + cleanup <- spatialkit:::.with_seed(seed + 1L) + on.exit(cleanup(), add = TRUE) + z <- sin(xy[, 1L] / 700) + cos(xy[, 2L] / 900) + stats::rnorm(nrow(xy), sd = 0.8) + partition_points_sf(xy, crs = crs, z = z) +} + +.pl_record <- list(kind = "density", init = "kmeans++", density_power = 1, density_k = 8L) + +# The pipeline after the profile, with the checks every case shares. +.pl_run <- function(pts, prof, n, level) { + seeds <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = n, sample_points = pts)) + expect_identical(nrow(seeds), as.integer(level)) + expect_identical(attr(seeds, "partition"), .pl_record) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + expect_identical(tess$params$partition, .pl_record) + expect_identical(tess$params$boundary_source, "seeds' cover") + expect_identical(nrow(tess$cells), as.integer(level)) + # One cell per seed, and each seed in its own cell. + expect_identical(sort(tess$index), sort(tess$cells$cell_id)) + + assigned <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + # Every observation in exactly one cell. + expect_identical(nrow(assigned), nrow(pts)) + expect_false(anyNA(assigned$cell_id)) + expect_true(all(assigned$cell_id %in% tess$cells$cell_id)) + inside <- lengths(sf::st_intersects(pts, tess$cells)) + expect_true(all(inside >= 1L)) + expect_lte(sum(inside > 1L), 0L) # none on a shared edge here + + summ <- summarize_by_cell(assigned, response_var = "z", id_col = "cell_id", estimate = "mean") + expect_identical(sum(summ$n), nrow(pts)) + expect_identical(nrow(summ), as.integer(level)) + list(seeds = seeds, tess = tess, assigned = assigned, summ = summ) +} + + +test_that("the density kind runs from profile to summary, with the counts the profile reported", { + pts <- .pl_pts() + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 8, nstart = 4, + partition = "density", estimate = NULL, + obs_per_cell = NULL, sac = NULL)) + expect_identical(attr(prof, "partition")[1:4], .pl_record) + expect_named(attr(prof, "partition")$objective, as.character(prof$levels)) + expect_true(all(is.finite(attr(prof, "partition")$objective))) + expect_true(all(diff(attr(prof, "partition")$objective) < 0)) + # Every column a k-means profile has, and every level scored. + expect_true(all(is.finite(prof$wss)) && all(is.finite(prof$cp)) && all(is.finite(prof$rss))) + expect_true(all(diff(prof$wss) < 0)) + expect_output(print(prof), "4 density-weighted k-means++ starts (power 1, 8 neighbours) per level", + fixed = TRUE) + + sel <- select_resolution(prof, criterion = "cp") + expect_identical(sel$partition, .pl_record) + expect_identical(attr(sel$seeds, "partition"), .pl_record) + level <- sel$best + out <- .pl_run(pts, prof, sel, level) + + # The seeds are the profile's centres at that level ... + cen <- attr(prof, "centres")[[as.character(level)]] + expect_equal(partition_xy(out$seeds), cen, tolerance = 1e-12) + # ... so the cells hold the points the profile counted: its smallest and + # median cell, and the whole set of counts of the scored partition. + counts <- as.integer(table(out$assigned$cell_id)) + row <- prof[prof$levels == level, ] + expect_identical(min(counts), row$cell_n_min) + expect_equal(stats::median(counts), row$cell_n_median) + scored <- tabulate(partition_nearest(partition_xy(pts), cen), nbins = level) + expect_identical(sort(counts), sort(scored)) + expect_identical(sort(as.integer(out$summ$n)), sort(scored)) + # Point by point: an observation is in the cell of its nearest centre. + # `index` gives the cell each seed sits in. + nearest <- partition_nearest(partition_xy(pts), partition_xy(out$seeds)) + expect_identical(out$assigned$cell_id, out$tess$index[nearest]) + # And the residual sum of squares the profile scored is the cells'. + rss <- sum(tapply(pts$z, out$assigned$cell_id, function(v) sum((v - mean(v))^2))) + expect_equal(rss, row$rss, tolerance = 1e-10) + # The record of the seeds describes the cells: sizes and sum of squares. + km <- attr(out$seeds, "kmeans") + expect_identical(sort(km$size), sort(scored)) + expect_equal(km$tot_withinss, row$wss, tolerance = 1e-10) +}) + +test_that("every level of a density ladder gives the cells it was scored on", { + pts <- .pl_pts(seed = 22L) + prof <- resolution_profile(pts, levels = c(3L, 12L, 40L), nstart = 3, partition = "density") + xy <- partition_xy(pts) + for (i in seq_len(nrow(prof))) { + L <- prof$levels[i] + seeds <- spatialkit:::.profile_seeds(prof, L) + expect_identical(attr(seeds, "partition"), .pl_record) + s <- voronoi_seeds_kmeans(pts, structure(list(best = L, seeds = seeds, criterion = "cp", + edge = NA_character_, structured = TRUE), + class = "resolution_selection")) + expect_identical(attr(s, "partition"), .pl_record) + tess <- build_tessellation(s, method = "voronoi", quiet = TRUE) + expect_false(anyNA(tess$index)) + counts <- tabulate(match( + assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE)$cell_id, + tess$cells$cell_id), nbins = L) + expect_identical(min(counts), prof$cell_n_min[i]) + expect_equal(stats::median(counts), prof$cell_n_median[i]) + } +}) + +test_that("a profile passed as the count, and lon/lat points, go through the same way", { + pts <- .pl_pts(n_bg = 100L, n_cl = 300L, seed = 23L) + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 6, nstart = 3, + partition = "density", estimate = NULL, + obs_per_cell = NULL, sac = NULL)) + level <- select_resolution(prof, criterion = "cp")$best + out <- .pl_run(pts, prof, prof, level) + expect_match(attr(out$seeds, "n_from"), "resolution_profile() read with", fixed = TRUE) + + # Lon/lat points: the profile works in a projected CRS, the seeds come back + # in degrees, and the cells still hold every observation. + ll <- sf::st_transform(pts, 4326) + prof_ll <- partition_quietly(resolution_profile(ll, "z", n_levels = 6, nstart = 3, + partition = "density", estimate = NULL, + obs_per_cell = NULL, sac = NULL)) + sel_ll <- select_resolution(prof_ll, criterion = "cp") + seeds <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel_ll, sample_points = ll)) + expect_true(sf::st_is_longlat(seeds)) + expect_identical(attr(seeds, "partition"), .pl_record) + tess <- partition_quietly(build_tessellation(seeds, method = "voronoi", quiet = TRUE)) + expect_identical(tess$params$partition, .pl_record) + assigned <- partition_quietly(assign_features_to_polygons( + sf::st_transform(ll, sf::st_crs(tess$cells)), tess$cells, polygon_id_col = "cell_id", + quiet = TRUE)) + expect_identical(nrow(assigned), nrow(ll)) + expect_false(anyNA(assigned$cell_id)) + counts <- as.integer(table(assigned$cell_id)) + row <- prof_ll[prof_ll$levels == sel_ll$best, ] + expect_identical(min(counts), row$cell_n_min) + expect_equal(stats::median(counts), row$cell_n_median) +}) + +test_that("fresh density seeds go through the tessellation with their record", { + pts <- .pl_pts(seed = 24L) + rec_rnd <- list(kind = "density", init = "random", density_power = 0.5, density_k = 5L) + s <- voronoi_seeds_kmeans(pts, 30, partition = "density", init = "random", + density_power = 0.5, density_k = 5, nstart = 10) + # What built the seeds, and how the start that was kept ended: the steps + # it took, the limit, and whether it stopped before the limit. + full <- attr(s, "partition") + expect_named(full, c("kind", "init", "density_power", "density_k", + "iter", "iter_max", "converged")) + expect_identical(full[1:4], rec_rnd) + expect_identical(full$iter_max, 100L) + expect_true(full$converged) + expect_true(is.integer(full$iter) && full$iter >= 1L && full$iter < 100L) + expect_identical(unique(s$method), "kmeans") + expect_identical(s$seed_id, 1:30) + expect_s3_class(attr(s, "cover"), "sfc") + tess <- build_tessellation(s, method = "voronoi", quiet = TRUE) + expect_identical(tess$params$partition, full) + expect_identical(create_voronoi_polygons(s, quiet = TRUE)$params$partition, full) + expect_false(anyNA(tess$index)) + # The record survives a transform and a subset, as the cover does. + expect_identical(attr(sf::st_transform(s, 3857), "partition"), full) + expect_identical(attr(s[1:10, ], "partition"), full) + # A CRS given to the tessellation moves the seeds; the record still arrives. + expect_identical(build_tessellation(s, method = "voronoi", crs = 3857, + quiet = TRUE)$params$partition, full) + # So it does when build_tessellation() projects the seeds itself: seeds in + # lon/lat, and seeds with no CRS whose coordinates are degrees. + ll <- sf::st_transform(pts, 4326) + s_ll <- voronoi_seeds_kmeans(ll, 30, partition = "density", init = "random", + density_power = 0.5, density_k = 5, nstart = 10) + expect_identical(attr(s_ll, "partition")[1:4], rec_rnd) + expect_identical(partition_quietly(build_tessellation(s_ll, method = "voronoi", + quiet = TRUE))$params$partition, + attr(s_ll, "partition")) + s_na <- partition_quietly(voronoi_seeds_kmeans(sf::st_set_crs(ll, NA), 30, + partition = "density", init = "random", + density_power = 0.5, density_k = 5, nstart = 10)) + expect_true(is.na(sf::st_crs(s_na))) + expect_identical(attr(s_na, "partition")[1:4], rec_rnd) + expect_identical(partition_quietly(build_tessellation(s_na, method = "voronoi", + quiet = TRUE))$params$partition, + attr(s_na, "partition")) + # Read by one helper wherever it sits. + expect_identical(spatialkit:::.partition_record(s), rec_rnd) + expect_identical(spatialkit:::.partition_record(tess), rec_rnd) + prof <- resolution_profile(pts, levels = c(5L, 9L), nstart = 2, partition = "density", + estimate = NULL, obs_per_cell = NULL, sac = NULL) + expect_identical(spatialkit:::.partition_record(prof), .pl_record) + + # get_voronoi_seeds(): the record of the run describes the seeds' cells. + g <- get_voronoi_seeds(method = "kmeans", n = 30, sample_points = pts, + partition = "density", set_seed = 4, kmeans_nstart = 10) + km <- attr(g, "kmeans") + expect_named(km, c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart", + "objective", "converged")) + expect_true(km$converged) + expect_identical(attr(g, "partition"), + c(.pl_record, list(iter = km$iter, iter_max = 100L, converged = TRUE))) + xy <- partition_xy(pts) + expect_identical(km$cluster, as.integer(partition_nearest(xy, partition_xy(g)))) + expect_identical(km$size, tabulate(km$cluster, nbins = 30L)) + mu <- rowsum(xy, km$cluster) / km$size + expect_equal(km$tot_withinss, sum((xy - mu[km$cluster, ])^2), tolerance = 1e-10) + expect_gt(km$objective, 0) + expect_identical(km$nstart, 10L) +}) + +test_that("a profile fitted to a subsample still tessellates the whole layer", { + pts <- .pl_pts(n_bg = 400L, n_cl = 1200L, seed = 25L) + prof <- partition_quietly(resolution_profile(pts, "z", n_levels = 5, nstart = 2, + sample_n = 500, partition = "density", + estimate = NULL, obs_per_cell = NULL, + sac = NULL)) + expect_identical(attr(prof, "bounds")$n_sample, 500L) + sel <- select_resolution(prof, criterion = "cp") + seeds <- partition_quietly(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + assigned <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + expect_identical(nrow(assigned), nrow(pts)) + expect_false(anyNA(assigned$cell_id)) + expect_identical(sum(summarize_by_cell(assigned, "z", id_col = "cell_id", + estimate = "mean")$n), nrow(pts)) + expect_identical(tess$params$partition, .pl_record) +}) + + +# ---- The profile's columns under the density kind --------------------------------- + +test_that("reliability does not read the cells, and Cp counts them as it does for k-means", { + pts <- .pl_pts(seed = 26L) + # One variogram for both profiles, written by hand so that it has a range + # and a nugget whatever is installed: only the cells differ. + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.6, 0.5), range = c(0, 300)) + sac <- structure(900, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts), detrended = FALSE) + lv <- c(4L, 10L, 25L, 60L) + p_km <- partition_quietly(resolution_profile(pts, "z", levels = lv, nstart = 3, sac = sac, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans")) + p_den <- partition_quietly(resolution_profile(pts, "z", levels = lv, nstart = 3, sac = sac, + partition = "density", estimate = NULL, + obs_per_cell = NULL)) + expect_true(all(is.finite(p_km$reliability))) + expect_identical(p_den$reliability, p_km$reliability) + expect_identical(attr(p_den, "bounds"), attr(p_km, "bounds")) + expect_identical(attr(p_den, "one_cell")[c("n", "rss", "cp", "constant")], + attr(p_km, "one_cell")[c("n", "rss", "cp", "constant")]) + # Cp is the formula of the k-means kind on the density kind's cells, with + # the variogram's nugget. + cn <- attr(p_den, "cp_noise") + expect_identical(cn$source, "variogram nugget") + expect_identical(cn$value, 0.6) + n <- nrow(pts) + expect_equal(p_den$cp, p_den$rss / n + cn$value * 2 * lv / n, tolerance = 1e-12) + # The test of the cells against one mean is the F test on these cells. + f_p <- attr(p_den, "one_cell")$f_p + tss <- attr(p_den, "one_cell")$rss + expect_equal(unname(f_p), + stats::pf(((tss - p_den$rss) / (lv - 1)) / (p_den$rss / (n - lv)), + lv - 1, n - lv, lower.tail = FALSE), tolerance = 1e-10) + expect_false(isTRUE(all.equal(p_den$rss, p_km$rss))) + # k-means minimises the unweighted sum of squares, so the density kind's is + # no lower at any level, and its weighted sum is not that sum. + expect_true(all(p_den$wss > p_km$wss)) + expect_true(all(attr(p_den, "partition")$objective != p_den$wss)) +}) + +test_that("the elbow is read off the unweighted curve, and uniform points have none", { + cleanup <- spatialkit:::.with_seed(30L) + xy <- cbind(stats::runif(600, 0, 1000), stats::runif(600, 0, 1000)) + cleanup() + u <- partition_points_sf(xy) + p <- resolution_profile(u, n_levels = 8, nstart = 3, partition = "density") + expect_true(all(is.na(p$elbow))) + expect_error(select_resolution(p, "elbow"), "no elbow") + # Clustered points have one, and it is the sag of the profile's own wss. + cl <- .pl_pts(seed = 27L) + pc <- resolution_profile(cl, n_levels = 8, nstart = 3, partition = "density") + expect_true(any(is.finite(pc$elbow))) + xs <- partition_xy(cl) + tss <- sum(sweep(xs, 2L, colMeans(xs))^2) + rd <- spatialkit:::.elbow_read(c(1L, pc$levels), c(tss, pc$wss)) + expect_identical(pc$elbow, rd$sag[-1L]) + sel <- select_resolution(pc, "elbow") + expect_identical(sel$partition, .pl_record) +}) + + +test_that("a level with an empty cell is reported, and Cp counts the occupied cells", { + # A centre of the density kind that loses its points stays where it is. + # The engine is stood in for here, so that the level has an empty centre + # whatever the starts do: its partition into four cells is handed back + # with a fifth centre that holds no point. The last two tests of this + # file reach the same warning with nothing stood in for. + pts <- .pl_pts(n_bg = 60L, n_cl = 120L, seed = 31L) + real <- spatialkit:::.partition_centres + local_mocked_bindings(.partition_centres = function(xy, k, ...) { + fit <- real(xy, k - 1L, ...) + fit$centers <- rbind(fit$centers, c(min(xy[, 1L]) - 1e4, min(xy[, 2L]) - 1e4)) + fit$size <- c(fit$size, 0L) + fit$withinss <- c(fit$withinss, 0) + fit + }) + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.6, 0.5), range = c(0, 300)) + sac <- structure(900, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts), detrended = FALSE) + w <- NULL + prof <- withCallingHandlers( + resolution_profile(pts, "z", levels = 5L, nstart = 2, sac = sac, partition = "density"), + spatialkit_empty_cells = function(c) { w <<- c; invokeRestart("muffleWarning") }, + warning = function(c) invokeRestart("muffleWarning")) + expect_s3_class(w, "spatialkit_empty_cells") + expect_identical(w$level, 5L) + expect_identical(w$empty, 1L) + expect_match(conditionMessage(w), "at 5 cells, 1 of the centres hold no point", fixed = TRUE) + expect_identical(prof$cell_n_min, 0L) + expect_identical(prof$cells_resp, 4L) + # Four cell means, not five, in the variance term. + n <- nrow(pts) + expect_equal(prof$cp, prof$rss / n + 0.6 * (4 / n + 4 / n), tolerance = 1e-12) +}) + + +# ---- Arguments ----------------------------------------------------------------------- + +test_that("the partition arguments are validated like their neighbours", { + pts <- .pl_pts(n_bg = 40L, n_cl = 80L, seed = 28L) + calls <- list( + resolution_profile = function(...) resolution_profile(pts, n_levels = 3, nstart = 2, ...), + voronoi_seeds_kmeans = function(...) voronoi_seeds_kmeans(pts, 5, ...), + get_voronoi_seeds = function(...) get_voronoi_seeds(method = "kmeans", n = 5, + sample_points = pts, set_seed = 1, ...)) + for (nm in names(calls)) { + f <- calls[[nm]] + expect_error(f(partition = "equal"), "should be one of", info = nm) + expect_error(f(init = "furthest"), "should be one of", info = nm) + expect_error(f(partition = "density", density_power = -0.1), + sprintf("%s(): `density_power` must be a single number from 0 to 2 and at least 0", nm), + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_power = 2.5), + "`density_power` must be a single number from 0 to 2 and at most 2", + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_power = "1"), + "`density_power` must be a single number from 0 to 2; got character", + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_power = c(1, 2)), + "`density_power` must be a single number from 0 to 2; got numeric of length 2", + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_power = NA_real_), + "`density_power` must be a single number from 0 to 2", fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_k = 0), + "`density_k` must be a single positive whole number of neighbours and at least 1", + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_k = 2.5), + "`density_k` must be a single positive whole number of neighbours; got 2.5", + fixed = TRUE, info = nm) + expect_error(f(partition = "density", density_k = Inf), + "`density_k` must be a single positive whole number of neighbours", + fixed = TRUE, info = nm) + # The ends of the range are allowed. + expect_no_error(f(partition = "density", density_power = 0, density_k = 1)) + expect_no_error(f(partition = "density", density_power = 2, density_k = 500)) + # Set where they are not read: said, and the result is the k-means + # kind's without them. + expect_warning(a <- f(density_power = 0.5, partition = "kmeans"), + sprintf("%s(): `density_power` is read by partition = \"density\" only", nm), + fixed = TRUE) + expect_identical(a, f(partition = "kmeans")) + expect_warning(f(density_power = 0.5, density_k = 4, partition = "kmeans"), + "`density_power` and `density_k` are read by partition = \"density\" only", + fixed = TRUE) + } + expect_no_error(voronoi_seeds_kmeans(pts, 5, init = NULL)) + # A value of `init` that is not a string names the function and the + # argument, where match.arg() names neither. + for (nm in names(calls)) { + f <- calls[[nm]] + expect_error(f(init = 1), sprintf("%s(): `init` should be one of \"kmeans++\", \"random\"", nm), + fixed = TRUE, info = nm) + expect_error(f(init = 1), "got numeric", fixed = TRUE, info = nm) + expect_error(f(init = "furthest"), "got \"furthest\"", fixed = TRUE, info = nm) + expect_error(f(init = c("random", "kmeans++")), "got character of length 2", fixed = TRUE, + info = nm) + expect_error(f(init = NA_character_), "`init` should be one of", fixed = TRUE, info = nm) + } + expect_error(voronoi_seeds_kmeans(pts, 5, init = 1), "\"random\", or NULL; got numeric", + fixed = TRUE) + # As match.arg() does, a leading part of a name is the name. + expect_identical(voronoi_seeds_kmeans(pts, 5, init = "rand", partition = "kmeans"), + voronoi_seeds_kmeans(pts, 5, partition = "kmeans")) + expect_identical(attr(voronoi_seeds_kmeans(pts, 5, init = "kmeans"), "partition")$init, + "kmeans++") +}) + +test_that("methods that draw no k-means say that the partition arguments are not theirs", { + pts <- .pl_pts(n_bg = 40L, n_cl = 80L, seed = 28L) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + expect_warning(r <- get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2, + partition = "density"), + "`partition` and `init` are read by method = \"kmeans\" only", fixed = TRUE) + expect_identical(r, get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2)) + expect_null(attr(r, "partition")) + expect_warning(get_voronoi_seeds(method = "provided", seeds = pts[1:4, ], init = "kmeans++"), + "method = \"provided\" ignores them", fixed = TRUE) +}) + +test_that("scored centres are returned whatever kind the call names, and the call is told", { + pts <- .pl_pts(n_bg = 100L, n_cl = 300L, seed = 29L) + p_km <- resolution_profile(pts, levels = c(6L, 14L), nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans") + p_den <- resolution_profile(pts, levels = c(6L, 14L), nstart = 2, partition = "density", + estimate = NULL, obs_per_cell = NULL, sac = NULL) + sel_of <- function(p, L) structure( + list(best = L, seeds = spatialkit:::.profile_seeds(p, L), criterion = "cp", + edge = NA_character_, structured = TRUE), class = "resolution_selection") + km14 <- sel_of(p_km, 14L); den14 <- sel_of(p_den, 14L) + + # A k-means selection with the density kind asked for: k-means centres. + w <- tryCatch(voronoi_seeds_kmeans(pts, km14, partition = "density"), warning = identity) + expect_s3_class(w, "spatialkit_partition_unused") + expect_identical(w$kind, "kmeans") + expect_identical(w$init, "kmeans++") + s <- suppressWarnings(voronoi_seeds_kmeans(pts, km14, partition = "density")) + expect_equal(partition_xy(s), attr(p_km, "centres")[["14"]], tolerance = 1e-12) + expect_null(attr(s, "partition")) + # A density selection with k-means named, or another starting rule. + expect_warning(g <- get_voronoi_seeds(method = "kmeans", n = den14, sample_points = pts, + partition = "kmeans"), + class = "spatialkit_partition_unused") + expect_identical(attr(g, "partition"), .pl_record) + expect_equal(partition_xy(g), attr(p_den, "centres")[["14"]], tolerance = 1e-12) + expect_warning(voronoi_seeds_kmeans(pts, den14, init = "random"), + "built with partition = \"density\" from k-means++ starts (power 1, 8 neighbours)", + fixed = TRUE) + # The density kind with another power than the profile's. + expect_warning(voronoi_seeds_kmeans(pts, den14, partition = "density", density_power = 0.5), + class = "spatialkit_partition_unused") + expect_warning(voronoi_seeds_kmeans(pts, den14, partition = "density", density_k = 4), + class = "spatialkit_partition_unused") + # Unnamed, or named as built: nothing to say. + expect_no_warning(voronoi_seeds_kmeans(pts, den14)) + expect_no_warning(voronoi_seeds_kmeans(pts, den14, partition = "density", init = "kmeans++")) + expect_no_warning(get_voronoi_seeds(method = "kmeans", n = km14, sample_points = pts)) + # A count as a number is a fresh run of the kind asked for. + fresh <- voronoi_seeds_kmeans(pts, 14, partition = "density", nstart = 10) + expect_false(isTRUE(all.equal(partition_xy(fresh), attr(p_km, "centres")[["14"]]))) +}) + +test_that("the partition labels read as the print method prints them", { + lab <- spatialkit:::.partition_label + expect_identical(lab(list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L), 25L), + "25 density-weighted k-means++ starts (power 1, 8 neighbours)") + expect_identical(lab(list(kind = "kmeans", init = "random"), 5L), "5 random starts") + expect_identical(lab(list(kind = "kmeans", init = "random"), 1L), "1 random start") + expect_identical(lab(list(kind = "density", init = "random", density_power = 0.5, + density_k = 3L)), + "density-weighted random starts (power 0.5, 3 neighbours)") + expect_identical(lab(list(kind = "density", init = "kmeans++", density_power = 2, + density_k = 1L), 3L), + "3 density-weighted k-means++ starts (power 2, 1 neighbour)") + pts <- .pl_pts(n_bg = 40L, n_cl = 80L, seed = 28L) + expect_output(print(resolution_profile(pts, n_levels = 3, nstart = 2, init = "random", + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")), + "geometry only; 2 random starts per level", fixed = TRUE) + # A selection names the kind of its cells when the profile recorded one, + # and prints as it always did when it did not. + den <- partition_quietly(resolution_profile(pts, "z", n_levels = 4, nstart = 2, + partition = "density", estimate = NULL, + obs_per_cell = NULL, sac = NULL)) + expect_output(print(select_resolution(den, criterion = "cp")), + " cells : density-weighted k-means++ starts (power 1, 8 neighbours)", + fixed = TRUE) + km <- partition_quietly(resolution_profile(pts, "z", n_levels = 4, nstart = 2, + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + expect_false(any(grepl("cells :", + capture.output(print(select_resolution(km, criterion = "cp"))), + fixed = TRUE))) +}) + +test_that("a seeding function says when a density seed holds no point", { + pts <- .pl_pts(n_bg = 60L, n_cl = 120L, seed = 31L) + real <- spatialkit:::.partition_centres + local_mocked_bindings(.partition_centres = function(xy, k, ...) { + fit <- real(xy, k - 1L, ...) + fit$centers <- rbind(fit$centers, c(min(xy[, 1L]) - 1e4, min(xy[, 2L]) - 1e4)) + fit$size <- c(fit$size, 0L) + fit$withinss <- c(fit$withinss, 0) + fit + }) + w <- tryCatch(voronoi_seeds_kmeans(pts, 6, partition = "density"), warning = identity) + expect_s3_class(w, "spatialkit_empty_cells") + expect_identical(w$empty, 1L) + expect_match(conditionMessage(w), "1 of the 6 seeds hold no point", fixed = TRUE) + expect_warning(g <- get_voronoi_seeds(method = "kmeans", n = 6, sample_points = pts, + partition = "density", set_seed = 1), + class = "spatialkit_empty_cells") + expect_identical(nrow(g), 6L) + expect_identical(attr(g, "kmeans")$size[6L], 0L) +}) + + +# ---- A centre with no point, with nothing stood in for ----------------------------- + +# At counts from about a fifth of the points up a start of the density kind, +# a random one most often, can end with a centre that holds no point (see +# "Conditions" in the help of resolution_profile()). 800 points with 28 +# dense places and 400 centres from single random starts: measured under +# seeds 1 to 30, two runs with one such centre (seeds 7 and 23). The seeds +# are searched for and not written down, so that the tests do not hang on +# one platform's arithmetic. +.pl_empty_layer <- function() { + xy <- partition_towns_xy(n = 800L, seed = 5L) + cleanup <- spatialkit:::.with_seed(6L) + on.exit(cleanup(), add = TRUE) + list(xy = xy, pts = partition_points_sf(xy, z = stats::rnorm(nrow(xy)))) +} + +test_that("a real density run that leaves a centre empty is reported and still tessellates", { + lay <- .pl_empty_layer() + xy <- lay$xy; pts <- lay$pts + k <- 400L + runs <- lapply(1:30, function(s) partition_warnings( + voronoi_seeds_kmeans(pts, k, partition = "density", init = "random", nstart = 1, set_seed = s))) + hit <- which(vapply(runs, function(r) + length(partition_of_class(r, "spatialkit_empty_cells")) > 0L, logical(1))) + expect_gt(length(hit), 0L) + skip_if(length(hit) == 0L, "no start of the 30 left a centre empty here") + s <- hit[1L] + r <- runs[[s]] + # Nothing else is raised, and the warning counts the seeds that are no + # point's nearest. + expect_length(r$warnings, 1L) + w <- r$warnings[[1L]] + seeds <- r$value + expect_identical(nrow(seeds), k) + expect_true(all(is.finite(partition_xy(seeds)))) + sizes <- tabulate(partition_nearest(xy, partition_xy(seeds)), nbins = k) + expect_gte(w$empty, 1L) + expect_identical(w$empty, sum(sizes == 0L)) + expect_identical(w$level, k) + expect_match(conditionMessage(w), + sprintf("voronoi_seeds_kmeans(): %d of the 400 seeds hold no point", w$empty), + fixed = TRUE) + expect_match(conditionMessage(w), + sprintf("so %d of their Voronoi cells will hold a point", k - w$empty), + fixed = TRUE) + # It is the engine's partition under that seed, empty centre and all. + set.seed(s) + eng <- spatialkit:::.partition_centres(xy, k, partition = "density", init = "random", + nstart = 1L, iter.max = 100L) + expect_identical(partition_xy(seeds), eng$centers) + expect_identical(eng$size, sizes) + expect_true(eng$converged) + + # The tessellation has a cell for every seed. Every observation is in + # exactly one, and the cells that hold one are the occupied centres'. + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + expect_identical(nrow(tess$cells), k) + expect_identical(tess$params$partition, attr(seeds, "partition")) + assigned <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + expect_identical(nrow(assigned), nrow(pts)) + expect_false(anyNA(assigned$cell_id)) + expect_true(all(lengths(sf::st_intersects(pts, tess$cells)) == 1L)) + expect_identical(length(unique(assigned$cell_id)), k - w$empty) + expect_identical(sort(as.integer(table(assigned$cell_id))), sort(sizes[sizes > 0L])) + summ <- summarize_by_cell(assigned, response_var = "z", id_col = "cell_id", estimate = "mean") + expect_identical(sum(summ$n), nrow(pts)) + expect_identical(nrow(summ), k - w$empty) + + # get_voronoi_seeds() under the same seed: the same seeds, the same + # warning, and a size of 0 in the record of the run. + rg <- partition_warnings(get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", init = "random", + kmeans_nstart = 1, set_seed = s)) + expect_length(rg$warnings, 1L) + expect_s3_class(rg$warnings[[1L]], "spatialkit_empty_cells") + expect_identical(rg$warnings[[1L]]$empty, w$empty) + expect_identical(partition_xy(rg$value), partition_xy(seeds)) + expect_identical(attr(rg$value, "kmeans")$size, sizes) +}) + +test_that("a real profile level with an empty centre is reported, and its seeds carry it", { + lay <- .pl_empty_layer() + xy <- lay$xy; pts <- lay$pts + # Measured under seeds 1 to 12: one empty centre at 400 cells under seeds + # 2 and 10. + runs <- lapply(1:12, function(s) partition_warnings( + resolution_profile(pts, levels = c(200L, 400L), nstart = 1, seed = s, min_cell_n = 1, + partition = "density", init = "random"))) + hit <- which(vapply(runs, function(r) + length(partition_of_class(r, "spatialkit_empty_cells")) > 0L, logical(1))) + expect_gt(length(hit), 0L) + skip_if(length(hit) == 0L, "no profile of the 12 had a level with an empty centre here") + r <- runs[[hit[1L]]] + prof <- r$value + for (w in partition_of_class(r, "spatialkit_empty_cells")) { + row <- prof[prof$levels == w$level, ] + cen <- attr(prof, "centres")[[as.character(w$level)]] + expect_identical(nrow(cen), w$level) + sizes <- tabulate(partition_nearest(xy, cen), nbins = w$level) + expect_gte(w$empty, 1L) + expect_identical(w$empty, sum(sizes == 0L)) + expect_identical(row$cell_n_min, 0L) + expect_match(conditionMessage(w), + sprintf("resolution_profile(): at %d cells, %d of the centres hold no point", + w$level, w$empty), fixed = TRUE) + # The level's seeds are all its centres; their cells hold every point, + # in as many cells as the level has occupied ones. + seeds <- voronoi_seeds_kmeans(pts, structure( + list(best = w$level, seeds = spatialkit:::.profile_seeds(prof, w$level), criterion = "cp", + edge = NA_character_, structured = TRUE), class = "resolution_selection")) + expect_identical(nrow(seeds), w$level) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + assigned <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + expect_false(anyNA(assigned$cell_id)) + expect_identical(length(unique(assigned$cell_id)), w$level - w$empty) + } + # A level with no empty centre has no such warning and a smallest cell of + # at least one point. + quiet_levels <- setdiff(prof$levels, vapply(partition_of_class(r, "spatialkit_empty_cells"), + function(w) w$level, integer(1))) + expect_true(all(prof$cell_n_min[prof$levels %in% quiet_levels] >= 1L)) +}) diff --git a/tests/testthat/test-core-partition-properties.R b/tests/testthat/test-core-partition-properties.R new file mode 100644 index 00000000..ca42e95c --- /dev/null +++ b/tests/testthat/test-core-partition-properties.R @@ -0,0 +1,634 @@ +# tests/testthat/test-core-partition-properties.R +# --------------------------------------------------------------------------- +# What the density kind promises: cells of about equal counts on clustered +# points once the cells outnumber the clusters (and counts like plain +# k-means' below that), and a result that depends on the points alone, not +# on the order of their rows, the unit of their coordinates, repeated +# locations, the count asked for, the caller's random-number stream or +# whether FNN is installed. +# --------------------------------------------------------------------------- + +.pp_engine <- function(xy, k, ..., seed = 1L) { + set.seed(seed) + spatialkit:::.partition_centres(xy, k, partition = "density", ...) +} + +.pp_ok <- function(fit, xy, k) { + # The shape every engine result has. + expect_identical(dim(fit$centers), c(as.integer(k), 2L)) + expect_true(all(is.finite(fit$centers))) + expect_length(fit$cluster, nrow(xy)) + expect_true(all(fit$cluster >= 1L & fit$cluster <= k)) + expect_identical(sum(fit$size), nrow(xy)) + expect_identical(fit$size, tabulate(fit$cluster, nbins = k)) + expect_true(all(is.finite(fit$withinss)) && all(fit$withinss >= 0)) + expect_true(is.finite(fit$objective) && fit$objective >= 0) + expect_true(all(is.finite(fit$weights)) && all(fit$weights > 0)) + invisible(fit) +} + + +# ---- Counts ------------------------------------------------------------------ + +test_that("on a clustered layout the density kind's counts are close to equal, k-means' are not", { + # The measure is the coefficient of variation of the cell counts (sd over + # mean; 0 when every cell holds the same number) and the fullest cell's + # count over the emptiest's. 1,200 points, 900 of them in four clusters + # over a sparse background. Simulated over 20 such layers, 5 starts, + # medians (and ranges) of the coefficient of variation: + # cells k-means density + # 20 1.36 (1.09-1.53) 0.31 (0.18-0.43) + # 60 1.20 (1.04-1.40) 0.28 (0.24-0.34) + # 130 1.18 (1.10-1.36) 0.34 (0.30-0.37) + # and of fullest over emptiest, 24, 40 and 50 against 3.3, 4.3 and 6.8. + for (seed in c(41L, 52L)) { + xy <- partition_clustered_xy(seed = seed) + for (k in c(20L, 60L, 130L)) { + set.seed(1) + km <- spatialkit:::.partition_centres(partition_sorted(xy), k, partition = "kmeans", + init = "kmeans++", nstart = 5L) + den <- .pp_engine(xy, k, nstart = 5L, iter.max = 100L) + cv_km <- partition_count_cv(km$size); cv_den <- partition_count_cv(den$size) + expect_gt(cv_km, 0.9) + expect_lt(cv_den, 0.5) + expect_lt(cv_den, cv_km / 2.5) + expect_gt(max(km$size) / min(km$size), 3 * max(den$size) / min(den$size)) + expect_gt(min(den$size), 0L) + } + } +}) + +test_that("the counts even out only once the cells outnumber the dense places", { + # 2,000 points with 28 dense places: half of the points in 3 large + # clusters, 30 percent in 25 small tight ones, the rest spread out. + # Simulated over 20 such layers, 5 starts, medians (and ranges) of the + # coefficient of variation of the cell counts, and of the density kind's + # over k-means': + # cells k-means density density over k-means + # 5 0.63 (0.41-0.93) 0.71 (0.40-0.92) 1.01 (0.69-1.37) + # 10 0.90 (0.79-1.38) 0.97 (0.80-1.24) 1.00 (0.88-1.49) + # 20 1.08 (0.85-1.32) 1.01 (0.87-1.47) 0.98 (0.78-1.32) + # 60 0.95 (0.86-1.27) 0.31 (0.24-0.35) 0.31 (0.21-0.37) + # 130 1.05 (0.92-1.12) 0.43 (0.37-0.45) 0.41 (0.36-0.47) + # With fewer cells than dense places a cell takes in whole clusters, large + # and small, under either kind, and the density kind's counts are as + # uneven as k-means'. On the four-cluster layout of the test above every + # count tried is above the number of clusters. + for (seed in c(1L, 2L)) { + xy <- partition_towns_xy(seed = seed) + cv_at <- function(k) { + set.seed(1) + km <- spatialkit:::.partition_centres(partition_sorted(xy), k, partition = "kmeans", + init = "kmeans++", nstart = 5L) + den <- .pp_engine(xy, k, nstart = 5L, iter.max = 100L) + c(km = partition_count_cv(km$size), den = partition_count_cv(den$size)) + } + # Measured on these two layers: 1.12 and 1.05 at 10 cells, 0.87 and 1.17 + # at 20, between 0.89 and 1.31 of k-means'. + for (k in c(10L, 20L)) { + v <- cv_at(k) + expect_gt(v[["den"]], 0.7) + expect_gt(v[["den"]], 0.75 * v[["km"]]) + } + # And 0.25 and 0.31 at 60 cells, 0.45 and 0.41 at 130, under half of + # k-means' 0.88 to 0.97. + for (k in c(60L, 130L)) { + v <- cv_at(k) + expect_gt(v[["km"]], 0.7) + expect_lt(v[["den"]], 0.55) + expect_lt(v[["den"]], 0.6 * v[["km"]]) + } + } +}) + +test_that("the public functions show both ends on that layout", { + xy <- partition_towns_xy(seed = 1L) + pts <- partition_points_sf(xy) + count_cv <- function(seeds) partition_count_cv( + tabulate(partition_nearest(xy, partition_xy(seeds)), nbins = nrow(seeds))) + # Measured: 0.82 at 10 cells under the density kind, as under k-means from + # either start; 0.31 at 60 cells, against 0.88 for k-means from k-means++ + # starts. + expect_gt(count_cv(voronoi_seeds_kmeans(pts, 10, partition = "density", nstart = 10)), 0.7) + expect_gt(count_cv(voronoi_seeds_kmeans(pts, 10, init = "kmeans++", partition = "kmeans")), 0.7) + expect_lt(count_cv(voronoi_seeds_kmeans(pts, 60, partition = "density", nstart = 10)), 0.5) + expect_gt(count_cv(voronoi_seeds_kmeans(pts, 60, init = "kmeans++", partition = "kmeans")), 0.7) + # In a profile the median cell over the mean cell (1 for equal counts) was + # 0.42 and 0.42 at 10 and 20 cells under the density kind, where k-means + # gave 0.51 and 0.42, and 0.81 and 0.72 at 60 and 130 cells. + lv <- c(10L, 20L, 60L, 130L) + p_den <- resolution_profile(pts, levels = lv, nstart = 4, partition = "density", + estimate = NULL, obs_per_cell = NULL, sac = NULL) + share <- p_den$cell_n_median / (nrow(pts) / lv) + expect_true(all(share[1:2] < 0.55)) + expect_true(all(share[3:4] > 0.65)) +}) + +test_that("the public functions give those counts", { + xy <- partition_clustered_xy(seed = 41L) + pts <- partition_points_sf(xy) + k <- 60L + count_cv <- function(seeds) partition_count_cv( + tabulate(partition_nearest(xy, partition_xy(seeds)), nbins = nrow(seeds))) + # Measured on this layer: 0.74 for the k-means kind's own random starts, 1.12 + # for k-means++ starts (the lower sum of squares, and the less even + # counts), 0.32 for the density kind and 0.34 for it from random starts. + cv_default <- count_cv(voronoi_seeds_kmeans(pts, k, partition = "kmeans")) + cv_pp <- count_cv(voronoi_seeds_kmeans(pts, k, init = "kmeans++", partition = "kmeans")) + cv_den <- count_cv(voronoi_seeds_kmeans(pts, k, partition = "density", nstart = 10)) + cv_den_rnd <- count_cv(voronoi_seeds_kmeans(pts, k, partition = "density", init = "random", + nstart = 10)) + expect_gt(cv_default, 0.6) + expect_gt(cv_pp, 0.9) + expect_lt(cv_den, 0.5) + expect_lt(cv_den_rnd, 0.5) + expect_lt(cv_den, cv_default / 2) + expect_lt(count_cv(get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", set_seed = 2, + kmeans_nstart = 10)), 0.5) + # In a profile. With equal counts the median cell holds the mean count, + # n / L; under k-means a few large cells of sparse ground hold most of the + # points and the median cell holds far fewer. Measured: 0.91 and 0.95 of + # the mean under the density kind at 20 and 60 cells, 0.34 and 0.40 under + # k-means; smallest cells of 35 and 8 points against 10 and 2. + lv <- c(20L, 60L) + p_km <- resolution_profile(pts, levels = lv, nstart = 4, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans") + p_den <- resolution_profile(pts, levels = lv, nstart = 4, partition = "density", + estimate = NULL, obs_per_cell = NULL, sac = NULL) + expect_true(all(p_den$cell_n_median / (nrow(pts) / lv) > 0.8)) + expect_true(all(p_km$cell_n_median / (nrow(pts) / lv) < 0.5)) + expect_true(all(p_den$cell_n_min >= 2L * p_km$cell_n_min)) +}) + +test_that("density_power runs from plain k-means' counts at 0 to equal counts at 1", { + xy <- partition_clustered_xy(seed = 41L) + cv_at <- function(p) partition_count_cv(.pp_engine(xy, 60L, nstart = 4L, iter.max = 100L, + density_power = p)$size) + cv <- vapply(c(0, 0.5, 1), cv_at, numeric(1)) + expect_gt(cv[1L], 0.9) # every weight is one + expect_lt(cv[2L], cv[1L]) + expect_lt(cv[3L], cv[2L]) + # Power 0 is plain k-means by Lloyd's iteration: the weights are all one + # and the weighted sum is the within-cell sum of squares about the centres, + # which are then the cell means. + f0 <- .pp_engine(xy, 25L, nstart = 3L, iter.max = 200L, density_power = 0) + expect_identical(f0$weights, rep(1, nrow(xy))) + expect_true(f0$converged) + expect_equal(f0$objective, f0$wss, tolerance = 1e-10) + expect_equal(f0$centers, rowsum(xy, f0$cluster) / f0$size, tolerance = 1e-10, + ignore_attr = TRUE) +}) + +test_that("withinss is the unweighted sum of squares of each cell about its own mean", { + xy <- partition_clustered_xy(seed = 41L) + fit <- .pp_ok(.pp_engine(xy, 18L, nstart = 3L), xy, 18L) + mu <- rowsum(xy, fit$cluster) / fit$size + ss <- as.numeric(rowsum(rowSums((xy - mu[fit$cluster, ])^2), fit$cluster)) + expect_equal(fit$withinss, ss, tolerance = 1e-10) + expect_equal(fit$wss, sum(ss), tolerance = 1e-10) + # Between and within add up to the total, as for any partition into cells. + tss <- sum(sweep(xy, 2L, colMeans(xy))^2) + bss <- sum(fit$size * rowSums(sweep(mu, 2L, colMeans(xy))^2)) + expect_equal(fit$wss + bss, tss, tolerance = 1e-10) + # The centres are weighted means, so they are not the cell means, and the + # cells are those of the centres: every point is with its nearest one. + expect_gt(max(abs(fit$centers - mu)), 1e-3) + expect_identical(fit$cluster, as.integer(partition_nearest(xy, fit$centers))) + wm <- rowsum(xy * fit$weights, fit$cluster) / as.numeric(rowsum(fit$weights, fit$cluster)) + expect_true(fit$converged) + expect_equal(fit$centers, wm, tolerance = 1e-9, ignore_attr = TRUE) +}) + + +# ---- Row order ---------------------------------------------------------------- + +test_that("the density kind does not depend on the order of the rows", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + set.seed(99); perm <- sample.int(nrow(xy)) + for (init in c("kmeans++", "random")) for (k in c(1L, 6L, 40L)) { + a <- .pp_engine(xy, k, nstart = 3L, init = init) + b <- .pp_engine(xy[perm, ], k, nstart = 3L, init = init) + expect_identical(b$centers, a$centers) + expect_identical(b$cluster, a$cluster[perm]) + expect_identical(b$weights, a$weights[perm]) + expect_identical(b[c("size", "withinss", "wss", "objective", "spread", "iter")], + a[c("size", "withinss", "wss", "objective", "spread", "iter")]) + } + # Through the public functions. + pts <- partition_points_sf(xy) + s1 <- voronoi_seeds_kmeans(pts, 25, partition = "density") + s2 <- voronoi_seeds_kmeans(pts[perm, ], 25, partition = "density") + expect_identical(partition_xy(s2), partition_xy(s1)) + g1 <- get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, + partition = "density", set_seed = 3) + g2 <- get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts[perm, ], + partition = "density", set_seed = 3) + expect_identical(partition_xy(g2), partition_xy(g1)) + expect_identical(attr(g2, "kmeans")$cluster, attr(g1, "kmeans")$cluster[perm]) + p1 <- resolution_profile(pts, n_levels = 5, nstart = 3, partition = "density") + p2 <- resolution_profile(pts[perm, ], n_levels = 5, nstart = 3, partition = "density") + expect_identical(as.data.frame(p2), as.data.frame(p1)) + expect_identical(attr(p2, "centres"), attr(p1, "centres")) + # k-means++ starts in a seeding function are order-free as well; the + # function's own random starts cluster the rows as they come. + expect_identical(partition_xy(voronoi_seeds_kmeans(pts[perm, ], 25, init = "kmeans++")), + partition_xy(voronoi_seeds_kmeans(pts, 25, init = "kmeans++"))) +}) + + +# ---- Units ---------------------------------------------------------------------- + +test_that("the density kind does not depend on the unit of the coordinates", { + xy <- partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L) + for (k in c(5L, 30L)) { + m <- .pp_engine(xy, k, nstart = 3L) + for (f in c(1e-3, 3937 / 1200, 1e6)) { # kilometres, US survey feet, micrometres + u <- .pp_engine(xy * f, k, nstart = 3L) + expect_identical(u$cluster, m$cluster) + expect_identical(u$iter, m$iter) + expect_lt(max(abs(u$centers / f - m$centers)), 1e-9 * 1000) + expect_equal(u$weights, m$weights, tolerance = 1e-9) + expect_equal(u$wss / f^2, m$wss, tolerance = 1e-9) + expect_equal(u$objective / f^2, m$objective, tolerance = 1e-9) + expect_equal(u$spread, m$spread, tolerance = 1e-9) + } + # A shift of origin moves the centres with the points. + s <- .pp_engine(sweep(xy, 2L, c(5e5, 5e6), "+"), k, nstart = 3L) + expect_identical(s$cluster, m$cluster) + expect_lt(max(abs(sweep(s$centers, 2L, c(5e5, 5e6)) - m$centers)), 1e-6) + } +}) + +test_that("seeds are the same places whether the layer is in metres or in feet", { + # One projection in two units: NAD83 / North Carolina in metres (EPSG:32119) + # and in US survey feet (EPSG:2264). + xy <- partition_clustered_xy(n_bg = 120L, n_cl = 280L, side = 20000, + origin = c(6e5, 2e5), seed = 9L) + m <- partition_points_sf(xy, crs = 32119) + ft <- tryCatch(sf::st_transform(m, 2264), error = function(e) NULL) + skip_if(is.null(ft), "EPSG:2264 is not available in this PROJ installation") + ratio <- stats::median(sf::st_coordinates(ft)[, 1L] / sf::st_coordinates(m)[, 1L]) + skip_if_not(isTRUE(all.equal(ratio, 3937 / 1200, tolerance = 1e-6)), + "the two CRSs do not differ by the unit alone here") + s_m <- voronoi_seeds_kmeans(m, 20, partition = "density") + s_ft <- voronoi_seeds_kmeans(ft, 20, partition = "density") + back <- partition_xy(sf::st_transform(s_ft, 32119)) + expect_lt(max(abs(back - partition_xy(s_m))), 1e-4) # a tenth of a millimetre +}) + + +# ---- Repeated locations ---------------------------------------------------------- + +test_that("repeated locations are counted, share a cell and never give a zero distance", { + # Five stations visited thirty times each, and 200 single visits. + cleanup <- spatialkit:::.with_seed(8L) + st <- cbind(stats::runif(5, 100, 900), stats::runif(5, 100, 900)) + sc <- cbind(stats::runif(200, 0, 1000), stats::runif(200, 0, 1000)) + cleanup() + xy <- rbind(st[rep(1:5, each = 30L), ], sc) + station <- c(rep(1:5, each = 30L), rep(NA_integer_, 200L)) + for (k in c(1L, 5L, 12L, 30L, 205L)) { + fit <- .pp_ok(.pp_engine(xy, k, nstart = 3L), xy, k) + # The thirty visits to a station are in one cell. + per_station <- tapply(fit$cluster[1:150], station[1:150], function(v) length(unique(v))) + expect_true(all(per_station == 1L)) + # And carry one weight, which is finite and of ordinary size: a station + # is thirty points in a disc that reaches its eighth other location, not + # a point with eight neighbours at distance zero. + w_station <- tapply(fit$weights[1:150], station[1:150], function(v) length(unique(v))) + expect_true(all(w_station == 1L)) + expect_lt(max(fit$weights) / min(fit$weights), 1e4) + } + # One centre per distinct location is the most there can be. + expect_identical(nrow(unique(xy)), 205L) + full <- .pp_engine(xy, 205L, nstart = 2L) + expect_identical(sort(full$size, decreasing = TRUE)[1:6], c(30L, 30L, 30L, 30L, 30L, 1L)) + expect_equal(full$wss, 0, tolerance = 1e-12) + expect_null(.pp_engine(xy, 206L, nstart = 2L)) + # The rows in another order give the same cells. + set.seed(5); perm <- sample.int(nrow(xy)) + expect_identical(.pp_engine(xy[perm, ], 12L, nstart = 3L)$centers, + .pp_engine(xy, 12L, nstart = 3L)$centers) +}) + +test_that("layers that are all repeats, one location or a line are handled", { + st <- cbind(c(0, 10, 10, 0, 5), c(0, 0, 10, 10, 5)) + xy <- st[rep(1:5, times = c(30L, 30L, 30L, 30L, 30L)), ] + for (k in 1:5) { + fit <- .pp_ok(.pp_engine(xy, k, nstart = 3L), xy, k) + expect_true(all(fit$size %% 30L == 0L)) + } + expect_identical(sort(.pp_engine(xy, 5L)$size), rep(30L, 5L)) + expect_null(.pp_engine(xy, 6L)) + # Every point at one location: one centre, there. + one <- matrix(c(3, 4), 20L, 2L, byrow = TRUE) + f1 <- .pp_ok(.pp_engine(one, 1L), one, 1L) + expect_identical(f1$centers, matrix(c(3, 4), 1L)) + expect_identical(f1$wss, 0) + expect_null(.pp_engine(one, 2L)) + # Points on a line, and two points. + line <- cbind(seq(0, 100, length.out = 40L), 7) + fl <- .pp_ok(.pp_engine(line, 6L, nstart = 3L), line, 6L) + expect_equal(fl$centers[, 2L], rep(7, 6L), tolerance = 1e-12) + two <- rbind(c(0, 0), c(1, 1)) + expect_identical(.pp_ok(.pp_engine(two, 2L), two, 2L)$size, c(1L, 1L)) + expect_equal(.pp_engine(two, 1L)$centers, matrix(c(0.5, 0.5), 1L), tolerance = 1e-12) + # A non-finite coordinate is an error, not a non-finite centre. + expect_error(.pp_engine(rbind(two, c(NA, 1)), 1L), "non-finite coordinates") +}) + + +# ---- The count asked for --------------------------------------------------------- + +test_that("k = 1, k = n - 1 and k = n give that many centres, and k above n none", { + xy <- partition_clustered_xy(n_bg = 30L, n_cl = 50L, seed = 12L) + n <- nrow(xy) + for (init in c("kmeans++", "random")) { + f1 <- .pp_ok(.pp_engine(xy, 1L, init = init), xy, 1L) + # One centre: the weighted mean of the points. + expect_equal(as.numeric(f1$centers), colSums(xy * f1$weights) / sum(f1$weights), + tolerance = 1e-12) + expect_identical(f1$size, n) + fn1 <- .pp_ok(.pp_engine(xy, n - 1L, init = init, iter.max = 100L), xy, n - 1L) + expect_identical(sort(fn1$size), c(rep(1L, n - 2L), 2L)) + fn <- .pp_ok(.pp_engine(xy, n, init = init), xy, n) + expect_identical(fn$size, rep(1L, n)) + expect_equal(fn$wss, 0, tolerance = 1e-12) + expect_equal(fn$objective, 0, tolerance = 1e-12) + expect_null(.pp_engine(xy, n + 1L, init = init)) + expect_null(.pp_engine(xy, 0L, init = init)) + } +}) + +test_that("the public functions clamp a count at or above the number of points", { + xy <- partition_clustered_xy(n_bg = 30L, n_cl = 50L, seed = 12L) + pts <- partition_points_sf(xy) + n <- nrow(pts) + expect_identical(nrow(voronoi_seeds_kmeans(pts, 1, partition = "density")), 1L) + expect_identical(nrow(voronoi_seeds_kmeans(pts, n - 1L, partition = "density")), n - 1L) + for (k in c(n, n + 50L)) { + expect_warning(s <- voronoi_seeds_kmeans(pts, k, partition = "density"), "clamping to 79") + expect_identical(nrow(s), n - 1L) + expect_true(all(is.finite(partition_xy(s)))) + expect_warning(g <- get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", set_seed = 1), + "clamping") + expect_identical(nrow(g), n - 1L) + expect_identical(sum(attr(g, "kmeans")$size), n) + } + # A layer of repeats is held to its distinct locations. + dup <- pts[rep(1:10, each = 6L), ] + expect_warning(s <- voronoi_seeds_kmeans(dup, 25, partition = "density"), + "only 10 unique positions") + expect_identical(nrow(s), 10L) + # A density profile's ladder stops where a k-means one does. + p <- resolution_profile(pts, n_levels = 4, nstart = 2, min_cell_n = 1, partition = "density") + expect_identical(max(p$levels), n - 1L) + expect_identical(p$levels, resolution_profile(pts, n_levels = 4, nstart = 2, + min_cell_n = 1)$levels) + expect_true(all(is.finite(p$wss))) + expect_true(all(vapply(attr(p, "centres"), function(m) all(is.finite(m)), logical(1)))) +}) + + +# ---- Seeds and the caller's stream ------------------------------------------------- + +test_that("a seed fixes the result, and the caller's random-number stream is untouched", { + xy <- partition_clustered_xy(n_bg = 100L, n_cl = 200L, seed = 13L) + pts <- partition_points_sf(xy) + set.seed(2024); before <- .Random.seed; expected_next <- stats::runif(3) + + check <- function(call) { + set.seed(2024) + a <- call() + expect_identical(.Random.seed, before) + expect_identical(stats::runif(3), expected_next) + set.seed(77) # another stream, the same answer + expect_identical(call(), a) + a + } + v <- check(function() voronoi_seeds_kmeans(pts, 15, partition = "density")) + check(function() voronoi_seeds_kmeans(pts, 15, init = "kmeans++")) + check(function() get_voronoi_seeds(method = "kmeans", n = 15, sample_points = pts, + partition = "density", set_seed = 5)) + check(function() resolution_profile(pts, n_levels = 4, nstart = 2, partition = "density")) + check(function() resolution_profile(pts, n_levels = 4, nstart = 2, init = "random")) + # Another seed is another partition. + expect_false(identical(partition_xy(voronoi_seeds_kmeans(pts, 15, partition = "density", + set_seed = 1)), + partition_xy(v))) + # set_seed = NULL draws from the session's stream, as it always did. + set.seed(31); a <- get_voronoi_seeds(method = "kmeans", n = 15, sample_points = pts, + partition = "density") + set.seed(31); b <- get_voronoi_seeds(method = "kmeans", n = 15, sample_points = pts, + partition = "density") + expect_identical(a, b) + # The engine itself draws from the stream it is given, and nowhere else. + set.seed(8); e1 <- spatialkit:::.partition_centres(xy, 9L, partition = "density") + set.seed(8); e2 <- spatialkit:::.partition_centres(xy, 9L, partition = "density") + expect_identical(e1, e2) +}) + + +# ---- Nothing non-finite --------------------------------------------------------------- + +test_that("no input gives a non-finite centre", { + cleanup <- spatialkit:::.with_seed(3L) + awkward <- list( + lattice = as.matrix(expand.grid(x = 1:15, y = 1:15)), + far = cbind(1e9 + stats::runif(200), -4e8 + stats::runif(200)), + tiny = cbind(stats::runif(200), stats::runif(200)) * 1e-9, + huge = cbind(stats::runif(200), stats::runif(200)) * 1e150, + sliver = cbind(stats::runif(200, 0, 1e6), stats::runif(200, 0, 1e-3)), + two_scale = rbind(cbind(stats::runif(150), stats::runif(150)) * 1e-4, + cbind(stats::runif(50, 0, 1e4), stats::runif(50, 0, 1e4))), + near_dup = rbind(cbind(stats::runif(100), stats::runif(100)), + matrix(0.5, 30L, 2L) + stats::rnorm(60, sd = 1e-13))) + cleanup() + for (nm in names(awkward)) { + xy <- unname(awkward[[nm]]) + for (k in c(1L, 3L, 20L, 90L)) for (p in c(0, 1, 2)) for (init in c("kmeans++", "random")) { + fit <- .pp_engine(xy, k, nstart = 2L, density_power = p, init = init) + expect_false(is.null(fit)) + .pp_ok(fit, xy, k) + bb <- apply(xy, 2L, range) + # The centres lie within the points' bounding box. + slack <- 1e-9 * max(bb[2L, ] - bb[1L, ]) + expect_true(all(fit$centers[, 1L] >= bb[1L, 1L] - slack & + fit$centers[, 1L] <= bb[2L, 1L] + slack)) + expect_true(all(fit$centers[, 2L] >= bb[1L, 2L] - slack & + fit$centers[, 2L] <= bb[2L, 2L] + slack)) + } + } + # density_k from one neighbour to more than there are points. + xy <- awkward$lattice + for (kn in c(1L, 3L, 8L, 224L, 5000L)) + .pp_ok(.pp_engine(xy, 12L, nstart = 2L, density_k = kn), xy, 12L) +}) + + +# ---- FNN ------------------------------------------------------------------------------ + +test_that("the result is the same with and without FNN, ties included", { + skip_if_not_installed("FNN") + cleanup <- spatialkit:::.with_seed(4L) + lattice <- as.matrix(expand.grid(x = 1:20, y = 1:20)) + sets <- list( + clustered = partition_clustered_xy(n_bg = 150L, n_cl = 350L, seed = 7L), + # On a lattice a point is often the same distance from two centres, and + # several locations are the same distance from a point. + lattice = lattice, + repeats = rbind(lattice, lattice[sample.int(400L, 150L), ])) + cleanup() + for (nm in names(sets)) { + xy <- unname(sets[[nm]]) + for (k in c(4L, 16L, 60L)) for (kn in c(5L, 8L)) for (init in c("kmeans++", "random")) { + with_fnn <- .pp_engine(xy, k, nstart = 2L, density_k = kn, init = init, use_fnn = TRUE) + without <- .pp_engine(xy, k, nstart = 2L, density_k = kn, init = init, use_fnn = FALSE) + expect_identical(without, with_fnn) + } + } + # The pieces on their own: the neighbour sets and distances, and the + # nearest centre under ties. + u <- spatialkit:::.partition_locations(sets$repeats)$u + a <- spatialkit:::.knn_locations(u, 5L, use_fnn = TRUE) + b <- spatialkit:::.knn_locations(u, 5L, use_fnn = FALSE) + expect_identical(a$d, b$d) + expect_identical(t(apply(a$idx, 1L, sort)), t(apply(b$idx, 1L, sort))) + cx <- c(5, 10, 15, 10); cy <- c(10, 5, 10, 15) + expect_identical(spatialkit:::.nearest_centre(lattice[, 1L], lattice[, 2L], cx, cy, use_fnn = TRUE), + spatialkit:::.nearest_exact(lattice[, 1L], lattice[, 2L], cx, cy)) + # The point in the middle is the same distance from all four: the lowest + # centre number has it. + mid <- which(lattice[, 1L] == 10 & lattice[, 2L] == 10) + expect_identical(spatialkit:::.nearest_centre(lattice[, 1L], lattice[, 2L], cx, cy)[mid], 1L) +}) + +test_that("tied neighbour distances are settled by the kd-tree as the exact search settles them", { + skip_if_not_installed("FNN") + same <- function(u, k) { + a <- spatialkit:::.knn_locations(u, k, use_fnn = TRUE) + b <- spatialkit:::.knn_locations(u, k, use_fnn = FALSE) + expect_identical(a$d, b$d) + expect_identical(t(apply(a$idx, 1L, sort)), t(apply(b$idx, 1L, sort))) + # The tie search on its own, asked for every row. + tied <- spatialkit:::.knn_tied_rows(u, seq_len(nrow(u)), k) + expect_identical(t(apply(tied, 1L, sort)), t(apply(b$idx, 1L, sort))) + invisible(a) + } + # Layers on which most rows tie: a square lattice at projected magnitudes, + # a triangular one, a line, and coordinates rounded to a coarse grid. + square <- as.matrix(expand.grid(x = 1:24, y = 1:24)) * 100 + 4e5 + tri <- cbind(rep(1:20, 20L) + rep(c(0, 0.5), each = 20L, times = 10L), + rep(1:20, each = 20L) * sqrt(3) / 2) + line <- cbind(1:200, 0) + rounded <- spatialkit:::.partition_locations( + round(partition_clustered_xy(n_bg = 300L, n_cl = 900L, seed = 3L) / 10) * 10)$u + for (k in c(1L, 2L, 3L, 6L, 8L, 13L, 40L)) { + same(square, k); same(tri, k); same(line, k); same(rounded, k) + } + same(square, nrow(square) - 2L) + same(square, nrow(square) - 1L) + # Twelve locations at distance exactly 5 from the origin (3-4-5 triangles) + # and a far ring. For one neighbour the first shortlist, four long, lies + # inside the tie, and so does the second; the origin's k nearest are the + # first k of the twelve in coordinate order. + ring <- rbind(c(5, 0), c(-5, 0), c(0, 5), c(0, -5), c(3, 4), c(3, -4), c(-3, 4), c(-3, -4), + c(4, 3), c(4, -3), c(-4, 3), c(-4, -3)) + u <- spatialkit:::.partition_locations(rbind(c(0, 0), ring, ring * 7 + 0.25))$u + origin <- which(u[, 1L] == 0 & u[, 2L] == 0) + on_ring <- which(rowSums(u^2) == 25) + expect_length(on_ring, 12L) + for (k in c(1L, 2L, 3L, 5L, 11L, 12L, 13L, 24L)) { + a <- same(u, k) + if (k <= 12L) { + expect_identical(sort(a$idx[origin, ]), on_ring[seq_len(k)]) + expect_identical(a$d[origin], 5) + } + } + # In any row order: the rule is the lower row number, whatever order the + # kd-tree meets the tied locations in. 36 locations at distance exactly + # 65 from the origin, in shuffled rows, so that a shortlist that ends + # inside the tie seldom holds the lowest row numbers and has to be + # lengthened until it holds every tied location. + p65 <- rbind(c(16, 63), c(25, 60), c(33, 56), c(39, 52)) + oct <- rbind(p65, p65[, 2:1]) + r65 <- rbind(oct, cbind(-oct[, 1L], oct[, 2L]), cbind(oct[, 1L], -oct[, 2L]), -oct, + c(65, 0), c(-65, 0), c(0, 65), c(0, -65)) + expect_identical(unique(rowSums(r65^2)), 4225) + all65 <- rbind(c(0, 0), r65, r65 * 3 + 0.5) + for (seed in 1:4) { + cleanup <- spatialkit:::.with_seed(seed) + u <- all65[sample.int(nrow(all65)), ] + cleanup() + origin <- which(u[, 1L] == 0 & u[, 2L] == 0) + tied <- which(rowSums(u^2) == 4225) + expect_length(tied, 36L) + for (k in c(1L, 2L, 3L, 7L, 20L)) { + a <- same(u, k) + expect_identical(sort(a$idx[origin, ]), tied[seq_len(k)]) + } + } + # With FNN no row is compared with every location, tied or not: the exact + # search is stood in for by an error, and the tied lattice still goes + # through. + expected <- spatialkit:::.knn_locations(square, 6L, use_fnn = FALSE) + local_mocked_bindings(.knn_exact_rows = function(...) stop("the exact search was called")) + got <- spatialkit:::.knn_locations(square, 6L, use_fnn = TRUE) + expect_identical(got$d, expected$d) + expect_error(spatialkit:::.knn_locations(square, 6L, use_fnn = FALSE), + "the exact search was called") +}) + +test_that("the floor on the neighbour distance is a millionth of the extent, in any unit", { + # A lattice of spacing 100 with two close pairs of locations: one pair a + # ten-thousandth of the extent apart, which is above the floor, and one a + # hundred-millionth apart, which is read as a millionth. With one + # neighbour the local density at a location is 1 / (pi d^2), d the distance + # to the nearest other location. + lat <- as.matrix(expand.grid(x = 0:5, y = 0:5)) * 100 + extent <- sqrt(2) * 500 + xy <- unname(rbind(lat, + c(150.5, 250.5), c(150.5 + 1e-4 * extent, 250.5), + c(350.5, 250.5), c(350.5 + 1e-8 * extent, 250.5))) + for (f in c(1, 1000, 1e-3)) { + fit <- .pp_engine(xy * f, 3L, density_k = 1L, nstart = 1L) + w <- fit$weights + # The corner of the lattice has its nearest neighbour at 100. + expect_equal(w[37:38] / w[1L], rep((100 / (1e-4 * extent))^2, 2L), tolerance = 1e-6) + expect_equal(w[39:40] / w[1L], rep((100 / (1e-6 * extent))^2, 2L), tolerance = 1e-9) + } + # The function that reads the densities, on coordinates already divided by + # the extent. + u <- cbind(c(0, 0.3, 0.3 + 1e-4, 0.7, 0.7 + 1e-8, 1), c(0, 0.5, 0.5, 0.5, 0.5, 1) / 1) + w <- spatialkit:::.density_weights(u, rep(1L, 6L), power = 1, k_nn = 1L, use_fnn = FALSE) + d_corner <- sqrt(0.3^2 + 0.5^2) + expect_equal(w[2:3] / w[1L], rep((d_corner / 1e-4)^2, 2L), tolerance = 1e-6) + expect_equal(w[4:5] / w[1L], rep((d_corner / 1e-6)^2, 2L), tolerance = 1e-9) + expect_identical(spatialkit:::.DENSITY_FLOOR_REL, 1e-6) +}) + +test_that("the local density is the usual nearest-neighbour estimate where no location repeats", { + cleanup <- spatialkit:::.with_seed(6L) + xy <- cbind(stats::runif(120), stats::runif(120)) + cleanup() + loc <- spatialkit:::.partition_locations(xy) + expect_identical(loc$m, rep(1L, 120L)) + d <- as.matrix(stats::dist(loc$u)); diag(d) <- Inf + d8 <- unname(apply(d, 1L, function(v) sort(v)[8L])) + w <- spatialkit:::.density_weights(loc$u, loc$m, power = 1, k_nn = 8L, use_fnn = FALSE) + expect_equal(w, (8 / (pi * d8^2)) / mean(8 / (pi * d8^2)), tolerance = 1e-12) + # With repeats: the points at the location and at its 8 nearest other + # locations, over the disc that reaches the furthest of those. + m2 <- rep(1L, 120L); m2[c(3L, 50L)] <- c(30L, 4L) + w2 <- spatialkit:::.density_weights(loc$u, m2, power = 1, k_nn = 8L, use_fnn = FALSE) + nb <- unname(t(apply(d, 1L, function(v) order(v)[1:8]))) + cnt <- (m2 - 1) + rowSums(matrix(m2[nb], 120L, 8L)) + rho <- cnt / (pi * d8^2) + expect_equal(w2, rho / mean(rep.int(rho, m2)), tolerance = 1e-12) + expect_equal(mean(rep.int(w2, m2)), 1, tolerance = 1e-12) + # Power 0, and one location: every weight is one. + expect_identical(spatialkit:::.density_weights(loc$u, loc$m, 0, 8L, FALSE), rep(1, 120L)) + expect_identical(spatialkit:::.density_weights(loc$u[1L, , drop = FALSE], 5L, 1, 8L, FALSE), 1) +}) diff --git a/tests/testthat/test-core-partition-reference.R b/tests/testthat/test-core-partition-reference.R new file mode 100644 index 00000000..94ef1b64 --- /dev/null +++ b/tests/testthat/test-core-partition-reference.R @@ -0,0 +1,253 @@ +# tests/testthat/test-core-partition-reference.R +# --------------------------------------------------------------------------- +# The package's density kind and its random starts reproduce the experiment +# that tested them. +# +# den_centres() and rnd_centres() (helper-partition-reference.R) are that +# experiment's functions. Two of den_centres()'s guards depend on the unit +# of the coordinates: the neighbour distance is not taken below 1, and Lloyd's +# iteration stops when no centre moves by 1e-6. The package states both as +# fractions of the extent. On point sets where neither guard binds (every +# 8th-neighbour distance is far above 1, and a step either moves a centre by +# far more than 1e-6 or not at all), given the same point order and seed, +# the package's centres are the reference's. +# +# den_centres() takes the rows as they come; the package works in coordinate +# order, so the reference is given the rows in that order. +# --------------------------------------------------------------------------- + +.pr_sets <- function() list( + # 1,200 points, 900 of them in four clusters, on a square of side 1000. + clustered = partition_clustered_xy(seed = 11L), + # 800 points spread over a 2000 x 700 rectangle. + uniform = { + cleanup <- spatialkit:::.with_seed(5L) + xy <- cbind(stats::runif(800, 0, 2000), stats::runif(800, 0, 700)) + cleanup() + xy + }) + +.pr_density <- function(xy, k, seed, ...) { + set.seed(seed) + spatialkit:::.partition_centres(xy, k, partition = "density", init = "kmeans++", + nstart = DEN_NSTART, iter.max = DEN_ITER, + density_power = DEN_POWER, density_k = DEN_NN, ...) +} + + +test_that("neither unit-dependent guard of the reference binds on the test point sets", { + skip_if_not_installed("FNN") + for (nm in names(.pr_sets())) { + xy <- .pr_sets()[[nm]] + d8 <- FNN::get.knn(xy, k = DEN_NN)$nn.dist[, DEN_NN] + # The reference's floor of 1 unit, and the package's of 1e-6 of the extent. + extent <- sqrt(sum((apply(xy, 2L, max) - apply(xy, 2L, min))^2)) + expect_gt(min(d8), 1) + expect_gt(min(d8) / extent, spatialkit:::.DENSITY_FLOOR_REL) + # With no floor in play the reference's density is k / (pi d^2) exactly. + expect_identical(local_density(xy), DEN_NN / (pi * d8^2)) + } +}) + +test_that("the density kind's centres are den_centres()'s, to 1e-8", { + skip_if_not_installed("FNN") + worst <- 0 + for (nm in names(.pr_sets())) { + xy <- .pr_sets()[[nm]] + xs <- partition_sorted(xy) + for (k in c(2L, 7L, 30L, 120L)) for (seed in c(1L, 77L)) { + ref <- den_centres(xs, k, seed) + got <- .pr_density(xy, k, seed) + expect_identical(dim(got$centers), dim(ref)) + d <- max(abs(got$centers - ref)) + worst <- max(worst, d) + expect_lt(d, 1e-8) + # The cells are the reference's as well: every point to its nearest + # centre. + expect_identical(got$cluster, as.integer(partition_nearest(xy, ref))) + } + } + # Measured: 2e-12 at most on these coordinates, which run to 2000. + expect_lt(worst, 1e-10) +}) + +test_that("the weights are the reference's: local density to the power 1, mean 1", { + skip_if_not_installed("FNN") + xy <- .pr_sets()$clustered + w_ref <- local_density(xy)^DEN_POWER + w_ref <- w_ref / mean(w_ref) + got <- .pr_density(xy, 12L, 3L) + expect_equal(got$weights, w_ref, tolerance = 1e-12) + expect_equal(mean(got$weights), 1, tolerance = 1e-12) + # The objective is the reference's weighted sum at the centres returned. + cl <- partition_nearest(xy, got$centers) + expect_equal(got$objective, sum(w_ref * rowSums((xy - got$centers[cl, ])^2)), + tolerance = 1e-10) +}) + +test_that("at projected magnitudes the two agree to the reference's own rounding", { + # The same comparison at coordinates of 5e5 and 5e6, where one unit in the + # last place of a coordinate is 9.3e-10. The reference adds up its + # weighted means at that magnitude; the package centres the coordinates on + # their bounding box first and adds up numbers no larger than the extent. + # The two then differ by a few units in the last place of the coordinates: + # 2.8e-9 to 9.3e-9 on this layer. The size depends on the layout and + # grows with the points per cell, so other layers pass the 1e-8 that holds + # at small coordinates. It is the reference's rounding and not a + # difference of method: the cells are identical, and against the weighted + # mean of each cell computed on centred coordinates the package is within + # 1.2e-10 where the reference is up to 9.3e-9 away. + skip_if_not_installed("FNN") + xy <- partition_clustered_xy(n_bg = 500L, n_cl = 2500L, clusters = 6L, side = 1e5, + origin = c(5e5, 5e6), seed = 3L) + xs <- partition_sorted(xy) + mid <- colMeans(xy) + xc <- sweep(xy, 2L, mid) + for (k in c(7L, 30L, 120L)) { + ref <- den_centres(xs, k, 77L) + got <- .pr_density(xy, k, 77L) + expect_lt(max(abs(got$centers - ref)), 1e-6) + expect_identical(got$cluster, as.integer(partition_nearest(xy, ref))) + wm <- sweep(rowsum(xc * got$weights, got$cluster) / + as.numeric(rowsum(got$weights, got$cluster)), 2L, mid, "+") + expect_lt(max(abs(got$centers - wm)), 1e-9) + expect_lte(max(abs(got$centers - wm)), max(abs(ref - wm))) + } +}) + +test_that("where the reference's floor of one unit binds, the package's does not", { + # The clustered layout on a square of side 25: the 8th neighbour of most + # points is nearer than 1, so the reference reads the same density off all + # of them. It is the same layout as on a square of side 1000, where the + # floor does not bind, and the reference gives a different partition of it. + # The package gives the same one at either size. + skip_if_not_installed("FNN") + big <- partition_clustered_xy(n_bg = 100L, n_cl = 200L, clusters = 3L, side = 1000, seed = 8L) + small <- big / 40 + d8 <- FNN::get.knn(small, k = DEN_NN)$nn.dist[, DEN_NN] + expect_gt(mean(d8 < 1), 0.5) + expect_gt(min(FNN::get.knn(big, k = DEN_NN)$nn.dist[, DEN_NN]), 1) + k <- 12L + ref_big <- den_centres(partition_sorted(big), k, 4L) + ref_small <- den_centres(partition_sorted(small), k, 4L) + expect_gt(max(abs(ref_small * 40 - ref_big)), 1) # the unit changed the answer + got_big <- .pr_density(big, k, 4L) + got_small <- .pr_density(small, k, 4L) + expect_lt(max(abs(got_small$centers * 40 - got_big$centers)), 1e-8) + expect_identical(got_small$cluster, got_big$cluster) + # And the package's answer is the reference's where the reference is + # unit-free. + expect_lt(max(abs(got_big$centers - ref_big)), 1e-8) +}) + +test_that("get_voronoi_seeds(partition = \"density\") returns den_centres()'s centres", { + # Through the public function: 3 starts, 40 Lloyd steps, 8 neighbours, + # power 1, the settings of the experiment. + skip_if_not_installed("FNN") + xy <- .pr_sets()$clustered + pts <- partition_points_sf(xy) + for (k in c(9L, 40L)) { + ref <- den_centres(partition_sorted(xy), k, 21L) + s <- get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + partition = "density", kmeans_nstart = DEN_NSTART, + kmeans_iter = DEN_ITER, set_seed = 21L) + expect_lt(max(abs(partition_xy(s) - ref)), 1e-8) + expect_identical(attr(s, "partition")$kind, "density") + expect_identical(attr(s, "partition")$init, "kmeans++") + } +}) + +test_that("a density profile's centres are the engine's at the profile's settings", { + # resolution_profile() runs `nstart` starts of at most 100 Lloyd steps. + # Geometry only, so nothing draws from the stream before the sweep. + xy <- .pr_sets()$uniform + pts <- partition_points_sf(xy) + prof <- resolution_profile(pts, levels = 15L, nstart = 4, seed = 9, partition = "density") + set.seed(9) + eng <- spatialkit:::.partition_centres(xy, 15L, partition = "density", nstart = 4L, + iter.max = 100L) + expect_identical(attr(prof, "centres")[["15"]], eng$centers) + expect_identical(prof$wss, eng$wss) + expect_identical(unname(attr(prof, "partition")$objective), eng$objective) +}) + +test_that("with the reference's 40 steps a density profile's centres are den_centres()'s", { + # Every start of this case stops moving before step 40, so the limit of + # 100 the profile runs to makes no difference. + skip_if_not_installed("FNN") + xy <- .pr_sets()$clustered + pts <- partition_points_sf(xy) + k <- 30L + set.seed(1) + eng <- spatialkit:::.partition_centres(xy, k, partition = "density", nstart = DEN_NSTART, + iter.max = DEN_ITER) + expect_true(eng$converged) + prof <- resolution_profile(pts, levels = k, nstart = DEN_NSTART, seed = 1, + partition = "density") + expect_lt(max(abs(attr(prof, "centres")[[as.character(k)]] - + den_centres(partition_sorted(xy), k, 1L))), 1e-8) +}) + + +# ---- Random starts ---------------------------------------------------------- + +test_that("random starts are rnd_centres()'s: stats::kmeans() from 5 starts, 100 iterations", { + xy <- .pr_sets()$clustered + for (k in c(3L, 20L, 150L)) for (seed in c(4L, 9L)) { + ref <- rnd_centres(xy, k, seed) + expect_identical(attr(ref, "warned"), 0L) + expect_false(attr(ref, "fell")) + ref <- matrix(as.numeric(ref), ncol = 2L) + # One start at a time, as the profile runs them ... + set.seed(seed) + each <- spatialkit:::.partition_centres(xy, k, partition = "kmeans", init = "random", + nstart = RND_NSTART, iter.max = RND_ITER) + # ... and as one stats::kmeans() call, as the seeding functions run them. + set.seed(seed) + one <- spatialkit:::.partition_centres(xy, k, partition = "kmeans", init = "random", + nstart = RND_NSTART, iter.max = RND_ITER, + one_call = TRUE) + expect_identical(each$centers, ref) + expect_identical(one$centers, ref) + expect_identical(each$cluster, one$cluster) + expect_identical(each$wss, one$wss) + # The start-by-start run also has the spread of the starts. + expect_true(is.finite(each$spread) && each$spread >= 0) + expect_true(is.na(one$spread)) + } +}) + +test_that("a single random start is the one stats::kmeans(nstart = 1) draws", { + # With one start stats::kmeans() draws among all the rows and turns to the + # distinct rows only when two of those drawn coincide. + xy <- .pr_sets()$uniform + dup <- rbind(xy[1:60, ], xy[1:60, ], xy[1:30, ]) + for (x in list(xy, dup)) for (seed in 1:3) { + set.seed(seed) + km <- suppressWarnings(stats::kmeans(x, centers = 12L, nstart = 1L, iter.max = 100L)) + set.seed(seed) + got <- spatialkit:::.partition_centres(x, 12L, partition = "kmeans", init = "random", + nstart = 1L, iter.max = 100L) + expect_identical(got$centers, unname(km$centers)) + } +}) + +test_that("get_voronoi_seeds() and a random-start profile return rnd_centres()'s centres", { + xy <- .pr_sets()$clustered + pts <- partition_points_sf(xy) + k <- 20L + # The seeding function clusters the rows as they come, as rnd_centres() does. + ref <- matrix(as.numeric(rnd_centres(xy, k, 4L)), ncol = 2L) + s <- get_voronoi_seeds(method = "kmeans", n = k, sample_points = pts, + kmeans_nstart = RND_NSTART, kmeans_iter = RND_ITER, set_seed = 4L, + partition = "kmeans") + expect_identical(partition_xy(s), ref) + # The profile puts the rows in coordinate order first. + ref_sorted <- matrix(as.numeric(rnd_centres(partition_sorted(xy), k, 4L)), ncol = 2L) + prof <- resolution_profile(pts, levels = k, nstart = RND_NSTART, seed = 4, init = "random", + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans") + expect_identical(attr(prof, "centres")[[as.character(k)]], ref_sorted) + expect_identical(attr(prof, "partition")[c("kind", "init")], + list(kind = "kmeans", init = "random")) +}) diff --git a/tests/testthat/test-core-pipeline.R b/tests/testthat/test-core-pipeline.R new file mode 100644 index 00000000..510ff368 --- /dev/null +++ b/tests/testthat/test-core-pipeline.R @@ -0,0 +1,366 @@ +# tests/testthat/test-core-pipeline.R +# --------------------------------------------------------------------------- +# The path from a profile to a summary, through exported functions only: +# resolution_profile(), select_resolution(), get_voronoi_seeds(), +# build_tessellation(), assign_features_to_polygons(), summarize_by_cell(). +# The cells built from a selection are the cells the profile scored: every +# row lies in the cell of its nearest scored centre, and the leave-one-out +# error computed on the built and assigned cells is the profile's at the +# chosen level. On projected and lon/lat input, for both kinds of +# partition, for a count set by a size and one chosen by the leave-one-out +# minimum, and for centres fitted to a subsample. +# Also here: what the check reports on gridded locations, where a row can +# lie exactly on the boundary between two cells, and for features that are +# not points. +# +# Every profile names `partition`, `nstart`, `estimate`, `obs_per_cell` and +# `sac`, every selection its `criterion`, every summary its `estimate`. +# --------------------------------------------------------------------------- + +.pp_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.pp_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.pp_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) + +.pp_names <- c("version", "rule", "estimate", "cells", "obs_per_cell", "obs_per_cell_asked", + "response", "n", "n_points", "n_fit", "seed", "features", "scored", + "partition", "crs", "scored_cells") +.pp_sizes <- c(18, 12, 9, 6, 4.5, 3, 2) + +# The layer: seed 7001; `u`, then `v`, 3,000 values each, uniform on 0 to +# 1e5; then the response, sin(u / 2e4) + cos(v / 1.5e4) plus normal noise of +# standard deviation 1.5; the points at (5e5 + u, 5e6 + v) in EPSG:32617. +.pp_store <- new.env(parent = emptyenv()) +.pp_layer <- function() { + if (is.null(.pp_store$pts)) { + d <- local({ + .pp_seed(7001) + u <- stats::runif(3000, 0, 1e5) + v <- stats::runif(3000, 0, 1e5) + z <- sin(u / 2e4) + cos(v / 1.5e4) + stats::rnorm(3000, 0, 1.5) + data.frame(x = 5e5 + u, y = 5e6 + v, z = z) + }) + .pp_store$pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32617) + } + .pp_store$pts +} + +# One path, by the calls a user writes, with what every path has to show. +.pp_path <- function(pts, prof, criterion, estimate, n_fit = 3000L) { + sel <- select_resolution(prof, criterion = criterion) + seeds <- .pp_catch(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + # The one warning the seeding may raise here: a minimum at an end of the sizes. + expect_true(all(vapply(seeds$warnings, inherits, logical(1), "spatialkit_bound_chosen"))) + seeds <- seeds$value + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + out <- .pp_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = estimate)) + + # ---- the record, from the selection to the summary ------------------------- + rec <- sel$count_rule + expect_identical(names(rec), .pp_names) + expect_identical(rec$rule, criterion) + expect_identical(rec$estimate, estimate) + expect_identical(rec$cells, as.integer(sel$best)) + expect_identical(rec$response, "z") + expect_identical(rec$n, 3000L) + expect_identical(rec$n_points, 3000L) + expect_identical(rec$n_fit, as.integer(n_fit)) + expect_identical(rec$seed, 123) + expect_identical(rec$features, "points") + expect_identical(rec$scored$rows, "all") + expect_identical(rec$scored$n, 3000L) + expect_identical(rec$scored_cells, NA) + on_seeds <- rec; on_seeds$scored_cells <- TRUE + expect_identical(attr(sel$seeds, "count_rule"), on_seeds) + expect_identical(attr(seeds, "count_rule"), on_seeds) + expect_identical(tess$params$count_rule, on_seeds) + expect_identical(attr(tess$cells, "count_rule"), on_seeds) + expect_identical(attr(asg, "count_rule"), on_seeds) + got <- attr(out$value, "count_rule") + expect_identical(got$check, list(estimate = "match", cells = "match")) + got$check <- NULL + expect_identical(got, on_seeds) + expect_length(.pp_of(out, "spatialkit_cells_differ"), 0L) + expect_length(.pp_of(out, "spatialkit_estimate_mismatch"), 0L) + + # ---- every row in the cell of its nearest scored centre --------------------- + expect_identical(nrow(seeds), as.integer(sel$best)) + expect_identical(nrow(asg), 3000L) + cen <- unname(sf::st_coordinates(sel$seeds)[, 1:2]) + expect_identical(sf::st_crs(sel$seeds), rec$crs) + xy <- unname(sf::st_coordinates(sf::st_transform(pts, rec$crs))[, 1:2]) + nearest <- .nearest_centre(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L], .has_backend("FNN")) + expect_false(anyNA(tess$index)) + expect_identical(asg$cell_id, tess$index[nearest]) + + # ---- the summary's leave-one-out error is the profile's at that level ------- + at_level <- prof$loo[match(sel$best, prof$levels)] + expect_identical(rec$scored$loo, at_level) + fit <- .pool_column(asg$z, asg$cell_id, .pooled_xy(asg, rec$crs)$xy, NULL, want = estimate, + use_fnn = .has_backend("FNN"))$fit + found <- if (identical(estimate, "pooled")) fit$loo_pooled else fit$loo_mean + expect_true(is.finite(at_level)) + expect_lt(abs(found - at_level) / at_level, 1e-10) + expect_identical(fit$N, 3000L) + expect_identical(fit$K, rec$scored$cells) + if (identical(estimate, "pooled")) { + own <- attr(out$value, "pooled")$columns$resp_z + expect_lt(abs(own$loo - at_level) / at_level, 1e-10) + expect_identical(attr(out$value, "pooled")$crs, rec$crs) + } + invisible(list(sel = sel, seeds = seeds, tess = tess, asg = asg, out = out$value)) +} + + +# ---- End to end ------------------------------------------------------------------- + +test_that("the cells built from a selection reproduce the profile's score, on projected and lon/lat input", { + pts <- .pp_layer() + layers <- list(projected = pts, `lon/lat` = sf::st_transform(pts, 4326)) + kinds <- list(list(partition = "density", nstart = 3), list(partition = "kmeans", nstart = 5)) + paths <- 0L + for (nm in names(layers)) for (kind in kinds) { + layer <- layers[[nm]] + # By a size, for pooled values. + pooled <- resolution_profile(layer, "z", partition = kind$partition, nstart = kind$nstart, + sac = "auto", seed = 123, estimate = "pooled", + obs_per_cell = 4.5) + P <- .pp_path(layer, pooled, "size", "pooled") + expect_identical(P$sel$best, 667L) + expect_identical(P$sel$count_rule$obs_per_cell_asked, 4.5) + expect_identical(P$sel$count_rule$partition$kind, kind$partition) + expect_identical(P$sel$count_rule$partition$nstart, as.integer(kind$nstart)) + # By the lowest leave-one-out error, for plain means. + plain <- suppressWarnings( + resolution_profile(layer, "z", partition = kind$partition, nstart = kind$nstart, + sac = "auto", seed = 123, estimate = "mean", + obs_per_cell = .pp_sizes)) + M <- .pp_path(layer, plain, "loo", "mean") + expect_true(M$sel$best %in% plain$levels) + # The seeds come back in the CRS of the points they are for, and the + # record names the projected CRS the profile worked in. + expect_identical(sf::st_crs(P$seeds), sf::st_crs(layer)) + expect_false(sf::st_is_longlat(P$sel$count_rule$crs)) + paths <- paths + 2L + } + expect_identical(paths, 8L) +}) + +test_that("centres fitted to a subsample are checked on every row of the layer", { + skip_if_not_installed("gstat") + pts <- .pp_layer() + prof <- suppressWarnings( + resolution_profile(pts, "z", estimate = "pooled", obs_per_cell = NULL, sample_n = 1500, + sac = NULL, partition = "density", nstart = 3, seed = 123)) + expect_identical(attr(prof, "bounds")$n_sample, 1500L) + S <- .pp_path(pts, prof, "loo", "pooled", n_fit = 1500L) + rec <- attr(S$out, "count_rule") + expect_identical(rec$n_fit, 1500L) + expect_identical(rec$n_points, 3000L) + expect_match(gsub("\\s+", " ", paste(utils::capture.output(print(rec)), collapse = " ")), + "fitted to a subsample of 1500 of the 3000 points", fixed = TRUE) +}) + + +# ---- Points on a lattice ---------------------------------------------------------- + +# 60 x 50 locations at one spacing from one corner, in EPSG:32617; the +# response of seed 9001, drawn after the locations are laid. +.pp_lattice <- function(step, x0, y0) { + g <- expand.grid(i = seq_len(60L) - 1L, j = seq_len(50L) - 1L) + z <- local({ + .pp_seed(9001) + sin(g$i / 12) + cos(g$j / 9) + stats::rnorm(nrow(g), 0, 1.5) + }) + sf::st_as_sf(data.frame(x = x0 + step * g$i, y = y0 + step * g$j, z = z, + row = seq_len(nrow(g))), + coords = c("x", "y"), crs = 32617) +} + +test_that("on gridded locations the check says match exactly when no row was placed in another cell", { + lattices <- list(`whole metres` = .pp_lattice(100, 5e5, 5e6), + `spacing 0.7` = .pp_lattice(0.7, 5e5 + 0.1, 5e6 + 0.3)) + kinds <- list(list(partition = "kmeans", nstart = 5), list(partition = "density", nstart = 3)) + moved_in <- integer(0) + on_edge <- integer(0) + for (nm in names(lattices)) for (kind in kinds) { + pts <- lattices[[nm]] + info <- paste(nm, kind$partition) + prof <- suppressWarnings( + resolution_profile(pts, "z", partition = kind$partition, nstart = kind$nstart, + sac = "auto", seed = 123, estimate = "pooled", obs_per_cell = 4.5)) + sel <- select_resolution(prof, criterion = "size") + seeds <- suppressWarnings(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + # The profile's placement: each row to its nearest scored centre, a tie + # to the lower-numbered one. + cen <- unname(sf::st_coordinates(sel$seeds)[, 1:2]) + xy <- unname(sf::st_coordinates(pts)[, 1:2]) + scored_in <- tess$index[.nearest_centre(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L], .has_backend("FNN"))] + # The path's placement: the polygon that holds the row, a row on a shared + # edge to the smaller polygon. + asg <- suppressWarnings(assign_features_to_polygons(pts, tess$cells, + polygon_id_col = "cell_id", quiet = TRUE)) + expect_identical(formals(assign_features_to_polygons)$tie_break, + quote(c("smallest_area", "first"))) + placed_in <- asg$cell_id[match(pts$row, asg$row)] + unassigned <- sum(is.na(placed_in)) + moved <- sum(placed_in != scored_in, na.rm = TRUE) + moved_in[info] <- moved + # The same cells without their record: the polygons alone decide. + bare <- tess$cells + attr(bare, "count_rule") <- NULL + by_polygons <- assign_features_to_polygons(pts, bare, polygon_id_col = "cell_id", quiet = TRUE) + on_edge[info] <- sum(by_polygons$cell_id[match(pts$row, by_polygons$row)] != scored_in, + na.rm = TRUE) + # A row placed in another cell than the profile's is a row on a boundary: + # the centre of the cell it was placed in is as near as its nearest + # centre, exactly or to the rounding of the coordinates. Any other row + # in another cell would be a row the path misplaced. + elsewhere <- which(!is.na(placed_in) & placed_in != scored_in) + if (length(elsewhere)) { + d2 <- function(rows, centre) (xy[rows, 1L] - cen[centre, 1L])^2 + + (xy[rows, 2L] - cen[centre, 2L])^2 + nearest <- match(scored_in[elsewhere], tess$index) + placed <- match(placed_in[elsewhere], tess$index) + gap <- abs(d2(elsewhere, placed) - d2(elsewhere, nearest)) / d2(elsewhere, nearest) + expect_true(all(gap < 1e-6), info = info) + } + + r <- .pp_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled")) + check <- attr(r$value, "count_rule")$check$cells + w <- .pp_of(r, "spatialkit_cells_differ") + own <- attr(r$value, "pooled")$columns$resp_z + at_level <- prof$loo[match(sel$best, prof$levels)] + if (unassigned == 0L && moved == 0L) { + expect_identical(check, "match", info = info) + expect_length(w, 0L) + expect_lt(abs(own$loo - at_level) / at_level, 1e-10) + # In any order of the rows: the profile holds them in coordinate + # order, the summary as they come. + for (seed in c(1L, 2L)) { + shuffled <- asg[local({ .pp_seed(seed); sample.int(nrow(asg)) }), ] + attr(shuffled, "count_rule") <- attr(asg, "count_rule") + rs <- .pp_catch(summarize_by_cell(shuffled, "z", id_col = "cell_id", + cells_sf = tess$cells, estimate = "pooled")) + expect_identical(attr(rs$value, "count_rule")$check$cells, "match", info = info) + loo <- attr(rs$value, "pooled")$columns$resp_z$loo + expect_lt(abs(loo - at_level) / at_level, 1e-10) + } + } else { + expect_identical(check, "differ", info = info) + expect_length(w, 1L) + # A row in no cell is a row fewer; rows in other cells leave the count, + # and change the occupied cells or, with those unchanged, the error. + kind_of <- if (unassigned > 0L) "n" + else if (!identical(own$cells, sel$count_rule$scored$cells)) "cells" + else "loo" + expect_identical(w[[1L]]$what, kind_of, info = info) + expect_identical(w[[1L]]$found$n, 3000L - unassigned, info = info) + if (identical(kind_of, "loo")) + expect_match(conditionMessage(w[[1L]]), + "rows exactly on a boundary between two cells (gridded locations)", + fixed = TRUE) + } + } + # Which lattice has rows on a boundary rests on exact ties, which another + # GEOS or another arithmetic can settle the other way, so the counts are + # held only on the platform the frozen fixture was recorded on. There the + # polygons alone put no row of either lattice in another cell than the + # profile's under the k-means kind, and 5 and 7 of 3,000 under the density + # kind, every one of them on a boundary; the assignment, on cells that + # carry the scored centres, gives each of them the cell the profile scored + # it in, so no row is elsewhere and the check reads match on all four. + # test-core-gridded-ties.R holds the branch that reports rows elsewhere. + expect_identical(names(moved_in), c("whole metres kmeans", "whole metres density", + "spacing 0.7 kmeans", "spacing 0.7 density")) + expect_identical(names(on_edge), names(moved_in)) + recorded <- readRDS(test_path("fixtures", "core-frozen.rds"))$info + if (core_frozen_same_platform(core_frozen_platform(), recorded)) { + expect_identical(unname(on_edge), c(0L, 5L, 0L, 7L)) + expect_identical(unname(moved_in), c(0L, 0L, 0L, 0L)) + } +}) + + +# ---- Features that are not points ------------------------------------------------- + +test_that("polygon features are scored at one point and assigned by overlap, and the cells are not compared", { + # 4,800 squares centred on locations of seed 5105, of side a third of the + # mean cell width at 4.5 rows a cell. A square's point is its centre, and + # the cell that holds the centre holds most of the square unless the + # square lies across a corner of the cells, which about one square in a + # thousand does: 10 of these, and 4, 5 and 4 of the layers of seeds 5102 + # to 5104. + d <- local({ + .pp_seed(5105) + x <- stats::runif(4800, 0, 1e5); y <- stats::runif(4800, 0, 1e5) + data.frame(x = 5e5 + x, y = 5e6 + y, + z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(4800, 0, 1.5)) + }) + side <- sqrt(1e10 / 1067) / 3 + squares <- lapply(seq_len(nrow(d)), function(i) sf::st_polygon(list(cbind( + d$x[i] + side * c(-0.5, 0.5, 0.5, -0.5, -0.5), d$y[i] + side * c(-0.5, -0.5, 0.5, 0.5, -0.5))))) + polys <- sf::st_sf(z = d$z, row = seq_len(nrow(d)), geometry = sf::st_sfc(squares, crs = 32617)) + + prof <- resolution_profile(polys, "z", partition = "density", nstart = 3, sac = "auto", + seed = 123, estimate = "pooled", obs_per_cell = 4.5) + expect_identical(attr(prof, "estimate")$features, "other") + sel <- select_resolution(prof, criterion = "size") + expect_identical(sel$best, 1067L) + expect_identical(sel$count_rule$features, "other") + at_points <- coerce_to_points(polys, "auto") + seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = at_points) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + expect_identical(attr(tess$cells, "count_rule")$scored_cells, TRUE) + + # By largest overlap. Some squares straddle a boundary, and a few have + # most of their area in another cell than their point's. + asg <- assign_features_to_polygons(polys, tess$cells, polygon_id_col = "cell_id", quiet = TRUE) + expect_identical(nrow(asg), 4800L) + # The assigned features carry the record of the cells, points or not. + expect_true(all(sf::st_geometry_type(asg) == "POLYGON")) + expect_identical(attr(asg, "count_rule"), attr(tess$cells, "count_rule")) + expect_gt(sum(lengths(sf::st_intersects(polys, tess$cells)) > 1L), 1000L) + cen <- unname(sf::st_coordinates(sel$seeds)[, 1:2]) + xy <- unname(sf::st_coordinates(at_points)[, 1:2]) + scored_in <- tess$index[.nearest_centre(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L], .has_backend("FNN"))] + elsewhere <- sum(asg$cell_id[match(polys$row, asg$row)] != scored_in) + expect_gt(elsewhere, 0L) + + r <- .pp_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled")) + expect_length(.pp_of(r, "spatialkit_cells_differ"), 0L) + expect_identical(attr(r$value, "count_rule")$check, + list(estimate = "match", cells = "not checked: the features are not points")) + # The summary's own error describes the cells as assigned, which are not + # the cells as scored wherever a square was assigned elsewhere. + own <- attr(r$value, "pooled")$columns$resp_z$loo + expect_true(is.finite(own)) + if (elsewhere > 0L) + expect_false(isTRUE(all.equal(own, sel$count_rule$scored$loo, tolerance = 1e-8))) + + # The same features assigned by their points are the rows the profile scored. + by_point <- assign_features_to_polygons(at_points, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + expect_identical(by_point$cell_id[match(polys$row, by_point$row)], scored_in) + r <- .pp_catch(summarize_by_cell(by_point, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled")) + expect_identical(attr(r$value, "count_rule")$check, list(estimate = "match", cells = "match")) + expect_length(.pp_of(r, "spatialkit_cells_differ"), 0L) + at_level <- sel$count_rule$scored$loo + expect_lt(abs(attr(r$value, "pooled")$columns$resp_z$loo - at_level) / at_level, 1e-10) +}) diff --git a/tests/testthat/test-core-pool-edge.R b/tests/testthat/test-core-pool-edge.R new file mode 100644 index 00000000..73578186 --- /dev/null +++ b/tests/testthat/test-core-pool-edge.R @@ -0,0 +1,1166 @@ +# tests/testthat/test-core-pool-edge.R +# --------------------------------------------------------------------------- +# summarize_by_cell(estimate = "pooled", obs_level = ) on the inputs where +# pooling has little or nothing to work with: one test for each case the +# design lists for the pooled value and for the interval for one observation, +# through the exported function, with the values returned and the class and +# fields of the condition raised. +# +# The cells here are an ID column on the rows: the pooled columns read each +# row's ID and its coordinates and nothing of a polygon, so a layer can be +# given exactly the cells a case needs. Every call names `estimate`. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.pe_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.pe_points <- function(x, y, data, crs = 32617) + sf::st_as_sf(cbind(data.frame(x = x, y = y), data), coords = c("x", "y"), crs = crs) + +.pe_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.pe_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.pe_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.pe_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] +.pe_new <- function(x) grep("^\\.\\.(pooled|obs)_", names(x), value = TRUE) + +.pe_without_fnn <- function(env = parent.frame()) + testthat::local_mocked_bindings( + .has_backend = function(pkg) + if (identical(pkg, "FNN")) FALSE else requireNamespace(pkg, quietly = TRUE), + .env = env) + +.pe_pooled <- function(layer, ..., id_col = "cell_id") + summarize_by_cell(layer, ..., id_col = id_col, estimate = "pooled") + +# 720 rows of a smooth field with noise on a 10 x 6 grid of cells, the cell an +# arithmetic function of the coordinates: x, then y, then z. Every cell +# holds several rows, and the layer raises nothing on the pooled path. +.pe_store <- new.env(parent = emptyenv()) +.pe_layer <- function() { + if (is.null(.pe_store$layer)) { + d <- local({ + .pe_seed(3001) + x <- stats::runif(720, 0, 1e5); y <- stats::runif(720, 0, 1e5) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(720, 0, 0.5)) + }) + d$cell_id <- as.integer(6 * floor(d$x / 1e4) + floor(d$y / (1e5 / 6)) + 1) + .pe_store$layer <- .pe_points(d$x, d$y, d[c("z", "cell_id")]) + } + .pe_store$layer +} + +# The pooled residuals of a column written out from what the frame and the +# record hold: each row predicted by its cell's value with the row taken out, +# sigma2, tau2 and the targets held. +.pe_residuals <- function(y, id, out, rec, name, id_col = "cell_id") { + at <- match(id, out[[id_col]]) + n <- as.integer(table(id)[as.character(id)]) + S <- as.numeric(tapply(y, id, sum)[as.character(id)]) + t <- out[[paste0("..pooled_target_", name)]][at] + m1 <- (S - y) / pmax(n - 1L, 1L) + w1 <- ifelse(n > 1L, rec$tau2 / (rec$tau2 + rec$sigma2 / pmax(n - 1L, 1L)), 0) + y - (w1 * m1 + (1 - w1) * t) +} + +# For each region the regions whose centroids are nearest, by the rule of the +# design: distance, then the lower x, then the lower y, then the lower number. +.pe_neighbours <- function(cen, k = 8L) { + K <- nrow(cen) + t(vapply(seq_len(K), function(j) { + d2 <- (cen[, 1L] - cen[j, 1L])^2 + (cen[, 2L] - cen[j, 2L])^2 + o <- order(d2, cen[, 1L], cen[, 2L], seq_len(K)) + o[o != j][seq_len(min(k, K - 1L))] + }, integer(min(k, K - 1L)))) +} + +test_that("the layer of these tests has cells of several rows and raises nothing", { + L <- .pe_layer() + expect_identical(length(unique(L$cell_id)), 60L) + expect_gte(min(table(L$cell_id)), 4L) + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + expect_identical(attr(r$value, "pooled")$columns$resp_z$status, "ok") +}) + + +# ---- A cell with one row, and a cell with none ----------------------------------- + +test_that("a cell with one row has a value between its row and its target, and the same interval", { + L <- .pe_layer() + L$cell_id[7L] <- 999L # row 7 is now a cell of its own + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9, conf_level = 0.95)) + expect_length(r$warnings, 0L) + out <- r$value + rec <- attr(out, "pooled")$columns$resp_z + i <- which(out$cell_id == 999L) + expect_identical(out$n[i], 1L) + expect_identical(out$resp_mean_z[i], L$z[7L]) + # The plain columns of a one-row cell are as they were: no spread, no error. + expect_true(all(is.na(c(out$..sd_resp_z[i], out$..se_resp_z[i], out$..ci_lo_resp_z[i], + out$..ci_hi_resp_z[i])))) + # Its pooled value: the weight of one row on its value, the rest on its target. + w1 <- rec$tau2 / (rec$tau2 + rec$sigma2) + expect_equal(out$..pooled_w_resp_z[i], w1, tolerance = 1e-12) + expect_identical(out$..pooled_w_resp_z[i], min(out$..pooled_w_resp_z)) + expect_equal(out$..pooled_resp_z[i], w1 * L$z[7L] + (1 - w1) * out$..pooled_target_resp_z[i], + tolerance = 1e-12) + expect_false(is.na(out$..pooled_target_resp_z[i])) + expect_identical(rec$share_alone, 1 / 720) + # Left out, the row is predicted by the target of its cell. + e <- .pe_residuals(L$z, L$cell_id, out, rec, "resp_z") + expect_equal(e[7L], L$z[7L] - out$..pooled_target_resp_z[i], tolerance = 1e-12) + expect_equal(rec$loo, mean(e^2), tolerance = 1e-10) + # The interval has the offsets of every other cell. + expect_identical(out$..obs_lo_resp_z[i], out$..pooled_resp_z[i] + rec$offsets[1L]) + expect_identical(out$..obs_hi_resp_z[i], out$..pooled_resp_z[i] + rec$offsets[2L]) + expect_equal(rec$offsets, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + tolerance = 1e-10) + expect_equal(unique(round(out$..obs_hi_resp_z - out$..obs_lo_resp_z, 10)), + round(diff(rec$offsets), 10)) +}) + +test_that("a cell with no scored row of a column gets NA, and is no cell's neighbour", { + L <- .pe_layer() + L$p <- L$z + 1 + cell <- 23L + L$p[L$cell_id == cell] <- NA # every row of the cell misses p + r <- .pe_catch(.pe_pooled(L, "z", "p", obs_level = 0.9)) + expect_length(r$warnings, 0L) + out <- r$value + i <- which(out$cell_id == cell) + # No value is made up from the neighbours, and no interval. + for (col in grep("pred_p$", .pe_new(out), value = TRUE)) { + expect_identical(out[[col]][i], NA_real_, info = col) + expect_false(anyNA(out[[col]][-i]), info = col) + } + expect_false(is.na(out$..pooled_resp_z[i])) + expect_true(is.nan(out$pred_mean_p[i]) || is.na(out$pred_mean_p[i])) + expect_identical(attr(out, "pooled")$columns$pred_p$cells, 59L) + # The other cells' values are those of a layer without the cell. + less <- .pe_pooled(L[L$cell_id != cell, ], predictor_vars = "p", obs_level = 0.9) + for (col in grep("pred_p$", .pe_new(out), value = TRUE)) + expect_identical(out[[col]][-i], less[[col]], info = col) + # A polygon no row fell in: NA in the joined frame. + squares <- sf::st_sf(cell_id = c(cell, 5000L, 1L), + geometry = sf::st_sfc(lapply(1:3, function(k) sf::st_polygon(list( + cbind(c(0, 1, 1, 0, 0) + 2 * k, c(0, 0, 1, 1, 0))))), crs = 32617)) + joined <- suppressWarnings(.pe_pooled(L, "z", "p", obs_level = 0.9, cells_sf = squares)) + expect_identical(joined$cell_id, c(cell, 5000L, 1L)) + expect_true(all(is.na(sf::st_drop_geometry(joined)[2L, .pe_new(joined)]))) + expect_identical(joined$..pooled_resp_z[c(1L, 3L)], out$..pooled_resp_z[match(c(cell, 1L), out$cell_id)]) + expect_identical(joined$..pooled_pred_p[1L], NA_real_) +}) + + +# ---- Rows that take no part ----------------------------------------------------- + +test_that("rows with a missing or infinite value are not rows of the column", { + L <- .pe_layer() + L$z[c(3L, 9L)] <- c(NA, NaN) + L$z[11L] <- Inf + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_nonfinite") + expect_identical(.pe_fields(r$warnings[[1L]])[c("n", "columns")], list(n = 1L, columns = "z")) + rec <- attr(r$value, "pooled")$columns$resp_z + expect_identical(rec$n, 717L) + keep <- !(seq_len(nrow(L)) %in% c(3L, 9L, 11L)) + want <- .pe_pooled(L[keep, ], "z", obs_level = 0.9) + for (col in .pe_new(want)) expect_identical(r$value[[col]], want[[col]], info = col) + expect_identical(rec, attr(want, "pooled")$columns$resp_z) +}) + +test_that("rows without a cell take no part, and their summary row has NA in the new columns", { + L <- .pe_layer() + loose <- c(4L, 100L, 250L, 400L, 555L) + K <- L + K$cell_id[loose] <- NA + r <- .pe_catch(.pe_pooled(K, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + out <- r$value + i <- which(is.na(out$cell_id)) + expect_length(i, 1L) + expect_identical(out$n[i], 5L) + expect_equal(out$resp_mean_z[i], mean(L$z[loose])) # the plain columns are kept + expect_false(is.na(out$..se_resp_z[i])) + expect_true(all(is.na(sf::st_drop_geometry(out)[i, .pe_new(out)]))) + want <- .pe_pooled(L[-loose, ], "z", obs_level = 0.9) + for (col in .pe_new(want)) expect_identical(out[[col]][-i], want[[col]], info = col) + expect_identical(attr(out, "pooled")$columns$resp_z, attr(want, "pooled")$columns$resp_z) + expect_identical(attr(out, "pooled")$columns$resp_z$n, 715L) +}) + +test_that("rows without a location count in the plain columns and not in the pooled ones", { + L <- .pe_layer() + L$p <- L$z * 2 + # Two rows of one cell and one of another lose their point. + nowhere <- c(which(L$cell_id == 17L)[1:2], which(L$cell_id == 44L)[1L]) + L$p[nowhere[2L]] <- NA # this row has no value of p + g <- sf::st_geometry(L) + for (i in nowhere) g[[i]] <- sf::st_point() + sf::st_geometry(L) <- g + r <- .pe_catch(.pe_pooled(L, "z", "p", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_rows_skipped") + # Rows are counted once, whichever columns they have a value of. + # The columns are those with such a row, in the order of the frame. + expect_identical(.pe_fields(r$warnings[[1L]]), + list(n = 3L, cells = 2L, columns = c("z", "p"))) + only_z <- L + only_z$p[nowhere] <- NA + expect_identical(.pe_fields(.pe_catch(.pe_pooled(only_z, "z", "p"))$warnings[[1L]]), + list(n = 3L, cells = 2L, columns = "z")) + rec <- attr(r$value, "pooled")$columns + expect_identical(c(rec$resp_z$skipped, rec$pred_p$skipped), c(3L, 2L)) + expect_identical(c(rec$resp_z$n, rec$pred_p$n), c(717L, 717L)) + # n and the plain mean still hold the rows. + plain <- summarize_by_cell(L, "z", "p", id_col = "cell_id", estimate = "mean") + expect_identical(r$value$n, plain$n) + expect_identical(sum(r$value$n), 720L) + expect_identical(r$value$resp_mean_z, plain$resp_mean_z) + # The pooled columns are those of the located rows. + want <- .pe_pooled(L[-nowhere, ], "z", "p", obs_level = 0.9) + for (col in .pe_new(want)) expect_identical(r$value[[col]], want[[col]], info = col) + # A row without a location and without a cell is no row of any cell: nothing is said. + M <- .pe_layer() + g <- sf::st_geometry(M); g[[12L]] <- sf::st_point(); sf::st_geometry(M) <- g + M$cell_id[12L] <- NA + expect_length(.pe_catch(.pe_pooled(M, "z"))$warnings, 0L) + # Nor is a row without a location and without a value of any pooled column. + M <- .pe_layer() + g <- sf::st_geometry(M); g[[12L]] <- sf::st_point(); sf::st_geometry(M) <- g + M$z[12L] <- NA + expect_length(.pe_catch(.pe_pooled(M, "z"))$warnings, 0L) +}) + + +# ---- Pooling unavailable ---------------------------------------------------------- + +test_that("a layer without geometry gets NA pooled columns and one warning", { + L <- .pe_layer() + L$p <- L$z + 2 + df <- sf::st_drop_geometry(L) + r <- .pe_catch(.pe_pooled(df, "z", "p", obs_level = 0.9, conf_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + w <- r$warnings[[1L]] + expect_identical(.pe_fields(w), list(reason = "no coordinates", columns = c("z", "p"))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): estimate = \"pooled\" needs the observations' locations, and ", + "`assigned_points_sf` carries no geometry: the pooled columns are NA. The plain ", + "columns are unaffected.")) + expect_null(conditionCall(w)) + out <- r$value + expect_length(.pe_new(out), 10L) + for (col in .pe_new(out)) expect_identical(out[[col]], rep(NA_real_, nrow(out)), info = col) + rec <- attr(out, "pooled") + expect_true(is.na(rec$crs)) + for (nm in c("resp_z", "pred_p")) { + expect_identical(rec$columns[[nm]]$status, "no coordinates", info = nm) + expect_identical(rec$columns[[nm]]$n, 0L, info = nm) + expect_identical(rec$columns[[nm]]$offsets, c(NA_real_, NA_real_), info = nm) + } + # It is a warning and not an error, and the plain columns are the ones of + # the call of plain means. + plain <- summarize_by_cell(df, "z", "p", id_col = "cell_id", conf_level = 0.9, + estimate = "mean") + expect_identical(setdiff(names(out), .pe_new(out)), names(plain)) + for (col in names(plain)) expect_identical(out[[col]], plain[[col]], info = col) + # The table of intervals is there all the same. + expect_identical(nrow(attr(out, "intervals")), 2L) +}) + +test_that("a column with no row that has a value, a cell and a location is NA", { + L <- .pe_layer() + L$none <- NA_real_ + r <- .pe_catch(.pe_pooled(L, "none", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "no located value", columns = "none")) + expect_identical( + conditionMessage(r$warnings[[1L]]), + paste0("summarize_by_cell(): the pooled columns of 'none' are NA: no row has a value of ", + "it, a cell and a location.")) + out <- r$value + for (col in .pe_new(out)) expect_identical(out[[col]], rep(NA_real_, 60L), info = col) + rec <- attr(out, "pooled")$columns$resp_none + expect_identical(c(rec$n, rec$cells, rec$skipped), c(0L, 0L, 0L)) + expect_identical(rec$status, "no located value") + expect_identical(c(rec$sigma2, rec$tau2, rec$loo), rep(NA_real_, 3L)) + # A layer of no rows: a frame of no rows with the columns, and the same status. + r <- .pe_catch(.pe_pooled(L[0L, ], "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + expect_identical(r$warnings[[1L]]$reason, "no located value") + expect_identical(nrow(r$value), 0L) + expect_length(.pe_new(r$value), 5L) +}) + +test_that("with no cell of two rows the pooled columns are NA", { + # Twenty locations with two rows each, every row a cell of its own. + L <- .pe_layer()[c(1:20, 1:20), ] + L$z[21:40] <- L$z[21:40] + 0.25 + L$cell_id <- 101:140 + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + # One warning: a column without an interval is not warned about its + # repeated locations, nor about the few residuals it would rest on. + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + expect_identical(attr(r$value, "pooled")$columns$resp_z$repeated, 40L) + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "no cell holds two values", columns = "z", n = c(z = 40L), + cells = c(z = 40L))) + out <- r$value + for (col in .pe_new(out)) expect_identical(out[[col]], rep(NA_real_, 40L), info = col) + rec <- attr(out, "pooled")$columns$resp_z + expect_identical(rec$status, "no cell holds two values") + expect_identical(c(rec$n, rec$cells, rec$df), c(40L, 40L, 0L)) + expect_identical(rec$share_alone, 1) + expect_identical(rec$sigma2, NA_real_) + expect_identical(out$resp_mean_z, L$z) # the plain mean of each row's cell + # Five such cells are few cells, and nothing is said of their targets: + # there are none. + r <- .pe_catch(.pe_pooled(L[1:5, ], "z")) + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + expect_identical(r$warnings[[1L]]$cells, c(z = 5L)) + # One cell of two rows is enough for a fit, and then the weights rest on one + # value beyond one per cell. + L$cell_id[2L] <- 101L + r <- .pe_catch(.pe_pooled(L, "z")) + expect_true("spatialkit_pool_few_df" %in% .pe_classes(r)) + expect_false("spatialkit_pool_unavailable" %in% .pe_classes(r)) + expect_identical(.pe_of(r, "spatialkit_pool_few_df")[[1L]]$df, c(z = 1L)) + expect_false(anyNA(r$value$..pooled_resp_z)) +}) + +test_that("the limit on an exact search is 2e9 pairs, and a status in the summary", { + expect_identical(.EXACT_PAIRS_MAX, 2e9) + expect_identical(.exact_pairs_max(), 2e9) + # The neighbours of K cells are K^2 pairs: about 44,700 cells at the limit. + expect_identical(floor(sqrt(.EXACT_PAIRS_MAX)), 44721) + L <- .pe_layer() + .pe_without_fnn() + withr::local_options(spatialkit.exact_pairs_max = 3599) # 60 cells are 3,600 pairs + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_unavailable") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "work limit", columns = "z", work = 3600, limit = 3599, + cells = c(z = 60L))) + expect_match(conditionMessage(r$warnings[[1L]]), "Install FNN: the result is the same.", + fixed = TRUE) + expect_identical(attr(r$value, "pooled")$columns$resp_z$status, "work limit") + expect_true(all(is.na(r$value$..obs_lo_resp_z))) + withr::local_options(spatialkit.exact_pairs_max = 3600) + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + expect_identical(attr(r$value, "pooled")$columns$resp_z$status, "ok") +}) + + +# ---- One cell ------------------------------------------------------------------------ + +test_that("one cell: the value is the plain mean, and the interval is read from the plain residuals", { + L <- .pe_layer()[1:150, ] + L$cell_id <- 5L + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + w <- r$warnings[[1L]] + expect_identical(.pe_fields(w), list(reason = "one cell", columns = "z", n = c(z = 150L))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): the values of 'z' lie in one cell, so there is nothing to ", + "pool toward: the pooled value is the plain mean and its weight is 1.")) + out <- r$value + expect_identical(nrow(out), 1L) + expect_equal(out$..pooled_resp_z, mean(L$z), tolerance = 1e-12) + expect_equal(out$..pooled_resp_z, out$resp_mean_z, tolerance = 1e-12) + expect_identical(out$..pooled_w_resp_z, 1) + expect_identical(out$..pooled_target_resp_z, NA_real_) + rec <- attr(out, "pooled")$columns$resp_z + expect_identical(rec$status, "one cell") + expect_identical(rec$tau2, NA_real_) + expect_identical(c(rec$cells, rec$neighbours, rec$df), c(1L, 0L, 149L)) + expect_equal(rec$sigma2, stats::var(L$z), tolerance = 1e-12) + expect_identical(rec$structured, NA) + # The residuals are the plain ones, (y - m) n / (n - 1). + e <- (L$z - mean(L$z)) * 150 / 149 + expect_equal(rec$loo, mean(e^2), tolerance = 1e-12) + expect_equal(rec$loo_one_cell, rec$loo, tolerance = 1e-12) + expect_equal(rec$offsets, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + tolerance = 1e-10) + expect_identical(c(out$..obs_lo_resp_z, out$..obs_hi_resp_z), out$..pooled_resp_z + rec$offsets) + # Twenty rows in one cell: nothing is said of the values beyond one per + # cell, since no weight rests on them. + r <- .pe_catch(.pe_pooled(L[1:20, ], "z")) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + expect_identical(attr(r$value, "pooled")$columns$resp_z$df, 19L) +}) + +test_that("one row in one cell: a value, a weight of 1, and no spread, error or interval", { + L <- .pe_layer()[42L, ] + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "one cell", columns = "z", n = c(z = 1L))) + out <- r$value + expect_identical(out$..pooled_resp_z, L$z) + expect_identical(out$..pooled_w_resp_z, 1) + expect_identical(c(out$..pooled_target_resp_z, out$..obs_lo_resp_z, out$..obs_hi_resp_z), + rep(NA_real_, 3L)) + rec <- attr(out, "pooled")$columns$resp_z + expect_identical(rec$status, "one cell") + expect_identical(c(rec$sigma2, rec$tau2, rec$loo, rec$loo_se, rec$loo_one_cell), + rep(NA_real_, 5L)) + expect_identical(rec$offsets, c(NA_real_, NA_real_)) + expect_identical(c(rec$n, rec$cells, rec$df), c(1L, 1L, 0L)) + expect_identical(rec$share_alone, 1) +}) + + +# ---- Few cells, and few values beyond one per cell ------------------------------------- + +test_that("with 2 to 9 cells the target is the mean of all the other cells, with a warning", { + base <- .pe_layer() + for (K in c(2L, 3L, 9L)) { + L <- base + tag <- sprintf("%d cells", K) + # K bands of equal width from west to east, so their counts differ. + L$cell_id <- as.integer(cut(sf::st_coordinates(L)[, 1L], K, labels = FALSE)) + r <- .pe_catch(.pe_pooled(L, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_few_cells", info = tag) + out <- r$value + expect_gt(length(unique(out$n)), 1L) + expect_gt(diff(range(out$..pooled_w_resp_z)), 0) + w <- r$warnings[[1L]] + expect_identical(.pe_fields(w), + list(columns = "z", cells = c(z = K), own_weight = c(z = min(out$..pooled_w_resp_z))), + info = tag) + expect_identical( + conditionMessage(w), + sprintf(paste0( + "summarize_by_cell(): 'z' has values in fewer than 10 cells (%d), so each cell's target ", + "is the mean of all the other cells, not of cells near it. A cell with a small own ", + "weight then gets a pooled value on the far side of the overall mean from its plain ", + "mean, and two cells can change order. The `..pooled_w_*` columns hold the weights; ", + "estimate = \"mean\" gives the plain means."), K)) + # Each target is the mean of every row outside the cell. + S <- as.numeric(tapply(L$z, L$cell_id, sum)) + expect_equal(out$..pooled_target_resp_z, (sum(L$z) - S) / (720 - out$n), tolerance = 1e-12, + info = tag) + rec <- attr(out, "pooled")$columns$resp_z + expect_identical(c(rec$cells, rec$neighbours), c(K, K - 1L), info = tag) + expect_identical(rec$status, "ok", info = tag) + # The interval is computed. + expect_false(anyNA(c(out$..obs_lo_resp_z, out$..obs_hi_resp_z)), info = tag) + expect_equal(rec$offsets, + stats::quantile(.pe_residuals(L$z, L$cell_id, out, rec, "resp_z"), + c(0.05, 0.95), names = FALSE, type = 7), tolerance = 1e-10) + } + # Ten cells are not few. + L <- base + L$cell_id <- as.integer(cut(sf::st_coordinates(L)[, 1L], 10L, labels = FALSE)) + expect_false("spatialkit_pool_few_cells" %in% .pe_classes(.pe_catch(.pe_pooled(L, "z")))) +}) + +test_that("two cells with no difference between them: the pooled values are the plain means swapped", { + # 60 rows in each of two cells, one distribution for both. + d <- local({ + .pe_seed(3011) + data.frame(x = c(stats::runif(60, 0, 100), stats::runif(60, 200, 300)), + y = stats::runif(120, 0, 100), v = stats::rnorm(120)) + }) + L <- .pe_points(d$x, d$y, data.frame(v = d$v, cell_id = rep(c("east", "west"), each = 60L))) + r <- .pe_catch(.pe_pooled(L, "v", obs_level = 0.9)) + out <- r$value + rec <- attr(out, "pooled")$columns$resp_v + expect_identical(rec$tau2, 0) + expect_identical(rec$status, "no signal between cells") + # Three events for one column, in the order of the design's table. + expect_identical(.pe_classes(r), c("spatialkit_pool_degenerate", "spatialkit_pool_few_cells", + "spatialkit_no_structure")) + expect_identical(.pe_of(r, "spatialkit_pool_degenerate")[[1L]]$reason, "no signal between cells") + expect_identical(.pe_of(r, "spatialkit_pool_few_cells")[[1L]]$own_weight, c(v = 0)) + # The two plain means differ, and each cell's pooled value is the other's mean. + expect_gt(abs(diff(out$resp_mean_v)), 0.01) + expect_equal(out$..pooled_resp_v, rev(out$resp_mean_v), tolerance = 1e-12) + expect_identical(out$..pooled_w_resp_v, c(0, 0)) + expect_identical(out$..pooled_resp_v, out$..pooled_target_resp_v) + # So each lies on the far side of the overall mean from its own plain mean. + overall <- mean(L$v) + expect_true(all(sign(out$..pooled_resp_v - overall) == -sign(out$resp_mean_v - overall))) + # The interval is computed: the residuals are real. + expect_false(anyNA(c(out$..obs_lo_resp_v, out$..obs_hi_resp_v))) + expect_gt(diff(rec$offsets), 1) +}) + +test_that("few values beyond one per cell: the values are returned with spatialkit_pool_few_df", { + # 120 cells of which 117 hold one row and 3 hold two. + d <- local({ + .pe_seed(3002) + x <- stats::runif(123, 0, 1e5); y <- stats::runif(123, 0, 1e5) + data.frame(x = x, y = y, v = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(123, 0, 0.3)) + }) + L <- .pe_points(d$x, d$y, data.frame(v = d$v, cell_id = c(1:120, 1:3))) + r <- .pe_catch(.pe_pooled(L, "v")) + # Everything the layer raises, in the order of the design's table. + expect_identical(.pe_classes(r), c("spatialkit_pool_degenerate", "spatialkit_pool_few_df", + "spatialkit_no_structure")) + w <- .pe_of(r, "spatialkit_pool_few_df") + expect_length(w, 1L) + expect_identical(.pe_fields(w[[1L]]), + list(columns = "v", needed = 30L, df = c(v = 3L), n = c(v = 123L), + cells = c(v = 120L))) + expect_identical( + conditionMessage(w[[1L]]), + paste0("summarize_by_cell(): the spread of 'v' inside a cell is estimated from fewer than ", + "30 values beyond one per cell (3), and every own weight rests on it: the pooled ", + "values and their weights are unstable.")) + rec <- attr(r$value, "pooled")$columns$resp_v + expect_identical(rec$df, 3L) + expect_equal(rec$share_alone, 117 / 123) + # sigma2 is the spread of the three pairs, and the values are as computed. + pairs <- L$v[c(1:3, 121:123)] + expect_equal(rec$sigma2, sum((pairs[1:3] - pairs[4:6])^2 / 2) / 3, tolerance = 1e-12) + expect_false(anyNA(r$value$..pooled_resp_v)) + expect_true(all(r$value$..pooled_w_resp_v >= 0 & r$value$..pooled_w_resp_v <= 1)) + # The field is not called structureless. Its cells predict a left-out row + # several times better than one mean; what fails is the F test, which has + # three values beyond one per cell behind it, and the warning says that. + expect_false(rec$structured) + expect_gt(rec$loo_one_cell, 3 * rec$loo) + expect_gte(rec$structure_p, 0.05) + ns <- .pe_of(r, "spatialkit_no_structure")[[1L]] + expect_identical(ns$beats, c(v = TRUE)) + expect_identical( + conditionMessage(ns), + sprintf(paste0( + "summarize_by_cell(): the pooled values of 'v' predict a left-out observation better ", + "than one mean for all rows, but the F test does not tell the cell means from one mean ", + "(leave-one-out error %s against %s; F test of the cells against one mean, p = %s; ", + "median own weight %.2f), so no spatial structure these cells can use is shown. The ", + "values are returned."), + format(signif(rec$loo, 4)), format(signif(rec$loo_one_cell, 4)), + format(signif(rec$structure_p, 2)), rec$own_weight)) + expect_false(grepl("no better than one mean", conditionMessage(ns), fixed = TRUE)) + expect_false(grepl("looks smooth", conditionMessage(ns), fixed = TRUE)) + # Beside a column of white noise, for which one mean does as well as the + # cells: one warning, a sentence for each of the two, and the numbers of + # both behind the sentences, in the order of the frame. + L$wn <- local({ .pe_seed(3021); stats::rnorm(123) }) + r2 <- .pe_catch(.pe_pooled(L, "v", "wn")) + ns2 <- .pe_of(r2, "spatialkit_no_structure") + expect_length(ns2, 1L) + expect_identical(ns2[[1L]]$columns, c("v", "wn")) + expect_identical(ns2[[1L]]$beats, c(v = TRUE, wn = FALSE)) + rw <- attr(r2$value, "pooled")$columns$pred_wn + expect_lt(rw$loo_one_cell, rw$loo) + piece <- function(r1) sprintf( + paste0("'%s': leave-one-out error %s against %s; F test of the cells against one mean, ", + "p = %s; median own weight %.2f."), + r1$column, format(signif(r1$loo, 4)), format(signif(r1$loo_one_cell, 4)), + format(signif(r1$structure_p, 2)), r1$own_weight) + expect_identical( + conditionMessage(ns2[[1L]]), + paste(paste0( + "summarize_by_cell(): the pooled values of 'wn' predict a left-out observation no better ", + "than one mean for all rows, so it shows no spatial structure these cells can use. The ", + "values are returned. A map of them looks smooth because each is mostly its neighbours' ", + "mean, not because the response varies smoothly. The pooled values of 'v' predict a ", + "left-out observation better than one mean for all rows, but the F test does not tell ", + "the cell means from one mean, so no spatial structure these cells can use is shown for ", + "it either."), piece(rec), piece(rw))) + # Thirty such values are enough; twenty-nine are not. + d <- local({ + .pe_seed(3004) + x <- stats::runif(90, 0, 1e5); y <- stats::runif(90, 0, 1e5) + data.frame(x = x, y = y, v = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(90, 0, 0.3)) + }) + M <- .pe_points(d$x, d$y, data.frame(v = d$v, cell_id = c(1:60, 1:30))) + r30 <- .pe_catch(.pe_pooled(M, "v")) + expect_identical(attr(r30$value, "pooled")$columns$resp_v$df, 30L) + expect_false("spatialkit_pool_few_df" %in% .pe_classes(r30)) + r29 <- .pe_catch(.pe_pooled(M[-90L, ], "v")) + expect_identical(.pe_of(r29, "spatialkit_pool_few_df")[[1L]]$df, c(v = 29L)) +}) + + +# ---- No spread, no signal, no structure -------------------------------------------------- + +test_that("a constant column: weights of 1, a zero-width interval, no leave-one-out error", { + L <- .pe_layer() + L$k <- 0.1 + r <- .pe_catch(.pe_pooled(L, "k", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "no spread inside any cell", columns = "k", constant = c(k = TRUE))) + out <- r$value + expect_identical(out$..pooled_w_resp_k, rep(1, 60L)) + expect_equal(out$..pooled_resp_k, rep(0.1, 60L), tolerance = 1e-14) + # Zero width: both ends are the value itself. + expect_identical(out$..obs_lo_resp_k, out$..pooled_resp_k) + expect_identical(out$..obs_hi_resp_k, out$..pooled_resp_k) + rec <- attr(out, "pooled")$columns$resp_k + expect_identical(rec$status, "no spread inside any cell") + expect_true(rec$constant) + expect_identical(c(rec$sigma2, rec$tau2), c(0, 0)) + expect_identical(c(rec$loo, rec$loo_se, rec$loo_one_cell), rep(NA_real_, 3L)) + expect_identical(rec$offsets, c(0, 0)) + expect_identical(rec$structured, NA) + expect_identical(rec$own_weight, 1) +}) + +test_that("a column constant inside every cell and not overall: weights of 1, residuals of 0", { + L <- .pe_layer() + L$step <- 0.1 * L$cell_id # one value a cell, 60 values in all + r <- .pe_catch(.pe_pooled(L, "step", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(reason = "no spread inside any cell", columns = "step", + constant = c(step = FALSE))) + out <- r$value + rec <- attr(out, "pooled")$columns$resp_step + expect_identical(rec$status, "no spread inside any cell") + expect_false(rec$constant) + expect_identical(rec$sigma2, 0) + expect_gt(rec$tau2, 0) + expect_identical(out$..pooled_w_resp_step, rep(1, 60L)) + expect_equal(out$..pooled_resp_step, 0.1 * out$cell_id, tolerance = 1e-12) + # Every row shares its cell, so every residual is 0: an error of 0 and an + # interval of no width. + expect_identical(c(rec$loo, rec$loo_se), c(0, 0)) + expect_identical(rec$offsets, c(0, 0)) + expect_identical(out$..obs_lo_resp_step, out$..pooled_resp_step) + expect_gt(rec$loo_one_cell, 0) + # With a fifth of the rows alone in their cell, those rows are predicted by + # their targets and the ends of the interval are theirs. + alone <- seq(1L, nrow(L), by = 5L) + L$cell_id[alone] <- 1000L + seq_along(alone) + L$step <- 0.1 * (L$cell_id %% 97L) + r <- .pe_catch(.pe_pooled(L, "step", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + out <- r$value + rec <- attr(out, "pooled")$columns$resp_step + expect_identical(rec$status, "no spread inside any cell") + expect_equal(rec$share_alone, 0.2) + e <- L$step - out$..pooled_target_resp_step[match(L$cell_id, out$cell_id)] + e[!(seq_len(nrow(L)) %in% alone)] <- 0 + expect_equal(rec$loo, mean(e^2), tolerance = 1e-12) + expect_gt(rec$loo, 0) + expect_equal(rec$offsets, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + tolerance = 1e-10) + expect_lt(rec$offsets[1L], 0); expect_gt(rec$offsets[2L], 0) + # With 3 percent of the rows alone, fewer than 5 percent of the residuals + # lie on either side of 0, and both ends are 0. + L <- .pe_layer() + alone <- seq(1L, nrow(L), by = 34L) + L$cell_id[alone] <- 1000L + seq_along(alone) + L$step <- 0.1 * (L$cell_id %% 97L) + rec <- attr(suppressWarnings(.pe_pooled(L, "step", obs_level = 0.9)), "pooled")$columns$resp_step + expect_lt(rec$share_alone, 0.05) + expect_gt(rec$loo, 0) + expect_identical(rec$offsets, c(0, 0)) +}) + +test_that("a column without spread is warned of that, and of nothing its weights rest on", { + # 30 rows in 5 cells: few cells, 25 values beyond one per cell, and fewer + # residuals than a 90 percent interval wants. `v` varies inside the cells, + # `k` is constant, `step` is constant inside every cell and not overall. + d <- local({ + .pe_seed(3012) + x <- stats::runif(30, 0, 1e5); y <- stats::runif(30, 0, 1e5) + data.frame(x = x, y = y, noise = stats::rnorm(30, 0, 0.2)) + }) + L <- .pe_points(d$x, d$y, data.frame(cell_id = rep(1:5, 6L))) + L$v <- 2 * L$cell_id + d$noise + L$k <- 0.1 + L$step <- 0.1 * L$cell_id + # The column with spread raises the three, so the layer is one on which + # they are due. + r <- .pe_catch(.pe_pooled(L, "v", obs_level = 0.9)) + expect_identical(.pe_classes(r), c("spatialkit_pool_few_cells", "spatialkit_pool_few_df", + "spatialkit_few_residuals")) + expect_identical(attr(r$value, "pooled")$columns$resp_v$status, "ok") + # The count the interval wants is the first whole number at which five + # residuals are expected beyond each end: 34 at a level of 0.7, where + # 5 / 0.15 is 33.3. + fr <- .pe_of(.pe_catch(.pe_pooled(L, "v", obs_level = 0.7)), "spatialkit_few_residuals")[[1L]] + expect_identical(fr$needed, 34L) + expect_match(conditionMessage(fr), + "the 70% interval of 'v' rests on fewer than 34 leave-one-out residuals (30)", + fixed = TRUE) + # A constant column: its weights are set to 1, its spread to 0 and its + # residuals to 0. One warning says so, and no other. + r <- .pe_catch(.pe_pooled(L, "k", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_degenerate") + rec <- attr(r$value, "pooled")$columns$resp_k + expect_identical(c(rec$cells, rec$df, rec$n), c(5L, 25L, 30L)) + expect_identical(rec$offsets, c(0, 0)) + expect_identical(r$value$..pooled_w_resp_k, rep(1, 5L)) + # Constant inside every cell: nothing of the cells or of the values beyond + # one per cell. Its interval is read from residuals, so the count of + # those is still said. + r <- .pe_catch(.pe_pooled(L, "step", obs_level = 0.9)) + expect_identical(.pe_classes(r), c("spatialkit_pool_degenerate", "spatialkit_few_residuals")) + expect_identical(.pe_classes(.pe_catch(.pe_pooled(L, "step"))), "spatialkit_pool_degenerate") + # The three columns in one call: each warning names the columns it is true of. + r <- .pe_catch(.pe_pooled(L, "v", c("k", "step"), obs_level = 0.9)) + expect_identical(.pe_classes(r), c("spatialkit_pool_degenerate", "spatialkit_pool_few_cells", + "spatialkit_pool_few_df", "spatialkit_few_residuals")) + expect_identical(lapply(r$warnings, function(w) w$columns), + list(c("k", "step"), "v", "v", c("v", "step"))) + # Rows that share a location: said of the column whose interval is read + # from residuals, not of the constant one. + twice <- L[c(seq_len(30L), 1:5), ] + expect_identical(attr(suppressWarnings(.pe_pooled(twice, "k")), "pooled")$columns$resp_k$repeated, + 10L) + expect_identical(.pe_classes(.pe_catch(.pe_pooled(twice, "k", obs_level = 0.9))), + "spatialkit_pool_degenerate") + expect_true("spatialkit_repeated_locations" %in% + .pe_classes(.pe_catch(.pe_pooled(twice, "v", obs_level = 0.9)))) +}) + +test_that("no signal between cells: every weight is 0 and each value is its target", { + L <- .pe_layer() + L$w <- local({ .pe_seed(3101); stats::rnorm(nrow(L)) }) + r <- .pe_catch(.pe_pooled(L, "w", obs_level = 0.9)) + expect_identical(.pe_classes(r), c("spatialkit_pool_degenerate", "spatialkit_no_structure")) + rec <- attr(r$value, "pooled")$columns$resp_w + expect_identical(rec$status, "no signal between cells") + expect_identical(rec$tau2, 0) + expect_gt(rec$sigma2, 0) + w <- r$warnings[[1L]] + expect_identical(.pe_fields(w), list(reason = "no signal between cells", columns = "w", + sigma2 = c(w = rec$sigma2))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): every own weight of 'w' is 0: the cell means differ from ", + "their neighbours' means by no more than the spread inside the cells explains. Each ", + "pooled value is then the mean of the cell's nearest cells and holds none of the ", + "cell's own values.")) + out <- r$value + expect_identical(out$..pooled_w_resp_w, rep(0, 60L)) + expect_identical(out$..pooled_resp_w, out$..pooled_target_resp_w) + expect_false(isTRUE(all.equal(out$..pooled_resp_w, out$resp_mean_w))) + # The interval is computed: the residuals are those of the targets. + e <- L$w - out$..pooled_target_resp_w[match(L$cell_id, out$cell_id)] + expect_equal(rec$offsets, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + tolerance = 1e-10) + expect_equal(rec$loo, mean(e^2), tolerance = 1e-12) + expect_false(anyNA(out$..obs_lo_resp_w)) +}) + +test_that("a response without structure: the values and the interval are returned, with a warning", { + L <- .pe_layer() + L$w <- local({ .pe_seed(3102); stats::rnorm(nrow(L)) }) + r <- .pe_catch(.pe_pooled(L, "w", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_no_structure") + out <- r$value + rec <- attr(out, "pooled")$columns$resp_w + expect_identical(rec$status, "ok") + expect_false(rec$structured) + expect_gt(rec$tau2, 0) + # One mean for all rows does as well as the cells, to the margin of the rule. + expect_lte(rec$loo_one_cell, rec$loo * 1.02) + expect_false(anyNA(out$..pooled_resp_w)) + # The interval is then about as wide as the response's own 5th to 95th percentiles. + own <- diff(stats::quantile(L$w, c(0.05, 0.95), names = FALSE)) + expect_gt(diff(rec$offsets) / own, 0.9) + expect_lt(diff(rec$offsets) / own, 1.15) + # Each value is mostly its neighbours' mean. + expect_lt(rec$own_weight, 0.4) + # The field of the same layer is structured, and says nothing. + expect_true(attr(.pe_pooled(L, "z"), "pooled")$columns$resp_z$structured) +}) + + +# ---- Locations that repeat or coincide ------------------------------------------------------ + +test_that("rows at one location each count, and are left out one at a time", { + # 240 locations with three rows each. + d <- local({ + .pe_seed(3005) + x <- rep(stats::runif(240, 0, 1e5), 3L); y <- rep(stats::runif(240, 0, 1e5), 3L) + data.frame(x = x, y = y, v = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(720, 0, 0.5)) + }) + L <- .pe_points(d$x, d$y, data.frame(v = d$v)) + L$cell_id <- as.integer(6 * floor(d$x / 1e4) + floor(d$y / (1e5 / 6)) + 1) + r <- .pe_catch(.pe_pooled(L, "v", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_repeated_locations") + expect_identical(.pe_fields(r$warnings[[1L]]), + list(columns = "v", n = c(v = 720L), total = c(v = 720L))) + out <- r$value + rec <- attr(out, "pooled")$columns$resp_v + expect_identical(rec$repeated, 720L) + expect_identical(sum(out$n), 720L) # each row counts in its cell + expect_true(all(out$n %% 3L == 0L)) + # One row is left out and the others at its location stay. + e <- .pe_residuals(L$v, L$cell_id, out, rec, "resp_v") + expect_equal(rec$loo, mean(e^2), tolerance = 1e-10) + expect_equal(rec$offsets, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + tolerance = 1e-10) + # Without the level the count is in the record and nothing is said. + quiet <- .pe_catch(.pe_pooled(L, "v")) + expect_length(quiet$warnings, 0L) + expect_identical(attr(quiet$value, "pooled")$columns$resp_v$repeated, 720L) + # A layer whose locations are all different counts none. + expect_identical(attr(.pe_pooled(.pe_layer(), "z"), "pooled")$columns$resp_z$repeated, 0L) +}) + +test_that("rows at one location in different cells each count in their own cell", { + # 360 locations, two rows at each, the two in cells of two overlapping + # sets: 20 cells from west to east and 12 from south to north. + d <- local({ + .pe_seed(3006) + x <- stats::runif(360, 0, 1e5); y <- stats::runif(360, 0, 1e5) + data.frame(x = rep(x, 2L), y = rep(y, 2L), + v = sin(rep(x, 2L) / 2e4) + cos(rep(y, 2L) / 1.5e4) + stats::rnorm(720, 0, 0.4)) + }) + cell <- c(as.integer(floor(d$x[1:360] / 5e3)) + 1L, + 100L + as.integer(floor(d$y[361:720] / (1e5 / 12))) + 1L) + L <- .pe_points(d$x, d$y, data.frame(v = d$v, cell_id = cell)) + r <- .pe_catch(.pe_pooled(L, "v")) + expect_length(r$warnings, 0L) + out <- r$value + expect_identical(nrow(out), 32L) + expect_identical(sum(out$n[out$cell_id < 100L]), 360L) + expect_identical(sum(out$n[out$cell_id > 100L]), 360L) + expect_identical(attr(out, "pooled")$columns$resp_v$repeated, 720L) + # The values are the engine's on that grouping. + xy <- unname(sf::st_coordinates(L)[, 1:2]) + u <- sort(unique(cell)) + f <- .pool_fit(d$v, match(cell, u), length(u), xy, want = "pooled") + expect_identical(out$..pooled_resp_v, f$value) + expect_identical(out$..pooled_target_resp_v, f$target) + # Cells of the two sets are each other's neighbours where their rows' + # centroids are near, whatever polygons they came from. + cen <- rowsum(xy, match(cell, u)) / tabulate(match(cell, u)) + nb <- .pe_neighbours(cen) + expect_true(any(u[nb[1L, ]] > 100L) && any(u[nb[1L, ]] < 100L)) +}) + +test_that("cells that share a centroid are not their own neighbours", { + # A 5 x 4 grid of cells of four rows each on whole metres, and two more cells + # whose rows have one centroid: (250, 250) for both. + g <- expand.grid(cx = seq(100, 900, by = 200), cy = seq(100, 700, by = 200)) + x <- c(rep(g$cx, each = 4L) + c(-20, 20, -20, 20), 240, 260, 250, 250) + y <- c(rep(g$cy, each = 4L) + c(-20, -20, 20, 20), 250, 250, 230, 270) + cell <- c(rep(seq_len(nrow(g)), each = 4L), 21L, 21L, 22L, 22L) + v <- local({ .pe_seed(3007); sin(x / 300) + cos(y / 250) + stats::rnorm(length(x), 0, 0.3) }) + L <- .pe_points(x, y, data.frame(v = v, cell_id = cell)) + out <- suppressWarnings(.pe_pooled(L, "v")) + cen <- rowsum(cbind(x, y), cell) / tabulate(cell) + expect_identical(unname(cen[21L, ]), unname(cen[22L, ])) + nb <- .pe_neighbours(unname(cen)) + expect_identical(nb[21L, 1L], 22L) # each is the other's nearest + expect_identical(nb[22L, 1L], 21L) + S <- as.numeric(rowsum(v, cell)); n <- tabulate(cell) + target <- rowSums(matrix(S[nb], 22L)) / rowSums(matrix(n[nb], 22L)) + expect_equal(out$..pooled_target_resp_v, target, tolerance = 1e-12) + # A cell that was its own neighbour would have its own rows in its target. + own <- (rowSums(matrix(S[nb[, -8L]], 22L)) + S) / (rowSums(matrix(n[nb[, -8L]], 22L)) + n) + expect_gt(abs(out$..pooled_target_resp_v[21L] - own[21L]), 1e-6) + # The exact search gives the kd-tree's answer. (Without FNN the call above + # ran on the exact search already.) + skip_if_not_installed("FNN") + exact <- local({ .pe_without_fnn(); suppressWarnings(.pe_pooled(L, "v")) }) + expect_identical(exact, out) +}) + +test_that("on gridded locations a tie between neighbours goes to the lower x, then the lower y", { + # A 30 x 20 lattice at 100 m in cells of 2 x 2 locations: 150 cells whose + # centroids are a lattice themselves, so candidate neighbours tie. + g <- expand.grid(i = 0:29, j = 0:19) + x <- 1000 + 100 * g$i; y <- 2000 + 100 * g$j + cell <- as.integer(15 * (g$j %/% 2L) + g$i %/% 2L + 1L) + v <- local({ .pe_seed(3008); sin(x / 900) + cos(y / 700) + stats::rnorm(length(x), 0, 0.3) }) + L <- .pe_points(x, y, data.frame(v = v, cell_id = cell)) + r <- .pe_catch(.pe_pooled(L, "v", obs_level = 0.9)) + expect_length(r$warnings, 0L) + out <- r$value + cen <- unname(rowsum(cbind(x, y), cell) / tabulate(cell)) + nb <- .pe_neighbours(cen) + # The eighth and the ninth nearest tie for the two cells beside each corner + # of the lattice: there the rule decides which cells are in the target. + d2 <- as.matrix(stats::dist(cen))^2 + tied <- vapply(seq_len(150L), function(j) { + s <- sort(d2[j, -j]); s[8L] == s[9L] }, NA) + expect_identical(sum(tied), 8L) + S <- as.numeric(rowsum(v, cell)); n <- tabulate(cell) + expect_equal(out$..pooled_target_resp_v, + rowSums(matrix(S[nb], 150L)) / rowSums(matrix(n[nb], 150L)), tolerance = 1e-12) + # Ties settled the other way give other targets in the tied cells. + other <- t(vapply(seq_len(150L), function(j) { + o <- order(d2[j, ], -cen[, 1L], -cen[, 2L]); o[o != j][1:8] }, integer(8))) + alt <- rowSums(matrix(S[other], 150L)) / rowSums(matrix(n[other], 150L)) + expect_identical(which(abs(alt - out$..pooled_target_resp_v) > 1e-9), which(tied)) + # The same values in any row order, and with either search. + for (s in 1:3) { + p <- local({ .pe_seed(3080 + s); sample.int(nrow(L)) }) + again <- .pe_pooled(L[p, ], "v", obs_level = 0.9) + for (col in .pe_new(out)) expect_equal(again[[col]], out[[col]], tolerance = 1e-12, + info = paste(col, s)) + } + skip_if_not_installed("FNN") + exact <- local({ .pe_without_fnn(); .pe_pooled(L, "v", obs_level = 0.9) }) + expect_identical(exact, out) +}) + + +# ---- Columns --------------------------------------------------------------------------------- + +test_that("a column named as response and as predictor is fitted once and returned under both", { + L <- .pe_layer() + real <- .pool_column + force(real) + fits <- 0L + testthat::local_mocked_bindings(.pool_column = function(...) { + fits <<- fits + 1L + real(...) + }) + out <- .pe_pooled(L, "z", "z", obs_level = 0.9) + expect_identical(fits, 1L) + for (stem in c("..pooled_", "..pooled_w_", "..pooled_target_", "..obs_lo_", "..obs_hi_")) + expect_identical(out[[paste0(stem, "pred_z")]], out[[paste0(stem, "resp_z")]], info = stem) + expect_identical(.pe_new(out), + c(paste0(c("..pooled_", "..pooled_w_", "..pooled_target_", "..obs_lo_", + "..obs_hi_"), "resp_z"), + paste0(c("..pooled_", "..pooled_w_", "..pooled_target_", "..obs_lo_", + "..obs_hi_"), "pred_z"))) + rec <- attr(out, "pooled")$columns + expect_identical(names(rec), c("resp_z", "pred_z")) + expect_identical(c(rec$resp_z$role, rec$pred_z$role), c("response", "predictor")) + expect_identical(rec$resp_z[-2L], rec$pred_z[-2L]) + # A warning names the column once. + L$w <- local({ .pe_seed(3102); stats::rnorm(nrow(L)) }) + r <- .pe_catch(.pe_pooled(L, "w", c("w", "z", "z"))) + expect_identical(.pe_classes(r), "spatialkit_no_structure") + expect_identical(r$warnings[[1L]]$columns, "w") + expect_identical(names(attr(r$value, "pooled")$columns), c("resp_w", "pred_w", "pred_z")) +}) + +test_that("a column that is not numeric gets no pooled column", { + L <- .pe_layer() + L$flag <- L$z > 0 + L$kind <- ifelse(L$z > 0, "high", "low") + L$fac <- factor(L$kind) + # A logical response alone: today's warning, no new column and no record. + r <- .pe_catch(.pe_pooled(L, "flag", obs_level = 0.9)) + expect_length(r$warnings, 1L) + expect_identical(class(r$warnings[[1L]])[1L], "simpleWarning") + expect_match(conditionMessage(r$warnings[[1L]]), + "response column(s) 'flag' are not numeric and are not summarised", fixed = TRUE) + expect_length(.pe_new(r$value), 0L) + expect_null(attr(r$value, "pooled")) + expect_null(attr(r$value, "intervals")) + plain <- suppressWarnings(summarize_by_cell(L, "flag", id_col = "cell_id", estimate = "mean")) + expect_identical(r$value, plain) + # Beside numeric columns the others are skipped and the numeric ones pooled. + r <- .pe_catch(.pe_pooled(L, "flag", c("kind", "z", "fac"))) + expect_length(r$warnings, 2L) + expect_identical(.pe_new(r$value), paste0(c("..pooled_", "..pooled_w_", "..pooled_target_"), + "pred_z")) + expect_identical(names(attr(r$value, "pooled")$columns), "pred_z") + # A response that is not a column, and no column at all. + r <- .pe_catch(.pe_pooled(L, "absent")) + expect_length(r$warnings, 1L) + expect_null(attr(r$value, "pooled")) + none <- .pe_pooled(L) + expect_identical(none, summarize_by_cell(L, id_col = "cell_id", estimate = "mean")) + expect_null(attr(none, "pooled")) + # An integer column is numeric: it is pooled as its doubles. + L$count <- as.integer(round(10 * L$z)) + a <- .pe_pooled(L, "count") + L$count_dbl <- as.numeric(L$count) + b <- .pe_pooled(L, "count_dbl") + expect_identical(a$..pooled_resp_count, b$..pooled_resp_count_dbl) + expect_type(a$..pooled_resp_count, "double") +}) + +test_that("both families of interval are returned under their own names", { + L <- .pe_layer() + both <- .pe_pooled(L, "z", obs_level = 0.9, conf_level = 0.8) + obs <- .pe_pooled(L, "z", obs_level = 0.9) + conf <- .pe_pooled(L, "z", conf_level = 0.8) + expect_true(all(c("..ci_lo_resp_z", "..ci_hi_resp_z", "..obs_lo_resp_z", "..obs_hi_resp_z") %in% + names(both))) + # Neither changes the other. + expect_identical(both$..obs_lo_resp_z, obs$..obs_lo_resp_z) + expect_identical(both$..obs_hi_resp_z, obs$..obs_hi_resp_z) + expect_identical(both$..ci_lo_resp_z, conf$..ci_lo_resp_z) + expect_identical(both$..ci_hi_resp_z, conf$..ci_hi_resp_z) + # They are different intervals: one is centred on the plain mean and narrows + # with the count, the other has one width for every cell. + expect_equal(both$..ci_lo_resp_z + both$..ci_hi_resp_z, 2 * both$resp_mean_z, tolerance = 1e-12) + expect_length(unique(round(both$..obs_hi_resp_z - both$..obs_lo_resp_z, 10)), 1L) + expect_gt(length(unique(round(both$..ci_hi_resp_z - both$..ci_lo_resp_z, 10))), 50L) + expect_identical(attr(both, "intervals")$level, c(0.9, 0.8)) +}) + + +# ---- Coordinates ----------------------------------------------------------------------------- + +test_that("coordinates without a CRS are used as they are, or projected when they look like lon/lat", { + L <- .pe_layer() + base <- .pe_pooled(L, "z", obs_level = 0.9) + # Planar numbers without a CRS: the same values, and the record says no CRS. + bare <- sf::st_set_crs(L, NA) + r <- .pe_catch(.pe_pooled(bare, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + for (col in .pe_new(base)) expect_identical(r$value[[col]], base[[col]], info = col) + expect_true(is.na(attr(r$value, "pooled")$crs)) + # Numbers that look like degrees, without a CRS: projected as the lon/lat + # layer is, with the warning ensure_projected() raises for the assumption. + ll <- sf::st_transform(L, 4326) + want <- .pe_pooled(ll, "z", obs_level = 0.9) + r <- .pe_catch(.pe_pooled(sf::st_set_crs(ll, NA), "z", obs_level = 0.9)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "CRS is missing; assuming EPSG:4326", fixed = TRUE) + for (col in .pe_new(want)) expect_identical(r$value[[col]], want[[col]], info = col) + expect_false(isTRUE(sf::st_is_longlat(attr(r$value, "pooled")$crs))) + # The projected values are the planar layer's to the accuracy of the projection. + for (col in .pe_new(want)) expect_equal(want[[col]], base[[col]], tolerance = 1e-6, info = col) +}) + +test_that("features that are not points are read at one point each", { + L <- .pe_layer()[1:300, ] + squares <- sf::st_buffer(L, 300, endCapStyle = "SQUARE") + expect_true(all(sf::st_geometry_type(squares) == "POLYGON")) + r <- .pe_catch(.pe_pooled(squares, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + expect_identical(r$value, .pe_pooled(coerce_to_points(squares, "auto"), "z", obs_level = 0.9)) + # A square around a point has the point as its centre, to rounding. + pts <- .pe_pooled(L, "z", obs_level = 0.9) + for (col in .pe_new(pts)) expect_equal(r$value[[col]], pts[[col]], tolerance = 1e-9, info = col) + # Points stored as MULTIPOINT are the points themselves. + multi <- sf::st_cast(L, "MULTIPOINT") + expect_identical(.pe_pooled(multi, "z", obs_level = 0.9), pts) + # The point of a polygon is the one coerce_to_points(, "auto") gives, a point + # on its surface, and not its centroid: for an L the two are far apart. + ells <- sf::st_sf( + cell_id = 1:3, + geometry = sf::st_sfc(lapply(c(0, 5000, 10000), function(dx) sf::st_polygon(list(cbind( + dx + c(0, 3000, 3000, 200, 200, 0, 0), c(0, 0, 200, 200, 2000, 2000, 0))))), crs = 32617)) + at <- .pooled_xy(ells) + expect_identical(at$xy, unname(sf::st_coordinates(coerce_to_points(ells, "auto"))[, 1:2])) + cen <- unname(sf::st_coordinates(coerce_to_points(ells, "centroid"))[, 1:2]) + expect_gt(min(sqrt(rowSums((at$xy - cen)^2))), 100) + expect_identical(at$crs, sf::st_crs(ells)) + expect_null(.pooled_xy(sf::st_drop_geometry(ells))) + # A layer with a third coordinate: the first two are read. + xyz <- sf::st_zm(L, drop = FALSE, what = "Z") + expect_identical(ncol(sf::st_coordinates(xyz)), 3L) + z3 <- .pe_pooled(xyz, "z", obs_level = 0.9) + for (col in .pe_new(pts)) expect_identical(z3[[col]], pts[[col]], info = col) +}) + +test_that("points and other features in one layer are each read at their own point", { + L <- .pe_layer()[1:300, ] + ell <- function(p) sf::st_polygon(list(rbind( + p, p + c(3000, 0), p + c(3000, 200), p + c(200, 200), p + c(200, 2000), p + c(0, 2000), p))) + xy <- unname(sf::st_coordinates(L)) + ells <- sf::st_set_geometry(L, sf::st_sfc(lapply(seq_len(300L), function(i) ell(xy[i, ])), + crs = sf::st_crs(L))) + # Whether the layer needs reducing is asked of every feature, not of the + # first or the last: points followed by polygons, and polygons by points. + for (first in c("points", "polygons")) { + mixed <- if (first == "points") rbind(L[1:150, ], ells[151:300, ]) + else rbind(ells[1:150, ], L[151:300, ]) + expect_setequal(as.character(unique(sf::st_geometry_type(mixed))), c("POINT", "POLYGON")) + at <- .pooled_xy(mixed) + expect_identical(dim(at$xy), c(300L, 2L), info = first) + as_points <- coerce_to_points(mixed, "auto") + expect_identical(at$xy, unname(sf::st_coordinates(as_points)[, 1:2]), info = first) + # The points are kept as they are, and a polygon is read away from its corner. + kept <- if (first == "points") 1:150 else 151:300 + expect_identical(at$xy[kept, ], xy[kept, ], info = first) + expect_gt(min(sqrt(rowSums((at$xy[-kept, ] - xy[-kept, ])^2))), 50) + r <- .pe_catch(.pe_pooled(mixed, "z", obs_level = 0.9)) + expect_length(r$warnings, 0L) + expect_identical(r$value, .pe_pooled(as_points, "z", obs_level = 0.9), info = first) + } +}) + +test_that("lon/lat features are reduced to points first and projected then", { + # The order resolution_profile() takes. Projected first, a polygon's point + # on its surface is another point. + L <- .pe_layer()[1:300, ] + ell <- function(p) sf::st_polygon(list(rbind( + p, p + c(4000, 0), p + c(4000, 500), p + c(500, 500), p + c(500, 4000), p + c(0, 4000), p))) + xy <- unname(sf::st_coordinates(L)) + ells <- sf::st_transform( + sf::st_set_geometry(L, sf::st_sfc(lapply(seq_len(300L), function(i) ell(xy[i, ])), + crs = sf::st_crs(L))), 4326) + expect_true(sf::st_is_longlat(ells)) + r <- .pe_catch(.pooled_xy(ells)) + # sf warns that a point on the surface of a lon/lat polygon may not be + # correct; the point is projected before any distance is taken, and the + # warning is not passed on. The call of plain means raises none either. + expect_length(r$warnings, 0L) + as_points <- ensure_projected(suppressWarnings(coerce_to_points(ells, "auto"))) + expect_identical(r$value$xy, unname(sf::st_coordinates(as_points)[, 1:2])) + expect_identical(r$value$crs, sf::st_crs(as_points)) + expect_false(isTRUE(sf::st_is_longlat(r$value$crs))) + other <- unname(sf::st_coordinates( + suppressWarnings(coerce_to_points(ensure_projected(ells), "auto")))[, 1:2]) + expect_gt(max(sqrt(rowSums((r$value$xy - other)^2))), 0.1) # metres + # Through the exported function: the values of those points, and no warning + # that is sf's. + got <- .pe_catch(.pe_pooled(ells, "z", obs_level = 0.9)) + want <- .pe_catch(.pe_pooled(as_points, "z", obs_level = 0.9)) + expect_identical(.pe_classes(got), .pe_classes(want)) + expect_false(any(grepl("st_point_on_surface", vapply(got$warnings, conditionMessage, ""), + fixed = TRUE))) + for (col in .pe_new(want$value)) + expect_identical(got$value[[col]], want$value[[col]], info = col) + expect_identical(attr(got$value, "pooled")$crs, sf::st_crs(as_points)) + expect_length(.pe_catch(summarize_by_cell(ells, "z", id_col = "cell_id", + estimate = "mean"))$warnings, 0L) +}) + +test_that("a coordinate too large to take a distance from is a row without a location", { + expect_identical(.POOL_XY_MAX, 1e150) + L <- .pe_layer() + at <- unname(sf::st_coordinates(L)[7L, ]) + put <- function(x, y) { + far <- L + g <- sf::st_geometry(far) + g[[7L]] <- sf::st_point(c(x, y)) + sf::st_geometry(far) <- g + far + } + want <- .pe_pooled(L[-7L, ], "z", obs_level = 0.9) + # Both coordinates too large, the second alone, the first alone. + for (p in list(c(1e200, 1e200), c(at[1L], .Machine$double.xmax), c(-1e151, at[2L]))) { + tag <- paste(format(p), collapse = ", ") + far <- put(p[1L], p[2L]) + r <- .pe_catch(.pe_pooled(far, "z", obs_level = 0.9)) + expect_identical(.pe_classes(r), "spatialkit_pool_rows_skipped", info = tag) + expect_identical(.pe_fields(r$warnings[[1L]]), list(n = 1L, cells = 1L, columns = "z"), + info = tag) + # The pooled columns are those of the layer without the row, the plain + # ones still hold it, and the exact search gives the same frame. + for (col in .pe_new(want)) expect_identical(r$value[[col]], want[[col]], + info = paste(tag, col)) + expect_identical(sum(r$value$n), 720L) + exact <- local({ .pe_without_fnn(); suppressWarnings(.pe_pooled(far, "z", obs_level = 0.9)) }) + expect_identical(exact, r$value, info = tag) + } + # A large coordinate a distance can be taken from is a location: the row + # takes part, with either search. + for (p in list(c(1e30, 1e30), c(at[1L], -1e150), c(1e150, at[2L]))) { + tag <- paste(format(p), collapse = ", ") + far <- put(p[1L], p[2L]) + r <- .pe_catch(.pe_pooled(far, "z", obs_level = 0.9)) + expect_false("spatialkit_pool_rows_skipped" %in% .pe_classes(r), info = tag) + expect_identical(attr(r$value, "pooled")$columns$resp_z$n, 720L, info = tag) + expect_false(anyNA(r$value$..pooled_resp_z), info = tag) + exact <- local({ .pe_without_fnn(); suppressWarnings(.pe_pooled(far, "z", obs_level = 0.9)) }) + expect_identical(exact, r$value, info = tag) + } +}) diff --git a/tests/testthat/test-core-pool-helper.R b/tests/testthat/test-core-pool-helper.R new file mode 100644 index 00000000..189b6278 --- /dev/null +++ b/tests/testthat/test-core-pool-helper.R @@ -0,0 +1,324 @@ +# tests/testthat/test-core-pool-helper.R +# --------------------------------------------------------------------------- +# The reference functions of helper-pool-reference.R are the text they were +# copied as, and they run on the layouts the engine is checked on. +# +# The functions are a fixed point for the tests of R/pool.R, so the first +# test holds their text still. The second holds the layouts still: their +# settings, and the coordinates, response and regions each gives. The others +# run the functions on every layout and check what they return against the +# same quantities worked out row by row: a copy that had lost a line would +# not pass. +# --------------------------------------------------------------------------- + +test_that("the copied block of the reference helper has not been edited", { + lines <- sub("\r$", "", readLines(test_path("helper-pool-reference.R"), warn = FALSE)) + from <- grep("^# ---- core-factorial/20_estimates.R", lines) + to <- grep("^# ---- Layouts", lines) + expect_length(from, 1L) + expect_length(to, 1L) + block <- paste(lines[from:(to - 1L)], collapse = "\n") + # The block as it was copied from the experiments' files. A change here is + # a change to the reference, not a correction of it. + expect_identical(digest::digest(block, algo = "sha256", serialize = FALSE), + "d3cc783800fa057f4762a5ea57f78c183833c69e816b766ef1b3c869b926529c") + expect_identical(EST, c("P", "R", "L", "PAR")) + expect_identical(NEIGHBOURS, 8L) + for (f in c("oneway", "reml_oneway", "weight", "reldiff", "parent_of", "region_estimates", + "predict_partition", "loo_plain", "pick_rung", "rung_k", "wfun", "reml_means", + "fit_regions", "loo_int")) + expect_true(is.function(get(f)), info = f) +}) + +test_that("the layouts are the thirteen of the engine's tests, and are the same on every call", { + expect_length(POOL_LAYOUTS, 13L) + # The settings, written out: rows, rows per region, clustered or not, the + # number of regions where it is set, and the seed each is drawn under. + stated <- data.frame( + N = c(600, 600, 600, 3000, 3000, 3000, 3000, 40, 12, 9, 60, 60, 90), + per = c(18, 4.5, 2, 4.5, 9, 3, 2, 4.5, 4.5, 4.5, NA, NA, NA), + clustered = c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, + FALSE, FALSE, TRUE), + K = c(rep(NA, 10), 2, 3, 4), + seed = c(826, 731.5, 714, 3131.5, 3163, 3121, 3114, 171.5, 143.5, 140.5, 5, 6, 7)) + pick <- function(l, nm) if (is.null(l[[nm]])) NA else l[[nm]] + seed_of <- function(l) if (is.null(l$seed)) + eval(formals(pool_layout)$seed, list(N = l$N, per = l$per)) else l$seed + expect_identical(vapply(POOL_LAYOUTS, function(l) as.numeric(l$N), numeric(1)), stated$N) + expect_identical(vapply(POOL_LAYOUTS, function(l) as.numeric(pick(l, "per")), numeric(1)), + stated$per) + expect_identical(vapply(POOL_LAYOUTS, function(l) l$clustered, logical(1)), stated$clustered) + expect_identical(vapply(POOL_LAYOUTS, function(l) as.numeric(pick(l, "K")), numeric(1)), + stated$K) + expect_identical(vapply(POOL_LAYOUTS, function(l) as.numeric(seed_of(l)), numeric(1)), + stated$seed) + # What each layout is, from one run: the regions it has, the sums of its + # coordinates and of its response, the sum of squares of the coordinates + # about the regions' centroids, its first row, its largest region and its + # regions of one row. A change to the draws, to their order, to the + # response or to the k-means fit moves one of them. + pinned <- list( + list(K = 33L, x = 29874706.2895214, y = 28792422.7186013, z = 140.246634888009, + wss = 26439897402.9235, first = c(45574.0485340357, 11603.8269363344, 1.76399348173672), + largest = 37L, alone = 0L, + regions = "fd062acf5a72dade85aea1c49438c1130a36c56bf834399e75578b321b23328b"), + list(K = 133L, x = 29715273.1257956, y = 29639554.288378, z = 83.4625253875932, + wss = 4598880412.62402, first = c(81091.2917600945, 12437.1200334281, -1.09252907117771), + largest = 10L, alone = 2L, + regions = "36c86cd123197947c275c8ad86b8247b684094167e4e4cf4c949d4d2b9c9f270"), + list(K = 300L, x = 39526653.8854346, y = 40511077.5110761, z = -60.6694540007996, + wss = 316262114.417961, first = c(83434.6807526603, 74346.5297039839, -0.288675094614457), + largest = 5L, alone = 107L, + regions = "a024f5e5195dfebef544634998f11229b811bcb22d55f8f81a88144a26803d5f"), + list(K = 667L, x = 136283944.421336, y = 197566173.908574, z = 1155.78586429603, + wss = 1467946939.7624, first = c(68475.5925537745, 86202.6189963955, 0.67636526770625), + largest = 13L, alone = 39L, + regions = "ccaa86f8fe1e76b33827478ac0b87c174e2904954bb01260e04b1885992d2dee"), + list(K = 333L, x = 148742602.818901, y = 149702122.419886, z = 576.068167900529, + wss = 11185811292.6901, first = c(85614.8979626596, 17524.1708289832, -0.773295764742362), + largest = 19L, alone = 0L, + regions = "c0a4fef54697d3cf27179d46a6c787a7bb3f6834a1e70b3fc9b069e75c15d659"), + list(K = 1000L, x = 135971717.360894, y = 130139974.012379, z = 913.383691126545, + wss = 713700440.715928, first = c(51671.8402377044, 21982.1038269469, -0.70027314610776), + largest = 9L, alone = 134L, + regions = "cd404c3466e24e4902acb8cda89c10a5212ff7c0bc766fa3f5b6b470c738e6a8"), + list(K = 1500L, x = 147678263.059002, y = 151589194.867504, z = 582.11146843136, + wss = 1042374972.84667, first = c(69767.6845593378, 53949.3277901784, -0.939162754885976), + largest = 7L, alone = 536L, + regions = "a6f35a014d2e5c495a3644f910936e166a572b087511cf83268d1a00e43e4f54"), + list(K = 9L, x = 1998256.63326774, y = 1874450.39760787, z = 9.79517962950725, + wss = 4964049010.7189, first = c(16371.9046860933, 59489.6582653746, 0.456385099586902), + largest = 8L, alone = 0L, + regions = "bb67f9970cb629dda9732b1ef532d7caedf290d9ed8882f3a7978299779a6b4c"), + list(K = 3L, x = 593708.877358586, y = 732662.02150844, z = 4.77098301529861, + wss = 5621047760.91425, first = c(94322.5271301344, 95603.4328555688, -0.400924170733543), + largest = 7L, alone = 0L, + regions = "5e918ee4e0970ac5b38003809833bafa5565e92efbd74aab888f51fd71e1734d"), + list(K = 2L, x = 655398.420360455, y = 363021.137519904, z = -4.56240929685216, + wss = 5220797540.42634, first = c(91986.9286115127, 27714.2144500128, -1.06983221268626), + largest = 7L, alone = 0L, + regions = "954e7ac196f2aafcfdf9f38642edd8aee913bbd73b35bf11ced2c33693e2ad15"), + list(K = 2L, x = 2969596.72642406, y = 3207225.74295942, z = 15.5424211974207, + wss = 56285508381.0287, first = c(20021.4452575892, 62396.6502491385, -0.364812325134488), + largest = 31L, alone = 0L, + regions = "d3a490a96f0c08a035ed84c064030965e7ab5d0378ec488a95567b0f3bc96328"), + list(K = 3L, x = 3396383.72983318, y = 2914499.51124378, z = -5.18568712226186, + wss = 38488574836.6697, first = c(60626.8297648057, 25096.3960308582, 0.136392097837547), + largest = 25L, alone = 0L, + regions = "cde65ba054d2d4f3f6321e5e1069b7cb60663b509d1f63af208dcbb95b448381"), + list(K = 4L, x = 4324757.12586078, y = 4356933.26675007, z = 49.7154318092928, + wss = 37068536222.5694, first = c(79334.3344396412, 8184.14742803582, 0.0718807282317518), + largest = 31L, alone = 0L, + regions = "94a7db8adadb8a204add1b98ba92670fec824e8db4a538573b740d170411dc6e")) + # Which row is in which region is held where the platform is the one the + # numbers were taken on (the frozen fixture's): elsewhere a k-means fit + # differs in its last bits. + here <- core_frozen_platform() + same_platform <- core_frozen_same_platform( + here, readRDS(test_path("fixtures", "core-frozen.rds"))$info) + for (i in seq_along(POOL_LAYOUTS)) { + L <- do.call(pool_layout, POOL_LAYOUTS[[i]]) + P <- pinned[[i]] + tag <- sprintf("layout %d", i) + n <- tabulate(L$gi, L$K) + cen <- rowsum(L$xy, L$gi) / n + expect_identical(L$K, P$K, info = tag) + expect_equal(sum(L$xy[, 1]), P$x, tolerance = 1e-9, info = tag) + expect_equal(sum(L$xy[, 2]), P$y, tolerance = 1e-9, info = tag) + expect_equal(sum(L$y), P$z, tolerance = 1e-9, info = tag) + expect_equal(sum((L$xy - cen[L$gi, ])^2), P$wss, tolerance = 1e-9, info = tag) + expect_equal(c(L$xy[1, ], L$y[1]), P$first, tolerance = 1e-9, info = tag) + expect_identical(max(n), P$largest, info = tag) + expect_identical(sum(n == 1L), P$alone, info = tag) + if (same_platform) + expect_identical(digest::digest(paste(L$gi, collapse = ","), algo = "sha256", + serialize = FALSE), P$regions, info = tag) + } + shape <- vapply(POOL_LAYOUTS, function(l) { + L <- do.call(pool_layout, l) + c(N = nrow(L$xy), K = L$K, rows = length(L$y), groups = length(unique(L$gi)), + top = max(L$gi)) + }, numeric(5)) + expect_identical(unname(shape["N", ]), + c(600, 600, 600, 3000, 3000, 3000, 3000, 40, 12, 9, 60, 60, 90)) + # rung_k() of the rows and the size, less the centres that took no row. + wanted <- vapply(POOL_LAYOUTS, function(l) + if (is.null(l$K)) rung_k(l$N, l$per) else l$K, numeric(1)) + expect_true(all(shape["K", ] <= wanted)) + expect_true(all(shape["K", ] >= 0.9 * wanted)) + expect_identical(unname(shape["K", 11:13]), c(2, 3, 4)) + expect_identical(shape["groups", ], shape["K", ]) + expect_identical(shape["top", ], shape["K", ]) + # The regions are those of the nearest centre: every row is nearer the + # centroid of its own region than that of any other. + for (l in POOL_LAYOUTS) { + L <- do.call(pool_layout, l) + cen <- rowsum(L$xy, L$gi) / tabulate(L$gi) + d2 <- outer(L$xy[, 1], cen[, 1], "-")^2 + outer(L$xy[, 2], cen[, 2], "-")^2 + expect_gte(mean(max.col(-d2, ties.method = "first") == L$gi), 0.98) + } + # A layout does not depend on the session's random numbers, and leaves them. + set.seed(1); a <- do.call(pool_layout, POOL_LAYOUTS[[3L]]); after <- stats::runif(1) + set.seed(2); b <- do.call(pool_layout, POOL_LAYOUTS[[3L]]) + expect_identical(a, b) + set.seed(1) + expect_identical(stats::runif(1), after) + # Nor on the kind of generator the session has set, which it leaves too. + old_kind <- RNGkind() + old_seed <- get(".Random.seed", envir = globalenv()) + withr::defer({ + suppressWarnings(do.call(RNGkind, as.list(old_kind))) + assign(".Random.seed", old_seed, envir = globalenv()) + }) + other_kind <- c("L'Ecuyer-CMRG", "Box-Muller", "Rounding") + suppressWarnings(do.call(RNGkind, as.list(other_kind))) + set.seed(1) + drawn <- stats::runif(1) + set.seed(1) + expect_identical(do.call(pool_layout, POOL_LAYOUTS[[3L]]), a) + # R-devel reports a fourth kind (the binomial generator); the three set here + # are the first three on every version. + expect_identical(RNGkind()[seq_along(other_kind)], other_kind) + expect_identical(stats::runif(1), drawn) + suppressWarnings(do.call(RNGkind, as.list(old_kind))) + # Clustered and uniform layouts differ in how even the regions are. + cv <- function(l) { n <- tabulate(do.call(pool_layout, l)$gi); stats::sd(n) / mean(n) } + expect_gt(cv(POOL_LAYOUTS[[4L]]), cv(POOL_LAYOUTS[[2L]])) +}) + +test_that("the reference functions run on every layout and agree with a row-by-row count", { + skip_if_not_installed("FNN") + for (l in POOL_LAYOUTS) { + L <- do.call(pool_layout, l) + y <- L$y; gi <- L$gi; K <- L$K; xy <- L$xy; N <- length(y) + tag <- sprintf("N = %d, K = %d", N, K) + nn1 <- pool_nearest_other(xy) + # Another row, and the nearest one. + expect_false(any(nn1 == seq_len(N)), info = tag) + if (N <= 600L) { + d <- as.matrix(stats::dist(xy)) + diag(d) <- Inf + expect_identical(nn1, unname(apply(d, 1L, which.min)), info = tag) + } + R <- region_estimates(y, gi, K, xy, want = c("P", "L")) + Fr <- fit_regions(gi, gi[1:3], y, xy, xy[1:3, , drop = FALSE], nn1) + + # The plain mean and the one-way parts. + n <- tabulate(gi, K) + m <- vapply(seq_len(K), function(j) mean(y[gi == j]), numeric(1)) + expect_equal(unname(R$est[, "P"]), m, tolerance = 1e-12, info = tag) + expect_identical(R$a$n, n, info = tag) + expect_equal(R$a$sigma2, sum((y - m[gi])^2) / (N - K), tolerance = 1e-12, info = tag) + + # The pooled value: its neighbours, target, weight and the value itself. + k_nb <- min(8L, K - 1L) + expect_identical(dim(Fr$nb), c(K, k_nb), info = tag) + expect_false(any(Fr$nb == seq_len(K)), info = tag) + cen <- t(vapply(seq_len(K), function(j) colMeans(xy[gi == j, , drop = FALSE]), numeric(2))) + for (j in unique(c(1L, K, round(seq(1, K, length.out = 6))))) { + d <- sqrt((cen[, 1] - cen[j, 1])^2 + (cen[, 2] - cen[j, 2])^2) + expect_setequal(Fr$nb[j, ], order(d)[2:(k_nb + 1L)]) + } + target <- vapply(seq_len(K), function(j) mean(y[gi %in% Fr$nb[j, ]]), numeric(1)) + expect_equal(Fr$t, target, tolerance = 1e-10, info = tag) + tau2 <- max(0, (sum(n * (m - target)^2) - K * R$a$sigma2) / N) + expect_equal(Fr$tau2, tau2, tolerance = 1e-9, info = tag) + expect_true(all(Fr$w >= 0 & Fr$w <= 1), info = tag) + expect_identical(unname(Fr$est[, "L"]), unname(R$est[, "L"]), info = tag) + expect_equal(unname(R$est[, "L"]), Fr$w * m + (1 - Fr$w) * target, tolerance = 1e-10, + info = tag) + + # Leave one row out, for a sample of rows: the region's count and mean + # again without the row, the variances and the targets held. + rows <- if (N <= 600L) seq_len(N) else round(seq(1, N, length.out = 300)) + e_mean <- e_pool <- numeric(length(rows)) + for (s in seq_along(rows)) { + i <- rows[s]; j <- gi[i] + rest <- y[gi == j & seq_len(N) != i] + if (length(rest)) { + w <- if (tau2 + R$a$sigma2 / length(rest) > 0) + tau2 / (tau2 + R$a$sigma2 / length(rest)) else 1 + e_mean[s] <- y[i] - mean(rest) + e_pool[s] <- y[i] - (w * mean(rest) + (1 - w) * target[j]) + } else { + e_mean[s] <- y[i] - m[gi[nn1[i]]] + e_pool[s] <- y[i] - target[j] + } + } + expect_equal(Fr$eP[rows], e_mean, tolerance = 1e-9, info = tag) + expect_equal(Fr$eL[rows], e_pool, tolerance = 1e-9, info = tag) + expect_identical(Fr$loo_P, loo_plain(y, gi, R$a, nn1), info = tag) + expect_identical(Fr$loo_P, mean(Fr$eP^2), info = tag) + expect_identical(Fr$loo_L, mean(Fr$eL^2), info = tag) + expect_identical(Fr$loo_L_se, stats::sd(Fr$eL^2) / sqrt(N), info = tag) + + # The interval from the residuals. + q <- stats::quantile(Fr$eL, c(0.05, 0.95), names = FALSE, type = 7) + expect_identical(loo_int(Fr$est[, "L"], Fr$eL, 1, 1), + cbind(Fr$est[, "L"] + q[1], Fr$est[, "L"] + q[2]), info = tag) + } +}) + +test_that("the rest of the reference functions do what their names say", { + skip_if_not_installed("FNN") + # The count at a size: n over m, rounded to the even number at a half, and + # never below two. + expect_identical(rung_k(600, 4.5), 133L) + expect_identical(rung_k(9, 2), 4L) # 4.5 rounds to 4 + expect_identical(rung_k(27, 2), 14L) # 13.5 rounds to 14 + expect_identical(rung_k(12, 18), 2L) + expect_identical(pick_rung(c(3, 1, 1, 2)), 2L) + expect_identical(weight(0, 0, 3), 1) + expect_identical(weight(1, 2, 2), 0.5) + expect_identical(wfun(0, 0), 1) + expect_identical(wfun(3, 1), 0.75) + expect_identical(reldiff(c(1, 2, -4), c(1, 4, -2)), c(0, 0.5, 0.5)) + + L <- do.call(pool_layout, POOL_LAYOUTS[[2L]]) + # A response with no structure, drawn so that the moment estimate of the + # between-region variance is negative: it is set to 0, every weight is 0 + # and the pooled value is the target. + noise <- withr::with_seed(903, stats::rnorm(length(L$y)), .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + Fn <- fit_regions(L$gi, L$gi[1:3], noise, L$xy, L$xy[1:3, , drop = FALSE], + pool_nearest_other(L$xy)) + expect_lt(Fn$Q - Fn$K * Fn$sigma2, 0) + expect_identical(Fn$tau2, 0) + expect_identical(Fn$w, rep(0, Fn$K)) + expect_identical(unname(Fn$est[, "L"]), Fn$t) + expect_identical(unname(region_estimates(noise, L$gi, L$K, L$xy, want = "L")$est[, "L"]), + Fn$t) + + # The nearest other row is not defined by the reference where a location + # repeats: FNN returns a row as its own neighbour there. + expect_error(pool_nearest_other(rbind(L$xy[1:50, ], L$xy[1:50, ])), + "two rows share a location") + + a <- oneway(L$y, L$gi, L$K) + r <- reml_oneway(a) + expect_true(is.finite(r$sigma2) && r$sigma2 > 0 && is.finite(r$tau2) && r$tau2 >= 0) + expect_error(oneway(L$y[1:5], 1:5, 5L), "no group holds two") + rm0 <- reml_means(c(1, 1, 1), c(1, 1, 1)) + expect_identical(rm0$tau2, 0) + expect_gt(reml_means(c(-5, 0, 5, 10), rep(0.01, 4))$tau2, 1) + + # A held-out row in a region with no training row takes the value of the + # region of its nearest training row. + hold <- L$gi %in% c(1L, 2L) | seq_along(L$y) %% 7 == 0 + P <- predict_partition(L$gi[!hold], L$gi[hold], L$y[!hold], L$xy[!hold, ], L$xy[hold, ], + want = c("P", "R", "L")) + expect_identical(P$n_empty, sum(L$gi[hold] %in% c(1L, 2L))) + expect_identical(dim(P$pred), c(sum(hold), 3L)) + expect_true(all(is.finite(P$pred))) + tr_mean <- vapply(split(L$y[!hold], L$gi[!hold]), mean, numeric(1)) + te <- which(hold) + kept <- !(L$gi[te] %in% c(1L, 2L)) + expect_equal(unname(P$pred[kept, "P"]), unname(tr_mean[as.character(L$gi[te][kept])]), + tolerance = 1e-12) + lost <- te[!kept][1L] + tr <- which(!hold) + near <- tr[which.min((L$xy[tr, 1] - L$xy[lost, 1])^2 + (L$xy[tr, 2] - L$xy[lost, 2])^2)] + expect_equal(unname(P$pred[which(te == lost), "P"]), + unname(tr_mean[as.character(L$gi[near])]), tolerance = 1e-12) + expect_identical(P$n_own[which(te == lost)], 0L) +}) diff --git a/tests/testthat/test-core-pool-properties.R b/tests/testthat/test-core-pool-properties.R new file mode 100644 index 00000000..48a90bbf --- /dev/null +++ b/tests/testthat/test-core-pool-properties.R @@ -0,0 +1,1963 @@ +# tests/testthat/test-core-pool-properties.R +# --------------------------------------------------------------------------- +# What the engine of R/pool.R promises on any input, checked without the +# reference functions: the leave-one-out residuals against a loop that takes +# each row out, the behaviour under a change of scale, of row order and of +# region numbering, the outputs that are set when a column has no spread, +# the order of the degenerate cases, the neighbour searches on tied and +# coincident points, the rule for a response without structure, the bound on +# exact searches, and what `want`, `geo` and `cache` leave uncomputed. +# +# None of it needs FNN. Each test runs on the exact searches of base R, and +# on FNN's kd-tree as well where FNN is installed; the tests that hold the +# two paths to identical() are the ones that skip without it. +# +# The package's internal functions are called by name: testthat runs a +# package's tests in an environment that inherits from its namespace. +# --------------------------------------------------------------------------- + +# ---- Layouts ----------------------------------------------------------------- + +.pt_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +# Regions of a k-means fit at `K` centres: each row in the region of its +# nearest centre, the regions that hold a row numbered 1 to K. +.pt_regions <- function(xy, K, seed = 1L) { + .pt_seed(seed) + km <- suppressWarnings(stats::kmeans(xy, K, nstart = 3, iter.max = 100)) + g <- .nearest_centre(xy[, 1], xy[, 2], km$centers[, 1], km$centers[, 2]) + match(g, sort(unique(g))) +} + +.pt_store <- new.env(parent = emptyenv()) +.pt_keep <- function(key, expr) { + if (is.null(.pt_store[[key]])) .pt_store[[key]] <- expr + .pt_store[[key]] +} + +.pt_layout <- function(i) .pt_keep(paste0("layout", i), do.call(pool_layout, POOL_LAYOUTS[[i]])) + +# The lattice: 60 x 50 locations at a spacing of 0.7 from (0.1, 0.3). None +# of its coordinates is exact in binary, so sums of them taken in different +# orders differ in their last bits, and every location has neighbours at +# exactly equal distances. `centres` regions: 667 gives about 4.5 rows a +# region and none of one row; 1,500 gives 2 rows a region and many of one. +.pt_lattice <- function(centres = 667L) .pt_keep(paste0("lattice", centres), { + xy <- as.matrix(expand.grid(x = seq(0.1, by = 0.7, length.out = 60), + y = seq(0.3, by = 0.7, length.out = 50))) + dimnames(xy) <- NULL + y <- local({ + .pt_seed(31) + sin(xy[, 1] / 9) + cos(xy[, 2] / 7) + stats::rnorm(nrow(xy), 0, 0.5) + }) + gi <- .pt_regions(xy, centres, 3L) + list(xy = xy, y = y, gi = gi, K = max(gi)) +}) + +# 400 rows in 90 regions, for the columns without spread. +.pt_small <- function() .pt_keep("small", { + xy <- local({ .pt_seed(7); cbind(stats::runif(400, 0, 1e4), stats::runif(400, 0, 1e4)) }) + gi <- .pt_regions(xy, 90L, 1L) + list(xy = xy, gi = gi, K = max(gi)) +}) + +# `K` regions of 500 rows each, every row within 900 of its region's centre. +# The sum of 500 values that are not exact in binary is off by a rounding +# error, which is what the regions of the layouts above are too small to show. +.pt_large <- function(K) .pt_keep(paste0("large", K), { + gi <- rep(seq_len(K), each = 500L) + cen <- local({ .pt_seed(111); cbind(stats::runif(K, 0, 1e5), stats::runif(K, 0, 1e5)) }) + xy <- local({ + .pt_seed(112) + cen[gi, ] + cbind(stats::runif(500L * K, -900, 900), stats::runif(500L * K, -900, 900)) + }) + list(xy = xy, gi = gi, K = K) +}) + +# The test for no spread inside the regions on the sum of squares the fit +# uses: about the regions' means, each mean its sum over its count. +.pt_written_rule <- function(y, gi) { + m <- as.numeric(rowsum(y, gi)) / tabulate(gi) + .no_spread(sum((y - m[gi])^2), y) +} + +# The searches a test runs on: the exact one, and FNN's where it is installed. +.pt_paths <- function() c(FALSE, if (requireNamespace("FNN", quietly = TRUE)) TRUE) +.pt_path_tag <- function(f) if (f) "with FNN" else "exact search" + +# The largest absolute difference between two vectors of the same length. +.pt_gap <- function(a, b) { + stopifnot(length(a) == length(b)) + if (!length(a)) return(0) + max(abs(a - b)) +} + + +# ---- Definitions written again, row by row ----------------------------------- + +# Each region's neighbours by the rule alone: every other region by squared +# distance between centroids, a tie to the lower first coordinate, then the +# lower second, then the lower number. +.pt_neighbours <- function(cen, k = 8L) { + K <- nrow(cen); k <- min(as.integer(k), K - 1L) + out <- matrix(0L, K, k) + for (j in seq_len(K)) { + d2 <- (cen[, 1] - cen[j, 1])^2 + (cen[, 2] - cen[j, 2])^2 + o <- order(d2, cen[, 1], cen[, 2], seq_len(K)) + out[j, ] <- o[o != j][seq_len(k)] + } + out +} + +# A nearest other row by the rule alone. A row that shares its location +# takes the first other row there, rows ordered by region and then as given; +# a row alone at its location takes the first row of the nearest other +# location, a tie to the lower first coordinate, then the lower second. +.pt_nearest_other <- function(xy, gi, rows = seq_len(nrow(xy))) { + n <- nrow(xy) + vapply(rows, function(i) { + here <- which(xy[, 1] == xy[i, 1] & xy[, 2] == xy[i, 2]) + here <- here[order(gi[here], here)] + if (length(here) > 1L) return(here[here != i][1L]) + d2 <- (xy[, 1] - xy[i, 1])^2 + (xy[, 2] - xy[i, 2])^2 + d2[i] <- Inf + near <- which(d2 == min(d2)) + best <- near[order(xy[near, 1], xy[near, 2])][1L] + at <- which(xy[, 1] == xy[best, 1] & xy[, 2] == xy[best, 2]) + at[order(gi[at], at)][1L] + }, integer(1)) +} + +# Take each row out, compute its region's count and mean again, hold sigma2, +# tau2 and the targets, and predict it. +.pt_leave_out <- function(y, gi, xy, fit) { + N <- length(y) + rows_of <- split(seq_len(N), gi) + eL <- eP <- numeric(N) + for (i in seq_len(N)) { + j <- gi[i] + rest <- setdiff(rows_of[[j]], i) + if (length(rest)) { + mean_rest <- sum(y[rest]) / length(rest) + v <- fit$sigma2 / length(rest) + w <- if (fit$tau2 + v > 0) fit$tau2 / (fit$tau2 + v) else 1 + eL[i] <- y[i] - (w * mean_rest + (1 - w) * fit$target[j]) + eP[i] <- y[i] - mean_rest + } else { + eL[i] <- y[i] - fit$target[j] + d2 <- (xy[, 1] - xy[i, 1])^2 + (xy[, 2] - xy[i, 2])^2 + d2[i] <- Inf + eP[i] <- y[i] - fit$m[gi[which.min(d2)]] + } + } + list(eL = eL, eP = eP) +} + + +# ---- 7. Leave-one-out by brute force ---------------------------------------- + +test_that("7. taking each row out and predicting it gives the two residual vectors", { + for (i in c(2L, 3L, 7L)) for (f in .pt_paths()) { + L <- .pt_layout(i); tag <- sprintf("layout %d, %s", i, .pt_path_tag(f)) + y <- L$y; gi <- L$gi; K <- L$K; xy <- L$xy; N <- length(y) + A <- .pool_fit(y, gi, K, xy, use_fnn = f) + + # What is held while a row is out, each from its definition. + n <- as.integer(table(gi)) + m <- vapply(seq_len(K), function(j) mean(y[gi == j]), numeric(1)) + expect_identical(A$n, n, info = tag) + expect_lt(.pt_gap(A$m, m), 1e-12) + expect_equal(A$sigma2, sum((y - m[gi])^2) / (N - K), tolerance = 1e-12, info = tag) + cen <- t(vapply(seq_len(K), function(j) colMeans(xy[gi == j, , drop = FALSE]), numeric(2))) + expect_equal(unname(A$cen), cen, tolerance = 1e-12, info = tag) + expect_identical(A$nb, .pt_neighbours(unname(A$cen)), info = tag) + expect_false(any(A$nb == seq_len(K)), info = tag) + target <- vapply(seq_len(K), function(j) mean(y[gi %in% A$nb[j, ]]), numeric(1)) + expect_lt(.pt_gap(A$target, target), 1e-12) + Q <- sum(n * (m - target)^2) + expect_equal(A$Q, Q, tolerance = 1e-12, info = tag) + expect_equal(A$tau2, max(0, (Q - K * A$sigma2) / N), tolerance = 1e-10, info = tag) + w <- A$tau2 / (A$tau2 + A$sigma2 / n) + expect_lt(.pt_gap(A$w, w), 1e-12) + expect_lt(.pt_gap(A$value, w * m + (1 - w) * target), 1e-12) + + # The residuals. + B <- .pt_leave_out(y, gi, xy, A) + expect_lt(.pt_gap(A$resid_pooled, B$eL), 1e-12) + expect_lt(.pt_gap(A$resid_mean, B$eP), 1e-12) + expect_equal(A$loo_pooled, mean(B$eL^2), tolerance = 1e-12, info = tag) + expect_equal(A$loo_mean, mean(B$eP^2), tolerance = 1e-12, info = tag) + expect_equal(A$loo_pooled_se, stats::sd(B$eL^2) / sqrt(N), tolerance = 1e-12, info = tag) + expect_equal(A$loo_mean_se, stats::sd(B$eP^2) / sqrt(N), tolerance = 1e-12, info = tag) + + # One mean for all rows: each row predicted by the mean of the others. + e1 <- vapply(seq_len(N), function(r) y[r] - mean(y[-r]), numeric(1)) + expect_equal(A$loo_one, mean(e1^2), tolerance = 1e-12, info = tag) + expect_equal(A$loo_one_se, stats::sd(e1^2) / sqrt(N), tolerance = 1e-12, info = tag) + expect_identical(A$loo_one, mean(((y - mean(y)) * N / (N - 1))^2), info = tag) + + # The F test of the region means against one mean, from the sum of + # squares between the regions. + between <- sum(n * (m - mean(y))^2) + p <- stats::pf((between / (K - 1)) / (sum((y - m[gi])^2) / (N - K)), K - 1, N - K, + lower.tail = FALSE) + expect_gt(p, 0) + expect_lt(abs(A$f_p / p - 1), 1e-6) + } + # Layouts 3 and 7 hold regions of one row, the residuals with their own rule. + expect_gt(sum(tabulate(.pt_layout(3L)$gi) == 1L), 50L) + expect_gt(sum(tabulate(.pt_layout(7L)$gi) == 1L), 500L) +}) + +test_that("7. the F test's p-value is the one-way analysis of variance's", { + for (i in 8:13) { + L <- .pt_layout(i) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = FALSE) + aov1 <- stats::anova(stats::lm(L$y ~ factor(L$gi))) + expect_equal(A$f_p, aov1[["Pr(>F)"]][1L], tolerance = 1e-9, info = sprintf("layout %d", i)) + expect_true(A$f_p > 0 && A$f_p < 1, info = sprintf("layout %d", i)) + } + expect_gt(.pool_fit(.pt_layout(9L)$y, .pt_layout(9L)$gi, 3L, .pt_layout(9L)$xy, + use_fnn = FALSE)$f_p, 0.05) +}) + + +# ---- 8. A change of scale ---------------------------------------------------- + +test_that("8. y -> a + b y moves the values the same way and leaves the weights", { + for (i in c(2L, 4L)) for (f in .pt_paths()) { + L <- .pt_layout(i); tag <- sprintf("layout %d, %s", i, .pt_path_tag(f)) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + for (ab in list(c(37.5, -2.5), c(-4, 1000), c(0.3, 0.01))) { + a <- ab[1L]; b <- ab[2L] + B <- .pool_fit(a + b * L$y, L$gi, L$K, L$xy, use_fnn = f) + rel <- function(got, want) max(abs(got - want)) / max(abs(want)) + expect_lt(rel(B$value, a + b * A$value), 1e-10) + expect_lt(rel(B$m, a + b * A$m), 1e-10) + expect_lt(rel(B$target, a + b * A$target), 1e-10) + expect_lt(.pt_gap(B$w, A$w), 1e-10) + expect_lt(rel(B$resid_pooled, b * A$resid_pooled), 1e-10) + expect_lt(rel(B$resid_mean, b * A$resid_mean), 1e-10) + expect_equal(B$sigma2, b^2 * A$sigma2, tolerance = 1e-10, info = tag) + expect_equal(B$tau2, b^2 * A$tau2, tolerance = 1e-10, info = tag) + expect_equal(B$loo_pooled, b^2 * A$loo_pooled, tolerance = 1e-10, info = tag) + expect_equal(B$loo_mean, b^2 * A$loo_mean, tolerance = 1e-10, info = tag) + expect_equal(B$loo_one, b^2 * A$loo_one, tolerance = 1e-10, info = tag) + expect_equal(B$f_p, A$f_p, tolerance = 1e-8, info = tag) + expect_identical(B$nb, A$nb, info = tag) + expect_identical(B$cen, A$cen, info = tag) + expect_identical(B$status, A$status, info = tag) + } + } +}) + + +# ---- 9. Row order and numbering ---------------------------------------------- + +test_that("9. the fit does not depend on the order of the rows or the numbering of the regions", { + cases <- list(`3,000 rows at 4.5 a region` = .pt_layout(4L), + `the lattice in 667 regions` = .pt_lattice(667L), + `the lattice in 1,500 regions` = .pt_lattice(1500L)) + # The lattice at 1,500 centres is there for the rows alone in their region: + # at 667 it has none, and their neighbour is where a tie could go by row. + expect_identical(sum(tabulate(cases[[2L]]$gi) == 1L), 0L) + expect_gt(sum(tabulate(cases[[3L]]$gi) == 1L), 100L) + for (nm in names(cases)) for (f in .pt_paths()) { + L <- cases[[nm]]; tag <- sprintf("%s, %s", nm, .pt_path_tag(f)) + y <- L$y; gi <- L$gi; K <- L$K; xy <- L$xy; N <- length(y) + A <- .pool_fit(y, gi, K, xy, use_fnn = f) + # The centroids are the sums of the rows taken by first coordinate, then + # by second: that expression and no other order that would do as well. + o <- order(xy[, 1], xy[, 2]) + expect_identical(unname(A$cen), unname(rowsum(xy[o, , drop = FALSE], gi[o]) / A$n), info = tag) + worst <- 0 + for (s in 1:20) { + .pt_seed(100 + s) + p <- sample(N) # row i of the new order is row p[i] + lab <- sample(K) # region j is now numbered lab[j] + B <- .pool_fit(y[p], lab[gi[p]], K, xy[p, , drop = FALSE], use_fnn = f) + # Every region has the same regions as neighbours, nearest first. + expect_identical(B$nb[lab, , drop = FALSE], matrix(lab[A$nb], K), info = tag) + # The centroids are the same numbers: they are summed in coordinate order. + expect_identical(unname(B$cen[lab, , drop = FALSE]), unname(A$cen), info = tag) + expect_identical(B$n[lab], A$n, info = tag) + worst <- max(worst, + .pt_gap(B$S[lab], A$S), .pt_gap(B$m[lab], A$m), + .pt_gap(B$target[lab], A$target), .pt_gap(B$w[lab], A$w), + .pt_gap(B$value[lab], A$value), + .pt_gap(B$resid_pooled, A$resid_pooled[p]), + .pt_gap(B$resid_mean, A$resid_mean[p])) + for (v in c("sigma2", "tau2", "Q", "loo_pooled", "loo_pooled_se", "loo_mean", + "loo_mean_se", "loo_one", "loo_one_se")) + expect_equal(B[[v]], A[[v]], tolerance = 1e-12, info = paste(tag, v)) + expect_equal(B$f_p, A$f_p, tolerance = 1e-9, info = tag) + expect_identical(B$status, A$status, info = tag) + } + expect_lt(worst, 1e-12) + } +}) + +test_that("9. on the lattice, centroids summed in row order would move with the rows", { + # What the test above guards against, shown on its own data: the centroid + # of a region summed in the order of the rows is not the same number from + # one row order to the next. + L <- .pt_lattice(667L) + n <- tabulate(L$gi, L$K) + moved <- vapply(1:5, function(s) { + .pt_seed(100 + s) + p <- sample(length(L$y)) + !identical(unname(rowsum(L$xy[p, ], L$gi[p]) / n), unname(rowsum(L$xy, L$gi) / n)) + }, NA) + expect_true(all(moved)) +}) + + +# ---- 10. Weights and values -------------------------------------------------- + +test_that("10. weights lie in [0, 1], rise with the count, and values lie between mean and target", { + for (i in 1:7) for (f in .pt_paths()) { + L <- .pt_layout(i); tag <- sprintf("layout %d, %s", i, .pt_path_tag(f)) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + expect_true(all(A$w >= 0 & A$w <= 1), info = tag) + lo <- pmin(A$m, A$target); hi <- pmax(A$m, A$target) + slack <- 1e-12 * max(abs(c(A$m, A$target))) + expect_true(all(A$value >= lo - slack & A$value <= hi + slack), info = tag) + # Within one fit a region with more rows has the larger weight, and + # regions of one count have one weight. + expect_gt(A$tau2, 0) + by_n <- split(A$w, A$n) + expect_true(all(vapply(by_n, function(v) length(unique(v)) == 1L, NA)), info = tag) + one <- vapply(by_n, function(v) v[1L], numeric(1)) + expect_true(all(diff(one[order(as.integer(names(one)))]) > 0), info = tag) + expect_equal(A$w, A$tau2 / (A$tau2 + A$sigma2 / A$n), tolerance = 1e-12, info = tag) + } +}) + + +# ---- 11. No spread ----------------------------------------------------------- + +test_that("11. a constant column gets outputs that are set, whatever its value", { + L <- .pt_small() + expect_identical(length(L$gi), 400L) + expect_gte(L$K, 85L) + for (f in .pt_paths()) for (const in c(0.1, 1234.56, 1 / 3, 52000.37, -7e-9, 0)) { + tag <- sprintf("constant %s, %s", format(const, digits = 8), .pt_path_tag(f)) + A <- .pool_fit(rep(const, 400), L$gi, L$K, L$xy, use_fnn = f) + expect_identical(A$sigma2, 0, info = tag) + expect_identical(A$tau2, 0, info = tag) + expect_identical(A$w, rep(1, L$K), info = tag) + expect_identical(A$value, A$m, info = tag) + expect_identical(A$resid_pooled, numeric(400), info = tag) + expect_identical(A$resid_mean, numeric(400), info = tag) + for (v in c("loo_pooled", "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", + "loo_one_se", "f_p")) + expect_identical(A[[v]], NA_real_, info = paste(tag, v)) + expect_true(A$constant, info = tag) + expect_true(A$flat, info = tag) + expect_identical(A$status, "no spread inside any cell", info = tag) + expect_lt(max(abs(A$value - const)), 1e-9 * max(abs(const), 1e-300)) + } + # The arithmetic these outputs replace: for a constant that is not exact in + # binary the sums of squares are rounding error and not zero, so the rule + # has something to catch. 3.5 is exact and would not test it. + y <- rep(0.1, 400) + m <- as.numeric(rowsum(y, L$gi)) / tabulate(L$gi) + expect_gt(sum((y - m[L$gi])^2), 0) + expect_identical(sum((rep(3.5, 400) - 3.5)^2), 0) +}) + +test_that("11. a column constant inside every region and not overall is flat, not constant", { + L <- .pt_small(); gi <- L$gi; K <- L$K; n <- tabulate(gi, K) + alone <- which(n[gi] == 1L) + shared <- n[gi] > 1L + expect_gt(length(alone), 0L) + for (f in .pt_paths()) { + for (scaling in list(function(g) 0.1 * g, function(g) 1234.56 + g / 7, + function(g) as.numeric(g))) { + y <- scaling(gi) + tag <- sprintf("first value %s, %s", format(y[1L]), .pt_path_tag(f)) + A <- .pool_fit(y, gi, K, L$xy, use_fnn = f) + expect_true(A$flat, info = tag) + expect_false(A$constant, info = tag) + expect_identical(A$sigma2, 0, info = tag) + expect_identical(A$w, rep(1, K), info = tag) + expect_identical(A$value, A$m, info = tag) + expect_identical(A$status, "no spread inside any cell", info = tag) + expect_identical(A$f_p, NA_real_, info = tag) + # Residuals: exactly 0 for a row that shares its region; for a row + # alone in its region, its distance from the target (pooled) and from + # the mean of its nearest other row's region (plain). + expect_true(all(A$resid_pooled[shared] == 0), info = tag) + expect_true(all(A$resid_mean[shared] == 0), info = tag) + expect_identical(A$resid_pooled[alone], y[alone] - A$target[gi[alone]], info = tag) + near <- .pt_nearest_other(L$xy, gi, alone) + expect_identical(A$resid_mean[alone], y[alone] - A$m[gi[near]], info = tag) + expect_true(all(A$resid_mean[alone] != 0), info = tag) + for (v in c("loo_pooled", "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", + "loo_one_se", "tau2", "Q")) + expect_true(is.finite(A[[v]]), info = paste(tag, v)) + expect_gt(A$tau2, 0) + } + } +}) + +test_that("11. the rule for no spread is relative to the size of the values", { + L <- .pt_small() + noise <- local({ .pt_seed(11); stats::rnorm(400) }) + A <- .pool_fit(1e6 + 1e-9 * noise, L$gi, L$K, L$xy, use_fnn = FALSE) + expect_true(A$constant) + expect_identical(A$status, "no spread inside any cell") + expect_identical(A$w, rep(1, L$K)) + B <- .pool_fit(1e6 + 1e-3 * noise, L$gi, L$K, L$xy, use_fnn = FALSE) + expect_false(B$constant) + expect_false(B$flat) + expect_gt(B$sigma2, 1e-7) + expect_true(B$status %in% c("ok", "no signal between cells")) + expect_true(is.finite(B$loo_pooled)) + # The rule itself. + y <- c(1, 2, 3) + lim <- 100 * .Machine$double.eps^2 * sum(y^2) + expect_true(.no_spread(lim, y)) + expect_false(.no_spread(lim * 1.01, y)) + expect_true(.no_spread(0, c(0, 0))) +}) + +test_that("11. a constant column in regions of 500 rows gets the same outputs", { + L <- .pt_large(4L); gi <- L$gi; K <- L$K; N <- length(gi) + expect_identical(tabulate(gi), rep(500L, 4)) + for (f in .pt_paths()) for (const in c(0.1, 1234.56, 52000.37, 0.7)) { + tag <- sprintf("constant %s, %s", format(const, digits = 8), .pt_path_tag(f)) + y <- rep(const, N) + # Why these regions: the sum of 500 such values is off by a rounding + # error, so the sum of squares inside the regions, as the fit computes + # it, does not pass for no spread. Only the test of the whole column, or + # the one about corrected means, sees that this column has none. + expect_false(.pt_written_rule(y, gi), info = tag) + A <- .pool_fit(y, gi, K, L$xy, use_fnn = f) + expect_true(A$constant, info = tag) + expect_true(A$flat, info = tag) + expect_identical(A$status, "no spread inside any cell", info = tag) + expect_identical(A$sigma2, 0, info = tag) + expect_identical(A$tau2, 0, info = tag) + expect_identical(A$w, rep(1, K), info = tag) + expect_identical(A$value, A$m, info = tag) + expect_identical(A$resid_pooled, numeric(N), info = tag) + expect_identical(A$resid_mean, numeric(N), info = tag) + for (v in c("loo_pooled", "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", + "loo_one_se", "f_p")) + expect_identical(A[[v]], NA_real_, info = paste(tag, v)) + } +}) + +test_that("11. a column constant inside regions of 500 rows is flat", { + L <- .pt_large(12L); gi <- L$gi; K <- L$K; N <- length(gi); n <- tabulate(gi) + expect_identical(n, rep(500L, 12)) + for (f in .pt_paths()) + for (scaling in list(function(g) 0.1 * g, function(g) 1234.56 + g / 7, function(g) g / 3)) { + y <- scaling(gi) + tag <- sprintf("first value %s, %s", format(y[1L], digits = 8), .pt_path_tag(f)) + # Not flat by the sum of squares the fit computes: the means carry the + # rounding of their sums. + expect_false(.pt_written_rule(y, gi), info = tag) + A <- .pool_fit(y, gi, K, L$xy, use_fnn = f) + expect_true(A$flat, info = tag) + expect_false(A$constant, info = tag) + expect_identical(A$status, "no spread inside any cell", info = tag) + expect_identical(A$sigma2, 0, info = tag) + expect_identical(A$w, rep(1, K), info = tag) + expect_identical(A$value, A$m, info = tag) + expect_identical(A$f_p, NA_real_, info = tag) + # Every row shares its region, so every residual is exactly 0. + expect_identical(A$resid_pooled, numeric(N), info = tag) + expect_identical(A$resid_mean, numeric(N), info = tag) + expect_identical(A$loo_pooled, 0, info = tag) + expect_identical(A$loo_mean, 0, info = tag) + expect_true(is.finite(A$loo_one) && A$loo_one > 0, info = tag) + expect_gt(A$tau2, 0) + } + + # In the column's record the status is the same, and `structured` is not + # read for a column without spread. + P <- .pool_column(0.1 * gi, gi, L$xy, obs_level = 0.9, want = "pooled", use_fnn = FALSE) + expect_identical(P$record$status, "no spread inside any cell") + expect_false(P$record$constant) + expect_identical(P$record$sigma2, 0) + expect_identical(P$record$structured, NA) + expect_identical(P$record$offsets, c(0, 0)) + + # Values that differ inside a region by a last bit or two have no spread + # either: the rule is the bound of .no_spread(), not equality. + y <- (0.1 * gi) * (1 + .Machine$double.eps * rep_len(c(-2, 1, 0, 2, -1), N)) + expect_gt(length(unique(y[gi == 1L])), 2L) + expect_false(.pt_written_rule(y, gi)) + A <- .pool_fit(y, gi, K, L$xy, use_fnn = FALSE) + expect_true(A$flat) + expect_false(A$constant) + expect_identical(A$status, "no spread inside any cell") + expect_identical(A$w, rep(1, K)) + # A spread of one part in a million million inside the regions is spread. + y <- (0.1 * gi) * (1 + 1e-12 * local({ .pt_seed(113); stats::rnorm(N) })) + B <- .pool_fit(y, gi, K, L$xy, use_fnn = FALSE) + expect_false(B$flat) + expect_gt(B$sigma2, 0) + expect_true(B$status %in% c("ok", "no signal between cells")) + + # The corrected sum of squares itself. With no spread it is far below the + # sum about the means as summed; with spread the two are one number to + # rounding, so a column that has spread is never called flat by it. + y <- 1234.56 + gi / 7 + res <- y - (as.numeric(rowsum(y, gi)) / n)[gi] + expect_gt(sum(res^2), 100 * .Machine$double.eps^2 * sum(y^2)) + expect_lt(.ss_within(res, gi, n), 1e-6 * sum(res^2)) + y <- .pt_layout(4L) + res <- y$y - (as.numeric(rowsum(y$y, y$gi)) / tabulate(y$gi))[y$gi] + expect_equal(.ss_within(res, y$gi, tabulate(y$gi)), sum(res^2), tolerance = 1e-12) + expect_identical(.ss_within(c(1, -1, 2, 4), c(1L, 1L, 2L, 2L), c(2L, 2L)), 4) +}) + +test_that("the own weight is tau2 over tau2 plus the mean's variance, and 1 where both are 0", { + expect_identical(.pool_weight(1, 1), 0.5) + expect_identical(.pool_weight(3, 1), 0.75) + expect_identical(.pool_weight(0, 2), 0) + expect_identical(.pool_weight(2, 0), 1) + expect_identical(.pool_weight(0, 0), 1) + expect_identical(.pool_weight(0.5, c(0.5, 1.5, 0)), c(0.5, 0.25, 1)) + expect_identical(.pool_weight(0, c(0, 4)), c(1, 0)) + # The reference's two forms of it. + expect_identical(.pool_weight(0.37, 1.2 / 1:9), weight(0.37, 1.2, 1:9)) + expect_identical(.pool_weight(c(0, 0.37, 0), c(0, 0.4, 1)), wfun(c(0, 0.37, 0), c(0, 0.4, 1))) +}) + + +# ---- 12. The order of the degenerate cases ----------------------------------- + +test_that("12. one region with several rows: the plain mean and the plain residuals", { + y <- c(2.5, 3.25, 1, 4.75, 3) + xy <- cbind(c(0, 10, 20, 30, 45), c(5, 0, 12, 7, 3)) + for (f in .pt_paths()) { + A <- .pool_fit(y, rep(1L, 5), 1L, xy, use_fnn = f) + expect_identical(A$status, "one cell") + expect_identical(A$m, 14.5 / 5) + expect_identical(A$value, A$m) + expect_identical(A$w, 1) + expect_identical(A$target, NA_real_) + expect_identical(A$tau2, NA_real_) + expect_identical(A$Q, NA_real_) + expect_identical(A$f_p, NA_real_) + expect_identical(dim(A$nb), c(1L, 0L)) + expect_true(is.integer(A$nb)) + expect_equal(A$sigma2, sum((y - mean(y))^2) / 4, tolerance = 1e-14) + expect_equal(A$sigma2, stats::var(y), tolerance = 1e-14) + e <- vapply(1:5, function(i) y[i] - mean(y[-i]), numeric(1)) + expect_lt(.pt_gap(A$resid_pooled, e), 1e-14) + expect_identical(A$resid_mean, A$resid_pooled) + expect_identical(A$resid_pooled, (y - A$m) * 5 / 4) + expect_equal(A$loo_pooled, mean(e^2), tolerance = 1e-14) + expect_identical(A$loo_mean, A$loo_pooled) + expect_identical(A$loo_one, A$loo_pooled) + expect_equal(A$loo_pooled_se, stats::sd(e^2) / sqrt(5), tolerance = 1e-14) + expect_identical(A$loo_one_se, A$loo_pooled_se) + expect_equal(unname(A$cen), matrix(colMeans(xy), 1L), tolerance = 1e-14) + expect_false(A$constant) + expect_false(A$flat) + } +}) + +test_that("12. one region and a constant column, and one region of one row", { + xy <- cbind(c(0, 10, 20), c(5, 0, 12)) + y <- rep(0.1, 3) + # Three times 0.1 over 3 is not 0.1 in floating point, so the sum of + # squares about the mean is rounding error and not zero. + expect_gt(sum((y - sum(y) / 3)^2), 0) + A <- .pool_fit(y, rep(1L, 3), 1L, xy, use_fnn = FALSE) + expect_identical(A$status, "one cell") # not "no spread inside any cell" + expect_identical(A$sigma2, 0) + expect_identical(A$resid_pooled, numeric(3)) + expect_identical(A$resid_mean, numeric(3)) + for (v in c("loo_pooled", "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", + "loo_one_se", "tau2", "target", "f_p")) + expect_identical(A[[v]], NA_real_, info = v) + expect_identical(A$w, 1) + expect_identical(A$value, A$m) + expect_true(A$constant) + expect_true(A$flat) + + B <- .pool_fit(7.25, 1L, 1L, cbind(3, 4), use_fnn = FALSE) + expect_identical(B$status, "one cell") + expect_identical(B$value, 7.25) + expect_identical(B$w, 1) + expect_identical(B$N, 1L) + expect_identical(B$K, 1L) + expect_identical(B$sigma2, NA_real_) + expect_identical(B$resid_pooled, NA_real_) + expect_identical(B$resid_mean, NA_real_) + for (v in c("loo_pooled", "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", + "loo_one_se", "tau2", "target", "Q", "f_p")) + expect_identical(B[[v]], NA_real_, info = v) + expect_identical(dim(B$nb), c(1L, 0L)) + # The interval read from these residuals has no ends. + expect_identical(.obs_offsets(B$resid_pooled, 0.9), c(NA_real_, NA_real_)) +}) + +test_that("12. no region holds two rows: a status and no fit", { + y <- c(4, 1, 3, 9, 2, 6, 5, 8, 7, 10) / 7 + xy <- cbind(seq(0, 90, by = 10), c(3, 1, 4, 1, 5, 9, 2, 6, 5, 3)) + for (case in list(y, rep(0.1, 10))) { # with spread, and constant + A <- .pool_fit(case, 1:10, 10L, xy, use_fnn = FALSE) + expect_identical(A$status, "no cell holds two values") + expect_identical(A$n, rep(1L, 10)) + expect_identical(A$S, case) + expect_identical(A$m, case) + expect_identical(A$N, 10L) + expect_identical(A$K, 10L) + expect_null(A$resid_pooled) + expect_null(A$resid_mean) + for (v in c("sigma2", "cen", "nb", "target", "Q", "tau2", "w", "value", "loo_pooled", + "loo_pooled_se", "loo_mean", "loo_mean_se", "loo_one", "loo_one_se", "f_p")) + expect_true(all(is.na(A[[v]])), info = v) + expect_true(A$flat) + } + expect_false(.pool_fit(y, 1:10, 10L, xy, use_fnn = FALSE)$constant) + expect_true(.pool_fit(rep(0.1, 10), 1:10, 10L, xy, use_fnn = FALSE)$constant) + # No search is made for a fit that is not made. + local_mocked_bindings(.region_neighbours = function(...) stop("searched"), + .nearest_other = function(...) stop("searched")) + expect_identical(.pool_fit(y, 1:10, 10L, xy, use_fnn = FALSE)$status, + "no cell holds two values") +}) + +test_that("12. region means that are all equal: no signal between cells", { + # Thirty regions of four rows whose values sum to exactly zero in each, so + # every plain mean and every target is 0 by construction. + cen <- local({ .pt_seed(12); cbind(stats::runif(30, 0, 1e5), stats::runif(30, 0, 1e5)) }) + gi <- rep(1:30, each = 4L) + xy <- cen[gi, ] + cbind(rep(c(-40, 40, -40, 40), 30), rep(c(-40, -40, 40, 40), 30)) + # Each value is followed by its negative, so the running sum of a region + # returns to exactly 0 whatever the scale. + y <- rep(c(-1.5, 1.5, -0.5, 0.5), 30) * rep(seq(1, 2, length.out = 30), each = 4L) + for (f in .pt_paths()) { + A <- .pool_fit(y, gi, 30L, xy, use_fnn = f) + expect_identical(A$m, numeric(30)) + expect_identical(A$status, "no signal between cells") + expect_identical(A$tau2, 0) + expect_gt(A$sigma2, 0) + expect_identical(A$w, numeric(30)) + expect_identical(A$value, A$target) + expect_identical(A$Q, 0) + expect_false(A$flat) + expect_false(A$constant) + expect_true(is.finite(A$loo_pooled) && A$loo_pooled > 0) + expect_identical(A$f_p, 1) + # With a weight of 0 a left-out row is predicted by its region's target. + expect_identical(A$resid_pooled, y - A$target[gi]) + } + # A column with no spread at all has no signal either; the earlier case names it. + expect_identical(.pool_fit(rep(0.1, 120), gi, 30L, xy, use_fnn = FALSE)$status, + "no spread inside any cell") +}) + +test_that("12. one region: `want` decides which residuals are returned", { + y <- c(2.5, 3.25, 1, 4.75, 3) + xy <- cbind(c(0, 10, 20, 30, 45), c(5, 0, 12, 7, 3)) + both <- .pool_fit(y, rep(1L, 5), 1L, xy, use_fnn = FALSE) + pooled <- .pool_fit(y, rep(1L, 5), 1L, xy, want = "pooled", use_fnn = FALSE) + plain <- .pool_fit(y, rep(1L, 5), 1L, xy, want = "mean", use_fnn = FALSE) + shared <- c("n", "S", "m", "N", "K", "sigma2", "cen", "nb", "target", "Q", "tau2", "w", + "value", "loo_one", "loo_one_se", "f_p", "constant", "flat", "status") + expect_identical(pooled[shared], both[shared]) + expect_identical(plain[shared], both[shared]) + expect_identical(names(pooled), names(both)) + expect_identical(names(plain), names(both)) + expect_true(is.finite(both$loo_pooled) && is.finite(both$loo_mean)) + # The one asked for is the full fit's; the other has no vector and NA for + # its two numbers. + expect_identical(pooled[c("resid_pooled", "loo_pooled", "loo_pooled_se")], + both[c("resid_pooled", "loo_pooled", "loo_pooled_se")]) + expect_null(pooled$resid_mean) + expect_identical(pooled$loo_mean, NA_real_) + expect_identical(pooled$loo_mean_se, NA_real_) + expect_identical(plain[c("resid_mean", "loo_mean", "loo_mean_se")], + both[c("resid_mean", "loo_mean", "loo_mean_se")]) + expect_null(plain$resid_pooled) + expect_identical(plain$loo_pooled, NA_real_) + expect_identical(plain$loo_pooled_se, NA_real_) +}) + +test_that("12. the fit refuses regions that are not numbered 1 to K with a row in each", { + xy <- cbind(1:6, c(2, 4, 1, 3, 6, 5)) + y <- c(1, 2, 4, 3, 6, 5) + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 4L, 4L), 4L, xy, use_fnn = FALSE), "numbered 1 to K") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 3L), 2L, xy, use_fnn = FALSE), "numbered 1 to K") + # Three numbers in use and K = 3, but one of them is not among 1 to K. + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 4L, 4L), 3L, xy, use_fnn = FALSE), "numbered 1 to K") + # Every region of 1 to K holds a row, and one row is in none of them. + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 4L), 3L, xy, use_fnn = FALSE), "numbered 1 to K") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 0L), 3L, xy, use_fnn = FALSE), "numbered 1 to K") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, NA, 3L), 3L, xy, use_fnn = FALSE), "numbered 1 to K") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 3L), 3L, xy[1:5, ], use_fnn = FALSE), + "one row per value") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 3L), 3L, xy, want = character(0)), "`want`") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L, 3L), 3L, xy, want = "median"), "`want`") + # No value at all, and a region for some of the values only. + expect_error(.pool_fit(numeric(0), integer(0), 0L, matrix(0, 0L, 2L), use_fnn = FALSE), + "at least one value") + expect_error(.pool_fit(y, c(1L, 1L, 2L, 2L, 3L), 3L, xy, use_fnn = FALSE), "the region of each") +}) + +test_that("12. a coordinate matrix that is not two columns of numbers is refused", { + # With a third column the kd-tree would search in three dimensions and the + # exact search in two, and the two paths would give different neighbours. + L <- .pt_layout(2L); n <- tabulate(L$gi) + xyz <- cbind(L$xy, 100 * seq_along(L$y)) + for (f in .pt_paths()) { + tag <- .pt_path_tag(f) + expect_error(.pool_fit(L$y, L$gi, L$K, xyz, use_fnn = f), "two columns", info = tag) + expect_error(.pool_fit(L$y, L$gi, L$K, xyz, want = "pooled", use_fnn = f, + geo = .pool_geometry(L$gi, L$K, L$xy, n, f)), + "two columns", info = tag) + expect_error(.pool_geometry(L$gi, L$K, xyz, n, f), "two columns", info = tag) + expect_error(.nearest_other(xyz, L$gi, 1:5, f), "two columns", info = tag) + expect_error(.region_neighbours(xyz[1:30, ], 8L, f), "two columns", info = tag) + # A column's rows are handed over as their first two coordinates, so a + # layer with heights gets the answer of the layer without, on both paths. + expect_identical(.pool_column(L$y, L$gi, xyz, 0.9, c("pooled", "mean"), f), + .pool_column(L$y, L$gi, L$xy, 0.9, c("pooled", "mean"), f), info = tag) + } + expect_error(.pool_fit(L$y, L$gi, L$K, as.data.frame(L$xy), use_fnn = FALSE), "numeric matrix") + expect_error(.pool_fit(L$y, L$gi, L$K, L$xy[, 1], use_fnn = FALSE), "numeric matrix") + expect_error(.pool_fit(L$y, L$gi, L$K, matrix("a", nrow(L$xy), 2L), use_fnn = FALSE), + "numeric matrix") + # Two columns of numbers that are no matrix: an array of three dimensions. + expect_error(.pool_fit(L$y, L$gi, L$K, array(L$xy, c(nrow(L$xy), 2L, 1L)), use_fnn = FALSE), + "numeric matrix") + expect_error(.pool_geometry(L$gi, L$K, L$xy[-1, ], n, FALSE), "one row per value") + expect_error(.nearest_other(L$xy[-1, ], L$gi, 1:5, FALSE), "one row per value") +}) + +test_that("12. whole numbers are fitted as doubles, values and coordinates alike", { + # rowsum() of integers returns NA, without a warning, once a sum passes + # .Machine$integer.max. Here every region's sum of the values does, and + # every region's sum of the second coordinate. + L <- .pt_large(4L); gi <- L$gi; K <- L$K; N <- length(gi) + y <- as.integer(round(5e6 + 1e5 * local({ .pt_seed(121); stats::rnorm(N) }))) + xi <- round(cbind(4e5, 5.1e6)[rep(1L, N), ] + L$xy) + xd <- xi + storage.mode(xi) <- "integer" + expect_true(is.integer(y) && is.integer(xi) && is.double(xd)) + expect_true(all(is.na(suppressWarnings(rowsum(y, gi))))) + expect_true(all(is.na(suppressWarnings(rowsum(xi[, 2], gi))))) + for (f in .pt_paths()) { + tag <- .pt_path_tag(f) + A <- .pool_fit(as.numeric(y), gi, K, xd, use_fnn = f) + expect_identical(A$status, "ok", info = tag) + expect_false(anyNA(A$value) || anyNA(A$cen), info = tag) + expect_identical(.pool_fit(y, gi, K, xd, use_fnn = f), A, info = tag) + expect_identical(.pool_fit(as.numeric(y), gi, K, xi, use_fnn = f), A, info = tag) + expect_identical(.pool_fit(y, gi, K, xi, use_fnn = f), A, info = tag) + expect_identical(.pool_geometry(gi, K, xi, A$n, f), A[c("cen", "nb")], info = tag) + expect_identical(.nearest_other(xi, gi, seq_len(N), f), .nearest_other(xd, gi, seq_len(N), f), + info = tag) + # The same through a column of an assigned layer. + P <- .pool_column(as.numeric(y), gi, xd, 0.9, c("pooled", "mean"), f) + expect_identical(P$fit, A, info = tag) + expect_identical(.pool_column(y, gi, xi, 0.9, c("pooled", "mean"), f), P, info = tag) + } + # One region, the case in which an integer sum past the limit gave NA and + # the status "one cell". + one <- .pool_fit(y, rep(1L, N), 1L, xd, use_fnn = FALSE) + expect_identical(one$value, sum(as.numeric(y)) / N) + expect_identical(one, .pool_fit(as.numeric(y), rep(1L, N), 1L, xd, use_fnn = FALSE)) +}) + + +# ---- 13. Neighbours of the regions ------------------------------------------- + +# Centroids on which a search by distance alone has no single answer. +.pt_centroid_sets <- function() { + .pt_seed(13) + base <- cbind(stats::runif(40, 0, 1e5), stats::runif(40, 0, 1e5)) + coincident <- base + coincident[12, ] <- coincident[5, ] # a pair + coincident[33, ] <- coincident[20, ] # another + coincident[8, ] <- coincident[30, ] <- coincident[7, ] # a triple + list(`two pairs and a triple of coincident centroids` = coincident, + `a lattice of centroids` = + unname(as.matrix(expand.grid(seq(0.1, by = 0.7, length.out = 30), + seq(0.3, by = 0.7, length.out = 30)))), + `centroids rounded to the kilometre` = + round(cbind(stats::runif(600, 0, 3e4), stats::runif(600, 0, 3e4)), -3), + `two regions` = base[1:2, ], + `two regions on one centroid` = base[c(3, 3), ], + `three regions` = base[1:3, ], + `three regions on a line` = cbind(c(0, 1, 2), 0), + `nine regions` = base[1:9, ], + `ten regions` = base[1:10, ], + `no ties` = base) +} + +test_that("13. no region is its own neighbour, and ties go by coordinate, then by number", { + sets <- .pt_centroid_sets() + expect_gt(anyDuplicated(sets[[1L]]), 0L) + expect_gt(anyDuplicated(sets[[3L]]), 0L) + for (nm in names(sets)) for (f in .pt_paths()) { + cen <- sets[[nm]]; K <- nrow(cen); tag <- sprintf("%s, %s", nm, .pt_path_tag(f)) + nb <- .region_neighbours(cen, 8L, f) + expect_true(is.integer(nb), info = tag) + expect_identical(dim(nb), c(K, min(8L, K - 1L)), info = tag) + expect_false(any(nb == seq_len(K)), info = tag) + expect_true(all(nb >= 1L & nb <= K), info = tag) + expect_true(all(apply(nb, 1L, anyDuplicated) == 0L), info = tag) + expect_identical(nb, .pt_neighbours(cen, 8L), info = tag) + # Nearest first. + d <- matrix(sqrt((cen[nb, 1] - cen[, 1])^2 + (cen[nb, 2] - cen[, 2])^2), K) + if (ncol(d) > 1L) expect_true(all(d[, -1L] >= d[, -ncol(d)]), info = tag) + # Another number of neighbours. + expect_identical(.region_neighbours(cen, 3L, f), .pt_neighbours(cen, 3L), info = tag) + # Renumbered, the regions keep their neighbours, but for regions on one + # centroid, which only their number tells apart. + if (!anyDuplicated(cen)) { + lab <- local({ .pt_seed(131); sample(K) }) + cen2 <- cen; cen2[lab, ] <- cen + expect_identical(.region_neighbours(cen2, 8L, f)[lab, , drop = FALSE], + matrix(lab[nb], K), info = tag) + } + } + # One region has no neighbour, and none is searched for. + expect_identical(.region_neighbours(cbind(1, 2), 8L, FALSE), matrix(0L, 1L, 0L)) +}) + +test_that("13. FNN's path and the exact path return the same neighbours", { + skip_if_not_installed("FNN") + sets <- .pt_centroid_sets() + for (nm in names(sets)) { + cen <- sets[[nm]] + for (k in c(8L, 3L, 1L)) + expect_identical(.region_neighbours(cen, k, TRUE), .region_neighbours(cen, k, FALSE), + info = sprintf("%s, %d neighbours", nm, k)) + } + # On coincident centroids the kd-tree alone returns a region as its own + # neighbour, which is why such rows are searched again. + co <- sets[[1L]] + raw <- FNN::get.knn(co, k = 8L)$nn.index + expect_true(any(raw == seq_len(nrow(co)))) + # Where nothing ties, the neighbours are the kd-tree's own. + expect_identical(.region_neighbours(sets[["no ties"]], 8L, TRUE), + FNN::get.knn(sets[["no ties"]], k = 8L)$nn.index) + # A whole fit on coincident centroids: the two paths agree, and no region's + # own sum is in its target. + L <- .pt_layout(2L) + xy <- L$xy + twins <- which(L$gi %in% c(4L, 9L)) + # Regions 4 and 9 on one point, in whole metres so that both centroids + # are that point exactly. + xy[twins, ] <- round(xy[rep(twins[1L], length(twins)), ]) + A <- .pool_fit(L$y, L$gi, L$K, xy, use_fnn = TRUE) + B <- .pool_fit(L$y, L$gi, L$K, xy, use_fnn = FALSE) + expect_identical(unname(A$cen[4, ]), unname(A$cen[9, ])) + expect_identical(A, B) + expect_false(any(A$nb == seq_len(L$K))) +}) + +# Stand-ins for FNN's two searches that return what a kd-tree with other +# rounding than R's could return. Such a tree ranks candidates at nearly one +# distance in another order than the distances R computes, so it can hand +# back the further members of such a group and leave the nearest out. These +# do that and nothing else: where the candidates around the end of the list +# are within one part in 1e9 of one squared distance, as the package computes +# it, the nearest of them is dropped and the next one taken in. `count$rows` +# counts the rows it happened to. +.pt_by_distance <- function(nn, d2) { + o <- t(apply(d2, 1L, order)) + at <- cbind(as.vector(row(o)), as.vector(o)) + list(nn = matrix(nn[at], nrow(nn)), d2 = matrix(d2[at], nrow(nn))) +} +.pt_push_knn <- function(real, count) { + force(real); force(count) # FNN's own function, read before it is replaced + function(data, k = 10, ...) { + n <- nrow(data) + if (k < 2L || k + 1L > n - 1L) return(real(data, k = k, ...)) + nn <- real(data, k = k + 1L, ...)$nn.index + d2 <- matrix((data[nn, 1] - data[, 1])^2 + (data[nn, 2] - data[, 2])^2, n) + s <- .pt_by_distance(nn, d2) + # Places k - 1, k and k + 1 at nearly one distance: k - 1 is left out. + group <- s$d2[, k + 1L] <= s$d2[, k - 1L] * (1 + 1e-9) + out <- s$nn[, seq_len(k), drop = FALSE] + out[group, ] <- s$nn[group, c(seq_len(k - 2L), k, k + 1L), drop = FALSE] + count$rows <- count$rows + sum(group) + list(nn.index = out) + } +} +.pt_push_knnx <- function(real, count) { + force(real); force(count) + function(data, query, k = 10, ...) { + if (k != 3L || nrow(data) < 5L) return(real(data, query, k = k, ...)) + nn <- real(data, query, k = 4L, ...)$nn.index + d2 <- matrix((data[nn, 1] - query[, 1])^2 + (data[nn, 2] - query[, 2])^2, nrow(query)) + s <- .pt_by_distance(nn, d2) + # The location asked about stands first, at distance 0. Its three + # nearest others at nearly one distance: the nearest of them is left out. + group <- s$d2[, 4L] <= s$d2[, 2L] * (1 + 1e-9) + out <- s$nn[, 1:3, drop = FALSE] + out[group, ] <- s$nn[group, c(1L, 3L, 4L), drop = FALSE] + count$rows <- count$rows + sum(group) + list(nn.index = out) + } +} + +test_that("13. neighbours a kd-tree returns out of order within rounding are searched again", { + skip_if_not_installed("FNN") + # On this platform FNN's distances are R's to the last bit, so the lattices + # above give one answer whether or not near ties are searched again. The + # margin of one part in 1e9 is for a kd-tree built with other arithmetic; + # the stand-in is one. + square <- .pt_lattice(667L)$xy + a <- expand.grid(i = 0:29, j = 0:24) + hexagonal <- unname(cbind(a$i + 0.5 * (a$j %% 2), a$j * sqrt(3) / 2)) * 100 + 0.1 + for (case in list(list("square lattice, 2 neighbours", square, 2L), + list("square lattice, 5 neighbours", square, 5L), + list("hexagonal lattice, 8 neighbours", hexagonal, 8L))) { + u <- case[[2L]]; k <- case[[3L]] + want <- .region_neighbours(u, k, FALSE) + count <- new.env(); count$rows <- 0L + got <- local({ + local_mocked_bindings(get.knn = .pt_push_knn(FNN::get.knn, count), .package = "FNN") + .region_neighbours(u, k, TRUE) + }) + expect_gt(count$rows, nrow(u) %/% 2L) # most rows of a lattice + expect_identical(got, want, info = case[[1L]]) + } +}) + +# 1,316 centroids of which 811 share their point with eight others or more: +# 601 on one point, 201 on another and 9 on a third. 8 on a fourth and a +# pair on a fifth are one short of that and are searched for like any other. +.pt_point_key <- function(xy) sprintf("%.17g %.17g", xy[, 1], xy[, 2]) +.pt_crowded <- function() .pt_keep("crowded", { + .pt_seed(132) + base <- cbind(stats::runif(500, 0, 1e5), stats::runif(500, 0, 1e5)) + cen <- rbind(base, base[rep(1L, 600), ], base[rep(2L, 200), ], base[rep(3L, 8), ], + base[rep(4L, 7), ], base[rep(5L, 1), ]) + cen <- cen[sample(nrow(cen)), ] + key <- .pt_point_key(cen) + at <- match(key, key) + list(cen = cen, key = key, crowd = tabulate(at, nrow(cen))[at] > 8L) +}) + +test_that("13. centroids that share a point with eight others or more are not searched for", { + S <- .pt_crowded(); cen <- S$cen; K <- nrow(cen); crowd <- S$crowd + expect_identical(K, 1316L) + expect_identical(sum(crowd), 601L + 201L + 9L) + rule <- .pt_neighbours(cen, 8L) + expect_false(any(rule == seq_len(K))) + + # The exact path searches for the others only, and only they count as work. + searched <- NULL + exact <- .knn_exact_rows + local({ + local_mocked_bindings(.knn_exact_rows = function(x, y, rows, k) { + searched <<- c(searched, rows) + exact(x, y, rows, k) + }) + expect_identical(.region_neighbours(cen, 8L, FALSE), rule) + }) + expect_length(searched, sum(!crowd)) + pairs <- as.numeric(sum(!crowd)) * K + withr::with_options(list(spatialkit.exact_pairs_max = pairs - 1), { + e <- tryCatch(.region_neighbours(cen, 8L, FALSE), error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, pairs) + }) + withr::with_options(list(spatialkit.exact_pairs_max = pairs), + expect_identical(.region_neighbours(cen, 8L, FALSE), rule)) + # Fewer neighbours asked for: more points are crowded, and the rule holds. + expect_identical(.region_neighbours(cen, 1L, FALSE), .pt_neighbours(cen, 1L)) + expect_identical(.region_neighbours(cen, 7L, FALSE), .pt_neighbours(cen, 7L)) + + # Every centroid on one point: its neighbours are the first eight others + # by number, and nothing is searched, whatever the limit. + one <- cen[rep(which(crowd)[1L], 60L), ] + withr::with_options(list(spatialkit.exact_pairs_max = 0), { + nb <- .region_neighbours(one, 8L, FALSE) + expect_identical(nb, .pt_neighbours(one, 8L)) + expect_identical(nb[1L, ], 2:9) + expect_identical(nb[5L, ], c(1:4, 6:9)) + expect_identical(nb[9L, ], 1:8) + expect_identical(nb[60L, ], 1:8) + }) + # A whole fit of 40 regions of two rows, every row on one point in whole + # metres: no search, and no region's own sum in its target. + gi <- rep(1:40, each = 2L) + xy <- matrix(c(431250, 5123456), 80L, 2L, byrow = TRUE) + y <- local({ .pt_seed(133); stats::rnorm(80) }) + A <- withr::with_options(list(spatialkit.exact_pairs_max = 0), + .pool_fit(y, gi, 40L, xy, use_fnn = FALSE)) + expect_identical(A$nb, .pt_neighbours(unname(A$cen), 8L)) + expect_identical(A$nb[1L, ], 2:9) + expect_equal(A$target[1L], mean(y[gi %in% 2:9]), tolerance = 1e-14) + + skip_if_not_installed("FNN") + expect_identical(.pool_fit(y, gi, 40L, xy, use_fnn = TRUE), A) + # With FNN: the same neighbours; no centroid of a crowded point is handed + # to the search that settles ties, which would list every other centroid + # on its point for each of them; and what the kd-tree is asked for stays + # in proportion to the centroids, not to the square of a crowd. + tied <- NULL + asked <- 0 + settle <- .knn_tied_rows + knnx <- FNN::get.knnx + got <- local({ + local_mocked_bindings(.knn_tied_rows = function(u, rows, k) { + tied <<- rbind(tied, u[rows, , drop = FALSE]) + settle(u, rows, k) + }) + local_mocked_bindings(get.knnx = function(data, query, k = 10, ...) { + asked <<- asked + as.numeric(nrow(query)) * k + knnx(data, query, k = k, ...) + }, .package = "FNN") + .region_neighbours(cen, 8L, TRUE) + }) + expect_identical(got, rule) + expect_gt(nrow(tied), 0L) + expect_false(any(.pt_point_key(tied) %in% S$key[crowd])) + expect_true(any(.pt_point_key(tied) %in% S$key[!crowd])) + # One run: 27,362 entries, 21 for each centroid. Searching for the crowded + # ones as for the others asked for 1,518,789. + expect_lt(asked, 60 * K) + for (k in c(1L, 7L)) + expect_identical(.region_neighbours(cen, k, TRUE), .region_neighbours(cen, k, FALSE), + info = sprintf("%d neighbours", k)) + # Every centroid on one point: the kd-tree is not asked at all. + local({ + local_mocked_bindings(get.knn = function(...) stop("the kd-tree was asked"), + get.knnx = function(...) stop("the kd-tree was asked"), + .package = "FNN") + expect_identical(.region_neighbours(one, 8L, TRUE), .pt_neighbours(one, 8L)) + }) +}) + + +# ---- 14. The nearest other row ----------------------------------------------- + +.pt_row_sets <- function() { + .pt_seed(5) + xy <- cbind(stats::runif(3000, 0, 1e5), stats::runif(3000, 0, 1e5)) + lat <- unname(as.matrix(expand.grid(1:40, 1:40))) * 0.7 + rep_xy <- xy[c(1:2000, sample(2000, 1000, TRUE)), ] + rep_gi <- sample(700L, 3000, TRUE) + list(random = list(xy = xy, gi = .pt_regions(xy, 667L, 2L)), + lattice = list(xy = lat, gi = .pt_regions(lat, 500L, 4L)), + `repeated locations, regions at random` = list(xy = rep_xy, gi = rep_gi), + `twenty rows on two locations` = list(xy = cbind(rep(c(0, 1), 10), 0), gi = rep(1:5, 4)), + `three rows on a line` = list(xy = cbind(c(0, 1, 2), 0), gi = 1:3)) +} +.pt_rows <- function() .pt_keep("rows", { + sets <- .pt_row_sets() + lapply(sets, function(s) c(s, list(rule = .pt_nearest_other(s$xy, s$gi)))) +}) + +test_that("14. the nearest other row follows the rule, whatever the order of the rows", { + sets <- .pt_rows() + expect_identical(anyDuplicated(sets$random$xy), 0L) + expect_gt(sum(duplicated(sets[[3L]]$xy)), 500L) + for (nm in names(sets)) for (f in .pt_paths()) { + xy <- sets[[nm]]$xy; gi <- sets[[nm]]$gi; n <- nrow(xy); rows <- seq_len(n) + tag <- sprintf("%s, %s", nm, .pt_path_tag(f)) + a <- .nearest_other(xy, gi, rows, f) + expect_true(is.integer(a), info = tag) + expect_length(a, n) + expect_false(any(a == rows), info = tag) + expect_identical(a, sets[[nm]]$rule, info = tag) + # A subset of the rows, in any order, gets the rows' own answers. + pick <- c(n, 1L, rows[rows %% 7L == 3L]) + expect_identical(.nearest_other(xy, gi, pick, f), a[pick], info = tag) + expect_identical(.nearest_other(xy, gi, integer(0), f), integer(0), info = tag) + # Under another order of the rows the neighbour is at the same location + # and in the same region. + for (s in 1:10) { + .pt_seed(500 + s) + p <- sample(n) + ap <- .nearest_other(xy[p, , drop = FALSE], gi[p], rows, f) + expect_identical(gi[p][ap], gi[a[p]], info = tag) + expect_identical(xy[p, , drop = FALSE][ap, , drop = FALSE], xy[a[p], , drop = FALSE], + info = tag) + } + } + # A lattice in whole numbers is where the rule shows: every interior + # location has four others at exactly one distance, and the one with the + # lower first coordinate is taken, in any order of the rows. + grid <- cbind(as.numeric(rep(1:7, 6)), as.numeric(rep(1:6, each = 7))) + p <- local({ .pt_seed(14); sample(nrow(grid)) }) + for (f in .pt_paths()) { + a <- .nearest_other(grid[p, ], rep(1:6, 7), seq_len(nrow(grid)), f) + from <- grid[p, ]; to <- grid[p, ][a, ] + inner <- from[, 1] > 1 + expect_identical(to[inner, 1], from[inner, 1] - 1) + expect_identical(to[inner, 2], from[inner, 2]) + # On the left edge there is no such location; the nearest is above or below. + expect_identical(to[!inner, 1], from[!inner, 1]) + expect_identical(abs(to[!inner, 2] - from[!inner, 2]), rep(1, sum(!inner))) + } + # One row has no other. + expect_identical(.nearest_other(cbind(1, 2), 1L, 1L, FALSE), NA_integer_) +}) + +test_that("14. FNN's path and the exact path return the same rows, and the kd-tree's where nothing ties", { + skip_if_not_installed("FNN") + sets <- .pt_rows() + for (nm in names(sets)) { + xy <- sets[[nm]]$xy; gi <- sets[[nm]]$gi; rows <- seq_len(nrow(xy)) + expect_identical(.nearest_other(xy, gi, rows, TRUE), .nearest_other(xy, gi, rows, FALSE), + info = nm) + } + r <- sets$random + expect_identical(.nearest_other(r$xy, r$gi, seq_len(3000), TRUE), + FNN::get.knn(r$xy, k = 1L)$nn.index[, 1]) + expect_identical(.nearest_other(r$xy, r$gi, seq_len(3000), FALSE), + FNN::get.knn(r$xy, k = 1L)$nn.index[, 1]) +}) + +test_that("14. a nearest location a kd-tree returns out of order within rounding is searched again", { + skip_if_not_installed("FNN") + # The stand-in of test 13 for the other search: where a location's three + # nearest others are at nearly one distance it returns the second and the + # third and leaves the nearest out. + L <- .pt_lattice(1500L); rows <- seq_along(L$y) + want <- .nearest_other(L$xy, L$gi, rows, FALSE) + count <- new.env(); count$rows <- 0L + got <- local({ + local_mocked_bindings(get.knnx = .pt_push_knnx(FNN::get.knnx, count), .package = "FNN") + .nearest_other(L$xy, L$gi, rows, TRUE) + }) + expect_gt(count$rows, length(rows) %/% 2L) + expect_identical(got, want) +}) + +test_that("14. with a cache no location is searched twice", { + sets <- .pt_rows() + search <- .nearest_location_search + for (nm in c("random", "lattice", "repeated locations, regions at random")) + for (f in .pt_paths()) { + xy <- sets[[nm]]$xy; gi <- sets[[nm]]$gi; n <- nrow(xy); rows <- seq_len(n) + tag <- sprintf("%s, %s", nm, .pt_path_tag(f)) + plain <- .nearest_other(xy, gi, rows, f) + asked <- list() + local_mocked_bindings(.nearest_location_search = function(u, q, ...) { + asked[[length(asked) + 1L]] <<- q + search(u, q, ...) + }) + cache <- new.env() + half <- rows[rows %% 2L == 0L] + expect_identical(.nearest_other(xy, gi, half, f, cache), plain[half], info = tag) + expect_length(asked, 1L) + # The rest of the rows: only locations not yet found are searched. + expect_identical(.nearest_other(xy, gi, rows, f, cache), plain, info = tag) + expect_length(asked, 2L) + expect_length(intersect(asked[[1L]], asked[[2L]]), 0L) + # Again, and with the rows in other regions: nothing is searched. + expect_identical(.nearest_other(xy, gi, rows, f, cache), plain, info = tag) + gi2 <- rev(gi) + expect_identical(.nearest_other(xy, gi2, rows, f, cache), + .nearest_other(xy, gi2, rows, f), info = tag) + expect_length(asked, 3L) # the call without a cache, and no other + # A cache filled on other locations starts again and is not read. The + # two coordinates change places, so the locations stand in another order + # and what the cache holds would be wrong for them. + other <- cbind(xy[, 2], xy[, 1]) + expect_identical(.nearest_other(other, gi, rows, f, cache), + .nearest_other(other, gi, rows, f), info = tag) + expect_identical(cache$u, .partition_locations(other)$u, info = tag) + } +}) + +test_that("14. a fit with a cache is the fit without, and searches once over several fits", { + L <- .pt_layout(7L) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = FALSE) + cache <- new.env() + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = FALSE, cache = cache), A) + expect_identical(sum(!is.na(cache$nearest)), sum(A$n == 1L)) + # The same rows in other regions: the locations already found are not + # searched again. + gi2 <- .pt_regions(L$xy, 1200L, 9L); K2 <- max(gi2) + want <- .pool_fit(L$y, gi2, K2, L$xy, use_fnn = FALSE) + search <- .nearest_location_search + asked <- integer(0) + local_mocked_bindings(.nearest_location_search = function(u, q, ...) { + asked <<- c(asked, q) + search(u, q, ...) + }) + known <- which(!is.na(cache$nearest)) + expect_identical(.pool_fit(L$y, gi2, K2, L$xy, use_fnn = FALSE, cache = cache), want) + expect_length(intersect(asked, known), 0L) + expect_identical(anyDuplicated(asked), 0L) +}) + + +# ---- 15. A response without structure ---------------------------------------- + +test_that("15. the rule: regions beat one mean by a margin, and by more than chance", { + # FALSE when one mean is within `tol` of the regions, or better. + expect_false(.no_structure(1, 1.02, 1e-6, tol = 0.02)$structured) + expect_false(.no_structure(1, 0.9, 1e-6, tol = 0.02)$structured) + expect_false(.no_structure(1, 1.019, 0, tol = 0.02)$structured) + expect_true(.no_structure(1, 1.021, 1e-6, tol = 0.02)$structured) + expect_false(.no_structure(1, 1.021, 1e-6, tol = 0.05)$structured) + # FALSE when the F test is not below 5 percent after the adjustment. + expect_false(.no_structure(1, 2, 0.05, tol = 0.02)$structured) + expect_true(.no_structure(1, 2, 0.0499, tol = 0.02)$structured) + expect_false(.no_structure(1, 2, 0.01, tol = 0.02, n_searched = 5L)$structured) + expect_true(.no_structure(1, 2, 0.0099, tol = 0.02, n_searched = 5L)$structured) + expect_false(.no_structure(1, 2, 0.9, tol = 0.02, n_searched = 7L)$structured) + # What it returns. + r <- .no_structure(1, 2, 0.004, tol = 0.02, n_searched = 5L) + expect_identical(names(r), c("structured", "structure_p", "beats")) + expect_identical(r$structure_p, 0.02) + expect_true(r$beats) + expect_identical(.no_structure(1, 2, 0.4, tol = 0.02, n_searched = 5L)$structure_p, 1) + expect_false(.no_structure(1, 1, 0.001, tol = 0.02)$beats) + # NA with a missing error; with a missing p-value NA when the regions beat + # one mean, and FALSE when they do not: the first condition has failed + # whatever the test would have said. + expect_identical(.no_structure(NA_real_, 2, 0.001, tol = 0.02)$structured, NA) + expect_identical(.no_structure(1, NA_real_, 0.001, tol = 0.02)$structured, NA) + expect_identical(.no_structure(Inf, 2, 0.001, tol = 0.02)$structured, NA) + expect_identical(.no_structure(1, 2, NA_real_, tol = 0.02)$structured, NA) + expect_identical(.no_structure(1, 2, NA_real_, tol = 0.02)$structure_p, NA_real_) + expect_identical(.no_structure(1, 1, NA_real_, tol = 0.02)$structured, FALSE) + expect_identical(.no_structure(1, 2, numeric(0), tol = 0.02)$structured, NA) + expect_identical(.STRUCTURE_TOL, 0.02) +}) + +test_that("15. white noise is called structureless and a field with noise is not", { + # 200 layers of each kind: 300 locations uniform on a 1e5 square, x then y, + # then the response, then regions of the density kind at 67 centres (4.5 + # rows a region) from 3 k-means++ starts under set.seed(123). + one <- function(seed, field) { + .pt_seed(seed) + xy <- cbind(stats::runif(300, 0, 1e5), stats::runif(300, 0, 1e5)) + y <- if (field) sin(xy[, 1] / 2e4) + cos(xy[, 2] / 1.5e4) + stats::rnorm(300, 0, 1.5) + else stats::rnorm(300) + set.seed(123) + kb <- .partition_centres(xy, .count_at(300, 4.5), partition = "density", + init = "kmeans++", nstart = 3L, iter.max = 100L) + g <- .nearest_centre(xy[, 1], xy[, 2], kb$centers[, 1], kb$centers[, 2]) + gi <- match(g, sort(unique(g))) + f <- .pool_fit(y, gi, max(gi), xy, want = "pooled") + .no_structure(f$loo_pooled, f$loo_one, f$f_p, tol = 0.02, n_searched = 1L)$structured + } + expect_identical(.count_at(300, 4.5), 67L) + noise <- vapply(1:200, function(r) one(4000 + r, FALSE), NA) + field <- vapply(1:200, function(r) one(5000 + r, TRUE), NA) + expect_false(anyNA(noise)) + expect_false(anyNA(field)) + # One run of these seeds: FALSE on 195 of the noise layers, TRUE on 200 of + # the field layers. + expect_gte(sum(!noise), 185L) + expect_gte(sum(field), 190L) +}) + + +# ---- 16. The bound on exact searches ----------------------------------------- + +test_that("16. an exact search above the limit stops with spatialkit_work_limit", { + cen <- local({ .pt_seed(16); cbind(stats::runif(20, 0, 100), stats::runif(20, 0, 100)) }) + withr::local_options(spatialkit.exact_pairs_max = 10) + e <- tryCatch(.region_neighbours(cen, 8L, FALSE), error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_s3_class(e, "error") + expect_identical(e$work, 400) + expect_identical(e$limit, 10) + expect_identical(e$what, "cell neighbours") + expect_null(conditionCall(e)) + expect_identical( + conditionMessage(e), + paste0("resolution_profile(): finding each cell's neighbours among 20 cells would compare ", + "4e+02 pairs without the FNN package, above the limit of 10 ", + "(options(spatialkit.exact_pairs_max = )). Install FNN: the result is the same.")) + # The caller's name is the one handed down. + e2 <- tryCatch(.region_neighbours(cen, 8L, FALSE, caller = "cell_values_at"), + error = function(e) e) + expect_match(conditionMessage(e2), "^cell_values_at\\(\\): ") + # Nothing at the limit or below it. + withr::local_options(spatialkit.exact_pairs_max = 400) + expect_identical(.region_neighbours(cen, 8L, FALSE), .pt_neighbours(cen, 8L)) + withr::local_options(spatialkit.exact_pairs_max = 399) + expect_error(.region_neighbours(cen, 8L, FALSE), class = "spatialkit_work_limit") +}) + +test_that("16. the guard itself, the fit and the nearest other row", { + expect_null(.work_guard(10, 10, "a search", "f")) + expect_null(.work_guard(0, 0, "a search", "f")) + e <- tryCatch(.work_guard(11, 10, "spacing", "cell_values_at", + search = "the spacing of 4 locations", + data = list(locations = 4L)), + error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "spacing") + expect_identical(e$locations, 4L) + expect_identical(e$work, 11) + expect_identical(e$limit, 10) + expect_identical( + conditionMessage(e), + paste0("cell_values_at(): the spacing of 4 locations would compare 11 pairs without the ", + "FNN package, above the limit of 10 (options(spatialkit.exact_pairs_max = )). ", + "Install FNN: the result is the same.")) + expect_match(conditionMessage(tryCatch(.work_guard(2, 1, "x", "f", remedy = "Do less."), + error = function(e) e)), "Do less\\.$") + + # The default limit, and an option that is not a number of pairs. + expect_identical(.EXACT_PAIRS_MAX, 2e9) + expect_identical(.FIT_WORK_MAX, 1e10) + withr::local_options(spatialkit.exact_pairs_max = NULL) + expect_identical(.exact_pairs_max(), 2e9) + withr::local_options(spatialkit.exact_pairs_max = 5e3L) + expect_identical(.exact_pairs_max(), 5000) + # A limit of 0 is a limit: no exact search of even one pair. + withr::local_options(spatialkit.exact_pairs_max = 0) + expect_identical(.exact_pairs_max(), 0) + expect_error(.region_neighbours(cbind(c(0, 1, 3), 0), 8L, FALSE), class = "spatialkit_work_limit") + for (bad in list("100", NA_real_, -1, c(1, 2))) { + withr::local_options(spatialkit.exact_pairs_max = bad) + expect_error(.exact_pairs_max(), "spatialkit.exact_pairs_max", fixed = TRUE) + } + + # The fit passes the error on: its neighbours first, then, for plain means, + # the nearest other row of the rows alone in their region. + L <- .pt_layout(3L) # 600 rows, 300 regions, 107 of one row + expect_identical(L$K, 300L) + alone <- sum(tabulate(L$gi) == 1L) + withr::local_options(spatialkit.exact_pairs_max = NULL) + geo <- .pool_geometry(L$gi, L$K, L$xy, tabulate(L$gi), FALSE) + withr::local_options(spatialkit.exact_pairs_max = 300^2 - 1) + e <- tryCatch(.pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = FALSE), error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, 300^2) + expect_identical(e$what, "cell neighbours") + withr::local_options(spatialkit.exact_pairs_max = 300^2) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "pooled", use_fnn = FALSE)$status, "ok") + # The rows alone in their region against every location: fewer pairs than + # the neighbours of the regions took, so the limit is lowered to show it. + withr::local_options(spatialkit.exact_pairs_max = alone * 600 - 1) + e <- tryCatch(.pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", geo = geo, use_fnn = FALSE), + error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, alone * 600) + expect_identical(e$what, "nearest other location") + expect_match(conditionMessage(e), + sprintf("finding the nearest other location of %d of 600 locations", alone)) + # Pooled values need no such search, so the same call for them returns; + # and at the limit the search for plain means runs. + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "pooled", geo = geo, + use_fnn = FALSE)$status, "ok") + withr::local_options(spatialkit.exact_pairs_max = alone * 600) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", geo = geo, + use_fnn = FALSE)$status, "ok") +}) + +test_that("16. the pairs are counted as a double, past the largest integer", { + # 46,341 regions is the first count whose square is no integer in R, and + # just above what the default limit allows; a product taken in integers + # would be NA there and the stop a plain error about a missing value. The + # guard stops before any search, so these take no time. + withr::local_options(spatialkit.exact_pairs_max = NULL) + cen <- local({ .pt_seed(161); cbind(stats::runif(46341), stats::runif(46341)) }) + e <- tryCatch(.region_neighbours(cen, 8L, FALSE), error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, 46341^2) + expect_gt(e$work, .Machine$integer.max) + expect_identical(e$limit, 2e9) + expect_identical(e$what, "cell neighbours") + # The same for the nearest other row of 50,000 rows, each alone at its + # location. + xy <- local({ .pt_seed(162); cbind(stats::runif(50000), stats::runif(50000)) }) + e <- tryCatch(.nearest_other(xy, seq_len(50000), seq_len(50000), FALSE), error = function(e) e) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$work, 50000^2) + expect_identical(e$what, "nearest other location") + # In a column of an assigned layer that stop is a status. + y <- local({ .pt_seed(163); stats::rnorm(2L * 46341L) }) + P <- .pool_column(y, rep(seq_len(46341L), 2L), rbind(cen, cen + 1e-3), NULL, "pooled", FALSE) + expect_identical(P$record$status, "work limit") + expect_identical(P$work, 46341^2) + expect_identical(P$limit, 2e9) +}) + +test_that("the engine's constants", { + expect_identical(.POOL_NEIGHBOURS, 8L) + expect_identical(.OBS_PER_CELL_DEFAULT, 4.5) + expect_identical(.OBS_PER_CELL_LADDER, c(18, 12, 9, 6, 4.5, 3, 2)) + expect_identical(.RECORD_TOL, 1e-8) + expect_identical(.FEW_RESIDUALS, 5) + expect_identical(.POOL_MIN_DF, 30L) + expect_identical(.STRUCTURE_TOL, 0.02) + expect_identical(.EXACT_PAIRS_MAX, 2e9) + expect_identical(.FIT_WORK_MAX, 1e10) +}) + +test_that("16. with FNN nothing is bounded", { + skip_if_not_installed("FNN") + L <- .pt_layout(3L) + want <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = TRUE) + withr::local_options(spatialkit.exact_pairs_max = 1) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = TRUE), want) +}) + +test_that("16. .has_backend() answers for a package, and one mock switches FNN off", { + expect_true(.has_backend("stats")) + expect_false(.has_backend("a.package.that.does.not.exist")) + expect_identical(.has_backend("FNN"), requireNamespace("FNN", quietly = TRUE)) + expect_identical(formals(.pool_fit)$use_fnn, quote(.has_backend("FNN"))) + # With the answer FALSE the fit takes the exact path: FNN is not reached. + L <- .pt_layout(2L) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = FALSE) + local_mocked_bindings(.has_backend = function(pkg) FALSE, + .knn_tied_rows = function(...) stop("the kd-tree path was taken")) + withr::local_options(spatialkit.exact_pairs_max = 10) + expect_error(.pool_fit(L$y, L$gi, L$K, L$xy), class = "spatialkit_work_limit") + withr::local_options(spatialkit.exact_pairs_max = NULL) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy), A) +}) + + +# ---- 17. want ---------------------------------------------------------------- + +test_that("17. `want` decides which residuals are computed and nothing else", { + L <- .pt_layout(7L) # 3,000 rows at 2 a region + for (f in .pt_paths()) { + tag <- .pt_path_tag(f) + both <- .pool_fit(L$y, L$gi, L$K, L$xy, want = c("pooled", "mean"), use_fnn = f) + pooled <- .pool_fit(L$y, L$gi, L$K, L$xy, want = "pooled", use_fnn = f) + plain <- .pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", use_fnn = f) + shared <- c("n", "S", "m", "N", "K", "sigma2", "cen", "nb", "target", "Q", "tau2", "w", + "value", "loo_one", "loo_one_se", "f_p", "constant", "flat", "status") + expect_identical(pooled[shared], both[shared], info = tag) + expect_identical(plain[shared], both[shared], info = tag) + # The default is both. + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f), both, info = tag) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = c("mean", "pooled"), use_fnn = f), + both, info = tag) + # The one asked for is the one of the full fit. + mine_p <- c("resid_pooled", "loo_pooled", "loo_pooled_se") + mine_m <- c("resid_mean", "loo_mean", "loo_mean_se") + expect_identical(pooled[mine_p], both[mine_p], info = tag) + expect_identical(plain[mine_m], both[mine_m], info = tag) + expect_true(is.finite(both$loo_pooled) && is.finite(both$loo_mean), info = tag) + # The one not asked for: no vector, and NA for its two numbers. + expect_null(pooled$resid_mean) + expect_identical(pooled$loo_mean, NA_real_, info = tag) + expect_identical(pooled$loo_mean_se, NA_real_, info = tag) + expect_null(plain$resid_pooled) + expect_identical(plain$loo_pooled, NA_real_, info = tag) + expect_identical(plain$loo_pooled_se, NA_real_, info = tag) + # The list has the same elements in the same order whatever was asked. + expect_identical(names(pooled), names(both), info = tag) + expect_identical(names(plain), names(both), info = tag) + expect_identical( + names(both), + c("n", "S", "m", "N", "K", "sigma2", "cen", "nb", "target", "Q", "tau2", "w", "value", + "resid_pooled", "resid_mean", "loo_pooled", "loo_pooled_se", "loo_mean", + "loo_mean_se", "loo_one", "loo_one_se", "f_p", "constant", "flat", "status"), + info = tag) + } +}) + +test_that("17. pooled values alone never look for a nearest other row", { + L <- .pt_layout(7L) + expect_gt(sum(tabulate(L$gi) == 1L), 500L) + want <- .pool_fit(L$y, L$gi, L$K, L$xy, want = "pooled", use_fnn = FALSE) + local_mocked_bindings(.nearest_other = function(...) stop("the nearest other row was searched for")) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "pooled", use_fnn = FALSE), want) + expect_error(.pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", use_fnn = FALSE), + "nearest other row was searched for") + # Nor does a fit handed every row's nearest other row, nor one of a + # constant column, whose residuals are set. + nn1 <- .pt_nearest_other(L$xy, L$gi) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", nn1 = nn1, + use_fnn = FALSE)$status, "ok") + expect_identical(.pool_fit(rep(0.1, 3000), L$gi, L$K, L$xy, use_fnn = FALSE)$status, + "no spread inside any cell") + # One region needs none either. + expect_identical(.pool_fit(L$y, rep(1L, 3000), 1L, L$xy, use_fnn = FALSE)$status, "one cell") +}) + +test_that("17. a fit handed each row's nearest other row uses it", { + L <- .pt_layout(3L) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", use_fnn = FALSE) + alone <- which(A$n[L$gi] == 1L) + nn1 <- .pt_nearest_other(L$xy, L$gi) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", nn1 = nn1, use_fnn = FALSE), A) + # Another row handed in gives that row's region's mean. + other <- nn1 + other[alone] <- ifelse(nn1[alone] == 1L, 2L, 1L) + B <- .pool_fit(L$y, L$gi, L$K, L$xy, want = "mean", nn1 = other, use_fnn = FALSE) + expect_identical(B$resid_mean[alone], L$y[alone] - A$m[L$gi[other[alone]]]) + expect_identical(B$resid_mean[-alone], A$resid_mean[-alone]) + expect_false(identical(B$loo_mean, A$loo_mean)) +}) + + +# ---- 18. geo, and column names in words -------------------------------------- + +test_that("18. a fit given the centroids and neighbours of an earlier fit computes neither again", { + for (i in c(4L, 12L)) for (f in .pt_paths()) { + L <- .pt_layout(i); tag <- sprintf("layout %d, %s", i, .pt_path_tag(f)) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + geo <- A[c("cen", "nb")] + other <- cos(L$xy[, 1] / 3e4) + L$y^2 # another column on the same rows + C <- .pool_fit(other, L$gi, L$K, L$xy, use_fnn = f) + local({ + local_mocked_bindings( + .region_neighbours = function(...) stop("the neighbours were searched for"), + .pool_geometry = function(...) stop("the centroids were summed")) + expect_identical(.pool_fit(L$y, L$gi, L$K, L$xy, geo = geo, use_fnn = f), A, info = tag) + expect_identical(.pool_fit(other, L$gi, L$K, L$xy, geo = geo, use_fnn = f), C, info = tag) + expect_error(.pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f), "centroids were summed") + }) + # The geometry is what the fit computes for itself. + expect_identical(.pool_geometry(L$gi, L$K, L$xy, A$n, f), geo, info = tag) + # It is read: neighbours of the right shape that are not these regions' + # nearest give other targets. With three regions there are no others. + if (L$K > 9L) { + further <- geo + further$nb <- .region_neighbours(geo$cen, 9L, f)[, -1L] # the second to the ninth nearest + expect_false(identical(.pool_fit(L$y, L$gi, L$K, L$xy, geo = further, use_fnn = f)$target, + A$target), info = tag) + } + } + # One region: its geometry is passed on like any other. + y <- c(1, 2, 4); xy <- cbind(c(0, 1, 5), c(0, 2, 1)) + A <- .pool_fit(y, rep(1L, 3), 1L, xy, use_fnn = FALSE) + local_mocked_bindings(.pool_geometry = function(...) stop("the centroids were summed")) + expect_identical(.pool_fit(y, rep(1L, 3), 1L, xy, geo = A[c("cen", "nb")], use_fnn = FALSE), A) +}) + +test_that("18. a fit refuses centroids and neighbours that are not of its regions' shape", { + L <- .pt_layout(2L); K <- L$K # 600 rows in 133 regions + A <- .pool_fit(L$y, L$gi, K, L$xy, use_fnn = FALSE) + geo <- A[c("cen", "nb")] + fit <- function(geo, ...) .pool_fit(L$y, L$gi, K, L$xy, geo = geo, use_fnn = FALSE, ...) + expect_identical(fit(geo), A) + # Those of other regions of the same rows, fewer and more. With fewer, + # S[nb] would be laid out in K rows without a complaint and every target + # would be a sum over other regions. + for (centres in c(60L, 250L)) { + g2 <- .pt_regions(L$xy, centres, 5L); K2 <- max(g2) + expect_false(K2 == K) + geo2 <- .pool_geometry(g2, K2, L$xy, tabulate(g2), FALSE) + expect_error(fit(geo2), "`geo` must hold the centroids and neighbours of these 133 regions") + expect_error(fit(geo2, want = "pooled"), "`geo` must hold") + # A column of an assigned layer passes the refusal on: it is no status. + expect_error(.pool_column(L$y, L$gi, L$xy, NULL, "pooled", FALSE, geo = geo2), "`geo` must hold") + } + # Each part of the shape. + bad <- function(change) { g <- geo; change(g) } + expect_error(fit(bad(function(g) { g$nb[7L, 3L] <- 7L; g })), "`geo` must hold") # itself + expect_error(fit(bad(function(g) { g$nb[7L, 3L] <- K + 1L; g })), "`geo` must hold") # no region + expect_error(fit(bad(function(g) { g$nb[7L, 3L] <- 0L; g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$nb[7L, 3L] <- NA; g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$nb <- g$nb[, -1L]; g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$nb <- t(g$nb); g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$cen <- g$cen[-1L, ]; g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$cen <- cbind(g$cen, 0); g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$cen[2L, 1L] <- NA; g })), "`geo` must hold") + expect_error(fit(bad(function(g) { g$nb <- NULL; g })), "`geo` must hold") + expect_error(fit(geo$nb), "`geo` must hold") + # What a fit without one returns when nothing was fitted is no geometry. + none <- .pool_fit(L$y[1:5], 1:5, 5L, L$xy[1:5, ], use_fnn = FALSE) + expect_identical(none$status, "no cell holds two values") + expect_error(.pool_fit(L$y[1:5], 1:5, 5L, L$xy[1:5, ], geo = none[c("cen", "nb")], + use_fnn = FALSE), "`geo` must hold") +}) + +test_that("18. column names in the words of a warning", { + expect_identical(.cols_text("a"), "'a'") + expect_identical(.cols_text(c("a", "b")), "'a' and 'b'") + expect_identical(.cols_text(c("a", "b", "c")), "'a', 'b' and 'c'") + expect_identical(.cols_text(letters[1:6]), "'a', 'b', 'c', 'd', 'e' and 'f'") + expect_identical(.cols_text(letters[1:7]), "'a', 'b', 'c', 'd', 'e', 'f' and 1 more") + expect_identical(.cols_text(letters[1:10]), "'a', 'b', 'c', 'd', 'e', 'f' and 4 more") + expect_identical(.cols_text(c("income", "share of renters")), "'income' and 'share of renters'") + expect_identical(.cols_text(character(0)), "") +}) + + +# ---- The interval's offsets --------------------------------------------------- + +test_that("the offsets are quantiles at probabilities rounded to 12 places", { + e <- local({ .pt_seed(19); stats::rnorm(937) }) + for (level in c(0.5, 0.8, 0.9, 0.95, 0.99)) { + p <- round((1 - level) / 2, 12) + expect_identical(.obs_offsets(e, level), + stats::quantile(e, c(p, 1 - p), names = FALSE, type = 7), + info = format(level)) + } + expect_identical(.obs_offsets(e, 0.9), stats::quantile(e, c(0.05, 0.95), names = FALSE)) + expect_identical(.obs_offsets(e, 0.95), stats::quantile(e, c(0.025, 0.975), names = FALSE)) + expect_identical(.obs_offsets(e, 0.8), stats::quantile(e, c(0.1, 0.9), names = FALSE)) + # What the rounding is for: (1 - 0.9) / 2 is not 0.05 in floating point. + expect_false((1 - 0.9) / 2 == 0.05) + off <- .obs_offsets(e, 0.9) + expect_lt(off[1L], 0) + expect_gt(off[2L], 0) + # A constant column's residuals are all 0 and the interval has no width. + expect_identical(.obs_offsets(numeric(50), 0.9), c(0, 0)) + # Fewer than two residuals, or a missing one: no interval. + expect_identical(.obs_offsets(1.5, 0.9), c(NA_real_, NA_real_)) + expect_identical(.obs_offsets(NULL, 0.9), c(NA_real_, NA_real_)) + expect_identical(.obs_offsets(c(1, NA, 3), 0.9), c(NA_real_, NA_real_)) + expect_identical(.obs_offsets(c(-1, 3), 0.5), c(0, 2)) +}) + + +# ---- One column of an assigned layer ------------------------------------------ + +# 3,000 rows at 4.5 a region, as an assigned layer would hand them over: an +# ID per row of the type asked for, in an order that is not the regions'. +.pt_ids <- function(gi, K, type) { + code <- local({ .pt_seed(77); sample(100000L, K) }) + switch(type, + integer = code[gi], + double = (code / 8)[gi], + # Upper and lower case, which the C locale and a language's own + # order sort differently. + character = paste0(c("a", "B", "c", "D")[code %% 4L + 1L], code)[gi], + factor = factor(sprintf("u%05d", code)[gi], levels = rev(sprintf("u%05d", sort(code))))) +} + +test_that("a column's values are the fit's, by region ID of any type", { + L <- .pt_layout(4L) + for (f in .pt_paths()) for (type in c("integer", "double", "character", "factor")) { + tag <- sprintf("%s IDs, %s", type, .pt_path_tag(f)) + id <- .pt_ids(L$gi, L$K, type) + P <- .pool_column(L$y, id, L$xy, obs_level = 0.9, want = c("pooled", "mean"), use_fnn = f) + # The regions in the order of the IDs: radix order. + u <- unique(id); u <- u[order(u, method = "radix")] + expect_identical(P$ids, u, info = tag) + if (type == "character") { + expect_identical(P$ids, withr::with_collate("C", sort(unique(id))), info = tag) + # The same in a session whose locale sorts strings another way. + for (loc in c("en_US.UTF-8", "en_US", "English_United States.1252")) { + other <- suppressWarnings(tryCatch( + withr::with_collate(loc, list( + sorts = sort(c("B", "a")), + ids = .pool_column(L$y, id, L$xy, obs_level = 0.9, want = c("pooled", "mean"), + use_fnn = f)$ids)), + error = function(e) NULL)) + if (is.null(other) || identical(other$sorts, c("B", "a"))) next + expect_identical(other$ids, P$ids, info = paste(tag, loc)) + expect_false(identical(withr::with_collate(loc, sort(unique(id))), P$ids), + info = paste(tag, loc)) + break + } + } + if (type == "factor") expect_identical(as.character(P$ids), + levels(id)[levels(id) %in% id], info = tag) + gi <- match(id, u) + A <- .pool_fit(L$y, gi, L$K, L$xy, use_fnn = f) + expect_identical(P$fit, A, info = tag) + expect_identical(P$value, A$value, info = tag) + expect_identical(P$w, A$w, info = tag) + expect_identical(P$target, A$target, info = tag) + expect_identical(P$n, A$n, info = tag) + expect_identical(P$geo, A[c("cen", "nb")], info = tag) + expect_identical(P$mask, rep(TRUE, 3000), info = tag) + expect_identical(P$work, NA_real_, info = tag) + expect_identical(P$limit, NA_real_, info = tag) + off <- .obs_offsets(A$resid_pooled, 0.9) + expect_identical(P$obs_lo, A$value + off[1L], info = tag) + expect_identical(P$obs_hi, A$value + off[2L], info = tag) + # Region by region these are the values of the regions numbered as the + # layout numbers them, to rounding. + B <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + at <- match(id[match(seq_len(L$K), L$gi)], P$ids) + expect_lt(.pt_gap(P$value[at], B$value), 1e-12) + expect_lt(.pt_gap(P$w[at], B$w), 1e-12) + expect_lt(.pt_gap(P$target[at], B$target), 1e-12) + + # The column's entry in the record. + r <- P$record + expect_identical(names(r), c("column", "role", "n", "cells", "df", "neighbours", "sigma2", + "tau2", "own_weight", "share_alone", "loo", "loo_se", + "loo_one_cell", "structured", "structure_p", "offsets", + "repeated", "skipped", "constant", "status"), info = tag) + expect_identical(r$column, NA_character_, info = tag) + expect_identical(r$role, NA_character_, info = tag) + expect_identical(r$n, 3000L, info = tag) + expect_identical(r$cells, L$K, info = tag) + expect_identical(r$df, 3000L - L$K, info = tag) + expect_identical(r$neighbours, 8L, info = tag) + expect_identical(r$sigma2, A$sigma2, info = tag) + expect_identical(r$tau2, A$tau2, info = tag) + expect_identical(r$own_weight, stats::median(A$w), info = tag) + expect_identical(r$share_alone, sum(A$n == 1L) / 3000, info = tag) + expect_identical(r$loo, A$loo_pooled, info = tag) + expect_identical(r$loo_se, A$loo_pooled_se, info = tag) + expect_identical(r$loo_one_cell, A$loo_one, info = tag) + s <- .no_structure(A$loo_pooled, A$loo_one, A$f_p, tol = 0.02) + expect_true(r$structured, info = tag) + expect_identical(r$structured, s$structured, info = tag) + expect_identical(r$structure_p, s$structure_p, info = tag) + expect_identical(r$offsets, off, info = tag) + expect_identical(r$repeated, 0L, info = tag) + expect_identical(r$skipped, 0L, info = tag) + expect_false(r$constant, info = tag) + expect_identical(r$status, "ok", info = tag) + } + # Without a level there is no interval. + P <- .pool_column(L$y, L$gi, L$xy, obs_level = NULL, want = "pooled", use_fnn = FALSE) + expect_null(P$obs_lo) + expect_null(P$obs_hi) + expect_null(P$record$offsets) + expect_true("offsets" %in% names(P$record)) + expect_null(P$fit$resid_mean) + expect_identical(P$record$neighbours, 8L) +}) + +test_that("rows without a value, a region or a location are as if absent", { + L <- .pt_layout(2L); n <- length(L$y) + y <- L$y; id <- sprintf("r%03d", L$gi); xy <- L$xy + y[c(3, 50, 51)] <- NA + y[77] <- Inf + y[90] <- NaN + id[c(10, 200)] <- NA + xy[c(20, 300), 1] <- NA + xy[400, 2] <- Inf + xy[c(3, 10), 2] <- NA # also without a value, or without a region + gone <- c(3, 50, 51, 77, 90, 10, 200, 20, 300, 400) + for (f in .pt_paths()) { + P <- .pool_column(y, id, xy, obs_level = 0.9, want = c("pooled", "mean"), use_fnn = f) + Q <- .pool_column(y[-gone], id[-gone], xy[-gone, ], obs_level = 0.9, + want = c("pooled", "mean"), use_fnn = f) + expect_identical(which(!P$mask), as.integer(sort(gone))) + expect_identical(P[c("ids", "n", "value", "w", "target", "obs_lo", "obs_hi", "geo", "fit")], + Q[c("ids", "n", "value", "w", "target", "obs_lo", "obs_hi", "geo", "fit")]) + expect_identical(P$record[names(P$record) != "skipped"], + Q$record[names(Q$record) != "skipped"]) + # Rows with a value and a region and no location: 20, 300 and 400. + expect_identical(P$record$skipped, 3L) + expect_identical(Q$record$skipped, 0L) + expect_identical(P$record$n, n - 10L) + expect_identical(Q$mask, rep(TRUE, n - 10L)) + } +}) + +test_that("each case in which a column has no pooled value, or no pooling, has its status", { + L <- .pt_layout(2L); n <- length(L$y); K <- L$K + col <- function(y = L$y, id = L$gi, xy = L$xy, obs_level = 0.9, want = "pooled", + use_fnn = FALSE, ...) + .pool_column(y, id, xy, obs_level = obs_level, want = want, use_fnn = use_fnn, ...) + + # No coordinates at all. + P <- col(xy = NULL) + expect_identical(P$record$status, "no coordinates") + expect_identical(P$record$n, 0L) + expect_identical(P$record$cells, 0L) + expect_identical(P$record$skipped, n) + expect_length(P$ids, 0L) + expect_identical(P$value, numeric(0)) + expect_identical(P$obs_lo, numeric(0)) + expect_identical(P$mask, logical(n)) + expect_null(P$fit); expect_null(P$geo) + expect_identical(P$record$offsets, c(NA_real_, NA_real_)) + + # Coordinates, and no row with a value, a region and a location. + for (P in list(col(y = rep(NA_real_, n)), col(id = rep(NA_integer_, n)), + col(xy = matrix(NA_real_, n, 2)))) { + expect_identical(P$record$status, "no located value") + expect_identical(P$record$cells, 0L) + expect_length(P$ids, 0L) + expect_identical(P$mask, logical(n)) + expect_null(P$fit) + } + expect_identical(col(xy = matrix(NA_real_, n, 2))$record$skipped, n) + expect_identical(col(y = rep(NA_real_, n))$record$skipped, 0L) + + # One region. + P <- col(id = rep("all", n)) + expect_identical(P$record$status, "one cell") + expect_identical(P$ids, "all") + expect_equal(P$value, mean(L$y), tolerance = 1e-14) + expect_identical(P$value, P$fit$m) + expect_identical(P$w, 1) + expect_identical(P$target, NA_real_) + expect_identical(P$record$neighbours, 0L) + expect_identical(P$record$tau2, NA_real_) + expect_identical(P$record$structured, NA) + expect_identical(P$record$own_weight, 1) + expect_identical(P$record$offsets, .obs_offsets((L$y - P$fit$m) * n / (n - 1), 0.9)) + expect_identical(P$obs_hi - P$obs_lo, diff(P$record$offsets)) + # One row in all. + P <- col(y = 3.5, id = 9L, xy = cbind(1, 2)) + expect_identical(P$record$status, "one cell") + expect_identical(P$value, 3.5) + expect_identical(P$w, 1) + expect_identical(P$record$sigma2, NA_real_) + expect_identical(P$record$loo, NA_real_) + expect_identical(c(P$obs_lo, P$obs_hi), c(NA_real_, NA_real_)) + expect_identical(P$record$share_alone, 1) + + # No region holds two rows. + P <- col(y = L$y[1:12], id = letters[12:1], xy = L$xy[1:12, ]) + expect_identical(P$record$status, "no cell holds two values") + expect_identical(P$ids, letters[1:12]) + expect_identical(P$n, rep(1L, 12)) + expect_identical(P$value, rep(NA_real_, 12)) + expect_identical(P$w, rep(NA_real_, 12)) + expect_identical(P$obs_lo, rep(NA_real_, 12)) + expect_identical(P$record$df, 0L) + expect_identical(P$record$share_alone, 1) + expect_identical(P$record$sigma2, NA_real_) + expect_identical(P$record$own_weight, NA_real_) + expect_null(P$geo) + expect_false(P$record$constant) + + # The work limit is a status here, with the pairs and the limit kept. + withr::with_options(list(spatialkit.exact_pairs_max = 100), { + P <- col() + expect_identical(P$record$status, "work limit") + expect_identical(P$work, as.numeric(K)^2) + expect_identical(P$limit, 100) + expect_identical(P$value, rep(NA_real_, K)) + expect_identical(P$w, rep(NA_real_, K)) + expect_identical(P$obs_hi, rep(NA_real_, K)) + expect_identical(P$ids, seq_len(K)) + expect_identical(P$record$cells, K) + expect_identical(P$record$n, n) + expect_identical(P$record$share_alone, sum(tabulate(L$gi) == 1L) / n) + expect_null(P$fit); expect_null(P$geo) + expect_identical(P$mask, rep(TRUE, n)) + # A flat column over the limit is "work limit" too: the search comes first. + expect_identical(col(y = rep(0.1, n))$record$status, "work limit") + # Fewer regions than the limit allows, and a search that is not needed. + expect_true(col(id = (L$gi %% 9L) + 1L)$record$status %in% + c("ok", "no signal between cells")) + expect_identical(col(id = rep(1L, n))$record$status, "one cell") + }) + # With plain means asked for, the search for the nearest other row of the + # rows alone in their region is bounded the same way. + withr::with_options(list(spatialkit.exact_pairs_max = 100), { + geo2 <- withr::with_options(list(spatialkit.exact_pairs_max = NULL), + .pool_geometry(L$gi, K, L$xy, tabulate(L$gi), FALSE)) + P <- col(want = "mean", geo = geo2) + expect_identical(P$record$status, "work limit") + expect_identical(P$work, sum(tabulate(L$gi) == 1L) * as.numeric(n)) + expect_identical(col(want = "pooled", geo = geo2)$record$status, "ok") + }) + + # No spread inside any region; no signal between regions. + P <- col(y = rep(52000.37, n)) + expect_identical(P$record$status, "no spread inside any cell") + expect_true(P$record$constant) + expect_identical(P$w, rep(1, K)) + expect_identical(P$record$offsets, c(0, 0)) + expect_identical(P$obs_lo, P$value) + expect_identical(P$obs_hi, P$value) + expect_identical(P$record$loo, NA_real_) + expect_identical(P$record$structured, NA) + P <- col(y = 0.1 * L$gi) + expect_identical(P$record$status, "no spread inside any cell") + expect_false(P$record$constant) + expect_identical(P$record$structured, NA) + expect_true(is.finite(P$record$loo)) + # Flat and no better than one mean: `structured` is read only where there + # is spread inside the regions, so it stays NA and is not FALSE. + few <- local({ .pt_seed(41); list(xy = cbind(stats::runif(40), stats::runif(40)), + y = stats::rnorm(40)) }) + few$y[40] <- few$y[39] # the one region of two rows, both the same + P <- col(y = few$y, id = c(1:39, 39L), xy = few$xy) + expect_identical(P$record$status, "no spread inside any cell") + expect_false(P$record$constant) + expect_lte(P$fit$loo_one, P$fit$loo_pooled * 1.02) + expect_identical(P$record$structured, NA) + expect_identical(P$record$structure_p, NA_real_) + expect_identical(P$record$df, 1L) + noise <- local({ .pt_seed(903); stats::rnorm(n) }) + P <- col(y = noise) + expect_identical(P$record$status, "no signal between cells") + expect_identical(P$record$tau2, 0) + expect_identical(P$record$own_weight, 0) + expect_false(P$record$structured) + expect_true(all(is.finite(P$obs_lo))) +}) + +test_that("a column's record counts the rows that share a location", { + L <- .pt_layout(2L); n <- length(L$y) + xy <- L$xy + xy[5:7, ] <- xy[rep(4L, 3), ] # four rows on one location + xy[100, ] <- xy[99, ] # and a pair + P <- .pool_column(L$y, L$gi, xy, obs_level = NULL, want = "pooled", use_fnn = FALSE) + expect_identical(P$record$repeated, 6L) + expect_identical(.repeated_rows(xy), 6L) + expect_identical(.repeated_rows(L$xy), 0L) + expect_identical(.repeated_rows(xy[c(1, 1, 1), ]), 3L) + expect_identical(.repeated_rows(xy[1, , drop = FALSE]), 0L) + # A row without a value at a repeated location is not a scored row. + y <- L$y; y[100] <- NA + expect_identical(.pool_column(y, L$gi, xy, NULL, "pooled", FALSE)$record$repeated, 4L) + # Gridded locations, where many rows share one coordinate and not the + # other: two rows at (1, 1) with a row at (1, 2) between them in the order + # of the first coordinate alone. + expect_identical(.repeated_rows(rbind(c(1, 1), c(1, 2), c(1, 1))), 2L) + expect_identical(.repeated_rows(rbind(c(1, 1), c(2, 1), c(1, 2), c(2, 2))), 0L) + grid <- unname(as.matrix(expand.grid(seq(0.1, by = 0.7, length.out = 20), + seq(0.3, by = 0.7, length.out = 15)))) + twice <- local({ .pt_seed(88); sample(nrow(grid), 100L) }) + both <- rbind(grid, grid[twice, ]) + both <- both[local({ .pt_seed(89); sample(nrow(both)) }), ] + expect_identical(.repeated_rows(grid), 0L) + expect_identical(.repeated_rows(both), 200L) + expect_identical(.repeated_rows(rbind(both, grid[twice[1:10], ])), 210L) +}) + +test_that("a column's `structured` is the rule's at the margin of 2 percent, for one level", { + # What .pool_column() hands the rule, held by its arguments: on a layer + # with a strong field, or with none, any margin gives the same answer. + L <- .pt_layout(4L) + rule <- .no_structure + seen <- NULL + local_mocked_bindings(.no_structure = function(loo, loo_one, p, tol, n_searched = 1L) { + seen <<- list(loo = loo, loo_one = loo_one, p = p, tol = tol, n_searched = n_searched) + rule(loo, loo_one, p, tol, n_searched) + }) + P <- .pool_column(L$y, L$gi, L$xy, obs_level = NULL, want = "pooled", use_fnn = FALSE) + expect_identical(seen$tol, 0.02) + expect_identical(seen$tol, .STRUCTURE_TOL) + expect_equal(seen$n_searched, 1) + expect_identical(seen$loo, P$fit$loo_pooled) + expect_identical(seen$loo_one, P$fit$loo_one) + expect_identical(seen$p, P$fit$f_p) + expect_identical(P$record$structured, rule(seen$loo, seen$loo_one, seen$p, 0.02, 1L)$structured) + expect_identical(P$record$structure_p, min(1, P$fit$f_p)) + # A layer on which the margin decides: one mean's error is 3 percent above + # the regions', and the F test is far from chance. + f <- P$fit + local_mocked_bindings(.pool_fit = function(...) { + f$loo_one <- f$loo_pooled * 1.03 + f$f_p <- 1e-6 + f + }) + expect_true(.pool_column(L$y, L$gi, L$xy, NULL, "pooled", FALSE)$record$structured) + local_mocked_bindings(.pool_fit = function(...) { + f$loo_one <- f$loo_pooled * 1.01 + f$f_p <- 1e-6 + f + }) + expect_false(.pool_column(L$y, L$gi, L$xy, NULL, "pooled", FALSE)$record$structured) +}) + +test_that("a later column with the same rows takes the first one's centroids and neighbours", { + L <- .pt_layout(4L) + id <- sprintf("c%04d", L$gi) + first <- .pool_column(L$y, id, L$xy, obs_level = 0.9, want = "pooled", use_fnn = FALSE) + other <- cos(L$xy[, 2] / 2e4) + 0.3 * L$y + alone <- .pool_column(other, id, L$xy, obs_level = 0.9, want = "pooled", use_fnn = FALSE) + local_mocked_bindings(.region_neighbours = function(...) stop("the neighbours were searched for")) + again <- .pool_column(other, id, L$xy, obs_level = 0.9, want = "pooled", use_fnn = FALSE, + geo = first$geo) + expect_identical(again, alone) + # Without them the search is made, and here it is the mock's stop: a plain + # error is passed on, only the work limit becomes a status. + expect_error(.pool_column(other, id, L$xy, obs_level = 0.9, want = "pooled", use_fnn = FALSE), + "neighbours were searched for") +}) diff --git a/tests/testthat/test-core-pool-reference.R b/tests/testthat/test-core-pool-reference.R new file mode 100644 index 00000000..3c20cf62 --- /dev/null +++ b/tests/testthat/test-core-pool-reference.R @@ -0,0 +1,175 @@ +# tests/testthat/test-core-pool-reference.R +# --------------------------------------------------------------------------- +# The engine of R/pool.R against the reference functions of +# helper-pool-reference.R, bit for bit. +# +# On the thirteen layouts of the helper (9 to 3,000 rows, 2 to 1,500 regions, +# 18 to 2 rows per region, uniform and clustered, up to 536 regions of one +# row) every number the engine and the reference both compute is held to +# identical(), with FNN and with the exact searches of base R. The layouts +# have no two candidate neighbours at one distance and no repeated location; +# test-core-pool-properties.R covers those. +# +# The reference functions call FNN, so every test here but the fifth skips +# without it. +# --------------------------------------------------------------------------- + +# One layout with what the reference returns for it, computed once. +.pr_store <- new.env(parent = emptyenv()) +.pr_case <- function(i) { + key <- as.character(i) + if (is.null(.pr_store[[key]])) { + L <- do.call(pool_layout, POOL_LAYOUTS[[i]]) + nn1 <- pool_nearest_other(L$xy) + L$nn1 <- nn1 + L$R <- region_estimates(L$y, L$gi, L$K, L$xy, want = c("P", "L")) + L$Fr <- fit_regions(L$gi, L$gi[1:3], L$y, L$xy, L$xy[1:3, , drop = FALSE], nn1) + L$tag <- sprintf("layout %d: %d rows in %d regions", i, length(L$y), L$K) + .pr_store[[key]] <- L + } + .pr_store[[key]] +} + +# The two searches: FNN's kd-tree and the exact one. +.pr_paths <- c(TRUE, FALSE) +.pr_tag <- function(L, use_fnn) paste0(L$tag, if (use_fnn) ", with FNN" else ", exact search") + + +test_that("1. the pooled value and the plain mean are region_estimates()'s", { + skip_if_not_installed("FNN") + for (i in seq_along(POOL_LAYOUTS)) for (f in .pr_paths) { + L <- .pr_case(i); tag <- .pr_tag(L, f) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + expect_identical(A$value, unname(L$R$est[, "L"]), info = tag) + expect_identical(A$m, unname(L$R$est[, "P"]), info = tag) + # The one-way parts the estimates are built from. + expect_identical(A$n, L$R$a$n, info = tag) + expect_identical(A$S, L$R$a$S, info = tag) + expect_identical(A$N, L$R$a$N, info = tag) + expect_identical(A$K, L$K, info = tag) + expect_identical(A$status, "ok", info = tag) + } +}) + +test_that("2. the parts of the pooled value and both residual vectors are fit_regions()'s", { + skip_if_not_installed("FNN") + for (i in seq_along(POOL_LAYOUTS)) for (f in .pr_paths) { + L <- .pr_case(i); tag <- .pr_tag(L, f); Fr <- L$Fr + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + expect_identical(A$sigma2, Fr$sigma2, info = tag) + expect_identical(A$tau2, Fr$tau2, info = tag) + expect_identical(A$w, Fr$w, info = tag) + expect_identical(A$target, Fr$t, info = tag) + expect_identical(A$Q, Fr$Q, info = tag) + expect_identical(A$nb, Fr$nb, info = tag) + expect_identical(A$resid_pooled, Fr$eL, info = tag) + expect_identical(A$resid_mean, Fr$eP, info = tag) + expect_identical(A$loo_pooled, Fr$loo_L, info = tag) + expect_identical(A$loo_pooled_se, Fr$loo_L_se, info = tag) + # The centroids are summed in coordinate order where the reference sums + # them in row order, so they agree to rounding and not to the last bit. + expect_equal(unname(A$cen), unname(rowsum(L$xy, L$gi) / A$n), tolerance = 1e-12, + info = tag) + } +}) + +test_that("3. the plain mean's leave-one-out error is loo_plain()'s and fit_regions()'s", { + skip_if_not_installed("FNN") + for (i in seq_along(POOL_LAYOUTS)) for (f in .pr_paths) { + L <- .pr_case(i); tag <- .pr_tag(L, f) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + expect_identical(A$loo_mean, loo_plain(L$y, L$gi, L$R$a, L$nn1), info = tag) + expect_identical(A$loo_mean, L$Fr$loo_P, info = tag) + expect_identical(A$loo_mean_se, stats::sd(L$Fr$eP^2) / sqrt(length(L$y)), info = tag) + # The nearest other row the fit found for the rows alone in their region + # is the reference's, and a fit handed the reference's rows is the same. + alone <- which(A$n[L$gi] == 1L) + expect_identical(.nearest_other(L$xy, L$gi, alone, f), L$nn1[alone], info = tag) + B <- .pool_fit(L$y, L$gi, L$K, L$xy, nn1 = L$nn1, use_fnn = f) + expect_identical(B, A, info = tag) + } + # The layouts hold regions of one row, which is where the two differ from + # the residual formula of the regions that hold more. + expect_gt(sum(.pr_case(7L)$R$a$n == 1L), 500L) +}) + +test_that("4. the interval's offsets are the 5th and 95th percentiles, and the ends loo_int()'s", { + skip_if_not_installed("FNN") + for (i in seq_along(POOL_LAYOUTS)) for (f in .pr_paths) { + L <- .pr_case(i); tag <- .pr_tag(L, f) + A <- .pool_fit(L$y, L$gi, L$K, L$xy, use_fnn = f) + e <- A$resid_pooled + off <- .obs_offsets(e, 0.90) + expect_identical(off, stats::quantile(e, c(0.05, 0.95), names = FALSE, type = 7), + info = tag) + expect_identical(cbind(A$value + off[1L], A$value + off[2L]), + loo_int(A$value, e, 1, 1), info = tag) + # And against the reference's own value and residuals. + expect_identical(cbind(A$value + off[1L], A$value + off[2L]), + loo_int(L$Fr$est[, "L"], L$Fr$eL, 1, 1), info = tag) + } +}) + +test_that("5. the count at a size is rung_k()'s", { + # rung_k() is arithmetic alone, so this one runs without FNN. + expect_identical(.OBS_PER_CELL_LADDER, c(18, 12, 9, 6, 4.5, 3, 2)) + expect_identical(.OBS_PER_CELL_DEFAULT, 4.5) + n <- 9:10000 + halves <- 0L + for (m in .OBS_PER_CELL_LADDER) { + want <- vapply(n, function(v) rung_k(v, m), integer(1)) + expect_identical(.count_at(n, m), want, info = sprintf("size %s", m)) + expect_identical(vapply(n, function(v) .count_at(v, m), integer(1)), want, + info = sprintf("size %s, one count at a time", m)) + halves <- halves + sum((n / m) %% 1 == 0.5) + } + # The range holds quotients that end in a half, which R rounds to the even + # number: 4.5 to 4, 13.5 to 14, 2.5 to 2, 3.5 to 4. + expect_gt(halves, 1000L) + expect_identical(.count_at(9, 2), 4L) + expect_identical(.count_at(27, 2), 14L) + expect_identical(.count_at(45, 18), 2L) + expect_identical(.count_at(63, 18), 4L) + # Never fewer than two regions. + expect_identical(.count_at(12, 18), 2L) + expect_identical(.count_at(1, 4.5), 2L) +}) + +test_that("6. with one value beyond one per region the fit is region_estimates()'s", { + skip_if_not_installed("FNN") + # Forty regions of one row and a forty-first row in region 17: N - K = 1, + # the fewest values sigma2 can rest on. + cleanup <- pool_seed(61) + xy <- cbind(stats::runif(40, 0, 1e5), stats::runif(40, 0, 1e5)) + xy <- rbind(xy, xy[17, ] + c(350, -210)) + y <- sin(xy[, 1] / 2e4) + cos(xy[, 2] / 1.5e4) + stats::rnorm(41, 0, 0.6) + cleanup() + gi <- c(1:40, 17L); K <- 40L + nn1 <- pool_nearest_other(xy) + R <- region_estimates(y, gi, K, xy, want = c("P", "L")) + Fr <- fit_regions(gi, gi[1:3], y, xy, xy[1:3, , drop = FALSE], nn1) + expect_identical(R$a$N - R$a$K, 1L) + for (f in .pr_paths) { + tag <- if (f) "with FNN" else "exact search" + A <- .pool_fit(y, gi, K, xy, use_fnn = f) + expect_identical(A$value, unname(R$est[, "L"]), info = tag) + expect_identical(A$m, unname(R$est[, "P"]), info = tag) + expect_identical(A$sigma2, R$a$sigma2, info = tag) + expect_identical(A$sigma2, sum((y - A$m[gi])^2) / 1, info = tag) + expect_identical(A$tau2, Fr$tau2, info = tag) + expect_identical(A$w, Fr$w, info = tag) + expect_identical(A$target, Fr$t, info = tag) + expect_identical(A$nb, Fr$nb, info = tag) + expect_identical(A$resid_pooled, Fr$eL, info = tag) + expect_identical(A$resid_mean, Fr$eP, info = tag) + expect_identical(A$loo_pooled, Fr$loo_L, info = tag) + expect_identical(A$loo_mean, Fr$loo_P, info = tag) + expect_true(A$status %in% c("ok", "no signal between cells"), info = tag) + } + # One row fewer and no region holds two: the reference stops, and the + # engine returns the status without a fit. + expect_error(region_estimates(y[1:40], 1:40, 40L, xy[1:40, ], want = c("P", "L")), + "no group holds two") + expect_identical(.pool_fit(y[1:40], 1:40, 40L, xy[1:40, ])$status, + "no cell holds two values") +}) diff --git a/tests/testthat/test-core-pool-summary.R b/tests/testthat/test-core-pool-summary.R new file mode 100644 index 00000000..060eb724 --- /dev/null +++ b/tests/testthat/test-core-pool-summary.R @@ -0,0 +1,1843 @@ +# tests/testthat/test-core-pool-summary.R +# --------------------------------------------------------------------------- +# summarize_by_cell(estimate = "pooled", obs_level = ): the pooled columns, +# their record and their warnings, through the exported function. +# +# The pooled value, its own weight, its target, the interval for one +# observation and the leave-one-out error in the record are held to the +# reference functions of helper-pool-reference.R on cells built from real +# polygons. The columns a call shares with estimate = "mean" are held +# identical() to that call's, so nothing the function returned before moves. +# +# Every call names `estimate`. Unless a test says otherwise the cells are of +# the density kind from 3 k-means++ starts, built as a user builds them: +# voronoi_seeds_kmeans(), build_tessellation(), assign_features_to_polygons(). +# A backend is switched off by replacing .has_backend(), as the code under +# test asks for FNN through that one function. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.ps_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +.ps_store <- new.env(parent = emptyenv()) +.ps_keep <- function(key, expr) { + if (is.null(.ps_store[[key]])) .ps_store[[key]] <- expr + .ps_store[[key]] +} + +.ps_points <- function(x, y, data, crs = 32617) + sf::st_as_sf(cbind(data.frame(x = x, y = y), data), coords = c("x", "y"), crs = crs) + +# Cells of the density kind at `k` centres from 3 k-means++ starts, and the +# layer assigned to them. +.ps_assign <- function(pts, k) { + seeds <- suppressWarnings( + voronoi_seeds_kmeans(pts, k, set_seed = 123, nstart = 3, partition = "density", + init = "kmeans++")) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + list(asg = assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id"), + cells = tess$cells) +} + +# A call with its warnings kept and muffled. +.ps_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.ps_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.ps_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) + +# What a classed condition carries besides its text. +.ps_fields <- function(w) unclass(w)[setdiff(names(unclass(w)), c("message", "call"))] + +.ps_without_fnn <- function(env = parent.frame()) + testthat::local_mocked_bindings( + .has_backend = function(pkg) + if (identical(pkg, "FNN")) FALSE else requireNamespace(pkg, quietly = TRUE), + .env = env) + +.ps_pooled_names <- function(x) grep("^\\.\\.(pooled|obs)_", names(x), value = TRUE) + +# 900 rows with a response and two predictors that all vary smoothly over the +# layer, in 150 cells: x, then y, then z, p1 and p2. No column of it raises +# a warning of the pooled path. +.ps_layer <- function() .ps_keep("layer", { + d <- local({ + .ps_seed(2001) + x <- stats::runif(900, 0, 1e5); y <- stats::runif(900, 0, 1e5) + data.frame(x = x, y = y, + z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(900, 0, 0.6), + p1 = cos(x / 1.2e4) - sin(y / 2.5e4) + stats::rnorm(900, 0, 0.5), + p2 = (x + y) / 5e4 + stats::rnorm(900, 0, 0.4)) + }) + .ps_assign(.ps_points(d$x, d$y, d[c("z", "p1", "p2")]), 150L) +}) + +# The (3000, 4.5) layout of the engine's reference tests, assigned through +# real polygons: Voronoi cells on the seeds of the k-means kind from 10 starts. +.ps_reference <- function() .ps_keep("reference", { + L <- do.call(pool_layout, POOL_LAYOUTS[[4L]]) + pts <- .ps_points(L$xy[, 1], L$xy[, 2], data.frame(v = L$y)) + seeds <- voronoi_seeds_kmeans(pts, 667, set_seed = 456, nstart = 10, partition = "kmeans") + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + list(layout = L, cells = tess$cells, + asg = assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id")) +}) + +# The lattice of the engine's property tests: 60 x 50 locations at a spacing +# of 0.7 from (0.1, 0.3), in the regions of a k-means fit at 667 centres. +# None of its coordinates is exact in binary and every location has +# neighbours at exactly equal distances. The regions are an ID column: a row +# on a boundary between two polygons would be assigned by the tie rule of +# assign_features_to_polygons(), which is not what is tested here. +.ps_lattice <- function() .ps_keep("lattice", { + xy <- as.matrix(expand.grid(x = seq(0.1, by = 0.7, length.out = 60), + y = seq(0.3, by = 0.7, length.out = 50))) + dimnames(xy) <- NULL + v <- local({ + .ps_seed(31) + sin(xy[, 1] / 9) + cos(xy[, 2] / 7) + stats::rnorm(nrow(xy), 0, 0.5) + }) + g <- local({ + .ps_seed(3) + km <- suppressWarnings(stats::kmeans(xy, 667L, nstart = 3, iter.max = 100)) + .nearest_centre(xy[, 1], xy[, 2], km$centers[, 1], km$centers[, 2]) + }) + .ps_points(xy[, 1], xy[, 2], data.frame(v = v, cell_id = match(g, sort(unique(g))))) +}) + +# 900 rows on a 10 x 10 grid of squares, the cell an arithmetic function of +# the coordinates, so that the cells are the same on every platform. +.ps_grid_layer <- function() .ps_keep("grid", { + d <- local({ + .ps_seed(2002) + x <- stats::runif(900, 0, 1e5); y <- stats::runif(900, 0, 1e5) + data.frame(x = x, y = y, + income = 52000 + 9000 * sin(x / 2e4) + 7000 * cos(y / 1.5e4) + + stats::rnorm(900, 0, 6000)) + }) + d$cell_id <- as.integer(10 * floor(d$x / 1e4) + floor(d$y / 1e4) + 1) + .ps_points(d$x, d$y, d[c("income", "cell_id")]) +}) + +# 400 rows of a Gaussian field with an exponential covariance and a nugget, +# on which a variogram is identified, in 60 cells: x, then y, then z, p1, p2. +.ps_field_layer <- function() .ps_keep("field", { + d <- local({ + .ps_seed(2010) + x <- 5e5 + stats::runif(400, 0, 1000); y <- 5e6 + stats::runif(400, 0, 1000) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- 10 + as.numeric(t(chol(exp(-D / 90) + diag(0.3, 400))) %*% stats::rnorm(400)) + data.frame(x = x, y = y, z = z, p1 = 0.5 * z + stats::rnorm(400), p2 = stats::rnorm(400)) + }) + .ps_assign(.ps_points(d$x, d$y, d[c("z", "p1", "p2")], crs = 32632), 60L) +}) + + +# ---- The argument omitted, and the columns the two estimates share ----------- + +test_that("estimate = \"pooled\" named is the call without the argument", { + L <- .ps_layer() + calls <- list( + function(...) summarize_by_cell(L$asg, "z", id_col = "cell_id", ...), + function(...) summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", + deff = "kish", conf_level = 0.9, ...), + function(...) summarize_by_cell(L$asg, "z", id_col = "cell_id", cells_sf = L$cells, + area = TRUE, deff = 2, ...), + function(...) summarize_by_cell(L$asg, "z", id_col = "cell_id", agg_funs = median, ...), + function(...) summarize_by_cell(sf::st_drop_geometry(L$asg), "z", "p1", + id_col = "cell_id", ...)) + for (f in calls) { + # The default is the pooled value beside the plain mean, with the same + # warnings as when it is named (a layer with no geometry has none to + # pool by). + plain <- .ps_catch(f()) + named <- .ps_catch(f(estimate = "pooled")) + expect_identical(named$value, plain$value) + expect_identical(.ps_classes(named), .ps_classes(plain)) + expect_identical(.ps_catch(f(estimate = "pooled", obs_level = NULL))$value, plain$value) + expect_false(is.null(attr(plain$value, "pooled"))) + # No attribute of the pooled path on the frame of plain means. + expect_null(attr(f(estimate = "mean"), "pooled")) + expect_null(attr(f(estimate = "mean"), "intervals")) + expect_length(.ps_pooled_names(f(estimate = "mean")), 0L) + } + # The two new arguments come last, so a call by position is as it was. + expect_identical(utils::tail(names(formals(summarize_by_cell)), 2L), + c("estimate", "obs_level")) + # Which of the two `estimate` defaults to is held in test-core-defaults.R; + # the test above (the argument named against the argument omitted) is the + # one expectation of this file that reads the default. + expect_setequal(eval(formals(summarize_by_cell)$estimate), c("mean", "pooled")) + expect_null(formals(summarize_by_cell)$obs_level) + expect_identical( + summarize_by_cell(L$asg, "z", NULL, "cell_id", list(mean = function(x) mean(x, na.rm = TRUE)), + NULL, 1, NULL, 500L, TRUE, 0.9, FALSE), + summarize_by_cell(L$asg, "z", id_col = "cell_id", conf_level = 0.9)) + # A layer with structure in every column raises nothing on the pooled path, + # and the call draws no random number. + .ps_seed(77) + before <- get(".Random.seed", envir = globalenv()) + r <- .ps_catch(summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)) + expect_length(r$warnings, 0L) + expect_identical(get(".Random.seed", envir = globalenv()), before) + expect_error(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "median"), + "should be one of") +}) + +test_that("every column and attribute the two estimates share is identical", { + settings <- list(`deff = 1` = list(), `deff = "kish"` = list(deff = "kish"), + `deff = 2` = list(deff = 2)) + layers <- list(`deff = 1` = .ps_layer(), `deff = "kish"` = .ps_layer(), + `deff = 2` = .ps_layer()) + if (requireNamespace("gstat", quietly = TRUE)) { + # A variogram of the response, on a layer where one is identified. + layers$`a supplied sac` <- .ps_field_layer() + sac <- suppressWarnings(estimate_sac_range(layers$`a supplied sac`$asg, "z")) + expect_true(is.finite(as.numeric(sac))) + settings$`a supplied sac` <- list(deff = "variogram", sac = sac) + } + compared <- 0L + for (nm in names(settings)) for (conf in list(NULL, 0.95)) + for (shape in c("frame", "cells", "area")) { + L <- layers[[nm]] + args <- c(list(L$asg, "z", c("p1", "p2"), id_col = "cell_id", conf_level = conf), + settings[[nm]], + switch(shape, frame = list(), cells = list(cells_sf = L$cells), + area = list(cells_sf = L$cells, area = TRUE))) + tag <- sprintf("%s, conf_level %s, %s", nm, format(conf), shape) + a <- suppressWarnings(do.call(summarize_by_cell, c(args, list(estimate = "mean")))) + b <- suppressWarnings(do.call(summarize_by_cell, c(args, list(estimate = "pooled")))) + new <- .ps_pooled_names(b) + expect_length(new, 9L) + # Every present column keeps its name, its values and its position; the + # new ones stand together behind the grouped summary's. + expect_identical(setdiff(names(b), new), names(a), info = tag) + for (col in names(a)) expect_identical(b[[col]], a[[col]], info = paste(tag, col)) + at <- match(new, names(b)) + expect_identical(at, seq(at[1L], length.out = 9L), info = tag) + last <- if (!identical(settings[[nm]], list())) "deff_method" else "cell_weight" + expect_identical(names(b)[at[1L] - 1L], last, info = tag) + if (shape != "frame") + expect_identical(names(b)[at[9L] + 1L], attr(b, "sf_column"), info = tag) + for (att in c("deff_applied", "icc", "area_error")) + expect_identical(attr(b, att), attr(a, att), info = paste(tag, att)) + expect_identical(setdiff(names(attributes(b)), names(attributes(a))), + c("pooled", "intervals"), info = tag) + expect_identical(class(b), class(a), info = tag) + compared <- compared + 1L + } + expect_gte(compared, 18L) + # The design effect was applied where it was asked for, so the comparison + # above is of corrected columns and not of two frames without any. + k <- suppressWarnings(summarize_by_cell(.ps_layer()$asg, "z", id_col = "cell_id", + deff = "kish", estimate = "pooled")) + expect_true(all(k$deff_applied)) + expect_identical(attr(k, "deff_applied")$method, "kish") + if (requireNamespace("gstat", quietly = TRUE)) { + v <- suppressWarnings(summarize_by_cell(.ps_field_layer()$asg, "z", id_col = "cell_id", + deff = "variogram", sac = sac, estimate = "pooled")) + expect_identical(unique(v$deff_method), "variogram") + expect_identical(attr(v, "deff_applied")$method, "variogram") + } +}) + +test_that("deff does not enter the pooled columns", { + L <- .ps_layer() + one <- summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", deff = 1, + estimate = "pooled", obs_level = 0.9) + for (d in list("kish", 3)) { + other <- summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", deff = d, + estimate = "pooled", obs_level = 0.9, conf_level = 0.95) + for (col in .ps_pooled_names(one)) + expect_identical(other[[col]], one[[col]], info = paste(format(d), col)) + expect_identical(attr(other, "pooled")$columns, attr(one, "pooled")$columns) + # The standard errors did move. + expect_false(isTRUE(all.equal(other$..se_resp_z, one$..se_resp_z))) + } +}) + + +# ---- Reproduction ------------------------------------------------------------ + +test_that("the pooled columns and the record are the reference functions' on real polygons", { + skip_if_not_installed("FNN") + R <- .ps_reference() + asg <- R$asg + expect_identical(nrow(asg), 3000L) + expect_true(is.integer(asg$cell_id)) + xy <- unname(sf::st_coordinates(asg)[, 1:2]) + expect_identical(xy, R$layout$xy) # the rows are in fixture order + y <- asg$v + g <- asg$cell_id + u <- sort(unique(g)); K <- length(u); gi <- match(g, u) + expect_gt(K, 600L) + ref <- region_estimates(y, gi, K, xy, want = c("P", "L")) + fr <- fit_regions(g, g, y, xy, xy, pool_nearest_other(xy)) + li <- loo_int(unname(ref$est[, "L"]), fr$eL, 1, 1) + N <- length(y) + + for (fnn in c(TRUE, FALSE)) { + tag <- if (fnn) "FNN" else "exact" + out <- local({ + if (!fnn) .ps_without_fnn() + r <- .ps_catch(summarize_by_cell(asg, "v", id_col = "cell_id", estimate = "pooled", + obs_level = 0.90)) + expect_length(r$warnings, 0L) + r$value + }) + expect_identical(out$cell_id, u, info = tag) + expect_identical(out$..pooled_resp_v, unname(ref$est[, "L"]), info = tag) + expect_identical(out$..pooled_w_resp_v, fr$w, info = tag) + expect_identical(out$..pooled_target_resp_v, fr$t, info = tag) + expect_identical(out$..obs_lo_resp_v, li[, 1], info = tag) + expect_identical(out$..obs_hi_resp_v, li[, 2], info = tag) + rec <- attr(out, "pooled")$columns$resp_v + expect_identical(rec$loo, fr$loo_L, info = tag) + expect_identical(rec$loo_se, fr$loo_L_se, info = tag) + expect_identical(rec$own_weight, stats::median(fr$w), info = tag) + expect_identical(rec$share_alone, sum(fr$n == 1L) / N, info = tag) + expect_identical(rec$df, N - K, info = tag) + expect_identical(rec$loo_one_cell, mean(((y - mean(y)) * N / (N - 1))^2), info = tag) + expect_identical(rec$sigma2, fr$sigma2, info = tag) + expect_identical(rec$tau2, fr$tau2, info = tag) + expect_identical(rec$n, N, info = tag) + expect_identical(rec$cells, K, info = tag) + expect_identical(rec$offsets, + stats::quantile(fr$eL, c(0.05, 0.95), names = FALSE, type = 7), info = tag) + expect_identical(rec$status, "ok", info = tag) + } + # The layout has cells of one row, where the weight is smallest. + expect_gt(sum(fr$n == 1L), 20L) + + # In another row order and with IDs that are not whole numbers the sums are + # taken in another order, and the equality is to rounding. + p <- local({ .ps_seed(41); sample.int(N) }) + lab <- local({ .ps_seed(42); sample(sprintf("cell-%04d", seq_len(K))) }) + alt <- asg[p, ] + alt$cell_id <- lab[gi[p]] + out <- summarize_by_cell(alt, "v", id_col = "cell_id", estimate = "pooled", obs_level = 0.90) + at <- match(lab, out$cell_id) + expect_false(is.unsorted(out$cell_id)) + expect_false(identical(at, seq_len(K))) + expect_equal(out$..pooled_resp_v[at], unname(ref$est[, "L"]), tolerance = 1e-12) + expect_equal(out$..pooled_w_resp_v[at], fr$w, tolerance = 1e-12) + expect_equal(out$..pooled_target_resp_v[at], fr$t, tolerance = 1e-12) + expect_equal(out$..obs_lo_resp_v[at], li[, 1], tolerance = 1e-12) + expect_equal(out$..obs_hi_resp_v[at], li[, 2], tolerance = 1e-12) + rec <- attr(out, "pooled")$columns$resp_v + expect_equal(rec$loo, fr$loo_L, tolerance = 1e-12) + expect_equal(rec$own_weight, stats::median(fr$w), tolerance = 1e-12) + expect_identical(rec$share_alone, sum(fr$n == 1L) / N) + expect_identical(rec$df, N - K) +}) + +test_that("the pooled value is its weight times the plain mean and the rest times the target", { + L <- .ps_layer() + out <- summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", estimate = "pooled") + for (v in c("resp_z", "pred_p1", "pred_p2")) { + w <- out[[paste0("..pooled_w_", v)]] + m <- out[[sub("_", "_mean_", v, fixed = TRUE)]] + expect_equal(out[[paste0("..pooled_", v)]], + w * m + (1 - w) * out[[paste0("..pooled_target_", v)]], + tolerance = 1e-12, info = v) + expect_true(all(w > 0 & w < 1), info = v) + # The weights of one column rise with the cell's count. + expect_false(is.unsorted(w[order(out$n)]), info = v) + } +}) + +test_that("a valued row without a location is left out of the pooled mean, with a warning", { + L <- .ps_layer() + asg <- L$asg + # A row of a cell of four rows or more loses its point; its value is the + # cell's largest by far, so the two means differ visibly. + cell <- as.integer(names(which(table(asg$cell_id) >= 4L))[1L]) + row <- which(asg$cell_id == cell)[1L] + asg$z[row] <- 50 + g <- sf::st_geometry(asg) + g[[row]] <- sf::st_point() + sf::st_geometry(asg) <- g + r <- .ps_catch(summarize_by_cell(asg, "z", id_col = "cell_id", estimate = "pooled")) + expect_identical(.ps_classes(r), "spatialkit_pool_rows_skipped") + w <- r$warnings[[1L]] + expect_identical(.ps_fields(w), list(n = 1L, cells = 1L, columns = "z")) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): 1 row(s) in 1 cell(s) have empty or non-finite coordinates. ", + "They count in `n` and the plain columns and take no part in the pooled columns.")) + out <- r$value + rec <- attr(out, "pooled")$columns$resp_z + expect_identical(rec$skipped, 1L) + expect_identical(rec$n, nrow(asg) - 1L) + i <- which(out$cell_id == cell) + expect_identical(out$n[i], sum(asg$cell_id == cell)) # the row still counts in n + identity_gap <- abs(out$..pooled_resp_z - + (out$..pooled_w_resp_z * out$resp_mean_z + + (1 - out$..pooled_w_resp_z) * out$..pooled_target_resp_z)) + # In that cell the plain mean holds the row and the pooled value's own mean + # does not, so the identity fails there. Its neighbours' targets changed + # with it, and everywhere else the identity holds. + expect_gt(identity_gap[i], 1) + expect_lt(max(identity_gap[-i]), 1e-12) + # The pooled columns are those of the layer without the row. + less <- summarize_by_cell(asg[-row, ], "z", id_col = "cell_id", estimate = "pooled") + for (col in .ps_pooled_names(out)) expect_identical(out[[col]], less[[col]], info = col) + rec$skipped <- 0L + expect_identical(rec, attr(less, "pooled")$columns$resp_z) +}) + + +# ---- Columns, attributes and the join ----------------------------------------- + +test_that("the new columns follow the present ones, the response's first", { + L <- .ps_layer() + out <- summarize_by_cell(L$asg, "z", c("p2", "p1"), id_col = "cell_id", deff = "kish", + conf_level = 0.95, estimate = "pooled", obs_level = 0.9) + stems <- c("..pooled_", "..pooled_w_", "..pooled_target_", "..obs_lo_", "..obs_hi_") + # Behind every present column, the design effect's two included; then the + # response's, then each predictor's in the order of `predictor_vars`. + expect_identical(utils::tail(names(out), 18L), + c("cell_weight", "deff_applied", "deff_method", paste0(stems, "resp_z"), + paste0(stems, "pred_p2"), paste0(stems, "pred_p1"))) + # Without a level, three columns a variable; without a design effect they + # follow cell_weight. + out <- summarize_by_cell(L$asg, "z", "p1", id_col = "cell_id", estimate = "pooled") + expect_identical(utils::tail(names(out), 7L), + c("cell_weight", paste0(stems[1:3], "resp_z"), paste0(stems[1:3], "pred_p1"))) + # Predictors alone. + out <- summarize_by_cell(L$asg, predictor_vars = c("p1", "p2"), id_col = "cell_id", + estimate = "pooled") + expect_identical(.ps_pooled_names(out), + c(paste0(stems[1:3], "pred_p1"), paste0(stems[1:3], "pred_p2"))) + expect_identical(names(attr(out, "pooled")$columns), c("pred_p1", "pred_p2")) + # With the cells joined, the geometry and the area follow. + out <- summarize_by_cell(L$asg, "z", id_col = "cell_id", cells_sf = L$cells, area = TRUE, + estimate = "pooled", obs_level = 0.9) + expect_identical(utils::tail(names(out), 9L), + c("cell_weight", paste0(stems, "resp_z"), "geometry", "cell_area", + "n_per_area")) +}) + +test_that("the record has the fields of the design, and each column its entry", { + L <- .ps_layer() + out <- summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", conf_level = 0.95, + estimate = "pooled", obs_level = 0.9) + rec <- attr(out, "pooled") + expect_s3_class(rec, "spatialkit_pooled") + expect_identical(names(rec), c("toward", "neighbours", "crs", "obs_level", "conf_level", + "intervals", "columns")) + expect_identical(rec$toward, "neighbours") + expect_identical(rec$neighbours, 8L) + expect_identical(rec$crs, sf::st_crs(L$asg)) + expect_identical(rec$obs_level, 0.9) + expect_identical(rec$conf_level, 0.95) + expect_identical(names(rec$columns), c("resp_z", "pred_p1", "pred_p2")) + fields <- c("column", "role", "n", "cells", "df", "neighbours", "sigma2", "tau2", + "own_weight", "share_alone", "loo", "loo_se", "loo_one_cell", "structured", + "structure_p", "offsets", "repeated", "skipped", "constant", "status") + for (nm in names(rec$columns)) { + r <- rec$columns[[nm]] + expect_identical(names(r), fields, info = nm) + expect_identical(r$column, sub("^(resp|pred)_", "", nm), info = nm) + expect_identical(r$role, if (startsWith(nm, "resp_")) "response" else "predictor", info = nm) + expect_identical(r$n, 900L, info = nm) + expect_identical(r$cells, length(unique(L$asg$cell_id)), info = nm) + expect_identical(r$df, r$n - r$cells, info = nm) + expect_identical(r$neighbours, 8L, info = nm) + expect_identical(r$own_weight, stats::median(out[[paste0("..pooled_w_", nm)]]), info = nm) + expect_identical(r$share_alone, sum(out$n == 1L) / 900, info = nm) + expect_true(r$structured, info = nm) + expect_lt(r$structure_p, 0.05) + expect_lt(r$loo, r$loo_one_cell) + expect_gt(r$loo_se, 0) + expect_length(r$offsets, 2L) + expect_identical(out[[paste0("..obs_lo_", nm)]], out[[paste0("..pooled_", nm)]] + r$offsets[1L]) + expect_identical(out[[paste0("..obs_hi_", nm)]], out[[paste0("..pooled_", nm)]] + r$offsets[2L]) + expect_identical(c(r$repeated, r$skipped), c(0L, 0L), info = nm) + expect_false(r$constant, info = nm) + expect_identical(r$status, "ok", info = nm) + } + # Without the levels the fields are there and NULL. + bare <- attr(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled"), "pooled") + expect_identical(names(bare), names(rec)) + expect_null(bare$obs_level) + expect_null(bare$conf_level) + expect_identical(names(bare$columns$resp_z), fields) + expect_null(bare$columns$resp_z$offsets) + # The engine's own fit of the same rows is what the record and the frame hold. + xy <- unname(sf::st_coordinates(L$asg)[, 1:2]) + u <- sort(unique(L$asg$cell_id)) + f <- .pool_fit(L$asg$z, match(L$asg$cell_id, u), length(u), xy, want = "pooled") + expect_identical(out$..pooled_resp_z, f$value) + expect_identical(rec$columns$resp_z$loo, f$loo_pooled) + expect_identical(rec$columns$resp_z$loo_se, f$loo_pooled_se) + expect_identical(rec$columns$resp_z$loo_one_cell, f$loo_one) + expect_identical(rec$columns$resp_z$structure_p, f$f_p) +}) + +test_that("the attributes survive the join, and a cell without a row is NA", { + L <- .ps_layer() + ids <- sort(unique(L$asg$cell_id)) + gone <- ids[c(3L, 77L)] + asg <- L$asg[!(L$asg$cell_id %in% gone), ] + plain <- summarize_by_cell(asg, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9, conf_level = 0.95, deff = "kish") + joined <- summarize_by_cell(asg, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9, conf_level = 0.95, deff = "kish", + cells_sf = L$cells) + expect_s3_class(joined, "sf") + expect_identical(nrow(joined), nrow(L$cells)) + expect_identical(attr(joined, "pooled"), attr(plain, "pooled")) + expect_identical(attr(joined, "intervals"), attr(plain, "intervals")) + expect_identical(attr(joined, "icc"), attr(plain, "icc")) + new <- .ps_pooled_names(plain) + expect_length(new, 10L) + empty <- joined$cell_id %in% gone + expect_identical(sum(empty), 2L) + for (col in new) { + expect_true(all(is.na(joined[[col]][empty])), info = col) + at <- match(plain$cell_id, joined$cell_id) + expect_identical(joined[[col]][at], plain[[col]], info = col) + expect_false(anyNA(joined[[col]][!empty]), info = col) + } + # The empty cells are no cell's neighbour: the values are those of a layer + # that never held them. + expect_identical(attr(joined, "pooled")$columns$resp_z$cells, length(ids) - 2L) + # The frame returned keeps the cells' CRS, and IDs of another class than the + # cells' are joined as today, with the attributes kept. + expect_identical(sf::st_crs(joined), sf::st_crs(L$cells)) + cells_chr <- L$cells + cells_chr$cell_id <- as.character(cells_chr$cell_id) + mixed <- summarize_by_cell(asg, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9, conf_level = 0.95, deff = "kish", + cells_sf = cells_chr) + expect_type(mixed$cell_id, "character") + expect_identical(attr(mixed, "pooled"), attr(plain, "pooled")) + expect_identical(attr(mixed, "intervals"), attr(plain, "intervals")) + expect_identical(mixed$..pooled_resp_z[match(as.character(plain$cell_id), mixed$cell_id)], + plain$..pooled_resp_z) + # A `cells_sf` that cannot be joined leaves the frame, with its attributes. + r <- .ps_catch(summarize_by_cell(asg, "z", id_col = "cell_id", estimate = "pooled", + cells_sf = "not a layer")) + expect_length(r$warnings, 1L) + expect_s3_class(attr(r$value, "pooled"), "spatialkit_pooled") + expect_identical(attr(r$value, "intervals"), attr(r$value, "pooled")$intervals) +}) + + +# ---- Missing and infinite values ---------------------------------------------- + +test_that("a column is pooled on its own rows: the rows that miss it are as if absent", { + L <- .ps_layer() + asg <- L$asg + miss1 <- local({ .ps_seed(51); sample.int(nrow(asg), 60L) }) + miss2 <- local({ .ps_seed(52); sample.int(nrow(asg), 45L) }) + both_miss <- length(intersect(miss1, miss2)) # they overlap in a few rows only + expect_gt(both_miss, 0L); expect_lt(both_miss, 10L) + asg$p1[miss1] <- NA + asg$p2[miss2] <- NA + # A cell whose rows all miss p1, so the column has a cell fewer than the others. + cell <- as.integer(names(which(table(asg$cell_id) == 3L))[1L]) + asg$p1[asg$cell_id == cell] <- NA + both <- summarize_by_cell(asg, "z", c("p1", "p2"), id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + for (v in c("p1", "p2")) { + keep <- !is.na(asg[[v]]) + own <- summarize_by_cell(asg[keep, ], predictor_vars = v, id_col = "cell_id", + estimate = "pooled", obs_level = 0.9) + at <- match(own$cell_id, both$cell_id) + for (col in .ps_pooled_names(own)) + expect_identical(both[[col]][at], own[[col]], info = col) + expect_identical(attr(both, "pooled")$columns[[paste0("pred_", v)]], + attr(own, "pooled")$columns[[paste0("pred_", v)]]) + expect_identical(attr(own, "pooled")$columns[[paste0("pred_", v)]]$n, sum(keep)) + } + # The response misses nothing and is as it is without the predictors. + alone <- summarize_by_cell(asg, "z", id_col = "cell_id", estimate = "pooled", obs_level = 0.9) + for (col in .ps_pooled_names(alone)) expect_identical(both[[col]], alone[[col]], info = col) + # The cell whose rows all miss p1 has no pooled value of it, and one of the others. + i <- which(both$cell_id == cell) + expect_true(all(is.na(unlist(sf::st_drop_geometry(both)[i, grep("pred_p1$", .ps_pooled_names(both), value = TRUE)])))) + expect_false(is.na(both$..pooled_pred_p2[i])) + expect_identical(attr(both, "pooled")$columns$pred_p1$cells, + attr(both, "pooled")$columns$resp_z$cells - 1L) +}) + +test_that("an infinite value is a missing value, and is said once", { + L <- .ps_layer() + asg <- L$asg + asg$z[c(5L, 300L)] <- c(Inf, -Inf) + asg$p1[17L] <- Inf + na <- asg + na$z[c(5L, 300L)] <- NA + na$p1[17L] <- NA + r <- .ps_catch(summarize_by_cell(asg, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9)) + expect_identical(.ps_classes(r), "spatialkit_nonfinite") + expect_identical(r$warnings[[1L]]$columns, c("z", "p1")) + expect_identical(r$warnings[[1L]]$n, 3L) + # The same condition as the call of plain means raises. + m <- .ps_catch(summarize_by_cell(asg, "z", "p1", id_col = "cell_id", estimate = "mean")) + expect_identical(conditionMessage(m$warnings[[1L]]), conditionMessage(r$warnings[[1L]])) + want <- summarize_by_cell(na, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + expect_identical(r$value, want) + expect_identical(attr(r$value, "pooled")$columns$resp_z$n, 898L) +}) + + +# ---- One warning per call and reason ------------------------------------------- + +test_that("three structureless columns raise one spatialkit_no_structure that names all three", { + # White noise in the response and both predictors: x, then y, then the three + # columns, 3,000 rows in 667 cells. + d <- local({ + .ps_seed(6101) + x <- stats::runif(3000, 0, 1e5); y <- stats::runif(3000, 0, 1e5) + data.frame(x = x, y = y, a = stats::rnorm(3000), b = stats::rnorm(3000), + c = stats::rnorm(3000)) + }) + A <- .ps_assign(.ps_points(d$x, d$y, d[c("a", "b", "c")]), 667L) + r <- .ps_catch(summarize_by_cell(A$asg, "b", c("c", "a"), id_col = "cell_id", + estimate = "pooled")) + expect_identical(.ps_classes(r), "spatialkit_no_structure") + w <- r$warnings[[1L]] + rec <- attr(r$value, "pooled")$columns + f <- .ps_fields(w) + expect_identical(names(f), c("criterion", "n", "one_cell", "columns", "estimate", "loo", + "structure_p", "beats")) + expect_identical(f$columns, c("b", "c", "a")) # the order of the frame + expect_identical(f$criterion, "loo") + expect_identical(f$estimate, "pooled") + by <- function(field) stats::setNames( + vapply(rec, function(r) as.numeric(r[[field]]), numeric(1)), c("b", "c", "a")) + expect_identical(f$n, stats::setNames(rep(rec$resp_b$cells, 3L), c("b", "c", "a"))) + expect_identical(f$one_cell, by("loo_one_cell")) + expect_identical(f$loo, by("loo")) + expect_identical(f$structure_p, by("structure_p")) + expect_true(all(!vapply(rec, function(r) r$structured, NA))) + # For each of the three one mean does as well as the cells, to the margin. + expect_identical(f$beats, c(b = FALSE, c = FALSE, a = FALSE)) + for (r1 in rec) expect_lte(r1$loo_one_cell, r1$loo * 1.02) + # Several columns: the sentences first, then the numbers of each column. + piece <- function(nm) { + r1 <- rec[[nm]] + sprintf(paste0("'%s': leave-one-out error %s against %s; F test of the cells against one ", + "mean, p = %s; median own weight %.2f."), r1$column, + format(signif(r1$loo, 4)), format(signif(r1$loo_one_cell, 4)), + format(signif(r1$structure_p, 2)), r1$own_weight) + } + expect_identical( + conditionMessage(w), + paste(paste0("summarize_by_cell(): the pooled values of 'b', 'c' and 'a' predict a left-out ", + "observation no better than one mean for all rows, so they show no spatial ", + "structure these cells can use. The values are returned. A map of them looks ", + "smooth because each is mostly its neighbours' mean, not because the response ", + "varies smoothly."), + piece("resp_b"), piece("pred_c"), piece("pred_a"))) + expect_null(conditionCall(w)) + # One column alone: the singular, and no name before its numbers. + one <- .ps_catch(summarize_by_cell(A$asg, "a", id_col = "cell_id", estimate = "pooled")) + expect_identical(.ps_classes(one), "spatialkit_no_structure") + ra <- attr(one$value, "pooled")$columns$resp_a + expect_identical( + conditionMessage(one$warnings[[1L]]), + sprintf(paste0( + "summarize_by_cell(): the pooled values of 'a' predict a left-out observation no ", + "better than one mean for all rows (leave-one-out error %s against %s; F test of the ", + "cells against one mean, p = %s; median own weight %.2f), so it shows no spatial ", + "structure these cells can use. The values are returned. A map of them looks smooth ", + "because each is mostly its neighbours' mean, not because the response varies ", + "smoothly."), + format(signif(ra$loo, 4)), format(signif(ra$loo_one_cell, 4)), + format(signif(ra$structure_p, 2)), ra$own_weight)) + # The values are returned. + expect_false(anyNA(one$value$..pooled_resp_a)) + # Plain means of the same layer say nothing. + expect_length(.ps_catch(summarize_by_cell(A$asg, "a", id_col = "cell_id", + estimate = "mean"))$warnings, 0L) +}) + +test_that("a warning that lists many columns says what it has to say before their numbers", { + # A response and ten predictors, all white noise, with long names: x, then + # y, then the eleven columns; 1,200 rows in 100 cells. + nm <- sprintf("a_long_column_name_%02d", 1:11) + d <- local({ + .ps_seed(6102) + x <- stats::runif(1200, 0, 1e5); y <- stats::runif(1200, 0, 1e5) + cbind(data.frame(x = x, y = y), + as.data.frame(stats::setNames(lapply(nm, function(i) stats::rnorm(1200)), nm))) + }) + cell <- function(x, y) as.integer(10 * floor(x / 1e4) + floor(y / 1e4) + 1) + pts <- .ps_points(d$x, d$y, d[nm]) + pts$cell_id <- cell(d$x, d$y) + # R prints the first getOption("warning.length") characters of a warning. + withr::local_options(warning.length = 1000L) + r <- .ps_catch(summarize_by_cell(pts, nm[1L], nm[-1L], id_col = "cell_id", + estimate = "pooled")) + w <- .ps_of(r, "spatialkit_no_structure") + expect_length(w, 1L) + cols <- w[[1L]]$columns + expect_gte(length(cols), 8L) + # For each of them one mean does as well as the cells, to the margin of the + # rule: for one at least its error is above the cells', by less than that. + expect_true(all(!w[[1L]]$beats)) + rec <- attr(r$value, "pooled")$columns + expect_true(any(vapply(rec, function(c1) + isFALSE(c1$structured) && c1$loo_one_cell > c1$loo && c1$loo_one_cell <= 1.02 * c1$loo, NA))) + msg <- conditionMessage(w[[1L]]) + # The whole text passes what R prints; the closing sentence does not. + expect_gt(nchar(msg), 1000L) + closing <- "not because the response varies smoothly." + ends <- regexpr(closing, msg, fixed = TRUE) + nchar(closing) - 1L + expect_gt(ends, 0L) + expect_lt(ends, 600L) + expect_true(grepl(closing, substr(msg, 1L, getOption("warning.length")), fixed = TRUE)) + expect_true(grepl("The values are returned.", substr(msg, 1L, ends), fixed = TRUE)) + # Six names and six columns' numbers, the numbers behind the sentences; the + # condition holds every column. + expect_match(msg, sprintf("'%s' and %d more predict", cols[6L], length(cols) - 6L), fixed = TRUE) + at <- vapply(cols, function(v) + regexpr(sprintf("'%s': leave-one-out error ", v), msg, fixed = TRUE)[1L], 1L) + expect_true(all(at[1:6] > ends)) + expect_false(is.unsorted(at[1:6])) + expect_true(all(at[-(1:6)] == -1L)) + expect_true(endsWith(msg, sprintf("And %d more, in attr(, \"pooled\").", length(cols) - 6L))) + expect_identical(names(w[[1L]]$loo), cols) + # With six columns every number is given, and nothing is said of more. + six <- .ps_catch(summarize_by_cell(pts, cols[1L], cols[2:6], id_col = "cell_id", + estimate = "pooled")) + m6 <- conditionMessage(.ps_of(six, "spatialkit_no_structure")[[1L]]) + expect_identical(lengths(regmatches(m6, gregexpr("leave-one-out error ", m6, fixed = TRUE))), 6L) + expect_false(grepl("more, in attr", m6, fixed = TRUE)) + expect_true(grepl(closing, substr(m6, 1L, getOption("warning.length")), fixed = TRUE)) + + # The same for rows that share a location: every row of the layer twice. + twice <- .ps_points(rep(d$x, 2L), rep(d$y, 2L), rbind(d[nm], d[nm])) + twice$cell_id <- cell(rep(d$x, 2L), rep(d$y, 2L)) + r <- .ps_catch(summarize_by_cell(twice, nm[1L], nm[-1L], id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)) + w <- .ps_of(r, "spatialkit_repeated_locations") + expect_length(w, 1L) + expect_identical(w[[1L]]$columns, nm) + expect_identical(w[[1L]]$n, stats::setNames(rep(2400L, 11L), nm)) + expect_identical( + conditionMessage(w[[1L]]), + paste0("summarize_by_cell(): rows with a value share a location with another row (", + paste(sprintf("2400 of the 2400 rows of '%s'", nm[1:6]), collapse = "; "), + "; and 5 more). The leave-one-out error leaves one row out and keeps the others at ", + "its location, so it, and an interval built from it, describes a further observation ", + "at a place already observed, not an observation at a new place.")) + expect_lt(nchar(conditionMessage(w[[1L]])), 1000L) +}) + +test_that("ten constant predictors raise one spatialkit_pool_degenerate, six of them named", { + L <- .ps_layer() + asg <- L$asg + consts <- c(0.1, 1234.56, 1 / 3, 52000.37, 0, 0.7, -2.5, 1e-9, 3.5, 99) + names(consts) <- sprintf("k%02d", 1:10) + for (nm in names(consts)) asg[[nm]] <- consts[[nm]] + r <- .ps_catch(summarize_by_cell(asg, "z", names(consts), id_col = "cell_id", + estimate = "pooled")) + expect_identical(.ps_classes(r), "spatialkit_pool_degenerate") + w <- r$warnings[[1L]] + expect_identical( + .ps_fields(w), + list(reason = "no spread inside any cell", columns = names(consts), + constant = stats::setNames(rep(TRUE, 10L), names(consts)))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): the values of 'k01', 'k02', 'k03', 'k04', 'k05', 'k06' and 4 ", + "more do not vary inside any cell, so every own weight is 1 and the pooled value is ", + "the plain mean. attr(, \"pooled\") says which columns are constant.")) + for (nm in names(consts)) { + expect_identical(r$value[[paste0("..pooled_w_pred_", nm)]], rep(1, nrow(r$value)), info = nm) + expect_equal(r$value[[paste0("..pooled_pred_", nm)]], rep(consts[[nm]], nrow(r$value)), + tolerance = 1e-12, info = nm) + rec <- attr(r$value, "pooled")$columns[[paste0("pred_", nm)]] + expect_identical(rec$status, "no spread inside any cell", info = nm) + expect_true(rec$constant, info = nm) + expect_identical(c(rec$sigma2, rec$tau2), c(0, 0), info = nm) + expect_identical(rec$loo, NA_real_, info = nm) + } +}) + +test_that("stations visited several times raise one spatialkit_repeated_locations", { + # 300 stations visited three times: 900 rows on 300 locations, three columns. + d <- local({ + .ps_seed(2003) + x <- stats::runif(300, 0, 1e5); y <- stats::runif(300, 0, 1e5) + x <- rep(x, 3L); y <- rep(y, 3L) + data.frame(x = x, y = y, + a = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(900, 0, 0.5), + b = cos(x / 1.2e4) + stats::rnorm(900, 0, 0.5), + c = (x - y) / 4e4 + stats::rnorm(900, 0, 0.5)) + }) + A <- .ps_assign(.ps_points(d$x, d$y, d[c("a", "b", "c")]), 60L) + # The third column misses two visits of each of two stations, so each has + # one row left that shares its location with no other row of the column. + A$asg$c[c(1L, 301L, 2L, 302L)] <- NA + r <- .ps_catch(summarize_by_cell(A$asg, "a", c("b", "c"), id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)) + expect_identical(.ps_classes(r), "spatialkit_repeated_locations") + w <- r$warnings[[1L]] + rep_c <- attr(r$value, "pooled")$columns$pred_c$repeated + expect_identical( + .ps_fields(w), + list(columns = c("a", "b", "c"), n = c(a = 900L, b = 900L, c = rep_c), + total = c(a = 900L, b = 900L, c = 896L))) + expect_identical(rep_c, 894L) + expect_identical( + conditionMessage(w), + sprintf(paste0( + "summarize_by_cell(): rows with a value share a location with another row (900 of the ", + "900 rows of 'a'; 900 of the 900 rows of 'b'; %d of the 896 rows of 'c'). The ", + "leave-one-out error leaves one row out and keeps the others at its location, so it, ", + "and an interval built from it, describes a further observation at a place already ", + "observed, not an observation at a new place."), rep_c)) + # The record counts them whether or not an interval is asked for; the warning + # is the interval's. + quiet <- .ps_catch(summarize_by_cell(A$asg, "a", c("b", "c"), id_col = "cell_id", + estimate = "pooled")) + expect_length(quiet$warnings, 0L) + expect_identical(attr(quiet$value, "pooled")$columns$resp_a$repeated, 900L) + # Each row counts in its cell, and the pooled values are the engine's. + expect_identical(sum(r$value$n), 900L) +}) + +test_that("two reasons for NA columns raise two spatialkit_pool_unavailable", { + # `a` has one value in each cell; `b` has values only on rows without a point. + d <- local({ + .ps_seed(2004) + x <- stats::runif(120, 0, 1e5); y <- stats::runif(120, 0, 1e5) + data.frame(x = x, y = y, z = sin(x / 2e4) + stats::rnorm(120, 0, 0.3), + cell_id = rep(1:30, 4L)) + }) + asg <- .ps_points(d$x, d$y, d[c("z", "cell_id")]) + asg$a <- ifelse(seq_len(120) <= 30L, asg$z, NA_real_) + asg$b <- NA_real_ + nowhere <- c(40L, 41L, 99L) + asg$b[nowhere] <- c(1, 2, 3) + g <- sf::st_geometry(asg) + for (i in nowhere) g[[i]] <- sf::st_point() + sf::st_geometry(asg) <- g + r <- .ps_catch(summarize_by_cell(asg, "a", "b", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9)) + expect_identical(.ps_classes(r), c("spatialkit_pool_unavailable", "spatialkit_pool_unavailable", + "spatialkit_pool_rows_skipped")) + # In the order of the design's table: no located value, then no cell with two. + w1 <- r$warnings[[1L]]; w2 <- r$warnings[[2L]] + expect_identical(.ps_fields(w1), list(reason = "no located value", columns = "b")) + expect_identical( + conditionMessage(w1), + paste0("summarize_by_cell(): the pooled columns of 'b' are NA: no row has a value of it, ", + "a cell and a location.")) + expect_identical(.ps_fields(w2), + list(reason = "no cell holds two values", columns = "a", n = c(a = 30L), + cells = c(a = 30L))) + expect_identical( + conditionMessage(w2), + paste0("summarize_by_cell(): the pooled columns of 'a' are NA: no cell holds two values of ", + "it, so the spread of values inside a cell cannot be estimated and nothing can set a ", + "weight. The plain columns are unaffected.")) + expect_identical(.ps_fields(r$warnings[[3L]]), list(n = 3L, cells = 3L, columns = "b")) + out <- r$value + for (col in .ps_pooled_names(out)) expect_true(all(is.na(out[[col]])), info = col) + expect_length(.ps_pooled_names(out), 10L) + rec <- attr(out, "pooled")$columns + expect_identical(rec$resp_a$status, "no cell holds two values") + expect_identical(rec$pred_b$status, "no located value") + expect_identical(c(rec$pred_b$n, rec$pred_b$cells, rec$pred_b$skipped), c(0L, 0L, 3L)) + # The plain columns are there. + expect_false(anyNA(out$resp_mean_a)) + expect_identical(sum(!is.na(out$pred_mean_b)), 3L) + # Two columns with one reason are named in one warning, in the plural. + asg$a2 <- asg$a + two <- .ps_catch(summarize_by_cell(asg, "a", "a2", id_col = "cell_id", estimate = "pooled")) + expect_identical(.ps_classes(two), "spatialkit_pool_unavailable") + expect_identical(two$warnings[[1L]]$columns, c("a", "a2")) + expect_identical( + conditionMessage(two$warnings[[1L]]), + paste0("summarize_by_cell(): the pooled columns of 'a' and 'a2' are NA: for none of them ", + "does any cell hold two values, so the spread of values inside a cell cannot be ", + "estimated and nothing can set a weight. The plain columns are unaffected.")) + asg$b2 <- asg$b + two <- .ps_catch(summarize_by_cell(asg, "b", "b2", id_col = "cell_id", estimate = "pooled")) + expect_identical( + conditionMessage(two$warnings[[1L]]), + paste0("summarize_by_cell(): the pooled columns of 'b' and 'b2' are NA: no row has a value ", + "of any of them, a cell and a location.")) +}) + + +test_that("the warnings of one call come in the order of the design's table", { + # 600 rows in 100 cells, and one column for each thing that can happen to a + # column: x, then y, then the response. Two rows share a location and three + # rows have none. + d <- local({ + .ps_seed(2020) + x <- stats::runif(600, 0, 1e5); y <- stats::runif(600, 0, 1e5) + x[2L] <- x[1L]; y[2L] <- y[1L] + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(600, 0, 0.5)) + }) + d$cell_id <- as.integer(10 * floor(d$x / 1e4) + floor(d$y / 1e4) + 1) + cells <- sort(unique(d$cell_id)) + count <- table(d$cell_id) + nowhere <- c(50L, 51L, 52L) + # Values only on the rows without a location. + d$none <- NA_real_ + d$none[nowhere] <- c(1, 2, 3) + # One value in each of 30 cells at most, none of them on a row without a + # location. + d$single <- ifelse(!duplicated(d$cell_id) & d$cell_id %in% cells[1:30], d$z, NA_real_) + d$single[nowhere] <- NA + # Values in one cell only. + d$one <- ifelse(d$cell_id == cells[40L], d$z, NA_real_) + # A constant. + d$k <- 0.1 + # Five rows in each of five cells, the same five values in every one: the + # cell means are equal, so nothing tells the cells apart. + five <- as.integer(names(count)[count >= 5L & names(count) != cells[40L]])[c(1L, 5L, 9L, 13L, 17L)] + d$same <- NA_real_ + for (cl in five) d$same[which(d$cell_id == cl)[1:5]] <- c(-2, -1, 0, 1, 2) + asg <- .ps_points(d$x, d$y, d[setdiff(names(d), c("x", "y"))]) + g <- sf::st_geometry(asg) + for (i in nowhere) g[[i]] <- sf::st_point() + sf::st_geometry(asg) <- g + preds <- c("none", "single", "one", "k", "same") + said <- function(r) vapply(r$warnings, function(w) + paste(c(class(w)[1L], w$reason), collapse = ": "), character(1)) + + r <- .ps_catch(summarize_by_cell(asg, "z", preds, id_col = "cell_id", estimate = "pooled", + obs_level = 0.9)) + status <- vapply(attr(r$value, "pooled")$columns, function(c1) c1$status, "") + expect_identical( + status, + c(resp_z = "ok", pred_none = "no located value", pred_single = "no cell holds two values", + pred_one = "one cell", pred_k = "no spread inside any cell", + pred_same = "no signal between cells")) + expect_identical( + said(r), + c("spatialkit_pool_unavailable: no located value", + "spatialkit_pool_unavailable: no cell holds two values", + "spatialkit_pool_degenerate: one cell", + "spatialkit_pool_degenerate: no spread inside any cell", + "spatialkit_pool_degenerate: no signal between cells", + "spatialkit_pool_few_cells", + "spatialkit_pool_few_df", + "spatialkit_no_structure", + "spatialkit_pool_rows_skipped", + "spatialkit_repeated_locations", + "spatialkit_few_residuals")) + # Each names the columns it is true of, in the order of the frame. The + # rows without a location hold a value of the response, of `none` and of the + # constant. + expect_identical( + lapply(r$warnings, function(w) w$columns), + list("none", "single", "one", "k", "same", "same", "same", "same", c("z", "none", "k"), "z", + c("one", "same"))) + + # Above the limit of an exact search: that reason stands after the two that + # need no search and before the columns whose values were computed. + .ps_without_fnn() + withr::local_options(spatialkit.exact_pairs_max = 10) + r <- .ps_catch(summarize_by_cell(asg, "z", preds, id_col = "cell_id", estimate = "pooled", + obs_level = 0.9)) + expect_identical( + said(r), + c("spatialkit_pool_unavailable: no located value", + "spatialkit_pool_unavailable: no cell holds two values", + "spatialkit_pool_unavailable: work limit", + "spatialkit_pool_degenerate: one cell", + "spatialkit_pool_rows_skipped", + "spatialkit_few_residuals")) + expect_identical(r$warnings[[3L]]$columns, c("z", "k", "same")) +}) + + +# ---- The work limit is a status ------------------------------------------------- + +test_that("above the limit of an exact search the pooled columns are NA and nothing stops", { + d <- local({ + .ps_seed(2005) + x <- stats::runif(400, 0, 1e5); y <- stats::runif(400, 0, 1e5) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(400, 0, 0.5), + p = cos(x / 1.2e4) + stats::rnorm(400, 0, 0.5)) + }) + A <- .ps_assign(.ps_points(d$x, d$y, d[c("z", "p")]), 40L) + expect_identical(length(unique(A$asg$cell_id)), 40L) + # The predictor has no value in one cell, so it has 39 cells where the + # response has 40: the warning speaks of the larger search. + A$asg$p[A$asg$cell_id == A$asg$cell_id[1L]] <- NA + mean_call <- summarize_by_cell(A$asg, "z", "p", id_col = "cell_id", cells_sf = A$cells, + conf_level = 0.9, estimate = "mean") + .ps_without_fnn() + withr::local_options(spatialkit.exact_pairs_max = 100) + seen <- list() + r <- withCallingHandlers( + .ps_catch(summarize_by_cell(A$asg, "z", "p", id_col = "cell_id", cells_sf = A$cells, + conf_level = 0.9, estimate = "pooled", obs_level = 0.9)), + condition = function(c) seen[[length(seen) + 1L]] <<- class(c)) + # The guard's error is caught inside the function: no condition of its class + # reaches the caller, as an error or otherwise. + expect_false(any(vapply(seen, function(k) "spatialkit_work_limit" %in% k, NA))) + expect_identical(.ps_classes(r), "spatialkit_pool_unavailable") + w <- r$warnings[[1L]] + expect_identical( + .ps_fields(w), + list(reason = "work limit", columns = c("z", "p"), work = 1600, limit = 100, + cells = c(z = 40L, p = 39L))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): the pooled columns of 'z' and 'p' are NA: finding each cell's ", + "neighbours among 40 cells without the FNN package would compare 1.6e+03 pairs, ", + "above the limit of 1e+02 (options(spatialkit.exact_pairs_max = )). Install FNN: ", + "the result is the same. The plain columns are unaffected.")) + out <- r$value + new <- .ps_pooled_names(out) + expect_length(new, 10L) + for (col in new) expect_true(all(is.na(out[[col]])), info = col) + rec <- attr(out, "pooled")$columns + expect_identical(rec$resp_z$status, "work limit") + expect_identical(rec$pred_p$status, "work limit") + expect_identical(c(rec$resp_z$n, rec$resp_z$cells, rec$resp_z$df), c(400L, 40L, 360L)) + expect_identical(rec$pred_p$cells, 39L) + # The predictor first: the same pairs and the same count in the text. + flipped <- .ps_catch(summarize_by_cell(A$asg, "p", "z", id_col = "cell_id", + estimate = "pooled")) + expect_identical(.ps_fields(flipped$warnings[[1L]])[c("work", "cells")], + list(work = 1600, cells = c(p = 39L, z = 40L))) + expect_match(conditionMessage(flipped$warnings[[1L]]), + "neighbours among 40 cells without the FNN package would compare 1.6e+03 pairs", + fixed = TRUE) + expect_identical(rec$resp_z$offsets, c(NA_real_, NA_real_)) + # Every column the call shares with the call of plain means is that call's. + expect_identical(setdiff(names(out), new), names(mean_call)) + for (col in names(mean_call)) expect_identical(out[[col]], mean_call[[col]], info = col) + # At the limit the search runs, and the values are those with FNN. + withr::local_options(spatialkit.exact_pairs_max = 1600) + at_limit <- .ps_catch(summarize_by_cell(A$asg, "z", "p", id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)) + expect_length(at_limit$warnings, 0L) + expect_identical(attr(at_limit$value, "pooled")$columns$resp_z$status, "ok") +}) + +test_that("without FNN the pooled columns are the ones with it", { + skip_if_not_installed("FNN") + for (layer in list(.ps_layer()$asg, .ps_lattice())) { + v <- if ("z" %in% names(layer)) "z" else "v" + with <- summarize_by_cell(layer, v, id_col = "cell_id", estimate = "pooled", obs_level = 0.9) + without <- local({ + .ps_without_fnn() + testthat::local_mocked_bindings( + get.knn = function(...) stop("FNN reached"), get.knnx = function(...) stop("FNN reached"), + .package = "FNN") + summarize_by_cell(layer, v, id_col = "cell_id", estimate = "pooled", obs_level = 0.9) + }) + expect_identical(without, with) + } +}) + + +# ---- Shared neighbour searches ----------------------------------------------------- + +test_that("columns with the same scored rows share one neighbour search", { + L <- .ps_layer() + real <- .region_neighbours + force(real) + calls <- 0L + testthat::local_mocked_bindings(.region_neighbours = function(...) { + calls <<- calls + 1L + real(...) + }) + full <- summarize_by_cell(L$asg, "z", c("p1", "p2"), id_col = "cell_id", estimate = "pooled") + expect_identical(calls, 1L) + # A missing value in one predictor: that column has other scored rows, and a + # search of its own. + asg <- L$asg + asg$p1[10L] <- NA + calls <- 0L + part <- summarize_by_cell(asg, "z", c("p1", "p2"), id_col = "cell_id", estimate = "pooled") + expect_identical(calls, 2L) + # Whichever column comes first, and a third mask is a third search. + calls <- 0L + summarize_by_cell(asg, "p1", c("z", "p2"), id_col = "cell_id", estimate = "pooled") + expect_identical(calls, 2L) + asg$p2[20L] <- NA + calls <- 0L + summarize_by_cell(asg, "z", c("p1", "p2"), id_col = "cell_id", estimate = "pooled") + expect_identical(calls, 3L) + # A row without a location is scored for no column: the columns still have + # the same scored rows, and share one search. + nowhere <- L$asg + g <- sf::st_geometry(nowhere) + g[[33L]] <- sf::st_point() + sf::st_geometry(nowhere) <- g + calls <- 0L + suppressWarnings(summarize_by_cell(nowhere, "z", c("p1", "p2"), id_col = "cell_id", + estimate = "pooled")) + expect_identical(calls, 1L) + # Sharing changes no number: each column is what it is when summarised alone. + for (v in c("p1", "p2")) { + own <- summarize_by_cell(L$asg, predictor_vars = v, id_col = "cell_id", estimate = "pooled") + for (col in .ps_pooled_names(own)) expect_identical(full[[col]], own[[col]], info = col) + } + expect_identical(part$..pooled_resp_z, full$..pooled_resp_z) + expect_identical(part$..pooled_pred_p2, full$..pooled_pred_p2) + expect_false(identical(part$..pooled_pred_p1, full$..pooled_pred_p1)) +}) + + +# ---- The intervals table and the print ---------------------------------------------- + +test_that("the intervals table has a row per family in the frame, and is in the record", { + G <- .ps_grid_layer() + call <- function(obs, conf, ...) + summarize_by_cell(G, "income", id_col = "cell_id", estimate = "pooled", + obs_level = obs, conf_level = conf, ...) + cases <- list(neither = call(NULL, NULL), obs = call(0.9, NULL), conf = call(NULL, 0.95), + both = call(0.9, 0.95)) + cols <- c("columns", "covers", "centre", "level", "method") + for (nm in names(cases)) { + tab <- attr(cases[[nm]], "intervals") + expect_identical(tab, attr(cases[[nm]], "pooled")$intervals, info = nm) + expect_s3_class(tab, "data.frame") + expect_identical(names(tab), cols, info = nm) + expect_identical(vapply(tab, typeof, ""), + c(columns = "character", covers = "character", centre = "character", + level = "double", method = "character"), info = nm) + } + expect_identical(vapply(cases, function(x) nrow(attr(x, "intervals")), 1L), + c(neither = 0L, obs = 1L, conf = 1L, both = 2L)) + obs_row <- data.frame( + columns = "..obs_lo_, ..obs_hi_", + covers = paste0("one further observation in the cell, located like the data; on average ", + "over observations, not cell by cell"), + centre = "pooled value", level = 0.9, + method = "quantiles of leave-one-out residuals", stringsAsFactors = FALSE) + ci_row <- data.frame( + columns = "..ci_lo_, ..ci_hi_", + covers = paste0("the cell's own mean, when its observations are spread through the cell; ", + "not a range for one observation"), + centre = "plain mean", level = 0.95, method = "t, deff = 1", stringsAsFactors = FALSE) + expect_identical(attr(cases$obs, "intervals"), obs_row) + expect_identical(attr(cases$conf, "intervals"), ci_row) + expect_identical(attr(cases$both, "intervals"), rbind(obs_row, ci_row)) + # `conf_level` is in the record, as `obs_level` is. + expect_null(attr(cases$obs, "pooled")$conf_level) + expect_identical(attr(cases$conf, "pooled")$conf_level, 0.95) + expect_identical(attr(cases$both, "pooled")[c("obs_level", "conf_level")], + list(obs_level = 0.9, conf_level = 0.95)) + # The columns the table names are in the frame exactly when it names them. + expect_identical(any(grepl("^\\.\\.obs_", names(cases$conf))), FALSE) + expect_identical(any(grepl("^\\.\\.ci_", names(cases$obs))), FALSE) + expect_true(all(c("..obs_lo_resp_income", "..ci_lo_resp_income") %in% names(cases$both))) + # The helper alone. + expect_identical(.intervals_table(0.9, 0.95, "1"), rbind(obs_row, ci_row)) + expect_identical(.intervals_table(NULL, NULL, "1"), rbind(obs_row, ci_row)[0L, ]) +}) + +test_that("what the t interval covers follows the design effect", { + L <- .ps_layer() + own <- paste0("the cell's own mean, when its observations are spread through the cell; ", + "not a range for one observation") + pop <- "the cell mean as an estimate of the population mean; not a range for one observation" + row <- function(...) { + out <- suppressWarnings(summarize_by_cell(L$asg, "z", id_col = "cell_id", conf_level = 0.95, + estimate = "pooled", ...)) + tab <- attr(out, "intervals") + expect_identical(nrow(tab), 1L) + expect_identical(tab$columns, "..ci_lo_, ..ci_hi_") + expect_identical(tab$centre, "plain mean") + unlist(tab[c("covers", "method")]) + } + expect_identical(row(deff = 1), c(covers = own, method = "t, deff = 1")) + expect_identical(row(), c(covers = own, method = "t, deff = 1")) + expect_identical(row(deff = "kish"), c(covers = pop, method = "t, deff = \"kish\"")) + expect_identical(row(deff = 2), c(covers = pop, method = "t, deff = 2")) + expect_identical(row(deff = 1.5), c(covers = pop, method = "t, deff = 1.5")) + # A design effect the function refuses is replaced by 1, and the row says 1. + expect_identical(row(deff = 0.5), c(covers = own, method = "t, deff = 1")) + # A number above 1 by less than seven digits show is applied, and the row + # does not read 1. + near <- suppressWarnings(summarize_by_cell(L$asg, "z", id_col = "cell_id", conf_level = 0.95, + estimate = "pooled", deff = 1.0000001)) + expect_identical(unique(near$deff_method), "fixed") + expect_identical(unlist(attr(near, "intervals")[c("covers", "method")]), + c(covers = pop, method = "t, deff = 1.0000001")) + # Kish's correction with an ICC of 0 corrects nothing: the interval is the + # one of deff = 1, `deff_method` says "none", and the row describes the + # numbers the frame holds. `u` has the same mean in every cell. + flat <- L$asg + flat$u <- flat$p2 - stats::ave(flat$p2, flat$cell_id) + ci <- function(resp, pred = NULL, deff) + suppressWarnings(summarize_by_cell(flat, resp, pred, id_col = "cell_id", conf_level = 0.95, + estimate = "pooled", deff = deff)) + k0 <- ci("u", deff = "kish") + expect_identical(attr(k0, "icc")$resp, 0) + expect_identical(unique(k0$deff_method), "none") + expect_identical(k0$..ci_lo_resp_u, ci("u", deff = 1)$..ci_lo_resp_u) + expect_identical(unlist(attr(k0, "intervals")[c("covers", "method")]), + c(covers = own, method = "t, deff = 1")) + expect_match(utils::capture.output(print(attr(k0, "pooled")))[4L], + "95% for THE CELL'S MEAN (t, deff = 1), centred on the plain mean;", fixed = TRUE) + # Beside columns Kish does correct, the row is Kish's and says which column + # it left as it was. + both <- ci("z", c("u", "p1"), deff = "kish") + expect_identical(unique(both$deff_method), "kish") + expect_gt(attr(both, "icc")$resp, 0.1) + expect_identical(attr(both, "icc")$pred[["u"]], 0) + expect_identical(unlist(attr(both, "intervals")[c("covers", "method")]), + c(covers = pop, method = "t, deff = \"kish\"; 1 for 'u', whose ICC is 0")) + # The same when it is the response Kish leaves as it was, and a predictor + # it corrects. + resp0 <- ci("u", c("z", "p1"), deff = "kish") + expect_identical(attr(resp0, "icc")$resp, 0) + expect_identical(unique(resp0$deff_method), "kish") + expect_identical(attr(resp0, "intervals")$method, + "t, deff = \"kish\"; 1 for 'u', whose ICC is 0") + txt <- utils::capture.output(print(attr(resp0, "pooled"))) + expect_identical( + grep("..ci_lo_", txt, fixed = TRUE, value = TRUE), + paste0(" ..ci_lo_, ..ci_hi_ : 95% for THE POPULATION MEAN (t, deff = \"kish\"; 1 for 'u', ", + "whose ICC is 0), centred on the plain mean;")) + # The label alone, and the table told what was applied. + expect_identical(.deff_label(NULL), "1") + expect_identical(.deff_label(NULL, kish_zero = "u"), "1") + expect_identical(.deff_label(list(method = "fixed", deff = 2.5)), "2.5") + expect_identical(.deff_label(list(method = "variogram")), "\"variogram\"") + expect_identical(.deff_label(list(method = "kish")), "\"kish\"") + expect_identical(.deff_label(list(method = "kish"), c("a", "b")), + "\"kish\"; 1 for 'a' and 'b', whose ICC is 0") + tiny <- .deff_label(list(method = "fixed", deff = 1 + 4 * .Machine$double.eps)) + expect_false(identical(tiny, "1")) + expect_gt(as.numeric(tiny), 1) + expect_identical(.intervals_table(NULL, 0.95, "1")$covers, own) + expect_identical(.intervals_table(NULL, 0.95, tiny)$covers, pop) + expect_identical(.intervals_table(NULL, 0.95, "\"kish\"; 1 for 'u', whose ICC is 0")$covers, pop) + skip_if_not_installed("gstat") + # A supplied variogram, on the layer where one is identified. + L <- .ps_field_layer() + sac <- suppressWarnings(estimate_sac_range(L$asg, "z")) + expect_true(is.finite(as.numeric(sac))) + expect_identical(row(deff = "variogram", sac = sac), + c(covers = pop, method = "t, deff = \"variogram\"")) + # A "variogram" request that falls back to Kish carries Kish's correction, + # and the row names the design effect the standard errors carry. + testthat::local_mocked_bindings(.vgm_correlation_fn = function(...) NULL, + .vgm_is_pure_nugget = function(...) FALSE) + fell <- .ps_catch(summarize_by_cell(L$asg, "z", id_col = "cell_id", conf_level = 0.95, + estimate = "pooled", deff = "variogram", sac = sac)) + expect_true("spatialkit_deff_fallback" %in% .ps_classes(fell)) + expect_identical(unique(fell$value$deff_method), "kish (variogram fallback)") + expect_identical(unlist(attr(fell$value, "intervals")[c("covers", "method")]), + c(covers = pop, method = "t, deff = \"kish\"")) +}) + +test_that("the record prints what was fitted, and each interval under its own words", { + G <- .ps_grid_layer() + shown <- function(obs, conf, ...) + utils::capture.output(print(attr( + summarize_by_cell(G, "income", id_col = "cell_id", estimate = "pooled", + obs_level = obs, conf_level = conf, ...), "pooled"))) + block <- c( + "Cell values: income, 900 rows in 100 cells", + " value : ..pooled_resp_income, pooled toward the 8 nearest cells (centroids of the rows)", + " variances : inside cells 3.80e+07 (from 800 values beyond one per cell);", + " between a cell and its target 3.84e+06", + " own weight : median 0.48 (..pooled_w_resp_income)", + " alone : 0.0% of the rows are the only one in their cell", + " loo : 4.02e+07 (leave-one-out mean squared error of the pooled value);", + " one mean for all rows: 1.01e+08") + interval <- c( + " interval : 90% for ONE OBSERVATION (..obs_lo_resp_income, ..obs_hi_resp_income):", + " value - 10500 to value + 10300, quantiles of 900 leave-one-out residuals") + also <- c( + "Also in the frame", + " ..ci_lo_, ..ci_hi_ : 95% for THE CELL'S MEAN (t, deff = 1), centred on the plain mean;", + " not a range for one observation") + closing <- "Away from the observations no interval here is calibrated." + expect_identical(shown(NULL, NULL), c(block, closing)) + expect_identical(shown(0.9, NULL), c(block, interval, closing)) + expect_identical(shown(NULL, 0.95), c(block, also, closing)) + expect_identical(shown(0.9, 0.95), c(block, interval, also, closing)) + # Under a design effect the other interval is for the population mean. + expect_identical( + shown(NULL, 0.9, deff = "kish")[10:11], + c(" ..ci_lo_, ..ci_hi_ : 90% for THE POPULATION MEAN (t, deff = \"kish\"), centred on the plain mean;", + " not a range for one observation")) + # print() returns its argument, invisibly, and reads nothing but the record. + rec <- attr(summarize_by_cell(G, "income", id_col = "cell_id", estimate = "pooled"), "pooled") + utils::capture.output(seen <- withVisible(print(rec))) + expect_false(seen$visible) + expect_identical(seen$value, rec) + expect_identical(utils::capture.output(print(structure(unclass(rec), class = "spatialkit_pooled"))), + c(block, closing)) +}) + +test_that("the print says when cells do no better, when all the others are the target, and a status", { + # A structureless predictor beside the response: its loo line says so. + G <- .ps_grid_layer() + G$noise <- local({ .ps_seed(2006); stats::rnorm(nrow(G)) }) + r <- .ps_catch(summarize_by_cell(G, "income", "noise", id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)) + expect_identical(.ps_classes(r), "spatialkit_no_structure") + txt <- utils::capture.output(print(attr(r$value, "pooled"))) + expect_length(txt, 21L) + expect_identical(txt[11L], "Cell values: noise, 900 rows in 100 cells") + expect_match(txt[18L], "^ one mean for all rows: [0-9.e+-]+: these cells do no better than one mean$") + expect_false(grepl("do no better", txt[8L], fixed = TRUE)) + expect_match(txt[19L], "(..obs_lo_pred_noise, ..obs_hi_pred_noise):", fixed = TRUE) + expect_identical(txt[21L], "Away from the observations no interval here is calibrated.") + # Five cells: the target is all the others. + five <- G + five$cell_id <- as.integer((five$cell_id - 1L) %/% 20L + 1L) + r <- .ps_catch(summarize_by_cell(five, "income", id_col = "cell_id", estimate = "pooled")) + expect_identical(.ps_classes(r), "spatialkit_pool_few_cells") + txt <- utils::capture.output(print(attr(r$value, "pooled"))) + expect_identical(txt[1:2], + c("Cell values: income, 900 rows in 5 cells", + " value : ..pooled_resp_income, pooled toward all the other cells (4 of them)")) + # Nine cells have eight others, all of them in each target; ten do not. + xy <- sf::st_coordinates(G) + value_line <- function(cell) { + g <- G + g$cell_id <- as.integer(cell) + utils::capture.output(print(attr(suppressWarnings( + summarize_by_cell(g, "income", id_col = "cell_id", estimate = "pooled")), "pooled")))[1:2] + } + third <- 1e5 / 3 + expect_identical(value_line(3 * floor(xy[, 1L] / third) + floor(xy[, 2L] / third) + 1), + c("Cell values: income, 900 rows in 9 cells", + " value : ..pooled_resp_income, pooled toward all the other cells (8 of them)")) + expect_identical(value_line(2 * floor(xy[, 1L] / 2e4) + floor(xy[, 2L] / 5e4) + 1), + c("Cell values: income, 900 rows in 10 cells", + " value : ..pooled_resp_income, pooled toward the 8 nearest cells (centroids of the rows)")) + # Rows that are the only one in their cell are counted in the `alone` line. + lone <- .ps_grid_layer() + lone$cell_id[c(10L, 200L, 400L, 600L, 800L)] <- 501:505 + txt <- utils::capture.output(print(attr(suppressWarnings( + summarize_by_cell(lone, "income", id_col = "cell_id", estimate = "pooled")), "pooled"))) + expect_identical(txt[1L], "Cell values: income, 900 rows in 105 cells") + expect_identical(txt[6L], " alone : 0.6% of the rows are the only one in their cell") + # A field in 120 cells of which 117 hold one row. The cells predict a + # left-out row several times better than one mean, and the F test, with + # three values beyond one per cell behind it, does not tell them from one + # mean: the loo line says that, and does not say the cells do no better. + d <- local({ + .ps_seed(3262) + x <- stats::runif(123, 0, 1e5); y <- stats::runif(123, 0, 1e5) + data.frame(x = x, y = y, v = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(123, 0, 0.3)) + }) + few <- .ps_points(d$x, d$y, data.frame(v = d$v, cell_id = c(1:120, 1:3))) + r <- .ps_catch(summarize_by_cell(few, "v", id_col = "cell_id", estimate = "pooled")) + expect_identical(.ps_classes(r), c("spatialkit_pool_few_df", "spatialkit_no_structure")) + rec <- attr(r$value, "pooled")$columns$resp_v + expect_identical(rec$status, "ok") + expect_false(rec$structured) + expect_gt(rec$loo_one_cell, 3 * rec$loo) + txt <- utils::capture.output(print(attr(r$value, "pooled"))) + expect_identical( + txt[8L], + sprintf(paste0(" one mean for all rows: %.2e: the F test does not tell these ", + "cells from one mean (p = %s)"), + rec$loo_one_cell, format(signif(rec$structure_p, 2)))) + expect_identical(txt[6L], " alone : 95.1% of the rows are the only one in their cell") + expect_match(conditionMessage(r$warnings[[2L]]), + "predict a left-out observation better than one mean for all rows, but the F test", + fixed = TRUE) + # A status other than "ok": the first line and the status, and the interval + # the block has not shown is listed below it. + G$k <- 0.1 + r <- .ps_catch(summarize_by_cell(G, "k", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9, conf_level = 0.95)) + expect_identical( + utils::capture.output(print(attr(r$value, "pooled"))), + c("Cell values: k, 900 rows in 100 cells", + " status : no spread inside any cell", + "Also in the frame", + " ..obs_lo_, ..obs_hi_ : 90% for ONE OBSERVATION (quantiles of leave-one-out residuals), centred on the pooled value;", + " on average over observations, not cell by cell", + " ..ci_lo_, ..ci_hi_ : 95% for THE CELL'S MEAN (t, deff = 1), centred on the plain mean;", + " not a range for one observation", + "Away from the observations no interval here is calibrated.")) + # One row in one cell. + r <- .ps_catch(summarize_by_cell(G[1L, ], "income", id_col = "cell_id", estimate = "pooled")) + expect_identical(utils::capture.output(print(attr(r$value, "pooled"))), + c("Cell values: income, 1 row in 1 cell", " status : one cell", + "Away from the observations no interval here is calibrated.")) +}) + + +# ---- A response without structure ---------------------------------------------------- + +test_that("white noise is reported as structureless, and a field with noise is not", { + skip_on_cran() + # 40 layers of each kind: 3,000 locations uniform on a 1e5 square, x then y, + # then the response; the points in EPSG:32617; the cells as a user builds + # them at 667 seeds of the density kind from 3 starts. + one <- function(seed, field) { + pts <- local({ + .ps_seed(seed) + x <- stats::runif(3000, 0, 1e5); y <- stats::runif(3000, 0, 1e5) + z <- if (field) sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(3000, 0, 1.5) + else stats::rnorm(3000) + .ps_points(x, y, data.frame(z = z)) + }) + seeds <- suppressWarnings( + voronoi_seeds_kmeans(pts, 667, set_seed = 123, nstart = 3, partition = "density")) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id") + r <- .ps_catch(summarize_by_cell(asg, "z", id_col = "cell_id", estimate = "pooled")) + list(r = r, seeds = seeds, pts = pts, rows = nrow(asg), + tau2 = attr(r$value, "pooled")$columns$resp_z$tau2) + } + raised <- function(x) length(.ps_of(x$r, "spatialkit_no_structure")) == 1L + noise <- lapply(1:40, function(r) one(6000 + r, FALSE)) + field <- lapply(1:40, function(r) one(7000 + r, TRUE)) + expect_true(all(vapply(c(noise, field), function(x) x$rows, 1L) == 3000L)) + # One run of these seeds: raised on 40 of the noise layers, with tau2 exactly + # 0 on 2 of them; raised on none of the field layers, with tau2 0 on none. + expect_gte(sum(vapply(noise, raised, NA)), 38L) + expect_lte(sum(vapply(noise, function(x) x$tau2 == 0, NA)), 8L) + expect_lte(sum(vapply(field, raised, NA)), 1L) + expect_lte(sum(vapply(field, function(x) x$tau2 == 0, NA)), 1L) + # Never more than one for a column, and nothing else but the warning for + # every own weight being 0, which white noise brings by chance. + expect_true(all(unlist(lapply(c(noise, field), function(x) .ps_classes(x$r))) %in% + c("spatialkit_no_structure", "spatialkit_pool_degenerate"))) + expect_true(all(vapply(noise, function(x) sum(.ps_classes(x$r) == "spatialkit_no_structure"), + 1L) <= 1L)) + # The condition's fields, on the first noise layer. + w <- .ps_of(noise[[1L]]$r, "spatialkit_no_structure")[[1L]] + rec <- attr(noise[[1L]]$r$value, "pooled")$columns$resp_z + expect_identical( + .ps_fields(w), + list(criterion = "loo", n = c(z = rec$cells), one_cell = c(z = rec$loo_one_cell), + columns = "z", estimate = "pooled", loo = c(z = rec$loo), + structure_p = c(z = rec$structure_p), beats = c(z = FALSE))) + expect_false(rec$structured) + # One mean does as well: its error is within 2 percent of the cells', or lower. + expect_lte(rec$loo_one_cell, rec$loo * 1.02) + # The seeds are the centres of one fit under set.seed(123), which is what a + # profile keeps at 667 cells of this kind, so later stages meet these cells. + for (x in list(noise[[1L]], field[[1L]])) { + xy <- unname(sf::st_coordinates(x$pts)[, 1:2]) + kb <- local({ + .ps_seed(123) + .partition_centres(xy, 667L, partition = "density", init = "kmeans++", nstart = 3L, + iter.max = 100L) + }) + expect_identical(unname(sf::st_coordinates(x$seeds)[, 1:2]), unname(kb$centers)) + } +}) + + +# ---- Any IDs, any polygons, any row order --------------------------------------------- + +test_that("the numbering and the type of the IDs change no value", { + L <- .ps_layer() + asg <- L$asg + u <- sort(unique(asg$cell_id)); K <- length(u) + numbered <- asg + numbered$cell_id <- match(asg$cell_id, u) # 1..K + base <- summarize_by_cell(numbered, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + new <- .ps_pooled_names(base) + same_values <- function(out, key, tag) { + at <- match(key, out$cell_id) + expect_false(anyNA(at), info = tag) + for (col in new) expect_equal(out[[col]][at], base[[col]], tolerance = 1e-12, + info = paste(tag, col)) + a <- attr(out, "pooled")$columns$resp_z; b <- attr(base, "pooled")$columns$resp_z + expect_equal(a, b, tolerance = 1e-12, info = tag) + } + # Character IDs in an order that is not the numbers'. + lab <- local({ .ps_seed(61); sample(c(sprintf("z%03d", 1:75), sprintf("A-%d", 1:75))) }) + expect_lte(K, length(lab)) + lab <- lab[seq_len(K)] + chr <- numbered + chr$cell_id <- lab[numbered$cell_id] + out <- summarize_by_cell(chr, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + expect_false(identical(order(lab, method = "radix"), seq_len(K))) + expect_identical(out$cell_id, sort(lab, method = "radix")) + same_values(out, lab, "character") + # Factor, double and negative IDs. + fac <- numbered + fac$cell_id <- factor(lab[numbered$cell_id], levels = rev(lab)) + same_values(summarize_by_cell(fac, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9), factor(lab, levels = rev(lab)), "factor") + dbl <- numbered + dbl$cell_id <- (K:1)[numbered$cell_id] * 1.5 - 100 + same_values(summarize_by_cell(dbl, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9), (K:1) * 1.5 - 100, "double") +}) + +test_that("polygons the user brings, overlapping ones and a grid, are read by their IDs alone", { + L <- .ps_layer() + pts <- L$asg[c("z", "p1")] + bnd <- sf::st_as_sfc(sf::st_bbox(pts)) + grid <- create_grid_polygons(bnd, target_cells = 100, type = "square", quiet = TRUE) + id <- intersect(c("poly_id", "polygon_id", "id", "cell_id", "grid_id"), names(grid))[1L] + # Overlapping squares: each cell of the grid grown by a third of its width. + wide <- grid + sf::st_geometry(wide) <- sf::st_buffer(sf::st_geometry(grid), + dist = sqrt(as.numeric(sf::st_area(grid))[1L]) / 3, + endCapStyle = "SQUARE", joinStyle = "MITRE") + wide$GEOID <- sprintf("U%03d", rev(seq_len(nrow(wide)))) + expect_gt(sum(lengths(sf::st_overlaps(wide)) > 0L), 50L) + for (case in list(list("grid", grid, id), list("overlapping", wide, "GEOID"))) { + cells <- case[[2L]]; col <- case[[3L]] + asg <- suppressWarnings(assign_features_to_polygons(pts, cells, polygon_id_col = col)) + expect_identical(nrow(asg), nrow(pts), info = case[[1L]]) + r <- .ps_catch(summarize_by_cell(asg, "z", "p1", id_col = col, cells_sf = cells, + estimate = "pooled", obs_level = 0.9)) + expect_length(r$warnings, 0L) + out <- r$value + u <- unique(asg[[col]]) + u <- u[order(u, method = "radix")] + numbered <- asg + numbered$region <- match(asg[[col]], u) + base <- summarize_by_cell(numbered, "z", "p1", id_col = "region", estimate = "pooled", + obs_level = 0.9) + at <- match(u, out[[col]]) + for (nm in .ps_pooled_names(base)) + expect_equal(out[[nm]][at], base[[nm]], tolerance = 1e-12, info = paste(case[[1L]], nm)) + expect_equal(attr(out, "pooled")$columns, attr(base, "pooled")$columns, tolerance = 1e-12) + # A polygon no row was given is NA and is no cell's neighbour. + expect_true(all(is.na(out$..pooled_resp_z[!(out[[col]] %in% u)])), info = case[[1L]]) + # No record of a count on cells a user brings. + expect_null(attr(out, "count_rule")) + } +}) + +test_that("the order of the rows changes no value, on scattered and on gridded locations", { + R <- .ps_reference() + layers <- list(`the (3000, 4.5) layout` = list(R$asg, "v"), `the lattice` = list(.ps_lattice(), "v")) + for (nm in names(layers)) { + layer <- layers[[nm]][[1L]]; v <- layers[[nm]][[2L]] + base <- summarize_by_cell(layer, v, id_col = "cell_id", estimate = "pooled", obs_level = 0.9) + for (s in 1:3) { + p <- local({ .ps_seed(70 + s); sample.int(nrow(layer)) }) + out <- summarize_by_cell(layer[p, ], v, id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + expect_identical(out$cell_id, base$cell_id, info = nm) + for (col in .ps_pooled_names(base)) + expect_equal(out[[col]], base[[col]], tolerance = 1e-12, info = paste(nm, col, s)) + expect_equal(attr(out, "pooled")$columns, attr(base, "pooled")$columns, + tolerance = 1e-12, info = nm) + } + } + # On the lattice the centroids of cells tie in distance, which is where a + # result that followed the rows would move by far more than rounding. + lat <- .ps_lattice() + xy <- unname(sf::st_coordinates(lat)[, 1:2]) + cen <- rowsum(xy, lat$cell_id) / tabulate(lat$cell_id) + d <- as.matrix(stats::dist(cen)); diag(d) <- Inf + near <- t(apply(d, 1L, sort))[, 1:9] + expect_gt(sum(abs(near[, 9L] - near[, 8L]) < 1e-9), 20L) +}) + +test_that("lon/lat rows give the values of the same rows projected by ensure_projected()", { + L <- .ps_layer() + ll <- sf::st_transform(L$asg, 4326) + proj <- ensure_projected(ll) + expect_false(isTRUE(sf::st_is_longlat(proj))) + a <- summarize_by_cell(ll, "z", "p1", id_col = "cell_id", estimate = "pooled", obs_level = 0.9) + b <- summarize_by_cell(proj, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + for (col in .ps_pooled_names(a)) + expect_equal(a[[col]], b[[col]], tolerance = 1e-8, info = col) + # The distances were measured in the projected CRS, never in degrees. + expect_identical(attr(a, "pooled")$crs, sf::st_crs(proj)) + expect_false(isTRUE(sf::st_is_longlat(attr(a, "pooled")$crs))) + # Degrees read as distances would give other neighbours: the layer is wider + # in degrees of longitude than in metres, relative to its height. + deg <- sf::st_set_crs(sf::st_set_crs(ll, NA), 32617) + c0 <- summarize_by_cell(deg, "z", id_col = "cell_id", estimate = "pooled") + expect_false(isTRUE(all.equal(c0$..pooled_target_resp_z, a$..pooled_target_resp_z, + tolerance = 1e-8))) + # With the cells joined the frame keeps the cells' CRS. + joined <- summarize_by_cell(ll, "z", id_col = "cell_id", cells_sf = L$cells, + estimate = "pooled") + expect_identical(sf::st_crs(joined), sf::st_crs(L$cells)) +}) + +test_that("on lon/lat rows the projection is chosen from every row of the layer", { + # Rows that hold no value of a column are as if absent for it, with one + # stated exception: lon/lat coordinates are projected in the CRS + # ensure_projected() picks for the whole layer, as the profile projects + # them, and the rows without a value are rows of the layer. + L <- .ps_layer() + ll <- sf::st_transform(L$asg, 4326) + bb <- sf::st_bbox(ll) + more <- function(lon, lat) { + e <- sf::st_as_sf(data.frame(lon = lon, lat = lat, z = NA_real_, p1 = NA_real_, + p2 = NA_real_, cell_id = 9000L + seq_along(lon)), + coords = c("lon", "lat"), crs = 4326) + rbind(ll, e[names(ll)]) + } + call <- function(x) summarize_by_cell(x, "z", "p1", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9) + alone <- call(ll) + new <- .ps_pooled_names(alone) + # Ten valueless rows inside the extent: the same CRS, and the same values. + near <- call(more(seq(bb[["xmin"]], bb[["xmax"]], length.out = 12L)[2:11], + seq(bb[["ymin"]], bb[["ymax"]], length.out = 12L)[2:11])) + expect_identical(attr(near, "pooled")$crs, attr(alone, "pooled")$crs) + at <- match(alone$cell_id, near$cell_id) + for (col in new) expect_identical(near[[col]][at], alone[[col]], info = col) + expect_identical(attr(near, "pooled")$columns, attr(alone, "pooled")$columns) + # Forty valueless rows across a continent: another CRS is picked for the + # layer, the distances between centroids are measured in it, and the values + # are those of the valued rows projected to that CRS beforehand. + far <- call(more(seq(-124, -70, length.out = 40L), rep(c(26, 48), 20L))) + crs_far <- attr(far, "pooled")$crs + expect_false(isTRUE(sf::st_is_longlat(crs_far))) + expect_false(identical(crs_far, attr(alone, "pooled")$crs)) + at <- match(alone$cell_id, far$cell_id) + expect_false(isTRUE(all.equal(far$..pooled_target_resp_z[at], alone$..pooled_target_resp_z, + tolerance = 1e-6))) + first <- call(sf::st_transform(ll, crs_far)) + for (col in new) expect_equal(far[[col]][at], first[[col]], tolerance = 1e-10, info = col) + expect_equal(attr(far, "pooled")$columns, attr(first, "pooled")$columns, tolerance = 1e-10) + # The cells of the valueless rows have no pooled value. + expect_true(all(is.na(far$..pooled_resp_z[far$cell_id > 9000L]))) + # A layer projected beforehand is used in its own CRS, whatever rows it holds. + proj <- sf::st_transform(more(seq(-124, -70, length.out = 40L), rep(c(26, 48), 20L)), 5070) + a <- call(proj) + b <- call(proj[!is.na(proj$z), ]) + expect_identical(attr(a, "pooled")$crs, sf::st_crs(5070)) + at <- match(b$cell_id, a$cell_id) + for (col in new) expect_identical(a[[col]][at], b[[col]], info = col) +}) + + +# ---- agg_funs -------------------------------------------------------------------------- + +test_that("the pooled value pools the mean whatever agg_funs computes", { + L <- .ps_layer() + base <- summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled") + med <- summarize_by_cell(L$asg, "z", id_col = "cell_id", agg_funs = median, + estimate = "pooled") + expect_true("resp_median_z" %in% names(med)) + expect_false("resp_mean_z" %in% names(med)) + for (col in .ps_pooled_names(base)) expect_identical(med[[col]], base[[col]], info = col) + expect_identical(attr(med, "pooled"), attr(base, "pooled")) + # An entry named `pooled` keeps its own column beside the pooled value's. + both <- summarize_by_cell(L$asg, "z", id_col = "cell_id", + agg_funs = list(pooled = function(x) max(x, na.rm = TRUE), + mean = function(x) mean(x, na.rm = TRUE)), + estimate = "pooled") + expect_true(all(c("resp_pooled_z", "..pooled_resp_z") %in% names(both))) + expect_identical(both$..pooled_resp_z, base$..pooled_resp_z) + expect_identical(both$resp_pooled_z, + as.numeric(tapply(L$asg$z, L$asg$cell_id, max))[match(both$cell_id, sort(unique(L$asg$cell_id)))]) + expect_false(isTRUE(all.equal(both$resp_pooled_z, both$..pooled_resp_z))) +}) + + +# ---- obs_level --------------------------------------------------------------------------- + +test_that("the interval's offsets are the stated quantiles of the leave-one-out residuals", { + R <- .ps_reference() + asg <- R$asg + xy <- unname(sf::st_coordinates(asg)[, 1:2]) + u <- sort(unique(asg$cell_id)) + e <- .pool_fit(asg$v, match(asg$cell_id, u), length(u), xy, want = "pooled")$resid_pooled + for (level in c(0.5, 0.9, 0.99)) { + r <- .ps_catch(summarize_by_cell(asg, "v", id_col = "cell_id", estimate = "pooled", + obs_level = level)) + expect_length(r$warnings, 0L) + out <- r$value + p <- c((1 - level) / 2, (1 + level) / 2) + off <- attr(out, "pooled")$columns$resp_v$offsets + expect_equal(off, stats::quantile(e, p, names = FALSE, type = 7), tolerance = 1e-12, + info = format(level)) + expect_identical(off, stats::quantile(e, round(p, 12), names = FALSE, type = 7)) + expect_identical(out$..obs_lo_resp_v, out$..pooled_resp_v + off[1L]) + expect_identical(out$..obs_hi_resp_v, out$..pooled_resp_v + off[2L]) + # The residuals straddle zero, so the value lies inside its interval, and + # the two offsets are the same in every cell. + expect_lt(off[1L], 0); expect_gt(off[2L], 0) + expect_true(all(out$..obs_lo_resp_v <= out$..pooled_resp_v & + out$..pooled_resp_v <= out$..obs_hi_resp_v)) + expect_identical(attr(out, "pooled")$obs_level, level) + expect_identical(attr(out, "intervals")$level, level) + # The share of residuals inside the offsets is the level. + expect_equal(mean(e >= off[1L] & e <= off[2L]), level, tolerance = 2 / length(e)) + } + # A wider level is a wider interval. + width <- vapply(c(0.5, 0.9, 0.99), function(level) + diff(attr(summarize_by_cell(asg, "v", id_col = "cell_id", estimate = "pooled", + obs_level = level), "pooled")$columns$resp_v$offsets), 1) + expect_false(is.unsorted(width, strictly = TRUE)) +}) + +test_that("obs_level is refused with plain means and when it is not a level", { + L <- .ps_layer() + expect_error( + summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "mean", obs_level = 0.9), + paste0("summarize_by_cell(): `obs_level` needs estimate = \"pooled\": the interval for an ", + "observation is built from the leave-one-out residuals of the pooled value and is ", + "centred on it. `conf_level` gives the plain mean's t interval, which is not a range ", + "for an observation."), fixed = TRUE) + # A confidence level beside it changes nothing. + expect_error(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "mean", + obs_level = 0.9, conf_level = 0.9), + "`obs_level` needs estimate = \"pooled\"", fixed = TRUE) + text <- paste0("summarize_by_cell(): `obs_level` must be a single number strictly between 0 ", + "and 1 (0.90 for a 90% interval), or NULL for no interval.") + # 1 - 1e-13 and 1e-13: the interval reads a level through its tail + # probability rounded to 12 decimals, to which these are 1 and 0. + for (bad in list(0, 1, -0.1, 1.5, 90, c(0.8, 0.9), NA_real_, "0.9", TRUE, Inf, numeric(0), + 1 - 1e-13, 1e-13)) + for (est in c("pooled", "mean")) { + e <- tryCatch(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = est, + obs_level = bad), error = function(e) e) + expect_s3_class(e, "error") + expect_identical(conditionMessage(e), text, info = paste(format(bad), collapse = ",")) + expect_null(conditionCall(e)) + } + # Both checks run before any summary: a layer that cannot be summarised + # (no ID column) still stops on the level. + expect_error(summarize_by_cell(L$asg["z"], "z", estimate = "mean", obs_level = 0.9), + "`obs_level` needs estimate", fixed = TRUE) + expect_error(summarize_by_cell(L$asg["z"], "z", estimate = "pooled", obs_level = 2), + "`obs_level` must be a single number", fixed = TRUE) +}) + +test_that("an interval on few residuals is returned with spatialkit_few_residuals", { + L <- .ps_layer() + # 96 rows of the layer in 12 cells: fewer than the 100 residuals at which + # five are expected beyond each end of a 90 percent interval. + d <- local({ + .ps_seed(2007) + x <- stats::runif(96, 0, 1e5); y <- stats::runif(96, 0, 1e5) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(96, 0, 0.3), + q = cos(x / 1.5e4) + stats::rnorm(96, 0, 0.3)) + }) + small <- .ps_points(d$x, d$y, d[c("z", "q")]) + small$cell_id <- as.integer(4 * floor(d$x / 2.5e4) + floor(d$y / 3.4e4) + 1) + expect_identical(length(unique(small$cell_id)), 12L) + r <- .ps_catch(summarize_by_cell(small, "z", "q", id_col = "cell_id", estimate = "pooled", + obs_level = 0.9)) + expect_identical(.ps_classes(r), "spatialkit_few_residuals") + w <- r$warnings[[1L]] + expect_identical(.ps_fields(w), + list(columns = c("z", "q"), needed = 100L, level = 0.9, + n = c(z = 96L, q = 96L))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): the 90% interval of 'z' and 'q' rests on fewer than 100 ", + "leave-one-out residuals (96, 96), the number at which five are expected beyond ", + "each end; its ends are unstable.")) + expect_false(anyNA(r$value$..obs_lo_resp_z)) + # Without the level nothing is said; at 0.5 twenty residuals are enough. + expect_length(.ps_catch(summarize_by_cell(small, "z", "q", id_col = "cell_id", + estimate = "pooled"))$warnings, 0L) + expect_length(.ps_catch(summarize_by_cell(small, "z", "q", id_col = "cell_id", + estimate = "pooled", obs_level = 0.5))$warnings, 0L) + # At 0.99 a thousand are needed, and the 900 rows of the layer are too few; + # at 0.9 they are enough. + r <- .ps_catch(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled", + obs_level = 0.99)) + expect_identical(.ps_classes(r), "spatialkit_few_residuals") + expect_identical(.ps_fields(r$warnings[[1L]]), + list(columns = "z", needed = 1000L, level = 0.99, n = c(z = 900L))) + expect_match(conditionMessage(r$warnings[[1L]]), "the 99% interval of 'z' rests on fewer than 1000", + fixed = TRUE) + # Exactly at the number nothing is said: 100 rows at 0.9. + d100 <- rbind(sf::st_drop_geometry(small)[c("z", "cell_id")], + data.frame(z = c(0.1, 0.2, 0.3, 0.4), cell_id = 1:4)) + hundred <- .ps_points(c(d$x, 100, 200, 300, 400), c(d$y, 100, 200, 300, 400), d100) + expect_identical(nrow(hundred), 100L) + expect_false("spatialkit_few_residuals" %in% + .ps_classes(.ps_catch(summarize_by_cell(hundred, "z", id_col = "cell_id", + estimate = "pooled", obs_level = 0.9)))) +}) + + +test_that("a level close to 1 is written with its digits, and the count it needs as a number", { + L <- .ps_layer() + seen <- list() + r <- withCallingHandlers( + .ps_catch(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled", + obs_level = 0.999999999)), + warning = function(w) seen[[length(seen) + 1L]] <<- w) + # One warning, of the class: none of R's own about a number that does not + # fit a whole number. + expect_identical(.ps_classes(r), "spatialkit_few_residuals") + w <- r$warnings[[1L]] + expect_identical(.ps_fields(w), + list(columns = "z", needed = 1e10, level = 0.999999999, n = c(z = 900L))) + expect_identical( + conditionMessage(w), + paste0("summarize_by_cell(): the 99.9999999% interval of 'z' rests on fewer than ", + "10000000000 leave-one-out residuals (900), the number at which five are expected ", + "beyond each end; its ends are unstable.")) + expect_false(grepl("NA", conditionMessage(w), fixed = TRUE)) + txt <- utils::capture.output(print(attr(r$value, "pooled"))) + expect_identical( + txt[9L], + " interval : 99.9999999% for ONE OBSERVATION (..obs_lo_resp_z, ..obs_hi_resp_z):") + # The offsets are the quantiles at the level, not the range of the residuals. + xy <- unname(sf::st_coordinates(L$asg)[, 1:2]) + u <- sort(unique(L$asg$cell_id)) + e <- .pool_fit(L$asg$z, match(L$asg$cell_id, u), length(u), xy, want = "pooled")$resid_pooled + off <- attr(r$value, "pooled")$columns$resp_z$offsets + expect_identical(off, stats::quantile(e, c(5e-10, 1 - 5e-10), names = FALSE, type = 7)) + expect_gt(off[1L], min(e)); expect_lt(off[2L], max(e)) + # Where the count fits a whole number it is one. + r <- .ps_catch(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled", + obs_level = 0.999999)) + expect_identical(r$warnings[[1L]]$needed, 10000000L) + expect_match(conditionMessage(r$warnings[[1L]]), + "the 99.9999% interval of 'z' rests on fewer than 10000000 leave-one-out", + fixed = TRUE) + # A level that is 1 or 0 to the twelve decimals the interval reads is + # refused, as 1 and 0 are, before any summary. + for (bad in c(1 - 1e-13, 1e-13)) + expect_error(summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled", + obs_level = bad), + "`obs_level` must be a single number strictly between 0 and 1", fixed = TRUE) + # The nearest levels the interval can tell from them are taken. + for (ok in c(1 - 1e-11, 1e-11)) + expect_false(anyNA(suppressWarnings( + summarize_by_cell(L$asg, "z", id_col = "cell_id", estimate = "pooled", + obs_level = ok))$..obs_lo_resp_z)) +}) + + +# ---- Cost ------------------------------------------------------------------------------ + +test_that("the pooled path adds little to a summary of 100,000 rows", { + skip_on_cran() + skip_if_not_installed("FNN") + # 100,000 rows in a 149 x 148 grid of cells, about 22,000, one column. + big <- local({ + .ps_seed(2008) + x <- stats::runif(1e5, 0, 1e6); y <- stats::runif(1e5, 0, 1e6) + pts <- .ps_points(x, y, data.frame(z = sin(x / 2e5) + cos(y / 1.5e5) + stats::rnorm(1e5))) + pts$cell_id <- as.integer(148 * floor(x / (1e6 / 149)) + floor(y / (1e6 / 148)) + 1) + pts + }) + cells <- length(unique(big$cell_id)) + expect_gt(cells, 21500L); expect_lt(cells, 22100L) + secs <- function(est) min(vapply(1:2, function(i) system.time( + suppressWarnings(summarize_by_cell(big, "z", id_col = "cell_id", estimate = est)))[["elapsed"]], + numeric(1))) + plain <- secs("mean") + pooled <- secs("pooled") + expect_lt(pooled - plain, 2) +}) diff --git a/tests/testthat/test-core-seeding-starts.R b/tests/testthat/test-core-seeding-starts.R new file mode 100644 index 00000000..7da84ea6 --- /dev/null +++ b/tests/testthat/test-core-seeding-starts.R @@ -0,0 +1,539 @@ +# tests/testthat/test-core-seeding-starts.R +# --------------------------------------------------------------------------- +# The seeding functions' partition arguments: `kmeans_nstart = NULL` and +# `nstart = NULL` (the kind's own number of starts), which partition +# arguments a call is taken to name beside scored centres and beside +# method = "random" or "provided", and the same on copies of the two +# functions whose own kind is the density kind, the edit a later step makes +# to their formals. +# +# Every call names `partition` and the number of starts where its result +# depends on them. A test of what a call that names no kind is told is made +# on copies of the functions whose own kind is written into their formals, +# the k-means kind or the density kind, so that no test here reads a default. +# --------------------------------------------------------------------------- + +.ss_pts <- function() + partition_points_sf(partition_clustered_xy(n_bg = 100L, n_cl = 300L, seed = 29L)) +.ss_bnd <- function(pts) sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + +# The four profiles of scored centres, and a fifth of the k-means kind from +# random starts: two levels, two starts, no response. +.ss_store <- new.env(parent = emptyenv()) +.ss_profiles <- function() { + if (is.null(.ss_store$p)) { + pts <- .ss_pts() + prof <- function(...) + resolution_profile(pts, levels = c(6L, 14L), nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, ...) + .ss_store$p <- list( + kmeans = prof(partition = "kmeans"), + density = prof(partition = "density"), + power = prof(partition = "density", density_power = 0.5), + k_nn = prof(partition = "density", density_k = 12), + random = prof(partition = "kmeans", init = "random")) + } + .ss_store$p +} +# A selection at 14 cells that carries the level's centres and nothing a +# warning about the count could be raised for. +.ss_sel <- function(p, L = 14L) structure( + list(best = L, seeds = spatialkit:::.profile_seeds(p, L), criterion = "cp", + edge = NA_character_, structured = TRUE), class = "resolution_selection") + +# A copy of a seeding function whose own kind is the one named: the k-means +# kind, or the density kind. +.ss_own <- function(f, kind) { + formals(f)$partition <- if (identical(kind, "density")) quote(c("density", "kmeans")) + else quote(c("kmeans", "density")) + f +} +.ss_text <- function(r) vapply(r$warnings, conditionMessage, character(1)) + + +# ---- NULL starts --------------------------------------------------------------- + +test_that("kmeans_nstart = NULL is 10 starts for k-means and 3 for the density kind", { + pts <- .ss_pts() + seeds <- function(...) partition_quietly( + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, set_seed = 1, ...)) + # The layer and the seed are ones on which 3 starts and 10 starts keep + # different centres, for either kind and either starting rule: a NULL read + # as the other kind's number would show. + for (case in list(list(partition = "kmeans"), + list(partition = "kmeans", init = "kmeans++"), + list(partition = "density"))) { + own <- if (identical(case$partition, "density")) 3 else 10 + other <- if (identical(case$partition, "density")) 10 else 3 + with_null <- do.call(seeds, c(case, list(kmeans_nstart = NULL))) + with_own <- do.call(seeds, c(case, list(kmeans_nstart = own))) + with_other <- do.call(seeds, c(case, list(kmeans_nstart = other))) + info <- paste(unlist(case), collapse = ", ") + expect_identical(with_null, with_own, info = info) + expect_identical(attr(with_null, "kmeans")$nstart, as.integer(own), info = info) + expect_false(isTRUE(all.equal(partition_xy(with_null), partition_xy(with_other))), + info = info) + } +}) + +test_that("nstart = NULL in voronoi_seeds_kmeans() is 10 starts for k-means and 3 for the density kind", { + pts <- .ss_pts() + seeds <- function(...) partition_quietly(voronoi_seeds_kmeans(pts, 25, set_seed = 1, ...)) + for (case in list(list(partition = "kmeans"), + list(partition = "kmeans", init = "kmeans++"), + list(partition = "density"))) { + own <- if (identical(case$partition, "density")) 3 else 10 + other <- if (identical(case$partition, "density")) 10 else 3 + with_null <- do.call(seeds, c(case, list(nstart = NULL))) + with_own <- do.call(seeds, c(case, list(nstart = own))) + with_other <- do.call(seeds, c(case, list(nstart = other))) + info <- paste(unlist(case), collapse = ", ") + # The function keeps no record of the number, so the identity is the test. + expect_identical(with_null, with_own, info = info) + expect_null(attr(with_null, "kmeans"), info = info) + expect_false("nstart" %in% names(attr(with_null, "partition")), info = info) + expect_false(isTRUE(all.equal(partition_xy(with_null), partition_xy(with_other))), + info = info) + } +}) + +test_that("a number of starts that is refused is refused in words that name NULL", { + pts <- .ss_pts() + # voronoi_seeds_kmeans() checks the number on every path. + for (kind in c("kmeans", "density")) { + expect_error(voronoi_seeds_kmeans(pts, 5, partition = kind, nstart = 0), + paste0("voronoi_seeds_kmeans(): `nstart` must be NULL or a single positive ", + "number of k-means restarts and at least 1; got 0."), fixed = TRUE) + expect_error(voronoi_seeds_kmeans(pts, 5, partition = kind, nstart = "three"), + paste0("voronoi_seeds_kmeans(): `nstart` must be NULL or a single positive ", + "number of k-means restarts; got character."), fixed = TRUE) + expect_error(voronoi_seeds_kmeans(pts, 5, partition = kind, nstart = c(2, 3)), + "`nstart` must be NULL or a single positive number of k-means restarts; got numeric of length 2.", + fixed = TRUE) + expect_error(voronoi_seeds_kmeans(pts, 5, partition = kind, nstart = NA_real_), + "`nstart` must be NULL or a single positive number of k-means restarts; got NA.", + fixed = TRUE) + } + # get_voronoi_seeds() checks it on the paths that are not the run it has + # always made: the density kind, and k-means++ starts. + for (extra in list(list(partition = "density"), list(partition = "kmeans", init = "kmeans++"))) { + f <- function(...) do.call(get_voronoi_seeds, + c(list(method = "kmeans", n = 5, sample_points = pts, set_seed = 1), + extra, list(...))) + expect_error(f(kmeans_nstart = 0), + paste0("get_voronoi_seeds(): `kmeans_nstart` must be NULL or a single positive ", + "whole number of starts and at least 1; got 0."), fixed = TRUE) + expect_error(f(kmeans_nstart = 2.5), + paste0("get_voronoi_seeds(): `kmeans_nstart` must be NULL or a single positive ", + "whole number of starts; got 2.5."), fixed = TRUE) + expect_error(f(kmeans_nstart = NA), + "`kmeans_nstart` must be NULL or a single positive whole number of starts; got logical.", + fixed = TRUE) + # The iteration limit takes no NULL, and its text has none. + expect_error(f(kmeans_iter = 0), + paste0("get_voronoi_seeds(): `kmeans_iter` must be a single positive whole ", + "number of iterations and at least 1; got 0."), fixed = TRUE) + } +}) + +test_that("method = \"random\" and \"provided\" do not read the number of starts, NULL or not", { + pts <- .ss_pts(); bnd <- .ss_bnd(pts) + base <- get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2) + expect_identical(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2, + kmeans_nstart = NULL), base) + expect_identical(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2, + kmeans_nstart = 0), base) + given <- get_voronoi_seeds(method = "provided", seeds = pts[1:4, ]) + expect_identical(get_voronoi_seeds(method = "provided", seeds = pts[1:4, ], + kmeans_nstart = NULL), given) +}) + +test_that("a call on a path that never reads the number of starts does not evaluate it", { + pts <- .ss_pts(); bnd <- .ss_bnd(pts) + sel <- .ss_sel(.ss_profiles()$kmeans) + # An argument that stops when it is evaluated, and a wrapper whose own + # argument for the number of starts the caller left out. + never <- quote(stop("the number of starts was evaluated")) + gvs_via <- function(f) function(starts, ...) f(..., kmeans_nstart = starts) + vsk_via <- function(f) function(starts, ...) f(..., nstart = starts) + + for (kind in c("kmeans", "density")) { + gvs <- .ss_own(get_voronoi_seeds, kind) + vsk <- .ss_own(voronoi_seeds_kmeans, kind) + # method = "random" and "provided". + base <- gvs(bnd, method = "random", n = 5, set_seed = 2) + expect_identical(eval(bquote(gvs(bnd, method = "random", n = 5, set_seed = 2, + kmeans_nstart = .(never)))), base, info = kind) + expect_identical(gvs_via(gvs)(, bnd, method = "random", n = 5, set_seed = 2), base, + info = kind) + given <- gvs(method = "provided", seeds = pts[1:4, ]) + expect_identical(eval(bquote(gvs(method = "provided", seeds = pts[1:4, ], + kmeans_nstart = .(never)))), given, info = kind) + expect_identical(gvs_via(gvs)(, method = "provided", seeds = pts[1:4, ]), given, info = kind) + # Scored centres from voronoi_seeds_kmeans(), which returns them before + # its check of the number, whichever kind is in force. + scored <- partition_quietly(vsk(pts, sel, partition = "kmeans")) + expect_identical(nrow(scored), 14L) + expect_identical(partition_quietly(eval(bquote(vsk(pts, sel, partition = "kmeans", + nstart = .(never))))), scored, info = kind) + expect_identical(partition_quietly(vsk_via(vsk)(, pts, sel, partition = "kmeans")), scored, + info = kind) + } + + # get_voronoi_seeds() beside scored centres: its own run of k-means from + # random starts checks nothing, and the centres are returned unread. + own_kmeans <- .ss_own(get_voronoi_seeds, "kmeans") + scored <- own_kmeans(method = "kmeans", n = sel, sample_points = pts) + expect_identical(eval(bquote(own_kmeans(method = "kmeans", n = sel, sample_points = pts, + kmeans_nstart = .(never)))), scored) + expect_identical(gvs_via(own_kmeans)(, method = "kmeans", n = sel, sample_points = pts), scored) + # The density kind and k-means++ starts check the number before anything + # else, scored centres or not, as they always have. + for (args in list(list(partition = "density"), list(init = "kmeans++"))) + expect_error(partition_quietly(do.call(own_kmeans, c( + list(method = "kmeans", n = sel, sample_points = pts, kmeans_nstart = never), args))), + "the number of starts was evaluated", fixed = TRUE) + expect_error(partition_quietly(eval(bquote( + .ss_own(get_voronoi_seeds, "density")(method = "kmeans", n = sel, sample_points = pts, + kmeans_nstart = .(never))))), + "the number of starts was evaluated", fixed = TRUE) + + # A fresh run of k-means from random starts reads the number where the fit + # first needs it and no sooner: after the checks of the other arguments, + # and after the stream is seeded. + expect_error(eval(bquote(own_kmeans(method = "kmeans", n = 5, set_seed = 1, + kmeans_nstart = .(never)))), + "k-means seeds require 'boundary'", fixed = TRUE) + expect_error(eval(bquote(own_kmeans(method = "kmeans", sample_points = pts, set_seed = 1, + kmeans_nstart = .(never)))), + "argument 'n' is required", fixed = TRUE) + expect_error(eval(bquote(own_kmeans(method = "kmeans", n = 5, sample_points = pts, + set_seed = 1, kmeans_nstart = .(never)))), + "the number of starts was evaluated", fixed = TRUE) + drawn <- NULL + with_draw <- own_kmeans(method = "kmeans", n = 5, sample_points = pts, set_seed = 1, + kmeans_nstart = { drawn <- stats::runif(1); 4 }) + expect_identical(drawn, withr::with_seed(1, stats::runif(1))) + expect_identical(attr(with_draw, "kmeans")$nstart, 4L) + # voronoi_seeds_kmeans() reads it at its check, after `k` is checked. + own_vsk <- .ss_own(voronoi_seeds_kmeans, "kmeans") + expect_error(eval(bquote(own_vsk(pts, 0, nstart = .(never)))), + "`k` must be a single positive number of seeds", fixed = TRUE) + expect_error(eval(bquote(own_vsk(pts, 5, nstart = .(never)))), + "the number of starts was evaluated", fixed = TRUE) +}) + + +# ---- The partition arguments a call names -------------------------------------- + +test_that("with the k-means kind as its own, a random or provided seeding is warned of a kind or a starting rule it names, and of no other", { + pts <- .ss_pts(); bnd <- .ss_bnd(pts) + gvs <- .ss_own(get_voronoi_seeds, "kmeans") + random <- function(...) gvs(bnd, method = "random", n = 5, set_seed = 2, ...) + provided <- function(...) gvs(method = "provided", seeds = pts[1:4, ], ...) + named <- "get_voronoi_seeds(): `partition` and `init` are read by method = \"kmeans\" only; method = \"%s\" ignores them." + for (case in list(list(random, "random"), list(provided, "provided"))) { + f <- case[[1L]]; method <- case[[2L]] + base <- partition_warnings(f()) + expect_length(base$warnings, 0L) + # Naming the kind the function has anyway asks for nothing it does not get. + expect_length(partition_warnings(f(partition = "kmeans"))$warnings, 0L) + for (args in list(list(partition = "density"), list(init = "kmeans++"), + list(init = "random"), list(partition = "kmeans", init = "random"))) { + r <- partition_warnings(do.call(f, args)) + expect_identical(.ss_text(r), sprintf(named, method)) + expect_identical(r$value, base$value) + } + # A density setting with no kind named: the present warning that the + # k-means kind does not read it. + r <- partition_warnings(f(density_power = 0.5)) + expect_identical(.ss_text(r), paste0( + "get_voronoi_seeds(): `density_power` is read by partition = \"density\" only, and ", + "partition = \"kmeans\" ignores it.")) + r <- partition_warnings(f(density_power = 0.5, density_k = 12)) + expect_identical(.ss_text(r), paste0( + "get_voronoi_seeds(): `density_power` and `density_k` are read by partition = ", + "\"density\" only, and partition = \"kmeans\" ignores them.")) + # With the density kind named too, one warning: the kind is not read. + r <- partition_warnings(f(partition = "density", density_power = 0.5)) + expect_identical(.ss_text(r), sprintf(named, method)) + } + # The functions themselves, whichever kind is their own: nothing named, + # nothing said; the density kind or a starting rule named, the one warning. + expect_length(partition_warnings( + get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2))$warnings, 0L) + expect_length(partition_warnings( + get_voronoi_seeds(method = "provided", seeds = pts[1:4, ]))$warnings, 0L) + expect_identical(.ss_text(partition_warnings( + get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2, partition = "density"))), + sprintf(named, "random")) + expect_identical(.ss_text(partition_warnings( + get_voronoi_seeds(method = "provided", seeds = pts[1:4, ], init = "kmeans++"))), + sprintf(named, "provided")) +}) + +test_that("a selection passed as the count by a call that names no partition argument raises nothing", { + pts <- .ss_pts() + profiles <- .ss_profiles() + for (nm in c("kmeans", "density", "power", "k_nn")) { + sel <- .ss_sel(profiles[[nm]]) + cen <- attr(profiles[[nm]], "centres")[["14"]] + for (r in list(partition_warnings(voronoi_seeds_kmeans(pts, sel)), + partition_warnings(get_voronoi_seeds(method = "kmeans", n = sel, + sample_points = pts)))) { + expect_length(r$warnings, 0L) + expect_equal(partition_xy(r$value), cen, tolerance = 1e-12) + expect_identical(attr(r$value, "partition"), + attr(profiles[[nm]], "partition")[c("kind", "init", "density_power", + "density_k")]) + } + } + # The kind named beside centres of that kind built at another power: both + # density settings are named with it, at their defaults. + sel <- .ss_sel(profiles$power) + for (r in list(partition_warnings(voronoi_seeds_kmeans(pts, sel, partition = "density")), + partition_warnings(get_voronoi_seeds(method = "kmeans", n = sel, + sample_points = pts, + partition = "density")))) { + expect_length(partition_of_class(r, "spatialkit_partition_unused"), 1L) + expect_length(r$warnings, 1L) + } +}) + +# The rule as it was before a call's supplied density settings were read: +# both settings named whenever the density kind is in force. +.ss_rule_before <- function(seeds, part, init, partition_given, arg, caller) { + rec <- attr(seeds, "partition", exact = TRUE) + kind <- if (is.null(rec)) "kmeans" else rec$kind + rule <- if (is.null(rec)) "kmeans++" else rec$init + named <- if (identical(part$kind, "density")) c("density_power", "density_k") + else part$unused + differs <- (isTRUE(partition_given) && !identical(part$kind, kind)) || + (!is.null(init) && !identical(init, rule)) || + (identical(kind, "density") && + (("density_power" %in% named && + !isTRUE(all.equal(part$asked$density_power, rec$density_power))) || + ("density_k" %in% named && + !identical(as.integer(part$asked$density_k), as.integer(rec$density_k))))) + if (differs) "spatialkit_partition_unused" + else if (!identical(kind, "density") && length(part$unused)) "density setting unused" + else "nothing" +} + +test_that("with the k-means kind as the functions' own, every call is told what it was told before", { + # Five kinds of profile by the 81 ways of leaving each of the four + # arguments unset or setting it to one of two values: 405 calls. + profiles <- .ss_profiles() + values <- list(partition = list(NULL, "kmeans", "density"), + init = list(NULL, "kmeans++", "random"), + density_power = list(NULL, 0.5, 0.7), + density_k = list(NULL, 12, 4)) + grid <- expand.grid(partition = 1:3, init = 1:3, density_power = 1:3, density_k = 1:3) + calls <- 0L + for (nm in names(profiles)) { + seeds <- spatialkit:::.profile_seeds(profiles[[nm]], 14L) + for (i in seq_len(nrow(grid))) { + a <- lapply(names(values), function(v) values[[v]][[grid[[v]][i]]]) + names(a) <- names(values) + given <- !vapply(a, is.null, logical(1)) + kind <- if (is.null(a$partition)) "kmeans" else a$partition # the functions' own + part <- .seed_partition_args(kind, a$init, a$density_power %||% 1, a$density_k %||% 8, + "f") + r <- partition_warnings(.scored_partition_unused( + seeds, part, part$init_given, given[["partition"]], arg = "n", caller = "f", + density_given = names(given)[given & names(given) %in% c("density_power", "density_k")])) + got <- if (!length(r$warnings)) "nothing" + else if (inherits(r$warnings[[1L]], "spatialkit_partition_unused")) + "spatialkit_partition_unused" + else "density setting unused" + expect_lte(length(r$warnings), 1L) + expect_identical(got, .ss_rule_before(seeds, part, part$init_given, given[["partition"]], + "n", "f"), + info = paste(nm, paste(names(a)[given], unlist(a[given]), collapse = " "))) + calls <- calls + 1L + } + } + expect_identical(calls, 405L) +}) + + +# ---- The same with the functions' own kind flipped ----------------------------- + +test_that("with the density kind as the functions' own, a call that names nothing is told nothing", { + pts <- .ss_pts() + profiles <- .ss_profiles() + gvs <- .ss_own(get_voronoi_seeds, "density") + vsk <- .ss_own(voronoi_seeds_kmeans, "density") + expect_identical(eval(formals(gvs)$partition), c("density", "kmeans")) + expect_identical(eval(formals(.ss_own(gvs, "kmeans"))$partition), c("kmeans", "density")) + via <- list(function(sel, ...) vsk(pts, sel, ...), + function(sel, ...) gvs(method = "kmeans", n = sel, sample_points = pts, ...)) + unused <- function(r) length(partition_of_class(r, "spatialkit_partition_unused")) + + for (nm in c("kmeans", "density", "power", "k_nn")) { + sel <- .ss_sel(profiles[[nm]]) + for (f in via) { + r <- partition_warnings(f(sel)) + expect_length(r$warnings, 0L) + # The scored centres, of the kind the profile was built with. + expect_equal(partition_xy(r$value), attr(profiles[[nm]], "centres")[["14"]], + tolerance = 1e-12) + expect_identical(attr(r$value, "partition"), + attr(profiles[[nm]], "partition")[c("kind", "init", "density_power", + "density_k")]) + } + } + # With the rule as it was, the two profiles built at other settings than + # the defaults were warned about on a call that names nothing. + part <- .seed_partition_args("density", NULL, 1, 8, "f") + for (nm in c("power", "k_nn")) + expect_identical(.ss_rule_before(spatialkit:::.profile_seeds(profiles[[nm]], 14L), part, + NULL, FALSE, "n", "f"), "spatialkit_partition_unused") + + # Beside the profile built at power 0.5. + sel <- .ss_sel(profiles$power) + for (f in via) { + expect_length(partition_warnings(f(sel, density_power = 0.5))$warnings, 0L) + for (other in list(list(density_power = 0.7), list(density_k = 4))) { + r <- partition_warnings(do.call(f, c(list(sel), other))) + expect_identical(unused(r), 1L) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), + "built with partition = \"density\" from k-means++ starts (power 0.5, 8 neighbours)", + fixed = TRUE) + } + # The neighbour count the profile has, supplied: nothing; and the kind + # named names both settings at the values in force, as it always has. + expect_length(partition_warnings(f(sel, density_k = 8))$warnings, 0L) + expect_identical(unused(partition_warnings(f(sel, partition = "density"))), 1L) + expect_length(partition_warnings(f(sel, partition = "density", + density_power = 0.5))$warnings, 0L) + } + # Beside the profile built with 12 neighbours. + sel <- .ss_sel(profiles$k_nn) + for (f in via) { + expect_length(partition_warnings(f(sel, density_k = 12))$warnings, 0L) + expect_identical(unused(partition_warnings(f(sel, density_k = 8))), 1L) + expect_length(partition_warnings(f(sel, density_power = 1))$warnings, 0L) + } + # Beside the k-means profile: a density setting supplied is read by + # nothing, and the kind named as built is nothing to say. + sel <- .ss_sel(profiles$kmeans) + for (f in via) { + r <- partition_warnings(f(sel, density_power = 0.5)) + expect_identical(unused(r), 1L) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), + "built with partition = \"kmeans\" from k-means++ starts, and those are returned", + fixed = TRUE) + # Supplied at its default counts as supplied. + expect_identical(unused(partition_warnings(f(sel, density_k = 8))), 1L) + expect_length(partition_warnings(f(sel, partition = "kmeans"))$warnings, 0L) + expect_identical(unused(partition_warnings(f(sel, partition = "density"))), 1L) + } +}) + +test_that("with the density kind as its own, a random or provided seeding is warned of what it names", { + pts <- .ss_pts(); bnd <- .ss_bnd(pts) + gvs <- .ss_own(get_voronoi_seeds, "density") + random <- function(...) gvs(bnd, method = "random", n = 5, set_seed = 2, ...) + provided <- function(...) gvs(method = "provided", seeds = pts[1:4, ], ...) + for (case in list(list(random, "random"), list(provided, "provided"))) { + f <- case[[1L]]; method <- case[[2L]] + base <- partition_warnings(f()) + expect_length(base$warnings, 0L) + r <- partition_warnings(f(density_power = 0.5)) + expect_identical(.ss_text(r), sprintf(paste0( + "get_voronoi_seeds(): `density_power` is read by method = \"kmeans\" only; method = ", + "\"%s\" ignores it."), method)) + expect_identical(r$value, base$value) + r <- partition_warnings(f(density_k = 12)) + expect_identical(.ss_text(r), sprintf(paste0( + "get_voronoi_seeds(): `density_k` is read by method = \"kmeans\" only; method = ", + "\"%s\" ignores it."), method)) + r <- partition_warnings(f(density_power = 0.5, density_k = 12)) + expect_identical(.ss_text(r), sprintf(paste0( + "get_voronoi_seeds(): `density_power` and `density_k` are read by method = \"kmeans\" ", + "only; method = \"%s\" ignores them."), method)) + # A kind or a starting rule named is the present warning, and one only. + for (args in list(list(partition = "density"), list(init = "random"), + list(partition = "density", density_power = 0.5))) { + r <- partition_warnings(do.call(f, args)) + expect_identical(.ss_text(r), sprintf(paste0( + "get_voronoi_seeds(): `partition` and `init` are read by method = \"kmeans\" only; ", + "method = \"%s\" ignores them."), method)) + } + # The k-means kind named: nothing of the kind, and a density setting + # beside it is the present warning of that kind. + expect_length(partition_warnings(f(partition = "kmeans"))$warnings, 0L) + r <- partition_warnings(f(partition = "kmeans", density_power = 0.5)) + expect_identical(.ss_text(r), paste0( + "get_voronoi_seeds(): `density_power` is read by partition = \"density\" only, and ", + "partition = \"kmeans\" ignores it.")) + } + # The line is for a random or provided seeding alone. A fresh run of the + # density kind as the function's own reads the settings, and is told + # nothing: it is the run of the same call with the kind named. + vsk <- .ss_own(voronoi_seeds_kmeans, "density") + for (setting in list(list(density_power = 0.5), list(density_k = 12), + list(density_power = 0.5, density_k = 12))) { + for (f in list(function(...) gvs(method = "kmeans", n = 25, sample_points = pts, + set_seed = 1, kmeans_nstart = 3, ...), + function(...) vsk(pts, 25, set_seed = 1, nstart = 3, ...))) { + info <- paste(names(setting), collapse = ", ") + r <- partition_warnings(do.call(f, setting)) + expect_identical(.ss_text(r), character(0), info = info) + named <- partition_warnings(do.call(f, c(list(partition = "density"), setting))) + expect_identical(.ss_text(named), character(0), info = info) + expect_identical(r$value, named$value, info = info) + expect_identical(attr(r$value, "partition")[names(setting)], + lapply(setting, function(v) if (v == 12) 12L else v), info = info) + # With the k-means kind named beside it, the present warning that the + # kind does not read the setting, and no other. + r <- partition_warnings(do.call(f, c(list(partition = "kmeans"), setting))) + expect_length(r$warnings, 1L) + expect_match(.ss_text(r), "read by partition = \"density\" only, and partition = \"kmeans\" ignores", + fixed = TRUE, info = info) + } + } + # With the k-means kind as the function's own the added line cannot be + # reached: the density kind is in force only where the call named it. + own_kmeans <- .ss_own(get_voronoi_seeds, "kmeans") + for (args in list(list(density_power = 0.5), list(partition = "density", density_power = 0.5), + list(partition = "kmeans", density_k = 12))) { + r <- partition_warnings(do.call(own_kmeans, c(list(bnd, method = "random", n = 5, + set_seed = 2), args))) + expect_false(any(grepl("is read by method = \"kmeans\" only; method", .ss_text(r), + fixed = TRUE))) + } +}) + +test_that("with the kind flipped and the starts NULL, a count as a number is 3 density starts", { + pts <- .ss_pts() + gvs <- .ss_own(get_voronoi_seeds, "density") + formals(gvs)["kmeans_nstart"] <- list(NULL) + vsk <- .ss_own(voronoi_seeds_kmeans, "density") + formals(vsk)["nstart"] <- list(NULL) + expect_null(formals(gvs)$kmeans_nstart) + a <- partition_quietly(gvs(method = "kmeans", n = 25, sample_points = pts, set_seed = 1)) + expect_identical(a, partition_quietly( + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, set_seed = 1, + partition = "density", kmeans_nstart = 3))) + expect_identical(attr(a, "kmeans")$nstart, 3L) + expect_identical(partition_quietly(vsk(pts, 25, set_seed = 1)), + partition_quietly(voronoi_seeds_kmeans(pts, 25, set_seed = 1, + partition = "density", nstart = 3))) + # And the k-means kind named there is the run of 10 random starts. + expect_identical(gvs(method = "kmeans", n = 25, sample_points = pts, set_seed = 1, + partition = "kmeans"), + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, set_seed = 1, + partition = "kmeans", kmeans_nstart = 10)) + expect_identical(vsk(pts, 25, partition = "kmeans"), + voronoi_seeds_kmeans(pts, 25, partition = "kmeans", nstart = 10)) + # With the k-means kind as their own and the starts NULL: the same run. + gvk <- .ss_own(get_voronoi_seeds, "kmeans") + formals(gvk)["kmeans_nstart"] <- list(NULL) + expect_identical(gvk(method = "kmeans", n = 25, sample_points = pts, set_seed = 1), + get_voronoi_seeds(method = "kmeans", n = 25, sample_points = pts, set_seed = 1, + partition = "kmeans", kmeans_nstart = 10)) +}) diff --git a/tests/testthat/test-core-switch.R b/tests/testthat/test-core-switch.R new file mode 100644 index 00000000..13afb348 --- /dev/null +++ b/tests/testthat/test-core-switch.R @@ -0,0 +1,432 @@ +# tests/testthat/test-core-switch.R +# --------------------------------------------------------------------------- +# The defaults after the switch, read off the functions themselves. +# +# The default path end to end, with nothing named beyond the data and the +# response: a profile of one level at round(n / 4.5) cells of the density +# kind, with `cp` and `reliability` NA and no variogram fitted; a selection +# by size; seeds, cells and the assignment; a summary with pooled columns +# and a record whose check reads "match". +# +# Each way back gives the object the baseline recorded before the switch +# (fixtures/core-frozen.rds, written by dev/baseline-core-frozen.R): the +# profile with estimate = NULL, obs_per_cell = NULL, sac = NULL and +# partition = "kmeans"; criterion = "cp" on it; the seeding functions with +# partition = "kmeans"; the summary with estimate = "mean". The same calls +# as they were recorded, with nothing named, now give other objects. +# +# What the seeding functions say of the kind when a call names none: nothing +# beside scored centres of either kind and any density setting, and nothing +# beside method = "random" or "provided". And Moran's z on a present ladder +# above its limit without FNN: NA with a warning, where it stopped before. +# --------------------------------------------------------------------------- + +.sw_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +# A call with its warnings and messages kept and muffled. +.sw_catch <- function(expr) { + warnings <- list() + messages <- character(0) + value <- withCallingHandlers(expr, + warning = function(w) { + warnings[[length(warnings) + 1L]] <<- w + invokeRestart("muffleWarning") + }, + message = function(m) { + messages <<- c(messages, conditionMessage(m)) + invokeRestart("muffleMessage") + }) + list(value = value, warnings = warnings, messages = messages) +} +.sw_of <- function(r, class) Filter(function(w) inherits(w, class), r$warnings) +.sw_text <- function(r) vapply(r$warnings, conditionMessage, character(1)) + +# The layer of the end-to-end tests of the record: seed 7001; `u`, then `v`, +# 3,000 values each, uniform on 0 to 1e5; then the response, +# sin(u / 2e4) + cos(v / 1.5e4) plus normal noise of standard deviation 1.5; +# the points at (5e5 + u, 5e6 + v) in EPSG:32617. +.sw_store <- new.env(parent = emptyenv()) +.sw_layer <- function() { + if (is.null(.sw_store$pts)) { + d <- local({ + .sw_seed(7001) + u <- stats::runif(3000, 0, 1e5) + v <- stats::runif(3000, 0, 1e5) + z <- sin(u / 2e4) + cos(v / 1.5e4) + stats::rnorm(3000, 0, 1.5) + data.frame(x = 5e5 + u, y = 5e6 + v, z = z) + }) + .sw_store$pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32617) + } + .sw_store$pts +} + + +# ---- The default path -------------------------------------------------------------- + +test_that("the default path is pooled values at 4.5 rows a cell, in density cells, with no variogram", { + pts <- .sw_layer() + # The profile, with nothing named but the data and the response. + log <- NULL + P <- NULL + log <- capture_spatialkit_log(P <- .sw_catch(resolution_profile(pts, "z")), + level = logger::WARN) + prof <- P$value + expect_length(P$warnings, 0L) + expect_length(P$messages, 0L) + expect_false(any(grepl("variogram", log, ignore.case = TRUE))) + # One level, at round(n / 4.5) cells of the density kind from 3 k-means++ + # starts, scored for the pooled value. + expect_identical(nrow(prof), 1L) + expect_identical(prof$levels, 667L) + expect_identical(prof$levels, as.integer(round(3000 / 4.5))) + expect_identical(attr(prof, "estimate")$value, "pooled") + expect_identical(attr(prof, "partition")[c("kind", "init", "density_power", "density_k")], + list(kind = "density", init = "kmeans++", density_power = 1, + density_k = 8L)) + expect_identical(attr(prof, "nstart"), 3L) + expect_true(is.finite(prof$loo)) + # No variogram: `cp` and `reliability` are NA, and the profile says why. + expect_identical(prof$cp, NA_real_) + expect_identical(prof$reliability, NA_real_) + expect_null(attr(prof, "variogram")) + expect_null(attr(prof, "sac")) + expect_identical(attr(prof, "bounds")$range, NA_real_) + expect_identical(attr(prof, "cp_noise")$source, "none") + # The profile is the one the values the defaults resolve to give when they + # are named. + expect_identical( + resolution_profile(pts, "z", estimate = "pooled", obs_per_cell = 4.5, sac = "auto", + partition = "density", nstart = 3), + prof) + + # The selection: by the size, with no rule named. + S <- .sw_catch(select_resolution(prof)) + sel <- S$value + expect_length(S$warnings, 0L) + expect_identical(sel$criterion, "size") + expect_identical(sel$best, 667L) + expect_identical(sel$count_rule$rule, "size") + expect_identical(sel$count_rule$estimate, "pooled") + expect_identical(sel$count_rule$partition$kind, "density") + expect_identical(sel$count_rule$partition$nstart, 3L) + expect_identical(sel, select_resolution(prof, criterion = "size")) + + # The seeds, the cells and the assignment, by the calls a user writes. + G <- .sw_catch(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)) + expect_length(G$warnings, 0L) + seeds <- G$value + expect_identical(nrow(seeds), 667L) + expect_identical(attr(seeds, "partition")$kind, "density") + expect_identical(attr(seeds, "count_rule")$scored_cells, TRUE) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id", quiet = TRUE) + expect_identical(nrow(asg), 3000L) + # Every row in the cell of its nearest scored centre. + rec <- sel$count_rule + cen <- unname(sf::st_coordinates(sel$seeds)[, 1:2]) + xy <- unname(sf::st_coordinates(sf::st_transform(pts, rec$crs))[, 1:2]) + nearest <- .nearest_centre(xy[, 1L], xy[, 2L], cen[, 1L], cen[, 2L], .has_backend("FNN")) + expect_identical(asg$cell_id, tess$index[nearest]) + + # The summary, with no estimate named: pooled columns beside the plain + # ones, and a record whose check reads "match". + V <- .sw_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells)) + out <- V$value + expect_length(V$warnings, 0L) + expect_true(all(c("resp_mean_z", "..pooled_resp_z", "..pooled_w_resp_z", + "..pooled_target_resp_z") %in% names(out))) + expect_false(any(c("..obs_lo_resp_z", "..obs_hi_resp_z", "..ci_lo_resp_z") %in% names(out))) + expect_false(is.null(attr(out, "pooled"))) + got <- attr(out, "count_rule") + expect_identical(got$check, list(estimate = "match", cells = "match")) + expect_identical(got$rule, "size") + # The summary's leave-one-out error is the profile's at that level. + own <- attr(out, "pooled")$columns$resp_z + expect_lt(abs(own$loo - prof$loo) / prof$loo, 1e-10) + expect_identical(out, suppressWarnings( + summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled"))) + + # voronoi_seeds_kmeans() given the selection returns the same centres. + K <- .sw_catch(voronoi_seeds_kmeans(pts, sel)) + expect_length(K$warnings, 0L) + expect_equal(partition_xy(K$value), partition_xy(seeds), tolerance = 1e-12) +}) + +test_that("a count given as a number is density cells from 3 k-means++ starts", { + pts <- .sw_layer()[1:600, ] + a <- get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, set_seed = 5) + expect_identical(a, get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, + set_seed = 5, partition = "density", kmeans_nstart = 3)) + expect_identical(attr(a, "kmeans")$nstart, 3L) + b <- voronoi_seeds_kmeans(pts, 40, set_seed = 5) + expect_identical(b, voronoi_seeds_kmeans(pts, 40, set_seed = 5, partition = "density", + nstart = 3)) + expect_identical(attr(b, "partition")$kind, "density") + # A number of starts that is not whole is refused under the density kind, + # which a call that names no kind now has. + expect_error(get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, + kmeans_nstart = 2.5), + "`kmeans_nstart` must be NULL or a single positive whole number of starts; got 2.5.", + fixed = TRUE) + expect_s3_class(suppressWarnings( + get_voronoi_seeds(method = "kmeans", n = 40, sample_points = pts, kmeans_nstart = 2.5, + partition = "kmeans")), "sf") +}) + + +# ---- The ways back ------------------------------------------------------------------- + +.sw_fixture <- local({ + cache <- NULL + function() { + if (is.null(cache)) cache <<- readRDS(test_path("fixtures", "core-frozen.rds")) + cache + } +}) + +# A record against the baseline's: by the rule for any platform, and on the +# baseline's own platform identical in every part. +.sw_expect_baseline <- function(got, want, nm) { + same <- core_frozen_same_platform(core_frozen_platform(), .sw_fixture()$info) + d <- core_frozen_check(got, want, same) + expect(length(d) == 0L, + paste(c(sprintf("`%s` is not what it was on the baseline.", nm), d), collapse = "\n")) + if (same) + for (part in c("value", "conditions", "output", "printed", "log", "rng")) + expect_identical(got[[part]], want[[part]], label = sprintf("the %s of `%s`", part, nm), + expected.label = "the baseline's") +} + +# Calls of the fixture, in the order the list runs them, by name; `old` +# names those to run as the baseline recorded them. +.sw_calls <- function(names, old = character(0)) { + base <- .sw_fixture() + calls <- core_frozen_calls() + calls <- calls[intersect(names(calls), names)] + for (nm in old) calls[[nm]] <- str2lang(base$calls_recorded[[nm]]) + calls +} + +test_that("each way back gives the object the baseline recorded", { + skip_on_cran() + skip_if_not_installed("gstat") + base <- .sw_fixture() + ways <- c("profile_default", "select_default_cp", "select_default_unnamed", + "seeds_number", "seeds_selection", "kmeans_number", "kmeans_selection", + "cells_number", "assigned_number", "values_default", "values_cells_sf") + # Each way back names the old default. + text <- core_frozen_call_text(.sw_calls(ways)) + expect_match(text$profile_default, paste0("estimate = NULL, obs_per_cell = NULL, ", + "sac = NULL, partition = \"kmeans\""), fixed = TRUE) + expect_match(text$select_default_unnamed, "criterion = \"cp\"", fixed = TRUE) + for (nm in c("seeds_number", "seeds_selection", "kmeans_number", "kmeans_selection")) + expect_match(text[[nm]], "partition = \"kmeans\"", fixed = TRUE, info = nm) + for (nm in c("values_default", "values_cells_sf")) + expect_match(text[[nm]], "estimate = \"mean\"", fixed = TRUE, info = nm) + + now <- core_frozen_run(base$data, .sw_calls(ways)) + for (nm in ways) .sw_expect_baseline(now[[nm]], base$records[[nm]], nm) +}) + +test_that("the calls as the baseline recorded them, with nothing named, give other objects", { + skip_on_cran() + skip_if_not_installed("gstat") + base <- .sw_fixture() + moved <- c("profile_default", "seeds_number", "kmeans_number", "values_default") + run <- core_frozen_run(base$data, .sw_calls(c(moved, "cells_number", "assigned_number"), + old = moved)) + for (nm in moved) + expect_false(isTRUE(all.equal(run[[nm]]$value, base$records[[nm]]$value)), info = nm) + # The profile is one level of pooled values in density cells. + p <- run$profile_default$value + expect_identical(nrow(p), 1L) + expect_identical(attr(p, "estimate")$value, "pooled") + expect_identical(attr(p, "partition")$kind, "density") + # The seeds are density seeds; the summary adds the pooled columns to the + # plain ones it had, which are unchanged. + expect_identical(attr(run$seeds_number$value, "partition")$kind, "density") + expect_identical(attr(run$kmeans_number$value, "partition")$kind, "density") + v <- run$values_default$value + old <- base$records$values_default$value + expect_true("..pooled_resp_z" %in% names(v)) + expect_true(all(names(old) %in% names(v))) +}) + +test_that("calls that read no default the switch moved give the baseline's object with nothing named", { + skip_on_cran() + skip_if_not_installed("gstat") + base <- .sw_fixture() + # Scored centres of the density kind passed as the count, and the random + # and provided seedings: their text names no kind, as when recorded. + same <- c("seeds_density_selection", "seeds_density_profile", "kmeans_density_selection", + "kmeans_density_profile") + expect_identical(core_frozen_call_text(.sw_calls(same)), base$calls_recorded[same]) + random <- c("seeds_random", "seeds_provided", "seeds_random_lonlat") + calls <- .sw_calls(c("profile_density", "select_density_cp", "profile_density_clustered", + same, random), old = random) + now <- core_frozen_run(base$data, calls) + for (nm in c(same, random)) .sw_expect_baseline(now[[nm]], base$records[[nm]], nm) + for (nm in random) expect_length(now[[nm]]$conditions, 0L) +}) + + +# ---- What the seeding functions say of the kind ---------------------------------------- + +.sw_pts <- function() + partition_points_sf(partition_clustered_xy(n_bg = 100L, n_cl = 300L, seed = 29L)) + +# Four profiles of scored centres at two levels from two starts, every +# setting the switch moved named: the k-means kind, and the density kind at +# its defaults, at power 0.5 and with 12 neighbours. +.sw_profiles <- function() { + if (is.null(.sw_store$profiles)) { + pts <- .sw_pts() + prof <- function(...) + resolution_profile(pts, levels = c(6L, 14L), nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, ...) + .sw_store$profiles <- list( + kmeans = prof(partition = "kmeans"), + density = prof(partition = "density"), + power = prof(partition = "density", density_power = 0.5), + k_nn = prof(partition = "density", density_k = 12)) + } + .sw_store$profiles +} +# A selection at 14 cells that carries the level's centres and nothing a +# warning about the count could be raised for. +.sw_sel <- function(p, L = 14L) structure( + list(best = L, seeds = spatialkit:::.profile_seeds(p, L), criterion = "cp", + edge = NA_character_, structured = TRUE), class = "resolution_selection") + +test_that("a selection passed as the count by a call that names no partition argument raises nothing", { + pts <- .sw_pts() + profiles <- .sw_profiles() + via <- list(function(sel, ...) voronoi_seeds_kmeans(pts, sel, ...), + function(sel, ...) get_voronoi_seeds(method = "kmeans", n = sel, + sample_points = pts, ...)) + unused <- function(r) length(.sw_of(r, "spatialkit_partition_unused")) + for (nm in names(profiles)) { + sel <- .sw_sel(profiles[[nm]]) + for (f in via) { + r <- .sw_catch(f(sel)) + expect_length(r$warnings, 0L) + expect_equal(partition_xy(r$value), attr(profiles[[nm]], "centres")[["14"]], + tolerance = 1e-12) + expect_identical(attr(r$value, "partition"), + attr(profiles[[nm]], "partition")[c("kind", "init", "density_power", + "density_k")]) + } + } + # Beside the profile built at power 0.5: the power it has, named, raises + # nothing; another power or neighbour count is said to be unused. + sel <- .sw_sel(profiles$power) + for (f in via) { + expect_length(.sw_catch(f(sel, density_power = 0.5))$warnings, 0L) + for (other in list(list(density_power = 0.7), list(density_k = 4))) { + r <- .sw_catch(do.call(f, c(list(sel), other))) + expect_identical(unused(r), 1L) + expect_length(r$warnings, 1L) + } + } + # Beside the profile built with 12 neighbours. + sel <- .sw_sel(profiles$k_nn) + for (f in via) { + expect_length(.sw_catch(f(sel, density_k = 12))$warnings, 0L) + expect_identical(unused(.sw_catch(f(sel, density_k = 8))), 1L) + } + # Beside the k-means profile: a density setting supplied is read by + # nothing, and the k-means kind named is the kind that built it. + sel <- .sw_sel(profiles$kmeans) + for (f in via) { + r <- .sw_catch(f(sel, density_power = 0.5)) + expect_identical(unused(r), 1L) + expect_length(r$warnings, 1L) + expect_length(.sw_catch(f(sel, partition = "kmeans"))$warnings, 0L) + } +}) + +test_that("a selection made by select_resolution() is handed on in silence whatever its settings", { + pts <- .sw_pts() + xy <- partition_xy(pts) + pts$z <- local({ + .sw_seed(30) + sin(xy[, 1L] / 150) + stats::rnorm(nrow(xy), sd = 0.5) + }) + for (args in list(list(density_power = 0.5), list(density_k = 12))) { + prof <- suppressWarnings(do.call(resolution_profile, + c(list(pts, "z", levels = c(6L, 14L), nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "density"), args))) + expect_identical(attr(prof, "partition")[[names(args)]], + if (identical(names(args), "density_k")) 12L else 0.5) + sel <- select_resolution(prof, criterion = "cp") + for (r in list(.sw_catch(voronoi_seeds_kmeans(pts, sel)), + .sw_catch(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = pts)))) { + # Only what the count itself may be told: an optimum at an end of the + # levels, or a response without structure. + classes <- vapply(r$warnings, function(w) class(w)[1L], character(1)) + expect_true(all(classes %in% c("spatialkit_bound_chosen", "spatialkit_no_structure"))) + expect_length(.sw_of(r, "spatialkit_partition_unused"), 0L) + expect_equal(partition_xy(r$value), attr(prof, "centres")[[as.character(sel$best)]], + tolerance = 1e-12) + expect_identical(attr(r$value, "partition")[[names(args)]], + attr(prof, "partition")[[names(args)]]) + } + } +}) + +test_that("a random or provided seeding that names no kind raises nothing", { + pts <- .sw_pts() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + random <- function(...) get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 2, ...) + provided <- function(...) get_voronoi_seeds(method = "provided", seeds = pts[1:4, ], ...) + for (case in list(list(random, "random"), list(provided, "provided"))) { + f <- case[[1L]]; method <- case[[2L]] + base <- .sw_catch(f()) + expect_length(base$warnings, 0L) + # A density setting supplied is read by nothing, and the call is told. + r <- .sw_catch(f(density_power = 0.5)) + expect_identical(.sw_text(r), sprintf(paste0( + "get_voronoi_seeds(): `density_power` is read by method = \"kmeans\" only; method = ", + "\"%s\" ignores it."), method)) + expect_identical(r$value, base$value) + # The k-means kind named is nothing to say. + expect_length(.sw_catch(f(partition = "kmeans"))$warnings, 0L) + expect_identical(f(partition = "kmeans"), base$value) + } +}) + + +# ---- Moran's z above its limit on a present ladder ----------------------------------- + +test_that("a present ladder above the limit of Moran's z returns without FNN or Matrix", { + skip_if_not_installed("gstat") + pts <- local({ + d <- local({ + .sw_seed(323) + x <- stats::runif(720, 0, 1e5); y <- stats::runif(720, 0, 1e5) + data.frame(x = x, y = y, z = sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(720, 0, 1.5)) + }) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32617) + }) + for (pkg in c("FNN", "Matrix")) { + r <- local({ + testthat::local_mocked_bindings(.KNN_DENSE_MAX = 159L) + testthat::local_mocked_bindings( + .has_backend = function(p) if (p %in% pkg) FALSE else requireNamespace(p, quietly = TRUE)) + .sw_catch(resolution_profile(pts, "z", levels = 160, sample_n = 720, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans", + init = "random", nstart = 1)) + }) + expect_s3_class(r$value, "resolution_profile") + w <- .sw_of(r, "spatialkit_moran_skipped") + expect_length(w, 1L) + expect_identical(w[[1L]]$missing, pkg) + expect_identical(r$value$levels, 160L) + expect_identical(r$value$moran_i, NA_real_, info = pkg) + expect_identical(r$value$moran_z, NA_real_, info = pkg) + expect_true(is.finite(r$value$rss)) + } +}) diff --git a/tests/testthat/test-core-values-at.R b/tests/testthat/test-core-values-at.R new file mode 100644 index 00000000..8642a07e --- /dev/null +++ b/tests/testthat/test-core-values-at.R @@ -0,0 +1,2053 @@ +# tests/testthat/test-core-values-at.R +# --------------------------------------------------------------------------- +# cell_values_at(): the value and interval of a cell at other locations. +# Which cell a location lies in (its nearest seed, or the polygon that holds +# it), the value it takes, the fill for a location with no cell or a cell +# without a value, the distance from the nearest observation, the two tie +# rules, the record of the call, and the coverage of the interval at +# held-out rows of simulated layers. +# +# The reference for the values at held-out rows is predict_partition() of +# the experiments (helper-pool-reference.R). +# +# Every profile names `partition`, `init`, `nstart`, `estimate`, +# `obs_per_cell` and `sac`, every selection its `criterion`, every summary +# its `estimate`. The regions are of the density kind from 3 k-means++ +# starts under seed 123. A simulated layer is drawn under the seed its +# test states: the locations (x, then y), then the response, then the rows +# held out. +# --------------------------------------------------------------------------- + +# ---- Layers and helpers ------------------------------------------------------ + +.va_seed <- function(seed, env = parent.frame()) + withr::local_seed(seed, .local_envir = env, .rng_kind = "Mersenne-Twister", + .rng_normal_kind = "Inversion", .rng_sample_kind = "Rejection") + +# A call with its warnings kept and muffled. +.va_catch <- function(expr) { + got <- list() + value <- withCallingHandlers(expr, warning = function(w) { + got[[length(got) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = got) +} +.va_classes <- function(r) vapply(r$warnings, function(w) class(w)[1L], character(1)) +.va_error <- function(expr) tryCatch({ expr; NULL }, error = function(e) e) +.va_print <- function(x) utils::capture.output(print(x)) +# The columns of a frame and nothing else: no row names, no record. +.va_cols <- function(d) { + d <- as.list(d) + attributes(d) <- list(names = names(d)) + d +} +.va_no_fnn <- function(env = parent.frame()) + testthat::local_mocked_bindings(.has_backend = function(pkg) FALSE, .env = env) + +.va_store <- new.env(parent = emptyenv()) +.va_keep <- function(key, expr) { + if (is.null(.va_store[[key]])) .va_store[[key]] <- expr + .va_store[[key]] +} + +# `n` locations uniform on a square of side 1e5 with its corner at (5e5, +# 5e6) in EPSG:32617; the response `z` is sin(x / 2e4) + cos(y / 1.5e4) plus +# normal noise of standard deviation 0.6, and `w` is 2 z + 1; `hold` rows are +# then held out by sample.int(). +.va_draw <- function(n, seed, hold) { + d <- local({ + .va_seed(seed) + x <- stats::runif(n, 0, 1e5); y <- stats::runif(n, 0, 1e5) + z <- sin(x / 2e4) + cos(y / 1.5e4) + stats::rnorm(n, 0, 0.6) + te <- sample.int(n, hold) + list(d = data.frame(x = 5e5 + x, y = 5e6 + y, z = z, w = 2 * z + 1), te = te) + }) + pts <- sf::st_as_sf(d$d, coords = c("x", "y"), crs = 32617) + list(rows = pts[-d$te, ], held = pts[d$te, ]) +} + +# The calls of the design's first block, from the profile to the summary: +# the count from a size of 4.5, the cells, the rows in them, and the two +# summaries, pooled values with both intervals at 0.90 and plain means. +.va_path <- function(rows) { + prof <- suppressWarnings( + resolution_profile(rows, "z", partition = "density", init = "kmeans++", nstart = 3, + sac = "auto", seed = 123, estimate = "pooled", obs_per_cell = 4.5)) + sel <- select_resolution(prof, criterion = "size") + seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = rows) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(rows, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + pooled <- summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled", obs_level = 0.90, conf_level = 0.90) + # Plain means on cells sized for pooled values: the summary says so. + plain <- .va_catch(summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "mean")) + stopifnot(identical(.va_classes(plain), "spatialkit_estimate_mismatch")) + seeds$cell_id <- tess$index + list(sel = sel, seeds = seeds, tess = tess, asg = asg, pooled = pooled, + plain = plain$value) +} + +# 600 locations (seed 6102), 120 held out; every row has a response. +.va_full <- function() .va_keep("full", { + L <- .va_draw(600, 6102, 120) + c(L, .va_path(L$rows)) +}) +# 1,500 locations (seed 6101), 300 held out; the other 1,200 have no response +# east of x = 580,000. The centres are fitted to all 1,200 and the size +# divides the rows with a response, so the centres in the east hold no +# scored row, and the held-out rows there lie in cells without a value. +.va_gap <- function() .va_keep("gap", { + L <- .va_draw(1500, 6101, 300) + L$rows$z[sf::st_coordinates(L$rows)[, 1L] > 5.8e5] <- NA + c(L, .va_path(L$rows)) +}) + +.va_at <- function(L, newdata, values = L$pooled, seeds = L$seeds, points = L$asg, + response = "z") + cell_values_at(newdata, values, points, response, id_col = "cell_id", seeds = seeds) + +# The coordinates of a layer and, for locations `q`, the nearest of the +# locations `u` by the rule of the design: the least squared distance, a tie +# to the lower x and then the lower y. +.va_xy <- function(layer) unname(sf::st_coordinates(layer)[, 1:2, drop = FALSE]) +.va_nearest <- function(q, u) { + vapply(seq_len(nrow(q)), function(i) { + d2 <- (q[i, 1L] - u[, 1L])^2 + (q[i, 2L] - u[, 2L])^2 + at <- which(d2 == min(d2)) + at[order(u[at, 1L], u[at, 2L])][1L] + }, integer(1)) +} + +# A layer made by hand: points at (5e5 + x, 5e6 + y) in EPSG:32617. +.va_points <- function(x, y, ..., crs = 32617) + sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, ...), coords = c("x", "y"), crs = crs) +.va_means <- function(rows) + summarize_by_cell(rows, "z", id_col = "cell_id", estimate = "mean") + +# Scored rows on a 6 x 5 lattice of spacing 10, two rows at each location. +# The location that is `i`-th in (x, y) order is cell 31 - i, so neither the +# order of the IDs nor that of the rows follows the coordinates; the rows +# are shuffled under seed 6201. The response of cell `k` is 10 k -+ 1. +.va_lattice <- function() .va_keep("lattice", { + g <- expand.grid(y = seq(0, 40, by = 10), x = seq(0, 50, by = 10)) + cell <- 31L - seq_len(30L) + d <- data.frame(x = rep(g$x, 2L), y = rep(g$y, 2L), cell_id = rep(cell, 2L), + z = 10 * rep(cell, 2L) + rep(c(-1, 1), each = 30L)) + d <- local({ .va_seed(6201); d[sample.int(60L), ] }) + rows <- .va_points(d$x, d$y, cell_id = d$cell_id, z = d$z) + list(rows = rows, values = .va_means(rows), at = g, cell = cell) +}) + + +# ---- The pieces ---------------------------------------------------------------- + +test_that("the columns of the summary that hold a column's value: the response's first, the pooled value first", { + expect_null(.values_at_columns(c("cell_id", "n", "resp_median_z"), "z")) + expect_identical(.values_at_columns(c("cell_id", "resp_mean_z"), "z"), + list(value = "resp_mean_z", estimate = "mean", lo = NULL, hi = NULL)) + expect_identical( + .values_at_columns(c("resp_mean_z", "..pooled_resp_z", "pred_mean_z", "..pooled_pred_z"), "z"), + list(value = "..pooled_resp_z", estimate = "pooled", lo = NULL, hi = NULL)) + expect_identical( + .values_at_columns(c("pred_mean_z", "resp_mean_z", "..pooled_pred_z"), "z")$value, + "resp_mean_z") + expect_identical( + .values_at_columns(c("pred_mean_w", "..pooled_pred_w", "..obs_lo_pred_w", "..obs_hi_pred_w", + "..obs_lo_resp_z", "..obs_hi_resp_z"), "w"), + list(value = "..pooled_pred_w", estimate = "pooled", lo = "..obs_lo_pred_w", + hi = "..obs_hi_pred_w")) + # One end of the interval alone is no interval; an interval beside a plain mean is not read. + expect_null(.values_at_columns(c("..pooled_resp_z", "..obs_lo_resp_z"), "z")$lo) + expect_null(.values_at_columns(c("resp_mean_z", "..obs_lo_resp_z", "..obs_hi_resp_z"), "z")$lo) + # The column is matched whole. + expect_null(.values_at_columns(c("resp_mean_zz", "..pooled_resp_zz"), "z")) +}) + +test_that("IDs are written in the class of the summary's ID column, also those the summary has no row for", { + expect_identical(.values_at_ids(c("3", NA, "1", "7"), c(1L, 2L, 3L)), c(3L, NA, 1L, 7L)) + # A whole number held as a double is matched by its digits: 1e5 is "100000". + expect_identical(.values_at_ids(c("100000", "250000"), c(1e5, 2e5)), c(1e5, 250000)) + expect_identical(.values_at_ids(c("b", NA, "zz"), c("a", "b")), c("b", NA, "zz")) + f <- .values_at_ids(c("b", NA, "zz", "a"), factor(c("b", "a"), levels = c("b", "a"))) + expect_identical(f, factor(c("b", NA, "zz", "a"), levels = c("b", "a", "zz"))) + # A missing ID in the summary (a row of unassigned points) is no cell. + expect_identical(.values_at_ids(c(NA, "2"), c(NA, 2L)), c(NA, 2L)) + # A class an ID cannot be written in from its text: as text. + d <- as.Date(c("2026-01-01", "2026-01-02")) + expect_identical(.values_at_ids(c("2026-01-02", NA), d), d[c(2L, NA)]) + expect_identical(.values_at_ids(c("2026-01-02", "x"), d), c("2026-01-02", "x")) + # An ordered factor stays one, with the new level after its own. + f <- .values_at_ids(c("lo", "zz", NA), factor(c("lo", "hi"), levels = c("lo", "hi"), + ordered = TRUE)) + expect_identical(f, factor(c("lo", "zz", NA), levels = c("lo", "hi", "zz"), ordered = TRUE)) + expect_false(is.ordered(.values_at_ids("zz", factor(c("lo", "hi"))))) + # A number the summary has no row for is the number its text says: a fraction in a + # double column is not cut to its whole part. + expect_identical(.values_at_ids(c("3.5", "2", "-0.25"), c(1, 2)), c(3.5, 2, -0.25)) + # An ID the class of the column cannot hold is not turned into NA or into another + # ID: every ID is then returned as text. + expect_identical(.values_at_ids(c("new-7", "3", NA), 1:5), c("new-7", "3", NA)) + expect_identical(.values_at_ids(c("3.5", "3"), 1:5), c("3.5", "3")) + expect_identical(.values_at_ids(c("new-7", "2"), c(1, 2)), c("new-7", "2")) + expect_identical(.values_at_ids(c("1e5", "2"), c(1, 2)), c("1e5", "2")) + expect_identical(.values_at_ids(c("3000000000", "2"), 1:5), c("3000000000", "2")) +}) + +test_that("the nearest centre is .nearest_centre()'s, a tie to the lower number, however many points tie", { + skip_if_not_installed("FNN") + # A lattice of centres, and points on it, half-way between two and between four. + g <- expand.grid(y = seq(0, 90, by = 10), x = seq(0, 110, by = 10)) + cx <- g$x; cy <- g$y + q <- rbind(cbind(cx, cy), cbind(cx + 5, cy), cbind(cx, cy + 5), cbind(cx + 5, cy + 5), + cbind(cx + 3, cy + 1)) + exact <- .nearest_exact(q[, 1L], q[, 2L], cx, cy) + expect_identical(.values_at_nearest(q[, 1L], q[, 2L], cx, cy, TRUE), exact) + expect_identical(.values_at_nearest(q[, 1L], q[, 2L], cx, cy, FALSE), exact) + expect_identical(.nearest_centre(q[, 1L], q[, 2L], cx, cy, use_fnn = TRUE), exact) + # The centres in another order: the lower number is another centre. + o <- rev(seq_along(cx)) + expect_identical(.values_at_nearest(q[, 1L], q[, 2L], cx[o], cy[o], TRUE), + .nearest_exact(q[, 1L], q[, 2L], cx[o], cy[o])) + expect_false(identical(o[.values_at_nearest(q[, 1L], q[, 2L], cx[o], cy[o], TRUE)], exact)) + # Centres that share a point, and centres all on one point. + local({ + .va_seed(6301) + for (K in c(17L, 40L, 300L)) { + ax <- round(stats::runif(K, 0, 12)); ay <- round(stats::runif(K, 0, 12)) + px <- round(stats::runif(400, 0, 24)) / 2; py <- round(stats::runif(400, 0, 24)) / 2 + expect_identical(.values_at_nearest(px, py, ax, ay, TRUE), .nearest_exact(px, py, ax, ay)) + } + }) + expect_identical(.values_at_nearest(c(1, 9), c(2, 8), rep(5, 40), rep(5, 40), TRUE), c(1L, 1L)) + # A tied point is settled from a shortlist, not by a search of every centre. + searched <- 0L + real <- .nearest_exact + force(real) + testthat::local_mocked_bindings(.nearest_exact = function(x, y, cx, cy) { + searched <<- searched + length(x) + real(x, y, cx, cy) + }) + expect_identical(.values_at_nearest(q[, 1L], q[, 2L], cx, cy, TRUE), exact) + expect_identical(searched, 0L) +}) + +test_that("the nearest centre is the exact one where centres are nearly the same distance away", { + skip_if_not_installed("FNN") + # Among 40 centres, centre 3 is 10 from the query and centre 2 further by two parts in + # 1e10: the nearer one has the higher number. + cen <- local({ + .va_seed(6302) + list(x = stats::runif(40, 50, 90), y = stats::runif(40, 50, 90)) + }) + cen$x[2L] <- 10 * (1 + 2e-10); cen$y[2L] <- 0 + cen$x[3L] <- 0; cen$y[3L] <- 10 + expect_identical(.nearest_exact(0, 0, cen$x, cen$y), 3L) + expect_identical(.values_at_nearest(0, 0, cen$x, cen$y, TRUE), 3L) + expect_identical(.values_at_nearest(0, 0, cen$x, cen$y, FALSE), 3L) + # A ring of 60 centres about the query at radii 100 (1 + j 1e-11), j from 0 to 59 in + # an order drawn under seed 6303, alone and among 40 centres far away. The nearest is + # the one with j = 0, which is not the first. + j <- local({ .va_seed(6303); sample.int(60L) - 1L }) + angle <- seq(0, 2 * pi, length.out = 61L)[-61L] + rx <- 100 * (1 + j * 1e-11) * cos(angle) + ry <- 100 * (1 + j * 1e-11) * sin(angle) + expect_gt(which(j == 0L), 1L) + expect_lt(j[1L], 50L) + qx <- c(0, 3); qy <- c(0, 4) + for (far in list(numeric(0), 1000 + cen$x)) { + ax <- c(rx, far); ay <- c(ry, far) + exact <- .nearest_exact(qx, qy, ax, ay) + expect_identical(exact[1L], which(j == 0L)) + expect_identical(.values_at_nearest(qx, qy, ax, ay, TRUE), exact) + expect_identical(.values_at_nearest(qx, qy, ax, ay, FALSE), exact) + } +}) + +test_that("a kd-tree that ranks nearly tied centres in another order than R gives the same nearest centre", { + skip_if_not_installed("FNN") + # Three centres at 1, 1 + 2e-12 and 1 + 4e-12 from the query, among 33. The stand-in + # for FNN's search returns, for a shortlist of two, the second and the third nearest, + # as a tree would whose rounding ranked the nearest of the three last. + cen <- local({ + .va_seed(6304) + list(x = c(1, 1 + 2e-12, 1 + 4e-12, stats::runif(30, 50, 90)), + y = c(0, 0, 0, stats::runif(30, 50, 90))) + }) + expect_identical(.nearest_exact(0, 0, cen$x, cen$y), 1L) + real <- FNN::get.knnx + force(real) + asked <- integer(0) + testthat::local_mocked_bindings(get.knnx = function(data, query, k, ...) { + asked <<- c(asked, as.integer(k)) + r <- real(data, query, k = min(nrow(data), k + 1L), ...) + keep <- if (k == 2L) 2:3 else seq_len(k) + list(nn.index = r$nn.index[, keep, drop = FALSE], nn.dist = r$nn.dist[, keep, drop = FALSE]) + }, .package = "FNN") + expect_identical(.values_at_nearest(0, 0, cen$x, cen$y, TRUE), 1L) + # The two centres of the first shortlist are too close to settle the point; the next + # shortlist, of four, holds the nearest. + expect_identical(asked, c(2L, 4L)) +}) + + +# ---- At the training rows ------------------------------------------------------ + +test_that("at the training rows each row gets its own cell's value, unfilled and at distance 0", { + L <- .va_full() + expect_true("cell_id" %in% names(L$asg)) + own <- match(L$asg$cell_id, L$pooled$cell_id) + for (seeds in list(NULL, L$seeds)) { + r <- .va_catch(.va_at(L, L$asg, seeds = seeds)) + # No warning: none about the ID column `newdata` carries, and no other. + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(nrow(at), nrow(L$asg)) + expect_identical(names(at), c("cell_id", "value", "estimate", "obs_lo", "obs_hi", "filled", + "filled_from", "dist_nearest", "dist_ratio")) + expect_identical(at$cell_id, L$asg$cell_id) + expect_identical(at$value, L$pooled$..pooled_resp_z[own]) + expect_identical(at$obs_lo, L$pooled$..obs_lo_resp_z[own]) + expect_identical(at$obs_hi, L$pooled$..obs_hi_resp_z[own]) + expect_identical(at$estimate, rep("pooled", nrow(at))) + expect_identical(at$filled, rep(FALSE, nrow(at))) + expect_identical(at$filled_from, rep(NA_integer_, nrow(at))) + expect_identical(at$dist_nearest, rep(0, nrow(at))) + expect_identical(at$dist_ratio, rep(0, nrow(at))) + # The plain means of the same cells. + p <- .va_catch(.va_at(L, L$asg, values = L$plain, seeds = seeds)) + expect_identical(.va_classes(p), character(0)) + expect_identical(names(p$value), c("cell_id", "value", "estimate", "filled", "filled_from", + "dist_nearest", "dist_ratio")) + expect_identical(p$value$value, L$plain$resp_mean_z[match(L$asg$cell_id, L$plain$cell_id)]) + expect_identical(p$value$estimate, rep("mean", nrow(at))) + expect_identical(p$value$filled, rep(FALSE, nrow(at))) + } + # The assignment itself does warn about that column, which is why it is not handed over. + expect_warning(assign_features_to_polygons(L$asg[1:5, ], L$pooled, polygon_id_col = "cell_id", + keep_unassigned = TRUE, quiet = TRUE), + "already carries column") +}) + +test_that("the same holds on lon/lat rows, measured in the CRS the count was scored in", { + L <- .va_keep("lonlat", { + F <- .va_full() + rows <- sf::st_transform(F$rows, 4326) + c(list(rows = rows, held = sf::st_transform(F$held, 4326)), .va_path(rows)) + }) + rec <- attr(L$pooled, "count_rule") + expect_true(isTRUE(sf::st_is_longlat(L$asg))) + expect_false(isTRUE(sf::st_is_longlat(rec$crs))) + own <- match(L$asg$cell_id, L$pooled$cell_id) + for (seeds in list(NULL, L$seeds)) { + r <- .va_catch(.va_at(L, L$asg, seeds = seeds)) + expect_identical(.va_classes(r), character(0)) + expect_identical(r$value$cell_id, L$asg$cell_id) + expect_identical(r$value$value, L$pooled$..pooled_resp_z[own]) + expect_identical(r$value$filled, rep(FALSE, nrow(L$asg))) + expect_identical(r$value$dist_nearest, rep(0, nrow(L$asg))) + expect_identical(attr(r$value, "values_at")$crs, rec$crs) + } + # Distances are metres of that CRS, not degrees. + at <- .va_at(L, L$held) + expect_gt(stats::median(at$dist_nearest), 100) + expect_gt(attr(at, "values_at")$spacing, 100) +}) + + +# ---- Held-out rows, against the experiments' function --------------------------- + +test_that("with seeds the values at held-out rows are predict_partition()'s, the rows of empty regions included", { + skip_if_not_installed("FNN") + L <- .va_gap() + rec <- attr(L$pooled, "count_rule") + expect_identical(sf::st_crs(L$asg), rec$crs) + expect_false(anyNA(L$tess$index)) + scored <- is.finite(L$asg$z) + cen <- .va_xy(L$seeds) + xy_tr <- .va_xy(L$asg)[scored, ] + xy_te <- .va_xy(L$held) + g_tr <- .nearest_centre(xy_tr[, 1L], xy_tr[, 2L], cen[, 1L], cen[, 2L], use_fnn = TRUE) + g_te <- .nearest_centre(xy_te[, 1L], xy_te[, 2L], cen[, 1L], cen[, 2L], use_fnn = TRUE) + # The cells of the summary are the regions of these centres. + expect_identical(L$asg$cell_id[scored], L$tess$index[g_tr]) + ref <- predict_partition(g_tr, g_te, L$asg$z[scored], xy_tr, xy_te, want = c("P", "L")) + empty <- !(g_te %in% g_tr) + expect_identical(ref$n_empty, sum(empty)) + # Centres in the east hold no scored row, and held-out rows lie in their regions. + expect_gt(ref$n_empty, 20L) + expect_lt(ref$n_empty, 150L) + # The cell of the nearest scored row, by the experiments' own expression. + from <- L$tess$index[g_tr[FNN::get.knnx(xy_tr, xy_te[empty, , drop = FALSE], + k = 1L)$nn.index[, 1L]]] + + for (est in c("L", "P")) { + values <- if (est == "L") L$pooled else L$plain + r <- .va_catch(.va_at(L, L$held, values = values)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_lt(max(abs(at$value - ref$pred[, est]) / pmax(1, abs(ref$pred[, est]))), 1e-12) + expect_identical(sum(at$filled), ref$n_empty) + expect_identical(at$filled, empty) + expect_identical(at$cell_id, L$tess$index[g_te]) + expect_identical(at$filled_from[empty], from) + expect_true(all(is.na(at$filled_from[!empty]))) + expect_identical(at$estimate, rep(if (est == "L") "pooled" else "mean", nrow(at))) + expect_identical(attr(at, "values_at")$filled, ref$n_empty) + # A filled row lies in one cell and takes the value of another. + expect_true(all(at$cell_id[empty] != at$filled_from[empty])) + expect_identical(at$value[empty], + values[[if (est == "L") "..pooled_resp_z" else "resp_mean_z"]][ + match(from, values$cell_id)]) + # The answer does not depend on the FNN package. + local({ + .va_no_fnn() + expect_identical(.va_at(L, L$held, values = values), at) + }) + } +}) + +test_that("the cell, the fill and its source are those of a search of every pair, with and without FNN", { + # The rule written out, without the experiments' function and without FNN: the cell of + # the nearest seed; filled when that cell holds no scored row; from the cell of the + # nearest scored row. No location of this layer is the same distance from two. + L <- .va_gap() + scored <- is.finite(L$asg$z) + q <- .va_xy(L$held) + cell <- L$tess$index[.va_nearest(q, .va_xy(L$seeds))] + holds <- cell %in% L$asg$cell_id[scored] + from <- L$asg$cell_id[scored][.va_nearest(q, .va_xy(L$asg)[scored, ])] + expect_gt(sum(!holds), 20L) + for (values in list(L$pooled, L$plain)) { + column <- if ("..pooled_resp_z" %in% names(values)) "..pooled_resp_z" else "resp_mean_z" + for (fnn in c(TRUE, FALSE)) local({ + if (!fnn) .va_no_fnn() + at <- .va_at(L, L$held, values = values) + expect_identical(at$cell_id, cell) + expect_identical(at$filled, !holds) + expect_identical(at$filled_from, ifelse(holds, NA_integer_, from)) + expect_identical(at$value, values[[column]][match(ifelse(holds, cell, from), values$cell_id)]) + expect_false(anyNA(at$value)) + }) + } +}) + +test_that("the interval of a held-out row is its value plus the summary's two offsets, filled or not", { + L <- .va_gap() + at <- .va_at(L, L$held) + off <- attr(L$pooled, "pooled")$columns$resp_z$offsets + expect_true(all(is.finite(off)) && off[1L] < 0 && off[2L] > 0) + expect_true(any(at$filled)) + expect_equal(at$obs_lo - at$value, rep(off[1L], nrow(at)), tolerance = 1e-12) + expect_equal(at$obs_hi - at$value, rep(off[2L], nrow(at)), tolerance = 1e-12) + src <- match(ifelse(at$filled, at$filled_from, at$cell_id), L$pooled$cell_id) + expect_identical(at$obs_lo, L$pooled$..obs_lo_resp_z[src]) + expect_identical(at$obs_hi, L$pooled$..obs_hi_resp_z[src]) +}) + + +# ---- Without seeds: the polygon that holds the location --------------------------- + +test_that("without seeds a location takes the value of the polygon that holds it, and one in no polygon is filled", { + L <- .va_gap() + # The held-out rows and three locations outside every polygon: west, south and far north-east. + far <- .va_points(c(-2e4, 5e4, 3e5), c(5e4, -3e4, 3e5)) + newdata <- rbind(sf::st_sf(geometry = sf::st_geometry(L$held)), + sf::st_sf(geometry = sf::st_geometry(far))) + outside <- c(rep(FALSE, nrow(L$held)), rep(TRUE, 3L)) + r <- .va_catch(.va_at(L, newdata, seeds = NULL)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + by_seeds <- .va_at(L, newdata) + inside <- !is.na(at$cell_id) + # Every location inside a polygon: the value, the cell and the fill of the seeds' call. + expect_gt(sum(inside), 290L) + expect_identical(.va_cols(at[inside, ]), .va_cols(by_seeds[inside, ])) + expect_identical(at$dist_nearest, by_seeds$dist_nearest) + # A location in no polygon: no cell, filled, from the cell of its nearest scored row. + expect_identical(inside[outside], rep(FALSE, 3L)) + expect_true(all(at$filled[!inside])) + scored <- is.finite(L$asg$z) + u <- .va_xy(L$asg)[scored, ] + nearest <- .va_nearest(.va_xy(newdata)[!inside, , drop = FALSE], u) + expect_identical(at$filled_from[!inside], L$asg$cell_id[scored][nearest]) + expect_identical(at$value[!inside], + L$pooled$..pooled_resp_z[match(at$filled_from[!inside], L$pooled$cell_id)]) + q <- .va_xy(newdata)[!inside, , drop = FALSE] + expect_identical(at$dist_nearest[!inside], + sqrt((q[, 1L] - u[nearest, 1L])^2 + (q[, 2L] - u[nearest, 2L])^2)) + # A location in a cell with no scored row keeps that cell's ID and has another in filled_from. + kept <- inside & at$filled + expect_gt(sum(kept), 20L) + expect_false(anyNA(at$cell_id[kept])) + expect_true(all(at$cell_id[kept] != at$filled_from[kept])) + expect_true(all(is.na(L$pooled$..pooled_resp_z[match(at$cell_id[kept], L$pooled$cell_id)]))) + expect_false(any(at$cell_id[kept] %in% L$asg$cell_id[scored])) + expect_true(all(at$filled_from[kept] %in% L$asg$cell_id[scored])) + expect_false(anyNA(at$value[kept])) + expect_identical(attr(at, "values_at")$assignment, "polygons") + expect_identical(attr(at, "values_at")$filled, sum(at$filled)) +}) + +test_that("with every location outside every polygon the call returns, all filled, and no warning leaves it", { + L <- .va_full() + far <- .va_points(c(-2e4, -3e4, 3e5, 5e4, 5e4), c(5e4, -3e4, 3e5, -1e4, 2e5)) + # The assignment warns of exactly this. + expect_warning( + assign_features_to_polygons(far, L$pooled, polygon_id_col = "cell_id", + keep_unassigned = TRUE, quiet = TRUE), + class = "spatialkit_unassigned") + r <- .va_catch(.va_at(L, far, seeds = NULL)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(nrow(at), 5L) + expect_identical(at$cell_id, rep(NA_integer_, 5L)) + expect_identical(at$filled, rep(TRUE, 5L)) + u <- .va_xy(L$asg) + nearest <- .va_nearest(.va_xy(far), u) + expect_identical(at$filled_from, L$asg$cell_id[nearest]) + expect_identical(at$value, L$pooled$..pooled_resp_z[match(at$filled_from, L$pooled$cell_id)]) + expect_false(anyNA(at$value)) + q <- .va_xy(far) + expect_identical(at$dist_nearest, + sqrt((q[, 1L] - u[nearest, 1L])^2 + (q[, 2L] - u[nearest, 2L])^2)) + expect_true(all(at$dist_ratio > 1)) + expect_identical(attr(at, "values_at")$filled, 5L) +}) + + +# ---- IDs of two classes ------------------------------------------------------------- + +test_that("IDs are matched as text: a summary with character IDs beside rows and seeds with integer ones", { + L <- .va_gap() + cells <- L$tess$cells + cells$cell_id <- as.character(cells$cell_id) + values <- summarize_by_cell(L$asg, "z", id_col = "cell_id", cells_sf = cells, + estimate = "pooled", obs_level = 0.90) + expect_type(values$cell_id, "character") + expect_type(L$asg$cell_id, "integer") + expect_type(L$seeds$cell_id, "integer") + same <- .va_at(L, L$held) + expect_type(same$cell_id, "integer") + expect_true(any(same$filled)) + for (seeds in list(L$seeds, NULL)) { + want <- .va_at(L, L$held, seeds = seeds) + at <- .va_at(L, L$held, values = values, seeds = seeds) + expect_type(at$cell_id, "character") + expect_type(at$filled_from, "character") + expect_identical(at$cell_id, as.character(want$cell_id)) + expect_identical(at$filled_from, as.character(want$filled_from)) + expect_equal(at$value, want$value, tolerance = 1e-12) + expect_false(anyNA(at$value)) + expect_identical(at[c("filled", "dist_nearest", "dist_ratio")], + want[c("filled", "dist_nearest", "dist_ratio")]) + } + # The other way round: character seeds beside a summary and rows with integer IDs. + chr <- L$seeds + chr$cell_id <- as.character(chr$cell_id) + expect_identical(.va_at(L, L$held, seeds = chr), same) +}) + +test_that("a whole number held as a double is matched by its digits, whichever layer holds it so", { + L <- .va_gap() + same <- .va_at(L, L$held) + # A cell that holds held-out rows and that filled rows take their value from gets the + # ID 100000, which as.character() writes in another way for a double than for an integer. + expect_identical(as.character(1e5), "1e+05") + expect_identical(as.character(100000L), "100000") + k0 <- intersect(same$filled_from[same$filled], same$cell_id[!same$filled])[1L] + expect_false(is.na(k0)) + shift <- function(x) x + (100000L - k0) + int <- function(layer) { layer$cell_id <- shift(layer$cell_id); layer } + dbl <- function(layer) { layer$cell_id <- as.numeric(shift(layer$cell_id)); layer } + cases <- list(values = list(dbl, int, int), points = list(int, dbl, int), + seeds = list(int, int, dbl), all = list(dbl, dbl, dbl)) + for (nm in names(cases)) { + f <- cases[[nm]] + at <- .va_at(L, L$held, values = f[[1L]](L$pooled), points = f[[2L]](L$asg), + seeds = f[[3L]](L$seeds)) + expect_type(at$cell_id, if (nm %in% c("values", "all")) "double" else "integer") + expect_type(at$filled_from, typeof(at$cell_id)) + expect_identical(as.integer(at$cell_id), shift(same$cell_id)) + expect_identical(as.integer(at$filled_from), shift(same$filled_from)) + expect_true(any(at$cell_id == 1e5) && any(at$filled_from == 1e5, na.rm = TRUE)) + expect_identical(.va_cols(at[-c(1L, 7L)]), .va_cols(same[-c(1L, 7L)])) + } + # By the polygons, whose IDs the assignment hands back in the class the summary holds. + at <- .va_at(L, L$held, values = dbl(L$pooled), points = int(L$asg), seeds = NULL) + want <- .va_at(L, L$held, seeds = NULL) + expect_type(at$cell_id, "double") + expect_identical(as.integer(at$cell_id), shift(want$cell_id)) + expect_identical(.va_cols(at[-c(1L, 7L)]), .va_cols(want[-c(1L, 7L)])) +}) + +test_that("a cell the summary has no row for keeps its ID, in the class of the summary's IDs, and is filled", { + L <- .va_full() + # One more seed on a held-out location, for a cell no row was assigned to. + extra <- sf::st_sf(seed_id = 9999L, method = "by hand", cell_id = 9999L, + geometry = sf::st_geometry(L$held)[7L]) + seeds <- rbind(L$seeds[c("seed_id", "method", "cell_id")], extra) + at <- .va_at(L, L$held, seeds = seeds) + expect_identical(at$cell_id[7L], 9999L) + # The locations nearest the new seed: that one, and those around it. + mine <- at$cell_id == 9999L + expect_lt(sum(mine), 10L) + expect_true(all(at$filled[mine])) + expect_false(anyNA(at$filled_from[mine])) + expect_identical(at$value[mine], + L$pooled$..pooled_resp_z[match(at$filled_from[mine], L$pooled$cell_id)]) + expect_identical(.va_cols(at[!mine, ]), .va_cols(.va_at(L, L$held)[!mine, ])) + # A summary without the cells' polygons, with IDs as text. + values <- sf::st_drop_geometry(L$pooled) + values$cell_id <- as.character(values$cell_id) + chr <- .va_at(L, L$held, values = values, seeds = seeds) + expect_identical(chr$cell_id[7L], "9999") + expect_identical(chr$cell_id, as.character(at$cell_id)) + expect_identical(chr$value, at$value) + # A cell the summary has no row for has no value to give: a location filled from it + # gets NA. + drop <- at$filled_from[7L] + less <- .va_at(L, L$held, values = L$pooled[L$pooled$cell_id != drop, ], seeds = seeds) + expect_identical(less$filled_from[7L], drop) + expect_true(is.na(less$value[7L])) + # A location in such a cell is not filled when the cell holds scored rows: it has NA. + busy <- as.integer(names(which.max(table(at$cell_id[!mine])))) + hit <- at$cell_id == busy + expect_gt(sum(hit), 1L) + less <- .va_at(L, L$held, values = L$pooled[L$pooled$cell_id != busy, ], seeds = seeds) + expect_identical(less$cell_id, at$cell_id) + expect_identical(less$filled[hit], rep(FALSE, sum(hit))) + expect_true(all(is.na(less$value[hit])) && all(is.na(less$filled_from[hit]))) + expect_identical(.va_cols(less[!hit & !mine, ]), .va_cols(at[!hit & !mine, ])) + # Seeds whose IDs the summary's integer column cannot hold: both ID columns are text, + # and no ID is lost. + named <- seeds + named$cell_id <- as.character(named$cell_id) + named$cell_id[nrow(named)] <- "new-7" + chr <- .va_at(L, L$held, seeds = named) + expect_type(chr$cell_id, "character") + expect_type(chr$filled_from, "character") + expect_identical(chr$cell_id, ifelse(mine, "new-7", as.character(at$cell_id))) + expect_identical(chr$filled_from, as.character(at$filled_from)) + expect_identical(.va_cols(chr[-c(1L, 7L)]), .va_cols(at[-c(1L, 7L)])) +}) + + +# ---- What passes through; other CRSs; empty geometry ------------------------------ + +test_that("`estimate` and the interval columns follow the summary", { + L <- .va_full() + pooled <- .va_at(L, L$held) + expect_identical(names(pooled), c("cell_id", "value", "estimate", "obs_lo", "obs_hi", "filled", + "filled_from", "dist_nearest", "dist_ratio")) + expect_identical(unique(pooled$estimate), "pooled") + expect_identical(attr(pooled, "values_at")$obs_level, 0.90) + expect_true(all(pooled$obs_lo < pooled$value & pooled$value < pooled$obs_hi)) + plain <- .va_at(L, L$held, values = L$plain) + expect_identical(names(plain), c("cell_id", "value", "estimate", "filled", "filled_from", + "dist_nearest", "dist_ratio")) + expect_identical(unique(plain$estimate), "mean") + expect_null(attr(plain, "values_at")$obs_level) + expect_true("obs_level" %in% names(attr(plain, "values_at"))) + expect_identical(plain[c("cell_id", "filled", "filled_from", "dist_nearest", "dist_ratio")], + pooled[c("cell_id", "filled", "filled_from", "dist_nearest", "dist_ratio")]) + # Pooled values without an interval: no interval columns, and the pooled value is read. + none <- L$pooled[setdiff(names(L$pooled), c("..obs_lo_resp_z", "..obs_hi_resp_z"))] + at <- .va_at(L, L$held, values = none) + expect_identical(names(at), names(plain)) + expect_identical(at$value, pooled$value) + expect_identical(unique(at$estimate), "pooled") + expect_null(attr(at, "values_at")$obs_level) + # A frame that kept the columns and lost its record: the level is not known. + bare <- L$pooled + attr(bare, "pooled") <- NULL + expect_identical(attr(.va_at(L, L$held, values = bare), "values_at")$obs_level, NA_real_) + expect_identical(.va_at(L, L$held, values = bare)$obs_lo, pooled$obs_lo) + # The record names the estimate the column holds, with or without the summary's record. + expect_identical(attr(.va_at(L, L$held, values = bare), "values_at")$estimate, "pooled") + expect_identical(unique(.va_at(L, L$held, values = bare)$estimate), "pooled") + expect_identical(attr(plain, "values_at")$estimate, "mean") +}) + +test_that("a column summarised as response and as predictor is read as the response; a predictor by its own columns", { + L <- .va_full() + both <- suppressWarnings( + summarize_by_cell(L$asg, "z", predictor_vars = c("z", "w"), id_col = "cell_id", + cells_sf = L$tess$cells, estimate = "pooled", obs_level = 0.90)) + expect_true(all(c("..pooled_resp_z", "..pooled_pred_z", "..pooled_pred_w", "resp_mean_z", + "pred_mean_z", "pred_mean_w", "..obs_lo_pred_w") %in% names(both))) + want <- .va_at(L, L$held) + # The predictor's copies moved, so that the two can be told apart. + moved <- both + for (nm in c("..pooled_pred_z", "pred_mean_z", "..obs_lo_pred_z", "..obs_hi_pred_z")) + moved[[nm]] <- moved[[nm]] + 1000 + at <- .va_at(L, L$held, values = moved) + expect_identical(at$value, want$value) + expect_identical(at$obs_lo, want$obs_lo) + # The same for plain means. + plain <- sf::st_drop_geometry(moved)[c("cell_id", "resp_mean_z", "pred_mean_z", "pred_mean_w")] + expect_identical(.va_at(L, L$held, values = plain)$value, + .va_at(L, L$held, values = L$plain)$value) + # A predictor: its pooled value and interval, then its mean. + w <- .va_at(L, L$held, values = both, response = "w") + src <- match(w$cell_id, both$cell_id) + expect_identical(w$value, both$..pooled_pred_w[src]) + expect_identical(w$obs_hi, both$..obs_hi_pred_w[src]) + expect_identical(attr(w, "values_at")$column, "w") + expect_identical(.va_at(L, L$held, values = plain, response = "w")$value, + both$pred_mean_w[src]) +}) + +test_that("`newdata` in lon/lat or another CRS is placed where the rows are", { + L <- .va_gap() + for (seeds in list(L$seeds, NULL)) { + want <- .va_at(L, L$held, seeds = seeds) + for (crs in c(4326, 3857, 32616)) { + at <- .va_at(L, sf::st_transform(L$held, crs), seeds = seeds) + expect_identical(at[1:7], want[1:7]) + expect_equal(at$dist_nearest, want$dist_nearest, tolerance = 1e-8) + expect_identical(attr(at, "values_at"), attr(want, "values_at")) + } + } + # Seeds in lon/lat. + expect_identical(.va_at(L, L$held, seeds = sf::st_transform(L$seeds, 4326))[1:7], + .va_at(L, L$held)[1:7]) +}) + +test_that("a row with an empty geometry is NA in every column, and a far coordinate is no location", { + L <- .va_full() + # Row 3 is empty; rows 5, 7, 8 and 9 have a coordinate too large to take a distance + # from (x, then y alone) or one that is not finite. + g <- sf::st_geometry(L$held[1:9, ]) + g[[3L]] <- sf::st_point() + g[[5L]] <- sf::st_point(c(1e200, 5e6)) + g[[7L]] <- sf::st_point(c(5e5, -1e200)) + g[[8L]] <- sf::st_point(c(Inf, 5e6)) + g[[9L]] <- sf::st_point(c(5e5, NaN)) + newdata <- sf::st_sf(k = 1:9, geometry = g) + for (seeds in list(L$seeds, NULL)) { + r <- .va_catch(.va_at(L, newdata, seeds = seeds)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(nrow(at), 9L) + for (i in c(3L, 5L, 7L, 8L, 9L)) expect_true(all(is.na(unlist(at[i, ])))) + expect_type(at$estimate, "character") + expect_type(at$filled, "logical") + keep <- c(1L, 2L, 4L, 6L) + want <- .va_at(L, L$held[keep, ], seeds = seeds) + expect_identical(.va_cols(at[keep, ]), .va_cols(want)) + expect_identical(attr(at, "values_at")$filled, sum(at$filled, na.rm = TRUE)) + } + # No location at all: no row, and the record still describes the scored rows. + none <- .va_at(L, L$held[0, ]) + expect_identical(dim(none), c(0L, 9L)) + expect_identical(attr(none, "values_at")$n, 480L) + expect_identical(attr(none, "values_at")$filled, 0L) + expect_identical(dim(.va_at(L, L$held[0, ], seeds = NULL)), c(0L, 9L)) +}) + +test_that("a feature that is not a point is read at the point coerce_to_points() gives it", { + L <- .va_full() + squares <- sf::st_buffer(L$held[1:30, ], 400, endCapStyle = "SQUARE") + expect_true(all(sf::st_geometry_type(squares) == "POLYGON")) + for (seeds in list(L$seeds, NULL)) + expect_identical(.va_at(L, squares, seeds = seeds), + .va_at(L, coerce_to_points(squares, "auto"), seeds = seeds)) + # A square is read at its centre, which is the held-out location. + expect_identical(.va_at(L, squares)$cell_id, .va_at(L, L$held[1:30, ])$cell_id) + # No column of `newdata` is read: one called like a column of the result, or the ID. + odd <- L$held[1:30, ] + odd$cell_id <- "x"; odd$value <- -1; odd$filled <- NA + expect_identical(.va_at(L, odd, seeds = NULL), .va_at(L, L$held[1:30, ], seeds = NULL)) +}) + +# Two cells made by hand: cell 1 is two squares of side 10, at x from 0 and from 20, and +# cell 2 the square between them; two rows in each square. +.va_parts <- function() .va_keep("parts", { + square <- function(x0, y0 = 0, side = 10) + sf::st_polygon(list(cbind(5e5 + x0 + c(0, side, side, 0, 0), 5e6 + y0 + c(0, 0, side, side, 0)))) + cells <- sf::st_sf(cell_id = 1:2, + geometry = sf::st_sfc(sf::st_multipolygon(list(square(0), square(20))), + square(10), crs = 32617)) + rows <- .va_points(c(2, 8, 22, 28, 12, 18), rep(5, 6L), cell_id = c(1L, 1L, 1L, 1L, 2L, 2L), + z = c(1, 2, 3, 2, 10, 12)) + list(square = square, cells = cells, rows = rows, + values = summarize_by_cell(rows, "z", id_col = "cell_id", cells_sf = cells, + estimate = "mean")) +}) + +test_that("a cell of several parts holds the locations in each of them", { + T <- .va_parts() + expect_identical(as.character(sf::st_geometry_type(T$values)), c("MULTIPOLYGON", "POLYGON")) + r <- .va_catch(cell_values_at(.va_points(c(5, 25, 15, 40), c(3, 7, 5, 5)), T$values, T$rows, "z", + id_col = "cell_id")) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(at$cell_id, c(1L, 1L, 2L, NA)) + expect_identical(at$value, c(2, 2, 11, 2)) + expect_identical(at$filled, c(FALSE, FALSE, FALSE, TRUE)) + expect_identical(at$filled_from, c(NA, NA, NA, 1L)) + expect_identical(at$dist_nearest, c(sqrt(13), sqrt(13), 3, 12)) +}) + +test_that("a layer that mixes points with other features is read feature by feature", { + T <- .va_parts() + # A point in the first square, a square of side 4 inside the second cell, and a point + # without coordinates. + mixed <- sf::st_sf(k = 1:3, geometry = sf::st_sfc(sf::st_point(c(5e5 + 5, 5e6 + 3)), + T$square(13, 2, 4), sf::st_point(), + crs = 32617)) + expect_identical(as.character(sf::st_geometry_type(mixed)), c("POINT", "POLYGON", "POINT")) + seeds <- .va_points(c(5, 15, 25), c(5, 5, 5), cell_id = c(1L, 2L, 3L)) + for (s in list(NULL, seeds)) { + r <- .va_catch(cell_values_at(mixed, T$values, T$rows, "z", id_col = "cell_id", seeds = s)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(nrow(at), 3L) + expect_identical(at$cell_id, c(1L, 2L, NA)) + expect_identical(at$value, c(2, 11, NA)) + expect_identical(at$filled, c(FALSE, FALSE, NA)) + # The square is read at its centre, (15, 4). + expect_identical(at$dist_nearest, c(sqrt(13), sqrt(10), NA)) + } +}) + + +# ---- By the polygons: the CRS handed over, and what the assignment says --------------- + +# The WARN lines the package logs while `expr` runs, in order, and nothing on the console. +.va_logged <- function(env = parent.frame()) { + log <- new.env(parent = emptyenv()) + log$lines <- character(0) + testthat::local_mocked_bindings(.sk_log = function(level, msg, raising = FALSE) { + if (identical(attr(level, "level"), "WARN")) log$lines <- c(log$lines, msg) + invisible(msg) + }, .env = env) + log +} +# The assignment, with what it is handed kept in `seen`. +.va_watch_assignment <- function(env = parent.frame()) { + seen <- new.env(parent = emptyenv()) + real <- assign_features_to_polygons + force(real) + testthat::local_mocked_bindings(assign_features_to_polygons = function(features_sf, polygons_sf, ...) { + seen$features <- sf::st_crs(features_sf) + seen$polygons <- sf::st_crs(polygons_sf) + seen$names <- names(polygons_sf) + seen$class <- class(polygons_sf) + seen$n <- nrow(polygons_sf) + real(features_sf, polygons_sf, ...) + }, .env = env) + seen +} + +test_that("without a CRS on `newdata` and `points` the locations are placed where the summary measured, not where the polygons' CRS says", { + L <- .va_full() + bare <- function(x) sf::st_set_crs(x, NA) + seen <- .va_watch_assignment() + want <- .va_at(L, L$held, seeds = NULL) + expect_identical(seen$features, sf::st_crs(32617)) + # Beside polygons with a CRS, locations with one go to the assignment as they arrived: + # it transforms them once. + in_3857 <- .va_at(L, sf::st_transform(L$held, 3857), seeds = NULL) + expect_identical(seen$features, sf::st_crs(3857)) + expect_identical(seen$polygons, sf::st_crs(32617)) + expect_identical(in_3857[1:7], want[1:7]) + # The working CRS is the record's, and the polygons are in it: no warning of the + # assignment about a layer the caller did not hand it. + r <- .va_catch(.va_at(L, bare(L$held), points = bare(L$asg), seeds = NULL)) + expect_identical(.va_classes(r), character(0)) + expect_identical(r$value, want) + expect_identical(seen$features, sf::st_crs(32617)) + # The polygons in another CRS than the working one: a summary transformed for a map, + # which keeps its record. + on_map <- sf::st_transform(L$pooled, 4326) + expect_identical(attr(on_map, "count_rule")$crs, sf::st_crs(32617)) + want_map <- .va_at(L, L$held, values = on_map, seeds = NULL) + expect_false(anyNA(want_map$cell_id)) + r <- .va_catch(.va_at(L, bare(L$held), values = on_map, points = bare(L$asg), seeds = NULL)) + expect_identical(.va_classes(r), character(0)) + expect_identical(r$value, want_map) + expect_identical(seen$features, sf::st_crs(32617)) + expect_identical(seen$polygons, sf::st_crs(4326)) +}) + +test_that("cells without a CRS are read as they were for the rows, whatever CRS `newdata` arrives in", { + L <- .va_full() + # 36 square cells over the layer, without a CRS, beside rows with one. + grid <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox(rbind(L$rows["z"], L$held["z"]))), n = c(6, 6)) + units <- sf::st_sf(unit = sprintf("U%02d", seq_along(grid)), geometry = sf::st_set_crs(grid, NA)) + asg <- suppressWarnings(assign_features_to_polygons(L$rows, units, polygon_id_col = "unit", + quiet = TRUE)) + out <- suppressWarnings(summarize_by_cell(asg, "z", id_col = "unit", cells_sf = units, + estimate = "mean")) + expect_true(is.na(sf::st_crs(out))) + expect_identical(sf::st_crs(asg), sf::st_crs(32617)) + seen <- .va_watch_assignment() + call <- function(newdata) .va_catch(cell_values_at(newdata, out, asg, "z", id_col = "unit")) + base <- call(L$held) + expect_false(anyNA(base$value$unit)) + expect_false(any(base$value$filled)) + # The cells of the rows' own coordinates. + inside <- sf::st_intersects(sf::st_set_crs(sf::st_geometry(L$held), NA), sf::st_geometry(units)) + expect_identical(base$value$unit, units$unit[vapply(inside, function(i) i[1L], integer(1))]) + for (crs in c(4326, 3857, 32616)) { + r <- call(sf::st_transform(L$held, crs)) + expect_identical(r$value[1:5], base$value[1:5]) + expect_equal(r$value$dist_nearest, base$value$dist_nearest, tolerance = 1e-8) + # Handed over in the CRS of `points`; the assignment stamps the cells with it and says so. + expect_identical(seen$features, sf::st_crs(32617)) + expect_true(is.na(seen$polygons)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "harmonize_crs(): `b` has no CRS", fixed = TRUE) + } + # Rows in lon/lat beside cells in degrees without a CRS: the CRS of `points`, not the + # projected one the distances are measured in. + rows_ll <- sf::st_transform(L$rows, 4326) + grid_ll <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox(sf::st_transform(rbind(L$rows["z"], L$held["z"]), + 4326))), n = c(6, 6)) + units_ll <- sf::st_sf(unit = sprintf("U%02d", seq_along(grid_ll)), + geometry = sf::st_set_crs(grid_ll, NA)) + asg_ll <- suppressWarnings(assign_features_to_polygons(rows_ll, units_ll, polygon_id_col = "unit", + keep_unassigned = TRUE, quiet = TRUE)) + out_ll <- suppressWarnings(summarize_by_cell(asg_ll, "z", id_col = "unit", cells_sf = units_ll, + estimate = "mean")) + in_ll <- suppressWarnings(cell_values_at(sf::st_transform(L$held, 4326), out_ll, asg_ll, "z", + id_col = "unit")) + expect_identical(seen$features, sf::st_crs(4326)) + in_utm <- suppressWarnings(cell_values_at(L$held, out_ll, asg_ll, "z", id_col = "unit")) + expect_identical(seen$features, sf::st_crs(4326)) + expect_false(isTRUE(sf::st_is_longlat(attr(in_utm, "values_at")$crs))) + expect_identical(in_utm[1:5], in_ll[1:5]) + # Nothing with a CRS, the cells neither: the coordinates of all three as they are, and + # no CRS for the assignment to stamp on anything. The one warning is + # ensure_projected()'s, about the rows it took for lon/lat. + bare <- function(x) sf::st_set_crs(x, NA) + r <- .va_catch(cell_values_at(bare(sf::st_transform(L$held, 4326)), out_ll, bare(asg_ll), "z", + id_col = "unit")) + expect_true(is.na(seen$features)) + expect_true(is.na(seen$polygons)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), + "ensure_projected(): CRS is missing; assuming EPSG:4326", fixed = TRUE) + expect_identical(r$value$unit, units_ll$unit[vapply( + sf::st_intersects(bare(sf::st_geometry(sf::st_transform(L$held, 4326))), + sf::st_geometry(units_ll)), function(i) i[1L], integer(1))]) + # The same in planar coordinates: no warning at all. + r <- .va_catch(cell_values_at(bare(L$held), out, bare(asg), "z", id_col = "unit")) + expect_identical(.va_classes(r), character(0)) + expect_true(is.na(seen$features)) + expect_identical(r$value[1:5], base$value[1:5]) +}) + +test_that("the assignment is handed the cells' polygons and IDs alone: a grouped summary, a row without an ID", { + L <- .va_full() + want <- .va_at(L, L$held, seeds = NULL) + seen <- .va_watch_assignment() + grouped <- dplyr::group_by(L$pooled, cell_id) + expect_s3_class(grouped, "grouped_df") + at <- .va_at(L, L$held, values = grouped, seeds = NULL) + expect_identical(.va_cols(at[1:7]), .va_cols(want[1:7])) + expect_identical(seen$names, c("cell_id", "geometry")) + expect_identical(seen$class, c("sf", "data.frame")) + expect_identical(seen$n, nrow(L$pooled)) + # A row of the summary without an ID is no cell: its polygon holds no location, and the + # locations in it are filled from the cell of their nearest scored row, whose value the + # summary no longer has under that ID. + gone <- as.integer(names(which.max(table(want$cell_id)))) + values <- L$pooled + values$cell_id[values$cell_id == gone] <- NA + at <- .va_at(L, L$held, values = values, seeds = NULL) + hit <- want$cell_id == gone + expect_identical(seen$n, nrow(L$pooled) - 1L) + expect_true(all(is.na(at$cell_id[hit]))) + expect_identical(at$filled, hit) + expect_identical(.va_cols(at[!hit, ]), .va_cols(want[!hit, ])) + # No ID at all: no location has a cell, and the assignment is not called. + seen$n <- NULL + values$cell_id <- NA_integer_ + at <- .va_at(L, L$held, values = values, seeds = NULL) + expect_null(seen$n) + expect_identical(at$filled, rep(TRUE, nrow(at))) + expect_true(all(is.na(at$cell_id))) +}) + +test_that("the warning that no location is in a polygon is neither raised nor logged, and every other warning of the assignment is", { + L <- .va_full() + bare <- function(x) sf::st_set_crs(x, NA) + far <- .va_points(c(-2e4, -3e4, 3e5), c(5e4, -3e4, 3e5)) + log <- .va_logged() + direct <- function() + .va_catch(assign_features_to_polygons(far, L$pooled, polygon_id_col = "cell_id", + keep_unassigned = TRUE, quiet = TRUE)) + # The assignment raises the warning for these locations, and logs its line. + expect_identical(.va_classes(direct()), "spatialkit_unassigned") + expect_length(log$lines, 1L) + expect_match(log$lines, "none of the 3 feature(s) fall inside any polygon", fixed = TRUE) + # Inside the call: neither. + log$lines <- character(0) + r <- .va_catch(.va_at(L, far, seeds = NULL)) + expect_identical(.va_classes(r), character(0)) + expect_identical(log$lines, character(0)) + expect_identical(r$value$filled, rep(TRUE, 3L)) + # Once the call has returned the warning is the assignment's again. + expect_null(.answered_state$classes) + expect_identical(.va_classes(direct()), "spatialkit_unassigned") + expect_length(log$lines, 1L) + # Also when the assignment stops: two polygons with one ID. + twice <- L$pooled + twice$cell_id[2L] <- twice$cell_id[1L] + expect_match(conditionMessage(.va_error(.va_at(L, far, values = twice, seeds = NULL))), + "assign_features_to_polygons(): the polygon ID column 'cell_id'", fixed = TRUE) + expect_null(.answered_state$classes) + expect_identical(.va_classes(direct()), "spatialkit_unassigned") + # Another warning of the assignment reaches the caller, with its line. Nothing here + # names a CRS but the polygons, so the assignment stamps theirs on the locations. + values <- L$pooled + rule <- attr(values, "count_rule"); rule$crs <- sf::NA_crs_ + attr(values, "count_rule") <- rule + pooled <- attr(values, "pooled"); pooled$crs <- sf::NA_crs_ + attr(values, "pooled") <- pooled + log$lines <- character(0) + r <- .va_catch(.va_at(L, bare(L$held), values = values, points = bare(L$asg), seeds = NULL)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "harmonize_crs(): `a` has no CRS", fixed = TRUE) + expect_identical(log$lines, conditionMessage(r$warnings[[1L]])) + expect_true(is.na(attr(r$value, "values_at")$crs)) + expect_identical(.va_cols(r$value), .va_cols(.va_at(L, L$held, seeds = NULL))) + # The same with every location outside: that warning passes, the other does not. + log$lines <- character(0) + r <- .va_catch(.va_at(L, bare(far), values = values, points = bare(L$asg), seeds = NULL)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "harmonize_crs(): `a` has no CRS", fixed = TRUE) + expect_identical(log$lines, conditionMessage(r$warnings[[1L]])) + expect_identical(r$value$filled, rep(TRUE, 3L)) +}) + +test_that("a span that answers for a class keeps that class back and no other, and closes to what was open before", { + log <- .va_logged() + raise <- function(class) .va_classes(.va_catch(.warn_classed(class, "%s is said", class[1L]))) + expect_null(.answered_state$classes) + expect_identical(raise("spatialkit_one"), "spatialkit_one") + outer <- .answer_for_classed("spatialkit_one") + expect_identical(raise("spatialkit_one"), character(0)) + expect_identical(raise("spatialkit_two"), "spatialkit_two") + # A condition of several classes is kept back when any of them is answered for. + expect_identical(raise(c("spatialkit_three", "spatialkit_one")), character(0)) + # A span opened inside another adds its class to the outer one's. + inner <- .answer_for_classed("spatialkit_two") + expect_identical(raise("spatialkit_two"), character(0)) + expect_identical(raise("spatialkit_one"), character(0)) + inner() + expect_identical(.answered_state$classes, "spatialkit_one") + expect_identical(raise("spatialkit_two"), "spatialkit_two") + expect_identical(raise("spatialkit_one"), character(0)) + outer() + expect_null(.answered_state$classes) + expect_identical(raise("spatialkit_one"), "spatialkit_one") + expect_identical(log$lines, c("spatialkit_one is said", "spatialkit_two is said", + "spatialkit_two is said", "spatialkit_one is said")) + # A warning kept back carries no fields away and returns its text unseen. + done <- .answer_for_classed("spatialkit_one") + expect_invisible(.warn_classed("spatialkit_one", "%d", 3L, data = list(n = 3L))) + expect_identical(.warn_classed("spatialkit_one", "%d", 3L), "3") + done() +}) + + +# ---- The record of the call ------------------------------------------------------ + +test_that("attr(, \"values_at\") says how the cells were found and what the distances are measured against", { + L <- .va_gap() + at <- .va_at(L, L$held) + rec <- attr(at, "values_at") + expect_s3_class(rec, "spatialkit_values_at") + expect_identical(names(rec), c("assignment", "crs", "column", "estimate", "obs_level", "n", + "locations", "spacing", "filled", "count_rule")) + expect_identical(rec$assignment, "seeds") + expect_identical(attr(.va_at(L, L$held, seeds = NULL), "values_at")$assignment, "polygons") + expect_identical(rec$crs, attr(L$pooled, "count_rule")$crs) + expect_identical(rec$column, "z") + expect_identical(rec$estimate, "pooled") + expect_identical(rec$obs_level, 0.90) + scored <- is.finite(L$asg$z) + expect_identical(rec$n, sum(scored)) + expect_identical(rec$locations, sum(scored)) + # The spacing: the median, over the scored locations, of the distance to the nearest other. + d <- as.matrix(stats::dist(.va_xy(L$asg)[scored, ])) + diag(d) <- Inf + expect_equal(rec$spacing, stats::median(apply(d, 1L, min)), tolerance = 1e-12) + expect_identical(at$dist_ratio, at$dist_nearest / rec$spacing) + expect_identical(rec$filled, sum(at$filled)) + expect_gt(rec$filled, 0L) + expect_identical(rec$count_rule, attr(L$pooled, "count_rule")) + expect_identical(rec$count_rule$check, list(estimate = "match", cells = "match")) + # Plain means of cells sized for pooled values carry the record with its mismatch. + expect_identical(attr(.va_at(L, L$held, values = L$plain), "values_at")$count_rule, + attr(L$plain, "count_rule")) + # Without a record: NULL, and the CRS the pooled columns were measured in. + bare <- L$pooled + attr(bare, "count_rule") <- NULL + no_rule <- attr(.va_at(L, L$held, values = bare), "values_at") + expect_null(no_rule$count_rule) + expect_true("count_rule" %in% names(no_rule)) + expect_identical(no_rule$crs, attr(L$pooled, "pooled")$crs) + # The distances are those from the scored rows: a row without a response is not one. + unscored <- L$asg[!scored, ] + expect_true(all(.va_at(L, unscored)$dist_nearest > 0)) +}) + +test_that("the working CRS is the record's, then the pooled columns', then the rows' own", { + L <- .va_full() + want <- .va_at(L, L$held) + # The rows and the new locations in another projected CRS than the count was scored in. + rows <- sf::st_transform(L$asg, 3857) + held <- sf::st_transform(L$held, 3857) + at <- cell_values_at(held, L$pooled, rows, "z", id_col = "cell_id", seeds = L$seeds) + expect_identical(attr(at, "values_at")$crs, sf::st_crs(32617)) + expect_identical(at[1:7], want[1:7]) + expect_equal(at$dist_nearest, want$dist_nearest, tolerance = 1e-8) + # The record's CRS comes before the pooled columns'. + values <- L$pooled + other <- attr(values, "pooled"); other$crs <- sf::st_crs(3857) + attr(values, "pooled") <- other + at <- cell_values_at(held, values, rows, "z", id_col = "cell_id", seeds = L$seeds) + expect_identical(attr(at, "values_at")$crs, sf::st_crs(32617)) + # The record gone: the pooled columns' CRS. + values <- L$pooled + attr(values, "count_rule") <- NULL + at <- cell_values_at(held, values, rows, "z", id_col = "cell_id", seeds = L$seeds) + expect_identical(attr(at, "values_at")$crs, sf::st_crs(32617)) + expect_equal(at$dist_nearest, want$dist_nearest, tolerance = 1e-8) + # Both gone: the rows' own CRS, in which a distance is another number (Web Mercator + # stretches these latitudes by about 1.4). + attr(values, "pooled") <- NULL + at <- cell_values_at(held, values, rows, "z", id_col = "cell_id", seeds = L$seeds) + expect_identical(attr(at, "values_at")$crs, sf::st_crs(3857)) + expect_gt(stats::median(at$dist_nearest / want$dist_nearest), 1.3) + # A record whose CRS is geographic or missing is not a CRS to measure in. + for (crs in list(sf::st_crs(4326), sf::NA_crs_)) { + values <- L$pooled + rule <- attr(values, "count_rule"); rule$crs <- crs + attr(values, "count_rule") <- rule + at <- cell_values_at(held, values, rows, "z", id_col = "cell_id", seeds = L$seeds) + expect_identical(attr(at, "values_at")$crs, sf::st_crs(32617)) + } +}) + +test_that("the record prints what was read and what the distances mean", { + L <- .va_gap() + at <- .va_at(L, L$held) + rec <- attr(at, "values_at") + expect_identical(.va_print(rec), c( + "Cell values at other locations: z, the pooled value", + " cell : of the nearest seed (the Voronoi cell before its clip to the cover)", + " interval : 90% for ONE OBSERVATION (obs_lo, obs_hi), centred on the value", + sprintf(" scored rows : %d rows at %d locations, measured in EPSG:32617", rec$n, rec$locations), + sprintf(" spacing : %s, the median distance from a scored location to the", + format(signif(rec$spacing, 4))), + " nearest other; dist_ratio is dist_nearest over it", + sprintf(" filled : %d locations have no cell with a value and take that of", rec$filled), + " the cell of the nearest scored row (filled_from)", + sprintf(" count : %d cells, set by size (the summary's record, in `count_rule`)", + rec$count_rule$cells), + "Away from the observations no interval here is calibrated.")) + utils::capture.output(returned <- print(rec)) + expect_identical(returned, rec) + # Plain means by the polygons, nothing filled, no record of the count. + F <- .va_full() + values <- F$plain + attr(values, "count_rule") <- NULL + rec <- attr(.va_at(F, F$held[1:10, ], values = values, seeds = NULL), "values_at") + expect_identical(.va_print(rec), c( + "Cell values at other locations: z, the plain mean", + " cell : the polygon of `values` that holds the location", + " scored rows : 480 rows at 480 locations, measured in EPSG:32617", + sprintf(" spacing : %s, the median distance from a scored location to the", + format(signif(rec$spacing, 4))), + " nearest other; dist_ratio is dist_nearest over it", + " filled : no location")) + # One filled location, one scored row, no CRS, no spacing. + one <- structure(list(assignment = "seeds", crs = sf::NA_crs_, column = "v", estimate = "mean", + obs_level = NULL, n = 1L, locations = 1L, spacing = NA_real_, + filled = 1L, count_rule = NULL), class = "spatialkit_values_at") + expect_identical(.va_print(one), c( + "Cell values at other locations: v, the plain mean", + " cell : of the nearest seed (the Voronoi cell before its clip to the cover)", + " scored rows : 1 row at 1 location, coordinates without a CRS", + " spacing : not available: the scored rows sit on one location, so dist_ratio is NA", + " filled : 1 location has no cell with a value and takes that of", + " the cell of the nearest scored row (filled_from)")) + # An interval whose level the frame did not keep. + one$obs_level <- NA_real_ + expect_true(" interval : for ONE OBSERVATION (obs_lo, obs_hi), centred on the value" %in% + .va_print(one)) +}) + +test_that("the print method of the record is registered", { + registered <- getNamespaceInfo(asNamespace("spatialkit"), "S3methods") + expect_true(any(registered[, 1L] == "print" & registered[, 2L] == "spatialkit_values_at")) + expect_true("cell_values_at" %in% getNamespaceExports("spatialkit")) + expect_identical(names(formals(cell_values_at)), + c("newdata", "values", "points", "response_var", "id_col", "seeds")) + expect_identical(formals(cell_values_at)$id_col, "poly_id") + expect_null(formals(cell_values_at)$seeds) +}) + + +# ---- Edge cases ------------------------------------------------------------------ + +test_that("a seed with an NA ID has no cell: the locations nearest it are filled", { + L <- .va_full() + want <- .va_at(L, L$held) + expect_false(any(want$filled)) + # The seed of the cell that holds the most held-out rows. + gone <- as.integer(names(which.max(table(want$cell_id)))) + seeds <- L$seeds + seeds$cell_id[seeds$cell_id == gone] <- NA + at <- .va_at(L, L$held, seeds = seeds) + hit <- want$cell_id == gone + expect_gt(sum(hit), 1L) + expect_true(all(is.na(at$cell_id[hit]))) + expect_identical(at$filled, hit) + # The cell they are filled from is the one that holds their nearest scored row. + u <- .va_xy(L$asg) + nearest <- .va_nearest(.va_xy(L$held)[hit, , drop = FALSE], u) + expect_identical(at$filled_from[hit], L$asg$cell_id[nearest]) + expect_identical(at$value[hit], + L$pooled$..pooled_resp_z[match(at$filled_from[hit], L$pooled$cell_id)]) + expect_identical(.va_cols(at[!hit, ]), .va_cols(want[!hit, ])) + # A row of the summary without an ID (the rows no cell holds) is no cell either: a + # location without a cell does not take its value. + flat <- sf::st_drop_geometry(L$pooled) + stray <- flat[1L, ] + stray$cell_id <- NA + stray$..pooled_resp_z <- 999 + expect_identical(.va_cols(.va_at(L, L$held, values = rbind(flat, stray), seeds = seeds)), + .va_cols(at)) + # Several seeds without a cell are no repeated ID. + seeds$cell_id[1:3] <- NA + expect_identical(nrow(.va_at(L, L$held, seeds = seeds)), nrow(L$held)) + # A seed with an empty geometry is nearest to nothing. + moved <- L$seeds + g <- sf::st_geometry(moved) + g[[which(moved$cell_id == gone)]] <- sf::st_point() + moved <- sf::st_set_geometry(moved, g) + at <- .va_at(L, L$held, seeds = moved) + expect_false(any(at$cell_id == gone)) + expect_identical(.va_cols(at[!hit, ]), .va_cols(want[!hit, ])) +}) + +test_that("a seed outside a boundary that is not convex has NA in `index`; the help's recipe gives it its cell", { + # A square with a notch cut from the top; five seeds inside it and one in + # the notch, whose Voronoi cell, clipped, is the inner top of both arms. + U <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(0, 0), c(1000, 0), c(1000, 1000), c(550, 1000), c(550, 300), + c(450, 300), c(450, 1000), c(0, 1000), c(0, 0)))), crs = 32617)) + in_u <- function(x, y) !(x > 450 & x < 550 & y > 300) + g <- expand.grid(x = seq(25, 975, 50), y = seq(25, 975, 50)) + g <- g[in_u(g$x, g$y), ] + g$z <- local({ .va_seed(7); g$x / 500 + 0.3 * sin(g$y / 70) + stats::rnorm(nrow(g), 0, 0.1) }) + rows <- sf::st_as_sf(g, coords = c("x", "y"), crs = 32617) + seeds <- sf::st_as_sf(data.frame(x = c(150, 850, 150, 850, 500, 500), + y = c(150, 150, 650, 650, 150, 800)), + coords = c("x", "y"), crs = 32617) + tb <- .va_catch(build_tessellation(seeds, boundary = U, method = "voronoi", quiet = TRUE)) + expect_identical(.va_classes(tb), "spatialkit_unassigned") + tess <- tb$value + expect_identical(nrow(tess$cells), 6L) + expect_identical(which(is.na(tess$index)), 6L) + # The notch seed's cell is the one cell no seed lies in, and it holds scored rows. + lost <- setdiff(tess$cells$cell_id, tess$index) + expect_length(lost, 1L) + asg <- assign_features_to_polygons(rows, tess$cells, polygon_id_col = "cell_id") + expect_gt(sum(asg$cell_id == lost), 10L) + out <- summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "mean") + h <- expand.grid(x = seq(10, 990, 40), y = seq(10, 990, 40)) + h <- h[in_u(h$x, h$y), ] + newp <- sf::st_as_sf(h, coords = c("x", "y"), crs = 32617) + holds <- tess$cells$cell_id[vapply(sf::st_intersects(newp, tess$cells), + function(i) if (length(i)) i[1L] else NA_integer_, + integer(1))] + expect_false(anyNA(holds)) + there <- holds == lost + expect_gt(sum(there), 10L) + # With `index` alone: the locations nearest the notch seed have no cell and are + # filled, as step 3 says, some of them from a cell that does not hold them. + seeds$cell_id <- tess$index + at <- cell_values_at(newp, out, asg, "z", id_col = "cell_id", seeds = seeds) + expect_true(all(is.na(at$cell_id[there]))) + expect_identical(at$filled, there) + expect_identical(at$cell_id[!there], holds[!there]) + expect_true(any(at$filled_from[there] != lost)) + # The recipe of "Seeds outside the boundary". + own <- tess$cells[!tess$cells$cell_id %in% tess$index, ] + near <- sf::st_nearest_feature(sf::st_point_on_surface(sf::st_geometry(own)), + seeds) + seeds$cell_id[near] <- own$cell_id + expect_identical(seeds$cell_id, c(tess$index[1:5], lost)) + at <- cell_values_at(newp, out, asg, "z", id_col = "cell_id", seeds = seeds) + expect_identical(at$cell_id, holds) + expect_false(any(at$filled)) + expect_identical(at$value, out$resp_mean_z[match(holds, out$cell_id)]) +}) + +test_that("what `seeds` and `values` must be", { + L <- .va_full() + seeds_text <- paste0( + "cell_values_at(): `seeds` must be an sf POINT layer with a column 'cell_id' that gives ", + "each seed's cell; for cells from build_tessellation(seeds), set seeds$cell_id <- tess$index.") + # Two seeds with one ID: both have the cell of another, and both are counted. + twice <- L$seeds + twice$cell_id[2L] <- twice$cell_id[1L] + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, seeds = twice))), paste0( + "cell_values_at(): 2 seeds have the cell of another in `seeds$cell_id`; each seed stands ", + "for one cell. Set the column from the tessellation built on these seeds ", + "(seeds$cell_id <- tess$index).")) + twice$cell_id[3:4] <- twice$cell_id[1L] + expect_match(conditionMessage(.va_error(.va_at(L, L$held, seeds = twice))), + "cell_values_at(): 4 seeds have the cell of another", fixed = TRUE) + # Two pairs. + pairs <- L$seeds + pairs$cell_id[c(2L, 9L)] <- pairs$cell_id[c(1L, 8L)] + expect_match(conditionMessage(.va_error(.va_at(L, L$held, seeds = pairs))), + "cell_values_at(): 4 seeds have the cell of another", fixed = TRUE) + # A plain error, raised without a call. + e <- .va_error(.va_at(L, L$held, seeds = twice)) + expect_null(e$call) + expect_identical(class(e), c("simpleError", "error", "condition")) + # Seeds on one location share its cell and are no error: the same frame as without + # the repeats, wherever in `seeds` they stand. + own <- L$seeds[c("seed_id", "method", "cell_id")] + expect_identical(.va_at(L, L$held, seeds = rbind(own, own[c(5L, 9L), ])), .va_at(L, L$held)) + expect_identical(.va_at(L, L$held, seeds = rbind(own[c(9L, 9L), ], own)), .va_at(L, L$held)) + # A third seed elsewhere with their ID: all three are counted. + third <- rbind(own, own[5L, ]) + third$cell_id[1L] <- third$cell_id[5L] + expect_match(conditionMessage(.va_error(.va_at(L, L$held, seeds = third))), + "cell_values_at(): 3 seeds have the cell of another", fixed = TRUE) + # Seeds that differ in one coordinate alone are at two locations. + for (shift in list(c(1, 0), c(0, 1))) { + beside <- rbind(own, own[5L, ]) + g <- sf::st_geometry(beside) + g[[nrow(beside)]] <- sf::st_point(sf::st_coordinates(g[5L])[1L, 1:2] + shift) + expect_match(conditionMessage(.va_error(.va_at(L, L$held, seeds = sf::st_set_geometry(beside, g)))), + "cell_values_at(): 2 seeds have the cell of another", fixed = TRUE) + } + # A seed without a location and the ID of another is not a seed on its location. + nowhere <- rbind(own, own[5L, ]) + g <- sf::st_geometry(nowhere) + g[[nrow(nowhere)]] <- sf::st_point() + expect_match(conditionMessage(.va_error(.va_at(L, L$held, seeds = sf::st_set_geometry(nowhere, g)))), + "cell_values_at(): 2 seeds have the cell of another", fixed = TRUE) + # Seeds without the ID column; not points; not an sf layer. + bare <- L$seeds[c("seed_id", "method")] + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, seeds = bare))), seeds_text) + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, seeds = L$tess$cells))), + seeds_text) + expect_identical( + conditionMessage(.va_error(.va_at(L, L$held, seeds = sf::st_drop_geometry(L$seeds)))), + seeds_text) + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, seeds = 107L))), seeds_text) + # A summary without the cells' polygons, and no seeds. + flat <- sf::st_drop_geometry(L$pooled) + polygons_text <- paste0( + "cell_values_at(): `values` carries no cell polygons, so a location cannot be placed in a ", + "cell. Build `values` with `cells_sf`, or pass the seeds the cells were built on as `seeds` ", + "(seeds$cell_id <- tess$index).") + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, values = flat, seeds = NULL))), + polygons_text) + # A summary of no rows has no polygon either; with seeds it has no value for any cell. + expect_identical( + conditionMessage(.va_error(.va_at(L, L$held, values = L$pooled[0, ], seeds = NULL))), + polygons_text) + none <- .va_at(L, L$held[1:5, ], values = L$pooled[0, ]) + expect_true(all(is.na(none$value))) + expect_identical(none$cell_id, .va_at(L, L$held[1:5, ])$cell_id) + # A summary whose geometry is not the cells' polygons. + on_points <- sf::st_set_geometry(flat, sf::st_geometry(L$seeds)[match(flat$cell_id, + L$seeds$cell_id)]) + expect_identical( + conditionMessage(.va_error(.va_at(L, L$held, values = on_points, seeds = NULL))), + polygons_text) + # With seeds the summary needs no geometry. + expect_identical(.va_at(L, L$held, values = flat), .va_at(L, L$held)) + # No value of the column: the median alone, or a column that was not summarised. + med <- suppressWarnings(summarize_by_cell(L$asg, "z", id_col = "cell_id", agg_funs = median, + estimate = "mean")) + expect_false("resp_mean_z" %in% names(med)) + expect_identical(conditionMessage(.va_error(.va_at(L, L$held, values = med))), paste0( + "cell_values_at(): `values` has no cell value of 'z' (neither `..pooled_resp_z` nor ", + "`resp_mean_z`). Summarise it with summarize_by_cell() first, with the mean in `agg_funs` ", + "or with estimate = \"pooled\".")) + expect_match(conditionMessage(.va_error(.va_at(L, L$held, response = "w"))), + "`values` has no cell value of 'w' (neither `..pooled_resp_w` nor `resp_mean_w`)", + fixed = TRUE) + # A column the summary holds as a predictor, without its mean: the predictor's names. + med <- suppressWarnings(summarize_by_cell(L$asg, "z", predictor_vars = "w", id_col = "cell_id", + agg_funs = median, estimate = "mean")) + expect_true(all(c("resp_median_z", "pred_median_w") %in% names(med))) + expect_match(conditionMessage(.va_error(.va_at(L, L$held, values = med, response = "w"))), + "`values` has no cell value of 'w' (neither `..pooled_pred_w` nor `pred_mean_w`)", + fixed = TRUE) + expect_match(conditionMessage(.va_error(.va_at(L, L$held, values = med))), + "`values` has no cell value of 'z' (neither `..pooled_resp_z` nor `resp_mean_z`)", + fixed = TRUE) + # Held as response and as predictor: the response's names. + both <- suppressWarnings(summarize_by_cell(L$asg, "z", predictor_vars = c("z", "w"), + id_col = "cell_id", agg_funs = median, + estimate = "mean")) + expect_true(all(c("resp_median_z", "pred_median_z") %in% names(both))) + expect_match(conditionMessage(.va_error(.va_at(L, L$held, values = both))), + "`values` has no cell value of 'z' (neither `..pooled_resp_z` nor `resp_mean_z`)", + fixed = TRUE) +}) + +test_that("what the other arguments must be", { + L <- .va_full() + msg <- function(expr) conditionMessage(.va_error(expr)) + flat <- sf::st_drop_geometry(L$held) + expect_identical(msg(.va_at(L, flat)), "cell_values_at(): `newdata` must be an sf object.") + expect_identical(msg(.va_at(L, sf::st_geometry(L$held))), + "cell_values_at(): `newdata` must be an sf object.") + expect_identical(msg(.va_at(L, L$held, points = sf::st_drop_geometry(L$asg))), + "cell_values_at(): `points` must be an sf object.") + expect_match(msg(.va_at(L, L$held, values = list(1))), "`values` must be the summarize_by_cell() result", + fixed = TRUE) + for (bad in list(NULL, c("z", "w"), 1, NA_character_, "")) + expect_match(msg(.va_at(L, L$held, response = bad)), + "cell_values_at(): `response_var` must be a single column name", fixed = TRUE) + expect_match(msg(cell_values_at(L$held, L$pooled, L$asg, "z", id_col = c("a", "b"))), + "cell_values_at(): `id_col` must be a single column name", fixed = TRUE) + expect_identical(msg(.va_at(L, L$held, response = "nope")), + "cell_values_at(): `points` has no column 'nope'.") + # The ID column is found as summarize_by_cell() finds it. + expect_identical(cell_values_at(L$held, L$pooled, L$asg, "z", seeds = L$seeds), + .va_at(L, L$held)) + expect_identical(cell_values_at(L$held, L$pooled, L$asg, "z", id_col = "nope", seeds = L$seeds), + .va_at(L, L$held)) + none <- L$asg[setdiff(names(L$asg), "cell_id")] + expect_identical(msg(.va_at(L, L$held, points = none)), paste0( + "cell_values_at(): could not find an ID column in `points`. Looked for: cell_id, poly_id, ", + "polygon_id.")) + other <- L$pooled + names(other)[names(other) == "cell_id"] <- "unit" + expect_match(msg(.va_at(L, L$held, values = other)), + "cell_values_at(): `values` has no ID column 'cell_id'", fixed = TRUE) + # No error carries a call. + expect_null(.va_error(.va_at(L, flat))$call) + expect_null(.va_error(.va_at(L, L$held, response = "nope"))$call) +}) + +test_that("no scored row is an error: no value, no cell, no location, or a column that is not a number", { + L <- .va_full() + text <- "cell_values_at(): `points` has no row with a value of 'z', a cell and a location." + msg <- function(points) conditionMessage(.va_error(.va_at(L, L$held, points = points))) + rows <- L$asg; rows$z <- NA_real_ + expect_identical(msg(rows), text) + rows <- L$asg; rows$z <- Inf + expect_identical(msg(rows), text) + rows <- L$asg; rows$cell_id <- NA_integer_ + expect_identical(msg(rows), text) + # A column that is not a number has no value the summary could have read: a string, and + # the types is.finite() accepts, a logical and a factor. + rows <- L$asg; rows$z <- as.character(rows$z) + expect_identical(msg(rows), text) + rows <- L$asg; rows$z <- rows$z > 0 + expect_identical(msg(rows), text) + rows <- L$asg; rows$z <- factor(round(rows$z)) + expect_identical(msg(rows), text) + expect_identical(msg(L$asg[0, ]), text) + rows <- sf::st_set_geometry(L$asg, sf::st_sfc(rep(list(sf::st_point()), nrow(L$asg)), + crs = sf::st_crs(L$asg))) + expect_identical(msg(rows), text) + # One scored row is enough. + rows <- L$asg; rows$z[-1L] <- NA + at <- .va_at(L, L$held[1:3, ], points = rows) + expect_identical(attr(at, "values_at")$n, 1L) + expect_identical(attr(at, "values_at")$spacing, NA_real_) +}) + +test_that("a row of `points` without a usable location is no scored row", { + L <- .va_full() + # Rows 1 to 4: an empty point, a y that is not a number, an x that is not a number (sf + # holds both as empty points), and a y too large to take a distance from. + rows <- L$asg + g <- sf::st_geometry(rows) + xy <- .va_xy(rows) + g[[1L]] <- sf::st_point() + g[[2L]] <- sf::st_point(c(xy[2L, 1L], NaN)) + g[[3L]] <- sf::st_point(c(NaN, xy[3L, 2L])) + g[[4L]] <- sf::st_point(c(xy[4L, 1L], 1e200)) + rows <- sf::st_set_geometry(rows, g) + for (seeds in list(L$seeds, NULL)) { + r <- .va_catch(.va_at(L, L$held, points = rows, seeds = seeds)) + expect_identical(.va_classes(r), character(0)) + expect_identical(attr(r$value, "values_at")$n, nrow(L$asg) - 4L) + expect_identical(attr(r$value, "values_at")$locations, nrow(L$asg) - 4L) + expect_identical(r$value, .va_at(L, L$held, points = L$asg[-(1:4), ], seeds = seeds)) + } +}) + +test_that("`newdata` without a CRS is refused beside rows with one, and runs beside rows without", { + L <- .va_full() + bare <- function(x) sf::st_set_crs(x, NA) + want <- .va_at(L, L$held) + expect_identical( + conditionMessage(.va_error(.va_at(L, bare(L$held)))), + paste0("cell_values_at(): `newdata` has no CRS and `points` has one; set it with ", + "sf::st_set_crs() so the locations can be placed.")) + expect_identical( + conditionMessage(.va_error(.va_at(L, bare(L$held), seeds = NULL))), + paste0("cell_values_at(): `newdata` has no CRS and `points` has one; set it with ", + "sf::st_set_crs() so the locations can be placed.")) + # Said before the rows are read: also where no row is scored. + unscored <- L$asg + unscored$z <- NA_real_ + expect_match(conditionMessage(.va_error(.va_at(L, bare(L$held), points = unscored))), + "cell_values_at(): `newdata` has no CRS and `points` has one", fixed = TRUE) + # Neither has one: the coordinates are used as they are. + r <- .va_catch(.va_at(L, bare(L$held), points = bare(L$asg), seeds = bare(L$seeds))) + expect_identical(.va_classes(r), character(0)) + expect_identical(r$value, want) + # Seeds without a CRS beside rows with one cannot be placed either. + expect_identical( + conditionMessage(.va_error(.va_at(L, L$held, seeds = bare(L$seeds)))), + paste0("cell_values_at(): `seeds` has no CRS and `points` has one; set it with ", + "sf::st_set_crs() so the seeds can be placed.")) + # Nothing with a CRS, and no record of one: the coordinates as they are, and no CRS in + # the record of the call. + values <- sf::st_drop_geometry(L$pooled) + rule <- attr(values, "count_rule"); rule$crs <- sf::NA_crs_ + attr(values, "count_rule") <- rule + pooled <- attr(values, "pooled"); pooled$crs <- sf::NA_crs_ + attr(values, "pooled") <- pooled + at <- .va_at(L, bare(L$held), values = values, points = bare(L$asg), seeds = bare(L$seeds)) + expect_true(is.na(attr(at, "values_at")$crs)) + expect_identical(.va_cols(at), .va_cols(want)) + # There a layer that does carry a CRS cannot be placed beside the rows. + expect_identical( + conditionMessage(.va_error(.va_at(L, L$held, values = values, points = bare(L$asg), + seeds = bare(L$seeds)))), + paste0("cell_values_at(): `newdata` has a CRS and `points` has none; set the CRS of ", + "`points` with sf::st_set_crs() so the locations can be placed.")) + expect_match( + conditionMessage(.va_error(.va_at(L, bare(L$held), values = values, points = bare(L$asg)))), + "cell_values_at(): `seeds` has a CRS and `points` has none", fixed = TRUE) +}) + +test_that("rows without a CRS whose coordinates look like lon/lat are read as the summary read them, and `newdata` with them", { + L <- .va_keep("lonlat", { + F <- .va_full() + rows <- sf::st_transform(F$rows, 4326) + c(list(rows = rows, held = sf::st_transform(F$held, 4326)), .va_path(rows)) + }) + bare <- function(x) sf::st_set_crs(x, NA) + want <- .va_at(L, L$held) + r <- .va_catch(.va_at(L, bare(L$held), points = bare(L$asg), seeds = bare(L$seeds))) + # ensure_projected() says what it took the rows for; nothing else is raised. + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "look like lon/lat", fixed = TRUE) + expect_identical(r$value, want) + expect_gt(stats::median(r$value$dist_nearest), 100) + # A layer with a CRS beside them is transformed as usual. + r <- .va_catch(.va_at(L, L$held, points = bare(L$asg))) + expect_identical(r$value, want) + # By the polygons, too. + r <- .va_catch(.va_at(L, bare(L$held), points = bare(L$asg), seeds = NULL)) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1L]]), "ensure_projected(): input has no CRS", + fixed = TRUE) + expect_identical(r$value, .va_at(L, L$held, seeds = NULL)) +}) + +test_that("scored rows on one location: a distance, no spacing and no ratio; the first cell in the order of the IDs", { + rows <- .va_points(rep(0, 6L), rep(0, 6L), cell_id = c(2L, 1L, 2L, 1L, 2L, 1L), + z = c(20, 10, 22, 12, 24, 14)) + values <- .va_means(rows) + seeds <- .va_points(c(-100, 100, 0), c(0, 0, 1000), cell_id = c(1L, 2L, 3L)) + newdata <- .va_points(c(-60, 70, 0), c(0, 0, 900)) + r <- .va_catch(cell_values_at(newdata, values, rows, "z", id_col = "cell_id", seeds = seeds)) + expect_identical(.va_classes(r), character(0)) + at <- r$value + expect_identical(at$cell_id, c(1L, 2L, 3L)) + expect_identical(at$value, c(12, 22, 12)) + expect_identical(at$filled, c(FALSE, FALSE, TRUE)) + # Rows of two cells share the location: the cell that comes first in the order of the IDs. + expect_identical(at$filled_from, c(NA, NA, 1L)) + expect_identical(at$dist_nearest, c(60, 70, 900)) + expect_identical(at$dist_ratio, rep(NA_real_, 3L)) + rec <- attr(at, "values_at") + expect_identical(rec$n, 6L) + expect_identical(rec$locations, 1L) + expect_identical(rec$spacing, NA_real_) + expect_null(rec$count_rule) + # Whatever the order of the rows. + for (o in list(6:1, c(1L, 3L, 5L, 2L, 4L, 6L))) + expect_identical(cell_values_at(newdata, values, rows[o, ], "z", id_col = "cell_id", + seeds = seeds), at) + # Strings are ordered as in the C locale, a factor by its levels. + as_ids <- function(x, map) { x$cell_id <- map[x$cell_id]; x } + chr <- c("b", "B", "a") + at_chr <- cell_values_at(newdata, .va_means(as_ids(rows, chr)), as_ids(rows, chr), "z", + id_col = "cell_id", seeds = as_ids(seeds, chr)) + expect_identical(at_chr$cell_id, c("b", "B", "a")) + expect_identical(at_chr$filled_from, c(NA, NA, "B")) + expect_identical(at_chr$value, c(12, 22, 22)) + fac <- factor(c("u", "v", "w"), levels = c("v", "u", "w")) + at_fac <- cell_values_at(newdata, .va_means(as_ids(rows, fac)), as_ids(rows, fac), "z", + id_col = "cell_id", seeds = as_ids(seeds, fac)) + expect_identical(as.character(at_fac$cell_id), c("u", "v", "w")) + expect_identical(as.character(at_fac$filled_from), c(NA, NA, "v")) + expect_true(is.factor(at_fac$filled_from)) +}) + +test_that("among rows of two cells at one location the cell is the first in the C-locale order, whatever the session's collation", { + # testthat runs a test under the C collation, where sort() gives that order too. This + # one runs under a collation that puts "b" before "B". + suppressWarnings(withr::local_collate("en_US.UTF-8")) + skip_if_not(identical(sort(c("b", "B", "a")), c("a", "b", "B")), + "no collation here that orders \"b\" before \"B\"") + ids <- c("b", "B") + rows <- .va_points(rep(0, 6L), rep(0, 6L), cell_id = ids[c(2L, 1L, 2L, 1L, 2L, 1L)], + z = c(20, 10, 22, 12, 24, 14)) + seeds <- .va_points(c(-100, 100, 0), c(0, 0, 1000), cell_id = c("b", "B", "a")) + at <- cell_values_at(.va_points(c(-60, 70, 0), c(0, 0, 900)), .va_means(rows), rows, "z", + id_col = "cell_id", seeds = seeds) + expect_identical(at$cell_id, c("b", "B", "a")) + expect_identical(at$filled_from, c(NA, NA, "B")) + expect_identical(at$value, c(12, 22, 22)) +}) + +test_that("a cell that holds scored rows is not filled, whatever `values` has for it", { + L <- .va_full() + # No value for any cell, as where the summary could not compute the pooled columns: + # nothing is taken from another cell, and every value is NA. + values <- L$pooled + values$..pooled_resp_z <- NA_real_ + values$..obs_lo_resp_z <- NA_real_ + values$..obs_hi_resp_z <- NA_real_ + for (seeds in list(L$seeds, NULL)) { + want <- .va_at(L, L$held, seeds = seeds) + at <- .va_at(L, L$held, values = values, seeds = seeds) + expect_identical(at$cell_id, want$cell_id) + expect_identical(at$filled, rep(FALSE, nrow(at))) + expect_true(all(is.na(at$filled_from))) + expect_true(all(is.na(at$value)) && all(is.na(at$obs_lo)) && all(is.na(at$obs_hi))) + expect_identical(at$dist_nearest, want$dist_nearest) + expect_identical(attr(at, "values_at")$filled, 0L) + expect_true(" filled : no location" %in% .va_print(attr(at, "values_at"))) + } + # A location in no cell is filled all the same, with the NA of the cell it is filled from. + far <- .va_points(c(-2e4, 3e5), c(5e4, 3e5)) + at <- .va_at(L, far, values = values, seeds = NULL) + expect_identical(at$filled, c(TRUE, TRUE)) + expect_identical(at$filled_from, .va_at(L, far, seeds = NULL)$filled_from) + expect_true(all(is.na(at$value))) +}) + +test_that("the pooled columns of a summary in which no cell holds two values give NA, unfilled", { + # Twelve rows, each alone in its cell: the summary has plain means and no pooled value. + rows <- .va_points(seq(0, 1100, by = 100), rep(c(0, 60, 20), 4L), cell_id = 1:12, + z = c(3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5, 8)) + r <- .va_catch(summarize_by_cell(rows, "z", id_col = "cell_id", estimate = "pooled")) + expect_true("spatialkit_pool_unavailable" %in% .va_classes(r)) + values <- r$value + expect_true(all(is.na(values$..pooled_resp_z))) + expect_false(anyNA(values$resp_mean_z)) + newdata <- .va_points(c(10, 480, 1090), c(5, 30, 15)) + seeds <- sf::st_sf(cell_id = rows$cell_id, geometry = sf::st_geometry(rows)) + at <- cell_values_at(newdata, values, rows, "z", id_col = "cell_id", seeds = seeds) + expect_identical(at$cell_id, c(1L, 6L, 12L)) + expect_identical(at$estimate, rep("pooled", 3L)) + expect_identical(at$value, rep(NA_real_, 3L)) + expect_identical(at$filled, rep(FALSE, 3L)) + expect_identical(at$filled_from, rep(NA_integer_, 3L)) + # The plain means of the same frame are there to be read. + plain <- values[c("cell_id", "resp_mean_z")] + expect_identical(cell_values_at(newdata, plain, rows, "z", id_col = "cell_id", seeds = seeds)$value, + c(3, 9, 8)) +}) + +test_that("a cell whose valued rows have no location keeps its mean, and is filled where it has no value", { + L <- .va_full() + want <- .va_at(L, L$held) + # The rows of the cell that holds the most held-out rows lose their geometry. + k <- as.integer(names(which.max(table(want$cell_id)))) + rows <- L$asg + g <- sf::st_geometry(rows) + for (i in which(rows$cell_id == k)) g[[i]] <- sf::st_point() + rows <- sf::st_set_geometry(rows, g) + hit <- want$cell_id == k + expect_gt(sum(hit), 1L) + expect_gt(sum(L$asg$cell_id == k), 1L) + # Plain means: the cell holds no scored row and has a mean, which its locations take. + plain <- suppressWarnings(summarize_by_cell(rows, "z", id_col = "cell_id", + cells_sf = L$tess$cells, estimate = "mean")) + mean_k <- plain$resp_mean_z[plain$cell_id == k] + expect_true(is.finite(mean_k)) + at <- .va_at(L, L$held, values = plain, points = rows) + expect_identical(at$cell_id, want$cell_id) + expect_identical(at$filled, rep(FALSE, nrow(at))) + expect_identical(at$value[hit], rep(mean_k, sum(hit))) + # No scored row lies in the cell, so its locations are further from the data. + expect_true(all(at$dist_nearest[hit] > 0)) + expect_identical(attr(at, "values_at")$n, sum(L$asg$cell_id != k)) + # Pooled values: no row of the cell has a location, so it has no pooled value and its + # locations are filled from another cell. + pooled <- suppressWarnings(summarize_by_cell(rows, "z", id_col = "cell_id", + cells_sf = L$tess$cells, estimate = "pooled", + obs_level = 0.90)) + expect_true(is.na(pooled$..pooled_resp_z[pooled$cell_id == k])) + at <- .va_at(L, L$held, values = pooled, points = rows) + expect_identical(at$filled, hit) + expect_false(anyNA(at$value)) + expect_true(all(at$filled_from[hit] != k)) +}) + +test_that("two scored locations have a spacing: the distance between them", { + rows <- .va_points(c(0, 30), c(0, 40), cell_id = 1:2, z = c(1, 2)) + seeds <- sf::st_sf(cell_id = 1:2, geometry = sf::st_geometry(rows)) + for (fnn in c(TRUE, FALSE)) local({ + if (!fnn) .va_no_fnn() + at <- cell_values_at(.va_points(c(0, 30), c(10, 45)), .va_means(rows), rows, "z", + id_col = "cell_id", seeds = seeds) + expect_identical(attr(at, "values_at")$locations, 2L) + expect_identical(attr(at, "values_at")$spacing, 50) + expect_identical(at$dist_nearest, c(10, 5)) + expect_identical(at$dist_ratio, c(0.2, 0.1)) + expect_identical(at$value, c(1, 2)) + }) +}) + +test_that("the record counts rows and locations apart, in the frame and in print", { + T <- .va_lattice() + seeds <- .va_points(T$at$x, T$at$y, cell_id = T$cell) + rec <- attr(cell_values_at(.va_points(13, 21), T$values, T$rows, "z", id_col = "cell_id", + seeds = seeds), "values_at") + expect_identical(rec$n, 60L) + expect_identical(rec$locations, 30L) + expect_true(" scored rows : 60 rows at 30 locations, measured in EPSG:32617" %in% .va_print(rec)) +}) + +test_that("an ID column named like a column of the result is refused", { + T <- .va_lattice() + for (nm in c("value", "estimate", "obs_lo", "obs_hi", "filled", "filled_from", "dist_nearest", + "dist_ratio")) { + rename <- function(x) { names(x)[names(x) == "cell_id"] <- nm; x } + seeds <- rename(.va_points(T$at$x, T$at$y, cell_id = T$cell)) + e <- .va_error(cell_values_at(.va_points(13, 21), rename(T$values), rename(T$rows), "z", + id_col = nm, seeds = seeds)) + expect_identical(conditionMessage(e), paste0( + "cell_values_at(): the ID column is named '", nm, "', which is a column of the result ", + "(value, estimate, obs_lo, obs_hi, filled, filled_from, dist_nearest, dist_ratio). ", + "Rename it in `points`, `values` and `seeds`.")) + expect_null(e$call) + } + # Any other name is the first column of the frame. + rename <- function(x) { names(x)[names(x) == "cell_id"] <- "values"; x } + at <- cell_values_at(.va_points(13, 21), rename(T$values), rename(T$rows), "z", id_col = "values", + seeds = rename(.va_points(T$at$x, T$at$y, cell_id = T$cell))) + expect_identical(names(at), c("values", "value", "estimate", "filled", "filled_from", + "dist_nearest", "dist_ratio")) + expect_false(anyDuplicated(names(at)) > 0L) +}) + + +# ---- The bound on the exact searches ------------------------------------------------ + +test_that("without FNN each exact search is bounded, and the spacing's does not depend on the locations asked for", { + # 20 scored locations on a 5 x 4 lattice in 4 cells, and the 4 cells' seeds. + g <- expand.grid(x = seq(0, 400, by = 100), y = seq(0, 300, by = 100)) + cell <- 1L + (g$x > 200) + 2L * (g$y > 100) + rows <- .va_points(g$x, g$y, cell_id = cell, z = g$x / 100 + g$y / 50) + values <- .va_means(rows) + seeds <- .va_points(c(100, 350, 100, 350), c(50, 50, 250, 250), cell_id = 1:4) + new <- function(k) .va_points(seq(10, by = 37, length.out = k), seq(15, by = 23, length.out = k)) + call <- function(k, seeds_k = seeds) + cell_values_at(new(k), values, rows, "z", id_col = "cell_id", seeds = seeds_k) + with_fnn <- if (requireNamespace("FNN", quietly = TRUE)) call(6L) else NULL + .va_no_fnn() + free <- call(6L) + if (!is.null(with_fnn)) expect_identical(free, with_fnn) + + withr::local_options(spatialkit.exact_pairs_max = 100) + # One new location: 20 pairs and 4 pairs for its two searches, and 400 for the spacing. + e <- .va_error(call(1L)) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "spacing") + expect_identical(e$work, 400) + expect_identical(e$limit, 100) + expect_null(e$call) + expect_identical(conditionMessage(e), paste0( + "cell_values_at(): the spacing of the scored rows (the nearest other of each of 20 scored ", + "locations) would compare 4e+02 pairs without the FNN package, above the limit of 1e+02 ", + "(options(spatialkit.exact_pairs_max = )). Install FNN: the result is the same.")) + # By the polygons as well, where no seed is searched for. + cells <- sf::st_sf(cell_id = 1:4, geometry = sf::st_buffer(sf::st_geometry(seeds), 100, + endCapStyle = "SQUARE")) + with_cells <- dplyr::left_join(cells, values, by = "cell_id") + e <- .va_error(cell_values_at(new(1L), with_cells, rows, "z", id_col = "cell_id")) + expect_identical(e$what, "spacing") + # Six new locations: 120 pairs for the nearest scored location, which is named first. + e <- .va_error(call(6L)) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "nearest scored location") + expect_identical(e$work, 120) + expect_match(conditionMessage(e), + "cell_values_at(): finding the nearest of 20 scored locations for 6 locations would", + fixed = TRUE) + # The limit is the most pairs allowed, not the first refused. + withr::local_options(spatialkit.exact_pairs_max = 400) + expect_identical(call(6L), free) + withr::local_options(spatialkit.exact_pairs_max = 399) + expect_identical(.va_error(call(6L))$what, "spacing") + # 101 seeds for four locations: 404 pairs, beside 80 and 400. + withr::local_options(spatialkit.exact_pairs_max = 400) + many <- rbind(seeds, .va_points(seq(1000, by = 10, length.out = 97), rep(1000, 97), + cell_id = 100L + 1:97)) + e <- .va_error(call(4L, many)) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "nearest seed") + expect_identical(e$work, 404) + expect_match(conditionMessage(e), + "cell_values_at(): finding the nearest of 101 seeds for 4 locations would", + fixed = TRUE) + # No pair at all under a limit of 0, but for a call that has none to compare. + withr::local_options(spatialkit.exact_pairs_max = 0) + expect_identical(.va_error(call(1L))$what, "nearest scored location") +}) + +test_that("the bound counts the rows and the seeds that have a location, and no others", { + # 20 scored locations. Of 32 rows of `newdata` two have a location, and of 325 seeds 25. + g <- expand.grid(x = seq(0, 400, by = 100), y = seq(0, 300, by = 100)) + rows <- .va_points(g$x, g$y, cell_id = 1L + (g$x > 200) + 2L * (g$y > 100), + z = g$x / 100 + g$y / 50) + values <- .va_means(rows) + empty <- function(k) sf::st_sfc(rep(list(sf::st_point()), k), crs = 32617) + located <- .va_points(c(10, 47), c(15, 38)) + newdata <- rbind(sf::st_sf(geometry = sf::st_geometry(located)), sf::st_sf(geometry = empty(30L))) + seeds <- rbind(.va_points(c(100, 350, 100, 350), c(50, 50, 250, 250), cell_id = 1:4), + .va_points(seq(1000, by = 10, length.out = 21L), rep(1000, 21L), + cell_id = 100L + 1:21), + sf::st_sf(cell_id = 1000L + 1:300, geometry = empty(300L))) + call <- function() cell_values_at(newdata, values, rows, "z", id_col = "cell_id", seeds = seeds) + .va_no_fnn() + free <- call() + expect_identical(nrow(free), 32L) + expect_identical(.va_cols(free[1:2, ]), + .va_cols(cell_values_at(located, values, rows, "z", id_col = "cell_id", + seeds = seeds[1:4, ]))) + # 2 x 20 pairs for the nearest scored location, 2 x 25 for the nearest seed, 20 x 20 + # for the spacing: all within 400. + withr::local_options(spatialkit.exact_pairs_max = 400) + expect_identical(call(), free) + # The seeds' search is stopped at 2 x 25 pairs, not at 2 x 325. + withr::local_options(spatialkit.exact_pairs_max = 45) + e <- .va_error(call()) + expect_s3_class(e, "spatialkit_work_limit") + expect_identical(e$what, "nearest seed") + expect_identical(e$work, 50) + expect_match(conditionMessage(e), + "cell_values_at(): finding the nearest of 25 seeds for 2 locations would", + fixed = TRUE) + # The scored locations' search at 2 x 20 pairs, not at 32 x 20. + withr::local_options(spatialkit.exact_pairs_max = 39) + e <- .va_error(call()) + expect_identical(e$what, "nearest scored location") + expect_identical(e$work, 40) + expect_match(conditionMessage(e), + "cell_values_at(): finding the nearest of 20 scored locations for 2 locations would", + fixed = TRUE) +}) + +test_that("with FNN no search is bounded", { + skip_if_not_installed("FNN") + g <- expand.grid(x = seq(0, 400, by = 100), y = seq(0, 300, by = 100)) + rows <- .va_points(g$x, g$y, cell_id = 1L + (g$x > 200) + 2L * (g$y > 100), + z = g$x / 100 + g$y / 50) + seeds <- .va_points(c(100, 350, 100, 350), c(50, 50, 250, 250), cell_id = 1:4) + newdata <- .va_points(c(10, 47, 84), c(15, 38, 61)) + want <- cell_values_at(newdata, .va_means(rows), rows, "z", id_col = "cell_id", seeds = seeds) + withr::local_options(spatialkit.exact_pairs_max = 0) + expect_identical(cell_values_at(newdata, .va_means(rows), rows, "z", id_col = "cell_id", + seeds = seeds), want) +}) + +test_that("the backend is asked for once, and the answer reaches every search", { + skip_if_not_installed("FNN") + L <- .va_full() + asked <- character(0) + testthat::local_mocked_bindings(.has_backend = function(pkg) { + asked <<- c(asked, pkg) + FALSE + }) + # A kd-tree reached by any search stops the call. + testthat::local_mocked_bindings( + get.knn = function(...) stop("FNN::get.knn() reached"), + get.knnx = function(...) stop("FNN::get.knnx() reached"), .package = "FNN") + at <- .va_at(L, L$held) + expect_identical(asked, "FNN") + expect_identical(nrow(at), nrow(L$held)) +}) + + +# ---- Ties --------------------------------------------------------------------------- + +test_that("a location the same distance from two scored locations takes the lower x, then the lower y", { + T <- .va_lattice() + # No location has a cell: the one seed stands for none. + seeds <- .va_points(25, 20, cell_id = NA_integer_) + # Half-way between two locations along x, along y, between four, and beside the last column. + q <- data.frame(x = c(5, 0, 5, 25, 45, 50, 13), y = c(0, 5, 5, 15, 40, 35, 21)) + newdata <- .va_points(q$x, q$y) + u <- cbind(T$at$x, T$at$y) + first <- .va_nearest(cbind(q$x, q$y), u) + # The ties are ties: the first six are the same distance from two or four locations. + tied <- vapply(seq_len(nrow(q)), function(i) { + d2 <- (q$x[i] - u[, 1L])^2 + (q$y[i] - u[, 2L])^2 + sum(d2 == min(d2)) + }, integer(1)) + expect_identical(tied, c(2L, 2L, 4L, 4L, 2L, 2L, 1L)) + want_cell <- T$cell[first] + expect_identical(want_cell, c(30L, 30L, 30L, 19L, 6L, 2L, 23L)) + # The other tied location has the lower ID at (45, 40) and comes first in neither the + # rows nor the IDs elsewhere, so no other rule gives these cells. + call <- function(rows) cell_values_at(newdata, T$values, rows, "z", id_col = "cell_id", + seeds = seeds) + at <- call(T$rows) + expect_identical(at$filled, rep(TRUE, 7L)) + expect_identical(at$cell_id, rep(NA_integer_, 7L)) + expect_identical(at$filled_from, want_cell) + expect_identical(at$value, 10 * want_cell) + expect_identical(at$dist_nearest, sqrt((q$x - u[first, 1L])^2 + (q$y - u[first, 2L])^2)) + expect_identical(attr(at, "values_at")$locations, 30L) + expect_identical(attr(at, "values_at")$spacing, 10) + # Under permutations of the rows. + for (seed in 1:5) { + o <- local({ .va_seed(6210 + seed); sample.int(nrow(T$rows)) }) + expect_identical(call(T$rows[o, ]), at) + } + expect_identical(call(T$rows[order(T$rows$cell_id), ]), at) + expect_identical(call(T$rows[order(-T$rows$cell_id), ]), at) + # Without FNN. + local({ + .va_no_fnn() + expect_identical(call(T$rows), at) + expect_identical(call(T$rows[order(T$rows$cell_id), ]), at) + }) + # The lower x before the lower y: without the rows at the corner, a location on the + # diagonal is the same distance from (0, 10), cell 29, and from (10, 0), cell 25. + xy <- .va_xy(T$rows) + no_corner <- T$rows[!(xy[, 1L] == 5e5 & xy[, 2L] == 5e6), ] + expect_identical(nrow(no_corner), 58L) + diagonal <- .va_points(c(2, 4.5), c(2, 4.5)) + for (fnn in c(TRUE, FALSE)) local({ + if (!fnn) .va_no_fnn() + at <- cell_values_at(diagonal, .va_means(no_corner), no_corner, "z", id_col = "cell_id", + seeds = seeds) + expect_identical(at$filled_from, c(29L, 29L)) + expect_identical(at$dist_nearest, sqrt(c(2^2 + 8^2, 4.5^2 + 5.5^2))) + }) + # Rows of a second cell at a location: the cell that comes first in the order of the IDs. + more <- rbind(T$rows, .va_points(c(40, 40, 0, 0), c(40, 40, 0, 0), + cell_id = c(3L, 3L, 40L, 40L), z = c(1, 2, 3, 4))) + values <- .va_means(more) + for (o in list(seq_len(nrow(more)), rev(seq_len(nrow(more))))) { + at2 <- cell_values_at(newdata, values, more[o, ], "z", id_col = "cell_id", seeds = seeds) + expect_identical(at2$filled_from, c(30L, 30L, 30L, 19L, 3L, 2L, 23L)) + expect_identical(at2$value, values$resp_mean_z[match(at2$filled_from, values$cell_id)]) + expect_identical(attr(at2, "values_at")$locations, 30L) + expect_identical(attr(at2, "values_at")$n, 64L) + } +}) + +test_that("a location the same distance from two seeds takes the first of them in `seeds`", { + T <- .va_lattice() + # A seed on every location, with the ID of the cell there. + seeds <- .va_points(T$at$x, T$at$y, cell_id = T$cell) + q <- data.frame(x = c(5, 0, 5, 25, 45, 50, 13), y = c(0, 5, 5, 15, 40, 35, 21)) + newdata <- .va_points(q$x, q$y) + u <- cbind(T$at$x, T$at$y) + first_of <- function(order_of_seeds) vapply(seq_len(nrow(q)), function(i) { + d2 <- (q$x[i] - u[, 1L])^2 + (q$y[i] - u[, 2L])^2 + T$cell[order_of_seeds[order_of_seeds %in% which(d2 == min(d2))][1L]] + }, integer(1)) + orders <- list(seq_len(30L), rev(seq_len(30L)), local({ .va_seed(6220); sample.int(30L) })) + got <- list() + for (o in orders) { + at <- cell_values_at(newdata, T$values, T$rows, "z", id_col = "cell_id", seeds = seeds[o, ]) + expect_identical(at$cell_id, first_of(o)) + expect_identical(at$filled, rep(FALSE, 7L)) + expect_identical(at$value, 10 * at$cell_id) + got[[length(got) + 1L]] <- at$cell_id + # Under a permutation of the rows, and without FNN. + expect_identical(cell_values_at(newdata, T$values, T$rows[rev(seq_len(60L)), ], "z", + id_col = "cell_id", seeds = seeds[o, ]), at) + local({ + .va_no_fnn() + expect_identical(cell_values_at(newdata, T$values, T$rows, "z", id_col = "cell_id", + seeds = seeds[o, ]), at) + }) + } + # The order of the seeds decides, so two orders give two answers at a tie and one elsewhere. + expect_identical(got[[1L]], c(30L, 30L, 30L, 19L, 6L, 2L, 23L)) + expect_identical(got[[2L]], c(25L, 29L, 24L, 13L, 1L, 1L, 23L)) +}) + + +# ---- Coverage at held-out rows of simulated layers ---------------------------------- + +test_that("the observation interval covers a held-out observation about as often as its level says, and the t interval does not", { + skip_on_cran() + # Forty layers, r = 1 to 40. set.seed(r): 3,000 locations, x then y uniform on a 1e5 + # square. The response is 3 times a field of 60 cosine waves plus normal noise of + # standard deviation 1; the field is drawn under set.seed(r + 1000), the noise after + # it, and then the held-out fifth, sample.int(3000, 600). + field <- function(xy, seed) { + set.seed(seed) + om <- matrix(stats::rnorm(120, sd = 1 / 9000), 60L) + phase <- stats::runif(60, 0, 2 * pi) + as.numeric(sqrt(2 / 60) * cos(xy %*% t(om) + rep(phase, each = nrow(xy))) %*% + stats::rnorm(60)) + } + one <- function(r) { + .va_seed(r) + xy <- cbind(stats::runif(3000, 0, 1e5), stats::runif(3000, 0, 1e5)) + z <- 3 * field(xy, r + 1000) + stats::rnorm(3000, sd = 1) + held <- sample.int(3000L, 600L) + pts <- sf::st_as_sf(data.frame(x = 5e5 + xy[, 1L], y = 5e6 + xy[, 2L], z = z), + coords = c("x", "y"), crs = 32617) + rows <- pts[-held, ] + new <- pts[held, ] + prof <- resolution_profile(rows, "z", partition = "density", init = "kmeans++", nstart = 3, + sac = "auto", seed = 123, estimate = "pooled", obs_per_cell = 4.5) + sel <- select_resolution(prof, criterion = "size") + seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = rows) + tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) + asg <- assign_features_to_polygons(rows, tess$cells, polygon_id_col = "cell_id", + quiet = TRUE) + out <- summarize_by_cell(asg, "z", id_col = "cell_id", cells_sf = tess$cells, + estimate = "pooled", obs_level = 0.90, conf_level = 0.90) + seeds$cell_id <- tess$index + at <- cell_values_at(new, out, asg, "z", id_col = "cell_id", seeds = seeds) + # The t interval of the cell the value came from, read as a range for an observation; + # a cell without one covers nothing. + src <- match(ifelse(at$filled, at$filled_from, at$cell_id), out$cell_id) + lo <- out$..ci_lo_resp_z[src] + hi <- out$..ci_hi_resp_z[src] + c(cells = sel$best, + obs = mean(new$z >= at$obs_lo & new$z <= at$obs_hi), + ci = mean(!is.na(lo) & !is.na(hi) & new$z >= lo & new$z <= hi)) + } + got <- vapply(1:40, one, numeric(3)) + expect_identical(unname(got["cells", ]), rep(533, 40L)) + expect_false(anyNA(got)) + # One run of these seeds gave 0.891 (single layers 0.850 to 0.915) and 0.578 (0.515 to 0.623). + expect_gt(mean(got["obs", ]), 0.87) + expect_lt(mean(got["obs", ]), 0.92) + expect_lt(mean(got["ci", ]), 0.70) +}) diff --git a/tests/testthat/test-cp-nonconverged-nugget.R b/tests/testthat/test-cp-nonconverged-nugget.R index f8967c36..07d18bd0 100644 --- a/tests/testthat/test-cp-nonconverged-nugget.R +++ b/tests/testthat/test-cp-nonconverged-nugget.R @@ -79,20 +79,20 @@ expect_gstat_verdict <- function(sac) { invisible(if (ok) v else NA) } -# gstat::fit.variogram() stubbed, as test-review3-S4-range-kriging.R stubs it: -# one exponential model with a nugget of 0.4 whose effective range (3 x 5000) -# is past every lag of a 1000 m square, returned with the warning gstat raises -# when its optimiser stops at the iteration limit, or without it. Whether -# the real optimiser reaches that limit on a given draw depends on the LAPACK -# build. What estimate_sac_range() and the profile make of the warning does -# not, and that is the part under test. +# The fit stubbed, as test-review3-S4-range-kriging.R stubs it: one +# exponential model with a nugget of 0.4 whose effective range (3 x 5000) is +# past every lag of a 1000 m square, marked as a fit whose criterion has no +# minimum inside the ranges searched, or as one that has. The stub replaces +# .sac_fit_model(), the profile least-squares fit estimate_sac_range() makes +# (gstat::fit.variogram() is no longer called, so stubbing that would change +# nothing). What estimate_sac_range() and the profile make of the mark is +# the part under test. cpn_fit_stub <- function(converges) { - function(object, model, ...) { + function(vg, cutoff_dist, family = "Exp", upper = 4, ...) { m <- gstat::vgm(psill = 1, model = "Exp", range = 5000, nugget = 0.4) attr(m, "singular") <- FALSE attr(m, "SSErr") <- 1 - if (!converges) - warning("No convergence after 200 iterations: try different initial values?") + attr(m, "converged") <- converges m } } @@ -168,14 +168,15 @@ test_that("a model built from REML parameters carries no verdict", { }) -test_that("a fit gstat gave up on, past the lags, gives cp no nugget on any platform", { +test_that("a fit with no minimum, past the lags, gives cp no nugget on any platform", { skip_if_not_installed("gstat") - # The whole chain with nothing left to the optimiser: gstat warns that it - # did not converge, estimate_sac_range() refuses the range as past the - # largest lag and marks the model, and the profile reads the mark. Nothing - # here is skipped, so a verdict that is lost or wrong on the way fails. + # The whole chain with nothing left to the fit: it reports a model whose + # criterion has no minimum inside the ranges searched, estimate_sac_range() + # refuses the range as past the largest lag and hands the mark on, and the + # profile reads the mark. Nothing here is skipped, so a verdict that is + # lost or wrong on the way fails. pts <- cpn_field(seed = 2) - local_mocked_bindings(fit.variogram = cpn_fit_stub(converges = FALSE), .package = "gstat") + local_mocked_bindings(.sac_fit_model = cpn_fit_stub(converges = FALSE)) sac <- suppressWarnings(estimate_sac_range(pts, "z", seed = 1)) expect_true(is.na(sac)) expect_identical(attr(sac, "rejected_reason"), PAST_LAGS) @@ -186,7 +187,7 @@ test_that("a fit gstat gave up on, past the lags, gives cp no nugget on any plat expect_cp_from_finest_level(out$value) expect_true(any(grepl(paste0("`sac` reports no usable range (", PAST_LAGS, "), and its variogram model did not converge; ", - "its nugget and sill are where the optimiser stopped"), + "its nugget and sill are where the fit stopped without reaching a minimum"), out$warnings, fixed = TRUE))) expect_false(any(grepl("still takes its nugget", out$warnings, fixed = TRUE))) @@ -201,13 +202,13 @@ test_that("a fit gstat gave up on, past the lags, gives cp no nugget on any plat }) -test_that("the same fit without gstat's warning still gives cp its nugget", { +test_that("the same fit with a minimum still gives cp its nugget", { skip_if_not_installed("gstat") # The counterpart, and the documented behaviour that does not change: the - # model is the one above and so is the refusal, but the optimiser did not - # give up, so the nugget was fitted at the short lags and serves Cp. + # model is the one above and so is the refusal, but the fit has a minimum, + # so the nugget was fitted at the short lags and serves Cp. pts <- cpn_field(seed = 2) - local_mocked_bindings(fit.variogram = cpn_fit_stub(converges = TRUE), .package = "gstat") + local_mocked_bindings(.sac_fit_model = cpn_fit_stub(converges = TRUE)) sac <- suppressWarnings(estimate_sac_range(pts, "z", seed = 1)) expect_true(is.na(sac)) expect_identical(attr(sac, "rejected_reason"), PAST_LAGS) @@ -246,7 +247,10 @@ test_that("a fit that did not converge, refused as past the lags, gives cp no nu identical(attr(sac, "rejected_reason"), PAST_LAGS) && isFALSE(attr(attr(sac, "variogram_model"), "converged")), "gstat's all-pairs fit did not end as 'not converged, past the largest lag' here") - expect_gt(sac_nugget(sac), 0) + # The nugget of such a fit is whatever the edge of the search gives (0 here, + # at its bound and marked so; 1.29 where gstat's optimiser used to halt). + # Either way it is a number that must not reach Cp. + expect_true(is.finite(sac_nugget(sac))) out <- cpn_warnings(resolution_profile(pts, "z", sac = sac, n_levels = 6, nstart = 3)) p <- out$value @@ -261,7 +265,7 @@ test_that("a fit that did not converge, refused as past the lags, gives cp no nu # fit did not converge. expect_true(any(grepl(paste0("`sac` reports no usable range (", PAST_LAGS, "), and its variogram model did not converge; ", - "its nugget and sill are where the optimiser stopped"), + "its nugget and sill are where the fit stopped without reaching a minimum"), out$warnings, fixed = TRUE))) expect_false(any(grepl("still takes its nugget", out$warnings, fixed = TRUE))) expect_true(any(grepl("`sac` gives no usable variogram model, so `cp` takes its noise variance", @@ -298,7 +302,7 @@ test_that("the model's own verdict decides, whatever the reason says", { expect_cp_from_finest_level(out$value) expect_true(any(grepl(paste0("reports no usable range (", reason, "), and its variogram model did not converge; ", - "its nugget and sill are where the optimiser stopped"), + "its nugget and sill are where the fit stopped without reaching a minimum"), out$warnings, fixed = TRUE)), info = reason) expect_false(any(grepl("still takes its nugget", out$warnings, fixed = TRUE)), info = reason) } @@ -307,7 +311,7 @@ test_that("the model's own verdict decides, whatever the reason says", { n_levels = 4, nstart = 2)) expect_cp_from_finest_level(out$value) expect_true(any(grepl(paste0("reports no usable range (", NOT_CONV, - "); its nugget and sill are where the optimiser stopped"), + "); its nugget and sill are where the fit stopped without reaching a minimum"), out$warnings, fixed = TRUE))) expect_length(grep("did not converge", out$warnings), 1L) expect_false(any(grepl("and its variogram model did not converge", out$warnings, fixed = TRUE))) @@ -363,18 +367,24 @@ test_that("a converged fit refused as past the lags still gives cp its nugget", }) -test_that("a converged fit of gstat's own, past the lags, still gives cp its nugget", { +test_that("a fit of the package's own with a minimum, past the lags, still gives cp its nugget", { skip_if_not_installed("gstat") - # An effective range of 5000 on a 1000 m square: the fit converges to a - # range near 5000, past the largest lag of 647, with a nugget of 0.049 - # where the field's is 0.05. - pts <- cpn_field(eff_range = 5000, nugget = 0.05, seed = 1) + # An effective range of 5000 on a 1000 m square. Under gstat's iterative + # fit seed 1 converged to a range near 5000, past the largest lag of 647, + # and the test skipped itself wherever that fit ended otherwise. The fit + # is a search now, and on seed 1 its criterion is still falling at four + # cutoffs (no minimum: the test before this one), so the skip held on + # every run. Seed 5 has the case this test is for: a minimum at 1363, + # past the largest lag of 660 and inside the ranges searched, with a + # nugget of 0.060 where the field's is 0.05. + pts <- cpn_field(eff_range = 5000, nugget = 0.05, seed = 5) sac <- suppressWarnings(estimate_sac_range(pts, "z", seed = 1)) - expect_gstat_verdict(sac) - skip_if_not(is.na(sac) && - identical(attr(sac, "rejected_reason"), PAST_LAGS) && - isTRUE(attr(attr(sac, "variogram_model"), "converged")), - "gstat's all-pairs fit did not end as 'converged, past the largest lag' here") + expect_true(is.na(sac)) + expect_identical(attr(sac, "rejected_reason"), PAST_LAGS) + expect_identical(expect_gstat_verdict(sac), TRUE) + expect_gt(attr(sac, "rejected_range"), attr(sac, "cutoff_dist")) + expect_lt(attr(sac, "rejected_range"), 3.5 * attr(sac, "cutoff_dist")) + expect_lt(abs(sac_nugget(sac) - 0.05), 0.04) out <- cpn_warnings(resolution_profile(pts, "z", sac = sac, n_levels = 6, nstart = 3)) p <- out$value expect_identical(attr(p, "cp_noise")$source, "variogram nugget") @@ -393,7 +403,7 @@ test_that("a sac whose model carries no verdict is judged by its reason", { n_levels = 4, nstart = 2)) expect_cp_from_finest_level(out$value) expect_true(any(grepl(paste0("reports no usable range (", NOT_CONV, - "); its nugget and sill are where the optimiser stopped"), + "); its nugget and sill are where the fit stopped without reaching a minimum"), out$warnings, fixed = TRUE))) for (reason in c(PAST_LAGS, DECREASING)) { out <- cpn_warnings(resolution_profile(pts, "z", sac = cpn_refused(reason), diff --git a/tests/testthat/test-cv-gwr.R b/tests/testthat/test-cv-gwr.R index 14d1c2b6..c4b6b17a 100644 --- a/tests/testthat/test-cv-gwr.R +++ b/tests/testthat/test-cv-gwr.R @@ -4,7 +4,6 @@ # number it returns describes the predictions it returns. test_that("cv_gwr() pools the fold predictions it returns", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") set.seed(21); n <- 90 diff --git a/tests/testthat/test-deff-variogram.R b/tests/testthat/test-deff-variogram.R index 489ff316..93f56177 100644 --- a/tests/testthat/test-deff-variogram.R +++ b/tests/testthat/test-deff-variogram.R @@ -234,10 +234,10 @@ test_that("a variogram family the function does not implement is refused, not re sac <- structure(300, class = c("sac_range", "numeric"), variogram_model = vm, crs = sf::st_crs(pts)) expect_warning( - out <- summarize_by_cell(pts, "z", deff = "variogram", sac = sac), + out <- summarize_by_cell(pts, "z", deff = "variogram", sac = sac, estimate = "mean"), "supports exponential, spherical and Gaussian variogram models.*'Mat'") expect_null(attr(out, "deff_applied")) - naive <- summarize_by_cell(pts, "z", deff = 1) + naive <- summarize_by_cell(pts, "z", deff = 1, estimate = "mean") expect_equal(out[["..se_resp_z"]], naive[["..se_resp_z"]]) }) @@ -296,7 +296,7 @@ test_that("summarize_by_cell(conf_level) on the variogram path uses the reduced sac <- structure(360, class = c("sac_range", "numeric"), variogram_model = vm, crs = sf::st_crs(pts)) out <- summarize_by_cell(pts, "z", deff = "variogram", sac = sac, - conf_level = 0.95) + conf_level = 0.95, estimate = "mean") expect_true(all(out[["..df_resp_z"]] > 0)) expect_true(all(out[["..df_resp_z"]] < out$n - 1)) # Reproducible from the same correlation function on the same points. diff --git a/tests/testthat/test-degenerate-geometry.R b/tests/testthat/test-degenerate-geometry.R index b49042a1..c64a0877 100644 --- a/tests/testthat/test-degenerate-geometry.R +++ b/tests/testthat/test-degenerate-geometry.R @@ -220,7 +220,7 @@ test_that("ensure_stable_poly_id refuses an empty layer and numbers a single pol test_that("summarize_by_cell returns the full column set for degenerate input", { empty <- sf::st_sf(poly_id = integer(0), y = numeric(0), geometry = sf::st_sfc(crs = 32632)) - out <- summarize_by_cell(empty, response_var = "y") + out <- summarize_by_cell(empty, response_var = "y", estimate = "mean") expect_equal(nrow(out), 0L) # The columns must still be there, or rbind()ing per-region results ragged. expect_true(all(c("poly_id", "n", "resp_mean_y", "..sd_resp_y", @@ -230,7 +230,7 @@ test_that("summarize_by_cell returns the full column set for degenerate input", # reporting 0 would claim perfect precision from one measurement. one <- sf::st_sf(poly_id = 1L, y = 3, geometry = sf::st_sfc(sf::st_point(c(1, 1)), crs = 32632)) - o1 <- summarize_by_cell(one, response_var = "y") + o1 <- summarize_by_cell(one, response_var = "y", estimate = "mean") expect_equal(nrow(o1), 1L) expect_equal(o1$n, 1L) expect_equal(o1[["resp_mean_y"]], 3) @@ -242,13 +242,13 @@ test_that("summarize_by_cell returns the full column set for degenerate input", # row over 10 values, with a real sd. dup <- .dg_coincident() dup$poly_id <- 1L - od <- summarize_by_cell(dup, response_var = "z") + od <- summarize_by_cell(dup, response_var = "z", estimate = "mean") expect_equal(nrow(od), 1L) expect_equal(od$n, 10L) expect_equal(od[["resp_mean_z"]], mean(dup$z)) expect_equal(od[["..se_resp_z"]], stats::sd(dup$z) / sqrt(10)) - expect_error(summarize_by_cell(.dg_one(), response_var = "z"), + expect_error(summarize_by_cell(.dg_one(), response_var = "z", estimate = "mean"), "could not find an ID column") }) diff --git a/tests/testthat/test-evaluation.R b/tests/testthat/test-evaluation.R index 73b423d6..e4f42e37 100644 --- a/tests/testthat/test-evaluation.R +++ b/tests/testthat/test-evaluation.R @@ -366,9 +366,10 @@ test_that("compare_models_cv warns on unknown model names and errors when none r test_that("compare_models_cv drops a recognised model whose backend is absent", { skip_if_not_installed("ranger") + # GWR needs sp alone: the local regressions are the package's own, and + # GWmodel, which this used to ask for as well, is not called. absent <- c("GWR", "Bayesian")[ - !c(requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE), + !c(requireNamespace("sp", quietly = TRUE), requireNamespace("brms", quietly = TRUE))] skip_if(length(absent) == 0L, "both optional backends are installed") diff --git a/tests/testthat/test-fix-aoa-rf-coords-text.R b/tests/testthat/test-fix-aoa-rf-coords-text.R new file mode 100644 index 00000000..f55ba9a4 --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-coords-text.R @@ -0,0 +1,92 @@ +# tests/testthat/test-fix-aoa-rf-coords-text.R +# --------------------------------------------------------------------------- +# What fit_rf_model() says about coordinates. +# +# The logged caution and the help said a forest given the coordinates will +# "fail wherever it has not been". Across 21 datasets the forest with +# coordinates had the lower RMSE in 601 of 630 block-fold comparisons and +# was never judged worse, so that is not a general statement. What holds is +# that the out-of-bag error and random folds overstate such a forest's +# accuracy and that the gain fades with distance, so the advice to validate +# with blocked or distance-matched folds stays. A fit without coordinates +# prints that it uses no spatial information. +# --------------------------------------------------------------------------- + +txt_pts <- function(n = 120, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = stats::runif(n, 0, 1000), y = stats::runif(n, 0, 1000), + a = stats::rnorm(n)), coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + stats::rnorm(n, 0, 0.3) + d +} + +test_that("the include_coords caution advises blocked folds without predicting failure", { + skip_if_not_installed("ranger") + rm(list = ls(spatialkit:::.warned_once), envir = spatialkit:::.warned_once) + logged <- paste(capture_spatialkit_log( + fit_rf_model(txt_pts(), "z", "a", num_trees = 50L, include_coords = TRUE)), + collapse = "\n") + expect_match(logged, "include_coords = TRUE") + # The general claim is gone. + expect_no_match(logged, "fail wherever it has not") + expect_no_match(logged, "fail badly") + # What it does say: why the easy scores are optimistic, and what to do. + expect_match(logged, "out-of-bag error and random cross-validation overstate") + expect_match(logged, "blocked or distance-matched folds") + expect_match(logged, "block_kfold") + expect_match(logged, "nndm") + expect_match(logged, "can reverse in a region the data never visited") + expect_match(logged, "once per session") + # Still a logged caution about a choice, not an R warning. + rm(list = ls(spatialkit:::.warned_once), envir = spatialkit:::.warned_once) + expect_no_warning(spatialkit_quiet_fit <- suppressMessages( + fit_rf_model(txt_pts(), "z", "a", num_trees = 50L, include_coords = TRUE))) +}) + +test_that("print() says when a forest uses no spatial information", { + skip_if_not_installed("ranger") + plain <- fit_rf_model(txt_pts(), "z", "a", num_trees = 50L) + out <- utils::capture.output(print(plain)) + expect_true(any(grepl("Coords as predictors: no - no spatial information used", + out, fixed = TRUE))) + with_xy <- suppressMessages( + fit_rf_model(txt_pts(), "z", "a", num_trees = 50L, include_coords = TRUE)) + out_xy <- utils::capture.output(print(with_xy)) + expect_true(any(grepl("Coords as predictors: YES - score with blocked folds", + out_xy, fixed = TRUE))) + expect_false(any(grepl("no spatial information used", out_xy, fixed = TRUE))) +}) + +test_that("the caution says how to compare the two forests, and the two calls pair up", { + skip_if_not_installed("ranger") + rm(list = ls(spatialkit:::.warned_once), envir = spatialkit:::.warned_once) + logged <- paste(capture_spatialkit_log( + fit_rf_model(txt_pts(), "z", "a", num_trees = 50L, include_coords = TRUE)), + collapse = "\n") + # The advice was "compare it on the same folds", with no word on how. + expect_match(logged, "pass them as `folds` to two cv_rf\\(\\) calls") + expect_match(logged, "one with include_coords = TRUE and one without") + expect_match(logged, "\\?cv_rf shows the two calls") + + # What ?cv_rf and ?fit_rf_model show: folds built once, handed to both + # calls. Each fold then holds out the same rows in both, so the per-fold + # tables pair up row for row. + d <- txt_pts(n = 160, seed = 2) + folds <- suppressWarnings(suppressMessages( + make_folds(d, k = 4, method = "block_kfold", seed = 1))) + plain <- suppressMessages(cv_rf(d, "z", "a", folds = folds, num_trees = 50L)) + with_xy <- suppressMessages(cv_rf(d, "z", "a", folds = folds, num_trees = 50L, + include_coords = TRUE)) + key <- function(cv) cv$predictions[order(cv$predictions$`..row_id`), + c("..row_id", "fold")] + expect_identical(key(plain), key(with_xy)) + expect_identical(plain$fold_metrics$fold, with_xy$fold_metrics$fold) + expect_false(is.null(plain$fold_metrics$n_test)) + expect_identical(plain$fold_metrics$n_test, with_xy$fold_metrics$n_test) + expect_identical(plain$fold_metrics$n_train, with_xy$fold_metrics$n_train) + expect_length(plain$fold_metrics$RMSE - with_xy$fold_metrics$RMSE, 4L) + expect_true(all(is.finite(c(plain$overall$RMSE, with_xy$overall$RMSE)))) + # The forests do differ: one of them split on location. + expect_false(isTRUE(all.equal(plain$overall$RMSE, with_xy$overall$RMSE))) +}) diff --git a/tests/testthat/test-fix-aoa-rf-distances.R b/tests/testthat/test-fix-aoa-rf-distances.R new file mode 100644 index 00000000..f5aef73c --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-distances.R @@ -0,0 +1,244 @@ +# tests/testthat/test-fix-aoa-rf-distances.R +# --------------------------------------------------------------------------- +# Two defects in the reference distances of area_of_applicability(). +# +# (a) The dense path (no FNN) built squared distances as +# |a|^2 + |b|^2 - 2ab, which for an exact copy of a reference row is a +# few ulp away from 0: clamped to 0 for most copies, about 1e-8 for the +# rest. Against a threshold at or near 0 that put exact copies of +# training rows outside the AOA and kept a threshold that should have +# been 0 just above it. The distance returned is now recomputed +# exactly, so the two paths agree. +# +# (b) With folds = NULL a training row that repeats another's predictor +# values was its "nearest other row" at distance 0. Sixty sites visited +# four times gave a threshold of 0 and 30 of 200 new points inside (the +# 30 exact copies), with a log line only. A repeat is the same point of +# predictor space: the reference is the nearest row with different +# values. Where folds split the repeats the threshold is 0 by +# definition, and that is a warning with a class. +# --------------------------------------------------------------------------- + +# 60 sites visited 4 times, and 200 new rows of which the first 30 are exact +# copies of a training row. The layout the defect was reported on. +dist_twins <- function() { + set.seed(1) + site <- data.frame(a = stats::rnorm(60, 50, 10), b = stats::rnorm(60, 1000, 300), + c = stats::rnorm(60, 0.01, 0.002)) + tr <- site[rep(1:60, each = 4), ] + nw <- rbind(site[1:30, ], + data.frame(a = stats::rnorm(170, 50, 10), + b = stats::rnorm(170, 1000, 300), + c = stats::rnorm(170, 0.01, 0.002))) + rownames(tr) <- NULL; rownames(nw) <- NULL + list(tr = tr, nw = nw, site = rep(1:60, each = 4)) +} +dist_pv <- c("a", "b", "c") + + +# --- (a) the dense path ------------------------------------------------------ + +test_that("the dense path gives an exact copy of a reference row distance 0", { + set.seed(2) + D <- scale(cbind(stats::rnorm(200, 50, 10), stats::rnorm(200, 1000, 300), + stats::rnorm(200, 0.01, 0.002), stats::rnorm(200))) + attr(D, "scaled:center") <- NULL; attr(D, "scaled:scale") <- NULL + Q <- D[sample(200, 120), , drop = FALSE] + d <- .aoa_min_dist(Q, D, use_fnn = FALSE) + # The fast formula alone left about one copy in ten near 1e-8. + expect_identical(d, rep(0, 120)) + # Whatever the block size. + expect_identical(.aoa_min_dist(Q, D, use_fnn = FALSE, chunk_size = 7L), + rep(0, 120)) + # And with repeated reference rows. + expect_identical(.aoa_min_dist(Q, rbind(D, D[1:50, ]), use_fnn = FALSE), + rep(0, 120)) +}) + +test_that("the dense path finds a copy among near-coincident reference rows", { + set.seed(3) + D <- matrix(stats::rnorm(400), 100, 4) + # A second row within 1e-9 of row 1: the fast formula cannot tell them + # apart, so the exact pass has to look at both. + D2 <- rbind(D, D[1, ] + c(1e-9, 0, 0, 0)) + expect_identical(.aoa_min_dist(D[1, , drop = FALSE], D2, use_fnn = FALSE), 0) + expect_identical(.aoa_min_dist(D2[101, , drop = FALSE], D2, use_fnn = FALSE), 0) + # The leave-one-out distance between the two is their true separation. + loo <- .aoa_min_dist(D2, D2, use_fnn = FALSE, exclude = seq_len(101)) + expect_equal(loo[c(1, 101)], c(1e-9, 1e-9), tolerance = 1e-5) +}) + +test_that("the dense and FNN paths agree to rounding without duplicates", { + skip_if_not_installed("FNN") + set.seed(4) + D <- matrix(stats::rnorm(300 * 5), 300, 5) + Q <- matrix(stats::rnorm(80 * 5), 80, 5) + expect_equal(.aoa_min_dist(Q, D, use_fnn = FALSE), + .aoa_min_dist(Q, D, use_fnn = TRUE), tolerance = 1e-12) + expect_equal(.aoa_train_dist(D, use_fnn = FALSE), + .aoa_train_dist(D, use_fnn = TRUE), tolerance = 1e-12) + lab <- rep(1:5, length.out = 300) + sp <- .aoa_fold_splits(lab, 300) + expect_equal(.aoa_train_dist(D, splits = sp, use_fnn = FALSE), + .aoa_train_dist(D, splits = sp, use_fnn = TRUE), tolerance = 1e-12) +}) + +test_that("with twins split across folds the two paths give the same zeros and flags", { + skip_if_not_installed("FNN") + L <- dist_twins() + set.seed(9) + lab <- sample(rep(1:5, length.out = 240)) + run <- function(fnn) suppressWarnings( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + use_fnn = fnn, folds = lab)) + f <- run(TRUE); d <- run(FALSE) + # The dense path used to report 216 zeros where FNN had 236, copies' DI up + # to 2.65e-08, and 26 of the 30 copies inside. + expect_identical(d$train_DI == 0, f$train_DI == 0) + expect_identical(sum(d$train_DI == 0), 236L) + expect_identical(d$threshold, 0) + expect_identical(f$threshold, 0) + expect_identical(d$aoa$DI[1:30], rep(0, 30)) + expect_identical(d$aoa$AOA, f$aoa$AOA) + expect_identical(sum(d$aoa$AOA[1:30]), 30L) + expect_equal(d$train_DI, f$train_DI, tolerance = 1e-12) + expect_equal(d$aoa$DI, f$aoa$DI, tolerance = 1e-12) +}) + +test_that("a threshold of exactly 0 is not lost on the dense path", { + # 100 sites visited twice; for 78 of them the two visits are in different + # folds, so 156 of 200 training rows (78%) have their twin on the training + # side and a DI of 0. Q3 is then 0 and so is the threshold. The dense + # path used to lose about a tenth of those zeros to rounding, which took + # the share below three quarters: the threshold came out near 1.6e-08 and + # the zero-threshold caution never fired. + set.seed(6) + site <- data.frame(a = stats::rnorm(100, 50, 10), b = stats::rnorm(100, 1000, 300), + c = stats::rnorm(100, 0.01, 0.002), d = stats::rnorm(100)) + tr <- site[rep(1:100, each = 2), ] + rownames(tr) <- NULL + first <- rep(1:5, length.out = 100) + second <- ifelse(seq_len(100) <= 78, first %% 5 + 1, first) + lab <- as.vector(rbind(first, second)) + nw <- data.frame(a = stats::rnorm(50, 50, 10), b = stats::rnorm(50, 1000, 300), + c = stats::rnorm(50, 0.01, 0.002), d = stats::rnorm(50)) + for (fnn in c(FALSE, if (requireNamespace("FNN", quietly = TRUE)) TRUE)) { + expect_warning( + res <- area_of_applicability(nw, train_sf = tr, + predictor_vars = c("a", "b", "c", "d"), + use_fnn = fnn, folds = lab), + class = "spatialkit_aoa_zero_threshold") + expect_identical(sum(res$train_DI == 0), 156L) + expect_identical(res$threshold, 0) + } +}) + + +# --- (b) repeated rows without folds ----------------------------------------- + +test_that("repeat visits no longer set the threshold to 0 without folds", { + L <- dist_twins() + for (fnn in c(FALSE, if (requireNamespace("FNN", quietly = TRUE)) TRUE)) { + # No warning of any kind: the case is handled, not degenerate. + res <- expect_no_warning( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + use_fnn = fnn)) + ded <- area_of_applicability(L$nw, train_sf = unique(L$tr), + predictor_vars = dist_pv, use_fnn = fnn) + # It was: threshold 0, 30 of 200 inside (26 on the dense path). + expect_gt(res$threshold, 0) + expect_gt(res$n_inside, 180L) + expect_identical(res$n_inside, 188L) + expect_identical(res$n_duplicates, 180L) + expect_true(all(res$train_DI > 0)) + expect_length(res$train_DI, 240L) + # Every visit to a site carries its site's reference distance. + expect_identical(res$train_DI, res$train_DI[rep(seq(1, 240, by = 4), each = 4)]) + # The same decisions as the 60 distinct sites give, and the same + # threshold as a distance. The scales differ by known constants only: + # the standard deviations are still taken over all 240 rows (n - 1 is + # 239, not 59, so every scaled distance is sqrt(239 / 236) times the + # distinct-site one), and the normaliser is still the mean pairwise + # distance over all 240 rows, so that a prediction point's DI does not + # depend on whether folds were passed. + expect_identical(res$aoa$AOA, ded$aoa$AOA) + expect_equal(res$threshold * res$normalizer * sqrt(236 / 239), + ded$threshold * ded$normalizer, tolerance = 1e-12) + expect_identical(ded$n_duplicates, 0L) + } +}) + +test_that("the distinct-row reference is logged and printed, not warned", { + L <- dist_twins() + lines <- capture_spatialkit_log( + res <- area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv)) + expect_true(log_has(lines, "180 of 240 training rows repeat another row's predictor values exactly \\(60 distinct points\\)")) + expect_false(log_has(lines, "threshold is 0")) + out <- utils::capture.output(print(res)) + expect_true(any(grepl("180 of 240 rows repeat another's values", out, fixed = TRUE))) +}) + +test_that("a layer with no repeated row is computed on its rows as given", { + skip_if_not_installed("FNN") + set.seed(8) + tr <- data.frame(a = stats::rnorm(150), b = stats::rnorm(150, 5, 2)) + nw <- data.frame(a = stats::rnorm(40), b = stats::rnorm(40, 5, 2)) + res <- area_of_applicability(nw, train_sf = tr, predictor_vars = c("a", "b"), + weights = NULL) + expect_identical(res$n_duplicates, 0L) + # By hand, the way it was always done: nearest other row over the mean + # pairwise distance. + X <- as.matrix(tr) + sc <- .aoa_scaling(X) + Z <- .aoa_apply_scaling(X, sc) + nn <- as.numeric(FNN::get.knn(Z, k = 1L)$nn.dist[, 1L]) + expect_identical(res$train_DI, nn / mean(as.numeric(stats::dist(Z)))) + expect_identical(res$threshold, .aoa_threshold(res$train_DI)) + g <- .aoa_row_groups(Z) + expect_identical(g$keep, seq_len(150)) + expect_identical(g$n_dup, 0L) +}) + +test_that(".aoa_row_groups groups exactly equal rows and nothing else", { + X <- rbind(c(1, 2), c(3, 4), c(1, 2), c(1, 2 + 1e-12), c(3, 4), c(0, 0)) + g <- .aoa_row_groups(X) + expect_identical(g$keep, c(1L, 2L, 4L, 6L)) + expect_identical(g$map, c(1L, 2L, 1L, 3L, 2L, 4L)) + expect_identical(g$n_dup, 2L) + one <- .aoa_row_groups(matrix(5, 1, 3)) + expect_identical(one$n_dup, 0L) +}) + +test_that("folds that split the repeats warn with a class; folds that keep them do not", { + L <- dist_twins() + set.seed(9) + lab <- sample(rep(1:5, length.out = 240)) + cond <- NULL + res <- withCallingHandlers( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + folds = lab), + spatialkit_aoa_zero_threshold = function(w) { + cond <<- w; invokeRestart("muffleWarning") + }) + expect_s3_class(cond, "spatialkit_aoa_zero_threshold") + expect_s3_class(cond, "warning") + expect_match(conditionMessage(cond), "threshold is 0 because 236 of 240 training rows") + expect_match(conditionMessage(cond), "leave_location_out") + expect_identical(res$threshold, 0) + expect_true(is.na(res$n_duplicates)) + # tryCatch() by class is what a script would write. + caught <- tryCatch( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + folds = lab), + spatialkit_aoa_zero_threshold = function(w) "caught") + expect_identical(caught, "caught") + # One fold per site keeps every visit together: an ordinary threshold. + by_site <- expect_no_warning( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + folds = L$site %% 5)) + expect_gt(by_site$threshold, 0) + # A threshold the caller supplied is theirs: nothing to warn about. + expect_no_warning( + area_of_applicability(L$nw, train_sf = L$tr, predictor_vars = dist_pv, + folds = lab, threshold = 0.4)) +}) diff --git a/tests/testthat/test-fix-aoa-rf-factors.R b/tests/testthat/test-fix-aoa-rf-factors.R new file mode 100644 index 00000000..df1a44ef --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-factors.R @@ -0,0 +1,289 @@ +# tests/testthat/test-fix-aoa-rf-factors.R +# --------------------------------------------------------------------------- +# Factor predictors, in the forest and in its area of applicability. +# +# (a) fit_rf_model() called ranger() without respect.unordered.factors, +# whose default for a regression forest is "ignore": a nominal factor is +# split on the order its levels are stored in. With a 40-level factor +# carrying random level effects the test RMSE was 1.05 that way against +# 0.57 with "order", the handling ranger's help recommends. "order" is +# now what an unordered factor or character predictor gets unless the +# caller passes the argument through `...`. +# +# (b) area_of_applicability() refused a forest fitted with a factor +# predictor outright. It still refuses by default, naming two ways +# forward: categorical = "indicator" and categorical = "drop". +# --------------------------------------------------------------------------- + +fac_pts <- function(n = 1500, L = 40, seed = 1) { + set.seed(seed) + g <- factor(sample(sprintf("c%02d", seq_len(L)), n, TRUE)) + eff <- stats::rnorm(L, 0, 2); names(eff) <- levels(g) + a <- stats::rnorm(n) + d <- sf::st_as_sf( + data.frame(x = stats::runif(n, 0, 1e4), y = stats::runif(n, 0, 1e4), a, g), + coords = c("x", "y"), crs = 32632) + d$z <- unname(eff[as.character(g)]) + a + stats::rnorm(n, 0, 0.5) + d +} +fac_rmse <- function(fit, te) sqrt(mean((predict(fit, te) - te$z)^2)) + + +# --- (a) the forest ---------------------------------------------------------- + +test_that("a nominal factor is split by response order by default", { + skip_if_not_installed("ranger") + d <- fac_pts() + tr <- d[1:1000, ]; te <- d[1001:1500, ] + f_def <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 200) + f_ord <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 200, + respect.unordered.factors = "order") + f_ign <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 200, + respect.unordered.factors = "ignore") + r_def <- fac_rmse(f_def, te); r_ord <- fac_rmse(f_ord, te); r_ign <- fac_rmse(f_ign, te) + + # The default is the "order" forest, not the "ignore" one it used to be. + expect_equal(r_def, r_ord, tolerance = 0.05) + expect_identical(predict(f_def, te), predict(f_ord, te)) + expect_lt(r_def, 0.75 * r_ign) + + expect_identical(f_def$info$respect_unordered_factors, "order") + expect_identical(f_def$info$categorical_predictors, "g") + # What the caller passes through `...` is what ranger gets, and is recorded. + expect_identical(f_ign$info$respect_unordered_factors, "ignore") + expect_false(identical(predict(f_ign, te), predict(f_def, te))) + + out <- utils::capture.output(print(f_def)) + expect_true(any(grepl("Categorical: g split by levels ordered by mean response", + out, fixed = TRUE))) + expect_true(any(grepl("stored level order", + utils::capture.output(print(f_ign)), fixed = TRUE))) +}) + +test_that("predictions do not depend on the level order newdata carries", { + skip_if_not_installed("ranger") + d <- fac_pts(n = 600, L = 12, seed = 2) + tr <- d[1:400, ]; te <- d[401:600, ] + fit <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 100) + p0 <- predict(fit, te) + te_rev <- te + te_rev$g <- factor(as.character(te$g), levels = rev(levels(te$g))) + expect_identical(predict(fit, te_rev), p0) + # Fewer levels than the forest was grown with, and a character column. + te_few <- te[as.character(te$g) %in% levels(te$g)[1:5], ] + keep <- which(as.character(te$g) %in% levels(te$g)[1:5]) + te_few$g <- droplevels(te_few$g) + expect_identical(predict(fit, te_few), p0[keep]) + te_chr <- te; te_chr$g <- as.character(te$g) + expect_identical(predict(fit, te_chr), p0) + + # A level the forest never saw is still an error naming it. + te_new <- te[1:5, ] + te_new$g <- factor(c("zz", as.character(te_new$g[-1]))) + expect_error(predict(fit, te_new), "level\\(s\\) the forest was never grown with.*zz") +}) + +test_that("a character predictor is treated as a nominal factor", { + skip_if_not_installed("ranger") + d <- fac_pts(n = 900, L = 20, seed = 3) + d$g <- as.character(d$g) + tr <- d[1:600, ]; te <- d[601:900, ] + f_def <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 150) + f_ign <- fit_rf_model(tr, "z", c("a", "g"), importance = "none", num_trees = 150, + respect.unordered.factors = "ignore") + expect_identical(f_def$info$respect_unordered_factors, "order") + expect_lt(fac_rmse(f_def, te), 0.85 * fac_rmse(f_ign, te)) +}) + +test_that("ordered factors and numeric-only forests are left as they were", { + skip_if_not_installed("ranger") + d <- fac_pts(n = 300, L = 5, seed = 4) + d$o <- factor(as.character(d$g), levels = levels(d$g), ordered = TRUE) + f_o <- fit_rf_model(d, "z", c("a", "o"), importance = "none", num_trees = 50) + expect_true(is.na(f_o$info$respect_unordered_factors)) + expect_identical(f_o$info$categorical_predictors, character(0)) + expect_false(any(grepl("Categorical", utils::capture.output(print(f_o))))) + # ranger's own call, with nothing added: the same forest. + r_o <- ranger::ranger(x = sf::st_drop_geometry(d)[, c("a", "o")], y = d$z, + num.trees = 50L, seed = 123L, importance = "none", + num.threads = 1L) + expect_equal(f_o$engine$predictions, r_o$predictions) + + # splitrule = "extratrees" has a default of its own in ranger ("partition"), + # which is left to it. + f_x <- fit_rf_model(d, "z", c("a", "g"), importance = "none", num_trees = 50, + splitrule = "extratrees") + expect_identical(f_x$info$respect_unordered_factors, "partition") + r_x <- ranger::ranger(x = sf::st_drop_geometry(d)[, c("a", "g")], y = d$z, + num.trees = 50L, seed = 123L, importance = "none", + num.threads = 1L, splitrule = "extratrees") + expect_equal(f_x$engine$predictions, r_x$predictions) + + f_n <- fit_rf_model(d, "z", "a", importance = "none", num_trees = 50) + expect_true(is.na(f_n$info$respect_unordered_factors)) + r_n <- ranger::ranger(x = sf::st_drop_geometry(d)[, "a", drop = FALSE], y = d$z, + num.trees = 50L, seed = 123L, importance = "none", + num.threads = 1L) + expect_equal(f_n$engine$predictions, r_n$predictions) +}) + + +# --- (b) the area of applicability ------------------------------------------- + +fac_aoa_pts <- function(n = 200, seed = 5, levels = c("urban", "rural", "forest")) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = stats::runif(n, 0, 1e3), y = stats::runif(n, 0, 1e3), + a = stats::rnorm(n), g = factor(sample(levels, n, TRUE))), + coords = c("x", "y"), crs = 32632) + d$z <- d$a + (d$g == "urban") + stats::rnorm(n, 0, 0.2) + d +} + +test_that("a forest with a factor predictor is refused with the two ways forward", { + skip_if_not_installed("ranger") + d <- fac_aoa_pts() + fit <- fit_rf_model(d, "z", c("a", "g"), num_trees = 100) + expect_error(area_of_applicability(d, model = fit), + "not numeric or logical: .g.*categorical = \"indicator\".*categorical = \"drop\"") +}) + +test_that("categorical = \"indicator\" gives the forest an area of applicability", { + skip_if_not_installed("ranger") + d <- fac_aoa_pts() + fit <- fit_rf_model(d, "z", c("a", "g"), num_trees = 100) + nd <- fac_aoa_pts(120, seed = 6) + res <- area_of_applicability(nd, model = fit, categorical = "indicator") + expect_s3_class(res, "aoa") + expect_identical(res$predictor_vars, c("a", "g")) + expect_identical(res$categorical_vars, "g") + expect_identical(res$params$categorical, "indicator") + expect_identical(names(res$weights), c("a", "g")) + expect_identical(names(res$scaling$scale), + c("a", "g=forest", "g=rural", "g=urban")) + # Rows on seen levels with ordinary numeric values are inside. + expect_gt(mean(res$aoa$AOA), 0.85) + expect_true(all(is.finite(res$aoa$DI))) + + # The scale the three indicator columns share: sqrt(1 - sum(p^2)). + p <- as.numeric(table(d$g)) / nrow(d) + expect_equal(unname(res$scaling$scale[-1]), rep(sqrt(1 - sum(p^2)), 3), + tolerance = 1e-12) + + # A level no training row has is outside, with DI = Inf and a count. + nd2 <- nd + nd2$g <- factor(c(rep("desert", 7), as.character(nd$g[-(1:7)]))) + expect_warning( + res2 <- area_of_applicability(nd2, model = fit, categorical = "indicator"), + "7 of 120 prediction row\\(s\\) carry a level of .g. that no training row has") + expect_true(all(is.infinite(res2$aoa$DI[1:7]))) + expect_false(any(res2$aoa$AOA[1:7])) + expect_identical(res2$aoa$DI[-(1:7)], res$aoa$DI[-(1:7)]) + expect_true(any(grepl("7 outside on a level no training row has", + utils::capture.output(print(res2)), fixed = TRUE))) + + # A character column in newdata matches by value; a missing level is NA. + nd3 <- nd; nd3$g <- as.character(nd$g); nd3$g[3] <- NA + res3 <- area_of_applicability(nd3, model = fit, categorical = "indicator") + expect_true(is.na(res3$aoa$DI[3])) + expect_identical(res3$aoa$DI[-3], res$aoa$DI[-3]) +}) + +test_that("the indicator distance is the same between any two levels", { + # Three levels with very different shares and no other predictor: the + # distance from a row to the nearest row on another level must not depend + # on which levels they are. + tr <- data.frame(g = rep(c("a", "b", "c"), times = c(60, 30, 10)), + stringsAsFactors = FALSE) + nd <- data.frame(g = c("a", "b", "c"), stringsAsFactors = FALSE) + res <- area_of_applicability(nd, train_sf = tr, predictor_vars = "g", + categorical = "indicator") + expect_identical(res$aoa$DI, c(0, 0, 0)) + # Leave-one-out on the three distinct rows: each is sqrt(2 / (1 - sum(p^2))) + # from the others, in units of the mean pairwise distance. + p <- c(0.6, 0.3, 0.1) + step <- sqrt(2 / (1 - sum(p^2))) + expect_equal(unique(res$train_DI * res$normalizer), step, tolerance = 1e-12) +}) + +test_that("categorical = \"drop\" computes the index on the numeric predictors", { + skip_if_not_installed("ranger") + d <- fac_aoa_pts() + fit <- fit_rf_model(d, "z", c("a", "g"), num_trees = 100) + nd <- fac_aoa_pts(80, seed = 7) + lines <- capture_spatialkit_log( + res <- area_of_applicability(nd, model = fit, categorical = "drop", + weights = NULL)) + expect_true(log_has(lines, "categorical = \"drop\": the index is computed on a alone")) + expect_identical(res$predictor_vars, "a") + expect_identical(res$categorical_vars, "g") + ref <- area_of_applicability(nd, train_sf = d, predictor_vars = "a") + expect_identical(res$aoa$DI, ref$aoa$DI) + expect_true(any(grepl("categorical : g left out of the index", + utils::capture.output(print(res)), fixed = TRUE))) + # Nothing left to measure is an error, not an empty index. + expect_error(area_of_applicability(nd, train_sf = d, predictor_vars = "g", + categorical = "drop"), + "leaves no predictor") +}) + +test_that("a model without categorical predictors is unaffected by `categorical`", { + set.seed(8) + tr <- data.frame(a = stats::rnorm(100), b = stats::rnorm(100)) + nd <- data.frame(a = stats::rnorm(40), b = stats::rnorm(40)) + ref <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b")) + for (how in c("indicator", "drop")) { + res <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + categorical = how) + expect_identical(res$aoa$DI, ref$aoa$DI) + expect_identical(res$threshold, ref$threshold) + expect_identical(res$categorical_vars, character(0)) + } + # Numeric when the index is defined, a factor in newdata: no setting can + # reconcile them, and the error says that instead of offering one. + nd_bad <- nd; nd_bad$b <- factor(round(nd$b)) + expect_error(area_of_applicability(nd_bad, train_sf = tr, + predictor_vars = c("a", "b"), + categorical = "indicator"), + "numeric or logical in the training data but categorical in `newdata`") +}) + +test_that("dropped_vars is a character vector, by predictor or by level column", { + # With nothing dropped it is character(0), as it always was. The naming + # of dropped indicator columns went through ifelse(), which returns + # logical(0) for an empty test, so every result with no constant predictor + # carried a logical there. + set.seed(9) + tr <- data.frame(a = stats::rnorm(60), b = stats::rnorm(60), k = 3) + nd <- data.frame(a = stats::rnorm(20), b = stats::rnorm(20), k = 3) + res <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b")) + expect_identical(res$dropped_vars, character(0)) + # A constant numeric predictor is named as itself. + res_k <- area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "b", "k")) + expect_identical(res_k$dropped_vars, "k") + + # Indicator coding. A factor with one level among the training rows is + # dropped whole and named as the predictor; a single level column of a + # factor that is kept (its only row removed for a missing value elsewhere) + # is named as the column. + tr$g <- rep(c("u", "f"), 30) + tr$one <- "only" + nd$g <- rep(c("u", "f"), 10) + nd$one <- "only" + res_i <- area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "g", "one"), + categorical = "indicator") + expect_identical(res_i$dropped_vars, "one") + expect_identical(res_i$predictor_vars, c("a", "g")) + tr2 <- tr + tr2$g[1] <- "r"; tr2$a[1] <- NA + res_c <- area_of_applicability(nd, train_sf = tr2, predictor_vars = c("a", "g"), + categorical = "indicator") + expect_identical(res_c$dropped_vars, "g=r") + expect_identical(res_c$predictor_vars, c("a", "g")) + # And with nothing dropped under indicator coding, still character(0). + res_n <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "g"), + categorical = "indicator") + expect_identical(res_n$dropped_vars, character(0)) +}) diff --git a/tests/testthat/test-fix-aoa-rf-location.R b/tests/testthat/test-fix-aoa-rf-location.R new file mode 100644 index 00000000..0fe79cea --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-location.R @@ -0,0 +1,288 @@ +# tests/testthat/test-fix-aoa-rf-location.R +# --------------------------------------------------------------------------- +# area_of_applicability() and models whose predictions depend on location. +# +# The index measured location only for a forest fitted with +# include_coords = TRUE. A GWR's coefficients and a Bayesian fit's Gaussian +# process are functions of location by construction, and for them the index +# was computed on the covariates alone: a GWR with a slope rising eastward, +# trained on x 0-1000, had 13 times the in-extent RMSE at x 1500-2500 and +# 84% of those points inside the AOA. +# +# Location now has an index of its own for those classes (and under +# coords = "yes"): nearest training point in map space, thresholded by the +# same rule and folds, and a point is inside only if inside on both. It is +# kept apart from the covariates because as two more equally weighted +# columns it is diluted: with 12 covariates 89% of points 200-500 units +# beyond the extent still read as inside. +# --------------------------------------------------------------------------- + +loc_pts <- function(m, x0, x1, p = 1, seed = NULL) { + if (!is.null(seed)) set.seed(seed) + d <- data.frame(x = stats::runif(m, x0, x1), y = stats::runif(m, 0, 1000)) + for (j in seq_len(p)) d[[paste0("a", j)]] <- stats::rnorm(m) + d$z <- (1 + d$x / 250) * d$a1 + stats::rnorm(m, 0, 0.3) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + +# A stand-in carrying a class and the fields area_of_applicability() reads, +# for the classes that cannot be fitted in a unit test. +loc_fake_fit <- function(train, vars, cls) { + structure(list(data_sf = train, predictor_vars = vars, response_var = "z", + info = list(), n = nrow(train)), + class = c(cls, "spatial_fit")) +} + + +test_that("a GWR fit has location measured: far points are outside", { + skip_if_not_installed("sp") + trn <- loc_pts(400, 0, 1000, seed = 3) + gf <- suppressWarnings(fit_gwr_model(trn, "z", "a1", bandwidth = 40)) + share <- function(x0, x1) { + nd <- loc_pts(300, x0, x1) + a <- area_of_applicability(nd, model = gf) + list(a = a, inside = mean(a$aoa$AOA), + inside_loc = mean(a$aoa$DI_location <= a$location$threshold), + inside_cov = mean(a$aoa$DI <= a$threshold)) + } + within <- share(0, 1000) + far <- share(1500, 2500) + farther <- share(4000, 5000) + near <- share(1000, 1200) + + # Inside the extent the location index lets nearly every point through, + # and the AOA is the covariate index's, a few points apart. + expect_gt(within$inside_loc, 0.9) + expect_gt(within$inside, within$inside_cov - 0.1) + expect_gt(within$inside, 0.75) + # Beyond it the covariates still say "inside" for most points (that was + # the whole answer before), and location says otherwise. + expect_gt(far$inside_cov, 0.7) + expect_lt(far$inside, 0.1) + expect_lt(farther$inside, 0.1) + expect_lt(near$inside, 0.5) + + a <- far$a + expect_identical(a$params$coords, "location index") + expect_true(all(c("DI", "DI_location", "AOA") %in% names(a$aoa))) + expect_true(is.list(a$location)) + expect_gt(a$location$threshold, 0) + expect_length(a$location$train_DI, 400L) + expect_identical(a$location$n_outside, 300L) + expect_identical(a$n_new, a$n_inside + a$n_outside + a$n_na) + expect_identical(a$aoa$AOA, + a$aoa$DI <= a$threshold & + a$aoa$DI_location <= a$location$threshold) + # The cut-off as a distance is of the order of the spacing of 400 points + # on a 1000 x 1000 square, not of the extent. + cut_m <- a$location$threshold * a$location$normalizer + expect_gt(cut_m, 20); expect_lt(cut_m, 200) + # The geometry handed back is the caller's. + expect_false(any(c("..x", "..y") %in% names(a$aoa))) + + out <- utils::capture.output(print(a)) + expect_true(any(grepl("location : measured on its own", out, fixed = TRUE))) + expect_true(any(grepl("on location", out, fixed = TRUE))) + + # coords = "no" is the covariates alone, as before, with a logged caution. + lines <- capture_spatialkit_log( + off <- area_of_applicability(loc_pts(300, 1500, 2500, seed = 30), model = gf, + coords = "no")) + expect_true(log_has(lines, "coords = \"no\", so location is not measured")) + expect_null(off$location) + expect_false("DI_location" %in% names(off$aoa)) + expect_gt(mean(off$aoa$AOA), 0.7) + expect_identical(off$params$coords, "none") +}) + +test_that("an unsampled gap inside the bounding box is outside for a GWR", { + skip_if_not_installed("sp") + set.seed(1) + f <- function(x) 3 + 2 * sin(2 * pi * x / 800) + xx <- c(stats::runif(200, 0, 300), stats::runif(200, 700, 1000)) + aa <- stats::rnorm(400) + trn <- sf::st_as_sf( + data.frame(x = xx, y = stats::runif(400, 0, 1000), a = aa, + z = f(xx) * aa + stats::rnorm(400, 0, 0.3)), + coords = c("x", "y"), crs = 32632) + gf <- suppressWarnings(fit_gwr_model(trn, "z", "a", bandwidth = 40)) + gap <- sf::st_as_sf( + data.frame(x = stats::runif(200, 400, 600), y = stats::runif(200, 0, 1000), + a = stats::rnorm(200)), coords = c("x", "y"), crs = 32632) + a <- area_of_applicability(gap, model = gf) + expect_lt(mean(a$aoa$AOA), 0.1) + + # The documented surface workflow: the grid takes its covariates from the + # nearest observation, so every cell's covariate DI is 0 and every cell + # used to be inside, the gap included. + surf <- suppressWarnings(suppressMessages( + predict_surface(gf, n_cells = 900, covariates = trn))) + s <- area_of_applicability(surf, model = gf) + gx <- sf::st_coordinates(suppressWarnings(sf::st_centroid(sf::st_geometry(s$aoa))))[, 1] + expect_true(all(s$aoa$DI == 0)) + in_gap <- gx > 400 & gx < 600 + expect_gt(sum(in_gap), 50L) + expect_lt(mean(s$aoa$AOA[in_gap]), 0.1) + expect_gt(mean(s$aoa$AOA[gx < 250 | gx > 750]), 0.8) +}) + +test_that("the location index is not diluted by the number of covariates", { + for (p in c(1L, 12L)) { + trn <- loc_pts(400, 0, 1000, p = p, seed = 100 * p + 1) + pv <- paste0("a", seq_len(p)) + inside <- function(x0, x1) + mean(area_of_applicability(loc_pts(300, x0, x1, p = p), train_sf = trn, + predictor_vars = pv, coords = "yes")$aoa$AOA) + expect_gt(inside(0, 1000), 0.8) + # As two more equally weighted columns: 82-89% inside at 1200-1500 and + # 7-15% at 1500-2500 with 8 to 12 covariates. + expect_lt(inside(1200, 1500), 0.05) + expect_lt(inside(1500, 2500), 0.05) + expect_lt(inside(4000, 5000), 0.05) + } +}) + +test_that("a bayesian_fit and a gwr_fit are location models under coords = \"auto\"", { + trn <- loc_pts(200, 0, 1000, seed = 5) + far <- loc_pts(100, 3000, 4000, seed = 6) + for (cls in c("gwr_fit", "bayesian_fit")) { + fit <- loc_fake_fit(trn, "a1", cls) + a <- area_of_applicability(far, model = fit) + expect_identical(a$params$coords, "location index") + expect_identical(a$n_inside, 0L) + expect_identical(a$location$n_outside, 100L) + } + # Any other fit, and no fit at all, are measured on the covariates alone + # unless asked. + for (fit in list(loc_fake_fit(trn, "a1", "lmsurf_fit"), NULL)) { + a <- if (is.null(fit)) + area_of_applicability(far, train_sf = trn, predictor_vars = "a1") + else area_of_applicability(far, model = fit) + expect_identical(a$params$coords, "none") + expect_null(a$location) + expect_false("DI_location" %in% names(a$aoa)) + expect_gt(a$n_inside, 50L) + } + yes <- area_of_applicability(far, model = loc_fake_fit(trn, "a1", "lmsurf_fit"), + coords = "yes") + expect_identical(yes$n_inside, 0L) +}) + +test_that("the location index uses the folds and handles shared locations", { + trn <- loc_pts(300, 0, 1000, seed = 7) + nd <- loc_pts(200, 0, 1300, seed = 8) + fit <- loc_fake_fit(trn, "a1", "gwr_fit") + fo <- suppressWarnings(suppressMessages( + make_folds(trn, k = 5, method = "block_kfold", seed = 1))) + loo <- area_of_applicability(nd, model = fit) + blk <- suppressWarnings(area_of_applicability(nd, model = fit, folds = fo)) + # A blocked hold-out is further from its training points than a + # leave-one-out neighbour is, in map space as in predictor space. + expect_gt(blk$location$threshold, loo$location$threshold) + expect_identical(blk$aoa$DI_location, loo$aoa$DI_location) + expect_gte(blk$n_inside, loo$n_inside) + + # Four visits to each of 75 sites: without folds a site's other visits are + # the same location, not its neighbours. + site <- loc_pts(75, 0, 1000, seed = 9) + rep4 <- site[rep(1:75, each = 4), ] + rep4$a1 <- stats::rnorm(300) + fit4 <- loc_fake_fit(rep4, "a1", "gwr_fit") + a4 <- expect_no_warning(area_of_applicability(nd, model = fit4)) + expect_gt(a4$location$threshold, 0) + expect_identical(a4$location$n_duplicates, 225L) + expect_identical(a4$n_duplicates, 0L) + # Folds that split the visits: the location threshold is 0, and that is + # the classed warning. + set.seed(10) + lab <- sample(rep(1:5, length.out = 300)) + expect_warning( + z <- area_of_applicability(nd, model = fit4, folds = lab), + class = "spatialkit_aoa_zero_threshold") + expect_identical(z$location$threshold, 0) +}) + +test_that("the location index needs geometry, and a projected CRS", { + trn <- loc_pts(100, 0, 1000, seed = 11) + nd <- loc_pts(20, 0, 1000, seed = 12) + fit <- loc_fake_fit(trn, "a1", "gwr_fit") + expect_error(area_of_applicability(sf::st_drop_geometry(nd), model = fit), + "location is measured.*`newdata` is not.*coords = \"no\"") + expect_s3_class( + area_of_applicability(sf::st_drop_geometry(nd), model = fit, coords = "no"), + "aoa") + ll_tr <- sf::st_transform(trn, 4326); ll_nd <- sf::st_transform(nd, 4326) + expect_error(area_of_applicability(ll_nd, train_sf = ll_tr, + predictor_vars = "a1", coords = "yes"), + "geographic CRS") + # newdata in another CRS is brought into the training one for the + # distances, and handed back as it came. + a_ll <- area_of_applicability(ll_nd, model = fit) + a_pr <- area_of_applicability(nd, model = fit) + expect_equal(a_ll$aoa$DI_location, a_pr$aoa$DI_location, tolerance = 1e-6) + expect_identical(sf::st_crs(a_ll$aoa), sf::st_crs(ll_nd)) + # A row with no geometry cannot be placed: inside on the covariates, not + # classified overall. + nd2 <- nd + sf::st_geometry(nd2)[1] <- sf::st_point() + a2 <- area_of_applicability(nd2, model = fit) + expect_true(is.na(a2$aoa$DI_location[1])) + expect_false(is.na(a2$aoa$DI[1])) + expect_identical(a2$n_new, a2$n_inside + a2$n_outside + a2$n_na) + expect_error(area_of_applicability(nd, model = fit, coords = "sometimes"), + "should be one of") +}) + +test_that("a forest with the coordinates as predictors keeps its own path", { + skip_if_not_installed("ranger") + trn <- loc_pts(200, 0, 1000, seed = 13) + far <- loc_pts(100, 3000, 4000, seed = 14) + rf <- suppressWarnings(suppressMessages( + fit_rf_model(trn, "z", "a1", num_trees = 100, include_coords = TRUE))) + a <- area_of_applicability(far, model = rf) + expect_identical(a$params$coords, "predictors") + expect_identical(a$predictor_vars, c("a1", "..x", "..y")) + expect_null(a$location) + expect_false("DI_location" %in% names(a$aoa)) + expect_identical(a$n_inside, 0L) + expect_identical(area_of_applicability(far, model = rf, coords = "yes")$aoa$DI, + a$aoa$DI) + # coords = "no" turns it off for a forest too, and says so. + lines <- capture_spatialkit_log( + off <- area_of_applicability(far, model = rf, coords = "no")) + expect_true(log_has(lines, "coords = \"no\", so location is not measured")) + expect_identical(off$predictor_vars, "a1") +}) + +test_that("with blocked folds a gap narrower than the hold-out distance reads as inside", { + # Two sampled strips, x 0-300 and 700-1000, and nothing between them. + # Without folds the location cut-off is the spacing of the points, and the + # middle of the gap is outside. With blocked folds it is the distance + # from a held-out block to its training data, which here is wider than + # half the gap, so the same points read as inside: the cross-validated + # error was earned on hold-outs that far from their training rows. The + # help says so; it used to say the index marks unsampled gaps, without + # condition. + set.seed(1) + xx <- c(stats::runif(200, 0, 300), stats::runif(200, 700, 1000)) + trn <- sf::st_as_sf( + data.frame(x = xx, y = stats::runif(400, 0, 1000), a1 = stats::rnorm(400), + z = stats::rnorm(400)), coords = c("x", "y"), crs = 32632) + gap <- sf::st_as_sf( + data.frame(x = stats::runif(200, 400, 600), y = stats::runif(200, 0, 1000), + a1 = stats::rnorm(200)), coords = c("x", "y"), crs = 32632) + fit <- loc_fake_fit(trn, "a1", "gwr_fit") + fo <- suppressWarnings(suppressMessages( + make_folds(trn, k = 5, method = "block_kfold", seed = 1))) + loo <- area_of_applicability(gap, model = fit) + blk <- suppressWarnings(area_of_applicability(gap, model = fit, folds = fo)) + cut <- function(a) a$location$threshold * a$location$normalizer + inside_loc <- function(a) mean(a$aoa$DI_location <= a$location$threshold) + # Every gap point is at least 100 units from the nearest strip. + expect_lt(cut(loo), 100) + expect_identical(inside_loc(loo), 0) + expect_gt(cut(blk), 100) + expect_gt(inside_loc(blk), 0.5) + # The distances themselves do not depend on the folds; the cut-off does. + expect_identical(blk$aoa$DI_location, loo$aoa$DI_location) +}) diff --git a/tests/testthat/test-fix-aoa-rf-plot.R b/tests/testthat/test-fix-aoa-rf-plot.R new file mode 100644 index 00000000..357be79f --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-plot.R @@ -0,0 +1,209 @@ +# tests/testthat/test-fix-aoa-rf-plot.R +# --------------------------------------------------------------------------- +# plot.aoa() and plot.feature_selection() against the results this group of +# fixes changed. +# +# (a) With a location index (a gwr_fit, a bayesian_fit, coords = "yes") +# `n_outside` counts the rows outside on EITHER index. plot.aoa() printed +# it beside the predictor threshold: a GWR result with 10 of 100 rows +# beyond that threshold and all 100 beyond the location one read "100 of +# 100 prediction locations outside (DI > 0.017)", then "90% of those +# inside sit below 51% of the threshold". The count beside "(DI > ...)" +# has to be the predictor index's, `n_outside_predictors`. And under +# categorical = "indicator" a row on a level no training row has was +# captioned "outside on a dropped predictor". +# +# (b) Under a fold-mean baseline select_features_forward() can drop the +# first variable at the end, so `selected` is the walked path without +# it. plot.feature_selection() matched selected[s] to step s and so +# drew sets that were never on the path. +# +# Both plot methods live in R/plotting-diagnostics.R and read the fields the +# two functions return: `n_outside_predictors`, `location`, +# `categorical_vars` and `params$categorical` of an aoa result, and +# `baseline$first` and `baseline$path` of a selection. These tests fail +# when a plot method does not read them; they are not skipped for it, +# because a result drawn wrongly is the defect they are here to catch. +# What a plot says is compared as one value in each test, so such a plot +# method fails each test once and the difference shows every line it got +# wrong. +# --------------------------------------------------------------------------- + +plt_pts <- function(m, x0, x1, seed) { + set.seed(seed) + d <- data.frame(x = stats::runif(m, x0, x1), y = stats::runif(m, 0, 1000), + a = stats::rnorm(m)) + d$z <- d$a + stats::rnorm(m, 0, 0.3) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} +# Carries the class and the fields area_of_applicability() reads. +plt_fake_gwr <- function(train) + structure(list(data_sf = train, predictor_vars = "a", response_var = "z", + info = list(), n = nrow(train)), + class = c("gwr_fit", "spatial_fit")) +plt_lines <- function(s) strsplit(s, "\n", fixed = TRUE)[[1]] +# The subtitle, and the caption's line on location when it has one. The +# share of the threshold in the subtitle's last line varies with the draw +# and is not what these tests are about, so it is written as N%. +plt_aoa_said <- function(p) + gsub("below [0-9]+%", "below N%", + c(plt_lines(p$labels$subtitle), + grep("second index", plt_lines(p$labels$caption), value = TRUE))) +# The caption's sentence on the rows off the axis, on one line. +plt_off_axis <- function(p) { + cap <- gsub("\n", " ", p$labels$caption, fixed = TRUE) + regmatches(cap, regexpr("[0-9]+ prediction locations? outside on .* off the axis", cap)) +} + + +test_that("plot.aoa() counts the predictor index beside the predictor threshold", { + skip_if_not_installed("ggplot2") + trn <- plt_pts(300, 0, 1000, seed = 3) + far <- plt_pts(100, 1500, 2500, seed = 4) + a <- area_of_applicability(far, model = plt_fake_gwr(trn)) + # All 100 are outside on location; far fewer on the predictor. + n_pred <- sum(a$aoa$DI > a$threshold) + expect_identical(a$n_outside, 100L) + expect_identical(a$location$n_outside, 100L) + expect_identical(a$n_outside_predictors, n_pred) + expect_lt(n_pred, 50L) + + # Points across the edge of the training extent: some are outside on the + # predictor, some on location, a few on both, so the three counts differ. + edge <- plt_pts(100, 0, 1300, seed = 6) + e <- area_of_applicability(edge, model = plt_fake_gwr(trn)) + e_pred <- sum(e$aoa$DI > e$threshold) + e_loc <- sum(e$aoa$DI_location > e$location$threshold) + expect_identical(c(e$n_outside_predictors, e$location$n_outside), c(e_pred, e_loc)) + expect_gt(e_pred, 0L) + expect_gt(e_loc, 0L) + expect_gt(e$n_outside, max(e_pred, e_loc)) + expect_lt(e$n_outside, e_pred + e_loc) + + p <- plot(a) + pe <- plot(e) + expect_s3_class(p, "ggplot") + expect_no_error(ggplot2::ggplot_build(p)) + expect_no_error(ggplot2::ggplot_build(pe)) + # Line 1 is the count that goes with "(DI > threshold)": the predictor + # index's, beside the predictor threshold, not the rows outside on either + # index. Line 2 is location, and the total the AOA column gives. Line 3 + # speaks of the predictor index, which is what it is computed from. The + # caption says what the curves are and gives the location threshold. + should_say <- function(r, n_pred) c( + sprintf("%d of 100 prediction locations outside on the predictors (DI > %.3g)", + n_pred, r$threshold), + sprintf("%d outside on location; %d outside the AOA (either)", + r$location$n_outside, r$n_outside), + "90% of those inside on the predictors sit below N% of that threshold", + sprintf(paste0("The curves are the predictor index; location is a second ", + "index (DI_location, threshold %.3g)"), r$location$threshold)) + expect_identical(list(far = plt_aoa_said(p), edge = plt_aoa_said(pe)), + list(far = should_say(a, n_pred), edge = should_say(e, e_pred))) + expect_no_error(ggplot2::ggplot_build(plot(a, type = "histogram"))) + + # Without a location index nothing changes: one count, and it is n_outside. + b <- area_of_applicability(far, train_sf = trn, predictor_vars = "a") + pb <- plot(b) + expect_match(pb$labels$subtitle, + sprintf("^%d of 100 prediction locations outside \\(DI > ", b$n_outside)) + expect_no_match(pb$labels$subtitle, "outside on location") + expect_no_match(pb$labels$caption, "second index") +}) + +test_that("plot.aoa() words DI = Inf as print.aoa() does", { + skip_if_not_installed("ggplot2") + set.seed(5) + tr <- data.frame(a = stats::rnorm(80), g = rep(c("u", "f"), 40), k = 1) + nd <- data.frame(a = stats::rnorm(30), g = c("zzz", "zzz", rep(c("u", "f"), 14)), + k = 1) + a <- suppressWarnings(area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "g"), + categorical = "indicator")) + expect_identical(sum(is.infinite(a$aoa$DI)), 2L) + # Every row on an unseen level: nothing to draw, and plot() stops. + nd3 <- nd; nd3$g <- "zzz" + d <- suppressWarnings(area_of_applicability(nd3, train_sf = tr, + predictor_vars = c("a", "g"), + categorical = "indicator")) + expect_identical(sum(is.infinite(d$aoa$DI)), 30L) + # The caption for the two rows, and the error for the thirty, each say + # which kind of row DI = Inf is under this coding. + expect_identical( + c(caption = plt_off_axis(plot(a)), + error = tryCatch({ plot(d); "plot() did not stop" }, error = conditionMessage)), + c(caption = paste0("2 prediction locations outside on a level no training ", + "row has, or on a dropped predictor (DI = Inf) are off ", + "the axis"), + error = paste0("plot.aoa(): no finite dissimilarity index to plot: 30 of ", + "30 prediction locations are outside on a level no ", + "training row has, or on a predictor dropped for having ", + "no training variance (DI = Inf)."))) + # A dropped numeric predictor, and nothing categorical: as before. + nd2 <- nd; nd2$k[1] <- 5 + b <- suppressWarnings(area_of_applicability(nd2, train_sf = tr, + predictor_vars = c("a", "k"))) + expect_identical(plt_off_axis(plot(b)), + "1 prediction location outside on a dropped predictor (DI = Inf) is off the axis") +}) + +test_that("plot.feature_selection() draws the walked path when the first variable was dropped", { + skip_if_not_installed("ggplot2") + # `proxy` is the best single predictor and of no use once a1 and a2 are in. + set.seed(4001) + n <- 240 + d <- data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + a1 = stats::rnorm(n), a2 = stats::rnorm(n), n1 = stats::rnorm(n)) + d$proxy <- d$a1 + d$a2 + stats::rnorm(n) + d$z <- d$a1 + d$a2 + stats::rnorm(n, 0, 0.5) + d <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + refusing <- function(tr, v) { + if (!length(v)) stop("this backend needs at least one predictor", call. = FALSE) + lm_spatial_fit(tr, "z", v) + } + sel <- suppressWarnings(suppressMessages( + select_features_forward(d, "z", c("proxy", "a1", "a2", "n1"), refusing, + k = 4, seed = 1, quiet = TRUE))) + expect_true(sel$baseline$first$dropped) + path <- sel$baseline$path + expect_identical(path[1], "proxy") + expect_identical(sel$selected, path[-1]) + # The selected set is not a step of the walk, so its score is in no row of + # the history: a plot that looks it up there marks another set. + h <- sel$history + expect_false(any(abs(h$score - sel$score) < 1e-12, na.rm = TRUE)) + + p <- plot(sel) + b <- ggplot2::ggplot_build(p) + geoms <- vapply(p$layers, function(l) class(l$geom)[1L], character(1)) + lab <- b$data[[which(geoms == "GeomText")]] + pts <- which(geoms == "GeomPoint") + chosen <- b$data[[pts[length(pts)]]] + # The labelled points are the sets the sweep walked: step s is path[s], at + # the score the history gives that set, and the variable taken out says + # so. The red mark is the selected set: its size, and its own score. + at <- lab[match(seq_along(path), lab$x), ] + expect_equal( + list(score = at$y, label = at$label, red_mark = c(chosen$x, chosen$y), + caption_names_the_drop = grepl( + "proxy was added first without a test and dropped at the end", + p$labels$caption, fixed = TRUE)), + list(score = vapply(seq_along(path), function(s) + h$score[h$step == s & h$variable == path[s]], numeric(1)), + label = c("proxy (dropped at the end)", path[-1]), + red_mark = c(length(sel$selected), sel$score), + caption_names_the_drop = TRUE)) + expect_match(p$labels$caption, sprintf("Selected: %s", paste(sel$selected, collapse = ", "))) + + # Nothing dropped: the path is the selection, as before. + own <- suppressWarnings(suppressMessages( + select_features_forward(d, "z", c("proxy", "a1", "a2", "n1"), + function(tr, v) lm_spatial_fit(tr, "z", v), + k = 4, seed = 1, quiet = TRUE))) + po <- plot(own) + expect_no_match(po$labels$caption, "dropped at the end") + bo <- ggplot2::ggplot_build(po) + lab_o <- bo$data[[which(vapply(po$layers, function(l) class(l$geom)[1L], + character(1)) == "GeomText")]] + expect_identical(lab_o$label[lab_o$x == 1], own$selected[1]) +}) diff --git a/tests/testthat/test-fix-aoa-rf-selection.R b/tests/testthat/test-fix-aoa-rf-selection.R new file mode 100644 index 00000000..bce8ea8c --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-selection.R @@ -0,0 +1,597 @@ +# tests/testthat/test-fix-aoa-rf-selection.R +# --------------------------------------------------------------------------- +# select_features_forward(): a baseline for every learner, and a step rule +# that does not accept fold noise. +# +# (a) fit_rf_model() refuses an empty predictor set, and fit_gwr_model() did +# when this was written (it now fits the local mean for character(0)), so +# with either as the learner the sweep had no step-0 score and the first +# variable was accepted unconditionally: on a response unrelated to +# every candidate a forest sweep selected 2.6 to 3.2 variables in 10 +# draws of 10. The training-fold mean is now the baseline for such a +# learner (it needs no model), the first variable is provisional, and +# the finished set is kept only if it beats that baseline. +# +# (b) With tol = 0 any gain was accepted, however far inside the +# fold-to-fold noise. The default rule now also asks the mean per-fold +# gain to exceed one standard error of itself; rule = "tol" is the old +# behaviour. +# +# (c) Under the fold-mean baseline the first variable is added without a +# test, and the test of the finished set does not show that it belongs +# there. A kept path of two or more is scored once more without it, +# and it is dropped when the set is no better with it by the rule. +# +# (d) A GWR sweep on the fold-mean baseline is pointed to a `null_fn` that +# can be written with exported functions: the kernel-weighted local +# mean of the help page's example. +# --------------------------------------------------------------------------- + +sel_noise <- function(n = 200, seed = 1) { + set.seed(1000 + seed) + d <- data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + c1 = stats::rnorm(n), c2 = stats::rnorm(n), + c3 = stats::rnorm(n), c4 = stats::runif(n)) + d$z <- stats::rnorm(n) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} +sel_signal <- function(n = 250, seed = 1, b = 0.5) { + set.seed(2000 + seed) + d <- data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + a1 = stats::rnorm(n), a2 = stats::rnorm(n), + n1 = stats::rnorm(n), n2 = stats::rnorm(n), n3 = stats::rnorm(n)) + d$z <- b * d$a1 + b * d$a2 + stats::rnorm(n) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} +sel_rf <- function(tr, v) + fit_rf_model(tr, "z", v, num_trees = 100, importance = "none") +sel_quiet <- function(expr) suppressWarnings(suppressMessages(expr)) + +# The fold-mean RMSE on the folds the sweep builds, by hand. +sel_fold_mean_rmse <- function(d, cands, k, seed) { + f <- sel_quiet(make_folds(d, k = k, method = "block_kfold", seed = seed, + response_var = "z", predictor_vars = cands)) + e <- unlist(lapply(f$folds, function(s) d$z[s$test] - mean(d$z[s$train]))) + sqrt(mean(e^2)) +} + +# A learner that, like the forest backend, refuses an empty set. +sel_lm_refusing <- function(tr, v) { + if (!length(v)) stop("this backend needs at least one predictor", call. = FALSE) + lm_spatial_fit(tr, "z", v) +} +sel_lm <- function(tr, v) lm_spatial_fit(tr, "z", v) + + +# --- (a) the baseline -------------------------------------------------------- + +test_that("a forest sweep has a baseline, and noise is not selected", { + skip_if_not_installed("ranger") + cands <- paste0("c", 1:4) + for (s in 1:3) { + d <- sel_noise(seed = s) + sel <- sel_quiet(select_features_forward(d, "z", cands, sel_rf, k = 4, + seed = s, quiet = TRUE)) + # It used to return one to four of these every time. + expect_identical(sel$selected, character(0)) + expect_true(is.na(sel$score)) + h <- sel$history + expect_identical(h$step[1], 0L) + expect_identical(h$variable[1], "") + expect_identical(sel$baseline$type, "fold mean") + expect_identical(sel$params$baseline, "fold mean") + expect_equal(sel$baseline$score, sel_fold_mean_rmse(d, cands, 4, s), + tolerance = 1e-10) + expect_identical(h$score[1], sel$baseline$score) + # The path the sweep reached is kept for inspection, with its verdict. + expect_gt(length(sel$baseline$path), 0L) + expect_false(sel$baseline$kept) + expect_true(all(sel$baseline$path %in% cands)) + } +}) + +test_that("a forest sweep still finds real predictors", { + skip_if_not_installed("ranger") + # z = 0.5 a1 + 0.5 a2 + N(0, 1): a true R2 of 0.33. No single variable + # beats the fold mean here, which is why the first step is provisional. + d <- sel_signal(seed = 1) + sel <- sel_quiet(select_features_forward(d, "z", c("a1", "a2", "n1", "n2", "n3"), + sel_rf, k = 4, seed = 1, quiet = TRUE)) + expect_true(all(c("a1", "a2") %in% sel$selected)) + expect_identical(sel$baseline$type, "fold mean") + expect_true(sel$baseline$kept) + expect_gt(sel$baseline$gain, 0) + expect_gt(sel$baseline$fold_gain, sel$baseline$fold_gain_se) + expect_identical(sel$baseline$path, sel$selected) + expect_lt(sel$score, sel$baseline$score) +}) + +test_that("the fold-mean baseline and its verdict are announced", { + d <- sel_noise(n = 150, seed = 4) + msgs <- character(0) + sel <- withCallingHandlers( + suppressWarnings(select_features_forward(d, "z", c("c1", "c2"), + sel_lm_refusing, k = 3, seed = 4)), + message = function(m) { + msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") + }) + expect_true(any(grepl("baseline is the training-fold mean", msgs))) + expect_true(any(grepl("The first variable is provisional", msgs))) + expect_true(any(grepl("\\[provisional\\]", msgs))) + expect_false(any(grepl("accepted unconditionally", msgs))) + if (!length(sel$selected)) + expect_true(any(grepl("does not beat the training-fold mean by the rule", msgs))) + # The probe of the empty set stays out of the console log. + lines <- capture_spatialkit_log( + sel_quiet(select_features_forward(d, "z", c("c1", "c2"), sel_lm_refusing, + k = 3, seed = 4, quiet = TRUE)), + level = logger::INFO) + expect_false(log_has(lines, "fit failed; skipping")) +}) + +test_that("a learner that fits its own null model is tested against it at step 1", { + d <- sel_signal(n = 200, seed = 2, b = 1) + cands <- c("a1", "a2", "n1") + own <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 2, quiet = TRUE)) + expect_identical(own$baseline$type, "null model") + expect_true(all(c("a1", "a2") %in% own$selected)) + # The intercept-only lm IS the training-fold mean, so a refusing learner + # falls back to the same step-0 score. + ref <- sel_quiet(select_features_forward(d, "z", cands, sel_lm_refusing, k = 4, + seed = 2, quiet = TRUE)) + expect_identical(ref$baseline$type, "fold mean") + expect_equal(ref$baseline$score, own$baseline$score, tolerance = 1e-10) + expect_identical(ref$selected, own$selected) + # And `null_fn` supplies a no-predictor model for a learner without one. + nf <- sel_quiet(select_features_forward( + d, "z", cands, sel_lm_refusing, k = 4, seed = 2, quiet = TRUE, + null_fn = function(tr) lm_spatial_fit(tr, "z", character(0)))) + expect_identical(nf$baseline$type, "null_fn") + expect_equal(nf$history, own$history) + expect_identical(nf$selected, own$selected) +}) + +test_that("bad rule arguments are refused by name", { + d <- sel_noise(n = 60, seed = 5) + expect_error(select_features_forward(d, "z", "c1", sel_lm, se_mult = -1), + "`se_mult` must be") + expect_error(select_features_forward(d, "z", "c1", sel_lm, se_mult = c(1, 2)), + "`se_mult` must be") + expect_error(select_features_forward(d, "z", "c1", sel_lm, rule = "aic"), + "should be one of") + expect_error(select_features_forward(d, "z", "c1", sel_lm, null_fn = "mean"), + "`null_fn` must be NULL or a function") + expect_error( + sel_quiet(select_features_forward(d, "z", "c1", sel_lm, k = 3, + null_fn = function(tr) stop("no"))), + "`null_fn` gave no cross-validated prediction") +}) + + +# --- (b) the step rule ------------------------------------------------------- + +test_that("history carries what the rule read, and every decision follows from it", { + d <- sel_signal(n = 200, seed = 3, b = 1) + cands <- c("a1", "a2", "n1", "n2", "n3") + sel <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 3, quiet = TRUE)) + h <- sel$history + expect_true(all(c("step", "variable", "score", "n_pred", "gain", "fold_gain", + "fold_gain_se") %in% names(h))) + expect_identical(sel$params$rule, "se") + expect_identical(sel$params$se_mult, 1) + # gain is the pooled improvement over the set the candidate was added to. + s1 <- h[h$step == 1L, ] + expect_equal(s1$gain, h$score[h$step == 0L] - s1$score, tolerance = 1e-12) + # Per-fold scores: one row per set and fold, and they reproduce fold_gain. + fs <- sel$fold_scores + expect_named(fs, c("step", "variable", "fold", "score")) + expect_identical(nrow(fs), 4L * nrow(h)) + f0 <- fs[fs$step == 0L, ] + fa <- fs[fs$step == 1L & fs$variable == sel$selected[1], ] + d1 <- f0$score[match(fa$fold, f0$fold)] - fa$score + row1 <- s1[s1$variable == sel$selected[1], ] + expect_equal(row1$fold_gain, mean(d1), tolerance = 1e-12) + expect_equal(row1$fold_gain_se, stats::sd(d1) / 2, tolerance = 1e-12) + # Every accepted step cleared both parts of the rule ... + for (s in seq_along(sel$selected)) { + r <- h[h$step == s & h$variable == sel$selected[s], ] + expect_gt(r$gain, 0) + expect_gt(r$fold_gain, r$fold_gain_se) + } + # ... and the step it stopped at did not. + nxt <- h[h$step == length(sel$selected) + 1L, ] + if (nrow(nxt)) { + best <- nxt[which.min(nxt$score), ] + expect_false(isTRUE(best$gain > 0 && best$fold_gain > best$fold_gain_se)) + } +}) + +test_that("the default rule refuses gains the folds do not agree on", { + # One real predictor, one weaker one, four noise candidates; ten draws. + count <- function(rule) { + out <- lapply(1:10, function(s) { + set.seed(3000 + s) + n <- 160 + d <- data.frame(x = stats::runif(n, 0, 1000), y = stats::runif(n, 0, 1000), + a = stats::rnorm(n), b = stats::rnorm(n)) + for (j in 1:4) d[[paste0("n", j)]] <- stats::rnorm(n) + d$z <- d$a + 0.4 * d$b + stats::rnorm(n, 0, 0.7) + d <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + sel_quiet(select_features_forward(d, "z", c("a", "b", paste0("n", 1:4)), + sel_lm, k = 5, seed = s, quiet = TRUE, + rule = rule))$selected + }) + c(noise = sum(vapply(out, function(v) sum(grepl("^n", v)), numeric(1))), + a = sum(vapply(out, function(v) "a" %in% v, logical(1))), + b = sum(vapply(out, function(v) "b" %in% v, logical(1)))) + } + se <- count("se") + tol <- count("tol") + # The strong predictor is never lost, and the weak one mostly kept: the + # rule is not simply refusing everything. (Here: 10 and 10 of 10.) + expect_identical(unname(se[["a"]]), 10) + expect_gte(se[["b"]], 8) + # Fewer noise variables than when any gain is accepted. (Here: 1 against + # 7. Over 40 draws with a weaker second predictor, coefficient 0.3, the + # counts were 7 against 36, with that predictor kept in 34 and 40.) + expect_lt(se[["noise"]], tol[["noise"]]) + expect_lte(se[["noise"]], 3) + expect_gte(tol[["noise"]], 5) +}) + +test_that("rule = \"tol\" accepts any gain above tol, as before", { + d <- sel_signal(n = 200, seed = 6, b = 1) + cands <- c("a1", "a2", "n1", "n2", "n3") + sel <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 6, quiet = TRUE, rule = "tol")) + h <- sel$history + expect_identical(sel$params$rule, "tol") + for (s in seq_along(sel$selected)) { + r <- h[h$step == s & h$variable == sel$selected[s], ] + expect_gt(r$gain, 0) + } + nxt <- h[h$step == length(sel$selected) + 1L, ] + if (nrow(nxt)) expect_false(isTRUE(max(nxt$gain, na.rm = TRUE) > 0)) + # A fold-mean baseline is applied under this rule too: an impossible tol + # leaves nothing selected, where the first variable used to be accepted + # whatever it scored. + none <- sel_quiet(select_features_forward(d, "z", cands, sel_lm_refusing, k = 4, + seed = 6, quiet = TRUE, rule = "tol", + tol = 1e6)) + expect_identical(none$selected, character(0)) + expect_false(none$baseline$kept) + expect_length(none$baseline$path, 1L) + expect_true(none$baseline$path %in% c("a1", "a2")) +}) + +test_that("tol accepts Inf and -Inf, as it did before it was checked", { + d <- sel_signal(n = 160, seed = 6, b = 1) + cands <- c("a1", "a2", "n1") + # Inf: nothing can clear it, so nothing is selected, under either rule and + # with either kind of baseline. (It stopped with "`tol` must be a single + # finite number; got Inf".) + for (rule in c("se", "tol")) { + own <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 6, quiet = TRUE, tol = Inf, + rule = rule)) + expect_identical(own$selected, character(0)) + expect_identical(own$baseline$type, "null model") + expect_identical(own$params$tol, Inf) + ref <- sel_quiet(select_features_forward(d, "z", cands, sel_lm_refusing, k = 4, + seed = 6, quiet = TRUE, tol = Inf, + rule = rule)) + expect_identical(ref$selected, character(0)) + expect_false(ref$baseline$kept) + } + # -Inf puts no floor under a step: with rule = "tol" every candidate is + # added, whatever it scores. + all_in <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 6, quiet = TRUE, tol = -Inf, + rule = "tol")) + expect_setequal(all_in$selected, cands) + # What is not a single number is still refused, by name. + expect_error(select_features_forward(d, "z", cands, sel_lm, tol = NA_real_), + "`tol` must be a single number") + expect_error(select_features_forward(d, "z", cands, sel_lm, tol = c(0, 1)), + "`tol` must be a single number.*length 2") + expect_error(select_features_forward(d, "z", cands, sel_lm, tol = "0"), + "`tol` must be a single number.*character") +}) + +test_that("a GWR sweep on the fold-mean baseline is told what that baseline shows", { + skip_if_not_installed("sp") + d <- sel_signal(n = 120, seed = 7, b = 1) + # Refusing the empty set here, as fit_gwr_model() does, so that the sweep + # falls back to the fold mean whatever fit_gwr_model() does with it. + gwr_fn <- function(tr, v) { + if (!length(v)) stop("a GWR needs at least one predictor", call. = FALSE) + fit_gwr_model(tr, "z", v, bandwidth = 30) + } + lines <- capture_spatialkit_log( + sel <- sel_quiet(select_features_forward(d, "z", c("a1", "n1"), gwr_fn, + k = 3, seed = 7, quiet = TRUE))) + expect_identical(sel$baseline$type, "fold mean") + expect_identical(sel$history$variable[1], "") + expect_true("a1" %in% sel$selected) + expect_true(log_has(lines, "the learner is a GWR and the baseline is the training-fold mean")) + expect_true(log_has(lines, "null_fn")) + # It says where a working `null_fn` is. + expect_true(log_has(lines, "The example in \\?select_features_forward builds one")) + # Not said for a learner whose models are not GWRs. + lines_lm <- capture_spatialkit_log( + sel_quiet(select_features_forward(d, "z", c("a1", "n1"), sel_lm_refusing, + k = 3, seed = 7, quiet = TRUE))) + expect_false(log_has(lines_lm, "the learner is a GWR")) +}) + + +# --- (c) the first variable under the fold-mean baseline ---------------------- + +# z = a1 + a2 + noise, and `proxy` = a1 + a2 + more noise: the best single +# predictor, and of no use once a1 and a2 are both in. +sel_proxy <- function(n = 240, seed = 1) { + set.seed(4000 + seed) + d <- data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + a1 = stats::rnorm(n), a2 = stats::rnorm(n), n1 = stats::rnorm(n)) + d$proxy <- d$a1 + d$a2 + stats::rnorm(n) + d$z <- d$a1 + d$a2 + stats::rnorm(n, 0, 0.5) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + +test_that("a first variable the finished set does not need is dropped", { + d <- sel_proxy() + cands <- c("proxy", "a1", "a2", "n1") + msgs <- character(0) + sel <- withCallingHandlers( + suppressWarnings(select_features_forward(d, "z", cands, sel_lm_refusing, + k = 4, seed = 1)), + message = function(m) { + msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") + }) + expect_identical(sel$baseline$type, "fold mean") + # The sweep walked proxy, then the two real predictors ... + expect_identical(sel$baseline$path[1], "proxy") + expect_true(all(c("a1", "a2") %in% sel$baseline$path)) + expect_true(sel$baseline$kept) + # ... and the selection is that path without its first variable. (It was + # the whole path: `proxy` stayed, never having been tested.) + f <- sel$baseline$first + expect_true(is.list(f)) + expect_identical(f$variable, "proxy") + expect_true(f$dropped) + expect_identical(sel$selected, sel$baseline$path[-1]) + expect_false("proxy" %in% sel$selected) + expect_match(f$note, "^dropped") + # The numbers the rule read: the path against the path without `proxy`, + # which did not clear it, and the rest against the fold mean, which did. + expect_identical(f$rest$vars, sel$selected) + expect_identical(sel$score, f$rest$score) + last <- sel$history[sel$history$step == length(sel$baseline$path) & + sel$history$variable == utils::tail(sel$baseline$path, 1), ] + expect_equal(f$gain, f$rest$score - last$score, tolerance = 1e-12) + expect_false(isTRUE(f$gain > 0 && f$fold_gain > f$fold_gain_se)) + expect_equal(f$rest$gain, sel$baseline$score - f$rest$score, tolerance = 1e-12) + expect_gt(f$rest$fold_gain, f$rest$fold_gain_se) + # By hand: the selected set's RMSE on the sweep's own folds. + fo <- sel_quiet(make_folds(d, k = 4, method = "block_kfold", seed = 1, + response_var = "z", predictor_vars = cands)) + e <- unlist(lapply(fo$folds, function(sp) { + m <- stats::lm(stats::reformulate(sel$selected, "z"), + sf::st_drop_geometry(d)[sp$train, ]) + d$z[sp$test] - stats::predict(m, sf::st_drop_geometry(d)[sp$test, ]) + })) + expect_equal(sel$score, sqrt(mean(e^2)), tolerance = 1e-10) + # The sweep's record is the sweep as it ran: the extra set is not a step. + expect_identical(max(sel$history$step), length(sel$baseline$path) + + as.integer(length(sel$baseline$path) < length(cands))) + expect_true(any(grepl("proxy was added first, without a test.*so it is dropped", + msgs))) + expect_true(any(grepl("its first variable only if the set is better with it", + msgs))) + + # A learner with a null model of its own tested `proxy` at step 1, where + # it does beat the intercept-only model, and has no such check to make: + # it walks the same path and keeps all of it. + own <- sel_quiet(select_features_forward(d, "z", cands, sel_lm, k = 4, + seed = 1, quiet = TRUE)) + expect_null(own$baseline$first) + expect_identical(own$selected, sel$baseline$path) +}) + +test_that("a first variable the set needs is kept, and a path of one has no second test", { + d <- sel_signal(n = 200, seed = 2, b = 1) + msgs <- character(0) + sel <- withCallingHandlers( + suppressWarnings(select_features_forward(d, "z", c("a1", "a2", "n1"), + sel_lm_refusing, k = 4, seed = 2)), + message = function(m) { + msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") + }) + f <- sel$baseline$first + expect_true(is.list(f)) + expect_false(f$dropped) + expect_match(f$note, "^kept: the set is better with it") + expect_identical(sel$selected, sel$baseline$path) + expect_identical(f$variable, sel$selected[1]) + expect_gt(f$gain, 0) + expect_gt(f$fold_gain, f$fold_gain_se) + expect_true(any(grepl("added first without a test, is kept", msgs))) + + # One real predictor: the path has one variable, and the test against the + # fold mean was the test of that variable. + d1 <- d; d1$z <- d1$a1 + stats::rnorm(nrow(d1), 0, 0.5) + one <- sel_quiet(select_features_forward(d1, "z", c("a1", "n1"), + sel_lm_refusing, k = 4, seed = 2, + quiet = TRUE, max_vars = 1)) + expect_identical(one$selected, "a1") + expect_true(one$baseline$kept) + expect_null(one$baseline$first) + # Nothing kept, nothing to test. + none <- sel_quiet(select_features_forward(sel_noise(seed = 2), "z", + paste0("c", 1:4), sel_lm_refusing, + k = 4, seed = 2, quiet = TRUE, + tol = Inf)) + expect_identical(none$selected, character(0)) + expect_null(none$baseline$first) +}) + +test_that("a first variable that cannot be tested stays, and the warning says so", { + d <- sel_proxy(seed = 2) + # Fits anything but the one set the end-of-path test needs. + picky <- function(tr, v) { + if (!length(v) || setequal(v, c("a1", "a2"))) + stop("this backend cannot fit that set", call. = FALSE) + lm_spatial_fit(tr, "z", v) + } + w <- character(0) + sel <- withCallingHandlers( + suppressMessages(select_features_forward(d, "z", c("proxy", "a1", "a2"), + picky, k = 4, seed = 2, + quiet = TRUE)), + warning = function(c) { + w <<- c(w, conditionMessage(c)); invokeRestart("muffleWarning") + }) + expect_identical(sel$baseline$path, sel$selected) + expect_identical(sel$selected[1], "proxy") + f <- sel$baseline$first + expect_false(f$dropped) + expect_match(f$note, "^not tested") + expect_true(is.na(f$rest$score)) + expect_true(any(grepl(paste0("proxy was added first, without a test, and the ", + "set without it, \\{a1, a2\\}, could not be scored"), + w))) +}) + +test_that("a first variable that cannot be told apart from the rest is kept and called unproven", { + # A learner whose error in each fold is read off a table, so that the three + # comparisons come out as wanted: the path {v1, v2} beats the fold mean in + # every fold; the path without v1 is no worse by the rule (better in two + # folds, worse in two); and {v2} alone does not beat the fold mean by the + # rule. Nothing separates v1 from v2 then, and dropping v1 would leave a + # set the rule does not support either. + set.seed(42) + n <- 200 + d <- sf::st_as_sf( + data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + v1 = stats::rnorm(n), v2 = stats::rnorm(n), v3 = stats::rnorm(n)), + coords = c("x", "y"), crs = 32632) + fo <- sel_quiet(make_folds(d, k = 4, method = "block_kfold", seed = 1)) + fold <- integer(n) + for (j in seq_along(fo$folds)) fold[fo$folds[[j]]$test] <- j + # z alternates +1 / -1 inside each fold: every training-fold mean is about + # 0, and the fold mean scores an RMSE of 1 in every fold. + d$z <- NA_real_ + for (j in 1:4) { + i <- which(fold == j) + d$z[i] <- rep(c(1, -1), length.out = length(i)) + } + key <- function(x) { + xy <- sf::st_coordinates(x) + paste(round(xy[, 1], 4), round(xy[, 2], 4)) + } + look <- data.frame(key = key(d), z = d$z, fold = fold) + err <- list("v1" = rep(0.95, 4), "v2" = c(1.25, 0.70, 1.25, 0.70), + "v3" = rep(1.30, 4), "v1+v2" = c(0.90, 0.91, 0.90, 0.91), + "v1+v3" = rep(0.97, 4), "v1+v2+v3" = rep(0.96, 4)) + oracle <- function(tr, v) { + if (!length(v)) stop("this backend needs at least one predictor", call. = FALSE) + new_spatial_fit("sel_oracle_fit", + engine = list(set = paste(sort(v), collapse = "+")), + formula = z ~ 1, response_var = "z", predictor_vars = v, + data_sf = tr) + } + registerS3method("predict", "sel_oracle_fit", function(object, newdata = NULL, ...) { + r <- look[match(key(newdata), look$key), ] + r$z + err[[object$engine$set]][r$fold] + }) + lines <- capture_spatialkit_log( + sel <- sel_quiet(select_features_forward(d, "z", c("v1", "v2", "v3"), oracle, + k = 4, seed = 1, quiet = TRUE))) + # The sweep's folds are the ones the table was laid out on. + expect_equal(sel$baseline$score, 1, tolerance = 1e-3) + expect_identical(sel$baseline$path, c("v1", "v2")) + expect_true(sel$baseline$kept) + f <- sel$baseline$first + expect_identical(f$variable, "v1") + expect_false(f$dropped) + expect_identical(sel$selected, c("v1", "v2")) + expect_match(f$note, "^kept, unproven") + # v1's gain over {v2}: within its standard error. {v2} over the fold + # mean: negative on the pooled score. + expect_lt(f$fold_gain, f$fold_gain_se) + expect_lt(f$rest$gain, 0) + expect_equal(f$rest$score, sqrt(sum(table(fold) * err$v2^2) / n), tolerance = 1e-10) + expect_true(log_has(lines, "v1 was added first, without a test, and this selection does not show that it predicts")) + expect_true(log_has(lines, "Read v1 as unproven")) +}) + + +# --- (d) a `null_fn` for a GWR, from exported functions ------------------------ + +# The model the example of ?select_features_forward builds: the +# kernel-weighted local mean under fit_gwr_model()'s default kernel +# (adaptive bisquare), which is an intercept-only GWR. +sel_local_mean <- function(tr, bandwidth = 30) { + new_spatial_fit("sel_local_mean_fit", + engine = list(xy = sf::st_coordinates(tr), y = tr$z, + bandwidth = bandwidth), + formula = z ~ 1, response_var = "z", + predictor_vars = character(0), data_sf = tr) +} +predict.sel_local_mean_fit <- function(object, newdata = NULL, ...) { + e <- object$engine + at <- if (is.null(newdata)) e$xy else sf::st_coordinates(newdata) + vapply(seq_len(nrow(at)), function(i) { + d <- sqrt((e$xy[, 1] - at[i, 1])^2 + (e$xy[, 2] - at[i, 2])^2) + h <- sort(d)[min(e$bandwidth, length(d))] + w <- ifelse(d > h, 0, (1 - d^2 / h^2)^2) + sum(w * e$y) / sum(w) + }, numeric(1)) +} +registerS3method("predict", "sel_local_mean_fit", predict.sel_local_mean_fit) + +test_that("the example's local mean is the package's own kernel-weighted mean", { + d <- sel_signal(n = 150, seed = 8, b = 1) + tr <- d[1:100, ]; te <- d[101:150, ] + got <- predict(sel_local_mean(tr, 30), te) + xy <- sf::st_coordinates(tr); at <- sf::st_coordinates(te) + ref <- vapply(seq_len(nrow(at)), function(i) { + dd <- sqrt((xy[, 1] - at[i, 1])^2 + (xy[, 2] - at[i, 2])^2) + w <- spatialkit:::.gw_kernel_weights(dd, 30, "bisquare", adaptive = TRUE) + sum(w * tr$z) / sum(w) + }, numeric(1)) + expect_equal(got, ref, tolerance = 1e-12) + expect_true(all(is.finite(got))) +}) + +test_that("with the local mean as `null_fn` a GWR's first variable is tested at step 1", { + skip_if_not_installed("sp") + d <- sel_signal(n = 120, seed = 7, b = 1) + gwr_fn <- function(tr, v) { + if (!length(v)) stop("a GWR needs at least one predictor", call. = FALSE) + fit_gwr_model(tr, "z", v, bandwidth = 30) + } + lines <- capture_spatialkit_log( + sel <- sel_quiet(select_features_forward(d, "z", c("a1", "n1"), gwr_fn, + k = 3, seed = 7, quiet = TRUE, + null_fn = sel_local_mean))) + expect_identical(sel$baseline$type, "null_fn") + expect_null(sel$baseline$first) + expect_true("a1" %in% sel$selected) + # Step 0 is the local mean on the sweep's folds, and step 1 was held to it. + h <- sel$history + expect_identical(h$variable[1], "") + r1 <- h[h$step == 1L & h$variable == sel$selected[1], ] + expect_gt(r1$gain, 0) + expect_gt(r1$fold_gain, r1$fold_gain_se) + # No caution: the baseline is the one it asks for. + expect_false(log_has(lines, "the learner is a GWR and the baseline is the training-fold mean")) + # Step 0 is the local mean scored on the sweep's own folds. + fo <- sel_quiet(make_folds(d, k = 3, method = "block_kfold", seed = 7, + response_var = "z", predictor_vars = c("a1", "n1"))) + e <- unlist(lapply(fo$folds, function(sp) + d$z[sp$test] - predict(sel_local_mean(d[sp$train, ]), d[sp$test, ]))) + expect_equal(sel$baseline$score, sqrt(mean(e^2)), tolerance = 1e-8) +}) diff --git a/tests/testthat/test-fix-aoa-rf-weights.R b/tests/testthat/test-fix-aoa-rf-weights.R new file mode 100644 index 00000000..74f4c3bb --- /dev/null +++ b/tests/testthat/test-fix-aoa-rf-weights.R @@ -0,0 +1,155 @@ +# tests/testthat/test-fix-aoa-rf-weights.R +# --------------------------------------------------------------------------- +# area_of_applicability(weights = "auto"). +# +# The default weighted every predictor equally even when the model carried +# variable importances, although the method the function names weights by +# importance. With 2 predictors a forest uses and 8 it does not, equal +# weights put about 70% of rows shifted 3 SD along a used predictor (4 times +# the in-sample RMSE) inside the AOA and 43% of rows shifted 4 SD along an +# unused one; pmax(importance, 0) puts 26% and 93% inside. +# +# The default is now "auto": the model's importance when it is finite, has a +# positive value, names every predictor in use and comes from a model with +# out-of-bag skill; equal weights, with a logged note, otherwise. +# weights = NULL stays the explicit request for equal weights. +# --------------------------------------------------------------------------- + +wt_pv <- c("a", "b", paste0("u", 1:8)) +wt_pts <- function(n, shift_real = 0, shift_noise = 0) { + d <- data.frame(x = stats::runif(n, 0, 1e4), y = stats::runif(n, 0, 1e4), + a = stats::rnorm(n) + shift_real, b = stats::rnorm(n)) + for (j in 1:8) d[[paste0("u", j)]] <- stats::rnorm(n) + shift_noise * (j == 1) + d$z <- 2 * d$a + sin(2 * d$b) * 2 + stats::rnorm(n, 0, 0.3) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} +wt_fit <- function(seed = 11, ...) { + set.seed(seed) + fit_rf_model(wt_pts(600), "z", wt_pv, num_trees = 300, seed = seed, ...) +} + + +test_that("the default weights a forest's predictors by its importance", { + skip_if_not_installed("ranger") + fit <- wt_fit() + nd <- rbind(wt_pts(300), wt_pts(300, shift_real = 3), + wt_pts(300, shift_noise = 4)) + grp <- rep(c("same", "used", "unused"), each = 300) + + auto <- area_of_applicability(nd, model = fit) + hand <- area_of_applicability(nd, model = fit, + weights = pmax(fit$info$importance, 0)) + none <- area_of_applicability(nd, model = fit, weights = NULL) + + # The default is the importance-weighted index, number for number. + expect_identical(auto$aoa$DI, hand$aoa$DI) + expect_identical(auto$aoa$AOA, hand$aoa$AOA) + expect_identical(auto$threshold, hand$threshold) + expect_identical(auto$weights, hand$weights) + expect_identical(auto$params$weights_source, "model importance") + expect_identical(auto$params$weights_note, "permutation importance") + expect_false(auto$params$weights_supplied) + expect_identical(hand$params$weights_source, "supplied") + expect_true(hand$params$weights_supplied) + # weights = NULL is still equal weights. + expect_identical(unname(none$weights), rep(1, 10)) + expect_identical(none$params$weights_source, "equal") + expect_false(isTRUE(all.equal(auto$aoa$DI, none$aoa$DI))) + + # What the weights are for. A 3 SD shift along a predictor the forest + # uses is mostly outside; a 4 SD shift along one it ignores is mostly in. + expect_lt(mean(auto$aoa$AOA[grp == "used"]), 0.40) + expect_gt(mean(auto$aoa$AOA[grp == "unused"]), 0.85) + # With equal weights it was the other way round. + expect_gt(mean(none$aoa$AOA[grp == "used"]), 0.55) + expect_lt(mean(none$aoa$AOA[grp == "unused"]), 0.65) + + # print() says where the weights came from. + p_auto <- utils::capture.output(print(auto)) + p_hand <- utils::capture.output(print(hand)) + p_none <- utils::capture.output(print(none)) + expect_true(any(grepl("weighted : yes, by the model's permutation importance", + p_auto, fixed = TRUE))) + expect_true(any(grepl("weighted : yes, by the weights supplied", p_hand, + fixed = TRUE))) + expect_true(any(grepl("weighted : no (all predictors count equally: weights = NULL)", + p_none, fixed = TRUE))) +}) + +test_that("\"auto\" is equal weights, without an error, when the importance means nothing", { + skip_if_not_installed("ranger") + set.seed(21) + trn <- wt_pts(200); nd <- wt_pts(60) + equal_and_says <- function(model, pattern, ...) { + lines <- capture_spatialkit_log( + res <- area_of_applicability(nd, model = model, ...), level = logger::INFO) + expect_identical(unname(res$weights), rep(1, length(res$weights))) + expect_identical(res$params$weights_source, "equal") + expect_match(res$params$weights_note, pattern) + expect_true(log_has(lines, paste0("weights = \"auto\": .*", pattern))) + out <- utils::capture.output(print(res)) + expect_true(any(grepl("no (all predictors count equally: ", out, fixed = TRUE))) + invisible(res) + } + + # importance = "none": nothing to read. + f_none <- fit_rf_model(trn, "z", wt_pv, num_trees = 60, importance = "none") + equal_and_says(f_none, "carries no variable importance") + + # No out-of-bag rows: the importance is NaN, which used to be an error + # for anyone who passed it. + f_nan <- suppressWarnings( + fit_rf_model(trn, "z", wt_pv, num_trees = 60, replace = FALSE, + sample_fraction = 1)) + expect_true(all(is.nan(f_nan$info$importance))) + equal_and_says(f_nan, "not finite") + expect_error(area_of_applicability(nd, model = f_nan, + weights = pmax(f_nan$info$importance, 0)), + "NaN") + + # A forest with no out-of-bag skill: its positive importances are noise. + noise <- trn; noise$z <- stats::rnorm(nrow(noise)) + f_noise <- fit_rf_model(noise, "z", wt_pv, num_trees = 100) + f_noise$info$oob_r_squared <- min(f_noise$info$oob_r_squared, -0.02) + expect_true(any(f_noise$info$importance > 0)) + equal_and_says(f_noise, "no out-of-bag skill") + + # predictor_vars overridden with a column the model never saw. + f_ab <- fit_rf_model(trn, "z", c("a", "b"), num_trees = 60) + equal_and_says(f_ab, "no entry for .u1.", predictor_vars = c("a", "b", "u1")) + + # A model with no importance at all (a GWR, a Bayesian fit, a learner of + # one's own). + bare <- structure(list(data_sf = trn, predictor_vars = c("a", "b"), + info = list()), class = c("lmsurf_fit", "spatial_fit")) + equal_and_says(bare, "carries no variable importance") + + # No model: equal weights, and nothing to log about it. + lines <- capture_spatialkit_log( + res <- area_of_applicability(nd, train_sf = trn, predictor_vars = c("a", "b")), + level = logger::INFO) + expect_identical(unname(res$weights), c(1, 1)) + expect_identical(res$params$weights_source, "equal") + expect_false(log_has(lines, "weights = \"auto\"")) +}) + +test_that("\"auto\" covers the coordinate columns of a coordinate-using forest", { + skip_if_not_installed("ranger") + set.seed(31) + trn <- wt_pts(250); nd <- wt_pts(60) + f_xy <- suppressWarnings(suppressMessages( + fit_rf_model(trn, "z", c("a", "b"), num_trees = 100, include_coords = TRUE))) + auto <- area_of_applicability(nd, model = f_xy) + hand <- area_of_applicability(nd, model = f_xy, + weights = pmax(f_xy$info$importance, 0)) + expect_identical(names(auto$weights), c("a", "b", "..x", "..y")) + expect_identical(auto$weights, hand$weights) + expect_identical(auto$aoa$DI, hand$aoa$DI) +}) + +test_that("a weights value that is neither \"auto\", NULL nor numeric is refused", { + trn <- wt_pts(60); nd <- wt_pts(20) + expect_error(area_of_applicability(nd, train_sf = trn, predictor_vars = c("a", "b"), + weights = "importance"), + "`weights` must be numeric, or NULL for equal weights, or \"auto\"") +}) diff --git a/tests/testthat/test-fix-bayes-adequacy-tables.R b/tests/testthat/test-fix-bayes-adequacy-tables.R new file mode 100644 index 00000000..2d873e8c --- /dev/null +++ b/tests/testthat/test-fix-bayes-adequacy-tables.R @@ -0,0 +1,80 @@ +# The GP adequacy status of a Bayesian fit is carried where fits are scored: +# compare_models() beside convergence_ok, and cv_bayes() fold_metrics. A fit +# whose basis was found too coarse ("below_resolution", +# "unresolved_short_range") showed nothing in either table. The Bayesian +# backend is mocked with helper-lmfit.R's lm fit, so no Stan toolchain is +# needed. + +.fat_pts <- function(n = 60, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 5 + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +.fat_fit <- function(d, status) { + f <- lm_spatial_fit(d, "z", "w") + f$info$convergence_ok <- TRUE + if (!is.null(status)) f$info$gp_adequacy <- list(status = status) + f +} + +test_that("compare_models() carries the GP adequacy status beside convergence_ok", { + d <- .fat_pts() + as_bayes <- function(f) { + class(f) <- c(class(f)[1L], "bayesian_fit", class(f)[-1L]) + f + } + fits <- list(fine = as_bayes(.fat_fit(d, "ok")), + coarse = as_bayes(.fat_fit(d, "below_resolution")), + missed = as_bayes(.fat_fit(d, "unresolved_short_range")), + older = as_bayes(.fat_fit(d, NULL)), + plain = lm_spatial_fit(d, "z", "w")) + cmp <- suppressWarnings(compare_models(fits)) + expect_true("gp_adequacy" %in% names(cmp)) + expect_type(cmp$gp_adequacy, "character") + got <- stats::setNames(cmp$gp_adequacy, cmp$model) + expect_identical(unname(got[c("fine", "coarse", "missed", "older", "plain")]), + c("ok", "below_resolution", "unresolved_short_range", NA, NA)) + # Beside convergence_ok, not in place of it. + expect_true("convergence_ok" %in% names(cmp)) +}) + +test_that("cv_bayes() fold_metrics carries each fold's GP adequacy status", { + d <- .fat_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + statuses <- c("ok", "unresolved_short_range", "below_resolution") + i <- 0L + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) { + i <<- i + 1L + .fat_fit(data_sf, statuses[i]) + }, + .package = "spatialkit") + cv <- suppressWarnings(suppressMessages(cv_bayes(d, "z", "w", folds = f, seed = 1))) + expect_true("gp_adequacy" %in% names(cv$fold_metrics)) + expect_identical(cv$fold_metrics$gp_adequacy, statuses) + expect_identical(cv$fold_metrics$convergence_ok, rep(TRUE, 3L)) +}) + +test_that("a fit without the status, and an all-failed run, keep the column", { + d <- .fat_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) .fat_fit(data_sf, NULL), + .package = "spatialkit") + cv <- suppressWarnings(suppressMessages(cv_bayes(d, "z", "w", folds = f, seed = 1))) + expect_identical(cv$fold_metrics$gp_adequacy, rep(NA_character_, 3L)) + + local_mocked_bindings( + fit_bayesian_spatial_model = function(...) stop("no fit here"), + .package = "spatialkit") + cv0 <- suppressWarnings(suppressMessages(cv_bayes(d, "z", "w", k = 3, seed = 1))) + expect_true("gp_adequacy" %in% names(cv0$fold_metrics)) + expect_type(cv0$fold_metrics$gp_adequacy, "character") +}) diff --git a/tests/testthat/test-fix-bayes-adequacy.R b/tests/testthat/test-fix-bayes-adequacy.R new file mode 100644 index 00000000..a48c5265 --- /dev/null +++ b/tests/testthat/test-fix-bayes-adequacy.R @@ -0,0 +1,786 @@ +# The post-fit check of the GP basis against the posterior. +# +# It was one number, the share of length-scale draws below the smallest +# length-scale the basis resolves, logged when above 10 percent and shown +# nowhere else. It could not fire when the data did not inform the +# length-scale: the posterior then equals the prior, which puts 1 percent +# below that floor by construction. A Gaussian process that had collapsed +# onto noise over structure finer than the basis therefore passed in silence. +# +# Whether the Gaussian process is identified is decided on the share of the +# variance it carries, where the family has a residual SD to form one, and on +# the length-scales only where it has not. The width of the length-scale +# posterior against its prior does not decide by itself: a surface smoother +# than the prior expects (a plane, a range longer than the extent) moves the +# length-scale to the long side of its prior, where the posterior is wider +# than the prior. Three real fits whose GP carried 0.57 to 0.94 of the +# variance at the 2.5 percent quantile were reported as "no spatial structure +# found" on that ground. +# +# The posterior answers neither question about what the surface left behind. +# A Gaussian process that carries a share of the variance at a long range is +# what a regional trend gives, and what a regional trend beside structure +# finer than the basis gives. The residuals are therefore read for every fit +# whose posterior was, and "ok" is not returned over residuals that are +# autocorrelated at short range. They used to be read only for a Gaussian +# process that was not identified: a weak plane plus a field with an 8 km +# range under a 33 km floor came back "ok", with no warning of any class, +# over residuals with a Moran's I of 0.143 (p = 5.6e-06). +# +# No Stan. The engine is a stand-in that carries posterior draws, the brms +# accessors are replaced, and the fitter's own code reads them. + +# A brmsfit stand-in holding the draws the adequacy check reads. +.fba_engine <- function(ls, sdgp, sigma) { + structure(list(ls = ls, sdgp = sdgp, sigma = sigma), + class = c("fba_draws", "brmsfit")) +} +registerS3method("as.matrix", "fba_draws", function(x, variable = NULL, + regex = FALSE, ...) { + if (identical(variable, "^lscale")) return(x$ls) + if (identical(variable, "^sdgp")) + return(matrix(x$sdgp, ncol = 1L, dimnames = list(NULL, "sdgp_gp..x..y"))) + if (identical(variable, "sigma")) + return(matrix(x$sigma, ncol = 1L, dimnames = list(NULL, "sigma"))) + stop("no such variable") +}) + +.fba_pts <- function(n = 300, seed = 7, range = NULL) { + set.seed(seed) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + z <- if (is.null(range)) stats::rnorm(n) else { + D <- as.matrix(stats::dist(xy)) + as.numeric(t(chol(exp(-D / (range / 3)) + diag(1e-8, n))) %*% stats::rnorm(n)) + + stats::rnorm(n, 0, 0.3) + } + sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), + coords = c("x", "y"), crs = 32617) +} + +# What the fitter will compute for this layer before sampling: the smallest +# length-scale the derived basis resolves and the prior it sets. +.fba_design <- function(d) { + xy <- sf::st_coordinates(d) + zz <- cbind((xy[, 1] - mean(xy[, 1])) / stats::sd(xy[, 1]), + (xy[, 2] - mean(xy[, 2])) / stats::sd(xy[, 2])) + b <- gp_lengthscale_bounds(zz) + sp <- spatialkit:::.gp_basis_spec(zz, b) + ig <- spatialkit:::.lscale_invgamma(b[["lower"]], b[["upper"]]) + list(ell_min = 1.75 * sp$c * sp$S / sp$k, shape = ig$shape, scale = ig$scale) +} + +# Fit with the stand-in engine and every sampler diagnostic clean. The fitted +# values are zero, so the residuals the Moran's I step sees are the response. +# `epred` replaces that stand-in for the posterior draw; `sac` is the range +# the variogram before fitting is taken to have returned. +.fba_fit <- function(d, engine, + epred = function(object, newdata, ...) + matrix(0, nrow = 4L, ncol = nrow(newdata)), + sac = 9e4) { + local_mocked_bindings( + brm = function(...) engine, + nuts_params = function(...) + data.frame(Chain = 1L, Iteration = 1L, Parameter = "divergent__", Value = 0), + rhat = function(...) c(b_Intercept = 1.001, sigma = 1.002), + neff_ratio = function(...) c(b_Intercept = 0.9, sigma = 0.8), + posterior_epred = epred, + .package = "brms") + local_mocked_bindings(estimate_sac_range = function(...) sac, + .package = "spatialkit") + w <- list() + fit <- withCallingHandlers( + suppressMessages(fit_bayesian_spatial_model(d, "z", character(0), + compute_loo = FALSE)), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }) + list(fit = fit, warnings = w) +} + +.fba_classes <- function(w) vapply(w, function(c) class(c)[1L], character(1)) + + +test_that(".gp_adequacy() separates not identified, below resolution and ok", { + set.seed(1) + N <- 2000 + ig_a <- 11.5; ig_b <- 9.7 # prior 1% point about 0.46 + spec <- sprintf("inv_gamma(%s, %s)", ig_a, ig_b) + prior_draws <- function() 1 / stats::rgamma(N, shape = ig_a, rate = ig_b) + ell_min <- 0.46 + + # The data did not move the length-scale and the GP carries no variance. + ni <- spatialkit:::.gp_adequacy( + cbind(lx = prior_draws(), ly = prior_draws()), + sdgp_draws = abs(stats::rnorm(N, 0, 0.05)), sigma_draws = rep(1.2, N), + gp_ell_min = ell_min, prior_spec = spec, xy_scale = c(28000, 29000)) + expect_identical(ni$status, "not_identified") + expect_false(ni$identified) + expect_identical(ni$identified_by, "spatial_share") + expect_true(all(abs(ni$contraction) < 0.25)) + expect_true(all(ni$prior_gap < 0.10)) + expect_lt(ni$spatial_share[["q2.5"]], 0.01) + # The share below the floor says nothing here: it restates the prior's 1%. + expect_lt(ni$frac_below, 0.05) + + # Identified, and the posterior wants a shorter length-scale than the basis + # resolves. + br <- spatialkit:::.gp_adequacy( + cbind(lx = stats::rnorm(N, 0.42, 0.03), ly = stats::rnorm(N, 0.50, 0.03)), + sdgp_draws = stats::rnorm(N, 1, 0.05), sigma_draws = stats::rnorm(N, 0.5, 0.02), + gp_ell_min = ell_min, prior_spec = spec, xy_scale = c(28000, 29000)) + expect_identical(br$status, "below_resolution") + expect_true(br$identified) + expect_gt(br$frac_below, 0.10) + expect_true(all(br$contraction > 0.9)) + + # Identified and clear of the floor. + ok <- spatialkit:::.gp_adequacy( + cbind(lx = stats::rnorm(N, 0.9, 0.05), ly = stats::rnorm(N, 1.0, 0.05)), + sdgp_draws = stats::rnorm(N, 1, 0.05), sigma_draws = stats::rnorm(N, 0.5, 0.02), + gp_ell_min = ell_min, prior_spec = spec, xy_scale = c(28000, 29000)) + expect_identical(ok$status, "ok") + expect_identical(dim(ok$effective_range), c(2L, 3L)) + # The effective range per axis in map units: 2.45 length-scales times the + # axis's own SD. + expect_equal(unname(ok$effective_range[, "q50"]), + sqrt(2 * log(20)) * c(28000, 29000) * c(0.9, 1.0), tolerance = 0.01) + + # Without a prior this function set, and without sigma, identification is + # unknown and the share alone decides. + un <- spatialkit:::.gp_adequacy( + cbind(lx = stats::rnorm(N, 0.9, 0.05)), sdgp_draws = stats::rnorm(N, 1, 0.05), + gp_ell_min = ell_min, prior_spec = "student_t(3, 0, 1)") + expect_true(is.na(un$identified)) + expect_true(is.na(un$identified_by)) + expect_true(all(is.na(un$prior_gap))) + expect_identical(un$status, "ok") + expect_null(un$spatial_share) +}) + +test_that(".gp_prior_gap() is the Kolmogorov-Smirnov distance to the prior", { + set.seed(11) + a <- 12.08121194; b <- 10.05144272 + cdf <- function(x) 1 - stats::pgamma(1 / x, shape = a, rate = b) + x <- stats::rlnorm(500, log(1.4), 0.3) + expect_equal(spatialkit:::.gp_prior_gap(x, cdf), + unname(suppressWarnings(stats::ks.test(x, cdf))$statistic)) + # Draws from the prior itself: a small gap. Draws far from it: near 1. + expect_lt(spatialkit:::.gp_prior_gap(1 / stats::rgamma(2000, a, rate = b), cdf), 0.06) + expect_gt(spatialkit:::.gp_prior_gap(stats::rnorm(500, 4, 0.1), cdf), 0.99) + expect_true(is.na(spatialkit:::.gp_prior_gap(c(1, NA), cdf))) + expect_identical(spatialkit:::.gp_share_floor, 0.01) + expect_identical(spatialkit:::.gp_contraction_floor, 0.25) + expect_identical(spatialkit:::.gp_prior_gap_floor, 0.30) +}) + +test_that("a length-scale posterior wider than its prior, on the long side, is not 'not identified'", { + # Draws shaped like a real fit of a plane plus noise (n = 200, 100 km + # square, default basis): length-scale mean/SD 1.48/0.44 and 2.06/0.52 + # against a prior with mean 0.91 and SD 0.29, GP share of the variance 0.71 + # to 0.95, R2 of the fitted surface 0.85. The contraction is negative on + # both axes, and on that alone the status was "not_identified". + set.seed(1) + N <- 1000 + lg <- function(m, s) { v <- log(1 + s^2 / m^2); stats::rlnorm(N, log(m) - v / 2, sqrt(v)) } + spec <- "inv_gamma(12.08121194, 10.05144272)" + ls <- cbind(lx = lg(1.48, 0.44), ly = lg(2.06, 0.52)) + ad <- spatialkit:::.gp_adequacy(ls, sdgp_draws = lg(1.2, 0.3), sigma_draws = lg(0.5, 0.03), + gp_ell_min = 0.46, prior_spec = spec, + xy_scale = c(28000, 29000)) + expect_true(all(ad$contraction < 0)) # wider than the prior + expect_true(all(ad$prior_gap > 0.5)) # and moved almost entirely + expect_gt(ad$spatial_share[["q2.5"]], 0.5) + expect_true(ad$identified) + expect_identical(ad$identified_by, "spatial_share") + expect_identical(ad$status, "ok") + expect_equal(ad$frac_below, 0) + + # A family with no sigma has no share. The same length-scales are then + # identified because they moved, although they did not narrow. + ns <- spatialkit:::.gp_adequacy(ls, sdgp_draws = lg(1.2, 0.3), gp_ell_min = 0.46, + prior_spec = spec) + expect_null(ns$spatial_share) + expect_true(ns$identified) + expect_identical(ns$identified_by, "length_scale") + expect_identical(ns$status, "ok") +}) + +test_that("without a share the length-scales decide: narrowed or moved is identified, neither is not", { + set.seed(2) + N <- 2000 + a <- 12.08121194; b <- 10.05144272 + spec <- sprintf("inv_gamma(%.10g, %.10g)", a, b) + prior_draws <- function() 1 / stats::rgamma(N, shape = a, rate = b) + med <- 1 / stats::qgamma(0.5, shape = a, rate = b) + psd <- b / ((a - 1) * sqrt(a - 2)) + sdgp <- stats::rnorm(N, 1, 0.05) + + # Equal to the prior on both axes: nothing narrowed, nothing moved. + eq <- spatialkit:::.gp_adequacy(cbind(lx = prior_draws(), ly = prior_draws()), + sdgp_draws = sdgp, gp_ell_min = 0.46, prior_spec = spec) + expect_false(eq$identified) + expect_identical(eq$identified_by, "length_scale") + expect_identical(eq$status, "not_identified") + expect_true(all(eq$contraction < 0.25) && all(eq$prior_gap < 0.30)) + + # Narrowed around the prior's median (0.6 of its SD): the distribution + # functions stay close, the variance does not. A fit whose true + # length-scale sat at the prior median looked like this (contraction 0.63 + # and 0.81, gaps 0.15 and 0.25). + nar <- spatialkit:::.gp_adequacy( + cbind(lx = stats::rnorm(N, med, 0.6 * psd), ly = prior_draws()), + sdgp_draws = sdgp, gp_ell_min = 0.46, prior_spec = spec) + expect_gt(nar$contraction[["lx"]], 0.25) + expect_lt(nar$prior_gap[["lx"]], 0.30) + expect_true(nar$identified) + expect_identical(nar$status, "ok") + + # Moved to the long side on one axis and wider there: identified. + mov <- spatialkit:::.gp_adequacy( + cbind(lx = prior_draws(), ly = stats::rlnorm(N, log(1.9), 0.25)), + sdgp_draws = sdgp, gp_ell_min = 0.46, prior_spec = spec) + expect_lt(mov$contraction[["ly"]], 0) + expect_gt(mov$prior_gap[["ly"]], 0.30) + expect_true(mov$identified) + expect_identical(mov$status, "ok") +}) + +test_that("where there is a share it decides, whatever the length-scales did", { + set.seed(3) + N <- 2000 + a <- 12.08121194; b <- 10.05144272 + spec <- sprintf("inv_gamma(%.10g, %.10g)", a, b) + prior_draws <- function() 1 / stats::rgamma(N, shape = a, rate = b) + # Length-scales the data did not move, under a GP that carries most of the + # variance: identified. + hi <- spatialkit:::.gp_adequacy( + cbind(lx = prior_draws(), ly = prior_draws()), + sdgp_draws = stats::rnorm(N, 1, 0.05), sigma_draws = stats::rnorm(N, 0.5, 0.02), + gp_ell_min = 0.46, prior_spec = spec) + expect_true(hi$identified) + expect_identical(hi$status, "ok") + # Length-scales far from their prior, under a GP that carries nothing: not + # identified. + lo <- spatialkit:::.gp_adequacy( + cbind(lx = stats::rlnorm(N, log(1.9), 0.25), ly = stats::rlnorm(N, log(1.9), 0.25)), + sdgp_draws = abs(stats::rnorm(N, 0, 0.03)), sigma_draws = rep(1.2, N), + gp_ell_min = 0.46, prior_spec = spec) + expect_false(lo$identified) + expect_identical(lo$identified_by, "spatial_share") + expect_identical(lo$status, "not_identified") +}) + +test_that(".lscale_prior_parse() reads the two priors the fitter sets", { + p <- spatialkit:::.lscale_prior_parse("inv_gamma(11.48820413, 9.596223034)") + # 1 - pgamma(1 / 1.7596, shape = 11.48820413, rate = 9.596223034) + expect_equal(p$cdf(1.7596), 0.984, tolerance = 1e-3) + expect_equal(p$var, 9.596223034^2 / (10.48820413^2 * 9.48820413)) + h <- spatialkit:::.lscale_prior_parse("normal(0, 2)") + expect_equal(h$cdf(2), 2 * stats::pnorm(1) - 1) + expect_equal(h$var, 4 * (1 - 2 / pi)) + expect_null(spatialkit:::.lscale_prior_parse("student_t(3, 0, 1)")) + expect_null(spatialkit:::.lscale_prior_parse("inv_gamma(1, 2); inv_gamma(3, 4)")) + expect_null(spatialkit:::.lscale_prior_parse(NULL)) +}) + +test_that("a GP collapsed onto noise over short-range structure is reported", { + skip_if_not_installed("brms") + # An exponential field with an 8 km range; the default basis resolves 33 km. + d <- .fba_pts(range = 8000) + des <- .fba_design(d) + set.seed(2) + N <- 800 + eng <- .fba_engine( + ls = cbind(`lscale_gp..x..y..x` = 1 / stats::rgamma(N, des$shape, rate = des$scale), + `lscale_gp..x..y..y` = 1 / stats::rgamma(N, des$shape, rate = des$scale)), + sdgp = abs(stats::rnorm(N, 0, 0.05)), sigma = stats::rnorm(N, 1.05, 0.03)) + r <- .fba_fit(d, eng) + ad <- r$fit$info$gp_adequacy + # The old check: about 1% of draws below the floor, so nothing was said. + expect_lt(ad$frac_below, 0.10) + expect_identical(ad$status, "unresolved_short_range") + expect_lt(ad$residual_moran$p, 0.05) + expect_identical(ad$residual_moran$k, 4L) + expect_true("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + msg <- conditionMessage(r$warnings[[which(.fba_classes(r$warnings) == + "spatialkit_gp_adequacy")]]) + expect_match(msg, "the Gaussian process carries no variance that can be told from zero (its share of the variance has a 95% interval of 0.000 to", + fixed = TRUE) + expect_match(msg, "residuals are autocorrelated at short range", fixed = TRUE) + expect_match(msg, "metre along x", fixed = TRUE) + # It is a statement about the approximation, not the sampler. + expect_true(isTRUE(r$fit$info$convergence_ok)) + expect_false("spatialkit_convergence" %in% .fba_classes(r$warnings)) + expect_identical(r$fit$info$convergence_diagnostics$gp_adequacy, + "unresolved_short_range") + # print() and summary() both show it. + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "** GP adequacy: unresolved_short_range -- the GP's share of the variance is 0.000 to", + fixed = TRUE) + expect_false(grepl("Convergence warnings present", txt, fixed = TRUE)) + stx <- paste(utils::capture.output(print(summary(r$fit))), collapse = "\n") + expect_match(stx, "** GP adequacy: unresolved_short_range", fixed = TRUE) +}) + +test_that("the same posterior over white noise is not called a failure", { + skip_if_not_installed("brms") + d <- .fba_pts(seed = 21) + des <- .fba_design(d) + set.seed(3) + N <- 800 + eng <- .fba_engine( + ls = cbind(`lscale_gp..x..y..x` = 1 / stats::rgamma(N, des$shape, rate = des$scale), + `lscale_gp..x..y..y` = 1 / stats::rgamma(N, des$shape, rate = des$scale)), + sdgp = abs(stats::rnorm(N, 0, 0.05)), sigma = stats::rnorm(N, 1, 0.03)) + logged <- capture_spatialkit_log(r <- .fba_fit(d, eng), level = logger::WARN) + ad <- r$fit$info$gp_adequacy + expect_identical(ad$status, "no_signal_above_floor") + expect_gt(ad$residual_moran$p, 0.05) + # Logged and printed, not raised. + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + expect_true(log_has(logged, "carries no variance that can be told from zero")) + expect_true(log_has(logged, "the residuals show no autocorrelation at short range")) + expect_true(log_has(logged, "A response with no spatial structure gives this")) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP adequacy: no_signal_above_floor -- the GP's share of the variance is 0.000 to", + fixed = TRUE) + expect_match(txt, "and the residuals show no autocorrelation at short range", fixed = TRUE) + expect_false(grepl("** GP adequacy", txt, fixed = TRUE)) +}) + +# The posterior of a real fit of a plane: both length-scales on the long side +# of the prior and wider than it, the GP carrying most of the variance. +.fba_plane_engine <- function(N = 800, seed = 6) { + set.seed(seed) + lg <- function(m, s) { v <- log(1 + s^2 / m^2); stats::rlnorm(N, log(m) - v / 2, sqrt(v)) } + .fba_engine( + ls = cbind(`lscale_gp..x..y..x` = lg(1.48, 0.44), `lscale_gp..x..y..y` = lg(2.06, 0.52)), + sdgp = lg(1.2, 0.3), sigma = lg(0.5, 0.03)) +} + +test_that("a GP that carries most of the variance at a long range is 'ok' when its residuals show nothing left over", { + skip_if_not_installed("brms") + # The residuals are white noise (the stand-in's fitted values are zero). + # The length-scale posterior is wider than its prior, which was read as + # "not identified" and reported as "found no structure it can represent". + logged <- capture_spatialkit_log(r <- .fba_fit(.fba_pts(seed = 21), .fba_plane_engine()), + level = logger::WARN) + ad <- r$fit$info$gp_adequacy + expect_true(all(ad$contraction < 0)) + expect_gt(ad$spatial_share[["q2.5"]], 0.5) + expect_true(ad$identified) + expect_identical(ad$status, "ok") + # "ok" now rests on the residuals as well, and the test is on the object. + expect_named(ad$residual_moran, c("I", "z", "p", "k")) + expect_gt(ad$residual_moran$p, 0.05) + expect_identical(ad$residual_moran$k, 4L) + expect_null(ad$residual_untested) + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + expect_false(log_has(logged, "carries no variance")) + expect_false(log_has(logged, "could not be tested")) + expect_identical(r$fit$info$convergence_diagnostics$gp_adequacy, "ok") + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP range: ", fixed = TRUE) + expect_false(grepl("GP adequacy", txt, fixed = TRUE)) +}) + +test_that("the same posterior over residuals with an 8 km range is not 'ok'", { + skip_if_not_installed("brms") + # An exponential field with an 8 km range under a 33 km floor, left entirely + # in the residuals: what a regional surface beside short-range structure + # leaves. The posterior is the one above, so every figure the status used + # to be read from says "ok": a share of the variance of 0.7 to 0.95, and + # under 1 percent of the length-scale draws below the floor. This returned + # "ok" with no warning. + d <- .fba_pts(range = 8000) + r <- .fba_fit(d, .fba_plane_engine()) + ad <- r$fit$info$gp_adequacy + expect_gt(ad$spatial_share[["q2.5"]], 0.5) + expect_true(ad$identified) + expect_lt(ad$frac_below, 0.01) + expect_identical(ad$status, "unresolved_short_range") + expect_lt(ad$residual_moran$p, 0.001) + expect_gt(ad$residual_moran$I, 0.1) + # The statistic is the one residual_morans_i() gives for these residuals. + ref <- suppressWarnings(suppressMessages( + residual_morans_i(r$fit, alternative = "greater", k = 4L))) + expect_equal(ad$residual_moran$I, ref$observed) + expect_equal(ad$residual_moran$p, ref$p_value) + expect_identical(r$fit$info$convergence_diagnostics$gp_adequacy, + "unresolved_short_range") + # Warned, in words for a Gaussian process that did find a surface. + expect_true("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + msg <- conditionMessage(r$warnings[[which(.fba_classes(r$warnings) == + "spatialkit_gp_adequacy")]]) + expect_match(msg, sprintf("the Gaussian process carries %.2f to %.2f of the variance (95%% interval) at an effective range of ", + ad$spatial_share[["q2.5"]], ad$spatial_share[["q97.5"]]), + fixed = TRUE) + expect_match(msg, sprintf("and the residuals are still autocorrelated at short range (Moran's I = %.3f over 4 nearest neighbours, one-sided p = %.2g)", + ad$residual_moran$I, ad$residual_moran$p), fixed = TRUE) + expect_match(msg, "The surface left structure behind", fixed = TRUE) + expect_match(msg, "cannot be held by this basis (gp_k = ", fixed = TRUE) + expect_match(msg, "A `gp_resolution` below", fixed = TRUE) + expect_false(grepl("carries no variance", msg, fixed = TRUE)) + # About the approximation, not the sampler. + expect_true(isTRUE(r$fit$info$convergence_ok)) + # print() and summary() flag it, with the share the GP does carry and the + # test, and print() does not offer the fitted range as the range. + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, sprintf("** GP adequacy: unresolved_short_range -- the GP's share of the variance is %.3f to %.3f (95%% interval), and the residuals are autocorrelated at short range (Moran's I = %.3f, one-sided p = %.2g)", + ad$spatial_share[["q2.5"]], ad$spatial_share[["q97.5"]], + ad$residual_moran$I, ad$residual_moran$p), fixed = TRUE) + expect_false(grepl("GP range: ", txt, fixed = TRUE)) + stx <- paste(utils::capture.output(print(summary(r$fit))), collapse = "\n") + expect_match(stx, "** GP adequacy: unresolved_short_range", fixed = TRUE) +}) + +test_that("a variogram range below the floor stays flagged in print() unless the residuals answer it", { + skip_if_not_installed("brms") + # The 8 km field again, with the variogram before fitting taken to have + # returned 9 km. Both of its supporting tests agree, so the fit warns + # before sampling. + d <- .fba_pts(range = 8000) + r <- .fba_fit(d, .fba_plane_engine(), sac = 9000) + expect_identical(r$fit$info$gp_prefit$status, "below_floor") + expect_true("spatialkit_gp_resolution" %in% .fba_classes(r$warnings)) + expect_identical(r$fit$info$gp_adequacy$status, "unresolved_short_range") + txt <- utils::capture.output(print(r$fit)) + # This fit printed "the fitted model does not bear that out", unflagged. + expect_true(any(grepl("** Range before fitting: a variogram put it at 9,000 metre, below what the basis resolves (an estimate; see GP adequacy)", + txt, fixed = TRUE))) + expect_false(any(grepl("does not bear that out", txt, fixed = TRUE))) + # The warning's advice carries the variogram's range, which the residuals + # agree with. + msg <- conditionMessage(r$warnings[[which(.fba_classes(r$warnings) == + "spatialkit_gp_adequacy")]]) + expect_match(msg, "The range a variogram gave before fitting (9,000 metre) is below that", + fixed = TRUE) + + # The posterior draw fails, so there are no residuals to test. The status + # is "ok" on the posterior alone, which is said, and print() keeps the flag. + logged <- capture_spatialkit_log( + r2 <- .fba_fit(d, .fba_plane_engine(), sac = 9000, + epred = function(...) stop("no draws in a stand-in")), + level = logger::WARN) + ad2 <- r2$fit$info$gp_adequacy + expect_identical(ad2$status, "ok") + expect_null(ad2$residual_moran) + expect_match(ad2$residual_untested, "no draws in a stand-in", fixed = TRUE) + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r2$warnings)) + expect_true(log_has(logged, "the residuals could not be tested for autocorrelation at short range")) + expect_true(log_has(logged, "rests on the posterior alone")) + txt2 <- utils::capture.output(print(r2$fit)) + expect_true(any(grepl("** Range before fitting: a variogram put it at 9,000 metre, below what the basis resolves (an estimate; the residuals were not tested after fitting)", + txt2, fixed = TRUE))) + expect_true(any(grepl("^ GP range: ", txt2))) +}) + +test_that(".gp_fit_resid_moran() returns the test, or the reason there is none", { + skip_if_not_installed("brms") + r <- .fba_fit(.fba_pts(seed = 21), .fba_plane_engine()) + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) + matrix(0, nrow = 4L, ncol = nrow(newdata)), + .package = "brms") + got <- spatialkit:::.gp_fit_resid_moran(r$fit, "gaussian") + expect_named(got, c("test", "reason")) + expect_true(is.na(got$reason)) + expect_identical(got$test$k, 4L) + ref <- suppressWarnings(suppressMessages( + residual_morans_i(r$fit, alternative = "greater", k = 4L))) + expect_equal(got$test[c("I", "z", "p")], + list(I = ref$observed, z = ref$z, p = ref$p_value)) + # A family with a probability per category has no residual per row. + cat_fam <- spatialkit:::.gp_fit_resid_moran(r$fit, "cumulative") + expect_null(cat_fam$test) + expect_match(cat_fam$reason, "no residual per row", fixed = TRUE) + # A posterior that cannot be drawn: no test, the cause, and no warning or + # log line of its own. + clear_fitted_cache(r$fit) + local_mocked_bindings(posterior_epred = function(...) stop("boom"), .package = "brms") + logged <- capture_spatialkit_log( + expect_no_warning(bad <- spatialkit:::.gp_fit_resid_moran(r$fit, "gaussian")), + level = logger::WARN) + expect_null(bad$test) + expect_match(bad$reason, "residuals() failed: ", fixed = TRUE) + expect_match(bad$reason, "boom", fixed = TRUE) + expect_length(logged, 0L) + expect_identical(spatialkit:::.gp_resid_k, 4L) + expect_identical(spatialkit:::.gp_resid_level, 0.05) +}) + +test_that("an identified GP below the floor warns, and one clear of it prints its range", { + skip_if_not_installed("brms") + d <- .fba_pts(range = 8000) + des <- .fba_design(d) + set.seed(4) + N <- 800 + short <- .fba_engine( + ls = cbind(`lscale_gp..x..y..x` = stats::rnorm(N, 0.9 * des$ell_min, 0.02), + `lscale_gp..x..y..y` = stats::rnorm(N, 1.05 * des$ell_min, 0.02)), + sdgp = stats::rnorm(N, 1, 0.05), sigma = stats::rnorm(N, 0.5, 0.02)) + r <- .fba_fit(d, short) + expect_identical(r$fit$info$gp_adequacy$status, "below_resolution") + expect_gt(r$fit$info$gp_adequacy$frac_below, 0.10) + expect_equal(r$fit$info$convergence_diagnostics$gp_lscale_below_resolution, + r$fit$info$gp_adequacy$frac_below) + expect_true("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + msg <- conditionMessage(r$warnings[[which(.fba_classes(r$warnings) == + "spatialkit_gp_adequacy")]]) + expect_match(msg, "of the posterior length-scale draws fall below", fixed = TRUE) + expect_match(msg, "A `gp_resolution` below", fixed = TRUE) + # The residuals are read here too (the 8 km field, the stand-in's fitted + # values being zero), and the warning adds what they show. + expect_lt(r$fit$info$gp_adequacy$residual_moran$p, 0.05) + expect_match(msg, "The residuals are autocorrelated at short range (Moran's I = ", + fixed = TRUE) + # This was a log line, and print() showed "GP basis: 23 per dim" and no more. + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "** GP adequacy: below_resolution", fixed = TRUE) + expect_true(isTRUE(r$fit$info$convergence_ok)) + + # Clear of the floor, over residuals with nothing in them (white noise: + # over the 8 km field this posterior is "unresolved_short_range", as the + # test above has it, and it used to be asserted "ok" here). + d2 <- .fba_pts(seed = 21) + des2 <- .fba_design(d2) + long <- .fba_engine( + ls = cbind(`lscale_gp..x..y..x` = stats::rnorm(N, 2 * des2$ell_min, 0.03), + `lscale_gp..x..y..y` = stats::rnorm(N, 2.2 * des2$ell_min, 0.03)), + sdgp = stats::rnorm(N, 1, 0.05), sigma = stats::rnorm(N, 0.5, 0.02)) + r2 <- .fba_fit(d2, long) + ad <- r2$fit$info$gp_adequacy + expect_identical(ad$status, "ok") + expect_gt(ad$residual_moran$p, 0.05) + expect_length(r2$warnings, 0L) + # The posterior effective range, in map units, twice the floor on x. + expect_equal(ad$effective_range["x", "q50"], 2 * r2$fit$info$gp_resolution[["x"]], + tolerance = 0.01) + txt2 <- paste(utils::capture.output(print(r2$fit)), collapse = "\n") + expect_match(txt2, "GP range: ", fixed = TRUE) + expect_false(grepl("GP adequacy", txt2, fixed = TRUE)) + # summary() adds nothing for a fit that is fine. (fitted() was not needed + # for this fit, so the stand-in for the posterior draw is set again here.) + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) + matrix(0, nrow = 4L, ncol = nrow(newdata)), + .package = "brms") + expect_false(grepl("GP ", paste(utils::capture.output(print(summary(r2$fit))), + collapse = "\n"), fixed = TRUE)) +}) + +test_that("an unchecked fit says so and an older fit prints as it did", { + skip_if_not_installed("brms") + d <- .fba_pts(n = 120) + local_mocked_bindings(brm = function(...) structure(list(), class = "fba_stub"), + .package = "brms") + local_mocked_bindings(estimate_sac_range = function(...) 9e4, + .package = "spatialkit") + fit <- suppressWarnings(suppressMessages(fit_bayesian_spatial_model( + d, "z", character(0), compute_loo = FALSE, check_convergence = FALSE))) + expect_identical(fit$info$gp_adequacy$status, "not_checked") + expect_length(fit$info$convergence_diagnostics, 0L) + expect_false(grepl("GP adequacy", paste(utils::capture.output(print(fit)), + collapse = "\n"), fixed = TRUE)) + # A fit saved before these fields existed prints without them. + old <- fit + old$info[c("gp_adequacy", "gp_resolution", "gp_prefit", "b_prior", + "b_prior_source", "predictor_levels")] <- NULL + txt <- paste(utils::capture.output(print(old)), collapse = "\n") + expect_match(txt, "GP basis: ", fixed = TRUE) + expect_false(grepl("GP resolves", txt, fixed = TRUE)) + expect_no_error(utils::capture.output(print(old))) +}) + + +# --------------------------------------------------------------------------- +# Real sampler (opt-in). Six default fits of two chains, three of 600 +# iterations and three of 1,000, one to two minutes each. +# --------------------------------------------------------------------------- + +.fba_stan_fit <- function(pts, iter = 600, seed = 123) { + w <- list(); fit <- NULL + utils::capture.output( + fit <- withCallingHandlers( + suppressMessages(fit_bayesian_spatial_model( + pts, "z", character(0), chains = 2, iter = iter, cores = 1, seed = seed, + compute_loo = FALSE, backend = "rstan")), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }), + type = "output") + list(fit = fit, warnings = w) +} + +test_that("a field the basis resolves is 'ok' and its range is recovered in map units", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + # A squared-exponential field on a 100 km square whose length-scale is the + # median of the prior this layout gets: an effective range near 0.6 of the + # side, well above the 32 km floor. + n <- 400 + set.seed(1) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + des <- .fba_design(sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2]), + coords = c("x", "y"), crs = 32617)) + med <- 1 / stats::qgamma(0.5, des$shape, rate = des$scale) + ell <- med * mean(c(stats::sd(xy[, 1]), stats::sd(xy[, 2]))) + e <- eigen(exp(-as.matrix(stats::dist(xy))^2 / (2 * ell^2)), symmetric = TRUE) + set.seed(5) + f <- as.numeric(e$vectors %*% (sqrt(pmax(e$values, 0)) * stats::rnorm(n))) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], + z = f + stats::rnorm(n, 0, sqrt(0.3))), + coords = c("x", "y"), crs = 32617) + r <- .fba_stan_fit(pts) + ad <- r$fit$info$gp_adequacy + expect_identical(ad$status, "ok") + expect_true(ad$identified) + expect_lt(ad$frac_below, 0.10) + # And nothing is left in the residuals at short range. + expect_gt(ad$residual_moran$p, 0.05) + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + # The posterior effective range, in metres, brackets the truth on each axis. + truth <- sqrt(2 * log(20)) * ell + expect_true(all(ad$effective_range[, "q2.5"] < truth)) + expect_true(all(ad$effective_range[, "q97.5"] > truth)) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP range: ", fixed = TRUE) +}) + +test_that("white noise is 'no_signal_above_floor', logged and not raised", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + n <- 400 + set.seed(1) + xy <- cbind(runif(n, 0, 8e5), runif(n, 0, 3e5)) + set.seed(77) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], + z = stats::rnorm(n, 0, sqrt(1.3))), + coords = c("x", "y"), crs = 32617) + r <- .fba_stan_fit(pts) + ad <- r$fit$info$gp_adequacy + # The share of draws below the floor (0.0075 in the fit this reproduces) + # said nothing; the status does. + expect_lt(ad$frac_below, 0.10) + expect_false(ad$identified) + expect_identical(ad$status, "no_signal_above_floor") + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP adequacy: no_signal_above_floor", fixed = TRUE) +}) + +test_that("a plane plus noise is 'ok': the GP carries the variance at a range longer than the extent", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + # The fit that was reported as "no spatial structure found": R2 of the + # fitted surface 0.85, the GP's share of the variance 0.71 to 0.95, and a + # length-scale posterior on the long side of its prior and wider than it + # (contraction -1.35 and -2.27). + n <- 200 + set.seed(42) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + z <- 3 * xy[, 1] / 1e5 + 2 * xy[, 2] / 1e5 + stats::rnorm(n, 0, 0.5) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), + coords = c("x", "y"), crs = 32617) + r <- .fba_stan_fit(pts) + ad <- r$fit$info$gp_adequacy + expect_true(all(ad$contraction < 0)) + expect_true(all(ad$prior_gap > 0.30)) + expect_gt(ad$spatial_share[["q2.5"]], 0.3) + expect_true(ad$identified) + expect_identical(ad$status, "ok") + expect_lt(ad$frac_below, 0.10) + # The residuals of a plane the surface took whole show nothing at short + # range (p was 0.90 in the fit this reproduces). + expect_gt(ad$residual_moran$p, 0.05) + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + # The posterior effective range is longer than the 32 km floor on both axes. + expect_true(all(ad$effective_range[, "q2.5"] > max(r$fit$info$gp_resolution))) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP range: ", fixed = TRUE) + expect_false(grepl("no_signal_above_floor", txt, fixed = TRUE)) + # The surface it fitted explains most of the response. + expect_gt(1 - stats::var(stats::residuals(r$fit)) / stats::var(z), 0.6) +}) + +test_that("a field with a 200 km range and a bowl stay 'ok': nothing is left in their residuals", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + # Two more surfaces that are smooth over the whole extent, with the plane + # above the three fits whose length-scale posterior is wider than its + # prior. Reading the residuals of every fit must not cost them their + # status: p was 0.90 and 0.97 in the fits these reproduce. + n <- 200 + set.seed(42) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + ell <- 2e5 / sqrt(2 * log(20)) + e <- eigen(exp(-as.matrix(stats::dist(xy))^2 / (2 * ell^2)), symmetric = TRUE) + z_se200 <- 2 * as.numeric(e$vectors %*% (sqrt(pmax(e$values, 0)) * stats::rnorm(n))) + + stats::rnorm(n, 0, 0.5) + set.seed(42) + xy_b <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + z_bowl <- 4 * ((xy_b[, 1] / 1e5 - 0.5)^2 + (xy_b[, 2] / 1e5 - 0.5)^2) / 0.5 + + stats::rnorm(n, 0, 0.3) + for (z in list(z_se200, z_bowl)) { + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), + coords = c("x", "y"), crs = 32617) + r <- .fba_stan_fit(pts, iter = 1000, seed = 3) + ad <- r$fit$info$gp_adequacy + expect_true(ad$identified) + expect_identical(ad$status, "ok") + expect_gt(ad$residual_moran$p, 0.05) + expect_lt(ad$residual_moran$I, 0.05) + expect_false("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP range: ", fixed = TRUE) + expect_false(grepl("GP adequacy", txt, fixed = TRUE)) + } +}) + +test_that("a weak plane plus a field with an 8 km range is not 'ok': the residuals hold what the surface left", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + # The fit that came back "ok" with no warning of any class and + # "Convergence: passed": a plane rising 1 along x and 0.7 along y, an + # exponential field with an 8 km effective range (about four fifths of the + # variance) and noise, on a 100 km square whose basis resolves 33 km. The + # Gaussian process took the plane (a share of the variance of 0.09 to 0.54 + # at 55 and 72 km, 2 percent of length-scale draws below the floor), its + # surface explained 19 percent of the response, and the residuals had a + # Moran's I of 0.143 (p = 5.6e-06) that nothing read. + n <- 400 + set.seed(1001) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + e <- eigen(exp(-as.matrix(stats::dist(xy)) / (8000 / 3)), symmetric = TRUE) + f <- as.numeric(e$vectors %*% (sqrt(pmax(e$values, 0)) * stats::rnorm(n))) + z <- xy[, 1] / 1e5 + 0.7 * xy[, 2] / 1e5 + f + stats::rnorm(n, 0, sqrt(0.1)) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), + coords = c("x", "y"), crs = 32617) + r <- .fba_stan_fit(pts, iter = 1000, seed = 3) + ad <- r$fit$info$gp_adequacy + # Everything the posterior says is what an adequate fit says. + expect_true(ad$identified) + expect_gt(ad$spatial_share[["q2.5"]], 0.01) + expect_lt(ad$frac_below, 0.10) + # The residuals do not. + expect_false(identical(ad$status, "ok")) + expect_identical(ad$status, "unresolved_short_range") + expect_lt(ad$residual_moran$p, 0.001) + expect_gt(ad$residual_moran$I, 0.05) + expect_true("spatialkit_gp_adequacy" %in% .fba_classes(r$warnings)) + msg <- conditionMessage(r$warnings[[which(.fba_classes(r$warnings) == + "spatialkit_gp_adequacy")]]) + expect_match(msg, "and the residuals are still autocorrelated at short range", + fixed = TRUE) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "** GP adequacy: unresolved_short_range", fixed = TRUE) + expect_false(grepl("GP range: ", txt, fixed = TRUE)) + # Most of the response is still in the residuals. + expect_lt(1 - stats::var(stats::residuals(r$fit)) / stats::var(z), 0.5) +}) diff --git a/tests/testthat/test-fix-bayes-convergence.R b/tests/testthat/test-fix-bayes-convergence.R new file mode 100644 index 00000000..8c5be421 --- /dev/null +++ b/tests/testthat/test-fix-bayes-convergence.R @@ -0,0 +1,386 @@ +# convergence_ok follows Stan's own diagnostics. +# +# The verdict cut R-hat at 1.05 and judged effective sample size as a share +# of the draws (below 0.1 failed). That share is 100 per chain only at the +# default 4 x 2000: a fit of two chains and 300 post-warmup draws each, with +# bulk and tail ESS of 130 and 137 and 66 parameters above R-hat 1.01, passed +# while rstan raised both of its ESS warnings on it. Tree-depth saturation +# and E-BFMI were not read, and a failed verdict was a log line only. +# +# R-hat has two tiers. One cut at 1.01 over every parameter fails fits that +# have converged: this model has about 540 parameters, and a default fit of +# four chains and 2,000 iterations whose smallest effective sample size was +# 1,278 (400 required) had one basis weight at 1.011. So above 1.05 fails, +# above 1.01 fails beside too few effective draws for that parameter, and +# above 1.01 with enough is a caution. +# +# No Stan: brms::brm() returns a stand-in and the brms accessors the check +# reads are replaced, so the rules run on vectors chosen for each case. + +.fbc_pts <- function(n = 120, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = stats::rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + stats::rnorm(n) + d +} + +.fbc_np <- function(n_div = 0, treedepth = rep(5, 40), energy = NULL, + chains = 2L) { + per <- length(treedepth) / chains + it <- rep(seq_len(per), times = chains) + ch <- rep(seq_len(chains), each = per) + if (is.null(energy)) { + set.seed(99); energy <- stats::rnorm(length(treedepth)) + } + rbind( + data.frame(Chain = ch, Iteration = it, Parameter = "divergent__", + Value = c(rep(1, n_div), rep(0, length(treedepth) - n_div))), + data.frame(Chain = ch, Iteration = it, Parameter = "treedepth__", + Value = treedepth), + data.frame(Chain = ch, Iteration = it, Parameter = "energy__", + Value = energy)) +} + +# Fit with the accessors returning what each case needs. `...` reaches the +# fitter (chains, iter, control). +.fbc_fit <- function(rhat, neff, np = .fbc_np(), ...) { + d <- .fbc_pts() + local_mocked_bindings( + brm = function(...) structure(list(), class = "brmsfit"), + nuts_params = function(...) np, + rhat = function(...) rhat, + neff_ratio = function(...) neff, + .package = "brms") + local_mocked_bindings(estimate_sac_range = function(...) 5000, + .package = "spatialkit") + w <- list() + fit <- withCallingHandlers( + suppressMessages(fit_bayesian_spatial_model(d, "z", "a", gp_k = 5, + compute_loo = FALSE, ...)), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }) + conv <- Filter(function(c) inherits(c, "spatialkit_convergence"), w) + list(fit = fit, conv = conv) +} + +.fbc_pars <- c("b_Intercept", "b_a", "sdgp_gp..x..y", "lscale_gp..x..y..x", + "sigma", "lprior") +.fbc_vec <- function(v) stats::setNames(rep_len(v, length(.fbc_pars)), .fbc_pars) + + +test_that("the effective-sample-size rule is 100 per chain, not a share of the draws", { + low <- spatialkit:::.bayes_low_ess + r <- c(a = 0.15, b = 0.5, c = NaN) + # Two chains of 500: 0.15 of 1000 draws is 150, under the 200 required. + # The share rule (below 0.1 fails) passed it. + expect_identical(low(r, n_draws = 1000, n_chains = 2), "a") + # Four chains of 10,000: 0.05 of 40,000 draws is 2,000, far above 400. + # The share rule failed it. + expect_identical(low(c(a = 0.05, b = 0.5), n_draws = 40000, n_chains = 4), + character(0)) + # At the default 4 x 1000 post-warmup draws the two rules agree. + expect_identical(low(c(a = 0.09, b = 0.11), n_draws = 4000, n_chains = 4), "a") + # Unknown draw or chain counts flag nothing; they do not error. + expect_identical(low(r, n_draws = NA_real_, n_chains = 2), character(0)) + expect_identical(spatialkit:::.bayes_ess_per_chain, 100) + expect_identical(spatialkit:::.bayes_rhat_max, 1.05) + expect_identical(spatialkit:::.bayes_rhat_caution, 1.01) + expect_identical(spatialkit:::.bayes_ebfmi_min, 0.3) +}) + +test_that(".bayes_rhat_tiers() fails above 1.05, and above 1.01 only beside too few effective draws", { + tiers <- spatialkit:::.bayes_rhat_tiers + rh <- c(a = 1.002, b = 1.011, c = 1.03, d = 1.06, e = NaN, f = 1.02) + ne <- c(a = 0.5, b = 0.32, c = 0.05, d = 0.9, e = NaN, f = 0.4) + # Four chains of 1000: 400 effective draws required. b has 1280 (caution), + # c has 200 (fails), d is above 1.05 whatever it has, f has 1600 (caution). + got <- tiers(rh, ne, n_draws = 4000, n_chains = 4) + expect_identical(got$failed, c("c", "d")) + expect_identical(got$caution, c("b", "f")) + # A constant parameter (NaN) is in neither. + expect_false("e" %in% c(got$failed, got$caution)) + # Nothing above 1.01: both empty. + expect_identical(tiers(c(a = 1.001, b = 1.009), ne, 4000, 4), + list(failed = character(0), caution = character(0))) + # An effective sample size that cannot be read does not excuse the R-hat: + # no ratios at all, a parameter missing from them, unknown draw counts. + expect_identical(tiers(rh, NULL, 4000, 4)$failed, c("b", "c", "d", "f")) + expect_identical(tiers(rh, ne[c("a", "c", "d")], 4000, 4)$failed, + c("b", "c", "d", "f")) + expect_identical(tiers(rh, ne, NA_real_, 4)$failed, c("b", "c", "d", "f")) + expect_length(tiers(rh, NULL, 4000, 4)$caution, 0L) + # The requirement follows the chains: at two chains of 500, c's 50 draws + # are short and b's 320 are enough. + got2 <- tiers(rh, ne, n_draws = 1000, n_chains = 2) + expect_identical(got2$failed, c("c", "d")) + expect_identical(got2$caution, c("b", "f")) +}) + +test_that(".bayes_convergence_advice() gives the remedy for the checks that failed", { + adv <- spatialkit:::.bayes_convergence_advice + # Divergences alone: adapt_delta, and no advice to run longer. + d <- adv("divergent", iter = 2000, chains = 4, adapt_delta = 0.9) + expect_match(d, "raise adapt_delta in `control` (now 0.90)", fixed = TRUE) + expect_match(d, "more iterations do not remove them", fixed = TRUE) + expect_false(grepl("Run more iterations", d, fixed = TRUE)) + # R-hat and effective sample size: more iterations, and nothing on + # adapt_delta. + r <- adv(c("rhat", "ess"), iter = 1000, chains = 2, adapt_delta = 0.9) + expect_identical(r, paste0("Run more iterations (iter = 1000, chains = 2 now) ", + "to bring R-hat down and raise the effective sample size.")) + expect_identical(adv("ess", iter = 1000, chains = 2), + "Run more iterations (iter = 1000, chains = 2 now) to raise the effective sample size.") + # E-BFMI is neither. + e <- adv("ebfmi", iter = 2000, chains = 4) + expect_match(e, "A low E-BFMI comes from the shape of the posterior", fixed = TRUE) + expect_false(grepl("Run more iterations|adapt_delta", e)) + # All of them, in one string, each once. + all4 <- adv(c("divergent", "ebfmi", "rhat", "ess"), 2000, 4, 0.95) + expect_match(all4, "(now 0.95)", fixed = TRUE) + expect_match(all4, "Run more iterations (iter = 2000, chains = 4 now)", fixed = TRUE) + expect_match(all4, "E-BFMI", fixed = TRUE) +}) + +test_that(".bayes_ebfmi() is the energy fraction per chain", { + set.seed(3) + e1 <- stats::rnorm(200) # independent energies: about 2 + e2 <- cumsum(stats::rnorm(200, sd = 0.05)) # a slow random walk: near 0 + np <- data.frame(Chain = rep(1:2, each = 200), Iteration = rep(1:200, 2), + Parameter = "energy__", Value = c(e1, e2)) + got <- spatialkit:::.bayes_ebfmi(np) + expect_named(got, c("1", "2")) + expect_equal(got[["1"]], (sum(diff(e1)^2) / 200) / stats::var(e1)) + expect_gt(got[["1"]], 1) + expect_lt(got[["2"]], 0.3) + # No energies recorded: nothing to report. + expect_length(spatialkit:::.bayes_ebfmi(np[0, ]), 0L) + expect_length(spatialkit:::.bayes_ebfmi(data.frame(Parameter = "divergent__", + Value = 0)), 0L) +}) + +test_that("a clean fit passes and raises nothing", { + skip_if_not_installed("brms") + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7)) + expect_true(isTRUE(r$fit$info$convergence_ok)) + expect_length(r$conv, 0L) + cd <- r$fit$info$convergence_diagnostics + expect_identical(cd$n_divergent, 0) + expect_identical(cd$n_max_treedepth, 0L) + expect_length(cd$rhat_failed, 0L) + expect_length(cd$neff_failed, 0L) + expect_length(cd$ess_failed, 0L) + # 4 chains x (2000 - 1000) draws by default. + expect_identical(cd$ess_required, 400) + expect_equal(cd$min_ess, 0.7 * 4000) + expect_named(cd$ebfmi, c("1", "2")) +}) + +test_that("R-hat above 1.05 fails the verdict and is raised with the parameters named", { + skip_if_not_installed("brms") + rh <- .fbc_vec(1.002) + rh[["sdgp_gp..x..y"]] <- 1.07 + rh[["lprior"]] <- NaN # constant parameter: not a failure + r <- .fbc_fit(rhat = rh, neff = .fbc_vec(0.7)) + expect_identical(r$fit$info$convergence_ok, FALSE) + cd <- r$fit$info$convergence_diagnostics + expect_identical(names(cd$rhat_failed), "sdgp_gp..x..y") + expect_length(cd$rhat_caution, 0L) + expect_equal(cd$max_rhat, 1.07) + # One R warning, classed, where there was a log line. + expect_length(r$conv, 1L) + msg <- conditionMessage(r$conv[[1]]) + expect_match(msg, paste0("1 parameter(s) fail on R-hat (max 1.070): 1 above 1.05, ", + "0 above 1.01 with too few effective draws: sdgp_gp..x..y"), + fixed = TRUE) + expect_match(msg, "$info$convergence_ok is FALSE", fixed = TRUE) + # R-hat is answered with more iterations, not with adapt_delta. + expect_match(msg, "Run more iterations (iter = 2000, chains = 4 now) to bring R-hat down.", + fixed = TRUE) + expect_false(grepl("adapt_delta", msg, fixed = TRUE)) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "Convergence warnings present", fixed = TRUE) +}) + +test_that("R-hat between 1.01 and 1.05 with enough effective draws is a caution, not a failure", { + skip_if_not_installed("brms") + # The fit the rule was changed for: about 540 parameters at the default + # four chains of 1000 draws, one basis weight at 1.011, and a smallest + # effective sample size of 1,278 against 400 required. It was failed and + # told to run more iterations. + pars <- c(.fbc_pars, sprintf("zgp_gp..x..y[%d]", 1:529)) + rh <- stats::setNames(rep(1.003, length(pars)), pars) + rh[["zgp_gp..x..y[63]"]] <- 1.011 + rh[["lprior"]] <- NaN + ne <- stats::setNames(rep(0.6, length(pars)), pars) + ne[["zgp_gp..x..y[63]"]] <- 1278 / 4000 + logged <- capture_spatialkit_log(r <- .fbc_fit(rhat = rh, neff = ne), + level = logger::WARN) + expect_true(isTRUE(r$fit$info$convergence_ok)) + expect_length(r$conv, 0L) + cd <- r$fit$info$convergence_diagnostics + expect_length(cd$rhat_failed, 0L) + expect_identical(names(cd$rhat_caution), "zgp_gp..x..y[63]") + expect_equal(unname(cd$rhat_caution), 1.011) + expect_equal(cd$max_rhat, 1.011) + # Recorded, logged and printed; not flagged. + expect_true(log_has(logged, "1 of 534 parameter\\(s\\) have R-hat between 1.01 and 1.05 \\(max 1.011\\)")) + expect_true(log_has(logged, "at least the 400 effective draws required")) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "Convergence: passed; 1 parameter(s) with R-hat between 1.01 and 1.05", + fixed = TRUE) + expect_false(grepl("Convergence warnings present", txt, fixed = TRUE)) + # print() on a summary says the same. (Built by hand: the stand-in engine + # has no fitted values for summary() to score.) + smry <- structure(list(class = "bayesian_fit", formula = r$fit$formula, n = r$fit$n, + response_var = "z", predictor_vars = "a", + info = r$fit$info[setdiff(names(r$fit$info), ".cache")], + in_sample = data.frame(n = r$fit$n, RMSE = 1, MAE = 1, R2 = 0.5)), + class = "summary.spatial_fit") + stx <- paste(utils::capture.output(print(smry)), collapse = "\n") + expect_match(stx, "Convergence: passed; 1 parameter(s) with R-hat between 1.01 and 1.05", + fixed = TRUE) + expect_false(grepl("Convergence warnings present", stx, fixed = TRUE)) + + # The same R-hat beside too few effective draws for that parameter fails, + # on both counts. + ne2 <- ne; ne2[["zgp_gp..x..y[63]"]] <- 300 / 4000 + r2 <- .fbc_fit(rhat = rh, neff = ne2) + expect_identical(r2$fit$info$convergence_ok, FALSE) + expect_identical(names(r2$fit$info$convergence_diagnostics$rhat_failed), + "zgp_gp..x..y[63]") + expect_length(r2$fit$info$convergence_diagnostics$rhat_caution, 0L) + m2 <- conditionMessage(r2$conv[[1]]) + expect_match(m2, paste0("1 parameter(s) fail on R-hat (max 1.011): 0 above 1.05, ", + "1 above 1.01 with too few effective draws: zgp_gp..x..y[63]"), + fixed = TRUE) + expect_match(m2, "effective sample size under 400", fixed = TRUE) + expect_match(m2, "to bring R-hat down and raise the effective sample size", fixed = TRUE) + + # And it fails when the effective sample size cannot be read at all. + r3 <- .fbc_fit(rhat = rh, neff = NULL) + expect_identical(r3$fit$info$convergence_ok, FALSE) + expect_identical(names(r3$fit$info$convergence_diagnostics$rhat_failed), + "zgp_gp..x..y[63]") + expect_match(conditionMessage(r3$conv[[1]]), + "1 above 1.01 with an effective sample size that could not be read: zgp_gp..x..y[63]", + fixed = TRUE) + + # A clean fit prints no convergence line at all. + r4 <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7)) + expect_false(grepl("Convergence", paste(utils::capture.output(print(r4$fit)), + collapse = "\n"), fixed = TRUE)) +}) + +test_that("effective sample size is judged per chain in the fit", { + skip_if_not_installed("brms") + ne <- .fbc_vec(0.7) + ne[["lscale_gp..x..y..x"]] <- 0.15 + # chains = 2, iter = 1000: 1000 post-warmup draws, so 150 effective draws + # against 200 required. convergence_ok was TRUE. + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = ne, chains = 2, iter = 1000) + expect_identical(r$fit$info$convergence_ok, FALSE) + cd <- r$fit$info$convergence_diagnostics + expect_identical(names(cd$neff_failed), "lscale_gp..x..y..x") + expect_equal(unname(cd$ess_failed), 150) + expect_identical(cd$ess_required, 200) + expect_equal(cd$min_ess, 150) + expect_length(r$conv, 1L) + expect_match(conditionMessage(r$conv[[1]]), + "1 parameter(s) with bulk or tail effective sample size under 200 (100 per chain x 2 chain(s); min 150): lscale_gp..x..y..x", + fixed = TRUE) + + # The same ratio is enough at the default four chains of 1000 draws: 600. + r4 <- .fbc_fit(rhat = .fbc_vec(1.002), neff = ne) + expect_true(isTRUE(r4$fit$info$convergence_ok)) + # And a ratio the share rule failed passes when the chains are long. + ne2 <- .fbc_vec(0.7); ne2[["sigma"]] <- 0.05 + r5 <- .fbc_fit(rhat = .fbc_vec(1.002), neff = ne2, chains = 4, iter = 20000) + expect_true(isTRUE(r5$fit$info$convergence_ok)) + expect_equal(r5$fit$info$convergence_diagnostics$min_ess, 0.05 * 40000) +}) + +test_that("divergences and low E-BFMI fail; tree-depth saturation is recorded only", { + skip_if_not_installed("brms") + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7), + np = .fbc_np(n_div = 3)) + expect_identical(r$fit$info$convergence_ok, FALSE) + msg <- conditionMessage(r$conv[[1]]) + expect_match(msg, "3 divergent transition(s) after warmup", fixed = TRUE) + # The remedy is adapt_delta. The warning used to close with "Run more + # iterations" whatever had failed, and more iterations do not remove + # divergent transitions. + expect_match(msg, "raise adapt_delta in `control` (now 0.90); more iterations do not remove them", + fixed = TRUE) + expect_false(grepl("Run more iterations", msg, fixed = TRUE)) + # A user's adapt_delta is the one reported. + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7), + np = .fbc_np(n_div = 2), control = list(adapt_delta = 0.95)) + expect_match(conditionMessage(r$conv[[1]]), "(now 0.95)", fixed = TRUE) + + set.seed(5) + walk <- c(stats::rnorm(20), cumsum(stats::rnorm(20, sd = 0.02))) + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7), + np = .fbc_np(energy = walk)) + expect_identical(r$fit$info$convergence_ok, FALSE) + expect_lt(r$fit$info$convergence_diagnostics$ebfmi[["2"]], 0.3) + expect_gt(r$fit$info$convergence_diagnostics$ebfmi[["1"]], 0.3) + expect_match(conditionMessage(r$conv[[1]]), "E-BFMI below 0.3 in chain(s) 2", + fixed = TRUE) + expect_match(conditionMessage(r$conv[[1]]), + "A low E-BFMI comes from the shape of the posterior", fixed = TRUE) + expect_false(grepl("Run more iterations", conditionMessage(r$conv[[1]]), fixed = TRUE)) + + # Transitions at the tree-depth limit (12, the package default): counted + # and logged, verdict unchanged. + td <- rep(5, 40); td[1:7] <- 12 + logged <- capture_spatialkit_log( + r <- .fbc_fit(rhat = .fbc_vec(1.002), neff = .fbc_vec(0.7), + np = .fbc_np(treedepth = td)), + level = logger::WARN) + expect_true(isTRUE(r$fit$info$convergence_ok)) + expect_identical(r$fit$info$convergence_diagnostics$n_max_treedepth, 7L) + expect_length(r$conv, 0L) + expect_true(log_has(logged, "7 transition\\(s\\) stopped at max_treedepth = 12")) +}) + +test_that("several failures arrive as one warning", { + skip_if_not_installed("brms") + rh <- .fbc_vec(1.002); rh[c("sigma", "b_a")] <- c(1.08, 1.02) + ne <- .fbc_vec(0.7); ne[["sigma"]] <- 0.01 + r <- .fbc_fit(rhat = rh, neff = ne, np = .fbc_np(n_div = 1)) + expect_length(r$conv, 1L) + msg <- conditionMessage(r$conv[[1]]) + expect_match(msg, "1 divergent transition(s)", fixed = TRUE) + # sigma is above 1.05. b_a is at 1.02 with 2,800 effective draws: a + # caution, counted in the message and not in the failures. + expect_match(msg, paste0("1 parameter(s) fail on R-hat (max 1.080): 1 above 1.05, ", + "0 above 1.01 with too few effective draws (1 more above ", + "1.01 have enough and are not counted): sigma"), + fixed = TRUE) + expect_identical(names(r$fit$info$convergence_diagnostics$rhat_caution), "b_a") + expect_match(msg, "effective sample size under 400", fixed = TRUE) + # Each failed check gets its own remedy, once. + expect_match(msg, "raise adapt_delta in `control` (now 0.90)", fixed = TRUE) + expect_match(msg, "Run more iterations (iter = 2000, chains = 4 now) to bring R-hat down and raise the effective sample size.", + fixed = TRUE) + # It can be caught by class. + caught <- tryCatch( + { + d <- .fbc_pts() + local_mocked_bindings( + brm = function(...) structure(list(), class = "brmsfit"), + nuts_params = function(...) .fbc_np(n_div = 2), + rhat = function(...) .fbc_vec(1.002), + neff_ratio = function(...) .fbc_vec(0.7), + .package = "brms") + local_mocked_bindings(estimate_sac_range = function(...) 5000, + .package = "spatialkit") + suppressMessages(fit_bayesian_spatial_model(d, "z", "a", gp_k = 5, + compute_loo = FALSE)) + "no condition" + }, + spatialkit_convergence = function(c) "caught") + expect_identical(caught, "caught") +}) diff --git a/tests/testthat/test-fix-bayes-gp-resolution.R b/tests/testthat/test-fix-bayes-gp-resolution.R new file mode 100644 index 00000000..54ed1969 --- /dev/null +++ b/tests/testthat/test-fix-bayes-gp-resolution.R @@ -0,0 +1,490 @@ +# What the GP basis of fit_bayesian_spatial_model() resolves, in map units, +# and what is said about it before anything is compiled. +# +# The basis has a floor: an effective range below which it cannot represent +# structure. With the defaults that floor is 14 to 33 percent of the extent +# along each axis, and nothing reported it in map units, compared it with the +# data, or let a caller ask for a finer one. +# +# No Stan: brms::brm() is replaced by a recorder. + +.fbr_capture <- function(...) { + cap <- new.env() + local_mocked_bindings( + brm = function(...) { cap$args <- list(...); structure(list(), class = "fbr_stub") }, + .package = "brms") + w <- list() + fit <- withCallingHandlers( + suppressMessages(fit_bayesian_spatial_model( + ..., compute_loo = FALSE, check_convergence = FALSE)), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }) + list(fit = fit, args = cap$args, warnings = w) +} + +.fbr_classes <- function(w) { + vapply(w, function(c) class(c)[1L], character(1)) +} + +# 500 points uniform on a 100 km square; the response is white noise unless +# `range` gives an exponential field's effective range. +.fbr_pts <- function(n = 500, seed = 20261011, side = 1e5, range = NULL, + nugget = 0.09) { + set.seed(seed) + xy <- cbind(runif(n, 0, side), runif(n, 0, side)) + z <- if (is.null(range)) stats::rnorm(n) else { + D <- as.matrix(stats::dist(xy)) + as.numeric(t(chol(exp(-D / (range / 3)) + diag(1e-8, n))) %*% stats::rnorm(n)) + + stats::rnorm(n, 0, sqrt(nugget)) + } + sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z, a = stats::rnorm(n)), + coords = c("x", "y"), crs = 32617) +} + +# A stand-in for estimate_sac_range() that returns what it is told. +.fbr_sac <- function(value, reason = NULL) { + function(...) if (is.null(reason)) value else + structure(NA_real_, rejected_reason = reason) +} + + +test_that("the fit stores the basis floor as an effective range in map units", { + skip_if_not_installed("brms") + d <- .fbr_pts() + local_mocked_bindings(estimate_sac_range = .fbr_sac(9e4), .package = "spatialkit") + r <- .fbr_capture(d, "z", character(0)) + inf <- r$fit$info + expect_named(inf$gp_resolution, c("x", "y")) + # By definition: sqrt(2 log 20) length-scales, each axis on its own SD. + cs <- inf$coord_scaling + expect_equal(unname(inf$gp_resolution), + sqrt(2 * log(20)) * inf$gp_ell_min * c(cs$x_scale, cs$y_scale)) + # Recomputed from the rule itself, outside the package: the lower bound is + # the 25th percentile of the pairwise distances as a length-scale, the + # boundary factor follows the upper bound, and k resolves the lower one. + xy <- sf::st_coordinates(d) + z <- cbind((xy[, 1] - mean(xy[, 1])) / stats::sd(xy[, 1]), + (xy[, 2] - mean(xy[, 2])) / stats::sd(xy[, 2])) + dd <- as.numeric(stats::dist(z)); dd <- dd[dd > 0] + Fse <- sqrt(2 * log(20)) + lower <- unname(stats::quantile(dd, 0.25)) / Fse + upper <- max(dd) / Fse + Xc <- sweep(z, 2, colMeans(z)); S <- max(1, max(Xc) - min(Xc)) + cc <- max(3.2 * upper / S, 1.25) + k <- min(max(ceiling(1.75 * cc / (lower / S)), 10), 50) + expect_identical(inf$gp_k, as.integer(k)) + expect_equal(unname(inf$gp_resolution), + Fse * (1.75 * cc * S / k) * c(stats::sd(xy[, 1]), stats::sd(xy[, 2]))) + # The value the review recorded for this layout: 32.3 km and 32.5 km, a + # third of the side. + expect_equal(unname(inf$gp_resolution) / 1000, c(32.3, 32.5), tolerance = 5e-3) + expect_null(inf$gp_resolution_requested) + + # print() gives it, with the CRS's unit. + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "GP resolves: effective ranges from 32,300 (x) and 32,500 (y) metre", + fixed = TRUE) +}) + +test_that("a response whose range is below the floor is warned about before compiling", { + skip_if_not_installed("brms") + skip_if_not_installed("gstat") + # An exponential field with a 6 km effective range on a 100 km square whose + # default basis resolves 33 km. Seeded: the range estimate is 7.3 km. + d <- .fbr_pts(n = 400, seed = 5, range = 6000) + r <- .fbr_capture(d, "z", character(0)) + expect_true("spatialkit_gp_resolution" %in% .fbr_classes(r$warnings)) + w <- r$warnings[[which(.fbr_classes(r$warnings) == "spatialkit_gp_resolution")]] + msg <- conditionMessage(w) + pf <- r$fit$info$gp_prefit + expect_identical(pf$status, "below_floor") + expect_lt(pf$range, pf$floor) + expect_equal(pf$floor, max(r$fit$info$gp_resolution)) + # Both numbers, in map units, and the basis size that would be needed. + fmt <- function(v) format(signif(v, 3), big.mark = ",", scientific = FALSE, trim = TRUE) + expect_match(msg, sprintf("at %s metre, shorter than the %s metre", fmt(pf$range), + fmt(pf$floor)), fixed = TRUE) + expect_match(msg, sprintf("gp_k = %s per dimension", format(pf$k_needed)), fixed = TRUE) + # It is said as what it is: a variogram estimate made before fitting, which + # the check after sampling tests on the residuals. It used to state the + # range as fact and say "this model cannot represent it"; and then to say + # the later check "supersedes" it, when that check read the residuals only + # for a Gaussian process that had found nothing. + expect_match(msg, "a variogram fitted before sampling puts the autocorrelation range of the response at", + fixed = TRUE) + expect_match(msg, "This is an estimate and can be wrong", fixed = TRUE) + expect_match(msg, "the check after sampling ($info$gp_adequacy, shown by print()) reads the fitted model and tests its residuals for what the surface left behind", + fixed = TRUE) + expect_false(grepl("supersedes", msg, fixed = TRUE)) + expect_match(msg, "If the range is right, structure at that range is counted as noise", + fixed = TRUE) + expect_false(grepl("cannot represent it", msg, fixed = TRUE)) + # Both tests that have to agree with the range do: autocorrelated at short + # range, and no longer at the floor's distance. + expect_lt(pf$moran$p, 0.05) + expect_false(pf$moran_floor$I > 0.05 && pf$moran_floor$p < 0.05) + expect_equal(pf$moran_floor$band, c(0.75, 1.25) * pf$floor) + expect_match(msg, "the autocorrelation at the floor's distance agrees with it (Moran's I = ", + fixed = TRUE) + # 104 per dimension is past the cap of 50: the message says so and points + # elsewhere, on the condition that the fitted model bears the range out. + expect_gt(pf$k_needed, 50) + expect_match(msg, "above the cap of 50", fixed = TRUE) + expect_match(msg, "if the fitted model bears the range out, use kriging", fixed = TRUE) + # The warning came before the model was built. Nothing was checked after + # it here, so print() flags the line. + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, sprintf("** Range before fitting: a variogram put it at %s metre", + fmt(pf$range)), fixed = TRUE) + + # A range the cap can reach is answered with the argument to pass. + local_mocked_bindings(estimate_sac_range = .fbr_sac(2.4e4), .package = "spatialkit") + r2 <- .fbr_capture(d, "z", character(0)) + m2 <- conditionMessage(r2$warnings[[which(.fbr_classes(r2$warnings) == + "spatialkit_gp_resolution")]]) + expect_match(m2, "gp_resolution = 24000 fits that basis", fixed = TRUE) +}) + +test_that("a short variogram range on a response still autocorrelated at the floor's distance is not warned about", { + skip_if_not_installed("brms") + # Smooth over long distances: a plane, and a sine with a 100 km wavelength, + # each plus noise. A variogram returned ranges of 5 to 7 km for surfaces + # like these (true ranges 60 to 90 km) in 1 to 9 draws of 60, and the + # short-lag Moran's I is significant for any real structure, so the range + # was warned about as fact. Here the variogram is handed that range. + n <- 400 + set.seed(31) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + mk <- function(z) sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), + coords = c("x", "y"), crs = 32617) + local_mocked_bindings(estimate_sac_range = .fbr_sac(6000), .package = "spatialkit") + for (z in list(3 * xy[, 1] / 1e5 + 2 * xy[, 2] / 1e5 + stats::rnorm(n, 0, 0.5), + sin(2 * pi * xy[, 1] / 1e5) + stats::rnorm(n))) { + logged <- capture_spatialkit_log(r <- .fbr_capture(mk(z), "z", character(0)), + level = logger::WARN) + pf <- r$fit$info$gp_prefit + expect_identical(pf$status, "below_floor_long_range") + expect_lt(pf$moran$p, 0.05) # the gate there was + expect_gt(pf$moran_floor$I, 0.05) # the one that was missing + expect_lt(pf$moran_floor$p, 0.05) + expect_false("spatialkit_gp_resolution" %in% .fbr_classes(r$warnings)) + # Logged, with both numbers, and printed without a flag. + expect_true(log_has(logged, "puts the autocorrelation range of the response at 6,000 metre")) + expect_true(log_has(logged, "is still autocorrelated at that distance")) + expect_true(log_has(logged, "no warning is raised on it")) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, " Range before fitting: a variogram put it at 6,000 metre, but the response is still autocorrelated at the floor's distance", + fixed = TRUE) + expect_false(grepl("** Range before fitting", txt, fixed = TRUE)) + } +}) + +test_that(".gp_floor_moran() is Moran's I over the pairs about one floor apart", { + n <- 300 + set.seed(8) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + fl <- 3.2e4 + # A plane: strongly correlated at any distance short of the extent. + pl <- spatialkit:::.gp_floor_moran(xy, xy[, 1] / 1e5 + stats::rnorm(n, 0, 0.1), floor = fl) + expect_gt(pl$I, 0.2) + expect_lt(pl$p, 1e-6) + expect_equal(pl$band, c(0.75, 1.25) * fl) + # Recomputed by hand: binary weights over the band, residuals of the mean. + z <- xy[, 1] / 1e5 + stats::rnorm(n, 0, 0.1) + got <- spatialkit:::.gp_floor_moran(xy, z, floor = fl) + D <- as.matrix(stats::dist(xy)); W <- (D >= 0.75 * fl & D < 1.25 * fl) * 1 + e <- z - mean(z) + expect_equal(got$I, (n / sum(W)) * sum(e * (W %*% e)) / sum(e^2)) + expect_equal(got$n_pairs, sum(W) / 2) + # White noise: nothing there. + wn <- spatialkit:::.gp_floor_moran(xy, stats::rnorm(n), floor = fl) + expect_lt(abs(wn$I), 0.05) + # With predictors the residuals are the ones tested: a response that is the + # predictor has none. + a <- xy[, 1] / 1e5 + ap <- spatialkit:::.gp_floor_moran(xy, 2 * a + stats::rnorm(n, 0, 0.1), X = cbind(a = a), + floor = fl) + expect_lt(abs(ap$I), 0.05) + # More rows than max_n are thinned at even steps, with no random draw. + set.seed(1); before <- .Random.seed + th <- spatialkit:::.gp_floor_moran(xy, z, floor = fl, max_n = 100L) + expect_identical(.Random.seed, before) + expect_lt(th$n_pairs, got$n_pairs / 4) + expect_gt(th$I, 0.2) + # No pair in the band, a floor that is not a distance, too few rows: NULL. + expect_null(spatialkit:::.gp_floor_moran(xy, z, floor = 1e7)) + expect_null(spatialkit:::.gp_floor_moran(xy, z, floor = NA_real_)) + expect_null(spatialkit:::.gp_floor_moran(xy[1:5, ], z[1:5], floor = fl)) + expect_identical(spatialkit:::.gp_range_correlation, 0.05) +}) + +test_that("print() flags the pre-fit range unless the residuals after sampling answer it", { + lines <- spatialkit:::.bayes_gp_print_lines + eff <- matrix(c(5e4, 6e4, 7e4, 5e4, 6e4, 7e4), nrow = 2, byrow = TRUE, + dimnames = list(c("x", "y"), c("q2.5", "q50", "q97.5"))) + info <- function(status, moran = NULL, prefit = "below_floor") list( + gp_resolution = c(x = 32300, y = 32500), + gp_prefit = list(status = prefit, range = 6000, unit = "metre"), + gp_adequacy = list(status = status, unit = "metre", effective_range = eff, + frac_below = 0.4, spatial_share = c(0, 0.01, 0.1), + residual_moran = moran)) + clear <- list(I = -0.012, z = -0.3, p = 0.62, k = 4L) + left <- list(I = 0.143, z = 4.4, p = 5.6e-06, k = 4L) + # "ok" on a residual test that found nothing: the variogram's range stays + # on the page as the estimate it was, unflagged, beside the test that + # answered it. It used to be flagged whatever the fit found, and then to + # read "the fitted model does not bear that out" whenever the posterior + # alone looked adequate, which was printed over a field with a 10 km range. + ok <- lines(info("ok", clear)) + expect_true(any(ok == " Range before fitting: a variogram put it at 6,000 metre, below what the basis resolves; after fitting, the residuals show no autocorrelation at short range (Moran's I = -0.012, one-sided p = 0.62)")) + expect_false(any(grepl("** Range before fitting", ok, fixed = TRUE))) + expect_false(any(grepl("does not bear that out", ok, fixed = TRUE))) + expect_true(any(grepl("^ GP range: ", ok))) + # "ok" with no residual test behind it keeps the flag and says why. + nt <- lines(info("ok")) + expect_true(any(nt == " ** Range before fitting: a variogram put it at 6,000 metre, below what the basis resolves (an estimate; the residuals were not tested after fitting)")) + expect_true(any(grepl("^ GP range: ", nt))) + # Not checked, or found short: flagged. + for (st in c("not_checked", "below_resolution", "unresolved_short_range", + "no_signal_above_floor")) { + got <- lines(info(st, if (st == "unresolved_short_range") left)) + expect_true(any(grepl("** Range before fitting: a variogram put it at 6,000 metre, below what the basis resolves (an estimate; see GP adequacy)", + got, fixed = TRUE)), info = st) + } + # The adequacy line carries the test it rests on. + us <- lines(info("unresolved_short_range", left)) + expect_true(any(us == " ** GP adequacy: unresolved_short_range -- the GP's share of the variance is 0.000 to 0.100 (95% interval), and the residuals are autocorrelated at short range (Moran's I = 0.143, one-sided p = 5.6e-06)")) + expect_false(any(grepl("^ GP range: ", us))) + + # A short range beside structure that reaches the floor is not read as the + # range, and is not a flag, until the residuals show the short range was + # there as well. + lr_ok <- lines(info("ok", clear, prefit = "below_floor_long_range")) + expect_true(any(lr_ok == " Range before fitting: a variogram put it at 6,000 metre, but the response is still autocorrelated at the floor's distance, so that is not read as its range")) + for (st in c("unresolved_short_range", "below_resolution")) { + lr_us <- lines(info(st, left, prefit = "below_floor_long_range")) + expect_true(any(lr_us == " ** Range before fitting: a variogram put it at 6,000 metre, below what the basis resolves; the response is also autocorrelated at the floor's distance (see GP adequacy)"), + info = st) + } + # A fit with no adequacy record (saved by an earlier version, or a stand-in) + # prints the unflagged line and does not stop. + bare <- list(gp_resolution = c(x = 32300, y = 32500), + gp_prefit = list(status = "below_floor_long_range", range = 6000, + unit = "metre")) + expect_true(any(grepl("^ Range before fitting: a variogram put it at 6,000 metre, but the response is still autocorrelated", + lines(bare)))) +}) + +test_that("a range that cannot be estimated is said, not passed over", { + skip_if_not_installed("brms") + d <- .fbr_pts(n = 400, seed = 5, range = 6000) + local_mocked_bindings( + estimate_sac_range = .fbr_sac(NA, reason = "variogram model did not converge"), + .package = "spatialkit") + logged <- capture_spatialkit_log(r <- .fbr_capture(d, "z", character(0)), + level = logger::WARN) + pf <- r$fit$info$gp_prefit + expect_identical(pf$status, "not_estimated") + expect_identical(pf$reason, "variogram model did not converge") + expect_true(is.na(pf$range)) + # Not an R warning (the range is unknown, not short) ... + expect_false("spatialkit_gp_resolution" %in% .fbr_classes(r$warnings)) + # ... but logged with the reason, and shown by print(). + expect_true(log_has(logged, "could not be estimated before fitting \\(variogram model did not converge\\)")) + txt <- paste(utils::capture.output(print(r$fit)), collapse = "\n") + expect_match(txt, "Range before fitting: not estimated (variogram model did not converge)", + fixed = TRUE) + # This field's range is 6 km: autocorrelated at short range and no longer + # at the floor's distance, so a range below the floor is not ruled out, and + # the log says so with both statistics. + expect_lt(pf$moran$p, 0.05) + expect_false(pf$moran_floor$I > 0.05 && pf$moran_floor$p < 0.05) + expect_true(log_has(logged, "It is autocorrelated at short range \\(Moran's I = ")) + expect_true(log_has(logged, "and not at the floor's distance")) + expect_true(log_has(logged, "so a range below that floor is not ruled out")) + + # A plane is autocorrelated at short range too, as any real structure is. + # It used to get the same "not ruled out"; its structure reaches past the + # floor, and the log now says that. + n <- 400 + set.seed(31) + xy <- cbind(runif(n, 0, 1e5), runif(n, 0, 1e5)) + pl <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], + z = 3 * xy[, 1] / 1e5 + 2 * xy[, 2] / 1e5 + + stats::rnorm(n, 0, 0.5)), + coords = c("x", "y"), crs = 32617) + logged2 <- capture_spatialkit_log(r2 <- .fbr_capture(pl, "z", character(0)), + level = logger::WARN) + pf2 <- r2$fit$info$gp_prefit + expect_identical(pf2$status, "not_estimated") + expect_lt(pf2$moran$p, 0.05) + expect_gt(pf2$moran_floor$I, 0.05) + expect_true(log_has(logged2, "It is still autocorrelated at the floor's distance")) + expect_true(log_has(logged2, "so its structure reaches at least as far as the basis resolves")) + expect_false(log_has(logged2, "not ruled out")) +}) + +test_that("a short variogram range on a response with no autocorrelation is not read as structure", { + skip_if_not_installed("brms") + # White noise. A variogram fitted to it returns a finite range below the + # floor in about one draw in three; here it is handed one. + d <- .fbr_pts(n = 400, seed = 12) + local_mocked_bindings(estimate_sac_range = .fbr_sac(7000), .package = "spatialkit") + r <- .fbr_capture(d, "z", character(0)) + expect_identical(r$fit$info$gp_prefit$status, "below_floor_no_autocorrelation") + expect_gt(r$fit$info$gp_prefit$moran$p, 0.05) + expect_false("spatialkit_gp_resolution" %in% .fbr_classes(r$warnings)) + # A range above the floor is simply fine. + local_mocked_bindings(estimate_sac_range = .fbr_sac(6e4), .package = "spatialkit") + r2 <- .fbr_capture(d, "z", character(0)) + expect_identical(r2$fit$info$gp_prefit$status, "ok") + expect_length(r2$warnings, 0L) +}) + +test_that("gp_resolution derives a finer basis and moves the prior with it", { + skip_if_not_installed("brms") + d <- .fbr_pts() + local_mocked_bindings(estimate_sac_range = .fbr_sac(9e4), .package = "spatialkit") + def <- .fbr_capture(d, "z", character(0))$fit$info + fin <- .fbr_capture(d, "z", character(0), gp_resolution = 20000)$fit$info + + expect_identical(fin$gp_resolution_requested, 20000) + expect_gt(fin$gp_k, def$gp_k) + # The basis resolves what was asked for, on both axes. + expect_true(all(fin$gp_resolution <= 20000)) + # And not much more: one basis function fewer would not. + cs <- fin$coord_scaling + one_fewer <- sqrt(2 * log(20)) * (1.75 * fin$gp_c * fin$gp_S / (fin$gp_k - 1)) * + max(cs$x_scale, cs$y_scale) + expect_gt(one_fewer, 20000) + # The prior's lower 1% tail sits at the length-scale that basis resolves. + expect_equal(fin$gp_lengthscale_bounds[["lower"]], fin$gp_ell_min) + expect_lt(fin$gp_lengthscale_bounds[["lower"]], def$gp_lengthscale_bounds[["lower"]]) + expect_false(identical(fin$gp_lscale_prior, def$gp_lscale_prior)) + ig <- spatialkit:::.lscale_invgamma(fin$gp_ell_min, fin$gp_lengthscale_bounds[["upper"]]) + expect_identical(fin$gp_lscale_prior, + sprintf("inv_gamma(%.10g, %.10g)", ig$shape, ig$scale)) + expect_lt(fin$gp_adequacy$prior_mass_below, 0.02) + + # A request the default basis already meets changes nothing. + same <- .fbr_capture(d, "z", character(0), gp_resolution = 60000)$fit$info + expect_identical(same$gp_k, def$gp_k) + expect_identical(same$gp_lscale_prior, def$gp_lscale_prior) +}) + +test_that("gp_resolution past the cap, or beside gp_k, is an error that says what is possible", { + skip_if_not_installed("brms") + d <- .fbr_pts() + calls <- 0L + local_mocked_bindings( + brm = function(...) { calls <<- calls + 1L; structure(list(), class = "fbr_stub") }, + .package = "brms") + # 5 km on a 100 km square needs about 150 functions per dimension. + err <- tryCatch( + suppressMessages(fit_bayesian_spatial_model(d, "z", character(0), + gp_resolution = 5000)), + error = conditionMessage) + expect_match(err, "`gp_resolution` = 5,000 metre needs gp_k = ", fixed = TRUE) + expect_match(err, "above the cap of 50 (2500)", fixed = TRUE) + expect_match(err, "At the cap this layout resolves effective ranges from", fixed = TRUE) + expect_match(err, "kriging", fixed = TRUE) + expect_error(suppressMessages(fit_bayesian_spatial_model( + d, "z", character(0), gp_resolution = 20000, gp_k = 30)), + "pass `gp_resolution` or `gp_k`, not both") + for (bad in list(-1, 0, c(1, 2), NA_real_, "20 km")) + expect_error(suppressMessages(fit_bayesian_spatial_model( + d, "z", character(0), gp_resolution = bad)), + "`gp_resolution` must be a single positive number") + # Nothing was compiled for any of them. + expect_identical(calls, 0L) +}) + +test_that("an explicit gp_k finer than the derived one moves the prior's lower tail; the default does not", { + skip_if_not_installed("brms") + d <- .fbr_pts() + local_mocked_bindings(estimate_sac_range = .fbr_sac(9e4), .package = "spatialkit") + def <- .fbr_capture(d, "z", character(0))$fit$info + k50 <- .fbr_capture(d, "z", character(0), gp_k = 50)$fit$info + # The percentile bounds, as the default prior has always been calibrated. + xy <- sf::st_coordinates(d) + zz <- cbind((xy[, 1] - mean(xy[, 1])) / stats::sd(xy[, 1]), + (xy[, 2] - mean(xy[, 2])) / stats::sd(xy[, 2])) + b <- gp_lengthscale_bounds(zz) + ig <- spatialkit:::.lscale_invgamma(b[["lower"]], b[["upper"]]) + expect_identical(def$gp_lscale_prior, + sprintf("inv_gamma(%.10g, %.10g)", ig$shape, ig$scale)) + expect_equal(def$gp_lengthscale_bounds, b) + # At gp_k = 50 the prior kept those bounds, so the finer basis was held to + # the coarser one's length-scales. Now its lower tail is what k = 50 + # resolves. + expect_equal(k50$gp_lengthscale_bounds[["lower"]], k50$gp_ell_min) + expect_lt(k50$gp_ell_min, b[["lower"]]) + expect_equal(k50$gp_lengthscale_bounds[["upper"]], b[["upper"]]) + expect_false(identical(k50$gp_lscale_prior, def$gp_lscale_prior)) +}) + +test_that("the prior mass below the floor is known before sampling", { + skip_if_not_installed("brms") + set.seed(11) + n <- 150 + d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1e5), y = runif(n, 0, 1e5), + z = stats::rnorm(n)), + coords = c("x", "y"), crs = 32617) + local_mocked_bindings(estimate_sac_range = .fbr_sac(9e4), .package = "spatialkit") + def <- .fbr_capture(d, "z", character(0))$fit + logged <- capture_spatialkit_log(k6 <- .fbr_capture(d, "z", character(0), gp_k = 6)$fit, + level = logger::WARN) + # A derived basis sits at the prior's 1% point; gp_k = 6 leaves 98% of the + # prior below what it resolves, and the post-fit share only restated that. + expect_lt(def$info$gp_adequacy$prior_mass_below, 0.02) + expect_gt(k6$info$gp_adequacy$prior_mass_below, 0.9) + expect_equal(k6$info$gp_adequacy$prior_mass_below, 0.984, tolerance = 2e-3) + # A coarser basis does not move the prior up to meet it. + expect_identical(k6$info$gp_lscale_prior, def$info$gp_lscale_prior) + expect_true(log_has(logged, "98% of the length-scale prior .* lies below the smallest length-scale gp_k = 6 resolves")) + expect_true(log_has(logged, "the derived value is 23")) + txt <- paste(utils::capture.output(print(k6)), collapse = "\n") + expect_match(txt, "98% of the length-scale prior lies below what this basis resolves", + fixed = TRUE) + expect_false(grepl("of the length-scale prior lies below", + paste(utils::capture.output(print(def)), collapse = "\n"), + fixed = TRUE)) +}) + +test_that(".gp_k_needed() inverts the resolution rule", { + # A basis sized by .gp_k_needed() for a range resolves that range, and one + # function fewer does not. + Fse <- sqrt(2 * log(20)) + for (rng in c(8000, 20000, 45000)) { + k <- spatialkit:::.gp_k_needed(rng, gp_c = 1.6, S = 3.5, xy_scale = c(28000, 29000)) + floor_at <- function(kk) Fse * (1.75 * 1.6 * 3.5 / kk) * 29000 + expect_lte(floor_at(k), rng) + expect_gt(floor_at(k - 1), rng) + } +}) + + +# --------------------------------------------------------------------------- +# Real sampler (opt-in) +# --------------------------------------------------------------------------- + +test_that("a requested resolution compiles and samples with the prior it moved", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + d <- .fbr_pts(n = 150, seed = 8, range = 25000) + fit <- NULL + utils::capture.output(suppressWarnings(suppressMessages( + fit <- fit_bayesian_spatial_model( + d, "z", character(0), gp_resolution = 25000, chains = 1, iter = 300, + cores = 1, seed = 1, compute_loo = FALSE, check_convergence = FALSE, + backend = "rstan"))), type = "output") + expect_s3_class(fit, "bayesian_fit") + expect_true(all(fit$info$gp_resolution <= 25000)) + # The prior Stan was given is the moved one. + ps <- brms::prior_summary(fit$engine) + expect_true(all(ps$prior[ps$class == "lscale" & nzchar(ps$coef)] == + fit$info$gp_lscale_prior)) + expect_equal(fit$info$gp_lengthscale_bounds[["lower"]], fit$info$gp_ell_min) + expect_true(all(is.finite(suppressMessages(predict(fit, newdata = d[1:5, ]))))) +}) diff --git a/tests/testthat/test-fix-bayes-new-levels.R b/tests/testthat/test-fix-bayes-new-levels.R new file mode 100644 index 00000000..a6cfe694 --- /dev/null +++ b/tests/testthat/test-fix-bayes-new-levels.R @@ -0,0 +1,274 @@ +# predict.bayesian_fit() and the levels of a categorical predictor. +# +# brms refuses a whole `newdata` whenever the LEVEL SET of one of its factors +# is not a subset of the levels brms kept at fit time, and predict() returned +# that failure as NA for every row, with a log line and no R condition. Three +# things triggered it: +# 1. one row carrying an unseen value; +# 2. a factor that only lists an extra level no row carries; +# 3. a model fitted on a subset whose factor kept a level with no rows, where +# even the training rows were refused (fitted() and summary() stopped). +# +# No Stan here except the last test (opt-in). The engine is an empty brmsfit +# (brms::brm(empty = TRUE): no compilation, no draws), and posterior_epred() +# is replaced by a stand-in that runs brms's own newdata validation, so the +# level rule being tested is brms's and not a copy of it. + +.fbl_pts <- function(n = 90, seed = 3) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + cover = factor(sample(c("forest", "crop", "urban"), n, TRUE))), + coords = c("x", "y"), crs = 32632) + d$z <- c(forest = 0, crop = 1, urban = 3)[as.character(d$cover)] + + stats::rnorm(n, 0, 0.5) + d +} + +# A bayesian_fit over an empty brmsfit, built the way the fitter builds one. +.fbl_fit <- function(d, store_levels = TRUE) { + xy <- sf::st_coordinates(d) + cs <- list(x_center = mean(xy[, 1]), x_scale = stats::sd(xy[, 1]), + y_center = mean(xy[, 2]), y_scale = stats::sd(xy[, 2])) + df <- sf::st_drop_geometry(d) + df$`..x` <- (xy[, 1] - cs$x_center) / cs$x_scale + df$`..y` <- (xy[, 2] - cs$y_center) / cs$y_scale + eng <- suppressMessages(brms::brm( + z ~ cover + gp(..x, ..y, k = 5, c = 1.5, scale = FALSE), data = df, + empty = TRUE)) + info <- list(coord_scaling = cs) + # What the fitter stores: the levels that occur in the training rows. + if (store_levels) + info$predictor_levels <- list(cover = list( + levels = levels(droplevels(as.factor(df$cover))), ordered = FALSE)) + new_spatial_fit("bayesian_fit", engine = eng, formula = z ~ cover, + response_var = "z", predictor_vars = "cover", data_sf = d, + info = info) +} + +# posterior_epred() stand-in: brms's own validation of `newdata` against the +# fit, then one number per row that depends only on the row's level (10, 20, +# 30 by level, in the fitted order), so a reference-level prediction for a row +# that should have been NA would show. +.fbl_mock_epred <- function(seen) { + function(object, newdata, ...) { + seen$na_levels <- c(seen$na_levels, anyNA(newdata$cover)) + seen$n <- c(seen$n, nrow(newdata)) + v <- brms::validate_newdata(newdata, object, check_response = FALSE) + matrix(rep(10 * as.integer(v$cover), each = 4L), nrow = 4L) + } +} + +.fbl_warnings <- function(expr) { + w <- list() + v <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + list(value = v, warnings = w) +} + + +test_that("the level helpers flag a value, not a listed level, and follow the training rows", { + d <- .fbl_pts() + df <- sf::st_drop_geometry(d) + lv <- spatialkit:::.bayes_predictor_levels(df, c("cover", "z")) + # Only categorical predictors, with the levels that occur. + expect_named(lv, "cover") + expect_identical(lv$cover$levels, c("crop", "forest", "urban")) + expect_false(lv$cover$ordered) + # A training level with no rows is not a fitted level: brms drops it. + lv2 <- spatialkit:::.bayes_predictor_levels(df[df$cover != "urban", ], "cover") + expect_identical(lv2$cover$levels, c("crop", "forest")) + # A character column gets its sorted distinct values, as brms makes them. + dfc <- df; dfc$cover <- as.character(dfc$cover) + expect_identical(spatialkit:::.bayes_predictor_levels(dfc, "cover")$cover$levels, + c("crop", "forest", "urban")) + + stub <- list(info = list(predictor_levels = lv), predictor_vars = "cover") + nd <- df[1:6, ] + # An unseen VALUE is flagged, by row. + ndA <- nd; ndA$cover <- as.character(ndA$cover); ndA$cover[6] <- "water" + a <- spatialkit:::.bayes_unseen_levels(stub, ndA) + expect_identical(a$unseen, c(rep(FALSE, 5), TRUE)) + expect_match(a$named, "'cover': 'water'", fixed = TRUE) + # An extra level no row carries is not. + ndC <- nd; ndC$cover <- factor(as.character(ndC$cover), + levels = c("crop", "forest", "urban", "water")) + expect_false(any(spatialkit:::.bayes_unseen_levels(stub, ndC)$unseen)) + # A missing value is not an unseen level; the row cleaning handles it. + ndN <- nd; ndN$cover[2] <- NA + expect_false(any(spatialkit:::.bayes_unseen_levels(stub, ndN)$unseen)) + # A level the training factor lists but has no rows for is unseen. + stub2 <- list(info = list(predictor_levels = lv2), predictor_vars = "cover") + u <- spatialkit:::.bayes_unseen_levels(stub2, nd) + expect_identical(u$unseen, as.character(nd$cover) == "urban") +}) + +test_that("one row with an unseen level is NA; the others are predicted, with one classed warning", { + skip_if_not_installed("brms") + d <- .fbl_pts() + fit <- .fbl_fit(d) + seen <- new.env() + local_mocked_bindings(posterior_epred = .fbl_mock_epred(seen), .package = "brms") + + ref <- suppressMessages(predict(fit, newdata = d[1:6, ])) + expect_equal(ref, 10 * as.integer(d$cover[1:6])) + + ndA <- d[1:6, ]; ndA$cover <- as.character(ndA$cover); ndA$cover[6] <- "water" + r <- .fbl_warnings(suppressMessages(predict(fit, newdata = ndA))) + # It was NA for all six, with no R warning. + expect_equal(r$value[1:5], ref[1:5]) + expect_true(is.na(r$value[6])) + expect_length(r$warnings, 1L) + expect_s3_class(r$warnings[[1]], "spatialkit_new_levels") + msg <- conditionMessage(r$warnings[[1]]) + expect_match(msg, "1 of 6 row(s)", fixed = TRUE) + expect_match(msg, "'cover': 'water'", fixed = TRUE) + expect_match(msg, "the other 5 row(s) are predicted", fixed = TRUE) + # The unseen row never reached brms, as a level or as an NA (brms predicts + # the reference level for an NA factor value). + expect_false(any(seen$na_levels)) + + # The same with a factor column, and with draws = TRUE: an NA column. + ndF <- d[1:6, ] + ndF$cover <- factor(c(as.character(d$cover[1:5]), "water")) + dr <- suppressWarnings(suppressMessages(predict(fit, newdata = ndF, draws = TRUE))) + expect_identical(dim(dr), c(4L, 6L)) + expect_identical(which(colSums(is.na(dr)) > 0), 6L) + expect_false(anyNA(dr[, 1:5])) + + # Every row unseen: all NA, and still the classed warning. + ndW <- d[1:3, ]; ndW$cover <- "water" + rw <- .fbl_warnings(suppressMessages(predict(fit, newdata = ndW))) + expect_true(all(is.na(rw$value))) + expect_s3_class(rw$warnings[[1]], "spatialkit_new_levels") +}) + +test_that("a factor that only lists an extra level predicts as before", { + skip_if_not_installed("brms") + d <- .fbl_pts() + fit <- .fbl_fit(d) + seen <- new.env() + local_mocked_bindings(posterior_epred = .fbl_mock_epred(seen), .package = "brms") + ref <- suppressMessages(predict(fit, newdata = d[1:6, ])) + ndC <- d[1:6, ] + ndC$cover <- factor(as.character(ndC$cover), + levels = c("crop", "forest", "urban", "water")) + # brms refused this newdata although no row carries "water": six NAs. + expect_no_warning(got <- suppressMessages(predict(fit, newdata = ndC))) + expect_equal(got, ref) +}) + +test_that("a model fitted on a subset with an unused level predicts its own rows", { + skip_if_not_installed("brms") + d <- .fbl_pts() + d2 <- d[d$cover != "urban", ] # levels() still lists "urban" + expect_true("urban" %in% levels(d2$cover)) + seen <- new.env() + local_mocked_bindings(posterior_epred = .fbl_mock_epred(seen), .package = "brms") + # With and without the levels stored at fit time (a fit saved by an earlier + # version has none and derives them from its training rows). + for (stored in c(TRUE, FALSE)) { + fit2 <- .fbl_fit(d2, store_levels = stored) + # fitted() stopped with brms's "New factor levels are not allowed". + fv <- fitted(fit2) + expect_length(fv, nrow(d2)) + expect_true(all(is.finite(fv))) + # predict() on the training rows returned NA for every one of them. + expect_no_warning(p <- suppressMessages(predict(fit2, newdata = d2[1:5, ]))) + expect_true(all(is.finite(p))) + expect_no_warning(pm <- suppressMessages(predict(fit2, summary = "median"))) + expect_true(all(is.finite(pm))) + # Rows of the parent layer that carry the level it was not fitted with. + r <- .fbl_warnings(suppressMessages(predict(fit2, newdata = d[1:6, ]))) + urban <- as.character(d$cover[1:6]) == "urban" + expect_identical(is.na(r$value), urban) + expect_length(r$warnings, 1L) + expect_match(conditionMessage(r$warnings[[1]]), + sprintf("%d of 6 row(s)", sum(urban)), fixed = TRUE) + } +}) + +test_that("predict_surface() does not depend on chunk_size when one cell has a new level", { + skip_if_not_installed("brms") + d <- .fbl_pts() + fit <- .fbl_fit(d) + seen <- new.env() + local_mocked_bindings(posterior_epred = .fbl_mock_epred(seen), .package = "brms") + g <- d[1:12, "cover"]; g$cover <- as.character(g$cover); g$cover[11] <- "water" + s4 <- suppressWarnings(suppressMessages(predict_surface(fit, grid = g, chunk_size = 4))) + sA <- suppressWarnings(suppressMessages(predict_surface(fit, grid = g, chunk_size = 5000))) + # Rows 9-12 were NA at chunk_size = 4 and all twelve at 5000. + expect_identical(which(is.na(s4$.pred)), 11L) + expect_equal(s4$.pred, sA$.pred) +}) + +test_that("any other failed draw is a classed warning, not only a log line", { + skip_if_not_installed("brms") + d <- .fbl_pts() + fit <- .fbl_fit(d) + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) stop("injected draw failure 9041"), + .package = "brms") + r <- .fbl_warnings(suppressMessages(predict(fit, newdata = d[1:4, ]))) + expect_true(all(is.na(r$value))) + expect_length(r$value, 4L) + expect_length(r$warnings, 1L) + expect_s3_class(r$warnings[[1]], "spatialkit_predict_failed") + expect_match(conditionMessage(r$warnings[[1]]), "injected draw failure 9041") + expect_match(conditionMessage(r$warnings[[1]]), "all 4 prediction(s) are NA", + fixed = TRUE) +}) + + +# --------------------------------------------------------------------------- +# Real sampler (opt-in) +# --------------------------------------------------------------------------- + +test_that("a real fit predicts the known-level rows and returns NA for the new level", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + d <- .fbl_pts() + fit_one <- function(dat) { + fit <- NULL + utils::capture.output(suppressWarnings(suppressMessages( + fit <- fit_bayesian_spatial_model( + dat, "z", "cover", gp_k = 5, chains = 1, iter = 400, cores = 1, + seed = 1, compute_loo = FALSE, check_convergence = FALSE, + backend = "rstan"))), type = "output") + fit + } + fit <- fit_one(d) + ref <- suppressMessages(predict(fit, newdata = d[1:6, ])) + expect_true(all(is.finite(ref))) + + # (a) five finite values, one NA, one warning + ndA <- d[1:6, ]; ndA$cover <- as.character(ndA$cover); ndA$cover[6] <- "water" + r <- .fbl_warnings(suppressMessages(predict(fit, newdata = ndA))) + expect_equal(r$value[1:5], ref[1:5]) + expect_true(is.na(r$value[6])) + expect_length(r$warnings, 1L) + expect_s3_class(r$warnings[[1]], "spatialkit_new_levels") + + # (b) an unused extra level predicts identically to the original factor + ndC <- d[1:6, ] + ndC$cover <- factor(as.character(ndC$cover), + levels = c("crop", "forest", "urban", "water")) + expect_equal(suppressMessages(predict(fit, newdata = ndC)), ref) + + # (d) predict_surface() gives the same surface at any chunk_size + g <- d[1:12, "cover"]; g$cover <- as.character(g$cover); g$cover[11] <- "water" + s4 <- suppressWarnings(suppressMessages(predict_surface(fit, grid = g, chunk_size = 4))) + sA <- suppressWarnings(suppressMessages(predict_surface(fit, grid = g, chunk_size = 5000))) + expect_identical(which(is.na(s4$.pred)), 11L) + expect_equal(s4$.pred, sA$.pred) + + # (c) a fit on a subset with an unused level: finite fitted() and predict() + d2 <- d[d$cover != "urban", ] + fit2 <- fit_one(d2) + expect_true(all(is.finite(fitted(fit2)))) + expect_true(all(is.finite(suppressMessages(predict(fit2, newdata = d2[1:5, ]))))) +}) diff --git a/tests/testthat/test-fix-bayes-prep.R b/tests/testthat/test-fix-bayes-prep.R new file mode 100644 index 00000000..d7464943 --- /dev/null +++ b/tests/testthat/test-fix-bayes-prep.R @@ -0,0 +1,173 @@ +# prep_model_data() says what it removes and marks what it lets through. +# +# It dropped incomplete rows with a log line only: 432 of 1,050 rows (41%) +# went with no R warning while the mean response moved from 0.03 to -0.62. A +# predictor with one value in every row and repeated locations passed through +# unmarked. + +.fbp_pts <- function(n = 1000, seed = 2) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + resp = stats::rnorm(n), p1 = stats::rnorm(n), const = 3, + grp = sample(letters[1:3], n, TRUE)), + coords = c("x", "y"), crs = 32632) + d +} + +.fbp_warnings <- function(expr) { + w <- list() + v <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + list(value = v, warnings = w, + classes = vapply(w, function(c) class(c)[1L], character(1))) +} + + +test_that("dropped rows raise a classed warning with the counts", { + d <- .fbp_pts() + d$p1[d$resp > 0.25] <- NA # missing on the high responses + n_na <- sum(is.na(d$p1)) + r <- .fbp_warnings(prep_model_data(d, "resp", c("p1", "grp"))) + expect_identical(nrow(r$value), 1000L - n_na) + # There was no R warning at all. + expect_identical(r$classes, "spatialkit_rows_dropped") + msg <- conditionMessage(r$warnings[[1]]) + expect_match(msg, sprintf("dropped %d of 1000 row(s) (%.1f%%)", n_na, n_na / 10), + fixed = TRUE) + expect_match(msg, sprintf("%d with a missing value, 0 with a non-finite value, 0 with an empty or non-finite geometry", + n_na), fixed = TRUE) + expect_match(msg, sprintf("Rows affected by column: p1 %d.", n_na), fixed = TRUE) + expect_match(msg, sprintf("The fit uses the %d row(s) that remain", 1000L - n_na), + fixed = TRUE) + # The missingness follows the response, and the message says by how much. + expect_match(msg, "not missing at random", fixed = TRUE) + + dr <- attr(r$value, "dropped") + expect_identical(dr$n, n_na) + expect_identical(dr$by_column, c(resp = 0L, p1 = n_na, grp = 0L)) + y <- d$resp + expect_equal(dr$response_std_diff, + (mean(y[is.na(d$p1)]) - mean(y[!is.na(d$p1)])) / stats::sd(y)) + expect_gt(dr$response_std_diff, 1) + # It can be caught, and muffled, by class. + expect_identical( + tryCatch(prep_model_data(d, "resp", "p1"), + spatialkit_rows_dropped = function(c) "caught"), "caught") + expect_no_warning(withCallingHandlers( + prep_model_data(d, "resp", "p1"), + spatialkit_rows_dropped = function(c) invokeRestart("muffleWarning"))) +}) + +test_that("the drop warning counts each reason and each column", { + d <- sf::st_as_sf(data.frame(x = 1:10, y = 10:1, + resp = c(1, 2, NA, 4, 5, 6, 7, NaN, 9, 10), + pred = c(1, 2, 3, 4, Inf, 6, 7, 8, 9.5, 11)), + coords = c("x", "y"), crs = 32632) + sf::st_geometry(d)[6] <- sf::st_sfc(sf::st_point(), crs = 32632) + r <- .fbp_warnings(prep_model_data(d, "resp", "pred")) + expect_identical(r$classes, "spatialkit_rows_dropped") + msg <- conditionMessage(r$warnings[[1]]) + expect_match(msg, "dropped 4 of 10 row(s) (40.0%): 2 with a missing value, 1 with a non-finite value, 1 with an empty or non-finite geometry", + fixed = TRUE) + expect_match(msg, "Rows affected by column: resp 2, pred 1, (geometry) 1.", fixed = TRUE) + dr <- attr(r$value, "dropped") + expect_identical(dr$by_column, c(resp = 2L, pred = 1L, `(geometry)` = 1L)) + # The counts the record always had are unchanged. + expect_identical(dr$n, 4L) + expect_identical(dr$n_geometry, 1L) + expect_identical(dr$which, c(3L, 5L, 6L, 8L)) + expect_identical(dr$reason, c("missing", "non_finite", "geometry", "missing")) + # Two dropped rows with a response, too few to read anything into. + expect_false(grepl("not missing at random", msg, fixed = TRUE)) +}) + +test_that("nothing dropped, nothing raised", { + d <- .fbp_pts(n = 60) + r <- .fbp_warnings(prep_model_data(d, "resp", c("p1", "grp"))) + expect_length(r$warnings, 0L) + dr <- attr(r$value, "dropped") + expect_identical(dr$n, 0L) + expect_true(is.na(dr$response_std_diff)) + expect_identical(dr$constant_predictors, character(0)) + expect_identical(dr$n_duplicate_locations, 0L) + expect_true(all(dr$by_column == 0L)) +}) + +test_that("a constant predictor is warned about by name and recorded", { + d <- .fbp_pts(n = 80) + d$one <- "a" + r <- .fbp_warnings(prep_model_data(d, "resp", c("p1", "const", "one", "grp"))) + expect_identical(r$classes, "spatialkit_constant_predictor") + msg <- conditionMessage(r$warnings[[1]]) + expect_match(msg, "const", fixed = TRUE) + expect_match(msg, "one", fixed = TRUE) + expect_match(msg, "take a single value in all 80 row(s) kept", fixed = TRUE) + expect_false(grepl("p1", msg, fixed = TRUE)) + expect_identical(attr(r$value, "dropped")$constant_predictors, c("const", "one")) + # The predictor is kept: the caller decides. + expect_true(all(c("const", "one") %in% names(r$value))) + + # Constant only among the rows that survive cleaning. + d2 <- .fbp_pts(n = 80) + d2$v <- 1; d2$v[1:5] <- 2; d2$p1[1:5] <- NA + r2 <- .fbp_warnings(prep_model_data(d2, "resp", c("p1", "v"))) + expect_setequal(r2$classes, c("spatialkit_rows_dropped", + "spatialkit_constant_predictor")) + expect_identical(attr(r2$value, "dropped")$constant_predictors, "v") +}) + +test_that("repeated locations are counted in the record, and not warned about", { + d <- .fbp_pts(n = 100) + d <- rbind(d, d[1:27, ]) + logged <- capture_spatialkit_log( + r <- .fbp_warnings(prep_model_data(d, "resp", "p1"))) + expect_length(r$warnings, 0L) + expect_identical(attr(r$value, "dropped")$n_duplicate_locations, 27L) + expect_true(log_has(logged, "27 of 127 row\\(s\\) kept share their coordinates")) + # Counted after cleaning: a repeat that is dropped is not a repeat. + d$p1[101:110] <- NA + r2 <- suppressWarnings(prep_model_data(d, "resp", "p1")) + expect_identical(attr(r2, "dropped")$n_duplicate_locations, 17L) +}) + +test_that("prediction mode logs and records, and raises neither warning", { + d <- .fbp_pts(n = 60) + d$p1[c(4, 9)] <- NA + d$const2 <- 1 + logged <- capture_spatialkit_log( + r <- .fbp_warnings(prep_model_data(d, "resp", c("p1", "const2"), + require_response = FALSE)), + level = logger::WARN) + # predict() returns NA at exactly these rows, so nothing is lost silently, + # and one row of newdata is "constant" in every column. + expect_length(r$warnings, 0L) + expect_identical(nrow(r$value), 58L) + expect_identical(attr(r$value, "dropped")$n, 2L) + expect_true(log_has(logged, "dropping 2 row\\(s\\)")) +}) + +test_that("the marks ride in the record and do not outlive the rows", { + d <- .fbp_pts(n = 60) + d <- rbind(d, d[1:3, ]) + out <- suppressWarnings(prep_model_data(d, "resp", c("p1", "const"))) + expect_identical(attr(out, "dropped")$n_duplicate_locations, 3L) + expect_null(attr(out[1:10, ], "dropped")) + expect_null(attr(out, "n_duplicate_locations")) +}) + +test_that("a fit still reports the rows prep removed as n_dropped", { + skip_if_not_installed("brms") + d <- .fbp_pts(n = 150) + d$p1[1:7] <- NA + local_mocked_bindings(brm = function(...) structure(list(), class = "fbp_stub"), + .package = "brms") + r <- .fbp_warnings(suppressMessages(fit_bayesian_spatial_model( + d, "resp", "p1", gp_k = 6, compute_loo = FALSE, check_convergence = FALSE))) + expect_identical(r$value$info$n_dropped, 7L) + expect_identical(r$value$n, 143L) + # The fitter passes the warning on, once. + expect_identical(sum(r$classes == "spatialkit_rows_dropped"), 1L) +}) diff --git a/tests/testthat/test-fix-bayes-robustness.R b/tests/testthat/test-fix-bayes-robustness.R new file mode 100644 index 00000000..3ebc14c7 --- /dev/null +++ b/tests/testthat/test-fix-bayes-robustness.R @@ -0,0 +1,74 @@ +# Two early exits in fit_bayesian_spatial_model(). +# +# The response was checked for its type and for n >= 2 only, so a constant +# response, or a handful of rows against several hundred basis functions, +# reached the compiler. + +.fbx_pts <- function(n = 120, seed = 6) { + set.seed(seed) + sf::st_as_sf( + data.frame(x = runif(n, 0, 1e5), y = runif(n, 0, 1e5), + z = stats::rnorm(n), k = 7, a = stats::rnorm(n), + cnt = 4L, flag = TRUE), + coords = c("x", "y"), crs = 32617) +} + +test_that("a constant response is refused before anything is compiled", { + skip_if_not_installed("brms") + d <- .fbx_pts() + calls <- 0L + local_mocked_bindings( + brm = function(...) { calls <<- calls + 1L; structure(list(), class = "fbx_stub") }, + .package = "brms") + expect_error( + suppressMessages(fit_bayesian_spatial_model(d, "k", "a", compute_loo = FALSE, + check_convergence = FALSE)), + "response 'k' takes a single value \\(7\\) in all 120 row\\(s\\)") + # Whatever the family: a count or a logical with one value has no more to + # explain than a Gaussian one. + expect_error( + suppressMessages(fit_bayesian_spatial_model(d, "cnt", "a", + family = stats::poisson(), + compute_loo = FALSE, + check_convergence = FALSE)), + "response 'cnt' takes a single value \\(4\\)") + expect_error( + suppressMessages(fit_bayesian_spatial_model(d, "flag", "a", + family = brms::bernoulli(), + compute_loo = FALSE, + check_convergence = FALSE)), + "response 'flag' takes a single value \\(TRUE\\)") + # It reached brms::brm() every time. + expect_identical(calls, 0L) +}) + +test_that("fewer rows than a tenth of the basis functions is a classed warning", { + skip_if_not_installed("brms") + d <- .fbx_pts() + local_mocked_bindings(brm = function(...) structure(list(), class = "fbx_stub"), + .package = "brms") + local_mocked_bindings(estimate_sac_range = function(...) 9e4, + .package = "spatialkit") + run <- function(dat, ...) { + w <- list() + fit <- withCallingHandlers( + suppressMessages(fit_bayesian_spatial_model(dat, "z", "a", compute_loo = FALSE, + check_convergence = FALSE, ...)), + warning = function(c) { w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") }) + list(fit = fit, w = Filter(function(c) inherits(c, "spatialkit_gp_basis_size"), w)) + } + # 30 rows against the derived basis (several hundred functions). + small <- run(d[1:30, ]) + nb <- small$fit$info$gp_n_basis + expect_gt(nb, 300) + expect_length(small$w, 1L) + expect_match(conditionMessage(small$w[[1]]), + sprintf("30 row(s) against %d basis functions (gp_k = %d per dimension)", + nb, small$fit$info$gp_k), fixed = TRUE) + # 120 rows against 36 functions, and against the derived basis: no warning + # at more than a tenth. + expect_length(run(d, gp_k = 6)$w, 0L) + full <- run(d) + expect_lt(full$fit$info$gp_n_basis / 10, 120) + expect_length(full$w, 0L) +}) diff --git a/tests/testthat/test-fix-bayes-slope-prior.R b/tests/testthat/test-fix-bayes-slope-prior.R new file mode 100644 index 00000000..692fb87b --- /dev/null +++ b/tests/testthat/test-fix-bayes-slope-prior.R @@ -0,0 +1,187 @@ +# The automatic slope prior of fit_bayesian_spatial_model(standardize_predictors +# = TRUE) follows the scale of the response. +# +# It was a fixed normal(0, 5) on every slope. Under an identity link a slope +# per SD of a predictor is in the units of the response, so the same data gave +# a slope of 0.3 with income in dollars and 10.1 (thousand) with income in +# thousands, with convergence_ok TRUE both times. +# +# Nothing here compiles a Stan model except the last test, which is opt-in via +# SPATIALKIT_TEST_BRMS like the other sampler tests: brms::brm() is replaced by +# a recorder and brms::validate_prior() / make_stancode() run for real. + +.fbs_pts <- function(n = 150, seed = 11) { + set.seed(seed) + x <- runif(n, 0, 1e5); y <- runif(n, 0, 1e5) + edu <- rnorm(n, 30, 10) + inc <- 60000 + 1500 * (edu - 30) + 4000 * sin(x / 3e4) + rnorm(n, 0, 8000) + sf::st_as_sf( + data.frame(x, y, edu, inc, inc_k = inc / 1000, + cnt = stats::rpois(n, 5), bin = as.integer(edu > 30), + pos = exp(inc / 3e4)), + coords = c("x", "y"), crs = 32617) +} + +.fbs_capture <- function(...) { + cap <- new.env() + local_mocked_bindings( + brm = function(...) { cap$args <- list(...); structure(list(), class = "fbs_stub") }, + .package = "brms") + fit <- suppressWarnings(suppressMessages( + fit_bayesian_spatial_model(..., compute_loo = FALSE, + check_convergence = FALSE))) + list(fit = fit, args = cap$args) +} + +.fbs_b_prior <- function(args) { + pr <- as.data.frame(args$prior) + pr$prior[pr$class == "b"] +} + +.fbs_scale <- function(spec) { + as.numeric(sub("^normal\\(0, (.*)\\)$", "\\1", spec)) +} + + +test_that("the automatic slope prior scales with the response under an identity link", { + skip_if_not_installed("brms") + d <- .fbs_pts() + r_usd <- .fbs_capture(d, "inc", "edu", standardize_predictors = TRUE, gp_k = 6) + r_k <- .fbs_capture(d, "inc_k", "edu", standardize_predictors = TRUE, gp_k = 6) + + b_usd <- .fbs_b_prior(r_usd$args) + b_k <- .fbs_b_prior(r_k$args) + # 2.5 SDs of the response, in the response's own units ... + expect_equal(.fbs_scale(b_usd), 2.5 * stats::sd(d$inc), tolerance = 1e-8) + expect_equal(.fbs_scale(b_k), 2.5 * stats::sd(d$inc_k), tolerance = 1e-8) + # ... so rescaling the response rescales the prior with it. Both were + # "normal(0, 5)". + expect_equal(.fbs_scale(b_usd) / .fbs_scale(b_k), 1000, tolerance = 1e-8) + + # What reaches Stan carries that scale, not a fixed 5. + code <- brms::make_stancode(r_usd$args$formula, data = r_usd$args$data, + family = r_usd$args$family, + prior = r_usd$args$prior) + expect_true(grepl(sprintf("normal_lpdf(b | 0, %s)", + sub("^normal\\(0, (.*)\\)$", "\\1", b_usd)), + code, fixed = TRUE)) + expect_false(grepl("normal_lpdf(b | 0, 5)", code, fixed = TRUE)) + + # The fit records the prior brms used, and print() shows it. + expect_identical(r_usd$fit$info$b_prior, b_usd) + expect_match(r_usd$fit$info$b_prior_source, "automatic") + txt <- paste(utils::capture.output(print(r_usd$fit)), collapse = "\n") + expect_match(txt, paste0("Slope prior: ", b_usd), fixed = TRUE) +}) + +test_that("the slope prior stays on a fixed unit scale for log and logit links", { + skip_if_not_installed("brms") + d <- .fbs_pts() + expect_identical(.fbs_b_prior(.fbs_capture( + d, "cnt", "edu", family = stats::poisson(), standardize_predictors = TRUE, + gp_k = 6)$args), "normal(0, 5)") + expect_identical(.fbs_b_prior(.fbs_capture( + d, "bin", "edu", family = brms::bernoulli(), standardize_predictors = TRUE, + gp_k = 6)$args), "normal(0, 5)") + # An identity-link family fitted through a log link is on the link's scale. + expect_identical(.fbs_b_prior(.fbs_capture( + d, "pos", "edu", family = stats::gaussian(link = "log"), + standardize_predictors = TRUE, gp_k = 6)$args), "normal(0, 5)") +}) + +test_that(".b_prior_auto() picks the scale the linear predictor is on", { + skip_if_not_installed("brms") + set.seed(4) + y <- stats::rnorm(80, 6e4, 1.5e4) + yp <- exp(stats::rnorm(80, 1, 0.6)) + auto <- spatialkit:::.b_prior_auto + + g <- auto(y, stats::gaussian()) + expect_identical(g$basis, "sd") + expect_equal(.fbs_scale(g$spec), 2.5 * stats::sd(y), tolerance = 1e-8) + expect_identical(auto(y, brms::student())$spec, g$spec) + expect_identical(auto(y, brms::skew_normal())$spec, g$spec) + # A family given as a bare string or as a function resolves the same way. + expect_identical(auto(y, "gaussian")$spec, g$spec) + expect_identical(auto(y, stats::gaussian)$spec, g$spec) + # A mixture of identity-link components is on the response's scale too. + mix <- suppressMessages(brms::mixture(stats::gaussian(), stats::gaussian())) + expect_identical(auto(y, mix)$spec, g$spec) + + # lognormal reports an identity link, and its location is on the log scale: + # sd(y) would be the wrong scale by a factor of sd(y) / sd(log y). + ln <- auto(yp, brms::lognormal()) + expect_identical(ln$basis, "sd_log") + expect_equal(.fbs_scale(ln$spec), 2.5 * stats::sd(log(yp)), tolerance = 1e-8) + expect_false(isTRUE(all.equal(.fbs_scale(ln$spec), 2.5 * stats::sd(yp)))) + + # Non-identity links keep the fixed prior. + for (fam in list(stats::poisson(), brms::bernoulli(), brms::negbinomial(), + stats::Gamma(link = "log"), brms::categorical(), + brms::cumulative(), stats::gaussian(link = "log"))) + expect_identical(auto(y, fam)$spec, "normal(0, 5)") + + # A constant response has no spread; normal(0, 0) is not a prior Stan takes. + k <- auto(rep(3, 20), stats::gaussian()) + expect_gt(.fbs_scale(k$spec), 0) + # A small scale is not rounded to a literal zero. + expect_gt(.fbs_scale(auto(y * 1e-9, stats::gaussian())$spec), 0) +}) + +test_that("a user prior, or no standardisation, sets no automatic slope prior", { + skip_if_not_installed("brms") + d <- .fbs_pts() + # Not standardised: brms's flat default, recorded as such. + r0 <- .fbs_capture(d, "inc", "edu", gp_k = 6) + expect_length(.fbs_b_prior(r0$args), 0L) + expect_identical(r0$fit$info$b_prior, "(flat)") + expect_identical(r0$fit$info$b_prior_source, "brms default") + # A user's own prior is kept as given and recorded as theirs. + up <- brms::set_prior("normal(0, 123)", class = "b") + ru <- .fbs_capture(d, "inc", "edu", standardize_predictors = TRUE, gp_k = 6, + prior = up) + expect_identical(.fbs_b_prior(ru$args), "normal(0, 123)") + expect_identical(ru$fit$info$b_prior, "normal(0, 123)") + expect_identical(ru$fit$info$b_prior_source, "from `prior`") + # No slopes, no slope prior. + ri <- .fbs_capture(d, "inc", character(0), gp_k = 6) + expect_true(is.na(ri$fit$info$b_prior)) +}) + + +# --------------------------------------------------------------------------- +# Real sampler (opt-in) +# --------------------------------------------------------------------------- + +test_that("the slope is recovered on a dollar-scale response and follows its units", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + d <- .fbs_pts() + ols <- stats::coef(stats::lm(inc ~ scale(edu), data = sf::st_drop_geometry(d)))[[2L]] + fit_one <- function(resp) { + fit <- NULL + utils::capture.output(suppressWarnings(suppressMessages( + fit <- fit_bayesian_spatial_model( + d, resp, "edu", standardize_predictors = TRUE, gp_k = 6, + chains = 2, iter = 600, cores = 1, seed = 1, compute_loo = FALSE, + backend = "rstan"))), type = "output") + fit + } + f_usd <- fit_one("inc") + f_k <- fit_one("inc_k") + b_usd <- coef(f_usd)["edu", ] + b_k <- coef(f_k)["edu", ] + # The fixed prior gave 0.21 (95% interval -9.6 to 10.7) against an OLS slope + # of about 14,000 per SD. + expect_lt(b_usd[["Q2.5"]], ols) + expect_gt(b_usd[["Q97.5"]], ols) + expect_gt(b_usd[["Estimate"]], 0.8 * ols) + # Dividing the response by 1000 divides the estimate by 1000, to Monte Carlo + # error (it was 0.21 against 13.7). + # Tolerance: half a posterior SD, five Monte Carlo standard errors at an + # effective sample size of 100. + expect_equal(b_usd[["Estimate"]] / 1000, b_k[["Estimate"]], + tolerance = 0.5 * b_k[["Est.Error"]] / abs(b_k[["Estimate"]])) +}) diff --git a/tests/testthat/test-fix-cells-assign-ids.R b/tests/testthat/test-fix-cells-assign-ids.R new file mode 100644 index 00000000..14ed4e22 --- /dev/null +++ b/tests/testthat/test-fix-cells-assign-ids.R @@ -0,0 +1,233 @@ +# tests/testthat/test-fix-cells-assign-ids.R +# --------------------------------------------------------------------------- +# assign_features_to_polygons(): where the polygon IDs come from, and what +# happens to features no polygon holds. +# +# The polygons' ID was read from a fallback column without a word (nine +# polygons with a zone attribute called `id` came back as three), polygons +# with no ID column at all were numbered in silence (their `GEOID`s unused), +# a duplicated ID merged two polygons' features, and features outside the +# layer were removed with one INFO line in the temp log. +# --------------------------------------------------------------------------- + +.fa_sq <- function(x0, y0, s) sf::st_polygon(list(rbind( + c(x0, y0), c(x0 + s, y0), c(x0 + s, y0 + s), c(x0, y0 + s), c(x0, y0)))) + +# A 3 x 3 grid of 100 m cells with no ID column, and 300 points inside it. +.fa_grid <- function() sf::st_sf(geometry = sf::st_sfc(lapply(0:8, function(i) + .fa_sq(5e5 + 100 * (i %% 3), 5e6 + 100 * (i %/% 3), 100)), crs = 32632)) +.fa_pts <- function(n = 300, seed = 9) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 300), y = 5e6 + runif(n, 0, 300)), + coords = c("x", "y"), crs = 32632) +} + +# Value, warnings (with classes and conditions) and messages of a call. +.fa_run <- function(expr) { + w <- character(0); cls <- list(); conds <- list(); m <- character(0) + val <- withCallingHandlers( + expr, + warning = function(c) { + w <<- c(w, conditionMessage(c)); cls[[length(cls) + 1L]] <<- class(c) + conds[[length(conds) + 1L]] <<- c + invokeRestart("muffleWarning") + }, + message = function(c) { m <<- c(m, conditionMessage(c)); invokeRestart("muffleMessage") }) + list(value = val, warnings = w, classes = cls, conditions = conds, messages = m) +} + + +# --- which column the IDs came from ------------------------------------------ + +test_that("a fallback ID column is named in a message", { + pts <- .fa_pts() + g <- .fa_grid(); g$cell_id <- 9:1 + r <- .fa_run(assign_features_to_polygons(pts, g)) + expect_length(r$warnings, 0L) + expect_length(r$messages, 1L) + expect_match(r$messages, "no 'poly_id' column; the polygon IDs are read from its 'cell_id' column") + # The IDs are the cells' own, under the name asked for. + expect_setequal(r$value$poly_id, 9:1) + expect_identical(nrow(r$value), 300L) + + # Naming the column is not a fallback, and says nothing. + r2 <- .fa_run(assign_features_to_polygons(pts, g, polygon_id_col = "cell_id")) + expect_length(r2$messages, 0L) + expect_setequal(r2$value$cell_id, 9:1) + # Nor is the default column when the polygons carry it. + g$poly_id <- 1:9 + expect_length(.fa_run(assign_features_to_polygons(pts, g))$messages, 0L) + + # quiet = TRUE silences the message, not the fallback. + g$poly_id <- NULL + r3 <- .fa_run(assign_features_to_polygons(pts, g, quiet = TRUE)) + expect_length(r3$messages, 0L) + expect_setequal(r3$value$poly_id, 9:1) +}) + +test_that("polygons with no ID column are numbered, and the message says so", { + pts <- .fa_pts() + g <- .fa_grid(); g$GEOID <- sprintf("37%03d", 1:9) + r <- .fa_run(assign_features_to_polygons(pts, g)) + expect_length(r$messages, 1L) + expect_match(r$messages, "no 'poly_id' column, and none of the fallback ID columns") + expect_match(r$messages, "numbered 1 to 9 in row order") + expect_match(r$messages, "`polygon_id_col`") + expect_setequal(r$value$poly_id, 1:9) + # The way the message points to: the GEOIDs, used. + r2 <- .fa_run(assign_features_to_polygons(pts, g, polygon_id_col = "GEOID")) + expect_length(r2$messages, 0L) + expect_setequal(r2$value$GEOID, sprintf("37%03d", 1:9)) +}) + +test_that("duplicated or missing polygon IDs are refused", { + pts <- .fa_pts() + # A zone attribute that happens to be called `id`: six cells used to be + # merged into three "polygons", with no condition raised. + g1 <- .fa_grid(); g1$id <- rep(1:3, each = 3) + expect_error(suppressMessages(assign_features_to_polygons(pts, g1)), + "polygon ID column 'id' \\(read because `polygons_sf` has no 'poly_id' column\\) holds 6 duplicated and 0 missing value\\(s\\) among 9 polygon\\(s\\)") + # A `poly_id` repeated once gave 8 IDs for 9 polygons. + g2 <- .fa_grid(); g2$poly_id <- c(1:8, 8L) + expect_error(assign_features_to_polygons(pts, g2), + "polygon ID column 'poly_id' \\(the column named by `polygon_id_col`\\) holds 1 duplicated and 0 missing") + # A missing ID made the features inside that polygon look unassigned. + g3 <- .fa_grid(); g3$poly_id <- c(1:8, NA) + expect_error(assign_features_to_polygons(pts, g3), + "holds 0 duplicated and 1 missing value\\(s\\) among 9 polygon\\(s\\)") + # The repair the message names works. + g1$poly_id <- seq_len(nrow(g1)) + expect_identical(nrow(assign_features_to_polygons(pts, g1)), 300L) +}) + +test_that("one unit stored in several rows: the error says how to keep it one cell", { + pts <- .fa_pts() + # Unit "A" is two of the nine squares (a region split into POLYGON rows). + g <- .fa_grid(); g$poly_id <- c("A", "A", "B", "C", "D", "E", "F", "G", "H") + err <- tryCatch(assign_features_to_polygons(pts, g), error = function(e) conditionMessage(e)) + expect_match(err, "holds 1 duplicated and 0 missing value\\(s\\) among 9 polygon\\(s\\)") + # Numbering the rows, the first repair named, would split the unit in two; + # the message says so and gives the repair that does not. + expect_match(err, "parts of one unit") + expect_match(err, "dplyr::summarise(dplyr::group_by(polygons_sf, poly_id))", fixed = TRUE) + expect_match(err, "Numbering the rows would make each part a cell of its own", fixed = TRUE) + # That repair works: eight polygons, the unit whole, every point assigned. + merged <- dplyr::summarise(dplyr::group_by(g, poly_id)) + expect_identical(nrow(merged), 8L) + out <- assign_features_to_polygons(pts, merged) + expect_identical(nrow(out), 300L) + in_a <- lengths(sf::st_intersects(pts, sf::st_union(g[1:2, ]))) > 0L + expect_identical(out$poly_id == "A", in_a) + # The column is named as it has to be typed, and only duplicates get the hint. + names(g)[names(g) == "poly_id"] <- "unit id" + expect_error(assign_features_to_polygons(pts, g, polygon_id_col = "unit id"), + "dplyr::group_by(polygons_sf, `unit id`)", fixed = TRUE) + g3 <- .fa_grid(); g3$poly_id <- c(1:8, NA) + err_na <- tryCatch(assign_features_to_polygons(pts, g3), error = function(e) conditionMessage(e)) + expect_false(grepl("parts of one unit", err_na)) +}) + + +# --- features no polygon holds ----------------------------------------------- + +test_that("features outside the layer are dropped with a classed warning and a record", { + set.seed(9) + inside <- .fa_pts() + outside <- sf::st_as_sf(data.frame(x = 5e5 + runif(30, 300.5, 305), + y = 5e6 + runif(30, 0, 300)), + coords = c("x", "y"), crs = 32632) + p2 <- rbind(inside, outside) + g <- .fa_grid(); g$poly_id <- 1:9 + + r <- .fa_run(assign_features_to_polygons(p2, g)) + expect_identical(nrow(r$value), 300L) + expect_length(r$warnings, 1L) + expect_true("spatialkit_unassigned" %in% r$classes[[1L]]) + expect_match(r$warnings, "30 of 330 feature\\(s\\) \\(9\\.1%\\) fall inside no polygon and are left out") + expect_identical(r$conditions[[1L]]$n, 30L) + expect_identical(r$conditions[[1L]]$total, 330L) + rec <- attr(r$value, "unassigned") + expect_identical(rec$n, 30L) + expect_identical(rec$which, 301:330) + expect_identical(rec$n_rows, 300L) + # Caught by class, without matching the message. + expect_identical(tryCatch(assign_features_to_polygons(p2, g), + spatialkit_unassigned = function(w) "caught"), "caught") + + # Kept on request: no warning, the same record, NA IDs. + k <- .fa_run(assign_features_to_polygons(p2, g, keep_unassigned = TRUE)) + expect_length(k$warnings, 0L) + expect_identical(nrow(k$value), 330L) + expect_identical(which(is.na(k$value$poly_id)), 301:330) + expect_identical(attr(k$value, "unassigned")$n, 30L) + expect_identical(attr(k$value, "unassigned")$which, 301:330) + + # Nothing outside: a record of zero, and silence. + ok <- .fa_run(assign_features_to_polygons(inside, g)) + expect_length(ok$warnings, 0L) + expect_identical(attr(ok$value, "unassigned")$n, 0L) + expect_identical(attr(ok$value, "unassigned")$which, integer(0)) + # The ties record is still there beside it. + expect_identical(attr(ok$value, "ties")$n_rows, 300L) +}) + +test_that("a subset of the result is never read as carrying its parent's unassigned record", { + set.seed(9) + inside <- .fa_pts(); inside$v <- rnorm(300) + outside <- sf::st_as_sf(data.frame(x = 5e5 + runif(30, 300.5, 305), + y = 5e6 + runif(30, 0, 300), v = 0), + coords = c("x", "y"), crs = 32632) + g <- .fa_grid(); g$poly_id <- 1:9 + a <- suppressWarnings(assign_features_to_polygons(rbind(inside, outside), g)) + expect_identical(spatialkit:::.get_row_record(a, "unassigned")$n, 30L) + # The record is stamped with the rows it was made for, so the package's + # reader returns nothing for a subset, whether or not `[` removed it. + expect_null(spatialkit:::.get_row_record(a[1:10, ], "unassigned")) + expect_null(spatialkit:::.get_row_record(dplyr::filter(a, v > 0), "unassigned")) + # The same rows without their geometry are the same rows. + expect_identical(attr(sf::st_drop_geometry(a), "unassigned")$n, 30L) +}) + +test_that("the unassigned record is removed by a subset, as the ties record beside it is", { + # `[` removes the records named in .row_record_attrs (R/utils.R). Before + # "unassigned" was listed there a 10-row subset still held the parent's + # n = 30 and n_rows = 300. + expect_true("unassigned" %in% spatialkit:::.row_record_attrs) + set.seed(9) + inside <- .fa_pts(); inside$v <- rnorm(300) + outside <- sf::st_as_sf(data.frame(x = 5e5 + runif(30, 300.5, 305), + y = 5e6 + runif(30, 0, 300), v = 0), + coords = c("x", "y"), crs = 32632) + g <- .fa_grid(); g$poly_id <- 1:9 + a <- suppressWarnings(assign_features_to_polygons(rbind(inside, outside), g)) + expect_null(attr(a[1:10, ], "ties")) + expect_null(attr(a[1:10, ], "unassigned")) + expect_null(attr(dplyr::filter(a, v > 0), "unassigned")) + expect_null(attr(dplyr::slice(a, 1:5), "unassigned")) +}) + +test_that("no feature inside any polygon keeps its warning, now with the class", { + g <- .fa_grid(); g$poly_id <- 1:9 + far <- sf::st_as_sf(data.frame(x = 6e5 + 1:5, y = 5e6 + 1:5), coords = c("x", "y"), + crs = 32632) + for (keep in c(FALSE, TRUE)) { + r <- .fa_run(assign_features_to_polygons(far, g, keep_unassigned = keep)) + expect_length(r$warnings, 1L) + expect_match(r$warnings, "none of the 5 feature\\(s\\) fall inside any polygon") + expect_true("spatialkit_unassigned" %in% r$classes[[1L]]) + expect_identical(attr(r$value, "unassigned")$n, 5L) + expect_identical(nrow(r$value), if (keep) 5L else 0L) + } +}) + +test_that("polygon features that only touch the layer are counted as unassigned", { + g <- .fa_grid(); g$poly_id <- 1:9 + # One square inside cell 1, one sharing only an edge with the grid. + f <- sf::st_sf(v = 1:2, geometry = sf::st_sfc(.fa_sq(5e5 + 10, 5e6 + 10, 20), + .fa_sq(5e5 + 300, 5e6 + 10, 20), + crs = 32632)) + r <- .fa_run(assign_features_to_polygons(f, g)) + expect_identical(nrow(r$value), 1L) + expect_true("spatialkit_unassigned" %in% r$classes[[1L]]) + expect_identical(attr(r$value, "unassigned")$which, 2L) +}) diff --git a/tests/testthat/test-fix-cells-cover.R b/tests/testthat/test-fix-cells-cover.R new file mode 100644 index 00000000..00c683c8 --- /dev/null +++ b/tests/testthat/test-fix-cells-cover.R @@ -0,0 +1,555 @@ +# tests/testthat/test-fix-cells-cover.R +# --------------------------------------------------------------------------- +# Voronoi cells built on seeds, with no boundary. +# +# The cells used to be clipped to the convex hull of the seeds themselves +# (grown by 2% of its diagonal). Seeds lie inside the data they stand for, +# so the cells stopped short of it, and assign_features_to_polygons() then +# removed the uncovered observations with one INFO line in the temp log: +# 72% of 3,000 uniform points at 4 seeds, 25% at 25, 4% at 100, and 15% on +# the profile -> selection -> seeds route. The seeders now attach the ground +# the seeds stand for as attr(, "cover"), the Voronoi builders derive their +# default boundary from it (or from a `cover` argument), and points in no +# cell are a classed warning with a count on the result. +# --------------------------------------------------------------------------- + +.fc_obs <- function(n = 600, seed = 2, side = 1e5, crs = 32617) { + set.seed(seed) + p <- sf::st_as_sf(data.frame(x = runif(n, 0, side), y = runif(n, 0, side)), + coords = c("x", "y"), crs = crs) + p$z <- rnorm(n) + p +} + +.fc_square <- function(side = 1e5, crs = 32617, x0 = 0, y0 = 0) { + sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(x0, y0), c(x0 + side, y0), c(x0 + side, y0 + side), c(x0, y0 + side), + c(x0, y0)))), crs = crs)) +} + +# Every warning an expression raises, with its classes, and its value. +.fc_conditions <- function(expr) { + msgs <- character(0); cls <- list(); conds <- list() + val <- withCallingHandlers( + suppressMessages(expr), + warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + cls[[length(cls) + 1L]] <<- class(w) + conds[[length(conds) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = val, warnings = msgs, classes = cls, conditions = conds) +} +.fc_has_class <- function(res, class) + vapply(res$classes, function(k) class %in% k, logical(1)) +# The profile of the two tests below is scored at three levels and its Cp +# optimum is the first, so a count read off it, or off its selection, comes +# with the warning that a bound chose the count (class +# spatialkit_bound_chosen; test-fix-resolution-bound-warning.R). It says +# nothing about the cover, so it is counted here and set aside by class. +.fc_bound_chosen <- function(expr) { + n <- 0L + val <- withCallingHandlers(expr, spatialkit_bound_chosen = function(w) { + n <<- n + 1L + invokeRestart("muffleWarning") + }) + expect_identical(n, 1L) + val +} + +# The whole route on a layer of seeds: cells, assignment, summary. Returns +# what the assertions need; raises nothing itself. +.fc_route <- function(seeds, obs, ...) { + built <- .fc_conditions(build_tessellation(seeds, method = "voronoi", + quiet = TRUE, ...)) + tess <- built$value + asg <- .fc_conditions(assign_features_to_polygons( + obs, tess$cells, polygon_id_col = "cell_id")) + sm <- suppressWarnings(summarize_by_cell(asg$value, "z", id_col = "cell_id")) + # The k-means partition itself: each observation's nearest seed, measured + # in the CRS the cells were built in. + near <- sf::st_nearest_feature(sf::st_transform(obs, sf::st_crs(tess$cells)), + sf::st_transform(seeds, sf::st_crs(tess$cells))) + list(tess = tess, built = built, asg = asg, sum_n = sum(sm$n), + nearest_cell = tess$index[near]) +} + +.fc_expect_all_assigned <- function(r, obs, info) { + expect_length(r$built$warnings, 0L) + expect_length(r$asg$warnings, 0L) + expect_identical(r$tess$params$n_outside, 0L, info = info) + expect_identical(nrow(r$asg$value), nrow(obs), info = info) + expect_identical(attr(r$asg$value, "unassigned")$n, 0L, info = info) + expect_identical(r$sum_n, nrow(obs), info = info) + # A Voronoi cell is the ground nearest its seed, so the polygon assignment + # is the nearest-seed assignment. + expect_identical(r$asg$value$cell_id, r$nearest_cell, info = info) +} + + +# --- the seeders attach the ground the seeds stand for ----------------------- + +test_that("the seeding functions attach a cover", { + obs <- .fc_obs(200) + bnd <- .fc_square() + + # k-means on points: the points' convex hull, in their CRS. + km <- voronoi_seeds_kmeans(obs, k = 6) + cov <- attr(km, "cover") + expect_s3_class(cov, "sfc") + expect_true(sf::st_crs(cov) == sf::st_crs(obs)) + expect_equal(as.numeric(sf::st_area(cov)), + as.numeric(sf::st_area(sf::st_convex_hull(sf::st_union(obs))))) + expect_true(all(lengths(sf::st_intersects(obs, cov)) == 1L)) + + # Random seeds: the boundary they were drawn in. + rn <- voronoi_seeds_random(bnd, k = 6, set_seed = 1) + expect_equal(as.numeric(sf::st_area(attr(rn, "cover"))), 1e10) + + # get_voronoi_seeds(): the boundary when there is one, else the cloud's hull. + g1 <- get_voronoi_seeds(bnd, method = "random", n = 6, set_seed = 1) + expect_equal(as.numeric(sf::st_area(attr(g1, "cover"))), 1e10) + g2 <- get_voronoi_seeds(bnd, method = "kmeans", n = 6, set_seed = 1) + expect_equal(as.numeric(sf::st_area(attr(g2, "cover"))), 1e10) + g3 <- get_voronoi_seeds(method = "kmeans", n = 6, sample_points = obs, set_seed = 1) + expect_equal(as.numeric(sf::st_area(attr(g3, "cover"))), + as.numeric(sf::st_area(sf::st_convex_hull(sf::st_union(obs))))) + g4 <- get_voronoi_seeds(bnd, method = "kmeans", n = 6, sample_points = obs, + set_seed = 1) + expect_equal(as.numeric(sf::st_area(attr(g4, "cover"))), 1e10) + # Provided seeds have a cover only when the call says what they stand for. + mine <- obs[1:5, ] + expect_null(attr(get_voronoi_seeds(method = "provided", seeds = mine), "cover")) + expect_false(is.null(attr(get_voronoi_seeds(bnd, method = "provided", seeds = mine), + "cover"))) +}) + +test_that("the cover is kept across the CRS alignment of the seeds", { + obs <- .fc_obs(200) + bnd_ll <- sf::st_transform(.fc_square(), 4326) + # The cloud is projected, the boundary lon/lat: the seeds are moved into + # the boundary's CRS, and the cover goes with them. + s <- get_voronoi_seeds(bnd_ll, method = "kmeans", n = 5, sample_points = obs, + set_seed = 1) + expect_true(sf::st_crs(s) == sf::st_crs(4326)) + expect_s3_class(attr(s, "cover"), "sfc") + # And across what a caller does to them, short of rbind(). + km <- voronoi_seeds_kmeans(obs, k = 5) + expect_false(is.null(attr(sf::st_transform(km, 4326), "cover"))) + expect_false(is.null(attr(km[1:3, ], "cover"))) + expect_null(attr(rbind(km, km), "cover")) +}) + + +# --- every observation gets a cell ------------------------------------------- + +test_that("k-means seeds with no boundary: every observation is assigned (projected)", { + obs <- .fc_obs(600) + for (k in c(1, 2, 4, 25, 100)) { + seeds <- suppressWarnings(voronoi_seeds_kmeans(obs, k = k)) + r <- .fc_route(seeds, obs) + expect_identical(nrow(r$tess$cells), as.integer(k)) + expect_identical(r$tess$params$boundary_source, "seeds' cover") + .fc_expect_all_assigned(r, obs, info = paste("k =", k)) + } +}) + +test_that("k-means seeds with no boundary: every observation is assigned (lon/lat)", { + # The seeds' working CRS is picked from the seeds' own extent, so the cover + # has to follow them out of the observations' CRS. + obs <- sf::st_transform(.fc_obs(600), 4326) + for (k in c(1, 2, 4, 25, 100)) { + seeds <- suppressWarnings(voronoi_seeds_kmeans(obs, k = k)) + r <- .fc_route(seeds, obs) + .fc_expect_all_assigned(r, obs, info = paste("lon/lat, k =", k)) + } +}) + +test_that("k-means seeds on a real lon/lat layer: every feature is assigned", { + shp <- system.file("shape/nc.shp", package = "sf") + skip_if(!nzchar(shp), "sf's nc.shp is not available") + nc <- suppressWarnings(sf::st_centroid(sf::st_geometry(sf::st_read(shp, quiet = TRUE)))) + obs <- sf::st_sf(z = seq_along(nc) / 10, geometry = nc) + for (k in c(3, 10, 30)) { + seeds <- voronoi_seeds_kmeans(obs, k = k) + r <- .fc_route(seeds, obs) + .fc_expect_all_assigned(r, obs, info = paste("nc, k =", k)) + } +}) + +test_that("observations with no CRS are covered too, in degrees and in metres", { + # Neither layer has a CRS: seeds and cover are read in one coordinate space, + # whichever way the builder then interprets the seeds. + planar <- sf::st_set_crs(.fc_obs(300), NA) + seeds <- voronoi_seeds_kmeans(planar, k = 9) + tess <- suppressMessages(build_tessellation(seeds, method = "voronoi", quiet = TRUE)) + expect_identical(tess$params$boundary_source, "seeds' cover") + expect_true(all(lengths(sf::st_intersects(planar, tess$cells)) >= 1L)) + + set.seed(3) + deg <- sf::st_as_sf(data.frame(x = runif(300, 10, 11), y = runif(300, 50, 51)), + coords = c("x", "y")) + seeds_d <- suppressWarnings(voronoi_seeds_kmeans(deg, k = 9)) + # CRS-less degrees are taken as EPSG:4326 and projected, with a warning; + # the cover is taken the same way. + tess_d <- suppressWarnings(suppressMessages( + build_tessellation(seeds_d, method = "voronoi", quiet = TRUE))) + deg_p <- sf::st_transform(sf::st_set_crs(deg, 4326), sf::st_crs(tess_d$cells)) + expect_true(all(lengths(sf::st_intersects(deg_p, tess_d$cells)) >= 1L)) +}) + +test_that("seeds drawn in a boundary fill it when the boundary is not passed on", { + bnd <- .fc_square() + obs <- .fc_obs(600) + for (m in c("random", "kmeans")) { + seeds <- get_voronoi_seeds(bnd, method = m, n = 10, set_seed = 3) + r <- .fc_route(seeds, obs) + .fc_expect_all_assigned(r, obs, info = m) + covered <- sum(as.numeric(sf::st_area(suppressWarnings( + sf::st_intersection(sf::st_geometry(r$tess$cells), sf::st_geometry(bnd)))))) / 1e10 + # 36% for 10 random seeds and 54% for 10 k-means seeds before. + expect_gt(covered, 0.9999) + } + r <- .fc_route(voronoi_seeds_random(bnd, k = 10, set_seed = 3), obs) + .fc_expect_all_assigned(r, obs, info = "voronoi_seeds_random") +}) + +test_that("seeds from a resolution profile or selection hold every observation", { + skip_if_not_installed("gstat") + set.seed(11) + obs <- sf::st_as_sf(data.frame(x = runif(400, 0, 5e4), y = runif(400, 0, 5e4)), + coords = c("x", "y"), crs = 32617) + obs$z <- rnorm(400) + sin(sf::st_coordinates(obs)[, 1] / 8000) + prof <- suppressWarnings(suppressMessages( + resolution_profile(obs, "z", levels = c(4, 9, 16), nstart = 5, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans"))) + # The profile keeps the hull of the points it was computed on. + expect_s3_class(attr(prof, "hull"), "sfc") + sel <- select_resolution(prof, criterion = "cp") + + # The route the package's warnings prescribe: 15% of rows lost before. + s1 <- .fc_bound_chosen(get_voronoi_seeds(method = "kmeans", n = sel, sample_points = obs, + partition = "kmeans")) + .fc_expect_all_assigned(.fc_route(s1, obs), obs, info = "selection + sample_points") + s2 <- .fc_bound_chosen(voronoi_seeds_kmeans(obs, k = sel, partition = "kmeans")) + .fc_expect_all_assigned(.fc_route(s2, obs), obs, info = "voronoi_seeds_kmeans(k = selection)") + # The profile alone: its own hull is the cover. + s3 <- .fc_bound_chosen(get_voronoi_seeds(method = "kmeans", n = prof, partition = "kmeans")) + expect_false(is.null(attr(s3, "cover"))) + .fc_expect_all_assigned(.fc_route(s3, obs), obs, info = "profile alone") + + # A selection whose centres carry the profile's hull, given with neither + # points nor a boundary: get_voronoi_seeds() hands the hull on as the cover. + # (The hull is put on the centres here; see the next test for what a + # select_resolution() result carries by itself.) + sel_h <- sel + attr(sel_h$seeds, "cover") <- attr(prof, "hull") + s4 <- .fc_bound_chosen(get_voronoi_seeds(method = "kmeans", n = sel_h, partition = "kmeans")) + expect_false(is.null(attr(s4, "cover"))) + expect_equal(as.numeric(sf::st_area(attr(s4, "cover"))), + as.numeric(sf::st_area(attr(prof, "hull")))) + r4 <- .fc_route(s4, obs) + expect_identical(r4$tess$params$boundary_source, "seeds' cover") + .fc_expect_all_assigned(r4, obs, info = "selection carrying the profile's hull") + + # Centres with nothing to say what ground they stand for: the cells stop + # at the centres' own hull, and that is said, at the build and at the + # assignment. + sel_0 <- sel + attr(sel_0$seeds, "cover") <- NULL + s5 <- .fc_bound_chosen(get_voronoi_seeds(method = "kmeans", n = sel_0, partition = "kmeans")) + expect_null(attr(s5, "cover")) + r5 <- .fc_route(s5, obs) + expect_true(any(.fc_has_class(r5$built, "spatialkit_no_cover"))) + expect_match(r5$built$warnings[.fc_has_class(r5$built, "spatialkit_no_cover")][1], + "layer of seeds .* no `boundary` and no cover") + expect_identical(r5$tess$params$boundary_source, "points") + expect_true(any(.fc_has_class(r5$asg, "spatialkit_unassigned"))) + # Passing the observations as `cover` repairs it. + r6 <- .fc_route(s5, obs, cover = obs) + expect_identical(r6$tess$params$boundary_source, "cover") + .fc_expect_all_assigned(r6, obs, info = "no cover on the centres, cover = observations") +}) + +test_that("a select_resolution() result alone holds every observation", { + skip_if_not_installed("gstat") + set.seed(11) + obs <- sf::st_as_sf(data.frame(x = runif(400, 0, 5e4), y = runif(400, 0, 5e4)), + coords = c("x", "y"), crs = 32617) + obs$z <- rnorm(400) + sin(sf::st_coordinates(obs)[, 1] / 8000) + prof <- suppressWarnings(suppressMessages( + resolution_profile(obs, "z", levels = c(4, 9, 16), nstart = 5, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans"))) + sel <- select_resolution(prof, criterion = "cp") + # select_resolution() builds its centres with .profile_seeds() (in + # R/resolution-profile.R), which puts the profile's hull on them as their + # cover. Without it a selection given with neither points nor a boundary + # had no cover to hand on and its cells stopped at the centres' hull (with + # two classed warnings; previous test). + expect_s3_class(attr(sel$seeds, "cover", exact = TRUE), "sfc") + s <- .fc_bound_chosen(get_voronoi_seeds(method = "kmeans", n = sel, partition = "kmeans")) + expect_false(is.null(attr(s, "cover"))) + r <- .fc_route(s, obs) + expect_identical(r$tess$params$boundary_source, "seeds' cover") + .fc_expect_all_assigned(r, obs, info = "selection alone") +}) + + +# --- the `cover` argument ---------------------------------------------------- + +test_that("`cover` sets the default boundary: points, a polygon, another CRS, no CRS", { + obs <- .fc_obs(400) + seeds <- voronoi_seeds_kmeans(obs, k = 8) + bare <- seeds + attr(bare, "cover") <- NULL # as rbind() leaves them + + # No cover, seeds: the old cells, and a classed warning. + res <- .fc_conditions(build_tessellation(bare, method = "voronoi", quiet = TRUE)) + expect_true(any(.fc_has_class(res, "spatialkit_no_cover"))) + expect_gt(sum(lengths(sf::st_intersects(obs, res$value$cells)) == 0L), 50L) + + inside <- function(tess) all(lengths(sf::st_intersects( + sf::st_transform(obs, sf::st_crs(tess$cells)), tess$cells)) >= 1L) + # The observations. + expect_no_warning(t1 <- build_tessellation(bare, method = "voronoi", quiet = TRUE, + cover = obs)) + expect_true(inside(t1)) + expect_identical(t1$params$boundary_source, "cover") + expect_null(t1$params$cover_outside) + # The boundary is the observations' hull grown by 2% of its diagonal. + hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(obs))) + bb <- sf::st_bbox(hull) + grown <- sf::st_buffer(hull, 0.02 * sqrt((bb[["xmax"]] - bb[["xmin"]])^2 + + (bb[["ymax"]] - bb[["ymin"]])^2)) + expect_equal(as.numeric(sf::st_area(t1$boundary)), as.numeric(sf::st_area(grown)), + tolerance = 1e-8) + expect_equal(sum(as.numeric(sf::st_area(t1$cells))), as.numeric(sf::st_area(grown)), + tolerance = 1e-8) + # A polygon. + expect_no_warning(t2 <- build_tessellation(bare, method = "voronoi", quiet = TRUE, + cover = .fc_square())) + expect_true(inside(t2)) + # The observations in another CRS. + expect_no_warning(t3 <- build_tessellation(bare, method = "voronoi", quiet = TRUE, + cover = sf::st_transform(obs, 4326))) + expect_true(inside(t3)) + # The observations with no CRS: read in the seeds' coordinates. + expect_no_warning(t4 <- build_tessellation(bare, method = "voronoi", quiet = TRUE, + cover = sf::st_set_crs(obs, NA))) + expect_true(inside(t4)) + # create_voronoi_polygons() takes it too. + expect_no_warning(t5 <- create_voronoi_polygons(bare, cover = obs, quiet = TRUE)) + expect_true(inside(t5)) + expect_identical(t5$params$boundary_source, "cover") + # The argument wins over the cover the seeds carry. + half <- .fc_square(side = 5e4) + t6 <- suppressWarnings(build_tessellation(seeds, method = "voronoi", quiet = TRUE, + cover = sf::st_geometry(half))) + expect_identical(t6$params$boundary_source, "cover") + + expect_error(build_tessellation(bare, method = "voronoi", cover = "obs"), + "`cover` must be an sf or sfc point or polygon layer") +}) + +test_that("a generator outside the cover keeps its ground, and a cover elsewhere is set aside", { + obs <- .fc_obs(300) + seeds <- voronoi_seeds_kmeans(obs, k = 8) + attr(seeds, "cover") <- NULL + # A cover over the western half: the eastern seeds still get cells. + west <- .fc_square(side = 5e4) + t1 <- suppressWarnings(build_tessellation(seeds, method = "voronoi", quiet = TRUE, + cover = west)) + expect_identical(t1$params$n_outside, 0L) + expect_identical(nrow(t1$cells), 8L) + # A cover that holds none of them is in another place: refused, by name. + far <- .fc_square(x0 = 9e6) + res <- .fc_conditions(build_tessellation(seeds, method = "voronoi", quiet = TRUE, + cover = far)) + hit <- .fc_has_class(res, "spatialkit_no_cover") + expect_identical(sum(hit), 1L) + expect_match(res$warnings[hit], "`cover` holds none of the points") + expect_identical(res$value$params$boundary_source, "points") +}) + + +# --- points in no cell are counted, and warned about ------------------------- + +test_that("a boundary smaller than the data: the build and the assignment both warn, with counts", { + obs <- .fc_obs(600) + seeds <- voronoi_seeds_kmeans(obs, k = 25) + small <- .fc_square(side = 5e4) + n_out <- sum(lengths(sf::st_intersects(obs, small)) == 0L) + expect_gt(n_out, 100L) + + # With the observations as `cover`, build_tessellation() counts the ones + # the boundary leaves out. + built <- .fc_conditions(build_tessellation(seeds, boundary = small, + method = "voronoi", quiet = TRUE, + cover = obs)) + hit <- .fc_has_class(built, "spatialkit_unassigned") + expect_true(any(grepl("`cover` point", built$warnings[hit]))) + expect_identical(built$value$params$cover_outside, n_out) + expect_identical(built$value$params$boundary_source, "boundary") + # The seeds outside the boundary are NA in `index`, counted and warned about. + expect_identical(built$value$params$n_outside, sum(is.na(built$value$index))) + expect_gt(built$value$params$n_outside, 0L) + expect_true(any(grepl("NA in `index`", built$warnings[hit]))) + + # assign_features_to_polygons(): an R warning with a class, not a log line. + asg <- .fc_conditions(assign_features_to_polygons(obs, built$value$cells, + polygon_id_col = "cell_id")) + hit_a <- .fc_has_class(asg, "spatialkit_unassigned") + expect_identical(sum(hit_a), 1L) + expect_match(asg$warnings[hit_a], sprintf("%d of 600 feature\\(s\\)", n_out)) + expect_identical(asg$conditions[[which(hit_a)]]$n, n_out) + expect_identical(asg$conditions[[which(hit_a)]]$total, 600L) + rec <- attr(asg$value, "unassigned") + expect_identical(rec$n, n_out) + expect_identical(rec$which, which(lengths(sf::st_intersects(obs, small)) == 0L)) + expect_identical(nrow(asg$value), 600L - n_out) +}) + +test_that("build_tessellation() counts and warns about points outside every cell", { + obs <- .fc_obs(300) + small <- .fc_square(side = 5e4) + n_out <- sum(lengths(sf::st_intersects(obs, small)) == 0L) + for (m in c("voronoi", "square", "hex")) { + res <- .fc_conditions(build_tessellation(obs, boundary = small, method = m, + approx_n_cells = if (m == "voronoi") NULL else 9, + quiet = TRUE)) + hit <- .fc_has_class(res, "spatialkit_unassigned") + expect_identical(sum(hit), 1L, info = m) + expect_match(res$warnings[hit], sprintf("%d of 300 point\\(s\\)", n_out), info = m) + expect_identical(res$value$params$n_outside, n_out, info = m) + expect_identical(sum(is.na(res$value$index)), n_out, info = m) + # Caught by class, without matching the message. + caught <- tryCatch( + build_tessellation(obs, boundary = small, method = m, quiet = TRUE, + approx_n_cells = if (m == "voronoi") NULL else 9), + spatialkit_unassigned = function(w) w$n) + expect_identical(caught, n_out, info = m) + } + # A lattice checks a point `cover` against its cells as well. + seeds <- voronoi_seeds_kmeans(obs, k = 5) + g <- .fc_conditions(build_tessellation(obs[lengths(sf::st_intersects(obs, small)) == 1L, ], + boundary = small, method = "square", + approx_n_cells = 9, quiet = TRUE, cover = obs)) + expect_identical(g$value$params$cover_outside, n_out) + expect_identical(g$value$params$n_outside, 0L) + expect_true(any(.fc_has_class(g, "spatialkit_unassigned"))) +}) + + +# --- the messages name what the code did ------------------------------------- + +test_that("the cover check says what set the cells, for the method that ran", { + obs <- .fc_obs(300) + small <- .fc_square(side = 5e4) + inside <- obs[lengths(sf::st_intersects(obs, small)) == 1L, ] + msg_of <- function(...) { + res <- .fc_conditions(build_tessellation(..., quiet = TRUE, cover = obs)) + hit <- .fc_has_class(res, "spatialkit_unassigned") & grepl("`cover` point", res$warnings) + expect_identical(sum(hit), 1L) + res$warnings[hit] + } + # Voronoi cells in a boundary: the boundary set them, and leaving it out + # would have the cells built to hold the cover. + v <- msg_of(voronoi_seeds_kmeans(obs, k = 9), boundary = small, method = "voronoi") + expect_match(v, "`boundary` sets the cells, and it does not hold them", fixed = TRUE) + expect_match(v, "leave `boundary` out so the cells are built to hold `cover`", fixed = TRUE) + # A grid is laid over the boundary whatever the cover: that advice was + # given here too, and a grid cannot be built without a boundary. + for (m in c("square", "hex")) { + g <- msg_of(inside, boundary = small, method = m, approx_n_cells = 9) + expect_match(g, "the grid is laid over `boundary`, and it does not hold them", fixed = TRUE) + expect_match(g, "`cover` sizes nothing for a grid: pass a boundary that holds the observations", + fixed = TRUE) + expect_false(grepl("leave `boundary` out", g, fixed = TRUE), info = m) + } + # Triangles span the hull of the points triangulated. With no boundary + # passed at all the message used to blame `boundary` and say to leave it out. + t0 <- msg_of(inside, method = "triangles") + expect_match(t0, "the triangles span the convex hull of `points_sf`, and it does not hold them", + fixed = TRUE) + expect_match(t0, "`cover` sizes nothing for method = \"triangles\"", fixed = TRUE) + expect_false(grepl("`boundary` sets the cells", t0, fixed = TRUE)) + expect_false(grepl("leave `boundary` out", t0, fixed = TRUE)) + t1 <- msg_of(inside, boundary = small, method = "triangles") + expect_match(t1, "convex hull of `points_sf`, clipped to `boundary`, and that does not hold them", + fixed = TRUE) + # What the triangle message points to does hold the cover. + fixed <- build_tessellation(voronoi_seeds_kmeans(inside, k = 9), method = "voronoi", + quiet = TRUE, cover = obs) + expect_true(all(lengths(sf::st_intersects(obs, fixed$cells)) >= 1L)) +}) + +test_that("a cover the seeds carry is called that, not `cover`, through build_tessellation()", { + obs <- .fc_obs(300) + seeds <- voronoi_seeds_kmeans(obs, k = 8) + # The message: no `cover` argument was passed. + said <- character(0) + tess <- withCallingHandlers( + build_tessellation(seeds, method = "voronoi"), + message = function(m) { said <<- c(said, conditionMessage(m)); invokeRestart("muffleMessage") }) + expect_true(any(grepl("deriving boundary from the cover the seeds carry", said, fixed = TRUE))) + expect_false(any(grepl("from `cover`", said, fixed = TRUE))) + expect_identical(tess$params$boundary_source, "seeds' cover") + expect_null(tess$params$cover_outside) + # The direct call says the same. + said2 <- character(0) + withCallingHandlers( + create_voronoi_polygons(seeds), + message = function(m) { said2 <<- c(said2, conditionMessage(m)); invokeRestart("muffleMessage") }) + expect_true(any(grepl("deriving boundary from the cover the seeds carry", said2, fixed = TRUE))) + # A `cover` that was passed is still called `cover`. + said3 <- character(0) + withCallingHandlers( + build_tessellation(seeds, method = "voronoi", cover = obs), + message = function(m) { said3 <<- c(said3, conditionMessage(m)); invokeRestart("muffleMessage") }) + expect_true(any(grepl("deriving boundary from `cover`", said3, fixed = TRUE))) + + # The warning for a cover in another place names its source the same way. + far <- seeds + attr(far, "cover") <- sf::st_geometry(.fc_square(x0 = 9e6)) + res <- .fc_conditions(build_tessellation(far, method = "voronoi", quiet = TRUE)) + hit <- .fc_has_class(res, "spatialkit_no_cover") + expect_identical(sum(hit), 1L) + expect_match(res$warnings[hit], "the cover the seeds carry holds none of the points", + fixed = TRUE) + expect_false(grepl("`cover` holds none", res$warnings[hit], fixed = TRUE)) + expect_identical(res$value$params$boundary_source, "points") + # And with the argument, the argument is named. + bare <- seeds; attr(bare, "cover") <- NULL + res2 <- .fc_conditions(build_tessellation(bare, method = "voronoi", quiet = TRUE, + cover = .fc_square(x0 = 9e6))) + expect_match(res2$warnings[.fc_has_class(res2, "spatialkit_no_cover")], + "`cover` holds none of the points", fixed = TRUE) +}) + + +# --- one cell per observation is as it was ----------------------------------- + +test_that("plain one-cell-per-observation Voronoi is unchanged", { + set.seed(4) + q <- sf::st_as_sf(data.frame(x = runif(60, 0, 1000), y = runif(60, 0, 1000)), + coords = c("x", "y"), crs = 32617) + expect_no_warning(tess <- build_tessellation(q, method = "voronoi", quiet = TRUE)) + expect_identical(nrow(tess$cells), 60L) + expect_identical(sort(tess$index), 1:60) + expect_identical(tess$params$n_outside, 0L) + expect_identical(tess$params$boundary_source, "points") + # The boundary is still the points' own hull grown by 2% of its diagonal. + hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(q))) + bb <- sf::st_bbox(hull) + grown <- sf::st_buffer(hull, 0.02 * sqrt((bb[["xmax"]] - bb[["xmin"]])^2 + + (bb[["ymax"]] - bb[["ymin"]])^2)) + expect_equal(as.numeric(sf::st_area(tess$boundary)), as.numeric(sf::st_area(grown)), + tolerance = 1e-10) + expect_equal(sum(as.numeric(sf::st_area(tess$cells))), as.numeric(sf::st_area(grown)), + tolerance = 1e-10) + # A transect and a single observation raise nothing either. + line <- sf::st_as_sf(data.frame(x = 5e5 + 0:9 * 10, y = 5e6 + 0:9 * 5), + coords = c("x", "y"), crs = 32632) + expect_no_warning(build_tessellation(line, method = "voronoi", quiet = TRUE)) + expect_no_warning(build_tessellation(q[1, ], method = "voronoi", quiet = TRUE)) +}) diff --git a/tests/testthat/test-fix-cells-kish-per-column.R b/tests/testthat/test-fix-cells-kish-per-column.R new file mode 100644 index 00000000..e7b3269f --- /dev/null +++ b/tests/testthat/test-fix-cells-kish-per-column.R @@ -0,0 +1,126 @@ +# tests/testthat/test-fix-cells-kish-per-column.R +# --------------------------------------------------------------------------- +# summarize_by_cell(deff = "kish"): one ICC per summarised column. +# +# One ICC used to be pooled over every predictor listed, so a column's +# standard error depended on which other predictors were named beside it. +# On 60 cells of 12 with an ICC-0 and an ICC-0.87 predictor the pooled 0.42 +# multiplied both standard errors by 3.13, where their own ICCs give 1.00 +# and 8.96; with no response, `cell_weight` was built from the pooled value +# as well. +# --------------------------------------------------------------------------- + +# 60 cells of 12: a white-noise predictor, a strongly clustered one, and an +# unclustered response. +.fk_points <- function(seed = 3, k = 60L, per = 12L) { + set.seed(seed) + n <- k * per + cell <- rep(seq_len(k), each = per) + d <- data.frame(x = 4e5 + runif(n, 0, 1e5), y = 4.6e6 + runif(n, 0, 1e5), + poly_id = cell) + d$resp <- rnorm(n) + d$noise <- rnorm(n) + d$clust <- rnorm(k)[cell] + rnorm(n, 0, 0.33) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32615) +} + +# The same ANOVA estimator on one column, by hand. +.fk_icc <- function(v, g) { + g <- factor(g); ni <- tabulate(g); k <- nlevels(g); N <- length(v) + gm <- tapply(v, g, mean) + msb <- sum(ni * (gm - mean(v))^2) / (k - 1) + msw <- sum((v - gm[g])^2) / (N - k) + n0 <- (N - sum(ni^2) / N) / (k - 1) + max(0, min(1, (msb - msw) / (msb + (n0 - 1) * msw))) +} + +test_that("each predictor's standard error, effective n and interval use its own ICC", { + pts <- .fk_points() + both <- summarize_by_cell(pts, "resp", c("noise", "clust"), deff = "kish", + conf_level = 0.95, estimate = "mean") + aloneN <- summarize_by_cell(pts, "resp", "noise", deff = "kish", conf_level = 0.95, + estimate = "mean") + aloneC <- summarize_by_cell(pts, "resp", "clust", deff = "kish", conf_level = 0.95, + estimate = "mean") + + # Adding or removing a predictor leaves the other's columns as they were. + for (stat in c("..se_", "..neff_", "..df_", "..ci_lo_", "..ci_hi_")) { + expect_equal(both[[paste0(stat, "pred_noise")]], aloneN[[paste0(stat, "pred_noise")]], + tolerance = 1e-12, info = stat) + expect_equal(both[[paste0(stat, "pred_clust")]], aloneC[[paste0(stat, "pred_clust")]], + tolerance = 1e-12, info = stat) + } + # In either order. + flipped <- summarize_by_cell(pts, "resp", c("clust", "noise"), deff = "kish", + conf_level = 0.95, estimate = "mean") + expect_equal(flipped[["..se_pred_noise"]], both[["..se_pred_noise"]], tolerance = 1e-12) + expect_equal(flipped[["..se_pred_clust"]], both[["..se_pred_clust"]], tolerance = 1e-12) + # The response is untouched by any of it. + only <- summarize_by_cell(pts, "resp", deff = "kish", conf_level = 0.95, estimate = "mean") + expect_equal(both[["..se_resp_resp"]], only[["..se_resp_resp"]], tolerance = 1e-12) + expect_equal(both$cell_weight, only$cell_weight, tolerance = 1e-12) + + # The numbers: the unclustered predictor's SE is the naive one, the + # clustered one's is about nine times it. Pooled, both were 3.13 times. + naive <- summarize_by_cell(pts, "resp", c("noise", "clust"), estimate = "mean") + expect_equal(both[["..se_pred_noise"]], naive[["..se_pred_noise"]], tolerance = 1e-12) + ratio_c <- stats::median(both[["..se_pred_clust"]] / naive[["..se_pred_clust"]]) + expect_gt(ratio_c, 7) + expect_lt(ratio_c, 11) +}) + +test_that("the ICCs are recorded per predictor column, by name", { + pts <- .fk_points() + d <- sf::st_drop_geometry(pts) + both <- summarize_by_cell(pts, "resp", c("noise", "clust"), deff = "kish", estimate = "mean") + icc <- attr(both, "icc") + expect_named(icc$pred, c("noise", "clust")) + expect_equal(icc$pred[["noise"]], .fk_icc(d$noise, d$poly_id), tolerance = 1e-10) + expect_equal(icc$pred[["clust"]], .fk_icc(d$clust, d$poly_id), tolerance = 1e-10) + expect_lt(icc$pred[["noise"]], 0.02) + expect_gt(icc$pred[["clust"]], 0.8) + expect_length(icc$resp, 1L) + # The same vector on the applied record. + da <- attr(both, "deff_applied") + expect_identical(da$icc_pred, icc$pred) + expect_identical(da$method, "kish") + # One predictor: still named. + one <- summarize_by_cell(pts, "resp", "clust", deff = "kish", estimate = "mean") + expect_named(attr(one, "icc")$pred, "clust") + # No predictor, no response column of that type: NA, as before. + expect_identical(attr(summarize_by_cell(pts, "resp", deff = "kish", estimate = "mean"), + "icc")$pred, + NA_real_) +}) + +test_that("with no response, cell_weight uses the first predictor's own ICC", { + pts <- .fk_points() + # Primary variable `noise` (ICC 0): its weight is its count, whatever else + # is listed. It fell from 12 to 2.12 when `clust` was listed after it. + nb <- summarize_by_cell(pts, predictor_vars = c("noise", "clust"), deff = "kish", + estimate = "mean") + n1 <- summarize_by_cell(pts, predictor_vars = "noise", deff = "kish", estimate = "mean") + expect_equal(nb$cell_weight, n1$cell_weight, tolerance = 1e-12) + expect_equal(nb$cell_weight, rep(12, 60)) + # The clustered predictor is still corrected, and the rows say a + # correction was applied. + expect_true(all(nb$deff_applied)) + expect_identical(unique(nb$deff_method), "kish") + # Primary variable `clust`: its own, strong, ICC sets the weight. + cb <- summarize_by_cell(pts, predictor_vars = c("clust", "noise"), deff = "kish", + estimate = "mean") + c1 <- summarize_by_cell(pts, predictor_vars = "clust", deff = "kish", estimate = "mean") + expect_equal(cb$cell_weight, c1$cell_weight, tolerance = 1e-12) + expect_true(all(cb$cell_weight < 2)) +}) + +test_that("a column with missing values keeps its own ICC and count", { + pts <- .fk_points() + pts$clust[c(1, 2, 14, 30)] <- NA + both <- summarize_by_cell(pts, "resp", c("noise", "clust"), deff = "kish", + conf_level = 0.9, estimate = "mean") + alone <- summarize_by_cell(pts, "resp", "clust", deff = "kish", conf_level = 0.9, + estimate = "mean") + expect_equal(both[["..se_pred_clust"]], alone[["..se_pred_clust"]], tolerance = 1e-12) + expect_equal(both[["..neff_pred_clust"]], alone[["..neff_pred_clust"]], tolerance = 1e-12) +}) diff --git a/tests/testthat/test-fix-cells-kriging.R b/tests/testthat/test-fix-cells-kriging.R new file mode 100644 index 00000000..471a3e39 --- /dev/null +++ b/tests/testthat/test-fix-cells-kriging.R @@ -0,0 +1,428 @@ +# tests/testthat/test-fix-cells-kriging.R +# --------------------------------------------------------------------------- +# kriging_adequacy(): a response that is not numeric, replicates that show +# more variation than the model's nugget, and what kriging buys in a cell, +# measured against the plain mean on the same variogram (plain_var, kr_gain, +# kr_shift). +# --------------------------------------------------------------------------- + +.fg_field <- function(n = 200, seed = 42) { + set.seed(seed) + x <- 5e5 + runif(n, 0, 10000); y <- 5e6 + runif(n, 0, 10000) + d <- as.matrix(stats::dist(cbind(x, y))) + lat <- as.numeric(t(chol(exp(-d / 2500) + diag(0.2, n))) %*% rnorm(n)) + sf::st_as_sf(data.frame(x = x, y = y, lat = lat), coords = c("x", "y"), crs = 32632) +} +.fg_setup <- function() { + pts <- .fg_field() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + cells <- create_grid_polygons(bnd, target_cells = 9, type = "square") + list(pts = pts, cells = cells, + asg = assign_features_to_polygons(pts, cells)) +} +.fg_sac <- function(nugget = 0.2, psill = 1, range = 2500) structure( + 3 * range, class = c("sac_range", "numeric"), + variogram_model = if (nugget > 0) + gstat::vgm(psill = psill, model = "Exp", range = range, nugget = nugget) + else gstat::vgm(psill = psill, model = "Exp", range = range), + crs = sf::st_crs(32632)) + +.fg_run <- function(expr) { + w <- character(0); cls <- list(); conds <- list() + val <- withCallingHandlers( + expr, + warning = function(c) { + w <<- c(w, conditionMessage(c)); cls[[length(cls) + 1L]] <<- class(c) + conds[[length(conds) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + list(value = val, warnings = w, classes = cls, conditions = conds) +} + + +# --- the response's type ------------------------------------------------------ + +test_that("a factor, character or date response is an error naming the column and its class", { + skip_if_not_installed("gstat") + s <- .fg_setup() + asg <- s$asg + lat <- asg$lat + asg$cat3 <- cut(lat, stats::quantile(lat, c(0, 1/3, 2/3, 1)), include.lowest = TRUE, + labels = c("low", "mid", "high")) + asg$ord <- factor(as.character(asg$cat3), levels = c("low", "mid", "high"), + ordered = TRUE) + asg$chr <- as.character(asg$cat3) + asg$num_chr <- as.character(round(lat, 3)) + asg$day <- as.Date("2024-01-01") + round(50 * lat) + + # A factor used to be kriged on its level codes, and the answer changed with + # the order of the levels, with nothing said. + expect_error(kriging_adequacy(asg, "cat3", s$cells, k = 4), + "response 'cat3' is a factor, and kriging needs a numeric or logical variable") + expect_error(kriging_adequacy(asg, "cat3", s$cells, k = 4), + "arbitrary relabelling of its levels") + expect_error(kriging_adequacy(asg, "cat3", s$cells, k = 4), + "pass an indicator column \\(cat3 == \"\"\\)") + expect_error(kriging_adequacy(asg, "ord", s$cells, k = 4), + "response 'ord' is a factor") + # Labels used to end in "fewer than 10 points with a finite response". + expect_error(kriging_adequacy(asg, "chr", s$cells, k = 4), + "response 'chr' is of class character") + # Numbers held as text, and dates, were converted without a word. + expect_error(kriging_adequacy(asg, "num_chr", s$cells, k = 4), + "response 'num_chr' is of class character.*not converted for you") + expect_error(kriging_adequacy(asg, "day", s$cells, k = 4), + "response 'day' is of class Date") + # With `sac` supplied estimate_sac_range() is never called, so the check + # cannot be left to it. + expect_error(kriging_adequacy(asg, "cat3", s$cells, k = 4, sac = .fg_sac()), + "response 'cat3' is a factor") +}) + +test_that("a logical response runs and its mean is the cell share; numeric is unchanged", { + skip_if_not_installed("gstat") + s <- .fg_setup() + asg <- s$asg + asg$pos <- asg$lat > 0 + ka <- suppressWarnings(kriging_adequacy(asg, "pos", s$cells, k = 4, sac = .fg_sac())) + d <- sf::st_drop_geometry(asg) + share <- as.numeric(tapply(d$pos, factor(d$poly_id, levels = ka$poly_id), mean)) + expect_equal(ka$mean, share, tolerance = 1e-12) + # (a cell with no point has no mean) + expect_true(all(ka$mean >= 0 & ka$mean <= 1, na.rm = TRUE)) + expect_gt(sum(is.finite(ka$mean)), 5L) + # An integer column is numeric. + asg$cnt <- as.integer(round(10 * asg$lat)) + expect_s3_class(suppressWarnings(kriging_adequacy(asg, "cnt", s$cells, k = 4, + sac = .fg_sac())), "kriging_adequacy") + # A numeric response is kriged as before. + kn <- suppressWarnings(kriging_adequacy(asg, "lat", s$cells, k = 4, sac = .fg_sac())) + expect_equal(kn$mean, as.numeric(tapply(d$lat, factor(d$poly_id, levels = kn$poly_id), + mean)), tolerance = 1e-12) +}) + + +# --- replicates against the nugget ------------------------------------------- + +# `n_loc` stations, each visited `m` times: a field with no nugget of its own +# (partial sill 1, range parameter 2500), and a measurement error of variance +# `me_var` on every visit. +.fg_visits <- function(n_loc = 200, m = 2, me_var = 0.5, seed = 31) { + set.seed(seed) + x <- 5e5 + runif(n_loc, 0, 10000); y <- 5e6 + runif(n_loc, 0, 10000) + d <- as.matrix(stats::dist(cbind(x, y))) + s <- as.numeric(t(chol(exp(-d / 2500) + diag(1e-8, n_loc))) %*% rnorm(n_loc)) + v <- data.frame(x = rep(x, m), y = rep(y, m), station = rep(seq_len(n_loc), m)) + v$lat <- s[v$station] + rnorm(nrow(v), 0, sqrt(me_var)) + sf::st_as_sf(v, coords = c("x", "y"), crs = 32632) +} + +test_that("a replicate variance above the nugget is used as the measurement error, and said", { + skip_if_not_installed("gstat") + v <- .fg_visits() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(v))) + cells <- create_grid_polygons(bnd, target_cells = 9, type = "square") + asg <- assign_features_to_polygons(v, cells) + d <- sf::st_drop_geometry(asg) + loc_mean <- as.numeric(tapply(d$lat, d$station, mean)) + sw2 <- sum((d$lat - loc_mean[d$station])^2) / 200 # pooled, 200 d.f. + lab <- rep(1:4, length.out = 200)[d$station] # a station is held out whole + + # A model with no nugget, and replicates that differ: the replicate variance + # used to be capped at the nugget (here 0), so the station means were + # kriged as exact and "(0 of 0)" was all that was said. + res <- .fg_run(kriging_adequacy(asg, "lat", cells, sac = .fg_sac(nugget = 0), folds = lab)) + hit <- vapply(res$classes, function(k) "spatialkit_replicate_var_above_nugget" %in% k, + logical(1)) + expect_identical(sum(hit), 1L) + expect_match(res$warnings[hit], "400 point\\(s\\) share a location with another") + expect_match(res$warnings[hit], sprintf("variance is %.3g (200 degrees of freedom)", sw2), + fixed = TRUE) + expect_match(res$warnings[hit], "above the variogram's nugget of 0") + expect_match(res$warnings[hit], "is used as the measurement-error variance") + expect_match(res$warnings[hit], + sprintf("Refit the variogram with a nugget of at least %.3g", sw2), fixed = TRUE) + expect_equal(res$conditions[[which(hit)]]$within_var, sw2, tolerance = 1e-10) + expect_identical(res$conditions[[which(hit)]]$nugget, 0) + rp <- attr(res$value, "replicates") + expect_identical(rp$n_points, 400L) + expect_equal(rp$within_var, sw2, tolerance = 1e-10) + expect_identical(rp$df, 200L) + expect_identical(rp$nugget, 0) + expect_equal(rp$nugget_used, sw2, tolerance = 1e-10) + expect_true(rp$above_nugget) + expect_output(print(res$value), + "replicates: pooled within-location variance .* is above the nugget 0 and is used") + + # It is used, not only reported: kriging the 200 means with error variance + # sw2 / 2 is kriging all 400 visits with sw2 as their measurement error. + vm0 <- attr(.fg_sac(nugget = 0), "variogram_model") + bk <- gstat::krige(lat ~ 1, asg, cells, model = vm0, weights = rep(1 / sw2, nrow(asg)), + nmax = 1000, debug.level = 0) + full <- suppressWarnings(kriging_adequacy(asg, "lat", cells, sac = .fg_sac(nugget = 0), + folds = lab, nmax = 1000)) + expect_equal(full$kr_pred, as.numeric(bk$var1.pred), tolerance = 1e-6) + expect_equal(full$kr_var, as.numeric(bk$var1.var), tolerance = 1e-6) + + # And the cross-validation statistic is nearer 1 for it. Kriging the + # station means as exact under the same model is what the cap did: over + # ten layers like this one the statistic read 2.96-4.42 that way and + # 0.84-1.15 with the replicate variance used. + means <- asg[!duplicated(asg$station), ] + means$lat <- loc_mean[means$station] + exact <- suppressWarnings(kriging_adequacy(means, "lat", cells, sac = .fg_sac(nugget = 0), + folds = lab[!duplicated(d$station)])) + expect_null(attr(exact, "replicates")) + z_new <- attr(res$value, "cv")$zscore_var + z_cap <- attr(exact, "cv")$zscore_var + expect_gt(z_cap, 2) + expect_lt(abs(z_new - 1), abs(z_cap - 1)) + expect_gt(z_new, 0.75); expect_lt(z_new, 1.3) + # The kriging variances grow with it: they were too small. + expect_true(all(res$value$kr_var > exact$kr_var)) +}) + +test_that("the replicate variance is used the same way on both sides of the nugget", { + skip_if_not_installed("gstat") + v <- .fg_visits() + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(v))) + cells <- create_grid_polygons(bnd, target_cells = 9, type = "square") + asg <- assign_features_to_polygons(v, cells) + d <- sf::st_drop_geometry(asg) + loc_mean <- as.numeric(tapply(d$lat, d$station, mean)) + sw2 <- sum((d$lat - loc_mean[d$station])^2) / 200 + lab <- rep(1:4, length.out = 200)[d$station] + + # A nugget with room for it: the plain warning, no class, no print line, + # and the rest of the nugget stays with the station as micro-scale variation. + ok <- .fg_run(kriging_adequacy(asg, "lat", cells, sac = .fg_sac(nugget = 2 * sw2), folds = lab)) + shared <- grepl("share a location", ok$warnings) + expect_identical(sum(shared), 1L) + expect_false("spatialkit_replicate_var_above_nugget" %in% ok$classes[[which(shared)]]) + expect_match(ok$warnings[shared], "differs between replicates") + rp <- attr(ok$value, "replicates") + expect_false(rp$above_nugget) + expect_equal(rp$nugget_used, 2 * sw2, tolerance = 1e-10) + expect_false(any(grepl("replicates:", utils::capture.output(print(ok$value))))) + + # A nugget a thousandth below the replicate variance and one a thousandth + # above it give the same kriging to that order: nothing jumps where the + # replicate variance crosses the nugget. + below <- suppressWarnings(kriging_adequacy(asg, "lat", cells, folds = lab, + sac = .fg_sac(nugget = sw2 * 0.999))) + above <- suppressWarnings(kriging_adequacy(asg, "lat", cells, folds = lab, + sac = .fg_sac(nugget = sw2 * 1.001))) + expect_true(attr(below, "replicates")$above_nugget) + expect_false(attr(above, "replicates")$above_nugget) + expect_equal(below$kr_var, above$kr_var, tolerance = 5e-3) + expect_equal(below$plain_var, above$plain_var, tolerance = 5e-3) + expect_equal(attr(below, "cv")$zscore_var, attr(above, "cv")$zscore_var, tolerance = 5e-3) + + # No replicates: no record. + one <- asg[!duplicated(asg$station), ] + none <- suppressWarnings(kriging_adequacy(one, "lat", cells, sac = .fg_sac(), + folds = lab[!duplicated(d$station)])) + expect_null(attr(none, "replicates")) +}) + + +# --- kriging against the plain mean, on one variogram ------------------------ + +# The plain mean's error variance against the cell's own average, written out +# with whole matrices: Var(sum a_j z_j - mean of the field over the cell's +# 500 discretisation points). `e` is each location's error variance. +.fg_plain_var <- function(xy, a, e, cell, range, psill) { + geo <- sf::as_Spatial(sf::st_set_crs(sf::st_geometry(cell), sf::NA_crs_)) + G <- sp::coordinates(sp::spsample(geo, n = 500, type = "regular", offset = c(0.5, 0.5))) + cross <- function(A, B) sqrt(outer(A[, 1], B[, 1], "-")^2 + outer(A[, 2], B[, 2], "-")^2) + Cs <- function(h) psill * exp(-h / range) + as.numeric(t(a) %*% Cs(cross(xy, xy)) %*% a) + sum(a^2 * e) - + 2 * sum(a * rowMeans(Cs(cross(xy, G)))) + mean(Cs(cross(G, G))) +} + +test_that("plain_var is the plain mean's variance under the variogram, and kr_var never exceeds it", { + skip_if_not_installed("gstat") + s <- .fg_setup() + ka <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, sac = .fg_sac(), k = 4)) + df <- sf::st_drop_geometry(ka) + # The comparison with s^2/n is gone; the two columns that replace it are in. + expect_false("kr_exceeds_design" %in% names(df)) + expect_true(all(c("plain_var", "kr_gain", "kr_shift") %in% names(df))) + + pop <- df$n >= 1L + expect_gt(sum(pop), 8L) + expect_gt(sum(!pop), 0L) # this grid has empty cells + expect_true(any(df$n == 1L)) # and a cell with one point + expect_true(all(is.finite(df$plain_var[pop]) & df$plain_var[pop] > 0)) + # Ordinary kriging is the best unbiased combination of a neighbourhood + # that holds the cell's own points, and the plain mean is one of them. + expect_true(all(df$kr_var[pop] <= df$plain_var[pop] * (1 + 1e-6))) + expect_equal(df$kr_gain[pop], 1 - df$kr_var[pop] / df$plain_var[pop], tolerance = 1e-12) + expect_true(all(df$kr_gain[pop] > 0 & df$kr_gain[pop] < 1)) + # Defined for a cell with one point, where s^2/n is not. + one <- df$n == 1L + expect_true(all(is.na(df$se[one]))) + expect_true(all(is.finite(df$kr_gain[one]) & is.finite(df$kr_shift[one]))) + # A cell with no point has no plain mean to compare with. + expect_true(all(is.na(df$plain_var[!pop]) & is.na(df$kr_gain[!pop]) & + is.na(df$kr_shift[!pop]))) + expect_true(all(is.finite(df$kr_pred[!pop]))) + + # plain_var against the definition written out, for three cells. + d <- sf::st_drop_geometry(s$asg); xy <- sf::st_coordinates(s$asg)[, 1:2] + for (i in utils::head(which(df$n >= 2L), 2L)) { + own <- d$poly_id == df$poly_id[i] + expect_equal(df$plain_var[i], + .fg_plain_var(xy[own, , drop = FALSE], rep(1 / sum(own), sum(own)), + rep(0.2, sum(own)), s$cells[i, ], range = 2500, psill = 1), + tolerance = 1e-8) + } + i <- which(one)[1L]; own <- d$poly_id == df$poly_id[i] + expect_equal(df$plain_var[i], .fg_plain_var(xy[own, , drop = FALSE], 1, 0.2, s$cells[i, ], + range = 2500, psill = 1), tolerance = 1e-8) + + # Cells whose neighbourhood had to grow to hold all their own points. + small <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, sac = .fg_sac(), k = 4, + nmax = 10)) + sm <- sf::st_drop_geometry(small) + grown <- !is.na(sm$kr_n_used) & sm$kr_n_used > 10L + expect_gt(sum(grown), 3L) + expect_true(all(sm$kr_var[grown] <= sm$plain_var[grown] * (1 + 1e-6))) + expect_true(all(sm$kr_gain[sm$n >= 1L] > 0)) + # plain_var is a property of the cell's own points: the neighbourhood does + # not enter it. + expect_equal(sm$plain_var, df$plain_var, tolerance = 1e-12) +}) + +test_that("kr_gain does not move with the scale of the sill, and kr_shift is in the model's units", { + skip_if_not_installed("gstat") + s <- .fg_setup() + base <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, sac = .fg_sac(), k = 4)) + # The same data, the same kriged estimates, sill and nugget multiplied by f. + # The comparison with s^2/n flagged 0, 1 and 8 of these 9 cells at f = 1/3, + # 1 and 3. + for (f in c(1 / 3, 3)) { + sc <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, k = 4, + sac = .fg_sac(nugget = 0.2 * f, psill = f))) + expect_equal(sc$kr_pred, base$kr_pred, tolerance = 1e-8) + expect_equal(sc$kr_gain, base$kr_gain, tolerance = 1e-8) + expect_equal(sc$kr_ratio, base$kr_ratio, tolerance = 1e-8) + expect_equal(sc$plain_var, f * base$plain_var, tolerance = 1e-8) + expect_equal(sc$kr_var, f * base$kr_var, tolerance = 1e-6) + # A sill three times too large makes every shift look sqrt(3) smaller: + # the shift is a check of the variogram, like the CV statistic. + expect_equal(sc$kr_shift * sqrt(f), base$kr_shift, tolerance = 1e-5) + } +}) + +test_that("kr_shift is the kriged-minus-plain difference over its own model standard deviation", { + skip_if_not_installed("gstat") + s <- .fg_setup() + # Every point in every neighbourhood, so the kriging can be written out. + ka <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, sac = .fg_sac(), k = 4, + nmax = 1000)) + df <- sf::st_drop_geometry(ka) + pop <- df$n >= 1L + expect_equal(df$kr_shift[pop], + (df$kr_pred[pop] - df$mean[pop]) / sqrt(df$plain_var[pop] - df$kr_var[pop]), + tolerance = 1e-12) + # The variance of (kriged - plain) from the kriging weights themselves is + # plain_var - kr_var: the kriging error is uncorrelated with the difference. + d <- sf::st_drop_geometry(s$asg); xy <- sf::st_coordinates(s$asg)[, 1:2]; n <- nrow(xy) + cross <- function(A, B) sqrt(outer(A[, 1], B[, 1], "-")^2 + outer(A[, 2], B[, 2], "-")^2) + K <- exp(-cross(xy, xy) / 2500) + diag(0.2, n) + geo <- sf::as_Spatial(sf::st_set_crs(sf::st_geometry(s$cells), sf::NA_crs_)) + for (i in utils::head(which(pop), 3L)) { + G <- sp::coordinates(sp::spsample(geo[i], n = 500, type = "regular", offset = c(0.5, 0.5))) + k <- rowMeans(exp(-cross(xy, G) / 2500)) + lam <- solve(rbind(cbind(K, 1), c(rep(1, n), 0)), c(k, 1))[seq_len(n)] + a <- as.numeric(d$poly_id == df$poly_id[i]); a <- a / sum(a) + expect_equal(sum(lam * d$lat), df$kr_pred[i], tolerance = 1e-6) + expect_equal(as.numeric(t(lam - a) %*% K %*% (lam - a)), + df$plain_var[i] - df$kr_var[i], tolerance = 1e-4) + } +}) + +test_that("where kriging returns the plain mean the gain is 0 and the shift is not defined", { + skip_if_not_installed("gstat") + s <- .fg_setup() + # One cell holding every point, under a pure nugget: the best unbiased + # combination of exchangeable observations is their plain mean, so the two + # estimates and the two variances coincide, and their difference over its + # standard deviation is rounding error over rounding error. + one <- sf::st_sf(poly_id = 1L, geometry = sf::st_as_sfc(sf::st_bbox(s$pts))) + asg <- s$asg; asg$poly_id <- 1L + nug <- structure(7500, class = c("sac_range", "numeric"), + variogram_model = gstat::vgm(psill = 0.7, model = "Nug", range = 0), + crs = sf::st_crs(32632)) + ka <- suppressWarnings(kriging_adequacy(asg, "lat", one, sac = nug, k = 4, nmax = 1000)) + expect_equal(ka$kr_pred, ka$mean, tolerance = 1e-8) + expect_equal(ka$plain_var, 0.7 / 200, tolerance = 1e-12) + expect_equal(ka$kr_var, ka$plain_var, tolerance = 1e-5) + expect_gte(ka$kr_gain, 0) + expect_lt(ka$kr_gain, 1e-5) + expect_true(is.na(ka$kr_shift)) + expect_output(print(ka), "kr_gain") + expect_false(any(grepl("kriged minus plain mean", utils::capture.output(print(ka))))) +}) + +test_that("with repeat visits the plain mean's variance uses the error variances the kriging uses", { + skip_if_not_installed("gstat") + v <- .fg_visits(n_loc = 90, m = 3, me_var = 0.1, seed = 8) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(v))) + cells <- create_grid_polygons(bnd, target_cells = 9, type = "square") + asg <- assign_features_to_polygons(v, cells) + d <- sf::st_drop_geometry(asg) + loc_mean <- as.numeric(tapply(d$lat, d$station, mean)) + sw2 <- sum((d$lat - loc_mean[d$station])^2) / 180 + first <- !duplicated(d$station); xy <- sf::st_coordinates(asg)[first, 1:2] + cell_of <- d$poly_id[first] + for (nug in c(0, 0.4)) { # the replicates above, and below, the nugget + ka <- suppressWarnings(kriging_adequacy(asg, "lat", cells, sac = .fg_sac(nugget = nug), + k = 4)) + df <- sf::st_drop_geometry(ka) + pop <- df$n >= 1L + expect_true(all(df$kr_var[pop] <= df$plain_var[pop] * (1 + 1e-6)), info = nug) + # A station's three visits share what the nugget holds beyond the + # replicate variance and average the rest. + e <- max(nug - sw2, 0) + sw2 / 3 + for (i in utils::head(which(df$n >= 6L), 2L)) { + own <- cell_of == df$poly_id[i] + expect_equal(df$plain_var[i], + .fg_plain_var(xy[own, , drop = FALSE], rep(1 / sum(own), sum(own)), + rep(e, sum(own)), cells[i, ], range = 2500, psill = 1), + tolerance = 1e-8, info = nug) + } + } +}) + + +# --- what print() says of the comparison ------------------------------------- + +test_that("print() reports the gain, the shift on the model's scale and the naive SE against plain_var", { + skip_if_not_installed("gstat") + s <- .fg_setup() + ka <- suppressWarnings(kriging_adequacy(s$asg, "lat", s$cells, sac = .fg_sac(), k = 4)) + df <- sf::st_drop_geometry(ka) + out <- utils::capture.output(print(ka)) + # The line that read as a count of cells where kriging does not pay is gone. + expect_false(any(grepl("kriging variance above s^2/n", out, fixed = TRUE))) + gain <- out[grepl("kr_gain", out, fixed = TRUE)] + expect_length(gain, 1L) + expect_match(gain, "share of the plain mean's error variance that kriging removes", fixed = TRUE) + expect_match(gain, sprintf("median %.2f, range %.2f-%.2f over the %d cell(s) with points and a kriged estimate", + stats::median(df$kr_gain, na.rm = TRUE), + min(df$kr_gain, na.rm = TRUE), max(df$kr_gain, na.rm = TRUE), + sum(is.finite(df$kr_gain))), fixed = TRUE) + sh <- out[grepl("kriged minus plain mean", out, fixed = TRUE)] + expect_match(sh, "sqrt(plain_var - kr_var)", fixed = TRUE) + expect_match(sh, sprintf("|shift| > 1 in %d of %d cell(s), > 2 in %d", + sum(abs(df$kr_shift) > 1, na.rm = TRUE), sum(is.finite(df$kr_shift)), + sum(abs(df$kr_shift) > 2, na.rm = TRUE)), fixed = TRUE) + # The naive standard error is set against the same model, not against kr_var. + two <- is.finite(df$se) + nv <- out[grepl("naive s^2/n", out, fixed = TRUE)] + expect_length(nv, 1L) + expect_match(nv, sprintf("in %d of the %d cell(s) with two or more points", + sum(df$se[two]^2 < df$plain_var[two]), sum(two)), fixed = TRUE) +}) diff --git a/tests/testthat/test-fix-cells-nonfinite.R b/tests/testthat/test-fix-cells-nonfinite.R new file mode 100644 index 00000000..b47ba1a8 --- /dev/null +++ b/tests/testthat/test-fix-cells-nonfinite.R @@ -0,0 +1,160 @@ +# tests/testthat/test-fix-cells-nonfinite.R +# --------------------------------------------------------------------------- +# summarize_by_cell(): an infinite value in a summarised column. +# +# It used to pass as a valid observation everywhere the function counts or +# averages: the cell's mean came back Inf (NaN when both signs met), its SE +# NA, while ..neff_ and cell_weight still counted the row; and under +# deff = "kish" one infinite row set the ICC to 0, so every cell's standard +# error came back uncorrected (0.169 against 1.365). No condition was raised. +# Infinite values are treated as missing now, once, before anything reads the +# columns, with a classed warning that gives the count. +# --------------------------------------------------------------------------- + +# Three cells of 30 with real between-cell differences. +.fn_points <- function(seed = 1) { + set.seed(seed) + id <- rep(1:3, each = 30L) + cx <- c(0, 1000, 2000)[id] + runif(90, 0, 800) + cy <- runif(90, 0, 800) + y <- 10 + c(-1, 0, 1.5)[id] + rnorm(90, sd = 1) + sf::st_as_sf(data.frame(poly_id = id, y = y, x = cx, yy = cy), + coords = c("x", "yy"), crs = 32615) +} +.fn_sac <- function() structure( + 300, class = c("sac_range", "numeric"), + variogram_model = data.frame(model = c("Nug", "Exp"), psill = c(0.2, 0.8), + range = c(0, 200)), + crs = sf::st_crs(32615)) + +.fn_run <- function(expr) { + w <- character(0); cls <- list(); conds <- list() + val <- withCallingHandlers( + expr, + warning = function(c) { + w <<- c(w, conditionMessage(c)); cls[[length(cls) + 1L]] <<- class(c) + conds[[length(conds) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + list(value = val, warnings = w, classes = cls, conditions = conds) +} +# The frame and the attributes a comparison should cover. +.fn_same <- function(a, b) { + expect_equal(as.data.frame(a), as.data.frame(b), tolerance = 1e-12) + expect_equal(attr(a, "icc"), attr(b, "icc"), tolerance = 1e-12) + expect_equal(attr(a, "deff_applied"), attr(b, "deff_applied"), tolerance = 1e-12) +} + +test_that("one Inf in a cell of 30 is left out of every statistic, with one warning", { + pts0 <- .fn_points() + ptsI <- pts0; ptsI$y[5] <- Inf + ptsN <- pts0; ptsN$y[5] <- NA + + res <- .fn_run(summarize_by_cell(ptsI, response_var = "y", conf_level = 0.95, estimate = "mean")) + out <- res$value + expect_equal(out$resp_mean_y[1], mean(pts0$y[1:30][-5]), tolerance = 1e-12) + expect_identical(out$n[1], 30L) + expect_equal(out[["..neff_resp_y"]][1], 29) + expect_equal(out$cell_weight[1], 29) + expect_true(all(is.finite(unlist(out[1, c("..sd_resp_y", "..se_resp_y", + "..ci_lo_resp_y", "..ci_hi_resp_y")])))) + # Exactly one warning, classed, naming 1 row and 1 cell. + expect_length(res$warnings, 1L) + expect_true("spatialkit_nonfinite" %in% res$classes[[1L]]) + expect_match(res$warnings, "1 infinite value\\(s\\) are treated as missing: response 'y' 1 row\\(s\\) in 1 cell\\(s\\)") + expect_identical(res$conditions[[1L]]$n, 1L) + expect_identical(res$conditions[[1L]]$columns, "y") + # The result is the one with that row set to NA. + .fn_same(out, summarize_by_cell(ptsN, response_var = "y", conf_level = 0.95, estimate = "mean")) +}) + +test_that("an Inf row gives the row-as-NA result under every design effect", { + pts0 <- .fn_points() + ptsI <- pts0; ptsI$y[5] <- Inf + ptsN <- pts0; ptsN$y[5] <- NA + + # "kish": the ICC is the clean one, so every cell is corrected. It was 0, + # with deff_applied FALSE and uncorrected SEs on all three cells. + kI <- suppressWarnings(summarize_by_cell(ptsI, "y", deff = "kish", conf_level = 0.95, + estimate = "mean")) + kN <- summarize_by_cell(ptsN, "y", deff = "kish", conf_level = 0.95, estimate = "mean") + .fn_same(kI, kN) + expect_gt(attr(kI, "icc")$resp, 0.5) + expect_true(all(kI$deff_applied)) + expect_gt(kI[["..se_resp_y"]][2], 1) + + # "variogram" with a supplied sac: cell_weight equals ..neff_. + vI <- suppressWarnings(summarize_by_cell(ptsI, "y", deff = "variogram", + sac = .fn_sac(), conf_level = 0.95, estimate = "mean")) + vN <- summarize_by_cell(ptsN, "y", deff = "variogram", sac = .fn_sac(), + conf_level = 0.95, estimate = "mean") + .fn_same(vI, vN) + expect_equal(vI$cell_weight, vI[["..neff_resp_y"]], tolerance = 1e-12) + + # A fixed number. + .fn_same(suppressWarnings(summarize_by_cell(ptsI, "y", deff = 2, conf_level = 0.95, + estimate = "mean")), + summarize_by_cell(ptsN, "y", deff = 2, conf_level = 0.95, estimate = "mean")) +}) + +test_that("user aggregation functions see the same rows as the built-in statistics", { + ptsI <- .fn_points(); ptsI$y[5] <- Inf + # The documented mean, passed explicitly: finite, and inside its interval. + # It was Inf beside a finite SE when only the built-ins were patched. + out <- suppressWarnings(summarize_by_cell( + ptsI, "y", agg_funs = list(mean = function(x) mean(x, na.rm = TRUE)), + conf_level = 0.95)) + expect_true(is.finite(out$resp_mean_y[1])) + expect_gt(out$resp_mean_y[1], out[["..ci_lo_resp_y"]][1]) + expect_lt(out$resp_mean_y[1], out[["..ci_hi_resp_y"]][1]) + # max and sum never see the infinite value. + mx <- suppressWarnings(summarize_by_cell( + ptsI, "y", agg_funs = list(max = function(x) max(x, na.rm = TRUE), + sum = function(x) sum(x, na.rm = TRUE)))) + expect_equal(mx$resp_max_y[1], max(.fn_points()$y[1:30][-5])) + expect_true(is.finite(mx$resp_sum_y[1])) +}) + +test_that("Inf and -Inf in one cell, an Inf in a predictor, and several columns", { + pts0 <- .fn_points() + # Both signs in one cell used to give a mean of NaN. + ptsB <- pts0; ptsB$y[5] <- Inf; ptsB$y[6] <- -Inf + rB <- .fn_run(summarize_by_cell(ptsB, "y", estimate = "mean")) + expect_equal(rB$value$resp_mean_y[1], mean(pts0$y[1:30][-(5:6)]), tolerance = 1e-12) + expect_match(rB$warnings, "2 infinite value\\(s\\).*response 'y' 2 row\\(s\\) in 1 cell\\(s\\)") + expect_equal(rB$value$cell_weight[1], 28) + + # A predictor column behaves the same way, and the response is untouched. + set.seed(2) + ptsD <- pts0; ptsD$p <- rnorm(90); p_clean <- ptsD$p; ptsD$p[70] <- Inf + rD <- .fn_run(summarize_by_cell(ptsD, "y", "p", conf_level = 0.9, estimate = "mean")) + expect_equal(rD$value$pred_mean_p[3], mean(p_clean[61:90][-10]), tolerance = 1e-12) + expect_equal(rD$value[["..neff_pred_p"]][3], 29) + expect_true(is.finite(rD$value[["..se_pred_p"]][3])) + expect_match(rD$warnings, "predictor 'p' 1 row\\(s\\) in 1 cell\\(s\\)") + expect_equal(rD$value$resp_mean_y, summarize_by_cell(pts0, "y", estimate = "mean")$resp_mean_y) + expect_equal(rD$value$cell_weight, rep(30, 3)) + + # Two columns, three cells: still one warning, naming both. + ptsE <- ptsD; ptsE$y[c(5, 40)] <- c(Inf, -Inf) + rE <- .fn_run(summarize_by_cell(ptsE, "y", "p", estimate = "mean")) + expect_length(rE$warnings, 1L) + expect_match(rE$warnings, "3 infinite value\\(s\\) are treated as missing: response 'y' 2 row\\(s\\) in 2 cell\\(s\\); predictor 'p' 1 row\\(s\\) in 1 cell\\(s\\)") + expect_identical(rE$conditions[[1L]]$columns, c("y", "p")) + expect_identical(rE$conditions[[1L]]$n, 3L) +}) + +test_that("data with no infinite value raise nothing and give the same frame", { + pts0 <- .fn_points() + ptsN <- pts0; ptsN$y[c(5, 40)] <- c(NA, NaN) # missing already, as before + for (p in list(pts0, ptsN)) { + res <- .fn_run(summarize_by_cell(p, "y", deff = "kish", conf_level = 0.95, estimate = "mean")) + expect_length(res$warnings, 0L) + } + out <- summarize_by_cell(pts0, "y", conf_level = 0.95, estimate = "mean") + d <- sf::st_drop_geometry(pts0) + expect_equal(out$resp_mean_y, as.numeric(tapply(d$y, d$poly_id, mean)), tolerance = 1e-12) + expect_equal(out[["..se_resp_y"]], + as.numeric(tapply(d$y, d$poly_id, stats::sd)) / sqrt(30), tolerance = 1e-12) + expect_equal(out$cell_weight, rep(30, 3)) +}) diff --git a/tests/testthat/test-fix-cells-variogram-fallback.R b/tests/testthat/test-fix-cells-variogram-fallback.R new file mode 100644 index 00000000..5a141a38 --- /dev/null +++ b/tests/testthat/test-fix-cells-variogram-fallback.R @@ -0,0 +1,150 @@ +# tests/testthat/test-fix-cells-variogram-fallback.R +# --------------------------------------------------------------------------- +# summarize_by_cell(deff = "variogram") when the request cannot be met. +# +# It used to fall back to deff = 1: the uncorrected interval, under the same +# column names, with deff_applied FALSE. That interval has the worst coverage +# of the grand mean (0.41 to 0.64 on real tract layers against 0.93 to 0.96 +# for Kish), and the variogram's range goes unidentified on about half of +# such layers. The fallback is "kish" now, with the classed warning kept and +# a `deff_method` column that says which correction each row carries. +# --------------------------------------------------------------------------- + +# Six cells of 25 points on a correlated field with a cell effect, so the +# Kish ICC is clearly positive. +.fv_field <- function(seed = 77) { + set.seed(seed) + n <- 150 + x <- rep(seq(0, 500, length.out = 6), each = 25) + runif(n, 0, 60) + y <- runif(n, 0, 60) + z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(cbind(x, y))) / 40) + + diag(1e-6, n))) %*% rnorm(n)) + rep(rnorm(6), each = 25) + sf::st_as_sf(data.frame(x = x, y = y, z = z, w = z + rnorm(n), + poly_id = rep(1:6, each = 25)), + coords = c("x", "y"), crs = 32632) +} + +.fv_rejected <- function(reason = "fitted range exceeds the largest lag fitted") { + structure(NA_real_, class = c("sac_range", "numeric"), rejected_reason = reason, + variogram_model = data.frame(model = "Exp", psill = 1, range = 1e6), + crs = sf::st_crs(32632)) +} +.fv_sac <- function(model = data.frame(model = c("Nug", "Exp"), psill = c(0.2, 0.8), + range = c(0, 40))) { + structure(120, class = c("sac_range", "numeric"), variogram_model = model, + crs = sf::st_crs(32632)) +} + +.fv_run <- function(expr) { + w <- character(0); cls <- list(); conds <- list() + val <- withCallingHandlers( + suppressMessages(expr), + warning = function(c) { + w <<- c(w, conditionMessage(c)); cls[[length(cls) + 1L]] <<- class(c) + conds[[length(conds) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + list(value = val, warnings = w, classes = cls, conditions = conds) +} + +test_that("a layer whose variogram range is refused returns Kish standard errors", { + pts <- .fv_field() + # The supplied fit is refused and so is the internal estimate. + local_mocked_bindings(estimate_sac_range = function(...) .fv_rejected()) + res <- .fv_run(summarize_by_cell(pts, "z", deff = "variogram", + sac = .fv_rejected(), conf_level = 0.95, estimate = "mean")) + out <- res$value + kish <- summarize_by_cell(pts, "z", deff = "kish", conf_level = 0.95, estimate = "mean") + iid <- summarize_by_cell(pts, "z", conf_level = 0.95, estimate = "mean") + + # Kish's numbers, not the uncorrected ones. + for (col in c("..se_resp_z", "..neff_resp_z", "..df_resp_z", "..ci_lo_resp_z", + "..ci_hi_resp_z", "cell_weight")) + expect_equal(out[[col]], kish[[col]], tolerance = 1e-12, info = col) + expect_true(all(out[["..se_resp_z"]] > 2 * iid[["..se_resp_z"]])) + expect_true(all(out[["..ci_hi_resp_z"]] - out[["..ci_lo_resp_z"]] > + 2 * (iid[["..ci_hi_resp_z"]] - iid[["..ci_lo_resp_z"]]))) + + # One warning, classed, saying what was applied. + expect_length(res$warnings, 1L) + expect_true("spatialkit_deff_fallback" %in% res$classes[[1L]]) + expect_match(res$warnings, "requires a fitted variogram model") + expect_match(res$warnings, "Falling back to deff = \"kish\" \\(ICC: response 'z' 0\\.[0-9]+\\)") + expect_identical(res$conditions[[1L]]$requested, "variogram") + expect_identical(res$conditions[[1L]]$used, "kish") + + # The rows are labelled, and the label survives binding results together. + expect_identical(out$deff_method, rep("kish (variogram fallback)", 6)) + expect_identical(out$deff_applied, rep(TRUE, 6)) + bound <- dplyr::bind_rows(out, kish) + expect_identical(bound$deff_method, + rep(c("kish (variogram fallback)", "kish"), each = 6)) + # The record names the method used, the one requested and why. + da <- attr(out, "deff_applied") + expect_identical(da$method, "kish") + expect_identical(da$requested, "variogram") + expect_match(da$fallback_reason, "none was available") + expect_null(attr(kish, "deff_applied")$requested) + # The ICC is recorded as for a "kish" request. + expect_equal(attr(out, "icc")$resp, attr(kish, "icc")$resp, tolerance = 1e-12) +}) + +test_that("a model family the variogram route cannot read falls back to Kish too", { + pts <- .fv_field() + mat <- .fv_sac(data.frame(model = c("Nug", "Mat"), psill = c(0.2, 0.8), + range = c(0, 40))) + res <- .fv_run(summarize_by_cell(pts, "z", "w", deff = "variogram", sac = mat, estimate = "mean")) + expect_length(res$warnings, 1L) + expect_true("spatialkit_deff_fallback" %in% res$classes[[1L]]) + expect_match(res$warnings, "the supplied model uses 'Mat'") + expect_match(res$warnings, "Falling back to deff = \"kish\"") + kish <- summarize_by_cell(pts, "z", "w", deff = "kish", estimate = "mean") + expect_equal(res$value[["..se_resp_z"]], kish[["..se_resp_z"]], tolerance = 1e-12) + expect_equal(res$value[["..se_pred_w"]], kish[["..se_pred_w"]], tolerance = 1e-12) + expect_identical(unique(res$value$deff_method), "kish (variogram fallback)") +}) + +test_that("when Kish's ICC is 0 as well, the uncorrected SE is returned and labelled", { + # No cell effect and no spatial structure: the ICC estimate is not positive. + set.seed(5) + n <- 150 + flat <- sf::st_as_sf(data.frame(x = runif(n, 0, 600), y = runif(n, 0, 60), + z = rep(c(-1, 1), length.out = n) + rnorm(n, 0, 0.01), + poly_id = rep(1:6, each = 25)), + coords = c("x", "y"), crs = 32632) + res <- .fv_run(summarize_by_cell(flat, predictor_vars = "z", deff = "variogram", + estimate = "mean")) + expect_length(res$warnings, 1L) + expect_true("spatialkit_deff_fallback" %in% res$classes[[1L]]) + expect_match(res$warnings, "whose ICC is 0 \\(predictor 'z' 0\\.000\\), so the standard errors are the uncorrected ones") + expect_identical(res$conditions[[1L]]$used, "none") + iid <- summarize_by_cell(flat, predictor_vars = "z", estimate = "mean") + expect_equal(res$value[["..se_pred_z"]], iid[["..se_pred_z"]], tolerance = 1e-12) + expect_identical(res$value$deff_applied, rep(FALSE, 6)) + expect_identical(res$value$deff_method, rep("none (variogram fallback)", 6)) + expect_null(attr(res$value, "deff_applied")) + expect_identical(unname(attr(res$value, "icc")$pred), 0) +}) + +test_that("deff_method names the correction on every path", { + pts <- .fv_field() + # No request: no label, the frame is as it always was. + expect_false("deff_method" %in% names(summarize_by_cell(pts, "z", estimate = "mean"))) + expect_identical(unique(summarize_by_cell(pts, "z", deff = "variogram", + sac = .fv_sac(), estimate = "mean")$deff_method), + "variogram") + expect_identical(unique(summarize_by_cell(pts, "z", deff = "kish", + estimate = "mean")$deff_method), "kish") + expect_identical(unique(summarize_by_cell(pts, "z", deff = 2, estimate = "mean")$deff_method), + "fixed") + refused <- suppressWarnings(summarize_by_cell(pts, "z", deff = 0.5, estimate = "mean")) + expect_identical(unique(refused$deff_method), "none") + expect_identical(unique(refused$deff_applied), FALSE) + # Joined to cells, a cell no point fell in has no label, as it has no flag. + sq <- function(x0) sf::st_polygon(list(rbind(c(x0, 0), c(x0 + 60, 0), c(x0 + 60, 60), + c(x0, 60), c(x0, 0)))) + cells <- sf::st_sf(poly_id = 1:7, geometry = sf::st_sfc(lapply(100 * 0:6, sq), + crs = 32632)) + joined <- summarize_by_cell(pts, "z", deff = "kish", cells_sf = cells, estimate = "mean") + expect_identical(joined$deff_method, c(rep("kish", 6), NA)) +}) diff --git a/tests/testthat/test-fix-folds-k-reduced.R b/tests/testthat/test-fix-folds-k-reduced.R new file mode 100644 index 00000000..89569e9b --- /dev/null +++ b/tests/testthat/test-fix-folds-k-reduced.R @@ -0,0 +1,244 @@ +# tests/testthat/test-fix-folds-k-reduced.R +# --------------------------------------------------------------------------- +# make_folds() returning fewer folds than asked. It was a log line only, at +# four sites in three methods, and the result kept no record of the k asked +# for. Each test here fails on the code before the fix. +# --------------------------------------------------------------------------- + +kr_pts <- function(n = 300, side = 1e4, seed = 42) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, side), y = 5e6 + runif(n, 0, side), + z = rnorm(n), a = rnorm(n), + g = sample(letters[1:3], n, TRUE)), + coords = c("x", "y"), crs = 32632) +} + +# Every warning a call raises, with its classes and the condition itself. +kr_collect <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + list(value = val, conditions = w, + messages = vapply(w, conditionMessage, ""), + reduced = Filter(function(c) inherits(c, "spatialkit_k_reduced"), w)) +} + +test_that("each of the four k-reduction sites raises the classed warning", { + u <- kr_pts() + calls <- list( + block_size = function() make_folds(u, k = 5, method = "block_kfold", + block_size = 4000, seed = 1), + block_grid = function() make_folds(u, k = 5, method = "block_kfold", + block_nx = 3, block_ny = 1, seed = 1), + groups = function() make_folds(u, k = 5, method = "leave_location_out", + group_var = "g", seed = 1), + rows = function() make_folds(u[1:7, ], k = 10, method = "random_kfold", + seed = 1)) + got <- c(block_size = 4L, block_grid = 3L, groups = 3L, rows = 7L) + asked <- c(block_size = 5L, block_grid = 5L, groups = 5L, rows = 10L) + for (nm in names(calls)) { + res <- r2_quiet(kr_collect(calls[[nm]]())) + expect_length(res$reduced, 1L) + cnd <- res$reduced[[1L]] + expect_s3_class(cnd, "warning") + # The counts travel on the condition, so a handler need not read text. + expect_identical(cnd$k, got[[nm]], info = nm) + expect_identical(cnd$k_requested, asked[[nm]], info = nm) + expect_match(conditionMessage(cnd), + sprintf("returning %d folds, not the k = %d asked for", got[[nm]], asked[[nm]]), + info = nm) + # ... and on the result, which used to keep no record of the k asked for. + expect_identical(res$value$k, got[[nm]], info = nm) + expect_identical(res$value$params$k_requested, asked[[nm]], info = nm) + expect_length(res$value$folds, got[[nm]]) + } + # tryCatch() by class sees it; it used to be invisible to any handler. + expect_identical( + r2_quiet(tryCatch(calls$block_size(), spatialkit_k_reduced = function(w) "caught")), + "caught") +}) + +test_that("a k that is honoured raises nothing and is recorded as asked", { + u <- kr_pts() + for (f in list( + r2_quiet(expect_no_warning(make_folds(u, k = 5, method = "random_kfold", seed = 1))), + r2_quiet(expect_no_warning(make_folds(u, k = 5, method = "block_kfold", seed = 1))), + r2_quiet(expect_no_warning(make_folds(u, k = 3, method = "leave_location_out", + group_var = "g", seed = 1))))) { + expect_identical(f$k, f$params$k_requested) + } + # The leave-one-out methods take no k; NA says none was given. + loo <- r2_quiet(suppressWarnings(make_folds(u[1:40, ], method = "buffered_loo", buffer = 300))) + expect_true(is.na(loo$params$k_requested)) +}) + +test_that("empty cells lower k once, with one warning that counts the blocks holding points", { + # Four clusters under a 3 x 3 grid: nine cells, four of them occupied. The + # cell count alone promised five folds; four came back and nothing warned. + set.seed(5) + cx <- c(500, 9500, 500, 5000); cy <- c(500, 9500, 9500, 5000); g <- rep(1:4, each = 100) + cl <- sf::st_as_sf(data.frame(x = 5e5 + cx[g] + rnorm(400, 0, 150), + y = 5e6 + cy[g] + rnorm(400, 0, 150)), + coords = c("x", "y"), crs = 32632) + bs <- as.numeric(diff(sf::st_bbox(cl)[c("xmin", "xmax")])) / 3.2 + res <- r2_quiet(kr_collect(make_folds(cl, k = 5, method = "block_kfold", + block_size = bs, seed = 1))) + expect_identical(c(res$value$params$grid_nx, res$value$params$grid_ny), c(3, 3)) + expect_identical(res$value$k, 4L) + expect_length(res$reduced, 1L) + expect_match(res$messages, "3 x 3 grid .* 4 of its blocks hold points") +}) + +test_that("the size the k warning names gives the k it promises", { + u <- kr_pts() + res <- r2_quiet(kr_collect(make_folds(u, k = 5, method = "block_kfold", + block_size = 4000, seed = 1))) + msg <- res$messages[[1L]] + expect_match(msg, "For 5 folds pass block_size = [0-9.]+ \\(the largest that gives 5\\)") + s <- as.numeric(sub(".*For 5 folds pass block_size = ([0-9.]+) .*", "\\1", msg)) + expect_lt(s, 4000) + f <- r2_quiet(expect_no_warning(make_folds(u, k = 5, method = "block_kfold", + block_size = s, seed = 1))) + expect_identical(f$k, 5L) + # "or pass k = 4 to keep these blocks": that works too, quietly. + f4 <- r2_quiet(expect_no_warning(make_folds(u, k = 4, method = "block_kfold", + block_size = 4000, seed = 1))) + expect_identical(f4$k, 4L) +}) + +test_that("the single-block error names a block size that works", { + u <- kr_pts() + err <- tryCatch(r2_quiet(make_folds(u, k = 5, method = "block_kfold", + block_size = 5100, seed = 1)), + error = function(e) conditionMessage(e)) + expect_match(err, "the block size \\(5100\\) produces a single block covering the whole extent") + # It used to say "set auto_range = FALSE", which leads back to the default + # grid and its leakage warning. + expect_no_match(err, "auto_range = FALSE") + expect_match(err, "the largest that gives 5 folds is [0-9.]+") + s <- as.numeric(sub(".*the largest that gives 5 folds is ([0-9.]+)\\.$", "\\1", err)) + f <- r2_quiet(expect_no_warning(make_folds(u, k = 5, method = "block_kfold", + block_size = s, seed = 1))) + expect_identical(f$k, 5L) +}) + +test_that("params records the block size built, not only the size asked", { + u <- kr_pts() + for (bs in c(2600, 3000, 4000)) { + f <- r2_quiet(suppressWarnings(make_folds(u, k = 4, method = "block_kfold", + block_size = bs, seed = 1))) + boxes <- lapply(sf::st_geometry(f$params$blocks), sf::st_bbox) + wd <- vapply(boxes, function(b) b[["xmax"]] - b[["xmin"]], numeric(1)) + ht <- vapply(boxes, function(b) b[["ymax"]] - b[["ymin"]], numeric(1)) + expect_equal(rep(f$params$block_width, length(wd)), wd) + expect_equal(rep(f$params$block_height, length(ht)), ht) + # A minimum edge: built at least as large, and under twice as large. + expect_identical(f$params$block_size, bs) + expect_gte(f$params$block_width, bs); expect_lt(f$params$block_width, 2 * bs) + expect_gte(f$params$block_height, bs); expect_lt(f$params$block_height, 2 * bs) + } + # Supplied blocks have no single width. + cells <- sf::st_as_sf(sf::st_make_grid(u, n = c(3, 3))) + fs <- r2_quiet(make_folds(u, k = 4, method = "block_kfold", blocks = cells, seed = 1)) + expect_true(is.na(fs$params$block_width) && is.na(fs$params$block_height)) +}) + +test_that("an axis shorter than block_size is spanned by one row, shorter than the size", { + # A corridor just under 40 km long (39.8 km between its outermost points) + # and 5 km wide, blocks of 10 km. Three fit along + # it; across it there is no room for one, so a single row spans the width + # and each block is as tall as the extent: half the size asked. "At least + # block_size" holds on the long axis only. + set.seed(4) + cor <- sf::st_as_sf(data.frame(x = 5e5 + runif(300, 0, 40000), y = 5e6 + runif(300, 0, 5000), + a = rnorm(300)), + coords = c("x", "y"), crs = 32632) + bb <- sf::st_bbox(cor) + w <- bb[["xmax"]] - bb[["xmin"]]; h <- bb[["ymax"]] - bb[["ymin"]] + bs <- 10000 + expect_lt(h, bs); expect_gt(w, 3 * bs) + f <- r2_quiet(expect_no_warning(make_folds(cor, k = 3, method = "block_kfold", + block_size = bs, seed = 1))) + p <- f$params + expect_identical(c(p$grid_nx, p$grid_ny), c(3, 1)) + # The long axis: one to under two times the size. + expect_equal(p$block_width, w / 3) + expect_gte(p$block_width, bs); expect_lt(p$block_width, 2 * bs) + # The short axis: the extent itself, which is below the size. + expect_equal(p$block_height, h) + expect_lt(p$block_height, bs) + # params describes the polygons returned. + boxes <- lapply(sf::st_geometry(p$blocks), sf::st_bbox) + expect_equal(vapply(boxes, function(b) b[["xmax"]] - b[["xmin"]], numeric(1)), + rep(p$block_width, 3)) + expect_equal(vapply(boxes, function(b) b[["ymax"]] - b[["ymin"]], numeric(1)), + rep(p$block_height, 3)) + + # A response with a range of about 9 km, wider than the corridor. + D <- as.matrix(stats::dist(sf::st_coordinates(cor))) + cor$z <- as.numeric(t(chol(exp(-3 * D / 9000) + diag(1e-8, 300))) %*% rnorm(300)) + + rnorm(300, 0, 0.3) + + # The sweep's table reports the same cells. + sw <- r2_quiet(suppressWarnings(suppressMessages( + cv_block_size_sweep(cor, "z", "a", fit_fn = r2_fit, block_sizes = bs, k = 3, + include_random = FALSE, sac = 6000, quiet = TRUE)))) + expect_equal(sw$block_width, w / 3) + expect_equal(sw$block_height, h) + expect_lt(sw$block_height, sw$block_size) + + # auto_range on the same corridor: a range above the corridor's width gets + # one row of blocks as tall as the corridor, so shorter than the range, + # and the message says what is built. + msgs <- character(0) + a <- r2_quiet(suppressWarnings(withCallingHandlers( + make_folds(cor, k = 4, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1), + message = function(m) { msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") }))) + rng <- as.numeric(a$params$sac_range) + # The estimate is 6044 where this was written; the check needs only that + # it is above the corridor's width (4969). + skip_if(!(is.finite(rng) && rng > h), + "the estimated range is not above the corridor's width on this platform") + expect_identical(a$params$grid_ny, 1) + expect_equal(a$params$block_height, h) + expect_lt(a$params$block_height, rng) + expect_gte(a$params$block_width, rng); expect_lt(a$params$block_width, 2 * rng) + expect_match(msgs[grepl("estimated spatial autocorrelation range", msgs)], + sprintf("a %s x 1 grid of blocks %s wide and %s tall", + format(a$params$grid_nx), format(signif(a$params$block_width, 4)), + format(signif(h, 4)))) +}) + +test_that("a cv_*() call that builds fewer folds passes the classed warning on", { + u <- kr_pts() + res <- r2_quiet(kr_collect(suppressMessages( + cv_spatial(u, "z", "a", fit_fn = r2_fit, k = 5, block_size = 4000, seed = 1)))) + expect_identical(res$value$n_folds_attempted, 4L) + expect_length(res$reduced, 1L) +}) + +test_that("cv_block_size_sweep() gathers the k reductions into one warning", { + # Four clusters: at the coarser sizes fewer than k blocks hold points. + set.seed(5) + cx <- c(500, 9500, 500, 5000); cy <- c(500, 9500, 9500, 5000); g <- rep(1:4, each = 30) + cl <- sf::st_as_sf(data.frame(x = 5e5 + cx[g] + rnorm(120, 0, 400), + y = 5e6 + cy[g] + rnorm(120, 0, 400), + a = rnorm(120)), + coords = c("x", "y"), crs = 32632) + cl$z <- cl$a + rnorm(120) + res <- r2_quiet(kr_collect(suppressMessages( + cv_block_size_sweep(cl, "z", "a", fit_fn = r2_fit, block_sizes = c(600, 3000), + k = 5, include_random = FALSE, sac = 1000, quiet = TRUE)))) + sw <- res$value + expect_true(any(sw$k < 5L)) + # One warning from the sweep, none passed through from make_folds(). + expect_length(res$reduced, 0L) + hit <- grepl("cv_block_size_sweep\\(\\): fewer than the k = 5 folds asked for in 1 of the 2 cross-validations \\(block size 3000: 4 folds\\)", + res$messages) + expect_identical(sum(hit), 1L) + # The table says what was built at each size. + expect_true(all(c("block_width", "block_height") %in% names(sw))) + expect_true(all(sw$block_width >= sw$block_size & sw$block_width < 2 * sw$block_size)) +}) diff --git a/tests/testthat/test-fix-folds-knndm.R b/tests/testthat/test-fix-folds-knndm.R new file mode 100644 index 00000000..68d26e44 --- /dev/null +++ b/tests/testthat/test-fix-folds-knndm.R @@ -0,0 +1,528 @@ +# tests/testthat/test-fix-folds-knndm.R +# --------------------------------------------------------------------------- +# make_folds(method = "knndm"): k folds matched to the distances from the +# prediction points to the data (Linnenbrink et al. 2024). Distance-matched +# folds existed only as leave-one-out, refused above 5,000 rows. The +# candidates are a random partition and clusterings of the samples packed +# into k folds; the one whose held-out distances are closest to the target +# (smallest Wasserstein distance W) is returned. +# --------------------------------------------------------------------------- + +kn_pts <- function(xy) sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2]), + coords = c("x", "y"), crs = 32632) +kn_box_grid <- function(lo = 0, hi = 1e4, m = 30) + kn_pts(as.matrix(expand.grid(seq(lo, hi, length.out = m), seq(lo, hi, length.out = m)))) +kn_uniform <- function(n, seed) { set.seed(seed); cbind(runif(n, 0, 1e4), runif(n, 0, 1e4)) } +kn_clustered <- function(n, seed, nc = 12) { + set.seed(seed) + c0 <- cbind(runif(nc, 1000, 9000), runif(nc, 1000, 9000)); i <- sample(nc, n, TRUE) + pmin(pmax(c0[i, ] + matrix(rnorm(2 * n, 0, 600), n), 0), 1e4) +} +kn_collect <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + list(value = val, warnings = w, + classes = vapply(w, function(c) class(c)[1L], "")) +} +kn_ns <- function(name) get(name, envir = asNamespace("spatialkit")) + +test_that("knndm returns k folds that partition the rows", { + pts <- kn_pts(kn_clustered(300, 1)) + f <- r2_quiet(make_folds(pts, k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = 1)) + expect_identical(f$method, "knndm") + expect_identical(f$k, 5L) + expect_length(f$folds, 5L) + tests <- unlist(lapply(f$folds, `[[`, "test")) + expect_setequal(tests, seq_len(300)) + expect_false(anyDuplicated(tests) > 0) + for (s in f$folds) { + expect_length(intersect(s$train, s$test), 0L) + expect_setequal(c(s$train, s$test), seq_len(300)) + } + # `assignment` says the same thing as the splits. + expect_identical(f$assignment$row_id, seq_len(300)) + for (j in 1:5) + expect_setequal(f$assignment$row_id[f$assignment$fold == j], f$folds[[j]]$test) + p <- f$params + expect_identical(p$k_requested, 5L) + expect_identical(p$fold_sizes, tabulate(f$assignment$fold, 5L)) + expect_length(p$realised_distances, 300L) + expect_length(p$target_distances, 900L) + expect_identical(p$crs, "EPSG:32632") + expect_identical(p$clustering, "ward") +}) + +test_that("the realised distances are each point's distance to the nearest point of another fold", { + xy <- kn_clustered(200, 2) + f <- r2_quiet(make_folds(kn_pts(xy), k = 4, method = "knndm", + prediction_points = kn_box_grid(), seed = 2)) + lab <- f$assignment$fold + D <- as.matrix(stats::dist(xy)) + by_hand <- vapply(seq_len(200), function(i) min(D[i, lab != lab[i]]), 0) + expect_equal(f$params$realised_distances, by_hand) + expect_equal(f$params$realised_median, stats::median(by_hand)) + # The target is the distance from each prediction point to its nearest sample. + g <- sf::st_coordinates(kn_box_grid()) - cbind(rep(5e5, 900), rep(5e6, 900)) + tg <- vapply(seq_len(900), function(i) sqrt(min((xy[, 1] - g[i, 1])^2 + (xy[, 2] - g[i, 2])^2)), 0) + expect_equal(f$params$target_distances, tg) +}) + +test_that("W of the folds returned is never above W of its own random candidate", { + for (seed in 1:4) for (layout in c("uniform", "clustered")) { + xy <- if (layout == "uniform") kn_uniform(250, seed) else kn_clustered(250, seed) + f <- r2_quiet(suppressWarnings(make_folds( + kn_pts(xy), k = 5, method = "knndm", prediction_points = kn_box_grid(), + seed = seed))) + p <- f$params; info <- paste(layout, seed) + expect_lte(p$wasserstein, p$wasserstein_random, label = info) + # The random partition is the first candidate, and is always admissible. + expect_identical(p$candidates$candidate[1L], "random", info = info) + expect_true(p$candidates$admissible[1L], info = info) + expect_equal(p$candidates$W[1L], p$wasserstein_random, info = info) + # What is returned is the smallest W among the admissible candidates. + expect_equal(p$wasserstein, min(p$candidates$W[p$candidates$admissible]), info = info) + # W is the Wasserstein distance between the two sets of distances. + expect_equal(p$wasserstein, + kn_ns(".fold_sep_compare")(p$realised_distances, p$target_distances)$w1, + info = info) + # A candidate that was set aside was not scored. + expect_true(all(is.na(p$candidates$W[!p$candidates$admissible])), info = info) + } +}) + +test_that("clustering brings the folds closer to the target than a random partition on clustered samples", { + # 12 clusters predicted onto a grid over the box: a random partition keeps + # a neighbour of every held-out point in training. + ratio <- vapply(1:4, function(seed) { + p <- r2_quiet(make_folds(kn_pts(kn_clustered(300, seed)), k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = seed))$params + expect_identical(p$chosen, "clusters") + expect_true(p$n_clusters >= 5L) + p$wasserstein / p$wasserstein_random + }, 0) + expect_lt(max(ratio), 0.9) +}) + +test_that("the random candidate is the partition random_kfold builds from the same seed", { + # Prediction points 5 m from the samples: no clustering comes closer than + # the random partition, which is what comes back. + xy <- kn_uniform(150, 3) + set.seed(30); near <- kn_pts(xy + matrix(rnorm(300, 0, 5), 150)) + f <- r2_quiet(suppressWarnings(make_folds(kn_pts(xy), k = 5, method = "knndm", + prediction_points = near, seed = 11))) + expect_identical(f$params$chosen, "random") + expect_true(is.na(f$params$n_clusters)) + r <- make_folds(kn_pts(xy), k = 5, method = "random_kfold", seed = 11) + expect_identical(f$assignment$fold, r$assignment$fold) + expect_equal(f$params$wasserstein, f$params$wasserstein_random) + # And for a fold count that does not divide n. + set.seed(5); lab <- kn_ns(".random_fold_labels")(23L, 4L) + r2 <- make_folds(kn_pts(xy[1:23, ]), k = 4, method = "random_kfold", seed = 5) + expect_identical(lab, r2$assignment$fold) +}) + +test_that("fold sizes stay within balance_tol, which is a limit for knndm", { + # Four clusters of very different sizes: few clusters per fold is uneven. + set.seed(4) + c0 <- cbind(c(2000, 8000, 2000, 8000), c(2000, 2000, 8000, 8000)) + i <- sample(4, 240, TRUE, prob = c(0.55, 0.25, 0.15, 0.05)) + pts <- kn_pts(c0[i, ] + matrix(rnorm(480, 0, 400), 240)) + far <- kn_box_grid(-1e4, 2e4) + loose <- r2_quiet(suppressWarnings(make_folds(pts, k = 3, method = "knndm", + prediction_points = far, seed = 1))) + expect_lte(loose$params$balance_ratio, 3) + expect_identical(loose$params$balance_tol, 3) + tight <- r2_quiet(suppressWarnings(make_folds(pts, k = 3, method = "knndm", + prediction_points = far, seed = 1, + balance_tol = 1.1))) + expect_lte(tight$params$balance_ratio, 1.1) + expect_equal(tight$params$balance_ratio, + max(tight$params$fold_sizes) / min(tight$params$fold_sizes)) + # The limit set candidates aside, and those are the ones past it. + cd <- tight$params$candidates + cl <- cd[cd$candidate == "clusters" & !is.na(cd$balance_ratio), ] + expect_true(any(!cl$admissible)) + expect_true(all(cl$balance_ratio[cl$admissible] <= 1.1)) + # With the limit lifted the uneven candidates are scored, and the match is + # at least as close. + free <- r2_quiet(suppressWarnings(make_folds(pts, k = 3, method = "knndm", + prediction_points = far, seed = 1, + balance_tol = Inf))) + expect_lte(free$params$wasserstein, tight$params$wasserstein) + # On the default tolerance over several clustered draws. + for (seed in 1:5) { + p <- r2_quiet(suppressWarnings(make_folds( + kn_pts(kn_clustered(200, seed, nc = 5)), k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = seed)))$params + expect_lte(p$balance_ratio, 3, label = paste("seed", seed)) + } +}) + +test_that("min_train caps the largest fold, and a value no k folds can meet is an error", { + pts <- kn_pts(kn_clustered(200, 6, nc = 3)) + far <- kn_box_grid(-1e4, 2e4) + # Two folds at the default 0.5: each fold is exactly half. + two <- r2_quiet(suppressWarnings(make_folds(pts, k = 2, method = "knndm", + prediction_points = far, seed = 1))) + expect_identical(sort(two$params$fold_sizes), c(100L, 100L)) + # A lower floor admits uneven halves. + low <- r2_quiet(suppressWarnings(make_folds(pts, k = 2, method = "knndm", + prediction_points = far, seed = 1, + min_train = 0.3))) + expect_lte(max(low$params$fold_sizes), 140L) + expect_gt(sum(low$params$candidates$admissible), sum(two$params$candidates$admissible)) + expect_lte(low$params$wasserstein, two$params$wasserstein) + expect_error(make_folds(pts, k = 5, method = "knndm", prediction_points = far, + min_train = 0.9), + "min_train = 0.9 cannot be met with k = 5 folds.*min_train <= 0.8") + expect_error(make_folds(pts, k = 5, method = "knndm", prediction_points = far, + min_train = 1), + "`min_train` must be a single number in \\(0, 1\\)") +}) + +test_that("a seed makes knndm reproducible, and the row order of the result is the input's", { + pts <- kn_pts(kn_clustered(250, 7)) + a <- r2_quiet(make_folds(pts, k = 5, method = "knndm", prediction_points = kn_box_grid(), seed = 9)) + b <- r2_quiet(make_folds(pts, k = 5, method = "knndm", prediction_points = kn_box_grid(), seed = 9)) + expect_identical(a$assignment, b$assignment) + expect_identical(a$params$candidates, b$params$candidates) + # The session RNG is left where it was. + set.seed(1); r1 <- runif(1) + set.seed(1); invisible(r2_quiet(make_folds(pts, k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = 9))) + expect_identical(runif(1), r1) + # Row IDs that are not 1..n travel through the splits. + pts$..row_id <- 1000L + seq_len(250) + d <- r2_quiet(make_folds(pts, k = 5, method = "knndm", prediction_points = kn_box_grid(), seed = 9)) + expect_setequal(unlist(lapply(d$folds, `[[`, "test")), 1000L + seq_len(250)) + expect_identical(d$assignment$fold, a$assignment$fold) +}) + +test_that("prediction points nearer than any fold can reach raise the out-of-reach warning", { + xy <- kn_uniform(200, 8) + set.seed(80); near <- kn_pts(xy + matrix(rnorm(400, 0, 5), 200)) + res <- r2_quiet(kn_collect(make_folds(kn_pts(xy), k = 5, method = "knndm", + prediction_points = near, seed = 1))) + expect_identical(res$classes, "spatialkit_nndm_out_of_reach") + cnd <- res$warnings[[1L]]; p <- res$value$params + expect_match(conditionMessage(cnd), "nearer to the data than any fold can hold a point out") + # What comes back is the random partition or a candidate as fine as one: + # nothing coarser can be nearer. + expect_match(conditionMessage(cnd), "the 5 folds returned \\((the random partition|19[0-9] clusters)") + expect_true(p$chosen == "random" || p$n_clusters >= 190L) + expect_match(conditionMessage(cnd), "pessimistic for these prediction locations, an upper bound") + expect_true(p$target_out_of_reach) + expect_false(p$short_of_target) + expect_equal(cnd$deficit, p$loo_ecdf_deficit) + expect_equal(cnd$tolerance, p$ecdf_deficit_tol) + expect_equal(p$ecdf_deficit_tol, 3 * sqrt(1 / 200 + 1 / 200)) + # The same rule, on the same two sets of distances, as method = "nndm". + nn <- r2_quiet(suppressWarnings(make_folds(kn_pts(xy), method = "nndm", + prediction_points = near)))$params + expect_equal(p$loo_ecdf_deficit, nn$loo_ecdf_deficit) + expect_equal(p$wasserstein_loo, nn$wasserstein_loo) + expect_identical(p$target_separated, nn$target_separated) + # A k-fold partition trains on fewer points than leave-one-out, so it is + # no nearer to this target. + expect_gte(p$wasserstein, p$wasserstein_loo) +}) + +test_that("a grid over evenly spread samples raises no warning", { + for (seed in 1:5) { + pts <- kn_pts(kn_uniform(300, seed)) + bb <- sf::st_bbox(pts) + grid <- sf::st_as_sf(expand.grid(x = seq(bb[["xmin"]], bb[["xmax"]], length.out = 30), + y = seq(bb[["ymin"]], bb[["ymax"]], length.out = 30)), + coords = c("x", "y"), crs = 32632) + res <- r2_quiet(kn_collect(make_folds(pts, k = 5, method = "knndm", + prediction_points = grid, seed = seed))) + expect_length(res$warnings, 0L) + expect_false(res$value$params$target_out_of_reach) + expect_false(res$value$params$short_of_target) + # The folds sit within a third of the target mean of the target (0.05 + # to 0.22 over these draws; a random partition on clustered samples is + # at 0.7). + expect_lt(res$value$params$wasserstein / res$value$params$target_mean, 1 / 3) + } +}) + +test_that("prediction points well beyond the samples raise the short-of-target warning", { + pts <- kn_pts(kn_clustered(300, 9)) + res <- r2_quiet(kn_collect(make_folds(pts, k = 5, method = "knndm", + prediction_points = kn_box_grid(-1e4, 2e4), + seed = 1))) + expect_identical(res$classes, "spatialkit_knndm_short_of_target") + cnd <- res$warnings[[1L]]; p <- res$value$params + expect_true(p$short_of_target) + expect_false(p$target_out_of_reach) + expect_match(conditionMessage(cnd), "still short of the target") + expect_match(conditionMessage(cnd), "tends to read low for these prediction locations") + expect_match(conditionMessage(cnd), "upper bound on performance") + # Five folds of twelve clusters: the candidate kept is the coarsest the + # two limits allow, and the message says which limits. + expect_match(conditionMessage(cnd), "the coarsest clustering allowed") + expect_match(conditionMessage(cnd), "min_train = 0.5") + expect_match(conditionMessage(cnd), "Fewer folds hold out larger regions") + expect_equal(cnd$held_out_mean, p$realised_mean) + expect_equal(cnd$target_mean, p$target_mean) + expect_equal(p$realised_mean, mean(p$realised_distances)) + expect_equal(p$target_mean, mean(p$target_distances)) + # The rule: the mean held-out distance is more than a quarter below the + # target's, and that shift is at least half of W. + expect_lt(p$realised_mean, 0.75 * p$target_mean) + expect_gte(p$target_mean - p$realised_mean, 0.5 * p$wasserstein) + # It is still the closest candidate. + expect_lte(p$wasserstein, p$wasserstein_random) + # A wider area is matched by coarser clusters than the samples' own extent. + own <- r2_quiet(make_folds(pts, k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = 1))$params + expect_false(own$short_of_target) + expect_lt(p$n_clusters, own$n_clusters) + expect_gt(p$realised_median, own$realised_median) +}) + +test_that("k is required, raised from 1 and lowered to n with the classed warning", { + pts <- kn_pts(kn_uniform(8, 10)) + grid <- kn_box_grid(m = 6) + expect_error(make_folds(pts, method = "knndm", prediction_points = grid), + "`k` \\(the number of folds\\) is required for method = \"knndm\"") + one <- r2_quiet(suppressWarnings(make_folds(pts, k = 1, method = "knndm", + prediction_points = grid, seed = 1))) + expect_identical(one$k, 2L) + res <- r2_quiet(kn_collect(make_folds(pts, k = 20, method = "knndm", + prediction_points = grid, seed = 1))) + red <- Filter(function(c) inherits(c, "spatialkit_k_reduced"), res$warnings) + expect_length(red, 1L) + expect_identical(red[[1L]]$k_requested, 20L) + expect_identical(red[[1L]]$k, 8L) + expect_match(conditionMessage(red[[1L]]), "returning 8 folds, not the k = 20 asked for") + expect_identical(res$value$k, 8L) + expect_identical(res$value$params$k_requested, 20L) + # One point per fold is leave-one-out: the held-out distance is the + # distance to the nearest other sample. + D <- as.matrix(stats::dist(sf::st_coordinates(pts))); diag(D) <- Inf + expect_equal(res$value$params$realised_distances, unname(apply(D, 1, min))) + expect_error(make_folds(kn_pts(kn_uniform(2, 1)), k = 2, method = "knndm", + prediction_points = grid), + "need at least 3 points") +}) + +test_that("prediction_points are required, and cells are reduced to points", { + pts <- kn_pts(kn_clustered(120, 11)) + expect_error(make_folds(pts, k = 4, method = "knndm"), + "make_folds\\(knndm\\): `prediction_points` is required") + cells <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox(pts)), n = c(12, 12)) + centres <- sf::st_centroid(cells) + a <- r2_quiet(suppressWarnings(make_folds(pts, k = 4, method = "knndm", + prediction_points = cells, seed = 2))) + b <- r2_quiet(suppressWarnings(make_folds(pts, k = 4, method = "knndm", + prediction_points = centres, seed = 2))) + expect_equal(a$params$target_distances, b$params$target_distances) + expect_identical(a$assignment$fold, b$assignment$fold) + expect_identical(a$params$n_prediction_points, 144L) + # The arguments of the other methods are refused or unused, not half-read. + expect_error(make_folds(pts, k = 4, method = "knndm", prediction_points = centres, + max_test = 10), + "`max_test` is only used by the leave-one-out methods") + expect_error(make_folds(pts, k = 4, method = "knndm", prediction_points = centres, + blocks = cells), + "`blocks` is only used by method = \"block_kfold\"") +}) + +test_that("above the Ward limit the samples are grouped by k-means and Ward carries on", { + core <- kn_ns(".knndm_folds") + xy <- kn_clustered(600, 12) + g <- sf::st_coordinates(kn_box_grid()) - cbind(rep(5e5, 900), rep(5e6, 900)) + D <- sqrt(outer(g[, 1], xy[, 1], "-")^2 + outer(g[, 2], xy[, 2], "-")^2) + tg <- apply(D, 1, min) + # Without FNN: the search falls back to sf. No skip, so this path runs on + # every machine. + set.seed(3); small <- core(xy, tg, k = 5, ward_max = 150L, use_fnn = FALSE) + expect_identical(small$clustering, "kmeans+ward") + expect_setequal(unique(small$fold), 1:5) + cd <- small$candidates + expect_identical(cd$candidate[1L], "random") + expect_equal(cd$W[small$chosen], min(cd$W[cd$admissible])) + expect_lte(cd$W[small$chosen], small$w_random) + # Cluster counts above the 150 groups were tried too (k-means runs of + # their own), and none has more clusters than distinct points. + expect_true(any(cd$n_clusters > 150L, na.rm = TRUE)) + expect_true(all(cd$n_clusters < 600L, na.rm = TRUE)) + expect_lt(cd$W[small$chosen], small$w_random) + # The held-out distances returned are those of the folds returned. + Dx <- as.matrix(stats::dist(xy)) + by_hand <- vapply(seq_len(600), function(i) min(Dx[i, small$fold != small$fold[i]]), 0) + expect_equal(small$realised, by_hand) + # Ward on all points for comparison: the same kind of answer. + set.seed(3); full <- core(xy, tg, k = 5, use_fnn = FALSE) + expect_identical(full$clustering, "ward") + expect_lt(abs(cd$W[small$chosen] - full$candidates$W[full$chosen]) / mean(tg), 0.15) +}) + +test_that("the FNN and sf searches give the same folds", { + skip_if_not_installed("FNN") + core <- kn_ns(".knndm_folds") + xy <- kn_clustered(500, 13) + g <- sf::st_coordinates(kn_box_grid()) - cbind(rep(5e5, 900), rep(5e6, 900)) + tg <- FNN::get.knnx(xy, g, k = 1)$nn.dist[, 1] + for (wm in c(4000L, 120L)) { + set.seed(4); a <- core(xy, tg, k = 5, ward_max = wm, use_fnn = TRUE) + set.seed(4); b <- core(xy, tg, k = 5, ward_max = wm, use_fnn = FALSE) + expect_identical(a$fold, b$fold, info = paste("ward_max", wm)) + expect_equal(a$candidates$W, b$candidates$W, info = paste("ward_max", wm)) + expect_equal(a$realised, b$realised, info = paste("ward_max", wm)) + expect_equal(a$loo_distances, b$loo_distances, info = paste("ward_max", wm)) + } +}) + +test_that("the nearest-other-point distance without FNN is exact, duplicates included", { + loo <- kn_ns(".loo_dist_xy") + for (n in c(2L, 3L, 5L, 64L, 97L)) { + set.seed(n); xy <- cbind(runif(n), runif(n)) + D <- as.matrix(stats::dist(xy)); diag(D) <- Inf + expect_equal(loo(xy, use_fnn = FALSE), unname(apply(D, 1, min)), info = paste("n", n)) + } + # A co-located pair is at distance 0 from each other. + set.seed(1); xy <- cbind(runif(20), runif(20)); xy <- rbind(xy, xy[c(3, 3, 7), ]) + D <- as.matrix(stats::dist(xy)); diag(D) <- Inf + expect_equal(loo(xy, use_fnn = FALSE), unname(apply(D, 1, min))) + skip_if_not_installed("FNN") + expect_equal(loo(xy, use_fnn = TRUE), unname(apply(D, 1, min))) +}) + +test_that("Ward's method continued from groups reproduces the cuts of the full tree", { + set.seed(14); xy <- cbind(runif(300), runif(300)) + full <- stats::hclust(stats::dist(xy), method = "ward.D2") + grp <- stats::cutree(full, k = 60) + part <- kn_ns(".ward_from_groups")(xy, grp) + for (q in c(2L, 3L, 7L, 20L, 45L, 59L)) { + a <- stats::cutree(full, k = q); b <- stats::cutree(part, k = q)[grp] + # The same partition, whatever the labels. + expect_identical(length(unique(paste(a, b))), q, info = paste("q", q)) + } +}) + +test_that("largest-first packing gives each block to the fold with the fewest points", { + pack <- kn_ns(".pack_largest_first") + set.seed(1); p <- pack(c(5L, 4L, 3L, 3L, 1L), 2L) + expect_identical(p$order, c(1L, 2L, 3L, 4L, 5L)) + # 5 | 4, then 3 to the fold at 4, 3 to the fold at 5, 1 to either fold at 8. + expect_identical(sort(p$loads), c(8L, 8L)) + expect_true(p$fold_of[1L] != p$fold_of[2L]) + expect_identical(p$fold_of[3L], p$fold_of[2L]) + expect_identical(p$fold_of[4L], p$fold_of[1L]) + expect_identical(as.integer(tapply(c(5L, 4L, 3L, 3L, 1L), factor(p$fold_of, 1:2), sum)), + p$loads) + # One block per fold when there are as many folds as blocks. + set.seed(2); q <- pack(c(2L, 9L, 4L), 3L) + expect_setequal(q$fold_of, 1:3) + expect_identical(sort(q$loads), c(2L, 4L, 9L)) +}) + +test_that("co-located samples and few distinct locations do not break knndm", { + set.seed(15) + base <- cbind(runif(30, 0, 1e4), runif(30, 0, 1e4)) + xy <- base[sample(30, 120, TRUE), ] # repeated measurements + f <- r2_quiet(suppressWarnings(make_folds(kn_pts(xy), k = 4, method = "knndm", + prediction_points = kn_box_grid(), seed = 1))) + expect_setequal(unlist(lapply(f$folds, `[[`, "test")), seq_len(120)) + expect_true(all(is.finite(f$params$realised_distances))) + expect_true(all(f$params$candidates$n_clusters < 30L, na.rm = TRUE)) + # Fewer distinct locations than folds leaves the random partition only. + two <- kn_pts(rbind(base[rep(1, 6), ], base[rep(2, 6), ])) + g <- r2_quiet(suppressWarnings(make_folds(two, k = 4, method = "knndm", + prediction_points = kn_box_grid(m = 6), seed = 1))) + expect_identical(g$params$chosen, "random") + expect_true(is.na(g$params$clustering)) + expect_identical(nrow(g$params$candidates), 1L) +}) + +test_that("fold_separation reads knndm folds against the target they carry", { + pts <- kn_pts(kn_clustered(300, 16)) + f <- r2_quiet(make_folds(pts, k = 5, method = "knndm", + prediction_points = kn_box_grid(), seed = 1)) + fs <- r2_quiet(fold_separation(f, pts)) + tg <- attr(fs, "target") + expect_identical(attr(fs, "method"), "knndm") + expect_identical(tg$source, "the prediction points the kNNDM folds were built for") + expect_identical(tg$basis, "all sites") + expect_identical(tg$n_prediction_points, 900L) + expect_equal(tg$w1, f$params$wasserstein) + expect_equal(tg$held_out_mean, f$params$realised_mean) + expect_false(tg$nndm_out_of_reach) + expect_true(tg$reading %in% c("closer", "farther", "matched", "mixed")) + out <- paste(capture.output(print(fs)), collapse = " ") + expect_match(out, "Fold separation: knndm, 5 fold") + expect_match(out, "the prediction points the kNNDM folds were built for") + # Out of reach: the print says why no fold design gets there. + xy <- kn_uniform(150, 17) + set.seed(170); near <- kn_pts(xy + matrix(rnorm(300, 0, 5), 150)) + nf <- r2_quiet(suppressWarnings(make_folds(kn_pts(xy), k = 5, method = "knndm", + prediction_points = near, seed = 1))) + ns <- r2_quiet(fold_separation(nf, kn_pts(xy))) + expect_true(attr(ns, "target")$nndm_out_of_reach) + expect_identical(attr(ns, "target")$reading, "farther") + expect_match(gsub("\\s+", " ", paste(capture.output(print(ns)), collapse = " ")), + "kNNDM cannot match prediction points this near to the data") +}) + +test_that("knndm folds run through cv_spatial, and on even samples score like random folds", { + # The mean over draws, not each draw: a single draw differs by several + # percent either way. + knn_fit <- function(train_sf, ...) new_spatial_fit( + subclass = "kn_knnsurf_fit", + engine = list(xy = sf::st_coordinates(train_sf), y = train_sf$z), + formula = z ~ 1, response_var = "z", predictor_vars = character(0), + data_sf = train_sf) + predict.kn_knnsurf_fit <- function(object, newdata = NULL, ...) { + e <- object$engine + q <- if (is.null(newdata)) e$xy else sf::st_coordinates(newdata) + vapply(seq_len(nrow(q)), function(i) { + d <- (e$xy[, 1] - q[i, 1])^2 + (e$xy[, 2] - q[i, 2])^2 + mean(e$y[order(d)[seq_len(min(5L, length(d)))]]) + }, 0) + } + registerS3method("predict", "kn_knnsurf_fit", predict.kn_knnsurf_fit) + ratio <- vapply(1:6, function(seed) { + set.seed(seed); n <- 200 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(xy)) / 60) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = 0.3) + pts <- sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], z = z), + coords = c("x", "y"), crs = 32632) + grid <- kn_pts(as.matrix(expand.grid(seq(17, 983, length.out = 25), + seq(17, 983, length.out = 25)))) + fk <- r2_quiet(make_folds(pts, k = 5, method = "knndm", prediction_points = grid, seed = seed)) + fr <- make_folds(pts, k = 5, method = "random_kfold", seed = seed) + rmse <- function(f) r2_quiet(suppressWarnings(cv_spatial( + pts, "z", character(0), fit_fn = knn_fit, folds = f, seed = 1)))$overall$RMSE + ck <- r2_quiet(suppressWarnings(cv_spatial(pts, "z", character(0), fit_fn = knn_fit, + folds = fk, seed = 1))) + expect_identical(ck$n_folds_succeeded, 5L) + ck$overall$RMSE / rmse(fr) + }, 0) + expect_lt(abs(mean(ratio) - 1), 0.05) +}) + +test_that("the messages that used to stop at the nndm row limit now name knndm", { + set.seed(18) + big <- kn_pts(cbind(runif(5001, 0, 1e5), runif(5001, 0, 1e5))) + grid <- kn_box_grid(0, 1e5, m = 20) + expect_error(make_folds(big, method = "nndm", prediction_points = grid), + "exceeds the safety threshold of 5000.*method = \"knndm\", which matches k folds") + other <- kn_ns(".block_other_method") + expect_match(other(5001L), "method = \"knndm\" does not depend on a block size") + expect_match(other(5001L), "takes at most 5000 rows, and this layer has 5001") + expect_match(other(5000L), "method = \"nndm\" does not depend on a block size") + # And the method that was pointed to runs on that layer. + f <- r2_quiet(suppressWarnings(make_folds(big, k = 5, method = "knndm", + prediction_points = grid, seed = 1))) + expect_identical(f$k, 5L) + expect_identical(f$params$clustering, "kmeans+ward") + expect_lte(f$params$wasserstein, f$params$wasserstein_random) + expect_lte(f$params$balance_ratio, 3) + expect_setequal(unlist(lapply(f$folds, `[[`, "test")), seq_len(5001)) +}) diff --git a/tests/testthat/test-fix-folds-leakage-advice.R b/tests/testthat/test-fix-folds-leakage-advice.R new file mode 100644 index 00000000..f27566e7 --- /dev/null +++ b/tests/testthat/test-fix-folds-leakage-advice.R @@ -0,0 +1,177 @@ +# tests/testthat/test-fix-folds-leakage-advice.R +# --------------------------------------------------------------------------- +# The leakage warning of make_folds(method = "block_kfold") ended "Pass +# block_size = or auto_range = TRUE" whatever the layout. On a +# square extent at k = 5 that gives five folds only for a range up to a third +# of the side: up to a half it returned four folds without a warning, and +# above it both settings stopped with the single-block error. The advice is +# now worked out for the layout, and these tests do what it says. +# --------------------------------------------------------------------------- + +la_layout <- function(kind, n = 400, w = 1e5, h = 1e5, seed = 1) { + set.seed(seed) + xy <- if (kind == "uniform") cbind(runif(n, 0, w), runif(n, 0, h)) else { + c0 <- cbind(runif(6, 0.1 * w, 0.9 * w), runif(6, 0.1 * h, 0.9 * h)) + i <- sample(6, n, TRUE) + c0[i, ] + cbind(rnorm(n, 0, 0.03 * w), rnorm(n, 0, 0.03 * h)) + } + sf::st_as_sf(data.frame(x = 4e5 + xy[, 1], y = 4.5e6 + xy[, 2]), + coords = c("x", "y"), crs = 32617) +} + +# Do what one piece of advice says and return what comes back. +la_follow <- function(pts, k, ...) { + reduced <- FALSE + val <- tryCatch( + withCallingHandlers( + r2_quiet(make_folds(pts, k = k, method = "block_kfold", seed = 1, ...)), + spatialkit_k_reduced = function(w) { reduced <<- TRUE; invokeRestart("muffleWarning") }, + warning = function(w) invokeRestart("muffleWarning"), + message = function(m) invokeRestart("muffleMessage")), + error = function(e) conditionMessage(e)) + list(value = val, reduced = reduced) +} + +# Check every claim an advice text makes about a layout. +la_check <- function(adv, pts, k, label) { + size <- as.numeric(sub(".*?block_size = ([0-9.]+).*", "\\1", adv, perl = TRUE)) + got <- la_follow(pts, k, block_size = size) + if (grepl("enough for k = [0-9]+ folds", adv)) { + # "Pass block_size = X: ... enough for k = K folds." + expect_false(is.character(got$value), info = label) + expect_identical(got$value$k, as.integer(k), info = label) + expect_false(got$reduced, info = label) + return(invisible("k")) + } + # Otherwise it names the largest size that still gives k folds, and that + # size is below the range the warning is about. + expect_match(adv, "The largest block_size that gives [0-9]+ folds is [0-9.]+", info = label) + alt <- as.numeric(sub(".*The largest block_size that gives [0-9]+ folds is ([0-9.]+),.*", "\\1", adv)) + expect_lt(alt, size) + alt_got <- la_follow(pts, k, block_size = alt) + expect_false(is.character(alt_got$value), info = label) + expect_identical(alt_got$value$k, as.integer(k), info = label) + expect_false(alt_got$reduced, info = label) + expect_match(adv, "method = \"nndm\"", fixed = TRUE, info = label) + if (grepl("stops with an error", adv)) { + # "block_size = X stops with an error": it does, with the single-block error. + expect_true(is.character(got$value), info = label) + expect_match(got$value, "single block", info = label) + return(invisible("error")) + } + # "... returns B folds, not K": B folds come back, with the classed warning. + expect_match(adv, "returns [0-9]+ folds, not [0-9]+", info = label) + b <- as.integer(sub(".*returns ([0-9]+) folds, not [0-9]+.*", "\\1", adv)) + expect_false(is.character(got$value), info = label) + expect_identical(got$value$k, b, info = label) + expect_lt(b, k) + expect_true(got$reduced, info = label) + invisible("fewer") +} + +test_that("the advice does what it says for ranges of 0.1 to 0.9 of the side", { + outcomes <- character(0) + for (kind in c("uniform", "clustered")) for (shape in c("square", "wide")) { + w <- if (shape == "square") 1e5 else 2.4e5 + pts <- la_layout(kind, w = w, seed = if (kind == "uniform") 3 else 4) + bb <- sf::st_bbox(pts) + reg <- sf::st_sf(geometry = sf::st_as_sfc(bb)) + for (frac in seq(0.1, 0.9, by = 0.1)) for (k in c(3L, 5L)) { + rng <- frac * 1e5 + 0.37 # not a round number, as an estimate is not + adv <- r2_quiet(spatialkit:::.block_range_advice(pts, reg, bb, rng, k)) + # The size named is at least the range it stands for. + size <- as.numeric(sub(".*?block_size = ([0-9.]+).*", "\\1", adv, perl = TRUE)) + expect_gte(size, rng) + outcomes <- c(outcomes, la_check(adv, pts, k, + sprintf("%s %s range %.1f k %d", kind, shape, frac, k))) + } + } + # The sweep covers all three outcomes; a test that only ever saw one would + # not be testing the other two. + expect_setequal(unique(outcomes), c("k", "fewer", "error")) +}) + +test_that("a range below 10 CRS units is quoted as itself, not rounded up to 1", { + # ceiling() turned a range of 0.3712 km into "Pass block_size = 1". + set.seed(2) + km <- sf::st_as_sf(data.frame(x = runif(200, 0, 10), y = runif(200, 0, 10)), + coords = c("x", "y"), crs = NA) + bb <- sf::st_bbox(km); reg <- sf::st_sf(geometry = sf::st_as_sfc(bb)) + adv <- spatialkit:::.block_range_advice(km, reg, bb, 0.3712, 5L) + expect_match(adv, "block_size = 0.372", fixed = TRUE) + expect_identical(spatialkit:::.block_size_at_least(0.3712), 0.372) + expect_identical(spatialkit:::.block_size_at_least(37128.4), 37129) +}) + +test_that("the default call's warning can be followed, end to end", { + skip_if_not_installed("gstat") + # A field whose range is known, on a 100 km square. What decides the + # advice is the range estimate_sac_range() returns for it, 43.5 km and + # 59.8 km for true effective ranges of 0.4 and 0.5 of the side: blocks of + # the first leave a 2 x 2 grid, blocks of the second a single block. (The + # iterative variogram fit this was first written against returned 37 km + # and 53 km at 0.3 and 0.4; the estimate at 0.3 is now 28 km, under a third + # of the side, for which five range-sized blocks do exist.) + sim <- function(eff_range, seed) { + set.seed(seed); n <- 700 + x <- runif(n, 0, 1e5); y <- runif(n, 0, 1e5) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-3 * d / eff_range) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, 0, sqrt(0.2)) + sf::st_as_sf(data.frame(x = 4e5 + x, y = 4.5e6 + y, z = z), + coords = c("x", "y"), crs = 32617) + } + seen <- character(0) + for (frac in c(0.4, 0.5)) { + dat <- sim(frac * 1e5, seed = 12) + w <- character(0) + f <- withCallingHandlers( + r2_quiet(make_folds(dat, k = 5, method = "block_kfold", response_var = "z", seed = 1)), + warning = function(c) { w <<- c(w, conditionMessage(c)); invokeRestart("muffleWarning") }) + adv <- grep("block dimension .* < autocorrelation range", w, value = TRUE) + # The default 4 x 4 grid has 25 km blocks and both ranges are above it. + expect_length(adv, 1L) + if (length(adv) != 1L) next + expect_identical(f$k, 5L) # the diagnostic sizes nothing + # The range the advice is about is above a third of the side. + expect_gt(as.numeric(f$params$sac_range), 1e5 / 3) + seen <- c(seen, la_check(adv, dat, 5L, sprintf("range %.1f", frac))) + # Where the text offers auto_range = TRUE as well, it gives the same + # outcome as the block size beside it. + if (grepl("or auto_range = TRUE", adv, fixed = TRUE)) { + size <- as.numeric(sub(".*?block_size = ([0-9.]+).*", "\\1", adv, perl = TRUE)) + a <- la_follow(dat, 5L, response_var = "z", auto_range = TRUE) + b <- la_follow(dat, 5L, block_size = size) + expect_identical(is.character(a$value), is.character(b$value)) + if (!is.character(a$value)) expect_identical(a$value$k, b$value$k) + expect_identical(a$reduced, b$reduced) + } + } + # Neither of these ranges fits five range-sized blocks, so neither message + # may promise them: one returns fewer folds and the other a single block. + expect_false("k" %in% seen) + expect_setequal(seen, c("fewer", "error")) +}) + +test_that("auto_range says what it built, and warns when that is fewer folds", { + skip_if_not_installed("gstat") + set.seed(12); n <- 400 + x <- runif(n, 0, 1e5); y <- runif(n, 0, 1e5) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-3 * d / 3e4) + diag(1e-8, n))) %*% rnorm(n)) + rnorm(n, 0, sqrt(0.2)) + dat <- sf::st_as_sf(data.frame(x = 4e5 + x, y = 4.5e6 + y, z = z), + coords = c("x", "y"), crs = 32617) + msgs <- character(0); reduced <- 0L + f <- tryCatch(withCallingHandlers( + r2_quiet(make_folds(dat, k = 5, method = "block_kfold", response_var = "z", + auto_range = TRUE, seed = 1)), + message = function(m) { msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") }, + spatialkit_k_reduced = function(w) { reduced <<- reduced + 1L; invokeRestart("muffleWarning") }), + error = function(e) NULL) + skip_if(is.null(f) || !isTRUE(f$params$block_size > 0), "no range-sized grid was built") + expect_true(any(grepl("using as minimum block size\\. Over the .* extent that is a [0-9]+ x [0-9]+ grid of blocks", + msgs))) + # Fewer folds than asked never comes back without the warning. + expect_identical(f$k < 5L, reduced == 1L) + expect_identical(f$params$k_requested, 5L) +}) diff --git a/tests/testthat/test-fix-folds-max-test.R b/tests/testthat/test-fix-folds-max-test.R new file mode 100644 index 00000000..288b4dff --- /dev/null +++ b/tests/testthat/test-fix-folds-max-test.R @@ -0,0 +1,145 @@ +# tests/testthat/test-fix-folds-max-test.R +# --------------------------------------------------------------------------- +# make_folds(max_test = ) for the two leave-one-out methods: folds are built +# for a seeded random subset of the held-out points while every row stays +# available for training. The model is refitted max_test times and the +# folds hold 4 * n * max_test bytes of row indices in place of 4 * n^2. +# --------------------------------------------------------------------------- + +mt_pts <- function(n, seed, side = 1e4) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, side), y = 5e6 + runif(n, 0, side), + a = rnorm(n), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) +} +mt_grid <- function(pts, m = 20) { + bb <- sf::st_bbox(pts) + sf::st_as_sf(expand.grid(x = seq(bb[["xmin"]], bb[["xmax"]], length.out = m), + y = seq(bb[["ymin"]], bb[["ymax"]], length.out = m)), + coords = c("x", "y"), crs = sf::st_crs(pts)) +} + +test_that("buffered_loo with max_test builds that many of the full design's folds", { + pts <- mt_pts(120, 1) + full <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 1500)) + sub <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 1500, + max_test = 25, seed = 7)) + expect_identical(sub$k, 25L) + expect_length(sub$folds, 25L) + expect_identical(sub$params$max_test, 25L) + held <- vapply(sub$folds, function(s) s$test, 0L) + expect_false(anyDuplicated(held) > 0) + expect_identical(held, sort(held)) + # Each fold is the fold the full design has for that point: every row is + # still available for training. + for (j in seq_along(held)) { + expect_identical(sub$folds[[j]]$train, full$folds[[held[j]]]$train) + expect_false(held[j] %in% sub$folds[[j]]$train) + } + # Rows that are not held out have no fold. + expect_identical(sub$assignment$row_id, seq_len(120)) + expect_identical(which(!is.na(sub$assignment$fold)), held) + expect_identical(sub$assignment$fold[held], seq_len(25)) + expect_identical(sum(is.na(sub$assignment$fold)), 95L) + # The subset is the seed's. + again <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 1500, + max_test = 25, seed = 7)) + expect_identical(again$assignment, sub$assignment) + other <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 1500, + max_test = 25, seed = 8)) + expect_false(identical(other$assignment$fold, sub$assignment$fold)) +}) + +test_that("nndm with max_test matches over every point and builds a subset of the folds", { + pts <- mt_pts(150, 2) + # A grid three times as wide as the samples, so that neighbours are excluded. + bb <- sf::st_bbox(pts) + wide <- sf::st_as_sf(expand.grid(x = seq(bb[["xmin"]] - 1e4, bb[["xmax"]] + 1e4, length.out = 20), + y = seq(bb[["ymin"]] - 1e4, bb[["ymax"]] + 1e4, length.out = 20)), + coords = c("x", "y"), crs = 32632) + full <- r2_quiet(suppressWarnings(make_folds(pts, method = "nndm", prediction_points = wide))) + sub <- r2_quiet(suppressWarnings(make_folds(pts, method = "nndm", prediction_points = wide, + max_test = 40, seed = 3))) + expect_gt(full$params$n_removed_total, 0L) + expect_identical(sub$k, 40L) + expect_length(sub$folds, 40L) + held <- vapply(sub$folds, function(s) s$test, 0L) + expect_identical(length(unique(held)), 40L) + for (j in seq_along(held)) + expect_identical(sub$folds[[j]]$train, full$folds[[held[j]]]$train) + expect_identical(which(!is.na(sub$assignment$fold)), held) + # The matching, and everything `params` says about it, is the full design's. + same <- setdiff(names(full$params), "seed") + expect_identical(sub$params[same], full$params[same]) + expect_length(sub$params$realised_distances, 150L) + expect_identical(sub$params$max_test, 40L) + expect_null(full$params$max_test) + # Without a subset nothing about the result has changed. + expect_identical(full$k, 150L) + expect_identical(full$assignment$fold, seq_len(150)) +}) + +test_that("a max_test at or above n holds every point out", { + pts <- mt_pts(40, 3) + full <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 800)) + all_ <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 800, max_test = 40)) + more <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 800, max_test = 500)) + expect_identical(all_$folds, full$folds) + expect_identical(more$folds, full$folds) + expect_identical(more$assignment, full$assignment) + expect_identical(more$k, 40L) +}) + +test_that("max_test is validated, and refused for the k-fold methods", { + pts <- mt_pts(60, 4) + for (bad in list(1, 2.5, -3, NA_real_, c(5, 6), "10", Inf)) + expect_error(make_folds(pts, method = "buffered_loo", buffer = 500, max_test = bad), + "`max_test` must be a single whole number >= 2") + for (m in c("random_kfold", "block_kfold", "leave_location_out", "knndm")) + expect_error(make_folds(pts, k = 5, method = m, max_test = 10, + prediction_points = mt_grid(pts)), + "`max_test` is only used by the leave-one-out methods", info = m) +}) + +test_that("max_test lets buffered_loo run where its storage limit refuses the full design", { + pts <- mt_pts(13000, 5, side = 2e5) + # 4 * 13000^2 bytes is 0.63 GB of row indices: refused, and the message + # names the way through with a number that works. + err <- tryCatch(make_folds(pts, method = "buffered_loo", buffer = 2000), + error = function(e) conditionMessage(e)) + expect_match(err, "would produce 13000 leave-one-out splits holding about 0.63 GB") + expect_match(err, "pass `max_test` to build and score a random subset") + ok <- as.numeric(sub(".*max_test = ([0-9]+) keeps the splits under 0.6 GB.*", "\\1", err)) + expect_true(is.finite(ok) && ok >= 2 && 4 * 13000 * ok / 1024^3 <= 0.6) + sub <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 2000, + max_test = 30, seed = 1)) + expect_identical(sub$k, 30L) + expect_true(all(vapply(sub$folds, function(s) length(s$train), 0L) > 12000L)) + expect_true(all(vapply(sub$folds, function(s) !(s$test %in% s$train), NA))) + # The largest subset the message offered is accepted by the size check. + expect_lte(4 * 13000 * ok / 1024^3, 0.6) +}) + +test_that("folds built with max_test are scored and measured as they are", { + pts <- mt_pts(90, 6) + sub <- r2_quiet(make_folds(pts, method = "buffered_loo", buffer = 1200, + max_test = 20, seed = 2)) + cv <- r2_quiet(suppressWarnings(cv_spatial(pts, "z", "a", fit_fn = r2_fit, + folds = sub, seed = 1))) + expect_identical(cv$n_folds_attempted, 20L) + expect_identical(cv$n_folds_succeeded, 20L) + held <- vapply(sub$folds, function(s) s$test, 0L) + fs <- r2_quiet(fold_separation(sub, pts)) + expect_identical(nrow(fs), 20L) + expect_identical(sum(fs$n_test), 20L) + expect_true(all(fs$min_dist > 1200)) + expect_identical(attr(fs, "n_unknown_ids"), 0L) + # nndm folds carry their target, and the subset is read against it. + nf <- r2_quiet(suppressWarnings(make_folds(pts, method = "nndm", + prediction_points = mt_grid(pts), + max_test = 30, seed = 2))) + ns <- r2_quiet(fold_separation(nf, pts)) + expect_identical(nrow(ns), 30L) + expect_identical(attr(ns, "target")$source, + "the prediction points the NNDM folds were built for") +}) diff --git a/tests/testthat/test-fix-folds-nndm-reach.R b/tests/testthat/test-fix-folds-nndm-reach.R new file mode 100644 index 00000000..81ad8415 --- /dev/null +++ b/tests/testthat/test-fix-folds-nndm-reach.R @@ -0,0 +1,155 @@ +# tests/testthat/test-fix-folds-nndm-reach.R +# --------------------------------------------------------------------------- +# make_folds(method = "nndm") returned plain leave-one-out, with no warning +# and max_ecdf_excess = 0, when the prediction points sat nearer to the data +# than leave-one-out can reach. Excluding neighbours only lengthens a +# held-out distance, so that side of the match is out of reach by +# construction; it is now measured, recorded and warned about. Each test +# fails on the code before the fix. +# --------------------------------------------------------------------------- + +nr_pts <- function(xy) sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2]), + coords = c("x", "y"), crs = 32632) +nr_grid <- function(pts, m = 40) { + bb <- sf::st_bbox(pts) + sf::st_as_sf(expand.grid(x = seq(bb[["xmin"]], bb[["xmax"]], length.out = m), + y = seq(bb[["ymin"]], bb[["ymax"]], length.out = m)), + coords = c("x", "y"), crs = sf::st_crs(pts)) +} +nr_collect <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + list(value = val, + reach = Filter(function(c) inherits(c, "spatialkit_nndm_out_of_reach"), w), + all = vapply(w, conditionMessage, "")) +} + +test_that("prediction points 5 m from the samples raise the classed warning", { + set.seed(1) + xy <- cbind(runif(200, 0, 1e4), runif(200, 0, 1e4)) + u <- nr_pts(xy) + near <- nr_pts(xy + matrix(rnorm(400, 0, 5), 200)) + res <- r2_quiet(nr_collect(make_folds(u, method = "nndm", prediction_points = near))) + p <- res$value$params + + # What came back is plain leave-one-out, a hundred times too far. + expect_identical(p$n_removed_total, 0L) + expect_true(all(lengths(lapply(res$value$folds, `[[`, "train")) == 199L)) + expect_gt(p$realised_median / p$target_median, 20) + expect_identical(p$max_ecdf_excess, 0) + + # It used to say nothing. Now: one warning of its own class ... + expect_length(res$reach, 1L) + cnd <- res$reach[[1L]] + expect_match(conditionMessage(cnd), "nearer to the data than leave-one-out can reach") + expect_match(conditionMessage(cnd), "plain leave-one-out, no neighbour excluded") + expect_match(conditionMessage(cnd), "pessimistic for these prediction locations, an upper bound") + expect_equal(cnd$deficit, p$loo_ecdf_deficit) + expect_equal(cnd$tolerance, p$ecdf_deficit_tol) + # ... and a record in the result. + expect_true(p$target_out_of_reach) + expect_gt(p$loo_ecdf_deficit, 0.9) + # Nothing was excluded, so the folds' deficit is leave-one-out's. + expect_equal(p$max_ecdf_deficit, p$loo_ecdf_deficit) + expect_equal(p$ecdf_deficit_tol, 3 * sqrt(1 / 200 + 1 / 200)) + # Nothing was excluded, so the folds are as far from the target as plain + # leave-one-out is. + expect_equal(p$wasserstein, p$wasserstein_loo) + expect_gt(p$wasserstein, 10 * p$target_median) + + # The deficit is the mirror of max_ecdf_excess, recomputed here by hand. + at <- sort(unique(c(p$target_distances, p$realised_distances))) + by_hand <- max(stats::ecdf(p$target_distances)(at) - stats::ecdf(p$realised_distances)(at)) + expect_equal(p$max_ecdf_deficit, by_hand) +}) + +test_that("a regular sample predicted between its nodes is out of reach too", { + g <- as.matrix(expand.grid(seq(250, 9750, by = 500), seq(250, 9750, by = 500))) + set.seed(5) + res <- r2_quiet(nr_collect(make_folds( + nr_pts(g), method = "nndm", + prediction_points = nr_pts(cbind(runif(1500, 0, 1e4), runif(1500, 0, 1e4)))))) + expect_length(res$reach, 1L) + expect_true(res$value$params$target_out_of_reach) +}) + +test_that("layouts whose folds match their target raise no such warning", { + # A uniform sample with a grid over its extent: plain leave-one-out is the + # right answer, and one fold's worth of deficit (1/n) would fire on every + # such layout. + for (seed in c(101, 102, 103)) { + set.seed(seed) + u <- nr_pts(cbind(runif(300, 0, 1e4), runif(300, 0, 1e4))) + res <- r2_quiet(nr_collect(make_folds(u, method = "nndm", prediction_points = nr_grid(u)))) + p <- res$value$params + expect_length(res$reach, 0L) + expect_false(p$target_out_of_reach) + expect_gt(p$loo_ecdf_deficit, 1 / 300) # the 1/n rule would have fired + expect_lt(p$loo_ecdf_deficit, p$ecdf_deficit_tol) + } + # A clustered sample with the grid, the layout NNDM is for: neighbours are + # excluded, and the folds end closer to the target than leave-one-out was. + set.seed(2001) + c0 <- cbind(runif(8, 1500, 8500), runif(8, 1500, 8500)); i <- sample(8, 200, TRUE) + cl <- nr_pts(c0[i, ] + matrix(rnorm(400, 0, 400), 200)) + res <- r2_quiet(nr_collect(make_folds(cl, method = "nndm", prediction_points = nr_grid(cl)))) + p <- res$value$params + expect_length(res$reach, 0L) + expect_false(p$target_out_of_reach) + expect_gt(p$n_removed_total, 0L) + expect_lt(p$wasserstein, p$wasserstein_loo) +}) + +test_that("an overshoot of the matching is recorded, and is not called out of reach", { + # Two tight clusters and a grid over the square between them. Plain + # leave-one-out is far too close here, so nothing is out of reach; but + # excluding a point's own cluster moves it out to the other one, past most + # of the prediction distances. That is the granularity of the matching, + # a different thing from prediction points nearer than leave-one-out. + set.seed(13) + ctr <- cbind(c(250, 750), c(250, 750)); i <- rep(1:2, each = 40) + two <- nr_pts(cbind(ctr[i, 1] + rnorm(80, 0, 40), ctr[i, 2] + rnorm(80, 0, 40))) + grid <- sf::st_as_sf(expand.grid(x = 5e5 + seq(50, 950, by = 75), y = 5e6 + seq(50, 950, by = 75)), + coords = c("x", "y"), crs = 32632) + res <- r2_quiet(nr_collect(make_folds(two, method = "nndm", prediction_points = grid))) + p <- res$value$params + expect_length(res$reach, 0L) + expect_false(p$target_out_of_reach) + expect_lt(p$loo_ecdf_deficit, p$ecdf_deficit_tol) + expect_gt(p$max_ecdf_deficit, p$loo_ecdf_deficit) + expect_gt(p$n_removed_total, 0L) + # fold_separation() still reads the folds as they are, without blaming + # the prediction points. + s <- fold_separation(res$value, two) + expect_false(attr(s, "target")$nndm_out_of_reach) + out <- gsub("\\s+", " ", paste(utils::capture.output(print(s)), collapse = " ")) + expect_no_match(out, "NNDM can only lengthen") +}) + +test_that("fold_separation() reads NNDM folds against the target they carry", { + set.seed(1) + xy <- cbind(runif(200, 0, 1e4), runif(200, 0, 1e4)) + u <- nr_pts(xy) + far <- r2_quiet(suppressWarnings(make_folds( + u, method = "nndm", prediction_points = nr_pts(xy + matrix(rnorm(400, 0, 5), 200))))) + s <- fold_separation(far, u, sac = 2000) + tg <- attr(s, "target") + expect_identical(tg$reading, "farther") + expect_identical(tg$basis, "all sites") + expect_true(tg$nndm_out_of_reach) + expect_equal(tg$target_all_median, far$params$target_median) + out <- gsub("\\s+", " ", paste(utils::capture.output(print(s)), collapse = " ")) + # It used to say these folds "reproduce the distances from the prediction + # points to the data", for every NNDM fold set. + expect_no_match(out, "reproduce the distances") + expect_match(out, "farther from their training data than the prediction points do") + expect_match(out, "NNDM can only lengthen a held-out distance") + + set.seed(101) + v <- nr_pts(cbind(runif(300, 0, 1e4), runif(300, 0, 1e4))) + ok <- r2_quiet(make_folds(v, method = "nndm", prediction_points = nr_grid(v))) + expect_identical(attr(fold_separation(ok, v, sac = 2000), "target")$reading, "matched") + expect_identical(attr(fold_separation(ok, v), "target")$reading, "matched") +}) diff --git a/tests/testthat/test-fix-folds-nndm-small-samples.R b/tests/testthat/test-fix-folds-nndm-small-samples.R new file mode 100644 index 00000000..862dc5d6 --- /dev/null +++ b/tests/testthat/test-fix-folds-nndm-small-samples.R @@ -0,0 +1,175 @@ +# tests/testthat/test-fix-folds-nndm-small-samples.R +# --------------------------------------------------------------------------- +# The out-of-reach warning of make_folds(method = "nndm") on small samples. +# +# Its tolerance, 3 * sqrt(1/n + 1/m) for n folds and m prediction points, is +# 1 or more whenever n * m / (n + m) <= 9, and a deficit is a difference of +# two shares, so it cannot exceed 1. For nine folds or fewer, and for up to +# eighteen with as many prediction points, plain leave-one-out therefore came +# back without a word however near the prediction points were. There the +# warning now rests on complete separation: every prediction point nearer to +# the data than any sample is to its nearest other sample. Each test that +# expects the warning fails on the code before the fix. +# --------------------------------------------------------------------------- + +ns_pts <- function(xy) sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2]), + coords = c("x", "y"), crs = 32632) +ns_collect <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + list(value = val, + reach = Filter(function(c) inherits(c, "spatialkit_nndm_out_of_reach"), w)) +} + +test_that("twelve samples with prediction points 5 m away raise the warning", { + set.seed(3) + xy <- cbind(runif(12, 0, 1e4), runif(12, 0, 1e4)) + u <- ns_pts(xy) + near <- ns_pts(xy + matrix(rnorm(24, 0, 5), 12)) + res <- r2_quiet(ns_collect(make_folds(u, method = "nndm", prediction_points = near))) + p <- res$value$params + + # Plain leave-one-out, two hundred times too far. + expect_identical(p$n_removed_total, 0L) + expect_gt(p$realised_median / p$target_median, 50) + # The share rule cannot fire here: its tolerance is above any deficit. + expect_equal(p$ecdf_deficit_tol, 3 * sqrt(1 / 12 + 1 / 12)) + expect_gt(p$ecdf_deficit_tol, 1) + expect_identical(p$loo_ecdf_deficit, 1) + # Every prediction distance is below every leave-one-out distance. + expect_lt(max(p$target_distances), min(p$realised_distances)) + expect_true(p$target_separated) + + # It used to say nothing. + expect_true(p$target_out_of_reach) + expect_length(res$reach, 1L) + cnd <- res$reach[[1L]] + expect_true(cnd$separated) + expect_equal(cnd$deficit, 1) + expect_equal(cnd$tolerance, p$ecdf_deficit_tol) + msg <- conditionMessage(cnd) + expect_match(msg, "nearer to the data than leave-one-out can reach") + expect_match(msg, "plain leave-one-out, no neighbour excluded") + expect_match(msg, "Every one of the 12 prediction points is nearer to the data") + expect_match(msg, "With 12 folds and 12 prediction points") + expect_match(msg, "pessimistic for these prediction locations, an upper bound") + # The numbers in the sentence are the ones in the result. + expect_match(msg, sprintf("(%s at most)", format(signif(max(p$target_distances), 4))), + fixed = TRUE) + expect_match(msg, sprintf("(%s at least)", format(signif(min(p$realised_distances), 4))), + fixed = TRUE) + + # fold_separation() reads the folds against the target they carry. + s <- fold_separation(res$value, u) + expect_true(attr(s, "target")$nndm_out_of_reach) + expect_identical(attr(s, "target")$reading, "farther") + out <- gsub("\\s+", " ", paste(utils::capture.output(print(s)), collapse = " ")) + expect_match(out, "NNDM can only lengthen a held-out distance") +}) + +test_that("a 3 x 3 sample predicted between its nodes is out of reach", { + # Nine nodes 3333 apart; no point of the square is farther than 2357 from + # one. The tolerance for nine folds is above 1 whatever the target. + g <- as.matrix(expand.grid((1:3 - 0.5) * 1e4 / 3, (1:3 - 0.5) * 1e4 / 3)) + set.seed(5) + res <- r2_quiet(ns_collect(make_folds( + ns_pts(g), method = "nndm", + prediction_points = ns_pts(cbind(runif(1500, 0, 1e4), runif(1500, 0, 1e4)))))) + p <- res$value$params + expect_gt(p$ecdf_deficit_tol, 1) + expect_true(p$target_separated) + expect_true(p$target_out_of_reach) + expect_length(res$reach, 1L) + expect_match(conditionMessage(res$reach[[1L]]), + "Every one of the 1500 prediction points is nearer to the data") +}) + +test_that("twelve samples with a grid over their extent raise nothing", { + for (seed in c(201, 202, 203, 204)) { + set.seed(seed) + u <- ns_pts(cbind(runif(12, 0, 1e4), runif(12, 0, 1e4))) + grid <- sf::st_as_sf(sf::st_make_grid(u, n = c(20, 20), what = "centers")) + res <- r2_quiet(ns_collect(make_folds(u, method = "nndm", prediction_points = grid))) + p <- res$value$params + expect_length(res$reach, 0L) + expect_false(p$target_separated) + expect_false(p$target_out_of_reach) + expect_lt(p$loo_ecdf_deficit, 1) + } +}) + +test_that("a partial shortfall on a small sample is recorded, not warned about", { + # Prediction points at 0.3 of the mean spacing from twelve samples: most + # are nearer than leave-one-out reaches, not all. With 12 against 12 that + # is within what two small sets of distances differ by; the deficit and + # the two medians are in the result for the caller to read. + set.seed(9048) + xy <- cbind(runif(12, 0, 1e4), runif(12, 0, 1e4)) + a <- runif(12, 0, 2 * pi); sp <- 1e4 / sqrt(12) + res <- r2_quiet(ns_collect(make_folds( + ns_pts(xy), method = "nndm", + prediction_points = ns_pts(xy + 0.3 * sp * cbind(cos(a), sin(a)))))) + p <- res$value$params + expect_false(p$target_separated) + expect_gt(p$loo_ecdf_deficit, 0.5) + expect_lt(p$loo_ecdf_deficit, 1) + expect_gt(p$ecdf_deficit_tol, 1) + expect_false(p$target_out_of_reach) + expect_length(res$reach, 0L) + expect_gt(p$realised_median, p$target_median) +}) + +test_that("a handful of distances is too few to call a separation", { + # Four samples and two prediction points beside two of them: the ordering + # is complete, and one of only choose(6, 4) = 15, so it is recorded and + # nothing is raised. + xy <- cbind(c(1000, 9000, 1000, 9000), c(1000, 1000, 9000, 9500)) + u <- ns_pts(xy) + two <- ns_pts(xy[1:2, ] + 5) + res <- r2_quiet(ns_collect(make_folds(u, method = "nndm", prediction_points = two))) + p <- res$value$params + expect_true(p$target_separated) + expect_false(p$target_out_of_reach) + expect_length(res$reach, 0L) + + # Seventeen prediction points beside three samples are enough: + # choose(20, 3) = 1140. + tri <- cbind(c(1000, 9000, 5000), c(1000, 1500, 9000)) + set.seed(4) + near <- ns_pts(tri[rep(1:3, length.out = 17), ] + matrix(rnorm(34, 0, 5), 17)) + res <- r2_quiet(ns_collect(make_folds(ns_pts(tri), method = "nndm", prediction_points = near))) + expect_true(res$value$params$target_separated) + expect_true(res$value$params$target_out_of_reach) + expect_length(res$reach, 1L) + # Sixteen are one short: choose(19, 3) = 969. + res <- r2_quiet(ns_collect(make_folds(ns_pts(tri), method = "nndm", + prediction_points = near[1:16, ]))) + expect_true(res$value$params$target_separated) + expect_false(res$value$params$target_out_of_reach) + expect_length(res$reach, 0L) +}) + +test_that("on larger samples the share rule decides as before", { + # 200 against 200, 5 m away: past the tolerance, and separated too. + set.seed(1) + xy <- cbind(runif(200, 0, 1e4), runif(200, 0, 1e4)) + res <- r2_quiet(ns_collect(make_folds( + ns_pts(xy), method = "nndm", + prediction_points = ns_pts(xy + matrix(rnorm(400, 0, 5), 200))))) + cnd <- res$reach[[1L]] + expect_lt(cnd$tolerance, 1) + expect_gt(cnd$deficit, cnd$tolerance) + # The message is the share rule's, with its tolerance. + expect_match(conditionMessage(cnd), "past the 0.300 allowed for 200 folds and 200 prediction points") + expect_no_match(conditionMessage(cnd), "Every one of the") + # A uniform sample with a grid target: neither rule fires. + set.seed(101) + u <- ns_pts(cbind(runif(300, 0, 1e4), runif(300, 0, 1e4))) + grid <- sf::st_as_sf(sf::st_make_grid(u, n = c(40, 40), what = "centers")) + res <- r2_quiet(ns_collect(make_folds(u, method = "nndm", prediction_points = grid))) + expect_length(res$reach, 0L) + expect_false(res$value$params$target_separated) + expect_false(res$value$params$target_out_of_reach) +}) diff --git a/tests/testthat/test-fix-folds-separation-target.R b/tests/testthat/test-fix-folds-separation-target.R new file mode 100644 index 00000000..8f81a78f --- /dev/null +++ b/tests/testthat/test-fix-folds-separation-target.R @@ -0,0 +1,241 @@ +# tests/testthat/test-fix-folds-separation-target.R +# --------------------------------------------------------------------------- +# fold_separation() printed "this score is optimistic" whenever more than +# half the held-out points had a training point inside the range. That share +# cannot give a direction: the same 100 percent goes with an unbiased score +# on evenly sited data and with a score 20 percent low on clustered data. +# Without a prediction target it now reports distances and no verdict; with +# one it compares the two sets of distances and words the reading by the +# signed gap. Each test fails on the code before the fix. +# --------------------------------------------------------------------------- + +st_pts <- function(xy) sf::st_as_sf(data.frame(x = 2e5 + xy[, 1], y = 4e6 + xy[, 2]), + coords = c("x", "y"), crs = 32617) +st_even <- function(n = 300, w = 3e5, h = 3e5, seed = 1) { + set.seed(seed); st_pts(cbind(runif(n, 0, w), runif(n, 0, h))) +} +st_clustered <- function(n = 300, w = 3e5, h = 3e5, seed = 1) { + set.seed(seed) + c0 <- cbind(runif(8, 0.1 * w, 0.9 * w), runif(8, 0.1 * h, 0.9 * h)); i <- sample(8, n, TRUE) + xy <- c0[i, ] + cbind(rnorm(n, 0, 0.04 * w), rnorm(n, 0, 0.04 * w)) + st_pts(cbind(pmin(pmax(xy[, 1], 0), w), pmin(pmax(xy[, 2], 0), h))) +} +st_grid <- function(pts, m = 30) { + bb <- sf::st_bbox(pts) + sf::st_as_sf(expand.grid(x = seq(bb[["xmin"]], bb[["xmax"]], length.out = m), + y = seq(bb[["ymin"]], bb[["ymax"]], length.out = m)), + coords = c("x", "y"), crs = sf::st_crs(pts)) +} +st_flat <- function(x) gsub("\\s+", " ", paste(utils::capture.output(print(x)), collapse = " ")) +st_q <- function(expr) r2_quiet(suppressWarnings(suppressMessages(expr))) +# Nearest-neighbour distance from each row of a to the rows of b, by hand. +st_nn <- function(a, b) apply(a, 1L, function(p) min(sqrt((b[, 1] - p[1])^2 + (b[, 2] - p[2])^2))) + +test_that("without a prediction target there are distances and no verdict", { + pts <- st_even(150, 8e5, 3e5, seed = 101) + rnd <- st_q(make_folds(pts, k = 5, method = "random_kfold", seed = 1)) + blk <- st_q(make_folds(pts, k = 5, method = "block_kfold", block_size = 1e5, seed = 1)) + buf <- st_q(make_folds(pts, method = "buffered_loo", buffer = 3e4)) + for (f in list(rnd, blk, buf)) { + s <- fold_separation(f, pts, sac = 1e5) + expect_null(attr(s, "target")) + expect_true(all(is.na(s$target_median_dist)) && all(is.na(s$dist_gap))) + out <- st_flat(s) + # The old print called all three "optimistic" and named a remedy; on this + # layout random folds are about unbiased and wider blocks read higher. + expect_no_match(out, "optimistic") + expect_no_match(out, "leak") + expect_no_match(out, "widen the") + expect_no_match(out, "use blocked or buffered folds") + expect_match(out, "No prediction target is given, so these are distances and no conclusion about the score") + expect_match(out, "Pass `prediction_points` to compare") + } + # No range either: still the distances and the same closing line. + expect_match(st_flat(fold_separation(rnd, pts)), "No prediction target is given") +}) + +test_that("mean_cor is a mean correlation, not a count inside the range", { + pts <- st_even(120, seed = 7) + f <- st_q(make_folds(pts, k = 4, method = "random_kfold", seed = 2)) + rng <- 6e4 + s <- fold_separation(f, pts, sac = rng) + xy <- sf::st_coordinates(pts) + for (j in 1:4) { + d <- st_nn(xy[f$folds[[j]]$test, , drop = FALSE], xy[f$folds[[j]]$train, , drop = FALSE]) + expect_equal(s$mean_cor[j], mean(exp(-3 * d / rng))) + # Every one of these points is inside the range, which the old column + # reported as 1 for each fold whatever the distances were. + expect_true(all(d < rng)) + expect_lt(s$mean_cor[j], 1) + } + expect_identical(attr(s, "range_model"), "Exp") + d_all <- unlist(lapply(f$folds, function(sp) st_nn(xy[sp$test, , drop = FALSE], xy[sp$train, , drop = FALSE]))) + expect_equal(attr(s, "pooled")$mean_cor, mean(exp(-3 * d_all / rng))) + expect_equal(attr(s, "pooled")$median_dist, stats::median(d_all)) + # A point at a twentieth of the range weighs more than one at nine tenths. + expect_gt(exp(-3 * 0.05), 5 * exp(-3 * 0.9)) + + # A range that carries a spherical fit is weighted by the spherical model. + sph <- structure(rng, class = c("sac_range", "numeric"), crs = sf::st_crs(pts), + variogram_model = data.frame(model = c("Nug", "Sph"), psill = c(0.1, 1), + range = c(0, rng))) + s2 <- fold_separation(f, pts, sac = sph) + expect_identical(attr(s2, "range_model"), "Sph") + d1 <- st_nn(xy[f$folds[[1]]$test, , drop = FALSE], xy[f$folds[[1]]$train, , drop = FALSE]) + expect_equal(s2$mean_cor[1], mean(1 - 1.5 * (d1 / rng) + 0.5 * (d1 / rng)^3)) +}) + +test_that("the three clear cases read matched, farther and closer", { + # Evenly sited points, a grid over the same box as the target. + even <- st_even(seed = 11); grid <- st_grid(even) + rnd <- st_q(make_folds(even, k = 5, method = "random_kfold", seed = 1)) + blk <- st_q(make_folds(even, k = 5, method = "block_kfold", block_size = 1e5, seed = 1)) + # With a range the reading is on the correlation scale, without one on the + # mean distance; the clear cases agree on both. + for (sac in list(1e5, NULL)) { + a <- attr(fold_separation(rnd, even, sac = sac, prediction_points = grid), "target") + expect_identical(a$reading, "matched") + expect_identical(a$scale, if (is.null(sac)) "distance" else "correlation") + b <- attr(fold_separation(blk, even, sac = sac, prediction_points = grid), "target") + expect_identical(b$reading, "farther") + expect_gt(b$mean_diff, 0) + } + # Clustered points, a grid over the whole box: random folds hold a point + # out next to its cluster while the map is mostly predicted between them. + cl <- st_clustered(seed = 12); gcl <- st_grid(cl) + rcl <- st_q(make_folds(cl, k = 5, method = "random_kfold", seed = 1)) + for (sac in list(1e5, NULL)) { + d <- attr(fold_separation(rcl, cl, sac = sac, prediction_points = gcl), "target") + expect_identical(d$reading, "closer") + expect_lt(d$mean_diff, 0) + } + + # The print words each as a statement about distances. + expect_match(st_flat(fold_separation(rnd, even, sac = 1e5, prediction_points = grid)), + "about as far from their training data as the prediction points do") + out_far <- st_flat(fold_separation(blk, even, sac = 1e5, prediction_points = grid)) + expect_match(out_far, "farther from their training data than the prediction points do, so the cross-validated error tends to read high") + out_near <- st_flat(fold_separation(rcl, cl, sac = 1e5, prediction_points = gcl)) + expect_match(out_near, "closer to their training data than the prediction points do, so the cross-validated error tends to read low") + for (o in c(out_far, out_near)) { + expect_no_match(o, "optimistic"); expect_no_match(o, "leak") + expect_match(o, "Held-out minus prediction: [+-][0-9.e+]+ in mean distance \\(W1 [0-9.e+]+\\); [+-][0-9.]+ on the correlation scale") + } + # The old print said "optimistic: widen the blocks" of the blocked design + # that already reads high on this layout. + expect_no_match(out_far, "widen") +}) + +test_that("the target distances are the ones a hand computation gives", { + pts <- st_even(90, seed = 21); grid <- st_grid(pts, m = 12) + f <- st_q(make_folds(pts, k = 3, method = "random_kfold", seed = 4)) + s <- fold_separation(f, pts, prediction_points = grid) + tg <- attr(s, "target") + xy <- sf::st_coordinates(pts); gxy <- sf::st_coordinates(grid) + expect_identical(tg$n_prediction_points, 144L) + expect_identical(tg$basis, "each fold's training data") + expect_identical(tg$source, "prediction_points") + # Each fold's prediction distances are to that fold's own training rows. + per <- lapply(f$folds, function(sp) list( + cv = st_nn(xy[sp$test, , drop = FALSE], xy[sp$train, , drop = FALSE]), + tg = st_nn(gxy, xy[sp$train, , drop = FALSE]))) + for (j in 1:3) { + expect_equal(s$target_median_dist[j], stats::median(per[[j]]$tg)) + expect_equal(s$dist_gap[j], mean(per[[j]]$cv) - mean(per[[j]]$tg)) + } + # Pooled: folds count by their share of the held-out points. + wts <- vapply(per, function(p) length(p$cv), 1) / nrow(pts) + expect_equal(tg$held_out_mean, mean(unlist(lapply(per, `[[`, "cv")))) + expect_equal(tg$target_mean, sum(wts * vapply(per, function(p) mean(p$tg), 1))) + expect_equal(tg$mean_diff, tg$held_out_mean - tg$target_mean) + # The distances to all sites sit beside them, and are shorter: each fold + # trains on two thirds of the sites. + all_d <- st_nn(gxy, xy) + expect_equal(tg$target_all_median, stats::median(all_d)) + expect_equal(tg$target_all_mean, mean(all_d)) + expect_lt(tg$target_all_mean, tg$target_mean) + # W1 is the unsigned area between the two distributions, never below the + # signed one. + expect_gte(tg$w1, abs(tg$mean_diff)) + expect_true(is.na(tg$cor_gap)) +}) + +test_that("prediction_points takes points, cells or an sfc, in any CRS", { + pts <- st_even(90, seed = 22); grid <- st_grid(pts, m = 10) + f <- st_q(make_folds(pts, k = 3, method = "random_kfold", seed = 4)) + base <- attr(fold_separation(f, pts, prediction_points = grid), "target") + expect_equal(attr(fold_separation(f, pts, prediction_points = sf::st_geometry(grid)), "target")$mean_diff, + base$mean_diff) + ll <- attr(fold_separation(f, pts, prediction_points = sf::st_transform(grid, 4326)), "target") + expect_equal(ll$mean_diff, base$mean_diff, tolerance = 1e-6) + # Grid cells are reduced to one point each. + cells <- sf::st_as_sf(sf::st_make_grid(pts, n = c(10, 10))) + expect_identical(attr(st_q(fold_separation(f, pts, prediction_points = cells)), "target")$n_prediction_points, + 100L) + expect_error(fold_separation(f, pts, prediction_points = data.frame(x = 1)), + "`prediction_points` must be an sf or sfc layer") + expect_error(fold_separation(f, pts, prediction_points = grid[0, ]), + "`prediction_points` has no rows") +}) + +test_that("leave-one-out schemes are measured against all sites", { + pts <- st_even(80, seed = 23); grid <- st_grid(pts, m = 10) + loo <- st_q(make_folds(pts, method = "buffered_loo", buffer = 2e4)) + s <- fold_separation(loo, pts, prediction_points = grid) + tg <- attr(s, "target") + expect_identical(tg$basis, "all sites") + xy <- sf::st_coordinates(pts) + all_d <- st_nn(sf::st_coordinates(grid), xy) + expect_equal(tg$target_mean, mean(all_d)) + expect_equal(unique(s$target_median_dist), stats::median(all_d)) + # Eighty one-point folds are not printed row by row. + out <- utils::capture.output(print(s)) + expect_true(any(grepl("and 70 more fold\\(s\\)", out))) + expect_lt(length(out), 40L) +}) + +test_that("crossing distributions read as mixed, and no reading names a verdict", { + rd <- spatialkit:::.fold_sep_reading + expect_identical(rd(-0.30, 0.30, 0.1), "closer") + expect_identical(rd(0.30, 0.31, 0.1), "farther") + expect_identical(rd(0.02, 0.05, 0.1), "matched") + # A net shift that is the remainder of two opposite ones names no side. + expect_identical(rd(-0.11, 0.50, 0.1), "mixed") + expect_identical(rd(0.02, 0.40, 0.1), "mixed") + expect_true(is.na(rd(NA_real_, 0.1, 0.1))) + + # Two samples that cross: equal means, different spreads. + cmp <- spatialkit:::.fold_sep_compare(c(1, 9), c(4, 6)) + expect_equal(cmp$diff, 0) + expect_equal(cmp$w1, 3) + # One wholly to one side of the other: the two areas are equal. + cmp2 <- spatialkit:::.fold_sep_compare(c(1, 2, 3), c(11, 12, 13)) + expect_equal(cmp2$diff, -10); expect_equal(cmp2$w1, 10) + # Weights: the second value counted three times is a sample of four. + expect_equal(spatialkit:::.fold_sep_compare(1, c(0, 4), wb = c(1, 3))$mean_b, 3) + + adv <- spatialkit:::.fold_separation_advice + tg <- function(reading) list(reading = reading, basis = "each fold's training data", + target_median = 10, target_all_median = 9, mean_diff = -3, + w1 = 4, cor_gap = -0.2, cor_w1 = 0.2) + for (rdg in c("closer", "farther", "matched", "mixed")) for (m in c("block_kfold", "nndm")) { + txt <- adv(tg(rdg), m) + expect_no_match(txt, "optimistic"); expect_no_match(txt, "leak") + expect_no_match(txt, "widen"); expect_no_match(txt, "use blocked") + } + expect_match(adv(tg("mixed"), "block_kfold"), "give no single direction") + expect_match(adv(NULL, "block_kfold"), "No prediction target is given") + expect_match(adv(tg("matched"), "random_kfold"), "do not make a score unbiased by themselves") +}) + +test_that("the old column name within_range is gone from the table and its pooled record", { + pts <- sf::st_as_sf(data.frame(x = 5e5 + 1000 * c(0, 1, 2, 3, 10, 11, 12, 13), + y = 4e6 + 1000 * c(0, 1, 0, 1, 0, 1, 0, 1)), + coords = c("x", "y"), crs = 32617) + folds <- list(list(train = 1:4, test = 5:8), list(train = 5:8, test = 1:4)) + s <- fold_separation(folds, pts, sac = 5000) + expect_true("mean_cor" %in% names(s)) + expect_false("within_range" %in% names(s)) + expect_true("mean_cor" %in% names(attr(s, "pooled"))) + expect_false("within_range" %in% names(attr(s, "pooled"))) +}) diff --git a/tests/testthat/test-fix-folds-small-inconsistencies.R b/tests/testthat/test-fix-folds-small-inconsistencies.R new file mode 100644 index 00000000..ab45b52f --- /dev/null +++ b/tests/testthat/test-fix-folds-small-inconsistencies.R @@ -0,0 +1,166 @@ +# tests/testthat/test-fix-folds-small-inconsistencies.R +# --------------------------------------------------------------------------- +# Three labelling and silence inconsistencies; none changes a score. +# 1. fold_separation()'s n_unknown_ids counted fold entries, not rows. +# 2. The cv_*() functions and compare_models_cv() dropped block_size and +# auto_range without a word when folds were supplied. +# 3. compare_models(newdata = ) labelled its rows "newdata" beside Moran's I +# columns computed on the training residuals, with nothing saying so. +# Each test fails on the code before the fix. +# --------------------------------------------------------------------------- + +si_pts <- function(n = 200, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1e4), y = 5e6 + runif(n, 0, 1e4), + a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + rnorm(n) + d +} +si_q <- function(expr) r2_quiet(suppressMessages(expr)) +# The conditions of one class a call raises; other warnings are muffled. +si_classed <- function(expr, class) { + hit <- list() + withCallingHandlers(expr, warning = function(c) { + if (inherits(c, class)) hit[[length(hit) + 1L]] <<- c + invokeRestart("muffleWarning") + }) + hit +} + +# ---- 1. n_unknown_ids counts rows ------------------------------------------- + +test_that("fold_separation() counts each unknown row once, whatever the fold count", { + u <- si_pts() + u$..row_id <- seq_len(nrow(u)) + u195 <- u[-(1:5), ] + for (k in c(3L, 5L, 10L)) { + f <- si_q(make_folds(u, k = k, method = "random_kfold", seed = 1)) + # Folds built on 200 rows, measured on 195 of them. Five rows are + # missing; they used to read as 15, 25 and 50. + s <- si_q(fold_separation(f, u195)) + expect_identical(attr(s, "n_unknown_ids"), 5L, info = paste("k =", k)) + expect_identical(sum(s$n_test), 195L) + # ... which is what cv_*() report for the same folds on the same layer. + cv <- si_q(suppressWarnings(cv_spatial(u195, "z", "a", fit_fn = r2_fit, folds = f))) + expect_identical(cv$n_unknown_ids, 5L) + } + # 200 buffered leave-one-out folds read as 996. + b <- si_q(suppressWarnings(make_folds(u, method = "buffered_loo", buffer = 300))) + expect_identical(attr(si_q(fold_separation(b, u195)), "n_unknown_ids"), 5L) + # A bare split list is counted the same way. + expect_identical(attr(si_q(fold_separation(b$folds, u195)), "n_unknown_ids"), 5L) + # Nothing missing, nothing counted. + f <- si_q(make_folds(u, k = 5, method = "random_kfold", seed = 1)) + expect_identical(attr(fold_separation(f, u), "n_unknown_ids"), 0L) + # The log line counts rows too. + lines <- capture_spatialkit_log(fold_separation(f, u195), level = logger::INFO) + expect_true(log_has(lines, "the folds name 5 row\\(s\\) `data_sf` does not have")) +}) + +# ---- 2. block_size and auto_range beside supplied folds --------------------- + +test_that("cv_spatial() warns when block_size or auto_range arrive with folds", { + u <- si_pts() + f5 <- si_q(make_folds(u, k = 5, method = "random_kfold", seed = 1)) + base <- si_q(cv_spatial(u, "z", "a", fit_fn = r2_fit, folds = f5)) + for (args in list(list(auto_range = TRUE), list(block_size = 3000), + list(auto_range = TRUE, block_size = 3000))) { + w <- list() + cv <- withCallingHandlers( + si_q(do.call(cv_spatial, c(list(u, "z", "a", fit_fn = r2_fit, folds = f5), args))), + spatialkit_fold_args_ignored = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + expect_length(w, 1L) + msg <- conditionMessage(w[[1L]]) + expect_match(msg, "^cv_spatial\\(\\): ") + expect_match(msg, "no effect because `folds` is supplied") + if (!is.null(args$block_size)) expect_match(msg, "`block_size`", fixed = TRUE) + if (isTRUE(args$auto_range)) expect_match(msg, "`auto_range = TRUE`", fixed = TRUE) + # The run itself is the one on the supplied folds, as before. + expect_identical(cv$predictions, base$predictions) + } +}) + +test_that("every cv_*() and compare_models_cv() raise the same classed warning", { + u <- si_pts() + f5 <- si_q(make_folds(u, k = 5, method = "random_kfold", seed = 1)) + # tryCatch() by class leaves the call at the warning, before any model is + # fitted, so the backends' packages are not needed to see it raised. + first <- function(expr) tryCatch({ expr; NULL }, spatialkit_fold_args_ignored = function(w) w) + hits <- list( + cv_gwr = if (requireNamespace("GWmodel", quietly = TRUE) && + requireNamespace("sp", quietly = TRUE)) + first(si_q(cv_gwr(u, "z", "a", folds = f5, bandwidth = 40, block_size = 3000))), + cv_bayes = first(si_q(cv_bayes(u, "z", "a", folds = f5, auto_range = TRUE))), + cv_rf = if (requireNamespace("ranger", quietly = TRUE)) + first(si_q(cv_rf(u, "z", "a", folds = f5, num_trees = 20, block_size = 3000))), + compare_models_cv = if (requireNamespace("ranger", quietly = TRUE)) + first(si_q(compare_models_cv(u, "z", "a", models = "RF", folds = f5, + quiet = TRUE, auto_range = TRUE)))) + hits <- Filter(Negate(is.null), hits) + # cv_bayes() needs no backend to get as far as the warning. + expect_true("cv_bayes" %in% names(hits)) + for (nm in names(hits)) { + expect_s3_class(hits[[nm]], "spatialkit_fold_args_ignored") + expect_s3_class(hits[[nm]], "warning") + # Named for the function the user called. + expect_match(conditionMessage(hits[[nm]]), sprintf("^%s\\(\\): ", nm), info = nm) + } +}) + +test_that("supplied folds without those arguments, and k, raise nothing", { + skip_if_not_installed("ranger") + u <- si_pts() + f5 <- si_q(make_folds(u, k = 5, method = "random_kfold", seed = 1)) + cls <- "spatialkit_fold_args_ignored" + # k is not checked: the package's own callers always pass it with folds. + expect_length(si_classed(si_q(cv_rf(u, "z", "a", folds = f5, num_trees = 20, k = 10)), cls), 0L) + expect_length(si_classed(si_q(cv_spatial(u, "z", "a", fit_fn = r2_fit, folds = f5, k = 3)), cls), 0L) + # compare_models_cv() builds one fold set and hands it to each backend + # with k: no warning from inside the package. + expect_length(si_classed(si_q(compare_models_cv(u, "z", "a", models = "RF", k = 4, + rf_args = list(num_trees = 20), + quiet = TRUE)), cls), 0L) + # block_size without folds is the documented use. + expect_length(si_classed(si_q(compare_models_cv(u, "z", "a", models = "RF", k = 4, + block_size = 2500, + rf_args = list(num_trees = 20), + quiet = TRUE)), cls), 0L) + # The sweep hands cv_spatial() its own folds at every size. + expect_length(si_classed(si_q(cv_block_size_sweep(u, "z", "a", fit_fn = r2_fit, k = 3, + n_sizes = 2, include_random = FALSE, + sac = 2000, quiet = TRUE)), cls), 0L) +}) + +# ---- 3. compare_models(newdata = ): which residuals Moran's I is about ------ + +test_that("compare_models() says which residuals its Moran columns describe", { + skip_if_not_installed("ranger") + u <- si_pts(160, seed = 2) + tr <- u[1:100, ]; te <- u[101:160, ] + fits <- list(RF = fit_rf_model(tr, "z", "a", num_trees = 100, seed = 1), + LM = lm_spatial_fit(tr, "z", "a")) + if (requireNamespace("GWmodel", quietly = TRUE) && requireNamespace("sp", quietly = TRUE)) + fits$GWR <- si_q(suppressWarnings(fit_gwr_model(tr, "z", "a", adaptive = TRUE, bandwidth = 30))) + with_new <- si_q(suppressWarnings(compare_models(fits, newdata = te))) + without <- si_q(suppressWarnings(compare_models(fits))) + + expect_true("resid_morans_basis" %in% names(with_new)) + basis <- stats::setNames(with_new$resid_morans_basis, with_new$model) + # A forest's residuals() are out-of-bag, every other backend's in-sample. + expect_identical(basis[["RF"]], "out-of-bag") + expect_identical(basis[["LM"]], "in-sample") + if ("GWR" %in% names(fits)) expect_identical(basis[["GWR"]], "in-sample") + # The metrics are on newdata; the Moran columns are not, and never say so. + expect_true(all(with_new$metric_basis == "newdata")) + expect_false(any(with_new$resid_morans_basis == "newdata", na.rm = TRUE)) + # They are the same numbers with and without newdata, from the same rows. + key <- c("resid_morans_I", "resid_morans_z", "resid_morans_p", "resid_morans_basis") + expect_equal(with_new[match(names(fits), with_new$model), key], + without[match(names(fits), without$model), key], ignore_attr = TRUE) + for (nm in names(fits)) + expect_equal(with_new$resid_morans_I[with_new$model == nm], + suppressWarnings(residual_morans_i(fits[[nm]]))$observed) +}) diff --git a/tests/testthat/test-fix-folds-zero-target.R b/tests/testthat/test-fix-folds-zero-target.R new file mode 100644 index 00000000..e0c2ecaf --- /dev/null +++ b/tests/testthat/test-fix-folds-zero-target.R @@ -0,0 +1,185 @@ +# tests/testthat/test-fix-folds-zero-target.R +# --------------------------------------------------------------------------- +# fold_separation() with a prediction target it could not put a reading on. +# +# Prediction points on top of the sites (a model scored where it was sampled) +# have a prediction mean of 0. On the distance scale the gap was divided by +# that mean, so it was infinite, the reading was NA, and print() closed with +# "No prediction target is given ... Pass `prediction_points`" under a header +# that named the target. NNDM folds measured in another CRS than the one +# their target distances are in had the target dropped and printed the same +# sentence. Each test fails on the code before the fix. +# --------------------------------------------------------------------------- + +zt_pts <- function(n = 80, seed = 7) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1e4), y = 5e6 + runif(n, 0, 1e4)), + coords = c("x", "y"), crs = 32632) +} +zt_flat <- function(x) gsub("\\s+", " ", paste(utils::capture.output(print(x)), collapse = " ")) +zt_q <- function(expr) r2_quiet(suppressWarnings(suppressMessages(expr))) + +test_that("prediction points on the samples read 'farther' without a range", { + u <- zt_pts() + nn <- zt_q(make_folds(u, method = "nndm", prediction_points = u)) + expect_identical(nn$params$target_median, 0) + expect_true(nn$params$target_out_of_reach) + designs <- list( + # The target the NNDM folds carry, and the same points passed again. + nndm_carried = list(folds = nn, pp = NULL), + nndm_passed = list(folds = nn, pp = u), + buffered_loo = list(folds = zt_q(make_folds(u, method = "buffered_loo", buffer = 800)), + pp = u), + random_60 = list(folds = zt_q(make_folds(u, k = 60, method = "random_kfold", seed = 1)), + pp = u)) + for (nm in names(designs)) { + s <- fold_separation(designs[[nm]]$folds, u, prediction_points = designs[[nm]]$pp) + tg <- attr(s, "target") + expect_identical(tg$basis, "all sites", info = nm) + expect_identical(tg$scale, "distance", info = nm) + # Every prediction point is a site, so every prediction distance is 0 ... + expect_identical(tg$target_mean, 0, info = nm) + expect_identical(tg$target_median, 0, info = nm) + # ... and the held-out distances lie wholly above them: the gap is the + # held-out mean, and it is all of the difference between the two. + expect_gt(tg$mean_diff, 0) + expect_equal(tg$mean_diff, tg$held_out_mean, info = nm) + expect_equal(tg$w1, tg$mean_diff, info = nm) + # It was NA, from a gap of Inf. + expect_identical(tg$reading, "farther", info = nm) + out <- zt_flat(s) + expect_match(out, "prediction target: 80 point\\(s\\)", info = nm) + # The closing lines used to deny, under that header, that there was one. + expect_no_match(out, "No prediction target is given", info = nm) + expect_no_match(out, "Pass `prediction_points`", info = nm) + expect_match(out, "The prediction points sit a median of 0 from the nearest of all sites", + info = nm) + expect_match(out, "farther from their training data than the prediction points do, so the cross-validated error tends to read high", + info = nm) + } + # The NNDM folds say why nothing could be done about it. + expect_match(zt_flat(fold_separation(nn, u)), "NNDM can only lengthen a held-out distance") + # With a range the reading was already right; the two scales now agree. + expect_identical(attr(fold_separation(nn, u, sac = 3000), "target")$reading, "farther") +}) + +test_that("held-out and prediction distances that are all 0 read 'matched'", { + # Twenty locations measured twice, the two measurements in opposite folds: + # every held-out point has its twin in the training data, and every + # prediction point (the sites again) lies on a training point too. + set.seed(9) + xy <- cbind(runif(20, 0, 1e4), runif(20, 0, 1e4)) + d <- sf::st_as_sf(data.frame(x = 5e5 + rep(xy[, 1], 2), y = 5e6 + rep(xy[, 2], 2)), + coords = c("x", "y"), crs = 32632) + splits <- list(list(train = 21:40, test = 1:20), list(train = 1:20, test = 21:40)) + s <- fold_separation(splits, d, prediction_points = d) + tg <- attr(s, "target") + expect_identical(tg$held_out_mean, 0) + expect_identical(tg$target_mean, 0) + expect_identical(tg$mean_diff, 0) + expect_identical(tg$w1, 0) + expect_identical(tg$reading, "matched") # was NA, from 0 / 0 + out <- zt_flat(s) + expect_no_match(out, "No prediction target is given") + expect_match(out, "about as far from their training data as the prediction points do") +}) + +test_that("the reading rule takes a tolerance of 0", { + rd <- spatialkit:::.fold_sep_reading + # Identical distributions are matched whatever the tolerance. + expect_identical(rd(0, 0, 0), "matched") + expect_identical(rd(0, 0, 0.1), "matched") + # With no tolerance any net shift that is most of the difference has a side. + expect_identical(rd(589.1, 589.1, 0), "farther") + expect_identical(rd(-3, 3, 0), "closer") + # Equal means and different spreads still cross. + expect_identical(rd(0, 3, 0), "mixed") + # The cases with a tolerance are read as before. + expect_identical(rd(-0.30, 0.30, 0.1), "closer") + expect_identical(rd(0.02, 0.05, 0.1), "matched") + expect_identical(rd(-0.11, 0.50, 0.1), "mixed") +}) + +test_that("a share of the prediction mean is read the same in distance units", { + # The distance-scale reading is now taken on the distances themselves, + # against a quarter of the prediction mean, in place of ratios to that + # mean. Where the mean is above 0 the two are the same rule. + set.seed(31) + pts <- sf::st_as_sf(data.frame(x = 2e5 + runif(200, 0, 3e5), y = 4e6 + runif(200, 0, 3e5)), + coords = c("x", "y"), crs = 32617) + grid <- sf::st_as_sf(sf::st_make_grid(pts, n = c(20, 20), what = "centers")) + rd <- spatialkit:::.fold_sep_reading + for (f in list(zt_q(make_folds(pts, k = 5, method = "random_kfold", seed = 1)), + zt_q(make_folds(pts, k = 5, method = "block_kfold", block_size = 1e5, seed = 1)), + zt_q(make_folds(pts, method = "buffered_loo", buffer = 2e4)))) { + tg <- attr(fold_separation(f, pts, prediction_points = grid), "target") + expect_gt(tg$target_mean, 0) + expect_identical(tg$tolerance, 0.25) + expect_identical(tg$reading, + rd(tg$mean_diff / tg$target_mean, tg$w1 / tg$target_mean, 0.25)) + } +}) + +test_that("NNDM folds measured in another CRS say their target is not compared", { + u <- zt_pts(150, seed = 3) + g <- sf::st_as_sf(sf::st_make_grid(u, n = c(25, 25), what = "centers")) + f <- zt_q(make_folds(u, method = "nndm", prediction_points = g)) + expect_identical(f$params$crs, "EPSG:32632") + + # Measured where the folds were built, the carried target is compared. + s0 <- fold_separation(f, u) + expect_type(attr(s0, "target"), "list") + expect_null(attr(s0, "not_compared")) + + # The same rows in another projected CRS: the carried distances are lengths + # in EPSG:32632 and cannot be set beside distances in EPSG:3857. + u2 <- sf::st_transform(u, 3857) + sac_other <- structure(3000, class = c("sac_range", "numeric"), crs = sf::st_crs(3857)) + for (s in list(zt_q(fold_separation(f, u2)), zt_q(fold_separation(f, u, sac = sac_other)))) { + expect_identical(attr(s, "crs"), "EPSG:3857") + # NULL, and not the sentence below: attr() matches names partially, so + # the reason is kept under a name that does not begin with "target". + expect_null(attr(s, "target")) + note <- attr(s, "not_compared") + expect_type(note, "character") + expect_match(note, "625 prediction points") + expect_match(note, "EPSG:32632") + expect_match(note, "EPSG:3857") + out <- zt_flat(s) + # These folds were built for a target; the print used to say none was given. + expect_no_match(out, "No prediction target is given") + expect_no_match(out, "prediction target: ") + expect_match(out, "so the two are not compared") + expect_match(out, "Pass `prediction_points` to have the target measured here") + } + # Following that advice gives the reading the folds have where they were built. + s2 <- fold_separation(f, u2, prediction_points = g) + expect_null(attr(s2, "not_compared")) + expect_identical(attr(s2, "target")$reading, attr(s0, "target")$reading) + expect_no_match(zt_flat(s2), "not compared") + + # Other fold schemes carry no target, and still say none is given. + r <- zt_q(make_folds(u, k = 5, method = "random_kfold", seed = 1)) + sr <- fold_separation(r, u2) + expect_null(attr(sr, "not_compared")) + expect_match(zt_flat(sr), "No prediction target is given") +}) + +test_that("the closing lines never deny a target that exists", { + adv <- spatialkit:::.fold_separation_advice + none <- adv(NULL, "block_kfold") + expect_match(none, "No prediction target is given") + # A target that was not compared, with the reason. + noted <- adv(NULL, "nndm", note = "These NNDM folds carry X in A and the distances here are in B, so the two are not compared.") + expect_no_match(noted, "No prediction target is given") + expect_match(noted, "so the two are not compared\\. Pass `prediction_points` to have the target measured here") + # A target that was measured but has no reading: the numbers, and no + # sentence saying there is no target. + unread <- adv(list(reading = NA_character_, basis = "all sites", target_median = 0, + target_all_median = 0, mean_diff = 12, w1 = 12, cor_gap = NA_real_, + cor_w1 = NA_real_), "buffered_loo") + expect_no_match(unread, "No prediction target is given") + expect_no_match(unread, "Pass `prediction_points`") + expect_match(unread, "The prediction points sit a median of 0 from the nearest of all sites") + expect_match(unread, "no reading is drawn") +}) diff --git a/tests/testthat/test-fix-gwr-bandwidth-search.R b/tests/testthat/test-fix-gwr-bandwidth-search.R new file mode 100644 index 00000000..f323ffd9 --- /dev/null +++ b/tests/testthat/test-fix-gwr-bandwidth-search.R @@ -0,0 +1,288 @@ +# tests/testthat/test-fix-gwr-bandwidth-search.R +# --------------------------------------------------------------------------- +# The default bandwidth of a GWR is searched for on a grid first. +# +# GWmodel::bw.gwr() runs a golden-section search over the whole range, which +# finds the minimum of a criterion that has one. When the coefficients vary +# at a range only a few dozen observations resolve, AICc has a minimum at a +# small bandwidth and falls again towards a global fit; the search compares +# its first two probes (at 0.38 and 0.62 of the range), drops the lower part +# of the range, and returns a bandwidth of nearly every observation as the +# selected one. It also scores any bandwidth with a window of deficient rank +# as infinite or as rounding error. +# +# The package's search scores 16 log-spaced bandwidths over the whole range, +# refines round the best of them, and keeps what it scored. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +.bs_catch <- function(expr) { + w <- character(0); cls <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); cls <<- c(cls, class(cnd)[1L]) + invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w, classes = cls) +} + +# 300 points; the slope of `a` varies with a period of about 500 m. +.bs_local_slope <- function(n, seed) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n); b <- rnorm(n) + mu <- 2 + (1 + sin(x / 80) * cos(y / 80)) * a + 0.5 * b + sf::st_as_sf(data.frame(x = x, y = y, a = a, b = b, z = mu + rnorm(n, 0, 0.5), mu = mu), + coords = c("x", "y"), crs = 32632) +} + +# The design, response and coordinates fit_gwr_model() works on. +.bs_parts <- function(d, vars) { + list(X = cbind(Intercept = 1, as.matrix(sf::st_drop_geometry(d)[, vars, drop = FALSE])), + y = d$z, xy = sf::st_coordinates(d)) +} + + +test_that("the default bandwidth is the criterion's minimum, not a near-global one", { + skip_if_not_installed("GWmodel") + skip_on_cran() + # Before: this layer got 299 of 300 neighbours, 52 AICc above the minimum + # over the counts from 5 up, which lies at 36. + d <- .bs_local_slope(300, 2) + r <- .bs_catch(fit_gwr_model(d, "z", c("a", "b"))) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_length(r$warnings, 0L) + expect_lt(fit$info$bandwidth, 0.2 * 300) + p <- .bs_parts(d, c("a", "b")) + # Every count to 100 and every fifth beyond. + counts <- c(5:100, seq(105, 300, by = 5)) + full <- vapply(counts, function(k) + .gwr_criterion(p$X, p$y, p$xy, k, "bisquare", TRUE)$value, numeric(1)) + expect_identical(counts[which.min(full)], 36) + expect_lt(fit$info$AICc - min(full), 1) + expect_lt(abs(fit$info$bandwidth - 36), 10) + expect_false(fit$info$bandwidth_is_fallback) + # GWmodel's search on the same data, scored the same way. + gw <- .gwr_quietly(suppressWarnings(GWmodel::bw.gwr( + z ~ a + b, data = .to_sp(d, c("z", "a", "b")), approach = "AICc", + kernel = "bisquare", adaptive = TRUE))) + expect_gt(gw, 0.9 * 300) + expect_gt(.gwr_criterion(p$X, p$y, p$xy, gw, "bisquare", TRUE)$value - fit$info$AICc, 20) + # What the search scored is kept, and the bandwidth is its minimum. + bs <- fit$info$bandwidth_search + expect_identical(bs$approach, "AICc") + expect_identical(bs$range, c(5, 300)) + expect_named(bs$curve, c("bandwidth", "criterion", "tr_S", "n_deficient", "stage")) + expect_identical(sum(bs$curve$stage == "grid"), 16L) + expect_lte(bs$n_evaluations, 30L) + expect_identical(nrow(bs$curve), bs$n_evaluations) + expect_false(is.unsorted(bs$curve$bandwidth)) + expect_identical(bs$curve$bandwidth[which.min(bs$curve$criterion)], fit$info$bandwidth) + expect_equal(bs$criterion, fit$info$AICc, tolerance = 1e-8) + # Every scored value is the criterion at that bandwidth. + on_grid <- bs$curve$bandwidth %in% counts + expect_equal(bs$curve$criterion[on_grid], + full[match(bs$curve$bandwidth[on_grid], counts)], tolerance = 1e-10) + # Two minima on the grid: the one selected and the global fit's. + expect_true(bs$multimodal) + expect_gte(bs$n_local_minima, 2L) + expect_false(bs$near_global) + expect_false(bs$at_upper); expect_false(bs$at_lower); expect_false(bs$none_defined) + expect_match(.gwr_bw_search_note(bs, TRUE), "the criterion has 2 local minima on the 16-point grid") + # Another draw of the same process: 299 neighbours before, 35 now. + f3 <- suppressMessages(fit_gwr_model(.bs_local_slope(300, 3), "z", c("a", "b"))) + expect_lt(f3$info$bandwidth, 0.2 * 300) +}) + +test_that("on a stationary process the search ends near the top of the range, and info says so", { + skip_if_not_installed("GWmodel") + set.seed(201); n <- 300 + d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 + d$a + 0.5 * d$b + rnorm(n, 0, 0.5) + r <- .bs_catch(fit_gwr_model(d, "z", c("a", "b"))) + fit <- r$value + # A minimum at or near the top is the ordinary outcome here: no warning. + expect_length(r$warnings, 0L) + bs <- fit$info$bandwidth_search + expect_gt(fit$info$bandwidth, 0.8 * n) + # Every observation in each window scores within 2 of the minimum: AICc + # does not tell this fit from a global regression, and info records it. + expect_true(bs$near_global) + expect_identical(bs$within[2L], 300) + expect_identical(bs$n_local_minima, 1L) + expect_false(bs$multimodal) + # No worse than GWmodel's search, which is right on such data. + gw <- .gwr_quietly(suppressWarnings(GWmodel::bw.gwr( + z ~ a + b, data = .to_sp(d, c("z", "a", "b")), approach = "AICc", + kernel = "bisquare", adaptive = TRUE))) + p <- .bs_parts(d, c("a", "b")) + expect_lte(fit$info$AICc, .gwr_criterion(p$X, p$y, p$xy, gw, "bisquare", TRUE)$value + 0.2) + # The one sentence the log line carries. + note <- .gwr_bw_search_note(bs, TRUE) + expect_match(note, "the widest bandwidth of the range \\(300 neighbours\\) scores within 2 of the minimum, so the criterion does not tell this fit from one global regression") + expect_identical(.gwr_bw_search_note(NULL, TRUE), "") +}) + +test_that("the note names a floor minimum, several minima and a flat criterion", { + bs <- list(none_defined = FALSE, bandwidth = 5, criterion = 100, approach = "AICc", + range = c(5, 300), near_global = FALSE, + at_upper = FALSE, at_lower = TRUE, multimodal = TRUE, n_local_minima = 3L, + flat = TRUE, within = c(5, 90), + curve = data.frame(stage = rep(c("grid", "refine"), c(16, 4)))) + note <- .gwr_bw_search_note(bs, TRUE) + top <- utils::modifyList(bs, list(bandwidth = 300, at_upper = TRUE, at_lower = FALSE, + near_global = TRUE, multimodal = FALSE, flat = FALSE)) + expect_identical(.gwr_bw_search_note(top, TRUE), + "the minimum is at the top of the range (300 neighbours), so the fit is close to one global regression.") + expect_match(note, "the minimum is at the bottom of the range \\(5 neighbours\\)") + expect_match(note, "the criterion has 3 local minima on the 16-point grid") + expect_match(note, "the criterion is flat: bandwidths from 5 to 90 neighbours are within 2 of the minimum") + bs$approach <- "CV" + expect_match(.gwr_bw_search_note(bs, FALSE), "bandwidths from 5 to 90 are within 1 percent of the minimum") + bs$none_defined <- TRUE + expect_identical(.gwr_bw_search_note(bs, TRUE), "") +}) + +test_that("a fixed bandwidth is searched from where half the windows are complete, and beats bw.gwr()", { + skip_if_not_installed("GWmodel") + d <- .bs_local_slope(300, 2) + p <- .bs_parts(d, c("a", "b")) + sp_d <- .to_sp(d, c("z", "a", "b")) + for (kernel in c("bisquare", "gaussian")) { + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE, kernel = kernel))) + bs <- fit$info$bandwidth_search + # The range: from the median distance to the 5th-nearest point (a third of + # it for the Gaussian) to the largest distance between two points. + dm <- as.matrix(stats::dist(p$xy)) + d5 <- stats::median(apply(dm, 1L, function(v) sort(v)[5L])) + expect_equal(bs$range, c(if (kernel == "gaussian") d5 / 3 else d5, max(dm)), + tolerance = 1e-10, info = kernel) + expect_gt(fit$info$bandwidth, bs$range[1L]) + expect_lt(fit$info$bandwidth, bs$range[2L]) + gw <- .gwr_quietly(suppressWarnings(GWmodel::bw.gwr( + z ~ a + b, data = sp_d, approach = "AICc", kernel = kernel, adaptive = FALSE))) + a_gw <- .gwr_criterion(p$X, p$y, p$xy, gw, kernel, FALSE)$value + expect_lte(fit$info$AICc, a_gw + 0.01, label = kernel) + } + # With the bisquare kernel GWmodel's search ends at 1048 m, 56 AICc above + # this one's 215 m. + f_b <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE))) + gw_b <- .gwr_quietly(suppressWarnings(GWmodel::bw.gwr( + z ~ a + b, data = sp_d, approach = "AICc", kernel = "bisquare", adaptive = FALSE))) + expect_gt(.gwr_criterion(p$X, p$y, p$xy, gw_b, "bisquare", FALSE)$value - f_b$info$AICc, 20) +}) + +test_that("a bandwidth with windows of deficient rank is scored on its fitted values, so a small one can win", { + # A slope that varies at short range and a regional covariate. GWmodel's + # scorer gives every bandwidth with a deficient window Inf (coded 0/1) or + # 950 to 3958 (coded 0.7/1.3, at 12 to 130 neighbours), so the search + # settled at about the smallest bandwidth with none: 163 and 154 neighbours + # of 400, fitted values 0.69 off the noise-free mean. Scored on what the + # windows estimate, the minimum is at 22 for both codings. + set.seed(11); n <- 400 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + mu <- 1 + (2 + 1.5 * sin(x / 90) * cos(y / 90)) * a + 3 * (x > 500) + z <- mu + rnorm(n, 0, 0.3) + got <- lapply(list(c(0, 1), c(0.7, 1.3)), function(lev) { + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, z = z, + region = ifelse(x > 500, lev[2], lev[1])), + coords = c("x", "y"), crs = 32632) + r <- .bs_catch(fit_gwr_model(d, "z", c("a", "region"))) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_identical(fit$info$bandwidth, 22) + expect_lt(sqrt(mean((fitted(fit) - mu)^2)), 0.3) + expect_gt(fit$info$bandwidth_search$curve$n_deficient[ + fit$info$bandwidth_search$curve$bandwidth == 22], 200L) + # The warning about the deficient windows says the bandwidth was selected. + w <- r$warnings[r$classes == "spatialkit_gwr_rank_deficient"] + expect_length(w, 1L) + expect_match(w, "No bandwidth was supplied: the search selected this one \\(22\\)") + fit + }) + expect_equal(got[[2L]]$info$AICc, got[[1L]]$info$AICc, tolerance = 1e-8) + expect_equal(got[[2L]]$info$bandwidth_search$curve$criterion, + got[[1L]]$info$bandwidth_search$curve$criterion, tolerance = 1e-8) +}) + +test_that("the criterion at a bandwidth is GWmodel's AICc and its leave-one-out score", { + skip_if_not_installed("GWmodel") + set.seed(9); n <- 120 + d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + (1 + sf::st_coordinates(d)[, 1] / 1000) * d$a - d$b + rnorm(n, 0, 0.4) + p <- .bs_parts(d, c("a", "b")) + dm <- GWmodel::gw.dist(p$xy) + for (cs in list(list(bw = 30L, ad = TRUE, k = "bisquare"), list(bw = 250, ad = FALSE, k = "gaussian"), + list(bw = 18L, ad = TRUE, k = "exponential"))) { + aicc <- GWmodel:::gwr.aic(cs$bw, p$X, p$y, cs$k, cs$ad, p$xy, dMat = dm, verbose = FALSE) + cv <- GWmodel:::gwr.cv(cs$bw, p$X, p$y, cs$k, cs$ad, p$xy, dMat = dm, verbose = FALSE) + ours <- .gwr_criterion(p$X, p$y, p$xy, cs$bw, cs$k, cs$ad, "AICc") + expect_equal(ours$value, aicc, tolerance = 1e-9, info = cs$k) + expect_equal(.gwr_criterion(p$X, p$y, p$xy, cs$bw, cs$k, cs$ad, "CV")$value, cv, + tolerance = 1e-8, info = cs$k) + expect_identical(ours$n_deficient, 0L) + } + # A bandwidth at which every window holds its own point alone has no AICc + # and no leave-one-out prediction: Inf, so no search settles there. + expect_identical(.gwr_criterion(p$X, p$y, p$xy, 1e-6, "bisquare", FALSE, "AICc")$value, Inf) + expect_identical(.gwr_criterion(p$X, p$y, p$xy, 1e-6, "bisquare", FALSE, "CV")$value, Inf) +}) + +test_that("when no bandwidth has a defined AICc the widest is used and the fit says it was not selected", { + set.seed(4); n <- 4 + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n) + r <- .bs_catch(fit_gwr_model(d, "z", c("a", "b"))) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_identical(fit$info$bandwidth, 4) + expect_true(fit$info$bandwidth_search$none_defined) + expect_true(fit$info$bandwidth_is_fallback) + w <- grep("has a defined AICc", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "^fit_gwr_model\\(\\): no bandwidth from 4 to 4 neighbours has a defined AICc, so none could be selected") + expect_match(w, "The widest, 4, is used") + expect_false(any(grepl("arbitrary fallback", r$warnings))) +}) + +test_that("cv_gwr(bandwidth = NULL) selects each fold's bandwidth by the same search", { + skip_on_cran() + # Before, the five folds of this layer were fitted at 222 to 238 of 240 + # neighbours, five nearly global regressions. They are fitted at 30 to 37. + # (On a draw whose AICc has two minima of nearly equal depth the folds can + # still fall on either; each fit's info$bandwidth_search says when.) + d <- .bs_local_slope(300, 1) + cv <- suppressWarnings(suppressMessages( + cv_gwr(d, "z", c("a", "b"), folds = make_folds(d, k = 5, method = "random_kfold", seed = 1)))) + expect_identical(sum(cv$fold_status$status == "ok"), 5L) + bw <- cv$fold_metrics$bandwidth + expect_lt(max(bw) / min(bw), 3) + expect_lt(max(bw), 0.25 * 240) +}) + +test_that("gwr_model_selection() takes its default bandwidth from the same search, for either criterion", { + d <- .bs_local_slope(300, 2) + sel <- suppressWarnings(suppressMessages(gwr_model_selection(d, "z", c("a", "b")))) + expect_identical(sel$bandwidth_source, "AICc search on the full model") + p <- .bs_parts(d, c("a", "b")) + ref <- .gwr_bw_search(p$X, p$y, p$xy, "bisquare", TRUE, approach = "AICc") + expect_identical(as.numeric(sel$bandwidth), ref$bandwidth) + expect_identical(sel$bandwidth_search$curve, ref$curve) + expect_lt(sel$bandwidth, 100L) + cvs <- suppressWarnings(suppressMessages( + gwr_model_selection(d, "z", c("a", "b"), bw_approach = "CV"))) + expect_identical(cvs$bandwidth_source, "CV search on the full model") + expect_identical(cvs$bandwidth_search$approach, "CV") + expect_null(suppressWarnings(suppressMessages( + gwr_model_selection(d, "z", c("a", "b"), bandwidth = 40)))$bandwidth_search) +}) diff --git a/tests/testthat/test-fix-gwr-local-solve.R b/tests/testthat/test-fix-gwr-local-solve.R new file mode 100644 index 00000000..15d7c3ce --- /dev/null +++ b/tests/testthat/test-fix-gwr-local-solve.R @@ -0,0 +1,714 @@ +# tests/testthat/test-fix-gwr-local-solve.R +# --------------------------------------------------------------------------- +# The local regressions of a GWR are solved by the package: one weighted +# least squares per window, by pivoted QR, with one tolerance. +# +# A window of deficient rank (a predictor constant among the weighted +# observations, exactly collinear predictors, fewer weighted observations +# than parameters) used to go to an inverse of X'WX, which stopped the whole +# fit or returned coefficients made of rounding error according to how the +# predictor was coded: an indicator at 0/1 stopped, the same indicator at +# 0.7/1.3 returned slopes of -117 to 271 around a true 5. The tests below +# take each such case in several codings and require the same outcome for +# all of them: the fit is returned, a coefficient the window cannot estimate +# is NA, and a fitted or predicted value is returned when it is estimable. +# +# On windows of full rank the results are GWmodel's, to rounding error. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +# Every warning raised while evaluating `expr`, muffled, with its class, +# beside the value (or the error message, as a character string). +.ls_catch <- function(expr) { + w <- character(0); cls <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); cls <<- c(cls, class(cnd)[1L]) + invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w, classes = cls) +} + +.ls_rmse <- function(e) sqrt(mean(e^2)) + +# `n` points over a square of side `extent`, `np` standard-normal predictors +# (a, b, ...) and a response whose slope on `a` drifts from west to east. +.ls_pts <- function(n, seed, np = 1L, extent = 1000) { + set.seed(seed) + x <- runif(n, 0, extent); y <- runif(n, 0, extent) + df <- data.frame(x = 5e5 + x, y = 5e6 + y) + for (j in seq_len(np)) df[[letters[j]]] <- rnorm(n) + df$z <- 1 + (1 + x / extent) * df$a + rnorm(n, 0, 0.3) + sf::st_as_sf(df, coords = c("x", "y"), crs = 32632) +} + +# 300 points on a 1 km square. `region` takes `lev[1]` west of x = 500 and +# `lev[2]` east of it, so a 40-neighbour window away from that line holds it +# constant. The response is 1 + 2 a + 3 (east of the line) + noise of SD 0.3: +# the same points, predictor, noise and response for every `lev`, so two +# codings are one data set, and the slope of `region` times `step` (the +# distance between the two levels) is the same number in both. +.ls_regional <- function(lev) { + set.seed(42); n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + east <- x > 500; eps <- rnorm(n, 0, 0.3) + region <- ifelse(east, lev[2], lev[1]) + mu <- 1 + 2 * a + 3 * east + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, region = region, z = mu + eps), + coords = c("x", "y"), crs = 32632) + # Windows in which `region` is constant among the rows of weight above 0. + flat <- vapply(seq_len(n), function(i) { + w <- .gw_kernel_weights(sqrt((x - x[i])^2 + (y - y[i])^2), 40L, "bisquare", TRUE) + length(unique(region[w > 0])) == 1L + }, logical(1)) + list(d = d, mu = mu, flat = flat, east = east, x = x, y = y, region = region, + step = lev[2] - lev[1]) +} + + +# --------------------------------------------------------------------------- +# Full rank: GWmodel's numbers +# --------------------------------------------------------------------------- + +test_that("a well-posed fit agrees with GWmodel::gwr.basic() in every column and diagnostic", { + skip_if_not_installed("GWmodel") + cases <- list( + list(d = .ls_pts(150, 9), p = "a", bw = 30L, adaptive = TRUE, kernel = "bisquare"), + list(d = .ls_pts(200, 4, 2L), p = c("a", "b"), bw = 200, adaptive = FALSE, kernel = "gaussian"), + list(d = .ls_pts(250, 5, 3L), p = c("a", "b", "c"), bw = 40L, adaptive = TRUE, kernel = "tricube"), + list(d = .ls_pts(180, 7), p = "a", bw = 300, adaptive = FALSE, kernel = "bisquare"), + list(d = .ls_pts(160, 8, 2L), p = c("a", "b"), bw = 25L, adaptive = TRUE, kernel = "exponential"), + list(d = .ls_pts(170, 6, 2L), p = c("a", "b"), bw = 20L, adaptive = TRUE, kernel = "boxcar")) + for (i in seq_along(cases)) { + cs <- cases[[i]]; lab <- paste("case", i, cs$kernel) + r <- .ls_catch(fit_gwr_model(cs$d, "z", cs$p, adaptive = cs$adaptive, + bandwidth = cs$bw, kernel = cs$kernel)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_false("spatialkit_gwr_rank_deficient" %in% r$classes, info = lab) + g <- GWmodel::gwr.basic( + formula = stats::reformulate(cs$p, "z"), data = .to_sp(cs$d, c("z", cs$p)), + bw = cs$bw, kernel = cs$kernel, adaptive = cs$adaptive) + ours <- fit$engine$SDF@data; theirs <- g$SDF@data + # The same table, column for column: coefficients, fitted values, + # residuals, studentised residuals, standard errors, t values, local R2. + expect_identical(names(ours), names(theirs), info = lab) + nm <- c("Intercept", cs$p) + expect_equal(as.matrix(ours[nm]), as.matrix(theirs[nm]), tolerance = 1e-8, info = lab) + expect_equal(ours$yhat, theirs$yhat, tolerance = 1e-10, info = lab) + se <- paste0(nm, "_SE") + expect_lt(max(abs(as.matrix(ours[se]) / as.matrix(theirs[se]) - 1)), 1e-8, label = lab) + expect_equal(as.matrix(ours), as.matrix(theirs), tolerance = 1e-7, info = lab) + # coef() and fitted() are that table's columns. + expect_equal(as.matrix(coef(fit)), as.matrix(theirs[nm]), tolerance = 1e-8, info = lab) + expect_equal(as.numeric(fitted(fit)), theirs$yhat, tolerance = 1e-10, info = lab) + # The global numbers: trace of the hat matrix, effective parameters, RSS, + # AIC, AICc, BIC. + dg <- g$GW.diagnostic; n <- nrow(cs$d) + expect_equal(fit$info$tr_S, .gwr_trace_s(dg$AIC, dg$RSS.gw, n), tolerance = 1e-6, info = lab) + expect_equal(fit$info$enp, dg$enp, tolerance = 1e-8, info = lab) + expect_equal(fit$info$edf, dg$edf, tolerance = 1e-8, info = lab) + expect_equal(fit$info$AICc, dg$AICc, tolerance = 1e-9, info = lab) + expect_equal(unlist(fit$engine$GW.diagnostic), unlist(dg), tolerance = 1e-8, info = lab) + expect_equal(sum(fit$info$local_collinearity$leverage), fit$info$tr_S, info = lab) + # Every window has full rank, and nothing is NA. + expect_true(all(fit$info$local_collinearity$rank == length(nm)), info = lab) + expect_identical(fit$info$n_rank_deficient, 0L, info = lab) + expect_identical(fit$info$n_local_singular, 0L, info = lab) + } +}) + +test_that("predictions on full-rank windows agree with GWmodel::gwr.predict(), variance included", { + skip_if_not_installed("GWmodel") + d <- .ls_pts(200, 4, 2L) + set.seed(3) + nd <- sf::st_as_sf(data.frame(x = 5e5 + runif(40, 100, 900), y = 5e6 + runif(40, 100, 900), + a = rnorm(40), b = rnorm(40)), + coords = c("x", "y"), crs = 32632) + for (cs in list(list(bw = 35L, adaptive = TRUE, kernel = "bisquare"), + list(bw = 250, adaptive = FALSE, kernel = "gaussian"))) { + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "b"), adaptive = cs$adaptive, bandwidth = cs$bw, + kernel = cs$kernel))) + g <- .gwr_quietly(GWmodel::gwr.predict( + z ~ a + b, data = .to_sp(d, c("z", "a", "b")), + predictdata = .to_sp(nd, c("a", "b")), bw = cs$bw, kernel = cs$kernel, + adaptive = cs$adaptive)) + p <- predict(fit, newdata = nd, se.fit = TRUE) + expect_equal(p$fit, g$SDF$prediction, tolerance = 1e-9, info = cs$kernel) + expect_identical(predict(fit, newdata = nd), p$fit) + expect_equal(p$se.pred^2, g$SDF$prediction_var, tolerance = 1e-8, info = cs$kernel) + expect_true(all(p$se.fit < p$se.pred)) + expect_equal(p$residual.scale^2, fit$info$sigma2) + expect_equal(p$df, fit$info$edf) + } +}) + +test_that("predict() at the training rows is fitted(), to the last bit, for every kernel", { + d <- .ls_pts(120, 3, 2L) + for (kernel in c("bisquare", "gaussian", "tricube", "boxcar", "exponential")) + for (ad in c(TRUE, FALSE)) { + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "b"), adaptive = ad, kernel = kernel, + bandwidth = if (ad) 25 else 350))) + expect_false(anyNA(fitted(fit))) + expect_identical(predict(fit, newdata = d), unname(fitted(fit)), + info = paste(kernel, ad)) + } + # And where windows are of deficient rank. + rg <- .ls_regional(c(0.7, 1.3)) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(rg$d, "z", c("a", "region"), bandwidth = 40))) + expect_gt(fit$info$n_rank_deficient, 100L) + expect_identical(predict(fit, newdata = rg$d), unname(fitted(fit))) +}) + +test_that("the window helper returns the rows and weights of the full kernel vector", { + set.seed(1) + for (rep in 1:60) { + n <- sample(c(3L, 10L, 60L), 1L) + d <- c(0, round(runif(n - 1L, 0, 300), sample(0:2, 1L))) + if (rep %% 3L == 0L) d[2:3] <- 0 # points at the regression point + if (rep %% 4L == 0L) d <- pmin(d, 100) # ties at the kernel's edge + for (k in c("bisquare", "gaussian", "tricube", "boxcar", "exponential")) + for (ad in c(TRUE, FALSE)) { + bw <- if (ad) sample(seq_len(n + 2L), 1L) else sample(c(1e-9, 50, 100, 1e4), 1L) + w <- .gw_kernel_weights(d, bw, k, ad) + win <- .gw_window(d, .gw_kernel_width(d, bw, ad), k) + expect_identical(win$rows, which(w > 0)) + expect_identical(win$w, w[which(w > 0)]) + } + } +}) + + +# --------------------------------------------------------------------------- +# A predictor constant inside a window, in three codings +# --------------------------------------------------------------------------- + +test_that("a regional covariate gives the same fit coded 0/1, 0.7/1.3 and 288.7/289.3", { + # Before the local solve: coded 0/1 the fit stopped ("inv(): matrix is + # singular"); coded 0.7/1.3 it returned with fitted values 5.3 off the + # noise-free mean in the flat windows (root mean square) and an in-sample + # R2 of -1.9; coded 288.7/289.3 they were 13.9 off and R2 was -18.9. + fits <- list(); sets <- list() + for (lev in list(c(0, 1), c(0.7, 1.3), c(288.7, 289.3))) { + rg <- .ls_regional(lev); lab <- paste(lev, collapse = "/") + r <- .ls_catch(fit_gwr_model(rg$d, "z", c("a", "region"), bandwidth = 40)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_identical(sum(rg$flat), 185L) + co <- coef(fit); fv <- fitted(fit) + # The slope of `region` is NA exactly in the flat windows. + expect_identical(is.na(co$region), rg$flat, info = lab) + # So is the intercept, which would absorb 3 * region there, unless + # `region` is 0 in the window: then it is identified, and returned. + expect_identical(is.na(co$Intercept), rg$flat & rg$region != 0, info = lab) + # The slope of `a` is an estimate everywhere, near its true 2. + expect_false(anyNA(co$a)) + expect_lt(abs(mean(co$a[rg$flat]) - 2), 0.05) + # Every fitted value is estimable, and close to the noise-free mean. + expect_false(anyNA(fv)) + expect_lt(.ls_rmse(fv[rg$flat] - rg$mu[rg$flat]), 0.15) + expect_lt(.ls_rmse(fv[!rg$flat] - rg$mu[!rg$flat]), 0.15) + expect_gt(model_metrics(fit)$R2, 0.95) + # Counted, placed, and warned about with a class. + expect_identical(fit$info$n_rank_deficient, 185L, info = lab) + expect_identical(fit$info$n_local_singular, 185L, info = lab) + expect_identical(fit$info$local_collinearity$rank, ifelse(rg$flat, 2L, 3L), info = lab) + expect_identical(unname(fit$info$nonfinite_coef[, "region"]), rg$flat, info = lab) + expect_identical(sum(r$classes == "spatialkit_gwr_rank_deficient"), 1L, info = lab) + w <- r$warnings[r$classes == "spatialkit_gwr_rank_deficient"] + expect_match(w, "^fit_gwr_model\\(\\): 185 of 300 local regressions are rank deficient at the bandwidth in use \\(40 neighbours, bisquare kernel\\)") + expect_match(w, sprintf("Intercept at %d, a at 0, region at 185", sum(rg$flat & rg$region != 0))) + expect_match(w, "GWmodel::gwr.mixed\\(\\)") + expect_no_match(w, "No bandwidth was supplied") + # Standard errors: NA with their coefficient, estimates elsewhere. + cs <- coef(fit, se = TRUE) + expect_identical(is.na(cs$se$region), rg$flat, info = lab) + expect_false(anyNA(cs$se$a)) + fits[[lab]] <- fit; sets[[lab]] <- rg + } + # One fit, three codings: the same ranks, trace, AICc, slopes of `a`, and + # fitted values up to the shift of the response's level. + ref <- fits[[1L]] + # The two numbers are this fit's own, recorded when the solve was written: + # they hold the solve to what it returned then. That the three codings + # agree is tested below without them. + expect_equal(ref$info$tr_S, 42.2988, tolerance = 1e-5) + expect_equal(ref$info$AICc, 145.2796, tolerance = 1e-5) + for (lab in names(fits)[-1L]) { + f <- fits[[lab]] + expect_identical(f$info$local_collinearity$rank, ref$info$local_collinearity$rank) + expect_equal(f$info$tr_S, ref$info$tr_S, tolerance = 1e-9, info = lab) + expect_equal(f$info$AICc, ref$info$AICc, tolerance = 1e-9, info = lab) + expect_equal(coef(f)$a, coef(ref)$a, tolerance = 1e-8, info = lab) + expect_equal(fitted(f), fitted(ref), tolerance = 1e-8, info = lab) + keep <- !sets[[lab]]$flat + expect_equal(coef(f)$region[keep] * sets[[lab]]$step, + coef(ref)$region[keep] * sets[[1L]]$step, tolerance = 1e-7, info = lab) + } +}) + +test_that("the rank does not depend on a predictor's origin, a million units out included", { + # A rank decision on the uncentred design depends on where 0 is: at + # 1000000.7 / 1000001.3 it called 30 of the 115 windows in which `region` + # does vary rank deficient. + rg0 <- .ls_regional(c(0, 1)) + rg6 <- .ls_regional(c(1e6 + 0.7, 1e6 + 1.3)) + f0 <- suppressWarnings(suppressMessages(fit_gwr_model(rg0$d, "z", c("a", "region"), bandwidth = 40))) + f6 <- suppressWarnings(suppressMessages(fit_gwr_model(rg6$d, "z", c("a", "region"), bandwidth = 40))) + expect_identical(f6$info$local_collinearity$rank, f0$info$local_collinearity$rank) + expect_equal(f6$info$tr_S, f0$info$tr_S, tolerance = 1e-7) + expect_equal(fitted(f6), fitted(f0), tolerance = 1e-6) + # A temperature in degrees C and in kelvin: the same slopes and fitted values. + set.seed(1); n <- 200 + x <- runif(n, 0, 1e4); y <- runif(n, 0, 1e4) + tC <- 15 + 4 * sin(x / 3000) + 3 * cos(y / 2500) + rnorm(n) + d <- sf::st_as_sf(data.frame(x = x, y = y, tC = tC, tK = tC + 273.15), + coords = c("x", "y"), crs = 32632) + d$yield <- 50 - 0.8 * d$tC + rnorm(n) + fC <- suppressMessages(fit_gwr_model(d, "yield", "tC", bandwidth = 30)) + fK <- suppressMessages(fit_gwr_model(d, "yield", "tK", bandwidth = 30)) + expect_equal(coef(fK)$tK, coef(fC)$tC, tolerance = 1e-10) + expect_equal(fitted(fK), fitted(fC), tolerance = 1e-10) + expect_equal(coef(fK, se = TRUE)$se$tK, coef(fC, se = TRUE)$se$tC, tolerance = 1e-9) +}) + +test_that("predict() is finite where the new row's region is its window's, and NA where it is not", { + # Before: coded 0.7/1.3, predict() returned a number for every row, 119 + # off at worst, with no warning. + set.seed(7); m <- 400 + nx <- runif(m, 0, 1000); ny <- runif(m, 0, 1000); na_ <- rnorm(m) + out <- list() + for (lev in list(c(0, 1), c(0.7, 1.3), c(288.7, 289.3))) { + rg <- .ls_regional(lev); lab <- paste(lev, collapse = "/") + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(rg$d, "z", c("a", "region"), bandwidth = 40))) + # The value `region` is constant at among the weighted training rows of + # each new location's window, or NA where it varies there. + held <- vapply(seq_len(m), function(j) { + w <- .gw_kernel_weights(sqrt((rg$x - nx[j])^2 + (rg$y - ny[j])^2), 40L, "bisquare", TRUE) + u <- unique(rg$region[w > 0]); if (length(u) == 1L) u else NA_real_ + }, numeric(1)) + expect_identical(sum(!is.na(held)), 234L) + # (a) Every new row carries the region of where it lies: all estimable. + nd <- sf::st_as_sf(data.frame(x = nx, y = ny, a = na_, + region = ifelse(nx > 500, lev[2], lev[1])), + coords = c("x", "y"), crs = 32632) + p <- expect_no_warning(predict(fit, newdata = nd)) + expect_false(anyNA(p)) + truth <- 1 + 2 * na_ + 3 * (nx > 500) + expect_lt(.ls_rmse(p - truth), 0.15) + expect_lt(max(abs(p - truth)), 1) + # (b) The boundary of the new rows' region moved 300 m east: 53 rows now + # carry a value their window's training rows do not have. Those, and + # only those, are NA. + nd2 <- nd; nd2$region <- ifelse(nx > 800, lev[2], lev[1]) + unseen <- !is.na(held) & held != nd2$region + expect_identical(sum(unseen), 53L) + r <- .ls_catch(predict(fit, newdata = nd2)) + expect_identical(is.na(r$value), unseen, info = lab) + expect_identical(r$classes, "spatialkit_gwr_not_estimable") + expect_match(r$warnings, "^predict.gwr_fit\\(\\): 53 of 400 location\\(s\\) have no estimable local regression") + expect_match(r$warnings, "At 0 of them no training point carries weight") + expect_match(r$warnings, "At 53 the training points in the window cannot place the new row") + truth2 <- 1 + 2 * na_ + 3 * (nx > 800) + expect_lt(.ls_rmse((r$value - truth2)[!unseen]), 0.2) + # A standard error is NA with its prediction. + ps <- suppressWarnings(predict(fit, newdata = nd2, se.fit = TRUE)) + expect_identical(is.na(ps$se.fit), unseen) + expect_identical(is.na(ps$se.pred), unseen) + out[[lab]] <- p + } + expect_equal(out[[2L]], out[[1L]], tolerance = 1e-8) + expect_equal(out[[3L]], out[[1L]], tolerance = 1e-8) +}) + + +# --------------------------------------------------------------------------- +# Fewer weighted observations than parameters, and exact collinearity +# --------------------------------------------------------------------------- + +# Fifty points in a 500 m square and one more 400 m beyond its corner, whose +# predictor value is `a_far`. With a fixed bisquare bandwidth of 150 the far +# point's window holds the far point alone: one weighted point for two +# parameters. +.ls_far_point <- function(a_far) { + set.seed(1); n <- 50 + x <- c(runif(n, 0, 500), 900); y <- c(runif(n, 0, 500), 900) + d <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, a = c(rnorm(n), a_far)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + c(rnorm(n, 0, 0.3), 0) + d +} + +test_that("a window with one weighted point for two parameters returns its fitted value and no slope", { + # Before: with the far point's predictor at 0.5 or 0 the fit stopped; at + # 0.3, 0.7 and 1.3 it returned local coefficients of (4, -8), (19.6, -156) + # and (9.0, -13.0) there, for a true (1, 2). + res <- lapply(c(0.5, 0.3, 0.7, 1.3, 0), function(a_far) { + d <- .ls_far_point(a_far) + r <- .ls_catch(fit_gwr_model(d, "z", "a", adaptive = FALSE, bandwidth = 150)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + lc <- fit$info$local_collinearity + expect_identical(lc$rank[51], 1L) + expect_true(all(lc$rank[-51] == 2L)) + expect_equal(lc$leverage[51], 1) + expect_equal(fitted(fit)[51], d$z[51]) + co <- coef(fit) + expect_true(is.na(co$a[51])) + # One point at a = a_far says what the line is at a_far and nothing about + # where it crosses a = 0, unless a_far is 0. + expect_identical(is.na(co$Intercept[51]), a_far != 0) + if (a_far == 0) expect_equal(co$Intercept[51], d$z[51]) + expect_false(anyNA(co[-51, ])) + expect_identical(fit$info$n_rank_deficient, 1L) + expect_identical(fit$info$n_saturated, 1L) + w <- r$warnings[r$classes == "spatialkit_gwr_rank_deficient"] + expect_length(w, 1L) + expect_match(w, "^fit_gwr_model\\(\\): 1 of 51 local regressions are rank deficient at the bandwidth in use \\(150, bisquare kernel\\)") + expect_match(w, "a bandwidth that leaves a window fewer observations than parameters") + expect_no_match(w, "No bandwidth was supplied") + fit + }) + # The other fifty windows do not hold the far point and are the same fit + # (to rounding: the far point's value moves the predictor's overall scale). + for (f in res[-1L]) + expect_equal(coef(f)[-51, ], coef(res[[1L]])[-51, ], tolerance = 1e-12) +}) + +test_that("exactly collinear predictors: no slope is identified, every fitted value is", { + set.seed(3); n <- 200 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, b = 2 * a + 1, k = 5), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + a + rnorm(n, 0, 0.1) + # b is 2 a + 1 everywhere: neither slope has one value, and neither has the + # intercept (the 1 in b can move into it). Before, this fit stopped. + r <- .ls_catch(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 30)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_true(all(is.na(as.matrix(coef(fit))))) + expect_false(anyNA(fitted(fit))) + expect_lt(.ls_rmse(fitted(fit) - (1 + a)), 0.1) + expect_true(all(fit$info$local_collinearity$rank == 2L)) + expect_true("spatialkit_gwr_rank_deficient" %in% r$classes) + # A predictor constant over the whole layer: its slope and the intercept go, + # the slope of `a` stays. Before, this fit returned slopes of -11 to 16 + # for `k` and fitted values 5 off the mean. + rk <- .ls_catch(fit_gwr_model(d, "z", c("a", "k"), bandwidth = 30)) + ck <- coef(rk$value) + expect_true(all(is.na(ck$k)) && all(is.na(ck$Intercept))) + expect_false(anyNA(ck$a)) + expect_equal(fitted(rk$value), + fitted(suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30))), + tolerance = 1e-10) +}) + +# Four clusters of 50, 400 m apart; `soil` is exactly constant inside each. +.ls_clusters <- function(lev) { + set.seed(5) + cl <- rep(1:4, each = 50) + d <- sf::st_as_sf(data.frame( + x = c(runif(50, 0, 100), runif(50, 400, 500), runif(50, 0, 100), runif(50, 400, 500)), + y = c(runif(50, 0, 100), runif(50, 0, 100), runif(50, 400, 500), runif(50, 400, 500)), + a = rnorm(200), soil = rep(lev, 2L)[cl]), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + 3 * (d$soil - lev[1]) + rnorm(200, 0, 0.2) + d +} + +test_that("a predictor constant in every window gives the same fit at 0/1 and at 0.3/1.3", { + # Before: 0/1 stopped; 0.3/1.3 returned slopes of -461 to 186 around a true 3. + f01 <- suppressWarnings(suppressMessages( + fit_gwr_model(.ls_clusters(c(0, 1)), "z", c("a", "soil"), bandwidth = 20))) + f03 <- suppressWarnings(suppressMessages( + fit_gwr_model(.ls_clusters(c(0.3, 1.3)), "z", c("a", "soil"), bandwidth = 20))) + for (f in list(f01, f03)) { + expect_true(all(is.na(coef(f)$soil))) + expect_false(anyNA(coef(f)$a)) + expect_false(anyNA(fitted(f))) + expect_identical(f$info$n_rank_deficient, 200L) + } + expect_equal(coef(f03)$a, coef(f01)$a, tolerance = 1e-9) + expect_equal(fitted(f03), fitted(f01), tolerance = 1e-9) + expect_identical(sum(is.na(coef(f01)$Intercept)), 100L) # the soil = 1 clusters + expect_identical(sum(is.na(coef(f03)$Intercept)), 200L) +}) + +test_that("a zero-width adaptive kernel leaves a window no rows: rank 0, nothing estimable", { + set.seed(2) + sx <- runif(30, 0, 1000); sy <- runif(30, 0, 1000) + dd <- data.frame(x = rep(sx, each = 4), y = rep(sy, each = 4)) + dd$a <- rnorm(120); dd$z <- 1 + 2 * dd$a + rnorm(120, 0, 0.3) + d <- sf::st_as_sf(dd, coords = c("x", "y"), crs = 32632) + r <- .ls_catch(fit_gwr_model(d, "z", "a", bandwidth = 4, kernel = "gaussian")) + fit <- r$value + expect_identical(fit$info$local_collinearity$rank, rep(0L, 120L)) + expect_identical(fit$info$n_rank_deficient, 120L) + expect_true(all(is.na(fitted(fit)))) + expect_identical(fit$info$n_local_singular, 120L) + expect_true(is.na(fit$info$AICc)) + expect_true(any(grepl("4 or more observations share one location", r$warnings))) + # Not the rank-deficiency warning: these windows have no fitted value. + expect_false("spatialkit_gwr_rank_deficient" %in% r$classes) +}) + + +# --------------------------------------------------------------------------- +# Gaussian and exponential kernels: every point has weight, none is cut off +# --------------------------------------------------------------------------- + +# Sixty points in a 500 m square and, 400 m and more from them, two points U +# and T on one line, `gap` metres apart. +.ls_pair <- function(gap) { + set.seed(7); n <- 60 + xy <- rbind(cbind(runif(n, 0, 500), runif(n, 0, 500)), c(900 - gap, 900), c(900, 900)) + d <- sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], a = rnorm(n + 2L)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n + 2L, 0, 0.3) + d +} + +# Weighted least squares at row `i` by another route: LINPACK's QR +# (lm.wfit) on the predictors centred at row i's own values, so that its +# intercept is the fitted value there. +.ls_wls_at <- function(d, i, vars, w) { + X <- as.matrix(sf::st_drop_geometry(d)[, vars, drop = FALSE]) + Xc <- cbind(1, sweep(X, 2L, X[i, ])) + f <- stats::lm.wfit(Xc, d$z, w / max(w), tol = 1e-13) + list(fitted = unname(f$coefficients[1L]), slopes = unname(f$coefficients[-1L]), + rank = f$rank) +} + +test_that("an isolated pair under a Gaussian kernel is fitted, with the least-squares coefficients", { + # A count of the points whose weight is above 1e-8 of the window's largest + # calls U's and T's windows one-point windows at a gap of 310 m (6.2 + # bandwidths) and would refuse the fit. The windows have full rank: every + # other point enters with its weight, however small against the pair's. + for (gap in c(300, 310)) { + d <- .ls_pair(gap) + r <- .ls_catch(fit_gwr_model(d, "z", "a", adaptive = FALSE, bandwidth = 50, + kernel = "gaussian")) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_false("spatialkit_gwr_rank_deficient" %in% r$classes) + expect_true(all(fit$info$local_collinearity$rank == 2L)) + xy <- sf::st_coordinates(d) + for (i in 61:62) { + w <- exp(-0.5 * ((xy[, 1] - xy[i, 1])^2 + (xy[, 2] - xy[i, 2])^2) / 50^2) + ref <- .ls_wls_at(d, i, "a", w) + expect_identical(ref$rank, 2L) + expect_equal(fitted(fit)[i], ref$fitted, tolerance = 1e-9, info = paste(gap, i)) + expect_equal(coef(fit)$a[i], ref$slopes, tolerance = 1e-7, info = paste(gap, i)) + } + } +}) + +test_that("an observation many Gaussian bandwidths from the rest keeps its fitted value and loses its slope", { + # One observation `far` metres beyond 60 others, fixed Gaussian 100. At + # 3 and 6.5 bandwidths its window has full rank and the coefficients are the + # weighted least squares. At 10 and 15 the others' weights are 1e-23 and + # less of its own: by the tolerance they say nothing about the slope, which + # is NA, and the fitted value is the observation. Before, the solver + # returned (0.88, 1.52) there at both distances, which no window of the + # point supports, and a fitted value 0.17 from the observation. + one <- function(far) { + set.seed(1); m <- 60 + x <- c(runif(m, 0, 500), 250); y <- c(runif(m, 0, 500), 500 + far) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = rnorm(m + 1L)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(m + 1L, 0, 0.3) + list(d = d, w = exp(-0.5 * ((x - 250)^2 + (y - 500 - far)^2) / 100^2)) + } + for (far in c(310, 651)) { + s <- one(far) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(s$d, "z", "a", adaptive = FALSE, bandwidth = 100, kernel = "gaussian"))) + ref <- .ls_wls_at(s$d, 61L, "a", s$w) + expect_identical(fit$info$local_collinearity$rank[61], 2L) + expect_equal(coef(fit)$a[61], ref$slopes, tolerance = 1e-8, info = far) + expect_equal(fitted(fit)[61], ref$fitted, tolerance = 1e-10, info = far) + } + for (far in c(1026, 1523)) { + s <- one(far) + r <- .ls_catch(fit_gwr_model(s$d, "z", "a", adaptive = FALSE, bandwidth = 100, + kernel = "gaussian")) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_identical(fit$info$local_collinearity$rank[61], 1L) + expect_true(is.na(coef(fit)$a[61])) + expect_equal(fitted(fit)[61], s$d$z[61], tolerance = 1e-12) + expect_equal(fit$info$local_collinearity$leverage[61], 1, tolerance = 1e-12) + expect_false(anyNA(coef(fit)$a[-61])) + expect_identical(sum(r$classes == "spatialkit_gwr_rank_deficient"), 1L) + } +}) + +test_that("a regional covariate under a fixed Gaussian or exponential kernel is fitted, whatever its origin", { + # Fixed Gaussian 60 and exponential 20 on the regional layer. Before, the + # Gaussian fit coded 0/1.3 was 0.18 off the noise-free mean and the one + # coded 288/289.3 was 2.6 off, by the origin alone; both are 0.13 off. + for (cs in list(list(kernel = "gaussian", bw = 60, n_def = 15L), + list(kernel = "exponential", bw = 20, n_def = 0L))) { + fits <- lapply(list(c(0, 1.3), c(288, 289.3)), function(lev) { + rg <- .ls_regional(lev) + r <- .ls_catch(fit_gwr_model(rg$d, "z", c("a", "region"), adaptive = FALSE, + bandwidth = cs$bw, kernel = cs$kernel)) + expect_s3_class(r$value, "gwr_fit") + expect_false(anyNA(fitted(r$value))) + expect_lt(.ls_rmse(fitted(r$value) - rg$mu), 0.25) + list(fit = r$value, rg = rg) + }) + f0 <- fits[[1L]]$fit; f288 <- fits[[2L]]$fit; rg <- fits[[1L]]$rg + rk <- f0$info$local_collinearity$rank + expect_identical(f288$info$local_collinearity$rank, rk, info = cs$kernel) + expect_identical(sum(rk < 3L), cs$n_def, info = cs$kernel) + expect_equal(fitted(f288), fitted(f0), tolerance = 1e-7, info = cs$kernel) + expect_equal(coef(f288)$region, coef(f0)$region, tolerance = 1e-6, info = cs$kernel) + # Where the window has full rank the coefficients are the weighted least + # squares, also where the other region's rows carry little weight. + xy <- sf::st_coordinates(rg$d) + kern <- function(dd) if (cs$kernel == "gaussian") exp(-0.5 * dd^2 / cs$bw^2) else exp(-dd / cs$bw) + for (i in c(which(rk == 3L)[c(1, 50, 120)], which.max(xy[, 1] * (rk == 3L)))) { + ref <- .ls_wls_at(rg$d, i, c("a", "region"), + kern(sqrt((xy[, 1] - xy[i, 1])^2 + (xy[, 2] - xy[i, 2])^2))) + expect_equal(fitted(f0)[i], ref$fitted, tolerance = 1e-9, info = paste(cs$kernel, i)) + expect_equal(unlist(coef(f0)[i, c("a", "region")], use.names = FALSE), ref$slopes, + tolerance = 1e-6, info = paste(cs$kernel, i)) + } + # Where it has not, the other region's rows are too far to say anything + # about `region`: its slope is NA and the fitted value is returned. + expect_true(all(is.na(coef(f0)$region[rk < 3L]))) + } +}) + +test_that("a Gaussian window that holds one region predicts NA for a row of the other", { + # Fixed Gaussian 40. A new location more than about 330 m from the line + # x = 500 has a window of rank 2: the other region's training rows are too + # far, by the tolerance, to say anything about `region`. Before, a row + # that carries the eastern value was predicted there (west of x = 170) 2.6 + # below the model's mean on average and up to 28 off, with no warning. It + # is NA; a row with the window's own value is predicted. + rg <- .ls_regional(c(0.7, 1.3)) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(rg$d, "z", c("a", "region"), adaptive = FALSE, bandwidth = 40, + kernel = "gaussian"))) + set.seed(7); m <- 400 + nx <- runif(m, 0, 1000); ny <- runif(m, 0, 1000); na_ <- rnorm(m) + mk <- function(region) sf::st_as_sf(data.frame(x = nx, y = ny, a = na_, region = region), + coords = c("x", "y"), crs = 32632) + own <- ifelse(nx > 500, 1.3, 0.7) + p_own <- expect_no_warning(predict(fit, newdata = mk(own))) + expect_false(anyNA(p_own)) + # Every row given the eastern value: in the west that is the other region's. + sp_train <- .to_sp(rg$d, c("z", "a", "region")) + sv <- .gwr_predict_at(z ~ a + region, sp_train, data.frame(a = na_, region = 1.3), + cbind(nx, ny), 40, "gaussian", FALSE) + west2 <- sv$rank == 2L & nx < 500 + expect_gt(sum(west2), 30L) + r <- .ls_catch(predict(fit, newdata = mk(rep(1.3, m)))) + expect_identical(is.na(r$value), west2) + expect_identical(r$classes, "spatialkit_gwr_not_estimable") + # In the eastern windows of rank 2 the value is the window's own: predicted. + expect_false(anyNA(r$value[sv$rank == 2L & nx > 500])) + expect_identical(r$value[nx > 500], p_own[nx > 500]) +}) + +test_that("far beyond the data a Gaussian kernel still predicts, on weights that compare", { + # 2.5 km from the data with a bandwidth of 200 no weight reaches 1e-8, yet + # many are within a few orders of the largest, and the solve depends only + # on how they compare. + d <- .ls_pts(200, 4, 2L) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE, bandwidth = 200, kernel = "gaussian"))) + nd <- sf::st_as_sf(data.frame(x = 5e5 + 3000, y = 5e6 + 500, a = 0.4, b = -0.2), + coords = c("x", "y"), crs = 32632) + xy <- sf::st_coordinates(d) + w <- exp(-0.5 * ((xy[, 1] - (5e5 + 3000))^2 + (xy[, 2] - (5e6 + 500))^2) / 200^2) + expect_lt(max(w), 1e-8) + r <- .ls_catch(predict(fit, newdata = nd)) + wls <- stats::lm.wfit(cbind(1, d$a, d$b), d$z, w / max(w))$coefficients + expect_equal(r$value, sum(wls * c(1, 0.4, -0.2)), tolerance = 1e-8) + # It is an extrapolation, and said to be one. + expect_identical(r$classes, "spatialkit_gwr_extrapolation") +}) + +test_that("600 locations east of a regional layer are all predicted, as they were", { + # Fixed Gaussian 110; every new row carries the eastern region's value. In + # 358 of the windows the training rows that count share one value of + # `region`; the predictions there were sound before (within 0.43 of the + # truth) and must stay finite and as close. + set.seed(8); n <- 300; x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, a = rnorm(n), + region = 1.3 * (x > 500)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + 3 * d$region + rnorm(n, 0, 0.3) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "region"), adaptive = FALSE, bandwidth = 110, + kernel = "gaussian"))) + set.seed(4); m <- 600 + nd <- data.frame(x = 5e5 + runif(m, 1000, 1500), y = 5e6 + runif(m, 0, 1000), + a = rnorm(m), region = 1.3) + r <- .ls_catch(predict(fit, newdata = sf::st_as_sf(nd, coords = c("x", "y"), crs = 32632))) + expect_false(anyNA(r$value)) + expect_false("spatialkit_gwr_not_estimable" %in% r$classes) + err <- abs(r$value - (1 + 2 * nd$a + 3 * 1.3)) + expect_lt(max(err), 0.43) + expect_lt(stats::median(err), 0.05) +}) + + +# --------------------------------------------------------------------------- +# Cross-validation folds are fitted and scored +# --------------------------------------------------------------------------- + +test_that("cv_gwr() with strips held out scores every fold near the noise SD, whatever the coding", { + # Four strips in x. Before: coded 0/1 all four folds failed and no score + # came back; coded 0.7/1.3 the fold RMSEs were 0.53, 0.29, 0.33 and 1.15 + # against a noise SD of 0.3. + score <- lapply(list(c(0, 1), c(0.7, 1.3)), function(lev) { + rg <- .ls_regional(lev) + lab <- as.integer(cut(rg$x, c(-1, 250, 500, 750, 1001))) + cv <- suppressWarnings(suppressMessages( + cv_gwr(rg$d, "z", c("a", "region"), folds = lab, bandwidth = 40))) + expect_identical(cv$fold_status$status, rep("ok", 4L)) + expect_identical(cv$overall$n_pred, 300L) + expect_true(all(cv$fold_metrics$RMSE > 0.2 & cv$fold_metrics$RMSE < 0.4)) + cv$fold_metrics$RMSE + }) + expect_equal(score[[2L]], score[[1L]], tolerance = 1e-7) + expect_equal(score[[1L]], c(0.297, 0.291, 0.329, 0.340), tolerance = 0.01) +}) + +test_that("cv_gwr() scores five of five folds under Gaussian and exponential kernels", { + # Random folds. An isolated observation under fixed Gaussian 100, and the + # regional covariate under fixed Gaussian 60 and exponential 20: a rule that + # refuses a fit for one thin window loses most or all of these folds. + # Before, all folds were scored, the Gaussian regional case at a pooled + # RMSE of 0.88 against a noise SD of 0.3; it is 0.31. + set.seed(11); n <- 60 + x <- c(runif(n, 0, 400), 400 + 620); y <- c(runif(n, 0, 400), 200); a <- c(rnorm(n), 0.3) + d1 <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, a = a, + z = 1 + 2 * a + rnorm(n + 1L, 0, 0.3)), + coords = c("x", "y"), crs = 32632) + cv1 <- suppressWarnings(suppressMessages( + cv_gwr(d1, "z", "a", folds = make_folds(d1, k = 5, method = "random_kfold", seed = 1), + adaptive = FALSE, bandwidth = 100, kernel = "gaussian"))) + expect_identical(sum(cv1$fold_status$status == "ok"), 5L) + expect_lt(cv1$overall$RMSE, 0.45) + rg <- .ls_regional(c(0, 1.3)) + fl <- make_folds(rg$d, k = 5, method = "random_kfold", seed = 1) + for (cs in list(list(kernel = "gaussian", bw = 60), list(kernel = "exponential", bw = 20))) { + cv <- suppressWarnings(suppressMessages( + cv_gwr(rg$d, "z", c("a", "region"), folds = fl, adaptive = FALSE, + bandwidth = cs$bw, kernel = cs$kernel))) + expect_identical(sum(cv$fold_status$status == "ok"), 5L, info = cs$kernel) + expect_lt(cv$overall$RMSE, 0.45) + expect_gte(cv$overall$n_pred, 290L) + } +}) diff --git a/tests/testthat/test-fix-gwr-origin-tally-label.R b/tests/testthat/test-fix-gwr-origin-tally-label.R new file mode 100644 index 00000000..90949694 --- /dev/null +++ b/tests/testthat/test-fix-gwr-origin-tally-label.R @@ -0,0 +1,215 @@ +# tests/testthat/test-fix-gwr-origin-tally-label.R +# --------------------------------------------------------------------------- +# Three repairs to what a GWR fit says about itself. +# +# 1. A predictor far from zero was still flagged as collinear (every window +# counted in info$n_local_collinear, the coefficient map refused) once the +# uncentred condition index passed 1e6, although the local solve centres +# each window and returns the same slopes at any origin. +# 2. predict()'s two counted warnings carry their counts as fields, and a +# caller that predicts in pieces can raise each once with totals. +# 3. print() headed the fit "", though no GWmodel code makes it. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +.otl_catch <- function(expr) { + conds <- list() + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + conds[[length(conds) + 1L]] <<- cnd + invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, conds = conds, + warnings = vapply(conds, conditionMessage, character(1)), + classes = vapply(conds, function(cnd) class(cnd)[1L], character(1))) +} + +# 200 points, one predictor whose slope drifts eastward. +.otl_layer <- function() { + set.seed(1); n <- 200 + x <- runif(n, 0, 1e4); y <- runif(n, 0, 1e4); t0 <- rnorm(n) + d <- sf::st_as_sf(data.frame(x = x, y = y, t0 = t0), coords = c("x", "y"), crs = 32632) + d$yield <- 50 - 0.8 * (1 + x / 1e4) * t0 + rnorm(n) + d +} + + +test_that("a predictor shifted far from zero is not flagged, and its slope map is drawn", { + d <- .otl_layer() + ref <- .otl_catch(fit_gwr_model(d, "yield", "t0", bandwidth = 30)) + expect_length(ref$warnings, 0L) + expect_identical(ref$value$info$n_local_collinear, 0L) + for (off in c(1e5, 1e7, 1e9)) { + lab <- sprintf("origin %g", off) + d$tt <- d$t0 + off + r <- .otl_catch(fit_gwr_model(d, "yield", "tt", bandwidth = 30)) + f <- r$value + expect_s3_class(f, "gwr_fit") + # Before, at 1e7 and 1e9: "100% of 200 locations have a collinear local + # design", n_local_collinear 200, and the map stopped with "every + # location is masked". + expect_length(r$warnings, 0L) + expect_identical(f$info$n_local_collinear, 0L, label = lab) + # The slopes are the origin-0 fit's, to the precision the shifted column + # has (its spacing is `off` times 2e-16). + expect_lt(max(abs(coef(f)$tt - coef(ref$value)$t0)), off * 1e-15, label = lab) + expect_lt(max(abs(fitted(f) - fitted(ref$value))), off * 1e-15, label = lab) + # The index with the intercept is kept, for the Intercept map. + expect_true(all(f$info$local_collinearity$cn > 1e4), label = lab) + if (requireNamespace("ggplot2", quietly = TRUE)) { + p <- plot(f, type = "coefficients", term = "tt") + expect_match(p$labels$subtitle, "No location masked", label = lab) + pI <- plot(f, type = "coefficients", term = "Intercept", mask = FALSE) + expect_s3_class(pI, "ggplot") + } + } + # At 1e7 the index is past the 1e6 a normal-equation solve breaks at. + d$tt <- d$t0 + 1e7 + f7 <- suppressMessages(fit_gwr_model(d, "yield", "tt", bandwidth = 30)) + expect_true(all(f7$info$local_collinearity$cn > 1e6)) + expect_lt(max(abs(coef(f7)$tt - coef(ref$value)$t0)), 2e-9) + # A window in which the predictor really is constant is still counted. + d$flat <- ifelse(sf::st_coordinates(d)[, 1] > 5e3, 1e7 + 1, 1e7) + rf <- .otl_catch(fit_gwr_model(d, "yield", "flat", bandwidth = 30)) + expect_gt(rf$value$info$n_local_collinear, 100L) + expect_true(any(grepl("local collinearity", rf$warnings))) +}) + +test_that("the extrapolation warning carries its counts, and can be dropped by class", { + set.seed(4); n <- 150 + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + fit <- suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30)) + nd <- sf::st_as_sf(data.frame(x = 5e5 + c(500, 3000, 4000, 9000), y = 5e6 + 500, + a = 0), coords = c("x", "y"), crs = 32632) + r <- .otl_catch(predict(fit, newdata = nd)) + expect_identical(r$classes, "spatialkit_gwr_extrapolation") + w <- r$conds[[1L]] + expect_identical(w$n_far, 3L) + expect_identical(w$n, 4L) + expect_identical(w$calls, 1L) + expect_equal(w$reach, fit$info$max_kernel_width) + expect_length(w$nearest, 2L) + expect_lt(w$nearest[1L], w$nearest[2L]) + expect_gt(w$nearest[1L], w$reach) + expect_match(conditionMessage(w), "^predict\\.gwr_fit\\(\\): 3 of 4 location\\(s\\) are farther from every training point than the widest kernel of the fit reaches") + # The documented way to drop it where extrapolation is intended. + expect_silent(p <- suppressWarnings(predict(fit, newdata = nd), + classes = "spatialkit_gwr_extrapolation")) + expect_false(anyNA(p)) + # The warning that counts NA predictions carries its counts too. + fx <- suppressMessages(fit_gwr_model(d, "z", "a", adaptive = FALSE, bandwidth = 150)) + rx <- .otl_catch(predict(fx, newdata = nd)) + expect_identical(rx$classes, "spatialkit_gwr_not_estimable") + expect_identical(rx$conds[[1L]]$n_na, 3L) + expect_identical(rx$conds[[1L]]$n, 4L) + expect_identical(rx$conds[[1L]]$n_empty, 3L) +}) + +test_that("a caller that predicts in pieces can raise each counted warning once, with totals", { + set.seed(4); n <- 150 + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + fit <- suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30)) + set.seed(5); m <- 120 + nd <- sf::st_as_sf(data.frame(x = 5e5 + runif(m, -1500, 2500), y = 5e6 + runif(m, -1500, 2500), + a = rnorm(m)), coords = c("x", "y"), crs = 32632) + whole <- .otl_catch(predict(fit, newdata = nd)) + expect_identical(whole$classes, "spatialkit_gwr_extrapolation") + total <- whole$conds[[1L]]$n_far + expect_gt(total, 20L) + chunks <- split(seq_len(m), rep(1:6, each = 20)) + # In pieces: one warning per piece, each with that piece's counts. + loose <- .otl_catch(unlist(lapply(chunks, function(i) predict(fit, newdata = nd[i, ])))) + expect_identical(loose$classes, rep("spatialkit_gwr_extrapolation", 6L)) + expect_identical(sum(vapply(loose$conds, function(w) w$n_far, integer(1))), total) + # Collected: one warning, the totals, the caller's name, the same values. + tallied <- .otl_catch(.gwr_tally_predict_warnings( + unlist(lapply(chunks, function(i) predict(fit, newdata = nd[i, ]))), + caller = "predict_surface", n_total = m)) + expect_identical(tallied$classes, "spatialkit_gwr_extrapolation") + w <- tallied$conds[[1L]] + expect_identical(w$n_far, total) + expect_identical(w$n, 120L) + expect_identical(w$calls, 6L) + expect_equal(w$nearest, whole$conds[[1L]]$nearest) + expect_match(conditionMessage(w), sprintf( + "^predict_surface\\(\\): %d of 120 location\\(s\\) are farther from every training point", total)) + expect_match(conditionMessage(w), "\\(totals over the 6 prediction calls that found any\\)") + expect_equal(unname(tallied$value), unname(whole$value)) + # Without `n_total` the denominator is the locations of the calls that warned. + t2 <- .otl_catch(.gwr_tally_predict_warnings( + lapply(chunks[1:2], function(i) predict(fit, newdata = nd[i, ])), caller = "cv_gwr")) + expect_identical(t2$conds[[1L]]$n, 40L) + expect_match(conditionMessage(t2$conds[[1L]]), "^cv_gwr\\(\\): ") + # Nested: the inner total is one more warning to the outer collector. + nested <- .otl_catch(.gwr_tally_predict_warnings({ + .gwr_tally_predict_warnings(lapply(chunks[1:3], function(i) predict(fit, newdata = nd[i, ])), + caller = "inner") + lapply(chunks[4:6], function(i) predict(fit, newdata = nd[i, ])) + }, caller = "outer", n_total = m)) + expect_identical(nested$classes, "spatialkit_gwr_extrapolation") + expect_identical(nested$conds[[1L]]$n_far, total) + expect_identical(nested$conds[[1L]]$calls, 6L) + # Nothing to report: the value, and no warning. Other warnings pass through. + inside <- nd[sf::st_coordinates(nd)[, 1] > 5e5 + 200 & sf::st_coordinates(nd)[, 1] < 5e5 + 800 & + sf::st_coordinates(nd)[, 2] > 5e6 + 200 & sf::st_coordinates(nd)[, 2] < 5e6 + 800, ] + quiet <- .otl_catch(.gwr_tally_predict_warnings(predict(fit, newdata = inside), caller = "x")) + expect_length(quiet$warnings, 0L) + expect_length(quiet$value, nrow(inside)) + other <- .otl_catch(.gwr_tally_predict_warnings({ warning("something else"); 1 }, caller = "x")) + expect_identical(other$warnings, "something else") + # The collector leaves no trace behind, also after an error. + expect_error(.gwr_tally_predict_warnings(stop("boom"), caller = "x"), "boom") + expect_identical(.gwr_predict_state$tally, 0L) + # The fixed-bandwidth warning about NA predictions is totalled the same way. + fx <- suppressMessages(fit_gwr_model(d, "z", "a", adaptive = FALSE, bandwidth = 150)) + one <- .otl_catch(predict(fx, newdata = nd)) + tx <- .otl_catch(.gwr_tally_predict_warnings( + lapply(chunks, function(i) predict(fx, newdata = nd[i, ])), caller = "predict_surface", + n_total = m)) + na_one <- one$conds[[which(one$classes == "spatialkit_gwr_not_estimable")]] + na_all <- tx$conds[[which(tx$classes == "spatialkit_gwr_not_estimable")]] + expect_identical(sum(tx$classes == "spatialkit_gwr_not_estimable"), 1L) + expect_identical(na_all$n_na, na_one$n_na) + expect_identical(na_all$n_empty, na_one$n_empty) + expect_match(conditionMessage(na_all), sprintf( + "^predict_surface\\(\\): %d of 120 location\\(s\\) have no estimable local regression", na_one$n_na)) +}) + +test_that("predict_surface() in chunks, wrapped in the collector, warns once with the whole grid's count", { + skip_if_not_installed("ggplot2") + set.seed(4); n <- 150 + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + fit <- suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30)) + g <- expand.grid(x = 5e5 + seq(-1500, 2500, length.out = 20), + y = 5e6 + seq(-1500, 2500, length.out = 15)) + g$a <- 0 + grid <- sf::st_as_sf(g, coords = c("x", "y"), crs = 32632) + one <- .otl_catch(predict_surface(fit, grid, chunk_size = 5000L)) + far <- one$conds[[which(one$classes == "spatialkit_gwr_extrapolation")]] + # The change predict_surface() needs is this wrapper round its chunk loop. + many <- .otl_catch(.gwr_tally_predict_warnings( + predict_surface(fit, grid, chunk_size = 50L), caller = "predict_surface", + n_total = nrow(grid))) + expect_identical(sum(many$classes == "spatialkit_gwr_extrapolation"), 1L) + got <- many$conds[[which(many$classes == "spatialkit_gwr_extrapolation")]] + expect_identical(got$n_far, far$n_far) + expect_identical(got$n, 300L) + expect_identical(got$calls, 6L) +}) + +test_that("print() heads a GWR fit without naming GWmodel", { + d <- .otl_layer() + fit <- suppressMessages(fit_gwr_model(d, "yield", "t0", bandwidth = 30)) + out <- capture.output(print(fit)) + expect_identical(out[1L], " spatial model fit") + expect_false(any(grepl("GWmodel", out, fixed = TRUE))) + expect_true(any(grepl("Eff. parameters", out, fixed = TRUE))) +}) diff --git a/tests/testthat/test-fix-gwr-repeated-locations.R b/tests/testthat/test-fix-gwr-repeated-locations.R new file mode 100644 index 00000000..2a54982b --- /dev/null +++ b/tests/testthat/test-fix-gwr-repeated-locations.R @@ -0,0 +1,419 @@ +# tests/testthat/test-fix-gwr-repeated-locations.R +# --------------------------------------------------------------------------- +# A layer with several observations per location. +# +# AICc counts the rows at one location as independent observations. When a +# location has an effect of its own, a window that holds little but the +# location reproduces its mean, the residual sum of squares falls to the +# spread within locations, and AICc is lowest where the windows interpolate. +# On 100 sites with 3 observations each the default bandwidth search settled +# at 7 neighbours: every coefficient NA, every prediction at a new site NA. +# +# The search now minimises the leave-one-location-out sum of squares on such +# a layer, from the hat matrix; its range counts locations; a bandwidth at +# which a term is estimable nowhere cannot be selected; the fit says how many +# locations the observations share. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +.rl_catch <- function(expr) { + w <- character(0); cls <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); cls <<- c(cls, class(cnd)[1L]) + invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w, classes = cls) +} + +# `sites` locations with `reps` observations each. The predictors belong to +# the site, the slope of `a` drifts eastward, and each site has an effect of +# its own (SD 0.3) under measurement noise (SD 0.2). +.rl_sites <- function(sites, reps, seed) { + set.seed(seed) + x <- runif(sites, 0, 1000); y <- runif(sites, 0, 1000) + a <- rnorm(sites); b <- rnorm(sites); u <- rnorm(sites, 0, 0.3) + id <- rep(seq_len(sites), reps); n <- length(id) + mu <- 1 + (1 + x[id] / 1000) * a[id] - 0.5 * b[id] + sf::st_as_sf(data.frame(x = 5e5 + x[id], y = 5e6 + y[id], a = a[id], b = b[id], + z = mu + u[id] + rnorm(n, 0, 0.2), mu = mu, site = id), + coords = c("x", "y"), crs = 32632) +} + +# 40 new sites inside the study area, and the noise-free mean there. +.rl_new_sites <- function() { + set.seed(99); m <- 40 + nd <- sf::st_as_sf(data.frame(x = 5e5 + runif(m, 100, 900), y = 5e6 + runif(m, 100, 900), + a = rnorm(m), b = rnorm(m)), + coords = c("x", "y"), crs = 32632) + nd$truth <- 1 + (1 + (sf::st_coordinates(nd)[, 1] - 5e5) / 1000) * nd$a - 0.5 * nd$b + nd +} + +.rl_parts <- function(d, vars = c("a", "b")) { + list(X = cbind(Intercept = 1, as.matrix(sf::st_drop_geometry(d)[, vars, drop = FALSE])), + y = d$z, xy = sf::st_coordinates(d)) +} + +# The leave-one-location-out residuals by their definition: each location's +# rows predicted by the local regression there on the rows of the other +# locations, the kernel keeping the width it has in the fit. +.rl_brute <- function(X, y, xy, bw, kernel, adaptive) { + loc <- .gwr_locations(xy) + full <- .gwr_local_solve(X, y, xy, bw, kernel, adaptive, what = "score") + out <- rep(NA_real_, length(y)) + for (g in seq_len(loc$n)) { + r <- which(loc$id == g) + if (!is.finite(full$width[r[1L]]) || full$width[r[1L]] <= 0) next + pr <- .gwr_local_solve(X[-r, , drop = FALSE], y[-r], xy[-r, , drop = FALSE], + full$width[r[1L]], kernel, FALSE, + rp = xy[r, , drop = FALSE], X_rp = X[r, , drop = FALSE], + what = "predict")$fitted + out[r] <- y[r] - pr + } + out +} + + +test_that("locations are told apart exactly, and the distinct rows are counted", { + xy <- cbind(c(1, 2, 1, 3, 2, 1), c(5, 5, 5, 5, 5, 6)) + loc <- .gwr_locations(xy) + expect_identical(loc$id, c(1L, 2L, 1L, 3L, 2L, 4L)) + expect_identical(loc$n, 4L) + expect_identical(loc$size, c(2L, 2L, 1L, 1L)) + # One unit in the last place is another location; printing both to 15 + # digits gives the same text. + near <- cbind(c(0.1 + 0.2, 0.3), c(1, 1)) + expect_identical(format(near[1, 1], digits = 15), format(near[2, 1], digits = 15)) + expect_identical(.gwr_locations(near)$n, 2L) + expect_identical(.gwr_locations(xy[1, , drop = FALSE])$n, 1L) + # Rows that share a location and every predictor are one distinct row. + X <- cbind(1, c(7, 8, 7, 9, 8.5, 7)) + expect_identical(.gwr_n_distinct(X, loc$id), 5L) + expect_identical(.gwr_n_distinct(X, seq_len(6L)), 6L) +}) + +test_that("the default bandwidth of a layer with 3 observations per site gives coefficients and predictions", { + d <- .rl_sites(100, 3, 2) + nd <- .rl_new_sites() + r <- .rl_catch(fit_gwr_model(d, "z", c("a", "b"))) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + # Before: 7 neighbours, 900 of 900 coefficients NA, 40 of 40 predictions NA. + # GWmodel's search gave 58 neighbours and a prediction error of 0.197. + expect_gte(fit$info$bandwidth, 58) + expect_identical(sum(is.na(as.matrix(coef(fit)))), 0L) + expect_identical(fit$info$n_rank_deficient, 0L) + p <- suppressWarnings(predict(fit, newdata = nd)) + expect_false(anyNA(p)) + expect_lt(sqrt(mean((p - nd$truth)^2)), 0.197) + expect_lt(sqrt(mean((fitted(fit) - d$mu)^2)), 0.2) + # One warning, classed, with the counts and how the bandwidth was chosen. + expect_identical(r$classes, "spatialkit_gwr_repeated_locations") + expect_match(r$warnings, "^fit_gwr_model\\(\\): the 300 observations are at 100 distinct location\\(s\\) \\(100 hold more than one observation, the most 3\\)") + expect_match(r$warnings, "No bandwidth was supplied: it was selected by leave-one-location-out cross-validation \\(each location predicted from the others\\), not by AICc") + expect_identical(fit$info$n_locations, 100L) + # What the search did is on the fit. + bs <- fit$info$bandwidth_search + expect_identical(bs$approach, "CV") + expect_identical(bs$requested, "AICc") + expect_true(bs$by_location) + expect_identical(bs$n_locations, 100L) + # Four sites of 3 rows and the row the bisquare kernel gives weight 0. + expect_identical(bs$range, c(13, 300)) + expect_identical(bs$curve$bandwidth[which.min(bs$curve$criterion)], fit$info$bandwidth) + # The summary says it too. + out <- capture.output(print(summary(fit))) + expect_true(any(grepl("Locations: 100 for 300 observations", out, fixed = TRUE))) +}) + +test_that("AICc falls towards the bandwidths that interpolate the site means, and they cannot be selected", { + d <- .rl_sites(100, 3, 2); p <- .rl_parts(d) + cr <- lapply(c(5, 7, 10, 13, 58), function(k) + .gwr_criterion(p$X, p$y, p$xy, k, "bisquare", TRUE, "AICc")) + # The numbers the help page quotes: 58 at 5 to 10 neighbours, 90 at 13, + # 221 at 58. + expect_equal(vapply(cr, `[[`, numeric(1), "AICc"), + c(58.43, 58.43, 58.43, 90.02, 220.59), tolerance = 1e-4) + # At 5 to 10 neighbours tr(S) is the number of sites: the fit is the site + # means. AICc is not a criterion there, and the reason is given. + expect_equal(vapply(cr[1:3], `[[`, numeric(1), "tr_S"), rep(100, 3), tolerance = 1e-8) + expect_identical(vapply(cr, `[[`, numeric(1), "n_distinct"), rep(100, 5)) + expect_identical(vapply(cr, `[[`, character(1), "why"), + c("df_distinct", "df_distinct", "df_distinct", "", "")) + expect_identical(vapply(cr[1:3], `[[`, numeric(1), "value"), rep(Inf, 3)) + # The leave-one-location-out score has no value where a site cannot be + # predicted from the others, and is far higher at 16 than at 58. + cv <- lapply(c(7, 10, 16, 58, 150), function(k) + .gwr_criterion(p$X, p$y, p$xy, k, "bisquare", TRUE, "CV")) + v <- vapply(cv, `[[`, numeric(1), "value") + expect_identical(v[1:2], c(Inf, Inf)) + expect_identical(vapply(cv, `[[`, character(1), "why"), c("leave_out", "leave_out", "", "", "")) + expect_gt(v[3], 5 * v[4]) + expect_lt(v[5], v[4]) + # At 13, the bottom of the range, one site's window holds a fourth site at + # weight 1.4e-5: without the site itself two sites are left for three + # parameters, to the solve's tolerance, and the score is undefined there. + cv13 <- .gwr_criterion(p$X, p$y, p$xy, 13, "bisquare", TRUE, "CV") + expect_identical(cv13$value, Inf) + expect_identical(cv13$why, "leave_out") + # The error of prediction at new sites, the other numbers of the help page: + # 46 at 10 neighbours, 1.35 at 13, 0.15 at 150. + set.seed(99); m <- 200 + nd <- sf::st_as_sf(data.frame(x = 5e5 + runif(m, 100, 900), y = 5e6 + runif(m, 100, 900), + a = rnorm(m), b = rnorm(m)), coords = c("x", "y"), crs = 32632) + truth <- 1 + (1 + (sf::st_coordinates(nd)[, 1] - 5e5) / 1000) * nd$a - 0.5 * nd$b + err <- vapply(c(10, 13, 150), function(k) { + f <- suppressWarnings(suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = k))) + sqrt(mean((suppressWarnings(predict(f, newdata = nd)) - truth)^2)) + }, numeric(1)) + expect_equal(err, c(46.1, 1.35, 0.149), tolerance = 0.01) +}) + +test_that("the leave-one-location-out residuals are those of refitting without the location", { + d <- .rl_sites(60, 3, 5); p <- .rl_parts(d) + # A second design in which one predictor differs between the rows of a site. + set.seed(8) + Xv <- p$X; Xv[, "b"] <- Xv[, "b"] + rnorm(nrow(Xv), 0, 0.5) + loc <- .gwr_locations(p$xy) + for (cs in list(list(X = p$X, bw = 13, k = "bisquare", ad = TRUE), + list(X = p$X, bw = 40, k = "bisquare", ad = TRUE), + list(X = Xv, bw = 25, k = "tricube", ad = TRUE), + list(X = Xv, bw = 30, k = "boxcar", ad = TRUE), + list(X = p$X, bw = 150, k = "gaussian", ad = FALSE), + list(X = Xv, bw = 20, k = "exponential", ad = TRUE), + list(X = Xv, bw = 260, k = "bisquare", ad = FALSE))) { + lab <- paste(cs$k, cs$bw) + sv <- .gwr_local_solve(cs$X, p$y, p$xy, cs$bw, cs$k, cs$ad, what = "score", loc = loc) + got <- .gwr_lolo_residuals(p$y - sv$fitted, sv$leverage, sv$hat_loc, loc) + ref <- .rl_brute(cs$X, p$y, p$xy, cs$bw, cs$k, cs$ad) + expect_false(anyNA(ref), label = lab) + expect_equal(got, ref, tolerance = 1e-8, label = lab) + expect_equal(.gwr_criterion(cs$X, p$y, p$xy, cs$bw, cs$k, cs$ad, "CV")$value, + sum(ref^2), tolerance = 1e-8, label = lab) + } + # Where the other sites of a window cannot place a site, both say so: at 10 + # neighbours a bisquare window holds 3 sites, and 2 are left for 3 + # parameters. + sv <- .gwr_local_solve(p$X, p$y, p$xy, 10, "bisquare", TRUE, what = "score", loc = loc) + got <- .gwr_lolo_residuals(p$y - sv$fitted, sv$leverage, sv$hat_loc, loc) + expect_true(all(is.na(got))) + expect_true(all(is.na(.rl_brute(p$X, p$y, p$xy, 10, "bisquare", TRUE)))) + # A layer without repeat locations: the leave-one-out residual e / (1 - h). + one <- !duplicated(loc$id) + l1 <- .gwr_locations(p$xy[one, ]) + s1 <- .gwr_local_solve(p$X[one, ], p$y[one], p$xy[one, ], 20, "bisquare", TRUE, what = "score") + expect_equal(.gwr_lolo_residuals(p$y[one] - s1$fitted, s1$leverage, NULL, l1), + (p$y[one] - s1$fitted) / (1 - s1$leverage), tolerance = 1e-12) +}) + +test_that("the range of the search counts locations, for either kind of bandwidth", { + d <- .rl_sites(100, 3, 2); p <- .rl_parts(d) + # Adaptive: the rows of the four nearest sites (itself included), and one + # more for the kernels that give the farthest row weight 0. + expect_identical(.gwr_bw_range(p$xy, 3L, "bisquare", TRUE), c(13, 300)) + expect_identical(.gwr_bw_range(p$xy, 3L, "tricube", TRUE), c(13, 300)) + expect_identical(.gwr_bw_range(p$xy, 3L, "boxcar", TRUE), c(10, 300)) + expect_identical(.gwr_bw_range(p$xy, 3L, "gaussian", TRUE), c(10, 300)) + # At that count every bisquare window holds four sites. + at13 <- vapply(seq_len(300L), function(i) { + dd <- sqrt((p$xy[, 1] - p$xy[i, 1])^2 + (p$xy[, 2] - p$xy[i, 2])^2) + length(unique(d$site[.gw_kernel_weights(dd, 13, "bisquare", TRUE) > 0])) + }, integer(1)) + expect_true(all(at13 >= 4L)) + # Sites of unequal size: the count is the largest any window needs. + xy <- rbind(cbind(rep(0, 5), 0), cbind(c(1, 2, 3, 10, 11, 12, 13), 0)) + expect_identical(.gwr_bw_range(xy, 2L, "bisquare", TRUE), c(8, 12)) + # Fixed: the median, over the rows, of the distance to the site that gives + # a window four of them. + one <- !duplicated(d$site) + dm <- as.matrix(stats::dist(p$xy[one, ])) + d5 <- apply(dm, 1L, function(v) sort(v)[5L]) + expect_equal(.gwr_bw_range(p$xy, 3L, "bisquare", FALSE), c(stats::median(d5), max(dm)), + tolerance = 1e-12) + # Counted in rows it would be the distance to the next site only. + expect_gt(.gwr_bw_range(p$xy, 3L, "bisquare", FALSE)[1L], + 2 * stats::median(apply(dm, 1L, function(v) sort(v)[2L]))) + # Without repeat locations nothing changes. + expect_identical(.gwr_bw_range(p$xy[one, ], 3L, "bisquare", TRUE), c(5, 100)) + expect_identical(.gwr_bw_range(p$xy[one, ], 3L, "gaussian", TRUE), c(4, 100)) +}) + +test_that("a fixed bandwidth, two observations per site and a kernel without an edge are selected the same way", { + nd <- .rl_new_sites() + # GWmodel's search before: prediction error 0.941 (fixed, 100 x 3), 0.145 + # and 0.151 (150 x 2). The first draft of the new search: all NA, 0.234 and + # 0.229. + for (cs in list(list(sites = 100, reps = 3, seed = 2, ad = FALSE, k = "bisquare", below = 0.2), + list(sites = 150, reps = 2, seed = 3, ad = TRUE, k = "bisquare", below = 0.145), + list(sites = 150, reps = 2, seed = 3, ad = FALSE, k = "bisquare", below = 0.151), + list(sites = 60, reps = 2, seed = 1, ad = TRUE, k = "gaussian", below = 0.2))) { + lab <- sprintf("%d x %d, %s %s", cs$sites, cs$reps, if (cs$ad) "adaptive" else "fixed", cs$k) + d <- .rl_sites(cs$sites, cs$reps, cs$seed) + r <- .rl_catch(fit_gwr_model(d, "z", c("a", "b"), adaptive = cs$ad, kernel = cs$k)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_identical(r$classes, "spatialkit_gwr_repeated_locations", label = lab) + expect_true(fit$info$bandwidth_search$by_location, label = lab) + expect_identical(sum(is.na(as.matrix(coef(fit)))), 0L, label = lab) + p <- suppressWarnings(predict(fit, newdata = nd)) + expect_false(anyNA(p), label = lab) + expect_lt(sqrt(mean((p - nd$truth)^2)), cs$below, label = lab) + } +}) + +test_that("a supplied bandwidth that interpolates the site means has no AICc, and the fit says why", { + d <- .rl_sites(100, 3, 2) + r <- .rl_catch(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 10)) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + expect_equal(fit$info$tr_S, 100, tolerance = 1e-8) + # The formula gives 58.43, which would rank this fit above the one at 58 + # neighbours (220.59). + expect_true(is.na(fit$info$AICc)) + w <- grep("AICc is reported as NA", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "The 300 observations are 100 distinct combinations of location and predictor values") + expect_match(w, "tr\\(S\\) = 100, is not below that number minus 2 \\(98\\)") + expect_match(w, "the value the formula gives \\(58\\.4334\\)") + expect_match(w, "Use a larger bandwidth\\.$") + # The warning about the shared locations does not claim a selection. + rep_w <- r$warnings[r$classes == "spatialkit_gwr_repeated_locations"] + expect_length(rep_w, 1L) + expect_no_match(rep_w, "No bandwidth was supplied") + expect_match(rep_w, "If the repeats are replicates of one measurement, fit their means, one row per location\\.$") + # At a bandwidth that leaves the windows room, AICc is reported. + f58 <- suppressWarnings(suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 58))) + expect_equal(f58$info$AICc, 220.59, tolerance = 1e-4) + # A predictor that differs between the rows of a site: every row is its own + # distinct row, and the rule is the usual one (n - 2). + set.seed(4); d$w <- d$a + rnorm(300, 0, 0.5) + p <- .rl_parts(d, c("w", "b")) + cr <- .gwr_criterion(p$X, p$y, p$xy, 13, "bisquare", TRUE, "AICc") + expect_identical(cr$n_distinct, 300L) + expect_identical(cr$why, "") +}) + +test_that("a fold of a cross-validation logs the shared locations and does not warn", { + d <- .rl_sites(60, 2, 1) + dat <- prep_model_data(d, "z", c("a", "b")) + r <- .rl_catch(fit_gwr_model(dat, "z", c("a", "b"), .already_prepped = TRUE)) + expect_s3_class(r$value, "gwr_fit") + expect_length(r$warnings, 0L) + expect_true(r$value$info$bandwidth_search$by_location) +}) + +test_that("a layer without repeat locations is searched by AICc and raises nothing", { + d <- .rl_sites(100, 1, 2) + r <- .rl_catch(fit_gwr_model(d, "z", c("a", "b"))) + fit <- r$value + expect_length(r$warnings, 0L) + expect_identical(fit$info$n_locations, 100L) + bs <- fit$info$bandwidth_search + expect_identical(bs$approach, "AICc") + expect_false(bs$by_location) + expect_identical(bs$range, c(5, 100)) + expect_false(any(grepl("Locations:", capture.output(print(summary(fit))), fixed = TRUE))) + # One pair of rows at one location is enough to change the criterion. + d2 <- rbind(d, d[1, ]); d2$z[101] <- d2$z[101] + 0.1 + r2 <- .rl_catch(fit_gwr_model(d2, "z", c("a", "b"))) + expect_identical(r2$classes, "spatialkit_gwr_repeated_locations") + expect_match(r2$warnings, "the 101 observations are at 100 distinct location\\(s\\) \\(1 hold more than one observation, the most 2\\)") + expect_identical(r2$value$info$bandwidth_search$approach, "CV") +}) + +test_that("a bandwidth at which a term is estimable nowhere cannot be selected", { + # A covariate that takes one value west of x = 500 and another east of it. + # Bisquare windows of 40 m hold one side only, wherever they are. + set.seed(3); n <- 200 + x <- c(runif(n / 2, 0, 400), runif(n / 2, 600, 1000)); y <- runif(n, 0, 1000); a <- rnorm(n) + region <- as.numeric(x > 500) + z <- 1 + 2 * a + 3 * region + rnorm(n, 0, 0.3) + X <- cbind(Intercept = 1, a = a, region = region); xy <- cbind(x, y) + sv <- .gwr_local_solve(X, z, xy, 150, "bisquare", FALSE, what = "score") + # The slope of `a` is estimable in every window; the covariate's and, with + # it, the intercept's in none on the east side, the intercept's on the west + # (where the covariate is 0). + expect_identical(sv$n_estimable[2:3], c(200L, 0L)) + expect_identical(sv$n_estimable[1L], 100L) + cr <- .gwr_criterion(X, z, xy, 150, "bisquare", FALSE, "AICc") + expect_identical(cr$value, Inf) + expect_identical(cr$why, "term") + expect_true(is.finite(cr$AICc)) + # A bandwidth that reaches across the gap estimates it in some windows. + wide <- .gwr_criterion(X, z, xy, 400, "bisquare", FALSE, "AICc") + expect_identical(wide$why, "") + expect_true(is.finite(wide$value)) + expect_gt(.gwr_local_solve(X, z, xy, 400, "bisquare", FALSE, what = "score")$n_estimable[3L], 0L) + # The fit counts the same windows, term by term, as the score does. + d <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, a = a, region = region, z = z), + coords = c("x", "y"), crs = 32632) + f <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("a", "region"), adaptive = FALSE, bandwidth = 400))) + expect_identical(as.integer(colSums(!f$info$nonfinite_coef)), + .gwr_local_solve(X, z, xy, 400, "bisquare", FALSE, what = "score")$n_estimable) + # The search does not settle where the covariate has no coefficient at all. + fs <- suppressWarnings(suppressMessages(fit_gwr_model(d, "z", c("a", "region"), adaptive = FALSE))) + expect_gt(sum(!is.na(coef(fs)$region)), 0L) + # A predictor that is one number over the whole layer has no coefficient at + # any bandwidth: none can be selected, and the warning gives that reason. + d$flat <- 2 + r <- .rl_catch(fit_gwr_model(d, "z", c("a", "flat"))) + expect_s3_class(r$value, "gwr_fit") + expect_true(r$value$info$bandwidth_search$none_defined) + expect_identical(names(r$value$info$bandwidth_search$undefined), "term") + w <- grep("has a defined AICc", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "so none could be selected: at each of the [0-9]+ tried a term can be estimated at no location\\. The widest, 200, is used") +}) + +test_that("gwr_model_selection() takes its bandwidth and its warnings from the same rules", { + d <- .rl_sites(100, 3, 2) + r <- .rl_catch(gwr_model_selection(d, "z", c("a", "b"))) + sel <- r$value + expect_s3_class(sel, "gwr_model_selection") + # Before: 7 neighbours, the three models tied at 58.43343, `a` selected. + fit <- suppressWarnings(suppressMessages(fit_gwr_model(d, "z", c("a", "b")))) + expect_identical(as.numeric(sel$bandwidth), fit$info$bandwidth) + expect_identical(sel$best, c("a", "b")) + expect_identical(sel$bandwidth_source, "leave-one-location-out CV search on the full model") + expect_true(sel$bandwidth_search$by_location) + expect_gt(sel$table$delta[2L], 100) + expect_identical(r$classes, "spatialkit_gwr_repeated_locations") + expect_match(r$warnings, "^gwr_model_selection\\(\\): the 300 observations are at 100 distinct location\\(s\\) \\(100 hold more than one observation, the most 3\\)") + expect_match(r$warnings, "No bandwidth was supplied: it was selected by leave-one-location-out cross-validation") + # Asked for by CV, the search leaves out locations too: with a twin left + # in, the leave-one-out score is lowest where the windows hold one site. + cvs <- suppressWarnings(suppressMessages(gwr_model_selection(d, "z", c("a", "b"), bw_approach = "CV"))) + expect_identical(as.numeric(cvs$bandwidth), fit$info$bandwidth) + expect_identical(cvs$bandwidth_search$requested, "CV") + # A supplied bandwidth at which every model reproduces the site means: the + # three are not ranked, and the warning names them. + r7 <- .rl_catch(gwr_model_selection(d, "z", c("a", "b"), bandwidth = 7)) + t7 <- r7$value$table + expect_true(all(is.na(t7$criterion[t7$variables != ""]))) + expect_identical(t7$variables[1L], "") + w <- grep("are not ranked", r7$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "^gwr_model_selection\\(\\): 3 of 4 model\\(s\\) are not ranked at bandwidth 7; their criterion is NA and they are listed last\\.") + expect_match(w, "3 \\(a; b; a \\+ b\\) reproduce the mean of the observations at each location, or nearly") + expect_match(w, "Use a larger bandwidth\\.$") + rep7 <- r7$warnings[r7$classes == "spatialkit_gwr_repeated_locations"] + expect_length(rep7, 1L) + expect_no_match(rep7, "No bandwidth was supplied") +}) + +test_that("cv_gwr(bandwidth = NULL) fits its folds at bandwidths that predict", { + skip_on_cran() + # Before, the folds of this layer were fitted at 7 to 10 neighbours. + d <- .rl_sites(100, 3, 2) + cv <- suppressWarnings(suppressMessages( + cv_gwr(d, "z", c("a", "b"), folds = make_folds(d, k = 5, method = "random_kfold", seed = 1)))) + expect_identical(sum(cv$fold_status$status == "ok"), 5L) + expect_true(all(cv$fold_metrics$bandwidth >= 58)) + expect_identical(cv$overall$n_pred, 300L) + # Noise SD 0.2 within a site and 0.3 between sites: 0.36 together. + expect_lt(cv$overall$RMSE, 0.45) +}) diff --git a/tests/testthat/test-fix-gwr-score-dense.R b/tests/testthat/test-fix-gwr-score-dense.R new file mode 100644 index 00000000..fd8ec988 --- /dev/null +++ b/tests/testthat/test-fix-gwr-score-dense.R @@ -0,0 +1,188 @@ +# tests/testthat/test-fix-gwr-score-dense.R +# --------------------------------------------------------------------------- +# The bandwidth criterion under a kernel that weights every row. +# +# A Gaussian or an exponential kernel gives every observation a weight at +# every regression point, so scoring a bandwidth by one QR per window is n +# factorisations of n rows. A default-bandwidth fit took 10.0 s at n = 1000 +# and 32.0 s at n = 2000 (fixed Gaussian), against 1.8 s and 6.2 s for +# GWmodel::bw.gwr(). +# +# The score of a window that is far from rank deficient now comes from its +# centred cross-products, many windows to one matrix product +# (.gwr_score_dense()); the QR loop keeps the windows that are not. These +# tests hold the two routes to the same numbers and the same ranks. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +# The score by the QR loop alone: the batched path answers no window. +.sd_qr_only <- function(...) { + testthat::local_mocked_bindings( + .gwr_score_dense = function(X, ...) list(done = logical(nrow(X)))) + .gwr_local_solve(...) +} + +.sd_layer <- function(n, p, seed, reps = 1L) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + id <- rep(seq_len(n), reps) + P <- matrix(rnorm(n * max(p, 1L)), n, max(p, 1L))[id, , drop = FALSE] + if (p >= 2L) P[, 2L] <- 0.7 * P[, 1L] + 0.5 * P[, 2L] + # With repeat locations, one predictor differs between the rows of a site. + if (reps > 1L && p >= 2L) P[, 2L] <- P[, 2L] + rnorm(nrow(P), 0, 0.3) + X <- cbind(Intercept = 1, P)[, seq_len(p + 1L), drop = FALSE] + if (p) colnames(X)[-1L] <- paste0("v", seq_len(p)) + list(X = X, xy = cbind(x, y)[id, , drop = FALSE], + y = 2 + (1 + x[id] / 1000) * P[, 1L] + rnorm(n, 0, 0.3)[id] + + rnorm(length(id), 0, 0.5)) +} + +.sd_rel <- function(a, b) { + ok <- is.finite(a) | is.finite(b) + if (!any(ok)) return(0) + max(abs(a[ok] - b[ok]) / pmax(1, abs(a[ok]))) +} + + +test_that("the batched score equals the QR loop's, window for window", { + cases <- list( + list(n = 250, p = 2, k = "gaussian", ad = FALSE, bw = c(8, 15, 40, 150, 800)), + list(n = 250, p = 2, k = "gaussian", ad = TRUE, bw = c(4, 10, 40, 250, 400)), + list(n = 250, p = 4, k = "exponential", ad = TRUE, bw = c(6, 18, 100)), + list(n = 250, p = 1, k = "exponential", ad = FALSE, bw = c(2, 5, 60, 500)), + list(n = 250, p = 0, k = "gaussian", ad = FALSE, bw = c(15, 150))) + answered <- 0L; left <- 0L + for (cs in cases) { + g <- .sd_layer(cs$n, cs$p, 1) + for (bw in cs$bw) { + lab <- sprintf("%s %s p=%d bw=%g", cs$k, if (cs$ad) "adaptive" else "fixed", cs$p, bw) + qr <- .sd_qr_only(g$X, g$y, g$xy, bw, cs$k, cs$ad, what = "score") + got <- .gwr_local_solve(g$X, g$y, g$xy, bw, cs$k, cs$ad, what = "score") + done <- .gwr_score_dense(g$X, g$y, g$xy, bw, cs$k, cs$ad)$done + answered <- answered + sum(done); left <- left + sum(!done) + # Everything that is a count or a decision is identical. + expect_identical(got$rank, qr$rank, label = lab) + expect_identical(got$n_window, qr$n_window, label = lab) + expect_identical(got$width, qr$width, label = lab) + expect_identical(got$n_estimable, qr$n_estimable, label = lab) + expect_identical(is.na(got$fitted), is.na(qr$fitted), label = lab) + # The batched path answers only windows the QR finds of full rank. + expect_true(all(qr$rank[done] == ncol(g$X)), label = lab) + # The numbers agree to rounding error. + expect_lt(.sd_rel(qr$fitted, got$fitted), 1e-9, label = lab) + expect_lt(.sd_rel(qr$leverage, got$leverage), 1e-9, label = lab) + } + } + # Both routes were taken: most windows batched, the nearly deficient ones + # (the smallest fixed bandwidths) left to the QR. + expect_gt(answered, 4000L) + expect_gt(left, 100L) +}) + +test_that("the batched path leaves a window to the QR when it is close to rank deficient", { + # A covariate that is one value on each side of x = 500: constant in the + # windows away from the boundary under a fixed Gaussian of 25, where the + # weights of the other side underflow against 1e-7. + set.seed(5); n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + region <- ifelse(x > 500, 1.3, 0.7) + z <- 1 + 2 * a + 3 * region + rnorm(n, 0, 0.3) + X <- cbind(Intercept = 1, a = a, region = region); xy <- cbind(x, y) + got <- .gwr_local_solve(X, z, xy, 25, "gaussian", FALSE, what = "score") + qr <- .sd_qr_only(X, z, xy, 25, "gaussian", FALSE, what = "score") + done <- .gwr_score_dense(X, z, xy, 25, "gaussian", FALSE)$done + deficient <- qr$rank < 3L + expect_gt(sum(deficient), 50L) + expect_false(any(done & deficient)) + expect_identical(got$rank, qr$rank) + expect_identical(got$n_estimable, qr$n_estimable) + expect_lt(.sd_rel(qr$fitted, got$fitted), 1e-9) + expect_lt(.sd_rel(qr$leverage, got$leverage), 1e-9) + # A predictor far from zero: centred on its mean before any product, so the + # batched path loses nothing to the origin. + Xs <- X; Xs[, "a"] <- Xs[, "a"] + 1e7 + got0 <- .gwr_local_solve(X, z, xy, 200, "gaussian", FALSE, what = "score") + got7 <- .gwr_local_solve(Xs, z, xy, 200, "gaussian", FALSE, what = "score") + expect_true(all(.gwr_score_dense(Xs, z, xy, 200, "gaussian", FALSE)$done)) + expect_lt(.sd_rel(got0$fitted, got7$fitted), 1e-7) + # A zero-width adaptive kernel (the bandwidth's rows share one location) + # has undefined weights: no window there, by either route. + xy2 <- xy; xy2[1:6, ] <- xy2[rep(1, 6), ] + got2 <- .gwr_local_solve(X, z, xy2, 5, "gaussian", TRUE, what = "score") + expect_true(all(is.na(got2$fitted[1:6]))) + expect_identical(got2$n_window[1:6], rep(0L, 6)) + expect_false(any(.gwr_score_dense(X, z, xy2, 5, "gaussian", TRUE)$done[1:6])) +}) + +test_that("on a layer whose locations repeat the batched path gives the same leave-out residuals", { + for (cs in list(list(p = 2, k = "gaussian", ad = TRUE, bw = c(7, 13, 40, 200), reps = 3L), + list(p = 2, k = "exponential", ad = FALSE, bw = c(10, 60, 400), reps = 3L), + list(p = 0, k = "exponential", ad = FALSE, bw = c(10, 60), reps = 2L))) { + g <- .sd_layer(90, cs$p, 3, cs$reps) + loc <- .gwr_locations(g$xy) + for (bw in cs$bw) { + lab <- sprintf("%s p=%d bw=%g", cs$k, cs$p, bw) + qr <- .sd_qr_only(g$X, g$y, g$xy, bw, cs$k, cs$ad, what = "score", loc = loc) + got <- .gwr_local_solve(g$X, g$y, g$xy, bw, cs$k, cs$ad, what = "score", loc = loc) + expect_identical(lengths(got$hat_loc), lengths(qr$hat_loc), label = lab) + r_qr <- .gwr_lolo_residuals(g$y - qr$fitted, qr$leverage, qr$hat_loc, loc) + r_got <- .gwr_lolo_residuals(g$y - got$fitted, got$leverage, got$hat_loc, loc) + expect_identical(is.na(r_got), is.na(r_qr), label = lab) + expect_lt(.sd_rel(r_qr, r_got), 1e-7, label = lab) + } + } +}) + +test_that("the criterion and the selected bandwidth do not depend on the route", { + g <- .sd_layer(200, 2, 7) + for (cs in list(list(k = "gaussian", ad = FALSE), list(k = "exponential", ad = TRUE))) { + a <- .gwr_bw_search(g$X, g$y, g$xy, cs$k, cs$ad) + b <- local({ + testthat::local_mocked_bindings( + .gwr_score_dense = function(X, ...) list(done = logical(nrow(X)))) + .gwr_bw_search(g$X, g$y, g$xy, cs$k, cs$ad) + }) + expect_identical(a$bandwidth, b$bandwidth, label = cs$k) + expect_identical(a$curve$bandwidth, b$curve$bandwidth, label = cs$k) + expect_equal(a$curve$criterion, b$curve$criterion, tolerance = 1e-9, label = cs$k) + expect_equal(a$curve$tr_S, b$curve$tr_S, tolerance = 1e-9, label = cs$k) + expect_identical(a$curve$n_deficient, b$curve$n_deficient, label = cs$k) + } + # The fit at the selected bandwidth, which the QR makes, has the AICc the + # search scored. + d <- sf::st_as_sf(data.frame(x = 5e5 + g$xy[, 1], y = 5e6 + g$xy[, 2], + v1 = g$X[, 2], v2 = g$X[, 3], z = g$y), + coords = c("x", "y"), crs = 32632) + fit <- suppressWarnings(suppressMessages( + fit_gwr_model(d, "z", c("v1", "v2"), adaptive = FALSE, kernel = "gaussian"))) + expect_equal(fit$info$bandwidth_search$criterion, fit$info$AICc, tolerance = 1e-9) +}) + +test_that("a kernel with an edge is scored by the QR loop alone", { + g <- .sd_layer(120, 2, 9) + called <- 0L + testthat::local_mocked_bindings( + .gwr_score_dense = function(X, ...) { called <<- called + 1L; list(done = logical(nrow(X))) }) + for (k in c("bisquare", "tricube", "boxcar")) + .gwr_local_solve(g$X, g$y, g$xy, 30, k, TRUE, what = "score") + expect_identical(called, 0L) + .gwr_local_solve(g$X, g$y, g$xy, 30, "gaussian", TRUE, what = "score") + expect_identical(called, 1L) + # The fit and the predictions are always the QR's. + .gwr_local_solve(g$X, g$y, g$xy, 30, "gaussian", TRUE, what = "fit") + .gwr_local_solve(g$X, g$y, g$xy, 30, "gaussian", TRUE, rp = g$xy[1:5, ], + X_rp = g$X[1:5, ], what = "predict") + expect_identical(called, 1L) +}) + +test_that("scoring a bandwidth under a Gaussian kernel takes a fraction of the QR loop's time", { + skip_on_cran() + g <- .sd_layer(1500, 2, 11) + best <- function(f) min(vapply(1:3, function(i) system.time(f())[["elapsed"]], numeric(1))) + t_new <- best(function() .gwr_local_solve(g$X, g$y, g$xy, 80, "gaussian", FALSE, what = "score")) + t_qr <- best(function() .sd_qr_only(g$X, g$y, g$xy, 80, "gaussian", FALSE, what = "score")) + # Measured 0.07 to 0.21 s against 0.33 to 0.50 s over three runs each; the + # best of three is compared, loosely, for a loaded machine. + expect_lt(t_new, 0.8 * t_qr) +}) diff --git a/tests/testthat/test-fix-gwr-se-extrapolation.R b/tests/testthat/test-fix-gwr-se-extrapolation.R new file mode 100644 index 00000000..6318f754 --- /dev/null +++ b/tests/testthat/test-fix-gwr-se-extrapolation.R @@ -0,0 +1,327 @@ +# tests/testthat/test-fix-gwr-se-extrapolation.R +# --------------------------------------------------------------------------- +# What the local solve gives the methods of a gwr_fit beside the estimates: +# local standard errors through coef(se = TRUE), the standard error of a +# prediction through predict(se.fit = TRUE), and a count of the predictions +# made farther from the training data than any window of the fit reached. +# --------------------------------------------------------------------------- + +skip_if_not_installed("sp") + +.se_catch <- function(expr) { + w <- character(0); cls <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); cls <<- c(cls, class(cnd)[1L]) + invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w, classes = cls) +} + +# The slope of `a` rises eastward; training extent 0-1000 in x and y. +.se_layer <- function(n = 250, seed = 3) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + (1 + x / 500) * d$a - 0.5 * d$b + rnorm(n, 0, 0.4) + d +} +.se_new <- function(m, xlim, seed = 8) { + set.seed(seed) + sf::st_as_sf(data.frame(x = runif(m, xlim[1], xlim[2]), y = runif(m, 0, 1000), + a = rnorm(m), b = rnorm(m)), + coords = c("x", "y"), crs = 32632) +} + + +# --------------------------------------------------------------------------- +# coef(se = TRUE) +# --------------------------------------------------------------------------- + +test_that("coef(se = TRUE) returns the estimates, GWmodel's standard errors and the t values", { + skip_if_not_installed("GWmodel") + d <- .se_layer() + for (cs in list(list(bw = 40L, adaptive = TRUE, kernel = "bisquare"), + list(bw = 180, adaptive = FALSE, kernel = "gaussian"))) { + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), adaptive = cs$adaptive, + bandwidth = cs$bw, kernel = cs$kernel)) + g <- GWmodel::gwr.basic(z ~ a + b, data = .to_sp(d, c("z", "a", "b")), bw = cs$bw, + kernel = cs$kernel, adaptive = cs$adaptive)$SDF@data + out <- coef(fit, se = TRUE) + expect_named(out, c("estimate", "se", "t")) + for (el in out) { + expect_s3_class(el, "data.frame") + expect_named(el, c("Intercept", "a", "b")) + expect_identical(nrow(el), nrow(d)) + } + # The default is unchanged: the estimates alone, as a data.frame. + expect_identical(coef(fit), out$estimate) + expect_identical(coef(fit, se = FALSE), out$estimate) + expect_equal(unname(as.matrix(out$se)), + unname(as.matrix(g[c("Intercept_SE", "a_SE", "b_SE")])), tolerance = 1e-6) + expect_equal(unname(as.matrix(out$t)), + unname(as.matrix(g[c("Intercept_TV", "a_TV", "b_TV")])), tolerance = 1e-6) + expect_equal(as.matrix(out$t), as.matrix(out$estimate) / as.matrix(out$se)) + # From the fit's own numbers: sigma^2 = RSS / (n - 2 tr S + tr S'S). + expect_equal(fit$info$sigma2, sum(residuals(fit)^2) / fit$info$edf) + expect_equal(fit$info$enp + fit$info$edf, nrow(d)) + } + expect_error(coef(fit, se = NA), "`se` must be TRUE or FALSE") + expect_error(coef(fit, se = "yes"), "`se` must be TRUE or FALSE") +}) + +test_that("coef(se = TRUE) takes the standard errors by position, and refuses a table without them", { + # A predictor called `a_SE` beside `a`: the coefficient of `a_SE` is one + # column, the standard error of `a` another of the same name. + set.seed(4); n <- 120 + d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), a_SE = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + d$a + 2 * d$a_SE + rnorm(n, 0, 0.3) + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "a_SE"), bandwidth = 40)) + out <- coef(fit, se = TRUE) + expect_named(out$estimate, c("Intercept", "a", "a_SE")) + expect_lt(abs(mean(out$estimate$a_SE) - 2), 0.1) + expect_true(all(out$se$a > 0 & out$se$a < 0.3)) + expect_equal(out$t$a, out$estimate$a / out$se$a) + # An engine that carries the coefficients alone. + bare <- fit + bare$engine <- list(SDF = sf::st_sf(Intercept = 1, a = 2, a_SE = 3, + geometry = sf::st_geometry(d))) + expect_identical(nrow(coef(bare)), 120L) + expect_error(coef(bare, se = TRUE), "does not carry standard errors and t values") +}) + + +# --------------------------------------------------------------------------- +# predict(se.fit = TRUE) +# --------------------------------------------------------------------------- + +test_that("predict(se.fit = TRUE) returns the fit's values with their standard errors", { + d <- .se_layer() + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 40)) + nd <- .se_new(60, c(100, 900)) + p <- predict(fit, newdata = nd, se.fit = TRUE) + expect_named(p, c("fit", "se.fit", "se.pred", "residual.scale", "df")) + expect_identical(p$fit, predict(fit, newdata = nd)) + expect_true(all(p$se.fit > 0 & p$se.fit < p$se.pred)) + expect_equal(p$se.pred^2, p$se.fit^2 + fit$info$sigma2) + expect_equal(p$residual.scale, sqrt(fit$info$sigma2)) + expect_equal(p$df, fit$info$edf) + # At the training rows the fitted value's variance is sigma^2 times the sum + # of squares of its hat row, and newdata = NULL means those rows. + p0 <- predict(fit, se.fit = TRUE) + expect_identical(p0$fit, unname(fitted(fit))) + expect_identical(p0, predict(fit, newdata = d, se.fit = TRUE)) + sv <- .gwr_local_solve(cbind(Intercept = 1, a = d$a, b = d$b), d$z, + sf::st_coordinates(d), 40L, "bisquare", TRUE, what = "fit") + expect_equal(p0$se.fit, sqrt(fit$info$sigma2 * sv$var_fit)) + expect_equal(sum(sv$var_fit), 2 * fit$info$tr_S - fit$info$enp) + # Rows dropped for a missing predictor keep their place, as NA. + nd2 <- nd[1:8, ]; nd2$a[c(2, 5)] <- NA + p2 <- predict(fit, newdata = nd2, se.fit = TRUE) + expect_identical(which(is.na(p2$fit)), c(2L, 5L)) + expect_identical(which(is.na(p2$se.pred)), c(2L, 5L)) + expect_identical(p2$fit[-c(2, 5)], p$fit[c(1, 3, 4, 6:8)]) + # The default return is the plain vector, and a bad `se.fit` is refused. + expect_type(predict(fit, newdata = nd), "double") + expect_error(predict(fit, newdata = nd, se.fit = NA), "`se.fit` must be TRUE or FALSE") + expect_error(predict(fit, newdata = nd, interval = "prediction"), "unused argument") +}) + +test_that("the prediction standard error covers held-out observations about as often as it says", { + # A stationary layer, so the local model is true everywhere: 90% intervals + # from se.pred should hold about 90% of new observations. + cover <- vapply(1:6, function(seed) { + set.seed(seed); n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, z = 1 + 2 * a + rnorm(n, 0, 0.5)), + coords = c("x", "y"), crs = 32632) + tr <- d[1:200, ]; te <- d[201:300, ] + fit <- suppressMessages(fit_gwr_model(tr, "z", "a", bandwidth = 60)) + p <- suppressWarnings(predict(fit, newdata = te, se.fit = TRUE)) + mean(abs(te$z - p$fit) <= stats::qnorm(0.95) * p$se.pred) + }, numeric(1)) + expect_gt(mean(cover), 0.85) + expect_lt(mean(cover), 0.95) +}) + +test_that("a fit without a residual variance returns NA standard errors and says why", { + d <- .se_layer(120) + nd <- .se_new(5, c(100, 900)) + # Put together by hand: the data and the settings, nothing from a solve. + bare <- new_spatial_fit("gwr_fit", engine = list(), formula = z ~ a + b, + response_var = "z", predictor_vars = c("a", "b"), data_sf = d, + info = list(bandwidth = 40, adaptive = TRUE, kernel = "bisquare")) + r <- .se_catch(predict(bare, newdata = nd, se.fit = TRUE)) + expect_false(anyNA(r$value$fit)) + expect_true(all(is.na(r$value$se.fit)) && all(is.na(r$value$se.pred))) + expect_true(is.na(r$value$residual.scale)) + expect_match(r$warnings, "the fit carries no residual variance") + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 40)) + expect_identical(r$value$fit, predict(fit, newdata = nd)) +}) + + +# --------------------------------------------------------------------------- +# summary(): effective parameters and the global benchmark +# --------------------------------------------------------------------------- + +test_that("the fit carries a global least-squares benchmark and summary() prints it", { + d <- .se_layer() + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 40)) + ols <- stats::lm(z ~ a + b, data = sf::st_drop_geometry(d)) + rss <- sum(stats::residuals(ols)^2); n <- nrow(d) + g <- fit$info$global_ols + expect_named(g, c("RSS", "RMSE", "AICc")) + expect_equal(g$RSS, rss) + expect_equal(g$RMSE, sqrt(rss / n)) + # The fit's own AICc formula, at a hat-matrix trace of 3. + expect_equal(g$AICc, n * log(rss / n) + n * log(2 * pi) + n * (n + 3) / (n - 2 - 3)) + # The slope of `a` doubles across this layer: the GWR is far below. + expect_lt(fit$info$AICc, g$AICc - 50) + txt <- paste(utils::capture.output(print(summary(fit))), collapse = "\n") + expect_match(txt, sprintf("Effective parameters: %.1f \\(residual degrees of freedom %.1f\\)", + fit$info$enp, fit$info$edf)) + expect_match(txt, sprintf("Global least squares on the same rows: AICc %.2f, RMSE %.4f", + g$AICc, g$RMSE)) + expect_match(txt, sprintf("This fit: AICc %.2f \\(below the global fit's by %.2f\\)", + fit$info$AICc, g$AICc - fit$info$AICc)) + expect_no_match(txt, "Rank-deficient windows") + expect_match(paste(utils::capture.output(print(fit)), collapse = "\n"), + sprintf("Eff. parameters: %.1f of 250 observations", fit$info$enp)) + # On a process whose coefficients do not vary, the selected GWR does not + # beat the global regression by AICc in most draws. + beats <- vapply(1:6, function(seed) { + set.seed(300 + seed); m <- 150 + s <- sf::st_as_sf(data.frame(x = runif(m, 0, 1000), y = runif(m, 0, 1000), a = rnorm(m)), + coords = c("x", "y"), crs = 32632) + s$z <- 1 + 2 * s$a + rnorm(m, 0, 0.5) + f <- suppressMessages(fit_gwr_model(s, "z", "a")) + f$info$AICc < f$info$global_ols$AICc + }, logical(1)) + expect_lte(sum(beats), 2L) + # A fit with windows of deficient rank says so in both prints. + set.seed(42); m <- 300 + x <- runif(m, 0, 1000); y <- runif(m, 0, 1000); a <- rnorm(m) + r <- sf::st_as_sf(data.frame(x = x, y = y, a = a, region = ifelse(x > 500, 1.3, 0.7), + z = 1 + 2 * a + 3 * (x > 500) + rnorm(m, 0, 0.3)), + coords = c("x", "y"), crs = 32632) + fr <- suppressWarnings(suppressMessages(fit_gwr_model(r, "z", c("a", "region"), bandwidth = 40))) + expect_match(paste(utils::capture.output(print(fr)), collapse = "\n"), + "Rank-deficient windows: 185 of 300 \\(their unestimable coefficients are NA; see \\$info\\$nonfinite_coef\\)") + expect_match(paste(utils::capture.output(print(summary(fr))), collapse = "\n"), + "Rank-deficient windows: 185 of 300 \\(their unestimable coefficients are NA\\)") +}) + + +# --------------------------------------------------------------------------- +# Predictions beyond the reach of the fit +# --------------------------------------------------------------------------- + +test_that("predict() counts the locations farther from the data than the widest kernel reaches", { + # Adaptive bisquare, 40 neighbours. Before: new locations three extents + # east of the data (x from 4000 to 5000) came back with no NA and no + # warning, at 35 times the in-extent error. + d <- .se_layer() + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 40)) + xy <- sf::st_coordinates(d) + dm <- as.matrix(stats::dist(xy)) + width <- max(apply(dm, 1L, function(v) sort(v)[40L])) + expect_equal(fit$info$max_kernel_width, width) + nearest <- function(nd) { + q <- sf::st_coordinates(nd) + vapply(seq_len(nrow(q)), function(i) + min(sqrt((xy[, 1] - q[i, 1])^2 + (xy[, 2] - q[i, 2])^2)), numeric(1)) + } + # Inside the extent: nothing to say. + inside <- .se_new(200, c(0, 1000)) + expect_no_warning(p_in <- predict(fit, newdata = inside)) + expect_false(anyNA(p_in)) + # A band that straddles the reach: some locations beyond it, some not. + band <- .se_new(200, c(1000, 1000 + 2 * width)) + far_b <- nearest(band) > width + expect_gt(sum(far_b), 20L); expect_gt(sum(!far_b), 20L) + r <- .se_catch(predict(fit, newdata = band)) + expect_false(anyNA(r$value)) + expect_identical(r$classes, "spatialkit_gwr_extrapolation") + expect_match(r$warnings, sprintf( + "^predict.gwr_fit\\(\\): %d of 200 location\\(s\\) are farther from every training point than the widest kernel of the fit reaches \\(%s in the units of the fit's CRS\\)", + sum(far_b), format(signif(width, 4)))) + expect_match(r$warnings, sprintf("the nearest training point is %s to %s away", + format(signif(min(nearest(band)[far_b]), 4)), + format(signif(max(nearest(band)[far_b]), 4)))) + expect_match(r$warnings, "the prediction\\(s\\) there are extrapolations in space") + # Three extents out: every one. + beyond <- .se_new(150, c(4000, 5000)) + rb <- .se_catch(predict(fit, newdata = beyond)) + expect_false(anyNA(rb$value)) + expect_match(rb$warnings, "^predict.gwr_fit\\(\\): 150 of 150 location\\(s\\) are farther") + # The class is there to be caught. + n_caught <- 0L + withCallingHandlers( + p_far <- predict(fit, newdata = beyond), + spatialkit_gwr_extrapolation = function(cnd) { + n_caught <<- n_caught + 1L; invokeRestart("muffleWarning") + }) + expect_identical(n_caught, 1L) + expect_identical(p_far, rb$value) + # The values are returned as computed, and they are what the warning is + # about: the slope keeps rising in the truth and the fit cannot know. + truth <- function(nd) 1 + (1 + sf::st_coordinates(nd)[, 1] / 500) * nd$a - 0.5 * nd$b + rmse <- function(e) sqrt(mean(e^2)) + expect_gt(rmse(rb$value - truth(beyond)), 5 * rmse(p_in - truth(inside))) +}) + +test_that("the reach is the bandwidth for a fixed kernel with an edge, and three bandwidths for one without", { + d <- .se_layer() + out <- .se_new(60, c(1000, 2500), seed = 2) + xy <- sf::st_coordinates(d); q <- sf::st_coordinates(out) + dq <- vapply(seq_len(nrow(q)), function(i) + sqrt((xy[, 1] - q[i, 1])^2 + (xy[, 2] - q[i, 2])^2), numeric(nrow(xy))) + near <- apply(dq, 2L, min) + # Bisquare, fixed 300: a location with no training point within 300 m has + # an empty window, and one with fewer than three has too few for three + # parameters. Both are NA, which the other warning counts by cause, and + # nothing finite is beyond the reach. + fb <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE, bandwidth = 300)) + within <- colSums(dq < 300) + expect_gt(sum(within == 0L), 5L); expect_gt(sum(within %in% 1:2), 0L) + rb <- .se_catch(predict(fb, newdata = out)) + expect_identical(is.na(rb$value), within < 3L) + expect_identical(rb$classes, "spatialkit_gwr_not_estimable") + expect_match(rb$warnings, sprintf("At %d of them no training point carries weight within the fixed bandwidth \\(300\\)", + sum(within == 0L))) + expect_match(rb$warnings, sprintf("At %d the training points in the window cannot place the new row", + sum(within %in% 1:2))) + # Gaussian, fixed 150: every location is predicted, and those more than 450 + # m from the data are counted. + fg <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE, bandwidth = 150, + kernel = "gaussian")) + rg <- .se_catch(predict(fg, newdata = out)) + expect_false(anyNA(rg$value)) + expect_identical(rg$classes, "spatialkit_gwr_extrapolation") + expect_match(rg$warnings, sprintf("^predict.gwr_fit\\(\\): %d of 60 location", sum(near > 450))) + expect_match(rg$warnings, "reaches \\(450 in the units of the fit's CRS, three times the widest gaussian bandwidth of 150\\)") + expect_identical(.gwr_kernel_reach(fg, xy, 150, FALSE, "gaussian"), list(width = 150, reach = 450)) + expect_identical(.gwr_kernel_reach(fb, xy, 300, FALSE, "bisquare"), list(width = 300, reach = 300)) +}) + +test_that("a fit put together by hand has its widest kernel worked out at prediction", { + d <- .se_layer(150) + fit <- suppressMessages(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 30)) + bare <- new_spatial_fit("gwr_fit", engine = list(), formula = z ~ a + b, + response_var = "z", predictor_vars = c("a", "b"), data_sf = d, + info = list(bandwidth = 30, adaptive = TRUE, kernel = "bisquare")) + xy <- sf::st_coordinates(d) + expect_equal(.gwr_kernel_reach(bare, xy, 30L, TRUE, "bisquare")$width, + fit$info$max_kernel_width) + beyond <- .se_new(20, c(3000, 4000)) + r1 <- .se_catch(predict(fit, newdata = beyond)) + r2 <- .se_catch(predict(bare, newdata = beyond)) + expect_identical(r2$value, r1$value) + expect_identical(r2$warnings, r1$warnings) + expect_identical(r2$classes, "spatialkit_gwr_extrapolation") +}) diff --git a/tests/testthat/test-fix-gwr-selection-null.R b/tests/testthat/test-fix-gwr-selection-null.R new file mode 100644 index 00000000..600e4702 --- /dev/null +++ b/tests/testthat/test-fix-gwr-selection-null.R @@ -0,0 +1,227 @@ +# tests/testthat/test-fix-gwr-selection-null.R +# --------------------------------------------------------------------------- +# gwr_model_selection() scores the model without predictors and reports the +# criterion gaps. +# +# The forward sweep starts from one predictor, so by itself it always names +# at least one, whether or not any candidate helps: on a response unrelated +# to three candidates it selected one of them every time. The table gave raw +# AICc and left the subtraction to the reader. The sweep is also the +# package's own, on the local solve, so a candidate that is constant inside +# some windows is scored on what they estimate. +# --------------------------------------------------------------------------- + +.sn_catch <- function(expr) { + w <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w) +} + +# The example of ?gwr_model_selection. +.sn_example <- function() { + set.seed(1); n <- 80 + dat <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n), noise = rnorm(n)), + coords = c("x", "y"), crs = 32632) + dat$z <- 2 * dat$a - dat$b + rnorm(n, 0, 0.5) + dat +} + + +test_that("the table carries the model without predictors and each model's gap to the best", { + skip_if_not_installed("sp") + dat <- .sn_example() + sel <- suppressMessages(gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 30)) + # The documented example still selects a + b. + expect_identical(sel$best, c("a", "b")) + tab <- sel$table + expect_named(tab, c("rank", "n_vars", "variables", "criterion", "delta")) + expect_identical(nrow(tab), 7L) # 3 + 2 + 1 and + expect_identical(sel$n_models, 7L) + none <- which(tab$variables == "") + expect_length(none, 1L) + expect_identical(tab$n_vars[none], 0L) + expect_true(is.finite(tab$criterion[none])) + # delta is the criterion minus the best: 0 in the first row. + expect_identical(tab$delta[1L], 0) + expect_equal(tab$delta, tab$criterion - min(tab$criterion)) + expect_false(is.unsorted(tab$delta)) + # The local mean is far behind a model that explains the response. + expect_gt(tab$delta[none], 50) + # It is a GWR without predictors at the sweep's bandwidth: the AICc of + # local weighted means of the response. + xy <- sf::st_coordinates(dat) + cr <- .gwr_criterion(matrix(1, 80, 1), dat$z, xy, 30L, "bisquare", TRUE) + expect_equal(tab$criterion[none], cr$value) + w1 <- .gw_kernel_weights(sqrt((xy[, 1] - xy[1, 1])^2 + (xy[, 2] - xy[1, 2])^2), + 30L, "bisquare", TRUE) + sv <- .gwr_local_solve(matrix(1, 80, 1, dimnames = list(NULL, "Intercept")), dat$z, + xy, 30L, "bisquare", TRUE, what = "score") + expect_equal(sv$fitted[1L], sum(w1 * dat$z) / sum(w1)) + expect_equal(sv$leverage[1L], 1 / sum(w1)) + # The models within 2 of the best, and the smallest of them. + expect_identical(sel$within_2, tab[tab$delta <= 2, , drop = FALSE]) + expect_identical(sel$smallest_within_2, c("a", "b")) + # raw is the forward sweep alone, in GWmodel's layout. + expect_length(sel$raw[[1L]], 6L) + expect_identical(dim(sel$raw[[2L]]), c(6L, 4L)) + expect_identical(sel$criterion, "AICc") + expect_true(sel$criterion_by_name) + expect_true(sel$criterion_verified) +}) + +test_that("on a response unrelated to the candidates the model without predictors is usually selected", { + skip_if_not_installed("sp") + # Before: one of the three candidates was selected in 8 of 8 draws, because + # nothing else could be. + best <- vapply(1:8, function(seed) { + set.seed(100 + seed); m <- 150 + d <- sf::st_as_sf(data.frame(x = runif(m, 0, 1000), y = runif(m, 0, 1000), + p1 = rnorm(m), p2 = rnorm(m), p3 = rnorm(m), z = rnorm(m)), + coords = c("x", "y"), crs = 32632) + s <- suppressMessages(gwr_model_selection(d, "z", c("p1", "p2", "p3"), bandwidth = 60)) + expect_identical(s$table$delta[1L], 0) + # Whatever is selected, the model without predictors is in the running. + expect_true("" %in% s$table$variables) + if (length(s$best)) paste(s$best, collapse = "+") else "" + }, character(1)) + expect_gte(sum(best == ""), 5L) +}) + +test_that("print() shows the gaps, the models within 2 of the best and the smallest of them", { + # Built on a stub engine, so it runs without GWmodel: six models of a + # sweep, and a model without predictors that the engine scored. + set.seed(11) + pts <- sf::st_as_sf(data.frame(x = runif(40, 0, 1000), y = runif(40, 0, 1000), + z = rnorm(40), a = rnorm(40), b = rnorm(40), cc = rnorm(40)), + coords = c("x", "y"), crs = 32632) + eng <- function(aicc, null = NULL) function(...) { + ml <- list(list("z", "a"), list("z", "b"), list("z", "cc"), list("z", c("a", "b")), + list("z", c("a", "cc")), list("z", c("a", "b", "cc"))) + m <- cbind(bandwidth = 30, AIC = aicc - 5, AICc = aicc, RSS = 1) + out <- list(model_list = ml, gwr_df = m, bandwidth = 30, bandwidth_source = "supplied", + used_dmat = FALSE, raw = list(ml, m)) + if (!is.null(null)) out$null_model <- c(bandwidth = 30, AIC = null - 5, AICc = null, RSS = 1) + out + } + # a + b best; a + b + cc and a within 2 of it; a is the smallest of them. + sel <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, + .engine = eng(c(111.5, 118, 125, 110, 119, 110.8), null = 140)) + expect_identical(sel$best, c("a", "b")) + expect_identical(sel$table$variables[1:3], c("a + b", "a + b + cc", "a")) + expect_equal(sel$table$delta[1:3], c(0, 0.8, 1.5)) + expect_identical(sel$within_2$variables, c("a + b", "a + b + cc", "a")) + expect_identical(sel$smallest_within_2, "a") + expect_identical(sel$table$variables[7L], "") + txt <- paste(utils::capture.output(print(sel)), collapse = "\n") + expect_match(txt, "delta") + expect_match(txt, "Selected: z ~ a \\+ b") + expect_match(txt, "Within 2 of the best \\(a difference this small does not separate models\\):") + expect_match(txt, "z ~ a \\+ b \\(\\+0\\.00\\)") + expect_match(txt, "z ~ a \\+ b \\+ cc \\(\\+0\\.80\\)") + expect_match(txt, "z ~ a \\(\\+1\\.50\\)") + expect_match(txt, "Smallest of them: z ~ a\n") + # A clear winner: the runner-up's gap is stated instead. + clear <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, + .engine = eng(c(120, 118, 125, 110, 119, 115), null = 140)) + txt2 <- paste(utils::capture.output(print(clear)), collapse = "\n") + expect_match(txt2, "No other model is within 2 of the best; the runner-up is 5\\.00 away\\.") + expect_identical(clear$smallest_within_2, c("a", "b")) + # The model without predictors wins: best is empty, and print says so. + nul <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, + .engine = eng(c(120, 118, 125, 110, 119, 115), null = 109)) + expect_identical(nul$best, character(0)) + expect_identical(nul$table$variables[1L], "") + expect_identical(nul$smallest_within_2, character(0)) + txt3 <- paste(utils::capture.output(print(nul)), collapse = "\n") + expect_match(txt3, "Selected: z ~ 1\n") + expect_match(txt3, "The model without predictors has the lowest criterion: no candidate") + expect_match(txt3, "z ~ 1 \\(\\+0\\.00\\)") + expect_match(txt3, "z ~ a \\+ b \\(\\+1\\.00\\)") + expect_match(txt3, "Smallest of them: z ~ 1\n") + # An engine that scores no such model gives the table it always gave, with + # the gaps. + old <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, + .engine = eng(c(120, 118, 125, 110, 119, 115))) + expect_identical(nrow(old$table), 6L) + expect_false("" %in% old$table$variables) + expect_equal(old$table$delta, old$table$criterion - 110) + # The table helper alone: delta, also when maximising and when nothing is + # finite. + expect_identical(.gwr_ms_table(list("a", character(0)), c(12, 10))$delta, c(0, 2)) + expect_identical(.gwr_ms_table(list("a", character(0)), c(12, 10))$variables, c("", "a")) + expect_equal(.gwr_ms_table(list("a", "b"), c(0.2, 0.8), minimise = FALSE)$delta, c(0, 0.6)) + expect_true(all(is.na(.gwr_ms_table(list("a", "b"), c(NA, NA))$delta))) + expect_identical(.gwr_ms_table(list("a", "b", "c"), c(NA, 5, 7))$delta, c(0, 2, NA)) +}) + +test_that("a well-posed sweep is the one GWmodel::gwr.model.selection() runs", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + dat <- .sn_example() + for (cs in list(list(bw = 30L, adaptive = TRUE, kernel = "bisquare"), + list(bw = 300, adaptive = FALSE, kernel = "gaussian"))) { + sel <- suppressMessages(gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = cs$bw, + adaptive = cs$adaptive, kernel = cs$kernel)) + sp_d <- .to_sp(dat, c("z", "a", "b", "noise")) + direct <- .gwr_quietly(GWmodel::gwr.model.selection( + DeVar = "z", InDeVars = c("a", "b", "noise"), data = sp_d, bw = cs$bw, + adaptive = cs$adaptive, kernel = cs$kernel, + dMat = GWmodel::gw.dist(dp.locat = sp::coordinates(sp_d)))) + # The same models in the same order, and the same bandwidth, AIC, AICc + # and RSS for each. + expect_identical(sel$raw[[1L]], direct[[1L]], info = cs$kernel) + expect_equal(unname(sel$raw[[2L]]), direct[[2L]], tolerance = 1e-9, info = cs$kernel) + expect_identical(colnames(sel$raw[[2L]]), c("bandwidth", "AIC", "AICc", "RSS")) + } + # quiet = FALSE writes one line per model, and changes nothing else. + out <- utils::capture.output( + loud <- gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 30, quiet = FALSE)) + expect_identical(sum(grepl("^Now calibrating model [1-6] of 6: z~", out)), 6L) + expect_identical(sum(grepl("^Now calibrating the model without predictors: z~1$", out)), 1L) + quiet <- suppressMessages(gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 30)) + expect_identical(loud$table, quiet$table) + # dmat_max_n is accepted and ignored: no distance matrix is built, so a + # fixed bandwidth needs none. + f0 <- suppressMessages(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 300, + adaptive = FALSE, dmat_max_n = 0)) + f1 <- suppressMessages(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 300, + adaptive = FALSE)) + expect_identical(f0$table, f1$table) + expect_false(f0$used_dmat) +}) + +test_that("a candidate constant inside some windows is ranked on what those windows estimate", { + skip_if_not_installed("sp") + # z = 1 + 2 a + 3 (east of x = 500) + noise; `region` codes east and west. + # Before: coded 0/1 the sweep stopped ("inv(): matrix is singular"); coded + # 0.7/1.3 it returned with no warning and AICc of 1810 to 1929 for the + # three models that hold `region`, the true driver, against 534 for `a` + # alone. + set.seed(42); n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n); east <- x > 500 + eps <- rnorm(n, 0, 0.3); b <- rnorm(n) + tabs <- lapply(list(c(0, 1), c(0.7, 1.3)), function(lev) { + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, b = b, z = 1 + 2 * a + 3 * east + eps, + region = ifelse(east, lev[2], lev[1])), + coords = c("x", "y"), crs = 32632) + r <- .sn_catch(gwr_model_selection(d, "z", c("a", "b", "region"), bandwidth = 40)) + sel <- r$value + expect_s3_class(sel, "gwr_model_selection") + expect_length(r$warnings, 0L) + expect_identical(sel$best, c("a", "region")) + expect_identical(sel$table$variables[1:2], c("a + region", "a + region + b")) + expect_true(all(is.finite(sel$table$criterion))) + sel$table + }) + # One data set in two codings: one table. + expect_identical(tabs[[2L]]$variables, tabs[[1L]]$variables) + expect_equal(tabs[[2L]]$criterion, tabs[[1L]]$criterion, tolerance = 1e-8) + # The AICc fit_gwr_model() gives the same model on these rows (pinned in + # test-fix-gwr-local-solve.R, where it was recorded from the solve). + expect_equal(tabs[[1L]]$criterion[1L], 145.2796, tolerance = 1e-5) +}) diff --git a/tests/testthat/test-fix-integration-callers.R b/tests/testthat/test-fix-integration-callers.R new file mode 100644 index 00000000..2cfd16c0 --- /dev/null +++ b/tests/testthat/test-fix-integration-callers.R @@ -0,0 +1,423 @@ +# tests/testthat/test-fix-integration-callers.R +# --------------------------------------------------------------------------- +# Where one function's change meets another's. +# +# 1. estimate_sac_range() refuses a layer with no spatial structure and +# attaches a pure nugget. Its callers ask one predicate for that verdict +# (.sac_no_structure(), R/utils.R) and act on it the same way. +# 2. predict() on a GWR counts, per call, the locations it cannot estimate +# and those beyond the reach of the fit. predict_surface(), which +# predicts in chunks, and cv_gwr(), which predicts fold by fold, raise +# each warning once with totals. +# 3. fit_gwr_model() fits the model with no predictors, the kernel-weighted +# local mean, which select_features_forward() takes as a GWR's baseline. +# 4. model_metrics() refuses the predict() arguments that return something +# other than one value per row. +# 5. kNNDM folds are named by the functions that label a fold scheme. +# --------------------------------------------------------------------------- + +fic_conditions <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }, message = function(m) invokeRestart("muffleMessage")) + list(value = val, conds = w, + messages = vapply(w, conditionMessage, character(1)), + classes = vapply(w, function(c) class(c)[1L], character(1))) +} + +# 240 points on a 1000 m square: an exponential field (effective range 150, +# nugget 0.2 on a sill of 1) and a white-noise column, in a 4 x 4 grid. +fic_layer <- local({ + val <- NULL + function() { + if (is.null(val)) { + set.seed(4401); n <- 240 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- drop(crossprod(chol(0.8 * exp(-3 * D / 150) + diag(0.2, n)), rnorm(n))) + pts <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, z = z, noise = rnorm(n)), + coords = c("x", "y"), crs = 32632) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + cells <- create_grid_polygons(bnd, target_cells = 16, type = "square") + val <<- list(pts = pts, cells = cells, + asg = suppressWarnings(assign_features_to_polygons(pts, cells))) + } + val + } +}) + + +# --- 1. one verdict for "no spatial structure" -------------------------------- + +test_that("the two no-structure refusals are the shared constants, and one predicate reads them", { + skip_if_not_installed("gstat") + s <- fic_layer() + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + expect_identical(attr(no, "rejected_reason"), .sac_reason_no_structure) + expect_true(.sac_no_structure(no)) + expect_true(.vgm_is_pure_nugget(attr(no, "variogram_model"))) + # The flat variogram: white noise let past the test. + set.seed(70302) + wn <- sf::st_as_sf(data.frame(x = 5e5 + runif(300, 0, 1000), y = 5e6 + runif(300, 0, 1000), + z = rnorm(300)), coords = c("x", "y"), crs = 32632) + flat <- suppressWarnings(estimate_sac_range(wn, "z", structure_alpha = 1)) + expect_identical(attr(flat, "rejected_reason"), .sac_reason_flat) + expect_true(.sac_no_structure(flat)) + expect_true(.vgm_is_pure_nugget(attr(flat, "variogram_model"))) + # Not the other refusals, an accepted range, a bare NA or nothing. + ok <- estimate_sac_range(s$pts, "z") + far <- suppressWarnings(estimate_sac_range(s$pts, "z", range_frac = 0.05)) + expect_true(is.finite(ok)); expect_true(is.na(far)) + expect_false(.sac_no_structure(ok)) + expect_false(.sac_no_structure(far)) + expect_false(.sac_no_structure(NA_real_)) + expect_false(.sac_no_structure(NULL)) + expect_false(.sac_no_structure(250)) + # A reason written by hand counts when it says so; a finite range never does. + by_hand <- structure(NA_real_, rejected_reason = "no spatial structure in this layer") + expect_true(.sac_no_structure(by_hand)) + expect_false(.sac_no_structure(structure(120, rejected_reason = .sac_reason_no_structure))) +}) + +test_that("every caller acts on the no-structure verdict, and none treats it as a failed fit", { + skip_if_not_installed("gstat") + s <- fic_layer() + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + + # resolution_profile(): no nugget for Cp, no warning about the model, and + # select_resolution() says the count is not identified. + rp <- fic_conditions(resolution_profile(s$pts, "noise", sac = no, n_levels = 4, nstart = 2, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans")) + expect_identical(attr(rp$value, "cp_noise")$source, "finest-level residual mean square") + expect_false(any(grepl("not a fitted value|optimiser|did not converge", rp$messages))) + sel <- suppressWarnings(select_resolution(rp$value, criterion = "cp")) + expect_false(sel$structured) + expect_true(any(grepl(.sac_reason_no_structure, sel$note, fixed = TRUE))) + + # summarize_by_cell(): a design effect of 1 by the variogram route. + sm <- fic_conditions(summarize_by_cell(s$asg, "noise", deff = "variogram", sac = no, + estimate = "mean")) + expect_length(sm$conds, 0L) + expect_true(all(sm$value$deff_method == "variogram")) + expect_true(all(attr(sm$value, "deff_applied")$deff == 1, na.rm = TRUE)) + # The flat variogram takes the same route. + set.seed(70302) + wn <- sf::st_as_sf(data.frame(x = 5e5 + runif(300, 0, 1000), y = 5e6 + runif(300, 0, 1000), + z = rnorm(300)), coords = c("x", "y"), crs = 32632) + flat <- suppressWarnings(estimate_sac_range(wn, "z", structure_alpha = 1)) + wn_cells <- create_grid_polygons(sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(wn))), + target_cells = 9, type = "square") + wn_asg <- suppressWarnings(assign_features_to_polygons(wn, wn_cells)) + sf2 <- fic_conditions(summarize_by_cell(wn_asg, "z", deff = "variogram", sac = flat, + estimate = "mean")) + expect_false(any(vapply(sf2$conds, inherits, logical(1), "spatialkit_deff_fallback"))) + expect_true(all(sf2$value$deff_method == "variogram")) + # A refusal that says "no spatial structure" but carries a model with a + # range is not that verdict's model: it is set aside like any refusal. + odd <- no + attr(odd, "variogram_model") <- attr(estimate_sac_range(s$pts, "z"), "variogram_model") + so <- fic_conditions(summarize_by_cell(s$asg, NULL, predictor_vars = "noise", + deff = "variogram", sac = odd, estimate = "mean")) + expect_identical(sum(vapply(so$conds, inherits, logical(1), "spatialkit_deff_fallback")), 1L) + + # kriging_adequacy(): the model is used, and the warning says what it is. + ka <- fic_conditions(kriging_adequacy(s$asg, "noise", s$cells, sac = no, k = 3)) + hit <- grepl("range was not identified", ka$messages, fixed = TRUE) + expect_identical(sum(hit), 1L) + expect_match(ka$messages[hit], .sac_reason_no_structure, fixed = TRUE) + expect_match(ka$messages[hit], "is a pure nugget: no spatial correlation was found") + expect_false(grepl("did not pin down", ka$messages[hit], fixed = TRUE)) + # Another refusal keeps the sentence written for it. + far <- suppressWarnings(estimate_sac_range(s$pts, "z", range_frac = 0.05)) + kf <- fic_conditions(kriging_adequacy(s$asg, "z", s$cells, sac = far, k = 3)) + expect_true(any(grepl("is one the data did not pin down", kf$messages, fixed = TRUE))) + + # plot(): the reason is the subtitle. + skip_if_not_installed("ggplot2") + expect_match(plot(no)$labels$subtitle, "^No effective range: no spatial structure detected") +}) + +test_that("a selection's centres carry the profile's hull as their cover", { + skip_if_not_installed("gstat") + s <- fic_layer() + prof <- suppressWarnings(resolution_profile(s$pts, "z", levels = c(4, 9, 16), nstart = 3)) + sel <- suppressWarnings(select_resolution(prof)) + expect_s3_class(attr(sel$seeds, "cover"), "sfc") + expect_equal(as.numeric(sf::st_area(attr(sel$seeds, "cover"))), + as.numeric(sf::st_area(attr(prof, "hull")))) +}) + + +# --- 2. the GWR's counted warnings, once per caller --------------------------- + +fic_gwr_layer <- function(n = 150, seed = 4) { + set.seed(seed) + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + d +} + +test_that("predict_surface() raises a GWR's extrapolation warning once, with the grid's totals", { + skip_if_not_installed("sp") + d <- fic_gwr_layer() + fit <- suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30)) + g <- expand.grid(x = 5e5 + seq(-1500, 2500, length.out = 20), + y = 5e6 + seq(-1500, 2500, length.out = 15)) + g$a <- 0 + grid <- sf::st_as_sf(g, coords = c("x", "y"), crs = 32632) + one <- fic_conditions(predict_surface(fit, grid, chunk_size = 5000L)) + many <- fic_conditions(predict_surface(fit, grid, chunk_size = 50L)) + for (r in list(one, many)) { + expect_identical(sum(r$classes == "spatialkit_gwr_extrapolation"), 1L) + w <- r$conds[[which(r$classes == "spatialkit_gwr_extrapolation")]] + expect_match(conditionMessage(w), "^predict_surface\\(\\): [0-9]+ of 300 location\\(s\\)") + expect_identical(w$n, 300L) + } + w1 <- one$conds[[which(one$classes == "spatialkit_gwr_extrapolation")]] + wm <- many$conds[[which(many$classes == "spatialkit_gwr_extrapolation")]] + expect_identical(wm$n_far, w1$n_far) + expect_gt(wm$n_far, 50L) + expect_identical(wm$calls, 6L) + expect_identical(w1$calls, 1L) + # One fit, one reach. + expect_length(wm$reach, 1L) + expect_equal(wm$reach, w1$reach) + expect_equal(many$value$.pred, one$value$.pred) + # A backend that raises neither class is not touched. + lm_fit <- lm_spatial_fit(d, "z", "a") + expect_length(fic_conditions(predict_surface(lm_fit, grid, chunk_size = 50L))$conds, 0L) +}) + +test_that("cv_gwr() raises each counted warning once for all its folds", { + skip_if_not_installed("sp") + d <- fic_gwr_layer(n = 160, seed = 9) + # Four strips as folds, and a fixed bandwidth that does not reach across a + # strip: every fold has held-out points no training point carries weight + # for. + x <- sf::st_coordinates(d)[, 1] + strips <- cut(x, 4, labels = FALSE) + per_fold <- fic_conditions(lapply(1:4, function(k) { + f <- suppressMessages(fit_gwr_model(d[strips != k, ], "z", "a", adaptive = FALSE, + bandwidth = 120)) + predict(f, d[strips == k, ]) + })) + n_na_folds <- sum(per_fold$classes == "spatialkit_gwr_not_estimable") + expect_gte(n_na_folds, 2L) # one warning per fold that has any + total_na <- sum(vapply(per_fold$conds[per_fold$classes == "spatialkit_gwr_not_estimable"], + function(w) w$n_na, integer(1))) + cv <- fic_conditions(cv_gwr(d, "z", "a", folds = strips, adaptive = FALSE, bandwidth = 120)) + expect_identical(sum(cv$classes == "spatialkit_gwr_not_estimable"), 1L) + w <- cv$conds[[which(cv$classes == "spatialkit_gwr_not_estimable")]] + expect_match(conditionMessage(w), "^cv_gwr\\(\\): ") + expect_identical(w$n_na, total_na) + expect_identical(w$calls, n_na_folds) + expect_identical(sum(is.na(cv$value$predictions$yhat)), total_na) + + # Adaptive folds are separate fits, each with its own reach: the total + # gives the smallest and the largest. + far <- d + sf::st_geometry(far)[strips == 4] <- sf::st_geometry(d)[strips == 4] + c(6000, 0) + sf::st_crs(far) <- 32632 + strips2 <- cut(sf::st_coordinates(far)[, 1], c(-Inf, 5e5 + 250, 5e5 + 500, 5e5 + 800, Inf), + labels = FALSE) + cv2 <- fic_conditions(cv_gwr(far, "z", "a", folds = strips2, bandwidth = 20)) + expect_identical(sum(cv2$classes == "spatialkit_gwr_extrapolation"), 1L) + w2 <- cv2$conds[[which(cv2$classes == "spatialkit_gwr_extrapolation")]] + expect_match(conditionMessage(w2), "^cv_gwr\\(\\): ") + if (w2$calls > 1L) { + expect_length(w2$reach, 2L) + expect_match(conditionMessage(w2), "each call predicted from a fit of its own") + } else expect_length(w2$reach, 1L) +}) + + +# --- 3. the GWR with no predictors -------------------------------------------- + +test_that("fit_gwr_model() with no predictors is the kernel-weighted local mean", { + skip_if_not_installed("sp") + set.seed(7); n <- 150 + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), n1 = rnorm(n)), + coords = c("x", "y"), crs = 32632) + xy <- sf::st_coordinates(d) + d$z <- 1 + sin(xy[, 1] / 300) + 2 * d$a + rnorm(n, 0, 0.3) + local_mean_at <- function(at, bw = 30, kernel = "bisquare", adaptive = TRUE) + vapply(seq_len(nrow(at)), function(i) { + dd <- sqrt((xy[, 1] - at[i, 1])^2 + (xy[, 2] - at[i, 2])^2) + w <- .gw_kernel_weights(dd, bw, kernel, adaptive = adaptive) + sum(w * d$z) / sum(w) + }, numeric(1)) + + r <- fic_conditions(fit_gwr_model(d, "z", character(0), bandwidth = 30)) + f0 <- r$value + expect_length(r$conds, 0L) + expect_s3_class(f0, "gwr_fit") + expect_identical(f0$predictor_vars, character(0)) + expect_identical(deparse(f0$formula), "z ~ 1") + expect_equal(as.numeric(fitted(f0)), local_mean_at(xy), tolerance = 1e-10) + expect_identical(names(coef(f0)), "Intercept") + expect_equal(as.numeric(coef(f0)$Intercept), as.numeric(fitted(f0)), tolerance = 1e-10) + # At new locations, with standard errors. + nd <- d[1:20, ] + sf::st_geometry(nd) <- sf::st_geometry(nd) + c(13, -7) + sf::st_crs(nd) <- 32632 + expect_equal(as.numeric(predict(f0, nd)), local_mean_at(sf::st_coordinates(nd)), + tolerance = 1e-10) + ps <- predict(f0, nd, se.fit = TRUE) + expect_true(all(is.finite(ps$se.fit)) && all(ps$se.pred > ps$se.fit)) + # A fixed Gaussian kernel, and a bandwidth the fit searches for. + fg <- suppressMessages(fit_gwr_model(d, "z", character(0), adaptive = FALSE, + bandwidth = 200, kernel = "gaussian")) + expect_equal(as.numeric(fitted(fg)), + local_mean_at(xy, bw = 200, kernel = "gaussian", adaptive = FALSE), + tolerance = 1e-10) + for (ad in c(TRUE, FALSE)) { + fs <- fic_conditions(fit_gwr_model(d, "z", character(0), adaptive = ad)) + expect_true(is.finite(fs$value$info$bandwidth)) + expect_true(is.finite(fs$value$info$AICc)) + expect_false(isTRUE(fs$value$info$bandwidth_is_fallback)) + } + # It prints, is scored, cross-validates and is compared like any GWR. + expect_output(print(f0), "Formula : z ~ 1", fixed = TRUE) + expect_true(is.finite(model_metrics(f0)$RMSE)) + cv <- suppressMessages(cv_gwr(d, "z", character(0), k = 3, bandwidth = 30)) + expect_identical(cv$n_folds_succeeded, 3L) + fa <- suppressMessages(fit_gwr_model(d, "z", "a", bandwidth = 30)) + cmp <- suppressWarnings(compare_models(list(none = f0, a = fa))) + expect_lt(cmp$AICc[cmp$model == "a"], cmp$AICc[cmp$model == "none"]) + # The map of its one coefficient is drawn, with nothing masked. + skip_if_not_installed("ggplot2") + p <- plot(f0, type = "coefficients") + expect_s3_class(p, "ggplot") + expect_match(p$labels$title, "Intercept") + # What is not a character vector is still refused by name. + expect_error(fit_gwr_model(d, "z", NULL, bandwidth = 30), + "`predictor_vars` must be a character vector") + expect_error(fit_gwr_model(d, "z", 3, bandwidth = 30), + "`predictor_vars` must be a character vector") +}) + +test_that("a GWR sweep takes the local mean as its null model, the baseline `null_fn` used to supply", { + skip_if_not_installed("sp") + set.seed(4007); n <- 120 + d <- sf::st_as_sf(data.frame(x = stats::runif(n, 0, 2000), y = stats::runif(n, 0, 2000), + a1 = stats::rnorm(n), n1 = stats::rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- d$a1 + stats::rnorm(n, 0, 0.5) + gwr_fn <- function(tr, v) fit_gwr_model(tr, "z", v, bandwidth = 30) + lines <- capture_spatialkit_log( + sel <- suppressWarnings(suppressMessages( + select_features_forward(d, "z", c("a1", "n1"), gwr_fn, k = 3, seed = 7, quiet = TRUE)))) + expect_identical(sel$baseline$type, "null model") + expect_null(sel$baseline$first) + expect_identical(sel$history$variable[1], "") + expect_true("a1" %in% sel$selected) + expect_false(log_has(lines, "the baseline is the training-fold mean")) + # Step 0 is the local mean under the sweep's kernel, on the sweep's folds. + fo <- suppressWarnings(suppressMessages( + make_folds(d, k = 3, method = "block_kfold", seed = 7, response_var = "z", + predictor_vars = c("a1", "n1")))) + e <- unlist(lapply(fo$folds, function(sp) { + tr <- d[sp$train, ]; te <- d[sp$test, ] + txy <- sf::st_coordinates(tr); at <- sf::st_coordinates(te) + te$z - vapply(seq_len(nrow(at)), function(i) { + dd <- sqrt((txy[, 1] - at[i, 1])^2 + (txy[, 2] - at[i, 2])^2) + w <- .gw_kernel_weights(dd, 30, "bisquare", adaptive = TRUE) + sum(w * tr$z) / sum(w) + }, numeric(1)) + })) + expect_equal(sel$baseline$score, sqrt(mean(e^2)), tolerance = 1e-8) + # A learner that refuses the empty set still falls back to the fold mean, + # and the caution says how to get the local mean. + refusing <- function(tr, v) { + if (!length(v)) stop("needs a predictor", call. = FALSE) + fit_gwr_model(tr, "z", v, bandwidth = 30) + } + lines2 <- capture_spatialkit_log( + sel2 <- suppressWarnings(suppressMessages( + select_features_forward(d, "z", c("a1", "n1"), refusing, k = 3, seed = 7, quiet = TRUE)))) + expect_identical(sel2$baseline$type, "fold mean") + expect_true(log_has(lines2, "pass character\\(0\\) on to fit_gwr_model\\(\\)")) +}) + + +# --- 4. model_metrics() and predict() arguments that change the shape --------- + +test_that("model_metrics() refuses draws = TRUE and se.fit = TRUE by name", { + d <- surf_test_points(80) + fit <- lm_spatial_fit(d, "z", "w") + expect_error(model_metrics(fit, newdata = d, draws = TRUE), + "model_metrics\\(\\): `draws = TRUE` cannot be passed through `...`.*matrix of posterior draws") + expect_error(model_metrics(fit, newdata = d, se.fit = TRUE), + "model_metrics\\(\\): `se.fit = TRUE` cannot be passed.*list with the standard errors") + # FALSE asks for the default shape and is passed on. + expect_equal(model_metrics(fit, newdata = d, draws = FALSE)$RMSE, + model_metrics(fit, newdata = d)$RMSE) + skip_if_not_installed("sp") + g <- suppressMessages(fit_gwr_model(fic_gwr_layer(), "z", "a", bandwidth = 30)) + expect_error(model_metrics(g, newdata = fic_gwr_layer(), se.fit = TRUE), + "`se.fit = TRUE` cannot be passed") +}) + + +# --- 5. kNNDM folds are named -------------------------------------------------- + +test_that("kNNDM folds get their own label in plot_folds() and print.kriging_adequacy()", { + s <- fic_layer() + grid <- sf::st_as_sf(expand.grid(x = 5e5 + seq(50, 950, by = 100), + y = 5e6 + seq(50, 950, by = 100)), + coords = c("x", "y"), crs = 32632) + f <- suppressWarnings(suppressMessages( + make_folds(s$pts, k = 3, method = "knndm", prediction_points = grid, seed = 1))) + expect_identical(f$method, "knndm") + expect_match(.fold_subtitle(f), "kNNDM") + expect_null(.fold_subtitle(list(method = "something else", params = list()))) + skip_if_not_installed("gstat") + ok <- estimate_sac_range(s$pts, "z") + ka <- suppressWarnings(suppressMessages( + kriging_adequacy(s$asg, "z", s$cells, sac = ok, folds = f))) + expect_output(print(ka), "kNNDM k-fold CV (knndm, 3 folds", fixed = TRUE) + skip_if_not_installed("ggplot2") + expect_match(plot_folds(f, s$pts)$labels$subtitle, "kNNDM") +}) + + +# --- 6. the projection chosen for a lon/lat layer does not depend on row order - + +test_that("ensure_projected() and make_folds(auto_range = TRUE) give one answer in any row order", { + skip_if_not_installed("gstat") + # 400 points over the conterminous United States, a field of effective + # range 600 km (the layer of test-fix-variogram-invariance.R). The + # candidates for a lon/lat layer were scored on rows taken at even spacing + # down the layer: as generated it got a Lambert azimuthal CRS, in four of + # six other row orders an Albers one, and make_folds(), which projects the + # layer before the range is estimated, sized its blocks at 505,530 or + # 506,838 accordingly. + set.seed(14); n <- 400 + lon <- runif(n, -120, -70); lat <- runif(n, 25, 50) + ll <- sf::st_as_sf(data.frame(lon, lat), coords = c("lon", "lat"), crs = 4326) + xy <- sf::st_coordinates(sf::st_transform(ll, 5070)) + ll$z <- as.numeric(crossprod(chol(0.8 * exp(-3 * as.matrix(stats::dist(xy)) / 600e3) + + diag(0.2, n)), rnorm(n))) + quiet <- function(expr) suppressWarnings(suppressMessages(expr)) + crs0 <- sf::st_crs(quiet(ensure_projected(ll))) + f0 <- quiet(make_folds(ll, k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1)) + expect_true(is.finite(f0$params$sac_range)) + for (s in 1:6) { + set.seed(s); p <- sample(n) + expect_true(sf::st_crs(quiet(ensure_projected(ll[p, ]))) == crs0, info = paste("order", s)) + f <- quiet(make_folds(ll[p, ], k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1)) + expect_identical(as.numeric(f$params$sac_range), as.numeric(f0$params$sac_range), + info = paste("order", s)) + expect_identical(f$params$crs, f0$params$crs, info = paste("order", s)) + } + # The score itself: the same number for the same points in any order. + set.seed(3); p <- sample(n) + expect_identical(.crs_distance_error(ll[p, ], sf::st_crs(5070)), + .crs_distance_error(ll, sf::st_crs(5070))) +}) diff --git a/tests/testthat/test-fix-integration-repeats.R b/tests/testthat/test-fix-integration-repeats.R new file mode 100644 index 00000000..50e8a83a --- /dev/null +++ b/tests/testthat/test-fix-integration-repeats.R @@ -0,0 +1,504 @@ +# tests/testthat/test-fix-integration-repeats.R +# --------------------------------------------------------------------------- +# One warning for one fact, when a function runs the same step many times. +# +# 1. predict() on a GWR counts, per call, the locations it cannot estimate +# and those beyond the reach of the fit. cv_spatial() with a GWR learner +# raises each once with totals, as cv_gwr() does, and +# cv_block_size_sweep() and select_features_forward(), which run many +# cross-validations, raise each once for the sweep. +# 2. A parallel run hands the package's own classed warnings back with their +# class and fields. +# 3. prep_model_data()'s warnings about a layer are raised once by a function +# that prepares it several times (compare_models_cv(), +# cv_block_size_sweep()). +# 4. cv_bayes(), and cv_spatial() with a Bayesian learner, raise the fit's +# classed warnings once per class, naming the folds. +# 5. resolution_profile() does not call a pure-nugget variogram unusable. +# --------------------------------------------------------------------------- + +fir_conditions <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }, message = function(m) invokeRestart("muffleMessage")) + list(value = val, conds = w, + messages = vapply(w, conditionMessage, character(1)), + classes = vapply(w, function(c) class(c)[1L], character(1))) +} +fir_one <- function(r, class) r$conds[[which(r$classes == class)]] + +fir_gwr_layer <- function(n = 160, seed = 9) { + set.seed(seed) + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + d +} + +# The lm stand-in with the classes of a learner whose predict() raises the +# GWR's count of locations it cannot estimate: one location per call, the +# same text in every fold of equal size. +fir_counting_fit <- function(train_sf) { + f <- lm_spatial_fit(train_sf, "z", "w") + class(f) <- c("fir_counting_fit", class(f)) + f +} +predict.fir_counting_fit <- function(object, newdata = NULL, ...) { + out <- NextMethod() + n <- length(out) + .gwr_warn("spatialkit_gwr_not_estimable", "%s", + .gwr_not_estimable_msg("predict.gwr_fit", 1L, n, 1L, "fixed bandwidth (5)"), + data = list(n_na = 1L, n = n, n_empty = 1L, + bw_text = "fixed bandwidth (5)", calls = 1L), + tallied = TRUE) + out +} +registerS3method("predict", "fir_counting_fit", predict.fir_counting_fit) + + +# --- 1. the GWR's counted warnings through the generic loops ------------------- + +test_that("cv_spatial() raises a GWR learner's counted warnings once, with cv_gwr()'s totals", { + skip_if_not_installed("sp") + d <- fir_gwr_layer() + # Four strips as folds and a fixed bandwidth that does not reach across a + # strip: several folds hold locations no training point carries weight for. + strips <- cut(sf::st_coordinates(d)[, 1], 4, labels = FALSE) + fixed <- function(tr) fit_gwr_model(tr, "z", "a", adaptive = FALSE, bandwidth = 120) + lines <- capture_spatialkit_log( + cs <- fir_conditions(cv_spatial(d, "z", "a", fit_fn = fixed, folds = strips)), + level = logger::WARN) + cg <- fir_conditions(cv_gwr(d, "z", "a", folds = strips, adaptive = FALSE, bandwidth = 120)) + expect_identical(sum(cs$classes == "spatialkit_gwr_not_estimable"), 1L) + expect_identical(sum(cs$classes == "spatialkit_gwr_extrapolation"), 0L) + ws <- fir_one(cs, "spatialkit_gwr_not_estimable") + wg <- fir_one(cg, "spatialkit_gwr_not_estimable") + expect_match(conditionMessage(ws), "^cv_spatial\\(\\): ") + expect_gte(ws$calls, 2L) # more than one fold had any + expect_identical(ws$n_na, wg$n_na) + expect_identical(ws$n, wg$n) + expect_identical(ws$calls, wg$calls) + expect_identical(sum(is.na(cs$value$predictions$yhat)), ws$n_na) + expect_equal(cs$value$overall$RMSE, cg$value$overall$RMSE) + # Logged once, as the total, and not once per fold. + expect_identical(sum(grepl("no estimable local", lines, fixed = TRUE)), 1L) + expect_true(log_has(lines, "cv_spatial\\(\\): [0-9]+ of [0-9]+ location")) + + # Adaptive folds reach as far as their kernels: a strip moved away is + # beyond every training point's reach. + far <- d + sf::st_geometry(far)[strips == 4] <- sf::st_geometry(d)[strips == 4] + c(6000, 0) + sf::st_crs(far) <- 32632 + strips2 <- cut(sf::st_coordinates(far)[, 1], c(-Inf, 5e5 + 250, 5e5 + 500, 5e5 + 800, Inf), + labels = FALSE) + adaptive <- function(tr) fit_gwr_model(tr, "z", "a", bandwidth = 20) + cs2 <- fir_conditions(cv_spatial(far, "z", "a", fit_fn = adaptive, folds = strips2)) + cg2 <- fir_conditions(cv_gwr(far, "z", "a", folds = strips2, bandwidth = 20)) + expect_identical(sum(cs2$classes == "spatialkit_gwr_extrapolation"), 1L) + w2 <- fir_one(cs2, "spatialkit_gwr_extrapolation") + expect_match(conditionMessage(w2), "^cv_spatial\\(\\): ") + expect_identical(w2$n_far, fir_one(cg2, "spatialkit_gwr_extrapolation")$n_far) + expect_gt(w2$n_far, 0L) + + # A learner that raises neither class is not touched. + expect_length(fir_conditions(cv_spatial(d, "z", "a", folds = strips, + fit_fn = function(tr) lm_spatial_fit(tr, "z", "a")))$conds, + 0L) +}) + +test_that("cv_block_size_sweep() and select_features_forward() raise them once for the sweep", { + skip_if_not_installed("sp") + d <- fir_gwr_layer(n = 200, seed = 21) + fixed <- function(tr) fit_gwr_model(tr, "z", "a", adaptive = FALSE, bandwidth = 90) + # Each cross-validation of the sweep on its own: one warning per size. + lines <- capture_spatialkit_log( + sw <- fir_conditions(cv_block_size_sweep(d, "z", "a", fit_fn = fixed, k = 3, + block_sizes = c(250, 330), sac = 100, + quiet = TRUE)), + level = logger::WARN) + na_by_cv <- vapply(attr(sw$value, "results"), + function(r) sum(is.na(r$predictions$yhat)), integer(1)) + skip_if(sum(na_by_cv > 0L) < 2L, "fewer than two of the cross-validations had an NA here") + expect_identical(sum(sw$classes == "spatialkit_gwr_not_estimable"), 1L) + w <- fir_one(sw, "spatialkit_gwr_not_estimable") + expect_match(conditionMessage(w), "^cv_block_size_sweep\\(\\): ") + expect_identical(w$n_na, sum(na_by_cv)) + expect_match(conditionMessage(w), + "a location predicted by several fits is counted once for each", fixed = TRUE) + expect_identical(sum(grepl("no estimable local", lines, fixed = TRUE)), 1L) + + # The selection sweep: every candidate set is cross-validated on the same + # folds, and each cross-validation had its own warning. + sel_fn <- function(tr, v) fit_gwr_model(tr, "z", v, adaptive = FALSE, bandwidth = 90) + lines2 <- capture_spatialkit_log( + fs <- fir_conditions(select_features_forward(d, "z", c("a", "b"), sel_fn, k = 3, + seed = 7, quiet = TRUE)), + level = logger::WARN) + expect_identical(sum(fs$classes == "spatialkit_gwr_not_estimable"), 1L) + wf <- fir_one(fs, "spatialkit_gwr_not_estimable") + expect_match(conditionMessage(wf), "^select_features_forward\\(\\): ") + expect_match(conditionMessage(wf), + "a location predicted by several fits is counted once for each", fixed = TRUE) + expect_gt(wf$calls, 1L) + expect_identical(sum(grepl("no estimable local", lines2, fixed = TRUE)), 1L) + expect_s3_class(fs$value, "feature_selection") + # The collector is closed again: a later predict() warns under its own name. + expect_identical(.gwr_predict_state$tally %||% 0L, 0L) +}) + +test_that("a total over fits with different bandwidths names no single bandwidth", { + raise <- function(bw) .gwr_warn( + "spatialkit_gwr_not_estimable", "%s", + .gwr_not_estimable_msg("predict.gwr_fit", 2L, 10L, 2L, bw), + data = list(n_na = 2L, n = 10L, n_empty = 2L, bw_text = bw, calls = 1L), + tallied = TRUE) + same <- fir_conditions(.gwr_tally_predict_warnings( + { raise("fixed bandwidth (50)"); raise("fixed bandwidth (50)") }, caller = "f")) + expect_length(same$conds, 1L) + expect_identical(same$conds[[1]]$n_na, 4L) + expect_match(same$messages, "within the fixed bandwidth (50).", fixed = TRUE) + expect_false(grepl("counted once for each", same$messages, fixed = TRUE)) + differ <- fir_conditions(.gwr_tally_predict_warnings( + { raise("fixed bandwidth (50)"); raise("fixed bandwidth (80)") }, caller = "f")) + expect_match(differ$messages, + "within the bandwidth of the fit that predicted it (the fits' bandwidths differ).", + fixed = TRUE) + # Nested: the inner total goes to the outer collector alone. + nested <- fir_conditions(.gwr_tally_predict_warnings({ + .gwr_tally_predict_warnings(raise("fixed bandwidth (50)"), caller = "inner") + .gwr_tally_predict_warnings({ raise("fixed bandwidth (50)"); raise("fixed bandwidth (50)") }, + caller = "inner") + }, caller = "outer", refits = TRUE)) + expect_length(nested$conds, 1L) + expect_match(nested$messages, "^outer\\(\\): 6 of 30 location") + expect_identical(nested$conds[[1]]$calls, 3L) + expect_match(nested$messages, + "(totals over the 3 prediction calls that found any; a location predicted by several fits is counted once for each)", + fixed = TRUE) +}) + + +# --- 2. classed warnings across a fork ----------------------------------------- + +test_that("a parallel run hands the package's classed warnings back as they were raised", { + d <- surf_test_points(80, seed = 5) + f <- make_folds(d, k = 4, method = "random_kfold", seed = 1) + # Sequential: four folds, one location each, the same text in every fold. + sq <- fir_conditions(cv_spatial(d, "z", "w", fit_fn = fir_counting_fit, folds = f, seed = 1)) + expect_identical(sq$classes, "spatialkit_gwr_not_estimable") + expect_identical(sq$conds[[1]]$n_na, 4L) + expect_identical(sq$conds[[1]]$calls, 4L) + + skip_on_cran() + skip_on_os("windows") + skip_if(.resolve_n_cores(2L) < 2L, "single-core machine") + noting_fit <- function(tr) { + .warn_classed("spatialkit_fir_note", "the same note from every fold", data = list(k = 7L)) + fir_counting_fit(tr) + } + lines <- capture_spatialkit_log( + pl <- fir_conditions(cv_spatial(d, "z", "w", fit_fn = noting_fit, folds = f, seed = 1, + parallel = 2L)), + level = logger::WARN) + # The counted warning: every fold's count arrives, though the four texts + # are identical, and the total is the sequential one. + expect_identical(sum(pl$classes == "spatialkit_gwr_not_estimable"), 1L) + wp <- fir_one(pl, "spatialkit_gwr_not_estimable") + expect_identical(wp$n_na, 4L) + expect_identical(wp$calls, 4L) + expect_identical(conditionMessage(wp), conditionMessage(sq$conds[[1]])) + expect_identical(sum(grepl("no estimable local", lines, fixed = TRUE)), 1L) + # Another classed warning: once per distinct text, class and fields kept, + # and marked with the fold that raised it first. + expect_identical(sum(pl$classes == "spatialkit_fir_note"), 1L) + wn <- fir_one(pl, "spatialkit_fir_note") + expect_identical(wn$k, 7L) + expect_true(wn$fold %in% 1:4) + expect_equal(pl$value$overall$RMSE, sq$value$overall$RMSE) +}) + + +# --- 3. the layer's warnings, once per run ------------------------------------- + +fir_holed_layer <- function(n = 150, seed = 31) { + set.seed(seed) + d <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), c0 = 3), + coords = c("x", "y"), crs = 32632) + d$z <- 1 + 2 * d$a + rnorm(n, 0, 0.3) + d$z[c(5, 60)] <- NA + d$a[c(17, 100, 101)] <- NA + d +} + +test_that("cv_block_size_sweep() raises the layer's warnings once, not once per size", { + d <- fir_holed_layer() + lm_fn <- function(tr) lm_spatial_fit(tr, "z", "a") + # One cross-validation raises each once. + one <- fir_conditions(cv_spatial(d, "z", c("a", "c0"), fit_fn = lm_fn, k = 3, seed = 1)) + expect_identical(sum(one$classes == "spatialkit_rows_dropped"), 1L) + expect_identical(sum(one$classes == "spatialkit_constant_predictor"), 1L) + # The sweep prepares the layer for its ladder and once per size, and the + # random-fold reference: four preparations here. + lines <- capture_spatialkit_log( + sw <- fir_conditions(cv_block_size_sweep(d, "z", c("a", "c0"), fit_fn = lm_fn, k = 3, + block_sizes = c(200, 300), sac = 100, + quiet = TRUE)), + level = logger::WARN) + expect_identical(nrow(sw$value), 3L) + expect_identical(sum(sw$classes == "spatialkit_rows_dropped"), 1L) + expect_identical(sum(sw$classes == "spatialkit_constant_predictor"), 1L) + expect_identical(fir_one(sw, "spatialkit_rows_dropped")$message, + fir_one(one, "spatialkit_rows_dropped")$message) + expect_match(fir_one(sw, "spatialkit_rows_dropped")$message, "dropped 5 of 150 row(s)", + fixed = TRUE) + expect_identical(sum(grepl("dropped 5 of 150", lines, fixed = TRUE)), 1L) + expect_identical(sum(grepl("take a single value", lines, fixed = TRUE)), 1L) + # Every cross-validation still records the rows it dropped. + expect_true(all(vapply(attr(sw$value, "results"), function(r) r$n_dropped, integer(1)) == 5L)) + + # The run is closed when the function returns, and when it stops: the next + # call warns again. + expect_null(.once_state$run) + expect_error(suppressWarnings( + cv_block_size_sweep(d, "z", c("a", "c0"), fit_fn = lm_fn, k = 3, + block_sizes = c(200, 300), max_fits = 1, quiet = TRUE)), + "above the budget") + expect_null(.once_state$run) + again <- fir_conditions(cv_spatial(d, "z", c("a", "c0"), fit_fn = lm_fn, k = 3, seed = 1)) + expect_identical(sum(again$classes == "spatialkit_rows_dropped"), 1L) +}) + +test_that("compare_models_cv() raises the layer's warnings once, not once per model", { + skip_if_not_installed("sp") + skip_if_not_installed("ranger") + d <- fir_holed_layer() + lines <- capture_spatialkit_log( + cmp <- fir_conditions(compare_models_cv(d, "z", "a", models = c("RF", "GWR"), k = 3, + quiet = TRUE, + rf_args = list(num_trees = 30, num_threads = 1), + gwr_args = list(bandwidth = 30))), + level = logger::WARN) + expect_identical(sum(cmp$classes == "spatialkit_rows_dropped"), 1L) + expect_identical(sum(grepl("dropped 5 of 150", lines, fixed = TRUE)), 1L) + expect_identical(sort(cmp$value$overall$model), c("GWR", "RF")) + expect_identical(cmp$value$gwr_cv$n_dropped, 5L) + expect_identical(cmp$value$rf_cv$n_dropped, 5L) + expect_null(.once_state$run) +}) + +test_that("select_features_forward() reports a constant candidate once, not once per set", { + d <- fir_holed_layer() + d$b <- rnorm(nrow(d)) + # `c0` is in one set at every step: {c0}, then {a, c0}, then {a, b, c0}. + fit_fn <- function(tr, v) lm_spatial_fit(tr, "z", setdiff(v, "c0")) + lines <- capture_spatialkit_log( + fs <- fir_conditions(select_features_forward(d, "z", c("a", "b", "c0"), fit_fn, k = 3, + seed = 3, quiet = TRUE)), + level = logger::WARN) + expect_gte(sum(grepl("c0", fs$value$history$variable, fixed = TRUE)), 2L) + expect_identical(sum(fs$classes == "spatialkit_constant_predictor"), 1L) + expect_identical(sum(grepl("take a single value", lines, fixed = TRUE)), 1L) + expect_null(.once_state$run) +}) + +test_that("a run raises a text once, another text as usual, and nests", { + said <- function() .warn_classed("spatialkit_fir_once", "said %d", 1L) + expect_length(fir_conditions({ said(); said() })$conds, 2L) # no run open + r <- fir_conditions({ + end <- .once_per_run("spatialkit_fir_once") + said(); said() + .warn_classed("spatialkit_fir_once", "said %d", 2L) # other text + .warn_classed("spatialkit_fir_other", "said %d", 1L) # other class, + .warn_classed("spatialkit_fir_other", "said %d", 1L) # not covered + inner_end <- .once_per_run("spatialkit_fir_other") # a run inside + said() + .warn_classed("spatialkit_fir_other", "said %d", 3L) + .warn_classed("spatialkit_fir_other", "said %d", 3L) + inner_end() + said() # still said + .warn_classed("spatialkit_fir_other", "said %d", 3L) # outer run again + end() + }) + expect_identical(r$messages, c("said 1", "said 2", "said 1", "said 1", "said 3", "said 3")) + expect_null(.once_state$run) + expect_length(fir_conditions(said())$conds, 1L) +}) + + +# --- 4. a Bayesian fit's warnings, once per class and by fold ------------------- + +fir_bayes_pts <- function(n = 60, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 5 + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +# The lm stand-in for fit_bayesian_spatial_model(), raising what the real +# fitter raises: fold 1 and 3 a range below the basis, fold 2 a sampler that +# did not converge, fold 3 a basis too coarse and too large for its rows. +# Which fold is running is read as the collector reads it. +fir_fake_bayes <- function(data_sf, response_var, predictor_vars, ..., seed = 123) { + i <- as.integer(.cv_fold_state$fold) + f <- lm_spatial_fit(data_sf, "z", "w") + f$info$convergence_ok <- i != 2L + f$info$gp_adequacy <- list(status = if (i == 3L) "below_resolution" else "ok") + if (i == 3L) + .warn_classed("spatialkit_gp_basis_size", + "fit_bayesian_spatial_model(): 40 row(s) against 900 basis functions.") + if (i %in% c(1L, 3L)) + .warn_classed("spatialkit_gp_resolution", + "fit_bayesian_spatial_model(): a variogram fitted before sampling puts the range at %d metre.", + 100L + i) + if (i == 2L) + .warn_classed("spatialkit_convergence", + "fit_bayesian_spatial_model(): the sampler's diagnostics fail: 3 divergent transition(s).", + data = list(failed = c("divergent", "ess"))) + if (i == 3L) + .warn_classed("spatialkit_gp_adequacy", + "fit_bayesian_spatial_model(): 23%% of the length-scale draws fall below the floor.") + f +} + +fir_expect_fold_warnings <- function(r, caller) { + classes <- c("spatialkit_convergence", "spatialkit_gp_basis_size", + "spatialkit_gp_resolution", "spatialkit_gp_adequacy") + # One per class, and nothing else. + expect_identical(sort(r$classes), sort(classes)) + expect_true(all(startsWith(r$messages, paste0(caller, "(): ")))) + conv <- fir_one(r, "spatialkit_convergence") + expect_match(conditionMessage(conv), "did not converge in 1 of 3 fold(s) (fold 2)", fixed = TRUE) + expect_match(conditionMessage(conv), + "The checks that failed: fold 2: divergent transitions, effective sample size.", + fixed = TRUE) + expect_match(conditionMessage(conv), "adapt_delta", fixed = TRUE) + expect_false(grepl("E-BFMI", conditionMessage(conv), fixed = TRUE)) + expect_identical(conv$folds, 2L) + expect_identical(conv$failed, list(`2` = c("divergent", "ess"))) + res <- fir_one(r, "spatialkit_gp_resolution") + expect_match(conditionMessage(res), "in 2 of 3 fold(s) (fold 1, 3)", fixed = TRUE) + expect_match(conditionMessage(res), + "Fold 1: a variogram fitted before sampling puts the range at 101 metre.", + fixed = TRUE) + expect_identical(res$folds, c(1L, 3L)) + expect_identical(names(res$fold_messages), c("1", "3")) + expect_match(res$fold_messages[["3"]], "at 103 metre", fixed = TRUE) + adq <- fir_one(r, "spatialkit_gp_adequacy") + expect_match(conditionMessage(adq), "in 1 of 3 fold(s) (fold 3)", fixed = TRUE) + expect_match(conditionMessage(adq), "Fold 3: 23% of the length-scale draws", fixed = TRUE) + big <- fir_one(r, "spatialkit_gp_basis_size") + expect_match(conditionMessage(big), "in 1 of 3 fold(s) (fold 3)", fixed = TRUE) + expect_identical(big$folds, 3L) +} + +test_that("cv_bayes() raises a fit's classed warnings once per class, naming the folds", { + d <- fir_bayes_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + local_mocked_bindings(fit_bayesian_spatial_model = fir_fake_bayes, .package = "spatialkit") + lines <- capture_spatialkit_log( + r <- fir_conditions(cv_bayes(d, "z", "w", folds = f, seed = 1)), + level = logger::WARN) + fir_expect_fold_warnings(r, "cv_bayes") + expect_match(conditionMessage(fir_one(r, "spatialkit_convergence")), + "fold_metrics$convergence_ok marks them", fixed = TRUE) + expect_match(conditionMessage(fir_one(r, "spatialkit_gp_adequacy")), + "fold_metrics$gp_adequacy has each fold's status", fixed = TRUE) + expect_identical(r$value$fold_metrics$convergence_ok, c(TRUE, FALSE, TRUE)) + # Each fold's own line is still in the log, beside the four totals. + expect_identical(sum(grepl("^.*fit_bayesian_spatial_model\\(\\): a variogram fitted", lines)), 2L) + expect_identical(sum(grepl("fit_bayesian_spatial_model(): the sampler's diagnostics fail", + lines, fixed = TRUE)), 1L) + expect_identical(sum(grepl("cv_bayes(): ", lines, fixed = TRUE)), 4L) + # It can still be caught by class. + expect_identical( + tryCatch(suppressMessages(cv_bayes(d, "z", "w", folds = f, seed = 1)), + spatialkit_convergence = function(c) "caught"), + "caught") +}) + +test_that("cv_spatial() does the same for a learner that fits the Bayesian model", { + d <- fir_bayes_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + local_mocked_bindings(fit_bayesian_spatial_model = fir_fake_bayes, .package = "spatialkit") + learner <- function(tr) fit_bayesian_spatial_model(tr, "z", "w") + r <- fir_conditions(cv_spatial(d, "z", "w", fit_fn = learner, folds = f, seed = 1)) + fir_expect_fold_warnings(r, "cv_spatial") + # No fold_metrics column to point at here. + expect_false(any(grepl("fold_metrics$", r$messages, fixed = TRUE))) + expect_match(conditionMessage(fir_one(r, "spatialkit_convergence")), + "in the learner's call", fixed = TRUE) + # A fold that did not converge and then failed to predict was not scored, + # so the convergence warning, which is about scores, leaves it out. + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, ...) { + ft <- fir_fake_bayes(data_sf) + if (identical(as.integer(.cv_fold_state$fold), 2L)) class(ft) <- c("fir_no_predict", "spatial_fit") + ft + }, .package = "spatialkit") + r2 <- fir_conditions(cv_spatial(d, "z", "w", fit_fn = learner, folds = f, seed = 1)) + expect_false("spatialkit_convergence" %in% r2$classes) + expect_identical(r2$value$fold_status$status, c("ok", "error", "ok")) + expect_true(any(grepl("1 of 3 fold(s) failed", r2$messages, fixed = TRUE))) + + # Forked folds: the same four, with the folds named. + skip_on_cran() + skip_on_os("windows") + skip_if(.resolve_n_cores(2L) < 2L, "single-core machine") + local_mocked_bindings(fit_bayesian_spatial_model = fir_fake_bayes, .package = "spatialkit") + rp <- fir_conditions(cv_spatial(d, "z", "w", fit_fn = learner, folds = f, seed = 1, + parallel = 2L)) + fir_expect_fold_warnings(rp, "cv_spatial") +}) + +test_that("a convergence summary without the folds' own warnings keeps the general advice", { + d <- fir_bayes_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, ...) { + ft <- lm_spatial_fit(data_sf, "z", "w") + ft$info$convergence_ok <- !identical(as.integer(.cv_fold_state$fold), 3L) + ft + }, .package = "spatialkit") + r <- fir_conditions(cv_bayes(d, "z", "w", folds = f, seed = 1)) + expect_identical(r$classes, "spatialkit_convergence") + expect_match(r$messages, "did not converge in 1 of 3 fold(s) (fold 3)", fixed = TRUE) + expect_match(r$messages, "The log says which checks failed", fixed = TRUE) + expect_identical(r$conds[[1]]$folds, 3L) +}) + + +# --- 5. a pure-nugget variogram is not "no usable model" ----------------------- + +test_that("resolution_profile() says what a no-structure variogram lacks", { + skip_if_not_installed("gstat") + set.seed(4401); n <- 240 + pts <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + noise = rnorm(n)), coords = c("x", "y"), crs = 32632) + no <- suppressWarnings(estimate_sac_range(pts, "noise")) + skip_if_not(.sac_no_structure(no), "the structure test did not refuse this draw") + expect_true(.vgm_is_pure_nugget(attr(no, "variogram_model"))) + for (sac in list(no, NULL)) { + lines <- capture_spatialkit_log( + r <- fir_conditions(resolution_profile(pts, "noise", sac = sac, n_levels = 4, nstart = 2))) + expect_identical(attr(r$value, "cp_noise")$source, "finest-level residual mean square") + hit <- grepl("so `cp` takes its noise variance from the residual mean square", r$messages, + fixed = TRUE) + expect_identical(sum(hit), 1L) + expect_match(r$messages[hit], + "found no spatial structure and gives no nugget that can be told from the sill, so `cp`", + fixed = TRUE) + # The model is the pure nugget the log line names, and it is used + # elsewhere: nothing calls it unusable. + expect_false(any(grepl("no usable variogram model", r$messages, fixed = TRUE))) + expect_true(log_has(lines, "found no spatial structure .*its model is a pure nugget")) + } + expect_match(fir_conditions(resolution_profile(pts, "noise", sac = no, n_levels = 4, + nstart = 2))$messages[1], + "^resolution_profile\\(\\): `sac` found no spatial structure") +}) diff --git a/tests/testthat/test-fix-resolution-bound-warning.R b/tests/testthat/test-fix-resolution-bound-warning.R new file mode 100644 index 00000000..9fc03169 --- /dev/null +++ b/tests/testthat/test-fix-resolution-bound-warning.R @@ -0,0 +1,128 @@ +# tests/testthat/test-fix-resolution-bound-warning.R +# --------------------------------------------------------------------------- +# A count that a bound of the ladder chose reaches the caller of the +# tessellation functions as an R warning with a class, and so does +# `supported = FALSE`. Both were log lines and a free-text attribute: +# tryCatch(), withCallingHandlers() and options(warn = 2) saw nothing. +# --------------------------------------------------------------------------- + +fbw_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(suppressMessages(expr), warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} +# A smooth trend with little noise: Cp keeps falling to the support ceiling. +fbw_pts <- function(n = 300, seed = 1) { + set.seed(seed) + d <- data.frame(x = 5e5 + runif(n, 0, 3000), y = 5e6 + runif(n, 0, 2000)) + d$z <- sin((d$x - 5e5) / 400) + rnorm(n, 0, 0.3) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} +fbw_bnd <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(5e5, 5e6), c(5e5 + 3000, 5e6), c(5e5 + 3000, 5e6 + 2000), c(5e5, 5e6 + 2000), + c(5e5, 5e6)))), crs = 32632)) +fbw_bound <- function(out) + out$warnings[vapply(out$warnings, inherits, logical(1), "spatialkit_bound_chosen")] + + +test_that("an optimum at the support ceiling is a classed warning in every function that takes the count", { + d <- fbw_pts() + p <- fbw_catch(resolution_profile(d, "z", sac = 400, n_levels = 6, nstart = 5, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + sel <- select_resolution(p, "cp") + expect_true(sel$at_ceiling) + expect_identical(sel$edge, "the support ceiling (n / min_cell_n)") + + calls <- list( + function(x) get_voronoi_seeds(method = "kmeans", n = x, sample_points = d, + partition = "kmeans"), + function(x) voronoi_seeds_kmeans(d, k = x, partition = "kmeans"), + function(x) build_tessellation(d, boundary = fbw_bnd, method = "hex", + approx_n_cells = x, quiet = TRUE)) + for (f in calls) for (x in list(sel, p)) { + out <- fbw_catch(f(x)) + w <- fbw_bound(out) + expect_length(w, 1L) + expect_identical(w[[1L]]$edge, sel$edge) + expect_identical(w[[1L]]$criterion, "cp") + expect_identical(w[[1L]]$n, sel$best) + expect_match(conditionMessage(w[[1L]]), + sprintf("is %d cells, the optimum of `cp`, and that optimum is the support ceiling", + sel$best)) + expect_match(conditionMessage(w[[1L]]), "the bound chose the count, not the criterion") + expect_match(conditionMessage(w[[1L]]), "Lower min_cell_n") + } + # Caught by class, and an error under warn = 2 semantics. + expect_identical(tryCatch(voronoi_seeds_kmeans(d, k = sel, partition = "kmeans"), + spatialkit_bound_chosen = function(w) "caught"), "caught") + expect_error(withCallingHandlers( + get_voronoi_seeds(method = "kmeans", n = sel, sample_points = d, partition = "kmeans"), + warning = function(w) stop("escalated: ", class(w)[1L])), + "escalated: spatialkit_bound_chosen") + # What chose the count rides on the resolved value as fields, too. + r <- suppressWarnings(spatialkit:::.resolve_cell_count(sel, "n", "f")) + expect_identical(r$edge, sel$edge) + expect_identical(r$criterion, "cp") + expect_true(r$at_ceiling) +}) + +test_that("an interior optimum, a plain number and a ranked vector raise no such warning", { + d <- fbw_pts() + p <- fbw_catch(resolution_profile(d, "z", sac = 400, n_levels = 6, nstart = 5))$value + # An interior optimum, made by hand: the third level of the ladder. + mid <- p + mid$cp <- abs(seq_along(mid$levels) - 3) + 1 + sel <- select_resolution(mid, "cp") + expect_identical(sel$best, mid$levels[3L]) + expect_true(is.na(sel$edge)) + for (x in list(sel, 12, c(9L, 12L, 6L))) { + out <- fbw_catch(get_voronoi_seeds(method = "kmeans", n = x, sample_points = d, + set_seed = 1)) + expect_length(fbw_bound(out), 0L) + } +}) + +test_that("a reliability pick at the range floor is a bound choosing, and is said", { + d <- fbw_pts(400) + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.3, 0.7), range = c(0, 200), + stringsAsFactors = FALSE) + sac <- structure(600, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(32632)) + p <- fbw_catch(resolution_profile(d, "z", sac = sac, n_levels = 8, nstart = 3))$value + rel <- select_resolution(p, "reliability") + expect_true(rel$at_floor) + out <- fbw_catch(get_voronoi_seeds(method = "kmeans", n = rel, sample_points = d)) + w <- fbw_bound(out) + expect_length(w, 1L) + expect_match(conditionMessage(w[[1L]]), "range floor") + expect_match(conditionMessage(w[[1L]]), "Fewer cells would be wider than the range") +}) + +test_that("supported = FALSE is a classed warning, not a log line alone", { + set.seed(2) + n <- 60 + d <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + # A range of 120 on a square kilometre needs about 60 cells; 60 points at + # nine a cell support 6. + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.2, 1), range = c(0, 40), + stringsAsFactors = FALSE) + sac <- structure(120, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) + lines <- capture_spatialkit_log( + out <- fbw_catch(resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2))) + expect_false(attr(out$value, "bounds")$supported) + w <- out$warnings[vapply(out$warnings, inherits, logical(1), "spatialkit_not_supported")] + expect_length(w, 1L) + expect_match(conditionMessage(w[[1L]]), "cannot support a tessellation") + expect_identical(w[[1L]]$reason, "floor above ceiling") + # Still logged, once. + expect_identical(sum(grepl("cannot support a tessellation", lines)), 1L) + expect_identical(tryCatch(resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2), + spatialkit_not_supported = function(w) "caught"), "caught") +}) diff --git a/tests/testthat/test-fix-resolution-moran-diagnostic.R b/tests/testthat/test-fix-resolution-moran-diagnostic.R new file mode 100644 index 00000000..d9df90df --- /dev/null +++ b/tests/testthat/test-fix-resolution-moran-diagnostic.R @@ -0,0 +1,234 @@ +# tests/testthat/test-fix-resolution-moran-diagnostic.R +# --------------------------------------------------------------------------- +# moran_z is a diagnostic of the cell means, not a count rule: Moran's z of +# the cell means is near 0 at 10 to 20 cells whatever the data and grows as +# cells get finer than the range. select_resolution() reads it only when +# asked, summary() leaves it out by default, and a profile handed to the +# tessellation functions is read by cp or not at all. +# --------------------------------------------------------------------------- + +fmd_field <- function(n = 500, seed = 2, a = 100, nugget = 0.3) { + set.seed(seed) + xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) + D <- as.matrix(stats::dist(xy)) + xy$w <- rnorm(n) + xy$z <- as.numeric(t(chol(exp(-D / a) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = sqrt(nugget)) + sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) +} +fmd_sac <- function(pts, range = 240, nugget = 0.3, psill = 1) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) +} +fmd_quiet <- function(expr) suppressWarnings(suppressMessages(expr)) +fmd_bnd <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(0, 0), c(1000, 0), c(1000, 1000), c(0, 1000), c(0, 0)))), crs = 32632)) + + +test_that("select_resolution() refuses moran_z unless asked, and says what it measures", { + pts <- fmd_field() + p <- fmd_quiet(resolution_profile(pts, "z", sac = fmd_sac(pts), n_levels = 10, nstart = 3)) + ok <- is.finite(p$moran_z) + expect_true(any(ok)) + + e <- tryCatch(select_resolution(p, "moran_z"), error = function(e) e) + expect_s3_class(e, "spatialkit_diagnostic_criterion") + msg <- conditionMessage(e) + expect_match(msg, "a diagnostic, not a count rule") + expect_match(msg, "`diagnostic = TRUE`", fixed = TRUE) + expect_match(msg, "Moran's z of the cell means over each cell's 8 nearest cells") + expect_match(msg, sprintf("computable from %d", min(p$levels[ok]))) + expect_match(msg, "does not say how well the cells represent the response") + + # Asked for, it is read as before, and the result carries what it means. + z <- select_resolution(p, "moran_z", diagnostic = TRUE) + expect_identical(z$best, p$levels[ok][which.min(abs(p$moran_z[ok]))]) + expect_match(z$note, "diagnostic, not a count rule") + expect_output(print(z), "least autocorrelated across") + expect_error(select_resolution(p, "moran_z", diagnostic = NA), "TRUE or FALSE") + + # With predictors the statistic is of the cell-mean regression residuals, + # and it is refused all the same. + pw <- fmd_quiet(resolution_profile(pts, "z", predictor_vars = "w", sac = fmd_sac(pts), + n_levels = 8, nstart = 3)) + ew <- tryCatch(select_resolution(pw, "moran_z"), error = function(e) e) + expect_s3_class(ew, "spatialkit_diagnostic_criterion") + expect_match(conditionMessage(ew), "residuals of the cell means regressed on the cell-mean predictors") + + # A profile where it is NA everywhere still says that first. + geo <- resolution_profile(pts, n_levels = 4, nstart = 1) + expect_error(select_resolution(geo, "moran_z"), "NA at every level") +}) + +test_that("summary() leaves moran_z out unless it is named, and out of the comparison", { + pts <- fmd_field() + p <- fmd_quiet(resolution_profile(pts, "z", sac = fmd_sac(pts), n_levels = 10, nstart = 3)) + s <- summary(p) + expect_false("moran_z" %in% s$criterion) + expect_true(all(c("cp", "reliability") %in% s$criterion)) + + named <- summary(p, criteria = c("cp", "reliability", "moran_z")) + expect_identical(named$criterion, c("cp", "reliability", "moran_z")) + expect_identical(named$best[3L], select_resolution(p, "moran_z", diagnostic = TRUE)$best) + # The levels the count criteria agree on are theirs alone. + expect_identical(attr(named, "common"), attr(summary(p, criteria = c("cp", "reliability")), + "common")) + out <- utils::capture.output(print(named)) + expect_true(any(grepl("moran_z is a diagnostic of the cell means, not a count rule", out))) + rng <- range(named$best[1:2]) + expect_true(any(grepl(sprintf("picks span %d to %d cells", rng[1L], rng[2L]), out))) + expect_lte(max(nchar(out)), 80L) +}) + +test_that("a profile whose cp is NA is not read by another criterion in silence", { + resolve <- spatialkit:::.resolve_cell_count + pts <- fmd_field() + sac <- fmd_sac(pts) + + # Geometry-only, given a variogram: cp is NA, reliability is finite. It + # used to be read by reliability and handed on as that many cells. + pg <- fmd_quiet(resolution_profile(pts, sac = sac, n_levels = 8, nstart = 2, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans")) + expect_false(any(is.finite(pg$cp))) + expect_true(any(is.finite(pg$reliability))) + expect_error(select_resolution(pg, criterion = "cp"), "NA at every level") + e <- tryCatch(resolve(pg, "n", "get_voronoi_seeds"), error = function(e) e) + expect_s3_class(e, "spatialkit_no_default_criterion") + expect_match(conditionMessage(e), "`cp`, the criterion a profile is read by, is NA at every level") + expect_match(conditionMessage(e), "Finite on it: reliability") + expect_match(conditionMessage(e), "select_resolution(, criterion = \"reliability\")", + fixed = TRUE) + expect_error(get_voronoi_seeds(fmd_bnd, method = "kmeans", n = pg, sample_points = pts, + partition = "kmeans"), + class = "spatialkit_no_default_criterion") + expect_error(build_tessellation(pts, boundary = fmd_bnd, method = "hex", + approx_n_cells = pg, quiet = TRUE), + class = "spatialkit_no_default_criterion") + # The way the message names works. + sel <- select_resolution(pg, "reliability") + expect_equal(fmd_quiet(resolve(sel, "n", "f"))$n, sel$best) + + # A response profile whose cp is NA at every level (a range alone, and + # levels too fine for the fallback noise variance) used to be read by + # moran_z. + pf <- fmd_quiet(resolution_profile(pts, "z", sac = 240, levels = c(260, 300, 350), + nstart = 1, estimate = NULL, obs_per_cell = NULL, + partition = "kmeans")) + expect_false(any(is.finite(pf$cp))) + expect_true(any(is.finite(pf$moran_z))) + ef <- tryCatch(resolve(pf, "n", "get_voronoi_seeds"), error = function(e) e) + expect_s3_class(ef, "error") + expect_match(conditionMessage(ef), "no criterion finite at any level") + expect_match(conditionMessage(ef), "`moran_z` is finite on it, but it is a diagnostic") +}) + +test_that("a geometry-only profile with an elbow is still read by the elbow", { + resolve <- spatialkit:::.resolve_cell_count + set.seed(6) + ctr <- cbind(runif(6, 100, 900), runif(6, 100, 900)) + g <- rep(1:6, each = 50) + cl <- sf::st_as_sf(data.frame(x = ctr[g, 1] + rnorm(300, 0, 10), + y = ctr[g, 2] + rnorm(300, 0, 10)), + coords = c("x", "y"), crs = 32632) + geo <- resolution_profile(cl, n_levels = 8, nstart = 5) + expect_true(any(is.finite(geo$elbow))) + r <- fmd_quiet(resolve(geo, "n", "get_voronoi_seeds")) + expect_equal(r$n, select_resolution(geo, "elbow")$best) + expect_identical(r$criterion, "elbow") + expect_match(r$from, "select_resolution\\(criterion = \"elbow\"\\)") +}) + +test_that("determine_optimal_levels() says, with a class, when Moran's z ranked its counts", { + fmd_dol <- function(...) { + ws <- list() + value <- withCallingHandlers(determine_optimal_levels(...), warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + hit <- vapply(ws, inherits, logical(1), "spatialkit_diagnostic_ranking") + list(value = value, n = sum(hit), w = if (any(hit)) ws[[which(hit)[1L]]] else NULL) + } + pts <- fmd_field(seed = 701) + + # A response alone: the first-ranked count is the first the statistic can + # be computed at, on this field as on white noise. It came back with the + # no-elbow warning and nothing about what had ranked it. + r <- fmd_dol(pts, max_levels = 40, response_var = "z", criterion = "morans_i") + d <- attr(r$value, "diagnostics") + expect_identical(r$n, 1L) + expect_identical(r$w$k, r$value[1L]) + expect_identical(r$w$criterion, "morans_i") + expect_false(r$w$upgraded) + expect_identical(r$w$first_computable, min(d$eval_ks[is.finite(d$moran_z[d$eval_ks])])) + expect_identical(r$w$window, range(d$eval_ks)) + msg <- conditionMessage(r$w) + expect_match(msg, "criterion = 'morans_i' ranks the candidates by |Moran's z| of the cell means", + fixed = TRUE) + expect_match(msg, "a diagnostic of whether neighbouring cells are independent, not a count rule") + expect_match(msg, sprintf("k = %d is ranked first; the statistic is computable from k = %d", + r$value[1L], r$w$first_computable)) + expect_match(msg, "Use criterion = \"geometric\" for the elbow's ranking", fixed = TRUE) + expect_identical(r$w$k, r$w$first_computable) + # It can be caught by class (the no-elbow warning, raised before it on + # these uniform points, is let through). + expect_identical( + withCallingHandlers( + tryCatch(determine_optimal_levels(pts, max_levels = 40, response_var = "z", + criterion = "morans_i"), + spatialkit_diagnostic_ranking = function(w) "caught"), + spatialkit_no_elbow = function(w) invokeRestart("muffleWarning")), + "caught") + + # With both model variables "geometric" is read as "combined", so the way + # back to the elbow's ranking has two parts when the criterion was named: + # the criterion has to go and a variable has to go. (The advice named the + # variable alone, and with criterion = "morans_i" still in the call that + # ranks by Moran's z all the same.) + rb <- fmd_dol(pts, max_levels = 40, response_var = "z", predictor_vars = "w", + criterion = "morans_i") + expect_identical(rb$n, 1L) + expect_false(rb$w$upgraded) + expect_match(conditionMessage(rb$w), + paste0("Use criterion = \"geometric\" and leave out `response_var` or ", + "`predictor_vars` (with both, \"geometric\" is read as \"combined\") ", + "for the elbow's ranking"), + fixed = TRUE) + # Following it gives the elbow's ranking, with no such warning. + expect_identical(fmd_dol(pts, max_levels = 40, response_var = "z", + criterion = "geometric")$n, 0L) + + # "combined", asked for or taken because both model variables are given: + # the same condition, and the message says which. + rc <- fmd_dol(pts, max_levels = 40, response_var = "z", criterion = "combined") + expect_identical(rc$n, 1L) + expect_false(rc$w$upgraded) + expect_match(conditionMessage(rc$w), "the WSS curve's sag, is flat (the curve has no elbow)", + fixed = TRUE) + ru <- fmd_dol(pts, max_levels = 40, response_var = "z", predictor_vars = "w") + expect_identical(ru$n, 1L) + expect_true(ru$w$upgraded) + expect_identical(ru$w$criterion, "combined") + mu <- conditionMessage(ru$w) + expect_match(mu, "(taken because `response_var` and `predictor_vars` were both supplied)", + fixed = TRUE) + expect_match(mu, "the residuals of the cell means regressed on the cell-mean predictors") + expect_match(mu, "Leave out `response_var` or `predictor_vars` for the elbow's ranking", + fixed = TRUE) + + # No such warning where Moran's z ordered nothing: the geometric criterion, + # a window below ten cells (the default max_levels), and an elbow below + # ten cells, where "combined" returns the geometric ranking. + expect_identical(fmd_dol(pts, max_levels = 40, response_var = "z")$n, 0L) + expect_identical(fmd_dol(pts, response_var = "z", predictor_vars = "w")$n, 0L) + set.seed(6) + ctr <- cbind(runif(8, 0, 1000), runif(8, 0, 1000)) + g <- rep(1:8, each = 50) + cl <- sf::st_as_sf(data.frame(x = ctr[g, 1] + rnorm(400, 0, 8), y = ctr[g, 2] + rnorm(400, 0, 8), + z = rnorm(400) + g, w = rnorm(400)), + coords = c("x", "y"), crs = 32632) + r8 <- fmd_dol(cl, max_levels = 14, response_var = "z", predictor_vars = "w") + expect_identical(r8$n, 0L) + expect_identical(r8$value[1L], 8L) +}) diff --git a/tests/testthat/test-fix-resolution-no-structure.R b/tests/testthat/test-fix-resolution-no-structure.R new file mode 100644 index 00000000..b3202f67 --- /dev/null +++ b/tests/testthat/test-fix-resolution-no-structure.R @@ -0,0 +1,211 @@ +# tests/testthat/test-fix-resolution-no-structure.R +# --------------------------------------------------------------------------- +# A count that is not a finding about the data reaches the caller as a flag +# and a classed condition, not as warning text alone: a Cp optimum that one +# cell for the whole layer matches (structured = FALSE), and a +# determine_optimal_levels() count read off a WSS curve with no elbow. +# --------------------------------------------------------------------------- + +fns_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(expr, warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} +fns_noise <- function(n = 600, seed = 7) { + set.seed(seed) + sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) +} +fns_field <- function(n = 400, seed = 2, a = 100, nugget = 0.3) { + set.seed(seed) + xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) + D <- as.matrix(stats::dist(xy)) + xy$z <- as.numeric(t(chol(exp(-D / a) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = sqrt(nugget)) + sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) +} +fns_sac <- function(pts, range = 240, nugget = 0.3, psill = 1, value = range, ...) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(value, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts), ...) +} + + +test_that("the profile keeps what one cell scores, the level every other has to beat", { + pts <- fns_noise() + p <- fns_catch(resolution_profile(pts, "z", sac = 300, n_levels = 8, nstart = 3))$value + one <- attr(p, "one_cell") + z <- pts$z + expect_identical(one$n, 600L) + expect_equal(one$rss, sum((z - mean(z))^2)) + # Cp by the formula of the levels, at L = 1, with their noise variance. + tau2 <- attr(p, "cp_noise")$value + expect_equal(one$cp, one$rss / 600 + tau2 * 2 * 1 / 600) + expect_false(one$constant) + expect_gt(one$rss, max(p$rss)) + expect_output(print(p), "one cell : rss") + # No response, no reference. + expect_null(attr(resolution_profile(pts, n_levels = 3, nstart = 1), "one_cell")) +}) + +test_that("select_resolution() flags a Cp optimum that one cell matches", { + # White noise: no level predicts better than one mean for the layer. + pts <- fns_noise() + p <- fns_catch(resolution_profile(pts, "z", sac = 300, n_levels = 8, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + s <- select_resolution(p, "cp") + expect_identical(s$structured, FALSE) + expect_equal(s$one_cell, attr(p, "one_cell")$cp) + expect_lte(s$one_cell, s$value * 1.02) + expect_match(s$note, "Cp at one cell") + expect_match(s$note, "the count is not identified") + expect_output(print(s), "not identified") + expect_identical(s$best, p$levels[which.min(p$cp)]) # the pick itself is unchanged + expect_identical(summary(p)$structured[summary(p)$criterion == "cp"], FALSE) + expect_output(print(summary(p)), "one cell for the whole layer does as well") + + # A field with structure: the best level beats one cell by far more than + # the tolerance. + f <- fns_field() + pf <- fns_catch(resolution_profile(f, "z", sac = fns_sac(f), n_levels = 8, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + sf_ <- select_resolution(pf, "cp") + expect_identical(sf_$structured, TRUE) + expect_gt(sf_$one_cell, sf_$value * 1.02) + expect_null(sf_$note) + + # A `cp` column that is not the one the profile computed has no reference. + edited <- pf + edited$cp <- rev(edited$cp) + expect_true(is.na(select_resolution(edited, "cp")$structured)) + # The criteria that are not Cp: an elbow is structure by definition, and + # reliability says nothing either way. + expect_true(is.na(select_resolution(pf, "reliability")$structured)) +}) + +test_that("a count with no structure behind it is a classed warning where it becomes cells", { + pts <- fns_noise() + p <- fns_catch(resolution_profile(pts, "z", sac = 300, n_levels = 8, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + for (x in list(p, select_resolution(p, "cp"))) { + out <- fns_catch(get_voronoi_seeds(method = "kmeans", n = x, sample_points = pts, + partition = "kmeans")) + expect_true("spatialkit_no_structure" %in% out$classes) + w <- out$warnings[[which(vapply(out$warnings, inherits, logical(1), + "spatialkit_no_structure"))[1L]]] + expect_identical(w$criterion, "cp") + expect_match(conditionMessage(w), "get_voronoi_seeds\\(\\): `n` is [0-9]+ cells") + expect_match(conditionMessage(w), "the count is not identified") + expect_identical(nrow(out$value), as.integer(w$n)) + } + expect_identical(tryCatch(voronoi_seeds_kmeans(pts, k = p, partition = "kmeans"), + spatialkit_no_structure = function(w) "caught"), "caught") + # A structured field raises none. + f <- fns_field() + pf <- fns_catch(resolution_profile(f, "z", sac = fns_sac(f), n_levels = 8, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + out <- fns_catch(get_voronoi_seeds(method = "kmeans", n = pf, sample_points = f, + partition = "kmeans")) + expect_false("spatialkit_no_structure" %in% out$classes) +}) + +test_that("a variogram refused for showing no spatial structure gives Cp no nugget, and the flag", { + # The model such a variogram still carries has the nugget a spurious short + # range left: here 0.05 on a variance of 1. Cp must not take it. + pts <- fns_noise() + sac <- fns_sac(pts, range = 30, nugget = 0.05, psill = 0.95, value = NA_real_, + rejected_reason = "no spatial structure detected at the nearest-neighbour scale") + out <- fns_catch(resolution_profile(pts, "z", sac = sac, n_levels = 8, nstart = 3)) + p <- out$value + expect_true(any(grepl("its nugget \\(0.05\\) is not a fitted value either", out$text))) + expect_identical(attr(p, "cp_noise")$source, "finest-level residual mean square") + expect_gt(attr(p, "cp_noise")$value, 0.8) + expect_null(attr(p, "variogram")) + expect_true(all(is.na(p$reliability))) + s <- select_resolution(p, "cp") + expect_identical(s$structured, FALSE) + expect_true(any(grepl("the profile's variogram found no spatial structure", s$note))) +}) + +test_that("determine_optimal_levels() says a count is not a finding with a class and the numbers", { + set.seed(5) + uni <- sf::st_as_sf(data.frame(x = runif(400, 0, 1000), y = runif(400, 0, 1000)), + coords = c("x", "y"), crs = 32632) + out <- fns_catch(determine_optimal_levels(uni)) + expect_true("spatialkit_no_elbow" %in% out$classes) + w <- out$warnings[[1L]] + expect_s3_class(w, "spatialkit_no_elbow") + expect_identical(w$k, out$value[1L]) + expect_identical(w$structured, FALSE) + expect_lt(w$sag, log(1.25)) + expect_match(conditionMessage(w), "the WSS curve has no elbow") + # The count itself, and its shape, are what they were. + expect_type(out$value, "integer") + expect_null(attributes(out$value)) + expect_identical(tryCatch(determine_optimal_levels(uni), + spatialkit_no_elbow = function(w) "caught"), "caught") + + # "na": no count where there is no finding, with the flag and the sag. + na <- fns_catch(determine_optimal_levels(uni, on_no_elbow = "na")) + expect_length(na$warnings, 0L) + expect_true(is.na(na$value)) + expect_type(na$value, "integer") + expect_identical(attr(na$value, "structured"), FALSE) + expect_equal(attr(na$value, "sag"), w$sag) + # "error": a classed error. + e <- tryCatch(determine_optimal_levels(uni, on_no_elbow = "error"), error = function(e) e) + expect_s3_class(e, "spatialkit_no_elbow") + expect_identical(e$k, out$value[1L]) + expect_error(determine_optimal_levels(uni, on_no_elbow = "nope"), "should be one of") + # NA is not a cell count, and the tessellation functions say where it came from. + expect_error(get_voronoi_seeds(method = "kmeans", n = na$value, sample_points = uni), + "on_no_elbow = \"na\"", fixed = TRUE) + + # Eight separated clusters: an elbow, no condition, the same answer under + # every setting. + set.seed(6) + ctr <- cbind(runif(8, 0, 1000), runif(8, 0, 1000)) + g <- rep(1:8, each = 50) + cl <- sf::st_as_sf(data.frame(x = ctr[g, 1] + rnorm(400, 0, 8), y = ctr[g, 2] + rnorm(400, 0, 8)), + coords = c("x", "y"), crs = 32632) + ok <- fns_catch(determine_optimal_levels(cl, max_levels = 14)) + expect_length(ok$warnings, 0L) + expect_identical(ok$value[1L], 8L) + expect_null(attributes(ok$value)) + expect_identical(determine_optimal_levels(cl, max_levels = 14, on_no_elbow = "error"), ok$value) + # Under "na" the count carries the flag too, so one test reads both outcomes. + k8 <- determine_optimal_levels(cl, max_levels = 14, on_no_elbow = "na") + expect_identical(as.integer(k8), ok$value) + expect_identical(attr(k8, "structured"), TRUE) + expect_gte(attr(k8, "sag"), log(1.25)) +}) + +test_that("the model-aware diagnostics carry the flag and the sag", { + set.seed(5) + n <- 400 + uni <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + z = rnorm(n), w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + out <- fns_catch(determine_optimal_levels(uni, max_levels = 40, response_var = "z", + predictor_vars = "w", criterion = "morans_i")) + d <- attr(out$value, "diagnostics") + expect_false(is.null(d)) + expect_identical(d$structured, FALSE) + expect_lt(d$sag, log(1.25)) + expect_true("spatialkit_no_elbow" %in% out$classes) + # Under "na" the window the ladder placed is not scored at all. + na <- determine_optimal_levels(uni, max_levels = 40, response_var = "z", + predictor_vars = "w", criterion = "morans_i", + on_no_elbow = "na") + expect_true(is.na(na)) + expect_identical(attr(na, "structured"), FALSE) +}) diff --git a/tests/testthat/test-fix-resolution-plot-subtitle.R b/tests/testthat/test-fix-resolution-plot-subtitle.R new file mode 100644 index 00000000..9d4886eb --- /dev/null +++ b/tests/testthat/test-fix-resolution-plot-subtitle.R @@ -0,0 +1,46 @@ +# tests/testthat/test-fix-resolution-plot-subtitle.R +# --------------------------------------------------------------------------- +# plot.resolution_profile() says why a profile is not supported, and labels +# the Moran panel as the diagnostic it is. Goes with the two-line change to +# R/plotting-diagnostics.R (lines 688 and 735). +# --------------------------------------------------------------------------- + +test_that("the subtitle of an unsupported profile gives the reason its bounds record", { + skip_if_not_installed("ggplot2") + set.seed(1) + n <- 200 + pts <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) + # Fewer than two cells at min_cell_n: the subtitle read "(floor 2, ceiling + # 2); the floor exceeds the ceiling". + few <- suppressWarnings(resolution_profile(pts, "z", min_cell_n = 150, + levels = c(2, 4, 8, 12, 16), nstart = 2)) + expect_identical(attr(few, "bounds")$ceiling_from, "fewer than two supported cells") + sub <- plot(few)$labels$subtitle + expect_match(sub, "; fewer than two cells meet min_cell_n = 150$") + expect_false(grepl("the floor exceeds the ceiling", sub)) + # A floor above the ceiling is still called that. + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.3, 1), range = c(0, 100 / 3), + stringsAsFactors = FALSE) + sac <- structure(100, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) + hi <- suppressWarnings(resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2)) + expect_false(attr(hi, "bounds")$supported) + expect_match(plot(hi)$labels$subtitle, "; the floor exceeds the ceiling$") + # A supported profile has no such clause. + ok <- suppressWarnings(resolution_profile(pts, "z", sac = 300, n_levels = 5, nstart = 2)) + expect_match(plot(ok)$labels$subtitle, "\\)$") +}) + +test_that("the Moran panel is labelled as a diagnostic", { + skip_if_not_installed("ggplot2") + set.seed(2) + n <- 300 + pts <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) + p <- suppressWarnings(resolution_profile(pts, "z", sac = 300, n_levels = 6, nstart = 2)) + g <- plot(p, criteria = c("cp", "moran_z")) + panels <- as.character(ggplot2::ggplot_build(g)$layout$layout$panel) + expect_true("|Moran's z| of cell means (a diagnostic, not a count rule)" %in% panels) + expect_false(any(grepl("Moran.*lower is better", panels))) +}) diff --git a/tests/testthat/test-fix-resolution-range-floor.R b/tests/testthat/test-fix-resolution-range-floor.R new file mode 100644 index 00000000..43ace2f1 --- /dev/null +++ b/tests/testthat/test-fix-resolution-range-floor.R @@ -0,0 +1,163 @@ +# tests/testthat/test-fix-resolution-range-floor.R +# --------------------------------------------------------------------------- +# The range floor is reported and not applied unless asked: the ladder of +# resolution_profile() starts at 2 by default, so an estimated (and on a +# response with no structure, spurious) range no longer sets the fewest cells +# a criterion can choose. `reliability`, whose own optimum lies below the +# floor, is read at or above it by select_resolution(). +# --------------------------------------------------------------------------- + +frf_field <- function(n = 400, seed = 2, a = 100, nugget = 0.3) { + set.seed(seed) + xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) + D <- as.matrix(stats::dist(xy)) + xy$z <- as.numeric(t(chol(exp(-D / a) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = sqrt(nugget)) + sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) +} +frf_sac <- function(pts, range = 240, nugget = 0.3, psill = 1) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) +} +frf_quiet <- function(expr) suppressWarnings(suppressMessages(expr)) + + +test_that("range_floor = FALSE is the default: the ladder starts at 2 and the floor is reported", { + expect_identical(formals(resolution_profile)$range_floor, FALSE) + pts <- frf_field() + sac <- frf_sac(pts) + p <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = 8, nstart = 3)) + b <- attr(p, "bounds") + # A range of 240 on about a square kilometre: a floor of 16 or so, which + # used to be the first level of the ladder. + expect_gt(b$floor, 10L) + expect_identical(b$floor, as.integer(ceiling(b$area / 240^2))) + expect_true(b$supported) + expect_false(b$range_floor) + expect_identical(min(p$levels), 2L) + expect_identical(max(p$levels), b$ceiling) + expect_true(any(p$levels < b$floor)) + expect_output(print(p), sprintf("floor %d from range 240, not applied", b$floor)) + + # Asked for, the floor starts the ladder as the default used to. + on <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = 8, nstart = 3, + range_floor = TRUE)) + expect_identical(min(on$levels), attr(on, "bounds")$floor) + expect_true(attr(on, "bounds")$range_floor) + # Cp over the ladder from 2 is free to choose below the floor; its edge + # label never names a floor that was not applied. + s <- select_resolution(p, "cp") + expect_false(isTRUE(grepl("range floor", s$edge))) +}) + +test_that("a spurious range on white noise does not start the ladder above 2", { + skip_if_not_installed("gstat") + # White noise on a clustered layout, two of the seeds on which the profile's + # own variogram returned ranges of 40 and 45 km and the ladder started at 98 + # and at 75 cells of 100. Whatever range the variogram returns here, the + # default ladder starts at 2. + # The generator of the layers this was measured on, random stream and all + # (the draws that are not used keep the stream in step with it). + sim_xy <- function(n, towns) { + k <- sample(nrow(towns), n, replace = TRUE) + in_town <- runif(n) < 0.6 + x <- ifelse(in_town, towns[k, 1] + rnorm(n, 0, 12e3), runif(n, 0, 500e3)) + y <- ifelse(in_town, towns[k, 2] + rnorm(n, 0, 12e3), runif(n, 0, 320e3)) + cbind(x = pmin(pmax(x, 0), 500e3), y = pmin(pmax(y, 0), 320e3)) + } + noise_layer <- function(seed, n = 900) { + set.seed(seed) + towns <- cbind(runif(8, 40e3, 460e3), runif(8, 30e3, 290e3)) + runif(40); runif(40); rnorm(60); rnorm(960); runif(40) + xy <- sim_xy(n, towns) + sim_xy(2000, towns) + sf::st_as_sf(data.frame(x = 3e5 + xy[, 1], y = 4.5e6 + xy[, 2], z = rnorm(n)), + coords = c("x", "y"), crs = 32615) + } + for (seed in c(1010, 1018, 1011)) { + p <- frf_quiet(resolution_profile(noise_layer(seed), "z", n_levels = 6, nstart = 2)) + expect_identical(min(p$levels), 2L) + expect_false(attr(p, "bounds")$range_floor) + } +}) + +test_that("select_resolution() reads reliability at or above the range floor", { + pts <- frf_field() + sac <- frf_sac(pts) + p <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = 10, nstart = 3)) + b <- attr(p, "bounds") + rel <- select_resolution(p, "reliability") + # The curve's own maximum is below the floor; read from the floor up, the + # pick is the floor, which is a level of the ladder, and the result says + # the floor chose. + free <- select_resolution(p, "reliability", range_floor = FALSE) + expect_identical(free$best, p$levels[which.max(p$reliability)]) + expect_lt(free$best, b$floor) + expect_true(is.na(free$range_floor)) + expect_identical(rel$best, b$floor) + expect_identical(rel$edge, "the range floor (area / range^2)") + expect_identical(rel$range_floor, b$floor) + expect_true(rel$at_floor) + expect_match(rel$edge, "range floor") + expect_true(all(rel$flat >= b$floor)) + expect_output(print(rel), "range floor") + # The other criteria are not held to it. + expect_true(is.na(select_resolution(p, "cp")$range_floor)) + expect_error(select_resolution(p, "reliability", range_floor = NA), "TRUE or FALSE") + + # A ladder the caller set is read as given, as it always was. + own <- frf_quiet(resolution_profile(pts, "z", sac = sac, levels = c(3, 6, 12, 24, 40), + nstart = 3)) + expect_true(attr(own, "bounds")$levels_given) + expect_identical(select_resolution(own, "reliability")$best, + own$levels[which.max(own$reliability)]) + # A ladder that starts at the floor gives the floor itself, as before. + on <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = 10, nstart = 3, + range_floor = TRUE)) + ron <- select_resolution(on, "reliability") + expect_identical(ron$best, on$levels[which.max(on$reliability)]) + if (ron$best == attr(on, "bounds")$floor) + expect_identical(ron$edge, "the range floor (area / range^2)") +}) + +test_that("the floor is a level of the ladder, so reliability returns the floor itself", { + # With no level on the floor the pick was the next level up: 54 cells for + # a floor of 45 at the default 20 levels, and a step of the ladder is a + # factor of 2 to 4 on a short one. + pts <- frf_field() + sac <- frf_sac(pts) + for (nl in c(5L, 8L, 20L)) { + p <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = nl, nstart = 2)) + b <- attr(p, "bounds") + expect_gt(b$floor, 2L) + expect_lt(b$floor, b$ceiling) + expect_true(b$floor %in% p$levels) + expect_identical(range(p$levels), c(2L, b$ceiling)) + expect_lte(nrow(p), nl + 1L) + rel <- select_resolution(p, "reliability") + expect_identical(rel$best, b$floor) + expect_identical(rel$edge, "the range floor (area / range^2)") + expect_true(rel$at_floor) + } + # The same ladder without a range has no such level: the floor adds one. + geo <- frf_quiet(resolution_profile(pts, n_levels = 5L, nstart = 2)) + p5 <- frf_quiet(resolution_profile(pts, "z", sac = sac, n_levels = 5L, nstart = 2)) + expect_identical(setdiff(p5$levels, geo$levels), attr(p5, "bounds")$floor) + + # No level is added where there is none to add: a floor of 2 is the first + # level already, a floor the layer cannot support is not a level of the + # ladder, and a ladder the caller set is scored as given. + low <- frf_quiet(resolution_profile(pts, "z", sac = frf_sac(pts, range = 2000), + n_levels = 5L, nstart = 2)) + expect_identical(attr(low, "bounds")$floor, 2L) + expect_identical(low$levels, geo$levels) + high <- frf_quiet(resolution_profile(pts, "z", sac = frf_sac(pts, range = 100), + n_levels = 5L, nstart = 2)) + expect_false(attr(high, "bounds")$supported) + expect_identical(high$levels, geo$levels) + own <- frf_quiet(resolution_profile(pts, "z", sac = sac, levels = c(3, 6, 12, 24, 40), + nstart = 2)) + expect_identical(own$levels, c(3L, 6L, 12L, 24L, 40L)) +}) diff --git a/tests/testthat/test-fix-resolution-response-ceiling.R b/tests/testthat/test-fix-resolution-response-ceiling.R new file mode 100644 index 00000000..815d6ea6 --- /dev/null +++ b/tests/testthat/test-fix-resolution-response-ceiling.R @@ -0,0 +1,246 @@ +# tests/testthat/test-fix-resolution-response-ceiling.R +# --------------------------------------------------------------------------- +# The support ceiling of resolution_profile() counts the rows that carry a +# response. It counted every point, so a layer with the response missing on +# three rows in four got four times the cells its scored rows support. +# --------------------------------------------------------------------------- + +frc_field <- function(n, seed, a = 100, nugget = 0.3, side = 1000) { + set.seed(seed) + xy <- data.frame(x = runif(n, 0, side), y = runif(n, 0, side)) + D <- as.matrix(stats::dist(xy)) + xy$z <- as.numeric(t(chol(exp(-D / a) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = sqrt(nugget)) + sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) +} + +# Every warning an expression raises, with its classes, none of them left to +# reach the reporter. +frc_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(expr, warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, + classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} + +# A variogram given by hand, so the bounds do not depend on a fit. +frc_sac <- function(pts, range = 240, nugget = 0.3, psill = 1) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) +} + + +test_that("the ceiling is floor(rows with a response / min_cell_n), and says so", { + pts <- frc_field(900, seed = 1) + sac <- frc_sac(pts) + set.seed(11) + miss <- sample(900, 675) + na <- pts + na$z[miss] <- NA + + out <- frc_catch(resolution_profile(na, "z", sac = sac, nstart = 3, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans")) + p <- out$value + b <- attr(p, "bounds") + # 225 scored rows at min_cell_n = 9 support 25 cells; every point would + # have given 100, at 2.25 scored rows per cell. + expect_identical(b$ceiling, 25L) + expect_identical(b$ceiling_from, "min_cell_n (rows with a response)") + expect_identical(b$n, 900L) + expect_identical(b$n_response, 225L) + expect_identical(max(p$levels), 25L) + expect_lte(select_resolution(p, "cp")$best, 25L) + + # Said by an R warning with a class, which carries both counts. + expect_true("spatialkit_response_ceiling" %in% out$classes) + w <- out$warnings[[which(vapply(out$warnings, inherits, logical(1), + "spatialkit_response_ceiling"))[1L]]] + expect_identical(w$n_response, 225L) + expect_identical(w$ceiling, 25L) + expect_match(conditionMessage(w), "225 of the 900 points carry a response") + expect_match(conditionMessage(w), "25 cells, not the 100") + + # The same ceiling as the 225 rows passed alone. + alone <- frc_catch(resolution_profile(na[-miss, ], "z", sac = sac, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans")) + expect_identical(attr(alone$value, "bounds")$ceiling, 25L) + expect_identical(attr(alone$value, "bounds")$ceiling_from, "min_cell_n") + expect_false("spatialkit_response_ceiling" %in% alone$classes) + + # The print names the rows the ceiling counts, and the edge label too. + expect_output(print(p), "on 900 points \\(225 with a response\\)") + expect_output(print(p), "ceiling 25 from min_cell_n = 9 on the 225 rows with a response") + edge <- spatialkit:::.ladder_edge(25L, p$levels, p$levels, b) + expect_identical(edge, "the support ceiling (rows with a response / min_cell_n)") +}) + +test_that("without a response, or with none on any row, the ceiling counts every point", { + pts <- frc_field(300, seed = 2) + geo <- frc_catch(resolution_profile(pts, n_levels = 5, nstart = 2)) + bg <- attr(geo$value, "bounds") + expect_identical(bg$ceiling, 33L) + expect_identical(bg$ceiling_from, "min_cell_n") + expect_true(is.na(bg$n_response)) + expect_false("spatialkit_response_ceiling" %in% geo$classes) + + # No row has a response: nothing can be scored, and the geometry columns + # keep the ladder a geometry-only profile has. + none <- pts + none$z <- NA_real_ + out <- frc_catch(resolution_profile(none, "z", n_levels = 5, nstart = 2)) + bn <- attr(out$value, "bounds") + expect_identical(bn$n_response, 0L) + expect_identical(bn$ceiling, 33L) + expect_identical(out$value$levels, geo$value$levels) + expect_true(all(is.na(out$value$cp))) + expect_false("spatialkit_response_ceiling" %in% out$classes) + expect_false("spatialkit_not_supported" %in% out$classes) +}) + +test_that("on a subsample the ceiling is held to two scored rows per cell", { + set.seed(3) + n <- 4000 + d <- data.frame(x = runif(n, 0, 2000), y = runif(n, 0, 2000), z = rnorm(n)) + d$z[sample(n, 3000)] <- NA + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + out <- frc_catch(resolution_profile(pts, "z", sac = 300, sample_n = 600, + n_levels = 5, nstart = 2)) + b <- attr(out$value, "bounds") + # About 150 of the 600 subsample rows are scored; half the subsample (300) + # left one scored row in two cells. + expect_true(is.finite(b$n_scored) && b$n_scored < 600L) + expect_lte(b$ceiling, floor(b$n_scored / 2)) + expect_identical(b$ceiling_from, "sample_n") + expect_output(print(out$value), + sprintf("from the %d scored rows of the 600-point subsample", b$n_scored)) + expect_identical(spatialkit:::.ladder_edge(b$ceiling, out$value$levels, out$value$levels, b), + "the subsample's ceiling (two scored subsample rows per cell; raise sample_n)") + # With a response on every row the cap is half the subsample, as it was. + set.seed(3) + full <- sf::st_as_sf(data.frame(x = runif(n, 0, 2000), y = runif(n, 0, 2000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) + bf <- attr(frc_catch(resolution_profile(full, "z", sac = 300, sample_n = 600, + n_levels = 4, nstart = 1))$value, "bounds") + expect_identical(bf$n_scored, 600L) + expect_identical(bf$ceiling, 300L) + expect_identical(bf$ceiling_from, "sample_n") +}) + +test_that("scored rows per occupied cell are reported, and a concentrated response is named", { + # The response on the western quarter of the extent alone: n / L is then + # not the scored rows per occupied cell, because three cells in four hold + # none. + set.seed(5) + n <- 900 + d <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)) + d$z[d$x >= 250] <- NA + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + n_resp <- sum(is.finite(d$z)) + + wide <- frc_catch(resolution_profile(pts, "z", sac = 300, levels = c(25, 100), nstart = 3)) + p <- wide$value + expect_true(all(c("cells_resp", "cell_resp_mean") %in% names(p))) + at100 <- p[p$levels == 100L, ] + # About a quarter of the 100 cells hold a scored row, with about 9 each. + expect_lt(at100$cells_resp, 45L) + expect_gt(at100$cells_resp, 15L) + expect_gt(at100$cell_resp_mean, 6) + expect_lt(at100$cell_resp_mean, 13) + expect_equal(p$cell_resp_mean, n_resp / p$cells_resp) + + # The default ladder stops at floor(n_resp / 9), which is conservative + # here, and the warning says so and names the way round it. + def <- frc_catch(resolution_profile(pts, "z", sac = 300, n_levels = 5, nstart = 2)) + expect_identical(attr(def$value, "bounds")$ceiling, as.integer(floor(n_resp / 9))) + w <- def$text[vapply(def$warnings, inherits, logical(1), "spatialkit_response_ceiling")] + expect_length(w, 1L) + expect_match(w, "lower than the occupied cells need") + expect_match(w, "`cell_resp_mean`", fixed = TRUE) + expect_match(w, "a profile of the rows with a response alone") + # A geometry-only profile leaves both columns NA. + geo <- resolution_profile(pts, levels = c(5, 10), nstart = 1) + expect_true(all(is.na(geo$cells_resp)) && all(is.na(geo$cell_resp_mean))) +}) + +test_that("the warning names the bound in force: sample_n on a subsample, not min_cell_n", { + # 4,000 points, 1,000 scored, cells fitted to 600: both ceilings are + # sample_n's (half the scored subsample rows, and half the subsample), and + # the message used to read "not the 300 that every point at min_cell_n = 9 + # would give", where min_cell_n allows 111 and 444. + set.seed(3) + n <- 4000 + d <- data.frame(x = runif(n, 0, 2000), y = runif(n, 0, 2000), z = rnorm(n)) + d$z[sample(n, 3000)] <- NA + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + out <- frc_catch(resolution_profile(pts, "z", sac = 300, sample_n = 600, + n_levels = 5, nstart = 2)) + b <- attr(out$value, "bounds") + w <- out$warnings[[which(vapply(out$warnings, inherits, logical(1), + "spatialkit_response_ceiling"))[1L]]] + msg <- conditionMessage(w) + expect_match(msg, sprintf("%d of the 600 points of the subsample carry a response", b$n_scored)) + expect_match(msg, "(1000 of the layer's 4000)", fixed = TRUE) + expect_match(msg, sprintf("the ceiling is %d cells, two scored subsample rows per cell", + b$ceiling)) + expect_match(msg, "not the 300 that half the subsample would give") + expect_match(msg, "`sample_n` sets this ceiling, not `min_cell_n`", fixed = TRUE) + expect_match(msg, "the layer's 1000 rows with a response support 111 cells at min_cell_n = 9") + expect_false(grepl("every point at min_cell_n", msg)) + # `cell_resp_mean` counts subsample rows, and the message says by how much + # the layer's cells hold more. + expect_match(msg, "`cell_resp_mean` counts the scored rows of the subsample", fixed = TRUE) + expect_match(msg, sprintf("about %.3g times as many", 1000 / b$n_scored), fixed = TRUE) + expect_equal(out$value$cell_resp_mean, b$n_scored / out$value$cells_resp) + expect_identical(w$ceiling_from, "sample_n") + expect_identical(w$n_sample, 600L) + expect_identical(w$n_scored, b$n_scored) + expect_identical(w$n_response, 1000L) + + # A subsample that does not bind: min_cell_n is named, and the rows + # `cell_resp_mean` counts are still said to be the subsample's. + set.seed(8) + n <- 3000 + d <- data.frame(x = runif(n, 0, 2000), y = runif(n, 0, 2000), z = rnorm(n)) + d$z[sample(n, 2700)] <- NA + sub <- frc_catch(resolution_profile(sf::st_as_sf(d, coords = c("x", "y"), crs = 32632), "z", + sac = 300, sample_n = 1500, n_levels = 4, nstart = 1)) + expect_identical(attr(sub$value, "bounds")$ceiling_from, "min_cell_n (rows with a response)") + m2 <- sub$text[vapply(sub$warnings, inherits, logical(1), "spatialkit_response_ceiling")] + expect_match(m2, "300 of the 3000 points carry a response, so the ceiling is 33 cells, not the 333 that every point at min_cell_n = 9 would give") + expect_match(m2, "rows of the subsample; the cells of the layer hold about") +}) + +test_that("rows short of a predictor are not said to lack a response", { + # The response is complete; a predictor is missing on half the rows. The + # warning read "150 of the 300 points carry a response". + set.seed(5) + n <- 300 + d <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n), w = rnorm(n)) + d$w[sample(n, 150)] <- NA + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + out <- frc_catch(resolution_profile(pts, "z", "w", sac = 300, n_levels = 5, nstart = 2)) + b <- attr(out$value, "bounds") + expect_identical(b$n_response, 150L) + expect_true(b$predictors) + expect_identical(b$ceiling, 16L) + msg <- out$text[vapply(out$warnings, inherits, logical(1), "spatialkit_response_ceiling")] + expect_length(msg, 1L) + expect_match(msg, "150 of the 300 points carry a response and every predictor, so the ceiling is 16 cells") + expect_match(msg, "built from the rows with a response and every predictor") + expect_false(grepl("carry a response,", msg, fixed = TRUE)) + expect_output(print(out$value), "on 300 points \\(150 with a response and every predictor\\)") + expect_output(print(out$value), + "from min_cell_n = 9 on the 150 rows with a response and every predictor") + # And the bound an optimum at that ceiling sits on is named the same way. + expect_identical(spatialkit:::.ladder_edge(b$ceiling, out$value$levels, out$value$levels, b), + "the support ceiling (rows with a response and every predictor / min_cell_n)") + # Without predictors the wording is the response's alone. + expect_false(attr(resolution_profile(pts, n_levels = 3, nstart = 1), "bounds")$predictors) +}) diff --git a/tests/testthat/test-fix-resolution-small-layers.R b/tests/testthat/test-fix-resolution-small-layers.R new file mode 100644 index 00000000..f27c9b1d --- /dev/null +++ b/tests/testthat/test-fix-resolution-small-layers.R @@ -0,0 +1,158 @@ +# tests/testthat/test-fix-resolution-small-layers.R +# --------------------------------------------------------------------------- +# A layer too small for a ladder of cell counts is not reported as supported: +# resolution_profile() used to raise floor(n / min_cell_n) = 0 or 1 to a +# ceiling of 2 "from min_cell_n", supported = TRUE, with nothing said, and +# determine_optimal_levels() returned 1 for two points and for none. +# --------------------------------------------------------------------------- + +fsl_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(expr, warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} +fsl_pts <- function(n, seed = 1) { + set.seed(seed) + sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) +} + + +test_that("fewer than two cells at min_cell_n is supported = FALSE, with a classed warning", { + for (n in c(3L, 10L, 17L)) { + out <- fsl_catch(resolution_profile(fsl_pts(n), "z", nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans")) + b <- attr(out$value, "bounds") + expect_false(b$supported) + expect_identical(b$ceiling_from, "fewer than two supported cells") + expect_identical(b$ceiling, 2L) + expect_identical(out$value$levels, 2L) # the one level is still shown + w <- out$warnings[vapply(out$warnings, inherits, logical(1), "spatialkit_not_supported")] + expect_length(w, 1L) + expect_match(conditionMessage(w[[1L]]), + sprintf("%d points at min_cell_n = 9 support %d cell", n, n %/% 9L)) + expect_match(conditionMessage(w[[1L]]), "`supported` is FALSE") + expect_identical(w[[1L]]$reason, "fewer than two supported cells") + expect_output(print(out$value), "fewer than two cells meet min_cell_n = 9") + expect_output(print(out$value), "no ladder: not supported") + } + # Eighteen points are two cells of nine: a ladder of one level, supported. + ok <- fsl_catch(resolution_profile(fsl_pts(18L), "z", nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans")) + expect_true(attr(ok$value, "bounds")$supported) + expect_identical(attr(ok$value, "bounds")$ceiling_from, "min_cell_n") + expect_false("spatialkit_not_supported" %in% ok$classes) +}) + +test_that("a min_cell_n above half the points is the same case, with or without a response", { + pts <- fsl_pts(200L) + for (resp in list(NULL, "z")) { + out <- fsl_catch(resolution_profile(pts, resp, min_cell_n = 150, nstart = 2, + estimate = NULL, obs_per_cell = NULL, sac = NULL, + partition = "kmeans")) + b <- attr(out$value, "bounds") + expect_false(b$supported) + expect_identical(b$ceiling_from, "fewer than two supported cells") + expect_true("spatialkit_not_supported" %in% out$classes) + expect_true(any(grepl("200 points at min_cell_n = 150 support 1 cell, and it takes two", + out$text))) + expect_true(any(grepl("Lower `min_cell_n` (at most 100 here)", out$text, fixed = TRUE))) + } + # The rows with a response are what is counted: 200 points, 12 scored. + few <- pts + few$z[13:200] <- NA + out <- fsl_catch(resolution_profile(few, "z", nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans")) + expect_false(attr(out$value, "bounds")$supported) + expect_true(any(grepl("12 rows with a response at min_cell_n = 9 support 1 cell", out$text))) +}) + +test_that("points on one location have no ladder either", { + one <- sf::st_as_sf(data.frame(x = rep(500, 30), y = rep(500, 30), z = rnorm(30)), + coords = c("x", "y"), crs = 32632) + out <- fsl_catch(resolution_profile(one, nstart = 2)) + b <- attr(out$value, "bounds") + expect_false(b$supported) + expect_identical(b$ceiling_from, "fewer than two distinct locations") + expect_true(any(grepl("the 30 points sit on 1 distinct location", out$text))) + expect_true("spatialkit_not_supported" %in% out$classes) +}) + +test_that("determine_optimal_levels() does not hand back 1 for a layer with no ladder", { + pts <- fsl_pts(40L) + # No rows: an error. It returned 1. + expect_error(determine_optimal_levels(pts[0, ]), "has no rows") + # One or two points: 1, said with the class every count that is not a + # finding carries, or NA, or an error, as asked. + for (n in 1:2) { + out <- fsl_catch(determine_optimal_levels(pts[seq_len(n), ])) + expect_identical(as.integer(out$value), 1L) + expect_true("spatialkit_no_elbow" %in% out$classes) + expect_match(out$text[1L], "too few for a ladder of cell counts") + expect_true(is.na(determine_optimal_levels(pts[seq_len(n), ], on_no_elbow = "na"))) + expect_error(determine_optimal_levels(pts[seq_len(n), ], on_no_elbow = "error"), + class = "spatialkit_no_elbow") + } + # Every point on one location. + one <- sf::st_as_sf(data.frame(x = rep(500, 12), y = rep(500, 12)), + coords = c("x", "y"), crs = 32632) + out <- fsl_catch(determine_optimal_levels(one)) + expect_identical(as.integer(out$value), 1L) + expect_true("spatialkit_no_elbow" %in% out$classes) + expect_match(out$text[1L], "sit on 1 distinct location") +}) + +test_that("the too-few warning gives advice that can be followed", { + # One row with a response of 200: "1 rows ... support 0 cells ... Lower + # `min_cell_n` (at most 0 here)", and min_cell_n cannot go below 1. + one <- fsl_pts(200L) + one$z[-1] <- NA + out <- fsl_catch(resolution_profile(one, "z", n_levels = 5, nstart = 2)) + msg <- out$text[vapply(out$warnings, inherits, logical(1), "spatialkit_not_supported")] + expect_length(msg, 1L) + expect_match(msg, "1 row with a response at min_cell_n = 9 supports 0 cells, and it takes two") + expect_match(msg, "Two cells take a response on at least two rows, whatever `min_cell_n` is", + fixed = TRUE) + expect_false(grepl("at most 0", msg)) + expect_false(grepl("1 rows", msg)) + # Two rows: a min_cell_n of 1 would give two cells, and that is what is said. + two <- fsl_pts(200L) + two$z[-(1:2)] <- NA + m2 <- fsl_catch(resolution_profile(two, "z", n_levels = 5, nstart = 2))$text + expect_true(any(grepl("2 rows with a response at min_cell_n = 9 support 0 cells", m2))) + expect_true(any(grepl("Lower `min_cell_n` (at most 1 here), or add rows with a response.", + m2, fixed = TRUE))) +}) + +test_that("levels the caller asked for are said to be scored as given", { + # Ten points, levels = 2:4: the warning said "the profile scores 2 cells" + # over a table of three levels, and the print "no ladder". + out <- fsl_catch(resolution_profile(fsl_pts(10L), "z", levels = 2:4, nstart = 2)) + p <- out$value + expect_identical(p$levels, 2:4) + expect_false(attr(p, "bounds")$supported) + msg <- out$text[vapply(out$warnings, inherits, logical(1), "spatialkit_not_supported")] + expect_match(msg, "10 points at min_cell_n = 9 support 1 cell, and it takes two, so no cell count meets `min_cell_n`", + fixed = TRUE) + expect_match(msg, "The 3 levels asked for in `levels` (2 to 4 cells) are scored as given", + fixed = TRUE) + expect_false(grepl("The profile scores 2 cells", msg)) + expect_false(grepl("no ladder", msg)) + shown <- utils::capture.output(print(p)) + expect_true(any(grepl("levels as given: not supported", shown))) + expect_false(any(grepl("no ladder", shown))) + # One level asked for. + m1 <- fsl_catch(resolution_profile(fsl_pts(10L), "z", levels = 3, nstart = 2))$text + expect_true(any(grepl("The 1 level asked for in `levels` (3 cells) is scored as given", + m1, fixed = TRUE))) + # A min_cell_n no level can meet, with levels given. + big <- fsl_catch(resolution_profile(fsl_pts(200L), "z", min_cell_n = 150, + levels = c(2, 4, 8, 12, 16), nstart = 2)) + expect_true(any(grepl("The 5 levels asked for in `levels` (2 to 16 cells) are scored as given", + big$text, fixed = TRUE))) + expect_output(print(big$value), "levels as given: not supported") +}) diff --git a/tests/testthat/test-fix-resolution-structure-test.R b/tests/testthat/test-fix-resolution-structure-test.R new file mode 100644 index 00000000..0785baea --- /dev/null +++ b/tests/testthat/test-fix-resolution-structure-test.R @@ -0,0 +1,180 @@ +# tests/testthat/test-fix-resolution-structure-test.R +# --------------------------------------------------------------------------- +# `structured`, the flag select_resolution() puts on a Cp optimum, needs the +# cells to beat one mean for the layer by more than chance: an F test of the +# cell means at the optimum, adjusted for the levels searched, beside the +# comparison of Cp at one cell with Cp at the optimum. That comparison alone +# called white noise structured on every layer whose Cp had a noise variance +# of 0, and on one small layer in seven. +# --------------------------------------------------------------------------- + +fst_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(expr, warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} +fst_noise <- function(n, seed) { + set.seed(seed) + sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) +} +fst_field <- function(n = 400, seed = 2, a = 100, nugget = 0.3) { + set.seed(seed) + xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) + D <- as.matrix(stats::dist(xy)) + xy$z <- as.numeric(t(chol(exp(-D / a) + diag(1e-8, n))) %*% rnorm(n)) + + rnorm(n, sd = sqrt(nugget)) + sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) +} +fst_sac <- function(pts, range = 240, nugget = 0.3, psill = 1) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) +} + + +test_that("the profile keeps the F test of each level's cells against one mean", { + pts <- fst_noise(300, 11) + p <- fst_catch(resolution_profile(pts, "z", sac = 300, n_levels = 6, nstart = 2))$value + one <- attr(p, "one_cell") + expect_named(one$f_p, as.character(p$levels)) + expect_true(all(one$f_p >= 0 & one$f_p <= 1)) + # The cells of a level are the Voronoi cells of its centres, so the test + # can be redone from outside: a one-way analysis of variance of the + # response on the cells. + xy <- sf::st_coordinates(pts) + for (L in p$levels[c(1L, 3L, length(p$levels))]) { + cen <- attr(p, "centres")[[as.character(L)]] + cl <- max.col(-(outer(xy[, 1], cen[, 1], "-")^2 + outer(xy[, 2], cen[, 2], "-")^2)) + aov_p <- stats::anova(stats::lm(pts$z ~ factor(cl)))[["Pr(>F)"]][1L] + expect_equal(one$f_p[[as.character(L)]], aov_p, tolerance = 1e-8) + } + # No response, no test. + expect_null(attr(resolution_profile(pts, n_levels = 3, nstart = 1), "one_cell")$f_p) +}) + +test_that("a Cp with no noise variance does not call white noise structured", { + # A nugget of 0: Cp is RSS / n, which falls with every finer level, so one + # cell is never within `tol` of the optimum. `structured` was TRUE on 10 + # of 10 such layers, in the call that warns Cp has no penalty, and the + # tessellation functions raised no spatialkit_no_structure. + for (seed in 41:45) { + pts <- fst_noise(400, seed) + out <- fst_catch(resolution_profile(pts, "z", sac = fst_sac(pts, 90, nugget = 0), + n_levels = 8, nstart = 2, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans")) + expect_true(any(grepl("the variogram's nugget is 0", out$text))) + expect_identical(attr(out$value, "cp_noise")$value, 0) + s <- select_resolution(out$value, "cp") + # The comparison of Cp at one cell with the optimum passes, as it must. + expect_gt(s$one_cell, s$value * 1.02) + expect_identical(s$structured, FALSE) + expect_gte(s$structure_p, 0.05) + expect_match(s$note, "by no more than chance allows") + expect_match(s$note, "Cp's noise variance is 0") + expect_match(s$note, "the count is not identified") + } + # And the count reaches the tessellation functions with the classed warning. + seeds <- fst_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts, + partition = "kmeans")) + expect_true("spatialkit_no_structure" %in% seeds$classes) + expect_output(print(summary(out$value)), "one cell for the whole layer does as well") +}) + +test_that("with no noise variance a field with structure is still called structured, and why", { + f <- fst_field() + p <- fst_catch(resolution_profile(f, "z", sac = fst_sac(f, 240, nugget = 0), + n_levels = 8, nstart = 2, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans"))$value + s <- select_resolution(p, "cp") + expect_identical(s$structured, TRUE) + expect_lt(s$structure_p, 1e-6) + # The Cp comparison says nothing there, and the result says what the flag + # rests on. + expect_match(s$note, "Cp's noise variance is 0") + expect_match(s$note, "rests on the F test of the cells against one mean alone") + seeds <- fst_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = f, + partition = "kmeans")) + expect_false("spatialkit_no_structure" %in% seeds$classes) +}) + +test_that("on small white-noise layers the flag is held to the level of its test", { + # Forty layers of 60 points, noise variance from the finest level. Cp at + # one cell is above the optimum by more than `tol` on about one in five, + # which alone used to make `structured` TRUE (27 of 200 such layers). + res <- t(vapply(1:40, function(i) { + p <- fst_catch(resolution_profile(fst_noise(60, 300 + i), "z", sac = 300, nstart = 2, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + s <- select_resolution(p, "cp") + c(structured = isTRUE(s$structured), tol_alone = s$one_cell > s$value * 1.02, + p = s$structure_p, levels = sum(is.finite(p$cp))) + }, numeric(4))) + expect_gte(sum(res[, "tol_alone"]), 6) + expect_lte(sum(res[, "structured"]), 5) + expect_lt(sum(res[, "structured"]), sum(res[, "tol_alone"])) + # TRUE only where the adjusted p-value is under 5 percent, and the + # adjustment is by the levels searched. + expect_true(all(res[res[, "structured"] == 1, "p"] < 0.05)) + expect_true(all(res[res[, "tol_alone"] == 1 & res[, "structured"] == 0, "p"] >= 0.05)) + + # One of the layers the Cp comparison passes and the test does not. + i <- which(res[, "tol_alone"] == 1 & res[, "structured"] == 0)[1L] + pts <- fst_noise(60, 300 + i) + p <- fst_catch(resolution_profile(pts, "z", sac = 300, nstart = 2, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans"))$value + s <- select_resolution(p, "cp") + expect_equal(s$structure_p, + min(1, attr(p, "one_cell")$f_p[[as.character(s$best)]] * sum(is.finite(p$cp)))) + expect_match(s$note, sprintf("the cell means at %d cells differ from one mean", s$best)) + expect_match(s$note, sprintf("adjusting for the %d levels searched", sum(is.finite(p$cp)))) + expect_match(s$note, "a gap that chance produces on a layer of this size") + expect_output(print(s), "not identified") + w <- fst_catch(get_voronoi_seeds(method = "kmeans", n = s, sample_points = pts, + partition = "kmeans")) + expect_true("spatialkit_no_structure" %in% w$classes) +}) + +test_that("a field with structure passes both, on a small layer too", { + f <- fst_field(300, seed = 21) + p <- fst_catch(resolution_profile(f, "z", sac = 300, n_levels = 8, nstart = 2, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + s <- select_resolution(p, "cp") + expect_identical(s$structured, TRUE) + expect_lt(s$structure_p, 0.05) + expect_gt(s$one_cell, s$value * 1.02) + expect_null(s$note) + # The criteria that are not Cp carry no p-value. + expect_true(is.na(select_resolution(p, "moran_z", diagnostic = TRUE)$structure_p)) +}) + +test_that("without the profile's F test the flag is not asserted", { + f <- fst_field() + p <- fst_catch(resolution_profile(f, "z", sac = fst_sac(f), n_levels = 8, nstart = 2, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + expect_identical(select_resolution(p, "cp")$structured, TRUE) + bare <- p + one <- attr(bare, "one_cell") + one$f_p <- NULL + attr(bare, "one_cell") <- one + s <- select_resolution(bare, "cp") + expect_true(is.na(s$structured)) + expect_true(is.na(s$structure_p)) + expect_match(s$note, "carries no F test") + # Where Cp at one cell is within `tol`, that alone still says FALSE. + n <- fst_noise(600, 7) + pn <- fst_catch(resolution_profile(n, "z", sac = 300, n_levels = 8, nstart = 3, + estimate = NULL, obs_per_cell = NULL, + partition = "kmeans"))$value + one <- attr(pn, "one_cell") + one$f_p <- NULL + attr(pn, "one_cell") <- one + expect_identical(select_resolution(pn, "cp")$structured, FALSE) +}) diff --git a/tests/testthat/test-fix-resolution-usability.R b/tests/testthat/test-fix-resolution-usability.R new file mode 100644 index 00000000..a9758f30 --- /dev/null +++ b/tests/testthat/test-fix-resolution-usability.R @@ -0,0 +1,155 @@ +# tests/testthat/test-fix-resolution-usability.R +# --------------------------------------------------------------------------- +# Small usability faults of the count functions: a constant response got a +# message about cell sizes, determine_optimal_levels() refused a response +# without predictors, a range floor equal to the ceiling left a ladder of one +# level, and gstat's console print came through resolution_profile(). +# --------------------------------------------------------------------------- + +fus_catch <- function(expr) { + ws <- list() + value <- withCallingHandlers(expr, warning = function(w) { + ws[[length(ws) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + list(value = value, warnings = ws, classes = unlist(lapply(ws, class)), + text = vapply(ws, conditionMessage, character(1))) +} +fus_pts <- function(n, seed = 1) { + set.seed(seed) + sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), z = rnorm(n)), + coords = c("x", "y"), crs = 32632) +} + + +test_that("a constant response is called constant, by the profile and by select_resolution()", { + pts <- fus_pts(200) + pts$z <- 5 + out <- fus_catch(resolution_profile(pts, "z", n_levels = 5, nstart = 2)) + p <- out$value + expect_true("spatialkit_constant_response" %in% out$classes) + expect_true(any(grepl("the response is constant over the 200 scored row", out$text))) + expect_true(any(grepl("`cp`, `moran_i` and `moran_z` are NA at every level", out$text, + fixed = TRUE))) + expect_true(attr(p, "one_cell")$constant) + expect_true(all(is.na(p$cp))) + expect_true(all(is.na(p$moran_i)) && all(is.na(p$moran_z))) + # The message used to ask for "a level whose cells hold two scored rows", + # which every level of this profile has. + e <- tryCatch(select_resolution(p, "cp"), error = function(e) conditionMessage(e)) + expect_match(e, "`cp` is NA at every level because the response is constant") + expect_false(grepl("two scored rows", e)) + # A response that varies is not called constant. + v <- fus_catch(resolution_profile(fus_pts(200), "z", sac = 300, n_levels = 5, nstart = 2)) + expect_false("spatialkit_constant_response" %in% v$classes) + expect_false(attr(v$value, "one_cell")$constant) +}) + +test_that("determine_optimal_levels() scores a response without predictors", { + pts <- fus_pts(400, seed = 5) + out <- fus_catch(determine_optimal_levels(pts, max_levels = 40, response_var = "z", + criterion = "morans_i")) + # It fell back to the geometric ranking with "needs both response_var and + # predictor_vars", though the statistic runs on an intercept alone. + expect_false(any(grepl("falling back to geometric", out$text))) + # The ranking is by a diagnostic, and that comes with it as a classed + # warning (see test-fix-resolution-moran-diagnostic.R). + expect_true("spatialkit_diagnostic_ranking" %in% out$classes) + d <- attr(out$value, "diagnostics") + expect_false(is.null(d)) + expect_true(any(is.finite(d$moran_z))) + expect_true(all(out$value %in% d$eval_ks[is.finite(d$moran_z[d$eval_ks])])) + # A response alone does not change the default criterion. + geo <- fus_catch(determine_optimal_levels(pts, max_levels = 40, response_var = "z")) + expect_null(attr(geo$value, "diagnostics")) + expect_identical(as.integer(geo$value), + as.integer(fus_catch(determine_optimal_levels(pts, max_levels = 40))$value)) + # Without a response there is still nothing to score, and that is said. + none <- fus_catch(determine_optimal_levels(pts, max_levels = 40, criterion = "morans_i")) + expect_true(any(grepl("criterion = 'morans_i' needs a response_var, and none was given", + none$text))) + expect_null(attr(none$value, "diagnostics")) +}) + +test_that("a range floor equal to the ceiling does not leave a ladder of one level", { + pts <- fus_pts(90) + area <- as.numeric(sf::st_area(sf::st_convex_hull(sf::st_union(sf::st_geometry(pts))))) + # 90 points support 10 cells; a range that puts the floor at 10 as well. + r <- sqrt(area / 9.5) + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.3, 1), range = c(0, r / 3), + stringsAsFactors = FALSE) + sac <- structure(r, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) + for (rf in c(TRUE, FALSE)) { + p <- suppressWarnings(resolution_profile(pts, "z", sac = sac, nstart = 2, range_floor = rf)) + b <- attr(p, "bounds") + expect_identical(b$floor, 10L) + expect_identical(b$ceiling, 10L) + expect_true(b$supported) + expect_identical(min(p$levels), 2L) + expect_gt(nrow(p), 3L) + expect_false(identical(select_resolution(p, "cp")$edge, "the only level scored")) + } +}) + +test_that("resolution_profile() lets nothing through to the console from the variogram fit", { + skip_if_not_installed("gstat") + # A layer on which gstat's fit is singular and the semivariance is far from + # the scale of the distances: fit.variogram() then print()s "a possible + # solution MIGHT be to scale semivariances and/or distances" each time. + set.seed(11) + n <- 300 + sing <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1e-3), y = 5e6 + runif(n, 0, 1e-3), + z = rnorm(n) * 1e6), + coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log( + printed <- utils::capture.output( + p <- suppressWarnings(resolution_profile(sing, "z", n_levels = 3, nstart = 1)))) + expect_length(printed, 0L) + expect_s3_class(p, "resolution_profile") + # What was held back is in the log, when there was anything. + if (any(grepl("printed", lines))) + expect_true(any(grepl("held back here: .*scale semivariances", lines))) +}) + +test_that("a response that is constant to within rounding scores nothing, as the message says", { + # 1e6 + 1e-9 x noise: called constant, and then given a finite `cp` + # computed from its rounding error, and 2 cells by select_resolution(). + near <- fus_pts(200) + near$z <- 1e6 + 1e-9 * near$z + out <- fus_catch(resolution_profile(near, "z", n_levels = 5, nstart = 2)) + p <- out$value + expect_true("spatialkit_constant_response" %in% out$classes) + expect_true(attr(p, "one_cell")$constant) + expect_true(all(is.na(p$cp))) + expect_true(all(is.na(p$moran_i)) && all(is.na(p$moran_z))) + expect_null(attr(p, "cp_noise")) + expect_true(is.na(attr(p, "one_cell")$cp)) + # No noise variance is read off rounding error, and none is announced. + expect_false(any(grepl("takes its noise variance", out$text))) + expect_error(select_resolution(p, "cp"), "because the response is constant") + expect_error(select_resolution(p, "moran_z", diagnostic = TRUE), + "because the response is constant") + + # A response the predictors fit exactly leaves residuals that are rounding + # error on the response's scale. Against their own sum of squares they + # never looked constant, and Cp took a noise variance of 7.9e-31. + lin <- fus_pts(200) + lin$w <- rnorm(200) + lin$z <- 3 * lin$w + 2 + ol <- fus_catch(resolution_profile(lin, "z", "w", n_levels = 5, nstart = 2)) + expect_true("spatialkit_constant_response" %in% ol$classes) + expect_true(any(grepl("the OLS residual of the response on `predictor_vars` is constant", + ol$text, fixed = TRUE))) + expect_true(all(is.na(ol$value$cp))) + expect_error(select_resolution(ol$value, "cp"), + "because the OLS residual of the response on the predictors is constant") + + # A small scale is not a constant: 1e-9 x noise is scored as any response. + tiny <- fus_pts(200) + tiny$z <- 1e-9 * tiny$z + ot <- fus_catch(resolution_profile(tiny, "z", sac = 300, n_levels = 5, nstart = 2)) + expect_false("spatialkit_constant_response" %in% ot$classes) + expect_false(attr(ot$value, "one_cell")$constant) + expect_true(all(is.finite(ot$value$cp))) +}) diff --git a/tests/testthat/test-fix-variogram-args.R b/tests/testthat/test-fix-variogram-args.R new file mode 100644 index 00000000..e9895036 --- /dev/null +++ b/tests/testthat/test-fix-variogram-args.R @@ -0,0 +1,87 @@ +# tests/testthat/test-fix-variogram-args.R +# --------------------------------------------------------------------------- +# estimate_sac_range() checks cutoff, range_frac, n_max, seed and +# keep_directional_fits, and the arguments added with them. +# +# A bad value used to come back as an unrelated refusal (cutoff = 0, -0.5, NA +# and c(0.2, 0.5) all returned NA with "no variogram model could be fitted +# (singular fits)"; range_frac = -1 returned "fitted range exceeds the largest +# lag fitted") or as a bare R error that named no argument ("missing value +# where TRUE/FALSE needed" for range_frac = NA and n_max = NA, "non-numeric +# argument to binary operator" for cutoff = "half"). +# --------------------------------------------------------------------------- + +fva_field <- function(n = 120, seed = 1) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(0.8 * exp(-D / 100) + diag(0.2, n))) %*% rnorm(n)) + sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, z = z), + coords = c("x", "y"), crs = 32632) +} + +test_that("a bad cutoff is an error that names the argument", { + skip_if_not_installed("gstat") + pts <- fva_field() + for (bad in list(0, -0.5, NA, NA_real_, "half", c(0.2, 0.5), 3, Inf, NULL, TRUE)) + expect_error(estimate_sac_range(pts, "z", cutoff = bad), + "^estimate_sac_range\\(\\): `cutoff` must be a single number above 0 and at most 1", + info = paste(deparse(bad), collapse = " ")) + # The message shows what was passed. + expect_error(estimate_sac_range(pts, "z", cutoff = 3), "got 3\\.$") + expect_error(estimate_sac_range(pts, "z", cutoff = c(0.2, 0.5)), "got numeric of length 2\\.$") + expect_error(estimate_sac_range(pts, "z", cutoff = "half"), "got character \\(half\\)\\.$") +}) + +test_that("a bad range_frac, n_max, seed or keep_directional_fits is an error that names it", { + skip_if_not_installed("gstat") + pts <- fva_field() + for (bad in list(NA, -1, 0, Inf, "1", c(1, 2))) + expect_error(estimate_sac_range(pts, "z", range_frac = bad), + "^estimate_sac_range\\(\\): `range_frac` must be a single finite number above 0", + info = paste(deparse(bad), collapse = " ")) + for (bad in list(NA, 10, 29.9, "many", c(100, 200), -Inf)) + expect_error(estimate_sac_range(pts, "z", n_max = bad), + "^estimate_sac_range\\(\\): `n_max` must be a single number of at least 30", + info = paste(deparse(bad), collapse = " ")) + for (bad in list(NA, "y", 1, c(TRUE, FALSE), NULL)) + expect_error(estimate_sac_range(pts, "z", keep_directional_fits = bad), + "^estimate_sac_range\\(\\): `keep_directional_fits` must be TRUE or FALSE", + info = paste(deparse(bad), collapse = " ")) + for (bad in list("a", NA, c(1, 2), Inf)) + expect_error(estimate_sac_range(pts, "z", n_max = 60, seed = bad), + "^estimate_sac_range\\(\\): `seed` must be NULL or a single whole number", + info = paste(deparse(bad), collapse = " ")) +}) + +test_that("the new arguments are checked the same way", { + skip_if_not_installed("gstat") + pts <- fva_field() + expect_error(estimate_sac_range(pts, "z", lags = "log"), "'arg' should be one of") + for (bad in list(4, 101, 7.5, NA, "15", c(10, 15))) + expect_error(estimate_sac_range(pts, "z", n_lags = bad), + "^estimate_sac_range\\(\\): `n_lags` must be a single whole number from 5 to 100", + info = paste(deparse(bad), collapse = " ")) + for (bad in list(0, -0.1, 1.5, NA, "0.05", c(0.05, 0.1))) + expect_error(estimate_sac_range(pts, "z", structure_alpha = bad), + "^estimate_sac_range\\(\\): `structure_alpha` must be a single number above 0 and at most 1", + info = paste(deparse(bad), collapse = " ")) +}) + +test_that("the values at the edges of what is allowed still run", { + skip_if_not_installed("gstat") + pts <- fva_field() + base <- estimate_sac_range(pts, "z") + expect_s3_class(base, "sac_range") + # No subsample is drawn at any of these, so the answer is the default one. + expect_identical(estimate_sac_range(pts, "z", n_max = Inf), base) + expect_identical(estimate_sac_range(pts, "z", n_max = 5000.7), base) + expect_identical(estimate_sac_range(pts, "z", seed = NULL), base) + # A fraction is floored: 60.9 points is 60 points. + r60 <- estimate_sac_range(pts, "z", n_max = 60.9) + expect_identical(attr(r60, "n_used"), 60L) + expect_identical(attr(r60, "n_subsampled"), 60L) + expect_s3_class(estimate_sac_range(pts, "z", cutoff = 1), "sac_range") + expect_s3_class(estimate_sac_range(pts, "z", n_lags = 5, lags = "equal"), "sac_range") + expect_s3_class(estimate_sac_range(pts, "z", structure_alpha = 1), "sac_range") +}) diff --git a/tests/testthat/test-fix-variogram-callers.R b/tests/testthat/test-fix-variogram-callers.R new file mode 100644 index 00000000..e3a800dc --- /dev/null +++ b/tests/testthat/test-fix-variogram-callers.R @@ -0,0 +1,253 @@ +# tests/testthat/test-fix-variogram-callers.R +# --------------------------------------------------------------------------- +# The callers of estimate_sac_range() keep working with what it returns now: +# an accepted range, the two refusals it did not have before (no spatial +# structure, a flat variogram) and a model with two structures. +# resolution_profile(), make_folds(auto_range = TRUE), +# summarize_by_cell(deff = "variogram"), kriging_adequacy() and plot() read +# the class, the value, `rejected_reason`, `variogram`, `variogram_model`, +# `crs` and `detrended`, and none of those changed its meaning. +# --------------------------------------------------------------------------- + +NO_STRUCTURE_REASON <- "no spatial structure detected at the nearest-neighbour scale" + +# 240 points on a 1000 m square with an exponential field (effective range +# 150, nugget 0.2 on a sill of 1), a white-noise column, and a 4 x 4 grid of +# cells they are assigned to. +fvc_setup <- local({ + val <- NULL + function() { + if (is.null(val)) { + set.seed(4401); n <- 240 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- drop(crossprod(chol(0.8 * exp(-3 * D / 150) + diag(0.2, n)), rnorm(n))) + pts <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, z = z, noise = rnorm(n)), + coords = c("x", "y"), crs = 32632) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + cells <- create_grid_polygons(bnd, target_cells = 16, type = "square") + val <<- list(pts = pts, cells = cells, + asg = suppressWarnings(assign_features_to_polygons(pts, cells))) + } + val + } +}) +fvc_warnings <- function(expr) { + w <- list() + val <- withCallingHandlers(expr, warning = function(c) { + w[[length(w) + 1L]] <<- c; invokeRestart("muffleWarning") + }) + list(value = val, messages = vapply(w, conditionMessage, character(1)), + classes = lapply(w, class)) +} + +test_that("the object keeps its class, its value and the attributes callers read", { + skip_if_not_installed("gstat") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + expect_true(is.finite(ok)); expect_true(is.na(no)) + expect_identical(attr(no, "rejected_reason"), NO_STRUCTURE_REASON) + for (r in list(ok, no)) { + expect_s3_class(r, c("sac_range", "numeric"), exact = TRUE) + expect_true(is.numeric(r) && length(r) == 1L) + expect_s3_class(attr(r, "variogram"), "data.frame") + expect_true(all(c("np", "dist", "gamma") %in% names(attr(r, "variogram")))) + vm <- attr(r, "variogram_model") + expect_s3_class(vm, "data.frame") + expect_true(all(c("model", "psill", "range") %in% names(vm))) + expect_s3_class(attr(r, "crs"), "crs") + expect_identical(attr(r, "detrended"), FALSE) + expect_identical(sac_nugget(r), attr(r, "nugget")) + expect_true(attr(vm, "converged")) + } + expect_null(attr(ok, "rejected_reason")) + # A nugget and one structure, or two when the equal-lag fit has a range + # at least twice as long that the adaptive variogram supports (it does + # here: 307 against 120). Either way the value is the effective range of + # the longest structure in the model attached. + vm <- attr(ok, "variogram_model") + expect_identical(as.character(vm$model)[1:2], c("Nug", "Exp")) + expect_identical(attr(ok, "structures"), nrow(vm) - 1L) + expect_equal(as.numeric(ok), 3 * max(vm$range)) + one <- estimate_sac_range(s$pts, "z", lags = "equal") + expect_identical(as.character(attr(one, "variogram_model")$model), c("Nug", "Exp")) + expect_equal(as.numeric(one), 3 * attr(one, "variogram_model")$range[2]) +}) + +test_that("make_folds(auto_range = TRUE) sizes blocks from a range and says why when there is none", { + skip_if_not_installed("gstat") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + f <- suppressMessages(make_folds(s$pts, k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1)) + expect_equal(as.numeric(f$params$sac_range), as.numeric(ok)) + expect_equal(as.numeric(f$params$block_size), as.numeric(ok)) + res <- fvc_warnings(make_folds(s$pts, k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "noise", seed = 1)) + hit <- grepl("no autocorrelation range was identified", res$messages) + expect_identical(sum(hit), 1L) + expect_match(res$messages[hit], NO_STRUCTURE_REASON, fixed = TRUE) + expect_match(res$messages[hit], "falling back to geometric blocks", fixed = TRUE) + expect_gt(res$value$params$grid_nx * res$value$params$grid_ny, 1L) +}) + +test_that("resolution_profile() takes no nugget from a layer with no structure", { + skip_if_not_installed("gstat") + s <- fvc_setup() + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + res <- fvc_warnings(resolution_profile(s$pts, "noise", sac = no, n_levels = 4, nstart = 2)) + p <- res$value + # Cp's noise variance is Mallows' own, read at the finest level, and there + # is no reliability curve: the pure-nugget model has no correlation to give. + expect_identical(attr(p, "cp_noise")$source, "finest-level residual mean square") + expect_true(all(is.finite(p$cp))) + expect_true(all(is.na(p$reliability))) + expect_false(any(grepl("nugget is 0", res$messages, fixed = TRUE))) + # The same when the profile estimates the variogram itself. + p2 <- suppressWarnings(resolution_profile(s$pts, "noise", n_levels = 4, nstart = 2)) + expect_identical(attr(attr(p2, "sac"), "rejected_reason"), NO_STRUCTURE_REASON) + expect_identical(attr(p2, "cp_noise")$source, "finest-level residual mean square") + # And with an accepted range the nugget is read from the model, as before. + ok <- estimate_sac_range(s$pts, "z") + p3 <- suppressWarnings(resolution_profile(s$pts, "z", sac = ok, n_levels = 4, nstart = 2)) + expect_identical(attr(p3, "cp_noise")$source, "variogram nugget") + expect_equal(attr(p3, "cp_noise")$value, sac_nugget(ok)) + expect_true(any(is.finite(p3$reliability))) +}) + +test_that("a fit with a minimum, refused as past the lags, still gives cp its nugget", { + skip_if_not_installed("gstat") + # The refusal is about the range. The nugget of a fit that has a minimum + # was fitted at the short lags, and the model says so (converged = TRUE). + s <- fvc_setup() + sac <- suppressWarnings(estimate_sac_range(s$pts, "z", range_frac = 0.05)) + expect_true(is.na(sac)) + expect_identical(attr(sac, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_identical(attr(attr(sac, "variogram_model"), "converged", exact = TRUE), TRUE) + res <- fvc_warnings(resolution_profile(s$pts, "z", sac = sac, n_levels = 4, nstart = 2)) + expect_identical(attr(res$value, "cp_noise")$source, "variogram nugget") + expect_equal(attr(res$value, "cp_noise")$value, sac_nugget(sac)) + expect_true(all(is.na(res$value$reliability))) + expect_true(any(grepl("`cp` still takes its nugget", res$messages, fixed = TRUE))) + # A variogram with no sill inside four cutoffs has no minimum: the model is + # marked, and neither its nugget nor its sill is used. + tr <- s$pts + tr$t <- 0.02 * sf::st_coordinates(tr)[, 1] + tr$z + sac2 <- suppressWarnings(estimate_sac_range(tr, "t")) + expect_identical(attr(sac2, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_identical(attr(attr(sac2, "variogram_model"), "converged", exact = TRUE), FALSE) + expect_equal(attr(sac2, "rejected_range"), 4 * attr(sac2, "cutoff_dist")) + res2 <- fvc_warnings(resolution_profile(tr, "t", sac = sac2, n_levels = 4, nstart = 2)) + expect_identical(attr(res2$value, "cp_noise")$source, "finest-level residual mean square") + expect_false(any(grepl("still takes its nugget", res2$messages, fixed = TRUE))) +}) + +test_that("summarize_by_cell(deff = 'variogram') uses an accepted model and falls back on a refusal", { + skip_if_not_installed("gstat") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + sm <- summarize_by_cell(s$asg, "z", deff = "variogram", sac = ok, estimate = "mean") + da <- attr(sm, "deff_applied") + expect_identical(da$method, "variogram") + expect_true(all(da$deff[is.finite(da$deff)] >= 1)) + expect_true(any(da$deff > 1.05, na.rm = TRUE)) + # No structure: the model that comes with the refusal is a pure nugget, + # under which distinct observations are uncorrelated. The design effect + # is 1 exactly, by the variogram route, and nothing falls back. (It used + # to be set aside with the other refusals: one warning of class + # spatialkit_deff_fallback, and Kish's correction.) + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + expect_identical(attr(no, "rejected_reason"), NO_STRUCTURE_REASON) + res <- fvc_warnings(summarize_by_cell(s$asg, "noise", deff = "variogram", sac = no, + estimate = "mean")) + expect_length(res$messages, 0L) + da <- attr(res$value, "deff_applied") + expect_identical(da$method, "variogram") + expect_true(all(da$deff[is.finite(da$deff)] == 1)) + expect_true(all(res$value$deff_method == "variogram")) + # The standard errors are the uncorrected ones, and the same when the + # function estimates the variogram itself. + plain <- summarize_by_cell(s$asg, "noise", estimate = "mean") + expect_equal(res$value$..se_resp_noise, plain$..se_resp_noise) + own <- fvc_warnings(summarize_by_cell(s$asg, "noise", deff = "variogram", estimate = "mean")) + expect_false(any(vapply(own$classes, function(k) "spatialkit_deff_fallback" %in% k, + logical(1)))) + expect_equal(own$value$..se_resp_noise, plain$..se_resp_noise) + # Any other refusal is still set aside, with the classed fallback warning + # when nothing can replace it. + far <- suppressWarnings(estimate_sac_range(s$pts, "z", range_frac = 0.05)) + expect_identical(attr(far, "rejected_reason"), "fitted range exceeds the largest lag fitted") + res2 <- fvc_warnings(summarize_by_cell(s$asg, NULL, predictor_vars = "z", + deff = "variogram", sac = far, estimate = "mean")) + cls <- vapply(res2$classes, function(k) "spatialkit_deff_fallback" %in% k, logical(1)) + expect_identical(sum(cls), 1L) + expect_match(res2$messages[cls], "fitted range exceeds the largest lag fitted", fixed = TRUE) +}) + +test_that("kriging_adequacy() kriges with the model, whichever verdict the range got", { + skip_if_not_installed("gstat") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + ka <- kriging_adequacy(s$asg, "z", s$cells, sac = ok, k = 3) + expect_s3_class(ka, "kriging_adequacy") + expect_true(all(is.finite(ka$kr_var[ka$n > 0]))) + # With no structure the model is a pure nugget. It is used, with a warning + # that the range was not identified and why. + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + res <- fvc_warnings(kriging_adequacy(s$asg, "noise", s$cells, sac = no, k = 3)) + expect_s3_class(res$value, "kriging_adequacy") + expect_true(any(grepl(paste0("range was not identified (", NO_STRUCTURE_REASON, ")"), + res$messages, fixed = TRUE))) +}) + +test_that("a model with two structures is read by every caller", { + skip_if_not_installed("gstat") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + # Built by hand the way estimate_sac_range() builds one: nugget, a short + # structure and a long one, with the long range as the value. + vm <- gstat::vgm(psill = 0.3, model = "Exp", range = 150, + add.to = gstat::vgm(psill = 0.5, model = "Exp", range = 20, nugget = 0.2)) + attr(vm, "converged") <- TRUE + two <- ok + attr(two, "variogram_model") <- vm + attr(two, "nugget") <- 0.2 + two[] <- 450 + expect_identical(as.character(vm$model), c("Nug", "Exp", "Exp")) + expect_identical(sac_nugget(two), 0.2) + expect_equal(spatialkit:::.vgm_nugget_of(vm), 0.2) + # The correlation function is the sum of both structures over the sill. + cf <- spatialkit:::.vgm_correlation_fn(vm) + expect_equal(cf(c(10, 100)), (0.5 * exp(-c(10, 100) / 20) + 0.3 * exp(-c(10, 100) / 150)) / 1) + p <- suppressWarnings(resolution_profile(s$pts, "z", sac = two, n_levels = 4, nstart = 2)) + expect_identical(attr(p, "cp_noise")$source, "variogram nugget") + expect_equal(attr(p, "cp_noise")$value, 0.2) + expect_equal(attr(p, "variogram")$psill, 0.8) + sm <- summarize_by_cell(s$asg, "z", deff = "variogram", sac = two) + expect_identical(attr(sm, "deff_applied")$method, "variogram") + ka <- kriging_adequacy(s$asg, "z", s$cells, sac = two, k = 3) + expect_s3_class(ka, "kriging_adequacy") + skip_if_not_installed("ggplot2") + expect_s3_class(plot(two), "ggplot") + expect_no_error(ggplot2::ggplot_build(plot(two))) +}) + +test_that("plot() draws each verdict and print() stays one line of number", { + skip_if_not_installed("gstat") + skip_if_not_installed("ggplot2") + s <- fvc_setup() + ok <- estimate_sac_range(s$pts, "z") + no <- suppressWarnings(estimate_sac_range(s$pts, "noise")) + flat <- suppressWarnings(estimate_sac_range(s$pts, "noise", structure_alpha = 1)) + for (r in list(ok, no, flat)) { + p <- plot(r) + expect_s3_class(p, "ggplot") + expect_no_error(ggplot2::ggplot_build(p)) + out <- utils::capture.output(print(r)) + expect_match(out[1], "^(NA|[0-9])") + expect_false(any(grepl("psill|gamma", out))) + } + expect_match(plot(ok)$labels$subtitle, "^Effective range = ") + expect_match(gsub("\n", " ", plot(no)$labels$subtitle), NO_STRUCTURE_REASON, fixed = TRUE) +}) diff --git a/tests/testthat/test-fix-variogram-directional.R b/tests/testthat/test-fix-variogram-directional.R new file mode 100644 index 00000000..be418d6d --- /dev/null +++ b/tests/testthat/test-fix-variogram-directional.R @@ -0,0 +1,119 @@ +# tests/testthat/test-fix-variogram-directional.R +# --------------------------------------------------------------------------- +# The largest directional range never stands in for the all-pairs fit. +# +# When the all-pairs fit was singular or had not converged and two or more +# directions had fitted, estimate_sac_range() returned the largest +# directional range as the estimate (anisotropy_used = TRUE) and logged +# "notable anisotropy detected ... Using the maximum". On ISOTROPIC fields +# (150 sites, effective range 30 km) that was 6 of 86 identified ranges, at a +# median 3.9 times the truth against 1.4 for the all-pairs answers, each from +# a quarter of the point pairs. +# --------------------------------------------------------------------------- + +# Isotropic exponential fields of the review's reproduction: 150 sites in a +# 500 x 320 km box, sill 1, noise 0.2, effective range 30 km. +fvd_iso <- function(rep, eff = 30e3) { + set.seed(90000L + rep + eff / 10) + n <- 150L + x <- stats::runif(n, 0, 500e3); y <- stats::runif(n, 0, 320e3) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- drop(crossprod(chol(exp(-3 * D / eff) + diag(1e-8, n)), stats::rnorm(n))) + + stats::rnorm(n, 0, sqrt(0.2)) + sf::st_as_sf(data.frame(x = 3e5 + x, y = 4.5e6 + y, z = z), coords = c("x", "y"), + crs = 32615) +} +# Pairs of points no farther apart than `cutoff`: what an all-pairs variogram +# out to that lag is computed from. +fvd_pairs_within <- function(pts, cutoff) { + d <- stats::dist(sf::st_coordinates(pts)) + sum(d <= cutoff) +} +# Draws on which the directional maximum used to be returned (12: 162.7 km, +# 17: 271.7 km, 55: 196.5 km, 5: 63.2 km, 34: 68.6 km, 65: 27.0 km) or was +# selected and then refused (50, 94). +FVD_REPS <- c(5, 12, 17, 34, 50, 55, 65, 94) + +test_that("an isotropic field never gets the directional maximum, at the default", { + skip_if_not_installed("gstat") + for (rep in FVD_REPS) { + pts <- fvd_iso(rep) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + info <- paste("rep", rep) + expect_identical(attr(r, "anisotropy_used"), FALSE, info = info) + expect_false(log_has(lines, "notable anisotropy"), info = info) + expect_false(log_has(lines, "Using the maximum"), info = info) + # The variogram attached is the all-pairs one, not a quarter of the pairs. + expect_equal(sum(attr(r, "variogram")$np), fvd_pairs_within(pts, attr(r, "cutoff_dist")), + info = info) + # The directional sweep is still reported, as the diagnostic it is. + expect_identical(names(attr(r, "directional")), c("0", "45", "90", "135")) + expect_identical(names(attr(r, "directional_status")), c("0", "45", "90", "135")) + expect_identical(names(attr(r, "directional_fitted")), c("0", "45", "90", "135")) + # An identified range is the all-pairs model's own. + if (is.finite(r)) + expect_equal(as.numeric(r), 3 * max(attr(r, "variogram_model")$range), info = info) + } +}) + +test_that("nor with the structure test off: the all-pairs fit decides, alone", { + skip_if_not_installed("gstat") + # structure_alpha = 1 takes away the one refusal the old code did not have, + # so the same layers reach the fit, and the fit is what used to be replaced. + for (rep in FVD_REPS) { + pts <- fvd_iso(rep) + lines <- capture_spatialkit_log( + r <- estimate_sac_range(pts, "z", structure_alpha = 1)) + info <- paste("rep", rep) + expect_identical(attr(r, "anisotropy_used"), FALSE, info = info) + expect_false(log_has(lines, "Using the maximum"), info = info) + expect_equal(sum(attr(r, "variogram")$np), fvd_pairs_within(pts, attr(r, "cutoff_dist")), + info = info) + if (is.finite(r)) { + expect_equal(as.numeric(r), 3 * max(attr(r, "variogram_model")$range), info = info) + } else { + expect_false(is.null(attr(r, "rejected_reason")), info = info) + } + } + # The three draws that returned 163, 272 and 197 km for a 30 km field. + far <- vapply(c(12, 17, 55), function(rep) + as.numeric(suppressWarnings(estimate_sac_range(fvd_iso(rep), "z", structure_alpha = 1))), + numeric(1)) + expect_true(all(is.na(far) | far < 100e3)) +}) + +test_that("with both lag settings, and for a refusal, anisotropy_used is FALSE", { + skip_if_not_installed("gstat") + pts <- fvd_iso(12) + for (l in c("adaptive", "equal")) { + r <- suppressWarnings(estimate_sac_range(pts, "z", lags = l, structure_alpha = 1)) + expect_identical(attr(r, "anisotropy_used"), FALSE) + rr <- suppressWarnings(estimate_sac_range(pts, "z", lags = l, range_frac = 1e-6, + structure_alpha = 1)) + expect_true(is.na(rr)) + expect_identical(attr(rr, "anisotropy_used"), FALSE) + } +}) + +test_that("an all-pairs range past the lags is refused whatever the directions found", { + skip_if_not_installed("gstat") + # An exponential field under an east-west trend: the pooled variogram rises + # past the fitted lags. Directions across the slope can reach a sill; they + # are reported and nothing is built from them. + set.seed(11) + n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 50) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + 4 * x / 1000 + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) + expect_true(is.na(r)) + expect_identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_gt(attr(r, "rejected_range"), attr(r, "cutoff_dist")) + expect_identical(attr(r, "anisotropy_used"), FALSE) + st <- attr(r, "directional_status") + expect_true(all(st %in% c("ok", "over_cutoff", "not_converged", "no_fit"))) + expect_equal(sum(is.finite(attr(r, "directional"))), sum(st == "ok")) + expect_true(log_has(lines, "exceeds the largest lag")) + expect_false(log_has(lines, "Using the maximum")) +}) diff --git a/tests/testthat/test-fix-variogram-invariance.R b/tests/testthat/test-fix-variogram-invariance.R new file mode 100644 index 00000000..7f36fd29 --- /dev/null +++ b/tests/testthat/test-fix-variogram-invariance.R @@ -0,0 +1,243 @@ +# tests/testthat/test-fix-variogram-invariance.R +# --------------------------------------------------------------------------- +# estimate_sac_range() is a function of the data: its verdict, range and +# nugget do not change with the unit of the response or of the coordinates, +# with the order of the rows, or with the last bits of the values. +# +# gstat's iterative fit was neither. On these layers (500 points on a 400 x +# 300 km extent; white noise, and a 25 km range under as much noise) the same +# layer asked eight ways gave more than one verdict in 6 of 10 white-noise +# layers and 2 of 10 short-range ones, the range moved by more than 5 percent +# in 9 and in 6, and gstat printed "a possible solution MIGHT be to scale +# semivariances and/or distances" 291 times to the console. +# --------------------------------------------------------------------------- + +# The layers of the review's reproduction, by seed. +fvi_layer <- function(seed, type = c("short", "white"), n = 500L) { + type <- match.arg(type) + set.seed(seed) + x <- stats::runif(n, 0, 400e3); y <- stats::runif(n, 0, 300e3) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- switch(type, + white = stats::rnorm(n), + short = drop(crossprod(chol(exp(-3 * D / 25e3) + diag(1e-8, n)), stats::rnorm(n))) + + stats::rnorm(n)) + sf::st_as_sf(data.frame(x = 5e5 + x, y = 4e6 + y, v = z), coords = c("x", "y"), + crs = 32615) +} +# What a result says, on the scale of the layer as generated: `by` is what +# the response was multiplied by, `len` what the coordinates were. +fvi_says <- function(s, by = 1, len = 1) { + vm <- attr(s, "variogram_model") + list(verdict = if (is.finite(s)) "identified" else attr(s, "rejected_reason"), + range = as.numeric(s) / len, + rejected = (attr(s, "rejected_range") %||% NA_real_) / len, + nugget = sac_nugget(s) / by^2, + sill = if (is.data.frame(vm)) sum(vm$psill) / by^2 else NA_real_, + converged = if (is.data.frame(vm)) attr(vm, "converged") else NA, + at_bound = attr(s, "nugget_at_bound"), + p = attr(s, "structure_p")) +} +expect_same_answer <- function(a, b, info) { + expect_identical(b$verdict, a$verdict, info = info) + expect_identical(b$converged, a$converged, info = info) + expect_identical(b$at_bound, a$at_bound, info = info) + expect_equal(b$range, a$range, tolerance = 1e-6, info = info) + expect_equal(b$rejected, a$rejected, tolerance = 1e-6, info = info) + expect_equal(b$nugget, a$nugget, tolerance = 1e-6, info = info) + expect_equal(b$sill, a$sill, tolerance = 1e-6, info = info) + expect_equal(b$p, a$p, tolerance = 1e-6, info = info) +} +# The layers on which the old answer moved: short-range 2, 5 and 6, white 1. +FVI_LAYERS <- list(list(102, "short"), list(105, "short"), list(106, "short"), + list(101, "white")) + +test_that("the answer does not depend on the unit of the response", { + skip_if_not_installed("gstat") + for (spec in FVI_LAYERS) { + L <- fvi_layer(spec[[1]], spec[[2]]) + base <- fvi_says(suppressWarnings(estimate_sac_range(L, "v"))) + # 1e-9: a response whose standard deviation fell under 1.5e-8 was called + # constant, whatever its values, so nanometres got no answer where + # metres got one. + for (by in c(1000, 0.001, 1e-9)) { + d <- L; d$v <- L$v * by + expect_same_answer(base, fvi_says(suppressWarnings(estimate_sac_range(d, "v")), by = by), + info = sprintf("%s %d, response times %g", spec[[2]], spec[[1]], by)) + } + # A shift costs six digits of the values and nothing else. + d <- L; d$v <- L$v + 1e6 + expect_same_answer(base, fvi_says(suppressWarnings(estimate_sac_range(d, "v"))), + info = sprintf("%s %d, response plus 1e6", spec[[2]], spec[[1]])) + } +}) + +test_that("a response is constant when its spread is rounding, in any unit", { + skip_if_not_installed("gstat") + L <- fvi_layer(102, "short") + r <- suppressWarnings(estimate_sac_range(L, "v")) + expect_true(is.finite(r)) + # A small unit, a large one, and a level far above the spread: all data. + for (by in c(1e-12, 1e-150, 1e150)) { + d <- L; d$v <- L$v * by + rb <- suppressWarnings(estimate_sac_range(d, "v")) + expect_null(attr(rb, "rejected_reason"), info = format(by)) + expect_equal(as.numeric(rb), as.numeric(r), tolerance = 1e-6, info = format(by)) + } + d <- L; d$v <- L$v + 1e8 # it was "the response is constant" + rs <- suppressWarnings(estimate_sac_range(d, "v")) + expect_null(attr(rs, "rejected_reason")) + expect_equal(as.numeric(rs), as.numeric(r), tolerance = 1e-4) + # Constant, and constant up to the last bits, in any unit. + for (level in c(3, 3e-9, 3e9)) { + d <- L; d$v <- level + expect_identical(attr(estimate_sac_range(d, "v"), "rejected_reason"), + "the response is constant", info = format(level)) + set.seed(1) + d$v <- level * (1 + 4 * .Machine$double.eps * stats::rnorm(nrow(L))) + expect_identical(attr(estimate_sac_range(d, "v"), "rejected_reason"), + "the response is constant", info = format(level)) + } + # Residuals of an exact fit are rounding against the response they are of. + d <- L; set.seed(2); d$w <- stats::rnorm(nrow(L)); d$v <- 1e-9 * (2 * d$w + 1) + expect_match(attr(estimate_sac_range(d, "v", "w"), "rejected_reason"), + "^the residuals on predictor_vars are constant") +}) + +test_that("the nugget and the sill scale by the square of the multiplier", { + skip_if_not_installed("gstat") + L <- fvi_layer(102, "short") + r1 <- estimate_sac_range(L, "v") + d <- L; d$v <- 1000 * L$v + r2 <- estimate_sac_range(d, "v") + expect_true(is.finite(r1)) + expect_equal(as.numeric(r2), as.numeric(r1), tolerance = 1e-8) + expect_equal(sac_nugget(r2), 1e6 * sac_nugget(r1), tolerance = 1e-8) + expect_equal(attr(r2, "variogram_model")$psill, 1e6 * attr(r1, "variogram_model")$psill, + tolerance = 1e-8) + expect_equal(attr(r2, "variogram")$gamma, 1e6 * attr(r1, "variogram")$gamma, + tolerance = 1e-10) + expect_equal(attr(r2, "short_lag_semivariance"), 1e6 * attr(r1, "short_lag_semivariance"), + tolerance = 1e-10) + # The bins hold the same pairs at the same lags. + expect_identical(attr(r2, "variogram")$np, attr(r1, "variogram")$np) + expect_equal(attr(r2, "variogram")$dist, attr(r1, "variogram")$dist, tolerance = 1e-12) +}) + +test_that("the answer does not depend on the unit of the coordinates", { + skip_if_not_installed("gstat") + for (spec in FVI_LAYERS) { + L <- fvi_layer(spec[[1]], spec[[2]]) + base <- fvi_says(suppressWarnings(estimate_sac_range(L, "v"))) + xy <- sf::st_coordinates(L) + # Kilometres, and US survey feet: neither is an exact binary multiple. + for (len in c(1 / 1000, 3937 / 1200)) { + d <- sf::st_as_sf(data.frame(x = xy[, 1] * len, y = xy[, 2] * len, v = L$v), + coords = c("x", "y"), crs = NA) + expect_same_answer(base, fvi_says(suppressWarnings(estimate_sac_range(d, "v")), len = len), + info = sprintf("%s %d, coordinates times %g", spec[[2]], spec[[1]], len)) + } + } +}) + +test_that("the same rows in another order give the identical object", { + skip_if_not_installed("gstat") + for (spec in FVI_LAYERS) { + L <- fvi_layer(spec[[1]], spec[[2]]) + a <- suppressWarnings(estimate_sac_range(L, "v")) + set.seed(7000 + spec[[1]]) + b <- suppressWarnings(estimate_sac_range(L[sample(nrow(L)), ], "v")) + xy <- sf::st_coordinates(L) + s <- suppressWarnings(estimate_sac_range(L[order(xy[, 1], xy[, 2]), ], "v")) + info <- sprintf("%s %d", spec[[2]], spec[[1]]) + # Identical, attributes and all: the value, the variogram, the model, the + # directional sweep and the structure test. + expect_identical(b, a, info = info) + expect_identical(s, a, info = info) + } + # With predictors the detrending fit sees the rows in the same order too. + L <- fvi_layer(102, "short") + set.seed(1); L$w <- rnorm(nrow(L)) + set.seed(2); perm <- sample(nrow(L)) + expect_identical(suppressWarnings(estimate_sac_range(L[perm, ], "v", "w")), + suppressWarnings(estimate_sac_range(L, "v", "w"))) +}) + +test_that("lon/lat rows in another order get the same projection and the identical object", { + skip_if_not_installed("gstat") + # 400 points over the conterminous United States, a field of effective + # range 600 km. The projection for a lon/lat layer is chosen by scoring + # candidates on rows taken at even spacing down the layer, so the rows had + # to be sorted before that choice and not after it: as generated this layer + # got a Lambert azimuthal CRS and a range of 505,530, and in four of six + # other row orders an Albers one and 506,838. + set.seed(14); n <- 400 + lon <- runif(n, -120, -70); lat <- runif(n, 25, 50) + ll <- sf::st_as_sf(data.frame(lon, lat), coords = c("lon", "lat"), crs = 4326) + xy <- sf::st_coordinates(sf::st_transform(ll, 5070)) + ll$z <- as.numeric(crossprod(chol(0.8 * exp(-3 * as.matrix(stats::dist(xy)) / 600e3) + + diag(0.2, n)), rnorm(n))) + a <- suppressWarnings(estimate_sac_range(ll, "z")) + expect_true(is.finite(a)) + expect_false(sf::st_is_longlat(attr(a, "crs"))) + for (s in 1:6) { + set.seed(s) + b <- suppressWarnings(estimate_sac_range(ll[sample(n), ], "z")) + expect_true(attr(b, "crs") == attr(a, "crs"), info = paste("order", s)) + expect_identical(b, a, info = paste("order", s)) + } + # A layer with no range to return keeps its evidence in any order too. + set.seed(13) + wn <- sf::st_as_sf(data.frame(x = runif(300, -120, -70), y = runif(300, 25, 50)), + coords = c("x", "y"), crs = 4326) + wn$z <- rnorm(300) + sf::st_coordinates(wn)[, 2] / 5 + a <- suppressWarnings(estimate_sac_range(wn, "z")) + set.seed(3) + b <- suppressWarnings(estimate_sac_range(wn[sample(300), ], "z")) + expect_identical(b, a) + expect_identical(attr(b, "max_dist"), attr(a, "max_dist")) +}) + +test_that("a change in the last bits of the values changes the answer by as little", { + skip_if_not_installed("gstat") + for (spec in FVI_LAYERS) { + L <- fvi_layer(spec[[1]], spec[[2]]) + base <- fvi_says(suppressWarnings(estimate_sac_range(L, "v"))) + set.seed(7000 + spec[[1]]) + d <- L; d$v <- L$v * (1 + 1e-12 * stats::rnorm(nrow(L))) + expect_same_answer(base, fvi_says(suppressWarnings(estimate_sac_range(d, "v"))), + info = sprintf("%s %d", spec[[2]], spec[[1]])) + } +}) + +test_that("nothing is printed to the console, whatever the scale of the response", { + skip_if_not_installed("gstat") + # gstat::fit.variogram() print()s a hint when a fit is singular and the + # semivariances are small against the distances, which no quiet setting, + # suppressWarnings() or suppressMessages() holds back. + old <- spatialkit_quiet(TRUE) + on.exit(spatialkit_quiet(old), add = TRUE) + for (spec in FVI_LAYERS) { + L <- fvi_layer(spec[[1]], spec[[2]]) + for (by in c(1, 0.1, 0.001)) { + d <- L; d$v <- L$v * by + out <- utils::capture.output(r <- suppressWarnings(estimate_sac_range(d, "v"))) + expect_identical(out, character(0), + info = sprintf("%s %d, response times %g", spec[[2]], spec[[1]], by)) + } + } +}) + +test_that("blocks sized from the range do not change with the unit of the response", { + skip_if_not_installed("gstat") + L <- fvi_layer(102, "short") + d <- L; d$v <- 1000 * L$v + f1 <- suppressWarnings(suppressMessages( + make_folds(L, k = 4, method = "block_kfold", auto_range = TRUE, response_var = "v", seed = 1))) + f2 <- suppressWarnings(suppressMessages( + make_folds(d, k = 4, method = "block_kfold", auto_range = TRUE, response_var = "v", seed = 1))) + expect_true(is.finite(f1$params$sac_range)) + expect_equal(as.numeric(f2$params$sac_range), as.numeric(f1$params$sac_range), tolerance = 1e-8) + expect_identical(c(f2$params$grid_nx, f2$params$grid_ny), c(f1$params$grid_nx, f1$params$grid_ny)) + expect_identical(f2$folds, f1$folds) +}) diff --git a/tests/testthat/test-fix-variogram-lags.R b/tests/testthat/test-fix-variogram-lags.R new file mode 100644 index 00000000..46c13c03 --- /dev/null +++ b/tests/testthat/test-fix-variogram-lags.R @@ -0,0 +1,474 @@ +# tests/testthat/test-fix-variogram-lags.R +# --------------------------------------------------------------------------- +# The lags start at the spacing of the closest pairs, and the nugget says how +# far it can be trusted. +# +# The variogram was binned in 15 equal lags out to half the extent, whatever +# the spacing of the points. On a clustered layer whose structure is shorter +# than the first bin (900 points in 60 clusters, effective range 30 against a +# bin 38 wide, nugget 0.4 on a sill of 1) the range came back at a median 77 +# with 10 of 28 within a factor 2 of the truth, and the nugget at 0.72, exactly +# 0 in 3 fits: all structure shorter than the first bin was counted as +# nugget, or none of the nugget was. +# --------------------------------------------------------------------------- + +# The clustered layout of the review's reproduction, and one draw of a field +# with effective range 30, partial sill 0.6 and nugget 0.4 on it. +fvl_sites <- local({ + val <- NULL + function() { + if (is.null(val)) { + set.seed(11) + cen <- cbind(runif(60, 0, 1000), runif(60, 0, 1000)) + xy <- cen[rep(1:60, each = 15), ] + matrix(rnorm(2 * 900, sd = 8), ncol = 2) + val <<- list(xy = xy, L = t(chol(0.6 * exp(-3 * as.matrix(stats::dist(xy)) / 30) + + diag(1e-8, 900)))) + } + val + } +}) +fvl_clustered <- function(i) { + s <- fvl_sites() + set.seed(100 + i) + z <- as.numeric(s$L %*% rnorm(900)) + sqrt(0.4) * rnorm(900) + sf::st_as_sf(data.frame(x = 5e5 + s$xy[, 1], y = 5e6 + s$xy[, 2], z = z), + coords = c("x", "y"), crs = 32632) +} +# An exponential field on uniform sites: effective range R, partial sill ps, +# nugget nug. +fvl_uniform <- function(seed, n = 300L, R = 300, ps = 0.8, nug = 0.2) { + set.seed(seed) + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + z <- drop(crossprod(chol(ps * exp(-3 * as.matrix(stats::dist(xy)) / R) + diag(1e-8, n)), + rnorm(n))) + rnorm(n, 0, sqrt(nug)) + sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], z = z), + coords = c("x", "y"), crs = 32632) +} + +test_that("a range shorter than an equal first bin is recovered on a clustered layer", { + skip_if_not_installed("gstat") + draws <- c(2, 4, 5, 6, 7, 8) + res <- lapply(draws, function(i) estimate_sac_range(fvl_clustered(i), "z")) + rng <- vapply(res, as.numeric, numeric(1)) + nug <- vapply(res, sac_nugget, numeric(1)) + # Every draw gets a range, and nearly every one within a factor 2 of 30 + # (the equal lags gave 409, 87, 21, 361, 79 and 28 on these six). + expect_true(all(is.finite(rng))) + expect_gte(sum(rng > 15 & rng < 60), 5L) + # The nugget is 0.4: within 0.2 of it in nearly every draw, and never at + # its bound (the equal lags gave 0.82, 0.68, 0, 0.76, 0.79 and 0). + expect_gte(sum(abs(nug - 0.4) <= 0.2), 5L) + expect_false(any(vapply(res, function(r) isTRUE(attr(r, "nugget_at_bound")), logical(1)))) + # The first lag is at the spacing of the points, far inside the first + # equal bin (38 wide, mean separation 17). + expect_true(all(vapply(res, function(r) attr(r, "first_lag"), numeric(1)) < 5)) +}) + +test_that("lags = 'equal' keeps the equal bins, and says where its nugget starts from", { + skip_if_not_installed("gstat") + pts <- fvl_clustered(4) + a <- estimate_sac_range(pts, "z") + e <- suppressWarnings(estimate_sac_range(pts, "z", lags = "equal")) + expect_identical(attr(a, "lags"), "adaptive") + expect_identical(attr(e, "lags"), "equal") + # Fifteen equal bins out to the cutoff. + be <- attr(e, "lag_boundaries") + expect_length(be, 15L) + expect_equal(be, attr(e, "cutoff_dist") * (1:15) / 15) + expect_lte(nrow(attr(e, "variogram")), 15L) + # Geometric bins, the last at the cutoff, the first far below an equal bin. + ba <- attr(a, "lag_boundaries") + expect_equal(ba[length(ba)], attr(a, "cutoff_dist")) + expect_equal(diff(log(ba)), rep(diff(log(ba))[1], length(ba) - 1L)) + expect_lt(ba[1], be[1] / 5) + expect_lte(length(ba), 16L) + # first_lag is the mean separation in the first bin of the variogram used. + for (r in list(a, e)) { + vg <- attr(r, "variogram") + expect_equal(attr(r, "first_lag"), min(vg$dist[vg$np > 0])) + } + expect_gt(attr(e, "first_lag"), 5 * attr(a, "first_lag")) + # n_lags sets the number of equal bins. + e10 <- suppressWarnings(estimate_sac_range(pts, "z", lags = "equal", n_lags = 10)) + expect_length(attr(e10, "lag_boundaries"), 10L) + expect_lte(nrow(attr(e10, "variogram")), 10L) + expect_equal(attr(e10, "lag_boundaries")[10], attr(e10, "cutoff_dist")) +}) + +test_that("with equal lags the fit minimises the criterion gstat's fit minimises", { + skip_if_not_installed("gstat") + # A well-determined field, where gstat's iteration converges: the two fits + # of the same variogram agree. + r <- estimate_sac_range(fvl_uniform(4201), "z", lags = "equal") + expect_true(is.finite(r)) + vg <- attr(r, "variogram") + g <- suppressWarnings(gstat::fit.variogram(vg, gstat::vgm(psill = NA, model = "Exp", + range = NA, nugget = NA))) + skip_if(isTRUE(attr(g, "singular")), "gstat's own fit is singular on this platform") + vm <- attr(r, "variogram_model") + expect_equal(vm$range[2], g$range[2], tolerance = 0.02) + expect_equal(vm$psill, g$psill, tolerance = 0.02) + # And at least as good by that criterion: sum of np / h^2 (gamma - model)^2. + sse <- function(m) { + fit <- m$psill[1] + m$psill[2] * (1 - exp(-vg$dist / m$range[2])) + sum(vg$np / vg$dist^2 * (vg$gamma - fit)^2) + } + expect_lte(sse(vm), sse(g) * (1 + 1e-6)) +}) + +test_that("every classed result carries the short-lag evidence", { + skip_if_not_installed("gstat") + pts <- fvl_uniform(4202) + new_attrs <- c("first_lag", "nugget_at_bound", "bins_below_range", + "short_lag_semivariance", "short_lag_pairs", "short_lag_dist", + "structure_p", "morans_i", "lags", "lag_boundaries", "structures", + "short_range", "n_used", "n_missing", "n_subsampled") + ok <- estimate_sac_range(pts, "z") + rej <- suppressWarnings(estimate_sac_range(pts, "z", range_frac = 1e-6)) + set.seed(1); pts$noise <- rnorm(nrow(pts)) + flat <- suppressWarnings(estimate_sac_range(pts, "noise")) + expect_true(is.finite(ok)); expect_true(is.na(rej)); expect_true(is.na(flat)) + for (r in list(ok, rej, flat)) { + expect_true(all(new_attrs %in% names(attributes(r))), + info = paste(setdiff(new_attrs, names(attributes(r))), collapse = ", ")) + # ... and every attribute it carried before. + expect_true(all(c("directional", "anisotropy", "anisotropy_used", "directional_status", + "directional_fitted", "detrended", "detrend_method", "max_dist", + "cutoff_dist", "crs", "variogram", "variogram_model", "nugget") %in% + names(attributes(r)))) + } + # The semivariance of nearest-neighbour pairs, against its definition: each + # point paired with its nearest other point, each pair counted once. + xy <- sf::st_coordinates(pts); z <- pts$z + D <- as.matrix(stats::dist(xy)); diag(D) <- Inf + nn <- apply(D, 1, which.min) + pr <- unique(t(apply(cbind(seq_along(nn), nn), 1, sort))) + expect_equal(attr(ok, "short_lag_semivariance"), mean(0.5 * (z[pr[, 1]] - z[pr[, 2]])^2)) + expect_identical(attr(ok, "short_lag_pairs"), nrow(pr)) + expect_equal(attr(ok, "short_lag_dist"), stats::median(D[pr])) + # It bounds the nugget from above: the field's nugget is 0.2. + expect_gt(attr(ok, "short_lag_semivariance"), 0.2) + expect_lt(sac_nugget(ok), attr(ok, "short_lag_semivariance") + 0.1) + # Bins inside the fitted range, counted on the variogram attached. + expect_identical(attr(ok, "bins_below_range"), + sum(attr(ok, "variogram")$dist < as.numeric(ok))) + expect_identical(attr(ok, "structures"), 1L) + expect_true(is.na(attr(ok, "short_range"))) +}) + +test_that("a nugget at its lower bound is marked, not handed on bare", { + skip_if_not_installed("gstat") + # A field with no nugget at all: the fit puts the nugget at 0, which is the + # bound of the search and not a measurement of it. + lines <- capture_spatialkit_log( + r <- estimate_sac_range(fvl_uniform(603, ps = 1, nug = 0), "z")) + expect_true(is.finite(r)) + expect_identical(sac_nugget(r), 0) + expect_identical(attr(r, "nugget_at_bound"), TRUE) + expect_true(log_has(lines, "is at its lower bound")) + expect_true(log_has(lines, "nugget_at_bound")) + # The closest pairs still say something: their semivariance is positive. + expect_gt(attr(r, "short_lag_semivariance"), 0) + # A fitted nugget away from the bound is not marked. + r2 <- estimate_sac_range(fvl_uniform(4202, nug = 0.5), "z") + expect_gt(sac_nugget(r2), 0.1) + expect_identical(attr(r2, "nugget_at_bound"), FALSE) + # A REML nugget stops short of exactly 0; within 1e-4 of the sill counts. + hand <- gstat::vgm(psill = 0.99, model = "Exp", range = 100, nugget = 6e-7) + expect_lte(spatialkit:::.vgm_nugget_of(hand), 1e-4 * sum(hand$psill)) +}) + +test_that("every fitted nugget of zero is marked as the bound it is", { + skip_if_not_installed("gstat") + # 600 points over 400 x 300 km, effective range 30 km, noise 0.2 on a sill + # of 1.2: the range spans a few bins and the nugget is weakly identified. + # Of 20 such fields the fitted nugget is exactly 0 in 3 (it was in 4 with + # equal lags, with nothing to tell them from an estimate). + one <- function(i) { + set.seed(5200 + i) + n <- 600L + x <- runif(n, 0, 400e3); y <- runif(n, 0, 300e3) + D <- as.matrix(stats::dist(cbind(x, y))) + z <- drop(crossprod(chol(exp(-3 * D / 30e3) + diag(1e-8, n)), rnorm(n))) + + rnorm(n, 0, sqrt(0.2)) + estimate_sac_range(sf::st_as_sf(data.frame(x = 5e5 + x, y = 4e6 + y, z = z), + coords = c("x", "y"), crs = 32615), "z") + } + res <- lapply(c(1, 2, 3, 5, 7, 14), one) + at_bound <- vapply(res, function(r) attr(r, "nugget_at_bound"), logical(1)) + nug <- vapply(res, sac_nugget, numeric(1)) + sill <- vapply(res, function(r) sum(attr(r, "variogram_model")$psill), numeric(1)) + expect_true(all(vapply(res, is.finite, logical(1)))) + # The mark is exactly "at or within 1e-4 of the sill of zero". + expect_identical(at_bound, nug <= 1e-4 * sill) + expect_true(any(at_bound)); expect_true(any(!at_bound)) + expect_true(all(nug[at_bound] == 0)) + # Where the nugget is at its bound the closest pairs still give a number: + # their semivariance, well above 0, is what a nugget cannot exceed. + sls <- vapply(res, function(r) attr(r, "short_lag_semivariance"), numeric(1)) + expect_true(all(is.finite(sls) & sls > 0.2)) + expect_true(all(nug <= sls)) +}) + +test_that("subsamples of one layer agree on its range", { + skip_if_not_installed("gstat") + # 20 subsamples of 80 percent of one clustered layer (range 30). With + # equal lags the 20 ranges ran from 63 to 153 and beyond (largest over + # smallest 5.4, median 94). + pts <- fvl_clustered(4) + r <- vapply(1:20, function(b) { + set.seed(3000 + b) + as.numeric(suppressWarnings(estimate_sac_range(pts[sort(sample(900, 720)), ], "z"))) + }, numeric(1)) + expect_gte(sum(is.finite(r)), 18L) + expect_lt(max(r, na.rm = TRUE) / min(r, na.rm = TRUE), 3) + expect_gt(stats::median(r, na.rm = TRUE), 20) + expect_lt(stats::median(r, na.rm = TRUE), 45) +}) + +test_that("bins with too few pairs are merged, pair-weighted, and none is dropped", { + f <- spatialkit:::.sac_merge_bins + vg <- data.frame(np = c(10, 10, 15, 40, 5), dist = c(1, 2, 3, 4, 5), + gamma = c(1, 2, 3, 4, 5)) + m <- f(vg, min_np = 30) + # 10 + 10 + 15 make the first bin; 40 the second, and the tail of 5 joins it. + expect_equal(m$np, c(35, 45)) + expect_equal(sum(m$np), sum(vg$np)) + expect_equal(m$dist, c((10 * 1 + 10 * 2 + 15 * 3) / 35, (40 * 4 + 5 * 5) / 45)) + expect_equal(m$gamma, c((10 * 1 + 10 * 2 + 15 * 3) / 35, (40 * 4 + 5 * 5) / 45)) + # Nothing to do when every bin is large enough, or there is one bin. + big <- data.frame(np = c(30, 50), dist = 1:2, gamma = 1:2) + expect_identical(f(big, min_np = 30), big) + expect_identical(f(vg[1, ], min_np = 30), vg[1, ]) + # Fewer pairs in all than one bin needs: a single bin with all of them. + expect_equal(f(vg[1:3, ], min_np = 100)$np, 35) +}) + +test_that("the adaptive boundaries start where the closest pairs end", { + f <- spatialkit:::.sac_lag_boundaries + set.seed(41); n <- 400 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + b <- f(xy, cutoff_dist = 700) + expect_true(all(diff(b) > 0)) + expect_equal(b[length(b)], 700) + expect_lte(length(b), 16L) # the first bin and up to 15 more + expect_gte(length(b), 6L) + expect_equal(diff(log(b)), rep(diff(log(b))[1], length(b) - 1L)) + # The first bin holds about max(50, n / 4) = 100 pairs, and no fewer. + d <- as.numeric(stats::dist(xy)) + expect_gte(sum(d <= b[1]), 100L) + expect_lte(sum(d <= b[1]), 200L) + # It is capped at a quarter of the cutoff on a layer too small to fill it. + small <- f(xy[1:12, ], cutoff_dist = 700) + expect_lte(small[1], 700 / 4 * (1 + 1e-12)) + # Repeat visits to a location do not break it: zero distances are not a lag. + dup <- rbind(xy, xy[1:100, ]) + bd <- f(dup, cutoff_dist = 700) + expect_true(all(is.finite(bd)) && all(bd > 0) && all(diff(bd) > 0)) + # The same boundaries in any unit of length. + expect_equal(f(xy / 1000, cutoff_dist = 0.7) * 1000, b, tolerance = 1e-12) +}) + +test_that("a variogram that rises steeply on geometric bins is not called decreasing", { + f <- spatialkit:::.variogram_decreasing + # Twelve bins a factor 2 apart whose pair counts grow by 3: a steep rise + # over the first five, then a sag of a tenth over the long lags. Weighted + # by pairs, the last steps spoke for all of them and this was refused. + vg <- data.frame(np = 60 * 3^(0:11), dist = 2^(0:11), + gamma = c(0.40, 0.55, 0.70, 0.85, 0.97, 1.00, 1.00, 0.99, 0.97, + 0.95, 0.93, 0.90)) + expect_false(f(vg)) + # A variogram that falls from its first bin on is still caught ... + fall <- vg; fall$gamma <- seq(1.6, 0.8, length.out = 12) + expect_true(f(fall)) + # ... and so is a hump: up to a peak in the short lags and back down. + hump <- vg; hump$gamma <- c(0.5, 0.6, 0.8, 1.0, 1.3, 1.6, 1.9, 2.2, 2.4, 1.6, 1.0, 0.9) + expect_true(f(hump)) + # On a layer: an ordinary field on the clustered layout is not refused for it. + skip_if_not_installed("gstat") + r <- estimate_sac_range(fvl_clustered(2), "z") + expect_false(f(attr(r, "variogram"))) + expect_false(identical(attr(r, "rejected_reason"), "empirical variogram decreases with distance")) +}) + +test_that("on uniform points the adaptive lags lose nothing to the equal ones", { + skip_if_not_installed("gstat") + # 300 points, effective range 300: the reference case of the old help page. + seeds <- 4301:4312 + a <- vapply(seeds, function(s) as.numeric(suppressWarnings( + estimate_sac_range(fvl_uniform(s), "z"))), numeric(1)) + e <- vapply(seeds, function(s) as.numeric(suppressWarnings( + estimate_sac_range(fvl_uniform(s), "z", lags = "equal"))), numeric(1)) + expect_gte(sum(is.finite(a)), 11L) + expect_gte(sum(is.finite(a)), sum(is.finite(e)) - 1L) + ma <- stats::median(a, na.rm = TRUE); me <- stats::median(e, na.rm = TRUE) + expect_gt(ma, 200); expect_lt(ma, 450) + expect_lt(abs(ma / me - 1), 0.25) +}) + +# A field with structure at two scales on the clustered layout: effective +# ranges `rs` (partial sill 0.4) and `rl` (0.3) over a nugget of 0.3. +fvl_nested <- function(seed, rs, rl) { + s <- fvl_sites() + D <- as.matrix(stats::dist(s$xy)) + set.seed(seed) + z <- drop(crossprod(chol(0.4 * exp(-3 * D / rs) + 0.3 * exp(-3 * D / rl) + + diag(1e-8, 900)), rnorm(900))) + rnorm(900, 0, sqrt(0.3)) + sf::st_as_sf(data.frame(x = 5e5 + s$xy[, 1], y = 5e6 + s$xy[, 2], z = z), + coords = c("x", "y"), crs = 32632) +} + +test_that("a much longer structure is kept in the model and sets the range", { + skip_if_not_installed("gstat") + # Structure at two scales on the clustered layout: 15 (partial sill 0.4) + # and 450 (0.3) over a nugget of 0.3. One structure fitted to lags that + # resolve the points follows the short one; blocks have to clear the long. + pts <- fvl_nested(9211, 15, 450) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + e <- estimate_sac_range(pts, "z", lags = "equal") + expect_identical(attr(r, "structures"), 2L) + vm <- attr(r, "variogram_model") + expect_identical(as.character(vm$model), c("Nug", "Exp", "Exp")) + expect_true(all(vm$psill[2:3] > 0)) + # The long range is the equal-lag fit's, it is inside the lags, and it is + # the estimate (277 here; the single adaptive fit gave 24). + expect_true(is.finite(r)); expect_true(is.finite(e)) + expect_equal(as.numeric(r), as.numeric(e), tolerance = 1e-8) + expect_equal(as.numeric(r), 3 * vm$range[3]) + expect_lt(as.numeric(r), attr(r, "cutoff_dist")) + expect_false(attr(r, "lag_fallback")) + expect_identical(attr(r, "lags"), "adaptive") + # The short one is at most half as long, and is reported. + expect_equal(attr(r, "short_range"), 3 * vm$range[2]) + expect_lte(2 * attr(r, "short_range"), as.numeric(r)) + expect_lt(attr(r, "short_range"), 60) + # The long structure carries its share of the semivariance, and both + # fits have a minimum, so the model is marked as one. + expect_gte(attr(vm, "long_share"), 0.03) + expect_identical(attr(vm, "converged"), TRUE) + # The nugget comes from the short lags: nearer 0.3 than the equal-lag + # fit's, which counts the short structure as nugget (0.26 against 0.59). + expect_lt(abs(sac_nugget(r) - 0.3), abs(sac_nugget(e) - 0.3)) + expect_true(log_has(lines, "structure at two scales")) + # Bins inside the short structure are what the nugget is told apart from. + expect_identical(attr(r, "bins_below_range"), + sum(attr(r, "variogram")$dist < attr(r, "short_range"))) +}) + +test_that("a long range at the edge of the search marks the two-structure model as no minimum", { + skip_if_not_installed("gstat") + # On this draw the equal-lag variogram has no sill inside four cutoffs: its + # criterion is still falling at the edge of the ranges searched, so the + # long range (2292 = 4 x 573) and the partial sill solved at it are that + # edge. The model built on it was marked converged = TRUE, which the help + # says of a fitted sill only. + pts <- fvl_nested(9203, 15, 450) + lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) + e <- suppressWarnings(estimate_sac_range(pts, "z", lags = "equal")) + expect_identical(attr(attr(e, "variogram_model"), "converged"), FALSE) + expect_true(is.na(r)) + expect_identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_identical(attr(r, "structures"), 2L) + expect_equal(attr(r, "rejected_range"), 4 * attr(r, "cutoff_dist")) + vm <- attr(r, "variogram_model") + expect_identical(attr(vm, "converged"), FALSE) + expect_identical(spatialkit:::.vgm_converged(vm), FALSE) + expect_true(log_has(lines, "the model is marked converged = FALSE")) + # A model so marked gives Cp no nugget: the flag is one bit for the whole + # model, and resolution_profile() takes nothing from a model without a + # minimum. + out <- suppressWarnings(resolution_profile(pts, "z", sac = r, n_levels = 4, nstart = 2)) + expect_identical(attr(out, "cp_noise")$source, "finest-level residual mean square") + # The helper passes the flag through, and defaults to a minimum. + f <- spatialkit:::.sac_fit_nested + vg <- attr(r, "variogram") + expect_identical(attr(f(vg, attr(r, "cutoff_dist"), 30, 400), "converged"), TRUE) + expect_identical(attr(f(vg, attr(r, "cutoff_dist"), 30, 400, converged = FALSE), + "converged"), FALSE) +}) + +test_that("a weaker long structure is kept too: the range does not drop under the equal-lag one", { + skip_if_not_installed("gstat") + # Ranges 20 and 200. A long structure was kept only when the equal-lag + # range was three times the adaptive one and carried a tenth of the + # semivariance, and on 30 such layers the range returned was under half + # the equal-lag one in 8. Blocks sized from it leak. The bars are a + # factor two and 3 percent now. + for (seed in c(9301, 9309, 9311)) { + pts <- fvl_nested(seed, 20, 200) + r <- suppressWarnings(estimate_sac_range(pts, "z")) + e <- suppressWarnings(estimate_sac_range(pts, "z", lags = "equal")) + expect_true(is.finite(r) && is.finite(e), info = seed) + expect_identical(attr(r, "structures"), 2L, info = seed) + expect_equal(as.numeric(r), as.numeric(e), tolerance = 1e-8, info = seed) + expect_gte(as.numeric(r), 100) + # The short structure is still there to read, near its 20. + expect_lt(attr(r, "short_range"), 50) + } + # On 9309 the long structure has 7 percent, under the old bar: the range + # was 34 where the equal lags give 142. + r <- suppressWarnings(estimate_sac_range(fvl_nested(9309, 20, 200), "z")) + sh <- attr(attr(r, "variogram_model"), "long_share") + expect_gt(sh, 0.03); expect_lt(sh, 0.10) + # A layer with one short structure keeps its short range where the + # adaptive variogram gives the equal-lag range nothing (draw 6: 361 with + # equal lags, and under 3 percent). + one <- estimate_sac_range(fvl_clustered(6), "z") + eq1 <- estimate_sac_range(fvl_clustered(6), "z", lags = "equal") + expect_identical(attr(one, "structures"), 1L) + expect_gt(as.numeric(eq1), 4 * as.numeric(one)) + expect_lt(as.numeric(one), 60) +}) + +test_that("a range the adaptive lags leave past the lags falls back to the equal-lag result", { + skip_if_not_installed("gstat") + # 400 uniform points, effective range 250, partial sill 0.3 under a nugget + # of 0.7. The adaptive lags put little weight on the long ones and their + # fit runs past the largest lag; the equal lags identify 381. The default + # refused 14 of 120 such layers that lags = "equal" answers. + set.seed(323); n <- 400 + u <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + z <- drop(crossprod(chol(0.3 * exp(-3 * as.matrix(stats::dist(u)) / 250) + diag(1e-8, n)), + rnorm(n))) + rnorm(n, 0, sqrt(0.7)) + pts <- sf::st_as_sf(data.frame(x = 5e5 + u[, 1], y = 5e6 + u[, 2], z = z), + coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + e <- estimate_sac_range(pts, "z", lags = "equal") + expect_true(is.finite(e)) + expect_true(is.finite(r)) + expect_identical(attr(r, "lag_fallback"), TRUE) + expect_identical(attr(e, "lag_fallback"), FALSE) + # The equal-lag result, whole: the value, the variogram, the model, the + # directional sweep, the lags and the first lag. + same <- setdiff(names(attributes(e)), "lag_fallback") + expect_identical(attributes(r)[same], attributes(e)[same]) + expect_identical(as.numeric(r), as.numeric(e)) + expect_identical(attr(r, "lags"), "equal") + expect_length(attr(r, "lag_boundaries"), 15L) + expect_true(log_has(lines, "The equal-lag result is returned")) + expect_true(log_has(lines, "lag_fallback")) + # The adaptive fit it replaces is past the lags, with nothing to fall + # back to once the equal-lag range is refused as well. + tight <- suppressWarnings(estimate_sac_range(pts, "z", range_frac = 0.3)) + expect_true(is.na(tight)) + expect_identical(attr(tight, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_identical(attr(tight, "lag_fallback"), FALSE) + expect_identical(attr(tight, "lags"), "adaptive") + # No other refusal falls back. Two white-noise layers, let through with + # the test for structure off: the adaptive variogram of one is flat and + # that of the other falls with distance, the equal lags fit a range to + # each (181 and 223), and neither is handed on. + for (case in list(list(70302, "the empirical variogram is flat: no spatial structure at the lags resolved"), + list(70329, "empirical variogram decreases with distance"))) { + set.seed(case[[1]]) + wn <- sf::st_as_sf(data.frame(x = 5e5 + runif(300, 0, 1000), y = 5e6 + runif(300, 0, 1000), + z = rnorm(300)), coords = c("x", "y"), crs = 32632) + a <- suppressWarnings(estimate_sac_range(wn, "z", structure_alpha = 1)) + expect_true(is.finite(suppressWarnings( + estimate_sac_range(wn, "z", structure_alpha = 1, lags = "equal")))) + expect_true(is.na(a)) + expect_identical(attr(a, "rejected_reason"), case[[2]]) + expect_identical(attr(a, "lag_fallback"), FALSE) + expect_identical(attr(a, "lags"), "adaptive") + } +}) diff --git a/tests/testthat/test-fix-variogram-missing.R b/tests/testthat/test-fix-variogram-missing.R new file mode 100644 index 00000000..9c15aa78 --- /dev/null +++ b/tests/testthat/test-fix-variogram-missing.R @@ -0,0 +1,189 @@ +# tests/testthat/test-fix-variogram-missing.R +# --------------------------------------------------------------------------- +# Rows with a missing response are dropped before the n_max subsample is +# drawn, and the subsample does not depend on the order of the rows. +# +# The subsample used to be drawn over every row, so a sparse response in a +# large layer was estimated from about n_max / n of its usable rows: 300 +# valued rows among 20,300 gave 239.8 from the 74 that fell in the draw +# (124.0 from the 300 alone), a different number for each seed (87.4 to +# 242.3), and 100 valued rows among 20,100 came back NA as "20 point(s) with +# a finite value to model". +# --------------------------------------------------------------------------- + +# An exponential field (effective range R, nugget share nug) on a 1000 m +# square, with x and y kept as columns so layers can be stacked. +fvm_field <- function(n, seed, R = 300, nug = 0.2) { + set.seed(seed) + xy <- cbind(5e5 + runif(n, 0, 1000), 5e6 + runif(n, 0, 1000)) + z <- as.numeric(t(chol((1 - nug) * exp(-3 * as.matrix(stats::dist(xy)) / R) + + diag(nug, n))) %*% rnorm(n)) + sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], z = z), coords = c("x", "y"), + crs = 32632, remove = FALSE) +} +# m rows with no response, scattered over the same square. +fvm_pad <- function(m, seed) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(m, 0, 1000), y = 5e6 + runif(m, 0, 1000), + z = NA_real_), coords = c("x", "y"), crs = 32632, + remove = FALSE) +} + +test_that("rows with no response do not use up the n_max subsample", { + skip_if_not_installed("gstat") + valued <- fvm_field(300, seed = 3) + padded <- rbind(valued, fvm_pad(20000, seed = 4)) + alone <- estimate_sac_range(valued, "z") + both <- estimate_sac_range(padded, "z") + expect_true(is.finite(alone)) + # The same estimate, to the last bit: the 20,000 empty rows change nothing. + expect_identical(as.numeric(both), as.numeric(alone)) + expect_identical(attr(both, "variogram"), attr(alone, "variogram")) + expect_identical(attr(both, "variogram_model"), attr(alone, "variogram_model")) + # The counts say what happened to the rows. + expect_identical(attr(alone, "n_used"), 300L) + expect_identical(attr(alone, "n_missing"), 0L) + expect_identical(attr(alone, "n_subsampled"), 0L) + expect_identical(attr(both, "n_used"), 300L) + expect_identical(attr(both, "n_missing"), 20000L) + expect_identical(attr(both, "n_subsampled"), 0L) + # No subsample is drawn, so the seed cannot matter. + for (s in c(1L, 2L, 99L)) + expect_identical(as.numeric(estimate_sac_range(padded, "z", seed = s)), + as.numeric(alone)) + # The rows left out are logged with their count. + lines <- capture_spatialkit_log(estimate_sac_range(padded, "z")) + expect_true(log_has(lines, "20000 of 20300 row\\(s\\) have a missing or non-finite response")) +}) + +test_that("a sparse response is not refused for the rows the subsample missed", { + skip_if_not_installed("gstat") + valued <- fvm_field(100, seed = 5) + padded <- rbind(valued, fvm_pad(20000, seed = 6)) + alone <- suppressWarnings(estimate_sac_range(valued, "z")) + both <- suppressWarnings(estimate_sac_range(padded, "z")) + # It used to be NA with "20 point(s) with a finite value to model, fewer + # than the 30 a variogram range is estimated from": 100 exist. + expect_false(grepl("fewer than the 30", attr(both, "rejected_reason") %||% "")) + expect_identical(as.numeric(both), as.numeric(alone)) + expect_identical(attr(both, "rejected_reason"), attr(alone, "rejected_reason")) + expect_identical(attr(both, "n_used"), 100L) + # When too few rows carry a value, the count in the reason is the layer's. + few <- rbind(valued[1:12, ], fvm_pad(500, seed = 7)) + r <- suppressWarnings(estimate_sac_range(few, "z")) + expect_true(is.na(r)) + expect_identical(attr(r, "rejected_reason"), paste0( + "12 point(s) with a finite value to model, fewer than the 30 a variogram ", + "range is estimated from")) +}) + +test_that("with more valued rows than n_max, the subsample is drawn from them alone", { + skip_if_not_installed("gstat") + valued <- fvm_field(400, seed = 8) + padded <- rbind(valued, fvm_pad(1500, seed = 9)) + alone <- suppressWarnings(estimate_sac_range(valued, "z", n_max = 150)) + both <- suppressWarnings(estimate_sac_range(padded, "z", n_max = 150)) + expect_identical(as.numeric(both), as.numeric(alone)) + expect_identical(attr(both, "variogram"), attr(alone, "variogram")) + expect_identical(attr(both, "n_used"), 150L) + expect_identical(attr(both, "n_subsampled"), 250L) + expect_identical(attr(both, "n_missing"), 1500L) + # The 150 points are all of the variogram's: every pair is one of theirs. + expect_lte(sum(attr(both, "variogram")$np), choose(150, 2)) +}) + +test_that("rows with no response take no part in choosing the projection", { + skip_if_not_installed("gstat") + # Lon/lat input is projected to a CRS picked from the layer's extent. The + # empty rows reach far beyond the valued ones here, and used to move that + # choice (a UTM zone for the valued rows alone, an equal-area CRS padded). + valued <- sf::st_transform(fvm_field(120, seed = 10), 4326) + set.seed(11) + far <- sf::st_as_sf(data.frame(x = runif(300, -30, 40), y = runif(300, 20, 65), + z = NA_real_), coords = c("x", "y"), crs = 4326, + remove = FALSE) + valued$x <- sf::st_coordinates(valued)[, 1]; valued$y <- sf::st_coordinates(valued)[, 2] + padded <- rbind(valued, far) + alone <- suppressWarnings(estimate_sac_range(valued, "z")) + both <- suppressWarnings(estimate_sac_range(padded, "z")) + expect_true(attr(both, "crs") == attr(alone, "crs")) + expect_identical(as.numeric(both), as.numeric(alone)) + expect_identical(attr(both, "max_dist"), attr(alone, "max_dist")) +}) + +test_that("a missing predictor leaves its row out before the subsample too", { + skip_if_not_installed("gstat") + pts <- fvm_field(200, seed = 12) + set.seed(13); pts$w <- rnorm(nrow(pts)) + gaps <- pts + gaps$w[c(3, 50, 120)] <- c(NA, Inf, NA) + full <- suppressWarnings(estimate_sac_range(pts[-c(3, 50, 120), ], "z", "w")) + r <- suppressWarnings(estimate_sac_range(gaps, "z", "w")) + expect_identical(as.numeric(r), as.numeric(full)) + expect_identical(attr(r, "n_used"), 197L) + expect_identical(attr(r, "n_missing"), 3L) + expect_true(attr(r, "detrended")) +}) + +test_that("a predictor missing on every row falls back to the raw response with a warning", { + skip_if_not_installed("gstat") + # Leaving out every row would leave nothing to model, and the trend cannot + # be fitted either way, so the documented fallback stands: the raw response, + # an R warning, and detrended = FALSE. + pts <- fvm_field(150, seed = 14) + raw <- suppressWarnings(estimate_sac_range(pts, "z")) + pts$bad <- NA_real_ + expect_warning(fb <- estimate_sac_range(pts, "z", predictor_vars = "bad"), + "OLS detrending on bad failed .* fitted to the RAW response") + expect_false(attr(fb, "detrended")) + expect_identical(as.numeric(fb), as.numeric(raw)) + expect_identical(attr(fb, "n_used"), 150L) +}) + +test_that("a predictor present on fewer than 30 rows gives the NA with their count, as it did", { + skip_if_not_installed("gstat") + # 240 rows with a response, the predictor on 20 of them. A trend can be + # fitted to 20 rows and a variogram cannot, so this is the unclassed NA + # that says how many rows there were to model. It is not the raw-response + # fallback: that is for a trend that cannot be fitted at all (the test + # above), and a range of the raw response is not what was asked for. + pts <- fvm_field(240, seed = 15) + set.seed(16); pts$w <- rnorm(nrow(pts)) + pts$w[21:240] <- NA + expect_no_warning(r <- estimate_sac_range(pts, "z", predictor_vars = "w")) + expect_true(is.na(r)) + expect_false(inherits(r, "sac_range")) + expect_identical(names(attributes(r)), "rejected_reason") + expect_identical(attr(r, "rejected_reason"), paste0( + "20 point(s) with a finite value to model, fewer than the 30 a variogram ", + "range is estimated from")) + # One complete row is still a trend to fit and nothing to fit a variogram to. + pts$w[2:240] <- NA + expect_no_warning(r1 <- estimate_sac_range(pts, "z", predictor_vars = "w", detrend = "reml")) + expect_identical(attr(r1, "rejected_reason"), paste0( + "1 point(s) with a finite value to model, fewer than the 30 a variogram ", + "range is estimated from")) + # Thirty complete rows are enough, and the result is of the residuals. + pts$w <- NA_real_ + set.seed(17); pts$w[1:40] <- rnorm(40) + r40 <- suppressWarnings(estimate_sac_range(pts, "z", predictor_vars = "w", + structure_alpha = 1)) + expect_s3_class(r40, "sac_range") + expect_true(attr(r40, "detrended")) + expect_identical(attr(r40, "n_used"), 40L) + expect_identical(attr(r40, "n_missing"), 200L) +}) + +test_that("above n_max the answer does not depend on the order of the rows", { + skip_if_not_installed("gstat") + # The subsample indexes rows, so the same 500 points in another order gave + # another 250 of them: 9 of 10 long-range layers changed their answer. + for (s in 1:3) { + pts <- fvm_field(500, seed = 300 + s) + set.seed(40 + s); shuffled <- pts[sample(nrow(pts)), ] + a <- suppressWarnings(estimate_sac_range(pts, "z", n_max = 250)) + b <- suppressWarnings(estimate_sac_range(shuffled, "z", n_max = 250)) + expect_identical(b, a, info = paste("layer", s)) + expect_identical(attr(a, "n_subsampled"), 250L) + } +}) diff --git a/tests/testthat/test-fix-variogram-reml.R b/tests/testthat/test-fix-variogram-reml.R new file mode 100644 index 00000000..fc0b4e0d --- /dev/null +++ b/tests/testthat/test-fix-variogram-reml.R @@ -0,0 +1,118 @@ +# tests/testthat/test-fix-variogram-reml.R +# --------------------------------------------------------------------------- +# detrend = "reml" keeps the best of its starts, by REML log-likelihood. +# +# .reml_trend() returned the first start that gave finite parameters and never +# compared likelihoods. Its starts were a tenth, a thirtieth and a third of +# the extent, used as the range parameter; when the true range is short +# against the extent they lie in a valley of the likelihood, and which side +# the optimiser climbs is arbitrary. On the layer below (240 clustered sites +# over 600 km, effective range 10 km, a linear trend) the first start ends at +# an effective range of 502 km with a nugget proportion of 0.96, at a +# log-likelihood 1.18 below the fit the second start reaches (4.4 km), and +# estimate_sac_range() refused it as past the largest lag. +# --------------------------------------------------------------------------- + +# Clustered sites over a 600 km extent, a 10 km exponential field with a +# nugget of 0.4 on a sill of 1, and a linear trend in x. +fvr_draw <- function(i, n_cl = 12L, per = 15L, bg = 60L, w = 600e3) { + set.seed(500 + i) + cen <- cbind(runif(n_cl, 0.1 * w, 0.9 * w), runif(n_cl, 0.1 * w, 0.9 * w)) + id <- rep(seq_len(n_cl), each = per) + xy <- rbind(cen[id, ] + matrix(rnorm(2 * length(id), sd = w / 60), ncol = 2), + cbind(runif(bg, 0, w), runif(bg, 0, w))) + n <- nrow(xy) + set.seed(900 + i) + D <- as.matrix(stats::dist(xy)) + z <- drop(crossprod(chol(0.6 * exp(-3 * D / 10e3) + diag(1e-8, n)), rnorm(n))) + + rnorm(n, 0, sqrt(0.4)) + 2 * xy[, 1] / w + d <- data.frame(x = xy[, 1], y = xy[, 2], z = z, X1 = xy[, 1] / w) + list(d = d, pts = sf::st_as_sf(d, coords = c("x", "y"), crs = 32615, remove = FALSE), + extent = max(diff(range(xy[, 1])), diff(range(xy[, 2])))) +} +# The REML log-likelihood gls() reaches from one starting range, as the old +# code started it. +fvr_ll_from <- function(dr, r0) { + d <- dr$d; d$.sac_x <- d$x; d$.sac_y <- d$y + f <- suppressWarnings(nlme::gls( + z ~ X1, data = d, method = "REML", + correlation = nlme::corExp(value = c(r0, 0.1), form = ~ .sac_x + .sac_y, nugget = TRUE))) + cs <- stats::coef(f$modelStruct$corStruct, unconstrained = FALSE) + list(logLik = as.numeric(stats::logLik(f)), eff_range = 3 * cs[["range"]], + nugget = cs[["nugget"]]) +} + +test_that("the REML fit kept is the best of the starts, not the first that converges", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + dr <- fvr_draw(7) + first <- fvr_ll_from(dr, dr$extent / 10) # the start the old code kept + second <- fvr_ll_from(dr, dr$extent / 30) + # The premise: the first start ends lower, at a range beyond the extent's + # scale, and the second finds the short range. + expect_gt(second$logLik, first$logLik + 0.5) + expect_gt(first$eff_range, 20 * second$eff_range) + + # structure_alpha = 1: the field's structure is weak on these sites (the + # correlation adds 1.5 to the log-likelihood), the test for spatial + # structure does not find it, and this test is about which REML fit is + # kept when one is made. + r <- suppressWarnings(estimate_sac_range(dr$pts, "z", "X1", detrend = "reml", + structure_alpha = 1)) + expect_identical(attr(r, "detrend_method"), "reml") + info <- attr(r, "reml") + # At least as good as either start, and clearly better than the first. + expect_gte(info$logLik, max(first$logLik, second$logLik) - 0.01) + expect_gt(info$logLik, first$logLik + 0.5) + # The range is the short one (the field's is 10 km), not hundreds of km. + fitted <- if (is.finite(r)) as.numeric(r) else attr(r, "rejected_range") + expect_lt(fitted, 50e3) + expect_gt(fitted, 1e3) + expect_false(identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted")) + # The model attached is that fit's. + vm <- attr(r, "variogram_model") + expect_equal(3 * vm$range[2], fitted) + expect_equal(sum(vm$psill), info$sigma2, tolerance = 1e-8) +}) + +test_that("the REML record says how good the fit is and how many starts it took", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + dr <- fvr_draw(7) + r <- suppressWarnings(estimate_sac_range(dr$pts, "z", "X1", detrend = "reml")) + # The REML record rides on the result whatever the verdict on the range. + info <- attr(r, "reml") + expect_true(all(c("n_used", "subsampled", "nugget_prop", "sigma2", "logLik", + "logLik_gain", "n_fits") %in% names(info))) + expect_identical(info$n_used, nrow(dr$pts)) + expect_true(is.finite(info$logLik)) + # The gain over the same trend with independent errors. The first start, + # which used to be kept, gains 0.35; the fit kept gains 1.5. + ll0 <- as.numeric(stats::logLik(nlme::gls(z ~ X1, data = dr$d, method = "REML"))) + expect_equal(info$logLik_gain, info$logLik - ll0, tolerance = 1e-6) + expect_gt(info$logLik_gain, 1) + expect_true(info$n_fits >= 1L && info$n_fits <= 4L) +}) + +test_that(".reml_trend() starts from the likelihood and does not discard a nugget near zero", { + skip_if_not_installed("nlme") + dr <- fvr_draw(7) + mf <- dr$d[, c("z", "X1")]; mf$.sac_x <- dr$d$x; mf$.sac_y <- dr$d$y + fit <- spatialkit:::.reml_trend(mf, z ~ X1, extent = dr$extent) + expect_type(fit, "list") + expect_true(all(c("beta", "range", "nugget_prop", "sigma2", "n_used", "subsampled", + "pair_floor", "logLik", "logLik_null", "n_fits") %in% names(fit))) + # One fit, from the best point of the likelihood grid, reaches the optimum. + expect_identical(fit$n_fits, 1L) + first <- fvr_ll_from(dr, dr$extent / 10) + expect_gt(fit$logLik, first$logLik + 0.5) + expect_lt(3 * fit$range, 50e3) + # The optimum has almost no nugget here. A fit is judged by its + # likelihood, not thrown out for where its nugget lies. + expect_lt(fit$nugget_prop, 0.2) + # The same rows in another order give the same fit. + set.seed(1); perm <- sample(nrow(mf)) + fit2 <- spatialkit:::.reml_trend(mf[perm, ], z ~ X1, extent = dr$extent) + expect_equal(fit2$logLik, fit$logLik, tolerance = 1e-6) + expect_equal(fit2$range, fit$range, tolerance = 1e-3) +}) diff --git a/tests/testthat/test-fix-variogram-structure.R b/tests/testthat/test-fix-variogram-structure.R new file mode 100644 index 00000000..9d6ea9ed --- /dev/null +++ b/tests/testthat/test-fix-variogram-structure.R @@ -0,0 +1,206 @@ +# tests/testthat/test-fix-variogram-structure.R +# --------------------------------------------------------------------------- +# estimate_sac_range() tests for spatial structure before it returns a range. +# +# Nothing did. A variogram model can be fitted to anything, and on white +# noise (300 points on a 1000 m square) a finite range came back for 24 of 60 +# layers, 7 of them with a nugget under half the sill, which removes the +# penalty of a resolution criterion that reads it. +# --------------------------------------------------------------------------- + +fvs_white <- function(i, n = 300L) { + set.seed(70000 + n + i) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + z = rnorm(n)), coords = c("x", "y"), crs = 32632) +} +# An exponential field: effective range R, nugget share nug. +fvs_field <- function(seed, n = 300L, R = 300, nug = 0.2) { + set.seed(seed) + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + z <- drop(crossprod(chol((1 - nug) * exp(-3 * as.matrix(stats::dist(xy)) / R) + + diag(nug, n)), rnorm(n))) + sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], z = z), + coords = c("x", "y"), crs = 32632) +} +NO_STRUCTURE <- "no spatial structure detected at the nearest-neighbour scale" + +test_that("white noise gets no range: at most 2 of 20 layers come back finite", { + skip_if_not_installed("gstat") + res <- lapply(1:20, function(i) suppressWarnings(estimate_sac_range(fvs_white(i), "z"))) + finite <- vapply(res, function(r) is.finite(r), logical(1)) + expect_lte(sum(finite), 2L) + refused <- vapply(res, function(r) identical(attr(r, "rejected_reason"), NO_STRUCTURE), + logical(1)) + # Most are refused by the test itself, with its evidence attached. + expect_gte(sum(refused), 17L) + for (r in res[refused]) { + expect_true(is.na(r)) + expect_s3_class(r, "sac_range") + expect_gte(attr(r, "structure_p"), 0.05) + expect_true(is.na(attr(r, "rejected_range"))) + expect_s3_class(attr(r, "variogram"), "data.frame") + } + # A layer the test lets through is one it found structure in. + for (r in res[!refused]) expect_lt(attr(r, "structure_p"), 0.05) +}) + +test_that("the refusal carries a pure-nugget model, not the model that was fitted", { + skip_if_not_installed("gstat") + pts <- fvs_white(1) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + expect_identical(attr(r, "rejected_reason"), NO_STRUCTURE) + vm <- attr(r, "variogram_model") + expect_identical(as.character(vm$model), "Nug") + expect_equal(vm$psill, stats::var(pts$z)) + expect_true(spatialkit:::.vgm_is_pure_nugget(vm)) + expect_null(spatialkit:::.vgm_correlation_fn(vm)) + # The nugget is the variance of the response, and it is not marked as a + # bound: it is the nugget of the model the test supports. + expect_equal(sac_nugget(r), stats::var(pts$z)) + expect_false(attr(r, "nugget_at_bound")) + expect_identical(attr(r, "structures"), 0L) + # The log line says what was measured and how to override it. + expect_true(log_has(lines, "no spatial structure detected at the nearest-neighbour scale")) + expect_true(log_has(lines, "Moran's I of the response on the [0-9]+ nearest neighbours is")) + expect_true(log_has(lines, "not below structure_alpha = 0.05")) + expect_true(log_has(lines, "set structure_alpha = 1 to fit a range regardless")) + # It prints as NA and draws, with the reason as the subtitle. + expect_output(print(r), "^NA") + skip_if_not_installed("ggplot2") + p <- plot(r) + expect_s3_class(p, "ggplot") + expect_match(gsub("\n", " ", p$labels$subtitle), + "No effective range: no spatial structure detected at the nearest-neighbour scale") +}) + +test_that("structure_alpha = 1 switches the refusal off and keeps the test attached", { + skip_if_not_installed("gstat") + pts <- fvs_white(1) + r0 <- suppressWarnings(estimate_sac_range(pts, "z")) + r1 <- suppressWarnings(estimate_sac_range(pts, "z", structure_alpha = 1)) + expect_identical(attr(r0, "rejected_reason"), NO_STRUCTURE) + expect_false(identical(attr(r1, "rejected_reason"), NO_STRUCTURE)) + expect_identical(attr(r1, "structure_p"), attr(r0, "structure_p")) + expect_identical(attr(r1, "structure_test"), attr(r0, "structure_test")) + expect_identical(attr(r1, "morans_i"), attr(r0, "morans_i")) + # A stricter or laxer level moves the line and nothing else. + p <- attr(r0, "structure_p") + lax <- suppressWarnings(estimate_sac_range(pts, "z", structure_alpha = min(1, p * 1.01))) + expect_false(identical(attr(lax, "rejected_reason"), NO_STRUCTURE)) +}) + +test_that("a field with structure passes, and the test is attached to the range", { + skip_if_not_installed("gstat") + for (s in 1:8) { + r <- suppressWarnings(estimate_sac_range(fvs_field(4100 + s), "z")) + expect_lt(attr(r, "structure_p"), 0.05) + expect_false(identical(attr(r, "rejected_reason"), NO_STRUCTURE)) + expect_gt(attr(r, "morans_i"), 0) + } + r <- estimate_sac_range(fvs_field(4101), "z") + tab <- attr(r, "structure_test") + expect_s3_class(tab, "data.frame") + expect_identical(names(tab), c("k", "morans_i", "z", "p")) + expect_identical(tab$k, c(2L, 4L, 8L, 16L)) + # The adjusted p-value is the smallest of the four, times four. + expect_equal(attr(r, "structure_p"), min(1, 4 * min(tab$p))) + expect_equal(attr(r, "morans_i"), tab$morans_i[tab$k == 8L]) + expect_equal(tab$p, stats::pnorm(tab$z, lower.tail = FALSE)) +}) + +test_that("the statistic is Moran's I on k nearest neighbours with its exact null moments", { + skip_if_not_installed("gstat") + set.seed(31); n <- 150 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)); y <- rnorm(n) + st <- spatialkit:::.sac_structure_test(xy, y) + # Against the definition, from the full distance matrix. + D <- as.matrix(stats::dist(xy)); diag(D) <- Inf + e <- y - mean(y) + for (j in seq_along(st$table$k)) { + k <- st$table$k[j] + lagged <- vapply(seq_len(n), function(i) mean(e[order(D[i, ])[seq_len(k)]]), numeric(1)) + expect_equal(st$table$morans_i[j], sum(e * lagged) / sum(e^2), tolerance = 1e-10) + } + # With an intercept alone the null mean is the classical -1 / (n - 1). + W <- spatialkit:::.build_knn_weights(xy, k = 8L) + mom <- spatialkit:::.morans_residual_moments(W, matrix(1, n, 1), sum(W), inherits(W, "Matrix")) + expect_equal(mom$EI, -1 / (n - 1), tolerance = 1e-10) + expect_equal(st$table$z[st$table$k == 8L], + (st$table$morans_i[st$table$k == 8L] - mom$EI) / sqrt(mom$VI), tolerance = 1e-10) + # No random numbers: the caller's stream is where it was, and two calls agree. + set.seed(5); before <- runif(2) + set.seed(5); st2 <- spatialkit:::.sac_structure_test(xy, y); after <- runif(2) + expect_identical(after, before) + expect_identical(st2, st) + # With a trend's design it is the statistic of the OLS residuals, under + # the moments that fit them. + X <- cbind(1, xy[, 1] / 1000, (xy[, 2] / 1000)^2) + stx <- spatialkit:::.sac_structure_test(xy, y, X) + ex <- stats::residuals(stats::lm(y ~ X - 1)) + expect_equal(stx$table$morans_i[stx$table$k == 8L], + (n / sum(W)) * sum(ex * as.numeric(W %*% ex)) / sum(ex^2), tolerance = 1e-10) + momx <- spatialkit:::.morans_residual_moments(W, X, sum(W), inherits(W, "Matrix")) + expect_lt(momx$EI, mom$EI) # residuals are pushed below -1/(n-1) + expect_equal(stx$table$z[stx$table$k == 8L], + (stx$table$morans_i[stx$table$k == 8L] - momx$EI) / sqrt(momx$VI), + tolerance = 1e-10) +}) + +test_that("repeat visits and a regular grid are tested without error, in any row order", { + skip_if_not_installed("gstat") + set.seed(32); n <- 120 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + xy <- rbind(xy, xy[1:30, ]); y <- rnorm(nrow(xy)) + a <- spatialkit:::.sac_structure_test(xy, y) + expect_true(is.finite(a$p) && a$p >= 0 && a$p <= 1) + g <- as.matrix(expand.grid(x = 1:12, y = 1:12)); storage.mode(g) <- "double" + set.seed(33); yg <- rnorm(nrow(g)) + b <- spatialkit:::.sac_structure_test(g, yg) + expect_true(is.finite(b$p)) + # Ties at the edge of a neighbourhood are shared out, so the order of the + # rows does not decide which tied neighbour counts. + perm <- sample(nrow(g)) + b2 <- spatialkit:::.sac_structure_test(g[perm, ], yg[perm]) + expect_equal(b2$table$morans_i, b$table$morans_i, tolerance = 1e-10) + expect_equal(b2$p, b$p, tolerance = 1e-8) + # Too few points for any neighbourhood: no test, not an error. + expect_null(spatialkit:::.sac_structure_test(xy[1:3, ], y[1:3])) +}) + +test_that("residuals on predictors are judged as residuals", { + skip_if_not_installed("gstat") + # White noise regressed on smooth predictors: no structure is left, and the + # refusal says it is about the residuals. + set.seed(34); n <- 200 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + d <- data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], a = xy[, 1] / 1000, + b = sin(xy[, 2] / 300), z = rnorm(n)) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z", c("a", "b"))) + expect_identical(attr(r, "rejected_reason"), NO_STRUCTURE) + expect_true(attr(r, "detrended")) + expect_true(log_has(lines, "Moran's I of the residuals on predictor_vars")) + # The statistic attached is the one for the OLS residuals on that design. + X <- stats::model.matrix(z ~ a + b, d) + st <- spatialkit:::.sac_structure_test(xy + matrix(c(5e5, 5e6), n, 2, byrow = TRUE), d$z, X) + expect_equal(attr(r, "structure_p"), st$p, tolerance = 1e-8) + # A response whose structure the predictors do not explain keeps its range. + f <- fvs_field(4102) + set.seed(35); f$w <- rnorm(nrow(f)) + rf <- suppressWarnings(estimate_sac_range(f, "z", "w")) + expect_lt(attr(rf, "structure_p"), 0.05) + expect_true(is.finite(rf)) +}) + +test_that("the size of the test is near its level on white noise", { + skip_if_not_installed("gstat") + # 300 layers of 100 points: the share with an adjusted p below 0.05. Over + # 1000 draws it was 0.041 at n = 300 and 0.053 at n = 100. + rej <- vapply(1:300, function(i) { + set.seed(880000 + i) + xy <- cbind(runif(100, 0, 1000), runif(100, 0, 1000)) + spatialkit:::.sac_structure_test(xy, rnorm(100))$p < 0.05 + }, logical(1)) + expect_gte(mean(rej), 0.02) + expect_lte(mean(rej), 0.10) +}) diff --git a/tests/testthat/test-fix-variogram-visits.R b/tests/testthat/test-fix-variogram-visits.R new file mode 100644 index 00000000..e979d4fb --- /dev/null +++ b/tests/testthat/test-fix-variogram-visits.R @@ -0,0 +1,374 @@ +# tests/testthat/test-fix-variogram-visits.R +# --------------------------------------------------------------------------- +# Rows that share a location (repeat visits) are read for what they are. +# +# estimate_sac_range() sorts its rows by coordinates and then by the +# response, so the rows of one location arrive in the order of their values. +# Three steps read meaning into that order or into the rows being neighbours: +# - the REML fit kept "the first" row of each location, which is its +# smallest response: with four visits of unit noise the intercept came +# out 1.04 low and the nugget at 0.41 for a truth of 1; +# - the short-lag semivariance paired each row with the next at its +# location, which pairs neighbouring order statistics: 0.205 for a +# variance between visits of 0.300 at 8 visits a location; +# - the test for spatial structure took the other visits to a location as +# its nearest neighbours, and found "structure" in 40 of 40 layers of +# 100 locations with independent effects, which then got a range (median +# 96 against 47 between locations) and a nugget of 0, because the pairs +# at zero separation were pooled into the first lag bin. +# --------------------------------------------------------------------------- + +# `sites` locations on a 1000 m square, `visits` rows at each. The location +# effect has variance 1 and effective range `R` (independent when R is NULL); +# the variance between visits is `noise`; the mean is `mu`. +fvv_layer <- function(seed, sites = 100L, visits = 5L, R = NULL, noise = 0.3, mu = 0) { + set.seed(seed) + sx <- runif(sites, 0, 1000); sy <- runif(sites, 0, 1000) + eff <- if (is.null(R)) rnorm(sites) else + drop(crossprod(chol(exp(-3 * as.matrix(stats::dist(cbind(sx, sy))) / R) + + diag(1e-8, sites)), rnorm(sites))) + m <- if (length(visits) == 1L) rep(visits, sites) else visits + site <- rep(seq_len(sites), m) + d <- data.frame(x = 5e5 + sx[site], y = 5e6 + sy[site], site = site) + d$w <- rnorm(nrow(d)) + d$z <- mu + eff[site] + rnorm(nrow(d), sd = sqrt(noise)) + d +} +fvv_sf <- function(d) sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + +test_that("the REML fit takes one visit a location at random, not its smallest response", { + skip_if_not_installed("nlme") + rt <- spatialkit:::.reml_trend + b0 <- nug <- numeric(8) + for (i in 1:8) { + d <- fvv_layer(8300 + i, visits = 5L, R = 300, noise = 1, mu = 10) + mf <- data.frame(z = d$z, w = d$w, .sac_x = d$x, .sac_y = d$y) + # The order estimate_sac_range() hands the rows over in: by coordinates, + # then by the response, so each location's smallest response is first. + mf <- mf[order(mf$.sac_x, mf$.sac_y, mf$z), ] + fit <- rt(mf, z ~ w, extent = 1000) + expect_identical(fit$n_used, 100L) + expect_identical(fit$n_colocated, 400L) + b0[i] <- fit$beta[["(Intercept)"]] + nug[i] <- fit$sigma2 * fit$nugget_prop + if (i <= 2L) { + # The same rows in any order give the same fit: the rows are put in a + # fixed order before one is drawn at each location. + set.seed(i); perm <- sample(nrow(mf)) + again <- rt(mf[perm, ], z ~ w, extent = 1000) + expect_identical(again$beta, fit$beta) + expect_identical(again$range, fit$range) + # Another seed draws other visits. + other <- rt(mf, z ~ w, extent = 1000, seed = 7L) + expect_false(isTRUE(all.equal(other$beta, fit$beta))) + } + } + # The intercept is 10: the eight fits average 9.93. The smallest of five + # visits of unit noise lies 1.16 below its location's level, and fits to + # those average 8.81. + expect_gt(mean(b0), 9.6) + expect_lt(mean(b0), 10.4) + # The nugget is the variance between visits, 1. A single fit of 100 + # locations places it anywhere from 0 to 1.4; the eight average 0.74, + # against 0.39 for fits to the minima (a fit to the means of five visits + # would aim at a fifth). + expect_gt(mean(nug), 0.55) +}) + +test_that("a layer with no repeated location gets the REML subsample it always got", { + skip_if_not_installed("nlme") + rt <- spatialkit:::.reml_trend + set.seed(77); n <- 90 + mf <- data.frame(.sac_x = runif(n, 0, 1000), .sac_y = runif(n, 0, 1000), w = rnorm(n)) + mf$z <- 2 + 0.5 * mf$w + rnorm(n) + set.seed(5); before <- runif(1) + set.seed(5); fit <- rt(mf, z ~ w, extent = 1000, max_n = 60L); after <- runif(1) + expect_identical(after, before) # the caller's stream is untouched + expect_identical(fit$n_used, 60L) + expect_identical(fit$n_colocated, 0L) + expect_true(fit$subsampled) + # The rows the fit used are those of a seeded draw over the sorted rows. + srt <- mf[order(mf$.sac_x, mf$.sac_y, mf$w, mf$z), ] + set.seed(123); idx <- sample.int(n, 60L) + D <- as.matrix(stats::dist(srt[idx, c(".sac_x", ".sac_y")])) + expect_equal(fit$pair_floor, sort(D[upper.tri(D)])[30]) +}) + +test_that("estimate_sac_range(detrend = 'reml') on repeat visits fits the locations, and says so", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + d <- fvv_layer(8101, sites = 120L, visits = 4L, R = 300, noise = 1, mu = 10) + d$z <- d$z + 0.5 * d$w + set.seed(3); d <- d[sample(nrow(d)), ] + lines <- capture_spatialkit_log( + r <- suppressWarnings(estimate_sac_range(fvv_sf(d), "z", "w", detrend = "reml", + structure_alpha = 1))) + expect_identical(attr(r, "detrend_method"), "reml") + expect_identical(attr(r, "reml")$n_used, 120L) + expect_identical(attr(r, "n_used"), 480L) # every row is detrended and binned + expect_true(log_has(lines, "120 location\\(s\\) have more than one row")) + expect_true(log_has(lines, "one row a location, drawn at random under `seed` \\(120 of 480")) + # The fit behind it is .reml_trend()'s on those rows: the draw is made on + # the rows in their sorted order, whatever order they came in. + mf <- data.frame(z = d$z, w = d$w, .sac_x = d$x, .sac_y = d$y) + direct <- spatialkit:::.reml_trend( + mf, z ~ w, extent = max(diff(range(d$x)), diff(range(d$y)))) + expect_equal(attr(r, "reml")$sigma2, direct$sigma2, tolerance = 1e-6) + expect_equal(attr(r, "reml")$nugget_prop, direct$nugget_prop, tolerance = 1e-6) + expect_equal(attr(r, "reml")$logLik, direct$logLik, tolerance = 1e-6) +}) + +test_that("the semivariance at zero separation is the variance between visits, from every pair", { + skip_if_not_installed("gstat") + for (v in c(2L, 5L, 8L)) { + d <- fvv_layer(9900 + v, visits = v) + r <- suppressWarnings(estimate_sac_range(fvv_sf(d), "z")) + within <- mean(tapply(d$z, d$site, stats::var)) + # With as many visits at every location, the mean over all pairs of rows + # at one location is the mean of the locations' variances, exactly. + expect_equal(attr(r, "zero_lag_semivariance"), within, tolerance = 1e-10) + expect_identical(attr(r, "zero_lag_pairs"), as.integer(100 * v * (v - 1) / 2)) + # It was 0.3 by construction: within sampling error of it, not short of + # it as the order-statistic pairs were. + expect_lt(abs(attr(r, "zero_lag_semivariance") - 0.3), 0.08) + # The nearest-neighbour pairs are between locations: one pair for each + # location and its nearest, counted once, at a positive separation. + expect_lte(attr(r, "short_lag_pairs"), 100L) + expect_gte(attr(r, "short_lag_pairs"), 50L) + expect_gt(attr(r, "short_lag_dist"), 0) + # They carry the variation between locations as well, so they bound the + # zero-lag value from above. + expect_gt(attr(r, "short_lag_semivariance"), attr(r, "zero_lag_semivariance")) + } + # A layer with no repeated location has no such pairs. + one <- suppressWarnings(estimate_sac_range(fvv_sf(fvv_layer(9911, visits = 1L, R = 300)), "z")) + expect_identical(attr(one, "zero_lag_pairs"), 0L) + expect_true(is.na(attr(one, "zero_lag_semivariance"))) +}) + +test_that(".sac_short_lag() matches its definition with unequal numbers of visits", { + set.seed(21); sites <- 25L + m <- sample(1:4, sites, replace = TRUE) + d <- fvv_layer(22, sites = sites, visits = m) + xy <- cbind(d$x, d$y); v <- d$z + got <- spatialkit:::.sac_short_lag(xy, v) + # Zero separation: every pair of rows at one location. + D <- as.matrix(stats::dist(xy)); ut <- upper.tri(D) + half <- outer(v, v, "-")^2 / 2 + expect_identical(got$zero_pairs, sum(ut & D == 0)) + expect_equal(got$zero_gamma, mean(half[ut & D == 0])) + expect_equal(got$zero_ss, sum(half[ut & D == 0])) + # Nearest neighbours: each location and its nearest other location, each + # such pair once; every pairing of their rows, the pair of locations + # weighing one. + sxy <- unique(xy); S <- as.matrix(stats::dist(sxy)); diag(S) <- Inf + nn <- apply(S, 1, which.min) + pr <- unique(t(apply(cbind(seq_len(nrow(sxy)), nn), 1, sort))) + key <- function(a) paste(a[, 1], a[, 2]) + loc <- match(key(xy), key(sxy)) + g <- vapply(seq_len(nrow(pr)), function(k) + mean(half[loc == pr[k, 1], loc == pr[k, 2]]), numeric(1)) + expect_equal(got$gamma, mean(g)) + expect_identical(got$pairs, nrow(pr)) + expect_equal(got$dist, stats::median(S[pr])) + # The order of the rows changes nothing: in particular, sorting the rows + # of each location by their value does not. + o <- order(xy[, 1], xy[, 2], v) + srt <- spatialkit:::.sac_short_lag(xy[o, ], v[o]) + expect_equal(srt[c("gamma", "zero_gamma")], got[c("gamma", "zero_gamma")]) + expect_identical(srt[c("pairs", "zero_pairs")], got[c("pairs", "zero_pairs")]) + # One location: nothing at a positive separation, the visits still count. + one <- spatialkit:::.sac_short_lag(cbind(rep(1, 4), rep(2, 4)), c(1, 2, 4, 7)) + expect_true(is.na(one$gamma)); expect_identical(one$pairs, 0L) + expect_identical(one$zero_pairs, 6L) + expect_equal(one$zero_gamma, stats::var(c(1, 2, 4, 7))) +}) + +test_that("pairs at zero separation are in no bin of the variogram", { + skip_if_not_installed("gstat") + d <- fvv_layer(9905, sites = 80L, visits = 4L, R = 300) + r <- suppressWarnings(estimate_sac_range(fvv_sf(d), "z", lags = "equal", n_lags = 10, + structure_alpha = 1)) + vg <- attr(r, "variogram") + # The variogram by hand, over pairs at a positive separation only. + D <- as.matrix(stats::dist(cbind(d$x, d$y))); ut <- upper.tri(D) + half <- outer(d$z, d$z, "-")^2 / 2 + b <- attr(r, "lag_boundaries") + lo <- c(0, b[-length(b)]) + hand <- t(vapply(seq_along(b), function(i) { + k <- ut & D > lo[i] & D <= b[i] + c(sum(k), mean(D[k]), mean(half[k])) + }, numeric(3))) + expect_equal(vg$np, hand[, 1]) + expect_equal(vg$dist, hand[, 2], tolerance = 1e-8) + expect_equal(vg$gamma, hand[, 3], tolerance = 1e-8) + # 480 pairs of visits were at zero separation; gstat puts them in the + # first bin, where they pulled its mean distance and semivariance down. + expect_identical(attr(r, "zero_lag_pairs"), 480L) + expect_equal(attr(r, "first_lag"), hand[1, 2], tolerance = 1e-8) + # The same holds for each direction, and for the adaptive bins. + ra <- suppressWarnings(estimate_sac_range(fvv_sf(d), "z", structure_alpha = 1, + keep_directional_fits = TRUE)) + va <- attr(ra, "variogram") + expect_equal(sum(va$np), sum(ut & D > 0 & D <= attr(ra, "cutoff_dist"))) + expect_gt(min(va$dist), min(D[ut & D > 0]) - 1e-9) + for (az in names(attr(ra, "directional_fits"))) { + vd <- attr(ra, "directional_fits")[[az]]$variogram + if (!is.null(vd)) expect_gt(min(vd$dist), min(D[ut & D > 0]) - 1e-9) + } +}) + +test_that(".sac_drop_zero_lag() takes the pairs out of the first row and leaves the rest", { + f <- spatialkit:::.sac_drop_zero_lag + vg <- data.frame(np = c(100, 50), dist = c(6, 20), gamma = c(0.7, 1.2)) + # 40 pairs at zero separation with half squared differences summing to 12 + # (a semivariance of 0.3): the 60 others sit at 10 with semivariance 29/30. + out <- f(vg, zero_pairs = 40, zero_ss = 12, first_bound = 15) + expect_equal(out$np, c(60, 50)) + expect_equal(out$dist, c(10, 20)) + expect_equal(out$gamma, c((70 - 12) / 60, 1.2)) + # Nothing to take out. + expect_identical(f(vg, 0L, 0, 15), vg) + # A first row with nothing but those pairs goes. + only <- data.frame(np = c(40, 50), dist = c(0, 20), gamma = c(0.3, 1.2)) + expect_equal(f(only, 40, 12, 15)$np, 50) + # A first row that cannot hold them (fewer pairs, or a remainder outside + # the bin or below zero) is left as it is. + expect_identical(f(vg, 400, 12, 15), vg) + expect_identical(f(vg, 40, 12, first_bound = 8), vg) + expect_identical(f(vg, 40, 500, 15), vg) +}) + +test_that("location effects alone are not spatial structure", { + skip_if_not_installed("gstat") + # 100 locations visited 5 times, independent location effects (variance 1) + # and a variance between visits of 0.3. Rows at one location are alike; + # locations near each other are not. + res <- lapply(1:12, function(i) + suppressWarnings(estimate_sac_range(fvv_sf(fvv_layer(9900 + i)), "z"))) + p <- vapply(res, function(r) attr(r, "structure_p"), numeric(1)) + expect_lte(sum(p < 0.05), 2L) # it was 12 of 12 + refused <- vapply(res, function(r) identical( + attr(r, "rejected_reason"), "no spatial structure detected at the nearest-neighbour scale"), + logical(1)) + expect_gte(sum(refused), 10L) + expect_lte(sum(vapply(res, is.finite, logical(1))), 1L) + # The test is the one made on the location means. + d <- fvv_layer(9901) + xy <- cbind(d$x, d$y) + first <- !duplicated(d$site) + on_means <- spatialkit:::.sac_structure_test(xy[first, ], as.numeric(tapply(d$z, d$site, mean))) + on_rows <- spatialkit:::.sac_structure_test(xy, d$z) + expect_equal(on_rows$p, on_means$p, tolerance = 1e-10) + expect_equal(on_rows$table$morans_i, on_means$table$morans_i, tolerance = 1e-10) + expect_identical(on_rows$n_locations, 100L) + expect_equal(attr(res[[1]], "structure_p"), on_means$p, tolerance = 1e-8) + # With a trend's design, the design is averaged over each location too. + X <- cbind(1, d$w) + with_x <- spatialkit:::.sac_structure_test(xy, d$z, X) + Xm <- cbind(1, as.numeric(tapply(d$w, d$site, mean))) + expect_equal(with_x$p, spatialkit:::.sac_structure_test( + xy[first, ], as.numeric(tapply(d$z, d$site, mean)), Xm)$p, tolerance = 1e-10) + # The refusal says what the test was made on. + lines <- capture_spatialkit_log(estimate_sac_range(fvv_sf(d), "z")) + expect_true(log_has(lines, "The 500 rows lie at 100 locations, and the test is made on the location means")) +}) + +test_that("structure between visited locations is still found, with its range", { + skip_if_not_installed("gstat") + # The location effect has an effective range of 300. + res <- lapply(1:6, function(i) + suppressWarnings(estimate_sac_range(fvv_sf(fvv_layer(9950 + i, R = 300)), "z"))) + p <- vapply(res, function(r) attr(r, "structure_p"), numeric(1)) + expect_true(all(p < 0.05)) + rng <- vapply(res, as.numeric, numeric(1)) + # 501, 343, 226, 461 and 343, and one refused as past the lags. + expect_gte(sum(is.finite(rng)), 4L) + expect_gt(stats::median(rng, na.rm = TRUE), 120) + expect_lt(stats::median(rng, na.rm = TRUE), 700) + # The same layer, rows in another order, gives the identical object. + d <- fvv_layer(9951, R = 300) + set.seed(4); perm <- sample(nrow(d)) + expect_identical(suppressWarnings(estimate_sac_range(fvv_sf(d[perm, ]), "z")), res[[1]]) +}) + +test_that("the nugget is not let under the variance between visits", { + skip_if_not_installed("gstat") + # 100 locations visited 5 times, a location effect of range 300 and a + # variance between visits of 0.3. Extrapolated from the positive lags + # alone, the nugget came out under that variance in 22 of 27 fits and + # exactly 0 in 7, while 1000 pairs of visits measure it at 0.28 to 0.32. + res <- lapply(1:8, function(i) + suppressWarnings(estimate_sac_range(fvv_sf(fvv_layer(9950 + i, R = 300)), "z"))) + for (r in res) { + z0 <- attr(r, "zero_lag_semivariance") + expect_identical(attr(r, "nugget_floor"), z0) + expect_gte(sac_nugget(r), z0) + # A nugget on its floor is a measurement, not the zero bound. + expect_identical(attr(r, "nugget_at_bound"), FALSE) + } + nug <- vapply(res, sac_nugget, numeric(1)) + expect_lt(abs(stats::median(nug) - 0.3), 0.08) + # Where the floor holds, the nugget is the floor to the last bit. + on_floor <- vapply(res, function(r) sac_nugget(r) == attr(r, "nugget_floor"), logical(1)) + expect_true(any(on_floor)) + # Fewer than 30 rows beyond one a location: too little to bound with. + d <- fvv_layer(9960, sites = 200L, visits = 1L, R = 300) + few <- rbind(d, d[1:20, ]) + few$z[201:220] <- few$z[201:220] + rnorm(20, sd = 0.5) + rf <- suppressWarnings(estimate_sac_range(fvv_sf(few), "z")) + expect_identical(attr(rf, "zero_lag_pairs"), 20L) + expect_true(is.finite(attr(rf, "zero_lag_semivariance"))) + expect_identical(attr(rf, "nugget_floor"), 0) + # No repeated location: no floor. + expect_identical(attr(suppressWarnings(estimate_sac_range(fvv_sf(d), "z")), "nugget_floor"), 0) +}) + +test_that(".sac_fit_model() and .sac_fit_nested() hold the nugget to a floor exactly", { + skip_if_not_installed("gstat") + fit <- spatialkit:::.sac_fit_model + # A variogram that rises from near zero: nugget 0.02, partial sill 1, + # effective range 200. + h <- c(10, 20, 40, 80, 160, 320, 500) + vg <- data.frame(np = c(60, 120, 300, 800, 2000, 5000, 8000), dist = h, + gamma = 0.02 + (1 - exp(-3 * h / 200))) + free <- fit(vg, cutoff_dist = 500) + expect_equal(free$psill[1], 0.02, tolerance = 1e-6) + expect_equal(3 * free$range[2], 200, tolerance = 1e-5) + # A floor under the fitted nugget changes nothing. + expect_equal(fit(vg, 500, nugget_min = 0.01)$psill, free$psill, tolerance = 1e-10) + # A floor above it holds, to the last bit, and the fit is the best one + # with the nugget there: no better at any other range. + held <- fit(vg, 500, nugget_min = 0.1) + expect_identical(held$psill[1], 0.1) + expect_gt(attr(held, "SSErr"), attr(free, "SSErr")) + sse <- function(r, c1) { + w <- vg$np / (h / 500)^2; w <- w / sum(w) + gbar <- sum(vg$np * vg$gamma) / sum(vg$np) + sum(w * (vg$gamma / gbar - 0.1 / gbar - c1 / gbar * (1 - exp(-3 * h / r)))^2) + } + at <- sse(3 * held$range[2], held$psill[2]) + expect_equal(at, attr(held, "SSErr"), tolerance = 1e-8) + for (r in 3 * held$range[2] * c(0.8, 1.25)) for (c1 in held$psill[2] * c(0.9, 1, 1.1)) + expect_gte(sse(r, c1), at * (1 - 1e-9)) + # A floor above every semivariance leaves the constant at the floor. + flat <- fit(vg, 500, nugget_min = 5) + expect_identical(as.character(flat$model), "Nug") + expect_identical(flat$psill, 5) + # One above the weighted mean (0.37 here, most of the weight being on the + # short lags) and under the long lags: the nugget sits on it, and the + # structure takes what is left. + mid <- fit(vg, 500, nugget_min = 0.5) + expect_identical(mid$psill[1], 0.5) + expect_gt(mid$psill[2], 0) + # The two-structure fit takes the same floor. + nest <- spatialkit:::.sac_fit_nested + g2 <- 0.02 + 0.5 * (1 - exp(-3 * h / 30)) + 0.5 * (1 - exp(-3 * h / 400)) + vg2 <- transform(vg, gamma = g2) + a <- nest(vg2, 500, 30, 400) + expect_equal(a$psill, c(0.02, 0.5, 0.5), tolerance = 1e-6) + b <- nest(vg2, 500, 30, 400, nugget_min = 0.1) + expect_identical(b$psill[1], 0.1) + expect_true(all(b$psill[2:3] > 0)) + expect_equal(nest(vg2, 500, 30, 400, nugget_min = 0.01)$psill, a$psill, tolerance = 1e-10) +}) diff --git a/tests/testthat/test-fold-methods.R b/tests/testthat/test-fold-methods.R index dd660cd0..a10d825c 100644 --- a/tests/testthat/test-fold-methods.R +++ b/tests/testthat/test-fold-methods.R @@ -67,10 +67,16 @@ test_that("every observation appears in exactly one test fold", { test_that("k above the group count degenerates to leave-one-group-out", { pts <- site_points(n_sites = 5, per_site = 4) - f <- make_folds(pts, k = 99, method = "leave_location_out", - group_var = "site", seed = 1) + # Fewer folds than asked used to be a log line only; it is now a warning + # of class spatialkit_k_reduced. + expect_warning( + f <- make_folds(pts, k = 99, method = "leave_location_out", + group_var = "site", seed = 1), + "returning 5 folds, not the k = 99 asked for: `site` has 5 distinct groups", + class = "spatialkit_k_reduced") expect_equal(f$k, 5L) expect_length(f$folds, 5L) + expect_identical(f$params$k_requested, 99L) }) test_that("leave_location_out validates its group column", { @@ -234,19 +240,31 @@ test_that("nndm folds do not depend on the row order of the input", { crs = 3857) gp$..row_id <- seq_len(nrow(gp)) fixtures$grid <- list(pts = gp, grid = nndm_setup()$grid) + # The regular-grid fixture predicts at the sample points themselves, so its + # target distances are 0 and no fold can match them. make_folds() used to + # return plain leave-one-out for it without a word; it now raises a warning + # of class spatialkit_nndm_out_of_reach, which is muffled here because this + # test is about row order (test-fix-folds-nndm-reach.R tests the warning). + reach <- 0L + quiet_reach <- function(expr) withCallingHandlers( + expr, spatialkit_nndm_out_of_reach = function(w) { + reach <<- reach + 1L; invokeRestart("muffleWarning") + }) for (fx in fixtures) { - f0 <- make_folds(fx$pts, method = "nndm", prediction_points = fx$grid, seed = 1) + f0 <- quiet_reach(make_folds(fx$pts, method = "nndm", prediction_points = fx$grid, seed = 1)) for (s in 1:3) { set.seed(100 + s) perm <- sample(nrow(fx$pts)) - f1 <- make_folds(fx$pts[perm, ], method = "nndm", - prediction_points = fx$grid, seed = 1) + f1 <- quiet_reach(make_folds(fx$pts[perm, ], method = "nndm", + prediction_points = fx$grid, seed = 1)) expect_equal(as_sets(f1), as_sets(f0)) expect_equal(f1$params$n_removed_total, f0$params$n_removed_total) expect_equal(sort(f1$params$realised_distances), sort(f0$params$realised_distances), tolerance = 1e-10) } } + # Raised for the grid fixture's four calls and for neither two-cluster one. + expect_identical(reach, 4L) }) test_that("the realised distance distribution is never more optimistic than the target", { diff --git a/tests/testthat/test-fold-separation.R b/tests/testthat/test-fold-separation.R index 41ff1ad8..f90ca79c 100644 --- a/tests/testthat/test-fold-separation.R +++ b/tests/testthat/test-fold-separation.R @@ -46,22 +46,31 @@ test_that("the distances are the real nearest-training distances", { expect_equal(s$median_dist[1], stats::median(d)) }) -test_that("a supplied range gives the share of the hold-out inside it", { +test_that("a supplied range gives the correlation-weighted share of the hold-out", { pts <- make_pts() f <- make_folds(pts, k = 4, method = "random_kfold", seed = 1) s <- fold_separation(f, pts, sac = 200) - expect_false(any(is.na(s$within_range))) - expect_true(all(s$within_range >= 0 & s$within_range <= 1)) + expect_false(any(is.na(s$mean_cor))) + expect_true(all(s$mean_cor >= 0 & s$mean_cor <= 1)) # On random folds over a 1000-unit square, every held-out point has a - # training neighbour far closer than 200 units. - expect_equal(unique(s$within_range), 1) + # training neighbour far closer than 200 units. The column used to count + # each such point as 1, so it read exactly 1 for every fold whatever the + # distances were; it is now the mean of exp(-3 d / range), which weighs a + # point by how close its nearest training point is. + xy <- sf::st_coordinates(pts) + te <- f$folds[[1]]$test; tr <- f$folds[[1]]$train + d <- apply(xy[te, , drop = FALSE], 1L, function(p) + min(sqrt((xy[tr, 1] - p[1])^2 + (xy[tr, 2] - p[2])^2))) + expect_true(all(d < 200)) + expect_equal(s$mean_cor[1], mean(exp(-3 * d / 200))) + expect_true(all(s$mean_cor > 0.3 & s$mean_cor < 1)) # Without a range the column is present but empty, and the print method # then omits it rather than showing a column of NAs. s0 <- fold_separation(f, pts) - expect_true(all(is.na(s0$within_range))) - expect_false(grepl("within_range", paste(utils::capture.output(print(s0)), + expect_true(all(is.na(s0$mean_cor))) + expect_false(grepl("mean_cor", paste(utils::capture.output(print(s0)), collapse = " "))) - expect_true(grepl("within_range", paste(utils::capture.output(print(s)), + expect_true(grepl("mean_cor", paste(utils::capture.output(print(s)), collapse = " "))) }) @@ -109,7 +118,9 @@ test_that("print() survives folds with nothing measurable in them", { # before matching or the pattern depends on where the line happened to break. flatten <- function(x) gsub("\\s+", " ", paste(x, collapse = " ")) flat1 <- flatten(out1) - expect_match(flat1, "closer to a training point") + # The summary line. It was "N% of held-out points sit closer to a training + # point than the correlation range", the count that carried the verdict. + expect_match(flat1, "Held-out points sit a median of .* from their nearest training point") expect_true(any(grepl("\\bNA\\b", out1))) # rendered NA, not "NA%" expect_false(any(grepl("NA%", out1, fixed = TRUE))) @@ -121,7 +132,7 @@ test_that("print() survives folds with nothing measurable in them", { for (j in seq_along(fa$folds)) fa$folds[[j]]$test <- integer(0) flat2 <- flatten(utils::capture.output(print(fold_separation(fa, pts, sac = 50)))) expect_match(flat2, "no separation to report") - expect_no_match(flat2, "closer to a training point") + expect_no_match(flat2, "from their nearest training point") }) test_that("a lon/lat layer is measured in projected units, not degrees", { diff --git a/tests/testthat/test-followups-cp-seeds-clip-nndm.R b/tests/testthat/test-followups-cp-seeds-clip-nndm.R index 62a99cf5..a28d5fb5 100644 --- a/tests/testthat/test-followups-cp-seeds-clip-nndm.R +++ b/tests/testthat/test-followups-cp-seeds-clip-nndm.R @@ -95,11 +95,16 @@ test_that("select_resolution() carries the centres of the partition it scored", test_that("get_voronoi_seeds() and voronoi_seeds_kmeans() return the scored centres", { d <- .fx_pts() p <- suppressWarnings(suppressMessages( - resolution_profile(d, "z", sac = 400, n_levels = 6, nstart = 5))) + resolution_profile(d, "z", sac = 400, n_levels = 6, nstart = 5, estimate = NULL, + obs_per_cell = NULL, partition = "kmeans"))) sel <- select_resolution(p, "cp") cen <- attr(p, "centres")[[as.character(sel$best)]] - s1 <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = d) + # Cp's optimum on this smooth field is the support ceiling, which each of + # these calls now says with a warning of class spatialkit_bound_chosen. + expect_warning(s1 <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = d, + partition = "kmeans"), + class = "spatialkit_bound_chosen") expect_equal(unname(sf::st_coordinates(s1)[, 1:2]), cen) expect_identical(s1$method, rep("kmeans", nrow(s1))) expect_match(attr(s1, "n_from"), "select_resolution\\(criterion = \"cp\"\\)") @@ -114,16 +119,21 @@ test_that("get_voronoi_seeds() and voronoi_seeds_kmeans() return the scored cent means <- cbind(tapply(xy[, 1], km$cluster, mean), tapply(xy[, 2], km$cluster, mean)) expect_equal(unname(means), cen, tolerance = 1e-8) - # The same from the profile itself, which is read at its default criterion. - s2 <- get_voronoi_seeds(method = "kmeans", n = p, sample_points = d) + # The same from the profile itself, which is read by Cp: it has no estimate. + expect_warning(s2 <- get_voronoi_seeds(method = "kmeans", n = p, sample_points = d, + partition = "kmeans"), + class = "spatialkit_bound_chosen") expect_equal(unname(sf::st_coordinates(s2)[, 1:2]), - unname(sf::st_coordinates(select_resolution(p)$seeds)[, 1:2])) + unname(sf::st_coordinates(select_resolution(p, criterion = "cp")$seeds)[, 1:2])) # voronoi_seeds_kmeans() takes the selection too, and returns the seeds in # the points' CRS. - s3 <- voronoi_seeds_kmeans(d, k = sel) + expect_warning(s3 <- voronoi_seeds_kmeans(d, k = sel, partition = "kmeans"), + class = "spatialkit_bound_chosen") expect_equal(unname(sf::st_coordinates(s3)[, 1:2]), cen) - s4 <- voronoi_seeds_kmeans(sf::st_transform(d, 4326), k = sel) + expect_warning(s4 <- voronoi_seeds_kmeans(sf::st_transform(d, 4326), k = sel, + partition = "kmeans"), + class = "spatialkit_bound_chosen") expect_identical(sf::st_crs(s4)$epsg, 4326L) expect_equal(unname(sf::st_coordinates(sf::st_transform(s4, 32632))[, 1:2]), cen, tolerance = 1e-6) @@ -139,10 +149,14 @@ test_that("a count as a number, or a selection without seeds, still runs a k-mea expect_false(is.na(attr(fresh, "kmeans")$iter)) old <- sel old$seeds <- NULL # a selection made before seeds were kept - s <- get_voronoi_seeds(method = "kmeans", n = old, sample_points = d, set_seed = 1) + # (The selection sits at the support ceiling: a classed warning now.) + expect_warning( + s <- get_voronoi_seeds(method = "kmeans", n = old, sample_points = d, set_seed = 1), + class = "spatialkit_bound_chosen") expect_false(is.na(attr(s, "kmeans")$iter)) expect_identical(nrow(s), as.integer(sel$best)) - expect_identical(nrow(voronoi_seeds_kmeans(d, k = old)), as.integer(sel$best)) + expect_warning(s_km <- voronoi_seeds_kmeans(d, k = old), class = "spatialkit_bound_chosen") + expect_identical(nrow(s_km), as.integer(sel$best)) }) diff --git a/tests/testthat/test-gwr-bandwidth.R b/tests/testthat/test-gwr-bandwidth.R index 14c8bcd6..993ac037 100644 --- a/tests/testthat/test-gwr-bandwidth.R +++ b/tests/testthat/test-gwr-bandwidth.R @@ -122,7 +122,6 @@ test_that("fit_gwr_model fits a two-valued NON-INTEGER response with a warning", # family = "binomial" was nonsense for such values. The same guard runs once # per fold inside cv_gwr(), where a small training fold can legitimately hold # only two distinct values, so a hard stop there aborted whole CV runs. - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") censored <- .gwr2v_points(c(0.0031, 12.7401)) @@ -147,17 +146,45 @@ test_that("fit_gwr_model fits a two-valued NON-INTEGER response with a warning", "family = 'binomial'") }) -test_that("the two-valued response guard sits behind the GWmodel requirement", { - # Dependency-free companion to the skipped test above, and the reason it has - # to skip: fit_gwr_model() checks for its backend BEFORE it looks at the - # response, so nothing about the response can be observed without GWmodel. - # Both response shapes therefore produce the same missing-backend error, and - # neither the warning nor the binary stop is reachable on this install. - skip_if(requireNamespace("GWmodel", quietly = TRUE), - "GWmodel is installed, so the backend check passes") - - for (z in list(c(0.0031, 12.7401), c(0, 1), c(1.5, 2.5, 3.5))) { - expect_error(fit_gwr_model(.gwr2v_points(z), "z", "a", bandwidth = 60), - "package 'GWmodel' is required") +test_that("no function of the package requires or calls GWmodel", { + # fit_gwr_model(), predict(), cv_gwr() and gwr_model_selection() used to + # stop with "package 'GWmodel' is required" before looking at anything + # else, and this test asserted that the two-valued response guard above + # could not be reached without it. The local regressions, the bandwidth + # search and the sweep are the package's own now, so the requirement + # guarded nothing and is gone: GWmodel is in Suggests for the tests that + # compare against it. Checked on the code itself, so that it holds on a + # machine where GWmodel is installed: no function body holds a + # `GWmodel::` call or asks for the namespace. (Messages that name a + # GWmodel function as advice are strings, not calls.) + ns <- asNamespace("spatialkit") + uses_gwmodel <- function(e) { + if (is.call(e) && is.symbol(e[[1L]])) { + fn <- as.character(e[[1L]]) + if (fn %in% c("::", ":::") && identical(as.character(e[[2L]]), "GWmodel")) + return(TRUE) + if (fn %in% c("requireNamespace", "loadNamespace", "library", "require", + "asNamespace", "getNamespace", "getExportedValue") && + length(e) >= 2L && identical(e[[2L]], "GWmodel")) + return(TRUE) + } + if (is.call(e) || is.pairlist(e) || is.list(e) || is.expression(e)) + for (i in seq_along(e)) + # An empty argument (x[, 1]) is the empty symbol; there is nothing in it. + if (!identical(e[[i]], quote(expr = )) && uses_gwmodel(e[[i]])) return(TRUE) + FALSE } + nms <- ls(ns, all.names = TRUE) + hits <- nms[vapply(nms, function(nm) { + f <- get(nm, envir = ns) + is.function(f) && !is.primitive(f) && + (uses_gwmodel(body(f)) || uses_gwmodel(as.list(formals(f)))) + }, logical(1))] + expect_identical(hits, character(0)) + # The check finds what it looks for. + expect_true(uses_gwmodel(quote(GWmodel::bw.gwr(f, data = d)))) + expect_true(uses_gwmodel(quote(if (!requireNamespace("GWmodel", quietly = TRUE)) stop("x")))) + expect_false(uses_gwmodel(quote(stop("use GWmodel::ggwr.basic()")))) + # And GWR is offered wherever sp is. + expect_identical(.model_available("GWR"), requireNamespace("sp", quietly = TRUE)) }) diff --git a/tests/testthat/test-gwr-local-collinearity.R b/tests/testthat/test-gwr-local-collinearity.R index bf356abe..60cc9fd9 100644 --- a/tests/testthat/test-gwr-local-collinearity.R +++ b/tests/testthat/test-gwr-local-collinearity.R @@ -78,7 +78,7 @@ test_that("the survey is the weighted condition index at every location", { }) test_that("fit_gwr_model() keeps the survey and the global index on the fit", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") pts <- lc_points() fit <- suppressWarnings(suppressMessages( fit_gwr_model(pts, "z", c("a", "b"), adaptive = TRUE, bandwidth = 60))) @@ -112,7 +112,7 @@ test_that("fit_gwr_model() keeps the survey and the global index on the fit", { }) test_that("the collinearity warning is the exact fraction, and quiet when there is nothing", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") d <- lc_clusters() # Every warning raised while evaluating `expr`, muffled; the value comes # back beside them, so a fit that fails is a test failure rather than a @@ -134,7 +134,7 @@ test_that("the collinearity warning is the exact fraction, and quiet when there }) test_that("the coefficient map draws the local coefficient and masks collinear windows", { - skip_if_not_installed("ggplot2"); skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("ggplot2"); skip_if_not_installed("sp") pts <- lc_points() fit <- suppressWarnings(suppressMessages( fit_gwr_model(pts, "z", c("a", "b"), adaptive = TRUE, bandwidth = 60))) diff --git a/tests/testthat/test-gwr-model-selection.R b/tests/testthat/test-gwr-model-selection.R index 44e00514..efbdb706 100644 --- a/tests/testthat/test-gwr-model-selection.R +++ b/tests/testthat/test-gwr-model-selection.R @@ -388,7 +388,6 @@ test_that("print.gwr_model_selection shows the ranking and states the caveats", # --- GWmodel-gated integration ---------------------------------------------- test_that("gwr_model_selection reads GWmodel's criterion with the right orientation", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") set.seed(42) @@ -403,8 +402,11 @@ test_that("gwr_model_selection reads GWmodel's criterion with the right orientat sel <- gwr_model_selection(dat, "z", c("a", "b", "noise"), bandwidth = 40) expect_s3_class(sel, "gwr_model_selection") - expect_identical(nrow(sel$table), 6L) # 3 + 2 + 1 - expect_identical(sel$table$rank, 1:6) + # 3 + 2 + 1 models of the forward sweep, and the model without predictors. + expect_identical(nrow(sel$table), 7L) + expect_identical(sel$table$rank, 1:7) + expect_identical(sum(sel$table$variables == ""), 1L) + expect_identical(nrow(sel$raw[[2]]), 6L) expect_false(is.unsorted(sel$table$criterion, na.rm = TRUE)) expect_identical(sel$bandwidth, 40L) expect_true(all(sel$best %in% c("a", "b", "noise"))) @@ -423,7 +425,6 @@ test_that("gwr_model_selection reads GWmodel's criterion with the right orientat }) test_that("gwr_model_selection selects a bandwidth when none is supplied", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") set.seed(7) @@ -436,8 +437,10 @@ test_that("gwr_model_selection selects a bandwidth when none is supplied", { dat$z <- 3 * dat$a + rnorm(n, 0, 0.3) sel <- gwr_model_selection(dat, "z", c("a", "b")) - expect_identical(nrow(sel$table), 3L) # 2 + 1 - expect_match(sel$bandwidth_source, "bw\\.gwr") + expect_identical(nrow(sel$table), 4L) # 2 + 1, and + # The package's own search, on the model with every candidate. + expect_identical(sel$bandwidth_source, "AICc search on the full model") + expect_s3_class(sel$bandwidth_search$curve, "data.frame") expect_true(is.finite(sel$bandwidth)) expect_gte(sel$bandwidth, 5L) # bisquare floor, n_cand + 3 expect_lte(sel$bandwidth, 60L) @@ -445,7 +448,6 @@ test_that("gwr_model_selection selects a bandwidth when none is supplied", { }) test_that("gwr_model_selection silences GWmodel's cat() progress unless asked", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") set.seed(9) diff --git a/tests/testthat/test-kriging-adequacy.R b/tests/testthat/test-kriging-adequacy.R index c163590a..5f679688 100644 --- a/tests/testthat/test-kriging-adequacy.R +++ b/tests/testthat/test-kriging-adequacy.R @@ -30,8 +30,11 @@ test_that("the diagnostics are computed per cell and the CV statistic is near 1 expect_s3_class(ka, "sf") expect_equal(nrow(ka), nrow(cells)) df <- sf::st_drop_geometry(ka) - expect_true(all(c("poly_id", "n", "mean", "se", "kr_pred", "kr_var", "kr_ratio", - "kr_exceeds_design", "kr_shift") %in% names(df))) + expect_true(all(c("poly_id", "n", "mean", "se", "plain_var", "kr_pred", "kr_var", + "kr_ratio", "kr_gain", "kr_shift") %in% names(df))) + # The comparison of kr_var with s^2/n is no longer returned: it was read as + # marking cells where kriging does not pay, and moved with the sill. + expect_false("kr_exceeds_design" %in% names(df)) expect_equal(sum(df$n), nrow(pts)) expect_true(all(is.finite(df$kr_pred))) expect_true(all(df$kr_var >= 0)) @@ -42,8 +45,13 @@ test_that("the diagnostics are computed per cell and the CV statistic is near 1 sm <- summarize_by_cell(asg, response_var = "z") expect_equal(df$mean[match(sm$poly_id, df$poly_id)], sm$resp_mean_z) expect_equal(df$se[match(sm$poly_id, df$poly_id)], sm$..se_resp_z) - expect_equal(df$kr_exceeds_design, df$kr_var > df$se^2) - expect_equal(df$kr_shift, (df$kr_pred - df$mean) / df$se) + # Kriging is set against the plain mean on the same variogram: the kriging + # variance never exceeds the plain mean's, and the shift is standardised by + # the standard deviation the model gives the difference (it was divided by + # the naive s / sqrt(n)). + expect_true(all(df$kr_var <= df$plain_var)) + expect_equal(df$kr_gain, 1 - df$kr_var / df$plain_var) + expect_equal(df$kr_shift, (df$kr_pred - df$mean) / sqrt(df$plain_var - df$kr_var)) # The kriged estimate is the block-kriging prediction gstat returns. bk <- gstat::krige(z ~ 1, locations = pts, newdata = cells, model = attr(ka_true_sac(), "variogram_model"), nmax = 50, @@ -60,7 +68,7 @@ test_that("the diagnostics are computed per cell and the CV statistic is near 1 expect_output(print(ka), "var of standardised error") }) -test_that("empty and one-point cells get a kriged estimate and NA design comparisons", { +test_that("empty cells get a kriged estimate and no comparison with a plain mean; one-point cells get both", { skip_if_not_installed("gstat") pts <- ka_field(n = 60, seed = 2) cells <- create_grid_polygons(ka_bnd, target_cells = 64, type = "square") @@ -69,8 +77,15 @@ test_that("empty and one-point cells get a kriged estimate and NA design compari df <- sf::st_drop_geometry(ka) expect_gt(sum(df$n == 0L), 0L) expect_true(all(is.finite(df$kr_pred[df$n == 0L]))) - expect_true(all(is.na(df$kr_exceeds_design[df$n < 2L]))) - expect_true(all(is.na(df$kr_shift[df$n < 2L]))) + # s^2 needs two points; the plain mean's variance under the variogram needs + # one, so a one-point cell has a gain and a shift (both were NA below two + # points when the shift was in units of s / sqrt(n)). + expect_true(all(is.na(df$se[df$n < 2L]))) + expect_true(all(is.na(df$plain_var[df$n == 0L]) & is.na(df$kr_gain[df$n == 0L]) & + is.na(df$kr_shift[df$n == 0L]))) + expect_gt(sum(df$n == 1L), 0L) + expect_true(all(is.finite(df$kr_gain[df$n == 1L]) & is.finite(df$kr_shift[df$n == 1L]))) + expect_true(all(df$kr_var[df$n >= 1L] <= df$plain_var[df$n >= 1L])) expect_true(all(is.na(df$mean[df$n == 0L]))) # Empty cells are worse determined than full ones. expect_gt(mean(df$kr_ratio[df$n == 0L]), mean(df$kr_ratio[df$n >= 3L])) @@ -248,10 +263,17 @@ test_that("repeat visits to a station are kriged from their means instead of com expect_equal(attr(ka, "n_locations"), 80L) expect_equal(attr(ka, "cv")$n_pred, 80L) expect_true(is.finite(attr(ka, "cv")$zscore_var)) - # With the whole nugget differing between visits, kriging the 80 means is - # kriging all 240 visits with the nugget as their measurement error. + # The visits differ by more than the nugget has room for, so the replicate + # variance is the measurement error (it was capped at the nugget, 0.2, and + # this test pinned the cap): kriging the 80 means is kriging all 240 visits + # with their pooled within-station variance as the error of each. + d <- sf::st_drop_geometry(asg); xy <- sf::st_coordinates(asg) + st_id <- match(paste(xy[, 1], xy[, 2]), unique(paste(xy[, 1], xy[, 2]))) + sw2 <- sum((d$z - as.numeric(tapply(d$z, st_id, mean))[st_id])^2) / (240 - 80) + expect_gt(sw2, 0.3) + expect_equal(attr(ka, "replicates")$nugget_used, sw2) bk <- gstat::krige(z ~ 1, rv, cells, model = vm[vm$model != "Nug", ], - weights = rep(1 / 0.2, nrow(rv)), debug.level = 0) + weights = rep(1 / sw2, nrow(rv)), debug.level = 0) expect_equal(df$kr_pred, as.numeric(bk$var1.pred), tolerance = 1e-8) expect_equal(df$kr_var, as.numeric(bk$var1.var), tolerance = 1e-8) expect_output(print(ka), "240 points at 80 distinct locations") diff --git a/tests/testthat/test-make-folds-row-ids.R b/tests/testthat/test-make-folds-row-ids.R index 839456ce..4e0a3ac1 100644 --- a/tests/testthat/test-make-folds-row-ids.R +++ b/tests/testthat/test-make-folds-row-ids.R @@ -82,7 +82,9 @@ test_that("auto-generated block folds stay aligned when prep_model_data drops ro data_sf <- sf::st_as_sf(df, coords = c("px", "py"), crs = 32632) data_sf$..row_id <- seq_len(n) - dat_sf <- prep_model_data(data_sf, "y", "x1") + # The drop is said with a classed warning. + expect_warning(dat_sf <- prep_model_data(data_sf, "y", "x1"), + class = "spatialkit_rows_dropped") keep_idx <- dat_sf$..row_id expect_length(keep_idx, n - 2L) expect_false(any(c(3L, 17L) %in% keep_idx)) @@ -169,7 +171,9 @@ test_that("the probe survives dropping rows and reprojection", { # prep_model_data() drops incomplete cases, so the probe must tolerate # missing probe rows rather than treating them as a mismatch. a2 <- a; a2$a[c(2, 5, 11)] <- NA - expect_no_error(cv_rf(a2, "z", "a", folds = folds_a, num_trees = 30, seed = 1)) + expect_warning( + expect_no_error(cv_rf(a2, "z", "a", folds = folds_a, num_trees = 30, seed = 1)), + class = "spatialkit_rows_dropped") # The probe is taken in EPSG:4326, so folds built on geographic input still # match after make_folds()/prep_model_data() project to their own CRS. @@ -272,8 +276,12 @@ test_that("n_folds_attempted counts the folds supplied, and a dropped fold warns a$a[a$..row_id %in% kill] <- NA if (!("..row_id" %in% names(a))) a$..row_id <- seq_len(nrow(a)) a$a[kill] <- NA - expect_warning(cv <- cv_rf(a, "z", "a", folds = f, num_trees = 30, seed = 1), - "dropped before fitting") + # Two warnings: the rows prep_model_data() dropped, and the fold that was + # left with nothing to test on. + expect_warning( + expect_warning(cv <- cv_rf(a, "z", "a", folds = f, num_trees = 30, seed = 1), + "dropped before fitting"), + class = "spatialkit_rows_dropped") expect_equal(cv$n_folds_attempted, 5L) expect_equal(cv$n_folds_succeeded, 4L) }) diff --git a/tests/testthat/test-plotting-diagnostics.R b/tests/testthat/test-plotting-diagnostics.R index 2c05763f..716f2758 100644 --- a/tests/testthat/test-plotting-diagnostics.R +++ b/tests/testthat/test-plotting-diagnostics.R @@ -236,14 +236,21 @@ test_that("plot.resolution_profile draws one panel per criterion with the select expect_s3_class(p, "ggplot") b <- ggplot2::ggplot_build(p) n_panels <- length(unique(b$layout$layout$PANEL)) - drawn <- c("cp", "reliability", "elbow", "moran_z") + # The profile scores the pooled value, so its leave-one-out error is drawn + # as a count criterion beside the present four. + expect_identical(attr(prof, "estimate")$value, "pooled") + drawn <- c("cp", "reliability", "elbow", "loo", "moran_z") drawn <- drawn[vapply(drawn, function(cn) any(is.finite(prof[[cn]])), logical(1))] + expect_true("loo" %in% drawn) expect_equal(n_panels, length(drawn)) - # The chosen points agree with select_resolution(). + # The chosen points agree with select_resolution(). moran_z has a panel + # and no chosen point: it is a diagnostic, which select_resolution() reads + # only when asked. + picked <- setdiff(drawn, "moran_z") geoms <- layer_geoms(p) chosen <- b$data[[which(geoms == "GeomPoint")[length(which(geoms == "GeomPoint"))]]] - expect_equal(nrow(chosen), length(drawn)) - best <- vapply(drawn, function(cn) select_resolution(prof, criterion = cn)$best, integer(1)) + expect_equal(nrow(chosen), length(picked)) + best <- vapply(picked, function(cn) select_resolution(prof, criterion = cn)$best, integer(1)) # The x axis may be log10-scaled (it is when the ladder spans a factor of # 8 or more), in which case the built data carry log10(levels). expect_true(setequal(round(chosen$x, 6), round(best, 6)) || diff --git a/tests/testthat/test-plotting-fits.R b/tests/testthat/test-plotting-fits.R index d4c90c41..dfffdfa3 100644 --- a/tests/testthat/test-plotting-fits.R +++ b/tests/testthat/test-plotting-fits.R @@ -97,8 +97,11 @@ test_that("the residual variogram plot builds", { ".resid")) expect_true(is.na(sac_flat)) expect_s3_class(attr(sac_flat, "variogram"), "data.frame") - expect_match(attr(sac_flat, "rejected_reason"), - "no variogram model|did not converge") + # White noise is refused for want of spatial structure, by a test made + # before any model is looked at. It used to end as "no variogram model" or + # "did not converge", whichever way gstat's fit happened to fail. + expect_identical(attr(sac_flat, "rejected_reason"), + "no spatial structure detected at the nearest-neighbour scale") # response = FALSE: the layer assertions below are about the RESIDUAL # curve alone; the response overlay has its own test file # (test-plotting-diagnostics.R). @@ -111,24 +114,21 @@ test_that("the residual variogram plot builds", { expect_equal("GeomLine" %in% layers2, !is.null(attr(sac_flat, "variogram_model"))) expect_match(p2$labels$subtitle, "^No effective range") - # The all-singular outcome, made deterministic: every fit.variogram() call - # reports a singular model. The NA carries the empirical variogram and no - # model, and the plot says why there is no range. - local_mocked_bindings( - fit.variogram = function(object, model, ...) { - model$psill <- c(0, 0); model$range <- c(0, 1) - attr(model, "singular") <- TRUE - model - }, - .package = "gstat") + # The no-model outcome, made deterministic: the fit reports that no model + # could be fitted. The NA carries the empirical variogram and no model, + # and the plot says why there is no range. The stub replaces + # .sac_fit_model(), the fit estimate_sac_range() makes (it used to replace + # gstat::fit.variogram(), which is no longer called), and the layer is the + # structured one, because white noise is refused before any fit is read. + local_mocked_bindings(.sac_fit_model = function(...) NULL) sac_sing <- suppressWarnings(estimate_sac_range( - sf::st_sf(.resid = residuals(fit_flat), geometry = sf::st_geometry(flat)), + sf::st_sf(.resid = residuals(fit), geometry = sf::st_geometry(pts)), ".resid")) expect_true(is.na(sac_sing)) expect_s3_class(attr(sac_sing, "variogram"), "data.frame") expect_null(attr(sac_sing, "variogram_model")) expect_match(attr(sac_sing, "rejected_reason"), "^no variogram model could be fitted") - p3 <- plot(fit_flat, type = "variogram", response = FALSE) + p3 <- plot(fit, type = "variogram", response = FALSE) expect_no_error(ggplot2::ggplot_build(p3)) layers3 <- vapply(p3$layers, function(l) class(l$geom)[1L], character(1)) expect_true("GeomPoint" %in% layers3) diff --git a/tests/testthat/test-predict-crs-alignment.R b/tests/testthat/test-predict-crs-alignment.R index e663eb26..f23aacfc 100644 --- a/tests/testthat/test-predict-crs-alignment.R +++ b/tests/testthat/test-predict-crs-alignment.R @@ -10,7 +10,6 @@ test_that("predict.gwr_fit aligns newdata CRS to the training CRS", { skip_if_not_installed("sp") - skip_if_not_installed("GWmodel") set.seed(31) n <- 40 diff --git a/tests/testthat/test-predict-na-alignment.R b/tests/testthat/test-predict-na-alignment.R index cad824b9..9f7e7fe8 100644 --- a/tests/testthat/test-predict-na-alignment.R +++ b/tests/testthat/test-predict-na-alignment.R @@ -23,7 +23,8 @@ test_that("prep_model_data drops NA and non-finite rows", { pts$row <- seq_len(5L) # Row 1: ok, Row 2: NA in y, Row 3: ok, Row 4: NA in x1, Row 5: Inf in y - clean <- prep_model_data(pts, "y", "x1", require_response = TRUE) + expect_warning(clean <- prep_model_data(pts, "y", "x1", require_response = TRUE), + class = "spatialkit_rows_dropped") expect_equal(nrow(clean), 2L) expect_equal(clean$row, c(1L, 3L)) @@ -182,7 +183,9 @@ test_that("prep_model_data ignores response NAs when require_response = FALSE (r expect_equal(nrow(result), 3L) # In training mode, only row 3 (no NA in y) should survive. - result_train <- prep_model_data(pts, "y", "x1", require_response = TRUE) + expect_warning( + result_train <- prep_model_data(pts, "y", "x1", require_response = TRUE), + class = "spatialkit_rows_dropped") expect_equal(nrow(result_train), 1L) }) diff --git a/tests/testthat/test-regressions.R b/tests/testthat/test-regressions.R index 55db4bc2..cf9b788c 100644 --- a/tests/testthat/test-regressions.R +++ b/tests/testthat/test-regressions.R @@ -204,12 +204,15 @@ test_that("cv_spatial reports fold labels that match make_folds()", { holed$w[folds$folds[[2]]$test] <- NA # The vanished fold is announced with a real warning, not only a log line. + # So are the rows prep_model_data() dropped, with a class. expect_warning( - res <- suppressMessages( - cv_spatial(holed, "z", "w", - fit_fn = function(tr) lm_spatial_fit(tr, "z", "w"), - folds = folds, seed = 1)), - "dropped before fitting") + expect_warning( + res <- suppressMessages( + cv_spatial(holed, "z", "w", + fit_fn = function(tr) lm_spatial_fit(tr, "z", "w"), + folds = folds, seed = 1)), + "dropped before fitting"), + class = "spatialkit_rows_dropped") expect_equal(sort(unique(res$fold_metrics$fold)), c(1L, 3L, 4L)) expect_equal(sort(unique(res$predictions$fold)), c(1L, 3L, 4L)) diff --git a/tests/testthat/test-resolution-profile.R b/tests/testthat/test-resolution-profile.R index 0034e866..e8d1f64e 100644 --- a/tests/testthat/test-resolution-profile.R +++ b/tests/testthat/test-resolution-profile.R @@ -106,8 +106,11 @@ test_that("determine_optimal_levels reports the restart budget and bumps in its pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], w = rnorm(640)), coords = c("x", "y"), crs = 32632) pts$z <- pts$w + rnorm(640) - out <- determine_optimal_levels(pts, max_levels = 30, response_var = "z", - predictor_vars = "w", criterion = "combined") + # Moran's z takes part in this ranking, and the call says so with a class. + expect_warning( + out <- determine_optimal_levels(pts, max_levels = 30, response_var = "z", + predictor_vars = "w", criterion = "combined"), + class = "spatialkit_diagnostic_ranking") d <- attr(out, "diagnostics") expect_false(is.null(d)) expect_identical(d$nstart, 25L) @@ -165,12 +168,14 @@ test_that(".reliability_at has an interior optimum and the measured shape", { test_that("a geometry-only profile scores the ladder on WSS, elbow and support", { pts <- rp_field(300) - prof <- resolution_profile(pts, n_levels = 8) + prof <- resolution_profile(pts, n_levels = 8, estimate = NULL, obs_per_cell = NULL, + sac = NULL, partition = "kmeans") expect_s3_class(prof, "resolution_profile") expect_s3_class(prof, "data.frame") expect_named(prof, c("levels", "wss", "wss_spread", "elbow", "cell_n_min", "cell_n_median", "cell_diam_median", "rss", "cp", - "moran_i", "moran_z", "reliability")) + "moran_i", "moran_z", "reliability", + "cells_resp", "cell_resp_mean")) b <- attr(prof, "bounds") expect_identical(b$floor, 2L) expect_identical(b$ceiling, 33L) # floor(300 / 9) @@ -195,7 +200,10 @@ test_that("a geometry-only profile scores the ladder on WSS, elbow and support", test_that("a response adds cp, moran_z and reliability, with the floor from the range", { skip_if_not_installed("gstat") pts <- rp_field(500) - prof <- resolution_profile(pts, response_var = "z", predictor_vars = "w", n_levels = 10) + # range_floor = TRUE: the ladder starts at the floor only when asked, since + # the default became FALSE. + prof <- resolution_profile(pts, response_var = "z", predictor_vars = "w", n_levels = 10, + range_floor = TRUE) expect_identical(attr(prof, "variable"), "residuals") vg <- attr(prof, "variogram") expect_false(is.null(vg)) @@ -246,8 +254,10 @@ test_that("a floor above the ceiling is reported as a finding, not resolved sile stringsAsFactors = FALSE) sac <- structure(120, class = c("sac_range", "numeric"), variogram_model = vm, crs = sf::st_crs(pts)) - lines <- capture_spatialkit_log( - prof <- resolution_profile(pts, response_var = "z", sac = sac, n_levels = 5)) + # An R warning with a class as well as a log line. + lines <- capture_spatialkit_log(expect_warning( + prof <- resolution_profile(pts, response_var = "z", sac = sac, n_levels = 5), + class = "spatialkit_not_supported")) b <- attr(prof, "bounds") expect_false(b$supported) expect_gt(b$floor, b$ceiling) @@ -307,7 +317,10 @@ test_that("resolution_profile is reproducible from its seed and subsamples large test_that("select_resolution reads the optimum and the flat region off each criterion", { skip_if_not_installed("gstat") pts <- rp_field(500) - prof <- resolution_profile(pts, response_var = "z", predictor_vars = "w", n_levels = 10) + # A ladder that starts at the range floor, as the default did when this + # was written: reliability is then read over every level of it. + prof <- resolution_profile(pts, response_var = "z", predictor_vars = "w", n_levels = 10, + range_floor = TRUE) s_cp <- select_resolution(prof, "cp") expect_s3_class(s_cp, "resolution_selection") @@ -331,7 +344,8 @@ test_that("select_resolution reads the optimum and the flat region off each crit s_el <- select_resolution(cl, "elbow") expect_identical(s_el$best, cl$levels[which.max(cl$elbow)]) - s_z <- select_resolution(prof, "moran_z", tol = 0.1) + # moran_z is a diagnostic and is read only when asked for. + s_z <- select_resolution(prof, "moran_z", tol = 0.1, diagnostic = TRUE) ok <- is.finite(prof$moran_z) expect_identical(s_z$best, prof$levels[ok][which.min(abs(prof$moran_z[ok]))]) expect_true(all(s_z$flat %in% prof$levels[ok])) @@ -398,7 +412,11 @@ test_that("summary() puts every criterion's pick in one table", { expect_true(all(c("criterion", "best", "flat_min", "flat_max", "n_flat", "value", "at_floor", "at_ceiling") %in% names(s))) expect_true(nrow(s) >= 1L) - expect_true(all(s$criterion %in% c("cp", "reliability", "elbow", "moran_z"))) + # The profile scores the pooled value, so its leave-one-out error is a + # criterion of the table beside the present four. + expect_identical(attr(prof, "estimate")$value, "pooled") + expect_true("loo" %in% s$criterion) + expect_true(all(s$criterion %in% c("cp", "reliability", "elbow", "moran_z", "loo"))) expect_false(anyDuplicated(s$criterion) > 0L) # Each row has to agree with select_resolution() on the same criterion: @@ -604,10 +622,12 @@ test_that("a band is read as a set everywhere it is reported", { levels = unique(round(exp(seq(log(4), log(60), length.out = 12))))))) expect_true(max(wide$levels) / min(wide$levels) > 8) - # Every criterion the profile scored. The fixture's locations are uniform, - # so its WSS curve has no elbow and `elbow` is NA throughout. + # Every count criterion the profile scored. The fixture's locations are + # uniform, so its WSS curve has no elbow and `elbow` is NA throughout. + # (moran_z is a diagnostic: select_resolution() reads it only when asked, + # and the plot draws its curve with no band.) for (cn in Filter(function(cn) any(is.finite(wide[[cn]])), - c("cp", "reliability", "elbow", "moran_z"))) { + c("cp", "reliability", "elbow"))) { w <- drawn(wide, cn) sw <- select_resolution(wide, cn) expect_identical(nrow(w$rects), @@ -661,7 +681,9 @@ test_that("print() survives every subset `[` produces, and stays inside 80 colum edge$reliability <- seq(0.1, 0.9, length.out = length(lv)) edge$elbow <- seq(0.1, 0.9, length.out = length(lv)) edge$moran_z <- seq(5, 0.1, length.out = length(lv)) - out <- utils::capture.output(print(summary(edge))) + # Named, because moran_z is no longer in the default set. + out <- utils::capture.output(print(summary( + edge, criteria = c("cp", "reliability", "elbow", "moran_z")))) expect_lte(max(nchar(out)), 80L) expect_lte(max(nchar(utils::capture.output(print(s)))), 80L) }) diff --git a/tests/testthat/test-return-accounting.R b/tests/testthat/test-return-accounting.R index cf6781bd..cf71b90b 100644 --- a/tests/testthat/test-return-accounting.R +++ b/tests/testthat/test-return-accounting.R @@ -188,7 +188,12 @@ test_that("prep_model_data() records what it dropped, and why, with the rows' id expect_equal(nrow(out), 4L) dr <- attr(out, "dropped") expect_type(dr, "list") - expect_named(dr, c("n", "n_geometry", "which", "row_id", "reason", "n_rows")) + # by_column, response_std_diff and the two marks on the kept rows were added + # with the classed drop warning; the first five fields and n_rows are as + # they were. + expect_named(dr, c("n", "n_geometry", "which", "row_id", "reason", + "by_column", "response_std_diff", "constant_predictors", + "n_duplicate_locations", "n_rows")) expect_identical(dr$n_rows, 4L) expect_identical(dr$n, 4L) expect_identical(dr$n_geometry, 1L) @@ -299,7 +304,7 @@ test_that("every fit carries n_dropped, and a CV run reports it too", { cv <- suppressMessages(suppressWarnings(cv_rf(d, "a", "z", folds = fo, num_trees = 50))) expect_identical(cv$n_dropped, 3L) expect_identical(cv$n_unknown_ids, 3L) - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") g <- suppressWarnings(suppressMessages(fit_gwr_model(d, "a", "z", adaptive = TRUE, bandwidth = 30))) expect_identical(g$info$n_dropped, 3L) }) @@ -502,20 +507,22 @@ test_that("summarize_by_cell() records the ICCs a Kish request estimated, applie pts$val <- 0.05 * sf::st_coordinates(pts)[, 1] + rnorm(200, sd = 0.5) # structured grid <- create_grid_polygons(ra_bnd, target_cells = 16, type = "square") asg <- assign_features_to_polygons(pts, grid) - sm <- summarize_by_cell(asg, response_var = "val", predictor_vars = "z", deff = "kish") + sm <- summarize_by_cell(asg, response_var = "val", predictor_vars = "z", deff = "kish", + estimate = "mean") icc <- attr(sm, "icc") expect_named(icc, c("resp", "pred")) expect_equal(icc$resp, attr(sm, "deff_applied")$icc_resp) expect_true(is.finite(icc$pred)) # Nothing applied (white-noise response, ICC clamped to 0): no deff_applied, # but the ICC is still on the result. - sm0 <- summarize_by_cell(asg, response_var = "z", deff = "kish") + sm0 <- summarize_by_cell(asg, response_var = "z", deff = "kish", estimate = "mean") expect_null(attr(sm0, "deff_applied")) expect_identical(attr(sm0, "icc"), list(resp = 0, pred = NA_real_)) # Survives the cells_sf join; absent without a Kish request. - smc <- summarize_by_cell(asg, response_var = "z", deff = "kish", cells_sf = grid) + smc <- summarize_by_cell(asg, response_var = "z", deff = "kish", cells_sf = grid, + estimate = "mean") expect_identical(attr(smc, "icc"), list(resp = 0, pred = NA_real_)) - expect_null(attr(summarize_by_cell(asg, response_var = "z"), "icc")) + expect_null(attr(summarize_by_cell(asg, response_var = "z", estimate = "mean"), "icc")) }) test_that("the variogram design effect at the cell row count is kept beside the applied one", { @@ -530,7 +537,7 @@ test_that("the variogram design effect at the cell row count is kept beside the asg <- assign_features_to_polygons(pts, grid) sac <- estimate_sac_range(pts, "z") skip_if(is.na(sac), "no identified range on this draw") - sm <- summarize_by_cell(asg, response_var = "z", deff = "variogram", sac = sac) + sm <- summarize_by_cell(asg, response_var = "z", deff = "variogram", sac = sac, estimate = "mean") da <- attr(sm, "deff_applied") expect_identical(da$method, "variogram") expect_length(da$deff_rows, nrow(sm)) @@ -540,7 +547,8 @@ test_that("the variogram design effect at the cell row count is kept beside the # join to cells_sf realigns both alike (an empty cell gets NA in each). asg2 <- asg; asg2$z[asg2$poly_id == asg2$poly_id[1]][1:2] <- NA smc <- summarize_by_cell(asg2[asg2$poly_id != asg2$poly_id[nrow(asg2)], ], - response_var = "z", deff = "variogram", sac = sac, cells_sf = grid) + response_var = "z", deff = "variogram", sac = sac, cells_sf = grid, + estimate = "mean") dac <- attr(smc, "deff_applied") expect_length(dac$deff_rows, nrow(smc)); expect_length(dac$deff, nrow(smc)) expect_identical(is.na(dac$deff_rows), is.na(dac$deff)) @@ -683,7 +691,7 @@ test_that("residual_morans_i() returns its weights, the kurtosis, the design ran }) test_that("fit_gwr_model() keeps the mask of non-finite local coefficients", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") pts <- surf_test_points(n = 120) pts$v <- rnorm(120) fit <- suppressWarnings(suppressMessages(fit_gwr_model(pts, "z", c("w", "v"), adaptive = TRUE, bandwidth = 40))) @@ -709,8 +717,11 @@ test_that("determine_optimal_levels() reports the elbow and the failed k in its pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], w = rnorm(640)), coords = c("x", "y"), crs = 32632) pts$z <- pts$w + rnorm(640) - out <- determine_optimal_levels(pts, max_levels = 30, response_var = "z", - predictor_vars = "w", criterion = "combined") + # Moran's z takes part in this ranking, and the call says so with a class. + expect_warning( + out <- determine_optimal_levels(pts, max_levels = 30, response_var = "z", + predictor_vars = "w", criterion = "combined"), + class = "spatialkit_diagnostic_ranking") d <- attr(out, "diagnostics") expect_false(is.null(d)) expect_true(is.numeric(d$knee_k) && length(d$knee_k) == 1L) @@ -729,7 +740,11 @@ test_that("build_tessellation() records the points it snapped to a nearest cell" all_pts <- rbind(pts, extra) bnd <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( c(0, 0), c(1000, 0), c(1000, 1000), c(0, 1000), c(0, 0)))), crs = 3857)) - tess <- build_tessellation(all_pts, boundary = bnd, method = "square", approx_n_cells = 16, quiet = TRUE) + # The point well outside is NA in `index`: counted, and warned about. + expect_warning( + tess <- build_tessellation(all_pts, boundary = bnd, method = "square", approx_n_cells = 16, quiet = TRUE), + "1 of 62 point\\(s\\) \\(1.6%\\) fall in no cell", class = "spatialkit_unassigned") + expect_identical(tess$params$n_outside, 1L) sn <- tess$params$snapped expect_named(sn, c("n", "which", "distance")) expect_identical(sn$n, 1L) @@ -762,7 +777,8 @@ test_that("area_of_applicability() returns the scaling and the fence's outlier c test_that("get_voronoi_seeds(kmeans) returns the clustering behind the seeds", { pts <- ra_points(n = 120) - seeds <- get_voronoi_seeds(ra_bnd, method = "kmeans", n = 6, sample_points = pts, set_seed = 1) + seeds <- get_voronoi_seeds(ra_bnd, method = "kmeans", n = 6, sample_points = pts, + set_seed = 1, partition = "kmeans") km <- attr(seeds, "kmeans") expect_named(km, c("cluster", "rows", "size", "withinss", "tot_withinss", "iter", "nstart")) expect_length(km$cluster, 120L) @@ -779,13 +795,15 @@ test_that("get_voronoi_seeds(kmeans) returns the clustering behind the seeds", { # A dropped (empty) point is absent from `rows`. bad <- pts; sf::st_geometry(bad)[5] <- sf::st_sfc(sf::st_point(), crs = 32632) seeds2 <- suppressWarnings(get_voronoi_seeds(ra_bnd, method = "kmeans", n = 6, - sample_points = bad, set_seed = 1)) + sample_points = bad, set_seed = 1, + partition = "kmeans")) expect_identical(attr(seeds2, "kmeans")$rows, setdiff(1:120, 5L)) - expect_null(attr(get_voronoi_seeds(ra_bnd, method = "random", n = 5, set_seed = 1), "kmeans")) + expect_null(attr(get_voronoi_seeds(ra_bnd, method = "random", n = 5, set_seed = 1, + partition = "kmeans"), "kmeans")) }) test_that("gwr_model_selection() says how its criterion column was found", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") pts <- surf_test_points(n = 100) pts$v <- rnorm(100) sel <- suppressWarnings(suppressMessages( diff --git a/tests/testthat/test-review-cv.R b/tests/testthat/test-review-cv.R index 0a2e351e..65157b2f 100644 --- a/tests/testthat/test-review-cv.R +++ b/tests/testthat/test-review-cv.R @@ -28,7 +28,6 @@ test_that("cv_gwr(parallel = 2) returns after a GWR has been fitted in the sessi # here (status 124) instead of hanging the whole suite. skip_on_cran() skip_on_os("windows") - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") skip_if(!nzchar(Sys.which("timeout")), "coreutils `timeout` not found") @@ -66,7 +65,7 @@ test_that("cv_gwr(parallel = 2) returns after a GWR has been fitted in the sessi " w <<- c(w, conditionMessage(x)); invokeRestart('muffleWarning') })", "cat('RESULT', par_res$n_folds_succeeded,", " isTRUE(all.equal(par_res$overall, seq_res$overall)),", - " any(grepl('OpenMP', w)), '\\n')" + " any(grepl('`parallel` is ignored', w, fixed = TRUE)), '\\n')" ), script) rscript <- file.path(R.home("bin"), "Rscript") @@ -94,7 +93,6 @@ test_that("compare_models_cv(gwr_args = list(parallel = 2)) never forks GWR fold # replaced by a stub that errors, so the old code fails here at once # instead of hanging on the GWR fits earlier tests have left in the session. skip_on_os("windows") - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") @@ -110,7 +108,7 @@ test_that("compare_models_cv(gwr_args = list(parallel = 2)) never forks GWR fold res <- suppressMessages( compare_models_cv(d, "price", "elev", models = "GWR", k = 3, seed = 7, quiet = TRUE, gwr_args = list(parallel = 2L))), - "cv_gwr\\(\\): `parallel` is ignored.*OpenMP") + "cv_gwr\\(\\): `parallel` is ignored.*not run in forked workers") expect_identical(res$gwr_cv$n_folds_succeeded, 3L) expect_equal(res$overall, ref$overall) }) @@ -176,6 +174,12 @@ test_that("a fold dropped before fitting is not warned about twice", { fitf <- function(tr) lm_spatial_fit(tr, "z", c("w", "zone")) r <- .rv_warnings(suppressMessages( cv_spatial(d, "z", c("w", "zone"), fit_fn = fitf, folds = d$lab))) + # prep_model_data() now raises its own (classed) warning for the rows it + # drops, once, ahead of the two about folds; it is not a second warning + # about the fold. + is_prep <- grepl("^prep_model_data\\(\\): dropped 3 of ", r$warnings) + expect_identical(sum(is_prep), 1L) + r$warnings <- r$warnings[!is_prep] expect_length(r$warnings, 2L) expect_match(r$warnings[1], "1 of 5 fold\\(s\\) dropped before fitting") expect_match(r$warnings[2], paste0("^cv_spatial\\(\\): 1 of 5 fold\\(s\\) ", @@ -188,6 +192,8 @@ test_that("a fold dropped before fitting is not warned about twice", { r2 <- .rv_warnings(suppressMessages( cv_spatial(d2, "z", "w", fit_fn = function(tr) lm_spatial_fit(tr, "z", "w"), folds = d2$lab))) + r2$warnings <- r2$warnings[!grepl("^prep_model_data\\(\\): dropped ", + r2$warnings)] expect_length(r2$warnings, 1L) expect_match(r2$warnings, "dropped before fitting") }) @@ -251,7 +257,11 @@ test_that("with no null model the rows every step-1 set predicted are the refere "step 1: \\{lc\\}") expect_identical(sel$selected, "a") expect_identical(sel$params$n_scored, 250L) - expect_identical(sel$history$n_pred, c(250L, 192L)) + # A step-0 row leads the history now: the training-fold mean, the baseline + # for a learner that cannot fit an empty set. (This asserted the two + # step-1 rows alone, from when such a learner had no baseline.) + expect_identical(sel$history$step, c(0L, 1L, 1L)) + expect_identical(sel$history$n_pred, c(250L, 250L, 192L)) }) @@ -272,7 +282,6 @@ test_that("compare_models_cv() re-scores the models on the rows they all predict # 150 rows, each of which keeps eight or more training points within reach, # so GWR predicts exactly those rows and RF all 200. skip_if_not_installed("ranger") - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") set.seed(4); n <- 200 xy <- rbind(cbind(runif(150, 0, 600), runif(150, 0, 1000)), diff --git a/tests/testthat/test-review-gwr.R b/tests/testthat/test-review-gwr.R index 03a813aa..0e0d5420 100644 --- a/tests/testthat/test-review-gwr.R +++ b/tests/testthat/test-review-gwr.R @@ -2,7 +2,6 @@ # GWR regressions from the adversarial review. # =========================================================================== -skip_if_not_installed("GWmodel") skip_if_not_installed("sp") diff --git a/tests/testthat/test-review-resolution.R b/tests/testthat/test-review-resolution.R index ba20a141..aa4d64dc 100644 --- a/tests/testthat/test-review-resolution.R +++ b/tests/testthat/test-review-resolution.R @@ -26,13 +26,18 @@ test_that("one missing response or predictor value does not switch the profile t d$z <- 3 * d$p + rnorm(n) pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) sac <- rr_sac(pts) - clean <- resolution_profile(pts, "z", "p", levels = c(10, 20, 40), sac = sac) + # A range of 1500 on this extent needs 43 cells and 300 points support 33: + # that finding is an R warning with a class now, where it was a log line. + expect_warning( + clean <- resolution_profile(pts, "z", "p", levels = c(10, 20, 40), sac = sac), + class = "spatialkit_not_supported") expect_identical(attr(clean, "variable"), "residuals") for (col in c("z", "p")) { holed <- pts holed[[col]][17] <- NA - lines <- capture_spatialkit_log( - prof <- resolution_profile(holed, "z", "p", levels = c(10, 20, 40), sac = sac)) + lines <- capture_spatialkit_log(expect_warning( + prof <- resolution_profile(holed, "z", "p", levels = c(10, 20, 40), sac = sac), + class = "spatialkit_not_supported")) expect_identical(attr(prof, "variable"), "residuals", info = col) expect_true(log_has(lines, "1 of 300 row"), info = col) expect_false(log_has(lines, "OLS fit on `predictor_vars` failed"), info = col) @@ -56,9 +61,11 @@ test_that("a layer larger than sample_n is bounded, judged and scored on all its d <- data.frame(x = runif(N, 0, 10000), y = runif(N, 0, 10000), z = rnorm(N)) pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) sac <- rr_sac(pts, range = 1200, nugget = 0.5, psill = 1) + # range_floor = TRUE: the ladder starts at the floor only when asked, since + # the default became FALSE. lines <- capture_spatialkit_log( prof <- resolution_profile(pts, "z", sac = sac, n_levels = 4, nstart = 3, - sample_n = 300)) + sample_n = 300, range_floor = TRUE)) b <- attr(prof, "bounds") expect_identical(b$n, 1200L) expect_identical(b$n_sample, 300L) diff --git a/tests/testthat/test-review2-aoa.R b/tests/testthat/test-review2-aoa.R index 4b61cd11..f942adeb 100644 --- a/tests/testthat/test-review2-aoa.R +++ b/tests/testthat/test-review2-aoa.R @@ -54,14 +54,43 @@ test_that("a zero threshold from duplicated training rows is explained", { tr$site <- rep(seq_len(30), each = 4) nd <- r2_aoa_pts(200, a = stats::rnorm(200), b = stats::rnorm(200)) + # Without folds a twin is the same point of predictor space, not a + # neighbour: each row is measured against the nearest row with different + # values, so the threshold is the one the 30 distinct sites give. (This + # block asserted threshold 0 and nothing inside, with a log line; that was + # the behaviour being reported, not the intended one.) lines <- capture_spatialkit_log( res <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"))) - expect_identical(res$threshold, 0) - expect_identical(res$n_inside, 0L) - expect_true(log_has(lines, "DI threshold is 0 because 120 of 120 training rows have an exact duplicate")) - expect_true(log_has(lines, "leave_location_out")) + expect_gt(res$threshold, 0) + expect_true(all(res$train_DI > 0)) + expect_identical(res$n_duplicates, 90L) + expect_gt(res$n_inside, 150L) + expect_false(log_has(lines, "DI threshold is 0")) + expect_true(log_has(lines, "90 of 120 training rows repeat another row's predictor values exactly \\(30 distinct points\\)")) out <- utils::capture.output(print(res)) - expect_true(any(grepl("120 of 120 training DI are 0: exact duplicates", out, + expect_true(any(grepl("90 of 120 rows repeat another's values", out, + fixed = TRUE))) + dedup <- area_of_applicability(nd, train_sf = tr[!duplicated(tr$site), ], + predictor_vars = c("a", "b")) + expect_identical(res$aoa$AOA, dedup$aoa$AOA) + + # Folds that split a site's visits put a twin on the training side of + # nearly every hold-out. The threshold is then 0 by definition, and that + # is a warning with a class, not a log line. + set.seed(11) + split_labs <- sample(rep(1:4, length.out = nrow(tr))) + lines0 <- capture_spatialkit_log( + expect_warning( + res0 <- area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "b"), + folds = split_labs), + class = "spatialkit_aoa_zero_threshold")) + expect_identical(res0$threshold, 0) + expect_identical(res0$n_inside, 0L) + expect_true(log_has(lines0, "DI threshold is 0 because [0-9]+ of 120 training rows have an exact duplicate")) + expect_true(log_has(lines0, "leave_location_out")) + out0 <- utils::capture.output(print(res0)) + expect_true(any(grepl("of 120 training DI are 0: exact duplicates", out0, fixed = TRUE))) # Folds that keep a site's visits together give the threshold its meaning diff --git a/tests/testthat/test-review2-assignment.R b/tests/testthat/test-review2-assignment.R index 32182189..f2e1060f 100644 --- a/tests/testthat/test-review2-assignment.R +++ b/tests/testthat/test-review2-assignment.R @@ -58,7 +58,7 @@ test_that("a non-finite numeric deff falls back to 1 with the classed warning", # NA and NaN used to stop with "missing value where TRUE/FALSE needed"; # Inf passed the check and gave uncorrected SEs beside cell_weight 0. expect_warning( - out <- summarize_by_cell(pts, "v", deff = bad), + out <- summarize_by_cell(pts, "v", deff = bad, estimate = "mean"), "must be a single number >= 1", class = "spatialkit_deff_fallback") expect_equal(out$cell_weight, out$n) expect_null(attr(out, "deff_applied")) @@ -69,11 +69,11 @@ test_that("a non-finite numeric deff falls back to 1 with the classed warning", test_that("deff_applied marks each row, and survives binding results together", { pts <- .r2_points() # The default frame is unchanged: no column. - expect_false("deff_applied" %in% names(summarize_by_cell(pts, "v"))) - fixed <- summarize_by_cell(pts, "v", deff = 2) + expect_false("deff_applied" %in% names(summarize_by_cell(pts, "v", estimate = "mean"))) + fixed <- summarize_by_cell(pts, "v", deff = 2, estimate = "mean") expect_identical(fixed$deff_applied, rep(TRUE, 4)) expect_false(is.null(attr(fixed, "deff_applied"))) - fell <- suppressWarnings(summarize_by_cell(pts, "v", deff = 0.5)) + fell <- suppressWarnings(summarize_by_cell(pts, "v", deff = 0.5, estimate = "mean")) expect_identical(fell$deff_applied, rep(FALSE, 4)) # Combined, the attribute is at best the first result's (bind_rows()) or # gone (rbind()); the column describes every row. @@ -83,7 +83,7 @@ test_that("deff_applied marks each row, and survives binding results together", rep(c(FALSE, TRUE), each = 4)) }) -test_that("a rejected sac falls back with the classed warning and FALSE rows", { +test_that("a rejected sac falls back to Kish with the classed warning, and the rows say so", { pts <- .r2_field() rejected <- structure(NA_real_, class = c("sac_range", "numeric"), rejected_reason = "fitted range exceeds the largest lag fitted", @@ -91,13 +91,19 @@ test_that("a rejected sac falls back with the classed warning and FALSE rows", { range = 1e6)) expect_warning( out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", - sac = rejected), + sac = rejected, estimate = "mean"), "fitted range exceeds", class = "spatialkit_deff_fallback") - expect_identical(out$deff_applied, rep(FALSE, 6)) + # The fallback is Kish now (this used to assert deff_applied FALSE on every + # row, the uncorrected SE): a correction was applied, and `deff_method` + # says it was not the one asked for. + expect_identical(out$deff_applied, rep(TRUE, 6)) + expect_identical(out$deff_method, rep("kish (variogram fallback)", 6)) + kish <- summarize_by_cell(pts, predictor_vars = "z", deff = "kish", estimate = "mean") + expect_equal(out[["..se_pred_z"]], kish[["..se_pred_z"]], tolerance = 1e-12) # Caught by class, without matching the message. caught <- tryCatch( summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", - sac = rejected), + sac = rejected, estimate = "mean"), spatialkit_deff_fallback = function(w) "caught") expect_identical(caught, "caught") # Joined to cells, an empty cell carries NA rather than a verdict. @@ -105,7 +111,7 @@ test_that("a rejected sac falls back with the classed warning and FALSE rows", { geometry = sf::st_sfc(lapply(0:6, function(i) .r2_sq(100 * i, 0, 60)), crs = 32632)) ok <- summarize_by_cell(pts, "z", deff = "variogram", sac = .r2_sac(), - cells_sf = cells) + cells_sf = cells, estimate = "mean") expect_identical(ok$deff_applied, c(rep(TRUE, 6), NA)) }) @@ -130,7 +136,7 @@ test_that("each cell's correlation matrix is built once, not once per column sta n_builds <<- n_builds + 1L real(...) }) - summarize_by_cell(pts, "z", deff = "variogram", sac = sac) + summarize_by_cell(pts, "z", deff = "variogram", sac = sac, estimate = "mean") # One per cell; the design effect at the row count reuses them (it used to # rebuild all six). expect_identical(n_builds, 6L) @@ -140,7 +146,7 @@ test_that("each cell's correlation matrix is built once, not once per column sta p2$z[c(1, 30, 60)] <- NA # one missing value in cells 1, 2 and 3 p2$w <- p2$z + 1 summarize_by_cell(p2, "z", predictor_vars = "w", deff = "variogram", - sac = sac, conf_level = 0.95) + sac = sac, conf_level = 0.95, estimate = "mean") # 6 for the cells, then per column the three incomplete cells once each # (z and w), and cell_weight's three: 15. The se/neff/df/ci closures used # to rebuild each of those five times: 45. @@ -154,7 +160,7 @@ test_that("an empty point no longer stops deff = 'variogram'", { empty <- pts sf::st_geometry(empty) <- g res <- .r2_warnings(summarize_by_cell(empty, "z", deff = "variogram", - sac = .r2_sac())) + sac = .r2_sac(), estimate = "mean")) expect_true(any(grepl("1 point\\(s\\) have empty or non-finite coordinates", res$warnings))) out <- res$value @@ -162,7 +168,7 @@ test_that("an empty point no longer stops deff = 'variogram'", { # Its value still counts in its cell; the other cells are untouched. expect_identical(out$n[1], 25L) expect_equal(out$resp_mean_z[1], mean(pts$z[1:25])) - ref <- summarize_by_cell(pts, "z", deff = "variogram", sac = .r2_sac()) + ref <- summarize_by_cell(pts, "z", deff = "variogram", sac = .r2_sac(), estimate = "mean") expect_equal(out[["..se_resp_z"]][-1], ref[["..se_resp_z"]][-1]) # The design effect of cell 1 is 1 + (25 - 1) * rbar over its 24 located # points. @@ -204,7 +210,7 @@ test_that("an anisotropic variogram is evaluated in its own geometry", { coords = c("x", "y"), crs = 32632) sac <- structure(300, class = c("sac_range", "numeric"), variogram_model = m, crs = sf::st_crs(32632)) - out <- summarize_by_cell(pts, "v", deff = "variogram", sac = sac) + out <- summarize_by_cell(pts, "v", deff = "variogram", sac = sac, estimate = "mean") d <- as.matrix(stats::dist(cbind(seq(0, 450, by = 50), 0))) R <- 0.8 * exp(-d / 60); diag(R) <- 1 expect_equal(attr(out, "deff_applied")$deff, sum(R) / 10) @@ -215,15 +221,15 @@ test_that("an anisotropic variogram is evaluated in its own geometry", { test_that("a response_var that cannot be summarised is a warning, not a silent skip", { pts <- .r2_points() - expect_warning(out <- summarize_by_cell(pts, "vall"), + expect_warning(out <- summarize_by_cell(pts, "vall", estimate = "mean"), "response_var 'vall' is not a column") expect_false(any(grepl("^resp_", names(out)))) pts$flag <- pts$v > 0 - expect_warning(summarize_by_cell(pts, "flag"), "'flag' are not numeric") - expect_warning(summarize_by_cell(pts, "v", predictor_vars = c("v", "nope")), + expect_warning(summarize_by_cell(pts, "flag", estimate = "mean"), "'flag' are not numeric") + expect_warning(summarize_by_cell(pts, "v", predictor_vars = c("v", "nope"), estimate = "mean"), "predictor_vars 'nope' are not columns") # Two names used to stop with "the condition has length > 1". - expect_error(summarize_by_cell(pts, c("v", "flag")), + expect_error(summarize_by_cell(pts, c("v", "flag"), estimate = "mean"), "`response_var` must be a single column name") }) @@ -237,7 +243,7 @@ test_that("a double ID of 100000 still joins an integer cell ID", { coords = c("x", "y"), crs = 32632) a <- assign_features_to_polygons(pts, cells) a$poly_id <- as.double(a$poly_id) # as from a GeoPackage Integer64 field - res <- .r2_warnings(summarize_by_cell(a, "v", cells_sf = cells)) + res <- .r2_warnings(summarize_by_cell(a, "v", cells_sf = cells, estimate = "mean")) out <- res$value # as.character(1e5) is "1e+05": that cell came back NA and its 11 points # were lost, with no R warning. @@ -253,7 +259,7 @@ test_that("summarised IDs that match no cell are reported", { cells <- sf::st_sf(poly_id = 1:3, geometry = sf::st_sfc(lapply(0:2, function(i) .r2_sq(10 * i, 0)), crs = 32632)) - expect_warning(out <- summarize_by_cell(pts, "v", cells_sf = cells), + expect_warning(out <- summarize_by_cell(pts, "v", cells_sf = cells, estimate = "mean"), "1 of the 4 summarised cell ID\\(s\\) \\(4\\) match no") expect_identical(nrow(out), 3L) }) @@ -268,7 +274,7 @@ test_that("cells keyed by 'id' are joined like assign_features_to_polygons() rea y = runif(18, 0, 10), v = rnorm(18)), coords = c("x", "y"), crs = 32632) a <- assign_features_to_polygons(pts, cells) # takes the 'id' column - out <- summarize_by_cell(a, "v", cells_sf = cells, area = TRUE) + out <- summarize_by_cell(a, "v", cells_sf = cells, area = TRUE, estimate = "mean") expect_s3_class(out, "sf") # Joined on 'id', not on the differently numbered 'cell_id': each count # sits on its own polygon. @@ -280,25 +286,26 @@ test_that("cells keyed by 'id' are joined like assign_features_to_polygons() rea # No ID column at all: a warning and a plain table, or an error when an # area was asked for. It used to be one log line and a plain table. nocol <- cells[, "geometry"] - expect_warning(plain <- summarize_by_cell(a, "v", cells_sf = nocol), + expect_warning(plain <- summarize_by_cell(a, "v", cells_sf = nocol, estimate = "mean"), "has none of the ID columns") expect_false(inherits(plain, "sf")) - expect_error(summarize_by_cell(a, "v", cells_sf = nocol, area = TRUE), + expect_error(summarize_by_cell(a, "v", cells_sf = nocol, area = TRUE, estimate = "mean"), "`area = TRUE` needs the cells' areas") - expect_warning(summarize_by_cell(a, "v", cells_sf = sf::st_drop_geometry(cells)), + expect_warning(summarize_by_cell(a, "v", cells_sf = sf::st_drop_geometry(cells), + estimate = "mean"), "`cells_sf` is not an sf object") }) test_that("agg_funs takes a bare function or function names", { pts <- .r2_points() med <- tapply(pts$v, pts$poly_id, median) - out <- summarize_by_cell(pts, "v", agg_funs = median) + out <- summarize_by_cell(pts, "v", agg_funs = median, estimate = "mean") # It used to become the mean, with only a log line. expect_equal(out$resp_median_v, as.numeric(med)) - out2 <- summarize_by_cell(pts, "v", agg_funs = c("median", "sum")) + out2 <- summarize_by_cell(pts, "v", agg_funs = c("median", "sum"), estimate = "mean") expect_equal(out2$resp_median_v, as.numeric(med)) expect_equal(out2$resp_sum_v, as.numeric(tapply(pts$v, pts$poly_id, sum))) - expect_warning(out3 <- summarize_by_cell(pts, "v", agg_funs = 3), + expect_warning(out3 <- summarize_by_cell(pts, "v", agg_funs = 3, estimate = "mean"), "Falling back to the mean") expect_true("resp_mean_v" %in% names(out3)) }) diff --git a/tests/testthat/test-review2-cv.R b/tests/testthat/test-review2-cv.R index cf2b57c7..e59c2088 100644 --- a/tests/testthat/test-review2-cv.R +++ b/tests/testthat/test-review2-cv.R @@ -347,7 +347,6 @@ test_that("folds on lon/lat polygons are accepted after sf_use_s2() is toggled", # --------------------------------------------------------------------------- test_that("cv_gwr() validates its kernel with match.arg() alone", { - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") src <- paste(deparse(body(cv_gwr)), collapse = " ") expect_false(grepl(".validate_kernel", src, fixed = TRUE)) diff --git a/tests/testthat/test-review2-fold-separation.R b/tests/testthat/test-review2-fold-separation.R index 0dd710a2..e3b8a853 100644 --- a/tests/testthat/test-review2-fold-separation.R +++ b/tests/testthat/test-review2-fold-separation.R @@ -26,12 +26,12 @@ test_that("fold_separation measures a recorded range in the CRS it was recorded f$params$sac_range <- structure(600, class = "sac_range", crs = sf::st_crs(32617)) a <- fold_separation(f, d) b <- fold_separation(f, sf::st_transform(d, 2264)) # the same layer in US feet - expect_equal(b$within_range, a$within_range, tolerance = 1e-6) + expect_equal(b$mean_cor, a$mean_cor, tolerance = 1e-6) expect_equal(attr(b, "crs"), "EPSG:32617") # The folds' own CRS is used when the range carries none. f$params$sac_range <- 600 b2 <- fold_separation(f, sf::st_transform(d, 2264)) - expect_equal(b2$within_range, a$within_range, tolerance = 1e-6) + expect_equal(b2$mean_cor, a$mean_cor, tolerance = 1e-6) # A bare number stays in data_sf's own units, as documented. b3 <- fold_separation(f$folds, sf::st_transform(d, 2264), sac = 600) expect_equal(attr(b3, "crs"), "EPSG:2264") diff --git a/tests/testthat/test-review2-folds.R b/tests/testthat/test-review2-folds.R index 37a5ea25..5d56d4ed 100644 --- a/tests/testthat/test-review2-folds.R +++ b/tests/testthat/test-review2-folds.R @@ -14,14 +14,20 @@ test_that("drop_empty_blocks = FALSE lowers k to the blocks that hold points", { xy <- rbind(cbind(rnorm(30, 100, 20), rnorm(30, 100, 20)), cbind(rnorm(30, 900, 20), rnorm(30, 900, 20))) p <- r2_pts(xy[, 1], xy[, 2]) + # The reduction was a log line only ("only 2 blocks hold points"), which + # this test pinned. It is now a warning of class spatialkit_k_reduced, + # logged as well. lines <- capture_spatialkit_log( - f <- make_folds(p, k = 5, method = "block_kfold", block_nx = 4, block_ny = 4, - drop_empty_blocks = FALSE, seed = 1)) + expect_warning( + f <- make_folds(p, k = 5, method = "block_kfold", block_nx = 4, block_ny = 4, + drop_empty_blocks = FALSE, seed = 1), + "returning 2 folds, not the k = 5 asked for: the requested 4 x 4 grid has 2 blocks that hold points", + class = "spatialkit_k_reduced")) expect_equal(f$k, 2L) expect_length(f$folds, 2L) expect_true(all(lengths(lapply(f$folds, `[[`, "test")) > 0L)) expect_true(is.finite(f$params$balance_ratio)) - expect_true(log_has(lines, "only 2 blocks hold points")) + expect_true(log_has(lines, "the requested 4 x 4 grid has 2 blocks that hold points")) # The empty blocks are still kept and packed. expect_equal(f$params$blocks_used, 16L) expect_identical(sort(unlist(f$params$fold_blocks)), 1:16) diff --git a/tests/testthat/test-review2-gwr.R b/tests/testthat/test-review2-gwr.R index de6bfb79..63c1bb9e 100644 --- a/tests/testthat/test-review2-gwr.R +++ b/tests/testthat/test-review2-gwr.R @@ -2,7 +2,6 @@ # GWR regressions from the second adversarial review. # =========================================================================== -skip_if_not_installed("GWmodel") skip_if_not_installed("sp") # Every warning raised while evaluating `expr`, muffled, beside its value (or @@ -65,6 +64,7 @@ test_that("a one-predictor GWR is surveyed for local collinearity", { # --------------------------------------------------------------------------- test_that("the survey's kernel weights equal GWmodel::gw.weight()", { + skip_if_not_installed("GWmodel") d <- c(0, 0, 50, 100, 100, 150) for (k in c("bisquare", "gaussian", "tricube", "boxcar", "exponential")) { # Fixed, with points exactly at the kernel's edge. @@ -84,6 +84,7 @@ test_that("the survey's kernel weights equal GWmodel::gw.weight()", { }) test_that("a fixed boxcar bandwidth equal to the grid spacing is not called singular", { + skip_if_not_installed("GWmodel") set.seed(3) g <- expand.grid(x = seq(0, 1500, by = 100), y = seq(0, 1500, by = 100)) g$a <- rnorm(nrow(g)); g$b <- rnorm(nrow(g)) @@ -100,17 +101,37 @@ test_that("a fixed boxcar bandwidth equal to the grid spacing is not called sing as.integer(colSums(W > 0))) }) -test_that("an exactly singular window stops the fit with the cause named", { +test_that("an exactly singular window returns NA for what it cannot estimate, with the cause named", { + # `soil` is a 0/1 indicator, constant inside every 20-neighbour window. The + # fit used to stop here ("inv(): matrix is singular"). The local solve + # returns the fit: the slope of `soil` is NA in every window, the intercept + # is NA where soil is 1 (it would absorb the slope there) and an estimate + # where soil is 0, and the slope of `a` and every fitted value are + # estimates. d <- .r2_clusters(exact = TRUE) r <- .r2_catch(fit_gwr_model(d, "z", c("a", "soil"), adaptive = TRUE, bandwidth = 20)) - expect_type(r$value, "character") - expect_match(r$value, "^fit_gwr_model\\(\\): GWR fit failed: inv\\(\\)") - expect_match(r$value, "local window's design is singular") - expect_match(r$value, "survey found [0-9]+ singular window") - # The collinearity warning before it does not promise NaN coefficients. - expect_true(any(grepl("an exactly singular window makes GWmodel stop the fit", + fit <- r$value + expect_s3_class(fit, "gwr_fit") + co <- coef(fit) + expect_true(all(is.na(co$soil))) + expect_identical(is.na(co$Intercept), d$soil == 1) + expect_false(anyNA(co$a)) + expect_lt(max(abs(co$a - 2)), 0.5) + expect_false(anyNA(fitted(fit))) + expect_lt(sqrt(mean((fitted(fit) - (2 * d$a + 3 * d$soil))^2)), 0.15) + expect_identical(fit$info$n_local_singular, 200L) + expect_identical(fit$info$n_rank_deficient, 200L) + expect_true(all(fit$info$local_collinearity$rank == 2L)) + w <- grep("local regressions are rank deficient", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "^fit_gwr_model\\(\\): 200 of 200 local regressions are rank deficient") + expect_match(w, "Intercept at 100, a at 0, soil at 200") + expect_match(w, "a predictor that is constant inside a window") + # The collinearity warning before it says what such a window returns. + expect_true(any(grepl("a coefficient that an exactly singular window cannot estimate is NA", r$warnings))) + expect_false(any(grepl("GWmodel stop", r$warnings))) }) test_that("non-finite coefficients at co-located points are blamed on the zero-width kernel", { @@ -207,12 +228,21 @@ test_that("gwr_model_selection() ranks a model with an undefined AICc last", { sel <- r$value expect_s3_class(sel, "gwr_model_selection") expect_lt(min(sel$raw[[2]][, 3]), 0) - expect_identical(sel$best, "a") - expect_true(any(grepl("AICc is undefined for 1 of 6 model\\(s\\) at bandwidth 6", + # Of the models with a predictor, `a` alone is best, as it was. The model + # without predictors is scored too and ranks above it: at 6 neighbours each + # window fits two parameters on five points, which costs more in AICc than + # `a` explains. + expect_identical(sel$table$variables[sel$table$n_vars > 0L][1L], "a") + expect_identical(sel$table$variables[1L], "") + expect_identical(sel$best, character(0)) + # Seven models: the six of the sweep and the one without predictors, which + # the table carries as ``. + expect_true(any(grepl("AICc is undefined for 1 of 7 model\\(s\\) at bandwidth 6", r$warnings))) - expect_true(is.na(sel$table$criterion[6])) - expect_identical(sel$table$n_vars[6], 3L) - expect_true(all(is.finite(sel$table$criterion[1:5]))) + expect_identical(nrow(sel$table), 7L) + expect_true(is.na(sel$table$criterion[7])) + expect_identical(sel$table$n_vars[7], 3L) + expect_true(all(is.finite(sel$table$criterion[1:6]))) }) test_that("gwr_model_selection() warns when it raises a too-small adaptive bandwidth", { @@ -231,8 +261,9 @@ test_that("gwr_model_selection() warns when it raises a too-small adaptive bandw # --------------------------------------------------------------------------- # An adaptive bandwidth above n was capped at n in silence: a distance passed -# with adaptive left at TRUE, and bw.gwr()'s choice below 20 points, whose -# search range [20, n] is then reversed. +# with adaptive left at TRUE. GWmodel::bw.gwr()'s choice below 20 points, +# whose search range [20, n] is reversed, was capped the same way; the +# package's own search covers the range the model allows, from its floor to n. # --------------------------------------------------------------------------- test_that("an adaptive bandwidth above n is capped with a warning that suggests adaptive = FALSE", { @@ -257,7 +288,13 @@ test_that("an adaptive bandwidth above n is capped with a warning that suggests rs$warnings))) }) -test_that("below 20 points, capping bw.gwr()'s choice at n is said", { +test_that("below 20 points the bandwidth is searched from the model's floor to n", { + # GWmodel::bw.gwr() searches adaptive counts from 20 up, a range that is + # empty for 12 observations: it returned 18, which was capped at 12 with a + # warning that said neither was an optimised bandwidth. The package's + # search runs from the floor for two parameters (4 neighbours with the + # bisquare kernel) to 12, so the bandwidth is a selected one and there is + # nothing to cap. set.seed(1) n <- 12 x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) @@ -265,18 +302,25 @@ test_that("below 20 points, capping bw.gwr()'s choice at n is said", { z = 1 + (x / 1000) * a + rnorm(n, 0, 0.3)), coords = c("x", "y"), crs = 32617) r <- .r2_catch(fit_gwr_model(d, "z", "a")) - expect_equal(r$value$info$bandwidth, 12) + bs <- r$value$info$bandwidth_search + expect_identical(bs$range, c(4, 12)) + expect_gte(r$value$info$bandwidth, 4) + expect_lte(r$value$info$bandwidth, 12) expect_false(r$value$info$bandwidth_is_fallback) - expect_true(any(grepl(paste0("bw\\.gwr\\(\\) searches adaptive bandwidths ", - "from 20 neighbours up to n, a range that is ", - "empty for 12 observations, and returned [0-9]+; ", - "using 12"), r$warnings))) + expect_false(any(grepl("bw\\.gwr|range that is empty|exceeds the 12 observations", + r$warnings))) + # Every count in the range was a candidate, and the one used has the lowest + # AICc of those scored. + expect_identical(bs$curve$bandwidth[which.min(bs$curve$criterion)], + r$value$info$bandwidth) + expect_equal(min(bs$curve$criterion), r$value$info$AICc, tolerance = 1e-8) s <- .r2_pts(14, 1, c("a", "b")) s$z <- 1 + s$a + rnorm(14, 0, 0.3) rs <- .r2_catch(gwr_model_selection(s, "z", c("a", "b"))) - expect_identical(rs$value$bandwidth, 14L) - expect_true(any(grepl("empty for 14 observations", rs$warnings))) + expect_gte(rs$value$bandwidth, 5L) + expect_lte(rs$value$bandwidth, 14L) + expect_false(any(grepl("empty for 14 observations", rs$warnings))) }) diff --git a/tests/testthat/test-review2-plotting.R b/tests/testthat/test-review2-plotting.R index 0e8b93e5..d5329ec3 100644 --- a/tests/testthat/test-review2-plotting.R +++ b/tests/testthat/test-review2-plotting.R @@ -32,7 +32,7 @@ test_that("labels = TRUE labels the package's own cells without naming a column" expect_equal(sort(as.numeric(txt$label)), sort(tess$cells$cell_id)) cells <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), - response_var = "z", cells_sf = tess$cells) + response_var = "z", cells_sf = tess$cells, estimate = "mean") expect_false("cell_id" %in% names(cells)) p2 <- plot_tessellation_map(cells, labels = TRUE) txt2 <- ggplot2::layer_data(p2, which(layer_geoms_r2(p2) == "GeomText")) @@ -349,7 +349,6 @@ test_that("the no-sill subtitle does not claim a range range_frac refused ran pa test_that("the GWR coefficient subtitle is right with mask = FALSE", { skip_if_not_installed("ggplot2") - skip_if_not_installed("GWmodel") skip_if_not_installed("sp") # A clean survey is not a missing one. set.seed(3); n <- 200 diff --git a/tests/testthat/test-review2-resolution.R b/tests/testthat/test-review2-resolution.R index 9cc66323..6a396ae0 100644 --- a/tests/testthat/test-review2-resolution.R +++ b/tests/testthat/test-review2-resolution.R @@ -82,10 +82,17 @@ test_that("a misspelt column is an error in determine_optimal_levels(), and a mi "column 'Z' not found") expect_error(determine_optimal_levels(pts, response_var = "z", predictor_vars = c("w", "Elev")), "Elev.*not found") - out <- r2_warnings(determine_optimal_levels(pts, max_levels = 6, response_var = "z", + # A model-aware criterion with no response to read falls back, and says + # so. (It used to say the same of a response without predictors, which + # the statistic does not need: the cell means are then regressed on an + # intercept alone.) + out <- r2_warnings(determine_optimal_levels(pts, max_levels = 6, predictor_vars = "w", criterion = "morans_i")) - expect_true(any(grepl("predictor_vars were not given", out$warnings))) + expect_true(any(grepl("needs a response_var, and none was given", out$warnings))) expect_null(attr(out$value, "diagnostics")) + resp_only <- r2_warnings(determine_optimal_levels(pts, max_levels = 6, response_var = "z", + criterion = "morans_i")) + expect_false(any(grepl("falling back to geometric", resp_only$warnings))) }) @@ -97,16 +104,24 @@ test_that("repeat visits let the ladder reach one cell per location", { set.seed(3) d$z <- rnorm(150) + rep(1:5, each = 30) pp <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) - prof <- resolution_profile(pp, "z", levels = 2:5, nstart = 3, sac = r2_sac(300)) + # (A range of 300 needs 12 cells and five stations allow 5: an R warning + # with a class now, where it was a log line.) + expect_warning( + prof <- resolution_profile(pp, "z", levels = 2:5, nstart = 3, sac = r2_sac(300), + estimate = NULL, obs_per_cell = NULL, partition = "kmeans"), + class = "spatialkit_not_supported") expect_identical(prof$levels, 2:5) expect_identical(prof$wss[4], 0) expect_true(is.finite(prof$cp[4])) - b <- attr(resolution_profile(pp, min_cell_n = 1, n_levels = 4, nstart = 3), "bounds") + b <- attr(resolution_profile(pp, min_cell_n = 1, n_levels = 4, nstart = 3, estimate = NULL, + obs_per_cell = NULL, sac = NULL, partition = "kmeans"), "bounds") expect_identical(b$ceiling, 5L) expect_identical(b$ceiling_from, "distinct locations") # Without repeats the cap stays one short of the points, which # stats::kmeans() needs. - expect_identical(resolution_profile(r2_pts(20), levels = 2:20, nstart = 2)$levels, 2:19) + expect_identical(resolution_profile(r2_pts(20), levels = 2:20, nstart = 2, estimate = NULL, + obs_per_cell = NULL, sac = NULL, + partition = "kmeans")$levels, 2:19) # determine_optimal_levels() reaches k = 5 as well, and reads the fall of # the WSS to zero there as the elbow: one cell per station, where it used # to warn that the stations had no cluster structure. @@ -243,8 +258,11 @@ test_that("k-means++ seeding draws in proportion to the squared distance", { test_that("range_floor = FALSE starts the ladder at 2 and still reports the floor", { pts <- r2_pts(300) sac <- r2_sac(250) - on <- resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2) + # FALSE is the default now; TRUE starts the ladder at the floor. + on <- resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2, range_floor = TRUE) off <- resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2, range_floor = FALSE) + expect_identical(resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2)$levels, + off$levels) expect_gt(attr(on, "bounds")$floor, 2L) expect_identical(min(on$levels), attr(on, "bounds")$floor) expect_identical(min(off$levels), 2L) diff --git a/tests/testthat/test-review2-tessellation.R b/tests/testthat/test-review2-tessellation.R index ffde3f99..4f5a9ce5 100644 --- a/tests/testthat/test-review2-tessellation.R +++ b/tests/testthat/test-review2-tessellation.R @@ -301,8 +301,12 @@ test_that("voronoi with expand > 0 returns the grown boundary its cells fill", { expect_equal(as.numeric(sum(sf::st_area(tess$boundary))), as.numeric(sum(sf::st_area(tess$cells))), tolerance = 1e-6) expect_gt(as.numeric(sum(sf::st_area(tess$boundary))), 1.5e6) - # expand = 0 is unchanged. - t0 <- build_tessellation(p, boundary = sq, quiet = TRUE) + # expand = 0 is unchanged: the two outside points have no cell, which is + # now counted and warned about. + expect_warning(t0 <- build_tessellation(p, boundary = sq, quiet = TRUE), + "2 of 32 point\\(s\\) \\(6.2%\\) fall in no cell", + class = "spatialkit_unassigned") + expect_identical(t0$params$n_outside, 2L) expect_equal(as.numeric(sf::st_area(t0$boundary)), 1e6) }) diff --git a/tests/testthat/test-review3-S2-tessellation.R b/tests/testthat/test-review3-S2-tessellation.R index 617ef237..f55958ce 100644 --- a/tests/testthat/test-review3-S2-tessellation.R +++ b/tests/testthat/test-review3-S2-tessellation.R @@ -78,7 +78,12 @@ test_that("an empty point is indexed NA by the triangulation, not an abort", { bnd <- .r3s2_box(5e5, 5e5 + 1000, 5e6, 5e6 + 1000, crs = 32632) # Stopped with "NA/NaN/Inf in foreign function call (arg 1)". for (b in list(bnd, NULL)) { - tri <- build_tessellation(pts, b, method = "triangles", quiet = TRUE) + # The NA is counted and warned about, and the warning says why: the + # point has no location. + expect_warning(tri <- build_tessellation(pts, b, method = "triangles", quiet = TRUE), + "1 of 21 point\\(s\\) .* They have empty geometry", + class = "spatialkit_unassigned") + expect_identical(tri$params$n_outside, 1L) expect_gt(nrow(tri$cells), 0L) expect_length(tri$index, 21L) expect_true(is.na(tri$index[21])) diff --git a/tests/testthat/test-review3-S3-assignment.R b/tests/testthat/test-review3-S3-assignment.R index ee37849f..15f2bd57 100644 --- a/tests/testthat/test-review3-S3-assignment.R +++ b/tests/testthat/test-review3-S3-assignment.R @@ -78,7 +78,7 @@ test_that("a rejected sac replaced by an estimate is not reported as a fallback" # estimate was then applied. local_mocked_bindings(estimate_sac_range = function(...) .r3_sac()) res <- .r3_conditions(summarize_by_cell(pts, "z", deff = "variogram", - sac = .r3_rejected())) + sac = .r3_rejected(), estimate = "mean")) expect_false(any(.r3_is_fallback(res))) expect_length(res$warnings, 1L) expect_match(res$warnings, "no usable range \\(fitted range exceeds") @@ -87,7 +87,7 @@ test_that("a rejected sac replaced by an estimate is not reported as a fallback" expect_identical(attr(res$value, "deff_applied")$method, "variogram") # tryCatch() on the class no longer throws the corrected result away. kept <- suppressWarnings(tryCatch( - summarize_by_cell(pts, "z", deff = "variogram", sac = .r3_rejected()), + summarize_by_cell(pts, "z", deff = "variogram", sac = .r3_rejected(), estimate = "mean"), spatialkit_deff_fallback = function(w) "caught")) expect_s3_class(kept, "data.frame") }) @@ -98,17 +98,20 @@ test_that("a rejected sac that cannot be replaced gives one fallback warning nam local_mocked_bindings(estimate_sac_range = function(...) .r3_rejected("variogram model did not converge")) res <- .r3_conditions(summarize_by_cell(pts, "z", deff = "variogram", - sac = .r3_rejected())) + sac = .r3_rejected(), estimate = "mean")) expect_length(res$warnings, 1L) expect_true(.r3_is_fallback(res)) expect_match(res$warnings, "supplied `sac` reports no usable range \\(fitted range exceeds") expect_match(res$warnings, "estimated from `response_var` reports no usable range \\(variogram model did not converge") - expect_false(any(res$value$deff_applied)) + # The one fallback is to Kish (this used to assert deff_applied FALSE, the + # uncorrected SE); the rows carry the label. + expect_true(all(res$value$deff_applied)) + expect_identical(unique(res$value$deff_method), "kish (variogram fallback)") # No response to estimate from: the rejection is still named. res2 <- .r3_conditions(summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", - sac = .r3_rejected())) + sac = .r3_rejected(), estimate = "mean")) expect_length(res2$warnings, 1L) expect_true(.r3_is_fallback(res2)) expect_match(res2$warnings, "fitted range exceeds.*no `response_var`") @@ -121,16 +124,17 @@ test_that("a residual (detrended) sac correcting response SEs is warned about", pts <- .r3_field() res <- .r3_sac(detrended = TRUE, detrend_method = "ols") # Used as given, as documented, but no longer in silence. - expect_warning(out <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = res), + expect_warning(out <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = res, + estimate = "mean"), "residuals on predictors \\(detrend = \"ols\"\\).*understated") expect_true(all(out$deff_applied)) - quiet <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = .r3_sac()) + quiet <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = .r3_sac(), estimate = "mean") expect_equal(out[["..se_resp_z"]], quiet[["..se_resp_z"]]) # Nothing to warn about without response columns, or with a response variogram. expect_no_warning(summarize_by_cell(pts, predictor_vars = "w", deff = "variogram", - sac = res)) + sac = res, estimate = "mean")) expect_no_warning(summarize_by_cell(pts, "z", deff = "variogram", - sac = .r3_sac(detrended = FALSE))) + sac = .r3_sac(detrended = FALSE), estimate = "mean")) }) @@ -145,8 +149,8 @@ test_that("deff = 'kish' records a correction made to the predictor SEs only", { pts$poly_id <- 1L + (xy[, 1] %/% 50) + 4L * (xy[, 2] %/% 50) pts$v <- rnorm(n) # response: unclustered pts$p <- rnorm(16, sd = 2)[pts$poly_id] + rnorm(n) # predictor: clustered - naive <- summarize_by_cell(pts, "v", "p") - k <- summarize_by_cell(pts, "v", "p", deff = "kish") + naive <- summarize_by_cell(pts, "v", "p", estimate = "mean") + k <- summarize_by_cell(pts, "v", "p", deff = "kish", estimate = "mean") expect_identical(attr(k, "icc")$resp, 0) expect_gt(attr(k, "icc")$pred, 0.5) # The predictor SEs were inflated about elevenfold; the rows used to say @@ -164,15 +168,17 @@ test_that("deff = 'kish' records a correction made to the predictor SEs only", { test_that("a pure-nugget variogram is applied as deff = 1, not reported as a fallback", { pts <- .r3_field() nug <- .r3_sac(model = data.frame(model = "Nug", psill = 1, range = 0)) - expect_no_warning(out <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug)) - naive <- summarize_by_cell(pts, "z") + expect_no_warning(out <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug, + estimate = "mean")) + naive <- summarize_by_cell(pts, "z", estimate = "mean") expect_true(all(out$deff_applied)) expect_equal(out[["..se_resp_z"]], naive[["..se_resp_z"]]) expect_equal(attr(out, "deff_applied")$rbar, rep(0, nrow(out))) # So is a structured component with no sill. nug2 <- .r3_sac(model = data.frame(model = c("Nug", "Exp"), psill = c(1, 0), range = c(0, 40))) - expect_no_warning(out2 <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug2)) + expect_no_warning(out2 <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug2, + estimate = "mean")) expect_true(all(out2$deff_applied)) }) @@ -182,11 +188,11 @@ test_that("deff_max_n must be a number of at least 2 for deff = 'variogram'", { # 1 and 0 returned uncorrected SEs marked deff_applied = TRUE; NA stopped # with "missing value where TRUE/FALSE needed". expect_error(summarize_by_cell(pts, "z", deff = "variogram", sac = .r3_sac(), - deff_max_n = bad), + deff_max_n = bad, estimate = "mean"), "`deff_max_n` must be") } # Unused, so unchecked, by every other deff. - expect_no_error(summarize_by_cell(pts, "z", deff = "kish", deff_max_n = 0)) + expect_no_error(summarize_by_cell(pts, "z", deff = "kish", deff_max_n = 0, estimate = "mean")) }) test_that("the rows with no cell ID get a cell_weight like any other group", { @@ -195,7 +201,7 @@ test_that("the rows with no cell ID get a cell_weight like any other group", { y = 5e6 + runif(40, 0, 300), v = rnorm(40)), coords = c("x", "y"), crs = 32632) a <- assign_features_to_polygons(pts, .r3_grid(), keep_unassigned = TRUE) - s <- summarize_by_cell(a, "v") + s <- summarize_by_cell(a, "v", estimate = "mean") na_row <- which(is.na(s$poly_id)) expect_length(na_row, 1L) expect_gt(s$n[na_row], 0) @@ -209,14 +215,14 @@ test_that("a fixed deff stays a scalar on the record when one cell is summarised coords = c("x", "y"), crs = 32632) grid <- .r3_grid() out <- summarize_by_cell(assign_features_to_polygons(pts, grid), "v", - cells_sf = grid, deff = 2) + cells_sf = grid, deff = 2, estimate = "mean") # It came back as c(2, NA, NA, ...). expect_identical(attr(out, "deff_applied"), list(method = "fixed", deff = 2)) }) test_that("agg_funs = pkg::fn is named after the function", { pts <- .r3_field() - out <- summarize_by_cell(pts, "z", agg_funs = stats::median) + out <- summarize_by_cell(pts, "z", agg_funs = stats::median, estimate = "mean") expect_true("resp_median_z" %in% names(out)) expect_false("resp_agg1_z" %in% names(out)) }) @@ -294,7 +300,8 @@ test_that("dplyr's row verbs drop a row record as `[` does", { dat <- sf::st_as_sf(data.frame(x = 1:5, y = 5:1, resp = c(1, 2, NA, 4, 5), pred = c(1, 2, 3, 4, Inf)), coords = c("x", "y"), crs = 32632) - clean <- prep_model_data(dat, "resp", "pred") + expect_warning(clean <- prep_model_data(dat, "resp", "pred"), + class = "spatialkit_rows_dropped") expect_null(attr(dplyr::filter(clean, resp > 1), "dropped")) # And for a geometry-free frame carrying a record (what st_drop_geometry() # of such a layer is). @@ -320,7 +327,7 @@ test_that("under knitr a caution raised as a warning is not repeated as a messag v = rnorm(20), poly_id = rep(1:4, each = 5)), coords = c("x", "y"), crs = 32632) # A design-effect fallback: it was a message and a warning. - res <- .r3_conditions(summarize_by_cell(pts, "v", deff = 0.5)) + res <- .r3_conditions(summarize_by_cell(pts, "v", deff = 0.5, estimate = "mean")) expect_identical(res$messages, 0L) expect_length(res$warnings, 1L) # The cross-validation cautions that are also R warnings (they used to be diff --git a/tests/testthat/test-review3-S4-range-kriging.R b/tests/testthat/test-review3-S4-range-kriging.R index 6e28e32b..c366350f 100644 --- a/tests/testthat/test-review3-S4-range-kriging.R +++ b/tests/testthat/test-review3-S4-range-kriging.R @@ -21,7 +21,11 @@ } # The white-noise REML refusal of test-sac-range.R (seed 7, 0.27 m), fitted -# once for the tests that read it. +# once for the tests that read it. structure_alpha = 1: white noise is now +# refused for want of spatial structure before any range is looked at, and +# these tests are about the REML floor, which that refusal would hide. +# lags = "equal": the floor is compared with the first of gstat's equal bins +# (about 30 m here), which is the binning these tests were written against. .r3s4_wn <- local({ val <- NULL function() { @@ -32,7 +36,8 @@ z = rnorm(n), w = rnorm(n)) pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) lines <- capture_spatialkit_log( - r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml"))) + r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml", + lags = "equal", structure_alpha = 1))) val <<- list(r = r, lines = lines, xy = as.matrix(d[, c("x", "y")])) } val @@ -65,8 +70,13 @@ test_that("a REML range the point pairs support is returned, and the same at any skip_if_not_installed("gstat") skip_if_not_installed("nlme") pts <- .r3s4_field(9, n = 300, rp = 10) - r5 <- estimate_sac_range(pts, "z", "cov", detrend = "reml") - r1 <- estimate_sac_range(pts, "z", "cov", detrend = "reml", cutoff = 0.1) + # Equal lags, whose first bin is the 30 m one this test is about, and the + # structure test off: a 30 m range on points about 29 m apart is below + # what that test detects (it is refused at the default, asserted below). + r5 <- estimate_sac_range(pts, "z", "cov", detrend = "reml", lags = "equal", + structure_alpha = 1) + r1 <- estimate_sac_range(pts, "z", "cov", detrend = "reml", cutoff = 0.1, + lags = "equal", structure_alpha = 1) expect_true(is.finite(r5)) expect_equal(as.numeric(r1), as.numeric(r5)) # Shorter than the first bin, which alone used to refuse it ... @@ -75,6 +85,13 @@ test_that("a REML range the point pairs support is returned, and the same at any d30 <- sort(as.numeric(stats::dist(sf::st_coordinates(pts))))[30] expect_gt(as.numeric(r5), d30) expect_null(attr(r5, "range_floor")) + # The structure test is attached either way, and at the default it decides. + expect_gte(attr(r5, "structure_p"), 0.05) + r0 <- suppressWarnings(estimate_sac_range(pts, "z", "cov", detrend = "reml")) + expect_true(is.na(r0)) + expect_identical(attr(r0, "rejected_reason"), + "no spatial structure detected at the nearest-neighbour scale") + expect_identical(attr(r0, "structure_p"), attr(r5, "structure_p")) }) test_that("a REML range below 30 pairs is refused, says so, and keeps the REML numbers", { @@ -103,27 +120,38 @@ test_that("a REML range below 30 pairs is refused, says so, and keeps the REML n expect_true(all(c("nugget_prop", "sigma2") %in% names(rm))) }) -test_that("the gstat-path floor refusal points at a smaller cutoff", { - # Not reachable on ordinary data (the binned fit did not go below the first - # lag on white noise or on 60 m fields), so the fit is stubbed to return a - # 6 m effective range on a field whose variogram rises normally. +test_that("the variogram-path floor refusal points at a smaller cutoff", { + # Hard to reach on ordinary data, so the fit is stubbed to return a 6 m + # effective range on a field whose variogram rises normally. The stub + # replaces .sac_fit_model(), the fit estimate_sac_range() makes; it used to + # replace gstat::fit.variogram(), which is no longer called. skip_if_not_installed("gstat") pts <- .r3s4_field(2, n = 150, rp = 100) local_mocked_bindings( - fit.variogram = function(object, model, ...) { + .sac_fit_model = function(vg, cutoff_dist, family = "Exp", upper = 4, ...) { m <- gstat::vgm(psill = 1, model = "Exp", range = 2, nugget = 0.2) attr(m, "singular") <- FALSE attr(m, "SSErr") <- 1 + attr(m, "converged") <- TRUE m - }, - .package = "gstat") - lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + }) + # Equal lags: a smaller cutoff narrows the bins, so that is the advice. + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z", lags = "equal")) expect_true(is.na(r)) expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") expect_equal(attr(r, "range_floor"), .r3s4_first_lag(r)) + expect_equal(attr(r, "first_lag"), .r3s4_first_lag(r)) expect_null(attr(r, "reml")) expect_true(log_has(lines, "shorter than the shortest lag the variogram resolves")) expect_true(log_has(lines, "re-run with a smaller `cutoff`")) + # Adaptive lags start at the closest pairs already, so a smaller cutoff is + # not offered: the points are too far apart for a range that short. + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") + expect_equal(attr(r, "range_floor"), .r3s4_first_lag(r)) + expect_true(log_has(lines, "shorter than the shortest lag the variogram resolves")) + expect_false(log_has(lines, "re-run with a smaller `cutoff`")) + expect_true(log_has(lines, "too far apart to measure a range that short")) }) diff --git a/tests/testthat/test-review3-S5-folds.R b/tests/testthat/test-review3-S5-folds.R index 910a2273..b9fa0c47 100644 --- a/tests/testthat/test-review3-S5-folds.R +++ b/tests/testthat/test-review3-S5-folds.R @@ -129,18 +129,21 @@ test_that("a single row of blocks is compared with the range along the row only" z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(x)) / 50) + diag(1e-6, n))) %*% rnorm(n)) p <- r2_pts(5e5 + x, rep(5e6, n), z = z) r <- suppressWarnings(as.numeric(estimate_sac_range(p, "z"))) - skip_if_not(is.finite(r) && r > 260 && r < 650, "range outside the fixture's window") + # The field's effective range is 150. The window was 260 to 650, around + # the 499 the equal-lag fit returned for it; the default lags now resolve + # the short lags and the estimate is 144. + skip_if_not(is.finite(r) && r > 100 && r < 250, "range outside the fixture's window") # Automatic grid: 15 x 1, blocks 667 m long, longer than the range. res <- r3_collect_warnings(r2_quiet( make_folds(p, k = 5, method = "block_kfold", response_var = "z", seed = 1))) expect_equal(c(res$value$params$grid_nx, res$value$params$grid_ny), c(15, 1)) expect_length(res$warnings, 0L) - # block_nx: 1000 m blocks are silent, 250 m blocks warn. + # block_nx: 1000 m blocks are silent, 100 m blocks warn. res <- r3_collect_warnings(r2_quiet( make_folds(p, k = 5, method = "block_kfold", response_var = "z", block_nx = 10, seed = 1))) expect_length(res$warnings, 0L) res <- r3_collect_warnings(r2_quiet( - make_folds(p, k = 5, method = "block_kfold", response_var = "z", block_nx = 40, seed = 1))) + make_folds(p, k = 5, method = "block_kfold", response_var = "z", block_nx = 100, seed = 1))) expect_length(res$warnings, 1L) expect_match(res$warnings, "block_nx/block_ny yield blocks smaller than autocorrelation range") @@ -167,11 +170,18 @@ test_that("a block size that leaves one block stops without announcing a lowered "the block size \\(600\\) produces a single block"), level = logger::INFO) expect_false(log_has(lines, "Reducing k to match")) - # Two blocks or more still lower k, and say so. + expect_false(log_has(lines, "returning [0-9]+ folds, not the k")) + # Two blocks or more still lower k, and say so. That was a log line only + # ("block_size produces only 4 blocks (< k = 5). Reducing k to match."), + # which this test pinned; it is now a warning of class + # spatialkit_k_reduced, logged as well. lines <- capture_spatialkit_log( - f <- make_folds(p, k = 5, method = "block_kfold", block_size = 400, seed = 1), + expect_warning( + f <- make_folds(p, k = 5, method = "block_kfold", block_size = 400, seed = 1), + "returning 4 folds, not the k = 5 asked for: block_size = 400 builds a 2 x 2 grid", + class = "spatialkit_k_reduced"), level = logger::INFO) - expect_true(log_has(lines, "block_size produces only 4 blocks \\(< k = 5\\). Reducing k")) + expect_true(log_has(lines, "returning 4 folds, not the k = 5 asked for")) expect_equal(f$k, 4L) }) diff --git a/tests/testthat/test-review3-S7-gwr-classes.R b/tests/testthat/test-review3-S7-gwr-classes.R index edb564ae..e9e26273 100644 --- a/tests/testthat/test-review3-S7-gwr-classes.R +++ b/tests/testthat/test-review3-S7-gwr-classes.R @@ -73,7 +73,7 @@ test_that("a regional covariate is still flagged, including a cluster at the glo expect_gte(flagged[[2L]], 55) }) -test_that("a far-from-zero origin flags the slopes only where GWmodel's solve degrades", { +test_that("a far-from-zero origin flags the slopes only for a fit GWmodel's solve made", { set.seed(1); n <- 200 x <- runif(n, 0, 10000); y <- runif(n, 0, 10000) el <- 500 + 150 * sin(x / 3000) + 100 * cos(y / 2500) + rnorm(n, 0, 5) @@ -81,18 +81,29 @@ test_that("a far-from-zero origin flags the slopes only where GWmodel's solve de s <- .gwr_local_collinearity(cbind(x, y), cbind(el), TRUE, 30, "bisquare") expect_gt(sum(!is.finite(s$cn) | s$cn > 30), 100) expect_equal(sum(.gwr_slopes_collinear(s)), 0L) - # Shifted until the uncentred index passes 1e6: flagged, on `cn` alone. + # Shifted until the uncentred index passes 1e6. That is where a solve of + # the uncentred normal equations, GWmodel's, loses the slopes, so a survey + # that belongs to such a fit (no `rank` column) is flagged on `cn` alone. s7 <- .gwr_local_collinearity(cbind(x, y), cbind(el + 1e7), TRUE, 30, "bisquare") expect_equal(s7$cn_slopes, s$cn_slopes, tolerance = 1e-6) expect_gt(sum(.gwr_slopes_collinear(s7)), 0L) expect_true(all(s7$cn[.gwr_slopes_collinear(s7)] > 1e6)) + # The package's solve centres each window and gives the same slopes at any + # origin: the survey of a fit it made carries the solve's rank, and is not + # flagged however large `cn` is. (Asserted the opposite before.) + expect_identical(sum(s7$cn > 1e6), sum(.gwr_slopes_collinear(s7))) + expect_identical(sum(.gwr_slopes_collinear(s7, own_solve = TRUE)), 0L) + expect_identical(sum(.gwr_slopes_collinear(cbind(s7, rank = 2L))), 0L) + # A `cn` that is singular to machine precision still counts. + s_inf <- cbind(s7, rank = 2L); s_inf$cn[1:3] <- Inf + expect_identical(which(.gwr_slopes_collinear(s_inf)), 1:3) # A survey made before cn_slopes existed falls back to cn > 30. old <- s[, c("row", "x", "y", "n_window", "cn")] expect_identical(.gwr_slopes_collinear(old), !is.finite(old$cn) | old$cn > 30) }) test_that("the same field in degrees C and in kelvin gets the same verdict and a drawable map", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") d <- .r3_temperature() rC <- .r3_catch(fit_gwr_model(d, "yield", "tC", bandwidth = 30)) rK <- .r3_catch(fit_gwr_model(d, "yield", "tK", bandwidth = 30)) @@ -130,7 +141,7 @@ test_that("the same field in degrees C and in kelvin gets the same verdict and a test_that("a far-from-zero predictor beside a second one no longer draws the global warning", { # v2.0.0 already warned on this for two or more predictors. - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") d <- .r3_temperature() rK <- .r3_catch(fit_gwr_model(d, "yield", c("tK", "nz"), bandwidth = 30)) rC <- .r3_catch(fit_gwr_model(d, "yield", c("tC", "nz"), bandwidth = 30)) @@ -148,69 +159,82 @@ test_that("a far-from-zero predictor beside a second one no longer draws the glo # --------------------------------------------------------------------------- # S7-GWR-CLASSES-3: the adaptive floor is not enough when neighbours tie at -# the kernel's edge (a regular grid); the warning and the fit error say so. +# the kernel's edge (a regular grid); the floor warning and the warning about +# the rank-deficient windows say so. # --------------------------------------------------------------------------- # A 10 x 10 grid of spacing 100 with predictor `a`. Away from the four # corners a point has three or four neighbours at 100 and none nearer, so at # the bisquare floor of 4 neighbours, the point itself counted, the kernel's # edge is at 100: they all get weight 0, and 96 local regressions hold their -# own point alone. X'WX is then [1, a; a, a^2], of rank 1 for two parameters. +# own point alone. One point for two parameters: rank 1. .r3_tied_grid <- function(a) { g <- expand.grid(x = 5e5 + (0:9) * 100, y = 5e6 + (0:9) * 100) g$a <- a; g$z <- 1 + 2 * g$a + rnorm(100) sf::st_as_sf(g, coords = c("x", "y"), crs = 32632) } -test_that("the floor warning and the singular-fit error name ties at the kernel's edge", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") - # Whether GWmodel calls a one-point window singular is a matter of rounding. - # Eliminating [1, a; a, a^2] leaves a^2 - a * a as the last pivot: 0 where - # the product is rounded before the subtraction, and the rounding error of - # a * a where the two are fused into one operation (as on arm64), unless - # a * a is exact. The predictor takes multiples of 1/8 in [-1, 1]: their - # squares are exact and none outranks the 1 as first pivot, so every step is - # exact, the pivot is 0 and the fit stops on any platform. +# What the fit on the tied grid has to be, whatever the predictor's values: +# returned, with 96 windows of rank 1 whose fitted value is their own +# observation, their slope NA, an undefined AICc, and warnings that say all +# of it. +.r3_expect_tied_fit <- function(r, d) { + expect_true(any(grepl("using 4\\. That is enough unless several neighbours tie at the kernel's edge", + r$warnings))) + expect_true(any(grepl("local collinearity: 96% of 100 locations have a collinear local design", + r$warnings))) + fit <- r$value + expect_s3_class(fit, "gwr_fit") + lc <- fit$info$local_collinearity + expect_identical(sum(lc$n_window == 1L & is.infinite(lc$cn)), 96L) + expect_identical(fit$info$n_local_collinear, 96L) + # The solve: 96 windows of rank 1, each saturated (leverage 1, the fitted + # value is the observation), and four corner windows of full rank. + expect_identical(as.integer(table(lc$rank)[c("1", "2")]), c(96L, 4L)) + expect_identical(fit$info$n_rank_deficient, 96L) + expect_identical(fit$info$n_saturated, 96L) + one <- lc$rank == 1L + expect_equal(lc$leverage[one], rep(1, 96L)) + expect_equal(fitted(fit)[one], d$z[one]) + expect_true(all(is.na(coef(fit)$a[one]))) + expect_false(anyNA(coef(fit)$a[!one])) + expect_identical(fit$info$n_local_singular, 96L) + # Not a silently interpolating fit: tr(S) is 99.4 of 100, so AICc is + # undefined and reported as NA, and both facts are warned about. + expect_gt(fit$info$tr_S, 99) + expect_true(is.na(fit$info$AICc)) + expect_length(grep("AICc is undefined", r$warnings), 1L) + w <- grep("local regressions are rank deficient", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "^fit_gwr_model\\(\\): 96 of 100 local regressions are rank deficient") + expect_match(w, "96 of those windows hold as many weighted observations as they have estimable coefficients") + expect_match(w, "neighbours tied at the kernel's edge \\(a regular grid\\)") +} + +test_that("the floor warning and the rank-deficiency warning name ties at the kernel's edge", { + skip_if_not_installed("sp") + # A one-point window gave GWmodel's solver [1, a; a, a^2] to invert, whose + # last pivot a^2 - a * a is 0 where the product is rounded before the + # subtraction and the rounding error of a * a where the two are fused (as + # on arm64), unless a * a is exact. With the predictor in eighths every + # step is exact, and the fit stopped on any platform; with normal draws it + # stopped or returned slopes of -45 to 77 around a true 2 according to the + # platform. The local solve returns the same fit for both. set.seed(2) d <- .r3_tied_grid(sample(seq(-1, 1, by = 0.125), 100, replace = TRUE)) r <- .r3_catch(fit_gwr_model(d, "z", "a", bandwidth = 2)) - expect_true(any(grepl("using 4\\. That is enough unless several neighbours tie at the kernel's edge", - r$warnings))) - expect_type(r$value, "character") - expect_match(r$value, "survey found 96 singular window") - expect_match(r$value, "neighbours tied at the kernel's edge \\(a regular grid\\)") + .r3_expect_tied_fit(r, d) # Kernels that keep the edge point are not told about ties. rg <- .r3_catch(fit_gwr_model(d, "z", "a", bandwidth = 2, kernel = "gaussian")) expect_false(any(grepl("tie at the kernel's edge", rg$warnings))) }) -test_that("a continuous predictor on the tied grid is flagged whether or not GWmodel stops", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") - # The squares of normal draws are rounded, so GWmodel stops on the 96 - # one-point windows or returns coefficients for them according to the - # platform's arithmetic. The survey does not depend on that: it counts the - # points that carry weight, and warns before the fit. +test_that("a continuous predictor on the tied grid gives the same fit as one in eighths", { + skip_if_not_installed("sp") set.seed(2) d <- .r3_tied_grid(rnorm(100)) r <- .r3_catch(fit_gwr_model(d, "z", "a", bandwidth = 2)) - expect_true(any(grepl("using 4\\. That is enough unless several neighbours tie at the kernel's edge", - r$warnings))) - expect_true(any(grepl("local collinearity: 96% of 100 locations have a collinear local design", - r$warnings))) - if (is.character(r$value)) { - expect_match(r$value, "survey found 96 singular window") - expect_match(r$value, "neighbours tied at the kernel's edge \\(a regular grid\\)") - } else { - # The fit that comes back carries the survey: the 96 windows are there to - # be read, each with one point and an infinite condition index. - expect_s3_class(r$value, "gwr_fit") - lc <- r$value$info$local_collinearity - expect_identical(sum(lc$n_window == 1L & is.infinite(lc$cn)), 96L) - expect_identical(r$value$info$n_local_collinear, 96L) - skip(paste0("GWmodel returned coefficients for the 96 one-point windows ", - "instead of stopping, so the singular-fit error is not reached ", - "with a continuous predictor on this platform")) - } + .r3_expect_tied_fit(r, d) }) @@ -237,7 +261,7 @@ test_that("gwr_model_selection() refuses an adaptive count below 1 or above R's }) test_that("cv_gwr() refuses an adaptive count below 1 up front, not in every fold", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") set.seed(1); n <- 60 dat <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), a = rnorm(n)), @@ -256,7 +280,7 @@ test_that("cv_gwr() refuses an adaptive count below 1 up front, not in every fol # --------------------------------------------------------------------------- test_that("the undefined-AICc warning gives advice that can be followed", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") set.seed(4); n <- 4 dat <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), a = rnorm(n), b = rnorm(n)), @@ -290,11 +314,16 @@ test_that("the undefined-AICc warning gives advice that can be followed", { # about a fixed bandwidth in the wrong units, and about a singular window. # --------------------------------------------------------------------------- -test_that("gwr_model_selection() warns about a tiny fixed bandwidth and explains a singular window", { - expect_match(.gwr_singular_hint(), "^ -- at least one local window's design is singular") - expect_no_match(.gwr_singular_hint(), "survey found") - expect_match(.gwr_singular_hint(3L), "The collinearity survey found 3 singular window") - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") +test_that("gwr_model_selection() warns about a tiny fixed bandwidth, and the rank hint names the causes", { + # No window stops a fit or a sweep any more, so there is no solver error to + # explain; the causes are named in the warning fit_gwr_model() raises about + # windows of deficient rank, and a selected bandwidth is called selected. + expect_match(.gwr_rank_hint(), "^ Typical causes are a predictor that is constant inside a window") + expect_match(.gwr_rank_hint(), "a mixed GWR, GWmodel::gwr.mixed\\(\\)\\)\\.$") + expect_no_match(.gwr_rank_hint(), "No bandwidth was supplied") + expect_match(.gwr_rank_hint("150"), + "No bandwidth was supplied: the search selected this one \\(150\\)") + skip_if_not_installed("sp") set.seed(1); n <- 60 dat <- sf::st_as_sf(data.frame(x = -80 + runif(n, 0, 0.5), y = 35 + runif(n, 0, 0.5), a = rnorm(n), b = rnorm(n)), @@ -304,10 +333,13 @@ test_that("gwr_model_selection() warns about a tiny fixed bandwidth and explains adaptive = FALSE)) expect_true(any(grepl("^gwr_model_selection\\(\\): a fixed bandwidth of 0.2 is less than a ten-thousandth", r$warnings))) - # What GWmodel then does with empty windows is a backend property; when it - # is the singular-matrix error, the error explains it. - if (is.character(r$value) && grepl("singular", r$value)) - expect_match(r$value, "local window's design is singular") + # At 0.2 m every window holds its own observation alone, every model + # interpolates, and no AICc is defined: the sweep says so and selects + # nothing. + expect_true(any(grepl("AICc is undefined for 4 of 4 model\\(s\\) at bandwidth 0.2", + r$warnings))) + expect_type(r$value, "character") + expect_match(r$value, "no model produced a finite criterion") # A bandwidth in the units the sweep runs in draws no such warning. ok <- .r3_catch(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 20000, adaptive = FALSE)) @@ -342,7 +374,7 @@ test_that("print() shows a fixed bandwidth with its unit and an adaptive one as # --------------------------------------------------------------------------- test_that("fit_gwr_model() refuses a non-numeric response up front", { - skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + skip_if_not_installed("sp") s <- surf_test_points(60) s$zc <- as.character(round(s$z, 3)) r <- .r3_catch(fit_gwr_model(s, "zc", "w")) diff --git a/tests/testthat/test-review3-final-A.R b/tests/testthat/test-review3-final-A.R index 2426101b..831178b3 100644 --- a/tests/testthat/test-review3-final-A.R +++ b/tests/testthat/test-review3-final-A.R @@ -47,7 +47,8 @@ test_that("area_of_applicability() takes the folds cv_*() takes when prep_model_ pts <- .fa_pts() pts$z[50] <- NA folds <- make_folds(pts, k = 4, method = "block_kfold", seed = 1) - prep <- .fa_quiet(prep_model_data(pts, "z", c("a", "b"))) + expect_warning(prep <- .fa_quiet(prep_model_data(pts, "z", c("a", "b"))), + class = "spatialkit_rows_dropped") expect_identical(nrow(prep), 119L) fit <- lm_spatial_fit(prep, "z", c("a", "b")) new <- pts[1:5, ] @@ -91,8 +92,9 @@ test_that("area_of_applicability() takes the folds cv_*() takes when prep_model_ p2 <- pts p2$..row_id <- 1000L + seq_len(nrow(p2)) f2 <- make_folds(p2, k = 4, method = "block_kfold", seed = 1) - fit2 <- lm_spatial_fit(.fa_quiet(prep_model_data(p2, "z", c("a", "b"))), - "z", c("a", "b")) + expect_warning(prep2 <- .fa_quiet(prep_model_data(p2, "z", c("a", "b"))), + class = "spatialkit_rows_dropped") + fit2 <- lm_spatial_fit(prep2, "z", c("a", "b")) expect_equal(area_of_applicability(new, model = fit2, folds = f2)$threshold, ref$threshold) }) @@ -101,8 +103,9 @@ test_that("a fold ID naming a row the data never had is still refused", { pts <- .fa_pts() pts$z[50] <- NA folds <- make_folds(pts, k = 4, method = "block_kfold", seed = 1) - fit <- lm_spatial_fit(.fa_quiet(prep_model_data(pts, "z", c("a", "b"))), - "z", c("a", "b")) + expect_warning(prep <- .fa_quiet(prep_model_data(pts, "z", c("a", "b"))), + class = "spatialkit_rows_dropped") + fit <- lm_spatial_fit(prep, "z", c("a", "b")) folds$folds[[1]]$test <- c(folds$folds[[1]]$test, 999L) expect_error(area_of_applicability(pts[1:5, ], model = fit, folds = folds), "names 1 ..row_id value\\(s\\) that are not in the training data \\(first: 999\\)") @@ -217,7 +220,7 @@ test_that("resolution_profile() refuses a units `sac` and a character one by nam # cells, with nothing said. expect_error(resolution_profile(pts, "z", sac = units::set_units(1.5, "km"), n_levels = 4), - "`sac` must be an estimate_sac_range\\(\\) result.*got 1\\.5 \\[km\\]") + "`sac` must be NULL, \"auto\", an estimate_sac_range\\(\\) result.*got 1\\.5 \\[km\\]") expect_error(resolution_profile(pts, "z", sac = "300", n_levels = 4), "got an object of class character") }) diff --git a/tests/testthat/test-review3-final-B.R b/tests/testthat/test-review3-final-B.R index 2f25f631..211e34c2 100644 --- a/tests/testthat/test-review3-final-B.R +++ b/tests/testthat/test-review3-final-B.R @@ -146,34 +146,46 @@ test_that("estimate_sac_range()'s early NA returns carry a rejected_reason and n }) -# ---- S11-contracts-7: the verdict fits the fold scheme ---------------------- - -test_that("fold_separation()'s verdict names a remedy the fold scheme has", { +# ---- S11-contracts-7: the closing lines fit what was measured --------------- + +# This test pinned a verdict per fold scheme ("optimistic: widen the blocks", +# "widen the buffer", "use blocked or buffered folds"), drawn from the share +# of held-out points inside the range. That share gives no direction (the +# same 100% goes with an unbiased score on even siting and a score 20% low on +# clustered siting), so the verdict and its remedies are gone: without a +# prediction target the print states distances and concludes nothing, for +# every scheme. The new behaviour is tested in +# test-fix-folds-separation-target.R; what is kept here is that no scheme is +# given a remedy it does not have, or any remedy at all. +test_that("fold_separation() names no verdict and no remedy without a target", { adv <- spatialkit:::.fold_separation_advice - expect_match(adv("block_kfold", 0.9), "optimistic: widen the blocks\\.$") - expect_match(adv("block_kfold", 0.3), "contiguous blocks at the edges") - expect_match(adv("buffered_loo", 0.9), "widen the buffer") - for (m in c("random_kfold", "leave_location_out", "supplied splits", NA)) { - expect_no_match(adv(m, 0.9), "blocks") - expect_match(adv(m, 0.9), "use blocked or buffered folds") - expect_no_match(adv(m, 0.3), "contiguous blocks") + for (m in c("block_kfold", "buffered_loo", "random_kfold", "leave_location_out", + "nndm", "supplied splits", NA)) { + txt <- adv(NULL, m) + expect_match(txt, "No prediction target is given") + for (gone in c("optimistic", "leak", "widen", "use blocked or buffered folds", + "contiguous blocks")) + expect_no_match(txt, gone) } - expect_no_match(adv("nndm", 0.9), "optimistic") - expect_match(adv("nndm", 0.9), "prediction points") - expect_match(adv("nndm", 0.05), "Little of the hold-out") set.seed(1) p <- r2_pts(runif(60, 0, 1000), runif(60, 0, 1000)) flatten <- function(x) gsub("\\s+", " ", paste(x, collapse = " ")) rnd <- make_folds(p, k = 3, method = "random_kfold", seed = 1) out <- flatten(utils::capture.output(print(fold_separation(rnd, p, sac = 500)))) - expect_match(out, "closer to a training point") + expect_match(out, "from their nearest training point") + expect_match(out, "No prediction target is given") expect_no_match(out, "widen the blocks") + expect_no_match(out, "optimistic") + # NNDM folds carry the distances from the prediction points they were + # built for, so they are read against those, and still not called + # optimistic. grid <- sf::st_as_sf(sf::st_make_grid(p, n = c(8, 8), what = "centers")) nn <- r2_quiet(suppressWarnings(make_folds(p, k = 5, method = "nndm", prediction_points = grid))) out_nn <- flatten(utils::capture.output(print(fold_separation(nn, p, sac = 500)))) - expect_match(out_nn, "closer to a training point") + expect_match(out_nn, "from their nearest training point") + expect_match(out_nn, "the prediction points the NNDM folds were built for") expect_no_match(out_nn, "optimistic") expect_no_match(out_nn, "widen the blocks") }) diff --git a/tests/testthat/test-sac-range.R b/tests/testthat/test-sac-range.R index c0e77832..30bc3eed 100644 --- a/tests/testthat/test-sac-range.R +++ b/tests/testthat/test-sac-range.R @@ -150,36 +150,39 @@ test_that("the all-pairs fit is the estimate, not the widest direction", { expect_lt(abs(as.numeric(r) / TRUE_RANGE - 1), 0.5) }) -test_that("the variogram fit does not depend on gstat's default starting range", { - # gstat starts the optimiser at a third of the longest lag. For a field - # whose range is a small fraction of the extent that is ten times too long, - # and whether the iteration lands or collapses to a singular model depended - # on floating-point details: the same 250-point field fitted on Linux and - # came back singular on an arm64 Mac, where the estimate then fell through - # to the directional maximum (315 against a true range of 80). Several - # starting ranges are tried now, and the best converged fit by gstat's own - # criterion is kept. Made deterministic: the default start (range = NA) - # is forced singular, and the answer must be the one the other starts give. +test_that("the variogram fit has no start value and does not call gstat's iterative fit", { + # gstat::fit.variogram() starts its optimiser at a third of the longest + # lag. For a field whose range is a small fraction of the extent that is + # ten times too long, and whether the iteration landed or collapsed to a + # singular model depended on floating-point details: the same 250-point + # field fitted on Linux and came back singular on an arm64 Mac, where the + # estimate then fell through to the directional maximum (315 against a + # true range of 80). The model is now fitted by a search over the range + # with the nugget and the partial sill solved exactly at each trial range + # (.sac_fit_model()), which has no start and cannot be singular. This + # test used to force gstat's default start to fail and expect the other + # starts to agree; fit.variogram() is not called at all now, so that mock + # did nothing and the test compared an estimate with itself. What is + # true now is asserted instead: the call would stop if it were made. skip_if_not_installed("gstat") pts <- sac_test_field() plain <- estimate_sac_range(pts, "z", seed = 1) expect_false(is.na(plain)) - real_fit <- gstat::fit.variogram local_mocked_bindings( - fit.variogram = function(object, model, ...) { - if (anyNA(model$range)) { - model$psill <- c(0, 0); model$range <- c(0, max(object$dist) / 3) - attr(model, "singular") <- TRUE - return(model) - } - real_fit(object, model, ...) - }, + fit.variogram = function(...) stop("gstat::fit.variogram() was called"), .package = "gstat") - retried <- estimate_sac_range(pts, "z", seed = 1) - expect_false(is.na(retried)) - expect_false(isTRUE(attr(retried, "anisotropy_used"))) - expect_equal(as.numeric(retried), as.numeric(plain), tolerance = 0.1) - expect_lt(abs(as.numeric(retried) / TRUE_RANGE - 1), 0.5) + for (binning in c("adaptive", "equal")) { + again <- estimate_sac_range(pts, "z", seed = 1, lags = binning) + expect_false(is.na(again), info = binning) + expect_false(isTRUE(attr(again, "anisotropy_used")), info = binning) + expect_lt(abs(as.numeric(again) / TRUE_RANGE - 1), 0.5) + # No start, so nothing to differ by: the model is marked as a minimum + # and the same call gives the identical object. + expect_true(attr(attr(again, "variogram_model"), "converged"), info = binning) + expect_identical(estimate_sac_range(pts, "z", seed = 1, lags = binning), again, + info = binning) + } + expect_identical(estimate_sac_range(pts, "z", seed = 1), plain) }) test_that("the returned range behaves as an ordinary number", { @@ -760,8 +763,15 @@ test_that("an all-pairs fit past the fitted lags is refused even when two direct # while the documentation said a trend is caught by the fitted-lag bound. # Whether two directions happened to fit flipped the answer between NA and # a finite range from draw to draw (12 of 30 went this way). + # + # Those numbers are of seed 11 under gstat's iterative fit, where the test + # then waited, behind a skip, for two directions to converge. The fit is + # deterministic now and seed 11 never gave it two, so the test was skipped + # on every run. Seed 15 gives the case outright: the pooled range is 1491 + # against a largest lag of 686, and the 0 and 135 degree directions are + # identified at 151 and 431. skip_if_not_installed("gstat") - set.seed(11) + set.seed(15) n <- 300 x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) d <- as.matrix(stats::dist(cbind(x, y))) @@ -769,9 +779,8 @@ test_that("an all-pairs fit past the fitted lags is refused even when two direct pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) st <- attr(r, "directional_status") - # The path under test needs two directions that reached a sill; that is a - # property of this draw on this platform's gstat, not of the code. - skip_if(sum(st == "ok") < 2L, "fewer than two directions reached a sill on this platform") + # The path under test needs two directions that reached a sill. + expect_gte(sum(st == "ok"), 2L) expect_true(is.na(r)) expect_s3_class(r, "sac_range") expect_identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted") @@ -796,8 +805,13 @@ test_that("a REML range shorter than the shortest lag is refused, not returned", d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), z = rnorm(n), w = rnorm(n)) pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + # structure_alpha = 1: white noise is refused for want of spatial structure + # before any range is looked at (asserted at the end), and this test is + # about the floor a REML range has to clear when that refusal is off. + # lags = "equal": the first lag "about 30 m" above is that of equal bins. lines <- capture_spatialkit_log( - r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml"))) + r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml", + lags = "equal", structure_alpha = 1))) expect_true(is.na(r)) expect_s3_class(r, "sac_range") expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") @@ -812,6 +826,11 @@ test_that("a REML range shorter than the shortest lag is refused, not returned", expect_true(is.finite(ok)) vg_ok <- attr(ok, "variogram") expect_gt(as.numeric(ok), min(vg_ok$dist[vg_ok$np > 0])) + # At the default the same white noise gets no range for the plainer reason. + r0 <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml")) + expect_true(is.na(r0)) + expect_identical(attr(r0, "rejected_reason"), + "no spatial structure detected at the nearest-neighbour scale") }) test_that("print() says what the range is a length in, and of what", { @@ -856,20 +875,27 @@ test_that("the anisotropy note points at the directional ranges that stay usable }) test_that("a small sample refused as 'decreases with distance' says sampling noise can do it", { - # 30 points of an ordinary exponential field: the short-lag bins are noisy - # enough to fall by 15%, and the refusal named only a periodic structure or - # a cluster whose variance differs. + # A small sample of an ordinary exponential field: the short-lag bins are + # noisy enough to fall by 15%, and the refusal named only a periodic + # structure or a cluster whose variance differs. + # + # The draw was 30 points at seed 2, behind a skip for the case that its + # short lags did not fall, and they did not on any run: the message for + # samples under 100 points had no test. These 80 points pass the test for + # spatial structure (p under 0.001) and their variogram falls from 1.42 at + # a lag of 95 to 1.02 at 258. skip_if_not_installed("gstat") - set.seed(2) - n <- 30 + set.seed(11) + n <- 80 x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) d <- as.matrix(stats::dist(cbind(x, y))) z <- as.numeric(t(chol(exp(-d / 50) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) - skip_if(!identical(attr(r, "rejected_reason"), "empirical variogram decreases with distance"), - "this draw's short lags did not fall on this platform") - expect_true(log_has(lines, "With 30 points the short-lag bins are noisy")) + expect_true(is.na(r)) + expect_identical(attr(r, "rejected_reason"), "empirical variogram decreases with distance") + expect_true(spatialkit:::.variogram_decreasing(attr(r, "variogram"))) + expect_true(log_has(lines, "With 80 points the short-lag bins are noisy")) # A large sample is not told that. big <- capture_spatialkit_log(suppressWarnings(estimate_sac_range(sac_test_field(), "z", range_frac = 1e-6))) diff --git a/tests/testthat/test-spatial-fit-s3.R b/tests/testthat/test-spatial-fit-s3.R index bbe283b5..10876283 100644 --- a/tests/testthat/test-spatial-fit-s3.R +++ b/tests/testthat/test-spatial-fit-s3.R @@ -79,7 +79,9 @@ test_that("print.spatial_fit labels and details a gwr_fit", { AICc = 412.25, bandwidth_is_fallback = FALSE)) txt <- .s3_printed(gwr) - expect_match(txt, " spatial model fit", fixed = TRUE) + # No GWmodel code computes the fit any more, so the header does not name it. + expect_match(txt, " spatial model fit", fixed = TRUE) + expect_false(grepl("GWmodel", txt, fixed = TRUE)) expect_match(txt, "Bandwidth: 37.5 neighbours (adaptive, gaussian kernel)", fixed = TRUE) expect_match(txt, "AICc : 412.25", fixed = TRUE) @@ -304,7 +306,7 @@ test_that("coef() on a spatial_fit errors rather than returning NULL", { gwr <- new_spatial_fit("gwr_fit", engine = list(), formula = z ~ w, response_var = "z", predictor_vars = "w", data_sf = pts, info = list()) - expect_error(coef(gwr), "no GWmodel `SDF` component") + expect_error(coef(gwr), "no `SDF` component") bay <- new_spatial_fit("bayesian_fit", engine = list(), formula = z ~ w, response_var = "z", predictor_vars = "w", diff --git a/tests/testthat/test-summarize-by-cell.R b/tests/testthat/test-summarize-by-cell.R index fbd59e12..823b61b9 100644 --- a/tests/testthat/test-summarize-by-cell.R +++ b/tests/testthat/test-summarize-by-cell.R @@ -24,7 +24,7 @@ test_that("summarize_by_cell default deff=1 gives classic SE", { pts <- .make_test_points(rho = 0) - out <- summarize_by_cell(pts, response_var = "y") + out <- summarize_by_cell(pts, response_var = "y", estimate = "mean") # SE should equal sd / sqrt(n) for each cell for (i in seq_len(nrow(out))) { expected_se <- out[["..sd_resp_y"]][i] / sqrt(out$n[i]) @@ -44,8 +44,8 @@ test_that("a numeric deff inflates every SE by exactly sqrt(deff)", { # cell's SE instead of multiplying it by sqrt(2), and return NA for every # cell with n <= deff. pts <- .make_test_points(rho = 0) - out_1 <- summarize_by_cell(pts, response_var = "y", deff = 1) - out_2 <- summarize_by_cell(pts, response_var = "y", deff = 2) + out_1 <- summarize_by_cell(pts, response_var = "y", deff = 1, estimate = "mean") + out_2 <- summarize_by_cell(pts, response_var = "y", deff = 2, estimate = "mean") ratio <- out_2[["..se_resp_y"]] / out_1[["..se_resp_y"]] expect_equal(ratio, rep(sqrt(2), length(ratio)), tolerance = 1e-12) expect_false(anyNA(out_2[["..se_resp_y"]])) @@ -59,8 +59,8 @@ test_that("a numeric deff inflates every SE by exactly sqrt(deff)", { # Small cells: n = 3 with deff = 3 used to come back NA, and n = 3 with # deff = 2 used to be doubled. Both are now sqrt(deff) like every other cell. small <- .make_test_points(n_cells = 3, pts_per_cell = 3, rho = 0) - s1 <- summarize_by_cell(small, response_var = "y", deff = 1) - s3 <- summarize_by_cell(small, response_var = "y", deff = 3) + s1 <- summarize_by_cell(small, response_var = "y", deff = 1, estimate = "mean") + s3 <- summarize_by_cell(small, response_var = "y", deff = 3, estimate = "mean") expect_false(anyNA(s3[["..se_resp_y"]])) expect_equal(s3[["..se_resp_y"]] / s1[["..se_resp_y"]], rep(sqrt(3), nrow(s1)), tolerance = 1e-12) @@ -79,8 +79,8 @@ test_that("an ESTIMATED design effect also corrects the biased sample variance", # the sqrt((n-1)/(n-deff)) rescale, 0.952 / 0.952 / 0.953 against a nominal # 0.95. This is what distinguishes the estimated paths from a constant. pts <- .make_test_points(n_cells = 8, pts_per_cell = 20, rho = 0.6) - o_iid <- summarize_by_cell(pts, response_var = "y", deff = 1) - o_k <- summarize_by_cell(pts, response_var = "y", deff = "kish") + o_iid <- summarize_by_cell(pts, response_var = "y", deff = 1, estimate = "mean") + o_k <- summarize_by_cell(pts, response_var = "y", deff = "kish", estimate = "mean") da <- attr(o_k, "deff_applied") skip_if(is.null(da) || !is.numeric(da$deff), "the ICC came out non-positive on this draw") @@ -134,7 +134,7 @@ test_that("summarize_by_cell deff='kish' applies Kish's exact 1 + (n-1) rho", { crs = 32632) ) - out <- summarize_by_cell(pts, response_var = "y", deff = "kish") + out <- summarize_by_cell(pts, response_var = "y", deff = "kish", estimate = "mean") # The ICC itself, from an INDEPENDENT one-way random-effects ANOVA with # Donner's (1986) n0 for unbalanced cells -- what ?summarize_by_cell @@ -239,7 +239,7 @@ test_that("summarize_by_cell reports NA spread for a one-observation cell", { for (dv in list(1, "kish")) { out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", - deff = dv) + deff = dv, estimate = "mean") lone <- out$n == 1L multi <- !lone expect_equal(sum(lone), 2L) @@ -279,7 +279,7 @@ test_that("summarize_by_cell deff='kish' estimates separate ICC for response and ) ) out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "x", - deff = "kish") + deff = "kish", estimate = "mean") da <- attr(out, "deff_applied") expect_equal(da$method, "kish") # Response ICC should be much larger than predictor ICC @@ -291,8 +291,8 @@ test_that("summarize_by_cell deff='kish' estimates separate ICC for response and # shrank ..se_resp_y by a factor of 20 the moment predictor_vars was added # -- passed every test (mutation testing, pass 6). The same coupling was # once a real bug for cell_weight (see the source), so pin all three. - only <- summarize_by_cell(pts, response_var = "y", deff = "kish") - pred_only <- summarize_by_cell(pts, response_var = "x", deff = "kish") + only <- summarize_by_cell(pts, response_var = "y", deff = "kish", estimate = "mean") + pred_only <- summarize_by_cell(pts, response_var = "x", deff = "kish", estimate = "mean") expect_equal(out[["..se_resp_y"]], only[["..se_resp_y"]], tolerance = 1e-12) expect_equal(out[["..se_pred_x"]], pred_only[["..se_resp_x"]], tolerance = 1e-12) expect_equal(out$cell_weight, only$cell_weight, tolerance = 1e-12) @@ -305,10 +305,11 @@ test_that("summarize_by_cell deff='kish' estimates separate ICC for response and }) -test_that("summarize_by_cell ICC z-scores predictors so scale does not dominate", { - # Regression test: if predictors are NOT standardised before pooling, - # a large-scale variable dominates and the predictor ICC reflects only - # that variable. After z-scoring, both contribute equally. +test_that("summarize_by_cell gives each predictor its own ICC, whatever its scale", { + # This test used to pin ONE pooled predictor ICC (the mean of the + # per-column ICCs, z-scored so scale did not dominate). A pooled value is + # right for a column only when every predictor shares it, so each predictor + # now has its own, and the assertions below are the per-column ones. set.seed(42) n_cells <- 10; n_per <- 30 ids <- rep(seq_len(n_cells), each = n_per) @@ -335,58 +336,51 @@ test_that("summarize_by_cell ICC z-scores predictors so scale does not dominate" ) ) - # ICC with both predictors (pooled, z-scored) + # ICCs with both predictors listed: one per column out_both <- summarize_by_cell(pts, response_var = "y", predictor_vars = c("x_small", "x_big"), - deff = "kish") + deff = "kish", estimate = "mean") da_both <- attr(out_both, "deff_applied") # ICC with only the small-scale predictor out_small <- summarize_by_cell(pts, response_var = "y", predictor_vars = "x_small", - deff = "kish") + deff = "kish", estimate = "mean") da_small <- attr(out_small, "deff_applied") - # --- The property z-scoring exists for: unit invariance ------------------- - # Re-express either predictor in units 10^6 times larger. Standardising - # before pooling makes the pooled ICC EXACTLY unchanged. Without it the - # rescaled column carries essentially all the pooled variance, so the answer - # would be that column's own ICC. + # --- Unit invariance, per column ------------------------------------------- + # Re-express either predictor in units 10^6 times larger: an ICC is a ratio + # of variances of one column, so neither column's ICC moves. .rescaled <- function(small_mult, big_mult) { p <- pts p$x_small <- p$x_small * small_mult p$x_big <- p$x_big * big_mult attr(summarize_by_cell(p, response_var = "y", predictor_vars = c("x_small", "x_big"), - deff = "kish"), "deff_applied")$icc_pred + deff = "kish", estimate = "mean"), "deff_applied")$icc_pred } expect_equal(.rescaled(1, 1e6), da_both$icc_pred, tolerance = 1e-10) expect_equal(.rescaled(1e6, 1), da_both$icc_pred, tolerance = 1e-10) - # --- The pooled value is the (weighted) MEAN of the per-column ICCs ------- - # Each z-scored column contributes its own cells as separate groups to one - # pooled one-way ANOVA, so with equal cell sizes the pooled ICC is the - # average of the per-column ICCs. x_big has essentially no intra-cell - # correlation, so the pooled value sits near rho_small / 2. - # - # An earlier version of this test bracketed rho_small / 4 and derived it - # from pooling the two columns under the SAME cell labels. That derivation - # was correct about the code and wrong about the statistic: independent - # per-column cell effects average away in a shared cell mean, and the - # between-cell sum of squares shrinks by about 1/m. Measured with four - # columns at true rho = 0.5, the old pooled ICC was 0.12 (per-column ANOVA - # 0.495), so every predictor SE was ~44% too small. + # --- One ICC per predictor column, named by column -------------------------- + expect_named(da_both$icc_pred, c("x_small", "x_big")) + # Each equals the ICC the column gets when it is the only predictor: the + # clustered column keeps its own, and the unclustered one is not pulled up + # to a pooled value (which was their mean, 0.46, for both). out_big <- summarize_by_cell(pts, response_var = "y", - predictor_vars = "x_big", deff = "kish") - icc_big <- attr(out_big, "deff_applied")$icc_pred - if (is.null(icc_big)) icc_big <- 0 # deff not applied when ICC <= 0 - expect_equal(da_both$icc_pred, (da_small$icc_pred + icc_big) / 2, - tolerance = 0.06) - # Regression guard against the shared-label pooling: that gave ~rho/4. - expect_gt(da_both$icc_pred, 0.35 * da_small$icc_pred) - - # And it is genuinely pulled by BOTH: strictly under the small-only ICC. - expect_lt(da_both$icc_pred, da_small$icc_pred) + predictor_vars = "x_big", deff = "kish", estimate = "mean") + expect_equal(da_both$icc_pred[["x_small"]], da_small$icc_pred[["x_small"]], + tolerance = 1e-12) + expect_equal(da_both$icc_pred[["x_big"]], attr(out_big, "icc")$pred[["x_big"]], + tolerance = 1e-12) + expect_gt(da_both$icc_pred[["x_small"]], 0.8) + expect_lt(da_both$icc_pred[["x_big"]], 0.05) + # And the standard errors follow: each column's SE is the one-predictor + # call's, so listing the other predictor changes nothing. + expect_equal(out_both[["..se_pred_x_small"]], out_small[["..se_pred_x_small"]], + tolerance = 1e-12) + expect_equal(out_both[["..se_pred_x_big"]], out_big[["..se_pred_x_big"]], + tolerance = 1e-12) }) @@ -398,7 +392,7 @@ test_that("summarize_by_cell invalid deff falls back to 1, with a real warning", # records that (no deff_applied is attached at deff = 1). So this has to be # a real R condition, not only a log line: assert the condition itself. expect_warning( - out <- summarize_by_cell(pts, response_var = "y", deff = -1), + out <- summarize_by_cell(pts, response_var = "y", deff = -1, estimate = "mean"), "must be a single number >= 1" ) @@ -412,7 +406,7 @@ test_that("summarize_by_cell invalid deff falls back to 1, with a real warning", # A design effect BELOW 1 would shrink the standard errors, so it takes the # same branch rather than being honoured. expect_warning( - out_half <- summarize_by_cell(pts, response_var = "y", deff = 0.5), + out_half <- summarize_by_cell(pts, response_var = "y", deff = 0.5, estimate = "mean"), "must be a single number >= 1" ) expect_equal(out_half[["..se_resp_y"]], out[["..se_resp_y"]], @@ -420,14 +414,14 @@ test_that("summarize_by_cell invalid deff falls back to 1, with a real warning", # A non-numeric, non-keyword value takes the same branch. expect_warning( - out2 <- summarize_by_cell(pts, response_var = "y", deff = "nonsense"), + out2 <- summarize_by_cell(pts, response_var = "y", deff = "nonsense", estimate = "mean"), "must be a single number >= 1" ) expect_null(attr(out2, "deff_applied")) # A vector is not a single number either. expect_warning( - summarize_by_cell(pts, response_var = "y", deff = c(2, 3)), + summarize_by_cell(pts, response_var = "y", deff = c(2, 3), estimate = "mean"), "must be a single number >= 1" ) }) @@ -449,7 +443,7 @@ test_that("summarize_by_cell joins cells_sf even when ID types differ", { ) ) - out <- summarize_by_cell(pts, response_var = "y", cells_sf = cells) + out <- summarize_by_cell(pts, response_var = "y", cells_sf = cells, estimate = "mean") # Result should be an sf object (geometry joined from cells_sf) expect_s3_class(out, "sf") # All 3 cells should be present with no NA from a failed join @@ -507,7 +501,7 @@ test_that("summarize_by_cell(deff = 'variogram') applies sum(R)/n per cell", { expect_false(is.null(attr(sac, "variogram_model"))) out <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac) + sac = sac, estimate = "mean") da <- attr(out, "deff_applied") expect_equal(da$method, "variogram") @@ -523,7 +517,7 @@ test_that("summarize_by_cell(deff = 'variogram') applies sum(R)/n per cell", { # .se_with_deff() applies on the Kish path -- sqrt(deff) for the mean's # inflated variance AND sqrt((n-1)/(n-deff)) for the downward bias in s^2 -- # so the two paths cannot drift apart. - iid <- summarize_by_cell(pts, response_var = "z", deff = 1) + iid <- summarize_by_cell(pts, response_var = "z", deff = 1, estimate = "mean") infl <- sqrt(da$deff) * sqrt((out$n - 1) / (out$n - da$deff)) expect_equal(out[["..se_resp_z"]], iid[["..se_resp_z"]] * infl, tolerance = 1e-10) @@ -545,9 +539,9 @@ test_that("summarize_by_cell passes deff_max_n through to the subsampler", { sac <- suppressWarnings(estimate_sac_range(pts, "z")) full <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac) + sac = sac, estimate = "mean") capped <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac, deff_max_n = 10L) + sac = sac, deff_max_n = 10L, estimate = "mean") da_cap <- attr(capped, "deff_applied") expect_equal(da_cap$max_n, 10L) @@ -568,7 +562,7 @@ test_that("summarize_by_cell passes deff_max_n through to the subsampler", { # attribute was checked: building the closure's deff from the SUBSAMPLE size # understated the SE of a 25-point cell by 2.5x with the attribute unchanged # (mutation testing, pass 6). Same identity as the uncapped test above. - iid <- summarize_by_cell(pts, response_var = "z", deff = 1) + iid <- summarize_by_cell(pts, response_var = "z", deff = 1, estimate = "mean") expect_equal(capped[["..se_resp_z"]], iid[["..se_resp_z"]] * sqrt(da_cap$deff) * sqrt((capped$n - 1) / (capped$n - da_cap$deff)), @@ -577,7 +571,7 @@ test_that("summarize_by_cell passes deff_max_n through to the subsampler", { expect_equal(capped$cell_weight, capped$n / da_cap$deff, tolerance = 1e-10) # A cap larger than every cell changes nothing at all. wide <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac, deff_max_n = 5000L) + sac = sac, deff_max_n = 5000L, estimate = "mean") expect_equal(attr(wide, "deff_applied")$deff, attr(full, "deff_applied")$deff) }) @@ -607,45 +601,54 @@ test_that(".se_with_deff returns NA, not Inf, at the bound deff == n", { sac <- structure(300, class = c("sac_range", "numeric"), variogram_model = data.frame(model = "Exp", psill = 1, range = 100), crs = sf::st_crs(32632)) - out <- summarize_by_cell(pts, "z", deff = "variogram", sac = sac) + out <- summarize_by_cell(pts, "z", deff = "variogram", sac = sac, estimate = "mean") expect_equal(attr(out, "deff_applied")$deff[1], 5) expect_identical(out[["..se_resp_z"]][1], NA_real_) expect_true(is.finite(out[["..se_resp_z"]][2])) }) -test_that("summarize_by_cell falls back to deff = 1 with no fitted variogram", { +test_that("summarize_by_cell falls back to Kish with no fitted variogram", { # Reachable whenever gstat is unavailable, and also -- deterministically, # without uninstalling anything -- when nothing supplies a variogram to fit. + # This test used to pin a fallback to deff = 1 (no `deff_applied`, SEs equal + # to the uncorrected ones, cell_weight equal to n). The fallback is Kish + # now: the uncorrected interval is the one with the worst coverage of the + # grand mean, and Kish needs no variogram. pts <- .vgm_cell_points() - # A real R warning, classed, as well as the log line: the standard errors - # come back uncorrected although a correction was asked for. + # A real R warning, classed, as well as the log line. lines <- capture_spatialkit_log( expect_warning( - out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram"), + out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", estimate = "mean"), "requires a fitted variogram model", class = "spatialkit_deff_fallback") ) expect_true(log_has(lines, "requires a fitted variogram model")) - expect_true(log_has(lines, "Falling back to deff = 1")) - expect_null(attr(out, "deff_applied")) - expect_false(any(out$deff_applied)) - - iid <- summarize_by_cell(pts, predictor_vars = "z", deff = 1) - expect_equal(out[["..se_pred_z"]], iid[["..se_pred_z"]]) - expect_equal(out$cell_weight, out$n) + expect_true(log_has(lines, "Falling back to deff = \"kish\"")) + expect_false(log_has(lines, "Falling back to deff = 1")) + expect_identical(attr(out, "deff_applied")$method, "kish") + expect_identical(attr(out, "deff_applied")$requested, "variogram") + expect_true(all(out$deff_applied)) + expect_identical(unique(out$deff_method), "kish (variogram fallback)") + + kish <- summarize_by_cell(pts, predictor_vars = "z", deff = "kish", estimate = "mean") + expect_equal(out[["..se_pred_z"]], kish[["..se_pred_z"]]) + expect_equal(out$cell_weight, kish$cell_weight) + iid <- summarize_by_cell(pts, predictor_vars = "z", deff = 1, estimate = "mean") + expect_true(all(out[["..se_pred_z"]] > iid[["..se_pred_z"]])) # Same when the estimation attempt itself fails (a broken or absent gstat). lines2 <- capture_spatialkit_log({ local_mocked_bindings( estimate_sac_range = function(...) stop("gstat unavailable")) expect_warning( - out2 <- summarize_by_cell(pts, response_var = "z", deff = "variogram"), + out2 <- summarize_by_cell(pts, response_var = "z", deff = "variogram", estimate = "mean"), "estimate_sac_range\\(\\) failed: gstat unavailable", class = "spatialkit_deff_fallback") }) expect_true(log_has(lines2, "requires a fitted variogram model")) - expect_null(attr(out2, "deff_applied")) + expect_identical(attr(out2, "deff_applied")$method, "kish") + expect_identical(unique(out2$deff_method), "kish (variogram fallback)") }) @@ -673,9 +676,9 @@ test_that("summarize_by_cell(deff = 'variogram') coerces non-POINT geometry firs sac <- suppressWarnings(estimate_sac_range(pts, "z")) point_out <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac) + sac = sac, estimate = "mean") multi_out <- summarize_by_cell(multi, response_var = "z", deff = "variogram", - sac = sac) + sac = sac, estimate = "mean") expect_equal(attr(multi_out, "deff_applied")$deff, attr(point_out, "deff_applied")$deff, tolerance = 1e-8) @@ -691,7 +694,7 @@ test_that("the variogram deff survives the cells_sf join, realigned per cell", { sac <- suppressWarnings(estimate_sac_range(pts, "z")) plain <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac) + sac = sac, estimate = "mean") # Cell polygons, including one with NO observations, in a different order # from the summarised rows. @@ -705,7 +708,7 @@ test_that("the variogram deff survives the cells_sf join, realigned per cell", { geometry = sf::st_sfc(lapply(1:5, mk), crs = 32632)) joined <- summarize_by_cell(pts, response_var = "z", deff = "variogram", - sac = sac, cells_sf = cells) + sac = sac, cells_sf = cells, estimate = "mean") da <- attr(joined, "deff_applied") # dplyr::left_join() rebuilds attributes from its `x` template, which used to @@ -754,15 +757,15 @@ test_that("NA-response rows do not move the variogram design effect or SE", { skip_if_not_installed("gstat") fx <- .vgm_na_fixture() a <- suppressMessages(summarize_by_cell(fx$pts, response_var = "val", - deff = "variogram", sac = fx$sac)) + deff = "variogram", sac = fx$sac, estimate = "mean")) # Blank out 8 of the 10 responses in cell 1 -- the locations stay. p2 <- fx$pts; p2$val[p2$poly_id == 1][3:10] <- NA b <- suppressMessages(summarize_by_cell(p2, response_var = "val", - deff = "variogram", sac = fx$sac)) + deff = "variogram", sac = fx$sac, estimate = "mean")) # Reference: the same 2 observed rows as their own 2-point cell. p3 <- fx$pts[!(fx$pts$poly_id == 1 & seq_len(40) %in% 3:10), ] cc <- suppressMessages(summarize_by_cell(p3, response_var = "val", - deff = "variogram", sac = fx$sac)) + deff = "variogram", sac = fx$sac, estimate = "mean")) i_b <- which(b$poly_id == 1); i_c <- which(cc$poly_id == 1) expect_equal(b[["..se_resp_val"]][i_b], cc[["..se_resp_val"]][i_c], tolerance = 1e-10) expect_equal(b$cell_weight[i_b], cc$cell_weight[i_c], tolerance = 1e-10) @@ -781,7 +784,7 @@ test_that("cell_weight is the effective count of the response, not of rows", { x = runif(30, 0, 100), y = runif(30, 0, 100)) d$val[d$poly_id == 1][1:7] <- NA # 3 finite responses in cell 1 pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) - out <- summarize_by_cell(pts, response_var = "val", deff = 2) + out <- summarize_by_cell(pts, response_var = "val", deff = 2, estimate = "mean") i <- which(out$poly_id == 1) expect_equal(out$n[i], 10L) expect_equal(out$cell_weight[i], 3 / 2) # was 10 / 2 = 5 @@ -798,9 +801,9 @@ test_that("the variogram design effect is evaluated in the variogram's CRS", { utm <- fx$pts geo <- sf::st_transform(utm, 4326) a <- suppressMessages(summarize_by_cell(utm, response_var = "val", - deff = "variogram", sac = fx$sac)) + deff = "variogram", sac = fx$sac, estimate = "mean")) b <- suppressMessages(summarize_by_cell(geo, response_var = "val", - deff = "variogram", sac = fx$sac)) + deff = "variogram", sac = fx$sac, estimate = "mean")) expect_equal(b[["..se_resp_val"]], a[["..se_resp_val"]], tolerance = 1e-6) expect_equal(attr(b, "deff_applied")$deff, attr(a, "deff_applied")$deff, tolerance = 1e-6) @@ -816,14 +819,15 @@ test_that("deff = 'kish' tolerates rows with no cell id", { x = runif(26, 0, 100), y = runif(26, 0, 100)) pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) expect_no_error(out <- suppressMessages( - summarize_by_cell(pts, response_var = "val", deff = "kish"))) + summarize_by_cell(pts, response_var = "val", deff = "kish", estimate = "mean"))) expect_true(all(is.finite(out[["..se_resp_val"]][!is.na(out$poly_id)]))) }) -test_that("the pooled ICC groups by (variable, cell), not by cell alone", { - # Pooling m z-scored columns under one cell label averages independent cell - # effects away and shrinks the ICC by ~1/m. With m = 4 columns at a common - # true rho, the pooled estimate must sit near rho, not rho / 4. +test_that("four predictors at a common ICC each get an estimate near it", { + # This test used to pin ONE pooled ICC for the four columns, near rho and + # not rho / 4 (what pooling them under one cell label gave). Each column + # has its own estimate now; they scatter round rho, their mean is the old + # pooled value, and none is anywhere near rho / 4. set.seed(77) n_cells <- 40; n_per <- 12; rho <- 0.5 ids <- rep(seq_len(n_cells), each = n_per) @@ -834,10 +838,18 @@ test_that("the pooled ICC groups by (variable, cell), not by cell alone", { pts <- sf::st_as_sf(d, coords = c("x", "y0"), crs = 32632) out <- suppressMessages(summarize_by_cell(pts, response_var = "y", predictor_vars = c("p1", "p2", "p3", "p4"), - deff = "kish")) + deff = "kish", estimate = "mean")) icc <- attr(out, "deff_applied")$icc_pred - expect_gt(icc, 0.35) # rho/4 = 0.125 would fail this - expect_lt(icc, 0.65) + expect_named(icc, c("p1", "p2", "p3", "p4")) + expect_gt(mean(icc), 0.35) # rho/4 = 0.125 would fail this + expect_lt(mean(icc), 0.65) + expect_true(all(icc > 0.25 & icc < 0.75)) + # Each is the estimate the column gets on its own. + for (v in names(icc)) { + one <- suppressMessages(summarize_by_cell(pts, response_var = "y", + predictor_vars = v, deff = "kish", estimate = "mean")) + expect_equal(icc[[v]], attr(one, "icc")$pred[[v]], tolerance = 1e-12) + } }) @@ -856,14 +868,15 @@ test_that("conf_level = NULL leaves the frame exactly as it was", { pts$e <- rnorm(nrow(pts)) for (dv in list(1, "kish", 2)) { out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", - deff = dv) + deff = dv, estimate = "mean") expect_length(.interval_cols(out), 0L) - # A requested design effect adds its per-row `deff_applied` flag, with - # or without conf_level; the default deff = 1 frame has none. + # A requested design effect adds its per-row `deff_applied` flag and the + # `deff_method` label (added with the Kish fallback for "variogram"), with + # or without conf_level; the default deff = 1 frame has neither. expect_named(out, c("poly_id", "n", "resp_mean_y", "..sd_resp_y", "..se_resp_y", "pred_mean_e", "..sd_pred_e", "..se_pred_e", "cell_weight", - if (!identical(dv, 1)) "deff_applied")) + if (!identical(dv, 1)) c("deff_applied", "deff_method"))) } }) @@ -878,7 +891,7 @@ test_that("with conf_level the interval columns follow each variable's sd and se pts <- .make_test_points(rho = 0.3) pts$e <- rnorm(nrow(pts)) out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", - conf_level = 0.95) + conf_level = 0.95, estimate = "mean") expect_named(out, c("poly_id", "n", "resp_mean_y", "..sd_resp_y", "..se_resp_y", "..neff_resp_y", "..df_resp_y", @@ -888,13 +901,13 @@ test_that("with conf_level the interval columns follow each variable's sd and se "..ci_lo_pred_e", "..ci_hi_pred_e", "cell_weight")) # Asking for an interval moves none of the existing numbers. - base <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e") + base <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", estimate = "mean") for (col in names(base)) expect_identical(out[[col]], base[[col]], info = col) }) test_that("at deff = 1 the interval is the classic t interval on n - 1 df", { pts <- .make_test_points(rho = 0) - out <- summarize_by_cell(pts, response_var = "y", conf_level = 0.90) + out <- summarize_by_cell(pts, response_var = "y", conf_level = 0.90, estimate = "mean") expect_equal(out[["..neff_resp_y"]], out$n) expect_equal(out[["..df_resp_y"]], out$n - 1) half <- stats::qt(0.95, out$n - 1) * out[["..sd_resp_y"]] / sqrt(out$n) @@ -902,7 +915,8 @@ test_that("at deff = 1 the interval is the classic t interval on n - 1 df", { expect_equal(out[["..ci_hi_resp_y"]], out$resp_mean_y + half, tolerance = 1e-12) # The centre is the mean of the column, whatever agg_funs computes. med <- summarize_by_cell(pts, response_var = "y", conf_level = 0.90, - agg_funs = list(median = function(x) median(x, na.rm = TRUE))) + agg_funs = list(median = function(x) median(x, na.rm = TRUE)), + estimate = "mean") expect_false("resp_mean_y" %in% names(med)) expect_equal((med[["..ci_lo_resp_y"]] + med[["..ci_hi_resp_y"]]) / 2, out$resp_mean_y, tolerance = 1e-12) @@ -916,7 +930,7 @@ test_that("on the Kish path the df stay at n - 1 while neff drops with the desig # (see the coverage test below for the property itself). pts <- .make_test_points(n_cells = 6, pts_per_cell = 12, rho = 0.5) out <- summarize_by_cell(pts, response_var = "y", deff = "kish", - conf_level = 0.95) + conf_level = 0.95, estimate = "mean") rho <- attr(out, "deff_applied")$icc_resp expect_gt(rho, 0) deff <- pmax(1, 1 + (out$n - 1) * rho) @@ -928,7 +942,7 @@ test_that("on the Kish path the df stay at n - 1 while neff drops with the desig expect_equal(out[["..ci_lo_resp_y"]], out$resp_mean_y - half, tolerance = 1e-12) expect_equal(out[["..ci_hi_resp_y"]], out$resp_mean_y + half, tolerance = 1e-12) # ... and wider than the naive interval, by the same factor as the SE. - naive <- summarize_by_cell(pts, response_var = "y", conf_level = 0.95) + naive <- summarize_by_cell(pts, response_var = "y", conf_level = 0.95, estimate = "mean") ratio_ci <- (out[["..ci_hi_resp_y"]] - out[["..ci_lo_resp_y"]]) / (naive[["..ci_hi_resp_y"]] - naive[["..ci_lo_resp_y"]]) expect_equal(ratio_ci, out[["..se_resp_y"]] / naive[["..se_resp_y"]], @@ -937,7 +951,7 @@ test_that("on the Kish path the df stay at n - 1 while neff drops with the desig test_that("a numeric deff keeps n - 1 df and divides neff by deff", { pts <- .make_test_points(rho = 0) - out <- summarize_by_cell(pts, response_var = "y", deff = 2, conf_level = 0.95) + out <- summarize_by_cell(pts, response_var = "y", deff = 2, conf_level = 0.95, estimate = "mean") expect_equal(out[["..neff_resp_y"]], out$n / 2) expect_equal(out[["..df_resp_y"]], out$n - 1) half <- stats::qt(0.975, out$n - 1) * out[["..se_resp_y"]] @@ -949,7 +963,7 @@ test_that("each column's neff and interval use that column's own non-missing row pts$e <- pts$y + rnorm(nrow(pts), sd = 0.1) pts$e[pts$poly_id == 2][1:6] <- NA # cell 2 keeps 4 of 10 for e out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", - deff = "kish", conf_level = 0.95) + deff = "kish", conf_level = 0.95, estimate = "mean") rho_e <- attr(out, "deff_applied")$icc_pred n_e <- c(10, 4, 10, 10) expect_equal(out[["..neff_pred_e"]], n_e / pmax(1, 1 + (n_e - 1) * rho_e), @@ -972,7 +986,8 @@ test_that("the interval is NA exactly where the standard error is", { function(i) sf::st_point(c(i, ids[i]))), crs = 32632)) for (dv in list(1, "kish", 2)) { - out <- summarize_by_cell(pts, response_var = "y", deff = dv, conf_level = 0.95) + out <- summarize_by_cell(pts, response_var = "y", deff = dv, conf_level = 0.95, + estimate = "mean") lone <- out$n == 1L for (col in c("..neff_resp_y", "..df_resp_y", "..ci_lo_resp_y", "..ci_hi_resp_y")) { expect_true(all(is.na(out[[col]][lone])), info = paste(col, "deff =", dv)) @@ -988,7 +1003,7 @@ test_that("the interval columns survive the cells_sf join", { geometry = sf::st_sfc(lapply(1:4, function(i) sf::st_buffer(sf::st_point(c(i, i)), 0.5)), crs = 32632)) out <- summarize_by_cell(pts, response_var = "y", cells_sf = cells, - conf_level = 0.95) + conf_level = 0.95, estimate = "mean") expect_s3_class(out, "sf") expect_true(all(c("..ci_lo_resp_y", "..ci_hi_resp_y", "..df_resp_y") %in% names(out))) expect_true(is.na(out[["..ci_lo_resp_y"]][out$poly_id == 4L])) diff --git a/vignettes/diagnostics.Rmd b/vignettes/diagnostics.Rmd index 451e0cbd..21286a8a 100644 --- a/vignettes/diagnostics.Rmd +++ b/vignettes/diagnostics.Rmd @@ -1,7 +1,7 @@ --- title: "Diagnostics" description: > - Residual autocorrelation, aggregation standard errors, kriging adequacy, the area of applicability, and two ways a score can leak. + Residual autocorrelation, aggregation standard errors, kriging adequacy, the area of applicability, two ways a score can leak, and the warnings about pooled cell values. author: "Justin Chase" date: "`r format(Sys.Date(), '%d %B %Y')`" output: @@ -54,7 +54,8 @@ values. It is silent on four things that decide whether the analysis holds up: whether the model left spatial structure in its residuals, whether the standard errors on aggregated values are the width they claim, whether a cell mean is the best estimate of that cell available, and where on the map the score applies at -all. A fifth section shows two ways the score itself can be wrong. +all. A fifth section shows two ways the score itself can be wrong, and a sixth +reads the warnings `summarize_by_cell()` raises about pooled cell values. ## A fixture and a model that is wrong in a known way @@ -188,7 +189,9 @@ cat(sprintf(paste("The median cell's standard error is %.2f times wider under", `deff = "kish"` estimates an intra-class correlation from the within-cell and between-cell variance and applies Kish's factor. `deff = "variogram"` takes the correlation from the fitted variogram model, so it uses the spatial structure -rather than the cell labels. The choice is recorded: +rather than the cell labels. When no usable variogram exists that request falls +back to `"kish"` with a warning, and the `deff_method` column names the +correction each row carries. The choice is recorded: ```{r deff-attrs} str(attr(vgm, "deff_applied")) @@ -211,16 +214,20 @@ ka <- kriging_adequacy(asg, "z", tess$cells, k = 4, seed = 1) ka ``` -Three readings. `kr_var` against the naive `se^2` says whether the naive -standard error was optimistic. `kr_shift` is how far the kriged estimate moved -from the plain mean, in units of the naive standard error, and a shift beyond -one or two of those says the mean and the spatial model disagree about that -cell. The blocked cross-validation at the end standardises each held-out error -by its kriging variance: a variance of 1 means the kriging variance is right, -and above 1 means it is understated. +Four readings. `plain_var` is the error variance of the plain mean under the +fitted variogram; a naive `se^2` below it says the naive standard error was +optimistic. `kr_gain` is the share of that variance kriging removes in the +cell. `kr_shift` is how far the kriged estimate moved from the plain mean, over +the standard deviation the variogram gives that difference: about a third of +cells beyond 1 and one in twenty beyond 2 is what a right variogram produces, +and more says the means and the model disagree. The blocked cross-validation +at the end standardises each held-out error by its kriging variance: a +variance of 1 means the kriging variance is right, and above 1 means it is +understated. ```{r kriging-cols} -head(st_drop_geometry(ka)[, c("n", "mean", "se", "kr_pred", "kr_var", "kr_shift")], 4) +head(st_drop_geometry(ka)[, c("n", "mean", "se", "plain_var", "kr_pred", "kr_var", + "kr_gain", "kr_shift")], 4) ``` An empty cell still gets a kriged estimate and variance, which is the practical @@ -228,7 +235,7 @@ reason to run this: a tessellation fine enough to be useful usually has cells with no observation in them. This grid has none, as the report's `empty cells` line says, because 25 cells over 350 points leaves every cell populated; the reporting vignette's grid over the North Carolina counties has -six. +five. ## 4. Where the score applies @@ -281,7 +288,7 @@ row. `select_features_forward()` does the selection inside the resampling, and it takes the fold scheme as an argument for the same reason the outer loop does. Blocked folds only keep test rows apart from training rows if the blocks are at least as wide as the autocorrelation range. `make_folds()` estimates that range -for what the candidates leave unexplained, about 330 m on this field, and warns +for what the candidates leave unexplained, about 320 m on this field, and warns when the blocks are narrower. The default grid here has blocks about 250 m across, so `block_size = 400` is passed: @@ -301,14 +308,172 @@ sel$history `history` has one row per candidate scored at each step. Step 0 is the intercept-only model, so `a` had to beat it to be added, and at step 2 adding the noise variable `b` made the cross-validated RMSE slightly worse, so the -selection stopped at `a`. With `tol` set, a candidate has to improve the score -by more than `tol`, from step 1 on. +selection stopped at `a`. A candidate is added when its pooled `gain` exceeds +`tol` and the mean of its per-fold gains (`fold_gain`) exceeds one standard +error of that mean (`fold_gain_se`), from step 1 on; `rule = "tol"` tests the +pooled gain alone. Its inner folds default to the scheme you pass. Passing `random_kfold` there logs a caution, because a leaky inner loop can select a variable for being spatially close to the response and an honest outer loop will then report a respectable number for a dishonestly chosen feature set. +## 6. Warnings about pooled cell values + +`summarize_by_cell()` returns by default, beside each cell's mean, a pooled +value: the mean pulled toward the mean of the cells around it. What it has to +say about those values, and about whether the cells are the ones their +count was chosen for, comes as R warnings with a class. Each is raised once +per call and reason and carries its numbers as fields, so it can be caught and +read without matching its text; a warning about the pooled columns also names +the columns it applies to. This vignette hides warnings, so the helper below +runs a call and returns the classes it raised: + +```{r raised} +raised <- function(expr) { + seen <- character(0) + withCallingHandlers(expr, warning = function(w) { + seen <<- c(seen, class(w)[1]) + invokeRestart("muffleWarning") + }) + seen +} +``` + +The cells are built for pooled values at 4.5 observations per cell, by the +calls `vignette("resolution")` and `vignette("reporting")` walk through. Those +are the defaults, so nothing is named but the response; `estimate = "mean"` +in the summary gives the plain means alone, and `vignette("resolution")` lists +the profile's earlier defaults: + +```{r pooled-cells} +prof <- resolution_profile(pts, "z") +size <- select_resolution(prof) +seeds <- get_voronoi_seeds(method = "kmeans", n = size, sample_points = pts) +vor <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) +asg_v <- assign_features_to_polygons(pts, vor$cells, polygon_id_col = "cell_id") + +raised(summarize_by_cell(asg_v, "z", id_col = "cell_id", cells_sf = vor$cells)) +``` + +A summary of the cell value the count was chosen for, on the cells and rows +that were scored, raises nothing. Each of the five warnings below is a +departure from that. + +**`spatialkit_estimate_mismatch`: the count was chosen for the other cell +value.** The selection wrote down that the count was set for pooled values, +the cells and the assigned layer carried that record, and this call asks for +plain means: + +```{r mismatch} +w <- tryCatch( + summarize_by_cell(asg_v, "z", id_col = "cell_id", cells_sf = vor$cells, + estimate = "mean"), + spatialkit_estimate_mismatch = function(w) w) +unlist(unclass(w)[c("chosen_for", "reported", "rule", "cells")]) +``` + +The summary is returned as asked. Report the value the count was chosen for, +or choose the count for the value reported: +`resolution_profile(estimate = "mean")` with +`select_resolution(criterion = "loo")`. + +**`spatialkit_cells_differ`: these are not the cells and rows that were +scored.** The summary fits the response again on what it is given and compares +the rows, the cells that hold one and the leave-one-out error with the +record. Here twenty rows were dropped after the assignment: + +```{r differ} +w <- tryCatch( + summarize_by_cell(asg_v[-(1:20), ], "z", id_col = "cell_id", + cells_sf = vor$cells), + spatialkit_cells_differ = function(w) w) +w$what +rbind(scored = unlist(w$scored), found = unlist(w$found)) +``` + +`what` names the first comparison that failed: `"n"` for another number of +rows with a response, `"cells"` for another number of cells that hold one, +`"loo"` for the same rows in the same number of cells with another error, +which means rows sit in other cells, and `"record"` when the assigned layer +and `cells_sf` carry different records. The usual causes are rows filtered +after the assignment, a boundary that leaves points in no cell, and a layer +other than the one profiled. On gridded locations a row can lie the same +distance from two centres, on the boundary between their cells. The profile +scores it in the cell of the lower-numbered centre, and +`assign_features_to_polygons()` gives a point there the same cell when the +cells carry the record of the centres scored, so a lattice passes the check. +`build_tessellation()` draws those cells in the profile's CRS whatever CRS +the seeds come back in. Cells built in another projected CRS, named with its +`crs`, are the nearest-centre cells of that CRS, so rows near a boundary, on +it or not, can sit in another cell, and the warning then speaks of them. The +values returned describe the cells as given, and +`attr(, "count_rule")$check` keeps the outcome. Cells the caller brings carry +no record and are not checked. + +**`spatialkit_no_structure`: the cells predict no better than one mean.** +`b` is noise by construction: + +```{r no-structure} +noise <- summarize_by_cell(asg_v, "b", id_col = "cell_id") +raised(summarize_by_cell(asg_v, "b", id_col = "cell_id")) +as.data.frame(attr(noise, "pooled")$columns$resp_b[ + c("loo", "loo_one_cell", "structure_p", "own_weight", "structured")]) +``` + +`structured` is `FALSE` when the leave-one-out error of one mean for all rows +(`loo_one_cell`) is within 2 percent of that of the pooled values (`loo`) or +below it, or when the F test of the cell means against one mean has +`p >= 0.05`. The values are returned, and a map of them still looks smooth, +because each is mostly the mean of its neighbours. On 200 simulated layers +with white noise as the response the median own weight was 0.11 and a cell's +pooled value had a correlation of 0.79 with the mean of its 8 nearest cells' +values, where the plain means had one of -0.02 +(`dev/sim-pooled-values.R` in the package's repository; `?summarize_by_cell` +gives the settings). Read the warning as: one mean describes this column, and +the map shows the pooling. + +**`spatialkit_pool_degenerate`: the values were computed and carry no +pooling.** Its `reason` says which of three cases it is. A column that does +not vary inside any cell is one of them: + +```{r degenerate} +asg_v$flat <- 1 +w <- tryCatch(summarize_by_cell(asg_v, "flat", id_col = "cell_id"), + spatialkit_pool_degenerate = function(w) w) +w$reason +``` + +With `"no spread inside any cell"` and with `"one cell"` every own weight is +1 and the pooled value is the plain mean. With `"no signal between cells"` +the cell means differ from their neighbours' by no more than the spread +inside the cells explains: every own weight is 0, and each pooled value is +the mean of the cell's neighbours and holds none of the cell's own +observations. That last case is not the test for a response without +structure. In the simulation it came on 20 of the 200 white-noise layers and +`spatialkit_no_structure` on all 200. + +**`spatialkit_pool_few_cells`: 2 to 9 cells.** The neighbours of a cell are +then all the other cells, so its target is the mean of every observation +outside it: + +```{r few-cells} +few <- create_grid_polygons(hull, target_cells = 4, type = "square") +asg_f <- assign_features_to_polygons(pts, few, quiet = TRUE) +raised(four <- summarize_by_cell(asg_f, "z")) +as.data.frame(four)[, c("poly_id", "n", "resp_mean_z", "..pooled_resp_z", + "..pooled_w_resp_z", "..pooled_target_resp_z")] +``` + +The overall mean lies between a cell's own mean and that target. A cell whose +own weight is below its share of the observations therefore gets a pooled +value on the far side of the overall mean from its plain mean, and two cells +can change order. The `..pooled_w_*` column shows how close each cell is to +that, and `estimate = "mean"` gives the plain means. + +`?summarize_by_cell` lists these classes and the others of the pooled values +under "Conditions", with the fields each carries. + ## Next `vignette("spatial-cross-validation")` covers fold schemes and block sizing. diff --git a/vignettes/getting-started.Rmd b/vignettes/getting-started.Rmd index bf251c4d..74f2ebf1 100644 --- a/vignettes/getting-started.Rmd +++ b/vignettes/getting-started.Rmd @@ -55,8 +55,8 @@ remotes::install_github("elkronos/gis_modeling_toolkit") remotes::install_github("elkronos/gis_modeling_toolkit", build_vignettes = TRUE) ``` -`sf`, `dplyr`, `logger` and `digest` install with it. Everything else is -optional and is needed only for the feature that uses it: +`sf`, `dplyr`, `logger`, `digest` and `FNN` install with it. Everything else +is optional and is needed only for the feature that uses it: ```{r suggests-table, echo=FALSE, results='asis'} cat( @@ -64,12 +64,12 @@ cat( "|---|---|\n", "| `gstat` | variogram fitting: `estimate_sac_range()`, design effects, kriging checks |\n", "| `ranger` | `fit_rf_model()` and `cv_rf()` |\n", -"| `sp`, `GWmodel` | `fit_gwr_model()` and `cv_gwr()` |\n", +"| `sp` | `fit_gwr_model()` and `cv_gwr()` |\n", "| `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()` and `cv_bayes()` |\n", "| `geometry` | Delaunay triangle tessellations |\n", "| `ggplot2` | every `plot_*()` function and every `plot()` method |\n", "| `patchwork` | only the stacked panels in `vignette(\"spatialkit_nc_demo\")` and `example_nc_demo.R` |\n", -"| `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers |\n", +"| `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers |\n", sep = "") ``` @@ -185,14 +185,16 @@ as above, only means the choice is made once and can be seen. Four more things about the data, each handled without stopping you: - A row whose response or predictor is `NA`, `NaN` or infinite is dropped - before a fit, and the count is logged; `prep_model_data()` is the function - that does it and `attr(x, "dropped")` says which rows. + before a fit, with a warning that gives the counts (class + `spatialkit_rows_dropped`); `prep_model_data()` is the function that does + it and `attr(x, "dropped")` says which rows. - Two observations at the same coordinates are fine for models and folds; a Voronoi tessellation keeps one seed per location, and every point at that location is indexed to its cell. - A point outside the boundary you tessellate gets no cell: `tess$index` - is `NA` for it and `assign_features_to_polygons()` leaves it out unless - you ask for it back with `keep_unassigned = TRUE`. + is `NA` for it and `assign_features_to_polygons()` leaves it out, with a + warning that gives the count, unless you ask for it back with + `keep_unassigned = TRUE`. - A variogram, which is what sizes blocks from the data, needs about thirty points; below that `estimate_sac_range()` returns `NA` and says so. @@ -204,6 +206,15 @@ points, score it on folds that hold out whole regions, and say where its predictions can be trusted. Each is covered in depth by one of the other vignettes. +The cell functions' defaults are pooled values beside the plain means and, +where the data draw the cells, 4.5 observations per cell in density-weighted +cells (`vignette("resolution")`). Each earlier default is one argument away: +`summarize_by_cell(estimate = "mean")` leaves the pooled columns out, +`resolution_profile(estimate = NULL, obs_per_cell = NULL)` scores the ladder +of cell counts, `select_resolution(criterion = "cp")` reads Mallows' Cp off +it, and `partition = "kmeans"` in `resolution_profile()` and the seeding +functions gives k-means cells. + ### Regions and aggregates ```{r pipeline} @@ -240,6 +251,15 @@ with one observation has a standard error of `NA`, because one number has no spread, and an empty cell has `n = NA`: both are kept, because a region with nothing in it is a fact about the map. +The three `..pooled_` columns are the pooled value, the cell's mean pulled +toward the mean of the cells around it, then its weight on the cell's own mean +and the mean it is pulled toward. With fewer than ten cells that hold an +observation, as here, a cell's target is the mean of all the others, and the +call warns of it (class `spatialkit_pool_few_cells`). It also warns that these +four cells do not tell the rate from one mean for the state (class +`spatialkit_no_structure`). This vignette hides warnings; `?summarize_by_cell` +says what the pooled value estimates and lists the warnings. + At the default `deff = 1` the standard error is the one for each cell's own mean, which is what a map of the regions reports, and it is right when a cell's points are spread through it. `deff = "kish"` or `"variogram"` gives instead the @@ -259,7 +279,9 @@ Eight cells, four of them slivers at the state's edge with no county inside, is coarse. A hundred county centroids spread fairly evenly have no elbow to find, and the call warns that `max_levels` chose this count rather than the data. `vignette("resolution")` is where to argue with it: -`resolution_profile()` scores every cell count on four criteria at once. +`resolution_profile()` sets the count from a number of observations per +cell, or scores every count on a ladder on four count criteria and a +diagnostic at once. ```{r map, eval=has_ggplot, fig.height=4.5, fig.alt="North Carolina covered by four large hexagonal cells shaded by their mean SIDS rate, plus four unshaded slivers at the edges that hold no county. The western cell has the lowest mean, about 1.5 per thousand, and the small southern cell the highest, about 2.8."} plot_tessellation_map(cells, boundary = boundary, fill_col = "resp_mean_rate", @@ -287,9 +309,10 @@ blocks that define them (`make_folds(blocks = tess$cells)`). # 5. Build folds that hold out whole regions. block_size is a distance in # the CRS's units, here metres. Blocks have to be at least as wide as the # autocorrelation range for the folds to be honest; on these data no range -# could be identified, so 100 km is set by hand. vignette("spatial-cross- -# validation") is about that choice, and make_folds(auto_range = TRUE) -# makes it from the data when gstat is installed. +# could be identified for what the predictor leaves unexplained, so 100 km +# is set by hand. vignette("spatial-cross-validation") is about that +# choice, and make_folds(auto_range = TRUE) makes it from the data when +# gstat is installed. random <- make_folds(obs, k = 4, method = "random_kfold", seed = 1) blocked <- make_folds(obs, k = 4, method = "block_kfold", block_size = 100e3, seed = 1) @@ -415,6 +438,8 @@ source(file.path(dir, "03-folds.R")) | **block** | a square of the study area used to build a fold; a fold holds out whole blocks | | **design effect (`deff`)** | how many times larger a cell mean's variance, as an estimate of the population mean, is than the independent-sample formula says, because the points in a cell are correlated; `n / deff` is the effective sample size for that estimate. The cell's own mean needs no such correction when its points are spread through the cell | | **flat region** | the cell counts a resolution criterion cannot distinguish from its optimum; a set, not an interval | -| **support ceiling, range floor** | the most cells the point count allows (`n / min_cell_n`) and the fewest the autocorrelation range allows (`area / range^2`); a criterion whose optimum sits on either is being chosen for by that bound | +| **pooled value** | a cell's mean pulled toward the mean of the 8 cells whose observations are nearest, by a weight that grows with the cell's count; `summarize_by_cell()` returns it beside the mean | +| **size** | the number of observations a cell is to hold on average, `obs_per_cell`; 4.5 sets the default count | +| **support ceiling, range floor** | the most cells the point count allows (`n / min_cell_n`, counting the rows with a response) and the fewest the autocorrelation range allows (`area / range^2`); a criterion whose optimum sits on either is being chosen for by that bound | | **dissimilarity index (DI)** | how far a prediction location's predictors sit from the training data, on the scale of the training data's own spread; the area of applicability is where DI stays below what cross-validation saw | | **row ID** | `..row_id`, a column the package stamps on a layer so that folds and dropped rows can be traced back to the rows you passed in | diff --git a/vignettes/reporting.Rmd b/vignettes/reporting.Rmd index 6781b5b4..cfed596a 100644 --- a/vignettes/reporting.Rmd +++ b/vignettes/reporting.Rmd @@ -1,7 +1,7 @@ --- title: "What to save, and what to report" description: > - What leaves the session: grouping an existing layer, membership lookups, exporting the regions, and which six numbers to report. + What leaves the session: grouping an existing layer, membership lookups, exporting the regions, which six numbers to report, and how to report a cell value. author: "Justin Chase" date: "`r format(Sys.Date(), '%d %B %Y')`" output: @@ -108,11 +108,15 @@ names(cells) sum(is.na(cells$n)) ``` -`r sum(is.na(cells$n))` of the `r nrow(cells)` regions are empty, carrying `NA` -rather than being silently dropped. A region with no data in it is a fact about -the map, and one worth keeping: it is where the model has nothing to stand on. +The three `..pooled_` columns are each region's pooled value, its weight on +the region's own mean and the mean it is pulled toward; `summarize_by_cell()` +adds them by default, `estimate = "mean"` leaves them out, and "Reporting a +cell value" below reads them. `r sum(is.na(cells$n))` of the `r nrow(cells)` +regions are empty, carrying `NA` rather than being silently dropped. A region +with no data in it is a fact about the map, and one worth keeping: it is where +the model has nothing to stand on. -```{r map, eval=has_ggplot, fig.height=3.6, fig.alt="The North Carolina counties grouped into eighteen hexagonal regions, each shaded by the mean 1974 SIDS rate of the counties inside it. County outlines show underneath. Six regions along the edges hold no county and are grey."} +```{r map, eval=has_ggplot, fig.height=3.6, fig.alt="The North Carolina counties grouped into seventeen hexagonal regions, each shaded by the mean 1974 SIDS rate of the counties inside it. County outlines show underneath. Five regions along the edges hold no county and are grey."} library(ggplot2) ggplot() + @@ -211,8 +215,9 @@ c(columns = length(attr_names(cells)), attr_names(shp) ``` -A shapefile field name is capped at ten characters, so the standard errors and -confidence bounds arrive as `X__s_rs_` and `X__c_l__`: of the +A shapefile field name is capped at ten characters, so the standard errors, +confidence bounds and pooled values arrive as `X__s_rs_`, `X__c_l__` and +`X__pld__`: of the `r length(setdiff(names(cells), attr(cells, "sf_column")))` columns `summarize_by_cell()` produced, `r length(intersect(setdiff(names(shp), attr(shp, "sf_column")), setdiff(names(cells), attr(cells, "sf_column"))))` survive the trip. GeoPackage keeps every one of them, and renames only the @@ -386,6 +391,128 @@ summary(populated$n) range(populated$..se_resp_rate, na.rm = TRUE) ``` +## Reporting a cell value + +`summarize_by_cell()` returns by default, beside each cell's mean, a pooled +value: the mean pulled toward the mean of the 8 cells around it. This section +builds cells sized for that value on a simulated layer and reads off what a +report of them has to carry. The layer is 600 points on a square of +20 km, with a smooth field plus noise: + +```{r value-fixture} +set.seed(7) +sx <- runif(600, 0, 2e4) +sy <- runif(600, 0, 2e4) +obs <- st_as_sf( + data.frame(x = 4e5 + sx, y = 4e6 + sy, + yield = 50 + 6 * sin(sx / 3000) + 6 * cos(sy / 2500) + + rnorm(600, sd = 3)), + coords = c("x", "y"), crs = 32617) +``` + +The count comes from a size, 4.5 observations per cell, scored for the pooled +value, in density-weighted cells. Those are the defaults, so the calls name +none of them. The cells are the ones that were scored, and the summary reports +the same cell value: + +```{r value-pipeline} +prof <- resolution_profile(obs, "yield") +sel <- select_resolution(prof) +seeds <- get_voronoi_seeds(method = "kmeans", n = sel, sample_points = obs) +tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) +asg <- assign_features_to_polygons(obs, tess$cells, + polygon_id_col = "cell_id") +vals <- summarize_by_cell(asg, "yield", id_col = "cell_id", + cells_sf = tess$cells, obs_level = 0.90) + +st_drop_geometry(vals)[1:4, c("cell_id", "n", "resp_mean_yield", + "..pooled_resp_yield", "..pooled_w_resp_yield", + "..obs_lo_resp_yield", "..obs_hi_resp_yield")] +``` + +Each earlier default is one argument away: `estimate = "mean"` in the summary +for the plain means alone, `estimate = NULL, obs_per_cell = NULL` in the +profile for the ladder of counts, `criterion = "cp"` for Mallows' Cp on that +ladder, and `partition = "kmeans"` in the profile and the seeding functions +for k-means cells. + +Two attributes of the frame hold the wording. `attr(, "pooled")` says what was +fitted and what each interval covers, and `attr(, "count_rule")` says how the +count was set and whether these are the cells and rows it was scored on: + +```{r value-records} +attr(vals, "pooled") +attr(vals, "count_rule") +``` + +A report of cell values reads four things off them. + +- **The value, and which one it is.** `..pooled_resp_yield` is the pooled + value and `resp_mean_yield` the plain mean. Both estimate the cell's level: + the expected value of one further observation located in the cell the way + its observations were. Neither is the average of a surface over the cell's + area. Give `n` beside either. +- **The own weight.** `..pooled_w_resp_yield` is the share of the pooled value + that is the cell's own mean; the rest is the mean of its neighbours. A cell + of two observations has a smaller weight than a cell of ten, so its value + says more about its surroundings and less about itself. It is not a + regression weight; for a regression on cell values use the plain mean with + `cell_weight`. +- **The interval, and what it covers.** `..obs_lo_*` and `..obs_hi_*` are a + range for one further observation in the cell, located like the data. The + statement holds on average over observations and not cell by cell, and the + two offsets are the same in every cell. It is not an interval for the + cell's level: none is returned. `..ci_*`, from `conf_level`, is an interval + for a mean and never a range for an observation. The table in + `attr(vals, "intervals")` gives the sentence for each family in the frame. +- **Where the value applies.** A cell's value and interval describe the part + of the cell where its observations lie, and a Voronoi cell can reach far + past them. A cell with no observation has `NA`. Away from the observations + no interval here is calibrated. + +The lines of a report can be written from the two records, so that they +describe the run that happened: + +```{r value-report} +rec <- attr(vals, "pooled")$columns$resp_yield +iv <- attr(vals, "intervals") +cr <- attr(vals, "count_rule") + +cat( + sprintf("- cells: %d, set by a %s of %s observations per cell; checked: %s", + cr$cells, cr$rule, format(cr$obs_per_cell_asked), cr$check$cells), + sprintf("- value: the cell mean pooled toward its %d nearest cells; median own weight %.2f", + rec$neighbours, rec$own_weight), + sprintf("- %s: %g%% for %s", iv$columns[1], 100 * iv$level[1], iv$covers[1]), + sprintf("- leave-one-out error %.3g against %.3g for one mean; structured: %s", + rec$loo, rec$loo_one_cell, rec$structured), + sprintf("- %.1f%% of observations are the only one in their cell", + 100 * rec$share_alone), + sep = "\n") +``` + +`cell_values_at()` gives the value at other locations, with each location's +distance from the nearest observation. `dist_ratio` is that distance over the +layer's typical spacing, and it is the number to report beside a value read +at a place that is not an observation. The third location below lies outside +the layer: + +```{r value-at} +seeds$cell_id <- tess$index +elsewhere <- st_as_sf( + data.frame(x = 4e5 + c(5000, 12000, 26000), y = 4e6 + c(5000, 9000, 10000)), + coords = c("x", "y"), crs = 32617) +cell_values_at(elsewhere, vals, asg, "yield", id_col = "cell_id", + seeds = seeds) +``` + +It gets a value and an interval like the others, because every location has a +nearest seed. Nothing flags it: the `dist_ratio` beside it does. On simulated +layers the interval at 0.90 held 91.5 percent of held-out observations with a +`dist_ratio` below 1 and 69.5 percent of those above 8 +(`dev/sim-pooled-values.R` in the package's repository; `?cell_values_at` gives +the settings and the classes between). + ## What to save Enough to rerun it, which is less than it sounds: diff --git a/vignettes/resolution.Rmd b/vignettes/resolution.Rmd index 0b830720..8acc2607 100644 --- a/vignettes/resolution.Rmd +++ b/vignettes/resolution.Rmd @@ -1,7 +1,7 @@ --- title: "Choosing a resolution" description: > - How many cells the data support: the ladder, four criteria that disagree, and how to read the flat region. + How many cells the data support: the ladder, the criteria that disagree, and how to read the flat region. author: "Justin Chase" date: "`r format(Sys.Date(), '%d %B %Y')`" output: @@ -64,9 +64,10 @@ Three functions answer the question, in increasing order of how much they tell you. `determine_optimal_levels()` reads an elbow off the coordinates alone and runs on the hard dependencies; it is the quick answer and the one `build_tessellation()` accepts directly. `resolution_profile()` scores every -cell count on a ladder against four criteria at once and needs gstat for two -of them. `select_resolution()` reads one criterion off that profile, and -`summary()` on the profile reads all four side by side. If the cells will feed +cell count on a ladder in five columns at once, four count criteria and one +diagnostic, and needs gstat for two of them. `select_resolution()` reads one +criterion off that profile, and `summary()` on the profile reads the count +criteria side by side. If the cells will feed a model, the profile is the one to use. If you need a count now and the data are all you have, the elbow is defensible when the points cluster, and this article says where it falls short. On points spread evenly there is no elbow @@ -74,10 +75,22 @@ to read, and both functions say so: the profile leaves its `elbow` column empty, and `determine_optimal_levels()` warns that the count it still returns was chosen by the ends of its ladder, not by the data. +Called with the response and nothing else, `resolution_profile()` takes its +defaults: one level at 4.5 observations per cell, scored for the pooled value +that `summarize_by_cell()` reports by default, in density-weighted cells, with +no variogram fitted. `select_resolution()` then reads the count off that size +("Setting a size" below). A ladder argument such as `n_levels` gives the ladder +this article reads first. Each earlier default is one argument away: +`estimate = NULL, obs_per_cell = NULL` in the profile for the ladder without +the pooled value's columns, `sac = NULL` for a variogram on a ladder of sizes, +`partition = "kmeans"` for k-means cells from 25 starts, `criterion = "cp"` in +`select_resolution()`, and `estimate = "mean"` in `summarize_by_cell()`. + The argument that says "how many" is spelled differently by the function it belongs to: `max_levels` bounds the elbow's ladder, `n_levels` sets the -profile's, `approx_n_cells` and `target_cells` are what the grid builders -take, and `n` is what `get_voronoi_seeds()` takes. Each of the last three +profile's and `obs_per_cell` sets it in observations per cell, +`approx_n_cells` and `target_cells` are what the grid builders take, and `n` +is what `get_voronoi_seeds()` takes. Each of the last three accepts the object the first two return. ## A fixture with known structure @@ -122,19 +135,24 @@ it, which is why the count is set when you place the seeds rather than when you tessellate them. The last section shows the two calls in order. Two things to know about this function before you rely on it. Its -`criterion = "morans_i"` and `criterion = "combined"` settings need both -`response_var` and `predictor_vars`; give it only a response and it warns -and falls back to `"geometric"`. And its ladder runs from 1 to -`max_levels` with no lower bound from the spatial correlation of the data, so it -can prefer cells wider than the field's own correlation range. The profile below -does impose that bound, which is why the two can disagree. +`criterion = "morans_i"` and `criterion = "combined"` settings rank the counts +around the elbow by Moran's z of the cell means, which is a diagnostic and not +a count rule; the call returns the ranking with a warning of class +`spatialkit_diagnostic_ranking` that says so. They need a `response_var`; +without one the call warns and falls back to `"geometric"`. And its ladder +runs from 1 to `max_levels` with no lower bound from the spatial correlation +of the data, so it can prefer cells wider than the field's own correlation +range. The profile below reports that bound, and `select_resolution()` reads +`reliability` from it up, which is why the two can disagree. ## The profile `resolution_profile()` fits every level on a ladder and reports what each one costs, so you can see the shape of the trade-off before picking a point on it. -Levels are spaced logarithmically, because cell diameter falls as -\(L^{-1/2}\). +`n_levels` asks for that ladder. Levels are spaced logarithmically, because +cell diameter falls as \(L^{-1/2}\). At its defaults the profile also scores +the leave-one-out error of the pooled value, `loo`, at every level, and draws +the cells by density-weighted k-means. ```{r profile} prof <- resolution_profile(pts, response_var = "z", n_levels = 16) @@ -149,7 +167,7 @@ cell of the same area, so compare it against something you already know about your own data, such as the spacing of a sampling grid or the size of a field, with that factor in mind. -### The four criteria +### Four criteria and a diagnostic ```{r criteria-table, echo=FALSE, results='asis'} cat( @@ -157,18 +175,27 @@ cat( "|---|---|---|---|\n", "| `elbow` | how far the log of the within-cluster sum of squares sags below a power law (the straight log-log line from one cell to the last level); `NA` at every level when the points have no cluster structure | coordinates only | larger |\n", "| `cp` | Mallows' \\(C_p\\) of the piecewise-constant approximation of the response by cell means | a response, and a variogram for the nugget | smaller |\n", -"| `moran_z` | spatial structure surviving in the residuals of the cell means | a response | nearer zero |\n", +"| `moran_z` | Moran's z of the cell means (of their regression residuals when predictors are given): whether neighbouring cells resemble each other | a response | a diagnostic, not a count rule |\n", "| `reliability` | the share of the spread in the cell means that is signal, not sampling noise | a variogram | larger |\n", +"| `loo` | the leave-one-out error of the cell value the profile scores, the pooled value by default (\"Setting a size\") | a response | smaller |\n", sep = "") ``` `elbow` sees the coordinates and knows nothing about what you measured. `cp` and `reliability` split the practical question in half: how well the cells represent -the field, and whether the cell values can be told apart from noise. `moran_z` -is the diagnostic, and a large deviate says the cells are still leaving spatial -pattern on the table. - -```{r plot-profile, fig.height=8, fig.alt="Three stacked panels, one per criterion the profile could score, against the number of cells on a shared axis; there is no elbow panel because these uniform points have no elbow. Mallows' Cp falls from 10 to 49 cells and turns up at 55, reliability declines steadily from 10 cells on, and the absolute Moran's z is lowest at 20 cells and climbs past 30. A red dot and dotted line mark each criterion's choice, and shaded bands the levels within tolerance of it. The bands are one to three levels wide, none has a gap, and no level sits inside all three."} +the field, and whether the cell values can be told apart from noise. What `cp` +estimates is the error of re-measuring the sampled sites, each predicted by the +mean of its cell, with the variogram's nugget as the noise of one measurement. +For a new location the penalty would also need the spread of the field inside a +cell, which the nugget leaves out. `moran_z` +is a diagnostic of the cell means and not a count rule. It grows as the cells +get finer than the range, because neighbouring cells then resemble each other, +and it is near zero at the coarsest counts it is computed at whatever the data. +It does not say how well the cells represent the response, so +`select_resolution()` refuses it unless asked with `diagnostic = TRUE`, and +`summary()` leaves it out unless it is named. + +```{r plot-profile, fig.height=8, fig.alt="Four stacked panels against the number of cells on a shared axis, from 2 to 55; there is no elbow panel because these uniform points have no elbow. Mallows' Cp falls across the ladder and is lowest at 44 cells. Reliability rises to a peak near 5 cells and declines after it. The leave-one-out error of the pooled value falls as Cp does and is lowest at 35 cells. The absolute Moran's z of the cell means is drawn from 12 cells on, stays near 1 or below up to 23 cells and climbs past 3 at 55. A red dot and dotted line mark the level selected for Cp, at 44 cells, for reliability, at 17 cells, and for the leave-one-out error, at 35 cells, with a shaded band over the levels within tolerance of each; the Moran panel has no selected level."} plot(prof) ``` @@ -177,20 +204,29 @@ Two behaviours are worth knowing before reading the numbers. ```{r cp-context, echo=FALSE} vg <- attr(prof, "variogram") nug <- round(vg$nugget, 2); psl <- round(vg$psill, 2) +cp_sel <- select_resolution(prof, criterion = "cp") ``` **`cp` needs a nugget to have an interior optimum.** On a smooth field the piecewise-constant approximation keeps improving as cells shrink, the penalty is too small to stop it, and the minimum lands wherever `min_cell_n` stops the ladder. The support ceiling is then doing the choosing, and -`select_resolution()` flags it. This fixture has a fitted nugget of -`r if (runs) nug else NA` against a partial sill of `r if (runs) psl else NA`, -which is why `cp` turns around inside the ladder here. +`select_resolution()` flags it. + +```{r cp-text, echo=FALSE, results='asis'} +cat(sprintf("This fixture has a fitted nugget of %s against a partial sill of %s,", nug, psl), + if (isTRUE(cp_sel$at_ceiling)) + "and `cp` still falls to the last level of the ladder here: its minimum is the support ceiling, as `summary()` says below.\n" + else + "which is why `cp` turns around inside the ladder here.\n") +``` -**`reliability` rises as cells get larger**, because bigger cells hold more -points and average away more noise. Its optimum can therefore sit on the coarse -end of whatever the ladder allows, which makes the answer a bound on the -analysis. The next section is about spotting that. +**`reliability` is highest at a coarse count**, because bigger cells hold more +points and average away more noise. Its maximum usually lies below the range +floor, where cells are wider than the range. `select_resolution()` therefore +reads it from the floor up, and what it returns is then the floor: a bound on +the analysis, with the range choosing and not the curve. The next section is +about spotting that. ## Choosing, and the flat region @@ -227,8 +263,8 @@ if (isTRUE(sel$at_floor)) { ``` Criteria can prefer different levels while agreeing on a region. `summary()` -on the profile reads all four at once, and closes with the levels that every -band contains: +on the profile reads the count criteria at once, and closes with the levels +that every band contains: ```{r compare-criteria} summary(prof) @@ -271,27 +307,32 @@ cat("A band is a set of levels, not an interval, because the criterion curves", "resolution that satisfies every way of asking.\n") ``` -The table is not a decision procedure, and nothing in the package will pick -for you. Cross-validating a model at each suggested level is affordable, but -it does not settle the question either: on a simulated field the level that -won on cross-validated \(R^2\) moved with the fold seed, and the coarsest -grid won most often because its score had the widest spread, not because it -was better. +The table is not a decision procedure, and nothing in the package picks among +its criteria for you. Cross-validating a model at each suggested level is +affordable, but it does not settle the question either: on a simulated field +the level that won on cross-validated \(R^2\) moved with the fold seed, and +the coarsest grid won most often because its score had the widest spread, not +because it was better. ## What the ladder can support -The ladder runs between two bounds the data impose, both recorded on the profile. +The ladder runs from 2 cells to a ceiling the data impose. The profile records +that ceiling and, beside it, a floor from the autocorrelation range. ```{r bounds} str(attr(prof, "bounds")) ``` -The ceiling is `floor(n / min_cell_n)`, or the number of distinct locations +The ceiling is `floor(n / min_cell_n)`, with `n` the rows that carry a +response when one is given, or the number of distinct locations when that is smaller (one short of it when no location repeats); `ceiling_from` says which. Past it the average cell holds too few points to estimate anything from, or k-means has more centres to place than distinct points. The floor is `ceiling(area / range^2)`, from the fitted autocorrelation range: cells wider than the range average over more -than one patch of the field, mixing values the field itself keeps apart. +than one patch of the field, mixing values the field itself keeps apart. The +range is an estimate, so by default the floor is reported and not applied: it +is a level of the ladder, `select_resolution(criterion = "reliability")` reads +from it up, and `range_floor = TRUE` starts the ladder there. When the floor exceeds the ceiling, the data cannot support a tessellation that respects their own correlation structure. `supported` is `FALSE`, a warning says @@ -299,6 +340,158 @@ so, and the ladder still runs from 2 to the ceiling so the cost of each level stays visible. The usual causes are too few points for the extent, or a correlation range shorter than the spacing between observations. +## Setting a size + +Of the criteria above, all but `loo` score the plain mean of a cell. +`summarize_by_cell()` reports beside it, by default, a *pooled* value: the +cell's mean pulled toward the mean of the 8 cells around it, by a weight that +grows with the number of observations the cell holds (`estimate = "pooled"`; +`vignette("reporting")` shows how to read and report one). For that value no +criterion sets the count. A *size* does: the number of observations a cell is +to hold on average, `obs_per_cell`. A size `s` on `n` observations is +`max(2, round(n / s))` cells. + +The default profile is one size, 4.5, scored for the pooled value, and +`select_resolution()` reads the count off it by that size. This is the call +with nothing named but the response: + +```{r size-default} +prof_default <- resolution_profile(pts, response_var = "z") +select_resolution(prof_default) +``` + +`obs_per_cell` puts the profile's ladder in those terms, one level per size, +with the centres fitted to every row. `estimate` names the cell value the +profile scores, the pooled value unless it says otherwise: + +```{r size-profile} +prof_size <- resolution_profile(pts, response_var = "z", + obs_per_cell = c(12, 9, 6, 4.5, 3)) +as.data.frame(prof_size)[, c("levels", "scored_per_cell", "loo", + "share_alone", "own_weight")] +``` + +Three of the columns say what a size leaves a cell value to stand on. + +- `loo` is the leave-one-out error of the pooled value: each observation is + predicted by the value of its cell computed without it, and the squared + errors are averaged. It needs no variogram. `sac = "auto"`, the default, + fits none on a ladder of sizes, so `cp` and `reliability` are `NA` in this + profile. +- `share_alone` is the share of the observations that are the only one in + their cell. +- `own_weight` is the median weight a pooled value gives its cell's own mean. + At 1 the pooled values are the plain means; at 0 each is the mean of the + cell's neighbours. + +At the size of the default profile this ladder has other centres, and so +another `loo`, than that profile had: a profile draws the starts of its levels +in turn from one random stream under `seed`, so a level's centres depend on +the other levels of the ladder. + +`select_resolution(criterion = "size")` returns the level of a size. It +searches for no optimum, so the result has no flat region and sits on no +bound: + +```{r size-select} +sel_size <- select_resolution(prof_size, criterion = "size", + obs_per_cell = 4.5) +sel_size +``` + +`loo` is in the table to compare sizes by, not to choose one. For pooled +values it tends to keep falling as the cells shrink, so its minimum tends to +be the finest size offered, and the end of the ladder would then be choosing. +On 200 simulated layers of 1,500 clustered observations of a field plus noise, +profiled at seven sizes from 18 to 2, the lowest `loo` of the pooled value was +at the size 2 on 176 (`dev/sim-pooled-values.R` in the package's repository; +`?resolution_profile` gives the settings). + +```{r size-text, echo=FALSE, results='asis'} +lowest <- prof_size$levels[which.min(prof_size$loo)] +cat(sprintf(paste("In the table above the lowest `loo` is at %d cells, %s.\n"), + lowest, + if (lowest == max(prof_size$levels)) "the finest size offered" + else "which is not the finest size offered: a tendency, not a rule")) +``` + +The size is therefore the caller's choice, made on other grounds: how many +observations a cell value should stand on, which `share_alone` and +`own_weight` describe. Under a size neither the cells, which are fitted to the +coordinates, nor their number, which is a count of rows, depend on the +response, so the count is not fitted to the values it will summarise. + +A size does not ask whether the response has spatial structure the cells can +use, so the selection asks it separately. `structured` is `FALSE` when one +mean for the whole layer predicts a left-out observation as well as the cells +do. The count stands either way, since the caller set it, and the functions +that take the selection as a count then warn (class +`spatialkit_no_structure`) that the cell values will say little that one mean +does not. + +```{r size-structured} +data.frame(structured = sel_size$structured, loo = sel_size$loo, + one_mean = sel_size$loo_one_cell) +``` + +The selection goes to `get_voronoi_seeds()`, as in "Next" below. It carries a +record of how the count was set, `sel_size$count_rule`, which the seeds, the +cells and the assigned layer hand on to `summarize_by_cell()`. The summary +then checks that it reports the cell value the count was chosen for, on the +cells and rows that were scored. + +## Leave-one-out for plain means + +With plain means the leave-one-out error does choose a count. Each observation +is predicted by the mean of the other observations of its cell, or, when it is +alone in its cell, by the mean of the cell of its nearest other observation. +`estimate = "mean"` scores that error in the profile, and the default +`obs_per_cell = "auto"` then offers the seven sizes 18, 12, 9, 6, 4.5, 3 and +2: + +```{r loo-profile} +prof_loo <- resolution_profile(pts, response_var = "z", estimate = "mean") +as.data.frame(prof_loo)[, c("levels", "scored_per_cell", "loo", "loo_se", + "share_alone")] + +sel_loo <- select_resolution(prof_loo, criterion = "loo") +sel_loo +``` + +```{r loo-text, echo=FALSE, results='asis'} +if (is.na(sel_loo$edge)) { + cat(sprintf(paste("The lowest error is at %d cells, inside the sizes offered,", + "so the criterion chose it.\n"), sel_loo$best)) +} else { + cat(sprintf(paste("The lowest error is at %d cells, which is %s: an end of", + "the ladder chose the count, and the functions that take", + "the selection warn of it (class", + "`spatialkit_bound_chosen`).\n"), sel_loo$best, sel_loo$edge)) +} +``` + +`sel_loo$flat` is every level whose error is within `tol` of the lowest, and +it is the answer to quote, as for any criterion. `loo_se` is the standard +error of one level's mean squared error. It is not the standard error of the +difference between two levels: their errors come from the same observations. + +Three things to know before relying on this criterion. The count now depends +on the values of the response, so the next section applies, and +`select_on = "split"` reads `loo` on one half of the layer. The error +describes locations among the observations: it compares counts where data are +near, and says nothing about the error of a map away from them. And it sets +the count of plain means only; for pooled values a size does, as above. In +the simulation of that section the lowest `loo` of the plain mean was at the +finest size on none of the 200 layers: it was at 6 observations per cell on +86 of them, at 4.5 on 51 and at 9 on 49. + +`criterion = "auto"` is the rule that goes with the profile's estimate: +`"size"` for pooled values and `"loo"` for plain means. It is +`select_resolution()`'s default, and a profile built with `estimate` and +passed straight to `get_voronoi_seeds()` as `n` is read the same way. +`criterion = "cp"` reads Mallows' Cp, which neither profile of these two +sections has, since neither fitted a variogram. + ## Choosing on one half, estimating on the other Picking the level from the same response you then aggregate is a form of @@ -324,7 +517,7 @@ half rather than as independence. Choose from `prof_split`, then aggregate the rows in `sp$estimation`. The cells on the ladder are still drawn on every point, so the count it picks is a count for the whole layer, and the ladder is as long as the full profile's. Only the -steps that read the response (the variogram, `cp`, `moran_z`) use the +steps that read the response (the variogram, `cp`, `moran_z`, `loo`) use the selection half. The cost is power: those criteria see half the data, so the profile is noisier and the band wider. The estimation rows also fill only their own half of the layer: a cell inside the selection half gets none of @@ -344,10 +537,12 @@ estimated on the selection half. Hand the selection to whichever call decides the cell count. For a Voronoi tessellation that is `get_voronoi_seeds()`. Given the `select_resolution()` result itself, it returns the centres of the partition the profile scored, and a -k-means partition is the Voronoi partition of its centres, so the cells built on -those seeds are the cells the criteria judged; the bare count `sel$best` would -run a new k-means, whose cells are not. `build_tessellation()` then works on the -seeds: +k-means partition, weighted or not, is the Voronoi partition of its centres, so +the cells built on those seeds are the cells the criteria judged; the bare +count `sel$best` would run a new k-means, whose cells are not. This selection +sits on the range floor, so the call warns that a bound chose the count (class +`spatialkit_bound_chosen`; warnings are not shown in this article). +`build_tessellation()` then works on the seeds: ```{r next-step} bnd <- clip_target_for(pts, expand = 0.02, quiet = TRUE) diff --git a/vignettes/spatial-cross-validation.Rmd b/vignettes/spatial-cross-validation.Rmd index 049dee63..4d09bbcc 100644 --- a/vignettes/spatial-cross-validation.Rmd +++ b/vignettes/spatial-cross-validation.Rmd @@ -1,7 +1,7 @@ --- title: "Spatial cross-validation" description: > - The five fold schemes, sizing blocks from the autocorrelation range, and reading a cross-validation result down to the last row. + The six fold schemes, sizing blocks from the autocorrelation range, and reading a cross-validation result down to the last row. author: "Justin Chase" date: "`r format(Sys.Date(), '%d %B %Y')`" output: @@ -149,7 +149,7 @@ Neither number is the truth. The blocked one answers a harder question, and it is the question most maps are used for: what happens at a location with no observation nearby. -## The five fold schemes +## The six fold schemes ```{r methods-table, echo=FALSE, results='asis'} cat( @@ -160,6 +160,7 @@ cat( "| `buffered_loo` | one point, and everything within `buffer` of it | n is small and you can afford n fits |\n", "| `leave_location_out` | every observation from one site, named by `group_var` | you have repeat visits and the site is the unit |\n", "| `nndm` | one point, and a distance-matched exclusion | you know where you will predict, and want the fold geometry to match it |\n", +"| `knndm` | one of `k` folds built from clusters of the points, matched to the prediction distances | the same, with more rows than `nndm` takes (5,000) or too many for one fit per point; the match is coarser |\n", sep = "") ``` diff --git a/vignettes/spatialkit_nc_demo.Rmd b/vignettes/spatialkit_nc_demo.Rmd index bdc97faf..01df64d7 100644 --- a/vignettes/spatialkit_nc_demo.Rmd +++ b/vignettes/spatialkit_nc_demo.Rmd @@ -24,8 +24,7 @@ has_ggplot <- requireNamespace("ggplot2", quietly = TRUE) has_geom <- requireNamespace("geometry", quietly = TRUE) has_ranger <- requireNamespace("ranger", quietly = TRUE) has_gstat <- requireNamespace("gstat", quietly = TRUE) -has_gwmodel <- requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE) +has_gwr <- requireNamespace("sp", quietly = TRUE) knitr::opts_chunk$set( echo = TRUE, @@ -54,13 +53,19 @@ walks through the `spatialkit` workflow end to end: cell means 5. Estimate the autocorrelation range, build spatial CV folds, and score a model under **blocked** versus **random** folds -6. Fit the models to keep: a random forest, GWR when it is installed, and the +6. Fit the models to keep: a random forest, GWR when `sp` is installed, and the two compared on identical folds 7. Predict onto a surface and mark where that surface is extrapolation Everything is self-contained — the boundary comes from the `nc.shp` demo shapefile bundled with `sf`, so no external files are needed. +The cell functions run at their defaults: density-weighted seeds +(`partition = "density"`, from 3 starts) and a pooled value beside each cell +mean (`estimate = "pooled"`). `partition = "kmeans"` in `get_voronoi_seeds()` +and `estimate = "mean"` in `summarize_by_cell()` give the k-means seeds and +the plain frame of earlier versions. + Optional backends are checked at the top and every section that needs one is guarded, so this document renders with whatever you happen to have installed. This table always runs, even when the gate below it is shut -- it is what says @@ -69,9 +74,9 @@ which backend is missing when the code stops producing output: ```{r backend-report, echo=FALSE, eval=TRUE} data.frame( package = c("ggplot2", "patchwork", "geometry", "ranger", "gstat", - "GWmodel + sp"), + "sp"), available = c(has_ggplot, requireNamespace("patchwork", quietly = TRUE), - has_geom, has_ranger, has_gstat, has_gwmodel), + has_geom, has_ranger, has_gstat, has_gwr), used_for = c("all plots", "the stacked comparison panels", "true Delaunay triangulation", "random forest backend", "variogram / autocorrelation range", "GWR backend") @@ -166,13 +171,14 @@ ggplot() + ## 3. Four tessellations -### 3a. Voronoi from ~40 k-means seeds +### 3a. Voronoi from ~40 density-weighted k-means seeds Voronoi cells are built around *seed* points, not the observations themselves. Seeding one cell per observation would give 300 cells each containing a single point — a nearest-neighbour interpolation rather than an aggregation, with no within-cell variation to compute a standard error from. `get_voronoi_seeds()` -clusters the observations first, so cell size follows sampling density. +clusters the observations first, each weighted by its local density, so cells +are small where the observations are dense. ```{r tess-voronoi} seeds <- get_voronoi_seeds( @@ -186,8 +192,18 @@ tess_voronoi <- build_tessellation( seeds, boundary = nc_boundary, method = "voronoi", clip = TRUE, quiet = TRUE ) +sum(is.na(tess_voronoi$index)) # seeds that lie in no cell ``` +A k-means centre is a mean of observations, and it can lie outside a boundary +that is not convex. Here one density-weighted centre lies just outside the +state outline, over a sound that coastal observations surround, and +`build_tessellation()` warns (class `spatialkit_unassigned`) that one point +falls in no cell; this vignette does not print warnings. The points are the +seeds, not the observations: the seed's cell is built inside the outline, every +observation falls in a cell, and the seed has `NA` in `tess_voronoi$index`. +`?cell_values_at` shows how to give such a seed its cell's ID. + ### 3b and 3c. Hex and square grids (~50 cells) ```{r tess-grids} @@ -244,7 +260,8 @@ cat(sprintf( `assign_features_to_polygons()` joins points to cells; `summarize_by_cell()` does the aggregation — means, standard deviations and standard errors for the -response and every predictor, plus `n` and `cell_weight`. There is no need to +response and every predictor, plus `n` and `cell_weight`, and beside each mean +a pooled value, the mean pulled toward the cells around it. There is no need to write the `group_by()`/`summarise()` by hand, and doing so loses the design-effect machinery below. @@ -383,9 +400,8 @@ principal directions and reports their ranges in the `directional` attribute diagnostic: each direction sees about a quarter of the point pairs, the maximum of four such fits is biased upward, and the windows are fixed to the coordinate axes, so nothing built from them is invariant to rotating the layer. The -all-pairs fit is the estimate whenever it is usable; the directional maximum -stands in for it only when the all-pairs fit fails, and the `anisotropy_used` -attribute is `TRUE` in that case alone. If you *know* the field is anisotropic, +all-pairs fit is the estimate or there is none: the largest directional range +never stands in for it. If you *know* the field is anisotropic, size blocks from the longest directional range explicitly: `max(attr(sac, "directional_fitted"), na.rm = TRUE)`, after checking `attr(sac, "directional_status")`, since `directional` is `NA` for a direction @@ -402,9 +418,8 @@ sac if (is.na(sac)) { cat("no identified range:", attr(sac, "rejected_reason"), "\n") } else { - cat(sprintf("range = %.0f ft; anisotropy ratio %.2f; used %s\n", - as.numeric(sac), attr(sac, "anisotropy"), - attr(sac, "anisotropy_used"))) + cat(sprintf("range = %.0f ft; anisotropy ratio %.2f\n", + as.numeric(sac), attr(sac, "anisotropy"))) } ``` @@ -445,9 +460,9 @@ library(patchwork) ### 5c. The number the fold scheme changes `fit_rf_model()` and `cv_rf()` need `ranger`. `include_coords = TRUE` hands the -forest the coordinates, which lets it memorise the training surface — the -failure mode the default (`FALSE`) exists to prevent, and the one random folds -cannot see. Scoring the same model on both fold schemes shows the size of the +forest the coordinates, which lets it fit the training surface by location. A +random hold-out then overstates its accuracy, which random folds cannot +show. Scoring the same model on both fold schemes shows the size of the gap: ```{r cv-contrast, eval=has_ggplot && has_ranger} @@ -522,9 +537,9 @@ cat(sprintf("Moran's I = %.4f (z = %.2f, p = %.3g)\n", mi$observed, mi$z, mi$p_value)) ``` -### GWR, if `GWmodel` is installed +### GWR, if `sp` is installed -```{r gwr-fit, eval=has_ggplot && has_gwmodel} +```{r gwr-fit, eval=has_ggplot && has_gwr} gwr_fit <- fit_gwr_model( data_sf = points_sf, response_var = "y", @@ -545,7 +560,7 @@ The fit raises no collinearity warning, but its survey of the local designs `?fit_gwr_model`) is worth a look: in 25 of the 300 windows the condition index that includes the intercept (`cn`) is above 30. The cause is `elevation`: it averages about 3,000 but has a standard deviation of only about -400 inside a 42-neighbour window, so locally it is nearly collinear with the +400 inside a 44-neighbour window, so locally it is nearly collinear with the intercept. What that leaves poorly determined is the local intercepts, not the slopes: the slope index (`cn_slopes`), which centres the predictors in each window, stays below 30 everywhere, so no slope is masked and the fit does not @@ -664,8 +679,8 @@ about it: | for | read | |:---|:---| | getting your own data in, and what the coordinates are in | `vignette("getting-started")` | -| how many cells, and the four criteria that disagree | `vignette("resolution")` | -| the five fold schemes, and sizing a block by measurement | `vignette("spatial-cross-validation")` | +| how many cells, and the criteria that disagree | `vignette("resolution")` | +| the six fold schemes, and sizing a block by measurement | `vignette("spatial-cross-validation")` | | residual autocorrelation, aggregation standard errors, and two ways to leak | `vignette("diagnostics")` | | handing the regions to someone else, and what to report | `vignette("reporting")` |