From 4782d4cdfa0f05b1060aa146b1793eb7bac3b1fb Mon Sep 17 00:00:00 2001 From: Justin Chase Date: Mon, 31 Aug 2026 21:37:37 -0400 Subject: [PATCH] Correct nine silent-wrong-answer defects found in the third audit pass Each was reproduced by execution and each fix measured. Moran's I * Drop self-neighbours from the k-NN weights. FNN returns a point's own index when coordinates are duplicated, putting 1/k on a diagonal the statistic requires to be zero: 77% of samples "significant" at p<0.05 on data with no structure. Requesting k+1 and dropping self is insufficient -- the displaced slot left a farther point standing in for a co-located one -- so duplicates are now grouped and answered exactly. * Add null = "auto"/"randomisation"/"residual". The exchangeable null is wrong for model residuals; the Cliff & Ord (1981 sec. 8.3) regression moments agree with spdep::lm.morantest() to machine precision. GWR * Read AICc from column 3, not the uncorrected AIC in column 2. GWmodel builds GWR.df by rbind() over unnamed vectors, so the positional read is the normal path. Verified on GWmodel 2.4.1 by recomputing AICc via gwr.basic(): AIC keeps a pure-noise predictor, AICc drops it. * fitted() no longer returns a coefficient surface for a predictor named fit/pred/prediction/fitted/yhat (in-sample R2 was -1.18 vs 0.981). * coef.gwr_fit() returns model terms only, not the whole 15-column SDF. * Omit dMat rather than passing NULL: bw.gwr() branches on missing(), so every dataset above 2000 points silently got the fallback bandwidth. Bayesian GP * Attach the length-scale prior at coefficient level. A global class "lscale" prior is silently dropped by brms, so Stan received defaults and the calibration machinery was dead weight (confirmed via make_stancode()). * Size the GP basis against brms's own domain measure -- the full pooled range of the centred coordinates, not the half-range -- so the boundary is no longer twice as wide as gp_k was sized for. Aggregation and folds * Correct the design-effect standard error: s^2 is biased low by the same clustering deff corrects for. 95% coverage went 0.63 -> 0.95 at rho=0.8. The deff = 1 path is bit-identical. * Scale a subsampled variogram design effect to the cell's own size (228.6 -> 1825.2 against a true 1821.8). * Sweep four azimuths, not two: 0/90 at +-22.5 degrees left half of all directions uncovered, halving the range for a diagonally oriented field. A non-converged or unidentified direction is excluded rather than read as a long range, and its variogram stays attached for inspection. * Rank level-selection candidates on the standardised deviate; |I| falls 56% across k on pure noise while |z| stays calibrated. * Refuse fold sets built from another dataset via a row fingerprint. * estimate_sac_range() is reproducible, validates its response type, and no longer advances the caller's RNG. 3379 tests passing, 0 failures, 0 warnings, 9 skips, on GWmodel 2.4.1 and brms 2.20.4. R CMD check: 1 NOTE (cmdstanr, not on CRAN). --- NEWS.md | 394 +++++++++++ R/area-of-applicability.R | 23 +- R/assignment.R | 97 ++- R/cross-validation.R | 718 ++++++++++++++++--- R/crs-geometry.R | 41 +- R/evaluation.R | 649 +++++++++++++++--- R/level-selection.R | 189 ++++- R/model-bayesian.R | 162 ++++- R/model-classes.R | 297 +++++++- R/model-gwr.R | 173 ++++- R/model-prep.R | 60 +- R/model-rf.R | 38 +- R/model-selection-gwr.R | 161 ++++- R/plotting-fits.R | 9 +- R/predict-surface.R | 13 +- R/seeding.R | 64 +- R/spatialkit-package.R | 67 ++ R/stable-ids-cache.R | 22 +- R/tessellation.R | 119 +++- README.md | 719 ++++++++++++++++---- cran-comments.md | 194 ++++-- dev/verify-gwr-aicc.R | 88 +++ inst/scripts/example_nc_demo.R | 5 +- man/assign_features_to_polygons.Rd | 18 + man/build_tessellation.Rd | 29 +- man/clear_fitted_cache.Rd | 11 +- man/clip_target_for.Rd | 10 +- man/coef.bayesian_fit.Rd | 8 +- man/coef.gwr_fit.Rd | 28 +- man/compare_models.Rd | 12 +- man/compare_models_cv.Rd | 10 +- man/create_grid_polygons.Rd | 30 +- man/create_voronoi_polygons.Rd | 16 +- man/cv_bayes.Rd | 17 +- man/cv_gwr.Rd | 19 +- man/cv_spatial.Rd | 48 +- man/determine_optimal_levels.Rd | 58 +- man/ensure_projected.Rd | 41 +- man/estimate_sac_range.Rd | 48 +- man/evaluate_insample.Rd | 4 +- man/fit_bayesian_spatial_model.Rd | 38 +- man/fit_gwr_model.Rd | 1 + man/fit_rf_model.Rd | 1 + man/fitted.bayesian_fit.Rd | 24 +- man/get_voronoi_seeds.Rd | 10 +- man/gwr_model_selection.Rd | 18 +- man/make_folds.Rd | 32 +- man/model_metrics.Rd | 14 +- man/new_spatial_fit.Rd | 84 ++- man/plot.spatial_fit.Rd | 9 +- man/predict.rf_fit.Rd | 8 +- man/predict_surface.Rd | 13 +- man/prep_model_data.Rd | 3 +- man/print.aoa.Rd | 8 +- man/print.gwr_model_selection.Rd | 7 +- man/print.rf_fit.Rd | 6 +- man/print.spatial_fit.Rd | 8 +- man/residual_morans_i.Rd | 131 +++- man/residuals.rf_fit.Rd | 9 +- man/spatialkit-package.Rd | 73 +- man/summarize_by_cell.Rd | 20 + man/voronoi_seeds_kmeans.Rd | 21 +- man/voronoi_seeds_random.Rd | 14 +- tests/testthat/test-area-of-applicability.R | 98 +++ tests/testthat/test-build-tessellation.R | 70 ++ tests/testthat/test-crs-projection.R | 49 ++ tests/testthat/test-deff-variogram.R | 36 +- tests/testthat/test-degenerate-geometry.R | 77 +++ tests/testthat/test-evaluation.R | 99 +++ tests/testthat/test-fold-methods.R | 66 ++ tests/testthat/test-gp-basis.R | 98 ++- tests/testthat/test-gwr-bandwidth.R | 59 ++ tests/testthat/test-gwr-model-selection.R | 32 +- tests/testthat/test-knn-weights.R | 168 +++++ tests/testthat/test-level-selection.R | 316 ++++----- tests/testthat/test-make-folds-row-ids.R | 74 ++ tests/testthat/test-model-rf.R | 118 ++++ tests/testthat/test-predict-surface.R | 46 ++ tests/testthat/test-regressions.R | 99 +++ tests/testthat/test-sac-range.R | 131 +++- tests/testthat/test-seeding.R | 137 +++- tests/testthat/test-summarize-by-cell.R | 170 ++++- vignettes/spatialkit_nc_demo.Rmd | 12 + 83 files changed, 6359 insertions(+), 857 deletions(-) create mode 100644 dev/verify-gwr-aicc.R diff --git a/NEWS.md b/NEWS.md index 35b77c1..be0b06e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -15,6 +15,228 @@ Throughout, *raises a warning* means a genuine R `warning()` — one ## Breaking changes +### Statistical corrections that change results (third audit pass) + +Each item below was measured, and the measurement is quoted so you can judge +whether it affects an analysis you have already run. + +* **`residual_morans_i()` no longer puts weight on a point's own residual.** + `FNN::get.knn()` reports a point's OWN index among its neighbours whenever + exact duplicate coordinates are present, which put `1/k` on the diagonal of a + matrix Moran's I is only defined for with a zero diagonal. On 40 sites x 4 + repeats with a response carrying **no** spatial structure, 120 of 160 rows + gained a self-weight, mean I came out at +0.086 against E[I] = -0.0063, and + **77% of samples were "significant" at p < 0.05** against a nominal 5%. + Repeat observations at one site are exactly what + `make_folds(method = "leave_location_out")` is for, so this was a mainstream + input. The dense fallback never had the fault, so the statistic also depended + silently on whether **FNN** happened to be installed; the two paths now share + one neighbour lookup and agree exactly. + + Requesting `k + 1` neighbours and dropping self is **not** sufficient on its + own — the slot self occupied displaced a genuine co-located neighbour and left + a farther point standing in for it (75 of 400 retained pairs sat at distance + 121 where a neighbour at distance 0 existed). Duplicate coordinates are now + grouped and answered exactly. + +* **`residual_morans_i()` gains a `null` argument, defaulting to `"auto"`.** + Model residuals are not exchangeable — they are orthogonal to the design + matrix — so the classical randomisation moments are wrong for them. At + n = 120 with six smooth covariates and independent errors, OLS residuals had + mean I = -0.031 against the exchangeable E[I] = -0.008, and the z-score + averaged -0.54 with sd 0.90 instead of 0 and 1. The Cliff & Ord (1981, + sec. 8.3) regression-residual moments restore mean z = -0.09, sd 1.03 and a + 4.3% rejection rate against a nominal 5%, and **agree with + `spdep::lm.morantest()` to machine precision** (verified at 1e-16 through the + public function). `"auto"` applies them only when the fit's residuals really + are the OLS residuals on the rebuilt design, which a forest's and a working + GWR's are not; the null actually used is reported in the return value. + +* **`summarize_by_cell()` standard errors under a design effect were too + small.** `s / sqrt(n / deff)` corrects the mean's variance for clustering but + leaves `s^2` biased low by the same clustering: for exchangeable correlation + rho, `E[s^2] = sigma^2 (n - deff)/(n - 1)`. The two errors compound. Measured + 95% CI coverage at n = 20: **0.905 at rho = 0.3, 0.796 at rho = 0.6, 0.632 at + rho = 0.8**; after rescaling by `sqrt((n-1)/(n-deff))`, 0.952 / 0.952 / 0.953. + Applies to `deff = "kish"`, `deff = "variogram"` and a fixed numeric `deff`. + **The default `deff = 1` path is bit-identical to before.** + +* **`summarize_by_cell(deff = "variogram")` reported the design effect of the + subsample, not of the cell.** A cell larger than `deff_max_n` was subsampled + and then answered with `sum(R)/n_used` — the design effect of a cell of + `deff_max_n` points. Measured on 4000 points with an exponential correlation + of range 60: true deff **1821.8**, reported **228.6**. The mean off-diagonal + correlation is now estimated from the subsample and scaled to the cell's own + size, giving 1825.2. Un-subsampled cells are algebraically unchanged. + +* **`determine_optimal_levels()` ranks model-aware candidates on the + standardised deviate, not on |Moran's I|.** E[I] and Var(I) both depend on the + cell count, so |I| shrinks as k grows whether or not the finer tessellation + captures anything. Over 300 replicates of a response with **no** spatial + structure, mean |I| fell monotonically from 0.114 at k = 10 to 0.050 at + k = 60 — an |I| ranking prefers the largest candidate for arithmetic reasons + alone. Candidates are now ordered by |z| using the Cliff & Ord residual + moments (exact here, since the cell-level residuals are OLS residuals by + construction); over the same runs z had mean ~0, sd ~1 and a 5% rejection rate + of 0.040-0.057 at every k. The `"diagnostics"` attribute now carries + `moran_z` alongside `moran_i`. + +* **`estimate_sac_range()` sweeps four azimuths, not two.** A +/-22.5 degree + window around 0 and 90 covers exactly **90 of the 180 distinct azimuths** — + every direction between 23 and 67 degrees, and between 113 and 157, fell into + neither. On simulated fields with 3:1 anisotropy and a true major-axis range + of 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**. Since + `make_folds(auto_range = TRUE)` sizes blocks from this number, a diagonally + oriented field silently got blocks half as wide as the correlation they were + meant to separate. `c(0, 45, 90, 135)` tiles all 180 azimuths; the same fields + now return 255 / 245 / 249 / 228. A direction whose variogram never reaches a + sill is excluded rather than taken as a long range, and the `directional` + attribute now has four named entries. + +* **`gwr_model_selection()` ranked on AIC while labelling the result AICc.** + GWmodel's `GWR.df` is documented and built as `c(bandwidth, AIC, AICc, RSS)` + and is `rbind()`ed over unnamed vectors, so it never carries column names — + making the positional read the path every real call takes, not a rare + fallback. Column 2 is the uncorrected AIC. Executed against a faithful + GWmodel stub on 200 points with two real predictors and one pure-noise + variable: **column 2 selects the model containing the noise variable; column 3 + selects `a + b`.** The result now also reports whether the table had the + documented four columns. + +* **`fit_bayesian_spatial_model()`'s calibrated length-scale prior never + reached Stan.** `brms::set_prior(spec, class = "lscale")` with no `coef` is a + *global* prior, and brms applies a global prior only to coefficients with no + individual prior of their own — every `lscale` coefficient always has one. + brms dropped it with a note and Stan received brms's defaults, which made + `gp_lengthscale_bounds()`, the tail calibration and `$info$gp_lscale_prior` + dead weight. Confirmed with `brms::make_stancode()`: the requested prior is + absent under the global form and present under the coefficient-level form, + which is now used. `$info$gp_lscale_prior` is read back from + `brms::validate_prior()`, so it records what brms will actually use. + +* **The GP basis was sized against the wrong domain measure.** brms builds the + boundary as `choose_L(x, c) = c * max(1, max(x) - min(x))` over the pooled, + column-centred covariates — the **full range**, not the per-axis half-range in + which Riutort-Mayol et al. state their inequalities. Recovering the boundary + from `make_standata()`'s eigenvalues confirms `L = c * full range` exactly at + every `c`, so the old convention built a boundary **twice as wide** as `gp_k` + was sized for: the GP was under-resolved, and `$info$gp_ell_min` — the + diagnostic meant to catch exactly that — was twice too lenient to fire. The + `c` floor is now brms's own default 1.25 rather than 1.2. + +* **`fitted()` on a `gwr_fit` could return a coefficient surface.** The search + for GWmodel's fitted-value column matched the whole candidate name vector with + `%in%` and took the first hit in the *SDF's* column order — and the local + coefficients come first. A predictor named `fit`, `pred`, `prediction`, + `fitted` or `yhat` therefore returned its own coefficient column, silently: + executed in-sample R^2 was **-1.18** against a true 0.981, and `residuals()`, + `summary()`, `model_metrics()`, `compare_models()` and every `cv_gwr()` fold + consumed it without a warning. The search now runs in preference order and + excludes any candidate that is also a model term; all five colliding names now + give R^2 = 0.981, identical to the renamed control. + +* **`coef.gwr_fit()` returned GWmodel's whole SDF data slot** — 15 columns for a + two-predictor fit, of which 3 are coefficients and the rest are standard + errors, t-values, the response, the fitted values, residuals and `Local_R2`. + It now returns the model terms only; reach for `object$engine$SDF` for the + rest. + +* **`estimate_sac_range()` is reproducible, and no longer disturbs the caller's + RNG.** `seed` now defaults to `123L` rather than `NULL`. The `n_max` + subsample is an internal approximation, not part of the answer, and leaving it + unseeded made the returned range differ between runs on identical input + (19531 / 19589 / 19605 on three calls) while silently advancing the caller's + stream — and `make_folds(auto_range = TRUE)` sizes its blocks from that + number. Pass `seed = NULL` for the old behaviour. + +* **`estimate_sac_range()` rejects a non-numeric response.** `as.numeric()` on a + factor returns its level codes, 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 (3700 against 2497 on the same data). + Factors and character columns are now an error naming the column; logicals are + read as 0/1. + +* **Fold sets built from a different dataset are refused.** Fold splits are + lists of `..row_id` values, and row IDs are `seq_len(nrow())` unless supplied, + so passing `cv_gwr()` a `folds` object built from another dataset of the same + size applied cleanly — every ID matched, every fold was populated, and the + model was scored on splits describing other observations. `make_folds()` now + records a small projection-invariant row fingerprint in + `params$row_probe`, and `cv_gwr()`, `cv_bayes()`, `cv_spatial()` and `cv_rf()` + error rather than proceed. Fold objects from earlier versions carry no + fingerprint and are passed through unchecked. + +* **`evaluate_insample()` rejects duplicated names in `fits`.** `model` is the + key `compare_models()` joins its metric and Moran's I tables on, so two fits + called `"GWR"` produced a 2x2 cross-join: four rows, every one carrying the + first fit's numbers, with the second fit never scored at all. + +* **`predict.rf_fit()` no longer consumes the global RNG.** `ranger`'s predict + draws a seed from the global stream when none is supplied, so the number of + `predict()` calls a script happened to make — via `predict_surface()`'s + `chunk_size`, a pure performance knob — shifted every later random draw, + including fold assignments. A constant seed is now supplied unless the caller + passes one; it does not affect a regression forest's predictions. + +* **`fit_gwr_model()` rejects a non-numeric predictor.** `gwr.basic()` expands + contrasts via `model.matrix()` and fits, but `gwr.predict()` does not and + fails, so the model appeared to fit and then silently predicted all `NA`. + +* **`fit_gwr_model()` no longer rejects a two-valued continuous response.** The + "binary" error is now gated on the response being integer-like. A + left-censored or saturated measurement (every observation at a detection limit + or a ceiling) has two distinct values and is perfectly continuous; it now + warns instead. The guard also runs once per fold inside `cv_gwr()`, where a + small training fold can legitimately hold only two distinct values. + +* **`gwr_model_selection()` works above `dmat_max_n`.** `bw.gwr()` branches on + `missing(dMat)`, not `is.null(dMat)`, so passing `dMat = NULL` explicitly took + the *supplied* branch and died — meaning **every dataset above 2000 points + silently fell back to the arbitrary fallback bandwidth**, with the message + blaming GWmodel. The argument is now omitted rather than passed as `NULL`. A + fixed bandwidth with no distance matrix, which GWmodel cannot start, is now + refused with a message naming both remedies. + +* `fitted()` returning the wrong length, or nothing, is now an error in + `summary()` and `model_metrics()` rather than a plausible row count over an + all-`NA` comparison. `new_spatial_fit()` is the documented extension point, so + a subclass with a missing or mis-sized `fitted()` method is user-reachable. + +* The cached `fitted()` on a `bayesian_fit` is stamped with the `n` and a digest + of the data it was computed from. The cache environment has reference + semantics — which is what makes it survive copy-on-modify — so `fit2 <- fit` + gave both objects the *same* cache, and assigning different data to the copy + returned the original's values at the original's length. + +* `make_folds()` drops rows with empty or non-finite coordinates, with a logged + warning naming the count, rather than letting an `EMPTY` POINT reach + `block_kfold`'s nearest-block rescue and die with "replacement has length + zero". + +* When every fold fails, the warning now names the first underlying error. + Previously "all 5 folds failed" was the whole diagnosis even when the cause + was simply that **brms** or **GWmodel** was not installed. + +* `make_folds()` records the CRS the folds were built in as `params$crs`. + Geographic input is projected by `ensure_projected()` to a CRS the caller + never chose, and `block_size`, `sac_range` and `buffer` are lengths in *that* + CRS. + +* `n_models` in `gwr_model_selection()` is computed in double precision; the + integer form overflowed to `NA` above 46341 candidates, so the guard meant to + refuse an impossible sweep errored on exactly the inputs it existed to catch. + +* `.morans_i_for_k()` returns `NA` at or below nine cells, where every cell + neighbours every other and Moran's I collapses to exactly `-1/(k-1)` for any + residual vector — a function of the cell count alone. + +* `residual_morans_i(fit, k = 1)` works on machines without **FNN**. `apply()` + simplified the length-1 result to a vector, making the neighbour index a + 1 x n matrix and every row after the first out of bounds. + +### API and default changes + * Removed the legacy wrappers `evaluate_models()`, `evaluate_models_cv()` and `phi_prior_bounds()`. Use `compare_models()`, `compare_models_cv()` and `gp_lengthscale_bounds()`. @@ -490,6 +712,93 @@ Throughout, *raises a warning* means a genuine R `warning()` — one * `gwr_model_selection()` reports which column it read when the diagnostic table is labelled but not with `AICc`, rather than calling it unlabelled. +* **`create_grid_polygons()` no longer truncates the grid when `cellsize` and + `n` are both supplied. This changes results.** `sf::st_make_grid()` does not + ignore `n` when `cellsize` is given: for square grids it takes the cell + dimensions from `cellsize` *and* the counts from `nx = n[1]`, `ny = n[2]`, + anchored at the bounding-box corner. `cellsize = 25` with `n = 2` on a + 100 × 100 boundary therefore produced 4 cells covering 2,500 of 10,000 square + units and silently left three quarters of the study area with no cells at + all — and because `clip = TRUE` had nothing outside the boundary to discard, + the result looked like an ordinary, complete grid. `cellsize` now wins, `n` + is dropped with a logged warning naming what it would have done, and the same + call returns 16 cells covering the whole boundary. `n` is still forwarded + when the *package* derived `cellsize` from it or from `target_cells`, which + is what the original code was written for: omitting it there lets sf + recompute `ceiling(w / cellsize)` and floating-point division pushes the + count one past the intended value. + +* **`fit_gwr_model()` no longer refuses a continuous response that happens to + take two values. This changes results: fits that used to error now run.** The + guard rejected any response with exactly two distinct finite values as + "binary" and pointed at `GWmodel::ggwr.basic(family = "binomial")`. Two + distinct values is not the same thing as binary: a measurement censored at a + detection limit or saturated at a ceiling (0.0031 / 12.7401) is perfectly + continuous, Gaussian GWR on it is a well-defined least-squares problem, and + the advice to switch to a binomial family is nonsense for such values. The + hard stop is now gated on the response also being integer-like, which is what + the surrounding code already used to separate coded categories from + measurements. A two-valued non-integer response raises a `warning()` naming + the two values and asking you to confirm it is genuinely continuous, then + fits. This also mattered inside `cv_gwr()`, where the guard runs once per + fold and a small training fold can legitimately hold only two distinct + values. + +* **`determine_optimal_levels()` no longer reports a Moran's I that is + arithmetically fixed. This changes which cell counts it returns.** + `.morans_i_for_k()` builds a `min(8, n_cells - 1)`-nearest-neighbour weight + matrix, so at nine cells or fewer every cell neighbours every other one. The + row-standardised matrix is then complete, `W %*% e = -e/(n - 1)` for *any* + mean-zero residual vector, and Moran's I collapses to exactly + `-1/(n_cells - 1)` whatever the data are. That is not merely uninformative: + `|I| = 1/(n_cells - 1)` falls monotonically in the number of cells, so + `criterion = "morans_i"` ranked the largest evaluated candidate first every + time, and `"combined"` carried the same tilt at half weight. Candidates below + the floor now return `NA_real_` and are excluded from the model-aware + ranking; when none clears it — the usual outcome at the default + `max_levels = 12`, since the search evaluates a window around the elbow — the + call falls back to the geometric ranking and logs a warning. Raise + `max_levels` above roughly 10 for the model-aware criteria to contribute at + all. `predictor_vars` also accepts logical columns now, read as 0/1, matching + `fit_rf_model()`/`cv_rf()`/`predict()`; factor and character predictors are + still refused by name. + +* `area_of_applicability()` accepts logical predictors, read as 0/1, instead of + refusing them alongside factors and characters. `fit_rf_model()` fits a + logical predictor, `cv_rf()` cross-validates it and `predict()` predicts with + it, so refusing to compute the dissimilarity index for the same model was + self-inconsistent. A logical's 0/1 standard deviation is meaningful, which is + the property the scaling needs; factor and character predictors, which would + need an arbitrary one-hot scaling, are still refused. + +* `residual_morans_i(fit, k = 1)` no longer errors with "subscript out of + bounds" on a machine without `FNN`. In the dense fallback the inner function + returns a scalar at `k = 1`, so `apply()` simplified the neighbour table to a + length-n vector and `t()` made it a 1 × n matrix; indexing `nn_idx[i, ]` + then failed for every `i > 1`. The result is now forced to `n × k`. + +* `make_folds()` no longer dies on an empty or non-finite geometry. + `st_coordinates()` yields one all-`NA` row per EMPTY POINT rather than zero + rows, so a row-count check let them through: `block_kfold`'s + `st_intersects()` returned `integer(0)`, `..block_id` went `NA`, and the + nearest-block rescue aborted with "replacement has length zero". Unusable + rows are now dropped with a warning naming the count, after `..row_id` is + stamped so the survivors keep their original row identities, and for every + method rather than just `block_kfold` — `random_kfold` would otherwise put an + unplottable point in a fold, and `nndm` and `buffered_loo` both feed the + coordinates to distance code. The rescue itself uses `vapply()` rather than + `apply()`, so a point whose distances are all `NA` keeps its `NA` instead of + collapsing the assignment. `points_sf` with no usable coordinates at all is + an error naming that, not a downstream one. + +* Every cross-validation wrapper names the cause when folds fail. + `.cv_run_folds()` returns each fold's error text rather than a bare `NULL`, + and `cv_gwr()`, `cv_bayes()` and `cv_spatial()` append `First error: ...` to + both the logged and the R-level "all N folds failed" message. Running + `cv_bayes()` without `brms` installed previously produced five `fold N fit + failed` warnings and an all-`NA` `$overall` with `n_pred = 0` in which the + word "brms" never appeared. + ## New features * New `fit_rf_model()` and `cv_rf()`: a `ranger` random forest as a first-class @@ -596,6 +905,13 @@ Throughout, *raises a warning* means a genuine R `warning()` — one result records `n_folds_attempted` and `n_folds_succeeded` — compare them before trusting `overall`. +* `make_folds()` records the CRS the folds were built in as `params$crs` + (`"EPSG:32632"`, an input string, or a WKT). `block_size` and `sac_range` are + lengths in *that* CRS, which is not necessarily the one the caller passed: + geographic input is projected by `ensure_projected()` to a CRS chosen for the + extent. Without the label the units of a recorded block size were not + recoverable from the result. + ## Documentation * Every runnable example is now runnable. Four exported functions @@ -639,6 +955,84 @@ Throughout, *raises a warning* means a genuine R `warning()` — one `group_by()`/`summarise()`, and adds a spatial cross-validation section contrasting `block_kfold` against `random_kfold` on the same data. +* The package-level help page (`?spatialkit`) gains "The pipeline, in order" + and "Where to start" sections, so `help(package = "spatialkit")` leads + somewhere rather than presenting 40 exports in alphabetical order. + +* Every exported function's description now says *when to reach for it* rather + than only what it does, and `@family` / `@seealso` links connect each step of + the pipeline to the one before and after it — `assign_features_to_polygons()` + to `summarize_by_cell()`, `determine_optimal_levels()` to + `build_tessellation()`, `new_spatial_fit()` to `cv_spatial()`, and the two + seeding functions to each other. `create_voronoi_polygons()` versus + `create_grid_polygons()`, and `voronoi_seeds_kmeans()` versus + `voronoi_seeds_random()`, each say which to pick and why. + +* `build_tessellation()` documents that `boundary` is **required** for + `method = "hex"` and `method = "square"` — the grid methods have no extent of + their own — and optional for `"voronoi"` and `"triangles"`, which derive one + from the points. The error existed; the requirement was not written down + anywhere. + +* `create_grid_polygons()` documents that `target_cells`, `cellsize` and `n` + are three ways of sizing one grid and that exactly one should be supplied, + that `cellsize` is in the units of the working CRS, and that `cellsize` takes + precedence over `n`. + +* `determine_optimal_levels()` documents the nine-cell resolution floor on the + model-aware criteria, why it exists, and that the whole call falls back to + the geometric ranking when no candidate clears it. + +* `compare_models_cv()` documents that dropping every requested backend is an + error (`"no viable models."`) rather than an empty comparison, and that the + returned frame carries only the models that actually ran, so callers should + check which names are present rather than assuming one row per request. + +* `new_spatial_fit()` documents the two obligations on a custom backend: + return an object built by the constructor, and define a + `predict.()` method — `cv_spatial()` scores folds through the + `predict()` generic, so without one every fold fails. + +* **README.** A new "Your own data" section shows both entry points — + `st_read()` for a spatial file and `read.csv()` + `st_as_sf()` for a table of + coordinates — using the `nc.shp` demo shapefile shipped with `sf` so it runs + anywhere. The README previously manufactured every example inline with a + hard-coded `crs = 32632` and never showed data entering the package at all. + A companion "CRS: what the numbers are in" subsection states that block + sizes, buffers, bandwidths, variogram ranges and `expand` distances are in + the units of the working CRS; that geographic input is projected + automatically to a CRS chosen for the extent; and how to pin one. + +* **README.** New guidance where none existed: how to choose among the four + tessellation methods, how `k` and `block_size` trade off against the + autocorrelation range, what to do when `estimate_sac_range()` returns `NA`, + how to read a design effect, which model backend to reach for (with the + recorded cost of each), and a "Troubleshooting" section covering the errors a + new user actually hits first. A worked hex-grid example replaces the previous + picture-only coverage of the grid methods. + +* **README.** Three corrections. The `estimate_sac_range()` example showed a + rejected range printing its attributes, which `print.sac_range()` has not + done since the attribute dump was removed; it now shows the bare `NA` and + reads the attributes explicitly. The `determine_optimal_levels()` passage + claimed the residual-autocorrelation criterion was doing work at cell counts + where it is arithmetically degenerate. The test-suite paragraph said "exactly + one" test guards on `brms`; six do, five of them additionally gated behind + `SPATIALKIT_TEST_BRMS` so they never run in the matrix. + +* **`inst/scripts/example_nc_demo.R`** said EPSG:2264 was projected "so + distances are metric". Its unit is the US survey foot, which is what the + script's own "Autocorrelation range: %.0f ft" line reports. The comment now + says planar, and names the unit every distance, bandwidth and block size in + the script is in. + +* **Vignette.** `print(rf_fit)` and `summary(rf_fit)` report the same OOB RMSE + but different R² (0.4733 against 0.4715). The vignette now explains why: + `print.rf_fit()` echoes `ranger`'s `r.squared` (`1 - MSE/var(y)`, unbiased + n − 1 variance) while `summary()` recomputes `1 - SS_res/SS_tot` from the + same out-of-bag predictions with an n denominator, so the unexplained + fractions differ by exactly n/(n − 1). + # spatialkit 1.0.0 First CRAN release, published 2026-08-07. diff --git a/R/area-of-applicability.R b/R/area-of-applicability.R index 0910474..a072113 100644 --- a/R/area-of-applicability.R +++ b/R/area-of-applicability.R @@ -29,12 +29,19 @@ what, paste(sQuote(missing_v), collapse = ", ")), call. = FALSE) sub <- df[, vars, drop = FALSE] - bad <- vars[!vapply(sub, is.numeric, logical(1))] + # Logicals are admitted: storage.mode() below gives them the natural 0/1 + # coding, whose standard deviation IS meaningful. fit_rf_model() fits a + # logical predictor, cv_rf() cross-validates it and predict() predicts with + # it, so refusing the same model here would be self-inconsistent. Only + # factor/character predictors -- which would need an arbitrary one-hot + # scaling -- are refused. + bad <- vars[!vapply(sub, function(v) is.numeric(v) || is.logical(v), + logical(1))] if (length(bad) > 0L) stop(sprintf(paste0("area_of_applicability(): predictor(s) in %s are not ", - "numeric: %s. The dissimilarity index is a Euclidean ", - "distance in scaled predictor space and has no ", - "definition for categorical predictors; recode them ", + "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."), what, paste(sQuote(bad), collapse = ", ")), call. = FALSE) m <- as.matrix(sub) @@ -707,6 +714,14 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, #' Print an area-of-applicability result #' +#' 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 +#' 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. +#' #' @param x An \code{aoa} object. #' @param ... Ignored. #' @return \code{x}, invisibly. diff --git a/R/assignment.R b/R/assignment.R index 44fbe79..0f6aac2 100644 --- a/R/assignment.R +++ b/R/assignment.R @@ -2,6 +2,14 @@ #' #' Joins an sf layer of input features to a polygon layer via spatial join. #' +#' This is the second step of the package's pipeline: it labels every +#' observation with the cell it falls in, which is what +#' [summarize_by_cell()] then aggregates over. Reach for it directly (rather +#' than for [sf::st_join()]) when the join has to be *unambiguous* --- it +#' resolves features matching several polygons by an explicit `tie_break` rule +#' instead of silently duplicating rows, so the assigned layer keeps one row +#' per input feature and cell-level counts mean what they say. +#' #' @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". @@ -31,6 +39,9 @@ #' grid <- create_grid_polygons(bnd, target_cells = 9, type = "square") #' assigned <- assign_features_to_polygons(pts, grid) #' table(assigned$poly_id) +#' @family aggregation +#' @seealso [build_tessellation()] to build the polygon layer; +#' [summarize_by_cell()] for the aggregation step that consumes the result. #' @export assign_features_to_polygons <- function( features_sf, polygons_sf, polygon_id_col = "poly_id", @@ -192,6 +203,42 @@ assign_features_to_polygons <- function( } +#' Standard error of a cell mean under a design effect +#' +#' Two corrections, not one. A design effect inflates the variance of the mean +#' to \eqn{\sigma^2 \mathrm{deff} / n}, which is what \code{s/sqrt(n/deff)} +#' applies --- but under the same within-cell correlation the ordinary sample +#' variance is \emph{also} biased downward. For exchangeable correlation +#' \eqn{\rho} (Kish's own assumption), with \eqn{\mathrm{deff} = 1 + (n-1)\rho}: +#' \deqn{E[s^2] = \sigma^2 (n - \mathrm{deff}) / (n - 1)} +#' so \eqn{s^2} understates \eqn{\sigma^2} by very nearly the factor deff +#' inflates the mean's variance by, and the two errors compound rather than +#' cancel. Measured 95\% CI coverage of the uncorrected form at \eqn{n = 30} +#' over 20,000 replicates: 0.921 at \eqn{\rho = 0.2}, 0.844 at \eqn{\rho = 0.5}, +#' 0.628 at \eqn{\rho = 0.8}. With the \eqn{\sqrt{(n-1)/(n-\mathrm{deff})}} +#' rescale below: 0.948, 0.950, 0.949. +#' +#' At \code{deff = 1} the factor is exactly 1, so the default path is +#' bit-identical to \code{s/sqrt(n)}. +#' +#' @param s Within-cell standard deviation. +#' @param n Number of non-missing observations in the cell. +#' @param deff Design effect for that cell, \eqn{\geq 1}. +#' @return The standard error, or \code{NA_real_} when the cell carries no +#' information about \eqn{\sigma} (\code{deff >= n}: complete redundancy). +#' @keywords internal +#' @noRd +.se_with_deff <- function(s, n, deff) { + if (!is.finite(s) || !is.finite(n) || n <= 1L) return(NA_real_) + if (!is.finite(deff) || deff <= 1) return(s / sqrt(n)) + # deff is bounded above by n (every observation a copy of every other). At + # that bound the cell holds one observation's worth of information and s + # carries none about sigma, so there is no standard error to report. + if (deff >= n) return(NA_real_) + s * sqrt(deff / n) * sqrt((n - 1) / (n - deff)) +} + + #' Per-cell design effect from a fitted variogram #' #' For \code{n} observations in a cell with correlation matrix \code{R}, the @@ -236,9 +283,19 @@ assign_features_to_polygons <- function( R <- matrix(as.numeric(cor_fn(as.numeric(d))), nrow = nrow(d), ncol = ncol(d)) diag(R) <- 1 n_used <- nrow(R) - # deff = sum(R) / n; bounded below by 1 (independence) and above by n - # (complete redundancy). - out[[as.character(id)]] <- min(max(sum(R) / n_used, 1), n_used) + # deff = sum(R)/n_i for the WHOLE cell, which is 1 + (n_i - 1) * Rbar with + # Rbar the mean off-diagonal correlation. Subsampling estimates Rbar just + # as well (the subsample's pairwise-distance distribution is the cell's), + # but sum(R)/n_used answers for a cell of size n_used -- so a subsampled + # cell used to be reported at the design effect of `max_n` points rather + # than of its own n_i. Measured: 4000 points, exponential correlation with + # a 60-unit range, true deff 1821.8; sum(R)/n_used at max_n = 500 gave + # 228.6, the rescale below gives 1825.2. + # + # When nothing was subsampled, n_used == n_i and this is algebraically + # identical to the old sum(R)/n_i, so unsubsampled cells are unchanged. + r_bar <- (sum(R) - n_used) / (n_used * (n_used - 1)) + out[[as.character(id)]] <- min(max(1 + (n_i - 1) * r_bar, 1), n_i) } out } @@ -249,6 +306,17 @@ assign_features_to_polygons <- function( #' Aggregates an sf point dataset into one row per cell. By default computes #' counts and means, but the aggregation function is configurable. #' +#' 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 +#' it from a plain `dplyr::group_by()` + `summarise()` is that it carries the +#' *uncertainty* of each aggregate with it: alongside every mean it returns a +#' within-cell standard deviation, a standard error and an observation count, +#' and it can correct that standard error for within-cell spatial +#' autocorrelation via `deff`. Reach for it whenever the cell-level values will +#' be modelled or mapped, because a cell mean over 2 observations and one over +#' 200 are not the same measurement and nothing downstream can tell them apart +#' otherwise. +#' #' In addition to user-specified aggregation functions, this function always #' computes within-cell standard deviation (`..sd_`) and standard error #' (`..se_`) for every numeric response/predictor column, plus a @@ -358,6 +426,9 @@ assign_features_to_polygons <- function( #' cells <- summarize_by_cell(assigned, response_var = "val", deff = "kish") #' cells #' attr(cells, "deff_applied") +#' @family aggregation +#' @seealso [assign_features_to_polygons()], which produces the input layer; +#' [build_tessellation()] for the cells themselves. #' @export summarize_by_cell <- function(assigned_points_sf, response_var = NULL, @@ -548,7 +619,10 @@ summarize_by_cell <- function(assigned_points_sf, } else { deff_i <- .deff } - s / sqrt(n_valid / deff_i) + # NOT s / sqrt(n_valid / deff_i): that corrects the mean's variance for + # clustering but leaves s^2 biased low by the same clustering. See + # .se_with_deff() for the derivation and the measured coverage. + .se_with_deff(s, n_valid, deff_i) } }) fns @@ -654,13 +728,22 @@ summarize_by_cell <- function(assigned_points_sf, } } else if (use_vgm && !is.null(vgm_deff)) { # Match each cell's deff by id, then rescale. The ..se_ closures ran with - # deff = 1, and SE scales as sqrt(deff), so multiplying by sqrt(deff_i) - # yields exactly s / sqrt(n / deff_i). + # deff = 1, so they hold s / sqrt(n); the factor below is exactly what + # .se_with_deff() would have returned had the per-cell deff been available + # inside the closure -- sqrt(deff) for the mean's variance AND + # sqrt((n - 1)/(n - deff)) for the downward bias in s^2 itself. Rescaling + # by sqrt(deff) alone would reproduce the under-coverage documented there. d_i <- unname(vgm_deff[as.character(out[[id_col]])]) d_i[!is.finite(d_i) | d_i < 1] <- 1 + n_i <- out$n + infl <- sqrt(d_i) * sqrt((n_i - 1) / (n_i - d_i)) + # deff >= n is complete redundancy: no information about sigma is left. + infl[!is.finite(infl) | d_i >= n_i] <- NA_real_ + infl[d_i <= 1] <- 1 + se_cols <- grep("^\\.\\.se_", names(out), value = TRUE) - for (cn in se_cols) out[[cn]] <- out[[cn]] * sqrt(d_i) + for (cn in se_cols) out[[cn]] <- out[[cn]] * infl out$cell_weight <- out$n / d_i attr(out, "deff_applied") <- list( diff --git a/R/cross-validation.R b/R/cross-validation.R index ead5dd7..2454be8 100644 --- a/R/cross-validation.R +++ b/R/cross-validation.R @@ -132,10 +132,145 @@ # Shared fold runner # ----------------------------------------------------------------------------- +#' Recover the message text from a \code{try-error} object +#' +#' \code{conditionMessage()} has no method for a \code{"try-error"} object, so +#' it must be reached through the condition hanging off the object as an +#' attribute; the deparsed string is the fallback for a \code{try-error} +#' carrying none. Shared by the per-fold catch and the parallel-worker catch. +#' +#' @param e A \code{try-error} object. +#' @return Character(1), whitespace-trimmed and collapsed to one line. +#' @keywords internal +#' @noRd +.try_error_message <- function(e) { + cond <- attr(e, "condition") + txt <- if (is.null(cond)) paste(as.character(e), collapse = " ") + else conditionMessage(cond) + txt <- gsub("[\r\n]+", " ", paste(txt, collapse = " ")) + trimws(txt) +} + + +#' Render the first fold error as a sentence to append to a warning +#' +#' 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. +#' +#' @param res The list returned by \code{.cv_run_folds()}. +#' @return Character(1); empty when there is nothing to add. +#' @keywords internal +#' @noRd +.cv_first_error_suffix <- function(res) { + msgs <- res$fit_errors + if (is.null(msgs) || length(msgs) == 0L) return("") + msg <- msgs[[1L]] + if (!is.character(msg) || is.na(msg) || !nzchar(msg)) return("") + if (nchar(msg) > 300L) msg <- paste0(substr(msg, 1L, 300L), "...") + paste0(" First error: ", msg) +} + + +#' A small, projection-invariant fingerprint of the rows a fold set describes +#' +#' Fold splits are lists of \code{..row_id} values, and row IDs are just +#' \code{seq_len(nrow())} unless the caller supplied them. Handing +#' \code{cv_gwr()} a \code{folds} object built from a \emph{different} dataset +#' of the same size therefore "worked": every ID matched, every fold was +#' populated, and the model was scored on splits that describe other +#' observations entirely. Nothing in the result said so. +#' +#' The probe stores the location of up to \code{max_probe} rows, spread evenly +#' over the row IDs, so the check can ask whether row 37 is still the same +#' point. Two properties matter: +#' \itemize{ +#' \item \strong{Projection-invariant.} The probe rows are transformed to +#' EPSG:4326 before being recorded, because \code{make_folds()} and +#' \code{prep_model_data()} both run \code{\link{ensure_projected}()} and +#' may land in different CRSs. Comparing raw coordinates would fire on +#' ordinary use. Data with no CRS is probed as-is. +#' \item \strong{Tolerant of dropped rows.} Per-row keys, not one digest +#' over all of them, so the comparison can be made over whichever probe +#' rows survived \code{prep_model_data()}'s complete-case filter. +#' } +#' +#' @param x An sf object carrying a \code{..row_id} column. +#' @param max_probe Maximum number of rows to record. 64 keeps the folds +#' object small while making a same-size different-dataset collision +#' effectively impossible. +#' @return A list with integer \code{row_id} and character \code{key}, or +#' \code{NULL} when no probe can be taken. +#' @keywords internal +#' @noRd +.fold_row_probe <- function(x, max_probe = 64L) { + tryCatch({ + if (!inherits(x, "sf") || !("..row_id" %in% names(x)) || nrow(x) == 0L) + return(NULL) + ids <- as.integer(x[["..row_id"]]) + take <- unique(round(seq(1, nrow(x), length.out = min(nrow(x), max_probe)))) + g <- sf::st_geometry(x)[take] + cr <- suppressWarnings(sf::st_crs(x)) + if (!is.na(cr)) + g <- suppressWarnings(sf::st_transform(g, 4326)) + xy <- suppressWarnings(sf::st_coordinates(g)) + if (is.null(xy) || nrow(xy) != length(take)) return(NULL) + list(row_id = ids[take], + key = sprintf("%.7g|%.7g", xy[, 1L], xy[, 2L])) + }, error = function(e) NULL) +} + + +#' Refuse fold splits that describe a different dataset +#' +#' Compares \code{folds$params$row_probe} against the data being +#' cross-validated, over whichever probe rows are still present. A fold set +#' built by an older version of this package carries no probe and is passed +#' through unchecked. +#' +#' @param folds A \code{make_folds()} return value, or \code{NULL}. +#' @param dat_sf The (prepped) sf being cross-validated. +#' @param caller Name used in the error message. +#' @return \code{invisible(NULL)}; called for the error. +#' @keywords internal +#' @noRd +.check_fold_probe <- function(folds, dat_sf, caller) { + probe <- tryCatch(folds$params$row_probe, error = function(e) NULL) + if (is.null(probe) || is.null(probe$row_id) || length(probe$row_id) == 0L) + return(invisible(NULL)) + now <- .fold_row_probe(dat_sf, max_probe = nrow(dat_sf)) + if (is.null(now)) return(invisible(NULL)) + + m <- match(probe$row_id, now$row_id) + ok <- !is.na(m) + if (!any(ok)) { + stop(sprintf(paste0("%s(): none of the row IDs in `folds` are present in ", + "the data. The folds were built from a different ", + "dataset; rebuild them with make_folds() on this one."), + caller), call. = FALSE) + } + bad <- sum(probe$key[ok] != now$key[m[ok]]) + if (bad > 0L) + stop(sprintf(paste0("%s(): the supplied `folds` were built from different ", + "data -- %d of %d checked row IDs sit at a different ", + "location here. Fold splits are lists of row IDs, so ", + "folds from another dataset of the same size apply ", + "silently and score the model on splits that describe ", + "other observations. Rebuild them with make_folds() on ", + "this data."), + caller, bad, sum(ok)), call. = FALSE) + invisible(NULL) +} + + #' Fit-predict a single CV fold #' #' Encapsulates the per-fold work so it can be called sequentially or in -#' parallel. Returns \code{NULL} on failure so the caller can filter. +#' parallel. Returns \code{NULL} when the fold is unusable before any work +#' starts, or \code{list(error = )} when the fit or the prediction +#' threw, so the caller can report the cause rather than only the count. #' #' @keywords internal #' @noRd @@ -158,15 +293,24 @@ train_df <- sf::st_drop_geometry(train_sf) test_df <- sf::st_drop_geometry(test_sf) - # Fit model on training fold + # 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" + # 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) if (inherits(fit_obj, "try-error")) { - .log_warn(".cv_run_folds(): fold %d fit failed; skipping.", fold_lab) - return(NULL) + msg <- .try_error_message(fit_obj) + .log_warn(".cv_run_folds(): fold %d fit failed; skipping. Cause: %s", + fold_lab, msg) + return(list(error = msg)) } if (!inherits(fit_obj, "spatial_fit")) { + msg <- sprintf("fit_fn() returned a %s, not a spatial_fit", + paste(class(fit_obj), collapse = "/")) .log_warn(".cv_run_folds(): fold %d did not return a spatial_fit; skipping.", fold_lab) - return(NULL) + return(list(error = msg)) } # Predict on test fold via the S3 generic @@ -176,8 +320,12 @@ silent = TRUE ) if (inherits(y_hat, "try-error") || !is.numeric(y_hat)) { - .log_warn(".cv_run_folds(): fold %d predict failed; skipping.", fold_lab) - return(NULL) + msg <- if (inherits(y_hat, "try-error")) .try_error_message(y_hat) else + sprintf("predict() returned a %s, not a numeric vector", + paste(class(y_hat), collapse = "/")) + .log_warn(".cv_run_folds(): fold %d predict failed; skipping. Cause: %s", + fold_lab, msg) + return(list(error = msg)) } # cv_spatial() is documented as the extensibility point for arbitrary # learners, so a fit_fn whose predict() returns the wrong length is @@ -386,26 +534,30 @@ # is killed, and Negate(is.null) keeps it -- the subsequent [[ "pred_row" ]] # then fails with "subscript out of bounds", destroying the real diagnosis. failed <- vapply(results, function(z) inherits(z, "try-error"), logical(1)) + worker_msgs <- character(0) if (any(failed)) { - # conditionMessage() has no method for a "try-error" object -- calling it - # on one throws, which would destroy the diagnosis in precisely the branch - # that only runs when a worker has already failed. The condition object - # hangs off the try-error as an attribute; the deparsed string is the - # fallback for the rare try-error carrying none. - msgs <- vapply(results[failed], function(z) { - cond <- attr(z, "condition") - if (is.null(cond)) trimws(paste(as.character(z), collapse = " ")) - else conditionMessage(cond) - }, character(1)) + worker_msgs <- vapply(results[failed], .try_error_message, character(1)) .log_warn("cv: %d fold(s) failed in a parallel worker: %s", - sum(failed), paste(unique(msgs), collapse = "; ")) + sum(failed), paste(unique(worker_msgs), collapse = "; ")) } results <- results[!failed] results <- Filter(Negate(is.null), results) + + # Folds that threw come back as list(error = ) rather than NULL, so + # the caller's "all N folds failed" warning can name the cause. `$` (not + # `[[`) because a successful fold's list has no "error" element and `[[` + # would abort with "subscript out of bounds". + is_err <- vapply(results, function(z) !is.null(z$error), logical(1)) + fit_errors <- c(worker_msgs, + unlist(lapply(results[is_err], `[[`, "error"), + use.names = FALSE)) + results <- results[!is_err] + pred_rows <- lapply(results, `[[`, "pred_row") fold_stats <- lapply(results, `[[`, "fold_stat") - list(pred_rows = pred_rows, fold_stats = fold_stats) + list(pred_rows = pred_rows, fold_stats = fold_stats, + fit_errors = as.character(fit_errors)) } @@ -438,19 +590,29 @@ #' ~95 \% of the sill. #' #' To guard against anisotropy, the function first estimates directional -#' variograms at 0° (N–S) and 90° (E–W) azimuths (tolerance 22.5°, -#' which avoids double-counting point pairs near the 45° diagonal but -#' requires denser point clouds for stable estimates). -#' When both fits succeed the \strong{maximum} of the two directional ranges -#' is returned, which is the conservative choice for spatial block CV — -#' blocks must be at least as large as the longest autocorrelation range to -#' avoid information leakage. +#' variograms at 0° (N–S), 45°, 90° (E–W) and 135° azimuths, each with a +#' ±22.5° tolerance. Those four windows tile all 180 distinct azimuths +#' exactly once, with no gap and no double-counted pair. When all four fits +#' succeed the \strong{maximum} of the four directional ranges is returned, +#' which is the conservative choice for spatial block CV — blocks must be at +#' least as large as the longest autocorrelation range to avoid information +#' leakage. #' -#' If either directional fit fails (e.g., too few point pairs in a direction), -#' the function falls back to an omnidirectional (isotropic) variogram. +#' Sweeping only 0° and 90° would leave the azimuths between 23° and 67°, and +#' between 113° and 157°, covered by neither window: on simulated fields with a +#' 3:1 anisotropy and a true major-axis range of 300, a two-direction sweep +#' recovered 255 and 249 for major axes at 0° and 90° but only 151 and 147 at +#' 45° and 135°. Since \code{make_folds(auto_range = TRUE)} sizes its blocks +#' from this number, that halved the blocks for a diagonally oriented field. #' -#' A log warning is emitted when notable anisotropy is detected (ratio of -#' directional ranges > 1.5). +#' If any directional fit fails (e.g., too few point pairs in a direction), +#' the function falls back to an omnidirectional (isotropic) variogram rather +#' than taking the maximum over the directions that did fit — which would bias +#' the answer downward precisely when the widest direction is the one that +#' failed. +#' +#' A log warning is emitted when notable anisotropy is detected (ratio of the +#' largest to the smallest directional range > 1.5). #' #' The returned range is in the coordinate units of the (projected) data and #' can be passed directly to \code{make_folds(block_size = ...)} to ensure @@ -476,14 +638,22 @@ #' \code{make_folds(auto_range = TRUE)} would collapse the block grid to a #' single block. Default 1.0; raise it to accept ranges extrapolated beyond #' the fitted lags. -#' @param seed Optional RNG seed for subsampling reproducibility. +#' @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 rather than 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 +#' different number to check how sensitive the estimate is to the subsample. +#' Ignored when \code{nrow(points_sf) <= n_max}, where nothing is sampled. #' @return A single value of class \code{sac_range}, which behaves as an #' ordinary number. There are three shapes, and they carry different #' attributes: #' \describe{ #' \item{Success}{A positive effective range in projected coordinate units, -#' with the fit attached as attributes \code{directional} (the 0° and 90° -#' ranges), \code{anisotropy} (their ratio), \code{max_dist}, +#' with the fit attached as attributes \code{directional} (the 0°, 45°, +#' 90° and 135° ranges, named by azimuth), \code{anisotropy} (largest +#' over smallest), \code{max_dist}, #' \code{cutoff_dist}, \code{variogram} (the empirical variogram) and #' \code{variogram_model} (the fitted \code{gstat} model), so the fit can #' be inspected rather than trusted.} @@ -519,7 +689,7 @@ estimate_sac_range <- function(points_sf, response_var, predictor_vars = NULL, n_max = 5000L, cutoff = 0.5, - range_frac = 1.0, seed = NULL) { + range_frac = 1.0, seed = 123L) { if (!requireNamespace("gstat", quietly = TRUE)) { .log_warn("estimate_sac_range(): package 'gstat' is required for variogram estimation; returning NA.") return(NA_real_) @@ -535,7 +705,17 @@ estimate_sac_range <- function(points_sf, response_var, pts <- ensure_projected(points_sf) - # Subsample if large + # 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) @@ -550,10 +730,41 @@ estimate_sac_range <- function(points_sf, response_var, return(NA_real_) } - # Build the variable to model: raw response or OLS residuals - y <- sf::st_drop_geometry(pts)[[response_var]] + # 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. + 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))) + 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 + } else { + stop(sprintf(paste0("estimate_sac_range(): response '%s' is %s, and a ", + "variogram needs a numeric variable. A factor's ", + "codes are an arbitrary relabelling of its levels ", + "-- fitting a variogram to them yields a range that ", + "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 = "/"))), + call. = FALSE) + } + } if (!is.null(predictor_vars) && length(predictor_vars) > 0L) { - df <- sf::st_drop_geometry(pts) + df <- pts_df ok_preds <- intersect(predictor_vars, names(df)) if (length(ok_preds) > 0L) { fml <- stats::reformulate(ok_preds, response_var) @@ -597,11 +808,51 @@ estimate_sac_range <- function(points_sf, response_var, # 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) { - m <- try(gstat::fit.variogram(vg, gstat::vgm(model = model_type)), - silent = TRUE) + converged <- TRUE + m <- withCallingHandlers( + try(gstat::fit.variogram(vg, gstat::vgm(model = model_type)), + 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) + # NOT `return(NULL)` on non-convergence. The range it carries must never + # size a block -- that is what the `converged` flag below 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. Discarding it here made plot(fit, type = "variogram") + # error out with "the residual variogram could not be fitted" on exactly + # that input. Mark it and let the caller decide. + attr(m, "converged") <- converged m } @@ -623,13 +874,42 @@ estimate_sac_range <- function(points_sf, response_var, eff <- if (identical(as.character(model_type), "Exp")) 3 * raw_range else raw_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. - structure(eff, vgm_model = vgm_model) + # 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)) } - # --- Directional variograms (0° and 90°, tolerance 22.5°) ---------------- - # gstat uses azimuth in degrees clockwise from north. 0° = N-S, 90° = E-W. - dir_fits <- lapply(c(0, 90), function(az) { + # 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 + + # --- 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. + # + # 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. + # + # 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, @@ -640,22 +920,55 @@ estimate_sac_range <- function(points_sf, response_var, }) dir_ranges <- vapply(dir_fits, function(f) as.numeric(f$fit), numeric(1)) - dir_success <- sum(is.finite(dir_ranges)) == 2L - anisotropy <- NA_real_ - vg_used <- NULL + # 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 + + # 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_ + fit_converged <- TRUE + vg_used <- NULL vgm_used <- NULL # --- Select the effective range ------------------------------------------ if (dir_success) { - effective_range <- max(dir_ranges) - anisotropy <- max(dir_ranges) / min(dir_ranges) - winner <- which.max(dir_ranges) + effective_range <- max(usable, na.rm = TRUE) + anisotropy <- max(usable, na.rm = TRUE) / 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; the estimate is the maximum over the rest."), + sum(!dir_ok), length(dir_az), + paste(sprintf("%d\u00b0", dir_az[!dir_ok]), collapse = ", ")) vg_used <- dir_fits[[winner]]$vg vgm_used <- attr(dir_fits[[winner]]$fit, "vgm_model") if (anisotropy > 1.5) { .log_warn( - "estimate_sac_range(): notable anisotropy detected (range ratio %.1f). Directional ranges: 0\u00b0 = %.1f, 90\u00b0 = %.1f. Using the maximum.", - anisotropy, dir_ranges[1], dir_ranges[2] + "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 { @@ -666,6 +979,11 @@ estimate_sac_range <- function(points_sf, response_var, ) iso_range <- .fit_vgm_range(vg_iso) 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. @@ -700,17 +1018,35 @@ estimate_sac_range <- function(points_sf, response_var, # 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. - max_supported <- range_frac * cutoff_dist - if (is.finite(max_supported) && effective_range > max_supported) { - .log_warn( - paste0("estimate_sac_range(): fitted range (%.0f) exceeds the largest ", - "lag the variogram was fitted over (%.4g = %s x cutoff %.0f); the ", - "empirical variogram never reached a sill, so the range is ", - "unidentified rather than long. Returning NA. Raise `cutoff` to ", - "fit longer lags, supply `predictor_vars` to detrend, or set a ", - "block size explicitly."), - effective_range, max_supported, format(range_frac), cutoff_dist - ) + over_cutoff <- is.finite(max_supported) && effective_range > max_supported + # 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) { + if (over_cutoff) { + .log_warn( + paste0("estimate_sac_range(): fitted range (%.0f) exceeds the largest ", + "lag the variogram was fitted over (%.4g = %s x cutoff %.0f); the ", + "empirical variogram never reached a sill, so the range is ", + "unidentified rather than long. Returning NA. Raise `cutoff` to ", + "fit longer lags, supply `predictor_vars` to detrend, or set a ", + "block size explicitly."), + effective_range, max_supported, format(range_frac), cutoff_dist + ) + } 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, supply `predictor_vars` to detrend, or set a block size ", + "explicitly. The empirical variogram is attached for ", + "inspection: plot(type = \"variogram\")."), + effective_range + ) + } # 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 @@ -730,14 +1066,16 @@ estimate_sac_range <- function(points_sf, response_var, variogram = vg_used, variogram_model = vgm_used, rejected_range = as.numeric(effective_range), - rejected_reason = "fitted range exceeds the largest lag fitted" + rejected_reason = if (over_cutoff) + "fitted range exceeds the largest lag fitted" + else "variogram model did not converge" )) } structure( effective_range, class = c("sac_range", "numeric"), - directional = stats::setNames(dir_ranges, c("0", "90")), + directional = stats::setNames(usable, as.character(dir_az)), anisotropy = anisotropy, max_dist = as.numeric(max_dist), cutoff_dist = as.numeric(cutoff_dist), @@ -760,9 +1098,19 @@ print.sac_range <- function(x, ...) { cat(format(as.numeric(x)), "\n") d <- attr(x, "directional") a <- attr(x, "anisotropy") - if (!is.null(d) && all(is.finite(d))) { - cat(sprintf(" directional: 0 deg = %s, 90 deg = %s", - format(d[[1]]), format(d[[2]]))) + # any(), not all(): a direction whose variogram never reached a sill is + # recorded as NA and excluded from the maximum, and suppressing the whole + # line in that case hides exactly the diagnostic worth seeing. + if (!is.null(d) && length(d) > 0L && any(is.finite(d))) { + # Names, not fixed positions: the azimuth sweep is c(0, 45, 90, 135) and + # an older stored object may carry only c(0, 90). + labs <- names(d) + if (is.null(labs)) labs <- as.character(seq_along(d) - 1L) + cat(" directional: ", + paste(sprintf("%s deg = %s", labs, + ifelse(is.finite(d), format(unname(d)), "unidentified")), + collapse = ", "), + sep = "") if (is.finite(a)) cat(sprintf(" (ratio %.2f)", a)) cat("\n") } @@ -789,6 +1137,35 @@ print.sac_range <- function(x, ...) { } +#' Label the CRS the folds were actually built in +#' +#' \code{make_folds()} projects geographic input with \code{ensure_projected()}, +#' so \code{block_size}, \code{sac_range} and \code{buffer} are lengths in a CRS +#' the caller may never have chosen. Recording a short label in +#' \code{folds$params$crs} makes those units recoverable. Prefers the +#' \code{AUTHORITY:CODE} form when there is one, falls back to the CRS's own +#' input string, and returns \code{NA_character_} for a missing CRS. +#' +#' @param x An sf/sfc object. +#' @return Character(1). +#' @keywords internal +#' @noRd +.fold_crs_label <- function(x) { + cr <- tryCatch(sf::st_crs(x), error = function(e) NULL) + if (is.null(cr) || is.na(cr)) return(NA_character_) + epsg <- tryCatch(cr$epsg, error = function(e) NULL) + if (!is.null(epsg) && length(epsg) == 1L && !is.na(epsg)) + return(paste0("EPSG:", epsg)) + inp <- tryCatch(cr$input, error = function(e) NULL) + if (!is.null(inp) && length(inp) == 1L && !is.na(inp) && nzchar(inp)) + return(as.character(inp)) + wkt <- tryCatch(cr$wkt, error = function(e) NULL) + if (!is.null(wkt) && length(wkt) == 1L && !is.na(wkt) && nzchar(wkt)) + return(as.character(wkt)) + NA_character_ +} + + # ----------------------------------------------------------------------------- # Fold Construction # ----------------------------------------------------------------------------- @@ -822,10 +1199,21 @@ print.sac_range <- function(x, ...) { #' @param block_nx,block_ny Optional grid dimensions for block_kfold. #' Ignored when \code{block_size} or \code{auto_range} override them. #' @param block_multiplier Numeric; target blocks multiplier. Default 3. -#' @param block_size Optional positive numeric minimum block edge length -#' (in projected CRS units). 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}. +#' @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}. +#' +#' 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 +#' (lon/lat) input is projected first by \code{\link{ensure_projected}()}, +#' which picks a local UTM zone or, at wide extents, an equal-area +#' projection — a CRS you did not choose, whose units are metres but whose +#' identity varies with the data. \code{block_size} is then interpreted in +#' \emph{that} CRS. The CRS actually used is recorded in +#' \code{params$crs} of the returned list; project the data yourself before +#' calling if you want to fix the units in advance. #' @param auto_range Logical. If \code{TRUE}, the spatial autocorrelation #' range is estimated via \code{estimate_sac_range()} — which fits #' directional variograms to account for anisotropy — and used as the @@ -894,6 +1282,19 @@ print.sac_range <- function(x, ...) { #' The returned \code{k} is the number of folds actually built, which is not #' always the \code{k} that was requested (see the \code{k} argument above), #' and \code{length(folds)} always matches it. +#' +#' For the methods that work in projected space — \code{"block_kfold"}, +#' \code{"buffered_loo"} and \code{"nndm"} — \code{params} 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 +#' definition). Every length in \code{params} — \code{block_size}, +#' \code{sac_range}, \code{buffer}, \code{median_buffer} — is in that CRS's +#' units, which for geographic input is a CRS +#' \code{\link{ensure_projected}()} chose rather than one you passed. +#' +#' Rows whose geometry is empty or has non-finite coordinates are dropped +#' before folding, with a logged warning naming the count; they appear in no +#' fold and in no \code{assignment} row. #' @family cross-validation #' @examples #' library(sf) @@ -940,8 +1341,39 @@ make_folds <- function(points_sf, k, if (!("..row_id" %in% names(points_sf))) points_sf$..row_id <- seq_len(nrow(points_sf)) + # Drop rows with no usable coordinates, AFTER ..row_id is stamped so the + # survivors keep their original row identities and the dropped rows simply + # never appear in a fold. st_coordinates() yields one all-NA row per EMPTY + # POINT rather than zero rows, so a row-count check alone lets them through: + # block_kfold's st_intersects() then returns integer(0) for them, ..block_id + # goes NA, st_distance() is all-NA and the nearest-block rescue used to die + # with "replacement has length zero". Matches voronoi_seeds_kmeans(), which + # drops the same rows with the same warning. Applied for every method -- + # random_kfold would happily put an unplottable point in a fold, and nndm + # and buffered_loo both feed the coordinates to distance code. + bad_geom <- sf::st_is_empty(points_sf) + if (!all(bad_geom)) { + xy_chk <- suppressWarnings(sf::st_coordinates(points_sf[!bad_geom, ])) + if (nrow(xy_chk) == sum(!bad_geom) && ncol(xy_chk) >= 2L) + bad_geom[!bad_geom] <- !stats::complete.cases(xy_chk[, 1:2, drop = FALSE]) + } + if (any(bad_geom)) { + .log_warn("make_folds(): dropping %d point(s) with empty or non-finite coordinates.", + sum(bad_geom)) + points_sf <- points_sf[!bad_geom, , drop = FALSE] + if (nrow(points_sf) == 0L) + stop("make_folds(): `points_sf` has no usable coordinates; there is nothing to split into folds.", + call. = FALSE) + } + + # One probe for every return path: .ret() is the single exit, so the folds + # object cannot ship without the fingerprint that lets a later cv_*() refuse + # it if it is handed the wrong data. Taken on `points_sf` AFTER the + # bad-geometry drop, so the recorded rows are ones that really are in a fold. + row_probe <- .fold_row_probe(points_sf) .ret <- function(method, k, folds, assignment, params) - list(method = method, k = k, folds = folds, assignment = assignment, params = params) + list(method = method, k = k, folds = folds, assignment = assignment, + params = c(params, list(row_probe = row_probe))) # ---- RANDOM K-FOLD ---- if (method == "random_kfold") { @@ -1111,8 +1543,20 @@ make_folds <- function(points_sf, k, if (anyNA(pts$..block_id)) { cent <- suppressWarnings(sf::st_centroid(sf::st_geometry(grid_sf))) na_idx <- which(is.na(pts$..block_id)) - dmat <- sf::st_distance(sf::st_geometry(pts[na_idx, ]), cent) - pts$..block_id[na_idx] <- apply(as.matrix(dmat), 1, which.min) + dmat <- as.matrix(sf::st_distance(sf::st_geometry(pts[na_idx, ]), cent)) + # vapply(), not apply(): a point whose distances are all NA (an empty + # geometry that survived upstream, or a grid with no finite centroid) + # makes which.min() return integer(0), and apply() then simplifies the + # whole result to a list() -- which assigns back as "replacement has + # length zero". Keep the NA instead and let the B/k guards below react. + pts$..block_id[na_idx] <- vapply( + seq_len(nrow(dmat)), + function(i) { + w <- which.min(dmat[i, ]) + if (length(w)) as.integer(w) else NA_integer_ + }, + integer(1) + ) } B <- max(pts$..block_id, na.rm = TRUE) # One block means one fold whose training set is empty -- blocked CV @@ -1168,6 +1612,12 @@ make_folds <- function(points_sf, k, block_size = block_size, sac_range = sac_range, auto_range = auto_range, + # `block_size` and `sac_range` are lengths in the CRS the + # folds were actually built in, which is NOT necessarily + # the CRS the caller passed: geographic input is projected + # by ensure_projected() to a CRS chosen here. Record it + # so the units are recoverable. + crs = .fold_crs_label(pts), boundary_supplied = !is.null(boundary)))) } @@ -1214,7 +1664,7 @@ make_folds <- function(points_sf, k, return(.ret(method, n, splits, .safe_tibble(row_id = pts$..row_id, fold = seq_len(n)), - list(buffer = buffer))) + list(buffer = buffer, crs = .fold_crs_label(pts)))) } # ---- LEAVE-LOCATION-OUT (grouped) ---- @@ -1363,6 +1813,7 @@ make_folds <- function(points_sf, k, return(.ret(method, n, splits, .safe_tibble(row_id = row_ids, fold = seq_len(n)), list(seed = seed, n_prediction_points = nrow(pred), + crs = .fold_crs_label(pts), median_buffer = stats::median(radii), median_excluded = stats::median(n_excluded), target_median = stats::median(g_target), @@ -1381,6 +1832,24 @@ make_folds <- function(points_sf, k, #' K-fold cross-validation for GWR #' +#' Refits a geographically weighted regression from scratch on each training +#' fold and scores it on the held-out fold, so the reported error is what the +#' model achieves at locations it did not see. Reach for it whenever you need +#' a defensible accuracy figure for a GWR: the in-sample \eqn{R^2} that +#' \code{\link{model_metrics}()} reports on a \code{gwr_fit} is close to +#' meaningless, because a local regression with a small bandwidth can track the +#' training points almost exactly. Bandwidth is re-selected per fold unless you +#' fix it with \code{bandwidth}, which keeps the selection itself inside the +#' cross-validation rather than tuning on the full data first. +#' +#' Folds default to spatial blocks (\code{\link{make_folds}(method = +#' "block_kfold")}), not random ones -- with autocorrelated data a random +#' split leaves a held-out point's neighbours in the training set and the score +#' comes back flattering. Use \code{\link{cv_bayes}()} for the same treatment +#' of a Bayesian GP model, \code{\link{cv_rf}()} for a forest, and +#' \code{\link{compare_models_cv}()} to score several backends on one set of +#' folds. +#' #' @param data_sf An sf object. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. @@ -1452,6 +1921,10 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, keep_idx <- dat_sf$`..row_id` + # 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, dat_sf, "cv_gwr") + if (is.null(folds)) { message("cv_gwr(): no folds supplied \u2014 using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", @@ -1511,8 +1984,11 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, n_attempted <- length(remapped_folds) n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { - .log_warn("cv_gwr(): all %d folds failed to produce predictions; results are empty.", n_attempted) - warning("cv_gwr(): all folds failed; cross-validation results contain no predictions.", call. = FALSE) + why <- .cv_first_error_suffix(res) + .log_warn("cv_gwr(): all %d folds failed to produce predictions; results are empty.%s", + n_attempted, why) + warning("cv_gwr(): all folds failed; cross-validation results contain no predictions.", + why, call. = FALSE) } else if (n_succeeded < n_attempted) { .log_warn("cv_gwr(): %d of %d folds produced predictions.", n_succeeded, n_attempted) } @@ -1535,6 +2011,22 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' K-fold cross-validation for the Bayesian spatial model #' +#' Refits the Gaussian-process model of +#' \code{\link{fit_bayesian_spatial_model}()} on each training fold and scores +#' it on the held-out fold. Beyond the point-prediction metrics the other CV +#' wrappers report, this one scores the whole predictive \emph{distribution}: +#' \code{predictive_coverage} says what fraction of held-out observations fell +#' inside the 50/80/95\% intervals, and \code{mean_CRPS} rates sharpness and +#' calibration together. That is the reason to reach for it -- a Bayesian model +#' is usually chosen for its uncertainty, and only held-out coverage shows +#' whether those intervals are honest at locations the model has not seen. +#' +#' It is the most expensive wrapper in the package by a wide margin: every fold +#' is a full MCMC run. Use few folds, and \code{parallel = TRUE} if you have +#' 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. +#' #' @param data_sf An sf object. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. @@ -1611,6 +2103,10 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, keep_idx <- dat_sf$`..row_id` n_pred <- length(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, dat_sf, "cv_bayes") + if (is.null(folds)) { message("cv_bayes(): no folds supplied \u2014 using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", @@ -1719,8 +2215,11 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, n_attempted <- length(remapped_folds) n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { - .log_warn("cv_bayes(): all %d folds failed to produce predictions; results are empty.", n_attempted) - warning("cv_bayes(): all folds failed; cross-validation results contain no predictions.", call. = FALSE) + why <- .cv_first_error_suffix(res) + .log_warn("cv_bayes(): all %d folds failed to produce predictions; results are empty.%s", + n_attempted, why) + warning("cv_bayes(): all folds failed; cross-validation results contain no predictions.", + why, call. = FALSE) } else if (n_succeeded < n_attempted) { .log_warn("cv_bayes(): %d of %d folds produced predictions.", n_succeeded, n_attempted) } @@ -1767,7 +2266,13 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' @param data_sf An sf object. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. -#' @param fit_fn A function(train_sf) that returns a \code{spatial_fit}. +#' @param fit_fn A function of one argument, the training slice of +#' \code{data_sf}, returning a \code{spatial_fit} built with +#' \code{\link{new_spatial_fit}()}. It is called once per fold on the +#' training rows only, so anything done inside it -- scaling, tuning, an inner +#' variable sweep -- is already nested and leak-free. The \code{subclass} it +#' stamps must have a \code{predict.()} method registered, because +#' that is how each fold is scored. #' @param folds Optional fold definitions. Built via block_kfold if NULL. #' @param k Number of folds. #' @param seed RNG seed. @@ -1799,6 +2304,44 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' \code{make_folds()$assignment$fold} even when some folds were unusable #' and dropped. #' @family cross-validation +#' @seealso \code{\link{new_spatial_fit}()} for the constructor a \code{fit_fn} +#' 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. +#' @examples +#' library(sf) +#' set.seed(1) +#' n <- 80 +#' site <- st_as_sf( +#' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), +#' coords = c("x", "y"), crs = 32632 +#' ) +#' site$price <- 10 + 0.01 * st_coordinates(site)[, 1] + 2 * site$elev + rnorm(n) +#' +#' # 1. A fit_fn returning a spatial_fit of your own subclass. +#' lm_fit <- function(train_sf) { +#' new_spatial_fit( +#' subclass = "lm_fit", +#' engine = lm(price ~ elev, st_drop_geometry(train_sf)), +#' formula = price ~ elev, +#' response_var = "price", +#' predictor_vars = "elev", +#' data_sf = train_sf +#' ) +#' } +#' +#' # 2. The predict() method cv_spatial() scores each fold with. Without it +#' # every fold fails and `overall` comes back all-NA. +#' predict.lm_fit <- function(object, newdata = NULL, ...) { +#' if (is.null(newdata)) newdata <- object$data_sf +#' as.numeric(stats::predict(object$engine, st_drop_geometry(newdata))) +#' } +#' registerS3method("predict", "lm_fit", predict.lm_fit) +#' +#' cv <- cv_spatial(site, "price", "elev", fit_fn = lm_fit, k = 3, seed = 1) +#' cv$overall +#' # Compare these before trusting the metrics above. +#' c(attempted = cv$n_folds_attempted, succeeded = cv$n_folds_succeeded) #' @export cv_spatial <- function(data_sf, response_var, predictor_vars, fit_fn, folds = NULL, k = 5, seed = 123, @@ -1813,6 +2356,10 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, dat_sf <- prep_model_data(data_sf, response_var, predictor_vars, boundary, pointize) keep_idx <- dat_sf$`..row_id` + # 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, dat_sf, "cv_spatial") + if (is.null(folds)) { message("cv_spatial(): no folds supplied \u2014 using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", @@ -1849,10 +2396,11 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, n_attempted <- length(remapped_folds) n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { - .log_warn("cv_spatial(): all %d folds failed to produce predictions; results are empty.", - n_attempted) + why <- .cv_first_error_suffix(res) + .log_warn("cv_spatial(): all %d folds failed to produce predictions; results are empty.%s", + n_attempted, why) warning("cv_spatial(): all folds failed; cross-validation results contain ", - "no predictions.", call. = FALSE) + "no predictions.", why, call. = FALSE) } else if (n_succeeded < n_attempted) { .log_warn("cv_spatial(): %d of %d folds produced predictions.", n_succeeded, n_attempted) diff --git a/R/crs-geometry.R b/R/crs-geometry.R index 15a9ca0..9669614 100644 --- a/R/crs-geometry.R +++ b/R/crs-geometry.R @@ -159,6 +159,33 @@ #' Coerces spatial objects to a projected coordinate reference system suitable #' for distance/area calculations. #' +#' @details +#' An object that already has a projected CRS is returned untouched. Only +#' geographic (lon/lat) input is transformed, and the CRS chosen depends on the +#' extent of the data — it is **not** always UTM: +#' +#' \describe{ +#' \item{Local extents}{The UTM zone containing the data's centre +#' (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.} +#' \item{Wide extents}{Once the data reach well beyond the roughly 3 degrees +#' a UTM zone is designed for, a single zone would distort distances by +#' several percent — and that error propagates straight into variogram +#' ranges, block sizes, GWR bandwidths and GP length-scales. An equal-area +#' projection centred on the data is used instead: Albers conic +#' (`+proj=aea`) for extents wider than tall, Lambert azimuthal +#' (`+proj=laea`) otherwise. A warning names the projection, the span that +#' triggered it, and this argument.} +#' \item{Missing CRS}{If `x` has no CRS at all but its bounding box looks +#' like lon/lat, EPSG:4326 is assumed with a warning, then the rules above +#' apply. Set the CRS explicitly to suppress it.} +#' } +#' +#' `target_crs` overrides all of this: pass it whenever you need a specific, +#' reproducible projection — comparing runs, matching an existing layer, or +#' fixing the units that [make_folds()]'s `block_size` will be interpreted in. +#' #' @param x An sf or sfc object (other objects returned unchanged). #' @param target_crs Optional target CRS (sf object, integer EPSG, or crs). #' Must resolve to a usable CRS via [sf::st_crs()]; an unusable value (one @@ -171,7 +198,19 @@ #' data.frame(lon = c(9.1, 9.2), lat = c(48.7, 48.8)), #' coords = c("lon", "lat"), crs = 4326 #' ) -#' st_crs(ensure_projected(pts_ll))$epsg # auto-selected UTM zone (32632) +#' # A local extent gets the containing UTM zone. +#' st_crs(ensure_projected(pts_ll))$epsg # 32632 +#' +#' # A continental extent gets an equal-area projection instead, with a +#' # warning naming it -- see Details. +#' wide <- st_as_sf( +#' data.frame(lon = c(-120, -70), lat = c(30, 48)), +#' coords = c("lon", "lat"), crs = 4326 +#' ) +#' st_crs(ensure_projected(wide))$proj4string +#' +#' # target_crs overrides the choice entirely. +#' st_crs(ensure_projected(pts_ll, target_crs = 3035))$epsg # 3035 #' @export ensure_projected <- function(x, target_crs = NULL) { if (!(inherits(x, "sf") || inherits(x, "sfc"))) return(x) diff --git a/R/evaluation.R b/R/evaluation.R index f4f413b..2659f1b 100644 --- a/R/evaluation.R +++ b/R/evaluation.R @@ -101,16 +101,190 @@ # Post-fit residual spatial autocorrelation check (Moran's I) # --------------------------------------------------------------------------- +#' Index pairs of the k nearest *other* observations +#' +#' Returns the \code{(i, j)} pairs of a k-nearest-neighbour graph with every +#' self-match removed, so the weight matrix built from them has a zero +#' diagonal. That is not cosmetic: Moran's I is defined only for +#' \eqn{w_{ii} = 0}, and both \eqn{E[I] = -1/(n-1)} and the Cliff & Ord +#' variance assume it. +#' +#' \code{FNN::get.knn()} reports a point's OWN index among its neighbours +#' whenever exact duplicate coordinates are present, which put \eqn{1/k} on the +#' diagonal and added a strictly positive \eqn{w_{ii} e_i^2} term to the +#' numerator. Repeat observations at one site are exactly what +#' \code{make_folds(method = "leave_location_out")} is for, and +#' \code{residual_morans_i()} reads \code{fit$data_sf} without de-duplicating, +#' so this was a mainstream input rather than a corner case: with 40 sites x 4 +#' repeats and a response carrying no spatial structure at all, 120 of 160 rows +#' gained a self-weight, mean I came out at +0.086 against +#' \eqn{E[I] = -0.0063}, and 77\% of samples were "significant" at +#' \eqn{p < 0.05} (nominal 5\%). \code{spdep::knearneigh()} never returns a +#' self-match, and neither did the dense fallback, so the statistic also +#' depended silently on whether \pkg{FNN} happened to be installed. +#' +#' The kd-tree path therefore asks for \code{k + 1} neighbours, drops any +#' \code{j == i}, and keeps the \code{k} nearest of what remains. +#' +#' @param coords Numeric matrix (n x 2) of projected coordinates. +#' @param k Integer neighbour count, already clamped to \code{n - 1}. +#' @param use_fnn Logical; use \pkg{FNN}'s kd-tree rather than a dense +#' \code{dist()} scan. +#' @return A list with integer vectors \code{i} and \code{j} of equal length. +#' @keywords internal +#' @noRd +.knn_pairs <- function(coords, k, use_fnn) { + n <- nrow(coords) + + # At k >= n - 1 every point neighbours every other, so no lookup can add + # anything -- and asking FNN for n - 1 neighbours of duplicated points can + # spend one of them on a self-match, silently losing a genuine neighbour. + if (k >= n - 1L) { + return(list( + i = rep(seq_len(n), each = n - 1L), + j = as.integer(unlist(lapply(seq_len(n), function(i) seq_len(n)[-i]), + use.names = FALSE)) + )) + } + + if (isTRUE(use_fnn)) { + kq <- k + 1L # k + 1 <= n - 1 here + nn_idx <- FNN::get.knn(coords, k = kq)$nn.index # n x kq, nearest first + # Entries within a row are distinct point indices, so at most one of them + # can be i itself. + self <- nn_idx == seq_len(n) # recycles down columns: [i, j] against i + + if (!any(self)) { + # No slot was spent on a self-match, so all k + 1 returned neighbours are + # genuine and the k nearest of them are a correct k-NN set. + idx <- nn_idx[, seq_len(k), drop = FALSE] + return(list(i = rep(seq_len(n), each = k), j = as.integer(t(idx)))) + } + + # A self-match means exact duplicate coordinates, and dropping it is NOT + # enough: the slot it occupied displaced a genuine tied neighbour, so the + # k that remain are not the k nearest. Measured on 25 sites x 4 repeats, + # k = 3: 75 of 400 retained pairs were a point at distance 121 standing in + # for a co-located one at distance 0. Group the duplicates and answer + # exactly instead. + return(.knn_pairs_dup(coords, k)) + } + + dmat <- as.matrix(stats::dist(coords)) + diag(dmat) <- Inf # self is never a neighbour + # matrix(..., nrow = n, ncol = k) forces the shape apply() will not. + # At k = 1 the inner function returns a scalar, so apply() simplifies to a + # length-n VECTOR and t() turns it into a 1 x n matrix -- making nn_idx[i, ] + # fail with "subscript out of bounds" for every i > 1. + # residual_morans_i(fit, k = 1) reached this on any machine without FNN. + nn_idx <- matrix(t(apply(dmat, 1, function(row) order(row)[seq_len(k)])), + nrow = n, ncol = k) + list(i = rep(seq_len(n), each = k), j = as.integer(t(nn_idx))) +} + + +#' Exact k-nearest-neighbour pairs when the coordinates contain exact duplicates +#' +#' \code{FNN::get.knn()} answers a tied query by returning \emph{some} of the +#' tied points, and the point's own index is eligible to be one of them --- so +#' with duplicates a \code{k + 1} query can come back holding self \emph{and} +#' having dropped a genuine co-located neighbour, leaving a farther point in +#' its place. Requesting one extra neighbour therefore removes the self-weight +#' but does not restore the neighbour it displaced. +#' +#' Duplicates are not exotic here: repeat observations at one site are exactly +#' what \code{make_folds(method = "leave_location_out")} exists for, and +#' \code{residual_morans_i()} reads \code{fit$data_sf} without de-duplicating. +#' +#' The structure of the problem makes an exact answer cheap. Points sharing a +#' coordinate are at distance 0 from each other and at an identical distance +#' from everything else, so the neighbour set is determined group-wise: take +#' the other members of the point's own group first, then fill from the nearest +#' \emph{other} groups in order. The k-d tree runs on the group +#' representatives, which are distinct by construction and so cannot tie +#' against themselves. +#' +#' @param coords Numeric matrix (n x 2) of projected coordinates. +#' @param k Integer neighbour count, already known to be \code{< n - 1}. +#' @return A list with integer vectors \code{i} and \code{j}, \code{k} entries +#' per row of \code{coords}. +#' @keywords internal +#' @noRd +.knn_pairs_dup <- function(coords, k) { + n <- nrow(coords) + + # "%.17g" round-trips a double exactly, so two rows share a key iff they are + # bit-identical. (as.character() would stop at 15 significant digits and + # could merge two points a few ulps apart -- harmless, but only by accident.) + key <- paste(sprintf("%.17g", coords[, 1L]), + sprintf("%.17g", coords[, 2L]), sep = "\r") + gid <- match(key, key) # representative row index per point + reps <- which(!duplicated(gid)) # one row index per distinct location + gid <- match(gid, gid[reps]) # 1..G + members <- split(seq_len(n), gid) + G <- length(reps) + + # Every point at one location: k < n - 1 already, so the first k of the other + # members is a correct answer (they are all at distance 0). + if (G == 1L) { + j <- unlist(lapply(seq_len(n), function(i) seq_len(n)[-i][seq_len(k)]), + use.names = FALSE) + return(list(i = rep(seq_len(n), each = k), j = as.integer(j))) + } + + # Nearest other GROUPS, in distance order. k groups always suffice: each + # supplies at least one member and at most k are ever needed. Ask for one + # extra and filter, so a self-match here could only cost an unused slot. + kg <- min(k + 1L, G - 1L) + nn <- FNN::get.knn(coords[reps, , drop = FALSE], k = kg)$nn.index + nn <- matrix(nn, nrow = G, ncol = kg) + + out_i <- vector("list", G) + out_j <- vector("list", G) + for (g in seq_len(G)) { + mem <- members[[g]] + m <- length(mem) + + # Members of the nearest other groups, in order, enough to top up any point + # of this group. Identical for every point in the group, since they share + # a coordinate. + ext <- integer(0) + if (k > m - 1L) { + for (h in nn[g, ]) { + if (h == g) next # defensive; representatives are distinct + ext <- c(ext, members[[h]]) + if (length(ext) >= k - (m - 1L)) break + } + ext <- ext[seq_len(k - (m - 1L))] + } + + js <- lapply(mem, function(i) { + own <- mem[mem != i] + if (length(own) >= k) own[seq_len(k)] else c(own, ext) + }) + out_i[[g]] <- rep(mem, each = k) + out_j[[g]] <- unlist(js, use.names = FALSE) + } + + list(i = as.integer(unlist(out_i, use.names = FALSE)), + j = as.integer(unlist(out_j, use.names = FALSE))) +} + + #' Build a row-standardised k-nearest-neighbour sparse weight matrix #' -#' For each observation the \code{k} closest neighbours receive weight 1; -#' all other pairs receive weight 0. +#' For each observation the \code{k} closest \emph{other} observations receive +#' weight 1; all other pairs, and the diagonal, receive weight 0. #' The resulting matrix is then row-standardised so that each row sums to 1. #' This is the standard default in spatial statistics (Anselin, 1988) and is #' far more robust to irregularly-spaced or clustered data than an #' inverse-distance scheme, which gives enormous weight to very close pairs #' and can inflate Moran's I significance. #' +#' The neighbour lookup itself is \code{.knn_pairs()}, which is where the +#' zero-diagonal guarantee lives — see the note there on duplicate +#' coordinates. +#' #' Uses \pkg{FNN} for O(n·k) kd-tree nearest-neighbour lookup when available, #' avoiding the O(n²) full distance matrix. Returns a #' \code{Matrix::sparseMatrix} (dgCMatrix), which keeps memory proportional to @@ -143,57 +317,238 @@ has_fnn <- isTRUE(use_fnn) has_matrix <- isTRUE(use_matrix) + # --- Fallback: dense O(n²) path when packages are missing ---- + # The guard has to test BOTH backends, not just FNN: the dense branch is + # 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) + 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) + + # Both backends share one neighbour lookup, so the zero diagonal (and the + # k + 1 request that FNN needs to guarantee it) cannot drift apart between + # them. The two paths differ only in how W is stored. + pr <- .knn_pairs(coords, k = k, use_fnn = has_fnn) + row_i <- pr$i + col_j <- pr$j + deg <- tabulate(row_i, nbins = n) # neighbours actually kept per row + deg[deg == 0L] <- 1L # isolate: leave a zero row, not NaN + if (has_fnn && has_matrix) { # --- Fast path: O(n*k) kd-tree lookup + sparse matrix ---- - nn_idx <- FNN::get.knn(coords, k = k)$nn.index # n x k matrix - row_i <- rep(seq_len(n), each = k) - col_j <- as.integer(t(nn_idx)) W <- Matrix::sparseMatrix( - i = row_i, j = col_j, x = 1 / k, # row-standardised + i = row_i, j = col_j, x = 1 / deg[row_i], # row-standardised dims = c(n, n), repr = "C" ) } else { - # --- Fallback: dense O(n²) path when packages are missing ---- - # The guard has to test BOTH backends, not just FNN: this branch is 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) - 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) - if (has_fnn) { - nn_idx <- FNN::get.knn(coords, k = k)$nn.index - } else { - dmat <- as.matrix(stats::dist(coords)) - diag(dmat) <- Inf - nn_idx <- t(apply(dmat, 1, function(row) order(row)[seq_len(k)])) - } W <- matrix(0, n, n) - for (i in seq_len(n)) W[i, nn_idx[i, ]] <- 1 - rs <- rowSums(W) - rs[rs == 0] <- 1 - W <- W / rs + W[cbind(row_i, col_j)] <- 1 / deg[row_i] } W } +#' Rebuild a fitted model's design matrix and test whether its residuals are +#' the OLS residuals on it +#' +#' The Cliff & Ord residual moments are exact for \eqn{e = My} with +#' \eqn{M = I - X(X'X)^{-1}X'} and nothing else, so rather than guessing from +#' the fit's class whether that holds, this checks it directly: rebuild +#' \code{X} from \code{predictor_vars} and \code{data_sf}, regress the response +#' on it, and compare the result with the residuals actually supplied. The +#' answer is exactly the condition the formula needs, and it degrades +#' gracefully — a GWR whose bandwidth is wide enough to be global OLS passes, +#' the same GWR at a small bandwidth does not. +#' +#' @param fit A \code{spatial_fit}. +#' @param resid The residual vector already extracted and subset by \code{keep}. +#' @param keep Logical vector over the rows of \code{fit$data_sf} marking the +#' observations that survived the finite-residual filter. +#' @return \code{NULL} when the design cannot be rebuilt, otherwise a list with +#' \code{X} (the model matrix, rows subset by \code{keep}) and \code{is_ols}. +#' @keywords internal +#' @noRd +.morans_ols_design <- function(fit, resid, keep) { + d <- fit$data_sf + rv <- fit$response_var + pv <- fit$predictor_vars + if (!inherits(d, "sf")) return(NULL) + if (!is.character(rv) || length(rv) != 1L || is.na(rv)) return(NULL) + if (is.null(pv)) pv <- character(0) + if (!is.character(pv)) return(NULL) + + df <- tryCatch(sf::st_drop_geometry(d), error = function(e) NULL) + if (is.null(df) || nrow(df) != length(keep)) return(NULL) + if (!all(c(rv, pv) %in% names(df))) return(NULL) + + df <- df[keep, c(rv, pv), drop = FALSE] + if (nrow(df) != length(resid) || anyNA(df)) return(NULL) + + y <- df[[rv]] + if (!is.numeric(y) || !all(is.finite(y))) return(NULL) + + X <- if (length(pv) == 0L) { + # An intercept-only model. tr(MW) = -S0/n for any W with a zero diagonal, + # so the residual moments reduce to E[I] = -1/(n - 1) exactly -- the + # classical value -- which is a useful sanity check on the general path. + matrix(1, nrow(df), 1L, dimnames = list(NULL, "(Intercept)")) + } else { + tryCatch( + stats::model.matrix(~ ., data = df[, pv, drop = FALSE]), + error = function(e) NULL + ) + } + if (!is.matrix(X) || nrow(X) != nrow(df) || !all(is.finite(X))) return(NULL) + + e_ols <- tryCatch(qr.resid(qr(X), y), error = function(e) NULL) + if (is.null(e_ols) || length(e_ols) != length(resid)) return(NULL) + + scale <- max(stats::sd(y), .Machine$double.eps) + list(X = X, is_ols = max(abs(resid - e_ols)) <= 1e-7 * scale) +} + + +#' Cliff & Ord (1981) sec. 8.3 moments of Moran's I for regression residuals +#' +#' For \eqn{e = M\varepsilon} with \eqn{M = I - X(X'X)^{-1}X'} and +#' \eqn{\varepsilon \sim N(0, \sigma^2 I)}: +#' \deqn{E[I] = (n/S_0)\,\mathrm{tr}(MW)/(n-p)} +#' \deqn{Var[I] = (n/S_0)^2 [\mathrm{tr}(MWMW') + \mathrm{tr}((MW)^2) + +#' (\mathrm{tr}MW)^2]/[(n-p)(n-p+2)] - E[I]^2} +#' +#' \eqn{M} is never formed. With \eqn{Q} an orthonormal basis of +#' \eqn{col(X)} (so \eqn{P = QQ'}), every trace reduces to a \eqn{q \times q} +#' one plus Frobenius norms of the \eqn{n \times q} products \eqn{WQ} and +#' \eqn{W'Q}, which keeps the sparse weight matrix sparse: +#' \deqn{\mathrm{tr}(MW) = \mathrm{tr}(W) - \mathrm{tr}(Q'WQ)} +#' \deqn{\mathrm{tr}((MW)^2) = \mathrm{tr}(W^2) - 2\,\mathrm{tr}(PW^2) + +#' \mathrm{tr}((Q'WQ)^2)} +#' \deqn{\mathrm{tr}(MWMW') = \mathrm{tr}(WW') - \mathrm{tr}(PW'W) - +#' \mathrm{tr}(PWW') + \mathrm{tr}((Q'WQ)(Q'WQ)')} +#' +#' Verified to agree with \code{spdep::lm.morantest()} and with an explicit +#' dense \eqn{M} to machine precision. +#' +#' @param W The weight matrix (base or \pkg{Matrix}). +#' @param X The design matrix. +#' @param S0 \code{sum(W)}, already computed by the caller. +#' @param is_sparse Whether \code{W} is a \pkg{Matrix} object. +#' @return \code{NULL} when the residual degrees of freedom are too small to +#' support the formula, otherwise a list with \code{EI}, \code{VI}, +#' \code{df} and \code{p}. +#' @keywords internal +#' @noRd +.morans_residual_moments <- function(W, X, S0, is_sparse) { + n <- nrow(X) + qrX <- tryCatch(qr(X), error = function(e) NULL) + if (is.null(qrX)) return(NULL) + q <- qrX$rank + df <- n - q + # (n - p + 2) sits in the denominator and the normal approximation is + # meaningless with a handful of residual degrees of freedom either way. + if (!is.finite(q) || q < 1L || df < 4L) return(NULL) + + Q <- qr.Q(qrX)[, seq_len(q), drop = FALSE] + Wt <- if (is_sparse) Matrix::t(W) else t(W) + WQ <- as.matrix(W %*% Q) # n x q + HQ <- as.matrix(Wt %*% Q) # n x q (= W' Q) + G <- crossprod(Q, WQ) # q x q (= Q' W Q) + + trW <- sum(if (is_sparse) Matrix::diag(W) else diag(W)) + trMW <- trW - sum(diag(G)) + trWWt <- sum(W * W) # tr(W W') + trW2 <- sum(W * Wt) # tr(W^2) + + trMWMWt <- trWWt - sum(WQ * WQ) - sum(HQ * HQ) + sum(G * G) + trMWMW <- trW2 - 2 * sum(HQ * WQ) + sum(G * t(G)) + + EI <- (n / S0) * trMW / df + VI <- (n / S0)^2 * (trMWMWt + trMWMW + trMW^2) / (df * (df + 2)) - EI^2 + if (!is.finite(EI) || !is.finite(VI)) return(NULL) + list(EI = EI, VI = VI, df = df, p = q) +} + + #' Compute Moran's I on the residuals of a fitted spatial model #' -#' Given a \code{spatial_fit} object (GWR or Bayesian), extracts the -#' residuals and the observation coordinates, builds a spatial weight -#' matrix, and computes the Moran's I statistic together with -#' its analytical expectation and variance under the randomisation -#' assumption (Cliff & Ord). A z-score and two-sided p-value are -#' provided so the caller can assess whether statistically significant -#' spatial autocorrelation remains after fitting. +#' Given a \code{spatial_fit} object, extracts the residuals and the +#' observation coordinates, builds a spatial weight matrix, and computes +#' Moran's I together with its analytical expectation and variance under a +#' stated null. A z-score and two-sided p-value are provided so the caller can +#' assess whether statistically significant spatial autocorrelation remains +#' after fitting. #' #' By default, weights are constructed as a k-nearest-neighbour (k = 8) #' binary matrix, row-standardised. Users may supply their own weight #' matrix via the \code{weights} argument. #' -#' @param fit A \code{spatial_fit} object (from \code{fit_gwr_model} or -#' \code{fit_bayesian_spatial_model}). +#' @section Which null, and when it is approximate: +#' Two nulls are available, and the one actually used is reported back in the +#' \code{null} element of the return value. +#' +#' \code{"randomisation"} is the classical exchangeable null: +#' \eqn{E[I] = -1/(n-1)} with the Cliff & Ord randomisation variance, +#' conditioning on the observed kurtosis. These are the moments of I for a +#' vector whose elements are equally likely in any order. +#' +#' \strong{Model residuals are not exchangeable.} They are orthogonal to the +#' design matrix, which pushes \eqn{E[I]} materially below \eqn{-1/(n-1)} +#' whenever the covariates are spatially smooth — and pushes it further the +#' more covariates there are. In a simulation with \eqn{n = 120}, six smooth +#' covariates and \emph{independent} errors (so the truth is "no residual +#' autocorrelation"), OLS residuals had mean \eqn{I = -0.031} against the +#' exchangeable \eqn{E[I] = -0.008}; the z-score averaged \eqn{-0.54} with +#' \eqn{sd = 0.90} instead of 0 and 1. The cost is power, which is the point +#' of the test: at a moderate residual autocorrelation the exchangeable null +#' rejected 13\% of the time where the correct one rejected 31\%. +#' +#' \code{"residual"} therefore uses the Cliff & Ord (1981) sec. 8.3 moments for +#' regression residuals, with \eqn{M = I - X(X'X)^{-1}X'} rebuilt from +#' \code{predictor_vars} and \code{data_sf}: +#' \deqn{E[I] = (n/S_0)\,\mathrm{tr}(MW)/(n-p)} +#' \deqn{Var[I] = (n/S_0)^2[\mathrm{tr}(MWMW') + \mathrm{tr}((MW)^2) + +#' (\mathrm{tr}MW)^2]/[(n-p)(n-p+2)] - E[I]^2} +#' These assume normal errors rather than conditioning on the observed +#' kurtosis. On the simulation above they restored the z-score to mean +#' \eqn{-0.09}, \eqn{sd = 1.03}, and the rejection rate to 4.3\% against a +#' nominal 5\%. They agree with \code{spdep::lm.morantest()} to machine +#' precision. +#' +#' \strong{These moments are exact for \eqn{e = My} and for nothing else}, so +#' \code{null = "auto"} does not guess from the fit's class: it rebuilds +#' \code{X}, regresses the response on it, and uses the residual moments only +#' when the supplied residuals \emph{are} those OLS residuals to numerical +#' tolerance. A GWR wide enough to have collapsed to global OLS passes that +#' test; the same GWR at a working bandwidth does not. +#' +#' \strong{For the flexible backends neither null is exact}, and \code{"auto"} +#' leaves them on \code{"randomisation"} because forcing the OLS moments on +#' them measurably makes matters worse, not better. Measured on null data +#' (\eqn{n = 120}, three smooth covariates, independent errors; nominal 5\%, +#' one-sided): +#' \tabular{lrr}{ +#' \strong{backend} \tab \strong{randomisation} \tab \strong{residual} \cr +#' OLS \tab 0.035 \tab 0.060 \cr +#' random forest \tab 0.128 \tab 0.200 \cr +#' GWR \tab 0.000 \tab 0.000 +#' } +#' An in-sample random forest is anticonservative under both — its residuals +#' are shrunk and spatially heteroscedastic, so the variance is understated +#' whichever moments are used (\eqn{sd(z) \approx 1.3}) — and GWR is +#' conservative under both, because it removes far more structure than a rank-p +#' projection does. Treat the p-value from those backends as a rough +#' indicator, and prefer cross-validated residuals or an explicit spatial +#' covariance model when the answer has to carry weight. +#' +#' A permutation null was considered and rejected: permuting the residual +#' vector destroys exactly the orthogonality that causes the bias, so its mean +#' is the exchangeable \eqn{-1/(n-1)} by construction (measured: +#' \eqn{-0.00840} against \eqn{-1/(n-1) = -0.00840}) and it reproduces the +#' randomisation null rather than correcting it. +#' +#' @param fit A \code{spatial_fit} object (from \code{fit_gwr_model}, +#' \code{fit_bayesian_spatial_model} or \code{fit_rf_model}). #' @param alternative Character: \code{"two.sided"} (default), #' \code{"greater"} (positive autocorrelation), or \code{"less"}. #' @param weights Optional user-supplied n x n weight matrix — a base @@ -208,34 +563,58 @@ #' @param k Integer number of nearest neighbours used when building the #' default weight matrix (ignored when \code{weights} is supplied). #' Default 8. +#' @param null Which null distribution the expectation, variance and p-value +#' are computed against. One of: +#' \describe{ +#' \item{\code{"auto"} (default)}{\code{"residual"} when the design matrix +#' can be rebuilt \emph{and} the fit's residuals are the OLS residuals on +#' it, \code{"randomisation"} otherwise.} +#' \item{\code{"randomisation"}}{Always the exchangeable moments.} +#' \item{\code{"residual"}}{Always the Cliff & Ord residual moments. Falls +#' back to \code{"randomisation"} with a logged warning if the design +#' cannot be rebuilt, and warns (but proceeds) if the residuals are not +#' the OLS residuals on it, in which case the moments are approximate.} +#' } +#' See \strong{Which null, and when it is approximate} above. #' @return A list with components: #' \describe{ #' \item{observed}{Numeric scalar, Moran's I statistic.} -#' \item{expected}{Expected I under the null of no spatial -#' autocorrelation, \eqn{-1/(n-1)}.} -#' \item{sd}{Standard deviation of I under the randomisation -#' assumption.} +#' \item{expected}{Expected I under the null named by \code{null}: +#' \eqn{-1/(n-1)} for \code{"randomisation"}, +#' \eqn{(n/S_0)\mathrm{tr}(MW)/(n-p)} for \code{"residual"}.} +#' \item{sd}{Standard deviation of I under that same null.} #' \item{z}{Standardised z-score, \eqn{(I - E[I]) / sd(I)}.} #' \item{p_value}{Two-sided (or one-sided) p-value from the #' normal approximation.} #' \item{n}{Number of observations used.} +#' \item{null}{The null actually used, \code{"randomisation"} or +#' \code{"residual"} — check this rather than assuming, since +#' \code{"auto"} chooses per fit and \code{"residual"} can fall back.} +#' \item{df}{Residual degrees of freedom behind the moments: +#' \eqn{n - p} for \code{"residual"} (where \eqn{p} is the rank of the +#' design matrix), \eqn{n - 1} for \code{"randomisation"}.} #' } #' Returns \code{NULL} with a warning if computation fails (e.g. fewer #' than 4 valid residuals). +#' @references Cliff, A. D. and Ord, J. K. (1981) \emph{Spatial Processes: +#' Models and Applications}. Pion, London. Section 8.3. #' @family model evaluation #' @examples #' \donttest{ -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' # Works on any spatial_fit; a forest keeps the example free of the optional +#' # GWR/Stan backends. +#' if (requireNamespace("ranger", quietly = TRUE)) { #' library(sf) #' set.seed(1) -#' n <- 60 +#' n <- 120 #' dat <- st_as_sf( #' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), #' coords = c("x", "y"), crs = 32632 #' ) -#' dat$price <- 10 + 0.01 * st_coordinates(dat)[, 1] + 2 * dat$elev + rnorm(n) -#' fit <- fit_gwr_model(dat, "price", "elev", bandwidth = 30) +#' # A strong east-west trend the predictor cannot explain: the residuals +#' # should still carry spatial structure, and this is what detects it. +#' dat$price <- 10 + 0.02 * st_coordinates(dat)[, 1] + 2 * dat$elev + rnorm(n) +#' fit <- fit_rf_model(dat, "price", "elev", num_trees = 100, seed = 1) #' residual_morans_i(fit) # z near 0 / p large = no residual structure #' } #' } @@ -243,8 +622,10 @@ residual_morans_i <- function(fit, alternative = c("two.sided", "greater", "less"), weights = NULL, - k = 8L) { + k = 8L, + null = c("auto", "randomisation", "residual")) { alternative <- match.arg(alternative) + null <- match.arg(null) if (!inherits(fit, "spatial_fit")) { .log_warn("residual_morans_i(): `fit` is not a spatial_fit object.") @@ -332,35 +713,85 @@ residual_morans_i <- function(fit, # note in the variance block below. The two are numerically identical. I <- (n / S0) * sum(resid_c * (W %*% resid_c)) / ss_c - # --- Analytical expectation & variance (randomisation assumption) --- - EI <- -1 / (n - 1) - - # Cliff & Ord variance under randomisation - # S1 = 0.5 * sum((W + t(W))^2) rewritten via the identity - # = sum(W^2) + sum(W * t(W)) - # so that sparse W never materialises the denser (W + t(W)) intermediate. - # - # NOTE: t(), rowSums(), colSums() and crossprod() are plain base functions - # that do NOT dispatch to Matrix's S4 methods when called from package code - # with Matrix loaded-but-not-attached, so sparse W needs the Matrix:: - # generics explicitly (or, for crossprod, the primitive-only rewrite used - # for I above). Only primitives -- *, %*%, and sum() -- dispatch on their - # own; crossprod is neither a primitive nor an internal generic, which is - # why it belongs on this list and not with them. + # NOTE for everything below: t(), rowSums(), colSums() and crossprod() are + # plain base functions that do NOT dispatch to Matrix's S4 methods when + # called from package code with Matrix loaded-but-not-attached, so sparse W + # needs the Matrix:: generics explicitly (or, for crossprod, the + # primitive-only rewrite used for I above). Only primitives -- *, %*%, and + # sum() -- dispatch on their own; crossprod is neither a primitive nor an + # internal generic, which is why it belongs on this list and not with them. is_sparse <- inherits(W, "Matrix") - Wt <- if (is_sparse) Matrix::t(W) else t(W) - S1 <- sum(W * W) + sum(W * Wt) - rs <- if (is_sparse) Matrix::rowSums(W) else rowSums(W) - cs <- if (is_sparse) Matrix::colSums(W) else colSums(W) - S2 <- sum((rs + cs)^2) - m2 <- ss_c / n - m4 <- sum(resid_c^4) / n - b2 <- m4 / (m2^2) # kurtosis - - A <- n * ((n^2 - 3 * n + 3) * S1 - n * S2 + 3 * S0^2) - D <- (n - 1) * (n - 2) * (n - 3) * S0^2 - C <- (n^2 - n) * S1 - 2 * n * S2 + 6 * S0^2 - VI <- (A - b2 * C) / D - EI^2 + + # --- Choose the null ------------------------------------------------------- + # The exchangeable moments below are the moments of I for a vector whose + # elements are equally likely in any order. Model residuals are not such a + # vector: they are orthogonal to the design matrix, which drags the true + # E[I] well below -1/(n - 1) once the covariates are spatially smooth. See + # ?residual_morans_i, section "Which null, and when it is approximate", for + # the measured size and power cost and for why "auto" refuses to apply the + # OLS residual moments to a backend whose residuals are not OLS residuals. + des <- if (identical(null, "randomisation")) NULL else + .morans_ols_design(fit, resid, ok) + + use_residual <- switch(null, + randomisation = FALSE, + auto = !is.null(des) && isTRUE(des$is_ols), + residual = !is.null(des) + ) + if (identical(null, "residual")) { + if (is.null(des)) { + .log_warn(paste0("residual_morans_i(): null = \"residual\" needs the design ", + "matrix, which cannot be rebuilt from this fit's ", + "`predictor_vars` and `data_sf`; using the randomisation ", + "null instead. The returned `null` element says which was used.")) + } else if (!isTRUE(des$is_ols)) { + .log_warn(paste0("residual_morans_i(): null = \"residual\" was requested, but ", + "these residuals are not the OLS residuals of the response on ", + "the rebuilt design matrix, so the Cliff & Ord residual ", + "moments are an approximation here rather than exact.")) + } + } + + mom <- NULL + if (use_residual) { + mom <- .morans_residual_moments(W = W, X = des$X, S0 = S0, + is_sparse = is_sparse) + if (is.null(mom) && !identical(null, "auto")) + .log_warn(paste0("residual_morans_i(): the residual moments are not usable ", + "here (too few residual degrees of freedom); using the ", + "randomisation null instead.")) + } + + if (!is.null(mom)) { + # --- Cliff & Ord (1981) sec. 8.3 residual moments --- + null_used <- "residual" + EI <- mom$EI + VI <- mom$VI + df_I <- mom$df + } else { + # --- Analytical expectation & variance (randomisation assumption) --- + null_used <- "randomisation" + EI <- -1 / (n - 1) + df_I <- n - 1 + + # Cliff & Ord variance under randomisation + # S1 = 0.5 * sum((W + t(W))^2) rewritten via the identity + # = sum(W^2) + sum(W * t(W)) + # so that sparse W never materialises the denser (W + t(W)) intermediate. + Wt <- if (is_sparse) Matrix::t(W) else t(W) + S1 <- sum(W * W) + sum(W * Wt) + rs <- if (is_sparse) Matrix::rowSums(W) else rowSums(W) + cs <- if (is_sparse) Matrix::colSums(W) else colSums(W) + S2 <- sum((rs + cs)^2) + m2 <- ss_c / n + m4 <- sum(resid_c^4) / n + b2 <- m4 / (m2^2) # kurtosis + + A <- n * ((n^2 - 3 * n + 3) * S1 - n * S2 + 3 * S0^2) + D <- (n - 1) * (n - 2) * (n - 3) * S0^2 + C <- (n^2 - n) * S1 - 2 * n * S2 + 6 * S0^2 + VI <- (A - b2 * C) / D - EI^2 + } # is.finite() as well as > 0: a degenerate kurtosis (b2) can make VI NaN, # and `if (NaN > 0)` is an error rather than FALSE. @@ -378,7 +809,7 @@ residual_morans_i <- function(fit, } list(observed = I, expected = EI, sd = sd_I, z = z, - p_value = p, n = n) + p_value = p, n = n, null = null_used, df = df_I) } @@ -390,19 +821,27 @@ residual_morans_i <- function(fit, #' #' @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}, and \code{resid_morans_p}. +#' \code{resid_morans_z}, \code{resid_morans_p} and \code{resid_morans_null} +#' (which null the p-value was computed against, per model). #' @keywords internal #' @noRd .residual_morans_table <- function(fits) { - rows <- lapply(names(fits), function(nm) { - mi <- residual_morans_i(fits[[nm]]) + # seq_along() rather than names(): fits[[nm]] returns the FIRST element of + # that name, so duplicated names scored one fit repeatedly. evaluate_insample() + # now rejects duplicates outright, but positional indexing means this cannot + # silently mis-report even if it is called directly. + nms <- names(fits) + rows <- lapply(seq_along(fits), function(i) { + mi <- residual_morans_i(fits[[i]]) if (is.null(mi)) { - data.frame(model = nm, resid_morans_I = NA_real_, + 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_, stringsAsFactors = FALSE) } else { - data.frame(model = nm, resid_morans_I = mi$observed, + 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, stringsAsFactors = FALSE) } }) @@ -423,7 +862,9 @@ residual_morans_i <- function(fit, #' @param fits A \code{spatial_fit} object, or a named list of them #' (e.g. \code{list(GWR = gwr_obj, Bayesian = bayes_obj)}). The names are #' used as the model labels and every element must have one; an unnamed -#' list is an error. +#' list is an error, and so are duplicated names --- \code{model} is the key +#' the comparison table is assembled on, so two fits sharing a name cannot be +#' told apart in the output. #' @param newdata Optional sf object for out-of-sample evaluation. #' Must contain the response variable and all predictors. #' If NULL, in-sample metrics are computed. @@ -452,8 +893,25 @@ evaluate_insample <- function(fits, newdata = NULL, ...) { "objects -- the names label the models in the output. Supply them, ", "e.g. list(GWR = gwr_fit, Bayesian = bayes_fit).", call. = FALSE) - rows <- lapply(nms, function(nm) { - obj <- fits[[nm]] + # Duplicated names are silently WRONG rather than merely ambiguous. `model` + # is the join key compare_models() merges the metric and Moran's I tables on, + # so two fits called "GWR" produced a 2 x 2 cross-join: four rows, every one + # of them carrying the first fit's numbers (fits[[nm]] returns the first + # match, so the second fit was never scored at all). + dup <- unique(nms[duplicated(nms)]) + if (length(dup) > 0L) + stop(sprintf( + paste0("evaluate_insample(): `fits` has duplicated name(s) %s. The names ", + "label the models and are the key the comparison table is built ", + "on, so they must be unique -- give the fits distinct names, e.g. ", + "list(GWR_bw50 = ..., GWR_bw80 = ...)."), + paste(sQuote(dup), collapse = ", ")), call. = FALSE) + + # seq_along() rather than the names themselves: fits[[nm]] returns the first + # element of that name, which is the other half of the duplicate-name bug. + rows <- lapply(seq_along(fits), function(i) { + obj <- fits[[i]] + nm <- nms[i] if (!inherits(obj, "spatial_fit")) { .log_warn("evaluate_insample(): '%s' is not a spatial_fit; skipping.", nm) return(NULL) @@ -476,10 +934,18 @@ evaluate_insample <- function(fits, newdata = NULL, ...) { #' a tidy comparison table including in-sample metrics and model-specific #' information criteria (AICc, LOOIC). #' -#' @param fits A named list of \code{spatial_fit} objects. +#' @param fits A named list of \code{spatial_fit} objects. Names must be +#' unique; see \code{\link{evaluate_insample}}. #' @param newdata Optional sf for out-of-sample evaluation. #' @param ... Extra arguments passed to predict(). -#' @return A data.frame comparing all models. +#' @return A data.frame comparing all models. Alongside the metrics it carries +#' \code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and +#' \code{resid_morans_null} --- the last naming which 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. The +#' significant-autocorrelation warning below is driven by that p-value, so +#' read its caveats in \code{?residual_morans_i} before treating silence as +#' evidence of no residual structure. #' @family model evaluation #' @export compare_models <- function(fits, newdata = NULL, ...) { @@ -500,8 +966,13 @@ compare_models <- function(fits, newdata = NULL, ...) { met_df$LOOIC <- NA_real_ met_df$bandwidth_is_fallback <- NA for (i in seq_len(nrow(met_df))) { - nm <- met_df$model[i] - obj <- fits[[nm]] + nm <- met_df$model[i] + # By index, not fits[[nm]]: name lookup returns the FIRST match, so with two + # fits of one name every row read the same object. evaluate_insample() now + # rejects duplicate names outright, and match() keeps this loop correct + # rather than merely lucky. met_df can be shorter than `fits` when a + # non-spatial_fit element was skipped, so the mapping is by name, not order. + obj <- fits[[match(nm, names(fits))]] if (inherits(obj, "gwr_fit")) { met_df$AICc[i] <- obj$info$AICc %||% NA_real_ is_fb <- isTRUE(obj$info$bandwidth_is_fallback) @@ -563,7 +1034,10 @@ compare_models <- function(fits, newdata = NULL, ...) { #' Names outside that set raise a warning and are dropped; if nothing #' recognised remains, this is an error rather than a silent fallback. #' A recognised model whose backend package is not installed is dropped with -#' a message. +#' a message so the call still returns the models that could run --- but if +#' \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 seed RNG seed. Default 123. #' @param folds Optional precomputed fold splits. @@ -586,6 +1060,11 @@ compare_models <- function(fits, newdata = NULL, ...) { #' @param quiet Logical; suppress messages. #' @return A list with overall, by_fold, and per-model cv_results #' (\code{gwr_cv}, \code{bayes_cv}, \code{rf_cv} for the models that ran). +#' Only the models that actually ran appear, so check which names are present +#' rather than assuming one entry per requested model: a backend whose package +#' is missing is dropped with a message. When \strong{no} requested backend +#' is available there is nothing to return and the function errors with +#' \code{"no viable models."} instead of returning an empty comparison. #' @family model evaluation #' @examples #' \donttest{ diff --git a/R/level-selection.R b/R/level-selection.R index ae432e8..2d24b21 100644 --- a/R/level-selection.R +++ b/R/level-selection.R @@ -64,29 +64,51 @@ } +#' The "not computable" return of .morans_i_for_k() +#' +#' Kept as a named constant so every early exit has the same shape as the +#' success path; a bare \code{NA_real_} from one of them would silently make +#' \code{moran_z[k]} the \emph{I} of the next candidate. +#' +#' @return \code{c(I = NA_real_, z = NA_real_)}. +#' @keywords internal +#' @noRd +.morans_na <- function() c(I = NA_real_, z = NA_real_) + + #' Compute Moran's I for residuals at a given tessellation resolution #' #' For a given k-means cluster assignment, fits OLS on cell-level means and #' computes Moran's I on the residuals using a k-nearest-neighbour (k = 8) -#' binary weight matrix, row-standardised. -#' Lower absolute Moran's I suggests the tessellation resolution adequately -#' captures the spatial structure in the data. +#' binary weight matrix, row-standardised, together with its standardised +#' deviate under the Cliff & Ord regression-residual moments. +#' +#' \strong{Rank on \code{z}, not on \code{I}.} \eqn{E[I]} and \eqn{Var[I]} +#' both depend on the number of cells, so \eqn{|I|} shrinks as \code{k} grows +#' whether or not the tessellation is capturing anything. Over 300 replicates +#' of a response with no spatial structure, mean \eqn{|I|} fell monotonically +#' from 0.114 at \code{k = 10} to 0.050 at \code{k = 60}; mean \eqn{|z|} over +#' the same runs was 0.77, 0.78, 0.76, 0.80 against the theoretical +#' \eqn{E|N(0,1)| = 0.798}. Ranking on \eqn{|I|} therefore prefers the finest +#' tessellation for arithmetic reasons rather than statistical ones. #' #' @param xy Numeric matrix of coordinates. #' @param response Numeric vector of response values. #' @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. -#' @return Numeric scalar: Moran's I statistic (values near 0 indicate the -#' tessellation resolution captures the spatial pattern; positive values -#' indicate residual spatial autocorrelation remains). +#' @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 +#' 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) { # Aggregate to cell-level means cell_ids <- sort(unique(cluster_ids)) n_cells <- length(cell_ids) - if (n_cells < 4L) return(NA_real_) + if (n_cells < 4L) return(.morans_na()) cell_resp <- numeric(n_cells) cell_xy <- matrix(0, n_cells, 2) @@ -101,33 +123,64 @@ # Fit OLS on cell means ok <- is.finite(cell_resp) & apply(is.finite(cell_pred), 1, all) - if (sum(ok) < 4L) return(NA_real_) + if (sum(ok) < 4L) return(.morans_na()) fit <- try(stats::lm.fit(x = cbind(1, cell_pred[ok, , drop = FALSE]), y = cell_resp[ok]), silent = TRUE) - if (inherits(fit, "try-error")) return(NA_real_) + if (inherits(fit, "try-error")) return(.morans_na()) resid <- fit$residuals n <- length(resid) # k-nearest-neighbour weight matrix via shared helper (sparse when possible) n_neighbors <- min(8L, n - 1L) - if (n_neighbors < 1L) return(NA_real_) + if (n_neighbors < 1L) return(.morans_na()) + + # Refuse to report a number that carries no information. When every cell is + # a neighbour of every other (n <= n_neighbors + 1, i.e. n <= 9 at the + # default of 8), W is the complete row-standardised matrix W_ij = 1/(n-1), + # so W %*% e = -e/(n-1) for ANY mean-zero residual vector, S0 = n, and + # Moran's I collapses to exactly -1/(n - 1) whatever the data are. It is not + # merely uninformative but biased for level selection: |I| = 1/(n-1) falls + # monotonically in the number of cells for arithmetic reasons alone, so + # criterion = "morans_i" would rank the largest candidate k first every time. + # NA excludes these candidates instead; determine_optimal_levels() falls back + # 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) # Moran's I = (n / S0) * (e' W e) / (e' e) S0 <- sum(W) if (S0 < .Machine$double.eps || sum(resid^2) < .Machine$double.eps) - return(NA_real_) + return(.morans_na()) resid_c <- resid - mean(resid) # sum(resid_c * (W %*% resid_c)) rather than crossprod(): .build_knn_weights() # returns a sparse Matrix when FNN and Matrix are installed, and # base::crossprod() does not dispatch on the dgeMatrix that W %*% resid_c # produces ("requires numeric/complex matrix/vector arguments"). The two # forms are numerically identical. Matches residual_morans_i(). - I <- (n / S0) * sum(resid_c * (W %*% resid_c)) / sum(resid_c^2) - as.numeric(I) + I <- as.numeric((n / S0) * sum(resid_c * (W %*% resid_c)) / sum(resid_c^2)) + + # The ranking needs a STANDARDISED deviate, not |I|. E[I] and Var(I) both + # depend on k, so |I| shrinks with the number of cells for arithmetic reasons + # that have nothing to do with the data. Measured over 300 replicates of a + # response with NO spatial structure (n = 1200, two noise predictors), mean + # |I| fell monotonically from 0.1136 at k = 10 to 0.0502 at k = 60 -- -55.9% + # -- so ranking on |I| prefers the finest candidate whatever the data say. + # Over the same runs mean |z| was 0.769, 0.778, 0.755, 0.801 against the + # theoretical E|N(0,1)| = 0.798, with sd(z) 0.96-1.02 and a two-sided 5% + # rejection rate of 0.040-0.057. It is calibrated, and flat in k. + # + # These are Cliff & Ord's regression-residual moments, and they are EXACT + # here: `resid` is by construction the OLS residual of the cell means on + # cbind(1, cell_pred), which is the one case the formula is derived for. + mom <- .morans_residual_moments(W = W, X = cbind(1, cell_pred[ok, , drop = FALSE]), + S0 = S0, is_sparse = inherits(W, "Matrix")) + z <- if (is.null(mom) || !is.finite(mom$VI) || mom$VI <= 0) NA_real_ + else (I - mom$EI) / sqrt(mom$VI) + + c(I = I, z = z) } @@ -153,6 +206,38 @@ #' promising candidate k values incur the cost of the full Moran's I #' computation. #' +#' \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 +#' tessellation is capturing anything. Measured over 300 replicates of a +#' response with \emph{no} spatial structure, mean \eqn{|I|} fell monotonically +#' from 0.114 at \code{k = 10} to 0.050 at \code{k = 60} (\eqn{-56\%}), which +#' made an \eqn{|I|} ranking prefer the largest candidate for arithmetic +#' reasons alone. Candidates are therefore ordered by +#' \eqn{|z| = |I - E[I]| / \mathrm{sd}(I)} using the Cliff & Ord regression +#' residual moments --- exact here, because the cell-level residuals are OLS +#' residuals by construction. Over the same runs \eqn{z} had mean \eqn{\approx +#' 0}, \eqn{\mathrm{sd} \approx 1} and a two-sided 5\% rejection rate of +#' 0.040--0.057 at every \code{k}. Both quantities are reported in the +#' \code{"diagnostics"} attribute, as \code{moran_i} and \code{moran_z}. +#' +#' \strong{Resolution floor on the model-aware criteria.} Moran's I is +#' computed on cell-level residuals with an 8-nearest-neighbour weight matrix, +#' so it only carries information once there are more than nine cells. At nine +#' or fewer, every cell is a neighbour of every other, the row-standardised +#' weight matrix is complete, and Moran's I collapses to exactly +#' \eqn{-1/(k - 1)} for \emph{any} residual vector — a function of \code{k} +#' alone, and one whose magnitude shrinks monotonically with \code{k}, which +#' would make \code{criterion = "morans_i"} prefer the largest candidate every +#' time. Those candidates therefore return \code{NA} and are excluded from the +#' model-aware ranking. When no candidate in the elbow neighbourhood clears +#' the floor — which is the usual outcome for small \code{max_levels} — the +#' whole call falls back to the geometric ranking and logs a warning; raise +#' \code{max_levels} above roughly 10 if you want the model-aware criteria to +#' contribute. Under \code{criterion = "combined"}, a candidate below the +#' floor that sits alongside candidates above it is ranked last on the Moran's +#' I axis while still competing on the geometric axis. +#' #' @param data_sf An sf object. #' @param max_levels Integer upper bound on levels. Default 12. #' @param top_n Integer; how many candidates to return. Default 3. Under @@ -164,15 +249,19 @@ #' @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. -#' @param predictor_vars Optional predictor column names. Must be numeric; -#' factor/character columns raise an error. +#' @param predictor_vars Optional predictor column names. Must be numeric or +#' logical (logicals are read as 0/1); factor/character columns raise an +#' error. #' @param criterion One of \code{"geometric"} (default when no response given), -#' \code{"morans_i"} (select k that minimizes |Moran's I|), or -#' \code{"combined"} (rank-average of WSS elbow distance and |Moran's I|). -#' Falls back to \code{"geometric"} if response/predictors are unavailable. +#' \code{"morans_i"} (select the k whose residual Moran's I is least +#' \emph{significant}), or \code{"combined"} (rank-average of WSS elbow +#' distance and that same quantity). Falls back to \code{"geometric"} if +#' response/predictors are unavailable, and also when no candidate clears the +#' nine-cell resolution floor described in \strong{Details}. #' @return An integer vector of candidate level counts. When #' \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is -#' attached with per-k Moran's I values — except when the model-aware path +#' attached with per-k Moran's I values (\code{moran_i}) and their +#' standardised deviates (\code{moran_z}) — except when the model-aware path #' itself falls back to the geometric result (no viable k in the elbow #' neighbourhood, or Moran's I could not be computed for any candidate), in #' which case no diagnostics are available and the attribute is absent. Both @@ -187,6 +276,10 @@ #' coords = c("x", "y"), crs = 32632 #' ) #' determine_optimal_levels(pts, max_levels = 6) +#' @family aggregation +#' @seealso [build_tessellation()], which takes the chosen level count as +#' `approx_n_cells`; [assign_features_to_polygons()] and +#' [summarize_by_cell()] for the steps that follow. #' @export determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, sample_n = 1500L, set_seed = 123L, @@ -236,20 +329,27 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # A factor or character predictor makes as.matrix() return a CHARACTER # matrix, which dies deep inside colMeans() with "'x' must be numeric". # Name the offending columns here instead. + # + # Logicals are NOT offending: as.matrix() on a logical column gives a + # logical matrix, which colMeans() handles, and storage.mode() below makes + # the 0/1 coding explicit. fit_rf_model()/cv_rf()/predict() all accept + # logical predictors, so rejecting them here would be inconsistent. non_num <- predictor_vars[!vapply(predictor_vars, - function(v) is.numeric(df[[v]]), + function(v) is.numeric(df[[v]]) || + is.logical(df[[v]]), logical(1))] if (length(non_num)) { stop(sprintf( - paste0("determine_optimal_levels(): `predictor_vars` must be numeric; ", - "%s %s not. Encode factor/character predictors numerically ", - "(e.g. with model.matrix()) before calling."), + paste0("determine_optimal_levels(): `predictor_vars` must be numeric ", + "or logical; %s %s not. Encode factor/character predictors ", + "numerically (e.g. with model.matrix()) before calling."), paste(sprintf("'%s'", non_num), collapse = ", "), if (length(non_num) == 1L) "is" else "are" ), call. = FALSE) } resp_vec <- as.numeric(df[[response_var]]) pred_mat <- as.matrix(df[, predictor_vars, drop = FALSE]) + storage.mode(pred_mat) <- "double" } if (n > sample_n) { @@ -333,17 +433,21 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # combined ranking below compares elbow distance and Moran's I computed # on the *same* clustering — the sweep's RNG state differs, so its WSS # can come from a different local optimum than the Moran evaluation. - moran_vals <- rep(NA_real_, k_max) + moran_vals <- rep(NA_real_, k_max) # raw I, reported in $diagnostics + moran_z <- rep(NA_real_, k_max) # standardised deviate, used for ranking wss_eval <- wss for (k in eval_ks) { km <- try(stats::kmeans(xy, centers = k, iter.max = 50, nstart = 5), silent = TRUE) if (inherits(km, "try-error")) next wss_eval[k] <- km$tot.withinss - moran_vals[k] <- .morans_i_for_k(xy, resp_vec, pred_mat, km$cluster) + mi <- .morans_i_for_k(xy, resp_vec, pred_mat, km$cluster) + moran_vals[k] <- mi[["I"]] + moran_z[k] <- mi[["z"]] } - valid_moran <- is.finite(moran_vals[eval_ks]) + # Ranking is on |z|. |I| is not comparable across k -- see .morans_i_for_k(). + valid_moran <- is.finite(moran_z[eval_ks]) if (!any(valid_moran)) { .log_warn("determine_optimal_levels(): Moran's I could not be computed; falling back to geometric.") @@ -354,15 +458,28 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, if (criterion == "morans_i") { # Select k that minimizes |Moran's I| among evaluated candidates. - abs_moran <- rep(Inf, k_max) - abs_moran[eval_ks] <- abs(moran_vals[eval_ks]) - abs_moran[!is.finite(abs_moran)] <- Inf - ranked <- order(abs_moran) + # + # Rank ONLY the candidates that actually produced a finite Moran's I. + # Ranking all of 1:k_max and truncating to top_n padded the answer with k + # values that were never evaluated: the unevaluated entries all sit at Inf, + # order() breaks those ties by index, and head() then appended 1, 2, 3, ... + # whenever top_n exceeded the number of finite candidates -- including k + # below the resolution floor, and k = 1, which is not a tessellation. + finite_ks <- eval_ks[is.finite(moran_z[eval_ks])] + if (length(finite_ks) == 0L) { + .log_warn(paste0("determine_optimal_levels(): no candidate produced a ", + "finite Moran's I (every candidate is at or below the ", + "resolution floor); falling back to geometric.")) + out <- as.integer(head(elbow$candidates, max(1L, as.integer(top_n)))) + out[out < 1L] <- 1L; out[out > k_max] <- k_max + return(unique(out)) + } + ranked <- finite_ks[order(abs(moran_z[finite_ks]))] out <- as.integer(head(ranked, max(1L, as.integer(top_n)))) out[out < 1L] <- 1L; out[out > k_max] <- k_max out <- unique(out) - attr(out, "diagnostics") <- list(moran_i = moran_vals, wss = wss[1:k_max], - eval_ks = eval_ks) + attr(out, "diagnostics") <- list(moran_i = moran_vals, moran_z = moran_z, + wss = wss[1:k_max], eval_ks = eval_ks) return(out) } @@ -384,9 +501,11 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, # Rank both criteria (lower rank = better) rank_elbow <- rank(-perp_dist, ties.method = "average") # higher distance = better - abs_moran_sub <- abs(moran_vals[eval_ks]) + # |z|, not |I|: the two rank candidates differently and only |z| is + # comparable across k. See .morans_i_for_k(). + abs_moran_sub <- abs(moran_z[eval_ks]) abs_moran_sub[!is.finite(abs_moran_sub)] <- max(abs_moran_sub[is.finite(abs_moran_sub)], 1) + 1 - rank_moran <- rank(abs_moran_sub, ties.method = "average") # lower |I| = better + rank_moran <- rank(abs_moran_sub, ties.method = "average") # lower |z| = better combined_rank <- (rank_elbow + rank_moran) / 2 best_idx <- order(combined_rank) @@ -394,7 +513,7 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, out[out < 1L] <- 1L; out[out > k_max] <- k_max out <- unique(out) attr(out, "diagnostics") <- list( - moran_i = moran_vals, wss = wss[1:k_max], + moran_i = moran_vals, moran_z = moran_z, wss = wss[1:k_max], wss_eval = wss_eval[1:k_max], combined_rank = stats::setNames(combined_rank, eval_ks), eval_ks = eval_ks, diff --git a/R/model-bayesian.R b/R/model-bayesian.R index 7d1e704..7a8df68 100644 --- a/R/model-bayesian.R +++ b/R/model-bayesian.R @@ -110,6 +110,25 @@ #' 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, rather than left in 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 +#' \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. +#' +#' 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 +#' \emph{varies} across the map. Choose \code{\link{fit_rf_model}()} when +#' predictive accuracy matters more than an interpretable model and the +#' response is non-linear in the predictors. The cost here is time: this is +#' full MCMC via 'brms' and Stan, so it is minutes rather than seconds, and the +#' GP is fitted through a reduced-rank basis approximation whose size +#' (\code{gp_k}) trades fidelity against runtime. +#' #' @param data_sf An sf object with response, predictors, and geometries. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. May be \code{character(0)} @@ -174,12 +193,23 @@ #' \code{gp(..x, ..y, k = gp_k)} carries \code{gp_k^2} basis functions -- the #' \code{gp_k} argument is the count \emph{per dimension}, not the total rank. #' Both \code{gp_k} and \code{gp_c} are therefore chosen from the ratio of the -#' estimated length-scale to the domain half-range, following +#' estimated length-scale to the domain extent, following #' Riutort-Mayol et al. (2023), rather than from the number of observations: #' \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}. #' +#' The domain extent used is the one \code{brms::gp(c = )} itself multiplies: +#' the full pooled range of the column-centred coordinates +#' (\code{brms:::choose_L()}), not the per-axis half-range in which +#' Riutort-Mayol et al. state their inequalities. Both constraints are really +#' constraints on the boundary \eqn{L = c \times S}, so expressing them in +#' brms's units is what keeps \code{gp_c}, \code{gp_k} and +#' \code{$info$gp_ell_min} describing the basis brms actually builds. A +#' \code{gp_c} derived on the half-range convention and handed to +#' \code{brms::gp()} produces a boundary twice as wide as intended, against +#' which \code{gp_k} under-resolves by a factor of two. +#' #' The GP term is built with \code{scale = FALSE}. \code{brms::gp()} otherwise #' rescales its covariates so the maximum Euclidean distance between two points #' is 1, and reports \code{lscale} in that space; since this function already @@ -223,7 +253,10 @@ #' 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_lengthscale_bounds -- the \code{c(lower, upper)} the length-scale prior -#' was calibrated over; gp_lscale_prior, loo, looic, +#' was calibrated over; gp_lscale_prior -- the length-scale prior +#' \code{brms::validate_prior()} reports the model will \emph{actually} use, +#' which is not necessarily the one this function requested (several entries, +#' semicolon-separated, if brms resolved the axes differently); loo, looic, #' convergence_ok, #' convergence_diagnostics). The raw brmsfit is in \code{$engine}. #' @family model fitting @@ -357,9 +390,29 @@ fit_bayesian_spatial_model <- function( # coordinates do not look like lon/lat, so this is not an unconditional # guarantee. Set the CRS on `data_sf` if a projected fit matters. + # `..x` and `..y` are this function's own reserved names: they are the + # columns handed to brms::gp() and the ones predict()/fitted() rebuild from + # $info$coord_scaling. A data column already using either name survives the + # cbind() below as a DUPLICATE, and both dat_df[["..x"]] and brms's + # gp(..x, ..y) then resolve to the user's column -- so the GP is fitted over + # arbitrary data while $info$coord_scaling records the transform that was + # never applied, and predict time writes a different `..x` than was fitted. + # Nothing downstream can detect this, so refuse it here. + reserved <- intersect(c("..x", "..y"), names(sf::st_drop_geometry(dat_sf))) + if (length(reserved) > 0L) + stop(sprintf(paste0("fit_bayesian_spatial_model(): column(s) %s in ", + "`data_sf` collide with the reserved names this ", + "function gives the scaled coordinates it hands to ", + "brms::gp(). Rename them (they would otherwise be ", + "silently used as the GP's coordinates in place of the ", + "geometry)."), + paste(sQuote(reserved), collapse = ", ")), + call. = FALSE) + coords <- sf::st_coordinates(dat_sf) if (!all(c("X", "Y") %in% colnames(coords))) colnames(coords)[1:2] <- c("X", "Y") - + + # Per-axis (anisotropic) standardization: each coordinate is centered and # divided by its own SD. This means the GP kernel is isotropic in the # *scaled* space but anisotropic in the original CRS whenever sd(X) != sd(Y). @@ -419,17 +472,21 @@ fit_bayesian_spatial_model <- function( stop("fit_bayesian_spatial_model(): `gp_c` must be a single finite number > 1.", call. = FALSE) gp_k <- as.integer(gp_k) - if (gp_c < 1.2) + if (gp_c < 1.25) .log_warn( - paste0("fit_bayesian_spatial_model(): gp_c = %.2f is below the minimum of ", - "1.2 recommended for the squared-exponential kernel; the GP ", - "boundary may truncate the domain."), + paste0("fit_bayesian_spatial_model(): gp_c = %.2f is below 1.25, the ", + "boundary factor brms itself defaults to (c = 5/4) and the floor ", + "this package derives; the GP boundary may truncate the domain. ", + "Note brms multiplies c by the full range of the centred ", + "coordinates, not the half-range."), gp_c ) # Smallest length-scale this (k, c) pair can resolve -- the inversion of - # m >= 1.75 * c / (ell/S). Reported here and re-checked against the - # posterior after fitting. + # m >= 1.75 * L / ell with L = c * S. gp_spec$S is brms's own domain + # measure (the pooled range of the centred coordinates), so this is the + # 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 .log_info( paste0("fit_bayesian_spatial_model(): GP basis k = %d per dimension, ", @@ -554,7 +611,42 @@ fit_bayesian_spatial_model <- function( ) } - ls_prior <- brms::set_prior(lscale_prior_spec, class = "lscale") + # Attach the prior at COEFFICIENT level, not globally. + # + # brms::set_prior(spec, class = "lscale") with no `coef` is a *global* + # prior, and brms only applies a global prior to coefficients that have no + # individual prior of their own. Every lscale coefficient always does -- + # brms assigns each one a default inv_gamma() -- so the calibrated prior + # was silently dropped with the note "The global prior ... of class + # 'lscale' will not be used in the model as all related coefficients have + # individual priors already", and Stan received brms's defaults. That made + # gp_lengthscale_bounds(), .lscale_invgamma(), the tail calibration and the + # %.10g guard all dead weight, and $info$gp_lscale_prior asserted a prior + # the model did not have. (A global class = "b" prior does stick, because + # brms's `b` defaults are flat; the asymmetry is specific to lscale.) + # + # The coefficient names are read back from brms rather than hard-coded: + # they embed the covariate names ("gp..x..y..x", "gp..x..y..y") and the + # count depends on `iso`, so deriving them is the only version-safe way. + ls_coefs <- tryCatch({ + gp_def <- brms::get_prior(fml, data = dat_df, family = family) + gp_def$coef[gp_def$class == "lscale" & nzchar(gp_def$coef)] + }, error = function(e) character(0)) + + ls_prior <- if (length(ls_coefs) > 0L) { + Reduce(`+`, lapply(ls_coefs, function(k) + brms::set_prior(lscale_prior_spec, class = "lscale", coef = k))) + } else { + # No lscale coefficient to attach to (a brms that names them + # differently, or a formula with no GP term). Fall back to the global + # form: it may be ignored, but it is the only thing left to say. + .log_warn(paste0("fit_bayesian_spatial_model(): brms reported no ", + "coefficient-level 'lscale' priors for this formula, so ", + "the calibrated length-scale prior is attached globally ", + "and brms may not use it. Check $info$gp_lscale_prior ", + "against brms::make_stancode().")) + brms::set_prior(lscale_prior_spec, class = "lscale") + } prior <- if (is.null(prior)) ls_prior else prior + ls_prior } else { .log_info( @@ -562,6 +654,30 @@ fit_bayesian_spatial_model <- function( ) } + # Record the prior brms will actually use, not the one that was requested. + # validate_prior() resolves globals against coefficient-level defaults and + # returns the full table brms hands to Stan, so reading the lscale rows back + # out of it is the only way $info$gp_lscale_prior can be trusted. On any + # failure the requested spec is kept and said to be unverified. + gp_lscale_prior_used <- lscale_prior_spec + vp <- tryCatch( + suppressWarnings(brms::validate_prior(prior, formula = fml, data = dat_df, + family = family)), + error = function(e) NULL + ) + if (!is.null(vp) && is.data.frame(vp) && all(c("class", "coef", "prior") %in% names(vp))) { + used <- unique(vp$prior[vp$class == "lscale" & nzchar(vp$coef) & + nzchar(vp$prior)]) + if (length(used) > 0L) { + gp_lscale_prior_used <- paste(used, collapse = "; ") + if (!is.null(lscale_prior_spec) && !all(used == lscale_prior_spec)) + .log_warn(paste0("fit_bayesian_spatial_model(): brms resolved the GP ", + "length-scale prior to %s, not the requested %s. ", + "$info$gp_lscale_prior records what brms will use."), + gp_lscale_prior_used, lscale_prior_spec) + } + } + brm_args <- list( formula = fml, data = dat_df, family = family, prior = prior, chains = chains, iter = iter, warmup = warmup, cores = cores, @@ -598,15 +714,22 @@ fit_bayesian_spatial_model <- function( }, error = function(e) NULL) if (!is.null(rhat_vals)) { - max_rhat <- max(rhat_vals, na.rm = TRUE) + # 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. + 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)[rhat_vals > 1.05] + bad_rhat <- names(rhat_vals)[which(rhat_vals > 1.05)] if (length(bad_rhat) > 0L) { convergence_ok <- FALSE .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(head(bad_rhat, 5), collapse = ", ") + paste(utils::head(bad_rhat, 5), collapse = ", ") ) } } @@ -618,15 +741,20 @@ fit_bayesian_spatial_model <- function( }, error = function(e) NULL) if (!is.null(neff_vals)) { - min_neff <- min(neff_vals, na.rm = TRUE) + # 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 + # NA names, and min() is guarded so an all-NaN vector reports NA rather + # than +Inf. + 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)[neff_vals < 0.1] + low_neff <- names(neff_vals)[which(neff_vals < 0.1)] 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(head(low_neff, 5), collapse = ", ") + paste(utils::head(low_neff, 5), collapse = ", ") ) } } @@ -693,7 +821,7 @@ fit_bayesian_spatial_model <- function( gp_k = gp_k, gp_c = gp_c, gp_iso = gp_iso, - gp_lscale_prior = lscale_prior_spec, + gp_lscale_prior = gp_lscale_prior_used, gp_n_basis = gp_k^2, gp_ell_min = gp_ell_min, gp_lengthscale_bounds = ls_bounds, diff --git a/R/model-classes.R b/R/model-classes.R index 31759be..c36e0f2 100644 --- a/R/model-classes.R +++ b/R/model-classes.R @@ -4,9 +4,23 @@ #' Build a spatial_fit S3 object #' -#' Low-level constructor used by \code{fit_gwr_model()}, -#' \code{fit_bayesian_spatial_model()} and \code{fit_rf_model()}. Users should -#' not call this directly. +#' The constructor for the \code{spatial_fit} class, and the public entry point +#' for plugging your own model backend into this package. The three built-in +#' fitters -- \code{\link{fit_gwr_model}()}, +#' \code{\link{fit_bayesian_spatial_model}()} and \code{\link{fit_rf_model}()} +#' -- all end by calling it, and so should a custom \code{fit_fn} written for +#' \code{\link{cv_spatial}()}: wrapping your model in a \code{spatial_fit} is +#' what lets it use the package's folds, metrics, comparison and +#' area-of-applicability machinery unchanged. +#' +#' There are two obligations. Return an object built here from your +#' \code{fit_fn}, and define a \code{predict()} method for the \code{subclass} +#' you chose -- \code{\link{cv_spatial}()} scores folds by calling the +#' \code{predict()} generic on the fit, so without a matching +#' \code{predict.()} every fold fails. Methods for +#' \code{\link{fitted}()}, \code{\link{residuals}()} and \code{\link{coef}()} +#' are optional; supply them if you want the corresponding helpers to work on +#' your fits too. #' #' @section The coef() contract: #' \code{coef()} on a \code{spatial_fit} either returns the coefficients or @@ -19,14 +33,62 @@ #' shorter answer than the caller expected. Wrap in \code{try()} or #' \code{tryCatch()} when sweeping over a heterogeneous list of fits. #' -#' @param subclass Character scalar: "gwr_fit", "bayesian_fit" or "rf_fit". -#' @param engine The raw model object. +#' @param subclass Character scalar naming the class to stamp on the object: +#' one of the built-ins \code{"gwr_fit"}, \code{"bayesian_fit"} or +#' \code{"rf_fit"}, or any name of your own for a custom backend (say +#' \code{"lm_fit"}). It is the S3 dispatch key: \code{predict()}, +#' \code{fitted()}, \code{residuals()} and \code{coef()} on the result all +#' dispatch on it, so a custom \code{subclass} \strong{requires} a matching +#' \code{predict.()} method to be usable with +#' \code{\link{cv_spatial}()}. +#' @param engine The raw model object your backend produced (an \code{lm}, +#' a \code{ranger} object, a \code{brmsfit}, ...). Nothing inspects it +#' except your own methods. #' @param formula A formula. #' @param response_var Character(1). #' @param predictor_vars Character vector. #' @param data_sf An sf object used for fitting. -#' @param info Named list of model-specific extras. +#' @param info Named list of model-specific extras. Set +#' \code{fitted_are_oob = TRUE} if your \code{fitted()} values are held out +#' rather than in-sample, so \code{summary()} labels them honestly. #' @return An object of class \code{c(subclass, "spatial_fit")}. +#' @seealso \code{\link{cv_spatial}()}, which consumes a custom \code{fit_fn}; +#' \code{\link{fit_rf_model}()} for a worked built-in fitter. +#' @family model fitting +#' @examples +#' library(sf) +#' set.seed(1) +#' n <- 80 +#' site <- st_as_sf( +#' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), +#' coords = c("x", "y"), crs = 32632 +#' ) +#' site$price <- 10 + 0.01 * st_coordinates(site)[, 1] + 2 * site$elev + rnorm(n) +#' +#' # A custom backend: an ordinary linear model behind the spatial_fit interface. +#' lm_fit <- function(train_sf) { +#' new_spatial_fit( +#' subclass = "lm_fit", +#' engine = lm(price ~ elev, st_drop_geometry(train_sf)), +#' formula = price ~ elev, +#' response_var = "price", +#' predictor_vars = "elev", +#' data_sf = train_sf +#' ) +#' } +#' +#' # Required: cv_spatial() scores each fold through the predict() generic, +#' # which dispatches on the subclass named above. +#' predict.lm_fit <- function(object, newdata = NULL, ...) { +#' if (is.null(newdata)) newdata <- object$data_sf +#' as.numeric(stats::predict(object$engine, st_drop_geometry(newdata))) +#' } +#' registerS3method("predict", "lm_fit", predict.lm_fit) +#' +#' cv <- cv_spatial(site, "price", "elev", fit_fn = lm_fit, k = 3, seed = 1) +#' cv$overall +#' # Always check these two agree before trusting the metrics above. +#' c(attempted = cv$n_folds_attempted, succeeded = cv$n_folds_succeeded) #' @export new_spatial_fit <- function(subclass, engine, formula, response_var, predictor_vars, data_sf, info = list()) { @@ -48,12 +110,55 @@ new_spatial_fit <- function(subclass, engine, formula, response_var, obj } +#' Fetch fitted() from a spatial_fit and check it against the fit's own n +#' +#' \code{new_spatial_fit()} is the documented extension point, so a subclass +#' whose \code{fitted()} method is missing or returns the wrong length is +#' user-reachable -- and nothing downstream notices. With no method at all, +#' \code{stats::fitted()} finds \code{object$fitted} (absent) and returns +#' \code{NULL}, so \code{.compute_reg_metrics()} reports \code{n = 0} and +#' all-\code{NA}; with a method returning 60 values for 120 rows, the metric +#' code drops the pairs it cannot align and reports the fit's \code{n = 120} +#' against all-\code{NA} numbers -- a plausible row count over a silently +#' mis-indexed comparison. \code{.cv_run_folds()} guards exactly this on the +#' prediction side; these two paths did not. +#' +#' @param object A \code{spatial_fit}. +#' @param .caller Name used in the error message. +#' @return \code{fitted(object)}, guaranteed to be length \code{object$n}. +#' @keywords internal +#' @noRd +.fitted_checked <- function(object, .caller = "model_metrics") { + fit_vals <- fitted(object) + n_exp <- object$n + if (is.null(fit_vals) || length(fit_vals) != n_exp) + stop(sprintf(paste0("%s(): fitted() returned %s for a fit of %d ", + "observation(s). Define a fitted.%s() method that ", + "returns one value per row of the fit's `data_sf`, in ", + "the same order (see ?new_spatial_fit)."), + .caller, + if (is.null(fit_vals)) "NULL" + else sprintf("%d value(s)", length(fit_vals)), + n_exp, class(object)[1L]), + call. = FALSE) + fit_vals +} + + # --------------------------------------------------------------------------- # print / summary # --------------------------------------------------------------------------- #' Print a fitted spatial model #' +#' Shows the one-screen summary of any \code{spatial_fit}: backend, formula, +#' number of observations, CRS, and the few backend-specific numbers worth +#' seeing immediately (GWR bandwidth, GP basis size, 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. +#' #' @param x A \code{spatial_fit} object. #' @param ... Ignored. #' @return \code{x}, invisibly (called for its side effect). @@ -116,7 +221,7 @@ print.spatial_fit <- function(x, ...) { #' data.frame, out-of-bag for an \code{rf_fit}). #' @export summary.spatial_fit <- function(object, ...) { - fit_vals <- fitted(object) + fit_vals <- .fitted_checked(object, .caller = "summary") y_obs <- sf::st_drop_geometry(object$data_sf)[[object$response_var]] # GWR fits locally varying coefficients at every observation, so the # global predictor count is not a valid effective-parameter count for @@ -166,6 +271,19 @@ print.summary.spatial_fit <- function(x, ...) { #' Compute goodness-of-fit metrics for a spatial model #' +#' Reports RMSE, MAE, MAPE, SMAPE, \eqn{R^2} and adjusted \eqn{R^2} for any +#' \code{spatial_fit}, in one row and on one scale, so that fits from different +#' backends can be read side by side. Reach for it to score a model on data you +#' hold out yourself (pass it as \code{newdata}), or to get a quick in-sample +#' reading of how closely a fit tracks its training data. +#' +#' It is not a substitute for cross-validation. With \code{newdata = NULL} the +#' numbers are in-sample for a \code{gwr_fit} or \code{bayesian_fit} -- and a +#' GWR can reach a near-perfect in-sample \eqn{R^2} at a small bandwidth +#' without predicting anything. For a figure you can report, use +#' \code{\link{cv_gwr}()}, \code{\link{cv_bayes}()}, \code{\link{cv_rf}()} +#' or \code{\link{compare_models_cv}()}. +#' #' @section What the metrics are computed on: #' With \code{newdata = NULL} the metrics come from \code{fitted(object)}. #' That is \strong{in-sample} for a \code{gwr_fit} or a \code{bayesian_fit}, @@ -190,7 +308,7 @@ model_metrics <- function(object, ...) UseMethod("model_metrics") #' @export model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { if (is.null(newdata)) { - y_hat <- fitted(object) + y_hat <- .fitted_checked(object, .caller = "model_metrics") y_obs <- sf::st_drop_geometry(object$data_sf)[[object$response_var]] } else { if (!(object$response_var %in% names(newdata))) @@ -326,7 +444,18 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { ) ), error = function(e) { + # 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. The + # commonest cause is a factor or character predictor: gwr.basic() expands + # contrasts via model.matrix() and fits, gwr.predict() does not and fails + # here. fit_gwr_model() now rejects those at fit time, so reaching this + # generally means the fit was built by other means. .log_warn("predict.gwr_fit(): gwr.predict() failed: %s", conditionMessage(e)) + warning(sprintf(paste0("predict.gwr_fit(): GWmodel::gwr.predict() ", + "failed, so every prediction is NA. Cause: %s"), + conditionMessage(e)), call. = FALSE) NULL } ) @@ -552,8 +681,26 @@ fitted.gwr_fit <- function(object, ...) { #' survives R's copy-on-modify). The cache holds epred column means only, #' which is why \code{predict(object, summary = "median")} and #' \code{predict(object, type = "predict")} recompute rather than reuse it. -#' Call \code{\link{clear_fitted_cache}} if the engine or the training data has -#' been mutated by hand after fitting. +#' Call \code{\link{clear_fitted_cache}} if the engine has been mutated by hand +#' after fitting. +#' +#' @section The cache is shared by copies, and validated: +#' An environment has reference semantics, which is what makes the memo survive +#' R's copy-on-modify -- but it also means \code{fit2 <- fit} gives the two +#' objects \emph{the same} cache. Assigning a different \code{data_sf} to the +#' copy would then have returned the original's cached values, at the original's +#' length, which \code{residuals()} silently recycled against the copy's shorter +#' response. The entry therefore carries the \code{n} and a digest of the +#' training data it was computed from, and is recomputed whenever either fails +#' to match, so a copy with different data recomputes instead of reading the +#' original's answer. +#' +#' Two consequences of the shared environment remain and cannot be removed from +#' here: \code{\link{clear_fitted_cache}} on one copy empties the cache both +#' share (harmless -- the other simply recomputes), and \code{identical()} +#' cannot distinguish two fits by their caches. The digest covers +#' \code{data_sf} only, not \code{$engine}: a hand-mutated \code{brmsfit} is +#' what \code{\link{clear_fitted_cache}} is for. #' #' @param object A \code{bayesian_fit}. #' @param ... Ignored. @@ -565,11 +712,21 @@ fitted.bayesian_fit <- function(object, ...) { # summary(), residuals(), model_metrics(), and compare_models() all # call fitted() independently. Caching avoids redundant passes. # The cache lives in an environment (reference semantics) so it - - # persists even though R lists are copy-on-modify. + # persists even though R lists are copy-on-modify -- and, for the same + # reason, is SHARED by every copy of the fit. See the @section above: + # the entry is stamped with the n and a digest of the data it was + # computed from, and anything that does not match is recomputed. cache <- object$info$.cache + key <- .fitted_cache_key(object) if (!is.null(cache) && exists(".fitted_values", envir = cache, inherits = FALSE)) { - return(get(".fitted_values", envir = cache, inherits = FALSE)) + hit <- get(".fitted_values", envir = cache, inherits = FALSE) + if (is.list(hit) && identical(hit$n, object$n) && + identical(hit$key, key) && + is.numeric(hit$values) && length(hit$values) == object$n) + return(hit$values) + # Stale (a copy carrying different data, or an entry written by an older + # version of this package). Drop it rather than returning it. + rm(list = ".fitted_values", envir = cache) } if (!requireNamespace("brms", quietly = TRUE)) @@ -584,21 +741,57 @@ fitted.bayesian_fit <- function(object, ...) { fitted_vals <- colMeans(draws) - # Store in cache for subsequent calls - if (!is.null(cache)) { - assign(".fitted_values", fitted_vals, envir = cache) + # Store in cache for subsequent calls, stamped so a copy carrying different + # data cannot read it back. A wrong-length result is never cached. + if (!is.null(cache) && length(fitted_vals) == object$n) { + assign(".fitted_values", + list(n = object$n, key = key, values = fitted_vals), + envir = cache) } fitted_vals } +#' Cheap fingerprint of the training data a cached fitted() was computed from +#' +#' Covers exactly what \code{.prepare_brms_pred_df()} reads: the attribute +#' columns and the coordinates. \code{$engine} is deliberately excluded -- +#' digesting a \code{brmsfit} with all its draws would cost more than the +#' posterior pass the cache exists to avoid, and a hand-mutated engine is what +#' \code{\link{clear_fitted_cache}} is for. Returns \code{NA_character_} if a +#' digest cannot be taken, which still fingerprints consistently (a stored +#' \code{NA} matches a computed \code{NA}), leaving the \code{n} and length +#' checks as the guard. +#' +#' @param object A \code{spatial_fit}. +#' @return A length-one character. +#' @keywords internal +#' @noRd +.fitted_cache_key <- function(object) { + tryCatch( + digest::digest(list( + n = object$n, + data = sf::st_drop_geometry(object$data_sf), + coords = unname(sf::st_coordinates(object$data_sf)) + )), + error = function(e) NA_character_ + ) +} + + #' Clear cached fitted values for a Bayesian spatial model #' #' Removes the lazily-cached \code{fitted()} result so that the next call #' recomputes from the posterior. This is only necessary if the underlying -#' \code{brmsfit} engine or training data has been manually mutated after -#' fitting — normal usage never requires it. +#' \code{brmsfit} engine has been manually mutated after fitting -- a change to +#' \code{data_sf} invalidates the entry on its own, because the cached value +#' carries a digest of the data it was computed from (see +#' \code{\link{fitted.bayesian_fit}}). Normal usage never requires it. +#' +#' The cache environment is shared by every copy of a fit, so clearing it +#' through one copy clears it for all of them. That is harmless: the others +#' recompute. #' #' @param object A \code{bayesian_fit} object. #' @return \code{object}, invisibly (called for side effect). @@ -652,9 +845,33 @@ residuals.bayesian_fit <- function(object, ...) { #' Extract GWR local coefficients #' +#' Returns the whole surface of coefficients -- one row per observation, one +#' column per term -- rather than the single global vector \code{coef()} +#' returns for an \code{lm}. That table is the point of fitting a GWR at all: +#' inspect the spread of a predictor's column to see where, and by how much, +#' its relationship with the response changes across the study area, and join +#' it back to \code{object$data_sf} to map it. Use +#' \code{\link{plot.spatial_fit}()} for a quick look at that map. +#' +#' @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 +#' (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 +#' names its coefficient columns differently -- the whole slot is returned with +#' a warning saying so, rather than an error or a silently short table. +#' #' @param object A \code{gwr_fit} object. #' @param ... Ignored. -#' @return A data.frame of local coefficient estimates (one row per obs). +#' @return A data.frame of local coefficient estimates: one row per +#' observation, one column per model term. #' 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}}. @@ -666,12 +883,52 @@ coef.gwr_fit <- function(object, ...) { if (is.null(sdf)) stop("coef.gwr_fit(): the fit carries no GWmodel `SDF` component, so the ", "local coefficients cannot be extracted.", call. = FALSE) - if (inherits(sdf, "Spatial")) sdf@data else sf::st_drop_geometry(sdf) + dat <- if (inherits(sdf, "Spatial")) sdf@data else sf::st_drop_geometry(sdf) + + # Keep only the model terms. gwr.basic()'s 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 + # 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( + colnames(stats::model.matrix(object$formula, + data = sf::st_drop_geometry(object$data_sf))), + error = function(e) NULL + ) + .norm <- function(x) tolower(gsub("[^[:alnum:]_.]", "", x)) + if (!is.null(want) && length(want) > 0L) { + sdf_n <- .norm(names(dat)) + pos <- integer(0) + for (w in .norm(want)) { + 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]) + .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 ", + "returned instead of the coefficients alone. Columns such ", + "as *_SE, *_TV, residual and Local_R2 are diagnostics, ", + "not coefficients."), + length(pos), length(want)) + } + dat } #' Extract Bayesian model fixed-effect summaries #' +#' Returns the posterior summary of the global (non-spatial) regression terms: +#' estimate, error and credible interval per predictor, as +#' \code{brms::fixef()} reports them. Reach for it to read the average effect +#' of a predictor with its uncertainty attached -- the Bayesian counterpart to +#' a coefficient table -- remembering that the Gaussian-process term has +#' already absorbed the spatially structured part of the signal, so these are +#' effects net of location. +#' #' @param object A \code{bayesian_fit} object. #' @param ... Ignored. #' @return A matrix of fixed-effect posterior summaries, as returned by diff --git a/R/model-gwr.R b/R/model-gwr.R index e9a8c96..a8ffe9c 100644 --- a/R/model-gwr.R +++ b/R/model-gwr.R @@ -7,6 +7,17 @@ #' GWmodel accepts kernel names as character strings directly (unlike spgwr #' which required function objects). #' +#' \strong{Currently unreachable.} Every entry point that takes a kernel -- +#' \code{fit_gwr_model()}, \code{gwr_model_selection()} and \code{cv_gwr()} -- +#' declares it as a \code{c("bisquare", ...)} default and runs +#' \code{match.arg()} on it, which rejects any value this function would have +#' to repair. \code{cv_gwr()} (R/cross-validation.R) is its only caller and +#' calls it on the line \emph{after} its own \code{match.arg()}, so the +#' fallback branch below cannot execute. It is kept, rather than deleted, +#' only because that caller lives in another file; if the redundant call there +#' is removed, remove this too. Do not add a comment anywhere claiming it +#' "earns its keep" in \code{cv_gwr()} -- it does not. +#' #' @param kernel Character scalar. #' @return The validated kernel string. #' @keywords internal @@ -123,10 +134,39 @@ # Strategy 1: direct prediction/fitted column. # GWmodel::gwr.basic stores fitted values in "yhat"; # gwr.predict may use "prediction" or the response name. + # + # Two properties of this search are load-bearing. + # + # (a) It runs in PREFERENCE order, not in the SDF's column order. + # gwr.basic's SDF is c(colnames(betas), "y", "yhat", "residual", ...), + # so the local COEFFICIENTS come first. Matching the whole name vector + # with %in% and taking hit[1] therefore picked whichever candidate name + # the DATA happened to list earliest: with a predictor called `fit`, + # `pred`, `prediction`, `fitted` or `yhat`, that is the coefficient + # surface for that predictor, not the fitted values. + # + # (b) Any candidate that is also a model term is excluded outright. In + # gwr.basic's SDF such a column is certainly a coefficient surface; in + # gwr.predict's it is suffixed "_coef" and would not match anyway. + # + # The failure this prevents is silent: fitted() returned a coefficient + # column, the in-sample R2 went negative, and residuals(), summary(), + # model_metrics(), compare_models() and every cv_gwr() fold consumed it + # without a warning. pred_col_names <- c("yhat", "pred", "prediction", "fitted", "fit") - hit <- names(sdf_data)[tolower(names(sdf_data)) %in% pred_col_names] - if (length(hit) >= 1L) { - vals <- suppressWarnings(as.numeric(sdf_data[[hit[1]]])) + sdf_lower <- tolower(names(sdf_data)) + model_terms <- tolower(c(response_var, all.vars(formula)[-1L], + "Intercept", "(Intercept)")) + hit <- NULL + for (cand in pred_col_names) { + idx <- which(sdf_lower == cand & !(sdf_lower %in% model_terms)) + if (length(idx) >= 1L) { hit <- idx[[1L]]; break } + } + if (!is.null(hit)) { + # Index positionally: an SDF can carry two columns of the same name (a + # predictor named "yhat" alongside gwr.basic's own), and [[]] would + # silently take the first. + vals <- suppressWarnings(as.numeric(sdf_data[[hit]])) if (length(vals) == n && any(is.finite(vals))) return(vals) } @@ -280,9 +320,10 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, if (!requireNamespace("sp", quietly = TRUE)) stop("fit_gwr_model(): package 'sp' is required (for GWmodel interop).", call. = FALSE) - # match.arg() has already rejected every invalid value, so .validate_kernel() - # would be a no-op here; it earns its keep in cv_gwr(), where `kernel` - # arrives unvalidated. + # match.arg() is the whole of kernel validation: an invalid value never gets + # past it. (.validate_kernel() below is called by cv_gwr() but only ever + # after that function's own match.arg(), so it is unreachable there too -- + # see its @noRd block.) kernel <- match.arg(kernel) # prep_model_data() accepts character(0) so an intercept-only spatial GP can @@ -327,7 +368,40 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, predictor_vars = predictor_vars, pointize = "auto" ) } - + + # Require plain POINT, mirroring fit_bayesian_spatial_model(), and for the + # same reason: st_coordinates() on a multi-vertex MULTIPOINT or a POLYGON + # returns one row per VERTEX, so the local-collinearity spot-check below + # would index `coords[si, ]` against a matrix that no longer has one row per + # observation. prep_model_data() coerces to POINT, so this only fires for + # `.already_prepped = TRUE` callers handing over unprepped geometry. + gtypes <- as.character(sf::st_geometry_type(dat, by_geometry = TRUE)) + if (!all(gtypes == "POINT")) + stop("fit_gwr_model(): geometry must be POINT after prep. ", + "Run prep_model_data() (or coerce_to_points()) first.", call. = FALSE) + + # GWmodel fits and predicts through two different code paths, and only one + # of them expands contrasts: gwr.basic() builds its design with + # model.matrix(), so a factor predictor fits cleanly, while gwr.predict() + # indexes the prediction frame by the raw variable names and multiplies the + # result, which for a factor column is "non-numeric argument to binary + # operator". predict.gwr_fit() catches that and returns all NA, so the + # model appears to fit and then silently predicts nothing. Reject the + # column here instead, where it can be named. + non_num <- predictor_vars[ + !vapply(sf::st_drop_geometry(dat)[, predictor_vars, drop = FALSE], + is.numeric, logical(1))] + if (length(non_num) > 0L) + stop(sprintf(paste0("fit_gwr_model(): predictor(s) %s are not numeric. ", + "GWmodel fits a factor or character predictor (via ", + "model.matrix contrasts) but cannot predict from it ", + "-- gwr.predict() does not expand contrasts and would ", + "return all NA. Encode the column as numeric indicator ", + "column(s) yourself, and pass those as predictors."), + paste(sQuote(non_num), collapse = ", ")), + call. = FALSE) + + # Warn or error if response looks non-continuous. # Gaussian GWR assumes a continuous response; binary data should error. # @@ -337,6 +411,17 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # (0 unique values)" and a constant response as "binary (1 unique value)", # while a genuinely binary non-integer response (1.5 / 2.5) failed the # integer-like gate and passed unremarked. + # + # REGRESSION NOTE: the two-distinct-value error is gated on `is_integer_like` + # and must stay that way. "Exactly two distinct finite values" is NOT the + # same thing as "binary": a left-censored or saturated measurement (every + # observation at a detection limit, say 0.0031, or at a ceiling, 12.7401) has + # two distinct values and is perfectly continuous -- Gaussian GWR on it is a + # well-defined least-squares problem, and the error's advice to switch to + # family = "binomial" is nonsense for such values. The guard also runs once + # per fold inside cv_gwr(), where a small training fold can legitimately hold + # only two distinct values. Non-integer 2-valued responses therefore take + # the warning path below, not a hard stop. resp_vals <- sf::st_drop_geometry(dat)[[response_var]] if (is.numeric(resp_vals)) { usable <- resp_vals[is.finite(resp_vals)] @@ -358,16 +443,26 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, call. = FALSE ) } - if (n_unique == 2L) { + + is_integer_like <- all(usable == round(usable)) + if (n_unique == 2L && is_integer_like) { stop( sprintf("fit_gwr_model(): response '%s' is binary (2 distinct values: %s). Gaussian GWR is invalid for binary outcomes. Consider GWmodel::ggwr.basic() with family = 'binomial'.", response_var, paste(format(sort(uniq)), collapse = ", ")), call. = FALSE ) } - - is_integer_like <- all(usable == round(usable)) - if (is_integer_like && n_unique <= 10L) { + if (n_unique == 2L) { + # Reached only when the response is NOT integer-like (the integer-like + # case stopped above). Two distinct non-integer values is the signature + # of a censored or saturated measurement, which is continuous: fit it, + # but say that the design is degenerate. + warning( + sprintf("fit_gwr_model(): response '%s' has only 2 distinct finite values (%s). The fit is a well-defined least-squares problem, but check that the response is genuinely continuous (e.g. censored at a detection limit) rather than a coded category; if it is categorical, use GWmodel::ggwr.basic() with family = 'binomial'.", + response_var, paste(format(sort(uniq)), collapse = ", ")), + call. = FALSE + ) + } else if (is_integer_like && n_unique <= 10L) { warning( sprintf("fit_gwr_model(): response '%s' is integer-valued with only %d unique values. Gaussian GWR assumes a continuous response; results may be unreliable for counts or ordinal outcomes.", response_var, n_unique), @@ -471,33 +566,39 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # --- Bandwidth selection --- bandwidth_is_fallback <- FALSE + bw_fallback_raw <- NA_real_ 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( - suppressWarnings( + .gwr_quietly(suppressWarnings( GWmodel::bw.gwr(fml, data = sp_dat, approach = "AICc", kernel = kernel, adaptive = adaptive) - ), + )), error = function(e) { .log_warn("fit_gwr_model(): bw.gwr() failed: %s", conditionMessage(e)) NA_real_ } ) - - if (!is.finite(bw) || is.na(bw) || bw <= 0) { + + # 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. + if (length(bw) != 1L || !is.numeric(bw) || !is.finite(bw) || bw <= 0) { bw <- .fallback_bandwidth(sp_dat, adaptive) bandwidth_is_fallback <- TRUE - warning( - sprintf( - "fit_gwr_model(): automatic bandwidth selection failed; using arbitrary fallback bandwidth = %.4f. This fallback has no relationship to the data's spatial structure and may produce a poor fit. Consider supplying an explicit `bandwidth` argument.", - bw - ), - call. = FALSE - ) + bw_fallback_raw <- as.numeric(bw) } } else { bw <- as.numeric(bandwidth) } - + # Clamp bandwidth to safe range if (adaptive) { bw <- as.integer(round(bw)) @@ -510,7 +611,31 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } if (bw > max_bw) bw <- max_bw } - + + # The fallback warning is issued AFTER the clamp, not before it. The clamp + # can move the value -- a 6-row dataset clamps the arbitrary 10 down to 6 -- + # 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) { + bw_used <- as.numeric(bw) + warning( + sprintf( + paste0("fit_gwr_model(): automatic bandwidth selection failed; using ", + "arbitrary fallback bandwidth = %.4f%s. This fallback has no ", + "relationship to the data's spatial structure and may produce ", + "a poor fit. Consider supplying an explicit `bandwidth` ", + "argument."), + bw_used, + if (isTRUE(bw_used == bw_fallback_raw)) "" + else sprintf(" (derived as %.4f, then clamped for %d observation(s) and %d parameter(s))", + bw_fallback_raw, n_obs, n_params) + ), + call. = FALSE + ) + } + + # --- Fit GWR --- fit <- tryCatch( GWmodel::gwr.basic(formula = fml, data = sp_dat, bw = bw, diff --git a/R/model-prep.R b/R/model-prep.R index 3b0a130..49df965 100644 --- a/R/model-prep.R +++ b/R/model-prep.R @@ -44,21 +44,29 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, "centroid", "line_midpoint", "bbox_center"), require_response = TRUE) { + # call. = FALSE on every one of these, as elsewhere in the package: these are + # argument-validation messages, and the call frame R would otherwise append + # is an internal one the user did not write (prep_model_data() is reached + # through fit_gwr_model(), the CV internals and every predict() method), so + # printing it buries the message that names the actual problem. if (!inherits(data_sf, "sf")) - stop("prep_model_data(): 'data_sf' must be an sf object.") + stop("prep_model_data(): 'data_sf' must be an sf object.", call. = FALSE) pointize <- match.arg(pointize) if (!is.character(response_var) || length(response_var) != 1L) - stop("prep_model_data(): 'response_var' must be a single column name.") + stop("prep_model_data(): 'response_var' must be a single column name.", + call. = FALSE) # character(0) is allowed: an intercept-only spatial GP is a legitimate # model (see fit_bayesian_spatial_model()). Backends that genuinely need a # predictor reject an empty set themselves, where the message can say why. if (!is.character(predictor_vars)) - stop("prep_model_data(): 'predictor_vars' must be a character vector.") + stop("prep_model_data(): 'predictor_vars' must be a character vector.", + call. = FALSE) req_cols <- if (require_response) c(response_var, predictor_vars) else predictor_vars miss <- setdiff(req_cols, names(data_sf)) if (length(miss)) - stop("prep_model_data(): missing required column(s): ", paste(miss, collapse = ", ")) + stop("prep_model_data(): missing required column(s): ", + paste(miss, collapse = ", "), call. = FALSE) # Coerce unless every geometry is already a plain POINT. MULTIPOINT must # be coerced too: a multi-vertex MULTIPOINT survives st_coordinates() with @@ -164,10 +172,33 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { #' Statistics and Computing 33:1) for the squared-exponential kernel used by #' \code{brms::gp()}: #' \preformatted{ -#' c >= 3.2 * (ell/S), c >= 1.2 +#' c >= 3.2 * (ell/S), c >= 1.25 #' m >= 1.75 * c / (ell/S) #' } -#' where \code{S} is the half-range of the (scaled) coordinate domain. +#' where \code{S} is \strong{the same domain measure \code{brms::gp(c = )} +#' multiplies}, namely the full pooled range of the column-centred coordinates. +#' +#' \strong{Why the range and not the half-range.} Riutort-Mayol et al. state +#' their inequalities against the domain half-range, but both are really +#' constraints on the \emph{boundary} \eqn{L}: contain the longest plausible +#' range (\eqn{L \ge 3.2\,\ell_{upper}}) and resolve the shortest +#' (\eqn{m \ge 1.75\,L/\ell_{lower}}). brms builds that boundary as +#' \preformatted{ +#' choose_L <- function(x, c) c * max(1, max(x) - min(x)) +#' } +#' over the column-centred covariate matrix, pooled across dimensions +#' (\code{brms:::.data_gp()}) -- the FULL range, about twice the per-axis +#' half-range. Deriving \code{c} against the half-range and handing the result +#' to \code{brms::gp()} therefore built a boundary twice as wide as intended: +#' \code{k} was sized for a boundary half the real one, so the GP was +#' systematically under-resolved, and the smallest resolvable length-scale +#' (\code{gp_ell_min}) was understated by the same factor -- making the post-fit +#' adequacy diagnostic, whose whole job is to catch under-resolution, twice too +#' lenient to fire. Working in brms's own units removes both. +#' +#' The floor is \code{1.25} rather than Riutort-Mayol's \code{1.2} because the +#' floor is convention-dependent too: it is brms's own default (\code{c = 5/4}), +#' and on the range convention it is the more generous of the two. #' #' \code{m} is the count PER DIMENSION. brms expands a full tensor grid over #' the GP covariates, so the fitted model carries \code{m^D} basis functions @@ -191,19 +222,28 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { #' per-dimension ceiling is derived from this as \code{floor(sqrt(max_basis))}, #' so there is a single cap rather than two that can contradict each other. #' @return A list with \code{k} (integer, per dimension), \code{c} (numeric), -#' \code{S} (numeric half-range) and \code{capped} (logical). +#' \code{S} (numeric; the pooled full range of the column-centred coordinates, +#' i.e. exactly what \code{brms::gp(c = )} multiplies) and \code{capped} +#' (logical). #' @keywords internal #' @noRd .gp_basis_spec <- function(coords_xy, ls_bounds, k_min = 10L, max_basis = 2500L) { - S <- max(apply(coords_xy, 2, function(z) diff(range(z)) / 2)) + # 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) + Xc <- sweep(xy, 2L, colMeans(xy, na.rm = TRUE)) + S <- suppressWarnings( + max(1, max(Xc, na.rm = TRUE) - min(Xc, na.rm = TRUE))) if (!is.finite(S) || S <= 0) S <- 1 - # Ratios of length-scale to domain half-range. + # Ratios of length-scale to the domain measure brms will use. r_lo <- max(ls_bounds[["lower"]] / S, .Machine$double.eps) # must resolve r_hi <- max(ls_bounds[["upper"]] / S, r_lo) # must contain - c_val <- max(3.2 * r_hi, 1.2) + # 1.25, not 1.2: the floor is stated on the half-range convention by + # Riutort-Mayol et al., and 5/4 is brms's own default on this one. + c_val <- max(3.2 * r_hi, 1.25) k_raw <- ceiling(1.75 * c_val / r_lo) k_max <- as.integer(floor(sqrt(max_basis))) diff --git a/R/model-rf.R b/R/model-rf.R index 5204a70..f73b80a 100644 --- a/R/model-rf.R +++ b/R/model-rf.R @@ -356,6 +356,12 @@ cv_rf <- function(data_sf, response_var, predictor_vars, folds = NULL, k = 5, #' with \code{predict.all} -- are rejected, because this method's contract is #' one number per row of \code{newdata}. Call #' \code{predict(fit$engine, data = ...)} directly for those. +#' \code{seed} defaults to a constant rather than being left unset: an unset +#' \code{seed} makes \code{ranger} draw one uniform from the global RNG +#' stream per call, so the number of \code{predict()} calls a script happens +#' to make (via \code{\link{predict_surface}}'s \code{chunk_size}, say) would +#' otherwise shift every later random draw. It does not affect a regression +#' forest's predictions; pass your own if you need one. #' @return Numeric vector, aligned to \code{nrow(newdata)} with \code{NA} for #' rows dropped as incomplete. #' @export @@ -383,8 +389,23 @@ predict.rf_fit <- function(object, newdata = NULL, ...) { # over -- the added coordinate columns are numeric and simply skipped. X <- .rf_align_levels(X, sf::st_drop_geometry(object$data_sf)) + # Supply a seed unless the caller passed one. + # + # ranger:::predict.ranger.forest does + # if (is.null(seed)) seed <- runif(1, 0, .Machine$integer.max) + # so every seedless predict() draws one uniform from the GLOBAL stream. + # predict_surface() calls predict() once per chunk, which makes + # `chunk_size` -- a pure performance knob that must not change any answer -- + # shift every subsequent random draw in the session: fold assignments + # measurably differ between a script that called predict_surface() and one + # that did not. For a regression forest the seed changes nothing about the + # prediction (it seeds ranger's own RNG, which only quantile/probability + # prediction consumes), so pinning it costs nothing and makes this method + # RNG-neutral. + dots <- list(...) + if (!("seed" %in% names(dots))) dots$seed <- 1L p <- tryCatch( - stats::predict(object$engine, data = X, ...)$predictions, + do.call(stats::predict, c(list(object$engine, data = X), dots))$predictions, error = function(e) { .log_warn("predict.rf_fit(): ranger predict failed: %s", conditionMessage(e)) @@ -430,6 +451,15 @@ fitted.rf_fit <- function(object, ...) { #' Out-of-bag residuals from a random forest fit #' +#' Observed response minus \code{\link{fitted.rf_fit}}, which for a forest is +#' the \strong{out-of-bag} prediction -- each observation predicted only by the +#' trees that did not see it. These are therefore already held-out residuals, +#' unlike \code{residuals.gwr_fit()} and \code{residuals.bayesian_fit()}, +#' which are in-sample. Feed them to \code{\link{residual_morans_i}()} to test +#' whether spatial structure the forest failed to capture is still sitting in +#' the residuals. Out-of-bag is not a substitute for spatial CV: use +#' \code{\link{cv_rf}()} for an honest map-accuracy figure. +#' #' @param object An \code{rf_fit}. #' @param ... Ignored. #' @return Numeric vector of length \code{object$n}. @@ -460,6 +490,12 @@ coef.rf_fit <- function(object, ...) { #' Print a random forest fit #' +#' 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. +#' #' @param x An \code{rf_fit}. #' @param ... Ignored. #' @return \code{x}, invisibly. diff --git a/R/model-selection-gwr.R b/R/model-selection-gwr.R index 6227d97..60b2bf6 100644 --- a/R/model-selection-gwr.R +++ b/R/model-selection-gwr.R @@ -15,17 +15,26 @@ #' Extract the ranking criterion from GWmodel's model-selection diagnostics #' -#' \code{GWmodel::gwr.model.selection()} returns its diagnostics as an -#' unlabelled numeric matrix in some versions and a labelled one in others. -#' The package's own documented usage indexes column 2 for AICc -#' (\code{model.sel[[2]][, 2]}), so that is the fallback; a matching column -#' name is preferred when one is present. +#' \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 +#' (\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 +#' -- 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} and -#' \code{label}. +#' \code{NA}), \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") { @@ -38,7 +47,7 @@ vals <- suppressWarnings(as.numeric(gwr_df)) vals[!is.finite(vals)] <- NA_real_ return(list(values = vals, column = 1L, column_name = NA_character_, - by_name = FALSE, + by_name = FALSE, shape_ok = FALSE, label = sprintf("%s (assumed: unlabelled vector)", criterion))) } @@ -57,8 +66,19 @@ by_name <- TRUE } } - # Fallback: GWmodel's own examples read AICc from column 2. - if (is.na(col)) col <- if (ncols >= 2L) 2L else 1L + # Fallback. GWmodel's GWR.df is documented AND implemented as + # c(bandwidth, AIC, AICc, RSS) + # so AICc lives in column 3. Column 2 is the UNCORRECTED AIC, which + # penalises the effective parameter count more weakly and therefore selects + # larger models -- on a forward sweep it will happily keep a pure-noise + # predictor that AICc drops, which is the failure AICc exists to prevent. + # Anything other than the documented four columns is a shape this code has + # never seen; read the same position but tell the caller to say so. + shape_ok <- TRUE + if (is.na(col)) { + col <- if (ncols >= 3L) 3L else ncols # ncols is 1 or 2 here + shape_ok <- identical(as.integer(ncols), 4L) + } raw <- if (is_df) gwr_df[[col]] else gwr_df[, col] vals <- suppressWarnings(as.numeric(raw)) @@ -74,14 +94,17 @@ else sprintf("%s (assumed: column %d, unlabelled)", criterion, col) list(values = vals, column = col, column_name = col_name, - by_name = by_name, label = label) + by_name = by_name, shape_ok = shape_ok, label = label) } #' Normalise GWmodel's model list into character vectors of predictors #' -#' Handles the three shapes the element can take: \code{list(DeVar, InDeVars)} -#' (what GWmodel returns), a formula, or a bare character vector. +#' Handles the three shapes the element can take: a two-element list of the +#' model's formula \emph{string} and its predictor vector -- which is what +#' GWmodel returns, \code{list(Generate.formula(DeVar, vars), vars)}, i.e. +#' \code{list("z ~ a + b", c("a", "b"))} -- a formula object, or a bare +#' character vector. #' #' @param model_list The first element of the \code{gwr.model.selection()} #' return. @@ -99,7 +122,10 @@ return(setdiff(all.vars(m), response_var)) } if (is.list(m)) { - # GWmodel stores list(DeVar, InDeVars); take the second slot. + # GWmodel stores list(" ~ +", c(v1, v2)) -- the model's + # formula as a STRING in the first slot, the predictor names in the + # second. Take the second slot; the setdiff() below is what keeps a + # first-slot fallback from returning the formula text as a variable name. part <- if (length(m) >= 2L) m[[2L]] else m[[1L]] return(setdiff(as.character(unlist(part, use.names = FALSE)), response_var)) @@ -224,11 +250,20 @@ 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( - GWmodel::bw.gwr(full_fml, data = sp_dat, approach = bw_approach, - kernel = kernel, adaptive = adaptive, dMat = dMat) - ), quiet), + .gwr_quietly(suppressWarnings(do.call(GWmodel::bw.gwr, bw_args)), quiet), error = function(e) { .log_warn("gwr_model_selection(): bw.gwr() failed: %s", conditionMessage(e)) @@ -268,16 +303,42 @@ if (bw > n_obs) bw <- as.integer(n_obs) } + # 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(GWmodel::gwr.model.selection( - DeVar = response_var, InDeVars = candidate_vars, data = sp_dat, - bw = bw, adaptive = adaptive, kernel = kernel, dMat = dMat - ), quiet), + .gwr_quietly(do.call(GWmodel::gwr.model.selection, ms_args), quiet), error = function(e) stop(sprintf("gwr_model_selection(): gwr.model.selection() failed: %s", conditionMessage(e)), call. = FALSE) @@ -379,7 +440,21 @@ #' \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, for \code{GWmodel::gwr.model.view()}). +#' (GWmodel's unmodified return: the two-element list of its model list and +#' its diagnostic table). +#' +#' @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 +#' \preformatted{ +#' GWmodel::gwr.model.view(sel$response_var, sel$candidate_vars, sel$raw[[1]]) +#' } +#' -- \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. #' #' @references #' Lu, B., Harris, P., Charlton, M. and Brunsdon, C. (2014). The GWmodel R @@ -425,9 +500,10 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, if (!is.character(response_var) || length(response_var) != 1L) stop("gwr_model_selection(): `response_var` must be a single column name.", call. = FALSE) - # match.arg() has already rejected every invalid value, so .validate_kernel() - # would be a no-op here; it earns its keep in cv_gwr(), where `kernel` - # arrives unvalidated. + # match.arg() is the only kernel validation this package needs: an invalid + # value never gets past it. (.validate_kernel() in R/model-gwr.R exists and + # is called by cv_gwr(), but only ever *after* that function's own + # match.arg(), so it is unreachable there too -- see its @noRd block.) kernel <- match.arg(kernel) bw_approach <- match.arg(bw_approach) @@ -461,7 +537,11 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, "there is nothing to select among otherwise.", call. = FALSE) p <- length(candidate_vars) - n_models <- as.integer(p * (p + 1L) / 2L) + # as.numeric() before the multiply: p * (p + 1L) is integer arithmetic, which + # overflows to NA (with a warning) above p = 46341, and `NA > max_models` is + # NA -- so the guard that exists to refuse an impossible sweep would itself + # error on the very inputs it is meant to catch. + n_models <- as.numeric(p) * (as.numeric(p) + 1) / 2 if (n_models > max_models) stop(sprintf(paste0("gwr_model_selection(): %d candidates would fit about ", "%d GWR models, above max_models = %d. Screen the ", @@ -481,11 +561,25 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, crit <- .gwr_ms_criterion(eng$gwr_df, criterion = "AICc") 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_warn(paste0("gwr_model_selection(): GWmodel's diagnostic table has no ", - "column named 'AICc'; reading column %d positionally, ", - "which is what GWmodel's own documentation does. Check ", + .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. + if (!isTRUE(crit$shape_ok) && !isTRUE(crit$by_name)) + .log_warn(paste0("gwr_model_selection(): GWmodel's 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]] n_failed <- sum(is.na(tab$criterion)) @@ -519,6 +613,13 @@ 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 -- worth checking before reporting one model as +#' the selected one. +#' #' @param x A \code{gwr_model_selection} object. #' @param n Number of top-ranked models to show. Default 10. #' @param ... Ignored. diff --git a/R/plotting-fits.R b/R/plotting-fits.R index c591682..d13b958 100644 --- a/R/plotting-fits.R +++ b/R/plotting-fits.R @@ -33,18 +33,19 @@ #' @family plotting #' @examples #' \donttest{ -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE) && +#' # Works on any spatial_fit; a forest keeps the example free of the optional +#' # GWR/Stan backends. +#' if (requireNamespace("ranger", quietly = TRUE) && #' requireNamespace("ggplot2", quietly = TRUE)) { #' library(sf) #' set.seed(1) -#' n <- 60 +#' n <- 120 #' pts <- st_as_sf( #' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), #' coords = c("x", "y"), crs = 32632 #' ) #' pts$price <- 10 + 0.01 * st_coordinates(pts)[, 1] + 2 * pts$elev + rnorm(n) -#' fit <- fit_gwr_model(pts, "price", "elev", bandwidth = 30) +#' fit <- fit_rf_model(pts, "price", "elev", num_trees = 100, seed = 1) #' plot(fit, type = "residuals") #' plot(fit, type = "observed_predicted") #' if (requireNamespace("gstat", quietly = TRUE)) diff --git a/R/predict-surface.R b/R/predict-surface.R index ed20a6b..54086be 100644 --- a/R/predict-surface.R +++ b/R/predict-surface.R @@ -94,19 +94,22 @@ #' @family prediction #' @examples #' \donttest{ -#' if (requireNamespace("GWmodel", quietly = TRUE) && -#' requireNamespace("sp", quietly = TRUE)) { +#' # Any spatial_fit works here; a forest keeps the example free of the +#' # optional GWR/Stan backends. +#' if (requireNamespace("ranger", quietly = TRUE)) { #' library(sf) #' set.seed(1) -#' n <- 60 +#' n <- 120 #' pts <- st_as_sf( #' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), #' coords = c("x", "y"), crs = 32632 #' ) #' pts$price <- 10 + 0.01 * st_coordinates(pts)[, 1] + 2 * pts$elev + rnorm(n) -#' fit <- fit_gwr_model(pts, "price", "elev", bandwidth = 30) +#' fit <- fit_rf_model(pts, "price", "elev", num_trees = 100, seed = 1) #' surf <- predict_surface(fit, n_cells = 500, covariates = pts) -#' plot(surf[".pred"]) +#' surf[".pred"] +#' # Check where that surface is extrapolating before mapping it. +#' area_of_applicability(surf, model = fit) #' } #' } #' @export diff --git a/R/seeding.R b/R/seeding.R index 680ad04..9bb3784 100644 --- a/R/seeding.R +++ b/R/seeding.R @@ -10,6 +10,14 @@ #' `method = "kmeans"` and `method = "random"`. **Ignored** for #' `method = "provided"`, where every row of `seeds` is returned; a mismatch #' between `n` and `nrow(seeds)` is reported as a warning. +#' +#' For `method = "kmeans"` it is an upper bound rather than a guarantee: +#' k-means cannot produce more centres than there are distinct positions in +#' the sampling cloud, nor as many centres as there are rows. When `n` +#' exceeds either ceiling it is clamped, with a warning naming the count +#' actually used — `n = nrow(sample_points)` is the common case, and yields +#' `nrow(sample_points) - 1` seeds. Check `nrow()` on the result rather than +#' assuming `n`. #' @param seeds sf POINT object of user-provided seeds (method = "provided"). #' @param sample_points Optional sf POINT cloud for k-means clustering. #' @param kmeans_nstart Integer; nstart for kmeans(). Default 10. @@ -104,11 +112,17 @@ get_voronoi_seeds <- function(boundary = NULL, } xy <- sf::st_coordinates(cloud_for_km) + # Two separate ceilings, both of which stats::kmeans() enforces with a + # raw message the caller cannot act on. `n_uniq` is "more cluster + # centers than distinct data points"; nrow(xy) - 1L is "number of cluster + # centres must lie between 1 and nrow(x)", which fires at k == nrow(x) + # exactly -- so n = nrow(sample_points) used to die on a raw kmeans error. n_uniq <- nrow(unique(round(xy, 10))) - k_use <- max(1L, min(as.integer(n), n_uniq)) + k_max <- min(n_uniq, nrow(xy) - 1L) + k_use <- max(1L, min(as.integer(n), k_max)) if (k_use < n) { - .log_warn("get_voronoi_seeds(kmeans): requested %d seeds but only %d unique positions; clamping.", - n, n_uniq) + .log_warn("get_voronoi_seeds(kmeans): requested %d seeds but the sampling cloud supports at most %d (%d unique position(s) among %d point(s)); clamping.", + as.integer(n), k_use, n_uniq, nrow(xy)) } km <- stats::kmeans(x = xy, centers = k_use, iter.max = kmeans_iter, @@ -168,9 +182,25 @@ get_voronoi_seeds <- function(boundary = NULL, #' K-means seed generation from point coordinates #' +#' Places `k` seed points at k-means cluster centres of the observed +#' 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 each carry a comparable number +#' of observations, which is what makes per-cell aggregates in +#' [summarize_by_cell()] similarly precise. 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 name. +#' +#' Lon/lat input is projected first so the k-means distances are metric rather +#' than degrees. Rows with empty or non-finite coordinates are dropped with a +#' warning, and `k` is clamped to the number of distinct positions. +#' #' @param points_sf An sf object with POINT geometries. -#' @param k Integer; requested number of clusters. Clamped to the number of -#' distinct point positions, with a warning, when it exceeds it. +#' @param k Integer; requested number of clusters, and an upper bound rather +#' than a guarantee. It is clamped, with a warning, to whichever is smaller +#' of the number of distinct point positions and `nrow(points_sf) - 1` — +#' k-means can produce neither more centres than there are distinct points +#' nor as many centres as there are rows. Check `nrow()` on the result. #' @param set_seed Optional integer RNG seed. Default 456. #' @return An sf object of **at most** `k` cluster-centre POINTs (fewer when #' `k` exceeds the number of distinct positions), with `seed_id` and @@ -203,11 +233,16 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { stop("voronoi_seeds_kmeans(): `points_sf` has no usable coordinates; ", "nothing to cluster.", call. = FALSE) + # As in get_voronoi_seeds(): stats::kmeans() refuses k > distinct rows AND + # k >= nrow(x), the latter with "number of cluster centres must lie between 1 + # and nrow(x)". k = nrow(points_sf) therefore used to error rather than + # clamp, despite `@return` promising "at most k". n_uniq <- nrow(unique(round(coords, 10))) - k_use <- max(1L, min(as.integer(k), n_uniq)) + k_max <- min(n_uniq, n - 1L) + k_use <- max(1L, min(as.integer(k), k_max)) if (k_use < k) { - .log_warn("voronoi_seeds_kmeans(): requested %d seeds but only %d unique positions among %d point(s); clamping.", - as.integer(k), n_uniq, n) + .log_warn("voronoi_seeds_kmeans(): requested %d seeds but only %d unique positions among %d point(s); clamping to %d.", + as.integer(k), n_uniq, n, k_use) } cleanup <- .with_seed(set_seed) @@ -229,6 +264,19 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { #' Random seed generation within a polygonal boundary #' +#' Draws `k` seed points uniformly at random inside `boundary`, ignoring where +#' the observations are. Reach for this when the cells should cover the study +#' area evenly — so that sparsely sampled ground still gets its own cells and +#' is visibly under-sampled in the results — rather than concentrating +#' resolution where the data already are, which is what +#' [voronoi_seeds_kmeans()] does. It is also the honest choice for a null or +#' sensitivity comparison: re-running an analysis over several random seedings +#' shows how much of a result depends on one particular tessellation. +#' +#' Sampling is by rejection inside the polygon, so an awkward geometry can +#' return fewer than `k` seeds; that shortfall is warned about rather than +#' silently padded. +#' #' @param boundary An sf or sfc polygonal object. #' @param k Integer; number of random seeds. #' @param set_seed Integer RNG seed. Default 456. diff --git a/R/spatialkit-package.R b/R/spatialkit-package.R index 0aa0e52..fde081f 100644 --- a/R/spatialkit-package.R +++ b/R/spatialkit-package.R @@ -1,3 +1,70 @@ +#' @section The pipeline, in order: +#' The package is built around one workflow. Each step names the function that +#' performs it; every step is optional except the ones your question needs. +#' +#' \enumerate{ +#' \item \strong{Choose a resolution.} \code{\link{determine_optimal_levels}()} +#' reads a cell count out of the spatial structure of the observations, +#' rather than making you guess one. +#' \item \strong{Tessellate.} \code{\link{build_tessellation}()} turns the +#' point pattern into analysis regions --- Voronoi, Delaunay triangles, or a +#' hex/square grid --- with reproducible cell identifiers. +#' \code{\link{get_voronoi_seeds}()} controls where Voronoi seeds go. +#' \item \strong{Assign.} \code{\link{assign_features_to_polygons}()} labels +#' every observation with the cell it falls in, resolving multi-match ties +#' explicitly rather than duplicating rows. +#' \item \strong{Aggregate.} \code{\link{summarize_by_cell}()} reduces to one +#' row per cell, carrying a standard error and observation count with every +#' aggregate, and can correct those errors for within-cell autocorrelation. +#' \item \strong{Fold.} \code{\link{make_folds}()} builds spatial +#' cross-validation folds --- blocked, buffered, leave-location-out or +#' nearest-neighbour distance-matched. Random folds flatter autocorrelated +#' data; these do not. +#' \item \strong{Fit.} \code{\link{fit_gwr_model}()} for coefficients that +#' vary across the map, \code{\link{fit_bayesian_spatial_model}()} for an +#' explicit spatial Gaussian process with calibrated uncertainty, or +#' \code{\link{fit_rf_model}()} for predictive accuracy. All three return a +#' \code{spatial_fit} with common \code{predict()}, \code{fitted()}, +#' \code{residuals()}, \code{coef()} and \code{plot()} methods; write your +#' own backend with \code{\link{new_spatial_fit}()}. +#' \item \strong{Validate.} \code{\link{cv_gwr}()}, +#' \code{\link{cv_bayes}()}, \code{\link{cv_rf}()} or the model-agnostic +#' \code{\link{cv_spatial}()} score a model on held-out blocks; +#' \code{\link{compare_models_cv}()} scores several backends on one set of +#' folds. \code{\link{residual_morans_i}()} tests whether spatial structure +#' survives in the residuals, and \code{\link{select_features_forward}()} +#' chooses predictors inside the cross-validation. +#' \item \strong{Predict.} \code{\link{predict_surface}()} projects a fit onto +#' a regular grid; \code{\link{plot_tessellation_map}()} and +#' \code{\link{plot.spatial_fit}()} draw the results. +#' \item \strong{Check applicability.} \code{\link{area_of_applicability}()} +#' flags where that surface extrapolates beyond the training data. A +#' cross-validation score says nothing about ground the model has never +#' seen; this is what tells you where the map should not be believed. +#' } +#' +#' 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 +#' distance over which observations remain correlated --- the number that +#' should be setting your block size. +#' +#' @section Where to start: +#' If you are reading a single page, read +#' \code{vignette("spatialkit_nc_demo", package = "spatialkit")}: it runs the +#' whole pipeline above on North Carolina data, with maps at each step. +#' +#' @seealso +#' \code{vignette("spatialkit_nc_demo", package = "spatialkit")} for the worked +#' end-to-end example. +#' +#' Useful entry points by task: +#' \code{\link{build_tessellation}()} (build regions), +#' \code{\link{summarize_by_cell}()} (aggregate to them), +#' \code{\link{make_folds}()} (split them honestly), +#' \code{\link{compare_models_cv}()} (score several models at once), +#' \code{\link{area_of_applicability}()} (find where not to trust the result). +#' #' @keywords internal "_PACKAGE" diff --git a/R/stable-ids-cache.R b/R/stable-ids-cache.R index 6e8a1e3..7e4c3de 100644 --- a/R/stable-ids-cache.R +++ b/R/stable-ids-cache.R @@ -60,11 +60,27 @@ ensure_stable_poly_id <- function(polygons_sf, method <- match.arg(method) - # Work on a transformed copy for the sort key + # Work on a transformed copy for the sort key. + # + # The transform is the whole mechanism by which the IDs are stable: sorting + # on a common CRS is what makes the same layer get the same IDs whichever + # projection it arrives in. Falling back to the untransformed geometry + # silently therefore does not degrade the result, it defeats the function's + # purpose -- the IDs stop being comparable with any other run -- so say so. sort_sf <- polygons_sf if (!is.null(transform_for_sort) && !is.na(sf::st_crs(sort_sf))) - sort_sf <- tryCatch(sf::st_transform(sort_sf, transform_for_sort), - error = function(e) sort_sf) + sort_sf <- tryCatch( + sf::st_transform(sort_sf, transform_for_sort), + error = function(e) { + .log_warn(paste0("ensure_stable_poly_id(): could not transform to the ", + "sort CRS (%s) -- %s. Sorting in the layer's own CRS ", + "instead, so the IDs assigned here are NOT comparable ", + "with IDs assigned to the same features in another ", + "projection."), + paste(format(transform_for_sort), collapse = " "), + conditionMessage(e)) + sort_sf + }) # Representative points — all paths produce an sfc_POINT vector rep_sfc <- switch(method, diff --git a/R/tessellation.R b/R/tessellation.R index e2a3636..8671860 100644 --- a/R/tessellation.R +++ b/R/tessellation.R @@ -4,6 +4,16 @@ #' Build a polygonal clip target from points and/or a boundary #' +#' Resolves the single polygon that every tessellation method clips against. +#' With a `boundary` it is that boundary (optionally buffered by `expand`); +#' without one it is the convex hull of `points_sf`, again optionally buffered. +#' Reach for it when you want to see or reuse the exact clip target +#' [build_tessellation()] will apply — for instance to check that a study-area +#' polygon actually contains the observations before tessellating, or to pass +#' the same envelope to [create_voronoi_polygons()] and +#' [create_grid_polygons()] so that two tessellations of one dataset cover +#' identical ground. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometry. #' @param boundary Optional polygonal sf object. #' @param expand Numeric expansion distance or fraction (0–1 = fraction of @@ -126,6 +136,21 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' Create Voronoi polygons from points with robust CRS and optional clipping #' +#' Assigns every location in the study area to its nearest input point, giving +#' one cell per point. This is the tessellation to reach for when the +#' observations themselves define the regions of interest — sampling sites, +#' monitoring stations, service points — because cell size then adapts to +#' sampling density instead of being imposed by a fixed grid: dense areas get +#' small cells and sparse areas large ones. Prefer [create_grid_polygons()] +#' instead when you need equal-area cells or a resolution independent of where +#' the data happen to be. +#' +#' The heavy lifting is [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 `boundary`, restoring the +#' point-to-cell correspondence that `st_voronoi()` scrambles, and stamping +#' stable `cell_id` values. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometries. #' @param boundary Optional polygonal sf object. #' @param expand Numeric; absolute buffer distance for the envelope. @@ -234,16 +259,37 @@ create_voronoi_polygons <- function( #' Create square or hexagonal grid polygons over a boundary #' +#' Lays a regular grid of equal-area cells over `boundary` and clips it to that +#' boundary. Reach for this rather than [create_voronoi_polygons()] when cell +#' size should be a decision you make — because you need per-cell rates +#' comparable across the map, or a resolution that stays fixed as the sample +#' grows — instead of one dictated by where the observations happen to be. +#' Hexagons (`type = "hex"`) avoid the axis-aligned artefacts of squares and +#' give every cell the same distance to all six neighbours, which matters for +#' anything that reads neighbourhoods. +#' +#' Size the grid with exactly one of `target_cells` (roughly how many cells you +#' want, the package derives the rest), `cellsize` (a fixed edge length in CRS +#' units) or `n` (a fixed number of columns and rows). See `@param cellsize` +#' for what happens when more than one is given. +#' #' @param boundary Polygonal sf or sfc object. #' @param target_cells Optional approximate desired number of cells. For hex #' grids the count is adjusted for hexagonal packing density, but the final #' cell count after clipping to an irregular boundary may deviate #' substantially from the requested value. #' @param type Grid type: `"square"` (the default) or `"hex"`. -#' @param cellsize Optional numeric cell size (length 1 or 2). -#' @param n Optional grid resolution (integer, length 1 or 2). Applies to -#' square grids only; [sf::st_make_grid()] derives hexagon placement from -#' `cellsize` alone. +#' @param cellsize Optional numeric cell size (length 1 or 2), in the units of +#' the working CRS. Takes precedence over `n`: if both are supplied, +#' `cellsize` is used, `n` is ignored and a warning is logged. Supply exactly +#' one of `target_cells`, `cellsize` and `n`. +#' @param n Optional grid resolution (integer, length 1 or 2) giving the number +#' of columns and rows to divide the boundary's bounding box into; the cell +#' size is derived from it. Applies to square grids only; [sf::st_make_grid()] +#' derives hexagon placement from `cellsize` alone. Ignored (with a logged +#' warning) when `cellsize` is also supplied — passing both would otherwise +#' truncate the grid to `n[1]` x `n[2]` cells anchored at the bounding-box +#' corner, covering only part of the boundary. #' @param clip Logical; clip grid to boundary. #' @param crs Optional target CRS. When `NULL` (default) the boundary is #' projected with [ensure_projected()], which changes the CRS of the returned @@ -311,10 +357,24 @@ create_grid_polygons <- function( } # Derive n and/or cellsize + # + # `cellsize_supplied` records whether the CALLER fixed the cell size, as + # opposed to the package deriving it from `n` or `target_cells`. It decides + # whether `n` is forwarded to st_make_grid() below; see the note there. + cellsize_supplied <- !is.null(cellsize) if (!is.null(cellsize)) { if (length(cellsize) == 1L) cellsize <- rep(cellsize, 2L) if (length(cellsize) != 2L || any(!is.finite(cellsize)) || any(cellsize <= 0)) stop("create_grid_polygons(): 'cellsize' must be positive numeric (length 1 or 2).") + if (!is.null(n)) { + .log_warn(paste0("create_grid_polygons(): both `cellsize` and `n` were ", + "supplied; `cellsize` wins and `n` (%s) is ignored. ", + "Pass one or the other -- `n` would cap the grid at ", + "%d x %d cells anchored at the bbox corner, leaving ", + "most of the boundary uncovered."), + paste(n, collapse = " x "), n[1L], n[2L]) + n <- NULL + } } else if (!is.null(n)) { cellsize <- c(w / n[1], h / n[2]) } else { @@ -341,16 +401,29 @@ create_grid_polygons <- function( grid_args <- list(x = env, what = "polygons", square = identical(type, "square")) + # REGRESSION NOTE -- do not "simplify" this back to passing both whenever + # both are non-NULL. + # # st_make_grid() does NOT ignore `n` when `cellsize` is given: for square # grids it uses `cellsize` for the cell dimensions AND `nx = n[1]`, - # `ny = n[2]` for the counts. Omitting `n` makes it recompute + # `ny = n[2]` for the counts, anchored at the bbox corner. That is exactly + # what we want when the PACKAGE derived `cellsize` from `n` (the `n` and + # `target_cells` branches above): omitting `n` there makes sf recompute # nx = ceiling(w / cellsize[1]), which floating-point division pushes one # past the intended count (e.g. w = 100, n = 9 gives 100/(100/9) = 9.0000...4 - # -> 10 columns). Pass both whenever both are known. For hex grids sf - # short-circuits to make_hex_grid() and reads `cellsize` only, so the extra - # argument is inert there. + # -> 10 columns). + # + # It is exactly what we do NOT want when the CALLER supplied `cellsize`: an + # unrelated `n` then truncates the grid to n[1] x n[2] cells in one corner + # of the bbox and silently leaves the rest of the boundary uncovered + # (cellsize = 25 with n = 2 on a 100x100 boundary covered 2500 of 10000 -- + # and clip = TRUE discards nothing, so it looks like an ordinary grid). + # `n` is dropped with a warning in that branch above, so it is NULL here. + # + # For hex grids sf short-circuits to make_hex_grid() and reads `cellsize` + # only, so the extra argument is inert there. if (!is.null(cellsize)) grid_args$cellsize <- cellsize - if (!is.null(n)) grid_args$n <- n + if (!is.null(n) && !cellsize_supplied) grid_args$n <- n grid_sfc <- do.call(sf::st_make_grid, grid_args) if (length(grid_sfc) == 0L) stop("create_grid_polygons(): st_make_grid() produced zero cells.") @@ -379,8 +452,34 @@ create_grid_polygons <- function( #' Build a tessellation (Voronoi, Delaunay triangles, hex grid, or square grid) #' +#' The single entry point for turning a point pattern into analysis regions, and +#' the first step of the package's pipeline. It wraps the four tessellation +#' methods behind one interface that handles CRS projection, clipping and stable +#' cell identifiers consistently, and returns the cell layer together with the +#' point-to-cell index that \code{\link{assign_features_to_polygons}()} and +#' \code{\link{summarize_by_cell}()} consume. Use it rather than the +#' individual constructors whenever you might want to compare methods: the +#' return shape does not change with \code{method}, so swapping +#' \code{"voronoi"} for \code{"hex"} costs one argument. +#' +#' Which method to reach for. \code{"voronoi"} gives one cell per point, so +#' resolution follows sampling density -- the choice when the observations +#' themselves define the regions. \code{"hex"} and \code{"square"} give +#' equal-area cells on a fixed grid, so cell size is a decision you make rather +#' than one the data makes for you; hexagons avoid the axis-aligned artefacts of +#' squares and have uniform neighbour distances. \code{"triangles"} returns +#' the Delaunay triangulation, useful for interpolation and adjacency work +#' rather than as an aggregation unit. \code{\link{determine_optimal_levels}()} +#' will suggest a cell count from the spatial structure of the data. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometry. -#' @param boundary Optional polygonal sf/sfc. +#' @param boundary Polygonal sf/sfc study area. **Required** for +#' `method = "hex"` and `method = "square"`, which have no extent of their +#' 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`. #' @param method One of "voronoi", "triangles", "hex", "square". #' @param approx_n_cells Approximate number of cells (grid methods). For hex #' grids the target is adjusted for packing density; the actual count after diff --git a/README.md b/README.md index e946421..bd1d3c8 100644 --- a/README.md +++ b/README.md @@ -6,6 +6,24 @@ [![R >= 4.1](https://img.shields.io/badge/R-%3E%3D%204.1-blue)](https://www.r-project.org/) [![License: MIT](https://img.shields.io/badge/License-MIT-green.svg)](https://github.com/elkronos/gis_modeling_toolkit/blob/main/LICENSE.md) +## Contents + +- [The problem this solves](#the-problem-this-solves) +- [Scope](#scope) +- [Installation](#installation) +- [Quick start](#quick-start) +- [Your own data](#your-own-data) +- [Which function do I want?](#which-function-do-i-want) +- [Tessellation](#tessellation) +- [Cross-validation](#cross-validation) +- [Choosing a backend](#choosing-a-backend) +- [Prediction](#prediction) +- [Diagnostics & statistical notes](#diagnostics--statistical-notes) +- [Troubleshooting](#troubleshooting) +- [Running it in practice](#running-it-in-practice) +- [Development](#development) +- [Project](#project) + ## The problem this solves You have point observations — sites, sensors, parcels, plots — and you need to @@ -23,10 +41,13 @@ boundaries. - **Seed cells where the observations actually are** — `get_voronoi_seeds()` places seeds by k-means on the point cloud, so cell density follows sampling density rather than an inherited grid. -- **Let the spatial structure choose how many** — `determine_optimal_levels()` - ranks candidate cell counts by the elbow of within-cluster variance, and, - once you hand it a response, also by how much spatial autocorrelation each - partition leaves in the residuals. Better than picking a round number. +- **Let the geometry choose how many** — `determine_optimal_levels()` ranks + candidate cell counts by the elbow of within-cluster variance. Hand it a + response as well and it additionally scores each partition by the spatial + autocorrelation left in the residuals — informative only once there are + more than about ten cells, for reasons spelled out under + [How many cells?](#how-many-cells). Better than picking a round number + either way. - **Build them, reproducibly** — `build_tessellation()` produces Voronoi, hex, square or Delaunay cells, clipped to your study area, with stable IDs that do not shift when the input row order does. @@ -96,6 +117,22 @@ coordinates out. It just stops being visible unless you measure it. `make_folds()`'s default is `random_kfold`, deliberately: it is the baseline you compare against, not the one to report. +## Scope + +Everything above is what the package is for. Here is where it stops, so you can +rule it out now rather than after the quick start: + +- **Regression only.** A non-numeric response is refused outright, and an + integer-coded binary response is refused by `fit_gwr_model()` with a pointer + to `GWmodel::ggwr.basic()`. (A two-valued *non*-integer response — a + measurement censored at a detection limit, say — is continuous, so it is + fitted with a warning rather than refused.) There is no classification path. +- **Vector point data only.** No raster support. `predict_surface()` returns an + `sf` POINT layer, not a `SpatRaster`; convert downstream if you need one. +- **No areal / lattice models.** Moran's I here is a *residual diagnostic on + point data*. There is no CAR, SAR or spatial-lag fitter. +- **No spatio-temporal folds.** Every fold scheme is purely spatial. + ## Installation `spatialkit` is on CRAN: @@ -156,17 +193,25 @@ df$elev <- rnorm(n) df$price <- 50 + 0.004 * df$x + 3 * df$elev + rnorm(n) pts <- st_as_sf(df, coords = c("x", "y"), crs = 32632) -# Voronoi cells grow from SEEDS, not from the observations themselves. -# Seeding one cell per point is a nearest-neighbour interpolation, not an -# aggregation: every cell holds one observation, so every ..sd_* / ..se_* -# column comes back NA and there is no within-cell variation to estimate an -# intra-class correlation from. +# Voronoi cells grow from SEEDS, not from the observations themselves. Seeding +# one cell per point is a nearest-neighbour interpolation, not an aggregation: +# every cell holds one observation, so every ..sd_* / ..se_* column comes back +# NA and there is no within-cell variation to estimate an intra-class +# correlation from. `method = "kmeans"` will not hand you one seed per point +# whatever n you ask for; the way to reproduce that degenerate case +# deliberately is get_voronoi_seeds(method = "provided", seeds = pts). seeds <- get_voronoi_seeds(sample_points = pts, method = "kmeans", n = 25) tess <- build_tessellation(seeds, method = "voronoi", quiet = TRUE) assigned <- assign_features_to_polygons(pts, tess$cells, polygon_id_col = "cell_id") -cells <- summarize_by_cell(assigned, response_var = "price", - predictor_vars = "elev", deff = "kish") + +# deff = "kish" widens the ..se_* columns by a design effect: the factor by +# which correlation between observations in the same cell shrinks the +# effective sample size, so an SE computed as if the n points were independent +# is too narrow. Standard errors are IID at the default deff = 1. The +# Diagnostics section below and ?summarize_by_cell cover how to read one. +cells <- summarize_by_cell(assigned, response_var = "price", + predictor_vars = "elev", deff = "kish") head(as.data.frame(cells)[, c("cell_id", "n", "resp_mean_price", "..sd_resp_price", "..se_resp_price")]) @@ -193,10 +238,11 @@ is identical. range <- estimate_sac_range(site, response_var = "price", predictor_vars = "elev") range #> NA -#> attr(,"rejected_range") [1] 98348.32 -#> attr(,"rejected_reason") [1] "fitted range exceeds the largest lag fitted" -# ...and a logged WARN spelling out that the fitted range (98348) exceeds the -# largest lag the variogram covers (7043), so it is unidentified, not long. +# It prints as a bare NA and nothing else. The diagnosis is in the attributes +# and in a logged WARN spelling out that the fitted range exceeds the largest +# lag the variogram covers (7043), so it is unidentified, not long: +attr(range, "rejected_range") #> [1] 98348.32 +attr(range, "rejected_reason") #> [1] "fitted range exceeds the largest lag fitted" # That NA is the correct answer, not a failure: this synthetic field is a smooth # sinusoid that never levels off inside the study area, so its range is @@ -233,48 +279,146 @@ comparison <- compare_models_cv(site, "price", "elev", comparison$overall ``` -`models` accepts any subset of `c("GWR", "Bayesian", "RF")` in any order. -An unrecognised name raises a `warning()` and is dropped; if nothing -recognised remains, that is an error rather than a silent fallback. A -recognised model whose backend package is not installed is dropped with a -message, so the call still returns the models that could run. Backend-specific -arguments go in `gwr_args`, `bayes_args` and `rf_args`. +`models` accepts any subset of `c("GWR", "Bayesian", "RF")` in any order. A +backend whose package is not installed is dropped with a message, so the call +still returns the models that could run — but only if at least one survives. +Drop them all and the call errors: + +```r +compare_models_cv(site, "price", "elev", models = c("GWR", "Bayesian"), folds = folds) +#> compare_models_cv(): dropping GWR (package/function unavailable). +#> compare_models_cv(): dropping Bayesian (package/function unavailable). +#> Error: compare_models_cv(): no viable models. +``` + +Backend-specific arguments go in `gwr_args`, `bayes_args` and `rf_args`. Which +backend to reach for, and what each one costs, is +[Choosing a backend](#choosing-a-backend). + +## Your own data + +Everything above manufactures its data inline so it runs on a bare install. +Your data arrives through one of two doors, and both end in the same place: an +`sf` object of POINTs in a projected CRS. + +```r +library(spatialkit) +library(sf) + +# --- Door 1: a spatial file (shapefile, GeoPackage, GeoJSON, ...) ----------- +nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) + +# nc.shp holds polygons; every model here takes point observations, so reduce +# them first. coerce_to_points() maps a polygon to a point guaranteed to lie +# inside it (st_point_on_surface()), a line to its midpoint and a MULTIPOINT +# to its centroid, keeping the attribute columns. +# ensure_projected() logs which CRS it chose and why -- see the next section. +counties <- ensure_projected(nc[, c("BIR74", "SID74")]) +obs <- coerce_to_points(counties) + +# Hex and square grids need a study area. Dissolving the source polygons is +# the usual way to get one; st_read() a separate outline if you have it. +boundary <- st_as_sf(st_union(counties)) +``` + +```r +# --- Door 2: a table with coordinate columns ------------------------------- +# (a stand-in for your own file; `tab` is what read.csv() would hand you) +csv <- tempfile(fileext = ".csv") +write.csv(data.frame(lon = st_coordinates(st_transform(obs, 4326))[, 1], + lat = st_coordinates(st_transform(obs, 4326))[, 2], + births = obs$BIR74, + sids = obs$SID74), + csv, row.names = FALSE) + +tab <- read.csv(csv) +head(tab, 2) +#> lon lat births sids +#> 1 -81.49692 36.41746 1091 1 +#> 2 -81.12964 36.47430 487 0 + +# `crs =` is not optional and cannot be guessed. Lon/lat from a GPS, a web +# API or a geocoder is almost always EPSG:4326; if the file came from a +# municipal or national dataset, the metadata names the CRS and it is +# frequently not 4326. +nc_pts_ll <- st_as_sf(tab, coords = c("lon", "lat"), crs = 4326) +nc_pts <- ensure_projected(nc_pts_ll) +``` + +`ensure_projected()` is the only step people skip, and it is the one that +decides what every distance in the package means. + +### CRS: what the numbers are in + +Block sizes, buffers, `expand` distances, GWR bandwidths and variogram ranges +are all plain numbers in **the units of the working CRS**. Nothing in the +package is in metres by default, and *projected* does not mean *metric* — +EPSG:2264, used by the vignette and the demo script, is in US survey feet. +`st_crs(x)$units_gdal` tells you which. + +Geographic (lon/lat) input is projected automatically, because degrees are not +a length: `estimate_sac_range()`, the distance-based `make_folds()` methods, +every `fit_*()` (via `prep_model_data()`) and `predict_surface()` route their +input through `ensure_projected()` before measuring anything. The CRS it picks +is chosen for your extent — a UTM zone from the data's centroid when the extent +is narrow enough for one, an equal-area projection centred on the data when it +is not, because forcing continental-width data into a single UTM zone costs +percent-scale distance errors that propagate silently into ranges, block sizes +and bandwidths. It says which, and why: + +```r +nc_pts <- ensure_projected(nc_pts_ll) +#> WARN .pick_local_projected_crs(): extent reaches 5.1 deg from the central +#> meridian of UTM zone 17, well beyond the 3 deg the zone is designed for +#> (8.1 deg longitude span in total). Using Albers equal-area (lat_1=34.5, +#> lat_2=36.1, lon_0=-79.5) instead; ... Pass target_crs to ensure_projected() +#> to override. + +st_crs(nc_pts)$units_gdal +#> [1] "metre" +``` + +Two consequences worth internalising: + +- **Project before you choose a number.** `make_folds(nc_pts_ll, block_size = + 2000)` succeeds on lon/lat input, and the 2000 is in metres of a CRS you + never chose. Call `ensure_projected()` yourself, look at `st_bbox()`, and + pick `block_size` against that. `folds$params$crs` records the CRS the folds + were actually built in, which is the one `block_size` was in. +- **Pin the CRS when it matters.** `ensure_projected(x, target_crs = 2264)` + or `build_tessellation(..., crs = 2264)` forces a specific one, which is + what you want when results have to line up with an existing analysis, a + published bandwidth, or a colleague's grid. ## Which function do I want? | I want to… | Use | |---|---| +| get my data into a projected CRS | `ensure_projected()`, `coerce_to_points()`, `harmonize_crs()` | | 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 | `determine_optimal_levels()` | | put points into cells and aggregate | `assign_features_to_polygons()` → `summarize_by_cell()` | +| draw the result | `plot_tessellation_map()` | | know how far spatial correlation reaches | `estimate_sac_range()` | -| build honest CV folds | `make_folds()` | +| build honest CV folds | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`) | | see whether my folds actually separate | `plot_folds()` | | fit a model | `fit_gwr_model()`, `fit_bayesian_spatial_model()`, `fit_rf_model()` | | score it out of sample | `cv_gwr()`, `cv_bayes()`, `cv_rf()` | | score *my own* learner on the same folds | `cv_spatial()` + `new_spatial_fit()` | -| pick predictors without leaking | `select_features_forward()` | +| score it in sample | `model_metrics()`, `evaluate_insample()`, `compare_models()` | +| pick predictors without leaking | `select_features_forward()` (`gwr_model_selection()` for the AICc counterpart) | | compare backends head to head | `compare_models_cv()` | | check for leftover spatial structure | `residual_morans_i()`, `plot(fit, type = "variogram")` | | turn a fit into a map | `predict_surface()` | | know where that map is extrapolation | `area_of_applicability()` | | free memory held by the caches | `clear_grid_cache()`, `clear_fitted_cache()` | -## Function overview - -| Area | Key functions | -|---|---| -| CRS & geometry | `ensure_projected()`, `harmonize_crs()`, `coerce_to_points()`, `prep_model_data()` | -| Tessellation | `build_tessellation()`, `create_voronoi_polygons()`, `create_grid_polygons()`, `create_grid_polygons_cached()`, `clip_target_for()`, `ensure_stable_poly_id()` | -| Seeding & resolution | `get_voronoi_seeds()`, `voronoi_seeds_kmeans()`, `voronoi_seeds_random()`, `determine_optimal_levels()` | -| Assignment & aggregation | `assign_features_to_polygons()`, `summarize_by_cell()` | -| Modeling | `fit_gwr_model()`, `fit_bayesian_spatial_model()`, `fit_rf_model()`, `gp_lengthscale_bounds()`, `new_spatial_fit()`; S3: `predict()`, `fitted()`, `residuals()`, `coef()`, `summary()`, `model_metrics()` | -| Cross-validation | `make_folds()` (`random_kfold`, `block_kfold`, `buffered_loo`, `leave_location_out`, `nndm`), `estimate_sac_range()`, `cv_gwr()`, `cv_bayes()`, `cv_rf()`, `cv_spatial()` | -| Variable selection | `select_features_forward()`, `gwr_model_selection()` | -| Prediction | `predict_surface()` | -| Comparison & diagnostics | `compare_models()`, `compare_models_cv()`, `evaluate_insample()`, `residual_morans_i()`, `area_of_applicability()` | -| Plotting | `plot_tessellation_map()`, `plot()` for `spatial_fit`, `plot_folds()` | -| Cache management | `clear_grid_cache()`, `clear_fitted_cache()` | +The lower-level exports behind these — `create_voronoi_polygons()`, +`create_grid_polygons()`, `create_grid_polygons_cached()`, `clip_target_for()`, +`ensure_stable_poly_id()`, `voronoi_seeds_kmeans()`, `voronoi_seeds_random()`, +`prep_model_data()` and `gp_lengthscale_bounds()` — are exported and documented +too; `help(package = "spatialkit")` lists everything. ### The `spatial_fit` interface @@ -326,13 +470,14 @@ scaling, tuning, an inner feature sweep — is already nested and leak-free. ## Tessellation -Three ways to cut the same geography. The first panel shows raw observations of -a smooth spatial field over North Carolina (high in the west, with an eastern -hotspot). The others show the same points aggregated into Voronoi regions grown -from k-means seeds, a hex grid, and a square grid — each cell coloured by the -mean of the points inside it (`assign_features_to_polygons()` + -`summarize_by_cell()`). All panels share one colour scale, so each tessellation -should look like a mosaic version of the raw data: +`build_tessellation()` offers four methods. Below, three of them cut the same +geography. The first panel shows raw observations of a smooth spatial field +over North Carolina (high in the west, with an eastern hotspot). The others +show the same points aggregated into Voronoi regions grown from k-means seeds, +a hex grid, and a square grid — each cell coloured by the mean of the points +inside it (`assign_features_to_polygons()` + `summarize_by_cell()`). All panels +share one colour scale, so each tessellation should look like a mosaic version +of the raw data: ![Raw spatial field and three tessellation methods aggregating it over North Carolina](https://raw.githubusercontent.com/elkronos/gis_modeling_toolkit/main/man/figures/readme-tessellations.png) @@ -340,31 +485,112 @@ All four methods return `cells` carrying a `cell_id` column, so downstream code and `plot_tessellation_map(fill_col = "cell_id")` treat them alike; hex and square grids additionally keep `poly_id`, holding the same values. +### Which method? + +| Method | A cell is | Reach for it when | +|---|---|---| +| `"voronoi"` | the area closer to one seed than to any other seed | cells should follow **sampling density** — small where you sampled densely, large where you did not. Seeds come from `get_voronoi_seeds()`; the observations themselves are not the seeds. | +| `"hex"` | one hexagon of a regular lattice over the boundary | you need a **regular lattice**: comparable cell areas and equal-distance neighbours, so cell size cannot confound the map | +| `"square"` | one square of a regular lattice over the boundary | the same, and the cells have to line up with an existing raster or grid | +| `"triangles"` | one Delaunay triangle of the input points | you want the **point-triplet structure** itself — adjacency, interpolation supports — rather than an aggregation | + +The practical split is whether the sampling design carries information you want +the partition to inherit. If it does, Voronoi. If it does not — and unequal +cell areas would be an artefact rather than a feature — hex or square. + +`"triangles"` is the odd one out: a Delaunay triangulation of n points has +roughly 2n triangles (300 points gave 586 in the demo script), so its cells are +far finer than the other three and most hold barely any data. +`summarize_by_cell()` needs several points per cell to say anything, which +rules `"triangles"` out for aggregation. + +### Hex and square grids need a boundary + +Voronoi and Delaunay take their extent from the points themselves — Voronoi +falls back to their convex hull when you pass no boundary. A grid cannot: +nothing in a point cloud says where a lattice should stop. Both grid methods +therefore **require** `boundary`, and say so rather than guessing: + +```r +build_tessellation(obs, method = "hex", approx_n_cells = 40) +#> Error: build_tessellation(): `boundary` is required for hex/square grids. + +hex <- build_tessellation(obs, boundary = boundary, method = "hex", + approx_n_cells = 40, clip = TRUE, quiet = TRUE) +nrow(hex$cells) +#> [1] 38 +``` + +(`obs` and `boundary` are from [Your own data](#your-own-data) above.) +`approx_n_cells` is a target, not a promise: `clip = TRUE` intersects the +lattice with the boundary and drops what falls outside, so the count comes back +near, not at, what you asked — the same call with `method = "square"` returns +32. Pass `cellsize` instead when the cell edge, in CRS units, is the thing you +need to hold fixed. + ### How many cells? Resolution is a modeling decision, not a cosmetic one: too few cells smooth the signal away, too many leave each cell with a handful of noisy observations. -`determine_optimal_levels()` combines two criteria — a geometric elbow on the -within-cluster sum of squares from a k-means sweep, and a model-aware check -computing Moran's I on OLS residuals at each candidate resolution. The Moran's -I profile measures how much spatial structure in the response remains -*unexplained* at that scale, so the combined ranking balances parsimony against -residual spatial independence. - -It returns a **vector of `top_n` candidates** (default 3), best first, with a -`"diagnostics"` attribute — not a single number: +`determine_optimal_levels()` offers two criteria and their combination. The +geometric one — `criterion = "geometric"` — takes the elbow of the +within-cluster sum of squares from a k-means sweep. The model-aware one — +`criterion = "morans_i"` — aggregates to cell means at each candidate k, fits +OLS, and computes Moran's I on the residuals, so it prefers the resolution that +leaves the least unexplained spatial structure. `"combined"` rank-averages the +two. `"geometric"` is the default, but supplying `response_var` *and* +`predictor_vars` auto-upgrades it to `"combined"` with a logged note — so the +model-aware half is on whenever you hand it a model, whether you asked or not. + +It returns a **vector of `top_n` candidates** (default 3), best first — not a +single number: ```r k <- determine_optimal_levels(pts, response_var = "price", predictor_vars = "elev", max_levels = 15, criterion = "combined") +#> WARN determine_optimal_levels(): Moran's I could not be computed; +#> falling back to geometric. k -#> [1] 4 5 6 +#> [1] 3 4 5 k[1] # the top-ranked candidate -#> [1] 4 -attr(k, "diagnostics")$moran_i +#> [1] 3 ``` +**Below ten cells, the elbow does all of the work — and that is most calls.** +Moran's I here runs over a k-nearest-neighbour graph on the cell centroids with +`min(8, n_cells - 1)` neighbours, so at nine cells or fewer every cell +neighbours every other one. On a complete, row-standardised graph Moran's I +collapses to exactly `-1/(n_cells - 1)` for *any* residual vector — the null +expectation, carrying nothing about your data — and `|I|` then falls +monotonically in k for purely arithmetic reasons, which would rank the largest +candidate first every time. Rather than report that, the model-aware criteria +return `NA` below the floor; when no candidate clears it, the whole call falls +back to the geometric ranking and logs the warning above. That is what happened +here: `max_levels = 15`, but the search only evaluates a window around the +elbow, and that window sat entirely inside the degenerate zone. + +So: **use the elbow to pick resolution, and treat the residual-autocorrelation +criterion as something that only starts contributing above roughly ten cells.** +Raise `max_levels` until the elbow neighbourhood reaches past it and the +diagnostics fill in: + +```r +k <- determine_optimal_levels(pts, response_var = "price", + predictor_vars = "elev", max_levels = 40, + criterion = "combined") +as.integer(k) # printing `k` itself dumps the diagnostics attribute too +#> [1] 5 6 10 + +d <- attr(k, "diagnostics") # present only when Moran's I ran +round(d$moran_i[d$eval_ks], 4) +#> [1] NA NA NA NA NA NA NA 0.0135 0.0411 +``` + +Seven `NA`s for k = 3..9, then two real values at k = 10 and 11. Only those two +carry information, and both are near zero — this synthetic field leaves little +residual structure at either resolution, so the elbow keeps the final say. + The same field cut at three resolutions, next to the raw observations — too coarse blurs the hotspot, too fine chases noise with near-empty cells, and the selected k preserves the trend without overfitting geography: @@ -400,6 +626,94 @@ grid yields fewer non-empty blocks, `leave_location_out` when there are fewer distinct groups, and `buffered_loo`/`nndm` always return `k = n`. Read `folds$k` rather than assuming. +### Choosing `k` and `block_size` + +For `block_kfold` these two arguments pull against each other, and the tension +is the whole design problem: + +- **`block_size` too small** and a held-out block is narrower than the + autocorrelation range, so training points just outside it still carry the + test points' signal. Leakage creeps back and you have paid for blocking + without buying anything. The block has to be wider than the range for the + hold-out to mean "somewhere the model has not been". +- **`k` too small** and each fold trains on `(k-1)/k` of the data — at `k = 3`, + two-thirds — so the score is of a model fitted on much less data than the one + you will ship, and pessimistic for that reason rather than for a spatial one. + Few folds also means few blocks, and a fold-to-fold spread computed from + three numbers. +- **`k` too large** and, at a fixed study area, the blocks shrink back below + the range. `k = 10` on a small extent is often just `random_kfold` with extra + steps. + +`estimate_sac_range()` is the anchor: get the range, make `block_size` +comfortably larger than it, then let `k` be whatever the extent supports at +that size. `k = 5` is a reasonable default to start from. `auto_range = TRUE` +does the first two steps for you — and, crucially, tells you when it could not: + +```r +folds <- make_folds(site, k = 5, method = "block_kfold", + auto_range = TRUE, response_var = "price", + predictor_vars = "elev", seed = 42) +#> WARN make_folds(block_kfold): auto_range requested but estimation +#> returned NA; falling back to geometric blocks. + +folds$k # may be lower than requested +#> [1] 5 +folds$params$block_size # NULL here -- the range was never identified +#> NULL +``` + +So always read both back. `plot_folds()` is the fastest check that the blocks +separate anything at all. + +### When `estimate_sac_range()` returns `NA` + +An `NA` is a refusal, not a failure: the empirical variogram never levelled +off, so the fitted range sits beyond the largest lag it was fitted over and is +unidentified rather than long. Handing that number to `make_folds()` would size +blocks from an artefact. The logged warning names three next steps, in the +order worth trying: + +1. **Raise `cutoff`.** It is a *fraction* of the maximum inter-point distance, + default `0.5`, so lags beyond half the study extent are never fitted. If the + sill is genuinely further out, `cutoff = 0.8` lets the fit see it — at the + cost of the noisiest, sparsest lags, which is why it is not the default. +2. **Supply `predictor_vars`.** The variogram is fitted to OLS residuals. A + large-scale trend the predictors would absorb otherwise looks like + autocorrelation that never decays — detrending is frequently the whole fix. +3. **Set `block_size` explicitly** and say in your write-up that you did. A + defensible starting point is a fraction of the study extent — one fifth of + the shorter bbox side gives roughly 5 x 5 blocks — sanity-checked with + `plot_folds()`. + +What you should not do is treat `NA` as "no autocorrelation" and fall back to +`random_kfold`. An unidentified range usually means correlation reaching *past* +the study area, which is the case where random folds are most optimistic. + +## Choosing a backend + +`compare_models_cv()` scores all three on identical folds and is the right +answer when you can afford it. It is not always cheap. On the recorded +baselines (`dev/baseline-accuracy.rds`: one machine, one run, 4-fold CV, 2 +chains × 1,000 iterations) the Bayesian GP took **1,186 s** at n = 2,000 +against **109 s** for `cv_gwr()` on the same data — and at n = 300, 142 s +against 0.8 s, so the ratio is not fixed either. A `cv_rf()` of the same shape +is seconds. So it is worth knowing what each backend is *for* before you spend +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 — "the elevation effect is strong in the west and absent in the east" is the answer only this one gives | moderate; grows quickly with n | +| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces, 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 rather than 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 — permutation importance is what you get instead of coefficients | far the lowest; the one to prototype with | + +Two things that are not backend choices. First, none of them fixes bad folds — +all three can interpolate location directly, which is where the gap at the top +of this file is widest, so the fold scheme has to be right before the backend +comparison means anything. Second, if the question is only "is there spatial +structure my predictors miss", `residual_morans_i()` on the cheapest fit you +can make answers it before you pick anything. + ## Prediction All three backends support true out-of-sample prediction — `newdata` needs only @@ -441,43 +755,17 @@ Chunking matters for `bayesian_fit`, where the posterior draw matrix is itself would. Pass `se = TRUE` for a posterior-SD surface where the backend exposes draws, and `boundary =` a polygon to clip to a study area. -## Parallel cross-validation - -Every CV function — `cv_gwr()`, `cv_bayes()`, `cv_rf()` and `cv_spatial()` — -accepts a `parallel` argument for fold-level parallelism via -`parallel::mclapply()` (macOS/Linux; falls back to sequential on Windows with a -message). This matters most for `cv_bayes()`, where every fold is a full MCMC -run: - -```r -cv <- cv_bayes(site, "price", "elev", k = 5, parallel = TRUE) # auto-detect cores -cv <- cv_rf(site, "price", "elev", k = 5, parallel = 4L) # explicit count -``` +## Diagnostics & statistical notes -Results are reproducible from `seed` and identical to `parallel = FALSE`: one -RNG stream per fold is drawn in the parent process, so each fold's stream is a -function of `(seed, fold index)` alone. +### Residual spatial autocorrelation -## Caching +`residual_morans_i()` computes Moran's I on model residuals with the Cliff & +Ord randomisation variance, using row-standardised k-NN weights by default +(sparse via `FNN` + `Matrix` when available) or a user-supplied weight matrix +(base or sparse `Matrix`). `compare_models()` runs it automatically and logs a +warning when residual spatial structure remains. -Grid construction and posterior expectations are both expensive enough to -memoise, so both are cached: - -- `create_grid_polygons_cached()` memoises grids keyed on boundary geometry, - CRS, target cell count and arguments. `clear_grid_cache()` empties it. -- `fitted()` on a `bayesian_fit` memoises `posterior_epred()` column means in - an environment carried on the object, because `summary()`, `residuals()`, - `model_metrics()` and `compare_models()` each call `fitted()` independently. - `clear_fitted_cache(fit)` drops it — needed only if you mutate the engine or - the training data by hand after fitting. - -## Diagnostics & statistical notes - -**Residual Moran's I.** `residual_morans_i()` computes Moran's I on model -residuals with the Cliff & Ord randomisation variance, using row-standardised -k-NN weights by default (sparse via `FNN` + `Matrix` when available) or a -user-supplied weight matrix (base or sparse `Matrix`). `compare_models()` runs -it automatically and logs a warning when residual spatial structure remains. +### Aggregation standard errors **Aggregation standard errors are IID unless you ask otherwise.** The `..se_*` columns from `summarize_by_cell()` are IID standard errors at the default @@ -493,13 +781,62 @@ fitted a variogram is for. Substituting a constant off-diagonal correlation recovers Kish exactly. Inspect what was applied via `attr(result, "deff_applied")`. -**Area of applicability.** A fitted model returns a number for any location you -hand it, including locations whose predictor values look nothing like anything -it was trained on. Those predictions are extrapolations dressed as -interpolations, and a cross-validation score says nothing about them — the -held-out folds were drawn from the same predictor distribution as the training -data. `area_of_applicability()` implements the dissimilarity index of Meyer & -Pebesma (2021) and marks where the score applies: +**Reading a design effect.** A design effect is a *variance* multiplier, so +standard errors move by its square root. Kish's is `deff_i = 1 + (n_i - 1) * rho` +per cell, from the intra-class correlation `rho`. + +- **deff ≈ 1** — no within-cell correlation worth correcting for. The IID + standard errors were already right. +- **deff = 4** — the cell's `n` points carry the information of `n/4` + independent ones, and its standard error is 2x the IID figure. + +The demo script (`inst/scripts/example_nc_demo.R`, 300 points in 40 Voronoi +cells) prints `ICC(response) = 0.742 | median deff = 5.45` and a median +response-SE inflation of `2.33x`, which is `sqrt(5.45)`. That is a strongly +clustered response: at ~7.5 points per cell, each cell carries the information +of fewer than two independent observations. + +Cell size is the lever, and it moves the wrong way from most people's +intuition. `deff` rises with cell occupancy, so *bigger* cells are worse. +Re-running the demo's aggregation at other seed counts, same data, same seed: + +| Voronoi cells | mean points/cell | ICC | median `deff` | SE inflation | +|---:|---:|---:|---:|---:| +| 10 | 30.0 | 0.665 | 21.28 | 4.61x | +| 20 | 15.0 | 0.714 | 9.93 | 3.15x | +| 40 | 7.5 | 0.742 | 5.45 | 2.33x | +| 80 | 3.8 | 0.780 | 3.34 | 1.83x | +| 120 | 2.5 | 0.790 | 1.79 | 1.61x | + +So there are two honest responses, and picking between them is a modeling +decision, not a formatting one: + +1. **Accept the wider intervals.** They are the correct ones. If the conclusion + survives them, it was never resting on the correlation. A large `deff` is + not a bug and not a warning — it is the price of cells big enough to hold + correlated observations, and it was always being paid; `deff = 1` just did + not show it on the invoice. +2. **Use more, smaller cells** (raise `n` in `get_voronoi_seeds()`, or a finer + grid) so that less spatial variation is trapped *inside* a cell, where it + only inflates `deff`, and more of it lands *between* cells, where it is + estimated. That costs precision on each individual cell mean, so it is a + trade, not a free win — and it does not manufacture information the + correlated sample never had. Nothing but more spatially independent sampling + does that. + +If cells are large enough that "every pair inside is equally correlated" stops +being credible, switch to `deff = "variogram"`, which lets the correlation +decay with distance instead. + +### Area of applicability + +A fitted model returns a number for any location you hand it, including +locations whose predictor values look nothing like anything it was trained on. +Those predictions are extrapolations dressed as interpolations, and a +cross-validation score says nothing about them — the held-out folds were drawn +from the same predictor distribution as the training data. +`area_of_applicability()` implements the dissimilarity index of Meyer & Pebesma +(2021) and marks where the score applies: ```r surf <- predict_surface(fit, n_cells = 2000, covariates = site) @@ -520,17 +857,17 @@ That is not a loophole — the area of applicability is defined relative to a performance estimate, and a spatially blocked estimate is a claim about predicting further away. +### Leakage: coordinates and variable selection + **Random forests and location.** `fit_rf_model()` defaults to `include_coords = FALSE`. Handing a forest the x and y coordinates lets it reproduce the training surface almost exactly by memorising location, then fail badly anywhere it has not seen; random cross-validation does not catch this, because nearby points leak between folds (Meyer et al. 2019). That is the -effect measured in the table at the top of this file. Relatedly, `fitted()` on -an `rf_fit` returns **out-of-bag** predictions rather than in-sample ones — -in-sample predictions from a forest are close to memorisation and would make -`summary()` report a fictitious R². The out-of-bag error is itself a *random* -hold-out, so it is optimistic under spatial autocorrelation for the same reason -random k-fold is; use `cv_rf()` for a blocked estimate. +effect measured in the table at the top of this file. And `summary()`'s +out-of-bag error is no substitute: OOB is itself a *random* hold-out, so it is +optimistic under spatial autocorrelation for exactly the reason random k-fold +is. Use `cv_rf()` for a blocked estimate. **Variable selection.** `select_features_forward()` scores candidates against spatially blocked inner folds, which is the entire point of having it: random @@ -542,6 +879,8 @@ easier surviving subset. `gwr_model_selection()` is the fast in-sample counterpart — the same forward search scored by AICc — and is worth cross-checking against the blocked estimate when the answer matters. +### Backend-specific notes + **GWR collinearity.** `fit_gwr_model()` checks the global condition number of the predictor matrix *and* spot-checks local condition numbers within bandwidth windows at sampled locations, since spatially clustered subsets can be @@ -562,22 +901,120 @@ length-scale per axis by default (`gp_iso = FALSE`), estimating directional structure from the data; pass `gp_iso = TRUE` for a single shared length-scale. The scaling strategy is recorded in `fit$info$coord_scaling$scaling_type`, and a data-informed length-scale prior is derived from the inter-point distance -distribution (see `gp_lengthscale_bounds()`). `predictor_vars = character(0)` -is accepted, giving an intercept-only spatial GP — the natural null model for -asking how much of a surface is spatial structure rather than covariate effect. +distribution (see `gp_lengthscale_bounds()`). The spatial null noted under +[Choosing a backend](#choosing-a-backend) is spelled +`predictor_vars = character(0)`. + +## Troubleshooting + +The handful you are most likely to meet, and what each is actually telling you. + +**`build_tessellation(): boundary is required for hex/square grids.`** +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. + +**`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 difference, or a column renamed by `read.csv()`'s +`check.names = TRUE` (`pop density` becomes `pop.density`). Check +`names(data_sf)`. The geometry column is not a predictor. + +**`fit_rf_model(): response 'y' is not numeric.`** +(And its `fit_gwr_model()` / `fit_bayesian_spatial_model()` equivalents.) +Everything here is regression. A factor or character response is refused +outright; a response that came back as character from a CSV needs +`as.numeric()` first — check for a stray thousands separator or `"NA"` string +if that produces `NA`s. `fit_gwr_model()` additionally refuses an +integer-coded two-valued response and points at `GWmodel::ggwr.basic()`. + +**`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 this is an error rather than a slow path. +`install.packages(c("FNN", "Matrix"))` — both, not either. + +**`compare_models_cv(): no viable models.`** +Every requested backend was dropped: unrecognised names raise a warning, +uninstalled backends print `dropping (package/function unavailable)`. +Read the messages immediately above the error — they name each one. Install the +backend, or request one you have. + +**`cv_*(): all folds failed; cross-validation results contain no predictions.`** +A warning, not an error: `$overall` comes back all-`NA` with `n_pred = 0`. The +per-fold `WARN` lines name the cause — a missing backend most often, but also a +degenerate training slice or a predictor constant within a fold. Compare +`cv$n_folds_succeeded` against `cv$n_folds_attempted` on every run, not just +when something looks wrong: a *partial* failure produces a plausible-looking +score computed from fewer folds than you asked for. + +**`estimate_sac_range()` returned `NA`.** +Not a failure — a refusal to report an unidentified range. See +[When `estimate_sac_range()` returns `NA`](#when-estimate_sac_range-returns-na). + +**`determine_optimal_levels(): Moran's I could not be computed; falling back to +geometric.`** +Every candidate resolution sat below the nine-cell floor where Moran's I is +arithmetically degenerate. Expected at small `max_levels`; see +[How many cells?](#how-many-cells). + +**Distances, bandwidths or block sizes look absurd.** Check the working CRS +first: `st_crs(x)$units_gdal`. A block size that made sense in metres is +meaningless in US survey feet, and lon/lat input gets projected to a CRS the +package chose. See [CRS: what the numbers are in](#crs-what-the-numbers-are-in). + +## Running it in practice + +Three concerns that show up once the pipeline works rather than while you are +building it: making cross-validation finish sooner, not recomputing what has +not changed, and seeing what the package is doing. + +### Parallel cross-validation + +Every CV function — `cv_gwr()`, `cv_bayes()`, `cv_rf()` and `cv_spatial()` — +accepts a `parallel` argument for fold-level parallelism via +`parallel::mclapply()` (macOS/Linux; falls back to sequential on Windows with a +message). This matters most for `cv_bayes()`, where every fold is a full MCMC +run: -## What spatialkit does not do +```r +# cv_bayes() needs `brms`. Without it every fold fails and you get an empty +# result, not an error -- a per-fold WARN naming the cause, one summarising +# R warning(), and $overall all-NA with n_pred = 0: +cv <- cv_bayes(site, "price", "elev", k = 5, parallel = TRUE) # auto-detect cores +#> WARN .cv_run_folds(): fold 1 fit failed; skipping. +#> Cause: fit_bayesian_spatial_model(): package 'brms' is required. +#> ... (once per fold) +#> Warning: cv_bayes(): all folds failed; cross-validation results contain no +#> predictions. First error: fit_bayesian_spatial_model(): package 'brms' is required. -- **Regression only.** A non-numeric response is refused outright, and a binary - numeric response is refused by `fit_gwr_model()` with a pointer to - `GWmodel::ggwr.basic()`. There is no classification path. -- **Vector point data only.** No raster support. `predict_surface()` returns an - `sf` POINT layer, not a `SpatRaster`; convert downstream if you need one. -- **No areal / lattice models.** Moran's I here is a *residual diagnostic on - point data*. There is no CAR, SAR or spatial-lag fitter. -- **No spatio-temporal folds.** Every fold scheme is purely spatial. +cv <- cv_rf(site, "price", "elev", k = 5, parallel = 4L) # explicit count +``` + +**Check `cv$n_folds_succeeded` against `cv$n_folds_attempted` before you read +`cv$overall`.** Every CV function records both, precisely because a partial or +total fold failure degrades rather than errors — a missing backend is only the +loudest cause; a fold whose training slice is degenerate fails the same way and +leaves the remaining folds looking fine. + +Results are reproducible from `seed` and identical to `parallel = FALSE`: one +RNG stream per fold is drawn in the parent process, so each fold's stream is a +function of `(seed, fold index)` alone. -## Logging +### Caching + +Grid construction and posterior expectations are both expensive enough to +memoise, so both are cached: + +- `create_grid_polygons_cached()` memoises grids keyed on boundary geometry, + CRS, target cell count and arguments. `clear_grid_cache()` empties it. +- `fitted()` on a `bayesian_fit` memoises `posterior_epred()` column means in + an environment carried on the object, because `summary()`, `residuals()`, + `model_metrics()` and `compare_models()` each call `fitted()` independently. + `clear_fitted_cache(fit)` drops it — needed only if you mutate the engine or + the training data by hand after fitting. + +### Logging Detailed diagnostics are logged to a session temp file, and warnings are echoed to the console. Logging is scoped to the `"spatialkit"` namespace and never @@ -593,16 +1030,6 @@ will not catch them and `suppressWarnings()` will not suppress them. Where the documentation says a function *raises* a warning, it means a genuine R `warning()`; where it says a function *logs* one, it means this. -## Documentation - -- Every exported function is documented: see `?fit_gwr_model`, `?make_folds`, - `?area_of_applicability`, etc. -- A worked end-to-end demo on the North Carolina boundary shipped with `sf` - runs as a vignette: `vignette("spatialkit_nc_demo")` after installing with - `build_vignettes = TRUE`. -- A runnable script version is installed with the package: - `system.file("scripts", "example_nc_demo.R", package = "spatialkit")`. - ## Development ```r @@ -616,26 +1043,42 @@ The checked-in `NAMESPACE` and `man/` are generated by roxygen2 7.3.1 (`RoxygenNote` in `DESCRIPTION`); `devtools::document()` reproduces them. The README figures are generated from actual package output; regenerate them -with `Rscript dev/make_readme_figures.R`. +with `Rscript dev/make_readme_figures.R`. `readme-resolution.png` labels the +cell count `determine_optimal_levels()` chose for that data, so it goes stale +whenever that function'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 I variance and its sparse-weights path, CV fold/row-ID alignment, CRPS, hex-grid sizing, CRS selection at wide extents, prediction CRS and NA alignment, and more). Tests that need an optional backend skip automatically -when it is absent. `ranger` guards the most of them, well ahead of `gstat`, -`ggplot2`, `FNN`, `sp`, `Matrix`, `geometry` and `GWmodel`; exactly one guards -on `brms`. The `backends` job in `R-CMD-check.yaml` installs all of those -except `brms`, so a green matrix means the guarded paths actually ran. `brms` -is left to the weekly `check-brms` workflow, whose header comment is explicit -about how little it currently exercises. +when it is absent, and the `backends` job in `R-CMD-check.yaml` installs every +optional backend except `brms`, so a green matrix means those guarded paths +actually ran. `brms` is the thin spot: its Stan smoke tests are *additionally* +gated behind the `SPATIALKIT_TEST_BRMS` environment variable, which only the +weekly `check-brms` workflow sets, so they do not run in the matrix even where +`brms` is installed. Contributions are welcome — please [open an issue](https://github.com/elkronos/gis_modeling_toolkit/issues) describing the bug or proposed change, and include a regression test with any fix. -## Citation +## Project + +### Documentation + +- `?spatialkit` is the package-level page: it walks the pipeline in order and + names the function that performs each step. +- Every exported function is documented: see `?fit_gwr_model`, `?make_folds`, + `?area_of_applicability`, etc. +- A worked end-to-end demo on the North Carolina boundary shipped with `sf` + runs as a vignette: `vignette("spatialkit_nc_demo")` after installing with + `build_vignettes = TRUE`. +- A runnable script version is installed with the package: + `system.file("scripts", "example_nc_demo.R", package = "spatialkit")`. + +### Citation ```r citation("spatialkit") @@ -649,17 +1092,17 @@ 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). -## Maintainer +### Maintainer Justin Chase — [issue tracker](https://github.com/elkronos/gis_modeling_toolkit/issues) -## License +### License MIT © Justin Chase. See [LICENSE.md](https://github.com/elkronos/gis_modeling_toolkit/blob/main/LICENSE.md). -## Disclaimer +### Disclaimer This is a personal project. It is not affiliated with, endorsed by, or connected to any organization. It uses public data sources only and was diff --git a/cran-comments.md b/cran-comments.md index 2c49ed3..3f07427 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -20,7 +20,8 @@ references at the same time. The CRAN page for 1.0.0 lists no reverse depends, imports or suggests, so there is nothing to break. Confirm with `revdepcheck::revdep_check()` before -submitting rather than relying on this note. +submitting rather than relying on this note. (This container has no network +access, so nothing here was checked against CRAN.) ## Summary @@ -36,8 +37,18 @@ Ubuntu 24.04.4 LTS, R 4.3.3, x86_64-pc-linux-gnu — the environment the results below were produced on. Installed: sf 1.0.15, dplyr 1.1.4, logger 0.2.2, digest 0.6.34, testthat 3.2.1, sp 2.1.2, ranger 0.16.0, tibble 3.2.1, geometry 0.4.7, gstat 2.1.1, ggplot2 3.4.4, patchwork 1.2.0, FNN 1.1.4, Matrix 1.6.5, -roxygen2 7.3.1, knitr 1.45, rmarkdown 2.25. **Not installed: `GWmodel`, `brms`, -`cmdstanr`, `loo`.** +roxygen2 7.3.1, knitr 1.45, rmarkdown 2.25, pkgload 1.3.4, spdep 1.3.1, +brms 2.20.4. + +**`GWmodel` was present only as a faithful API stub built from CRAN sources** -- +argument names and order, return shapes, SDF column naming and the `GWR.df` +column order, with real weighted least squares -- because the real package would +not install in this container. And although `brms` itself is installed, **Stan +could not compile here**, so no posterior was ever sampled: the brms findings +were established with `make_stancode()`, `make_standata()`, `get_prior()` and +`validate_prior()`, which need no compilation. **Every GWR and brms result +recorded below must be re-confirmed on a machine with the real packages before +submission.** Not installed: `cmdstanr`, `loo`. Still to run before any submission: @@ -52,57 +63,72 @@ Still to run before any submission: `gstat`, `FNN`, `Matrix`, `geometry`, `ranger` and `tibble` installed, so the optional code paths actually execute rather than skip. — * GitHub Actions `check-brms.yaml` (weekly, ubuntu-latest, R release) with - `brms` and the Stan toolchain. — + `brms` and the Stan toolchain, which is the only job that sets + `SPATIALKIT_TEST_BRMS` and therefore the only one that runs the five Stan + smoke tests. — ## R CMD check results -On the environment above, `R CMD check --no-manual --no-build-vignettes` on the -built tarball reports **2 WARNINGs, 1 NOTE**. All three are accounted for: - -* **NOTE — "Packages suggested but not available for checking: 'GWmodel', - 'brms', 'cmdstanr', 'loo'".** Environmental. These are the optional backends - this machine does not have; the `backends` and `check-brms` CI jobs exist to - cover them. - -* **WARNING — "checking R files for non-ASCII characters": `crs-geometry.R`.** - Real, and must be fixed before submission. `R/crs-geometry.R` line 188 carries - a literal U+2014 EM DASH inside a string literal in the `ensure_projected()` - error message: - - ``` - "object that carries a CRS — or omit `target_crs` to let a ", - ``` - - Replace it with `--` or the escape `—`. Em dashes elsewhere in `R/` sit - in comments and roxygen blocks, which the check tolerates; this is the only - one in code. - -* **WARNING — "checking R files for syntax errors":** the only content is - `Warning in Sys.setlocale("LC_CTYPE", "en_US.UTF-8") : OS reports request to - set locale to "en_US.UTF-8" cannot be honored`. Environmental: this container - ships only the C locale, so the check's own locale switch fails. No syntax - error was reported. Expect this WARNING to disappear on any machine with a - UTF-8 locale. - -`R CMD build` produces a 994 KB tarball, of which the built vignette is 857 KB. -Both `checking tests` and `checking running R code from vignettes` pass. - -`testthat` reports **1752 passing, 0 failures, 0 errors, 7 skips** on that -environment (`NOT_CRAN=true`). The seven skips are: - -* 5 skipped for `GWmodel` (`skip_if_not_installed`), which is not installed here -* 1 skipped for `brms`, likewise +On the environment above, `R CMD check --no-manual` on the built tarball -- +with the vignette built, the `GWmodel` stub and `brms` installed, and +`_R_CHECK_CRAN_INCOMING_=false` because `--as-cran` needs network access to +CRAN that this container does not have -- reports **1 NOTE and nothing else**. + +* **NOTE -- "Package suggested but not available for checking: 'cmdstanr'".** + Environmental, and expected: `cmdstanr` is not on CRAN. It is reached through + `Additional_repositories`, is used strictly conditionally via + `requireNamespace()`, and the `check-brms` CI job installs it. + +Everything previously recorded here as a blocker is resolved: + +* The **ERROR in "checking tests" is gone.** Those 15 failures were tests + asserting the pre-fix behaviour of `.morans_i_for_k()`. They have been + rewritten against the corrected contract, along with the tests that encoded + the pre-fix GP domain measure, GWR criterion column, Kish standard error and + subsampled design effect. `checking tests` passes. + +* The **non-ASCII WARNING** is gone: `checking R files for non-ASCII characters` + passes. The literal U+2014 EM DASH that sat inside a string literal in + `ensure_projected()`'s `target_crs` error message has been replaced with + `--`. Em dashes elsewhere in `R/` sit in comments and roxygen blocks, which + the check tolerates. + +* The **syntax-error WARNING** is gone: `checking R files for syntax errors` + passes with no output. It previously carried only a failed + `Sys.setlocale("LC_CTYPE", "en_US.UTF-8")` from the check's own locale switch. + +Two artefacts of this container are worth recognising if they appear again. +`checking package dependencies` emits +`Warning: unable to access index for repository ...` lines, because there is no +outbound network access here; it is not a check condition and does not affect +the status line. And building with `--no-build-vignettes` adds two WARNINGs +("Files in the 'vignettes' directory but no files in 'inst/doc'" and +"Directory 'inst/doc' does not exist") that a normal `R CMD build` does not +produce. + +`R CMD build` produces a 994 KB tarball, of which the built vignette HTML is the +bulk. `checking running R code from vignettes` passes. + +`testthat` reports **2126 passing, 0 failures, 0 errors, 9 skips** with +`NOT_CRAN=true` and both backends present. The nine skips are: + +* 5 Stan smoke tests in `test-bayes-smoke.R`, skipped because + `SPATIALKIT_TEST_BRMS` is unset -- `skip_if_not_installed("brms")` alone was + not enough, since these compile Stan models and would otherwise run in any + matrix job that happened to have `brms` * 1 Windows-only fallback path that cannot run on Linux +* 3 that skip *because* an optional backend is installed: they assert the + behaviour seen when `GWmodel` or `brms` is absent -With `GWmodel` and `brms` installed there would be none. Without `NOT_CRAN` set, -four further tests skip on purpose: they exercise `parallel::mclapply()` fork -behaviour, which is not appropriate to run on CRAN. +Under `R CMD check`, where `NOT_CRAN` is unset, four further tests skip on +purpose -- the `parallel::mclapply()` fork tests in `test-cv-parallel.R`, which +are `skip_on_cran()`. -This figure and the one in `README.md` describe the same run; the README does -not restate the count, precisely so the two cannot drift apart. +`README.md` does not restate these counts, precisely so the two cannot drift +apart. ## Breaking changes since the 1.0.0 tag @@ -110,13 +136,33 @@ Three exported functions have been removed: `evaluate_models()`, `evaluate_models_cv()` and `phi_prior_bounds()`. All three were thin wrappers the package's own documentation described as legacy, and each has a documented replacement (`compare_models()`, `compare_models_cv()` and -`gp_lengthscale_bounds()`). +`gp_lengthscale_bounds()`). `NAMESPACE` now exports 40 objects. Default results from `fit_bayesian_spatial_model()` also change, as a consequence of three corrections to the Gaussian process path (the basis count, the coordinate scaling, and the length-scale prior). The previous behaviour -remains reachable by passing `gp_k`, `gp_c` and `gp_iso` explicitly. `NEWS.md` -is the full record. +remains reachable by passing `gp_k`, `gp_c` and `gp_iso` explicitly. + +Three further corrections change results without being deliberate default +changes, so they are recorded under "Bug fixes" rather than "Breaking changes", +but a user upgrading should know about them: + +* `create_grid_polygons()` supplied with both `cellsize` and `n` used to return + a grid truncated to `n[1]` x `n[2]` cells anchored at the bounding-box corner, + silently covering only part of the boundary. `cellsize` now wins and `n` is + dropped with a logged warning. +* `fit_gwr_model()` used to refuse any response with exactly two distinct finite + values as "binary". A censored or saturated continuous measurement has two + distinct values and is a well-defined Gaussian GWR problem; the hard stop is + now gated on the response also being integer-like, and the non-integer case + warns and fits. Fits that used to error now run. +* `determine_optimal_levels()` no longer reports a Moran's I that is fixed by + arithmetic. Below a nine-cell floor the criterion returns `NA` and the call + falls back to the geometric ranking, which changes which cell counts it + returns at the default `max_levels`. + +`NEWS.md` is the full record: 20 breaking changes, 62 bug fixes, 13 new +features and 19 documentation entries relative to 1.0.0. ## What was wrong in 1.0.0 @@ -145,8 +191,9 @@ In descending order of user impact: making the basis count identically n. A model at n = 10,000 carried 10,000 basis functions. The count is now derived from the length-scale-to-domain ratio following Riutort-Mayol et al. (2023, Statistics and Computing 33:1). - Measured on the recorded baselines: at n = 2,000, `gp_k` 44 to 24 and the - basis count 1,936 to 576; at n = 10,000, 100 to 23 and 10,000 to 529; at + Measured on `dev/baseline-structural.rds`: at n = 2,000, `gp_k` 44 to 24 and + the basis count 1,936 to 576 on the elongated layout (44 to 22 and 1,936 to + 484 on the clustered one); at n = 10,000, 100 to 23 and 10,000 to 529; at n = 200 the basis is *larger* than before (225 to 529), which is the expected consequence of a correction rather than an optimisation. @@ -160,12 +207,49 @@ In descending order of user impact: 5. `make_folds(method = "nndm")` called `set.seed(seed)` unconditionally, and `seed` defaults to `NULL`. `set.seed(NULL)` re-initialises the RNG from the clock and process ID, so an ordinary call destroyed the caller's random - number stream. + number stream. Every seeded path is now guarded by an internal + `.with_seed()` helper that is a no-op when `seed` is `NULL`. 6. Cross-validation under `parallel = TRUE` was not reproducible; forked workers seeded themselves from the current time and process ID. -`NEWS.md` records roughly 100 further user-facing fixes and 14 new features. +A third audit pass found a further group of defects that returned a **plausible +wrong number** rather than failing, which is why they are called out here as +well as in `NEWS.md`. In each case the measurement is recorded there. + +7. `gwr_model_selection()` ranked models on AIC while labelling the answer + AICc: GWmodel's diagnostic table is built by `rbind()` over unnamed vectors + so it never carries column names, making the positional read the normal path + rather than a fallback, and column 2 is the uncorrected AIC. Executed, the + old column selected a model containing a pure-noise predictor that AICc drops. + +8. The calibrated GP length-scale prior never reached Stan. A `class = "lscale"` + prior with no `coef` is a *global* prior, which brms applies only to + coefficients that lack an individual prior — and every `lscale` coefficient + has one. Confirmed with `make_stancode()`. + +9. The GP basis was sized against the per-axis half-range while `brms::gp(c = )` + multiplies the full pooled range, so the boundary was twice as wide as + `gp_k` was sized for and the diagnostic meant to catch under-resolution was + twice too lenient. + +10. `fitted()` on a `gwr_fit` returned a local coefficient surface when a + predictor was named `fit`, `pred`, `prediction`, `fitted` or `yhat`; + executed in-sample R^2 was −1.18 against a true 0.981. + +11. `residual_morans_i()` put weight on a point's own residual whenever + coordinates were duplicated, and applied an exchangeable null to model + residuals. Both inflate significance; the corrected moments agree with + `spdep::lm.morantest()` to machine precision. + +12. `summarize_by_cell()`'s design-effect standard errors were too small + (95% coverage 0.63 at rho = 0.8), and a subsampled variogram design effect + answered for a cell of `deff_max_n` points rather than the cell's own size. + +13. `estimate_sac_range()` swept only two azimuths at ±22.5°, leaving half of + all directions covered by neither, and its `n_max` subsample was unseeded — + so the range was irreproducible above `n_max` and the caller's RNG was + advanced. ## Reverse dependencies @@ -191,12 +275,14 @@ None listed on the CRAN page for 1.0.0. Re-confirm with gates the relevant chunks on the result; the `ggplot2` gate is global, since every chunk in it either draws something or feeds something that does, so on a machine without `ggplot2` the vignette builds as code without output rather - than failing `R CMD build`. + than failing `R CMD build`. The vignette built and ran here with `ranger`, + `gstat`, `geometry` and `patchwork` present and `GWmodel` absent. * Exactly two examples are wrapped in `\dontrun{}`: `fit_bayesian_spatial_model()` and `cv_bayes()`, both of which run full MCMC via `brms` and require Stan compilation. Every other example runs, using `\donttest{}` plus a - `requireNamespace()` guard where it needs an optional backend. + `requireNamespace()` guard where it needs an optional backend. `checking + examples` passes. * Logging writes INFO+ to a session `tempdir()` file and WARN+ to the console (see `.onLoad` in `R/zzz.R`), all within a package-specific `logger` namespace diff --git a/dev/verify-gwr-aicc.R b/dev/verify-gwr-aicc.R new file mode 100644 index 0000000..7ea3089 --- /dev/null +++ b/dev/verify-gwr-aicc.R @@ -0,0 +1,88 @@ +#!/usr/bin/env Rscript +# --------------------------------------------------------------------------- +# Does GWmodel's gwr.model.selection() really report AICc in column 3? +# +# The whole third-pass GWR fix rests on this. GWmodel's own documentation and +# its Model.selection.r source say GWR.df is +# +# c(bandwidth, AIC, AICc, RSS) +# +# built by rbind() over UNNAMED vectors -- so the table never carries column +# names and the positional read is the path every real call takes. Column 2 is +# the UNCORRECTED AIC. Reading it ranks on AIC while labelling the answer AICc, +# which selects larger models and can keep a pure-noise predictor. +# +# That was verified against a faithful API stub, not the real package. This +# script settles it on a real GWmodel install. It does NOT trust the column +# order: it recomputes AICc independently for every candidate model with +# gwr.basic() and asks which column of GWR.df those numbers actually match. +# +# Rscript dev/verify-gwr-aicc.R +# --------------------------------------------------------------------------- + +for (p in c("sf", "sp", "GWmodel")) { + if (!requireNamespace(p, quietly = TRUE)) + stop("this script needs '", p, "' installed.", call. = FALSE) +} +suppressPackageStartupMessages({library(sf); library(sp); library(GWmodel)}) + +cat("GWmodel version:", as.character(utils::packageVersion("GWmodel")), "\n\n") + +set.seed(7) +n <- 200 +xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n), noise = rnorm(n)) +xy$y_resp <- 5 + 2 * xy$a - 1.5 * xy$b + rnorm(n, 0, 1) # `noise` is pure noise +spd <- SpatialPointsDataFrame(coords = as.matrix(xy[, c("x", "y")]), + data = xy[, c("a", "b", "noise", "y_resp")]) + +bw <- 60 +sel <- GWmodel::gwr.model.selection(DeVar = "y_resp", + InDeVars = c("a", "b", "noise"), + data = spd, bw = bw, + adaptive = TRUE, kernel = "bisquare") +model_list <- sel[[1]] +gwr_df <- sel[[2]] + +cat("GWR.df dim: ", paste(dim(gwr_df), collapse = " x "), "\n") +cat("GWR.df colnames: ", + if (is.null(colnames(gwr_df))) "" + else paste(colnames(gwr_df), collapse = ", "), "\n\n") + +# Independently recompute AIC and AICc for each candidate with gwr.basic(). +vars_of <- function(m) as.character(unlist(m[[2]], use.names = FALSE)) +ref <- t(vapply(model_list, function(m) { + v <- vars_of(m) + fml <- stats::reformulate(termlabels = v, response = "y_resp") + g <- GWmodel::gwr.basic(fml, data = spd, bw = bw, + adaptive = TRUE, kernel = "bisquare") + d <- g$GW.diagnostic + c(AIC = as.numeric(d$AIC), AICc = as.numeric(d$AICc)) +}, c(AIC = 0, AICc = 0))) + +tab <- data.frame( + model = vapply(model_list, function(m) paste(vars_of(m), collapse = " + "), + character(1)), + col2 = as.numeric(gwr_df[, 2]), + col3 = as.numeric(gwr_df[, 3]), + ref_AIC = ref[, "AIC"], ref_AICc = ref[, "AICc"] +) +print(tab, row.names = FALSE, digits = 7) + +close_to <- function(a, b) isTRUE(all.equal(a, b, tolerance = 1e-6)) +cat("\ncolumn 2 == independently computed AIC :", close_to(tab$col2, tab$ref_AIC), "\n") +cat("column 3 == independently computed AICc:", close_to(tab$col3, tab$ref_AICc), "\n") + +pick <- function(v) tab$model[which.min(v)] +cat("\nselected by column 2 (AIC) :", pick(tab$col2), "\n") +cat("selected by column 3 (AICc):", pick(tab$col3), "\n") + +ok <- close_to(tab$col3, tab$ref_AICc) && !close_to(tab$col2, tab$ref_AICc) +cat("\n", if (ok) + "PASS: AICc is column 3, and column 2 is not AICc. The fix reads the right column." + else + "FAIL: this GWmodel does NOT lay GWR.df out as c(bandwidth, AIC, AICc, RSS). Do not submit; tell Claude.", + "\n", sep = "") + +if (grepl("noise", pick(tab$col2)) && !grepl("noise", pick(tab$col3))) + cat("Confirmed on this data: AIC keeps the pure-noise predictor, AICc drops it.\n") diff --git a/inst/scripts/example_nc_demo.R b/inst/scripts/example_nc_demo.R index 64132c7..a831fe5 100644 --- a/inst/scripts/example_nc_demo.R +++ b/inst/scripts/example_nc_demo.R @@ -77,7 +77,10 @@ cat(" (set SPATIALKIT_DEMO_OUTPUT before sourcing to change it)\n\n") # 1. NORTH CAROLINA BOUNDARY # ============================================================================= # sf ships nc.shp (100 county polygons). Dissolve to a state outline and -# project to NAD83 / NC State Plane (ftUS) so distances are metric. +# project to NAD83 / NC State Plane (ftUS), EPSG:2264, so distances are planar +# rather than angular. Projected does not mean metric: 2264's unit is the US +# SURVEY FOOT, so every distance, bandwidth and block size below - and the +# autocorrelation range printed in section 6 - is in feet, not metres. nc_counties <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) nc_boundary <- nc_counties |> diff --git a/man/assign_features_to_polygons.Rd b/man/assign_features_to_polygons.Rd index cae6d3b..5a72ffd 100644 --- a/man/assign_features_to_polygons.Rd +++ b/man/assign_features_to_polygons.Rd @@ -43,6 +43,15 @@ already-assigned layer replaces the old IDs rather than failing. \description{ Joins an sf layer of input features to a polygon layer via spatial join. } +\details{ +This is the second step of the package's pipeline: it labels every +observation with the cell it falls in, which is what +\code{\link[=summarize_by_cell]{summarize_by_cell()}} then aggregates over. Reach for it directly (rather +than for \code{\link[sf:st_join]{sf::st_join()}}) when the join has to be \emph{unambiguous} --- it +resolves features matching several polygons by an explicit \code{tie_break} rule +instead of silently duplicating rows, so the assigned layer keeps one row +per input feature and cell-level counts mean what they say. +} \examples{ library(sf) set.seed(1) @@ -57,3 +66,12 @@ grid <- create_grid_polygons(bnd, target_cells = 9, type = "square") assigned <- assign_features_to_polygons(pts, grid) table(assigned$poly_id) } +\seealso{ +\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{summarize_by_cell}()} +} +\concept{aggregation} diff --git a/man/build_tessellation.Rd b/man/build_tessellation.Rd index 07aa902..eaa5096 100644 --- a/man/build_tessellation.Rd +++ b/man/build_tessellation.Rd @@ -20,7 +20,13 @@ build_tessellation( \arguments{ \item{points_sf}{An sf object with POINT/MULTIPOINT geometry.} -\item{boundary}{Optional polygonal sf/sfc.} +\item{boundary}{Polygonal sf/sfc study area. \strong{Required} for +\code{method = "hex"} and \code{method = "square"}, which have no extent of their +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}.} \item{method}{One of "voronoi", "triangles", "hex", "square".} @@ -57,7 +63,26 @@ carry \code{poly_id}, which holds the same values.} } } \description{ -Build a tessellation (Voronoi, Delaunay triangles, hex grid, or square grid) +The single entry point for turning a point pattern into analysis regions, and +the first step of the package's pipeline. It wraps the four tessellation +methods behind one interface that handles CRS projection, clipping and stable +cell identifiers consistently, and returns the cell layer together with the +point-to-cell index that \code{\link{assign_features_to_polygons}()} and +\code{\link{summarize_by_cell}()} consume. Use it rather than the +individual constructors whenever you might want to compare methods: the +return shape does not change with \code{method}, so swapping +\code{"voronoi"} for \code{"hex"} costs one argument. +} +\details{ +Which method to reach for. \code{"voronoi"} gives one cell per point, so +resolution follows sampling density -- the choice when the observations +themselves define the regions. \code{"hex"} and \code{"square"} give +equal-area cells on a fixed grid, so cell size is a decision you make rather +than one the data makes for you; hexagons avoid the axis-aligned artefacts of +squares and have uniform neighbour distances. \code{"triangles"} returns +the Delaunay triangulation, useful for interpolation and adjacency work +rather than as an aggregation unit. \code{\link{determine_optimal_levels}()} +will suggest a cell count from the spatial structure of the data. } \examples{ library(sf) diff --git a/man/clear_fitted_cache.Rd b/man/clear_fitted_cache.Rd index 15cf6fd..3d7ef2d 100644 --- a/man/clear_fitted_cache.Rd +++ b/man/clear_fitted_cache.Rd @@ -15,6 +15,13 @@ clear_fitted_cache(object) \description{ Removes the lazily-cached \code{fitted()} result so that the next call recomputes from the posterior. This is only necessary if the underlying -\code{brmsfit} engine or training data has been manually mutated after -fitting — normal usage never requires it. +\code{brmsfit} engine has been manually mutated after fitting -- a change to +\code{data_sf} invalidates the entry on its own, because the cached value +carries a digest of the data it was computed from (see +\code{\link{fitted.bayesian_fit}}). Normal usage never requires it. +} +\details{ +The cache environment is shared by every copy of a fit, so clearing it +through one copy clears it for all of them. That is harmless: the others +recompute. } diff --git a/man/clip_target_for.Rd b/man/clip_target_for.Rd index a082b3b..a03cd77 100644 --- a/man/clip_target_for.Rd +++ b/man/clip_target_for.Rd @@ -26,5 +26,13 @@ the layer is returned in the automatically selected local projected CRS, not the input CRS; a message reports this unless \code{quiet = TRUE}. } \description{ -Build a polygonal clip target from points and/or a boundary +Resolves the single polygon that every tessellation method clips against. +With a \code{boundary} it is that boundary (optionally buffered by \code{expand}); +without one it is the convex hull of \code{points_sf}, again optionally buffered. +Reach for it when you want to see or reuse the exact clip target +\code{\link[=build_tessellation]{build_tessellation()}} will apply — for instance to check that a study-area +polygon actually contains the observations before tessellating, or to pass +the same envelope to \code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}} and +\code{\link[=create_grid_polygons]{create_grid_polygons()}} so that two tessellations of one dataset cover +identical ground. } diff --git a/man/coef.bayesian_fit.Rd b/man/coef.bayesian_fit.Rd index 498980b..dcd0ac8 100644 --- a/man/coef.bayesian_fit.Rd +++ b/man/coef.bayesian_fit.Rd @@ -18,5 +18,11 @@ A matrix of fixed-effect posterior summaries, as returned by in \code{\link{new_spatial_fit}}. } \description{ -Extract Bayesian model fixed-effect summaries +Returns the posterior summary of the global (non-spatial) regression terms: +estimate, error and credible interval per predictor, as +\code{brms::fixef()} reports them. Reach for it to read the average effect +of a predictor with its uncertainty attached -- the Bayesian counterpart to +a coefficient table -- remembering that the Gaussian-process term has +already absorbed the spatially structured part of the signal, so these are +effects net of location. } diff --git a/man/coef.gwr_fit.Rd b/man/coef.gwr_fit.Rd index 72c6955..211b1de 100644 --- a/man/coef.gwr_fit.Rd +++ b/man/coef.gwr_fit.Rd @@ -12,11 +12,35 @@ \item{...}{Ignored.} } \value{ -A data.frame of local coefficient estimates (one row per obs). +A data.frame of local coefficient estimates: one row per +observation, one column per model term. 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}}. } \description{ -Extract GWR local coefficients +Returns the whole surface of coefficients -- one row per observation, one +column per term -- rather than the single global vector \code{coef()} +returns for an \code{lm}. That table is the point of fitting a GWR at all: +inspect the spread of a predictor's column to see where, and by how much, +its relationship with the response changes across the study area, and join +it back to \code{object$data_sf} to map it. Use +\code{\link{plot.spatial_fit}()} for a quick look at that map. } +\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 +(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 +names its coefficient columns differently -- the whole slot is returned with +a warning saying so, rather than an error or a silently short table. +} + diff --git a/man/compare_models.Rd b/man/compare_models.Rd index eed40e7..b2e608c 100644 --- a/man/compare_models.Rd +++ b/man/compare_models.Rd @@ -7,14 +7,22 @@ compare_models(fits, newdata = NULL, ...) } \arguments{ -\item{fits}{A named list of \code{spatial_fit} objects.} +\item{fits}{A named list of \code{spatial_fit} objects. Names must be +unique; see \code{\link{evaluate_insample}}.} \item{newdata}{Optional sf for out-of-sample evaluation.} \item{...}{Extra arguments passed to predict().} } \value{ -A data.frame comparing all models. +A data.frame comparing all models. Alongside the metrics it carries +\code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and +\code{resid_morans_null} --- the last naming which 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. The +significant-autocorrelation warning below is driven by that p-value, so +read its caveats in \code{?residual_morans_i} before treating silence as +evidence of no residual structure. } \description{ Takes a named list of already-fit \code{spatial_fit} objects and produces diff --git a/man/compare_models_cv.Rd b/man/compare_models_cv.Rd index b6bf157..36f9913 100644 --- a/man/compare_models_cv.Rd +++ b/man/compare_models_cv.Rd @@ -33,7 +33,10 @@ compare_models_cv( Names outside that set raise a warning and are dropped; if nothing recognised remains, this is an error rather than a silent fallback. A recognised model whose backend package is not installed is dropped with -a message.} +a message so the call still returns the models that could run --- but if +\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.} \item{k}{Number of folds. Default 5.} @@ -68,6 +71,11 @@ to \code{ranger::ranger()}.} \value{ A list with overall, by_fold, and per-model cv_results (\code{gwr_cv}, \code{bayes_cv}, \code{rf_cv} for the models that ran). +Only the models that actually ran appear, so check which names are present +rather than assuming one entry per requested model: a backend whose package +is missing is dropped with a message. When \strong{no} requested backend +is available there is nothing to return and the function errors with +\code{"no viable models."} instead of returning an empty comparison. } \description{ Fits and cross-validates one or more model types, returning a unified diff --git a/man/create_grid_polygons.Rd b/man/create_grid_polygons.Rd index c8a58a3..397ed32 100644 --- a/man/create_grid_polygons.Rd +++ b/man/create_grid_polygons.Rd @@ -25,11 +25,18 @@ substantially from the requested value.} \item{type}{Grid type: \code{"square"} (the default) or \code{"hex"}.} -\item{cellsize}{Optional numeric cell size (length 1 or 2).} +\item{cellsize}{Optional numeric cell size (length 1 or 2), in the units of +the working CRS. Takes precedence over \code{n}: if both are supplied, +\code{cellsize} is used, \code{n} is ignored and a warning is logged. Supply exactly +one of \code{target_cells}, \code{cellsize} and \code{n}.} -\item{n}{Optional grid resolution (integer, length 1 or 2). Applies to -square grids only; \code{\link[sf:st_make_grid]{sf::st_make_grid()}} derives hexagon placement from -\code{cellsize} alone.} +\item{n}{Optional grid resolution (integer, length 1 or 2) giving the number +of columns and rows to divide the boundary's bounding box into; the cell +size is derived from it. Applies to square grids only; \code{\link[sf:st_make_grid]{sf::st_make_grid()}} +derives hexagon placement from \code{cellsize} alone. Ignored (with a logged +warning) when \code{cellsize} is also supplied — passing both would otherwise +truncate the grid to \code{n[1]} x \code{n[2]} cells anchored at the bounding-box +corner, covering only part of the boundary.} \item{clip}{Logical; clip grid to boundary.} @@ -43,7 +50,20 @@ grid; a message reports this unless \code{quiet = TRUE}.} An sf polygon layer with poly_id column. } \description{ -Create square or hexagonal grid polygons over a boundary +Lays a regular grid of equal-area cells over \code{boundary} and clips it to that +boundary. Reach for this rather than \code{\link[=create_voronoi_polygons]{create_voronoi_polygons()}} when cell +size should be a decision you make — because you need per-cell rates +comparable across the map, or a resolution that stays fixed as the sample +grows — instead of one dictated by where the observations happen to be. +Hexagons (\code{type = "hex"}) avoid the axis-aligned artefacts of squares and +give every cell the same distance to all six neighbours, which matters for +anything that reads neighbourhoods. +} +\details{ +Size the grid with exactly one of \code{target_cells} (roughly how many cells you +want, the package derives the rest), \code{cellsize} (a fixed edge length in CRS +units) or \code{n} (a fixed number of columns and rows). See \verb{@param cellsize} +for what happens when more than one is given. } \examples{ library(sf) diff --git a/man/create_voronoi_polygons.Rd b/man/create_voronoi_polygons.Rd index b9ab029..496cd73 100644 --- a/man/create_voronoi_polygons.Rd +++ b/man/create_voronoi_polygons.Rd @@ -33,7 +33,21 @@ create_voronoi_polygons( A list with cells, index, boundary, method, params. } \description{ -Create Voronoi polygons from points with robust CRS and optional clipping +Assigns every location in the study area to its nearest input point, giving +one cell per point. This is the tessellation to reach for when the +observations themselves define the regions of interest — sampling sites, +monitoring stations, service points — because cell size then adapts to +sampling density instead of being imposed by a fixed grid: dense areas get +small cells and sparse areas large ones. Prefer \code{\link[=create_grid_polygons]{create_grid_polygons()}} +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 +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 +stable \code{cell_id} values. } \examples{ library(sf) diff --git a/man/cv_bayes.Rd b/man/cv_bayes.Rd index 42257a5..6dc7577 100644 --- a/man/cv_bayes.Rd +++ b/man/cv_bayes.Rd @@ -79,7 +79,22 @@ rows; an unweighted average would not be the pooled quantity when fold sizes differ, which for spatially blocked folds they routinely do. } \description{ -K-fold cross-validation for the Bayesian spatial model +Refits the Gaussian-process model of +\code{\link{fit_bayesian_spatial_model}()} on each training fold and scores +it on the held-out fold. Beyond the point-prediction metrics the other CV +wrappers report, this one scores the whole predictive \emph{distribution}: +\code{predictive_coverage} says what fraction of held-out observations fell +inside the 50/80/95\\% intervals, and \code{mean_CRPS} rates sharpness and +calibration together. That is the reason to reach for it -- a Bayesian model +is usually chosen for its uncertainty, and only held-out coverage shows +whether those intervals are honest at locations the model has not seen. +} +\details{ +It is the most expensive wrapper in the package by a wide margin: every fold +is a full MCMC run. Use few folds, and \code{parallel = TRUE} if you have +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. } \examples{ \dontrun{ diff --git a/man/cv_gwr.Rd b/man/cv_gwr.Rd index 19b1d3a..7755ff7 100644 --- a/man/cv_gwr.Rd +++ b/man/cv_gwr.Rd @@ -67,7 +67,24 @@ value rather than only in a warning, since \code{overall} is a well-formed all-\code{NA} row either way. } \description{ -K-fold cross-validation for GWR +Refits a geographically weighted regression from scratch on each training +fold and scores it on the held-out fold, so the reported error is what the +model achieves at locations it did not see. Reach for it whenever you need +a defensible accuracy figure for a GWR: the in-sample \eqn{R^2} that +\code{\link{model_metrics}()} reports on a \code{gwr_fit} is close to +meaningless, because a local regression with a small bandwidth can track the +training points almost exactly. Bandwidth is re-selected per fold unless you +fix it with \code{bandwidth}, which keeps the selection itself inside the +cross-validation rather than tuning on the full data first. +} +\details{ +Folds default to spatial blocks (\code{\link{make_folds}(method = +"block_kfold")}), not random ones -- with autocorrelated data a random +split leaves a held-out point's neighbours in the training set and the score +comes back flattering. Use \code{\link{cv_bayes}()} for the same treatment +of a Bayesian GP model, \code{\link{cv_rf}()} for a forest, and +\code{\link{compare_models_cv}()} to score several backends on one set of +folds. } \examples{ \donttest{ diff --git a/man/cv_spatial.Rd b/man/cv_spatial.Rd index 33517f6..6e07af0 100644 --- a/man/cv_spatial.Rd +++ b/man/cv_spatial.Rd @@ -29,7 +29,13 @@ cv_spatial( \item{predictor_vars}{Predictor column names.} -\item{fit_fn}{A function(train_sf) that returns a \code{spatial_fit}.} +\item{fit_fn}{A function of one argument, the training slice of +\code{data_sf}, returning a \code{spatial_fit} built with +\code{\link{new_spatial_fit}()}. It is called once per fold on the +training rows only, so anything done inside it -- scaling, tuning, an inner +variable sweep -- is already nested and leak-free. The \code{subclass} it +stamps must have a \code{predict.()} method registered, because +that is how each fold is scored.} \item{folds}{Optional fold definitions. Built via block_kfold if NULL.} @@ -79,7 +85,47 @@ Run K-fold CV for any model that returns a \code{spatial_fit} object. This is the extensibility point: to plug in a new model type, supply a \code{fit_fn(train_sf)} that returns a \code{spatial_fit}. } +\examples{ +library(sf) +set.seed(1) +n <- 80 +site <- st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), + coords = c("x", "y"), crs = 32632 +) +site$price <- 10 + 0.01 * st_coordinates(site)[, 1] + 2 * site$elev + rnorm(n) + +# 1. A fit_fn returning a spatial_fit of your own subclass. +lm_fit <- function(train_sf) { + new_spatial_fit( + subclass = "lm_fit", + engine = lm(price ~ elev, st_drop_geometry(train_sf)), + formula = price ~ elev, + response_var = "price", + predictor_vars = "elev", + data_sf = train_sf + ) +} + +# 2. The predict() method cv_spatial() scores each fold with. Without it +# every fold fails and `overall` comes back all-NA. +predict.lm_fit <- function(object, newdata = NULL, ...) { + if (is.null(newdata)) newdata <- object$data_sf + as.numeric(stats::predict(object$engine, st_drop_geometry(newdata))) +} +registerS3method("predict", "lm_fit", predict.lm_fit) + +cv <- cv_spatial(site, "price", "elev", fit_fn = lm_fit, k = 3, seed = 1) +cv$overall +# Compare these before trusting the metrics above. +c(attempted = cv$n_folds_attempted, succeeded = cv$n_folds_succeeded) +} \seealso{ +\code{\link{new_spatial_fit}()} for the constructor a \code{fit_fn} +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}()}, diff --git a/man/determine_optimal_levels.Rd b/man/determine_optimal_levels.Rd index 03abb03..4065b15 100644 --- a/man/determine_optimal_levels.Rd +++ b/man/determine_optimal_levels.Rd @@ -33,18 +33,22 @@ large \code{top_n} is; only the model-aware criteria can return more.} \code{predictor_vars}, enables model-aware level selection via Moran's I on OLS residuals.} -\item{predictor_vars}{Optional predictor column names. Must be numeric; -factor/character columns raise an error.} +\item{predictor_vars}{Optional predictor column names. Must be numeric or +logical (logicals are read as 0/1); factor/character columns raise an +error.} \item{criterion}{One of \code{"geometric"} (default when no response given), -\code{"morans_i"} (select k that minimizes |Moran's I|), or -\code{"combined"} (rank-average of WSS elbow distance and |Moran's I|). -Falls back to \code{"geometric"} if response/predictors are unavailable.} +\code{"morans_i"} (select the k whose residual Moran's I is least +\emph{significant}), or \code{"combined"} (rank-average of WSS elbow +distance and that same quantity). Falls back to \code{"geometric"} if +response/predictors are unavailable, and also when no candidate clears the +nine-cell resolution floor described in \strong{Details}.} } \value{ An integer vector of candidate level counts. When \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is -attached with per-k Moran's I values — except when the model-aware path +attached with per-k Moran's I values (\code{moran_i}) and their +standardised deviates (\code{moran_z}) — except when the model-aware path itself falls back to the geometric result (no viable k in the elbow neighbourhood, or Moran's I could not be computed for any candidate), in which case no diagnostics are available and the attribute is absent. Both @@ -71,6 +75,38 @@ lazily: k-means is re-run only for a focused neighbourhood around the elbow (±4 by default, or ±\code{top_n} if larger), so that only the most promising candidate k values incur the cost of the full Moran's I computation. + +\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 +tessellation is capturing anything. Measured over 300 replicates of a +response with \emph{no} spatial structure, mean \eqn{|I|} fell monotonically +from 0.114 at \code{k = 10} to 0.050 at \code{k = 60} (\eqn{-56\%}), which +made an \eqn{|I|} ranking prefer the largest candidate for arithmetic +reasons alone. Candidates are therefore ordered by +\eqn{|z| = |I - E[I]| / \mathrm{sd}(I)} using the Cliff & Ord regression +residual moments --- exact here, because the cell-level residuals are OLS +residuals by construction. Over the same runs \eqn{z} had mean \eqn{\approx +0}, \eqn{\mathrm{sd} \approx 1} and a two-sided 5\\% rejection rate of +0.040--0.057 at every \code{k}. Both quantities are reported in the +\code{"diagnostics"} attribute, as \code{moran_i} and \code{moran_z}. + +\strong{Resolution floor on the model-aware criteria.} Moran's I is +computed on cell-level residuals with an 8-nearest-neighbour weight matrix, +so it only carries information once there are more than nine cells. At nine +or fewer, every cell is a neighbour of every other, the row-standardised +weight matrix is complete, and Moran's I collapses to exactly +\eqn{-1/(k - 1)} for \emph{any} residual vector — a function of \code{k} +alone, and one whose magnitude shrinks monotonically with \code{k}, which +would make \code{criterion = "morans_i"} prefer the largest candidate every +time. Those candidates therefore return \code{NA} and are excluded from the +model-aware ranking. When no candidate in the elbow neighbourhood clears +the floor — which is the usual outcome for small \code{max_levels} — the +whole call falls back to the geometric ranking and logs a warning; raise +\code{max_levels} above roughly 10 if you want the model-aware criteria to +contribute. Under \code{criterion = "combined"}, a candidate below the +floor that sits alongside candidates above it is ranked last on the Moran's +I axis while still competing on the geometric axis. } \examples{ library(sf) @@ -83,3 +119,13 @@ pts <- st_as_sf( ) determine_optimal_levels(pts, max_levels = 6) } +\seealso{ +\code{\link[=build_tessellation]{build_tessellation()}}, which takes the chosen level count as +\code{approx_n_cells}; \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{summarize_by_cell}()} +} +\concept{aggregation} diff --git a/man/ensure_projected.Rd b/man/ensure_projected.Rd index d742235..79d992b 100644 --- a/man/ensure_projected.Rd +++ b/man/ensure_projected.Rd @@ -21,11 +21,50 @@ x, potentially with a new projected CRS. Coerces spatial objects to a projected coordinate reference system suitable for distance/area calculations. } +\details{ +An object that already has a projected CRS is returned untouched. Only +geographic (lon/lat) input is transformed, and the CRS chosen depends on the +extent of the data — it is \strong{not} always UTM: + +\describe{ +\item{Local extents}{The UTM zone containing the data's centre +(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.} +\item{Wide extents}{Once the data reach well beyond the roughly 3 degrees +a UTM zone is designed for, a single zone would distort distances by +several percent — and that error propagates straight into variogram +ranges, block sizes, GWR bandwidths and GP length-scales. An equal-area +projection centred on the data is used instead: Albers conic +(\code{+proj=aea}) for extents wider than tall, Lambert azimuthal +(\code{+proj=laea}) otherwise. A warning names the projection, the span that +triggered it, and this argument.} +\item{Missing CRS}{If \code{x} has no CRS at all but its bounding box looks +like lon/lat, EPSG:4326 is assumed with a warning, then the rules above +apply. Set the CRS explicitly to suppress it.} +} + +\code{target_crs} overrides all of this: pass it whenever you need a specific, +reproducible projection — comparing runs, matching an existing layer, or +fixing the units that \code{\link[=make_folds]{make_folds()}}'s \code{block_size} will be interpreted in. +} \examples{ library(sf) pts_ll <- st_as_sf( data.frame(lon = c(9.1, 9.2), lat = c(48.7, 48.8)), coords = c("lon", "lat"), crs = 4326 ) -st_crs(ensure_projected(pts_ll))$epsg # auto-selected UTM zone (32632) +# A local extent gets the containing UTM zone. +st_crs(ensure_projected(pts_ll))$epsg # 32632 + +# A continental extent gets an equal-area projection instead, with a +# warning naming it -- see Details. +wide <- st_as_sf( + data.frame(lon = c(-120, -70), lat = c(30, 48)), + coords = c("lon", "lat"), crs = 4326 +) +st_crs(ensure_projected(wide))$proj4string + +# target_crs overrides the choice entirely. +st_crs(ensure_projected(pts_ll, target_crs = 3035))$epsg # 3035 } diff --git a/man/estimate_sac_range.Rd b/man/estimate_sac_range.Rd index 7623c99..7fe365b 100644 --- a/man/estimate_sac_range.Rd +++ b/man/estimate_sac_range.Rd @@ -11,7 +11,7 @@ estimate_sac_range( n_max = 5000L, cutoff = 0.5, range_frac = 1, - seed = NULL + seed = 123L ) } \arguments{ @@ -41,7 +41,14 @@ observed lags rather than a long autocorrelation range. Passing it to single block. Default 1.0; raise it to accept ranges extrapolated beyond the fitted lags.} -\item{seed}{Optional RNG seed for subsampling reproducibility.} +\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 rather than 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 +different number to check how sensitive the estimate is to the subsample. +Ignored when \code{nrow(points_sf) <= n_max}, where nothing is sampled.} } \value{ A single value of class \code{sac_range}, which behaves as an @@ -49,8 +56,9 @@ ordinary number. There are three shapes, and they carry different attributes: \describe{ \item{Success}{A positive effective range in projected coordinate units, -with the fit attached as attributes \code{directional} (the 0° and 90° -ranges), \code{anisotropy} (their ratio), \code{max_dist}, +with the fit attached as attributes \code{directional} (the 0°, 45°, +90° and 135° ranges, named by azimuth), \code{anisotropy} (largest +over smallest), \code{max_dist}, \code{cutoff_dist}, \code{variogram} (the empirical variogram) and \code{variogram_model} (the fitted \code{gstat} model), so the fit can be inspected rather than trusted.} @@ -79,19 +87,29 @@ Fits exponential (or spherical) variogram models and returns the } \details{ To guard against anisotropy, the function first estimates directional -variograms at 0° (N–S) and 90° (E–W) azimuths (tolerance 22.5°, -which avoids double-counting point pairs near the 45° diagonal but -requires denser point clouds for stable estimates). -When both fits succeed the \strong{maximum} of the two directional ranges -is returned, which is the conservative choice for spatial block CV — -blocks must be at least as large as the longest autocorrelation range to -avoid information leakage. +variograms at 0° (N–S), 45°, 90° (E–W) and 135° azimuths, each with a +±22.5° tolerance. Those four windows tile all 180 distinct azimuths +exactly once, with no gap and no double-counted pair. When all four fits +succeed the \strong{maximum} of the four directional ranges is returned, +which is the conservative choice for spatial block CV — blocks must be at +least as large as the longest autocorrelation range to avoid information +leakage. -If either directional fit fails (e.g., too few point pairs in a direction), -the function falls back to an omnidirectional (isotropic) variogram. +Sweeping only 0° and 90° would leave the azimuths between 23° and 67°, and +between 113° and 157°, covered by neither window: on simulated fields with a +3:1 anisotropy and a true major-axis range of 300, a two-direction sweep +recovered 255 and 249 for major axes at 0° and 90° but only 151 and 147 at +45° and 135°. Since \code{make_folds(auto_range = TRUE)} sizes its blocks +from this number, that halved the blocks for a diagonally oriented field. -A log warning is emitted when notable anisotropy is detected (ratio of -directional ranges > 1.5). +If any directional fit fails (e.g., too few point pairs in a direction), +the function falls back to an omnidirectional (isotropic) variogram rather +than taking the maximum over the directions that did fit — which would bias +the answer downward precisely when the widest direction is the one that +failed. + +A log warning is emitted when notable anisotropy is detected (ratio of the +largest to the smallest directional range > 1.5). The returned range is in the coordinate units of the (projected) data and can be passed directly to \code{make_folds(block_size = ...)} to ensure diff --git a/man/evaluate_insample.Rd b/man/evaluate_insample.Rd index a443a19..2f6dec1 100644 --- a/man/evaluate_insample.Rd +++ b/man/evaluate_insample.Rd @@ -10,7 +10,9 @@ evaluate_insample(fits, newdata = NULL, ...) \item{fits}{A \code{spatial_fit} object, or a named list of them (e.g. \code{list(GWR = gwr_obj, Bayesian = bayes_obj)}). The names are used as the model labels and every element must have one; an unnamed -list is an error.} +list is an error, and so are duplicated names --- \code{model} is the key +the comparison table is assembled on, so two fits sharing a name cannot be +told apart in the output.} \item{newdata}{Optional sf object for out-of-sample evaluation. Must contain the response variable and all predictors. diff --git a/man/fit_bayesian_spatial_model.Rd b/man/fit_bayesian_spatial_model.Rd index 3fa8558..1d59722 100644 --- a/man/fit_bayesian_spatial_model.Rd +++ b/man/fit_bayesian_spatial_model.Rd @@ -116,25 +116,56 @@ 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_lengthscale_bounds -- the \code{c(lower, upper)} the length-scale prior -was calibrated over; gp_lscale_prior, loo, looic, +was calibrated over; gp_lscale_prior -- the length-scale prior +\code{brms::validate_prior()} reports the model will \emph{actually} use, +which is not necessarily the one this function requested (several entries, +semicolon-separated, if brms resolved the axes differently); loo, looic, convergence_ok, convergence_diagnostics). The raw brmsfit is in \code{$engine}. } \description{ -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, rather than left in 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 +\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. } \details{ +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 +\emph{varies} across the map. Choose \code{\link{fit_rf_model}()} when +predictive accuracy matters more than an interpretable model and the +response is non-linear in the predictors. The cost here is time: this is +full MCMC via 'brms' and Stan, so it is minutes rather than seconds, and the +GP is fitted through a reduced-rank basis approximation whose size +(\code{gp_k}) trades fidelity against runtime. + \strong{GP basis count and boundary factor.} \code{brms::gp()} builds a full tensor grid over its covariates, so a term \code{gp(..x, ..y, k = gp_k)} carries \code{gp_k^2} basis functions -- the \code{gp_k} argument is the count \emph{per dimension}, not the total rank. Both \code{gp_k} and \code{gp_c} are therefore chosen from the ratio of the -estimated length-scale to the domain half-range, following +estimated length-scale to the domain extent, following Riutort-Mayol et al. (2023), rather than from the number of observations: \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}. +The domain extent used is the one \code{brms::gp(c = )} itself multiplies: +the full pooled range of the column-centred coordinates +(\code{brms:::choose_L()}), not the per-axis half-range in which +Riutort-Mayol et al. state their inequalities. Both constraints are really +constraints on the boundary \eqn{L = c \times S}, so expressing them in +brms's units is what keeps \code{gp_c}, \code{gp_k} and +\code{$info$gp_ell_min} describing the basis brms actually builds. A +\code{gp_c} derived on the half-range convention and handed to +\code{brms::gp()} produces a boundary twice as wide as intended, against +which \code{gp_k} under-resolves by a factor of two. + The GP term is built with \code{scale = FALSE}. \code{brms::gp()} otherwise rescales its covariates so the maximum Euclidean distance between two points is 1, and reports \code{lscale} in that space; since this function already @@ -201,6 +232,7 @@ Gaussian processes for probabilistic programming. Other model fitting: \code{\link{fit_gwr_model}()}, \code{\link{fit_rf_model}()}, +\code{\link{new_spatial_fit}()}, \code{\link{prep_model_data}()} } \concept{model fitting} diff --git a/man/fit_gwr_model.Rd b/man/fit_gwr_model.Rd index 8d3ce63..c4e6c33 100644 --- a/man/fit_gwr_model.Rd +++ b/man/fit_gwr_model.Rd @@ -90,6 +90,7 @@ if (requireNamespace("GWmodel", quietly = TRUE) && Other model fitting: \code{\link{fit_bayesian_spatial_model}()}, \code{\link{fit_rf_model}()}, +\code{\link{new_spatial_fit}()}, \code{\link{prep_model_data}()} } \concept{model fitting} diff --git a/man/fit_rf_model.Rd b/man/fit_rf_model.Rd index 15d11c1..bcb2ba2 100644 --- a/man/fit_rf_model.Rd +++ b/man/fit_rf_model.Rd @@ -137,6 +137,7 @@ solution. \emph{BMC Bioinformatics} 8, 25. \doi{10.1186/1471-2105-8-25} Other model fitting: \code{\link{fit_bayesian_spatial_model}()}, \code{\link{fit_gwr_model}()}, +\code{\link{new_spatial_fit}()}, \code{\link{prep_model_data}()} } \concept{model fitting} diff --git a/man/fitted.bayesian_fit.Rd b/man/fitted.bayesian_fit.Rd index ae5559a..995248e 100644 --- a/man/fitted.bayesian_fit.Rd +++ b/man/fitted.bayesian_fit.Rd @@ -28,7 +28,27 @@ environment carried in \code{object$info$.cache} (reference semantics, so it survives R's copy-on-modify). The cache holds epred column means only, which is why \code{predict(object, summary = "median")} and \code{predict(object, type = "predict")} recompute rather than reuse it. -Call \code{\link{clear_fitted_cache}} if the engine or the training data has -been mutated by hand after fitting. +Call \code{\link{clear_fitted_cache}} if the engine has been mutated by hand +after fitting. +} + +\section{The cache is shared by copies, and validated}{ + +An environment has reference semantics, which is what makes the memo survive +R's copy-on-modify -- but it also means \code{fit2 <- fit} gives the two +objects \emph{the same} cache. Assigning a different \code{data_sf} to the +copy would then have returned the original's cached values, at the original's +length, which \code{residuals()} silently recycled against the copy's shorter +response. The entry therefore carries the \code{n} and a digest of the +training data it was computed from, and is recomputed whenever either fails +to match, so a copy with different data recomputes instead of reading the +original's answer. + +Two consequences of the shared environment remain and cannot be removed from +here: \code{\link{clear_fitted_cache}} on one copy empties the cache both +share (harmless -- the other simply recomputes), and \code{identical()} +cannot distinguish two fits by their caches. The digest covers +\code{data_sf} only, not \code{$engine}: a hand-mutated \code{brmsfit} is +what \code{\link{clear_fitted_cache}} is for. } diff --git a/man/get_voronoi_seeds.Rd b/man/get_voronoi_seeds.Rd index 21f6887..0dedbdd 100644 --- a/man/get_voronoi_seeds.Rd +++ b/man/get_voronoi_seeds.Rd @@ -23,7 +23,15 @@ get_voronoi_seeds( \item{n}{Integer; number of seeds to return. Required for \code{method = "kmeans"} and \code{method = "random"}. \strong{Ignored} for \code{method = "provided"}, where every row of \code{seeds} is returned; a mismatch -between \code{n} and \code{nrow(seeds)} is reported as a warning.} +between \code{n} and \code{nrow(seeds)} is reported as a warning. + +For \code{method = "kmeans"} it is an upper bound rather than a guarantee: +k-means cannot produce more centres than there are distinct positions in +the sampling cloud, nor as many centres as there are rows. When \code{n} +exceeds either ceiling it is clamped, with a warning naming the count +actually used — \code{n = nrow(sample_points)} is the common case, and yields +\code{nrow(sample_points) - 1} seeds. Check \code{nrow()} on the result rather than +assuming \code{n}.} \item{seeds}{sf POINT object of user-provided seeds (method = "provided").} diff --git a/man/gwr_model_selection.Rd b/man/gwr_model_selection.Rd index a8e1abb..65e11bc 100644 --- a/man/gwr_model_selection.Rd +++ b/man/gwr_model_selection.Rd @@ -69,7 +69,8 @@ candidate set the sweep ran over, both echoed by \code{print()}); \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, for \code{GWmodel::gwr.model.view()}). +(GWmodel's unmodified return: the two-element list of its model list and +its diagnostic table). } \description{ Wraps \code{GWmodel::gwr.model.selection()}, which grows a GWR model one @@ -113,6 +114,21 @@ The sweep fits \code{p * (p + 1) / 2} GWR models for \code{p} candidates -- \code{max_models} stops the call rather than letting it run 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 +\preformatted{ + GWmodel::gwr.model.view(sel$response_var, sel$candidate_vars, sel$raw[[1]]) +} +-- \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. +} + \examples{ \donttest{ if (requireNamespace("GWmodel", quietly = TRUE) && diff --git a/man/make_folds.Rd b/man/make_folds.Rd index 50518db..482ea44 100644 --- a/man/make_folds.Rd +++ b/man/make_folds.Rd @@ -47,10 +47,21 @@ Ignored when \code{block_size} or \code{auto_range} override them.} \item{block_multiplier}{Numeric; target blocks multiplier. Default 3.} -\item{block_size}{Optional positive numeric minimum block edge length -(in projected CRS units). 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}.} +\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}. + +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 +(lon/lat) input is projected first by \code{\link{ensure_projected}()}, +which picks a local UTM zone or, at wide extents, an equal-area +projection — a CRS you did not choose, whose units are metres but whose +identity varies with the data. \code{block_size} is then interpreted in +\emph{that} CRS. The CRS actually used is recorded in +\code{params$crs} of the returned list; project the data yourself before +calling if you want to fix the units in advance.} \item{auto_range}{Logical. If \code{TRUE}, the spatial autocorrelation range is estimated via \code{estimate_sac_range()} — which fits @@ -96,6 +107,19 @@ values (equal to row positions when the input has no pre-existing The returned \code{k} is the number of folds actually built, which is not always the \code{k} that was requested (see the \code{k} argument above), and \code{length(folds)} always matches it. + +For the methods that work in projected space — \code{"block_kfold"}, +\code{"buffered_loo"} and \code{"nndm"} — \code{params} 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 +definition). Every length in \code{params} — \code{block_size}, +\code{sac_range}, \code{buffer}, \code{median_buffer} — is in that CRS's +units, which for geographic input is a CRS +\code{\link{ensure_projected}()} chose rather than one you passed. + +Rows whose geometry is empty or has non-finite coordinates are dropped +before folding, with a logged warning naming the count; they appear in no +fold and in no \code{assignment} row. } \description{ Builds train/test splits using random K-fold, spatial block K-fold, or diff --git a/man/model_metrics.Rd b/man/model_metrics.Rd index 8068ffa..d68a1c2 100644 --- a/man/model_metrics.Rd +++ b/man/model_metrics.Rd @@ -22,7 +22,19 @@ see above).} A data.frame with n, RMSE, MAE, MAPE, SMAPE, R2, Adj_R2. } \description{ -Compute goodness-of-fit metrics for a spatial model +Reports RMSE, MAE, MAPE, SMAPE, \eqn{R^2} and adjusted \eqn{R^2} for any +\code{spatial_fit}, in one row and on one scale, so that fits from different +backends can be read side by side. Reach for it to score a model on data you +hold out yourself (pass it as \code{newdata}), or to get a quick in-sample +reading of how closely a fit tracks its training data. +} +\details{ +It is not a substitute for cross-validation. With \code{newdata = NULL} the +numbers are in-sample for a \code{gwr_fit} or \code{bayesian_fit} -- and a +GWR can reach a near-perfect in-sample \eqn{R^2} at a small bandwidth +without predicting anything. For a figure you can report, use +\code{\link{cv_gwr}()}, \code{\link{cv_bayes}()}, \code{\link{cv_rf}()} +or \code{\link{compare_models_cv}()}. } \section{What the metrics are computed on}{ diff --git a/man/new_spatial_fit.Rd b/man/new_spatial_fit.Rd index 5f8cd6a..423ff72 100644 --- a/man/new_spatial_fit.Rd +++ b/man/new_spatial_fit.Rd @@ -15,9 +15,18 @@ new_spatial_fit( ) } \arguments{ -\item{subclass}{Character scalar: "gwr_fit", "bayesian_fit" or "rf_fit".} +\item{subclass}{Character scalar naming the class to stamp on the object: +one of the built-ins \code{"gwr_fit"}, \code{"bayesian_fit"} or +\code{"rf_fit"}, or any name of your own for a custom backend (say +\code{"lm_fit"}). It is the S3 dispatch key: \code{predict()}, +\code{fitted()}, \code{residuals()} and \code{coef()} on the result all +dispatch on it, so a custom \code{subclass} \strong{requires} a matching +\code{predict.()} method to be usable with +\code{\link{cv_spatial}()}.} -\item{engine}{The raw model object.} +\item{engine}{The raw model object your backend produced (an \code{lm}, +a \code{ranger} object, a \code{brmsfit}, ...). Nothing inspects it +except your own methods.} \item{formula}{A formula.} @@ -27,15 +36,32 @@ new_spatial_fit( \item{data_sf}{An sf object used for fitting.} -\item{info}{Named list of model-specific extras.} +\item{info}{Named list of model-specific extras. Set +\code{fitted_are_oob = TRUE} if your \code{fitted()} values are held out +rather than in-sample, so \code{summary()} labels them honestly.} } \value{ An object of class \code{c(subclass, "spatial_fit")}. } \description{ -Low-level constructor used by \code{fit_gwr_model()}, -\code{fit_bayesian_spatial_model()} and \code{fit_rf_model()}. Users should -not call this directly. +The constructor for the \code{spatial_fit} class, and the public entry point +for plugging your own model backend into this package. The three built-in +fitters -- \code{\link{fit_gwr_model}()}, +\code{\link{fit_bayesian_spatial_model}()} and \code{\link{fit_rf_model}()} +-- all end by calling it, and so should a custom \code{fit_fn} written for +\code{\link{cv_spatial}()}: wrapping your model in a \code{spatial_fit} is +what lets it use the package's folds, metrics, comparison and +area-of-applicability machinery unchanged. +} +\details{ +There are two obligations. Return an object built here from your +\code{fit_fn}, and define a \code{predict()} method for the \code{subclass} +you chose -- \code{\link{cv_spatial}()} scores folds by calling the +\code{predict()} generic on the fit, so without a matching +\code{predict.()} every fold fails. Methods for +\code{\link{fitted}()}, \code{\link{residuals}()} and \code{\link{coef}()} +are optional; supply them if you want the corresponding helpers to work on +your fits too. } \section{The coef() contract}{ @@ -50,3 +76,49 @@ shorter answer than the caller expected. Wrap in \code{try()} or \code{tryCatch()} when sweeping over a heterogeneous list of fits. } +\examples{ +library(sf) +set.seed(1) +n <- 80 +site <- st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), + coords = c("x", "y"), crs = 32632 +) +site$price <- 10 + 0.01 * st_coordinates(site)[, 1] + 2 * site$elev + rnorm(n) + +# A custom backend: an ordinary linear model behind the spatial_fit interface. +lm_fit <- function(train_sf) { + new_spatial_fit( + subclass = "lm_fit", + engine = lm(price ~ elev, st_drop_geometry(train_sf)), + formula = price ~ elev, + response_var = "price", + predictor_vars = "elev", + data_sf = train_sf + ) +} + +# Required: cv_spatial() scores each fold through the predict() generic, +# which dispatches on the subclass named above. +predict.lm_fit <- function(object, newdata = NULL, ...) { + if (is.null(newdata)) newdata <- object$data_sf + as.numeric(stats::predict(object$engine, st_drop_geometry(newdata))) +} +registerS3method("predict", "lm_fit", predict.lm_fit) + +cv <- cv_spatial(site, "price", "elev", fit_fn = lm_fit, k = 3, seed = 1) +cv$overall +# Always check these two agree before trusting the metrics above. +c(attempted = cv$n_folds_attempted, succeeded = cv$n_folds_succeeded) +} +\seealso{ +\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{prep_model_data}()} +} +\concept{model fitting} diff --git a/man/plot.spatial_fit.Rd b/man/plot.spatial_fit.Rd index e564c6b..a1d1398 100644 --- a/man/plot.spatial_fit.Rd +++ b/man/plot.spatial_fit.Rd @@ -34,18 +34,19 @@ residuals, and where is it -- had to be written by hand each time. } \examples{ \donttest{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE) && +# Works on any spatial_fit; a forest keeps the example free of the optional +# GWR/Stan backends. +if (requireNamespace("ranger", quietly = TRUE) && requireNamespace("ggplot2", quietly = TRUE)) { library(sf) set.seed(1) - n <- 60 + n <- 120 pts <- st_as_sf( data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), coords = c("x", "y"), crs = 32632 ) pts$price <- 10 + 0.01 * st_coordinates(pts)[, 1] + 2 * pts$elev + rnorm(n) - fit <- fit_gwr_model(pts, "price", "elev", bandwidth = 30) + fit <- fit_rf_model(pts, "price", "elev", num_trees = 100, seed = 1) plot(fit, type = "residuals") plot(fit, type = "observed_predicted") if (requireNamespace("gstat", quietly = TRUE)) diff --git a/man/predict.rf_fit.Rd b/man/predict.rf_fit.Rd index 1cc7825..3a86016 100644 --- a/man/predict.rf_fit.Rd +++ b/man/predict.rf_fit.Rd @@ -20,7 +20,13 @@ data; an unseen level is an error, not a guess.} \code{predict.all = TRUE}, \code{type = "quantiles"}, \code{type = "se"} with \code{predict.all} -- are rejected, because this method's contract is one number per row of \code{newdata}. Call -\code{predict(fit$engine, data = ...)} directly for those.} +\code{predict(fit$engine, data = ...)} directly for those. +\code{seed} defaults to a constant rather than being left unset: an unset +\code{seed} makes \code{ranger} draw one uniform from the global RNG +stream per call, so the number of \code{predict()} calls a script happens +to make (via \code{\link{predict_surface}}'s \code{chunk_size}, say) would +otherwise shift every later random draw. It does not affect a regression +forest's predictions; pass your own if you need one.} } \value{ Numeric vector, aligned to \code{nrow(newdata)} with \code{NA} for diff --git a/man/predict_surface.Rd b/man/predict_surface.Rd index 247d4c1..7a11d68 100644 --- a/man/predict_surface.Rd +++ b/man/predict_surface.Rd @@ -73,19 +73,22 @@ grid long before the fit itself would. } \examples{ \donttest{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +# Any spatial_fit works here; a forest keeps the example free of the +# optional GWR/Stan backends. +if (requireNamespace("ranger", quietly = TRUE)) { library(sf) set.seed(1) - n <- 60 + n <- 120 pts <- st_as_sf( data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), coords = c("x", "y"), crs = 32632 ) pts$price <- 10 + 0.01 * st_coordinates(pts)[, 1] + 2 * pts$elev + rnorm(n) - fit <- fit_gwr_model(pts, "price", "elev", bandwidth = 30) + fit <- fit_rf_model(pts, "price", "elev", num_trees = 100, seed = 1) surf <- predict_surface(fit, n_cells = 500, covariates = pts) - plot(surf[".pred"]) + surf[".pred"] + # Check where that surface is extrapolating before mapping it. + area_of_applicability(surf, model = fit) } } } diff --git a/man/prep_model_data.Rd b/man/prep_model_data.Rd index 4cc9e6c..35c3c9a 100644 --- a/man/prep_model_data.Rd +++ b/man/prep_model_data.Rd @@ -65,6 +65,7 @@ prep_model_data(dat, "resp", "pred") # drops rows 3 (NA) and 5 (Inf) Other model fitting: \code{\link{fit_bayesian_spatial_model}()}, \code{\link{fit_gwr_model}()}, -\code{\link{fit_rf_model}()} +\code{\link{fit_rf_model}()}, +\code{\link{new_spatial_fit}()} } \concept{model fitting} diff --git a/man/print.aoa.Rd b/man/print.aoa.Rd index 3db7523..a6057e2 100644 --- a/man/print.aoa.Rd +++ b/man/print.aoa.Rd @@ -15,5 +15,11 @@ \code{x}, invisibly. } \description{ -Print an area-of-applicability result +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 +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. } diff --git a/man/print.gwr_model_selection.Rd b/man/print.gwr_model_selection.Rd index 713e594..9a675f8 100644 --- a/man/print.gwr_model_selection.Rd +++ b/man/print.gwr_model_selection.Rd @@ -17,5 +17,10 @@ \code{x}, invisibly. } \description{ -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 -- worth checking before reporting one model as +the selected one. } diff --git a/man/print.rf_fit.Rd b/man/print.rf_fit.Rd index 9b669af..c8bba58 100644 --- a/man/print.rf_fit.Rd +++ b/man/print.rf_fit.Rd @@ -15,5 +15,9 @@ \code{x}, invisibly. } \description{ -Print a random forest fit +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. } diff --git a/man/print.spatial_fit.Rd b/man/print.spatial_fit.Rd index eaed07f..46bfc23 100644 --- a/man/print.spatial_fit.Rd +++ b/man/print.spatial_fit.Rd @@ -15,5 +15,11 @@ \code{x}, invisibly (called for its side effect). } \description{ -Print a fitted spatial model +Shows the one-screen summary of any \code{spatial_fit}: backend, formula, +number of observations, CRS, and the few backend-specific numbers worth +seeing immediately (GWR bandwidth, GP basis size, 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. } diff --git a/man/residual_morans_i.Rd b/man/residual_morans_i.Rd index e67f264..bcb3806 100644 --- a/man/residual_morans_i.Rd +++ b/man/residual_morans_i.Rd @@ -8,12 +8,13 @@ residual_morans_i( fit, alternative = c("two.sided", "greater", "less"), weights = NULL, - k = 8L + k = 8L, + null = c("auto", "randomisation", "residual") ) } \arguments{ -\item{fit}{A \code{spatial_fit} object (from \code{fit_gwr_model} or -\code{fit_bayesian_spatial_model}).} +\item{fit}{A \code{spatial_fit} object (from \code{fit_gwr_model}, +\code{fit_bayesian_spatial_model} or \code{fit_rf_model}).} \item{alternative}{Character: \code{"two.sided"} (default), \code{"greater"} (positive autocorrelation), or \code{"less"}.} @@ -31,54 +32,146 @@ row-standardised weights.} \item{k}{Integer number of nearest neighbours used when building the default weight matrix (ignored when \code{weights} is supplied). Default 8.} + +\item{null}{Which null distribution the expectation, variance and p-value +are computed against. One of: +\describe{ +\item{\code{"auto"} (default)}{\code{"residual"} when the design matrix +can be rebuilt \emph{and} the fit's residuals are the OLS residuals on +it, \code{"randomisation"} otherwise.} +\item{\code{"randomisation"}}{Always the exchangeable moments.} +\item{\code{"residual"}}{Always the Cliff & Ord residual moments. Falls +back to \code{"randomisation"} with a logged warning if the design +cannot be rebuilt, and warns (but proceeds) if the residuals are not +the OLS residuals on it, in which case the moments are approximate.} +} +See \strong{Which null, and when it is approximate} above.} } \value{ A list with components: \describe{ \item{observed}{Numeric scalar, Moran's I statistic.} -\item{expected}{Expected I under the null of no spatial -autocorrelation, \eqn{-1/(n-1)}.} -\item{sd}{Standard deviation of I under the randomisation -assumption.} +\item{expected}{Expected I under the null named by \code{null}: +\eqn{-1/(n-1)} for \code{"randomisation"}, +\eqn{(n/S_0)\mathrm{tr}(MW)/(n-p)} for \code{"residual"}.} +\item{sd}{Standard deviation of I under that same null.} \item{z}{Standardised z-score, \eqn{(I - E[I]) / sd(I)}.} \item{p_value}{Two-sided (or one-sided) p-value from the normal approximation.} \item{n}{Number of observations used.} +\item{null}{The null actually used, \code{"randomisation"} or +\code{"residual"} — check this rather than assuming, since +\code{"auto"} chooses per fit and \code{"residual"} can fall back.} +\item{df}{Residual degrees of freedom behind the moments: +\eqn{n - p} for \code{"residual"} (where \eqn{p} is the rank of the +design matrix), \eqn{n - 1} for \code{"randomisation"}.} } Returns \code{NULL} with a warning if computation fails (e.g. fewer than 4 valid residuals). } \description{ -Given a \code{spatial_fit} object (GWR or Bayesian), extracts the -residuals and the observation coordinates, builds a spatial weight -matrix, and computes the Moran's I statistic together with -its analytical expectation and variance under the randomisation -assumption (Cliff & Ord). A z-score and two-sided p-value are -provided so the caller can assess whether statistically significant -spatial autocorrelation remains after fitting. +Given a \code{spatial_fit} object, extracts the residuals and the +observation coordinates, builds a spatial weight matrix, and computes +Moran's I together with its analytical expectation and variance under a +stated null. A z-score and two-sided p-value are provided so the caller can +assess whether statistically significant spatial autocorrelation remains +after fitting. } \details{ By default, weights are constructed as a k-nearest-neighbour (k = 8) binary matrix, row-standardised. Users may supply their own weight matrix via the \code{weights} argument. } +\section{Which null, and when it is approximate}{ + +Two nulls are available, and the one actually used is reported back in the +\code{null} element of the return value. + +\code{"randomisation"} is the classical exchangeable null: +\eqn{E[I] = -1/(n-1)} with the Cliff & Ord randomisation variance, +conditioning on the observed kurtosis. These are the moments of I for a +vector whose elements are equally likely in any order. + +\strong{Model residuals are not exchangeable.} They are orthogonal to the +design matrix, which pushes \eqn{E[I]} materially below \eqn{-1/(n-1)} +whenever the covariates are spatially smooth — and pushes it further the +more covariates there are. In a simulation with \eqn{n = 120}, six smooth +covariates and \emph{independent} errors (so the truth is "no residual +autocorrelation"), OLS residuals had mean \eqn{I = -0.031} against the +exchangeable \eqn{E[I] = -0.008}; the z-score averaged \eqn{-0.54} with +\eqn{sd = 0.90} instead of 0 and 1. The cost is power, which is the point +of the test: at a moderate residual autocorrelation the exchangeable null +rejected 13\\% of the time where the correct one rejected 31\\%. + +\code{"residual"} therefore uses the Cliff & Ord (1981) sec. 8.3 moments for +regression residuals, with \eqn{M = I - X(X'X)^{-1}X'} rebuilt from +\code{predictor_vars} and \code{data_sf}: +\deqn{E[I] = (n/S_0)\,\mathrm{tr}(MW)/(n-p)} +\deqn{Var[I] = (n/S_0)^2[\mathrm{tr}(MWMW') + \mathrm{tr}((MW)^2) + + (\mathrm{tr}MW)^2]/[(n-p)(n-p+2)] - E[I]^2} +These assume normal errors rather than conditioning on the observed +kurtosis. On the simulation above they restored the z-score to mean +\eqn{-0.09}, \eqn{sd = 1.03}, and the rejection rate to 4.3\\% against a +nominal 5\\%. They agree with \code{spdep::lm.morantest()} to machine +precision. + +\strong{These moments are exact for \eqn{e = My} and for nothing else}, so +\code{null = "auto"} does not guess from the fit's class: it rebuilds +\code{X}, regresses the response on it, and uses the residual moments only +when the supplied residuals \emph{are} those OLS residuals to numerical +tolerance. A GWR wide enough to have collapsed to global OLS passes that +test; the same GWR at a working bandwidth does not. + +\strong{For the flexible backends neither null is exact}, and \code{"auto"} +leaves them on \code{"randomisation"} because forcing the OLS moments on +them measurably makes matters worse, not better. Measured on null data +(\eqn{n = 120}, three smooth covariates, independent errors; nominal 5\\%, +one-sided): +\tabular{lrr}{ +\strong{backend} \tab \strong{randomisation} \tab \strong{residual} \cr +OLS \tab 0.035 \tab 0.060 \cr +random forest \tab 0.128 \tab 0.200 \cr +GWR \tab 0.000 \tab 0.000 +} +An in-sample random forest is anticonservative under both — its residuals +are shrunk and spatially heteroscedastic, so the variance is understated +whichever moments are used (\eqn{sd(z) \approx 1.3}) — and GWR is +conservative under both, because it removes far more structure than a rank-p +projection does. Treat the p-value from those backends as a rough +indicator, and prefer cross-validated residuals or an explicit spatial +covariance model when the answer has to carry weight. + +A permutation null was considered and rejected: permuting the residual +vector destroys exactly the orthogonality that causes the bias, so its mean +is the exchangeable \eqn{-1/(n-1)} by construction (measured: +\eqn{-0.00840} against \eqn{-1/(n-1) = -0.00840}) and it reproduces the +randomisation null rather than correcting it. +} + \examples{ \donttest{ -if (requireNamespace("GWmodel", quietly = TRUE) && - requireNamespace("sp", quietly = TRUE)) { +# Works on any spatial_fit; a forest keeps the example free of the optional +# GWR/Stan backends. +if (requireNamespace("ranger", quietly = TRUE)) { library(sf) set.seed(1) - n <- 60 + n <- 120 dat <- st_as_sf( data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), elev = rnorm(n)), coords = c("x", "y"), crs = 32632 ) - dat$price <- 10 + 0.01 * st_coordinates(dat)[, 1] + 2 * dat$elev + rnorm(n) - fit <- fit_gwr_model(dat, "price", "elev", bandwidth = 30) + # A strong east-west trend the predictor cannot explain: the residuals + # should still carry spatial structure, and this is what detects it. + dat$price <- 10 + 0.02 * st_coordinates(dat)[, 1] + 2 * dat$elev + rnorm(n) + fit <- fit_rf_model(dat, "price", "elev", num_trees = 100, seed = 1) residual_morans_i(fit) # z near 0 / p large = no residual structure } } } +\references{ +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}()}, diff --git a/man/residuals.rf_fit.Rd b/man/residuals.rf_fit.Rd index 5305eeb..ec394b0 100644 --- a/man/residuals.rf_fit.Rd +++ b/man/residuals.rf_fit.Rd @@ -15,5 +15,12 @@ Numeric vector of length \code{object$n}. } \description{ -Out-of-bag residuals from a random forest fit +Observed response minus \code{\link{fitted.rf_fit}}, which for a forest is +the \strong{out-of-bag} prediction -- each observation predicted only by the +trees that did not see it. These are therefore already held-out residuals, +unlike \code{residuals.gwr_fit()} and \code{residuals.bayesian_fit()}, +which are in-sample. Feed them to \code{\link{residual_morans_i}()} to test +whether spatial structure the forest failed to capture is still sitting in +the residuals. Out-of-bag is not a substitute for spatial CV: use +\code{\link{cv_rf}()} for an honest map-accuracy figure. } diff --git a/man/spatialkit-package.Rd b/man/spatialkit-package.Rd index 1359478..97dc147 100644 --- a/man/spatialkit-package.Rd +++ b/man/spatialkit-package.Rd @@ -8,13 +8,76 @@ \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. Model backends cover geographically weighted regression (GWR, via 'GWmodel'), Bayesian spatial Gaussian process regression (via 'brms') and random forests (via 'ranger'), each behind a common S3 class ('spatial_fit') 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, forward variable selection, model comparison, prediction onto a regular surface, and area-of-applicability estimation to flag where a fitted model extrapolates beyond its training data. } -\seealso{ -Useful links: -\itemize{ - \item \url{https://github.com/elkronos/gis_modeling_toolkit} - \item Report bugs at \url{https://github.com/elkronos/gis_modeling_toolkit/issues} +\section{The pipeline, in order}{ + +The package is built around one workflow. Each step names the function that +performs it; every step is optional except the ones your question needs. + +\enumerate{ +\item \strong{Choose a resolution.} \code{\link{determine_optimal_levels}()} +reads a cell count out of the spatial structure of the observations, +rather than making you guess one. +\item \strong{Tessellate.} \code{\link{build_tessellation}()} turns the +point pattern into analysis regions --- Voronoi, Delaunay triangles, or a +hex/square grid --- with reproducible cell identifiers. +\code{\link{get_voronoi_seeds}()} controls where Voronoi seeds go. +\item \strong{Assign.} \code{\link{assign_features_to_polygons}()} labels +every observation with the cell it falls in, resolving multi-match ties +explicitly rather than duplicating rows. +\item \strong{Aggregate.} \code{\link{summarize_by_cell}()} reduces to one +row per cell, carrying a standard error and observation count with every +aggregate, and can correct those errors for within-cell autocorrelation. +\item \strong{Fold.} \code{\link{make_folds}()} builds spatial +cross-validation folds --- blocked, buffered, leave-location-out or +nearest-neighbour distance-matched. Random folds flatter autocorrelated +data; these do not. +\item \strong{Fit.} \code{\link{fit_gwr_model}()} for coefficients that +vary across the map, \code{\link{fit_bayesian_spatial_model}()} for an +explicit spatial Gaussian process with calibrated uncertainty, or +\code{\link{fit_rf_model}()} for predictive accuracy. All three return a +\code{spatial_fit} with common \code{predict()}, \code{fitted()}, +\code{residuals()}, \code{coef()} and \code{plot()} methods; write your +own backend with \code{\link{new_spatial_fit}()}. +\item \strong{Validate.} \code{\link{cv_gwr}()}, +\code{\link{cv_bayes}()}, \code{\link{cv_rf}()} or the model-agnostic +\code{\link{cv_spatial}()} score a model on held-out blocks; +\code{\link{compare_models_cv}()} scores several backends on one set of +folds. \code{\link{residual_morans_i}()} tests whether spatial structure +survives in the residuals, and \code{\link{select_features_forward}()} +chooses predictors inside the cross-validation. +\item \strong{Predict.} \code{\link{predict_surface}()} projects a fit onto +a regular grid; \code{\link{plot_tessellation_map}()} and +\code{\link{plot.spatial_fit}()} draw the results. +\item \strong{Check applicability.} \code{\link{area_of_applicability}()} +flags where that surface extrapolates beyond the training data. A +cross-validation score says nothing about ground the model has never +seen; this is what tells you where the map should not be believed. +} + +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 +distance over which observations remain correlated --- the number that +should be setting your block size. } +\section{Where to start}{ + +If you are reading a single page, read +\code{vignette("spatialkit_nc_demo", package = "spatialkit")}: it runs the +whole pipeline above on North Carolina data, with maps at each step. +} + +\seealso{ +\code{vignette("spatialkit_nc_demo", package = "spatialkit")} for the worked +end-to-end example. + +Useful entry points by task: +\code{\link{build_tessellation}()} (build regions), +\code{\link{summarize_by_cell}()} (aggregate to them), +\code{\link{make_folds}()} (split them honestly), +\code{\link{compare_models_cv}()} (score several models at once), +\code{\link{area_of_applicability}()} (find where not to trust the result). } \author{ \strong{Maintainer}: Justin Chase \email{jchase.msu@gmail.com} [copyright holder] diff --git a/man/summarize_by_cell.Rd b/man/summarize_by_cell.Rd index c500af7..e3c0af5 100644 --- a/man/summarize_by_cell.Rd +++ b/man/summarize_by_cell.Rd @@ -95,6 +95,17 @@ Aggregates an sf point dataset into one row per cell. By default computes counts and means, but the aggregation function is configurable. } \details{ +This is the third step of the package's pipeline, taking the labelled layer +from \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} down to cell level. What distinguishes +it from a plain \code{dplyr::group_by()} + \code{summarise()} is that it carries the +\emph{uncertainty} of each aggregate with it: alongside every mean it returns a +within-cell standard deviation, a standard error and an observation count, +and it can correct that standard error for within-cell spatial +autocorrelation via \code{deff}. Reach for it whenever the cell-level values will +be modelled or mapped, because a cell mean over 2 observations and one over +200 are not the same measurement and nothing downstream can tell them apart +otherwise. + In addition to user-specified aggregation functions, this function always computes within-cell standard deviation (\verb{..sd_}) and standard error (\verb{..se_}) for every numeric response/predictor column, plus a @@ -147,3 +158,12 @@ cells <- summarize_by_cell(assigned, response_var = "val", deff = "kish") cells attr(cells, "deff_applied") } +\seealso{ +\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}()} +} +\concept{aggregation} diff --git a/man/voronoi_seeds_kmeans.Rd b/man/voronoi_seeds_kmeans.Rd index 761ad11..7b0d8bc 100644 --- a/man/voronoi_seeds_kmeans.Rd +++ b/man/voronoi_seeds_kmeans.Rd @@ -9,8 +9,11 @@ voronoi_seeds_kmeans(points_sf, k, set_seed = 456) \arguments{ \item{points_sf}{An sf object with POINT geometries.} -\item{k}{Integer; requested number of clusters. Clamped to the number of -distinct point positions, with a warning, when it exceeds it.} +\item{k}{Integer; requested number of clusters, and an upper bound rather +than a guarantee. It is clamped, with a warning, to whichever is smaller +of the number of distinct point positions and \code{nrow(points_sf) - 1} — +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.} \item{set_seed}{Optional integer RNG seed. Default 456.} } @@ -20,5 +23,17 @@ An sf object of \strong{at most} \code{k} cluster-centre POINTs (fewer when \code{method = "kmeans"} columns matching \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}. } \description{ -K-means seed generation from point coordinates +Places \code{k} seed points at k-means cluster centres of the observed +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 each carry a comparable number +of observations, which is what makes per-cell aggregates in +\code{\link[=summarize_by_cell]{summarize_by_cell()}} similarly precise. 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 name. +} +\details{ +Lon/lat input is projected first so the k-means distances are metric rather +than degrees. Rows with empty or non-finite coordinates are dropped with a +warning, and \code{k} is clamped to the number of distinct positions. } diff --git a/man/voronoi_seeds_random.Rd b/man/voronoi_seeds_random.Rd index 5971780..04f7869 100644 --- a/man/voronoi_seeds_random.Rd +++ b/man/voronoi_seeds_random.Rd @@ -20,5 +20,17 @@ with \code{seed_id} and \code{method = "random"} columns matching \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}. } \description{ -Random seed generation within a polygonal boundary +Draws \code{k} seed points uniformly at random inside \code{boundary}, ignoring where +the observations are. Reach for this when the cells should cover the study +area evenly — so that sparsely sampled ground still gets its own cells and +is visibly under-sampled in the results — rather than concentrating +resolution where the data already are, which is what +\code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}} does. It is also the honest choice for a null or +sensitivity comparison: re-running an analysis over several random seedings +shows how much of a result depends on one particular tessellation. +} +\details{ +Sampling is by rejection inside the polygon, so an awkward geometry can +return fewer than \code{k} seeds; that shortfall is warned about rather than +silently padded. } diff --git a/tests/testthat/test-area-of-applicability.R b/tests/testthat/test-area-of-applicability.R index d4a4f59..307a654 100644 --- a/tests/testthat/test-area-of-applicability.R +++ b/tests/testthat/test-area-of-applicability.R @@ -297,6 +297,42 @@ test_that(".aoa_threshold is the outlier-removed maximum", { expect_equal(.aoa_threshold(c(1, 2, 3, 4, 5)), 5) }) +test_that(".aoa_threshold's fence is 1.5 x IQR and not some other multiple", { + # Neither vector above can see the multiplier: c(rep(1, 9), 10) has IQR = 0, + # so the fence is Q3 for ANY multiple, and c(1, 2, 3, 4, 5) has max <= fence + # for every multiple >= 0.5. Both pass unchanged if the 1.5 of Meyer & + # Pebesma (2021) is quietly replaced by 1 or by 3. + # + # This one can. Take 1:9 and append one larger value. Because the appended + # value sorts above x[8], the type-7 quartiles of the ten-element sample stay + # at Q1 = 3.25 and Q3 = 7.75 wherever it lands, so IQR = 4.5 and the fence is + # exactly 7.75 + m * 4.5. Whether the appended value survives the fence then + # depends on m alone. + probe <- c(1:9, 99) + q3 <- stats::quantile(probe, 0.75, names = FALSE) + iqr_val <- stats::IQR(probe) + expect_equal(c(q3, iqr_val), c(7.75, 4.5)) + fence_at <- function(m) q3 + m * iqr_val + expect_equal(fence_at(1.5), 14.5) + + # Half a unit ABOVE the 1.5 fence: an outlier, discarded, so the threshold + # falls back to the largest ordinary value. Any multiplier >= 1.612 -- 2, or + # the 3 of the classic "far out" fence -- would keep it and return 15. + hi <- c(1:9, fence_at(1.5) + 0.5) + expect_equal(.aoa_threshold(hi), 9) + + # Half a unit BELOW it: inside the fence, so it IS the outlier-removed + # maximum. Any multiplier < 1.389 -- a plain 1 x IQR fence, say -- would + # discard it and return 9 instead. + lo <- c(1:9, fence_at(1.5) - 0.5) + expect_equal(.aoa_threshold(lo), 14) + + # Together the two pin the multiplier to [1.389, 1.612), which contains 1.5 + # and nothing else anyone would plausibly have written. + for (d in list(hi, lo)) + expect_equal(.aoa_threshold(d), max(d[d <= fence_at(1.5)])) +}) + test_that(".aoa_threshold ignores non-finite values", { expect_equal(.aoa_threshold(c(1, 2, 3, 4, 5, NA, Inf)), 5) expect_error(.aoa_threshold(c(NA_real_, NaN)), "no finite training DI") @@ -625,3 +661,65 @@ test_that("a coordinate-using model reprojects newdata before measuring it", { area_of_applicability(nd_proj, model = fit)$aoa$DI, tolerance = 1e-6) }) + + +test_that("area_of_applicability reads a logical predictor as 0/1", { + # The dissimilarity index is a Euclidean distance in scaled predictor space, + # so it needs a defensible numeric coding. A logical column HAS one -- + # TRUE/FALSE is 1/0 and its standard deviation is meaningful -- and every + # other part of the package fits, cross-validates and predicts with logical + # predictors, so refusing them only here was self-inconsistent. The contract + # is equality with the explicit 0/1 coding, not just the absence of an error. + set.seed(31) + n <- 120 + lg <- stats::runif(n) > 0.5 + tr_lgl <- sf::st_as_sf( + data.frame(x = stats::runif(n, 0, 1000), y = stats::runif(n, 0, 1000), + a = stats::rnorm(n), flag = lg), + coords = c("x", "y"), crs = 32632) + # Separate prediction points, spread from the middle of the training cloud + # out well past its edge, so the DI values actually vary. + nd_lgl <- sf::st_as_sf( + data.frame(x = seq(10, by = 10, length.out = 20), + y = seq(10, by = 10, length.out = 20), + a = seq(0, 8, length.out = 20), + flag = rep(c(TRUE, FALSE), 10)), + coords = c("x", "y"), crs = 32632) + + tr_num <- tr_lgl; tr_num$flag <- as.numeric(lg) + nd_num <- nd_lgl; nd_num$flag <- as.numeric(nd_lgl$flag) + expect_type(tr_lgl$flag, "logical") + expect_type(tr_num$flag, "double") + + res_lgl <- area_of_applicability(nd_lgl, train_sf = tr_lgl, + predictor_vars = c("a", "flag")) + res_num <- area_of_applicability(nd_num, train_sf = tr_num, + predictor_vars = c("a", "flag")) + + expect_s3_class(res_lgl, "aoa") + expect_equal(res_lgl$aoa$DI, res_num$aoa$DI, tolerance = 1e-12) + expect_equal(res_lgl$aoa$AOA, res_num$aoa$AOA) + expect_equal(res_lgl$threshold, res_num$threshold, tolerance = 1e-12) + expect_equal(res_lgl$train_DI, res_num$train_DI, tolerance = 1e-12) + expect_equal(res_lgl$normalizer, res_num$normalizer, tolerance = 1e-12) + # The numbers being compared are real ones, so equality is not vacuous. + expect_true(all(is.finite(res_lgl$aoa$DI))) + expect_gt(stats::sd(res_lgl$aoa$DI), 0) + expect_identical(res_lgl$predictor_vars, c("a", "flag")) + + # A logical predictor on its own is enough. + solo <- area_of_applicability(nd_lgl, train_sf = tr_lgl, + predictor_vars = "flag") + expect_equal(solo$aoa$DI, + area_of_applicability(nd_num, train_sf = tr_num, + predictor_vars = "flag")$aoa$DI, + tolerance = 1e-12) + + # Factors and characters are still refused, and the message says so. + tr_fac <- tr_lgl; tr_fac$flag <- factor(ifelse(lg, "yes", "no")) + nd_fac <- tr_fac[1:20, ] + expect_error( + area_of_applicability(nd_fac, train_sf = tr_fac, + predictor_vars = c("a", "flag")), + "are not numeric or logical") +}) diff --git a/tests/testthat/test-build-tessellation.R b/tests/testthat/test-build-tessellation.R index 0559bfc..70936e6 100644 --- a/tests/testthat/test-build-tessellation.R +++ b/tests/testthat/test-build-tessellation.R @@ -302,3 +302,73 @@ test_that("clip = FALSE leaves cells extending past the boundary", { expect_equal(clipped$params$clip, TRUE) expect_equal(whole$params$clip, FALSE) }) + + +# --------------------------------------------------------------------------- +# create_grid_polygons(): a caller-supplied `cellsize` wins over `n` +# --------------------------------------------------------------------------- + +test_that("create_grid_polygons ignores `n` when the caller fixes `cellsize`", { + # sf::st_make_grid() does NOT ignore `n` when `cellsize` is given: it uses + # cellsize for the cell dimensions and nx/ny for the COUNTS, anchored at the + # bounding-box corner. create_grid_polygons(cellsize = 25, n = 2) on a + # 100x100 boundary therefore returned 4 cells covering the bbox 0,0,50,50 -- + # a quarter of the study area -- and because clip = TRUE discards nothing + # there, it looked like a perfectly ordinary grid. + bnd <- .bt_boundary() + side <- 100 + expect_equal(as.numeric(sf::st_area(bnd)), side^2) + + lines <- capture_spatialkit_log(g <- create_grid_polygons(bnd, cellsize = 25, + n = 2)) + # `n` is dropped, and loudly: silently ignoring it would be its own trap. + expect_true(log_has(lines, "both `cellsize` and `n` were supplied")) + expect_true(log_has(lines, "`cellsize` wins and `n` \\(2 x 2\\) is ignored")) + + # 100 / 25 = 4 columns and 4 rows ... + expect_equal(nrow(g), 16L) + # ... covering the boundary completely, not a corner of it. + expect_equal(sum(as.numeric(sf::st_area(g))), side^2, tolerance = 1e-8) + expect_equal(unname(sf::st_bbox(g)[c("xmin", "ymin", "xmax", "ymax")]), + c(0, 0, side, side), tolerance = 1e-8) + # Every cell is the size that was asked for. + expect_equal(unique(round(as.numeric(sf::st_area(g)), 8)), 25^2) + + # Identical to passing `cellsize` alone -- which is the point: the extra `n` + # changed nothing. + alone <- create_grid_polygons(bnd, cellsize = 25) + expect_equal(nrow(alone), nrow(g)) + expect_equal(sf::st_bbox(alone), sf::st_bbox(g)) + + # And no warning when only one of them is given. + quiet <- capture_spatialkit_log(create_grid_polygons(bnd, cellsize = 25)) + expect_false(log_has(quiet, "both `cellsize` and `n`")) + quiet_n <- capture_spatialkit_log(create_grid_polygons(bnd, n = 4)) + expect_false(log_has(quiet_n, "both `cellsize` and `n`")) +}) + +test_that("create_grid_polygons still honours a package-derived cell size", { + # The `n` argument is forwarded to st_make_grid() when the PACKAGE derived + # cellsize from it, because ceiling(w / (w / n)) floating-point-rounds one + # cell too far (100 / (100/9) = 9.0000...4 -> 10 columns). Dropping `n` + # unconditionally would have reintroduced that off-by-one. + bnd <- .bt_boundary() + side <- 100 + + for (k in c(3L, 4L, 7L, 9L)) { + g <- create_grid_polygons(bnd, n = k) + expect_equal(nrow(g), k^2, info = paste("n =", k)) + expect_equal(sum(as.numeric(sf::st_area(g))), side^2, tolerance = 1e-8, + info = paste("n =", k)) + expect_equal(unique(round(as.numeric(sf::st_area(g)), 6)), (side / k)^2, + info = paste("n =", k)) + } + + # target_cells derives both, and covers the boundary in full. + for (tc in c(16L, 25L, 100L)) { + g <- create_grid_polygons(bnd, target_cells = tc) + expect_equal(nrow(g), tc, info = paste("target_cells =", tc)) + expect_equal(sum(as.numeric(sf::st_area(g))), side^2, tolerance = 1e-8, + info = paste("target_cells =", tc)) + } +}) diff --git a/tests/testthat/test-crs-projection.R b/tests/testthat/test-crs-projection.R index d2cf1b7..c85dd9b 100644 --- a/tests/testthat/test-crs-projection.R +++ b/tests/testthat/test-crs-projection.R @@ -199,3 +199,52 @@ test_that("harmonize_crs rejects non-spatial input", { expect_error(harmonize_crs(data.frame(x = 1), a), "`a` must be sf or sfc") expect_error(harmonize_crs(a, data.frame(x = 1)), "`b` must be sf or sfc") }) + + +test_that("ensure_projected refuses to assume lon/lat for a small integer-grid survey", { + # With no CRS at all, the only evidence available is the numbers themselves. + # Falling inside the lon/lat envelope is necessary but nowhere near + # sufficient: a local site survey in metres sits inside it too, and stamping + # EPSG:4326 on one silently teleports it to the Gulf of Guinea and then + # "projects" it. So a second test is required -- the data must look + # POSITIVELY geographic, either by spanning more than a degree or by + # carrying fractional-degree precision. + nocrs <- function(x, y) + sf::st_as_sf(data.frame(x = x, y = y), coords = c("x", "y")) + + # A 1 m quadrat frame on a whole-metre grid: extent 1 in both axes, no + # fractional part anywhere. Neither test is met, so nothing is assumed. + quad <- nocrs(c(0, 0, 1, 1), c(0, 1, 0, 1)) + lines <- capture_spatialkit_log(out <- ensure_projected(quad)) + expect_true(log_has(lines, "Not assuming EPSG:4326")) + expect_true(log_has(lines, "lack the decimal precision or extent")) + expect_true(is.na(sf::st_crs(out))) + expect_equal(sf::st_coordinates(out), sf::st_coordinates(quad)) + + # (a) More than a degree in ONE axis is enough to tip it the other way, so + # the extent test is doing real work and is not simply always false. + wide_x <- nocrs(c(0, 0, 2, 2), c(0, 1, 0, 1)) + lx <- capture_spatialkit_log(ox <- ensure_projected(wide_x)) + expect_true(log_has(lx, "assuming EPSG:4326")) + expect_false(is.na(sf::st_crs(ox))) + expect_false(sf::st_is_longlat(ox)) + + wide_y <- nocrs(c(0, 0, 1, 1), c(0, 2, 0, 2)) + expect_false(is.na(sf::st_crs( + suppressWarnings(ensure_projected(wide_y))))) + + # (b) So is fractional-degree precision within the same 1-degree box. + fine <- nocrs(c(9.10, 9.20, 9.30, 9.15), c(48.70, 48.75, 48.80, 48.72)) + lf <- capture_spatialkit_log(of <- ensure_projected(fine)) + expect_true(log_has(lf, "assuming EPSG:4326")) + expect_equal(sf::st_crs(of)$epsg, 32632L) # the containing UTM zone + + # An explicit CRS short-circuits the whole heuristic: the quadrat is left + # exactly where it is, with no guessing and no warning about it. + stamped <- quad + sf::st_crs(stamped) <- sf::st_crs(32632) + quiet <- capture_spatialkit_log(os <- ensure_projected(stamped)) + expect_false(log_has(quiet, "assuming EPSG:4326")) + expect_equal(sf::st_crs(os), sf::st_crs(32632)) + expect_equal(sf::st_coordinates(os), sf::st_coordinates(quad)) +}) diff --git a/tests/testthat/test-deff-variogram.R b/tests/testthat/test-deff-variogram.R index 7fd8ff2..37b524d 100644 --- a/tests/testthat/test-deff-variogram.R +++ b/tests/testthat/test-deff-variogram.R @@ -119,11 +119,39 @@ test_that("a NULL correlation function yields all-NA rather than erroring", { expect_true(all(is.na(d))) }) -test_that("large cells are subsampled to the requested cap", { +test_that("a subsampled cell reports ITS OWN design effect, not the subsample's", { + # deff = sum(R)/n_i = 1 + (n_i - 1) * Rbar. Subsampling estimates Rbar just + # as well -- the subsample's pairwise-distance distribution is the cell's -- + # but sum(R)/n_used answers for a cell of size n_used. The old code returned + # the design effect of `max_n` points instead of the cell's, understating it + # by roughly n_i/max_n: measured on 4000 points with an exponential + # correlation of range 60, true deff 1821.8 and max_n = 500 returned 228.6. set.seed(4) n <- 300 coords <- matrix(runif(n * 2, 0, 100), ncol = 2) - d <- cell_de(coords, rep("a", n), cor_fn(vgm_df(range = 30)), max_n = 50L) - expect_true(is.finite(d[["a"]])) - expect_lte(d[["a"]], 50) # cannot exceed the subsampled n + f <- cor_fn(vgm_df(range = 30)) + + full <- cell_de(coords, rep("a", n), f, max_n = n)[["a"]] + sub <- cell_de(coords, rep("a", n), f, max_n = 50L)[["a"]] + + expect_true(is.finite(sub)) + # Bounded by the CELL's size, which is the only meaningful ceiling. + expect_lte(sub, n) + # And close to the un-subsampled answer, which is the whole point. + expect_equal(sub, full, tolerance = 0.15) + # Regression guard: the old truncating form could not exceed max_n. + expect_gt(sub, 50) +}) + +test_that("an un-subsampled cell is unchanged by the rescale", { + # With n_used == n_i the new form is algebraically identical to sum(R)/n_i, + # so the common case must be bit-for-bit what it always was. + set.seed(9) + n <- 40 + coords <- matrix(runif(n * 2, 0, 100), ncol = 2) + f <- cor_fn(vgm_df(range = 30)) + d <- as.matrix(stats::dist(coords)) + R <- matrix(f(as.numeric(d)), n, n); diag(R) <- 1 + expect_equal(cell_de(coords, rep("a", n), f, max_n = n)[["a"]], + min(max(sum(R) / n, 1), n), tolerance = 1e-10) }) diff --git a/tests/testthat/test-degenerate-geometry.R b/tests/testthat/test-degenerate-geometry.R index a408c22..b49042a 100644 --- a/tests/testthat/test-degenerate-geometry.R +++ b/tests/testthat/test-degenerate-geometry.R @@ -295,3 +295,80 @@ test_that("predict_surface refuses to build a grid over no extent", { expect_true(".pred" %in% names(ok)) expect_false(anyNA(ok$.pred)) }) + + +# --------------------------------------------------------------------------- +# An EMPTY geometry INSIDE a populated layer +# +# The blocks above cover zero-row layers, which every guard already handled. +# An EMPTY POINT sitting among ordinary ones is a different animal: nrow() is +# positive, st_geometry_type() says POINT, and st_coordinates() returns one +# ALL-NA row for it rather than none -- so it slips past every row-count and +# type check and reaches the distance code. In block_kfold that meant +# st_intersects() -> integer(0) -> ..block_id NA -> an all-NA distance row -> +# which.min() returning integer(0) -> "replacement has length zero". +# --------------------------------------------------------------------------- + +.dg_with_empty <- function(n = 60, seed = 9) { + set.seed(seed) + geom <- sf::st_sfc( + c(lapply(seq_len(n), + function(i) sf::st_point(c(runif(1, 0, 1000), runif(1, 0, 1000)))), + list(sf::st_point())), + crs = 32632) + sf::st_sf(z = c(rnorm(n), 0), w = c(rnorm(n), 0), geometry = geom) +} + +test_that("make_folds drops an EMPTY geometry from a populated layer", { + pts <- .dg_with_empty() + n <- nrow(pts) - 1L + expect_equal(sum(sf::st_is_empty(pts)), 1L) + expect_true(all(as.character(sf::st_geometry_type(pts)) == "POINT")) + # st_coordinates() returns a FULL-HEIGHT matrix with one all-NA row, not a + # shorter one -- which is exactly why a row-count check cannot spot the + # empty geometry and a complete.cases() check has to. + xy <- suppressWarnings(sf::st_coordinates(pts)) + expect_equal(nrow(xy), n + 1L) + expect_equal(sum(!stats::complete.cases(xy[, 1:2, drop = FALSE])), 1L) + + grid <- sf::st_as_sf( + data.frame(x = stats::runif(15, 0, 1000), y = stats::runif(15, 0, 1000)), + coords = c("x", "y"), crs = 32632) + + args <- list( + random_kfold = list(k = 3, method = "random_kfold", seed = 1), + block_kfold = list(k = 3, method = "block_kfold", seed = 1), + buffered_loo = list(k = 3, method = "buffered_loo", buffer = 100, seed = 1), + nndm = list(method = "nndm", prediction_points = grid, seed = 1) + ) + + for (m in names(args)) { + lines <- capture_spatialkit_log( + f <- do.call(make_folds, c(list(points_sf = pts), args[[m]]))) + # Dropped, and the count is named rather than silently absorbed. + expect_true(log_has(lines, "dropping 1 point\\(s\\) with empty or non-finite"), + info = m) + # The empty row appears in no fold and in no assignment row ... + expect_equal(nrow(f$assignment), n, info = m) + expect_false((n + 1L) %in% f$assignment$row_id, info = m) + expect_setequal(f$assignment$row_id, seq_len(n)) + # ... and the survivors keep their ORIGINAL row identities, so the folds + # still index the layer the caller passed in. + all_rows <- sort(unique(unlist(lapply(f$folds, `[[`, "test")))) + expect_true(all(all_rows <= n), info = m) + expect_gt(length(f$folds), 0L) + expect_true(all(vapply(f$folds, function(s) length(s$train) > 0L, + logical(1))), info = m) + } +}) + +test_that("make_folds refuses a layer whose geometries are ALL empty", { + allempty <- sf::st_sf( + z = c(1, 2, 3), w = c(4, 5, 6), + geometry = sf::st_sfc(sf::st_point(), sf::st_point(), sf::st_point(), + crs = 32632)) + expect_equal(nrow(allempty), 3L) + expect_error(suppressWarnings(make_folds(allempty, k = 2, + method = "random_kfold", seed = 1)), + "no usable coordinates; there is nothing to split into folds") +}) diff --git a/tests/testthat/test-evaluation.R b/tests/testthat/test-evaluation.R index 7147cb3..1c9e307 100644 --- a/tests/testthat/test-evaluation.R +++ b/tests/testthat/test-evaluation.R @@ -384,3 +384,102 @@ test_that("compare_models_cv restores the caller's RNG stream", { after <- runif(2) expect_equal(before, after) }) + + +# --------------------------------------------------------------------------- +# .merge_args(): the four arguments that define WHAT is being compared +# --------------------------------------------------------------------------- + +test_that(".merge_args refuses per-model overrides of the comparison itself", { + # compare_models_cv() exists to score several backends on ONE dataset with + # ONE set of folds. A `gwr_args = list(folds = ...)` or + # `rf_args = list(data_sf = ...)` would quietly make the models + # incomparable while the result still looked like a comparison table, so the + # four defining arguments are stripped from the per-model lists. + merge_args <- spatialkit:::.merge_args + base <- list(data_sf = "THE DATA", response_var = "z", + predictor_vars = "w", folds = "THE FOLDS", + k = 5L, num_trees = 500L) + + # A NULL is the sharpest case: modifyList() DELETES an element it is given as + # NULL, so an unstripped `folds = NULL` does not merely fail to override the + # folds -- it removes them from the argument list entirely, and the CV + # wrapper then silently falls back to random folds. + # `.` stands in for the quote glyph throughout: sQuote() emits curly + # quotes under a UTF-8 locale and straight ones otherwise. + expect_warning(out <- merge_args(base, list(folds = NULL), "rf_args"), + "ignoring .folds.") + expect_identical(out, base) + expect_identical(out$folds, "THE FOLDS") + + # A non-NULL override of each protected name is refused the same way, while + # everything else in the same list still takes effect. + for (nm in c("data_sf", "response_var", "predictor_vars", "folds")) { + extra <- stats::setNames(list("HIJACKED", 40L), c(nm, "num_trees")) + expect_warning(o <- merge_args(base, extra, "gwr_args"), + sprintf("ignoring .%s.", nm)) + expect_identical(o[[nm]], base[[nm]], info = nm) + expect_identical(o$num_trees, 40L, info = nm) + } + + # Several at once are named together in one warning. + expect_warning( + both <- merge_args(base, list(data_sf = 1, folds = 2), "rf_args"), + ".data_sf., .folds.") + expect_identical(both, base) + + # The message says WHY, not just that something was dropped. + expect_warning(merge_args(base, list(folds = 1), "rf_args"), + "same data and the same folds") + expect_warning(merge_args(base, list(folds = 1), "bayes_args"), + "`bayes_args`") + + # Unprotected arguments merge by name, replacing rather than duplicating -- + # and silently, because there is nothing to complain about. + expect_silent(ok <- merge_args(base, list(num_trees = 40L, mtry = 2L), + "rf_args")) + expect_identical(ok$num_trees, 40L) + expect_identical(ok$mtry, 2L) + expect_identical(ok$data_sf, "THE DATA") + expect_equal(anyDuplicated(names(ok)), 0L) + + # Nothing supplied, nothing changed; an unnamed list is an error. + expect_identical(merge_args(base, NULL, "rf_args"), base) + expect_identical(merge_args(base, list(), "rf_args"), base) + expect_error(merge_args(base, list(40L), "rf_args"), + "every element of `rf_args` must be named") +}) + + +# --------------------------------------------------------------------------- +# "all folds failed" must name the cause +# --------------------------------------------------------------------------- + +test_that("an all-folds-failed CV warning names the first underlying error", { + # "all 5 folds failed" on its own is not a diagnosis. Overwhelmingly the + # reason is a missing optional backend, and the fitter says so plainly when + # called directly -- so the CV wrapper carries the first fold's error text + # into both the warning and the log line. + skip_if(requireNamespace("brms", quietly = TRUE), + "brms is installed, so every fold would succeed") + pts <- surf_test_points(50, seed = 4) + + lines <- capture_spatialkit_log( + expect_warning( + res <- suppressMessages(cv_bayes(pts, "z", "w", k = 2, seed = 1)), + "all folds failed" + ) + ) + # The condition the user sees carries the cause, not just the count. + expect_warning(suppressMessages(cv_bayes(pts, "z", "w", k = 2, seed = 1)), + "First error: .*package 'brms' is required") + # So does the log line, which also reports how many folds were attempted. + expect_true(log_has(lines, "all 2 folds failed")) + expect_true(log_has(lines, "First error: .*package 'brms' is required")) + # And each fold said why as it failed. + expect_true(log_has(lines, "fold 1 fit failed; skipping. Cause: .*'brms'")) + + # The result is still a well-formed, empty CV object. + expect_equal(res$n_folds_attempted, 2L) + expect_equal(res$n_folds_succeeded, 0L) +}) diff --git a/tests/testthat/test-fold-methods.R b/tests/testthat/test-fold-methods.R index e1bbbec..dafb884 100644 --- a/tests/testthat/test-fold-methods.R +++ b/tests/testthat/test-fold-methods.R @@ -348,3 +348,69 @@ test_that("a single block is refused rather than silently defeating blocked CV", "single block covering the whole extent" ) }) + + +# --------------------------------------------------------------------------- +# folds$params$crs: the CRS every length in params is measured in +# --------------------------------------------------------------------------- + +test_that("folds$params records the CRS the folds were actually built in", { + # block_size, sac_range, buffer and median_buffer are lengths in the CRS + # make_folds() worked in -- which for geographic input is one + # ensure_projected() chose, not one the caller passed. Without a label, + # "buffer = 500" is a number with no units attached to it. + set.seed(4) + n <- 45 + pts <- sf::st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)), + coords = c("x", "y"), crs = 32632) + grid <- sf::st_as_sf( + data.frame(x = runif(12, 0, 1000), y = runif(12, 0, 1000)), + coords = c("x", "y"), crs = 32632) + + projected <- list( + block_kfold = make_folds(pts, k = 3, method = "block_kfold", seed = 1), + buffered_loo = make_folds(pts, k = 3, method = "buffered_loo", + buffer = 100, seed = 1), + nndm = make_folds(pts, method = "nndm", + prediction_points = grid, seed = 1) + ) + for (m in names(projected)) { + expect_true("crs" %in% names(projected[[m]]$params), info = m) + # Projected input is used as it stands, so the label is the caller's CRS. + expect_identical(projected[[m]]$params$crs, "EPSG:32632", info = m) + } + + # Geographic input is projected first, so the label must name the CRS + # actually used -- NOT the EPSG:4326 that was passed in. + set.seed(5) + ll <- sf::st_as_sf( + data.frame(x = runif(n, 9, 9.5), y = runif(n, 48, 48.5)), + coords = c("x", "y"), crs = 4326) + grid_ll <- sf::st_as_sf( + data.frame(x = runif(12, 9, 9.5), y = runif(12, 48, 48.5)), + coords = c("x", "y"), crs = 4326) + + # What ensure_projected() picks for this extent, computed here rather than + # copied from a run. + used <- paste0("EPSG:", sf::st_crs(ensure_projected(ll))$epsg) + expect_identical(used, "EPSG:32632") # the containing UTM zone + + geographic <- list( + block_kfold = make_folds(ll, k = 3, method = "block_kfold", seed = 1), + buffered_loo = make_folds(ll, k = 3, method = "buffered_loo", + buffer = 500, seed = 1), + nndm = make_folds(ll, method = "nndm", + prediction_points = grid_ll, seed = 1) + ) + for (m in names(geographic)) { + expect_identical(geographic[[m]]$params$crs, used, info = m) + expect_false(identical(geographic[[m]]$params$crs, "EPSG:4326"), info = m) + } + + # The lengths the label explains are alongside it. + expect_true(all(c("block_size", "sac_range") %in% + names(geographic$block_kfold$params))) + expect_equal(geographic$buffered_loo$params$buffer, 500) + expect_true("median_buffer" %in% names(geographic$nndm$params)) +}) diff --git a/tests/testthat/test-gp-basis.R b/tests/testthat/test-gp-basis.R index ab6c6a0..ddc7d91 100644 --- a/tests/testthat/test-gp-basis.R +++ b/tests/testthat/test-gp-basis.R @@ -84,12 +84,45 @@ test_that(".gp_basis_spec tracks the length-scale ratio, not the coordinate scal expect_identical(k0, as.integer(ceiling(5.6 * b[["upper"]] / b[["lower"]]))) - for (mult in c(1e-3, 1e3)) { + # S is brms's own domain measure: the pooled range of the COLUMN-CENTRED + # coordinates, which is exactly what brms:::choose_L() multiplies by c. + # Verified against brms itself -- the boundary recovered from + # make_standata()'s slambda equals c * this quantity to the last digit at + # every c, and equals TWICE the per-axis half-range the earlier + # implementation used. + brms_S <- function(m) { + Xc <- sweep(as.matrix(m), 2L, colMeans(as.matrix(m))) + max(1, max(Xc) - min(Xc)) # the max(1, .) is brms's + } + # Scale invariance of k holds wherever brms's own max(1, .) floor does not + # bite -- which is every realistic input, since this package hands gp() the + # per-axis standardised coordinates (pooled centred range ~3.5 here). + for (mult in c(1, 1e3, 1e6)) { xy_s <- xy * mult s_s <- spatialkit:::.gp_basis_spec(xy_s, gp_lengthscale_bounds(xy_s)) + expect_gt(brms_S(xy_s), 1) # floor not engaged expect_identical(s_s$k, k0) # k unchanged ... - expect_equal(s_s$S, mult * max(apply(xy, 2, function(z) diff(range(z)) / 2))) - } # ... while S scaled by 1e6 + expect_equal(s_s$S, brms_S(xy_s)) # ... while S scales with it + } + # Regression guard: the half-range convention is exactly half of this, and + # using it built a GP boundary twice as wide as gp_k was sized for. + expect_equal(spatialkit:::.gp_basis_spec(xy, b)$S, brms_S(xy)) + expect_gt(brms_S(xy), 1.5 * max(apply(xy, 2, function(z) diff(range(z)) / 2))) +}) + +test_that(".gp_basis_spec reproduces brms's max(1, range) boundary floor", { + # choose_L() floors the domain range at 1, so below that extent brms builds + # the boundary from 1 rather than from the data. This function must do the + # same, or gp_k and gp_ell_min would describe a basis brms does not build. + # It is why k is NOT scale-invariant all the way down. + set.seed(2) + xy <- scale(matrix(runif(2 * 2000), ncol = 2)) + tiny <- xy * 1e-3 # pooled centred range ~0.0035 + s_t <- spatialkit:::.gp_basis_spec(tiny, gp_lengthscale_bounds(tiny)) + expect_equal(s_t$S, 1) # floored, not 0.0035 + expect_equal(s_t$c, 1.25) # so c falls to its floor + # and k rises, because the basis must now resolve a much smaller ell/S. + expect_gt(s_t$k, spatialkit:::.gp_basis_spec(xy, gp_lengthscale_bounds(xy))$k) }) test_that(".gp_basis_spec demands more basis functions for finer structure", { @@ -145,14 +178,23 @@ test_that(".gp_basis_spec sets c from the UPPER length-scale bound", { # not (3.2*upper)/S -- and allow a rounding tolerance: when this constraint # binds, c_val IS this product, so a strict >= is a floating-point coin flip. expect_gte(s$c, 3.2 * (b[["upper"]] / s$S) - 1e-9) - expect_gte(s$c, 1.2) + expect_gte(s$c, 1.25) # brms's own default boundary factor, c = 5/4 expect_gt(s$c, 1.5) # would have failed under the old default }) -test_that(".gp_basis_spec returns the domain half-range it used", { +test_that(".gp_basis_spec returns brms's own domain measure, not the half-range", { + # brms builds the GP boundary as choose_L(x, c) = c * max(1, max(x) - min(x)) + # over the column-centred, POOLED covariate matrix. Deriving c against the + # per-axis half-range and handing it to brms::gp() therefore produced a + # boundary twice as wide as intended, under-resolving the GP by a factor of + # two and making $info$gp_ell_min twice too lenient to catch it. xy <- scaled_uniform(500, seed = 5) s <- spatialkit:::.gp_basis_spec(xy, gp_lengthscale_bounds(xy)) - expect_equal(s$S, max(apply(xy, 2, function(z) diff(range(z)) / 2))) + Xc <- sweep(xy, 2L, colMeans(xy)) + expect_equal(s$S, max(1, max(Xc) - min(Xc))) + # ... and that is twice the old half-range, which is the size of the bug. + expect_equal(s$S / max(apply(xy, 2, function(z) diff(range(z)) / 2)), 2, + tolerance = 0.05) }) test_that(".gp_basis_spec survives degenerate coordinates", { @@ -173,6 +215,50 @@ test_that("gp_lengthscale_bounds returns a sane, separated interval", { expect_gte(b[["upper"]], b[["lower"]] * 1.2) # the separation guard }) +test_that("gp_lengthscale_bounds calibrates to 5 % SE correlation at the bound", { + # Finiteness, positivity and a 1.2x gap are satisfied by an interval that is + # 2.45x too wide at both ends, so none of them pins the calibration. The + # documented rule does: the squared-exponential kernel has + # + # corr(d) = exp(-d^2 / (2 l^2)), + # + # so requiring corr = 0.05 at distance d gives d^2 / (2 l^2) = log 20, i.e. + # l = d / sqrt(2 log 20). The lower bound applies that to the q_small + # quantile of the pairwise distances and the upper bound to the maximum, so + # BOTH bounds must reproduce a correlation of exactly 0.05 at their own + # distance. Nothing here re-uses the implementation's constant. + xy <- scaled_uniform(500, seed = 6) + b <- gp_lengthscale_bounds(xy) + + d <- as.numeric(stats::dist(xy)) # n = 500 <= max_n, so no sample + d <- d[d > 0] + dq <- stats::quantile(d, 0.25, names = FALSE, type = 7) # q_small default + dmax <- max(d) + # The separation guard must not be the thing setting `upper`, or the upper + # assertion below would be testing max() rather than the calibration. + expect_gt(dmax, 1.2 * dq) + + se_corr <- function(dist, l) exp(-dist^2 / (2 * l^2)) + expect_equal(se_corr(dq, b[["lower"]]), 0.05, tolerance = 1e-12) + expect_equal(se_corr(dmax, b[["upper"]]), 0.05, tolerance = 1e-12) + + # Equivalently, and more directly: the bounds ARE those distances divided by + # sqrt(2 log 20) ~ 2.448. A factor of 1 -- no conversion at all -- would put + # both bounds 2.45x too high and make the correlation above exp(-1/2) = 0.61. + expect_equal(unname(b[["lower"]]), dq / sqrt(2 * log(20)), tolerance = 1e-12) + expect_equal(unname(b[["upper"]]), dmax / sqrt(2 * log(20)), tolerance = 1e-12) + + # The separation guard still binds when the distance distribution is narrow + # enough that dmax < 1.2 * dq -- points on one tight ring, say. + ang <- seq(0, 2 * pi, length.out = 60)[-60] + ring <- cbind(cos(ang), sin(ang)) + br <- gp_lengthscale_bounds(ring, q_small = 0.9) + dr <- as.numeric(stats::dist(ring)); dr <- dr[dr > 0] + expect_lt(max(dr), 1.2 * stats::quantile(dr, 0.9, names = FALSE)) + expect_equal(unname(br[["upper"]]), unname(br[["lower"]]) * 1.2, + tolerance = 1e-12) +}) + test_that("the GP term disables brms's own covariate scaling", { # brms::gp() defaults to scale = TRUE, which normalises covariates so the max diff --git a/tests/testthat/test-gwr-bandwidth.R b/tests/testthat/test-gwr-bandwidth.R index 8c46e7d..cc3b1d1 100644 --- a/tests/testthat/test-gwr-bandwidth.R +++ b/tests/testthat/test-gwr-bandwidth.R @@ -83,3 +83,62 @@ test_that("a successful bandwidth selection is not labelled a fallback", { expect_false(auto$info$bandwidth_is_fallback) expect_true(is.finite(auto$info$bandwidth) && auto$info$bandwidth > 0) }) + + +# --------------------------------------------------------------------------- +# "Exactly two distinct values" is not the same thing as "binary" +# --------------------------------------------------------------------------- + +.gwr2v_points <- function(z, n = 60, seed = 2) { + set.seed(seed) + sf::st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), z = rep(z, length.out = n)), + coords = c("x", "y"), crs = 32632) +} + +test_that("fit_gwr_model fits a two-valued NON-INTEGER response with a warning", { + # A left-censored measurement -- everything either at the detection limit + # (0.0031) or at a single higher reading -- has exactly two distinct values + # and is perfectly continuous. Gaussian GWR on it is a well-defined + # least-squares problem, and the old error's advice to switch to + # 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)) + expect_equal(length(unique(censored$z)), 2L) + expect_false(all(censored$z == round(censored$z))) + + expect_warning(fit <- fit_gwr_model(censored, "z", "a", bandwidth = 300), + "has only 2 distinct finite values") + expect_s3_class(fit, "gwr_fit") + # Warned, not refused: it is the design that is degenerate, not the model. + expect_warning(fit_gwr_model(censored, "z", "a", bandwidth = 300), + "genuinely continuous \\(e.g. censored at a detection limit\\)") + + # An integer-valued pair is still a hard error, with the binomial advice. + binary <- .gwr2v_points(c(0, 1)) + expect_true(all(binary$z == round(binary$z))) + expect_error(fit_gwr_model(binary, "z", "a", bandwidth = 300), + "is binary \\(2 distinct values") + expect_error(fit_gwr_model(binary, "z", "a", bandwidth = 300), + "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 = 300), + "package 'GWmodel' is required") + } +}) diff --git a/tests/testthat/test-gwr-model-selection.R b/tests/testthat/test-gwr-model-selection.R index 3205753..026668f 100644 --- a/tests/testthat/test-gwr-model-selection.R +++ b/tests/testthat/test-gwr-model-selection.R @@ -32,21 +32,43 @@ test_that(".gwr_ms_criterion matches the column name case-insensitively and igno expect_equal(res$values, c(5, 6)) }) -test_that(".gwr_ms_criterion falls back to column 2 when the table is unlabelled", { - # This is what GWmodel's own documentation does: model.sel[[2]][, 2]. - m <- matrix(c(1, 2, 3, 40, 50, 60, 7, 8, 9), ncol = 3) +test_that(".gwr_ms_criterion reads AICc from column 3 when the table is unlabelled", { + # GWmodel's GWR.df is documented AND built as c(bandwidth, AIC, AICc, RSS): + # in Model.selection.r it is rbind()ed from + # c(bw, aic.rss[2], aic.rss[3], aic.rss[1]) with aic.rss = c(RSS, AIC, AICc) + # over UNNAMED vectors, so it never carries column names -- which makes this + # positional branch the path every real call takes, not a rare fallback. + # + # Column 2 is the UNCORRECTED AIC. Reading it ranked models on AIC while + # labelling the answer AICc, which selects larger models: executed against a + # faithful GWmodel stub, the old code selected the model containing a + # pure-noise predictor that AICc drops. + m <- matrix(c(1, 2, 3, 40, 50, 60, 7, 8, 9, 100, 200, 300), ncol = 4) res <- .gwr_ms_criterion(m) expect_false(res$by_name) - expect_identical(res$column, 2L) - expect_equal(res$values, c(40, 50, 60)) + expect_identical(res$column, 3L) + expect_equal(res$values, c(7, 8, 9)) + expect_true(res$shape_ok) # the documented four columns expect_match(res$label, "assumed") }) +test_that(".gwr_ms_criterion flags a table that is not the documented shape", { + # Anything other than c(bandwidth, AIC, AICc, RSS) is a layout this code has + # never seen; it reads the same position but tells the caller the ranking is + # unverified, so gwr_model_selection() can warn instead of asserting AICc. + m <- matrix(c(1, 2, 3, 40, 50, 60, 7, 8, 9), ncol = 3) + res <- .gwr_ms_criterion(m) + expect_false(res$by_name) + expect_identical(res$column, 3L) + expect_false(res$shape_ok) +}) + test_that(".gwr_ms_criterion falls back to column 1 for a single-column table", { m <- matrix(c(4, 5, 6), ncol = 1) res <- .gwr_ms_criterion(m) expect_identical(res$column, 1L) expect_equal(res$values, c(4, 5, 6)) + expect_false(res$shape_ok) }) test_that(".gwr_ms_criterion accepts a bare numeric vector", { diff --git a/tests/testthat/test-knn-weights.R b/tests/testthat/test-knn-weights.R index 368c29e..48e563a 100644 --- a/tests/testthat/test-knn-weights.R +++ b/tests/testthat/test-knn-weights.R @@ -69,3 +69,171 @@ test_that("k is clamped to n - 1", { expect_equal(unname(rowSums(as.matrix(W))), rep(1, 6), tolerance = 1e-12) expect_true(all(diag(as.matrix(W)) == 0)) # no self-neighbours }) + + +test_that("the dense path handles k = 1 without collapsing the index matrix", { + # At k = 1 the inner function handed to apply() returns a SCALAR, so apply() + # simplifies to a length-n vector and t() makes it a 1 x n matrix. The + # `nn_idx[i, ]` lookup below then failed with "subscript out of bounds" for + # every i > 1 -- so residual_morans_i(fit, k = 1) was broken outright on any + # machine without FNN. + build <- knn_fn() + set.seed(11) + coords <- matrix(runif(40 * 2), ncol = 2) # jittered: no distance ties + + W <- as.matrix(build(coords, k = 1L, use_fnn = FALSE)) + expect_equal(dim(W), c(40L, 40L)) + # Exactly one neighbour per row, weight 1, never itself. + expect_equal(unname(rowSums(W)), rep(1, 40), tolerance = 1e-12) + expect_equal(unname(rowSums(W > 0)), rep(1L, 40)) + expect_true(all(diag(W) == 0)) + + # The neighbour really is the nearest one, computed independently. + d <- as.matrix(stats::dist(coords)); diag(d) <- Inf + expect_equal(unname(apply(W, 1, which.max)), unname(apply(d, 1, which.min))) + + # ... and the two backends agree at k = 1 as they do at k = 8. + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + expect_equal(unname(as.matrix(build(coords, k = 1L))), unname(W), + tolerance = 1e-12) +}) + +test_that("residual_morans_i(k = 1) agrees with the dense k = 1 weights", { + # The user-visible form of the same crash. residual_morans_i() has no + # backend switch of its own, so on this machine it takes the FNN/Matrix path; + # supplying the DENSE k = 1 matrix through `weights` is what puts the fixed + # branch under the public function, and the two must give one statistic. + build <- knn_fn() + set.seed(12) + n <- 60 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2]), + coords = c("x", "y"), crs = 32632) + fit <- moran_stub_fit(pts, stats::rnorm(n)) + + for (k in c(1L, 2L)) { + lbl <- paste("k =", k) + dense <- build(xy, k = k, use_fnn = FALSE) + got <- residual_morans_i(fit, k = k) + ref <- residual_morans_i(fit, weights = dense) + + expect_true(is.finite(got$observed), info = lbl) + expect_true(is.finite(got$p_value), info = lbl) + expect_equal(got$observed, ref$observed, tolerance = 1e-12, info = lbl) + expect_equal(got$p_value, ref$p_value, tolerance = 1e-12, info = lbl) + # Cliff & Ord's null expectation, which does not depend on the weights. + expect_equal(got$expected, -1 / (n - 1), tolerance = 1e-12, info = lbl) + } +}) + + +# --------------------------------------------------------------------------- +# Duplicate coordinates +# +# FNN::get.knn() answers a tied query by returning SOME of the tied points, and +# the query point's own index is eligible to be one of them. With exact +# duplicates a k-nearest query therefore came back holding self -- putting 1/k +# on the diagonal of a matrix Moran's I is only defined for with a zero +# diagonal -- and asking for k + 1 and dropping self is NOT enough on its own, +# because the slot self occupied displaced a genuine co-located neighbour and +# left a farther point standing in for it. +# +# Repeat observations at one site are exactly what +# make_folds(method = "leave_location_out") exists for, and residual_morans_i() +# reads fit$data_sf without de-duplicating, so this is a mainstream input. +# --------------------------------------------------------------------------- + +.dup_layouts <- function() list( + "25 sites x 4 repeats" = local({ + set.seed(7) + cbind(rep(runif(25, 0, 1000), each = 4), rep(runif(25, 0, 1000), each = 4)) + }), + "5 sites x 20 repeats" = local({ + set.seed(11) + cbind(rep(runif(5, 0, 100), each = 20), rep(runif(5, 0, 100), each = 20)) + }), + "mixed dup and distinct" = local({ + set.seed(3) + rbind(cbind(rep(runif(10, 0, 500), each = 3), rep(runif(10, 0, 500), each = 3)), + cbind(runif(50, 0, 500), runif(50, 0, 500))) + }), + "all identical" = cbind(rep(5, 12), rep(9, 12)) +) + +test_that("duplicate coordinates leave a zero diagonal and row sums of 1", { + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + build <- knn_fn() + for (nm in names(.dup_layouts())) { + co <- .dup_layouts()[[nm]] + for (k in c(1L, 3L, 8L)) { + if (k >= nrow(co) - 1L) next + W <- as.matrix(build(co, k = k, use_fnn = TRUE, use_matrix = TRUE)) + lbl <- paste(nm, "k =", k) + expect_equal(max(abs(diag(W))), 0, info = lbl) + expect_equal(unname(rowSums(W)), rep(1, nrow(co)), info = lbl) + expect_equal(unique(rowSums(W != 0)), k, info = lbl) + } + } +}) + +test_that("with duplicates the kd-tree keeps the k NEAREST, not k of any", { + # The property a k + 1 query and a self-drop does NOT give you. Measured on + # 25 sites x 4 repeats at k = 3, that approach retained 75 of 400 pairs at a + # distance of 121 where a co-located neighbour at distance 0 existed. + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + build <- knn_fn() + for (nm in names(.dup_layouts())) { + co <- .dup_layouts()[[nm]] + D <- as.matrix(stats::dist(co)); diag(D) <- Inf + for (k in c(1L, 2L, 3L, 8L)) { + if (k >= nrow(co) - 1L) next + W <- as.matrix(build(co, k = k, use_fnn = TRUE, use_matrix = TRUE)) + lbl <- paste(nm, "k =", k) + for (i in seq_len(nrow(co))) { + expect_equal(sort(unname(D[i, W[i, ] != 0])), + unname(sort(D[i, ])[seq_len(k)]), info = lbl) + } + } + } +}) + +test_that("the kd-tree and the dense fallback agree on the same weights", { + # The statistic must not depend on whether FNN happens to be installed. On + # distinct coordinates the two matrices are identical; with ties they may + # break them differently, so the retained NEIGHBOUR DISTANCES are compared. + skip_if_not_installed("FNN") + skip_if_not_installed("Matrix") + build <- knn_fn() + set.seed(7) + distinct <- cbind(runif(200, 0, 1000), runif(200, 0, 1000)) + for (k in c(1L, 3L, 8L)) { + A <- as.matrix(build(distinct, k = k, use_fnn = TRUE, use_matrix = TRUE)) + B <- build(distinct, k = k, use_fnn = FALSE, use_matrix = FALSE) + expect_equal(A, B, ignore_attr = TRUE, info = paste("distinct, k =", k)) + } + for (nm in names(.dup_layouts())) { + co <- .dup_layouts()[[nm]] + D <- as.matrix(stats::dist(co)); diag(D) <- Inf + for (k in c(1L, 3L)) { + if (k >= nrow(co) - 1L) next + A <- as.matrix(build(co, k = k, use_fnn = TRUE, use_matrix = TRUE)) + B <- build(co, k = k, use_fnn = FALSE, use_matrix = FALSE) + expect_equal(sort(D[A != 0]), sort(D[B != 0]), + info = paste(nm, "k =", k)) + } + } +}) + +test_that("k = 1 works on the dense path", { + # apply() simplifies a length-1 result to a VECTOR, so t() made a 1 x n + # matrix and nn_idx[i, ] was out of bounds for every i > 1. + build <- knn_fn() + set.seed(5) + co <- cbind(runif(20, 0, 100), runif(20, 0, 100)) + W <- build(co, k = 1L, use_fnn = FALSE, use_matrix = FALSE) + expect_equal(unname(rowSums(W)), rep(1, 20)) + expect_equal(max(abs(diag(W))), 0) +}) diff --git a/tests/testthat/test-level-selection.R b/tests/testthat/test-level-selection.R index 3947c61..c9afb09 100644 --- a/tests/testthat/test-level-selection.R +++ b/tests/testthat/test-level-selection.R @@ -100,25 +100,89 @@ test_that(".elbow_from_wss rejects input it cannot use", { ) } -test_that(".morans_i_for_k returns the analytic value when every cell is a neighbour", { +test_that(".morans_i_for_k refuses the complete-graph value below the floor", { # The weight matrix uses k = min(8, n_cells - 1) neighbours, so with 9 or # fewer cells EVERY other cell is a neighbour and W is the complete # row-standardised matrix W_ij = 1/(n-1). Then W %*% e = -e/(n-1) for any # mean-zero residual vector, S0 = n, and Moran's I collapses to exactly - # -1/(n - 1) -- independent of the data. That is a closed-form expectation, - # and it is the configuration the sparse crossprod() bug crashed on. + # -1/(n - 1): a function of the CELL COUNT ALONE that no data set can move. + # + # Returning that number would not merely be uninformative. |I| = 1/(n - 1) + # falls monotonically in n for arithmetic reasons, so criterion = "morans_i" + # would rank the largest candidate best every single time. The function + # refuses it and returns NA, and determine_optimal_levels() drops those + # candidates from the model-aware ranking. fx <- .mifk_fixture() mk <- spatialkit:::.morans_i_for_k for (n_cells in c(4L, 5L, 6L, 9L)) { clusters <- rep(seq_len(n_cells), length.out = nrow(fx$xy)) - got <- mk(fx$xy, fx$spatial, fx$pred, clusters) - expect_equal(got, -1 / (n_cells - 1), tolerance = 1e-10, - info = paste("n_cells =", n_cells)) - expect_true(is.finite(got)) + lbl <- paste("n_cells =", n_cells) + got <- mk(fx$xy, fx$spatial, fx$pred, clusters) + flat <- mk(fx$xy, fx$flat, fx$pred, clusters) + # The return is c(I = , z = ): BOTH must be NA, since z is the quantity + # the ranking uses and an NA I beside a finite z would still be ranked. + expect_identical(names(got), c("I", "z"), info = lbl) + expect_true(all(is.na(got)), info = lbl) + # Refused for the flat response too -- the point is that the complete + # graph cannot tell these two apart, not that one of them is unusable. + expect_true(all(is.na(flat)), info = lbl) } }) +test_that(".morans_i_for_k reports a data-dependent value from ten cells up", { + # Ten cells is the first count above the floor: k = min(8, 9) = 8 of the 9 + # other cells are neighbours, so W is no longer complete and I stops being a + # function of n. A spatially coherent 5 x 2 partition, so the cell + # centroids are genuinely spread out rather than piled at the domain centre. + fx <- .mifk_fixture() + mk <- spatialkit:::.morans_i_for_k + clusters <- as.integer(cut(fx$xy[, 1], 5)) + + 5L * (as.integer(cut(fx$xy[, 2], 2)) - 1L) + expect_equal(length(unique(clusters)), 10L) + + # An independent reference: the dense (non-sparse) weight path plus the + # Cliff & Ord formula written out, so it shares no code with the branch + # under test. + ref_I <- function(resp) { + ids <- sort(unique(clusters)); nc <- length(ids) + cr <- numeric(nc); cxy <- matrix(0, nc, 2); cp <- matrix(0, nc, 1) + for (j in seq_along(ids)) { + m <- clusters == ids[j] + cr[j] <- mean(resp[m]) + cxy[j, ] <- colMeans(fx$xy[m, , drop = FALSE]) + cp[j, ] <- colMeans(fx$pred[m, , drop = FALSE]) + } + r <- stats::lm.fit(x = cbind(1, cp), y = cr)$residuals + W <- spatialkit:::.build_knn_weights(cxy, k = min(8L, nc - 1L), + use_fnn = FALSE, use_matrix = FALSE) + rc <- r - mean(r) + (nc / sum(W)) * sum(rc * (W %*% rc)) / sum(rc^2) + } + + I_spatial <- mk(fx$xy, fx$spatial, fx$pred, clusters)[["I"]] + I_flat <- mk(fx$xy, fx$flat, fx$pred, clusters)[["I"]] + + expect_true(is.finite(I_spatial)) + expect_true(is.finite(I_flat)) + expect_equal(I_spatial, ref_I(fx$spatial), tolerance = 1e-10) + expect_equal(I_flat, ref_I(fx$flat), tolerance = 1e-10) + + # The property the sub-floor case cannot have: two different residual + # vectors on the SAME clustering give two different statistics. + expect_false(isTRUE(all.equal(I_spatial, I_flat, tolerance = 1e-6))) + # And neither of them is the complete-graph constant the floor rejects. + expect_false(isTRUE(all.equal(I_spatial, -1 / 9, tolerance = 1e-6))) + expect_false(isTRUE(all.equal(I_flat, -1 / 9, tolerance = 1e-6))) + + # One cell fewer is below the floor and comes back NA, so ten is the + # boundary and not an arbitrary choice. + nine <- as.integer(cut(fx$xy[, 1], 3)) + + 3L * (as.integer(cut(fx$xy[, 2], 3)) - 1L) + expect_equal(length(unique(nine)), 9L) + expect_true(all(is.na(mk(fx$xy, fx$spatial, fx$pred, nine)))) +}) + test_that(".morans_i_for_k matches a dense hand computation for many cells", { # Above 9 cells the neighbour set is a genuine 8-NN graph and I depends on # the data. The reference below builds the weights on the DENSE path @@ -149,197 +213,89 @@ test_that(".morans_i_for_k matches a dense hand computation for many cells", { rc <- resid - mean(resid) expected <- (nc / sum(W)) * sum(rc * (W %*% rc)) / sum(rc^2) - expect_equal(spatialkit:::.morans_i_for_k(fx$xy, fx$spatial, fx$pred, - clusters), - expected, tolerance = 1e-10) + got <- spatialkit:::.morans_i_for_k(fx$xy, fx$spatial, fx$pred, clusters) + expect_equal(got[["I"]], expected, tolerance = 1e-10) # And the statistic discriminates: a response with no unexplained spatial # structure sits near zero, the trended one well above it. - flat_I <- spatialkit:::.morans_i_for_k(fx$xy, fx$flat, fx$pred, clusters) + flat <- spatialkit:::.morans_i_for_k(fx$xy, fx$flat, fx$pred, clusters) expect_gt(expected, 0.2) - expect_lt(abs(flat_I), 0.2) - expect_gt(expected, flat_I) + expect_lt(abs(flat[["I"]]), 0.2) + expect_gt(expected, flat[["I"]]) + + # The z companion is what determine_optimal_levels() ranks on, and it must + # be the Cliff & Ord standardised deviate of the SAME I -- recomputed here + # from the dense weights so the two paths share no code. + X <- cbind(1, cell_pred) + mom <- spatialkit:::.morans_residual_moments(W = W, X = X, S0 = sum(W), + is_sparse = FALSE) + expect_false(is.null(mom)) + expect_equal(got[["z"]], (expected - mom$EI) / sqrt(mom$VI), tolerance = 1e-10) + # The trended response is the significant one; the flat one is not. + expect_gt(got[["z"]], 2) + expect_lt(abs(flat[["z"]]), 2) }) test_that(".morans_i_for_k returns NA rather than a number it cannot justify", { fx <- .mifk_fixture() mk <- spatialkit:::.morans_i_for_k + # Every refusal keeps the c(I, z) shape: a bare NA_real_ from one early exit + # and a length-2 vector from another would make moran_z[k] pick up the I of + # the next candidate. + expect_na2 <- function(v) { + expect_identical(names(v), c("I", "z")) + expect_true(all(is.na(v))) + } # Fewer than 4 cells: no usable weight graph. - expect_true(is.na(mk(fx$xy, fx$spatial, fx$pred, - rep(1:3, length.out = nrow(fx$xy))))) + expect_na2(mk(fx$xy, fx$spatial, fx$pred, rep(1:3, length.out = nrow(fx$xy)))) # Non-finite cell means leave fewer than 4 usable cells. broken <- fx$spatial; broken[] <- NA_real_ - expect_true(is.na(mk(fx$xy, broken, fx$pred, - rep(1:6, length.out = nrow(fx$xy))))) + expect_na2(mk(fx$xy, broken, fx$pred, rep(1:6, length.out = nrow(fx$xy)))) # A perfectly explained response leaves zero residual variance. exact <- 3 + 2 * fx$pred[, 1] - expect_true(is.na(mk(fx$xy, exact, fx$pred, - rep(1:6, length.out = nrow(fx$xy))))) + expect_na2(mk(fx$xy, exact, fx$pred, rep(1:6, length.out = nrow(fx$xy)))) }) -# --------------------------------------------------------------------------- -# determine_optimal_levels() -# --------------------------------------------------------------------------- - -.dol_two_clusters <- function(seed = 1) { - set.seed(seed) - sf::st_as_sf( - data.frame(x = c(runif(25, 0, 10), runif(25, 90, 100)), - y = c(runif(25, 0, 10), runif(25, 90, 100))), - coords = c("x", "y"), crs = 32632 - ) -} - -.dol_model_points <- function(n = 150, seed = 3) { - set.seed(seed) - d <- sf::st_as_sf( - data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), a = rnorm(n)), - coords = c("x", "y"), crs = 32632) - d$z <- 0.01 * sf::st_coordinates(d)[, 1] + 2 * d$a + rnorm(n) - d -} - -test_that("determine_optimal_levels finds the elbow of two separated clusters", { - # Two tight, far-apart clusters: WSS collapses between k = 1 and k = 2 and - # is nearly flat afterwards, so the knee is at 2 and the candidate set is - # its immediate neighbourhood. - out <- determine_optimal_levels(.dol_two_clusters(), max_levels = 6) - - expect_type(out, "integer") - expect_true(2L %in% out) - expect_true(all(out >= 1L & out <= 6L)) - # Under "geometric" the candidate set is the knee plus two neighbours, so at - # most three values come back however large top_n is. - expect_lte(length(out), 3L) - expect_lte(length(determine_optimal_levels(.dol_two_clusters(), - max_levels = 6, top_n = 10)), 3L) - expect_null(attr(out, "diagnostics")) # no model-aware run, no diagnostics -}) +test_that("the ranking statistic is flat in k where |I| is not", { + # The reason determine_optimal_levels() ranks on z rather than |I|. E[I] and + # Var(I) both move with the cell count, so across datasets with NO spatial + # structure the SAMPLING DISTRIBUTION of |I| shrinks as k grows -- an |I| + # ranking then prefers the finest candidate for arithmetic reasons alone. + # + # Fresh data per replicate is load-bearing. Holding one dataset and only + # re-clustering it measures that realisation's own residual pattern, not the + # sampling distribution, and shows no such trend (it can even run the other + # way). The claim is about the statistic, so the data must be resampled. + skip_on_cran() + mk <- spatialkit:::.morans_i_for_k -test_that("determine_optimal_levels runs the model-aware criteria without crashing", { - # The regression: with FNN and Matrix installed, .morans_i_for_k() built a - # sparse weight matrix and base::crossprod() refused it, so every call with - # a model-aware criterion errored for >= 4 cells. - d <- .dol_model_points() - - for (crit in c("morans_i", "combined")) { - out <- determine_optimal_levels(d, max_levels = 8, response_var = "z", - predictor_vars = "a", criterion = crit) - expect_type(out, "integer") - expect_gte(length(out), 1L) - expect_true(all(out >= 1L & out <= 8L)) - - diag <- attr(out, "diagnostics") - expect_false(is.null(diag), info = crit) - expect_true(any(is.finite(diag$moran_i)), info = crit) - expect_true(all(is.finite(diag$wss)), info = crit) - # Moran's I was actually evaluated over the elbow neighbourhood: finite for - # every k that yields at least 4 cells, NA below that (the documented - # n_cells < 4 guard in .morans_i_for_k()). - big <- diag$eval_ks[diag$eval_ks >= 4L] - small <- diag$eval_ks[diag$eval_ks < 4L] - expect_gt(length(big), 0L) - expect_true(all(is.finite(diag$moran_i[big])), info = crit) - if (length(small)) - expect_true(all(is.na(diag$moran_i[small])), info = crit) - # Every k the neighbourhood did NOT evaluate stays NA. - expect_true(all(is.na(diag$moran_i[setdiff(seq_along(diag$moran_i), - diag$eval_ks)])), info = crit) + grab <- function(k, reps = 25L) { + v <- vapply(seq_len(reps), function(r) { + set.seed(7000 + r) + n <- 600 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + pr <- cbind(rnorm(n), rnorm(n)) + rs <- as.numeric(1 + pr %*% c(1, -1) + rnorm(n)) # no spatial structure + cl <- stats::kmeans(xy, centers = k, iter.max = 50, nstart = 3)$cluster + mk(xy, rs, pr, cl) + }, c(I = 0, z = 0)) + c(absI = mean(abs(v["I", ]), na.rm = TRUE), + absZ = mean(abs(v["z", ]), na.rm = TRUE)) } -}) - -test_that("determine_optimal_levels auto-upgrades and falls back with a log line", { - d <- .dol_model_points() - - # Supplying model variables under the default criterion upgrades to combined. - up <- capture_spatialkit_log( - out <- determine_optimal_levels(d, max_levels = 8, response_var = "z", - predictor_vars = "a"), - level = logger::INFO - ) - expect_true(log_has(up, "using combined criterion")) - expect_equal(attr(out, "diagnostics")$criterion, "combined") - - # Asking for a model-aware criterion without the variables falls back. - down <- capture_spatialkit_log( - geo <- determine_optimal_levels(d, max_levels = 6, criterion = "morans_i") - ) - expect_true(log_has(down, "requires response_var and predictor_vars")) - expect_null(attr(geo, "diagnostics")) - expect_equal(geo, determine_optimal_levels(d, max_levels = 6)) -}) - -test_that("determine_optimal_levels validates input and degenerate geometry", { - d <- .dol_model_points() - - expect_error(determine_optimal_levels(sf::st_drop_geometry(d)), - "must be an sf object") - - d$fac <- factor(sample(letters[1:3], nrow(d), replace = TRUE)) - expect_error( - determine_optimal_levels(d, response_var = "z", predictor_vars = "fac"), - "`predictor_vars` must be numeric" - ) - - # Fewer than 3 rows: one level, no clustering attempted. - expect_equal(determine_optimal_levels(d[1:2, ], max_levels = 4), 1L) - - # Only two distinct positions: k_max clamps to n_unique - 1 = 1, so again 1. - dup <- sf::st_as_sf( - data.frame(x = rep(c(0, 10), 10), y = rep(c(0, 10), 10)), - coords = c("x", "y"), crs = 32632) - expect_equal(determine_optimal_levels(dup, max_levels = 6), 1L) -}) - -test_that("determine_optimal_levels coerces MULTIPOINT before reading coordinates", { - # st_coordinates() returns one row per VERTEX, so a two-vertex MULTIPOINT - # layer produced an xy matrix twice as tall as resp_vec/pred_mat and every - # index below read a different feature than it thought. Coercing to - # representative points first makes the MULTIPOINT layer and its own - # centroids give the same answer. - set.seed(21) - n <- 120 - cx <- runif(n, 0, 1000); cy <- runif(n, 0, 1000) - mp <- sf::st_sfc(lapply(seq_len(n), function(i) { - sf::st_multipoint(rbind(c(cx[i] - 5, cy[i]), c(cx[i] + 5, cy[i]))) - }), crs = 32632) - - multi <- sf::st_sf(a = rnorm(n), geometry = mp) - multi$z <- 0.01 * cx + 2 * multi$a + rnorm(n) - - pts <- multi - sf::st_geometry(pts) <- sf::st_sfc( - lapply(seq_len(n), function(i) sf::st_point(c(cx[i], cy[i]))), crs = 32632) - - # One coordinate row per feature after coercion -- the property everything - # below depends on. - coerced <- coerce_to_points(multi, "auto") - expect_equal(nrow(sf::st_coordinates(coerced)), n) - expect_equal(unname(sf::st_coordinates(coerced)[, 1]), cx, tolerance = 1e-6) - - geo_multi <- determine_optimal_levels(multi, max_levels = 6) - geo_pts <- determine_optimal_levels(pts, max_levels = 6) - expect_equal(geo_multi, geo_pts) - - mod_multi <- determine_optimal_levels(multi, max_levels = 6, - response_var = "z", - predictor_vars = "a", - criterion = "combined") - mod_pts <- determine_optimal_levels(pts, max_levels = 6, - response_var = "z", - predictor_vars = "a", - criterion = "combined") - expect_equal(as.integer(mod_multi), as.integer(mod_pts)) - expect_equal(attr(mod_multi, "diagnostics")$moran_i, - attr(mod_pts, "diagnostics")$moran_i) -}) - -test_that("determine_optimal_levels restores the caller's RNG stream", { - d <- .dol_model_points() - set.seed(777); expected <- runif(3) - set.seed(777) - invisible(determine_optimal_levels(d, max_levels = 6, set_seed = 42L)) - expect_equal(runif(3), expected) + lo <- grab(12L) + hi <- grab(45L) + + # |I| falls materially across the window (measured ratio 0.60-0.65) ... + expect_lt(hi[["absI"]], 0.8 * lo[["absI"]]) + # ... while |z| stays in the neighbourhood of E|N(0,1)| = 0.798 at both ends, + # so the two candidates are compared on the same scale. + for (v in c(lo[["absZ"]], hi[["absZ"]])) { + expect_gt(v, 0.5) + expect_lt(v, 1.3) + } + # And the drift in |z| is small next to the drift in |I|. + expect_lt(abs(hi[["absZ"]] / lo[["absZ"]] - 1), + abs(hi[["absI"]] / lo[["absI"]] - 1)) }) diff --git a/tests/testthat/test-make-folds-row-ids.R b/tests/testthat/test-make-folds-row-ids.R index f7a1674..a318c9d 100644 --- a/tests/testthat/test-make-folds-row-ids.R +++ b/tests/testthat/test-make-folds-row-ids.R @@ -111,3 +111,77 @@ test_that("auto-generated block folds stay aligned when prep_model_data drops ro expect_setequal(dat_sf$..row_id[te_pos], remapped[[j]]$test) } }) + + +# --------------------------------------------------------------------------- +# Fold provenance +# +# Fold splits are lists of ..row_id values, and row IDs are just +# seq_len(nrow()) unless the caller supplied them. A `folds` object built from +# a DIFFERENT dataset of the same size therefore applied cleanly: every ID +# matched, every fold was populated, and the model was scored on splits that +# describe other observations. Nothing in the result said so. +# --------------------------------------------------------------------------- + +.probe_pts <- function(seed, n = 60) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 0.01 * sf::st_coordinates(d)[, 1] + 2 * d$a + rnorm(n) + d +} + +test_that("make_folds records a row probe in params", { + f <- make_folds(.probe_pts(1), k = 3, method = "random_kfold", seed = 1) + p <- f$params$row_probe + expect_false(is.null(p)) + expect_type(p$row_id, "integer") + expect_type(p$key, "character") + expect_equal(length(p$row_id), length(p$key)) + expect_true(all(p$row_id %in% seq_len(60))) +}) + +test_that("folds built on another dataset of the same size are refused", { + skip_if_not_installed("ranger") + a <- .probe_pts(1) + b <- .probe_pts(2) # same n, same columns, other points + expect_equal(nrow(a), nrow(b)) + + folds_a <- make_folds(a, k = 3, method = "random_kfold", seed = 1) + # Same data: runs. + expect_no_error(cv_rf(a, "z", "a", folds = folds_a, num_trees = 30, seed = 1)) + # Other data: refused, and the message says why rather than reporting + # plausible-looking metrics computed on the wrong splits. + expect_error( + cv_rf(b, "z", "a", folds = folds_a, num_trees = 30, seed = 1), + "built from different data" + ) +}) + +test_that("the probe survives dropping rows and reprojection", { + skip_if_not_installed("ranger") + a <- .probe_pts(3) + folds_a <- make_folds(a, k = 3, method = "random_kfold", seed = 1) + + # 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)) + + # 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. + geo <- sf::st_transform(a, 4326) + folds_geo <- make_folds(geo, k = 3, method = "random_kfold", seed = 1) + expect_no_error(cv_rf(geo, "z", "a", folds = folds_geo, num_trees = 30, seed = 1)) + expect_no_error(cv_rf(a, "z", "a", folds = folds_geo, num_trees = 30, seed = 1)) +}) + +test_that("a folds object with no probe is passed through unchecked", { + # Backwards compatibility: an object built by an earlier version. + skip_if_not_installed("ranger") + a <- .probe_pts(4) + f <- make_folds(a, k = 3, method = "random_kfold", seed = 1) + f$params$row_probe <- NULL + expect_no_error(cv_rf(a, "z", "a", folds = f, num_trees = 30, seed = 1)) +}) diff --git a/tests/testthat/test-model-rf.R b/tests/testthat/test-model-rf.R index e0567b8..41262e9 100644 --- a/tests/testthat/test-model-rf.R +++ b/tests/testthat/test-model-rf.R @@ -276,3 +276,121 @@ test_that("negative permutation importance produces an actionable message", { expect_error(.aoa_weight_vector(c(a = 1, b = -0.01), c("a", "b")), "pmax\\(importance, 0\\)") }) + + +# --- .rf_align_levels / unseen factor levels --------------------------------- + +.mk_rf_grouped <- function(n = 240, seed = 7, + train_levels = c("a", "b", "c")) { + set.seed(seed) + g <- sample(c("a", "b", "c"), n, replace = TRUE) + eff <- c(a = 0, b = 50, c = 100)[g] + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + g = factor(g, levels = train_levels), + z = unname(eff) + stats::rnorm(n, 0, 1)), + coords = c("x", "y"), crs = 32632 + ) + d +} + +test_that("predict.rf_fit refuses a factor level the forest never saw", { + # ranger matches factor predictors by level, so a level absent at training + # has no split to follow: depending on the version it either errors from + # deep inside ranger -- which predict.rf_fit()'s tryCatch would flatten into + # an all-NA vector plus a log line -- or, as in ranger 0.16, silently returns + # a plausible-looking number. Both are worse than an error naming the level. + skip_if_not_installed("ranger") + dat <- .mk_rf_grouped() + fit <- fit_rf_model(dat, "z", "g", num_trees = 100L, seed = 1) + + nd <- dat[1:5, ] + nd$g <- factor(c("a", "b", "c", "zz", "a")) + expect_error( + predict(fit, newdata = nd), + # `.` for the quote glyph: sQuote() emits curly quotes under a UTF-8 + # locale and straight ones otherwise, and neither is what is being tested. + "predictor 'g' in newdata has level\\(s\\) the forest was never grown with: .zz." + ) + # The message also names what WAS trained, so the caller can see the gap. + expect_error(predict(fit, newdata = nd), "Trained levels: .a., .b., .c.") + + # A character column is checked the same way -- the helper reads the training + # column's type, not newdata's. + nd_chr <- dat[1:5, ] + nd_chr$g <- c("a", "b", "c", "zz", "a") + expect_error(predict(fit, newdata = nd_chr), "was never grown with: .zz.") + + # NA is not an unseen level: it is missing, and must not trip the guard. + nd_na <- dat[1:5, ] + nd_na$g <- factor(c("a", NA, "c", "b", "a"), levels = c("a", "b", "c")) + expect_no_error(suppressWarnings(predict(fit, newdata = nd_na))) + + # And the ordinary case still predicts: the guard is not simply always on. + expect_true(all(is.finite(predict(fit, newdata = dat[1:5, ])))) +}) + +test_that(".rf_align_levels re-codes newdata against the TRAINING levels", { + # `factor(val)` -- newdata's own alphabetical level order -- is not the same + # factor as `factor(val, levels = )`. Their integer codes + # differ whenever newdata is missing a training level or the training levels + # are not in alphabetical order, and those codes are what a forest built + # through ranger's x/y interface is indexed by. + align <- spatialkit:::.rf_align_levels + + # Training levels deliberately NOT alphabetical, and newdata missing one. + train_X <- data.frame(g = factor(c("c", "a", "b", "a"), + levels = c("c", "a", "b")), + n = 1:4) + X <- data.frame(g = factor(c("b", "a")), n = c(9, 9)) + expect_identical(levels(X$g), c("a", "b")) # what newdata came with + + out <- align(X, train_X) + expect_identical(levels(out$g), c("c", "a", "b")) # training order, restored + expect_identical(as.integer(out$g), c(3L, 2L)) # ... and the codes with it + expect_identical(as.character(out$g), c("b", "a")) # labels never move + # Untouched columns pass through. + expect_identical(out$n, c(9, 9)) + + # Newdata's own coding would have been c(2L, 1L) -- a different forest path + # for every row. + expect_false(identical(as.integer(out$g), + as.integer(factor(as.character(X$g))))) + + # A character newdata column is coerced to the training levels too. + X_chr <- data.frame(g = c("b", "a"), n = c(9, 9), stringsAsFactors = FALSE) + out_chr <- align(X_chr, train_X) + expect_identical(levels(out_chr$g), c("c", "a", "b")) + expect_identical(as.integer(out_chr$g), c(3L, 2L)) + + # A character TRAINING column defines its levels as sorted unique values, + # and newdata is left as character for ranger to convert. + train_chr <- data.frame(g = c("c", "a", "b", "a"), stringsAsFactors = FALSE) + expect_identical(align(data.frame(g = c("b", "a"), + stringsAsFactors = FALSE), + train_chr)$g, + c("b", "a")) + # Numeric columns are not touched at all. + expect_identical(align(data.frame(v = c(1, 2)), data.frame(v = c(3, 4)))$v, + c(1, 2)) +}) + +test_that("predict.rf_fit is unaffected by newdata's own factor level order", { + # The user-visible consequence of the re-coding above: predicting on a slice + # that happens to contain only some of the training levels must give exactly + # what predicting on the full frame gave for those same rows. + skip_if_not_installed("ranger") + dat <- .mk_rf_grouped() + fit <- fit_rf_model(dat, "z", "g", num_trees = 200L, seed = 1) + + p_full <- predict(fit, newdata = dat) + sub <- which(dat$g %in% c("b", "c"))[1:40] + nd_sub <- dat[sub, ] + nd_sub$g <- droplevels(nd_sub$g) # levels become b, c + expect_identical(levels(nd_sub$g), c("b", "c")) + + expect_equal(predict(fit, newdata = nd_sub), p_full[sub], tolerance = 1e-12) + # The predictions really do separate the groups, so the equality above is + # not satisfiable by a constant. + expect_gt(diff(range(p_full)), 50) +}) diff --git a/tests/testthat/test-predict-surface.R b/tests/testthat/test-predict-surface.R index 911caf1..e156a2a 100644 --- a/tests/testthat/test-predict-surface.R +++ b/tests/testthat/test-predict-surface.R @@ -140,3 +140,49 @@ test_that("grid spacing is exactly cell_size and stays inside the bbox", { expect_gte(min(ux), as.numeric(bb[["xmin"]])) expect_lte(max(ux), as.numeric(bb[["xmax"]])) }) + + +test_that(".make_prediction_grid returns cell CENTRES, not corners", { + # A regular grid's points stand for cells, so the value at each one is the + # value of the cell it sits in the middle of. Anchoring at the bounding-box + # corner instead shifts the whole surface half a cell south-west: every + # prediction is then attributed to the wrong place, and the last half-cell + # strip on the far edge is dropped rather than covered. + grid_fn <- spatialkit:::.make_prediction_grid + bb <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 100, ymax = 100), + crs = sf::st_crs(32632)) + + g <- grid_fn(bb, sf::st_crs(32632), cell_size = 20) + xs <- sort(unique(g$..grid_x)); ys <- sort(unique(g$..grid_y)) + + # 100 / 20 = 5 cells per axis, centred at 10, 30, 50, 70, 90. + expect_equal(xs, seq(10, 90, by = 20)) + expect_equal(ys, seq(10, 90, by = 20)) + expect_equal(nrow(g), 25L) + expect_equal(attr(g, "cell_size"), 20) + + # Stated as the property rather than the numbers: the first centre is half a + # cell in from the lower bound, and the grid is symmetric about the box -- + # the gap left at the top equals the gap left at the bottom. + expect_equal(min(xs) - bb[["xmin"]], 20 / 2) + expect_equal(bb[["xmax"]] - max(xs), 20 / 2) + expect_equal(min(ys) - bb[["ymin"]], 20 / 2) + expect_equal(bb[["ymax"]] - max(ys), 20 / 2) + # No point sits ON the boundary, which is what a corner anchor would do. + expect_gt(min(xs), bb[["xmin"]]) + expect_gt(min(ys), bb[["ymin"]]) + + # A cell size that does not divide the extent evenly keeps the same rule: + # 100 / 30 -> 3 cells, centres 15, 45, 75, with the remainder left at the top. + g2 <- grid_fn(bb, sf::st_crs(32632), cell_size = 30) + xs2 <- sort(unique(g2$..grid_x)) + expect_equal(xs2, c(15, 45, 75)) + expect_equal(min(xs2) - bb[["xmin"]], 30 / 2) + + # A cell wider than the extent collapses to one point at the centre of the + # box, not at its corner. + g3 <- grid_fn(bb, sf::st_crs(32632), cell_size = 500) + expect_equal(nrow(g3), 1L) + expect_equal(g3$..grid_x, 50) + expect_equal(g3$..grid_y, 50) +}) diff --git a/tests/testthat/test-regressions.R b/tests/testthat/test-regressions.R index 4ac0222..80a8193 100644 --- a/tests/testthat/test-regressions.R +++ b/tests/testthat/test-regressions.R @@ -99,6 +99,105 @@ test_that(".remap_folds keeps the original fold labels when one is dropped", { }) +test_that(".remap_folds drops folds left with fewer than two training rows", { + # An empty (or one-row) TRAINING set is as fatal as an empty test set: there + # is nothing to fit on. Such folds used to reach .cv_fit_one_fold(), fail + # there one at a time, and surface only as a generic "all folds failed". + remap <- spatialkit:::.remap_folds + + # keep_idx admits only rows 1:6, so fold 2's training set shrinks to a single + # surviving row and fold 3's to none, while fold 1 keeps four. + folds <- list( + list(train = 3:10, test = 1:2), # -> train 3:6 (kept) + list(train = c(1L, 20L), test = 5L),# -> train 1 (dropped: < 2) + list(train = 30:40, test = 6L), # -> train none (dropped) + list(train = 1:5, test = 6L) # -> train 1:5 (kept) + ) + keep <- 1:6 + + lines <- capture_spatialkit_log(out <- remap(folds, keep)) + expect_true(log_has(lines, "fewer than 2 training rows")) + expect_true(log_has(lines, "2 fold\\(s\\)")) + + expect_length(out, 2L) + # The survivors keep their ORIGINAL labels, so the drop is not a renumbering. + expect_equal(vapply(out, function(z) z$fold_id, integer(1)), c(1L, 4L)) + expect_equal(out[[1]]$train, 3:6) + expect_equal(out[[2]]$train, 1:5) + # Every fold that came back really is fittable. + expect_true(all(vapply(out, function(z) length(z$train) >= 2L, logical(1)))) + + # A fold with exactly two training rows is on the right side of the line. + edge <- remap(list(list(train = c(1L, 2L, 90L), test = 3L)), keep) + expect_length(edge, 1L) + expect_equal(edge[[1]]$train, 1:2) +}) + + +# --------------------------------------------------------------------------- +# Pooled CV R-squared must use each observation's TRAINING-fold mean +# --------------------------------------------------------------------------- + +test_that("cv R-squared is scored against the training-fold mean, not the pooled one", { + # Out-of-sample R^2 measured against the test data's OWN mean is the classic + # flattering number: it credits the model for knowing where the held-out + # block sits, which at prediction time it does not. cv_spatial() therefore + # carries a per-observation y_train_mean through to .compute_reg_metrics(). + # + # Three explicit west-to-east strips over a steep x-gradient, so the two + # baselines are genuinely different: each strip's training mean is the mean + # of the OTHER two strips, which sits far from both the strip's own values + # and the pooled mean of everything held out. The only predictor is noise, + # so the fitted model predicts close to its training mean and the choice of + # baseline is the whole story. + set.seed(11) + n <- 90 + x <- runif(n, 0, 900); y <- runif(n, 0, 900) + pts <- sf::st_as_sf( + data.frame(x = x, y = y, w = rnorm(n), z = 0.1 * x + rnorm(n, 0, 2)), + coords = c("x", "y"), crs = 3857) + + strip <- cut(x, breaks = c(-Inf, 300, 600, Inf), labels = FALSE) + folds <- lapply(1:3, function(j) list(train = which(strip != j), + test = which(strip == j))) + expect_true(all(vapply(folds, function(f) length(f$test) >= 10L, logical(1)))) + + cv <- cv_spatial(pts, "z", "w", + fit_fn = function(tr) lm_spatial_fit(tr, "z", "w"), + folds = folds, seed = 1) + + p <- cv$predictions + expect_true("y_train_mean" %in% names(p)) + expect_equal(cv$n_folds_succeeded, 3L) + + # Every prediction carries the mean of ITS OWN fold's training rows. + for (j in seq_along(folds)) { + in_fold <- p$fold == j + expect_equal(sum(in_fold), length(folds[[j]]$test), info = paste("fold", j)) + expect_equal(unique(p$y_train_mean[in_fold]), + mean(pts$z[folds[[j]]$train]), tolerance = 1e-10, + info = paste("fold", j)) + } + # The three baselines really are three different numbers. + expect_equal(length(unique(p$y_train_mean)), 3L) + + ok <- is.finite(p$y) & is.finite(p$yhat) + rss <- sum((p$y[ok] - p$yhat[ok])^2) + r2_train <- 1 - rss / sum((p$y[ok] - p$y_train_mean[ok])^2) + r2_pooled <- 1 - rss / sum((p$y[ok] - mean(p$y[ok]))^2) + + # The two baselines are a full R^2 unit apart, so the assertion below picks + # one of them rather than tolerating either. + expect_gt(abs(r2_train - r2_pooled), 0.5) + expect_equal(cv$overall$R2, r2_train, tolerance = 1e-10) + expect_false(isTRUE(all.equal(cv$overall$R2, r2_pooled, tolerance = 1e-3))) + + # RMSE has no baseline, so it must be unaffected either way -- a check that + # the fixture is not simply broken. + expect_equal(cv$overall$RMSE, sqrt(rss / sum(ok)), tolerance = 1e-10) +}) + + test_that("cv_spatial reports fold labels that match make_folds()", { # The user-visible form of the same fix. pts <- .rg_points(40) diff --git a/tests/testthat/test-sac-range.R b/tests/testthat/test-sac-range.R index bfecfdb..79e8a5b 100644 --- a/tests/testthat/test-sac-range.R +++ b/tests/testthat/test-sac-range.R @@ -92,8 +92,18 @@ test_that("a supportable range is returned and carries its fit", { expect_true(is.finite(attr(r, "max_dist"))) expect_true(is.finite(attr(r, "cutoff_dist"))) expect_lte(as.numeric(r), attr(r, "cutoff_dist")) # the default guard - expect_false(is.null(attr(r, "directional"))) - expect_length(attr(r, "directional"), 2L) + # FOUR directions, named by azimuth. A 0/90 sweep at +/-22.5 degrees covers + # only 90 of the 180 distinct azimuths, so a field oriented near 45 or 135 + # degrees fell into neither window and had its range halved (measured: 151 + # and 147 against a true 300, versus 255 and 249 at 0 and 90). c(0, 45, 90, + # 135) tiles all of them. An entry is NA when that direction's variogram + # never reached a sill and was excluded from the maximum. + d <- attr(r, "directional") + expect_false(is.null(d)) + expect_length(d, 4L) + expect_identical(names(d), c("0", "45", "90", "135")) + expect_gte(sum(is.finite(d)), 2L) # the minimum to use them + expect_equal(as.numeric(r), max(d, na.rm = TRUE), tolerance = 1e-10) # The field was simulated with a known exponential range, so the estimate # should land near it. A wide band -- variogram estimation on 250 irregular @@ -156,3 +166,120 @@ test_that("make_folds(auto_range) falls back when the range is unidentified", { expect_gt(f$params$grid_nx * f$params$grid_ny, 1L) expect_gte(length(f$folds), 2L) }) + + +# --------------------------------------------------------------------------- +# Input validation and reproducibility +# --------------------------------------------------------------------------- + +test_that("a factor response is refused rather than silently coded", { + # as.numeric() on a factor returns LEVEL CODES -- an arbitrary integer + # relabelling of the categories -- so a variogram fitted to them changed when + # the levels were reordered (3700 against 2497 on the same data). + skip_if_not_installed("gstat") + pts <- sac_test_field() + pts$grp <- factor(sample(c("a", "b", "c"), nrow(pts), replace = TRUE)) + expect_error(estimate_sac_range(pts, "grp"), "factor") + pts$txt <- as.character(pts$grp) + expect_error(estimate_sac_range(pts, "txt"), "numeric") + # A missing column is named, not discovered downstream as "too few values". + expect_error(estimate_sac_range(pts, "nope"), "not found") + # Logical is fine: 0/1 is a well-defined variogram target. + pts$flag <- pts$z > stats::median(pts$z) + expect_false(is.null(estimate_sac_range(pts, "flag"))) +}) + +test_that("the n_max subsample is reproducible and leaves the RNG alone", { + # `seed` defaults to a constant. Unseeded, the subsample made the returned + # range differ between runs on identical input (19531 / 19589 / 19605) and + # silently advanced the caller's stream -- and make_folds(auto_range = TRUE) + # sizes its blocks from that number. + skip_if_not_installed("gstat") + set.seed(99) + n <- 400 + 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) + + a <- suppressWarnings(estimate_sac_range(pts, "z", n_max = 150L)) + b <- suppressWarnings(estimate_sac_range(pts, "z", n_max = 150L)) + expect_equal(as.numeric(a), as.numeric(b)) + + # The caller's stream is untouched across the call. + set.seed(1); before <- runif(3) + set.seed(1); invisible(suppressWarnings(estimate_sac_range(pts, "z", n_max = 150L))) + after <- runif(3) + expect_equal(before, after) + + # And a different seed is still available for a sensitivity check. + d <- suppressWarnings(estimate_sac_range(pts, "z", n_max = 150L, seed = 999L)) + expect_true(is.na(d) || is.numeric(as.numeric(d))) +}) + +test_that("all four azimuths are represented in the directional attribute", { + skip_if_not_installed("gstat") + r <- estimate_sac_range(sac_test_field(), "z", seed = 1) + d <- attr(r, "directional") + expect_identical(names(d), c("0", "45", "90", "135")) + # 0 and 90 alone at +/-22.5 degrees cover only half the azimuth circle. + covered <- function(az, tol) { + vapply(0:179, function(th) any(abs(((th - az + 90) %% 180) - 90) <= tol), + logical(1)) + } + expect_equal(sum(covered(c(0, 90), 22.5)), 90L) + expect_equal(sum(covered(c(0, 45, 90, 135), 22.5)), 180L) +}) + + +test_that("a non-converged variogram fit is refused but stays inspectable", { + # Two properties that pull against each other, and both matter. + # + # (1) The RANGE must be refused. gstat signals non-convergence with a warning + # and then returns anyway, so the number it reports is wherever the + # optimiser stopped rather than a fitted parameter, and + # make_folds(auto_range = TRUE) would size blocks from it. + # (2) The VARIOGRAM must survive. A curve that never reaches a sill is + # exactly the case worth looking at, so plot(type = "variogram") has to + # keep working -- discarding the fit made it error with "the residual + # variogram could not be fitted". + # + # And no bare gstat warning should reach the user: with the sweep at four + # azimuths each variogram gets about half the pairs, so a direction failing + # to converge is routine and the caller already handles it. + skip_if_not_installed("gstat") + set.seed(21) + n <- 200 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + # A pure linear trend: the variogram rises monotonically and never sills. + pts <- sf::st_as_sf( + data.frame(x = x, y = y, z = 0.02 * x + 0.01 * y + rnorm(n, 0, 0.5)), + coords = c("x", "y"), crs = 3857) + + expect_no_warning(r <- estimate_sac_range(pts, "z", seed = 1)) + + expect_true(is.na(r)) # (1) refused + expect_s3_class(r, "sac_range") + expect_false(is.null(attr(r, "variogram"))) # (2) still inspectable + expect_false(is.null(attr(r, "variogram_model"))) + expect_true(is.finite(attr(r, "rejected_range"))) + expect_match(attr(r, "rejected_reason"), + "did not converge|exceeds the largest lag") + # It prints as a bare NA rather than dumping its attributes. + expect_output(print(r), "NA") +}) + +test_that("estimate_sac_range never emits a raw gstat warning", { + # The four-azimuth sweep makes a failed directional fit ordinary. Whatever + # the data, the failure is handled internally -- the direction is excluded, + # or the whole range is refused -- and never surfaces as gstat's own warning. + skip_if_not_installed("gstat") + for (s in 1:6) { + set.seed(100 + s) + n <- 120 + 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) + expect_no_warning(estimate_sac_range(pts, "z", seed = 1), + message = paste("seed", s)) + } +}) diff --git a/tests/testthat/test-seeding.R b/tests/testthat/test-seeding.R index d717dcf..0099c44 100644 --- a/tests/testthat/test-seeding.R +++ b/tests/testthat/test-seeding.R @@ -186,8 +186,53 @@ test_that("voronoi_seeds_kmeans reproduces its centres and validates input", { "`points_sf` geometry must be one of: POINT") expect_error(voronoi_seeds_kmeans(sf::st_drop_geometry(pts), k = 3), "Expected an sf object") - # Nothing to cluster. - expect_error(voronoi_seeds_kmeans(pts[0, , drop = FALSE], k = 3)) + # A zero-row layer never reaches the clustering code: .assert_sf() rejects it + # first, because an empty geometry set has no type to check. Without the + # regexp this expectation passed on that message and looked like coverage of + # the "nothing to cluster" branch, which it is not -- see the next test. + expect_error(voronoi_seeds_kmeans(pts[0, , drop = FALSE], k = 3), + "`points_sf` geometry must be one of: POINT") +}) + +test_that("voronoi_seeds_kmeans drops unusable points and reports having none", { + # st_coordinates() yields one ALL-NA row per EMPTY POINT rather than zero + # rows, so a layer of empty points has nrow() > 0, passes .assert_sf() (its + # geometry type is POINT), and used to reach stats::kmeans() as a matrix of + # NAs -- which fails with "NA/NaN/Inf in foreign function call (arg 1)". + ll <- sf::st_crs(32632) + + # (a) An empty point INSIDE a populated layer is dropped, and the rest + # clusters exactly as if it had never been there. + set.seed(3) + n <- 20 + xy <- data.frame(x = runif(n, 0, 100), y = runif(n, 0, 100)) + good <- sf::st_as_sf(xy, coords = c("x", "y"), crs = ll) + mixed <- rbind( + good, + sf::st_sf(geometry = sf::st_sfc(sf::st_point(), crs = ll)) + ) + expect_equal(nrow(mixed), n + 1L) + expect_true(any(sf::st_is_empty(mixed))) + + lines <- capture_spatialkit_log(out <- voronoi_seeds_kmeans(mixed, k = 3, + set_seed = 11)) + expect_true(log_has(lines, "dropping 1 point\\(s\\) with empty or non-finite")) + expect_equal(nrow(out), 3L) + expect_true(all(is.finite(sf::st_coordinates(out)))) + # Identical to clustering the clean layer: the empty row contributed nothing. + expect_equal(sf::st_coordinates(out), + sf::st_coordinates(voronoi_seeds_kmeans(good, k = 3, + set_seed = 11))) + + # (b) A layer of NOTHING BUT empty points is the only way to reach the + # "nothing to cluster" branch -- a zero-row layer is stopped earlier. + allempty <- sf::st_sf( + id = 1:3, + geometry = sf::st_sfc(sf::st_point(), sf::st_point(), sf::st_point(), + crs = ll)) + expect_equal(nrow(allempty), 3L) + expect_error(voronoi_seeds_kmeans(allempty, k = 2), + "has no usable coordinates; nothing to cluster") }) @@ -303,3 +348,91 @@ test_that(".robust_st_sample returns exactly the requested number of points", { sf::st_sfc(sf::st_point(c(0, 0)), crs = 32632), 1)) expect_length(spatialkit:::.robust_st_sample(awkward, 25L), 25L) }) + + +# --------------------------------------------------------------------------- +# Every method returns seeds in the BOUNDARY's CRS +# --------------------------------------------------------------------------- + +test_that("get_voronoi_seeds returns seeds in the boundary CRS for every method", { + # NEWS states this for all three methods, and it is what makes the seeds + # droppable straight into build_tessellation() alongside the boundary. Two + # of the branches happen to produce boundary-CRS seeds already (they sample + # or align against the boundary), so only "provided" -- where the caller + # hands over seeds carrying whatever CRS they were stored in -- shows the + # difference. All three are asserted because all three are promised. + bnd <- .seed_sq() # EPSG:32632 + expect_equal(sf::st_crs(bnd), sf::st_crs(32632)) + + pts32 <- .seed_points(12, seed = 4) # same CRS ... + pts_ll <- sf::st_transform(pts32, 4326) # ... and a lon/lat copy + expect_equal(sf::st_crs(pts_ll)$epsg, 4326L) + + cases <- list( + provided = get_voronoi_seeds(bnd, method = "provided", seeds = pts_ll), + random = get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 1), + kmeans = get_voronoi_seeds(bnd, method = "kmeans", n = 4, + sample_points = pts_ll, set_seed = 1), + kmeans_internal = get_voronoi_seeds(bnd, method = "kmeans", n = 4, + set_seed = 1) + ) + for (nm in names(cases)) + expect_equal(sf::st_crs(cases[[nm]]), sf::st_crs(bnd), info = nm) + + # Aligning means REPROJECTING, not restamping: the provided seeds come back + # at the metric coordinates the degrees denote, not at the degrees relabelled. + got <- sf::st_coordinates(cases$provided) + expect_equal(unname(got), unname(sf::st_coordinates(pts32)), tolerance = 1e-6) + # ... and they are NOT the degrees they arrived as, merely relabelled. + expect_false(isTRUE(all.equal(unname(got), + unname(sf::st_coordinates(pts_ll)), + tolerance = 1e-3))) + + # And with no boundary at all there is nothing to align to, so the seeds keep + # their own CRS rather than silently losing it. + expect_equal(sf::st_crs(get_voronoi_seeds(method = "provided", + seeds = pts_ll)), + sf::st_crs(4326)) +}) + + +# --------------------------------------------------------------------------- +# k-means seed counts are clamped, not fatal +# --------------------------------------------------------------------------- + +test_that("k-means seeding clamps n to what k-means can actually produce", { + # stats::kmeans() refuses BOTH k > distinct rows and k >= nrow(x), the latter + # with "number of cluster centres must lie between 1 and nrow(x)". So + # n = nrow(sample_points) -- the obvious "one seed per point" request -- used + # to die on a raw kmeans error rather than clamp, despite `@return` + # promising "at most n". + bnd <- .seed_sq() + cloud <- .seed_points(12, seed = 4) + N <- nrow(cloud) + expect_equal(N, 12L) + + # Below the ceiling: exactly what was asked for, and no clamp message. + quiet <- capture_spatialkit_log( + under <- get_voronoi_seeds(bnd, method = "kmeans", n = N - 1L, + sample_points = cloud, set_seed = 1)) + expect_equal(nrow(under), N - 1L) + expect_false(log_has(quiet, "clamping")) + expect_equal(nrow(voronoi_seeds_kmeans(cloud, k = N - 1L, set_seed = 1)), + N - 1L) + + # AT the ceiling and ABOVE it: clamped to nrow - 1, with a message naming the + # count actually used. No error either way. + for (k in c(N, N + 3L)) { + lines <- capture_spatialkit_log( + at <- get_voronoi_seeds(bnd, method = "kmeans", n = k, + sample_points = cloud, set_seed = 1)) + expect_equal(nrow(at), N - 1L, info = paste("get_voronoi_seeds n =", k)) + expect_equal(at$seed_id, seq_len(N - 1L)) + expect_true(log_has(lines, "clamping"), info = paste("n =", k)) + + lines2 <- capture_spatialkit_log( + at2 <- voronoi_seeds_kmeans(cloud, k = k, set_seed = 1)) + expect_equal(nrow(at2), N - 1L, info = paste("voronoi_seeds_kmeans k =", k)) + expect_true(log_has(lines2, "clamping to 11"), info = paste("k =", k)) + } +}) diff --git a/tests/testthat/test-summarize-by-cell.R b/tests/testthat/test-summarize-by-cell.R index 58289b7..ba47bea 100644 --- a/tests/testthat/test-summarize-by-cell.R +++ b/tests/testthat/test-summarize-by-cell.R @@ -35,12 +35,24 @@ test_that("summarize_by_cell default deff=1 gives classic SE", { }) -test_that("summarize_by_cell deff=2 inflates SE by sqrt(2)", { +test_that("summarize_by_cell deff=2 inflates SE by more than sqrt(2)", { + # sqrt(deff) is only HALF the correction. deff inflates Var(xbar) to + # sigma^2 * deff / n, but under the same clustering the ordinary sample + # variance is biased low by exactly the amount that inflation assumes: + # E[s^2] = sigma^2 (n - deff) / (n - 1). + # Applying sqrt(deff) alone therefore leaves the second error in place and + # the two compound. Measured 95% CI coverage of the sqrt(deff)-only form at + # n = 20: 0.905 at rho = 0.3, 0.796 at rho = 0.6, 0.632 at rho = 0.8; with + # the sqrt((n-1)/(n-deff)) rescale, 0.952 / 0.952 / 0.953 against a nominal + # 0.95. 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) ratio <- out_2[["..se_resp_y"]] / out_1[["..se_resp_y"]] - expect_equal(ratio, rep(sqrt(2), nrow(out_1)), tolerance = 1e-12) + expect_equal(ratio, sqrt(2) * sqrt((out_1$n - 1) / (out_1$n - 2)), + tolerance = 1e-12) + # Strictly above the sqrt(deff)-only factor, which is the regression guard. + expect_true(all(ratio > sqrt(2))) # cell_weight halved expect_equal(out_2$cell_weight, out_2$n / 2) # attribute recorded @@ -66,6 +78,129 @@ test_that("summarize_by_cell deff='kish' inflates SE under correlation", { }) +test_that("summarize_by_cell deff='kish' applies Kish's exact 1 + (n-1) rho", { + # "Kish SE >= IID SE" holds for ANY design effect that grows with rho, so it + # does not pin the formula: 1 + n*rho, 1 + (n+1)*rho and (1 + rho)^n all pass + # it. Kish's deff is specifically + # + # deff_i = 1 + (n_i - 1) * rho, se_i = sd_i / sqrt(n_i / deff_i), + # + # floored at 1. Cells of DIFFERENT sizes, so an off-by-one in the (n - 1) + # cannot be absorbed into a rescaled rho: the ratio between the true and a + # mis-specified deff varies from cell to cell. + set.seed(4242) + n_per <- c(2L, 3L, 5L, 9L, 14L, 20L) + ids <- rep(seq_along(n_per), times = n_per) + n <- length(ids) + y <- rep(rnorm(length(n_per), 0, 3), times = n_per) + rnorm(n) + pts <- sf::st_sf( + poly_id = ids, + y = y, + geometry = sf::st_sfc(lapply(seq_len(n), + function(i) sf::st_point(c(i, ids[i]))), + crs = 32632) + ) + + out <- summarize_by_cell(pts, response_var = "y", deff = "kish") + rho <- attr(out, "deff_applied")$icc_resp + expect_gt(rho, 0) # otherwise deff is floored at 1 and pins nothing + expect_equal(out$n, n_per) + + deff <- pmax(1, 1 + (out$n - 1) * rho) + # TWO corrections: sqrt(deff/n) for the mean's inflated variance, and + # sqrt((n-1)/(n-deff)) because s^2 itself is biased low by the same + # clustering (E[s^2] = sigma^2 (n - deff)/(n - 1)). See .se_with_deff(). + se_ok <- out[["..sd_resp_y"]] * sqrt(deff / out$n) * + sqrt((out$n - 1) / (out$n - deff)) + expect_equal(out[["..se_resp_y"]], se_ok, tolerance = 1e-12) + + # cell_weight is the effective sample size n / deff, from the same formula. + expect_equal(out$cell_weight, out$n / deff, tolerance = 1e-12) + + # And the (n - 1) inside deff is load-bearing: the nearest plausible + # alternative gives visibly different standard errors on this design, so the + # assertion above is not satisfiable by an off-by-one. + d_off <- pmax(1, 1 + out$n * rho) + se_off_by_one <- out[["..sd_resp_y"]] * sqrt(d_off / out$n) * + sqrt((out$n - 1) / pmax(out$n - d_off, .Machine$double.eps)) + expect_false(isTRUE(all.equal(se_ok, se_off_by_one, tolerance = 1e-6))) + + # Regression guard: the sqrt(deff)-only form is strictly smaller wherever + # deff > 1, which is every cell with more than one observation here. + se_old <- out[["..sd_resp_y"]] / sqrt(out$n / deff) + bigger <- deff > 1 + expect_true(any(bigger)) + expect_true(all(se_ok[bigger] > se_old[bigger])) +}) + +test_that("the Kish standard error covers at the nominal rate", { + # The property the formula exists for. The design-effect SE targets + # Var(cell mean) UNCONDITIONALLY -- the cluster effect is part of the + # sampling variability -- so the estimand is the grand mean, not the realised + # cluster mean. Without the s^2 correction this ran at 0.80 for rho = 0.6. + skip_on_cran() + n_cells <- 20L; n_per <- 20L; rho <- 0.6 + hit <- logical(0) + for (r in 1:150) { + set.seed(9000 + r) + cid <- rep(seq_len(n_cells), each = n_per) + u <- rnorm(n_cells) + v <- sqrt(rho) * u[cid] + sqrt(1 - rho) * rnorm(n_cells * n_per) + pts <- sf::st_sf( + poly_id = cid, y = v, + geometry = sf::st_sfc(lapply(seq_along(cid), + function(i) sf::st_point(c(i, cid[i]))), + crs = 32632)) + out <- summarize_by_cell(pts, response_var = "y", deff = "kish") + hit <- c(hit, abs(out$resp_mean_y) <= + stats::qt(0.975, n_per - 1) * out[["..se_resp_y"]]) + } + expect_gt(mean(hit, na.rm = TRUE), 0.90) + expect_lt(mean(hit, na.rm = TRUE), 0.99) +}) + +test_that("summarize_by_cell reports NA spread for a one-observation cell", { + # A cell holding a single point has no within-cell variation, so its sd and + # se are undefined rather than zero -- the contract the README leans on when + # it explains why one-seed-per-point Voronoi cells are an interpolation and + # not an aggregation. Zero would read as "measured with perfect precision" + # and would sail straight into any weighting that reads these columns. + set.seed(808) + n_per <- c(1L, 1L, 4L, 6L) + ids <- rep(seq_along(n_per), times = n_per) + n <- length(ids) + pts <- sf::st_sf( + poly_id = ids, + y = rnorm(n), + e = rnorm(n), + geometry = sf::st_sfc(lapply(seq_len(n), + function(i) sf::st_point(c(i, ids[i]))), + crs = 32632) + ) + + for (dv in list(1, "kish")) { + out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", + deff = dv) + lone <- out$n == 1L + multi <- !lone + expect_equal(sum(lone), 2L) + expect_gt(sum(multi), 0L) + + for (col in c("..sd_resp_y", "..se_resp_y", "..sd_pred_e", "..se_pred_e")) { + expect_true(all(is.na(out[[col]][lone])), + info = paste(col, "deff =", dv)) + # Not NA everywhere -- the columns do carry numbers where there is + # something to measure, so the assertion above is about the lone cells. + expect_true(all(is.finite(out[[col]][multi])), + info = paste(col, "deff =", dv)) + expect_type(out[[col]], "double") + } + # The mean is still reported: it is the SPREAD that is undefined, not the + # summary itself. + expect_true(all(is.finite(out$resp_mean_y))) + } +}) + test_that("summarize_by_cell deff='kish' estimates separate ICC for response and predictors", { set.seed(99) n_cells <- 10; n_per <- 20 @@ -281,11 +416,17 @@ test_that("summarize_by_cell(deff = 'variogram') applies sum(R)/n per cell", { expect_equal(unname(da$deff), unname(.hand_deff(pts, sac)), tolerance = 1e-8) expect_true(all(da$deff > 1)) - # SE scales as sqrt(deff): the ..se_ closures run with deff = 1 and the - # result is rescaled afterwards, so this equality is the whole mechanism. - iid <- summarize_by_cell(pts, response_var = "z", deff = 1) - expect_equal(out[["..se_resp_z"]], iid[["..se_resp_z"]] * sqrt(da$deff), + # The ..se_ closures run with deff = 1 and the result is rescaled afterwards, + # so this equality is the whole mechanism. The factor is the same one + # .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) + 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) + # Regression guard: strictly above the sqrt(deff)-only rescale. + expect_true(all(infl > sqrt(da$deff))) # ... and the effective sample size is n / deff. expect_equal(out$cell_weight, out$n / da$deff, tolerance = 1e-10) expect_true(all(out$cell_weight < out$n)) @@ -308,11 +449,18 @@ test_that("summarize_by_cell passes deff_max_n through to the subsampler", { da_cap <- attr(capped, "deff_applied") expect_equal(da_cap$max_n, 10L) - # A design effect cannot exceed the number of points it was computed on, so - # capping the correlation matrix at 10 caps every cell's deff at 10. - expect_true(all(da_cap$deff <= 10)) - expect_true(all(attr(full, "deff_applied")$deff > 10)) - # A cap larger than every cell changes nothing. + # `deff_max_n` caps the SUBSAMPLE the correlation matrix is built on, not the + # answer. The design effect reported is still the CELL's -- estimated as + # 1 + (n_i - 1) * Rbar with Rbar taken from the subsample -- so it is bounded + # by the cell size, not by max_n, and stays close to the un-subsampled value. + # The old code returned sum(R)/n_used, i.e. the design effect of a cell of + # max_n points, understating a large cell by roughly n_i/max_n. + n_cell <- capped$n + expect_true(all(da_cap$deff <= n_cell)) + expect_true(any(da_cap$deff > 10)) # the old form could not exceed 10 + expect_equal(unname(da_cap$deff), unname(attr(full, "deff_applied")$deff), + tolerance = 0.35) + # 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) expect_equal(attr(wide, "deff_applied")$deff, diff --git a/vignettes/spatialkit_nc_demo.Rmd b/vignettes/spatialkit_nc_demo.Rmd index 4069b2f..066952f 100644 --- a/vignettes/spatialkit_nc_demo.Rmd +++ b/vignettes/spatialkit_nc_demo.Rmd @@ -431,6 +431,18 @@ summary(rf_fit) rf_fit$info$importance # coef() on an rf_fit errors: a forest has no coefficients ``` +The two printouts disagree in the third decimal of R² — `0.4733` above, +`0.4715` here — while reporting an identical RMSE. Neither is wrong, and +neither is a bug. Both read the *same* out-of-bag predictions; they differ only +in the denominator of the variance they compare against. `print.rf_fit()` +echoes `ranger`'s own `r.squared`, which is `1 - MSE_oob / var(y)` using the +unbiased (n − 1) sample variance. `summary()` recomputes +`1 - SS_res / SS_tot` from the predictions, where `SS_tot = sum((y - mean(y))^2)` +— an n denominator. The unexplained fraction therefore differs by exactly the +factor n / (n − 1), here 300/299, and RMSE, which involves no such comparison, +matches to four decimals. If you need a figure comparable across backends, use +`cv_rf()` rather than either. + ### Residual diagnostics `plot()` on any `spatial_fit` maps the residuals; visible structure means