diff --git a/.Rbuildignore b/.Rbuildignore index 098bf67..d8b9d9d 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -19,3 +19,8 @@ (^|/)Rplots\.pdf$ \.DS_Store$ ^Claude outputs$ +# Local files a build from a working tree would otherwise ship: the internal +# review notes (kept out of git by .gitignore) and the .claude/ directory of +# assistant settings and worktrees. +^CODE_REVIEW\.md$ +^\.claude$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 14655f2..b5b031d 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -43,26 +43,32 @@ jobs: http-user-agent: ${{ matrix.config.http-user-agent }} use-public-rspm: true - # Hard dependencies only. Installing Suggests here pulled the entire - # Stan toolchain into every matrix job -- slow everywhere, and fatal on - # r-devel, where nothing arrives as a binary. There CRAN's rstan 2.32.7 - # was compiled against StanHeaders 2.39.0.9000 from the stan-dev - # universe and died with "'ecuyer1988' is not a member of 'boost'": - # Stan dropped that typedef after 2.32. The optional backends are the - # job of the `backends` job below and of check-brms.yaml. + # Hard dependencies and a short list of Suggests. Installing all of + # Suggests here pulled the entire Stan toolchain into every matrix job -- + # slow everywhere, and fatal on r-devel, where nothing arrives as a + # binary. There CRAN's rstan 2.32.7 was compiled against StanHeaders + # 2.39.0.9000 from the stan-dev universe and died with "'ecuyer1988' is + # not a member of 'boost'": Stan dropped that typedef after 2.32. The + # optional backends are the job of the `backends` job below and of + # check-brms.yaml. # # Three Suggests are not optional in practice. knitr and rmarkdown build - # the vignette during R CMD build, and tests/testthat.R opens with + # the vignettes during R CMD build, and tests/testthat.R opens with # library(testthat), so without it the test stage errors rather than # skipping. _R_CHECK_FORCE_SUGGESTS_ = false does not cover this -- it # only downgrades the complaint about absent Suggests, it does not stop # check from running the test file. # - # ggplot2 is installed by choice rather than necessity. The vignette - # gates every chunk on requireNamespace("ggplot2") in its setup chunk, so - # R CMD build succeeds without it -- but then the vignette renders as code - # with no output and none of the plotting code runs anywhere in this - # matrix. It is a cheap pure-R install; keep it. + # ggplot2 and gstat are installed by choice rather than necessity. Every + # vignette gates its chunks on requireNamespace() in its setup chunk, so + # R CMD build succeeds without them -- but then the North Carolina demo + # (gated on ggplot2) and the resolution, diagnostics and spatial + # cross-validation vignettes (gated on gstat and ggplot2) render as code + # with no output, and the tests behind skip_if_not_installed("gstat") + # skip. Without these two, that code would run only on ubuntu, in the + # `backends` job below. gstat brings sp, FNN, zoo, xts, intervals, + # spacetime, sftime and stars with it; none declares a system + # requirement, but on r-devel they build from source, which is slower. - uses: r-lib/actions/setup-r-dependencies@v2 with: dependencies: '"hard"' @@ -71,6 +77,7 @@ jobs: any::knitr any::rmarkdown any::ggplot2 + any::gstat any::testthat needs: check @@ -145,7 +152,7 @@ jobs: - name: Confirm optional backends are installed run: | for (p in c("sp", "GWmodel", "gstat", "FNN", "Matrix", "geometry", - "ranger", "tibble")) { + "ranger", "tibble", "spdep")) { if (!requireNamespace(p, quietly = TRUE)) stop("Backend package not installed: ", p) } diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 681315b..eb32133 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -4,7 +4,8 @@ # Builds the pkgdown site and pushes it to the gh-pages branch, from which # GitHub Pages serves https://elkronos.github.io/gis_modeling_toolkit/. # Pull requests build the site (so a broken _pkgdown.yml or vignette fails -# the check) but do not deploy it. +# the check) but do not deploy it, and neither does a manual run from any +# branch but main. on: push: branches: [main, master] @@ -36,7 +37,7 @@ jobs: with: use-public-rspm: true - # Hard dependencies plus the optional packages the five vignettes gate + # Hard dependencies plus the optional packages the six vignettes gate # their chunks on: ggplot2, gstat, sp and GWmodel, geometry, ranger and # patchwork. Every gate is requireNamespace()-guarded, so a missing # package does not fail the build -- it silently renders that article @@ -80,8 +81,15 @@ jobs: run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) shell: Rscript {0} + # Publish from main, and from a published release as the r-lib template + # does. A pull request builds the site without publishing it, and so + # does a manual run started from any other branch: without the ref test + # a workflow_dispatch on an unmerged branch would replace the live site. + # The job-level `contents: write` above exists for this step. Pull + # requests from forks get a read-only token whatever it says, and the + # deploy action is pinned to a commit rather than a tag. - name: Deploy to GitHub pages 🚀 - if: github.event_name != 'pull_request' + if: github.event_name == 'release' || (github.event_name != 'pull_request' && github.ref == 'refs/heads/main') uses: JamesIves/github-pages-deploy-action@d92aa235d04922e8f08b40ce78cc5442fcfbfa2f # v4.8.0 with: clean: false diff --git a/DESCRIPTION b/DESCRIPTION index 98a11b5..a083158 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,15 +52,18 @@ Suggests: tibble, geometry, gstat, - ggplot2, + ggplot2 (>= 3.4.0), patchwork, FNN, Matrix, nlme, spdep, - testthat (>= 3.1.5), + testthat (>= 3.1.7), knitr, - rmarkdown + rmarkdown, + units, + vctrs, + withr Additional_repositories: https://stan-dev.r-universe.dev Config/testthat/edition: 3 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index f34b827..43ea321 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -64,10 +64,10 @@ export(fit_gwr_model) export(fit_rf_model) export(fold_separation) export(get_voronoi_seeds) -export(kriging_adequacy) export(gp_lengthscale_bounds) export(gwr_model_selection) export(harmonize_crs) +export(kriging_adequacy) export(make_folds) export(model_metrics) export(new_spatial_fit) diff --git a/NEWS.md b/NEWS.md index feb6578..d5d44b8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -19,7 +19,32 @@ `within_range` (the share inside the range), and its `print()` method closes with what that share means for the score. Nothing is estimated: the distances come from the geometry and the range is the one the folds - already carry or the one you pass. + already carry or the one you pass. A range that records its CRS (the + folds' own `params$sac_range` and `params$crs`, or an + `estimate_sac_range()` result) is compared with distances measured in that + CRS, so a copy of the layer in other units gives the same answer (a + US-foot copy used to report 19 percent of the hold-out inside a metre + range where the metre layer reported 89); `sac` and the distances are in + the units of the CRS the `crs` attribute names, metres for lon/lat input. + `fold` is the `fold_id` a `cv_*()` result's `$folds` carries, so a join on + it pairs each fold's error with its own distances (it was the list + position, which after a dropped fold paired one fold's error with + another's distances). A `units` object for `sac` is refused. As in + `cv_*()`, a `make_folds()` result whose recorded rows sit at other + locations in `data_sf` is refused. Folds built on `prep_model_data()`'s + 200 points and measured on the 195 that `assign_features_to_polygons()` + kept used to be matched by position, and reported 100 percent of the + hold-out inside the range against 23--48 percent on the right layer. The + location check is skipped when one layer is POINT and the other is not, + so folds built on polygons still measure their pointized copy. The + `print()` verdict now depends on the fold scheme: "widen the blocks" is + said only of blocked folds, buffered leave-one-out is told to widen the + buffer, and random, leave-location-out and hand-made splits are told to + use blocked or buffered folds. NNDM folds are no longer called + optimistic: they are built to reproduce the prediction-to-data distances, + so the share describes the prediction task. The range line gives the + CRS's unit ("in metres"), where it used to print the CRS code as if it + were a unit ("in EPSG:32617 units"). * `summary()` on a `resolution_profile()` puts every criterion's pick in one table: the level each prefers, the flat region around it, whether a ladder @@ -51,7 +76,11 @@ does not have, and `n_dropped` the rows `prep_model_data()` removed before any fold was fitted. The four together account for every row and every fold, so `n_folds_attempted - n_folds_succeeded` never has to be explained - from the log. + from the log. A parallel worker that was killed outright (for lack of + memory, say) is a `"worker_error"` too and enters the first-error text; it + used to show as `"skipped"` ("no result returned") and was left out of + that text. An `"ok"` row carries a `message` when the fold's + `fold_info_fn` failed. * `prep_model_data()` records what it removed. `attr(x, "dropped")` is a list with `n`, `n_geometry`, `which` (positions in the input), `row_id` @@ -63,7 +92,18 @@ count with nothing saying how many rows were lost or why. Every fit now carries the count as `$info$n_dropped`, and every `cv_*()` result as `n_dropped`. Silently losing a third of the rows is a classic cause of a - suspiciously good score. + suspiciously good score. The layer carries the class `"spatialkit_rows"` + after `"sf"` (`c("sf", "spatialkit_rows", "data.frame")`): `[` returns a + plain layer without the record, and `dplyr::bind_rows()`, + `vctrs::vec_rbind()` and `dplyr::union_all()` return a plain `sf` (with + the class ahead of `"sf"` they failed on two layers with the same record, + 'attr(obj, "sf_column") does not point to a geometry column'). + `dplyr::filter()`, `slice()`, `arrange()` and `distinct()` now drop the + record as `[` does (they kept it, so `filter()` down to 3 of 5 rows still + reported the parent's counts). Each record carries `n_rows`, the number + of rows it was made for. `sf::st_drop_geometry()` keeps the rows and the + record; binding such data frames keeps the first one's record, whose + `n_rows` then no longer matches, and the package's readers ignore it. * `make_folds(method = "block_kfold")` returns the block design it built the folds from. `assignment` gains a third column, `block_id`; `params` gains @@ -88,7 +128,11 @@ could not draw the blocks over their data, see that 40 of 64 blocks were empty, or tell whether a fold is one contiguous region or several. `plot_folds()` now draws those outlines under the points when the folds - carry them, and takes `blocks = FALSE` to suppress them. + carry them, and takes `blocks = FALSE` to suppress them. Its subtitle + states the parameter that decides whether the scheme leaks (the block + size, the buffer, the number of location groups or the median NNDM + exclusion), with the units of the folds' CRS; folds built from points + without a CRS get no units rather than "(NA units)". * `estimate_sac_range()`'s returns are uniform. The four directional variograms and their fits run unconditionally on every call, and the @@ -115,16 +159,26 @@ case with no `"deff_applied"` is exactly the one where a user wants to know what the ICC came out as --- and the `"variogram"` path adds `deff_rows`, the per-cell design effect at the cell's row count that the - log line reduced to a median and a max. `assign_features_to_polygons()` - reports the features that matched more than one polygon and had the - `tie_break` rule decide for them, as `attr(, "ties")` and a log line; a - tie-break firing on a third of the features means the polygon layer - overlaps and every cell count built from it is suspect. `ensure_projected()` - attaches `crs_choice`, the projections it considered with each one's - measured worst-case distance error. Every path that picks a local - projection reports what it picked, the two that compare nothing included: - a UTM zone on a local extent, and the equal-area projection chosen for a - layer straddling the antimeridian. + log line reduced to a median and a max. A `summarize_by_cell()` call that + requests a design effect (any `deff` other than 1) also returns a logical + `deff_applied` column, `TRUE` on every row when the correction was applied + and `FALSE` when it fell back to the uncorrected standard errors; unlike + the `"deff_applied"` attribute it survives `rbind()` and + `dplyr::bind_rows()` of many results. The default frame is unchanged. + `assign_features_to_polygons()` reports the features that matched more + than one polygon and had the `tie_break` rule decide for them, as + `attr(, "ties")` and a log line; a tie-break firing on a third of the + features means the polygon layer overlaps and every cell count built from + it is suspect. The layer carries the `"spatialkit_rows"` class after + `"sf"`, as `prep_model_data()`'s does, so binding such layers returns a + plain `sf`. The `"ties"` record is dropped by the same `dplyr` row verbs + as `prep_model_data()`'s, and with `largest = TRUE` it also counts + features that overlap two or more polygons by exactly the same area. + `ensure_projected()` attaches `crs_choice`, the projections + it considered with each one's measured worst-case distance error. Every + path that picks a local projection reports what it picked, the two that + compare nothing included: a UTM zone on a local extent, and the + equal-area projection chosen for a layer straddling the antimeridian. `residual_morans_i()` returns the residual `kurtosis` the randomisation variance conditions on, the design rank `p` behind the residual moments, `exact`, whether those moments are exact for these residuals, and @@ -167,8 +221,9 @@ `plot(estimate_sac_range(pts, "z"))` draws the empirical variogram, with the fitted model and the effective range overlaid where a range was identified, and a subtitle saying why not where it was not: the variogram - never reached a sill, both model fits were singular, or the optimiser - halted. Nothing is recomputed --- the plot reads the attributes the + never reached a sill, both model fits were singular, the optimiser + halted, or a `range_frac` below 1 refused a range inside the fitted lags. + Nothing is recomputed --- the plot reads the attributes the estimate already carries --- and the same drawing routine now serves `plot.spatial_fit(type = "variogram")`, so the two pictures agree. The "attached for inspection" messages `estimate_sac_range()` logs when it @@ -196,6 +251,8 @@ 0.958 coverage at exponential ranges of 150 and 400 on a 1000-unit domain, against 0.931 and 0.918 with `n - 1`. The help page's "Confidence intervals" section has the reasoning and the numbers. + `..neff_*`, like `..df_*` and the interval, is `NA` for a column with a + single non-missing value in the cell, where `cell_weight` still counts it. * `compare_models_cv()` gains `block_size` and `auto_range`, and now hands `response_var` and `predictor_vars` to `make_folds()` when it builds the @@ -205,7 +262,12 @@ that compares models, which until now was the one whose folds could never be checked against the range. `select_features_forward()` gains `auto_range` for its inner folds for the same reason, and records it in - `$params`. + `$params`. A shared fold set that cannot be built is an error. It used + to be a log line and a fall-back to each backend's default blocks, which + were given neither argument: `block_size = 1e6` (one block, which + `cv_rf()` refuses) returned a five-fold comparison on geometric blocks, + and `auto_range = TRUE` the small blocks it exists to prevent, with no R + condition. * `compare_models_cv()$overall` carries the Bayesian backend's calibration when a Bayesian model ran: `coverage_50`, `coverage_80`, `coverage_95` and `mean_CRPS`, the same fold-weighted summary `cv_bayes()` returns as @@ -220,7 +282,19 @@ tree)"). The defaults are ranger's, so no forest changes. The help page carries Strobl et al.'s (2007) case for `replace = FALSE`. Passing the ranger spellings through `...` is now refused like the other arguments the - wrapper sets. + wrapper sets. `replace = FALSE` with `sample_fraction = 1` grows every + tree on every row, so no row is out of bag. The fit now warns that + `fitted()`, the OOB error and the permutation importance are all `NaN` + (they were `NaN` in silence), and `print()` on such a fit says the OOB + error and the permutation importance are undefined, where it dropped the + OOB line and printed the importance line empty. + `area_of_applicability(weights = pmax(imp, 0))` failed on that importance + with a hint to use the very `pmax()` it had been given, because `pmax()` + keeps `NaN`; it now names the predictors whose weight is `NaN`, says why + (no row is out of bag), and says what to do instead: refit with out-of-bag + rows, or pass `weights = NULL`. With permutation importance, the fit's + own warning now says as much: `area_of_applicability()` cannot be + weighted by that importance, so pass `weights = NULL`. * `area_of_applicability()` records the method of the folds its threshold came from as `$params$folds_method` (`"block_kfold"`, `"random_kfold"`, ... from a `make_folds()` result; `"labels"` or `"splits"` when the input @@ -246,7 +320,24 @@ help page's new section carries the numbers. Iterating GLS trend fits against variogram refits (Neuman and Jacobson 1984) was measured too and recovers only part of the bias (0.80 in the quadratic case), so it was not - added. `nlme` joins Suggests. + added. `nlme` joins Suggests. A fitted range too short for enough pairs + of points to lie inside it is refused, with + `rejected_reason = "fitted range is below the shortest lag fitted"` and + the bound it fell short of as the `range_floor` attribute. For the + least-squares fits the bound is the shortest lag the empirical variogram + resolves (the mean separation in its first bin); it did not fire on white + noise or on fields with a 60 m range. The REML range is fitted to the + point pairs, not to those bins, so its bound is the distance within which + 30 pairs of the points the REML fit used lie, or that first lag when it is + shorter. On white noise (n = 300, 30 draws) the REML fit returned ranges + of 0.18--23.6 m in 19 draws (one of 0.27 m sized a 3642 x 3676 block grid, + refused as a unit mistake); the 16 of them up to 12.5 m are refused and + the estimate is finite in 13 of 30. REML estimates of a true 30 m range + that the first lag alone would have refused (14.5--28.8 m, in 10 of 20 + draws at n = 400 and 6 of 15 at n = 300) are returned, and at n = 400 the + same holds at `cutoff = 0.5` and `0.1`. The bound is about + identification, not a test for spatial structure. A refused REML result + keeps its `reml` list. * `sac_nugget()` returns the nugget variance behind an `estimate_sac_range()` result, and every classed result --- identified or rejected --- now carries it as a `nugget` attribute (`NA` when no model @@ -275,11 +366,16 @@ scored on every criterion at once. `resolution_profile()` runs a log-spaced ladder of level counts from a floor the autocorrelation range implies (`ceiling(area / range^2)`) to a ceiling the support implies - (`floor(n / min_cell_n)`), fits each level as the best of 25 k-means++ - restarts, and returns a data.frame with the WSS elbow statistic, Mallows' + (`floor(n / min_cell_n)`, where `n` is every point in the layer, not the + `sample_n` subsample the k-means runs on), fits each level as the best of + 25 k-means++ restarts, and returns a data.frame with the WSS elbow + statistic (read on log-log axes, and `NA` when the points have no cluster + structure to bend the curve), Mallows' C_p of the piecewise-constant approximation of the response (or of - its residuals on the predictors, with the nugget from the fitted - variogram as the noise variance), the standardised residual Moran's + its residuals on the predictors, fitted on the rows with a complete + response and predictors, with the nugget from the fitted variogram as the + noise variance and the penalty set for the whole layer), the + standardised residual Moran's z of the cell means, and an analytic reliability of the cell means --- the share of their spread that is between-cell signal rather than sampling noise, from the variogram alone via Krige's additivity relation @@ -300,7 +396,56 @@ flat to within 2 percent over a factor of 3--6 in the number of cells. Read the flat region. `determine_optimal_levels()` is unchanged in shape and keeps its - integer-vector interface. + integer-vector interface. A supplied `sac` whose range was refused (an + `NA` with a `rejected_reason`) is not read as accepted: `cp` keeps that + fit's nugget and warns, naming the reason, `reliability` is `NA` (it + needs the range), and a fit that did not converge, or whose range is below + the shortest lag fitted, gives neither (the whole refused fit used to be + used, and a correlation function whose range could be many times the + extent pinned the reliability optimum to the first level, with no R + warning). A range below the shortest lag means the structure cannot be + told from a nugget, so the nugget is not identified either: on white noise + detrended by REML it was 6e-7 on a sill of 0.99, and C_p, with no penalty, + ran to the support ceiling (33 cells). A nugget of 0 (under 1e-4 of the + sill, since a REML fit stops short of its bound: 6e-7 passed a test for + exactly 0), on which C_p has no penalty and falls to the ceiling, is + warned about, and so is a `sac` whose `detrended` flag does not match the + variable scored (a residual variogram on the raw response moved the C_p + pick from 2--4 cells to the ceiling of 44 in five of five simulated + fields); `attr(x, "variogram")` records `detrended`. When no `sac` is + passed, these warnings name the variogram the profile estimated (kept in + `attr(x, "sac")`), not a `sac` argument the caller never gave. A supplied + `sac` is read in its own CRS: the points are transformed to + `attr(sac, "crs")` first, as `summarize_by_cell()` does (a range in US + feet put the floor of a metre layer at 2 where the same range in metres + put it at 8). A `sac` given as a `units` object (`set_units(1.5, "km")`) + or a character string is refused by name; a `units` object used to be + read as a number in the CRS units, so 1.5 km became a range of 1.5 m and + a floor of 41 million cells. A plain number is taken as the range alone: + it sets the floor, and `cp` and `reliability` are + `NA`. Reliability's domain term is taken over the convex hull the + area is measured on, not the bounding box: on a 3000 x 120 strip the + reliability pick is 6 cells whether the strip lies axis-aligned or rotated + by 45 degrees (it was 8 and 2), and 10 either way on a square (it was 10 + and 8), and reliability values shift slightly on every profile. Row order + does not change the profile (see the `determine_optimal_levels()` item + under Bug fixes); over permutations of one 2000-point layer, WSS used to + move by up to 2.6 percent and the C_p pick across its flat region (222, + 173 and 135 cells). The ceiling reaches the number of distinct locations + when locations repeat (and explicit `levels` up to it are kept) instead of + stopping one short; with no location repeated, the print says the ceiling + is one short of the points rather than crediting the distinct locations. + Points with empty or non-finite coordinates are dropped with an R warning, + as in `determine_optimal_levels()`; it was a log line alone. + `range_floor = FALSE` starts the ladder at 2 whatever + the range and only reports the floor, so profiles whose range estimates + differ (cross-validation folds) have comparable ladders; with the floor + applying on one fold and not the next, reliability and the elbow moved by + a factor of 10--15 between folds. The default, `range_floor = TRUE`, + keeps the floor, and the help page describes that regime switch. Under + `select_on = "split"` a supplied `sac` is flagged in the log, since it + must be fitted on the selection half, and the help page shows the + two-call workflow. * `select_on = c("all", "split")` on `determine_optimal_levels()`, `resolution_profile()` and `select_features_forward()`. Whenever a @@ -310,10 +455,25 @@ post-selection, and its standard errors are descriptive rather than at nominal coverage (Gao, Bien and Witten 2022). `select_on = "split"` is sample splitting: the layer is cut into two spatially blocked halves - (`make_folds(k = 2, method = "block_kfold")`), the selection runs on the - first, and the row positions of both come back (as a `"split"` attribute - on the first two functions, as `$split` on the third) so the estimation - can be done on the half the selection never saw. + (`make_folds(k = 2, method = "block_kfold")`), the selection reads the + response on the first only, and the row positions of both come back (as a + `"split"` attribute on the first two functions, as `$split` on the third) + so the estimation can be done on the half the selection never saw. The + positions index the layer as passed, for all three functions + (`select_features_forward()`'s were positions after its completeness + filter, so with seven incomplete rows `pts[fs$split$estimation, ]` held 47 + rows of the selection half and 4 of the dropped ones). When the default + six-block split leaves fewer than 10 points in a half (a small layer, or a + small group far from the rest), it is retried on grids of about 16, 36 + and 100 blocks, with a warning, instead of stopping, and the split records + `grid`, `n_blocks`, `balance` (a 2:1 split on clustered layers used to + pass silently) and each half's `extent`. The halves are not independent: + blocking reduces the dependence across their shared border but does not + remove it (85 percent of the estimation points of the package's test + layer lie within the fitted range of a selection point), and the seed + decides only which side selects, not where the cut falls. The level-count + functions still draw their cells on every point, so the count they return + is a count for the whole layer it will be applied to. `select_features_forward()` also returns `score_holdout`: the selected set fitted on the selection half and scored on the other, the honest number its selection-internal `score` is not. The cost is precision --- half the @@ -341,9 +501,12 @@ millionth of the extent of a block --- an edge that reprojection moved by a rounding error; points inside more than one block take the first, with a warning when the blocks concerned overlap in area rather than share an - edge. `params` gains `n_blocks` (before empties were dropped), + edge. `params` gains `n_blocks` (before empties were dropped; for a grid, + `grid_nx * grid_ny`, the cells a `boundary` clips away included), `blocks_supplied` and `block_scale` on every `block_kfold` result; - `grid_nx`/`grid_ny` are `NA` for supplied blocks. + `grid_nx`/`grid_ny` are `NA` for supplied blocks. A `blocks` layer + without a CRS is brought into the points' CRS with an R warning naming + it, as `boundary` is. * `make_folds()` gains `balance_tol`, the largest-to-smallest fold size ratio above which `block_kfold` reports its folds as imbalanced. The @@ -379,11 +542,16 @@ one number per name --- anything else is an error, because a scoring function of the wrong shape is a mistake to surface) and forgiving where it should be (a function that throws on a fold is logged and its columns - are `NA` there; a fold is never dropped for it). The empty frames of a - run where every fold failed carry the columns, typed, when the function - can be called on zero-length input. `compare_models_cv()` hands one - function to every backend and protects it like the fold arguments, so the - columns of its `overall` are comparable across rows. `fold_info_fn` is + are `NA` there; a fold is never dropped for it). Nor may a name reuse a + per-fold extra (`CRPS`, `coverage_*`, `gp_k`, `gp_n_basis`, `n_draws`, + `bandwidth`, or a name the `fold_info_fn` returns) or `mean_CRPS`: each + used to replace the package's value silently, and + `cv_bayes()$predictive_coverage` then reported the user's number. The + empty frames of a run where every fold failed carry the columns, typed, + when the function can be called on zero-length input. + `compare_models_cv()` hands one function to every backend and protects it + like the fold arguments, so the columns of its `overall` are comparable + across rows. `fold_info_fn` is documented as the per-fold half of the same mechanism, with access to the fitted object and the held-out layer. @@ -402,18 +570,30 @@ percent, the conterminous United States forced into one zone 14 percent, Web Mercator over 2.5 degrees of latitude at 48N 4 percent, an equal-area projection a few tenths of a percent (the sphere the geodesic - areas are computed on against the ellipsoid). + areas are computed on against the ellipsoid). The measurement works + whether `sf_use_s2()` is on or off (with it off and no lwgeom it returned + `NA`, so `summarize_by_cell(area = TRUE)` refused every grid and + `purpose = "area"` skipped its warning), and its probe polygons are + densified before their geodesic area is taken, so an equal-area grid over + a near-global extent no longer measures 10 percent. With + `purpose = "area"`, a single polygon's candidates are scored rather than + falling back to the Lambert azimuthal unmeasured. * `summarize_by_cell()` gains `area = TRUE`: with `cells_sf`, the result - carries `cell_area` (planar, in the squared units of the cells' CRS) and - `n_per_area`, a point density; a rate of anything else is its `agg_funs` - sum over `cell_area`. The request is refused with an error --- not - answered with a number --- when the cells' CRS distorts areas across them - by more than 1 percent by the measurement above, because a density is a - comparison between cells and means nothing where the map scale differs - from one cell to the next; the message names the CRS, the figure and the - remedy. A cell with no observations gets `NA`, not zero. The measured - spread is attached as `attr(, "area_error")`. + carries `cell_area` (planar, in the squared units of the cells' CRS; for + lon/lat cells the geodesic area in square metres, not a planar area in + squared degrees) and `n_per_area`, a point density; a rate of anything + else is its `agg_funs` sum over `cell_area`. The request is refused with + an error --- not answered with a number --- when the cells' CRS distorts + areas across them by more than 1 percent by the measurement above, because + a density is a comparison between cells and means nothing where the map + scale differs from one cell to the next; the message names the CRS, the + figure and the remedy. A cell with no observations gets `NA`, not zero. + Lon/lat cells pass the distortion check by construction; with s2 switched + off their area needs lwgeom, and the request is refused without it. The + measured spread is attached as `attr(, "area_error")`. A `cells_sf` + with no ID column the summaries can be joined on is an error under + `area = TRUE`, since the area columns cannot be produced. * `build_tessellation(approx_n_cells = )` and `get_voronoi_seeds(n = )` accept what the level-selection step returned: the integer vector of @@ -425,7 +605,12 @@ `params$approx_n_cells` / `params$approx_n_cells_from` and as `attr(seeds, "n_from")`. The two functions the pipeline documents as a pair are now connected: `get_voronoi_seeds(n = determine_optimal_levels(pts))` - needs no number carried between the calls by hand. + needs no number carried between the calls by hand. A hex or square + lattice records `params$cells_occupied` and `params$cells_empty`, and a + count taken from a profile or a selection warns when fewer than three + quarters of it end up occupied: the count is of k-means cells, all of + them occupied, and on clustered points a lattice leaves about half its + cells empty. * Five diagnostic plots that show the curve behind a chosen point, the folds behind a pooled number, or the distribution behind a count. None @@ -439,35 +624,63 @@ column that is `NA` in every fold is refused with the reason (`Adj_R2` without `p`, coverage without draws) rather than drawn empty, and a per-fold extra with no pooled counterpart draws without the line and - says so. + says so. So does a count (`n_pred`, `n_MAPE`, `n_SMAPE`), whose + `overall` value is the total over the folds; it was drawn as the pooled + line, at 150 against folds of 30. A model with no finite per-fold value + gets no panel and no pooled line, and the caption names it, whether or + not `overall` has a value for it (RF's `bandwidth` was dropped without a + mention). A `compare_models_cv()` result keeps its model strip when + only one model is left to draw. - `plot.aoa()`: the dissimilarity index of the prediction locations - against the cross-validated training DI (ECDFs, or a histogram with the - training curve), threshold marked, with the share outside and how close - the inside ones run to the edge in the subtitle, and whether the - threshold came from cross-validated folds in the caption. + against the training DI --- cross-validated over the `folds` passed, or + else each point's distance to its nearest other training point; the + legend says which --- as ECDFs, or a histogram with the training curve, + threshold marked, with the share outside and how close the inside ones + run to the edge in the subtitle, and whether the threshold came from + cross-validated folds in the caption. Prediction locations outside on a + predictor dropped for having no training variance (`DI = Inf`) count in + the prediction curve, which then tops out below 1, and the caption says + how many are off the axis. It counts the `DI = NA` rows (a missing + predictor) as well. The curve used to leave the `Inf` rows out: it read + 0.97 inside at the threshold while the subtitle counted 11 of 40 + outside. A result with every row at `DI = Inf` was refused as "every + row had a missing or non-finite predictor", and the error now gives the + true reason. - `plot.spatial_fit(type = "variogram")` overlays the response's own variogram (hollow points, dashed fit) on the residual variogram, on the same points and lags, so the structure the model absorbed is the gap - between the two curves. The caption compares the sills only when both - ranges were identified; `response = FALSE` restores the residual curve - alone. + between the two curves. The response curve is whichever variogram + `estimate_sac_range()` returns for the response, which is its widest + single direction when the all-pairs fit is unusable (a response with a + trend, whose residuals are fine). A single-direction response curve is + labelled with its azimuth, and the caption compares the sills only when + both ranges were identified and the two curves cover the same point + pairs (such a curve used to be labelled plainly as the response, its + sill set against the all-pairs residual curve's: "Residual sill is 45% + of the response sill" from a quarter of the pairs). `response = FALSE` + restores the residual curve alone. - `plot_calibration(cv)`: observed against nominal coverage of `cv_bayes()`'s posterior predictive intervals, pooled (blue) and per - fold (grey), with the diagonal and a one-line verdict. The levels are - read off the `coverage_*` column names, so `coverage_levels = + fold (grey), with the diagonal and a one-line verdict. Each level is + drawn at the nominal value `cv_bayes()` records in `coverage_levels` + (0.995 was drawn at 1.00), so `coverage_levels = seq(0.1, 0.9, by = 0.1)` gives a full curve; the default three levels - are unchanged. + are unchanged. Its error for all-`NA` coverage names + `compute_pred_intervals = FALSE` as well as failed draws. - One sweep drawer behind three methods: `plot.resolution_profile()` (a panel per criterion, the level each selects marked, its flat region shaded, a note when a bound rather than the criterion is choosing); `plot.feature_selection()` (the accepted variable's score at each step - as the path, every other candidate faint, the stop in red, the - hold-out score as a separate mark when `select_on = "split"` computed - one --- and a caption saying whether the intercept-only model was - scored, since for the RF and GWR backends it usually is not, so the - path starts at the first variable); `plot.gwr_model_selection()` (every - model's AICc against its size, the best of each size joined, the winner - marked, its lead over the runner-up in the subtitle). + as the path, every other candidate faint, the stop in red, the best + candidate at the step after the stop, which was scored and not added, + hollow and labelled "not added" rather than drawn like the accepted + variables, the hold-out score as a separate mark when + `select_on = "split"` computed one --- and a caption saying whether the + intercept-only model was scored, since for the RF and GWR backends it + usually is not, so the path starts at the first variable); + `plot.gwr_model_selection()` (every model's AICc against its size, the + best of each size joined, the winner marked, its lead over the + runner-up in the subtitle). `select_features_forward()`'s result now carries class `"feature_selection"` so `plot()` finds the method; it is the same list otherwise. @@ -482,38 +695,89 @@ on simulated fields with a 100--130-unit range and a random forest with coordinates, the plateau begins at one to two times the estimated range. Each size is a full `cv_spatial()`, so a fit budget (`max_fits`, default - 60) refuses to start rather than run past it, and the ladder drops sizes - at which the grid holds fewer than `k` blocks so every point on the curve - is a `k`-fold cross-validation of the same shape. + 60) refuses to start rather than run past it. The default ladder runs up + to the largest size, at most half the shorter side, whose grid still holds + `k` cells. At the default `k = 5` half the side is a 2 x 2 grid of four + cells on any extent less than 1.5 times as long as it is wide, so that + rung used to be dropped every time. `n_sizes = 6` then ran five + cross-validations, the last at 0.30 of the side, and missed ranges up to a + third of it that a 3 x 3 grid reaches. The top is now about a third of + the side on such an extent. Sizes the caller passes in `block_sizes` + whose grid holds fewer than `k` cells are not run, and a warning names + them and the largest size that gives `k` blocks; they were dropped with + only a log line. A `units` object for `block_sizes` is refused by name. + On clustered data `make_folds()` can still lower `k` at the top sizes, + which the `k` column shows. The default ladder also skips sizes whose + grid would exceed the 1,000,000 blocks `make_folds()` builds (a 6 km x 2 m + transect used to abort with an error about `block_size`), runs along the + line for points on one axis-parallel line (they were refused as having "no + extent"), and warns when every rung is below the estimated range while + longer blocks would still fit `k` times along the longer side (a 10 km x + 100 m corridor: rungs of 4 to 50 m against a 1.7 km range, a flat curve + that read as no leakage). On a roughly square extent at `k = 5` that + warning also fired, as in the block-size tour script on a 996 m square, + with two wrong numbers. It called the top rung it had run (300) "half the + shorter side" (498). It said blocks only up to the longer side over `k` + (199, smaller than rungs already run) still gave `k` blocks, when blocks + up to 332 did. It now fires only where a longer block would still give + `k` blocks, and it names the top rung run and the largest size that gives + `k` blocks. User-supplied `block_sizes` over the grid cap + are refused before any fit, and a `sac` estimated in another CRS is + converted to the sweep's units with a warning (a metre range on a US-foot + axis was drawn 3.3 times too short). The plot's caption reads every + `coverage_*` column as "closer to the nominal level is better" (only + `coverage_50`, `coverage_80` and `coverage_95` were known, as + higher-is-better, so `coverage_97.5` from `cv_bayes()`'s full-precision + names was captioned "lower is better"). * `fit_gwr_model()` keeps its local collinearity survey. Every fitting - window --- not a sample of 30 --- has its kernel-weighted local design's - scaled condition index computed, the way Wheeler and Tiefelsdorf diagnose - GWR collinearity, and the fit carries it as `info$local_collinearity` - (one row per observation: coordinates, window size, condition index), - with `info$n_local_collinear`, `info$n_local_singular` and the global - `info$condition_index` beside `AICc`. The warning is now the exact - fraction of locations rather than a sampled one; its wording and its - thresholds (a quarter of the locations, or any) are unchanged. The - weighted survey sees what the unweighted spot-check could not: a bisquare - window's edge points contribute almost nothing to the fit, so they - contribute almost nothing to its conditioning. + window --- not a sample of 30 --- has scaled condition indices of its + kernel-weighted local design computed, the way Wheeler and Tiefelsdorf + diagnose GWR collinearity, and the fit carries them as + `info$local_collinearity` (one row per observation: coordinates, window + size, and two condition indices: `cn`, Belsley's uncentred index with the + intercept, and `cn_slopes`, the predictors centred in the window and + scaled by their study-area standard deviation), with + `info$n_local_collinear`, `info$n_local_singular` and the global + `info$condition_index` (on the centred predictors) beside `AICc`. + `n_local_collinear` and the warning count the windows whose slopes are + collinear (`cn_slopes` above 30, or `cn` above 1e6), so a predictor's + origin (degrees C or kelvin) does not change the verdict. The warning is + now the exact fraction of locations rather than a sampled one, and its + thresholds (a quarter of the locations, or any) are unchanged; above a + quarter it now says that an exactly singular window stops the fit, instead + of promising non-finite coefficients. The weighted survey sees what the + unweighted spot-check could not: a bisquare window's edge points + contribute almost nothing to the fit, so they contribute almost nothing to + its conditioning. The survey also runs with a single numeric predictor, + and its kernel weights equal `GWmodel::gw.weight()` exactly: a boxcar + keeps a point at the kernel's edge, and a zero-width adaptive kernel gives + `NaN`, counted as singular, instead of weight 1 at the co-located points. + (A grid with a boxcar bandwidth equal to its spacing used to be reported + collinear at every location while GWmodel fitted windows of 3 to 5 + points.) * `plot(fit, type = "coefficients")` for a GWR fit maps one local coefficient (`term`) at the training locations, which is the reason to fit GWR at all --- and masks the locations where it is not to be - believed: a collinear local design (condition index above 30, or - singular) or a non-finite coefficient is drawn hollow and grey, counted - in the subtitle, because the smooth surface a naive map draws over them - is the picture of an unstable estimate. `mask = FALSE` draws them - anyway and says how many it is drawing. + believed: a collinear local design (for a slope, the slope condition index + above 30 or singular; for the intercept, the condition index with the + intercept above 30) or a non-finite coefficient is drawn hollow and grey, + counted in the subtitle, because the smooth surface a naive map draws over + them is the picture of an unstable estimate. `mask = FALSE` draws them + anyway and says how many it is drawing. A fit with a duplicated + predictor name is drawn rather than refused as "every location is masked". + A slope map in kelvin is drawn like the one in degrees C; before, every + location was masked and the map refused. * `kriging_adequacy()`: what a block-kriging aggregator would deliver on a set of cells, computed beside the plain means and changing none of them. Per cell, from a fitted variogram (`estimate_sac_range()`'s, or estimated here): the block-kriging estimate and variance, that variance as a share - of the sill (`kr_ratio`, the coverage score --- near 1 the estimate is - the global mean), whether it exceeds the design-based `s^2/n` of the + of the variance the cell's mean would have with no data at all + (`kr_ratio`, the coverage score --- near 1 the data tell the cell nothing; + a share of the point sill never came near 1 for cells larger than the + range), whether it exceeds the design-based `s^2/n` of the plain mean (`kr_exceeds_design`), and the kriged-minus-plain shift in standard errors (`kr_shift`); plus the variance of the standardised errors from blocked cross-validation (`attr(, "cv")$zscore_var`), which @@ -525,9 +789,45 @@ function exists for: under uniform sampling kriged and plain means differed by more than one standard error in 11--24 percent of cells; under clustered sampling in 34--63 percent, with 3--27 of 16--64 cells empty - and kriged anyway. This is the first kriging path in the package - (`gstat::krige()` and `gstat::krige.cv()`); its model families are the - ones the package interprets elsewhere, and any other is refused by name. + and kriged anyway. Repeat visits to one location are kriged from their + mean, with the part of the nugget that varies between visits divided by + their count; kriging them as separate rows made every kriging system + singular and returned `NA` everywhere. Any cell or held-out location + gstat still cannot solve is counted in a warning. This is the first + kriging path in the package (`gstat::krige()`); its model families are + the ones the package interprets elsewhere, and any other is refused by + name. The cross-validation runs each `make_folds()` split on its own + training set, so `"buffered_loo"` and `"nndm"` keep their exclusion zones + (reduced to fold labels they ran as plain leave-one-out: with a 250 m + buffer, a standardised-error variance of 1.02 and RMSE 0.757, against + 0.873 and 0.944 with the buffer kept), and `print()` names the scheme + instead of calling every one "blocked CV". A cell holding locations that + the `nmax` nearest its centre leave out is kriged from all of its own + locations plus the `nmax` nearest outside it (a cell of 1,500 points was + otherwise estimated from its middle 50: 0.43 off against 0.07), and the + column `kr_n_used` says how many locations each cell was kriged from. + `max_neighbours` (default 2000) leaves out, with a warning, a cell that + would need a larger kriging system, and `max_box_ratio` (default 1000) a + cell whose bounding box exceeds its area that many times, because gstat + discretises over the whole box (+592 MB for one strip at 7,072); both are + counted in `attr(, "cells_left_out")` and by `print()`. The points are + put in the CRS the variogram was fitted in (`attr(sac, "crs")`), as + `summarize_by_cell()` does: a `sac` fitted in metres used on points in km + gave a CV statistic of 3.05 against 0.85. A `sac` whose variogram is of + residuals (`detrended = TRUE`) is used with a warning that the response is + kriged without its predictors and the variances come out too small + (4.3--5.2 against 0.67--1.53). `attr(, "rejected_reason")` records why a + `sac`'s range was refused, and the warning and `print()` say it instead of + "sill never reached" for every refusal. The cell ID is found and matched + as `summarize_by_cell()` finds it (cells keyed by `id` or `grid_id` too, + and a double ID of 1e5 matches an integer 100000, where it used to leave + that cell with n = 0), a point whose ID matches no cell is counted in a + warning, and a layer with no CRS is taken to be in the other's. Folds + whose recorded rows sit at other locations in `assigned_points_sf` are + refused, as in `cv_*()`. Folds built before + `assign_features_to_polygons()` dropped points used to be applied by + position, holding out the wrong points (cross-validation RMSE 1.82 + against 2.11 with folds built on the assigned layer), with nothing said. * `MAPE` and `SMAPE` now say how many rows they were averaged over. Every metrics frame --- `model_metrics()`, `summary()`, `evaluate_insample()`, @@ -535,18 +835,187 @@ `cv_bayes()`, `cv_spatial()`, `cv_rf()` and `compare_models_cv()` --- gains two trailing integer columns, `n_MAPE` and `n_SMAPE`: the rows each percentage error actually used once those where its denominator is zero - were dropped (`y == 0` for MAPE; `|y| + |yhat| == 0` for SMAPE). They equal - `n` (`n_pred` in the CV frames) when nothing was dropped, and are `0` in an - empty frame. The values themselves are unchanged: a MAPE over 58 of 120 - rows is the same number 2.0.0 reported, but it now arrives labelled, where - before nothing in the frame recorded that it was a subset average. + were dropped (`y` for MAPE, `|y| + |yhat|` for SMAPE, zero meaning no + larger than 100 machine epsilons times the data's own magnitude). They + equal `n` (`n_pred` in the CV frames) when nothing was dropped, and are + `0` in an empty frame. The values themselves are unchanged, apart from + what now counts as zero (see Bug fixes): a MAPE over 58 of 120 rows is the + same number 2.0.0 reported, but it now arrives labelled, where before + nothing in the frame recorded that it was a subset average. `print(summary(fit))` appends "(over k of n rows)" to its SMAPE line when the two differ. The columns sit after `Adj_R2` so code addressing the seven metric columns by position is unaffected; code pinning the exact column set needs the two names added. +* `voronoi_seeds_kmeans()` gains `nstart`, the number of `stats::kmeans()` + starts (default 10, as before). + +* `cv_bayes()` and `compare_models()` say when a Bayesian fit did not + converge. Both scored such a fit like any other, and only the fit's WARN + log lines (which `tryCatch()` and knitr never see, and + `spatialkit_quiet()` hides) said that its posterior was not to be + trusted. `cv_bayes()`'s `fold_metrics` gains `convergence_ok`: `TRUE` or + `FALSE` as `fit_bayesian_spatial_model()` judged that fold's sampler + (R-hat, effective sample size, divergences), and `NA` when `fit_args` + sets `check_convergence = FALSE`. A run with any `FALSE` raises one + warning naming those folds. `compare_models()` gains the same column and + warns once for each model that did not converge. Code that pins the + exact column set of either table needs the new name added. + ## Bug fixes +* **`coerce_to_points()` crashed R on an empty line feature.** sf's + `st_cast()` turns an empty MULTILINESTRING into one empty LINESTRING, not + zero parts, and `st_line_sample()` on it segfaulted and took the session + with it. A null geometry in a line layer loads exactly like this from a + GeoPackage or a shapefile, and `prep_model_data()`, every `cv_*()` function + and `fold_separation()` go through this path. GEOS's + `st_point_on_surface()` crashed the same way on a line feature holding an + empty part beside real ones, which `ensure_projected()` reached on ordinary + lon/lat input. Empty parts are now removed before either call, and an + empty feature becomes an empty POINT in its own row, which + `prep_model_data()` and `make_folds()` drop like any empty geometry. An + empty LINESTRING used to raise an error; it now gives an empty POINT like + every other geometry type. + +* **`cv_gwr(parallel = n)` hung forever once a GWR had been fitted in the + session.** GWmodel is built with OpenMP, and GNU libgomp is not fork-safe: + after `fit_gwr_model()`, a sequential `cv_gwr()` or a bare + `GWmodel::bw.gwr()`, the forked `mclapply()` workers blocked on a futex and + never returned, with no timeout. That is the ordinary fit-then-validate + order on Linux. `cv_gwr()` now runs its folds one after another whenever + `parallel` would fork, and says so in a warning. This gives up the + speed-up parallel folds had in a fresh session; the other `cv_*()` + functions still fork, since ranger does not use libgomp. A `cv_spatial()` + `fit_fn` that calls GWmodel can still hang with `parallel`, which its help + page now says. + +* **When some folds failed, `overall` quietly left them out.** A partial + failure was only logged, so `overall` pooled the surviving folds with no R + condition, and the folds that fail are usually the hardest to predict (a + region or a factor level no training fold covers). `cv_gwr()`, + `cv_bayes()`, `cv_spatial()` and `cv_rf()` now warn, naming each failed + fold and how many rows `overall` covers. Folds dropped before fitting are + already warned about and are not counted twice. + +* **`select_features_forward()` could pick a variable for making folds + fail.** Each candidate was scored on whatever rows its CV run predicted, + so a set whose fit failed on a fold (a factor level found in one block, an + ordinary case under block folds) was scored on fewer, easier rows. A + pure-noise factor beat the true driver: RMSE 2.35 on 192 rows against 2.63 + on 250, although the driver scored 1.73 on those same 192 rows. Every + candidate is now scored on one fixed row set (the rows the null model + predicts, or, with no null model, the rows the step-1 sets predict), a set + that leaves any of them unpredicted scores `NA` with a warning, and + `history` gains `n_pred`. + +* **`compare_models_cv()` ranked models scored on different rows.** Shared + folds guarantee the same splits, not the same scored rows: when one + backend lost a fold or returned `NA` predictions its `overall` row pooled a + subset, and the help page called the columns comparable. A fixed-bandwidth + GWR scored on 158 of 200 rows ranked above a random forest scored on all + 200, although the forest was 45 percent better on the 158 rows both + predicted. When the predicted row sets differ, every model is now rescored + on the rows all of them predicted, with a warning, `overall` carries + `n_pred`, and the all-rows numbers stay in `attr(overall, "all_rows")`. + The per-fold table and the Bayesian coverage columns are not rescored. + +* **`determine_optimal_levels()` read an elbow into points that have none.** + The elbow was the level furthest below the chord of the WSS curve on linear + axes. For points with no cluster structure WSS falls like `c / k`, and the + furthest point below that chord is exactly `sqrt(a * b)` for a ladder from + `a` to `b`, so the answer was set by the ladder's ends: 1,500 uniform points + gave 4, 4, 7, 9 and 13 for `max_levels` of 12, 20, 40, 80 and 160. At the + default `max_levels = 12` it also missed well-separated clusters (four + clusters came back as 3). The elbow is now read on log-log axes, where + `c / k` is a straight line, and counts only when the curve sags clearly + below it. Two, three, four, five, eight and ten well-separated clusters are + now recovered at the default on every seed tried (six came back as five on + one seed in five). With + no elbow the function still returns its linear-axis answer, but warns that + the ladder chose it; `build_tessellation()` and `get_voronoi_seeds()` refuse + a geometry-only `resolution_profile()` with no elbow instead of drawing a + count from it. A ladder of two levels (`max_levels` of 1 or 2, or three + points) has no line to test. The warning now says the ladder is too short + to read an elbow from and names what ended it. It used to say the curve + fell in a straight line "as it does for points with no cluster structure", + which two clusters 90 m apart at `max_levels = 2` were told. + +* **One invalid polygon changed the assignment rule for the whole layer.** + `assign_features_to_polygons()` wrapped `st_join(largest = TRUE)` in a + retry without `largest` on any error. The comment blamed a predicate that + cannot take `largest`, but sf never calls the predicate on that path; the + retry fired when GEOS threw on an invalid ring, and every straddling + feature was then assigned by `tie_break` instead: 95 of 200 buffered + parcels changed cell, and a polygon 91 percent inside one cell went to its + neighbour, with no warning. Invalid features and cells are now repaired + with `sf::st_make_valid()` for the join only, with a warning counting them, + and a join that still fails stops and names `largest = FALSE`. + +* **Lon/lat polygons were assigned to projected cells on bent cell edges.** + `assign_features_to_polygons()` moved the cells into the features' CRS, so + lon/lat features pulled the package's own projected cells into lon/lat, + and with s2 the largest-overlap join failed and fell into the silent + retry above: 55 of North Carolina's 100 counties went to a cell other than + their largest overlap on a 36-cell grid. The join now runs in the cells' + CRS whenever it is projected, and the features come back with the + geometry they arrived with. Lon/lat points near a cell edge can change + cell as a result; they now agree with a join done in the projected CRS. + +* **`build_tessellation(method = "triangles")` dropped most points at UTM + coordinates.** qhull lifts each point onto x^2 + y^2, and at projected + magnitudes (a northing near 5e6) the lift had no precision left to + separate points a few metres apart, so they never became vertices: 200 + points over 100 m gave 26 triangles instead of 386, and the help page's own + example lost 8 of its 20 points. The points are now centred before + triangulation. Triangles that were already right are the same triangles, + but qhull returns them in a different order, so triangle `cell_id` values + change. + +* **Data around a pole were projected to Web Mercator.** A layer spanning + more than 180 degrees of longitude with no gap was treated as global + coverage. Antarctic stations came out with worst-case distance errors near + 20,000 percent (the South Pole at y = -2.4e8 m), and Voronoi cells put 9.5 + percent of Arctic locations in a station's cell that was not their + nearest. A layer that lies wholly on one side of the equator now gets a + Lambert azimuthal equal-area projection centred on its pole whenever that + measures a smaller distance error than the global fallback: about 2 + percent on the same stations. + +* **GWR mixed elevation into its distances.** `prep_model_data()` kept the + Z (and M) coordinate of POINT Z input, which GPS layers and + `st_as_sf(coords = c("x", "y", "z"))` produce. `predict.gwr_fit()` then + handed GWmodel three coordinate columns, which it reshaped into two, + scrambling the prediction locations with no warning; + `gwr_model_selection()` ranked models on 3-D distances; and + `fit_gwr_model()` and `cv_gwr()` failed. Z and M are now dropped in + `prep_model_data()` and again where the data are handed to GWmodel. + +* **`predict.gwr_fit()` lost every prediction to one bad location.** It + went through `GWmodel::gwr.predict()`, which returns nothing for any row if + one location's window is empty or singular, so fixed-bandwidth block CV + failed every fold. It also never assigns its distance matrix once + training and new rows together exceed 10,000 (a 100 by 100 prediction grid + came back all `NA`), and it built the full training hat matrix for a + variance it then discarded, which is cubic in the training size. + Predictions now come from `gwr.basic(regression.points = )` in chunks, a + failing chunk is redone location by location, and only a truly singular + location is `NA`, with a warning counting them. Where the old path + worked, the values are identical. + +* **On brms 2.17 to 2.22, one far-off row moved every Bayesian prediction in + the call.** brms rebuilt the Hilbert-space GP's boundary from the rows + being predicted, and the package's padding rows could only widen it, so a + single row outside the training envelope changed the basis for every row, + interior ones included: a 40 by 40 grid padded 15 percent moved the + in-bbox cells by a mean of 22 percent of the surface's standard deviation, + and `predict_surface()` depended on `chunk_size`. On those versions the + GP term's boundary factor is now rescaled per call so the boundary stays + at its fitted value, and a row beyond the boundary, where the basis means + nothing, is `NA` with a warning. brms 2.23 stores the boundary itself; + there only the `NA` rule applies. The help page no longer says the + boundary "has to grow". + * **A `bayesian_fit`'s cached fitted values could come from another model.** The cache lives in an environment, so it is shared by every copy of a fit, and the entry was stamped with the row count and a digest of the training @@ -556,9 +1025,12 @@ object return the other's numbers --- and `clear_fitted_cache()`, which the help page offers for exactly this case, could not fix it, because clearing through one copy cleared the one shared entry and the next call re-wrote it. - The entry now carries the engine it was computed from and is used only for - that engine (`identical()`, which settles the common case by pointer, so - nothing is slower and no memory is held that the fit did not already hold). + The entry now carries the environment rstan and brms create for each + sampling run (`@.MISC` on the stanfit), which tells engines apart as well + as the engine itself does and is written once, and is used only for the + engine it came from (`identical()`, which settles the common case by + pointer, so nothing is slower and no memory is held that the fit did not + already hold, in a session or on disk). A stale entry is no longer deleted on a miss either: the fit that wrote it still wants it. `new_spatial_fit()` now always builds a fresh cache rather than adopting one that arrived in `info`, and `summary()` no longer carries @@ -583,9 +1055,17 @@ in a different order under `C` than under `en_US`, so `fold_metrics$fold`, `predictions$fold` and `fold_status$fold` named different groups on different machines from the same data and the same seed. The partition was - never affected, so pooled scores were right. The levels are now sorted with - `method = "radix"`, which is always C collation, making the numbering a - property of the labels alone. + never affected, so pooled scores were right. Character levels are now + sorted with `method = "radix"`, which is always C collation, making the + numbering a property of the labels alone. The C order applies to + character labels only: numeric labels are numbered in numeric order, as in + 2.0.0, and a factor by its own level order (an earlier development build + sorted numbers as strings too, so with ten or more numeric labels fold 2 + was the user's label 10). `area_of_applicability()` given a vector of + fold labels now numbers them by the same rule; it sorted character labels + with `as.factor()` under the session's collation, so a message could name + a different fold from the one `cv_*()` named for the same label. Its + partition and threshold were never affected. * **`residual_morans_i(k = )` silently answered a different question.** `k` reached the weight builder unvalidated, where `min()` collapses a vector: @@ -631,9 +1111,9 @@ counts and the call returns its counts and `cell_weight` as documented. * **`compare_models()` aborted on a list holding no `spatial_fit`.** - `evaluate_insample()` warns and skips a non-fit and returns `NULL` when - every element was skipped; the `NULL` then became a bare list and - `seq_len(nrow(NULL))` raised + `evaluate_insample()` warns and skips a non-fit, and returned `NULL` when + every element was skipped (it is now an error, below); the `NULL` then + became a bare list and `seq_len(nrow(NULL))` raised `"argument must be coercible to non-negative integer"`. It now says which argument is wrong and what belongs there. @@ -670,7 +1150,10 @@ on one of them aborted the call with "Loop 0 is not valid: Edge 1 is degenerate". The sort copy is now repaired after the transform as well. The geometry returned is still the caller's own, and the same cell gets the same - ID whether the layer arrives projected, in lon/lat or in Web Mercator. + ID whether the layer arrives projected, in lon/lat or in Web Mercator, + except where two fine cells' centres lie within the sort key's rounding + step of the same longitude (36 of 2,500 100 m cells straddling a UTM + central meridian changed ID via EPSG:3035); join such layers on geometry. * `select_features_forward()` now says when `fit_fn` is ignoring the variables it is handed. The learner it takes is a function of `(train_sf, predictor_vars)`, but the one `cv_spatial()` takes is a function @@ -699,12 +1182,13 @@ nearest-neighbour case, where every cell holds a single point, there is no within-cell variation and every standard error is `NA`. The warning names the argument and points at `get_voronoi_seeds()`, which is where a Voronoi - cell count is actually set. Under `method = "voronoi"` it adds that - `params` does not record the request either, so a saved result carries no - sign of it; that branch returns `create_voronoi_polygons()`'s own list, - which has no slot for the argument, whereas the triangles branch does echo - `approx_n_cells` back. The warning fires under `quiet = TRUE`, which gates - this function's `message()`s and is documented not to silence R warnings. + cell count is actually set. It adds that `params` does not record the + request either, so a saved result carries no sign of it: the Voronoi + branch returns `create_voronoi_polygons()`'s own list, which has no slot + for the argument, and the triangles branch no longer echoes + `approx_n_cells` back (below). The warning fires under `quiet = TRUE`, + which gates this function's `message()`s and is documented not to silence + R warnings. * `determine_optimal_levels()` fits each k as the best of 25 k-means++ restarts (Arthur and Vassilvitskii 2007; Fränti and Sieranoja 2019; @@ -721,7 +1205,12 @@ cases that were wrong; a clean curve gives the same answer. Under a model-aware criterion the function also now warns *before* the sweep when `max_levels` leaves no k above the nine-cell floor, rather than - fitting every k first and falling back afterwards. + fitting every k first and falling back afterwards. The seeding draws each + centre by inverting the cumulative squared distance rather than with + `sample.int(prob = )`: the same law, and a `resolution_profile()` of 3000 + points takes 10 s instead of 35 s (`determine_optimal_levels()` on 3000 + points, 4 s instead of 13 s), but it gives different centres for the same + seed than earlier development builds did. * `make_folds(method = "block_kfold")` can now raise its "block dimension < autocorrelation range" warning. The comparison was always there, but the @@ -735,7 +1224,16 @@ change. A hand-set `block_size` below the range raises the same warning. The estimate's own log lines stay off the console, and the check is skipped (with an INFO log line saying so) when `gstat` is not installed or - there are fewer than 30 points. + there are fewer than 30 points. Only a grid dimension that is split is + compared with the range, because a single row (or column) of blocks + borders no other block across its width. On points along a line the + comparison was with 0, so the warning fired on every call that had a + response: a 10 km line had 15 blocks 667 m long against a 499 m range. + Its advice, `block_size = 499`, made the blocks shorter (19 of 523 m). A + 10 km x 100 m corridor was compared with its 100 m width in the same way. + A `response_var` that names no column of `points_sf` is now an error for + `block_kfold`, whether or not `auto_range` is set. With `auto_range` off, + a misspelt name used to switch the check off silently. * `fit_rf_model(include_coords = TRUE)` logs its caution once per session rather than once per fit. Inside a five-fold `cv_rf()` or a twenty-fit @@ -758,7 +1256,1358 @@ the caller's back. Output from a call that succeeds is passed through unchanged, and when the stream is already diverted (under testthat, knitr or `capture.output(type = "message")`, where only one sink is permitted) the - call runs exactly as before. + call runs exactly as before. So does a call made after the session temp + directory has been deleted, when there is nowhere to divert the stream to; + it used to fail with "cannot open the connection". + +* **One empty point made `determine_optimal_levels()` return 1.** The + function reduced every feature to a point and projected it but never + dropped an empty or non-finite one, so a single `POINT EMPTY` made the + `k = 1` WSS `NA`, k-means failed at every `k`, and the failure handler + shrank the sweep to nothing: two well-separated clusters that gave + `2 1 3` gave `1` once one empty row was added, with only a log line about + interpolating the WSS. Such rows are now dropped with a warning that + gives their number, and under `select_on = "split"` the returned + positions still index the layer as passed. + +* **A few missing predictor values took Moran's I away from + `determine_optimal_levels()`.** A cell mean over a row with one missing + predictor was `NA` and dropped the whole cell, and how many cells that + removed depended on the points per cell, so `z` was computed on a + different subset of cells at each `k`. Three missing values in 400 rows + made every `z` in the evaluated window `NA`, and the call fell back to the + geometric ranking with a warning that did not mention missing values. + Rows with a missing or non-finite response or predictor now stay in the + WSS sweep and the cells and are left out of Moran's I, with a logged + count, so every cell mean uses the same rows. + +* **A misspelt `response_var` or `predictor_vars` in + `determine_optimal_levels()` silently changed the criterion.** A column + that was not there counted as "no model variables": with the default + criterion a typo kept `"geometric"` where supplying both variables + upgrades to `"combined"` (on one 400-point layer `7 6 8` instead of + `11 10 7`, with no warning and no diagnostics), and under `"morans_i"` or + `"combined"` the one log line said the variables were required although + both had been supplied. A named column that is not in the layer is now + an error, as it is in `resolution_profile()`, and a model-aware criterion + given no `predictor_vars` (or no `response_var`) falls back with an R + warning that says which is missing, rather than a log line. + +* **`determine_optimal_levels()` stopped one level short when locations + repeat.** The sweep was capped one short of the number of distinct + locations, the bound `stats::kmeans()` needs only when no location + repeats: five stations visited thirty times each could not reach `k = 5`. + The cap is now the number of distinct locations, and still one short of + the number of points. A `k` whose WSS is 0 (to within 1e-12 of the total: + a cell on every location) is left out of the log-log elbow line, and when + the rest of the curve has no elbow, the fall to zero is the elbow. + Leaving the level out and reading the rest made the call warn that the + five stations had no cluster structure and return `3 2 4` (one metre of + jitter gave `5 4 6`); it now returns `5 4`. Two stations visited thirty + times each give `2 1`, not `1 2`. Zero is relative because k-means leaves + floating-point residue: two groups of ten stations visited ten times each + have a WSS of 7.8e-17 at `k = 20`, which dragged the whole line down and, + at `max_levels = 30`, reported no cluster structure (still answering 2). + `resolution_profile()` reads its `elbow` column the same way. The + no-elbow warning names the bound that ended the ladder (the distinct + locations, the points or `max_levels`); it named `max_levels` whichever + bound it was. + +* **The same layer with its rows in another order gave + `determine_optimal_levels()` another answer.** The subsample and every + k-means start index rows, so a permutation of the input moved the WSS + curve and could move the count. The rows are now put in coordinate order + (response and predictors breaking ties) before either, so any + permutation of a layer gives the same result. Results for a given seed + differ from 2.0.0's for that reason too. + +* **`determine_optimal_levels()` blamed the wrong cause when its + model-aware criteria had nothing to score, and its help page understated + the fix.** The model-aware pass scores only the elbow's neighbourhood, + and on points with no cluster structure the elbow sits near + `sqrt(max_levels)`, so every candidate stayed at or below the nine-cell + floor until `max_levels` was about 40 (measured on 1000 uniform points: + 12, 20 and 30 all fell back, and 40 scored `k` = 10 and 11 alone). The + help page said "above roughly 10", and the fallback was logged as "Moran's + I could not be computed". The logged warning now names the window and + the floor and points to `resolution_profile()`, and the help page gives + the measured numbers. Which candidates are scored is unchanged. + +* **`build_tessellation()` could not tessellate CRS-less planar points + inside a CRS-less boundary.** `ensure_projected()` marks such points + `crs_assumed = "none"` ("planar, leave alone"), and `build_tessellation()` + read that mark as a CRS name: `st_crs("none")` failed with "invalid crs: + none" for every method, including the documented + `boundary = clip_target_for(pts)`, so CRS-less planar data could not be + gridded at all. Only a real assumption (EPSG:4326) is now given to the + boundary, which is refused if its coordinates cannot be degrees (below); + with no assumption both stay in the same unnamed space. + +* **When only one of the points and the boundary had a CRS, the + tessellation builders stopped on sf's bare "st_crs(x) == st_crs(y) is not + TRUE".** UTM points read from a CSV with a UTM boundary failed in all four + methods of `build_tessellation()` and in `create_voronoi_polygons()`; + projected points with a boundary that had lost its `.prj` failed in + `create_voronoi_polygons()` and `method = "triangles"`, and + `clip_target_for()` returned a target with no CRS --- for lon/lat points + with a CRS-less lon/lat boundary, in degrees, with `expand = 20` buffering + by 20 degrees. The side without a CRS is now interpreted in the other's, + as `harmonize_crs()` does, with a warning: lon/lat-looking coordinates are + reprojected from EPSG:4326, others are stamped. CRS-less points that do + not look like lon/lat are refused, with a message saying what to do, when + the boundary is geographic, because stamping degrees on them would be + wrong; a CRS-less boundary beside geographic points is read as lon/lat or + refused (below). + +* **A `boundary` without a CRS got a log line in `make_folds()`, `cv_*()` + and `predict_surface()`, where every other function raises an R warning, + and `cv_rf()` warned twice about one lon/lat boundary.** With projected + points, `build_tessellation()`, `clip_target_for()`, `plot_folds()` and + the rest said "`boundary` has no CRS ... stamping" as an R warning, while + `make_folds()`, `cv_*()` and `predict_surface()` stamped it with a "WARN + ensure_projected(): input has no CRS" log line that `tryCatch()` and + knitr never see and `spatialkit_quiet()` hides, naming neither the + function nor the argument. A boundary whose coordinates looked like + lon/lat got two R warnings from one `cv_rf()` call, one from + `prep_model_data()` and one from `make_folds()`, both naming + `ensure_projected()`. All three now warn as the others do, naming + themselves and `boundary` (`make_folds()` also `prediction_points`, + `predict_surface()` also `grid` and `covariates`), and a `cv_*()` call + warns once, naming the `cv_*()` function. Which CRS the layer ends up in + is unchanged. For `predict_surface()` this matters most on `grid` and + `covariates`: a layer stamped with the wrong CRS puts every covariate + lookup in the wrong place. The stamping warning of every function + now names the CRS it stamps ("stamping the target CRS ('EPSG:32632') + WITHOUT reprojection") instead of "the supplied `crs`", an argument most + of them do not have. + +* **A geographic `crs` made every tessellation method work in degrees.** + `build_tessellation()`, `create_voronoi_polygons()` and + `create_grid_polygons()` took `crs = 4326` as the CRS to compute in, so + Voronoi cells stopped being a nearest-point partition (150 points at + 53-57N: 20 percent of sampled locations lay in another point's cell), grid + cells were neither square nor equal-area, and clipping them under s2 + stopped with "Edge 0 is degenerate" (hex) or left a point inside the + boundary with an `NA` index (square). A geographic `crs` is now the CRS + the result is returned in: the cells are built and indexed in the local + projected CRS `ensure_projected()` picks, then transformed with long edges + densified. A hex or square grid sized by an explicit `cellsize` is still + laid in degrees, since that is the unit `cellsize` is in. + +* **`ensure_projected()` stopped on lon/lat polygons that s2 rejects, and + chose its UTM zone differently when `sf_use_s2()` was off.** The centre + that places the zone was `st_centroid(st_union())`: with s2 on, a polygon + with a repeated vertex (valid for GEOS, common in shapefiles) stopped + `ensure_projected()`, `create_grid_polygons()` and + `prep_model_data(boundary =)` with "Edge 1 is degenerate (duplicate + vertex)"; with s2 off it was planar in degrees, so two clusters at 0N and + 60N near -78 got UTM zone 17 in one session and zone 18 in another, and + sf's warning and message about it got past `quiet = TRUE`. The centre is + now always taken on the sphere, a geometry s2 rejects is repaired first, + and a mean of unit vectors is the last resort. + +* **A single study-area polygon was never scored, so `ensure_projected()` + kept a UTM zone at any extent.** A polygon layer is scored on one point + per feature, and one point makes no pair: every candidate scored `NA` and + the selector fell back to the zone. A CONUS outline stayed in UTM zone 15 + (12.8 percent worst-case distance error) where a Lambert azimuthal scores + 2.1 percent, and `prep_model_data(boundary =)` moved the whole analysis + into the zone with it. Layers with fewer than 40 features are now scored + on their outline's vertices too. + +* **`create_grid_polygons()` laid a grid over a near-global lon/lat boundary + in Web Mercator.** The cells were equal on the map and not on the ground: + the true areas of whole cells differed nearly five-fold. When the CRS + picked for distances distorts areas across the boundary by more than 1 + percent, the grid is now laid in the equal-area CRS + `ensure_projected(purpose = "area")` picks (Equal Earth here), with a + logged warning; a local extent keeps its UTM zone. + `create_grid_polygons_cached()` makes the same choice. + +* **With `sf_use_s2(FALSE)` the package needed lwgeom, which it does not + depend on.** The stable-ID sort key is measured in lon/lat, so every + Voronoi tessellation --- projected ones included, and the examples of + `create_voronoi_polygons()` and `build_tessellation()` --- failed with + "package lwgeom required", as did `ensure_stable_poly_id()`, + `create_grid_polygons_cached()` on a cache miss, and random and k-means + seeding on a lon/lat boundary. These measurements now run on the sphere + (s2) whatever the session's setting, which is restored afterwards; the + IDs are the ones s2-on sessions always got. + +* **Hex cell size depended on which way the boundary lay.** + `st_make_grid()` builds hexagons from `cellsize[1]` alone, and that was the + box's width over a rounded column count: a 1 x 1000 strip at + `target_cells = 9` got 1734 hexagons where the same strip lying flat got + 89. The size is now counted along the longer side, which leaves every + boundary at least as wide as it is tall with exactly the grid it had. + +* **Voronoi with `expand > 0` returned the boundary before it was grown.** + The cells are clipped to the grown boundary, so they covered 1.93 km^2 + against a returned `boundary` of 1 km^2, and points up to `expand` outside + it were indexed. `create_voronoi_polygons()` and + `build_tessellation(method = "voronoi")` now return the grown boundary, + and the documentation says `expand` grows the study area too. + +* **Collinear points gave an empty Delaunay triangulation.** + `build_tessellation(method = "triangles")` on a transect returned no cells + and an index of `NA`s, after logging that `delaunayn()` had failed, which + it had not. It now stops with a message that says the points are + collinear and points to `method = "voronoi"`; the fallback's log line + names the reason that applies. + +* **k-means seeding clustered CRS-less lon/lat points as if degrees were + metres.** `voronoi_seeds_kmeans()` and `get_voronoi_seeds(method = + "kmeans")` projected only when a CRS said lon/lat, so 800 CRS-less points + 89 km wide and 111 km tall were split east-west where the same points + tagged EPSG:4326 were split north-south. They now apply the lon/lat + heuristic `ensure_projected()` applies (with its warning) and return the + seeds in the input's own coordinates. + +* **`voronoi_seeds_random()` returned the same seeding on every call.** Its + default `set_seed = 456` reset the random-number stream inside the call, + so five calls under `set.seed(1)` to `set.seed(5)` gave one draw, and the + sensitivity comparison its help page recommends compared a seeding with + itself. The default is now `NULL`, as in `get_voronoi_seeds()`: the draw + comes from the session's stream. Pass `set_seed` for a fixed seeding. + This changes the default. + +* **`harmonize_crs()` refused a layer as `target_crs`.** A multi-row sf + failed with "the condition has length > 1" and a one-row one with "cannot + create a crs from an object of class sf", where `ensure_projected()` + accepts both. An sf or sfc target now means its CRS. + +* **`summarize_by_cell()` failed on `deff = NA` and mis-recorded + `deff = Inf`.** The check on a numeric `deff` came out `NA` for + `NA_real_` and `NaN`, so the call stopped with "missing value where + TRUE/FALSE needed" instead of the documented warning and fallback to 1. + `Inf` passed the check: the standard errors were the uncorrected ones, + yet `cell_weight` was 0 in every cell and `deff_applied` recorded + `deff = Inf`. Any `deff` that is not a single finite number of at least 1 + now falls back to 1 with the warning. + +* **`summarize_by_cell(deff = "variogram")` fell back to uncorrected + standard errors with no R warning when no model could be fitted.** With + predictors only and no `sac`, without gstat, or when + `estimate_sac_range()` returned no fit (fewer than 30 points), the only + signal was a log line: no `tryCatch()`, `withCallingHandlers()` or + `warnings()` saw it, and `spatialkit_quiet()` hid it, while the standard + errors came out about 5 times smaller than the corrected ones in one + check. It is now a warning that names the reason. Every design-effect + fallback (a refused `deff`, a rejected or unsupported variogram, no + model) is raised with class `"spatialkit_deff_fallback"`, so a loop over + many summaries can catch exactly that case. A rejected `sac` that a + variogram estimated from `response_var` replaces is not a fallback: it + gets a plain warning, and the classed warning is raised only when nothing + replaces it, once per call, naming every reason. A pure-nugget model (no + structured component) implies that distinct observations are uncorrelated, + so it is applied as a design effect of 1 in every cell, with + `deff_applied = TRUE`; it was reported as "the supplied model could not be + read", with the fallback warning. + +* **An empty point switched off `summarize_by_cell(deff = "variogram")` for + its cell.** Its missing coordinates made the cell's mean correlation + `NA`, and the cell silently got a design effect of 1: the standard error + of that cell was a quarter of the corrected one in one check. (In the + development version the same input stopped the call with "missing value + where TRUE/FALSE needed".) Points with empty or non-finite coordinates + now count towards their cell's values but not towards its correlation, + with a warning. + +* **`summarize_by_cell(deff = "variogram")` read an anisotropic variogram + as isotropic.** Only `model`, `psill` and `range` were read, so + `vgm(0.8, "Exp", 300, 0.2, anis = c(0, 0.2))` gave a correlation of 0.677 + at 50 m east-west where gstat's is 0.348, and a median design effect of + 14.1 against 7.7: standard errors too wide by a factor of 1.7. A 2-D + geometric anisotropy (`ang1`, `anis1`) is now applied as gstat applies it. + (`resolution_profile()`, which uses the same correlation function on + distances alone, still reads the major range.) + +* **A misspelt or non-numeric `response_var` was dropped in silence.** + `summarize_by_cell()` reported it through a progress message, which the + default `quiet = TRUE` suppresses, and returned a frame with no `resp_*` + column and `cell_weight` equal to `n`. A missing or non-numeric + `response_var` or predictor is now a warning, and a `response_var` of + more than one name is an error instead of "the condition has length > 1". + +* **A double cell ID of 100000 lost its cell in `summarize_by_cell(cells_sf + = )`.** When the points' and the cells' ID columns had different classes + (an integer `poly_id` against a double from a GeoPackage Integer64 field + or a CSV), both were converted with `as.character()`, which writes + `1e+05` for the double and `100000` for the integer. That cell came back + with `NA` summaries and its points left the result: 11 of 30 points in one + check, with no R warning. Whole numbers are now written out in full, and + a summarised ID that matches no cell is reported with a warning. + +* **`summarize_by_cell(cells_sf = )` did not read the ID columns + `assign_features_to_polygons()` writes from.** Cells keyed by `id` or + `grid_id` (common in shapefiles) were assigned cleanly and then summarised + to a plain table with no geometry, `cell_area` or `n_per_area`, and a + layer with `id` and a differently numbered `cell_id` was joined on + `cell_id`, putting 89 percent of the summaries on the wrong polygons in + one check. The cells are now searched in the order the assignment used, + and a `cells_sf` that cannot be joined is a warning (an error with + `area = TRUE`) rather than a log line. `agg_funs = median` or `"median"` + is honoured instead of being replaced by the mean. A single function is + named after the expression passed, so `stats::median` gives + `resp_median_*` as `median` does (it gave `resp_agg1_*`). + +* **`assign_features_to_polygons(largest = TRUE)` assigned polygon features + that only touch the cells.** sf keeps the largest intersection piece + without checking its area, so under GEOS a feature sharing only an edge or + a corner with the cell layer went to that cell with zero overlap, while + under s2 (lon/lat) the same feature was unassigned: sf's nc counties + against 50 of them as cells gave 70 rows projected and 50 in lon/lat. A + feature with no overlap area is now unassigned in every CRS. + +* **`tie_break = "smallest_area"` depended on the row order after all.** + Candidates of equal area --- the cells of any regular grid, for a point on + a shared edge --- fell through to the first row, so reversing the cells' + rows moved every edge point to the neighbouring cell (points at x = 100 + went to cells 1, 4 and 7, or to 2, 5 and 8), and on a cached grid, whose + IDs do not run row by row, one cell could take both of its edges. Equal + areas (to 9 digits) are now decided by the lowest, then leftmost, + bounding-box centre. On a `create_grid_polygons()` square grid that is the + cell row order already picked (1,681 of 1,681 lattice points unchanged); on + a hex grid 3 of 56 shared vertices move. + +* **`create_grid_polygons_cached()` could return another site's grid.** The + cache key used the CRS's `input` name, which is `"unknown"` for any custom + CRS read back from a GeoPackage or shapefile, so two site-centred CRSs + with the same local boundary coordinates shared an entry, and the second + site received the first one's grid 11,000 km away. The key now hashes the + CRS's WKT; the only cost is a rebuild when one CRS arrives written two + ways. `target_cells` now defaults to `NULL`, as in + `create_grid_polygons()`, so `cellsize =` or `n =` work without it. + +* **`ensure_stable_poly_id()` could number cells differently with s2 off.** + The sort key's centroid was taken planar in degrees when + `sf::sf_use_s2(FALSE)`, which moves it by far more than the key's rounding + step, so near-tied cells swapped IDs between s2-on and s2-off sessions (4 + of 2,000 Voronoi cells), and without lwgeom the s2-off call stopped at the + area. The key is now taken on the sphere for the sort copy only, whatever + the session setting. + +* **`summarize_by_cell(deff = "variogram")` built each cell's correlation + matrix up to five times per column.** The same call with two partly + missing columns and `conf_level` now builds 15 where it built 45. + +* **`estimate_sac_range()` returned the widest direction that reached a sill + when the all-pairs variogram had run past the fitted lags.** Under an + unremoved trend the pooled variogram rises without a sill, which the help + page said the fitted-lag bound catches; but when two of the four + directional variograms (those across the slope) did reach one, their + maximum came back as the range with `anisotropy_used = TRUE` and nothing + on the console. On an exponential field of range 150 with an east-west + trend, 12 of 30 draws returned 131--596 this way and 16 others `NA`, so + `make_folds(auto_range = TRUE)` switched between a 2 x 2 grid of 430 m and + geometric blocks from one draw to the next. The directions that reach a + sill are the shorter ones, so their maximum is a lower bound, not an + estimate. A converged all-pairs fit past the fitted lags is now refused + whatever the directions found (`rejected_reason = "fitted range exceeds + the largest lag fitted"`, the directional ranges still attached); the + directional maximum stands in only for an all-pairs fit that is singular + or did not converge. On stationary fields whose range is close to the + cutoff this also turns a few draws from a directional maximum into `NA` + (3 of 30 at an effective range of 570 on a 1000 m square). + +* **`print()` on an `estimate_sac_range()` result showed a bare number.** + For lon/lat input the number is in metres of a CRS the estimate picked, + and with `predictor_vars` it is the range of the residuals rather than of + the response; neither showed, so a mismatch with the layer it was about + to be used on could not be seen. A last line now names the unit and the + CRS (`in metres of EPSG:32617`) and whether the variogram is of the + response or of its residuals (and by which `detrend` method). For a layer + with no CRS the line says the range is in that layer's own coordinate + units (`in the coordinate units of a layer with no CRS`), still with what + was modelled; it used to be left out. + +* **`estimate_sac_range(predictor_vars = )` fitted its variogram to the raw + response, trend and all, when a single predictor or response value was + infinite.** `lm()`'s `na.exclude` drops `NA` but not `Inf`, so one `Inf` + among 200 rows stopped the detrending ("NA/NaN/Inf in 'x'"), and the + function fell back to the raw response with a warning. The range came + out at 2950 instead of 2168 (the answer with that row removed), and + `make_folds(auto_range = TRUE, predictor_vars = )` built blocks 37 + percent larger. `resolution_profile()`, which hides that warning, then + warned that the variogram it had estimated itself was of the raw + response. With `detrend = "reml"`, a `-Inf` predictor (a `log(0)` + covariate) first gave a false warning that the REML fit "did not + converge", and then the OLS fallback failed the same way. Rows with a + missing or non-finite response or predictor are now left out of the + detrending fit and the variogram, with a logged count, as + `prep_model_data()` and `resolution_profile()` already do. One `Inf` now + gives the same range as that row set to `NA` (2167.5 detrended on the + example; 1598.4 under REML). + +* **`make_folds(drop_empty_blocks = FALSE)` could return folds with no test + points.** `k` was lowered only when the highest block id holding a point + was below it, and with empty blocks kept that id says nothing about how + many blocks hold points: two clusters on a 4 x 4 grid gave id 16, so + `k = 5` was kept for 2 occupied blocks and three folds came back empty, + with no warning (the imbalance check skipped an empty fold). The `cv_*()` + functions then ran on the two folds that had points and + `area_of_applicability(folds =)` failed. `k` is now lowered to the number + of blocks that hold points, as `?make_folds` already said, the log line + names the numbers, and every point in a single one of several blocks is + the single-block error it always was with the default. + +* **The automatic block grid gave an east-west corridor more than twice as + many blocks as the same corridor running north-south.** Only the row count + was capped, so a layer more than about `block_multiplier * k` times as + wide as it is tall got `round(sqrt(15 * w/h))` columns at `k = 5`: 39 x 1 + on a 10 km x 100 m corridor against 1 x 15 turned on its side, blocks less + than half as long, and a scheme drifting towards random k-fold (1-NN CV + RMSE 0.77 against 0.94 on the same values; lower in 16 of 20 seeds). + Points on one horizontal line were treated as a square and got a 4 x 4 + grid that collapsed onto the line, lowering `k` from 5 to 4. The column + count is now capped at `block_multiplier * k` as the row count was, so + both orientations and both lines get 15 blocks at `k = 5`. Folds change + only for extents more than about `block_multiplier * k + 1` times as wide + as they are tall. + +* **`make_folds()` ignored `block_nx` or `block_ny` given alone, and + accepted invalid ones.** Giving one dimension sent the call to the + automatic grid without a word (`block_nx = 10` alone gave a 3 x 4 grid); + 0, a negative, `NA` or a vector failed inside sf or base R, and 2.7 was + truncated to 2. The dimension given is now used and the other derived + from the extent's aspect ratio (roughly square blocks), and each must be + a single whole number >= 1. + +* **With a non-rectangular `boundary`, `make_folds(block_kfold)` kept + zero-area slivers as blocks.** Where the boundary only touches a grid + cell at a corner or along an edge, the clipped cell is a POINT or a + LINESTRING, and it was kept as a block: packed into a fold under + `drop_empty_blocks = FALSE` (3 of 13 blocks under a triangular boundary), + and able to catch a data point lying exactly on the boundary as a + one-point block of its own. Only the areal part of the grid is kept now. + +* **`make_folds()` failed with R's own errors on a missing `k` or an + invalid `buffer`.** `k = NULL` (or no `k`) reached `if (k < 2)` and failed + with "argument is of length zero"; a `buffer` of `NA`, `numeric(0)` or + length 2 failed with "missing value where TRUE/FALSE needed" or a length + error, and an `NA` is exactly what `estimate_sac_range()` returns when no + range is identified. Both are now refused by name (the leave-one-out + methods still need no `k`), and so is a `units` object passed as + `buffer`, `block_size` or `block_nx`/`block_ny`, which used to fail inside + the units package without naming the argument. + +* **`make_folds(method = "buffered_loo")` said nothing when the buffer + excluded no neighbour.** The buffer is in the units of the CRS the folds + are built in, which for lon/lat input is metres, so a buffer in degrees + (0.1) excluded nothing and the scheme was plain leave-one-out: 79 of 79 + training points in every fold of an 80-point layer, no condition raised. + It now warns when no fold excludes any neighbour, and `?make_folds` says + what unit `buffer` is in. + +* **NNDM folds could be far more optimistic than their target with only a + log-file line to say so.** When `min_train` stops the matching --- samples + clustered well inside the prediction domain, the layout NNDM is meant + for --- the realised distances stay short: one cluster predicted onto a + 20 km grid kept a median of 1171 m against a target of 6704 m, 96 of 100 + folds held at the floor, while `?make_folds` said the result is never more + optimistic than the target. `make_folds()` now warns when the floor + leaves more than one point's worth of excess below `phi`, records + `params$n_at_min_train`, and the documentation states the guarantee only + where neither `phi` nor `min_train` binds. + +* **`make_folds(auto_range = TRUE)` fell back to geometric blocks with only + a log line.** When no range was identified (an unremoved trend, a range + past the fitted lags, fewer than 30 points, gstat missing), the blocks the + caller asked to be sized from the data were not, and under knitr, + `spatialkit_quiet` or `tryCatch()` nothing showed it. This is now a + warning that gives the rejection reason. `estimate_sac_range()` can give + up before it fits anything: fewer than 30 points, fewer than 30 finite + values, a constant response (or residuals, when the predictors explain + the response exactly), points with no extent, or gstat missing. It used + to return a bare `NA` then, with the reason only in a log line, and the + warning said only "estimate_sac_range() returned NA". That `NA` now + carries a `rejected_reason` attribute saying which (it is still unclassed, + with no other attribute). The warning quotes it, as do + `kriging_adequacy()`'s no-model error and `summarize_by_cell()`'s + fallback warning. + +* NNDM fold construction releases FNN's copy of the neighbour tables as soon + as it has them, so a second `n` x `n/2` pair is no longer held through the + sweep and the construction of the folds. The peak inside `get.knn()` is + unchanged. + +* **`cv_bayes()` rounded coverage levels to a whole percent, so close levels + overwrote each other.** Coverage columns were named + `sprintf("coverage_%.0f", 100 * level)`: `coverage_levels = c(0.5, 0.975, + 0.985, 0.995)` gave three columns for four levels, `coverage_98` holding + the 0.985 value and the 0.975 value lost, with no condition raised. Levels + given as percentages, `c(50, 80, 95)`, made every fold throw away its + CRPS, `n_draws` and coverage in silence. Columns are now named at full + precision (`coverage_97.5`; the default 50/80/95 names are unchanged), a + level outside (0, 1) or given twice is an error that suggests dividing by + 100 where that fits, and the result carries `coverage_levels`, the nominal + level of each column. + +* **An error in a `fold_info_fn` threw away all of that fold's extras + without a word.** `cv_spatial()` caught it and dropped the whole list, so + the columns were `NA` with `fold_status` `"ok"` and nothing logged; in + `cv_bayes()` one failing quantile cost `gp_k`, `n_draws`, CRPS and every + coverage column. The failure is now logged and named in + `fold_status$message`, and `cv_bayes()` computes coverage and CRPS in a + step of their own, so `gp_k`, `n_draws` and `yhat_sd` survive it. A + `fold_info_fn` that returns the wrong shape (a vector where a value + belongs, an unnamed or duplicated element, or a name `fold_metrics` + already has, such as `RMSE`) is an error that says so; `RMSE = -5` used to + overwrite the fold's real RMSE. + +* **`cv_spatial()` failed after fitting every fold when `..per_row` came + back from some folds only.** The prediction rows were stacked with + `rbind()`, which died on "numbers of columns of arguments do not match" + once every fold had been fitted, so the work was lost and the message did + not point at the cause. A fold without `..per_row` (returned + conditionally, of the wrong length, or from a `fold_info_fn` that threw) now + gets `NA` in those columns, and one of the wrong length is logged. + +* **Parallel cross-validation discarded folds that shared a core with a + failure.** `mclapply()` ran prescheduled, handing each core a chunk of + folds: an error that escaped one fold was copied to every fold of its + chunk, and a worker killed for lack of memory took all of its folds with + it. With four folds on two cores, a failure on fold 2 lost fold 4 as + well, and `overall` pooled 40 of 80 rows. Each fold now runs in its own + worker, so a failure costs that fold only, and an error that stops a + sequential run (a `metrics` or `fold_info_fn` return value of the wrong + shape) stops a parallel one too, naming the fold. A run in which nothing + fails gives the same numbers as before, since the per-fold seeds are drawn + before forking. + +* **`model_metrics(newdata = )` measured R-squared against a different + baseline from every `cv_*()` function.** It took the total sum of squares + about the new rows' own mean, where cross-validation takes it about the + training mean, so the same predictions on a split across a trend scored + R-squared -0.89 here and 0.35 from `cv_spatial()`. `model_metrics()`, + `evaluate_insample()` and `compare_models()` with `newdata` now use the + training mean too, the out-of-sample convention, and the help pages say + which baseline R-squared uses. In-sample numbers do not change. + +* **R-squared and MAPE depended on the units of the response.** The + thresholds below which a total sum of squares or a percentage-error + denominator counted as zero were absolute, so a response with standard + deviation below about 1.5e-8 got R-squared `NA` while RMSE and MAE were + fine (and `select_features_forward(metric = "R2")` selected nothing), and + one on a 1e-15 scale lost MAPE and SMAPE as well. "Zero" is now 100 + machine epsilons of the data's own magnitude for every metric: a rescaled + response gets the same R-squared and MAPE, a constant one still gets `NA`, + and on a response spanning many orders of magnitude a row whose + denominator is no larger than 100 epsilons times the largest (such as 1e-9 + against 1e6) no longer enters MAPE. + +* **`compare_models()` set out-of-bag random-forest metrics beside in-sample + ones without saying so.** Without `newdata` an `rf_fit`'s fitted values + are out-of-bag and every other backend's are in-sample, and the table could + rank the models the wrong way round: GWR RMSE 0.77 in-sample against RF + 0.82 out-of-bag, where the forest's in-sample RMSE was 0.40. + `evaluate_insample()` and `compare_models()` now carry a `metric_basis` + column (`"in-sample"`, `"out-of-bag"` or `"newdata"`), `compare_models()` + logs a note when a table mixes them, and both help pages say what the + metrics are computed on. + +* **`compare_models()` put LOOIC and AICc side by side for fits on different + rows.** Both are sums over the rows a model was fitted to, so a model + that lost 20 rows to a predictor's missing values showed LOOIC 32.2 + against 54.8 for the model on all 70, and looked 22.6 better while it was + worse on the rows they share. A column whose models were fitted to + different rows is now set to `NA`, with a warning naming each model's `n`. + The same happens to fits of the same rows with different responses (a + response and its log, say), since an information criterion compares models + of one response only, and the warning now says so. It used to say they + were "fitted to different rows (raw: n = 80, logged: n = 80)" and to + "Refit them on the same rows". + +* **`compare_models()` read significantly negative residual autocorrelation + as missed spatial structure.** The caution fired on a two-sided p-value + whatever the sign, so the alternating in-sample residuals of a GP or a + small-bandwidth GWR (Moran's I -0.13, p = 0.02) were logged as "may not + fully capture the spatial structure", the opposite diagnosis. A negative + z is now logged as what it usually means, a model tracking its data + closely. + +* **`compare_models_cv()` placed polygon rows in its shared blocks by a + different point than every model is fitted at.** The shared folds reduced + polygons and lines to their point-on-surface whatever `pointize` said, + while each backend fitted them at the `pointize` point: with + `pointize = "centroid"`, 119 of 150 L-shaped parcels were in a different + fold from a standalone `cv_gwr()` run. The shared blocks now use + `pointize`; with the default `"auto"` nothing changes. + +* **Saved folds on lon/lat polygons were refused after `sf_use_s2()` was + toggled.** The provenance check located each probed row by its centroid, + which on a geographic CRS is spherical with s2 on and planar with it off; + the two differ by up to 5e-4 degrees on county polygons, 500 times the + tolerance. Folds built before `sf_use_s2(FALSE)` (a common workaround for + invalid polygons), or saved and read in a session set the other way, were + rejected by every `cv_*()` as "built from different data". The probe now + always takes the planar centroid; folds saved by an older version are + checked the way they were made. + +* **`residual_morans_i()` gave the wrong reason when it could not use a + fit's residuals.** An error from `residuals()` was thrown away, and it and + a fit with no `residuals()` method (the `?new_spatial_fit` example has + none) were both reported as "could not extract enough residuals (n < 4)", + on a 100-row fit; a residual vector of the wrong length was reported as + "coordinate extraction failed". Each now has its own warning, quoting the + error where there is one, except that a fit with no `residuals()` method + is now scored on the response minus `fitted()` instead (below). + +* **A GWR whose local regressions interpolate the data won on AICc.** + GWmodel's AICc is defined only while the effective number of parameters, + tr(S), is below n - 2; past that its penalty turns negative. A small + adaptive bandwidth reached it, and so did any bandwidth raised to the old + floor, which for the bisquare and tricube kernels (they give the farthest + neighbour in a window weight 0) fitted every window exactly. On 100 + points `compare_models()` listed R2 = 1 and an AICc of -15033 against 292 + for the automatic bandwidth, and at n = 60 `gwr_model_selection()` + selected the real predictor plus three noise variables with -66689. + `fit_gwr_model()` now reports such an AICc as `NA` and + `gwr_model_selection()` ranks such models last, each with a warning giving + tr(S). The adaptive floor is one neighbour higher for bisquare and + tricube, and raising a supplied bandwidth to it is now a warning, not a log + line. `bandwidth = NULL` was not affected above 20 points. The raised + floor is enough unless several neighbours tie at the kernel's edge (a + regular grid); the warning now says so. Where an adaptive bandwidth is + already every observation, the undefined-AICc warning suggests fewer + predictors, more observations or a gaussian or exponential kernel instead + of a larger bandwidth. + +* **`fit_gwr_model()` never checked a one-predictor model for local + collinearity.** The check ran only with two or more numeric predictors, + but every local design includes the intercept, and a predictor nearly + constant inside a window is collinear with it. A regional covariate + nearly constant within each of four clusters gave local slopes from -97 to + 221 around a true 3 with no warning, while adding a noise predictor to the + same data warned at every location. One numeric predictor is now enough. + +* **GWR said a singular window came back as `NaN` coefficients; it stops + the fit.** GWmodel's matrix inverse throws on an exactly singular window, + so a 0/1 indicator constant within clusters failed the whole fit with a + bare "inv(): matrix is singular", while the help page and the collinearity + warning promised masked `NaN` coefficients. The non-finite coefficients + GWmodel does return come from co-located points, where an adaptive + bandwidth no larger than the number of observations at a site gives the + kernel zero width (160 of 160 at 40 sites of 4 observations, 4 + neighbours), and the warning blamed singular windows for those. The fit + error now says a window is singular and how many the collinearity check + found, and the non-finite warning names co-located points when they are + the cause. + +* **An adaptive GWR bandwidth above the number of points was capped in + silence.** `bandwidth = 1500`, meant as metres with `adaptive` left at + `TRUE`, became a 200-neighbour, near-global fit on 200 points without a + word; its local slopes varied less than half as much as the intended + fixed-distance fit's. `fit_gwr_model()` and `gwr_model_selection()` now + warn, naming n and pointing to `adaptive = FALSE`. `cv_gwr()` repeats the + warning in each fold whose training set is smaller than the bandwidth. + +* **Below 20 points, `bandwidth = NULL` did not fit at the bandwidth + `bw.gwr()` chose.** GWmodel searches adaptive bandwidths from 20 + neighbours up to n, so with fewer points its choice exceeds n (18 for 12 + points) and was capped at n, a different kernel with a worse AICc (18.3 + against 9.7), without a word. The cap stays and now raises a warning in + `fit_gwr_model()` and `gwr_model_selection()`; supply `bandwidth` for data + this small. + +* **A GWR predictor named twice raised false collinearity warnings.** + `fit_gwr_model(predictor_vars = c("a", "b", "a"))` fitted correctly, but + its collinearity checks ran on the duplicated column and warned "exactly + singular" and "100% of locations collinear", once in every `cv_gwr()` + fold, and the doubled count raised the bandwidth floor. Names are now + collapsed on entry, as `gwr_model_selection()` already did. + +* **A `gp_c` you set did not change the `gp_k` derived for it.** The basis + count was always sized for the boundary factor the package would have + chosen, so a wider boundary got the same number of basis functions and + could no longer resolve the lower length-scale bound it was sized for. The + advice under `gp_c` is to raise it for a long-range surface, which is + exactly the case that coarsened the basis. On 200 uniform points, + `gp_c = 3` fitted with `gp_k = 23` where the rule gives 43, and `gp_c = 5` + with 23 where the rule gives 70 (capped at 50); the cap warning could never + fire on this path. With `gp_k = NULL` the derived `gp_k` is now sized for + the `gp_c` actually used, and a capped value is logged. An explicit `gp_k` + still passes through untouched. + +* **`fit_bayesian_spatial_model()` could not fit `brms::categorical()` or a + `mixture()` family.** Those families give each distributional parameter + its own GP under the same coefficient names, and the automatic length-scale + prior kept only the names, so every coefficient got two identical rows and + brms stopped with "Duplicated prior specifications are not allowed" before + sampling. A user's `lscale` prior restricted to one `dpar` failed the same + way, because it was copied onto every category's coefficients. The prior + now carries each coefficient's `dpar`, `nlpar` and `resp`, and a global or + `dpar`-level `lscale` prior is expanded only onto the coefficients it + addresses and never over a coefficient-level one the user already gave. + With `standardize_predictors = TRUE` they still failed, on the automatic + `normal(0, 5)` slope prior, which carried no `dpar` and so matched no + slope of either family (brms: "The following priors do not correspond to + any model parameter: b ~ normal(0, 5)", a prior the user never wrote). + That prior is now set on each distributional parameter's slopes, as the + length-scale prior is; a family with one `mu` gets the same single row as + before. + +* **A two-level factor response under `brms::bernoulli()` fitted, and then + nothing could score it.** The response check refused a non-numeric + response only under gaussian, and the gaussian refusal itself pointed at + `bernoulli()`. brms fits the factor, but `residuals()` came back all `NA`, + `summary()`, `model_metrics()` and `compare_models()` stopped on "response + is factor", and `cv_bayes()` ran a full fold of MCMC before aborting in the + fold scoring (with `parallel = 2`, every fold ended as `worker_error`). A + factor or character response is now refused, before anything is compiled, + under every family except `categorical()` and the ordinal ones (cumulative, + sratio, cratio, acat), with a message saying to convert it to 0/1. Numeric + and logical 0/1 responses are unaffected. + +* **`predict()` on an ordinal or categorical `bayesian_fit` returned all + `NA` as a "posterior draw failed".** brms returns `posterior_epred()` for + those families as a draws x rows x categories array, which the method took + for a failed draw: a real `cumulative()` fit returned `NA` for all five + new rows, with only a log line, while `fitted()`, `summary()` and + `model_metrics()` said merely that they got an array. `predict()` under + its default `type = "epred"` and `fitted()` now stop, saying the family has + a probability per category and pointing at + `type = "predict", draws = TRUE`, whose share of draws in each category + estimates its probability for any rows, and at + `brms::posterior_epred($engine)` for the training rows + (`posterior_epred($engine, newdata = )`, which the message used to + suggest, refuses new rows without the scaled coordinates the method + builds). The message now counts the caller's rows, where it counted the + two GP-boundary rows as well ("150 x 7 x 3" for five rows). + `type = "predict"` without `draws = TRUE` on a `brms::categorical()` fit, + which returned the mean of unordered category indices (1.46, 1.97, ...), + is now an error; for an ordinal family it is the expected category index, + as documented. A genuinely failed draw still returns `NA` as + documented, and the log line now carries the cause. + +* **`predict()` on an `rf_fit` turned every ranger error into an all-`NA` + vector.** `type = "quantiles"` on a forest grown without + `quantreg = TRUE`, and `type = "se"` without `keep.inbag = TRUE`, which the + help page says are rejected, returned ten `NA`s for ten rows with no R + condition, and `model_metrics(newdata =, type = "se")` then reported + `n = 0`. A failure in ranger's predict method is now an error naming + ranger's reason; the `cv_*()` fold loop records it as the fold's cause and + `predict_surface()` stops naming the rows, as they already did for other + backends. A `newdata` with no complete row still returns all `NA` with a + log line, as for the other backends, rather than reaching ranger as a + zero-row frame; that had made a `predict_surface()` chunk outside the + covariates' coverage abort the whole surface. + +* **`check_convergence = FALSE` returned `convergence_ok = TRUE`.** The flag + started out `TRUE`, so a fit whose checks never ran (its max R-hat was 1.28) + claimed to have passed them over an empty diagnostics list, and `print()` + had nothing to caveat. It is now `NA` when nothing was checked, and + `print()` on the fit and on its `summary()` says "Convergence: NOT + CHECKED"; `summary()`'s printout also repeats the "Convergence warnings + present" flag, which it carried and never showed. A failed PSIS-LOO is now + logged with its cause instead of "LOO computation failed." alone, which had + left `compare_models()` showing `LOOIC` `NA` with nothing saying why. + +* **The convergence check raised dozens of "The ESS has been capped" + warnings.** `brms::neff_ratio()` runs posterior's ESS over every GP basis + weight, and posterior warns once per well-mixed one: an `n = 80` fit raised + 44 R warnings, 41 of them this one. R keeps only the first 50 warnings, so + a warning that mattered and came later, loo's Pareto-k among them, could + be dropped. That one message is now muffled around the R-hat and ESS + accessors; every other warning passes through, and the ratios are + unchanged. + +* **A saved `rf_fit` or `bayesian_fit` carried its engine twice.** The + model formula was built in the fitting function's frame and so captured + it, and that frame holds the forest or the `brmsfit` itself; a formula + serialises its environment, so `saveRDS()` wrote the engine a second time + (1.62 MB for a 100-tree forest of 0.72 MB; about 80 MB for a 40 MB + `brmsfit`, which brms's own copy of the formula doubled even in + `saveRDS(fit$engine)`). The formulas now carry the global environment, as + a formula typed at the console does. + +* **A forest with rows out of every tree's bag said nothing.** ranger returns + `NaN` as the out-of-bag prediction of a row every tree sampled, so with + `num_trees = 5` 20 of 200 rows had `NaN` fitted values and `summary()` + printed "n = 200" over an R-squared computed on 180. `fit_rf_model()` now + warns with the count, and `summary()` prints "(computed on 180 of 200 + rows ...)" when its metrics use fewer rows than the fit has. `cv_rf()` + does not use its fold forests' out-of-bag predictions, so it warns once + per run with the number of fold forests affected, instead of once per fold + (each of which told the user to score the forest with `cv_rf()`). + +* **`area_of_applicability()` counted rows that differ on a dropped + zero-variance predictor as inside the AOA.** A predictor constant in the + training data --- a land-cover dummy absent from the training region --- is + dropped from the distance, so new rows taking another value there were + judged on the other predictors alone: 37 of 40 urban rows came out inside, + where a single urban training row would have kept the predictor and put 1 + inside. Such rows now get `DI = Inf` (their scaled distance along that + predictor is infinite), are counted outside, and a warning gives the count; + `print()` says how many. + +* **`area_of_applicability()` returned a threshold of 0 from duplicated + training rows without saying why.** Each training row's reference is its + nearest other row, so exact duplicates in predictor space --- repeat visits + to a site with static covariates, covariates from a raster coarser than the + sampling --- have a training DI of 0; past about three quarters of the rows + the threshold is 0 and only exact copies count as inside (30 sites visited + four times: 0 of 200 new points inside, against 197 after deduplication). + The rule is unchanged; the result is now logged with the remedy + (leave-location-out folds, or deduplication) and `print()` shows the count + of zero training DI. + +* **`area_of_applicability()` refused all-zero weights, which the advice + `pmax(importance, 0)` produces whenever the model found no useful + predictor.** A one-predictor forest gave all-zero weights in 9 fits of 20 + when its predictor carried no signal, so the AOA was lost in the folds where + it mattered most. With one predictor the weight cannot change the index + (it is scale-invariant) and zero is accepted silently; with several, all + are weighted equally, as `weights = NULL` would, with a warning. + +* **A fractional `chunk_size` in `area_of_applicability()` marked + extrapolation as inside the AOA.** On the dense path (`use_fnn = FALSE`, + or FNN not installed) block starts became fractional and the rows between + blocks kept an initial DI of 0: with `chunk_size = 2.5`, 5 of 25 far-out + points were reported inside and 16 training DI of 0 moved the threshold. + `chunk_size` is now validated by name and truncated to whole rows. + +* **`area_of_applicability(model = fit, folds = folds)` stopped with "fold 1 + refers to rows outside 1:n" whenever `prep_model_data()` had dropped a + row, for the same folds `cv_*()` accepted.** One missing response in 200 + rows was enough: `make_folds()` numbers the rows of the layer it is given, + the fit keeps only the 199 rows `prep_model_data()` returned, and the fold + IDs were read as positions in those. The documented workflow ("pass the + same `make_folds()` result you passed to `cv_spatial()`") therefore failed + on any layer with a missing or non-finite modelling value or an empty + geometry. The rows the fit's `"dropped"` record names are now taken out + of the folds, as `cv_*()` take them out, with a log line giving the count; + a label vector with one label per row of the layer fitted from loses those + labels. The threshold is the one you get by removing the rows from the + folds by hand. Folds built on the model's own training data (the + `prep_model_data()` output) are still read as positions in it, and a fold + ID naming a row the data never had is still an error. + +* **`area_of_applicability()` applied folds built on other rows without a + word.** Fold splits are row IDs, and `cv_*()` compare the sample of row + locations `make_folds()` records against the data, refusing folds built + on another layer. `area_of_applicability()` did not: a model fitted on + the same rows in another order took the folds anyway and moved the + threshold (0.2432 against 0.2404). It now makes the same check on the + training data and refuses such folds with the `cv_*()` message. The + check is skipped (logged) when the folds were built on polygons and the + training data are the points a fit reduced them to, so a model fitted on + polygons with folds built on those polygons keeps working. + +* **`predict_surface()` filled a polygon grid with covariates from an + arbitrary point inside each cell.** `st_nearest_feature()` returns the + first zero-distance match the spatial index yields, so a + `create_grid_polygons()` grid got covariates that did not match the + location predicted at (predictions off by up to 2.6 on a 0-30 response) and + that changed with the row order of `covariates` (by up to 4.7), and the + result was a polygon layer where the manual promises points. The grid is + now reduced to one representative point per cell first. + +* **`predict_surface(..., draws = TRUE)` flattened the draw matrix into + `.pred`.** The argument was forwarded to `predict()`, and a backend that + honours it returned an `n_draws x n` matrix that became `.pred` column by + column (correlation with the right values: 0.03); with `se = TRUE` the + duplicated argument was reported as "backend does not expose posterior + draws". `draws` is now refused by name, and a `predict()` returning the + wrong number of values is an error. + +* **`predict_surface()`'s automatic grid could lose a whole column or row.** + When the extent is an exact multiple of the cell size, `floor()` of the + ratio landed one short through rounding (0.3 / 0.1 gives 2 cells), leaving + a cell-wide strip uncovered; at the default `n_cells` this hit 1197 of + 10000 random squares. The cell count now has a relative tolerance, so an + exact multiple gets exactly that many cells. + +* **`predict_surface()` kept a reused grid's old `.pred_se`.** Passing an + earlier surface as `grid` left that model's `.pred_se` beside the new + `.pred` unless this call replaced it, even after logging "returning + predictions only". It is now removed unless this call computes it. + +* **A `logger` configuration made before loading the package could still + abort its functions, and received its log lines.** `logger` seeds a new + namespace by copying *every* index of the user's global configuration, and + 2.0.0 pinned the formatter on index 1 only. A user with two global indices + set up before `library(spatialkit)` got `formatter_sprintf` or + `formatter_glue` on the console echo, so a `%` or a `{` in a message + (`"fold 2 skipped: object 'cov_{x' not found"`) aborted the function that + logged it and the R warning the manual promises never arrived; a third + global index kept the user's own appender and received spatialkit's WARN and + INFO lines in the user's log file. Both indices now have formatter, layout, + appender and threshold pinned, every message is marked + `logger::skip_formatter()`, and copied indices beyond the second are deleted + (on `logger` 0.2.2, which cannot delete one, switched off). The global + configuration is still never touched. + +* **Deleting the session temp directory made every function that logs fail + until the package was reloaded.** The trace file's path was fixed in + `tempdir()` at load time, so after an OS cleaner or `unlink(tempdir())` + every log call failed with "cannot open the connection", and a documented R + warning (`ensure_projected()`'s CRS assumption, say) became that error; + `tempdir(check = TRUE)`, R's own recovery, did not help. The trace now + resolves its path when a line is written, recreates the directory if it has + gone, and drops a line it cannot write; no logging failure aborts the caller + any more, so the warning always arrives. + +* **Logged cautions were missing from knitted documents.** The console echo + wrote to stderr, which knitr does not capture, so an R Markdown, Quarto or + pkgdown document showed the package's R warnings but none of its logged + cautions (`compare_models()`'s significant residual autocorrelation, for + one). While knitr is running the line is now also sent as an R message, so + it appears in the output and `message = FALSE` hides it; a line that is + raised as a warning too is not repeated. stderr gets exactly what it got + before, and nothing changes outside knitr. + +* **`plot_tessellation_map(labels = TRUE)` drew no labels on any layer this + package builds.** `label_col` defaulted to `"grid_id"`, a column no + function produces: Voronoi and Delaunay cells carry `cell_id`, grids + `poly_id` and `cell_id`, and `summarize_by_cell()` output `poly_id`, so the + map came back unlabelled with only a log line to say why. `label_col` now + defaults to `NULL`, which takes the first of `grid_id`, `cell_id`, + `poly_id`, `polygon_id` and `id` the layer has; `grid_id` stays first, so a + layer that has one is labelled as before, and naming a column still works. + +* **`plot_tessellation_map()` failed at print on a units, Date, POSIXct or + difftime fill column.** The fill scale was chosen with `is.numeric()`, so + Date, POSIXct and difftime columns got a discrete scale ("Continuous value + supplied to a discrete scale"), and an `st_area()` column (class units) + passed the test and then broke the viridis scale's arithmetic. The + function returned normally and the error came only when the plot was drawn. + Date and POSIXct now get the continuous scale on a date or time axis, and + units and difftime columns are drawn as numbers with the unit in the legend + title (`"area [m^2]"`) unless `legend_title` is given. + +* **`plot_folds()` failed at print when its layers disagreed on having a + CRS.** A CRS-less boundary beside projected points, or the reverse, + aborted inside `coord_sf()` with sf's "cannot transform sfc object with + missing crs". Since `plot_folds()` began drawing the block outlines it + also failed on the very layer the folds were built from: `make_folds()` + projects CRS-less lon/lat points to a UTM zone, and stamps CRS-less points + with a boundary's CRS, so the stored blocks carry a CRS the points do not. + A CRS-less layer is now brought into the points' CRS, or failing that the + folds' own, or the first layer's that has one: reprojected when its + coordinates look like lon/lat, and stamped with a warning otherwise, as + `make_folds()` does. + +* **`plot()` on a custom `spatial_fit` without a `residuals()` method + stopped with "could not extract residuals".** `?new_spatial_fit` calls + that method optional, but `residuals.default()` returns `NULL` for a + `spatial_fit`, so the residual map, the observed-against-predicted plot and + the residual variogram all refused a backend that had the required + `fitted()` method. The residuals are now the response minus `fitted()`, + which is what the built-in backends return; without a `fitted()` method the + error names the method to define. + +* **`citation("spatialkit")` gave the year it was called in, not the year of + the release.** DESCRIPTION has no `Date` field, so `inst/CITATION` fell + back to `Sys.Date()`. CRAN installs got the right year only by accident: + `meta$Date` partially matched `Date/Publication`. The year is now looked + up the way `utils::citation()` does it, by exact field name: the CRAN + publication date, then `Date`, then the date `R CMD build` packaged the + source (which a GitHub install via remotes or pak has). Only an install + straight from a source directory records none of these, and only then does + the current year appear. + +* **The plots' size arguments did nothing on ggplot2 older than 3.4.0.** + The line layers pass `linewidth =`, which ggplot2 3.4.0 introduced; older + versions warn "Ignoring unknown parameters" and draw at the default width, + so `outline_size`, `boundary_size` and the other size arguments were + silently ignored. Suggests now asks for `ggplot2 (>= 3.4.0)`. + +* The test suite calls `local_mocked_bindings()`, which testthat added in + 3.1.7, but Suggests allowed 3.1.5. On 3.1.5 or 3.1.6 every test that mocks + a function failed with "could not find function". Suggests now asks for + `testthat (>= 3.1.7)`. + +* **`determine_optimal_levels(criterion = "combined")` could put first a + cell count that Moran's I never scored, chosen by the rule the elbow had + stopped using.** On eight separated clusters (800 points, + `max_levels = 40`, four seeds) it returned `10 7 6`, `10 7 6`, `6 5 10` + and `6 10 7`. The geometric axis was still the chord on linear axes + across the elbow's window, which ranked 6 or 7 above the elbow of 8. The + candidates below the nine-cell floor, which Moran's I cannot score, shared + an average rank that shrank as more of them went unscored (6 of 9 for + seven of them), although the help page said they ranked last. The + geometric axis is now the log-log sag the elbow is read from, and it is + flat when the curve has no elbow, so Moran's z alone orders the window. + Every unscored candidate takes the last place on the Moran axis, and exact + ties go to the `k` nearest the elbow. And an elbow below ten cells, a + count Moran's I cannot score, is no longer ranked against the counts it + can: ranking it put ten, the smallest count Moran's I scores, first + whatever the response did (a response of noise and one varying by + cluster gave the same answer). There `"combined"` returns the geometric + ranking, logs why, and records it in the diagnostics (`criterion = + "geometric"`, `fallback`). The same layers now give `8 7 9`, `8 7 9`, + `7 6 8` and `8 7 9`, the geometric answer, and 800 uniform points, which + have no elbow and are ordered by Moran's z, `10 11 7` where they gave + `5 4 10`. Supplying both `response_var` and `predictor_vars` selects + this criterion by default. + +* **`build_tessellation(method = "hex")` or `"square"` laid its lattice over + a near-global lon/lat boundary in Web Mercator.** The points' CRS is + chosen for distances, and handed on as the grid's CRS it skipped the area + check `create_grid_polygons()` makes: on a boundary from 170W to 170E and + 60S to 70N, the full hexagons differed 5.75-fold in true area, where + `create_grid_polygons()` on the same boundary used Equal Earth (0.7 + percent). The lattice is now laid where `create_grid_polygons()` lays it: + in the CRS picked for the points unless that CRS distorts areas across the + boundary by more than 1 percent, and otherwise in the equal-area CRS + `ensure_projected(purpose = "area")` picks for the boundary, with a logged + warning, the points indexed in the same CRS. This applies with no `crs` + and with a geographic one; a local extent keeps its UTM zone. + +* **A CRS-less study area given with lon/lat points could be read as a + one-metre square.** `build_tessellation()` resolved a boundary without a + CRS against the UTM zone picked for the points, after projecting them, so + a one-degree tile with integer corners (which the lon/lat heuristic + declines) was stamped with that zone: one Voronoi cell, or 27 hexagons, + and all 50 points indexed `NA`. A boundary in British National Grid + metres was stamped with the UTM zone too. Such a boundary is now read in + the points' own CRS when its coordinates fit the lon/lat envelope, with a + warning, and refused with an error naming both layers when they do not; + `create_voronoi_polygons()` and `clip_target_for()` read it the same way. + +* **CRS-less lon/lat points with a CRS-less boundary in metres failed with + "`boundary` must be polygonal".** `build_tessellation()` stamped + EPSG:4326 on the boundary without looking at its coordinates, so a UTM + polygon was transformed to nothing and the error named its geometry type. + It now stops with an error saying the two layers cannot be placed in one + space. + +* **`create_voronoi_polygons()` tessellated CRS-less lon/lat points in + degrees, silently.** It projected only when a CRS said lon/lat, so 60 + CRS-less points at 55N got cells in which 17.7 percent of sampled + locations were not nearest to their cell's point, while + `build_tessellation()` on the same points warned, took them as EPSG:4326 + and projected them. It now applies the same lon/lat heuristic, with its + warning, and returns what `build_tessellation()` returns (0.1 percent, at + the cell edges). `?build_tessellation` no longer says a CRS-less pair + "stays in the same unnamed planar space" whatever its coordinates. + +* **Delaunay triangles returned in a geographic `crs` did not contain their + own points.** `build_tessellation(method = "triangles", crs = 4326)` on + 150 points left 9 of them touching no returned triangle, so a spatial join + on the result did not reproduce `index`. The corners of the returned + triangles are now put back on the input points after the round trip + through the working projection, and every point lies in its indexed + triangle. + +* **The tessellation builders failed on an sf layer as `crs`.** + `build_tessellation()`, `create_voronoi_polygons()` and + `create_grid_polygons()` stopped with an error from sf ("the condition has + length > 1", or "cannot create a crs from an object of class sf"). They + now take the layer's CRS, as `ensure_projected(target_crs =)` and + `harmonize_crs()` do. + +* **Random and k-means seeding on a lon/lat boundary warned "install package + lwgeom" on every call.** sf raises "coordinate ranges not computed along + great circles" for each lon/lat draw when lwgeom, which this package does + not depend on, is absent: one R warning per `voronoi_seeds_random()` or + `get_voronoi_seeds(method = "random")` call and two per k-means call. + That warning is muffled, and the draw is unchanged. The boundary's union + is taken on the sphere as well, so with `sf_use_s2(FALSE)` sf no longer + prints its planar `st_union()` message and the seeds are the ones an s2-on + session gets. + +* **A transect with sub-millimetre scatter got a sliver study area and a + 166,536-cell grid for `approx_n_cells = 25`.** `clip_target_for()` called + a bounding box degenerate only when its two ends were equal to rounding, + so 30 points along 1000 m with a y scatter of 1e-6 got a 1000 x 9e-7 + rectangle, over which the square grid had 166,536 cells (16 seconds) and + the hexagonal one 154,980 (28 seconds); a little thinner, and + `create_grid_polygons()` stopped at `max_cells` telling the user to check + the units of a `cellsize` they had not passed. A box whose short side is + below a millionth of the long side is now degenerate too (a buffer around + the points: 34 squares or 45 hexagons for 25), and the `max_cells` error + names the argument the size came from, `target_cells` (`approx_n_cells`), + `n` or `cellsize`. + +* **A whole `build_tessellation()` result passed as `boundary` failed with + sf's `no applicable method for 'st_geometry' applied to an object of class + "list"`.** `build_tessellation()`, `create_voronoi_polygons()` and + `clip_target_for()` now say that the object looks like a + `build_tessellation()` result and to pass its `$boundary`, as + `make_folds(blocks = )` already did for `$cells`; + `create_grid_polygons()`, `create_grid_polygons_cached()` and + `ensure_stable_poly_id()` add the same hint to their type errors. + +* **`build_tessellation(method = "triangles")` recorded an `approx_n_cells` + it had ignored.** `params$approx_n_cells` held the ignored count where + the help page says the count used is kept; it is now `NULL`, as for + Voronoi, and the warning says so for both methods. + +* **`summarize_by_cell(deff = "variogram")` said it was "Falling back to + deff = 1" for a rejected `sac`, and then applied a design effect.** A + `sac` whose fit `estimate_sac_range()` had rejected was set aside with + that warning, after which a variogram estimated from `response_var` was + fitted and applied: in one check every row came back corrected, with a + median design effect of 5.2, and in the development version the warning + carried the fallback class, so `tryCatch(spatialkit_deff_fallback = )` + threw the corrected result away. When the estimate was rejected too, the + one fallback raised two R warnings. A `sac` that an estimate replaces now + gets a plain warning saying what replaced it, and the fallback warning is + raised once per call, only when the standard errors really are the + uncorrected ones, naming every reason, the rejected `sac` included. + +* **`summarize_by_cell(deff = "variogram")` ignored a `sac` that carried no + variogram model without saying so.** A plain number, or + `units::set_units(1.5, "km")`, was passed over and the design effect came + from a variogram estimated from `response_var`, with no condition; the + caller could not tell that the value given had not been used. Such a + `sac` is now set aside with a warning, as a rejected `sac` is: a plain + warning when a variogram is estimated instead, and the classed + `spatialkit_deff_fallback` warning, naming it, when `deff` falls back + to 1. + +* **`summarize_by_cell(deff = "kish")` recorded no correction when only the + predictor standard errors were corrected.** The `"deff_applied"` + attribute followed the primary variable's ICC alone, so with an + unclustered response (ICC 0) and a clustered predictor (ICC 0.82) no + attribute was attached, and in the development version every row said + `deff_applied = FALSE`, while the predictor standard errors had been + inflated elevenfold. The attribute is now attached whenever either ICC is + positive; its `deff` stays the primary variable's (all 1 in that case). + +* **`summarize_by_cell()` corrected the response's standard errors with a + residual variogram without a word.** A `sac` from + `estimate_sac_range(..., predictor_vars = )` describes what the predictors + leave unexplained, a weaker correlation than the response's own: the + response standard errors came out at 0.60 of those from the response + variogram in one check, while `kriging_adequacy()` warned about the same + object. Such a `sac` is still used as given, as documented, but a warning + now says the response standard errors are understated. + +* **`assign_features_to_polygons()` dropped the features' own `id` column + when the cells were keyed by `id`.** The polygons' ID went through the + spatial join under its own name, so a site `id` collided with the cells' + `id` and was dropped, with a warning about a collision the result never + had: it only gains `polygon_id_col`. Only a column named `polygon_id_col` + is replaced now. + +* **`assign_features_to_polygons(largest = TRUE)` let the polygon row order + decide an exact tie in overlap.** sf keeps the first of equal largest + overlaps, so a 40 m square split evenly across the edge of cells 1 and 2 + went to cell 1, or to cell 2 with the polygon rows reversed. An exact tie + (areas equal to 9 significant digits) is now decided by `tie_break` among + the equally largest polygons, and counted in `attr(, "ties")`. + +* **Every largest-overlap assignment of polygon features raised sf's + "attribute variables are assumed to be spatially constant" warning.** + `sf::st_join(largest = TRUE)` adds grouping columns of its own before + intersecting, so the warning came with every ordinary call (the reporting + vignette hid it with `warning = FALSE`), said nothing about the data, and + could not be avoided with `st_agr()`. That warning alone is now muffled. + +* **`summarize_by_cell(deff = "variogram")` accepted a `deff_max_n` of + less than 2.** A value of 1 or 0 subsampled every cell to one point or + none, so the mean correlation came out `NaN`, the design effect 1 and the + standard errors uncorrected (4.1 times smaller than with the default in + one check) with nothing to say so; `NA` stopped the call with "missing + value where TRUE/FALSE needed". It must now be a single number of at + least 2, and anything else is an error that names it. + +* **The rows with no cell ID got a `cell_weight` of 0.** A layer assigned + with `keep_unassigned = TRUE` is summarised with its unassigned rows as a + group whose ID is `NA`, and `summarize_by_cell()` lost that group's count + of non-missing values: `cell_weight` was 0 beside `n = 5` and a finite + standard error. The group is now counted like any other. + +* **`attr(, "deff_applied")$deff` turned into a vector of `NA`s for a fixed + `deff` and one populated cell.** With `cells_sf`, the realignment to the + joined rows took a fixed `deff = 2` for a per-cell vector whenever exactly + one cell was summarised, and recorded `c(2, NA, NA, ...)`. A fixed design + effect is now recorded as the number. + +* **`make_folds(method = "block_kfold")`'s refusal of a grid above 1,000,000 + blocks told the caller to check a `block_size` they never passed, and a + `block_size` hundreds of orders of magnitude too small slipped past it.** + With `block_nx = 2000, block_ny = 1000` (or `block_multiplier = 1e6`) the + error read "Check that `block_size` (unset) is expressed in the data's CRS + units". With `block_size = 1e-200` the cell count overflowed to `Inf`, + which the guard let through, and `st_make_grid()` failed with "result + would be too long a vector". The message now names what produced the + grid: `block_size`, the range `auto_range` estimated, + `block_nx`/`block_ny`, or `block_multiplier` x `k`. A count too large to + represent is refused like any other. + +* **`make_folds()` accepted any `block_multiplier`, and a `units` object for + `phi` or `min_train` failed with an error that named no argument.** + `block_multiplier = NA` died inside `st_make_grid()` with "'length.out' + must be a non-negative number". `c(1, 3)` silently used 3, and + `units::set_units(100, m)` was read as 100, giving a 32 x 16 grid aimed at + 500 blocks. `phi = units::set_units(100, m)` failed inside the units + package with 'both operands of the expression should be "units" objects'. + `block_multiplier` must now be a single positive number, and `phi` and + `min_train` refuse a `units` object by name, as `block_size`, `buffer` and + `block_nx`/`block_ny` already did. + +* **`residual_morans_i()` and `compare_models()` had no residual Moran's I + for a custom fit without a `residuals()` method.** `?new_spatial_fit` + says `residuals()` is optional, and such a fit falls through to + `residuals.default()` and gets `NULL`, so `residual_morans_i()` returned + `NULL` with a warning and `compare_models()` reported all-`NA` + `resid_morans_*` columns. On 80 points with an east-west trend the + predictor could not explain, that hid a residual Moran's I of 0.754 (z = + 15.5, p = 4e-54). Such a fit is now scored on the observed response minus + `fitted()`, which is what the built-in backends' residuals are and what + `plot()` already used for it. `NULL` is returned only when that cannot be + formed either, and the warning quotes the reason. + +* **Re-using a `cv_*()` result's `$folds` renumbered every fold after a + dropped one.** The result's `$folds` holds the splits that survived, each + carrying the `fold_id` it was reported under, so five folds with fold 3 + dropped are labelled 1, 2, 4 and 5. Handed to a second `cv_*()` call, to + score another learner on the same splits, they were numbered by position + as 1, 2, 3 and 4, so the second run's fold 3 was the first run's fold 4 + (RMSE 2.90 in both), and a join on `fold` with the first run or with + `fold_separation()` paired different folds. Splits that carry a distinct + whole-number `fold_id` now keep it. Splits without one are still numbered + by position, as are splits whose ids repeat. + +* **A `fold_info_fn` whose `..per_row` reused a `predictions` column name + corrupted `predictions`.** A `..per_row` column called `yhat` (or `y`, + `fold`, `..row_id` or `y_train_mean`) was bound on beside the original, + and `predictions` came back with two `yhat` columns. In the development + version, `dplyr::bind_rows()` then renamed both (`yhat...4`, `yhat...6`) + with only a message, so `overall` found no `yhat` and was all `NA` with + `n_pred = 0`, beside per-fold RMSEs of 2.4 to 3.4 and no warning. Such a + name is now an error naming the column, as a clashing scalar extra already + was. Duplicated or empty `..per_row` names are errors too, in a parallel + run as in a sequential one. + +* **A `fold_info_fn` that returned a named vector lost its values without a + word.** `c(slope = 1.9)` in place of `list(slope = 1.9)` (the shape + `metrics` accepts) added no column, and `fold_status` read `"ok"` with an + empty message on every fold. A named vector is now taken as the list it + stands for. Any other return value that is not a list or `NULL` (a + function, an environment) is now an error. + +* **Folds built on a pointized copy of a polygon layer were refused as + "built from different data".** `make_folds(coerce_to_points(parcels))` + applied to `parcels` itself, with the same rows and IDs, was refused on 80 + L-shaped parcels because "64 of 64 checked row IDs sit at a different + location here". The error blamed "folds from another dataset". The + provenance check compares each polygon's centroid with the point + `coerce_to_points()` gave it, and under `"auto"` that is + `st_point_on_surface()`, which differs for every non-convex feature. The + folds' `params$row_probe` now records whether they were built on POINT + geometry. When that differs from the data, the error says so and tells + you to build the folds with `make_folds()` on the layer passed, which + reduces polygons to points itself. Folds from data that really differs + get the old message. + +* **`evaluate_insample()` returned `NULL` when no element of `fits` was a + `spatial_fit`.** Its help promises a data frame with one row per model, + and the only sign that every element had been skipped was a log line per + element, which `spatialkit_quiet()` hides and `tryCatch(warning = )` never + sees. It is now an error that names `fits`. + +* **`cv_rf(parallel = )` printed its core-count message twice when asked for + more workers than the machine has.** `cv_rf(parallel = 16)` on a 4-core + machine printed "cv parallel: 16 workers requested on a machine with 4 + cores; using 4." twice. It resolved the count once for its thread policy + and once more when the folds ran. It now prints the message once. + +* **`fit_gwr_model()` called local regressions unstable because of where a + predictor's units start.** A temperature field in kelvin beside a second + predictor drew "global design (intercept + predictors) has scaled + condition index 230 ... (collinearity risk)" and "100% of 30 sampled + locations have a collinear local design ... Local regressions there are + unstable", while the same field in degrees C drew no global warning and 6 + of 30; the local slopes of the two fits agree to 1e-10. Both indices were + computed on the uncentred design, where a predictor far from 0 against its + spread (kelvin, a year, elevation in feet) is collinear with the + intercept. That makes the local intercept an extrapolation to 0, but a + slope's precision does not depend on where the predictor's origin is. The + global index is now computed on the centred predictors, so it is 1 for a + single predictor and a change of origin does not move it. The local + survey keeps Belsley's uncentred index with the intercept as + `info$local_collinearity$cn` and adds `cn_slopes`: the predictors centred + at their weighted mean in the window, each divided by its standard + deviation over the study area. A window's slopes count as collinear when + `cn_slopes` is above 30 or singular, or when `cn` is above 1e6, where + GWmodel's uncentred solve starts losing precision in the slopes. + `n_local_collinear` and the warning count those windows. The kelvin and + degrees C fits now get the same verdict (0 of 200 locations), and a + regional covariate nearly constant within clusters is still flagged + everywhere (200 of 200). A window where only `cn` is above 30 is logged, + not warned about. + +* **`gwr_model_selection()` checked an adaptive bandwidth less strictly than + `fit_gwr_model()`.** `bandwidth = 3e9` with `adaptive = TRUE`, a distance + passed as a neighbour count, failed with "NAs introduced by coercion to + integer range" and then a bare "missing value where TRUE/FALSE needed". + `bandwidth = 0.5` was rounded to 0 neighbours and quietly raised to the + floor, where `fit_gwr_model()` refuses it. `gwr_model_selection()` now + runs `fit_gwr_model()`'s check before it prepares anything: an adaptive + count must be at least 1 and at most R's largest integer. `cv_gwr()` runs + the same check once, up front, instead of failing it in every fold and + returning "all folds failed". + +* **`gwr_model_selection()` with a fixed bandwidth in the wrong units failed + with a bare "inv(): matrix is singular".** On lon/lat data projected to + EPSG:32617, `bandwidth = 0.2, adaptive = FALSE` is 0.2 metres against an + extent of 44720 metres, so every window is empty. `fit_gwr_model()` + warned about exactly this and explained the singular window, but the sweep + said nothing. It now raises the same "less than a ten-thousandth of the + data's extent" warning, and its error explains a singular window as + `fit_gwr_model()`'s does. + +* **`print()` on a GWR fit showed a fixed bandwidth in scientific notation + and without its unit.** A fixed bandwidth of 122372 m printed as + "Bandwidth: 1.224e+05 (fixed, bisquare kernel)", so the value was rounded + to four digits and its unit was missing, although the help page tells the + reader to check it. It now prints "122,372 metre (fixed, bisquare + kernel)", and an adaptive one as "42 neighbours (adaptive, ...)". + +* **`fit_gwr_model()` did not refuse a character or factor response, as the + README says every model function does.** A response read from a CSV as + text went into `GWmodel::bw.gwr()`, which failed twice with "Not + compatible with requested type". That drew the arbitrary-fallback + bandwidth warning, and the fit then stopped with "'x' must contain finite + values only", naming neither the column nor the cause. It now stops first + with "response 'zc' is not numeric (it is character)", as `fit_rf_model()` + and `fit_bayesian_spatial_model()` do. + +* **`cv_bayes()` under an ordinal or categorical family sampled every fold + and then scored none of them.** Such a family predicts a probability per + response category, and cross-validation scores one number per row, so each + fold compiled and sampled a full model and was then discarded: under + `brms::cumulative()`, `k = 2` on 50 rows took 4.35 minutes to return "all + 2 folds failed to produce predictions". `cv_bayes()` now refuses + `brms::categorical()` and the ordinal families (cumulative, sratio, + cratio, acat) before fitting anything, with a message naming the family, + and the "Which metrics survive a non-Gaussian response" section (in + `?model_metrics`, `?cv_bayes` and `?compare_models_cv`) no longer calls + CRPS and interval coverage meaningful for "any family the backend + accepts". + +* **`predict_surface()`'s automatic grid left up to a cell of the training + extent uncovered on the east and north.** It took + `floor(extent / cell_size)` cells from the lower-left corner, so whenever + the extent was not a whole number of cells the rest of it got no + prediction. `cell_size = 100` on a 980 x 956 extent covered 900 x 900: + 13.5 percent of the box was uncovered, and 14 of 120 training points lay + in no cell. `cell_size = 334` gave 2 x 2 cells and left 65 of the 120 + points out. The grid now has enough cells to cover the box and is centred + on it. It overhangs the box by less than one cell, split evenly between + the two sides, so every cell centre still lies inside the box. An extent + that is an exact multiple of the cell size gets the same grid as before. + At the default `n_cells`, a grid usually gains one column or row (102 x 99 + cells instead of 101 x 98 on the extent above), and its centres move by + less than half a cell. + +* **`plot_tessellation_map(labels = TRUE)` warned at print on every lon/lat + layer, and failed at print on a units label column.** The label points + were computed with `st_point_on_surface()`, and `geom_sf_text()` ran it + again on those points when the plot was drawn. On longitude/latitude + cells that raised "st_point_on_surface may not give correct results for + longitude/latitude data", although nothing was wrong. A `label_col` + holding `st_area()` values (class units) failed with "units package is not + attached", as a units fill column did. The label points are now used as + computed, and a units or difftime label is drawn formatted, with its unit + (`"15073.393 [m^2]"`). A `fill_col` or `label_col` naming more than one + column, or `NA`, is now refused by name. It used to fail with R's + "'length = 2' in coercion to 'logical(1)'". ## Documentation @@ -837,10 +2686,12 @@ and Talbot 2010) --- not a performance estimate of the selected model. The honest estimate comes from running the selection inside `cv_spatial()`'s `fit_fn`, which the page now spells out. -* `fit_bayesian_spatial_model()` documents that `family =` accepts any - `brms` family --- zero-inflated and hurdle counts, negative binomial, - Bernoulli, beta and ordinal responses all reach `brms::brm()` with the - spatial GP term intact --- and gains a worked zero-inflated Poisson example. +* `fit_bayesian_spatial_model()` documents which `brms` families `family =` + takes --- zero-inflated and hurdle counts, negative binomial, Bernoulli, + beta, ordinal, categorical and mixture families all reach `brms::brm()` + with the spatial GP term intact, and a factor response is taken only + under `categorical()` and the ordinal families --- and gains a worked + zero-inflated Poisson example. The same page now records a trap: a family object `brms` cannot name skips the response-type check entirely rather than falling back to the gaussian rule, so a malformed `family` buys less validation, not more. @@ -871,6 +2722,226 @@ which builds folds where this one runs them, and that `blockCV`'s `$folds_ids` is accepted directly as `folds` everywhere. +* `?determine_optimal_levels` no longer calls the Cliff and Ord moments + behind Moran's z exact: they assume cell means of equal variance, and with + single-point cells beside cells of 70 or more points `z` ran slightly high + (mean 0.2--0.34, 7--8% rejection at 5%); `resolution_profile()` says + `cell_diam_median` is about 0.8 of the side of an equal-area square cell, + not a width (and `vignette("resolution")` no longer calls it one); the + Post-selection inference section and the vignette say that the estimation + rows of a split leave cells in the selection half empty and cells across + the border estimated from part of their points (coverage 0.88 against + 0.97 in simulations), and how to find the cells to trust; `sac_nugget()` + says the nugget is extrapolated from the first lag bin (about + `max_dist / 30` at the default cutoff), not observed below the closest + pair, and can be exactly 0 at the fit's bound. + +* The tessellation help pages are corrected: `clip_target_for()` returns + the points' bounding box, not their convex hull, and is not the target + `build_tessellation(method = "voronoi")` derives; + `create_voronoi_polygons()` and `build_tessellation()` say that a + multi-vertex MULTIPOINT feature gets one cell per vertex and that + `keep_duplicates` has no effect; `voronoi_seeds_random()` tops a short draw + up to exactly `k`; `voronoi_seeds_kmeans()` and `get_voronoi_seeds()` say + that their `stats::kmeans()` partition is not the k-means++ one + `resolution_profile()` scored, and no longer promise equal counts per + cell. + +* Documentation corrected: `summarize_by_cell()`'s `sac` no longer + identifies a rejected fit by a `status` attribute no `sac_range` carries + (it is an `NA` value with a `rejected_reason`), and says a rejected `sac` + is set aside and the variogram estimated as if none had been given; + `ensure_stable_poly_id()` and the reporting vignette say IDs are the same + across projections except for fine cells within the rounding step of one + longitude (36 of 2,500 100 m cells via EPSG:3035), not always; + `summarize_by_cell()`'s "Confidence intervals" says `..neff_*` is `NA` for + a single observation; the resolution vignette says the blocked split + reduces the leak between halves rather than removing it. + +* `?estimate_sac_range` now says that the exponential model is kept + whenever it converges and so overestimates the range on smoother fields + (about 1.8--2.1 times a Gaussian practical range, 1.3--1.4 times a + spherical one), and why the family is not chosen by fit (that biases + exponential fields low, to 0.82); that 15 lag bins make a range spanning + one or two of them come out long (60 m returned 89--102 m); that nothing + tests for spatial structure (white noise gave a finite range in 8 of 30 + draws); that the "decreases with distance" refusal also fires on small + samples of ordinary fields (7--9 of 60 at n = 30, 0--1 at n = 100), which + its warning now says below 100 points; that the anisotropy note goes to + the log file at INFO, not the console, and that the longest directional + range is read from `directional_fitted` after checking + `directional_status`, not `max(attr(, "directional"))`, which is `NA` + exactly when the major axis ran past the fitted lags (the note itself, the + nc_demo vignette and the help now say so); that an accepted range can + still exceed half the width of the layer, leaving + `make_folds(auto_range = TRUE)` room for one block (`range_frac`); and a + flat variogram's refusal message no longer claims the data "never reached + a sill" without mentioning that a structureless variogram ends there too. + The README counts six refusals, not five. + +* `?make_folds`: the NNDM details now say how the procedure differs from + `CAST::nndm()` (a strict removal rule, one point more conservative per + distance value, and ties broken by coordinates rather than row index) + instead of calling it the same; the n > 5000 refusal gives the worst-case + cost, O(n^3) time where `min_train` binds (about nine minutes at + n = 3000), not O(n^2); `drop_empty_blocks`, `boundary` and + `block_multiplier` say what they do on the cases above. + +* `?cv_rf` no longer says a `seed` passed through `...` overrides the + per-fold forest seed (`seed` is the function's own argument and never + reaches `...`); `?cv_bayes` says `parallel = n` compiles `n` Stan models at + once, at several GB each, and what a fold killed for memory reports; + `?residual_morans_i` and `?compare_models` say their methodological + cautions are logged, not raised as warnings. + +* `?fit_gwr_model`'s "Collinearity diagnostics" section described the + 30-location unweighted spot check the survey replaced, a global index on + the predictors alone, and a caveat that only a subset of locations is + examined; it now describes the code (every location, kernel-weighted, a + global index on the centred predictors, and at each location one index + with the intercept and one for the slopes alone). `?fit_gwr_model` and + `?gwr_model_selection` now state the adaptive bandwidth's floor and cap. + +* `?fit_bayesian_spatial_model`: `check_convergence` says the checks write + WARN log lines and set `$info$convergence_ok` rather than "issue warnings", + and that under cmdstanr nothing is raised as an R warning; the basis + adequacy check is described as logged, and as changing neither + `convergence_ok` nor `print()` (the argument's text listed it among the + checks that set `convergence_ok` to `FALSE`); the `family` argument and + the non-Gaussian section no longer promise that any response type brms can + fit works here; the spatial confounding section warns that coefficients + under `standardize_predictors = TRUE` are per standard deviation before + comparing with `lm()`. `?coef.bayesian_fit` gains a section on + standardised predictors, and `print()` on such a fit names them. + `?fitted.bayesian_fit` no longer says a failed posterior draw returns `NA` + (it has been an error since before this release). + `?gp_lengthscale_bounds` says its bounds are the prior's calibration range + and do not shrink with `n`. + +* `?area_of_applicability` states the outlier rule (type-7 quartiles) and how + the threshold differs from CAST's (the fence itself, capped at the largest + training DI, which is larger whenever `n_outliers > 0`), with the + `threshold =` value that reproduces it; the internal note that CAST uses + `boxplot.stats()` was out of date, and the package page no longer implies + the threshold matches CAST. `n_new` is documented as every row of + `newdata` (`n_inside + n_outside + n_na`), not the rows that passed the + finite-value filter. `?predict_surface` and the README say that + `se = TRUE` on a `bayesian_fit` gives the SD of the mean surface and that + `type = "predict"` gives the predictive SD. + +* The diagnostics vignette's area-of-applicability figure alt text no longer + calls the training curve cross-validated (no folds are passed there); + `?plot.aoa` and `?plot.feature_selection` describe the training DI and the + rejected last step as drawn. + +* The examples that stamp EPSG:32632 (UTM zone 32N) on simulated points now + put the points inside that zone. The README quick start, the + `fold_separation()` example, the resolution, diagnostics and spatial + cross-validation vignettes, and the fixture the scripts in `inst/scripts/` + share placed them at x and y between 0 and 1000, which is on the equator + about 4.5 degrees east, outside the zone. They are now offset by 500000 m + east and 5000000 m north, as the other examples already were. Every + printed result is unchanged, since the package works in planar units; only + the coordinates themselves, and the graticule on the maps, differ. + +* The examples of `resolution_profile()`, `select_resolution()`, `summary()` + and `plot()` on a profile use `set.seed(4)`, on which their comments hold + (C_p interior at 28 cells, reliability on the range floor); with + `set.seed(2)` C_p had moved to the support ceiling. The `plot()` example + no longer promises four panels on points that have no elbow. + +* Tour script 02 runs to the end again: step 02.6 drew the elbow's pick, + which its evenly spread points no longer have, and now draws the C_p pick. + It prints the bound each criterion's optimum sits on, points to + `min_cell_n` and `range_floor` rather than `n_levels` for moving one, and + computes what the `select_on = "split"` comparison shows (both picks on + the range floor) instead of calling the difference tuning. Script 08 no + longer calls its held-out half untouched or its score gap the selection + effect, and says its block size of 300 is under the range of about 357. + +* The README's resolution figure labels its middle count as the one + `resolution_profile()` rates most reliable, with the width of that + criterion's flat region; it was `determine_optimal_levels()`'s count, + which on those evenly spread sites the function now says the ladder chose. + The troubleshooting entry quotes the fallback messages + `determine_optimal_levels()` now gives, with their causes. + +* The resolution vignette's criteria table describes the elbow as the + log-log sag it is, `NA` on points with no cluster structure, and its + introduction says `determine_optimal_levels()` still returns a count + there, with a warning. + +* `?coerce_to_points` (`tmp_project`) states the rule a CRS-less layer is + read by: the lon/lat heuristic of `ensure_projected()`, not merely lying + inside the lon/lat envelope. + +* `?summarize_by_cell` now gives the derivation and the measured coverage of + the small-sample rescaling that goes with every data-derived design + effect, which the package page said were there; the package page lists it + among the defaults that were chosen, not cited. + +* `?estimate_sac_range` now says when the directional maximum is logged + (only when it stands in for a singular or non-converged all-pairs fit, at + WARN only above a ratio of 1.5, naming the directional ranges), and that a + range shorter than the first lag bin can come back several times too long + (a true 24 m returned 93--479 m at n = 1500, 19--32 m at `cutoff = 0.1`), + so a variogram at its sill in the first one or two bins calls for a + smaller `cutoff` whatever range was fitted. + +* `?make_folds` no longer says `auto_range` "fits directional variograms to + account for anisotropy". It sizes blocks from the omnidirectional range, + and for a field known to be anisotropic the page now points to + `directional_fitted`. An accepted range too wide for two blocks makes + `make_folds()` stop with an error, which the page now says; it had claimed + the grid "does not collapse to a single block". The log line announcing a + lowered `k` just before that error is gone. The page no longer says NNDM + never pushes a point's nearest-neighbour distance past `phi`: the last + exclusion can take it past by one neighbour step, as in `CAST::nndm()`. + The description lists all five methods. The page now says that `k = 1` is + raised to 2 by the three k-fold methods, and that only `block_kfold` + returns `params$blocks_supplied` and `params$boundary_supplied`. + +* The README's entry for "response 'y' is not numeric" notes that + `fit_bayesian_spatial_model()` takes a factor or character response under + `brms::categorical()` and the ordinal families. + +* The README, `?summarize_by_cell` and the getting-started, diagnostics, + reporting and North Carolina vignettes now say which estimand the + design-effect-corrected standard error is for. It is the standard error + of a cell mean as an estimate of the population mean. For a cell's own + mean, which is what a map reports, the default `deff = 1` standard error + is the right one when the points are spread through the cell. Several of + these pages had presented the correction as the right standard error for + the cells themselves, and there it is too wide by `sqrt(deff / (1 - rho))` + (4.6 at 20 points a cell and `rho = 0.5`). The getting-started pipeline, + which maps the cells, now aggregates at `deff = 1`. + +* Smaller corrections: the README's troubleshooting list adds + `"compare_models_cv(): no recognised model requested."`, which is the + error when no requested name is recognised, and says that + `"no viable models."` means every recognised backend is uninstalled. The + getting-started install table no longer says `patchwork` is needed for the + `plot_*()` functions. The North Carolina vignette explains why some + local designs of its GWR fit have a high condition index with the + intercept (an uncentred `elevation`, nearly collinear with the intercept + inside each window), and why the fit raises no collinearity warning: the + slope index stays below 30, so the slopes are well determined and only + the local intercepts are not. Its fold-map alt text now describes each + blocked fold as whole blocks in separate parts of the state, not as one + contiguous area. + +* `vignette("diagnostics")`: the "Two ways to leak" example of selection + inside the folds leaked itself (blocks about 250 m across against an + autocorrelation range of about 330 m) and its learner could not fit the + intercept-only model, so `tol` did not apply to the first variable. It + now passes `block_size = 400`, fits `z ~ 1` for an empty predictor set, + and shows `sel$history`. + +* `?fit_rf_model` recommended + `area_of_applicability(weights = pmax(fit$info$importance, 0))` without + condition. It now says this works only when that importance is finite, + which it is not when no row is out of bag. + # spatialkit 2.0.0 Everything below is relative to **1.0.0** (published on CRAN 2026-08-07). diff --git a/R/area-of-applicability.R b/R/area-of-applicability.R index 604bb3b..fe79bab 100644 --- a/R/area-of-applicability.R +++ b/R/area-of-applicability.R @@ -180,15 +180,56 @@ stop("area_of_applicability(): `weights` has no entry for: ", paste(sQuote(missing_w), collapse = ", "), call. = FALSE) w <- weights[vars] - if (anyNA(w) || any(!is.finite(w)) || any(w < 0)) + # A non-finite weight got the negative-weight advice, pmax(importance, 0), + # which keeps NaN: a forest with no out-of-bag rows has NaN permutation + # importance, and following the hint reproduced the same error. + bad <- !is.finite(w) + if (any(bad)) + stop(sprintf("area_of_applicability(): `weights` is %s for %s.%s", + if (all(is.nan(w[bad]))) "NaN" else "not finite", + paste(sQuote(names(w)[bad]), collapse = ", "), + if (any(is.nan(w[bad]))) + paste0(" Permutation importance is NaN when no row is out ", + "of bag (a forest grown with replace = FALSE and ", + "sample_fraction = 1), and pmax() keeps NaN; refit ", + "with out-of-bag rows (replace = TRUE or ", + "sample_fraction < 1), or pass weights = NULL.") + else ""), call. = FALSE) + if (any(w < 0)) stop("area_of_applicability(): `weights` must be finite and non-negative. ", "Permutation importance is slightly negative for predictors that do ", "not help, so pass pmax(importance, 0).", call. = FALSE) - if (all(w == 0)) - stop("area_of_applicability(): all `weights` are zero.", call. = FALSE) + w <- .aoa_equal_if_all_zero(w) w * (length(w) / sum(w)) } +#' Replace all-zero weights with equal ones +#' +#' The advice above, \code{pmax(importance, 0)}, is all zero whenever the +#' model found no predictor useful, which a forest with one predictor does +#' often (9 fits in 20 when that predictor carried no signal). That used to +#' be an error, and it lost the AOA in exactly the folds where the predictor +#' was weakest. With ONE predictor the weight cannot matter: the index is +#' invariant to the scale of the weights, so zero is just a degenerate way of +#' writing any positive value, and it is accepted silently. With several, +#' all-zero weights say nothing about how the predictors compare, so they are +#' weighted equally, as \code{weights = NULL} would, with a warning. +#' +#' @keywords internal +#' @noRd +.aoa_equal_if_all_zero <- function(w) { + if (length(w) == 0L || any(w != 0)) return(w) + if (length(w) > 1L) + .warn_and_log(paste0("area_of_applicability(): every weight is zero (%s), ", + "which says nothing about how the predictors compare; ", + "weighting them equally, as weights = NULL does. ", + "pmax(importance, 0) is all zero when the model found ", + "no predictor useful."), + paste(names(w), collapse = ", ")) + w[] <- 1 + w +} + #' Minimum distance from each query row to any data row #' @@ -218,6 +259,10 @@ # against the quantity it is divided by. if (is.null(chunk_size)) chunk_size <- max(1L, min(10000L, as.integer(floor(4e6 / max(1L, nd))))) + # A whole number of rows per block. A fractional chunk_size gave fractional + # block starts, the s:e ranges below truncated, and the rows between blocks + # kept the 0 they were initialised with: a DI of 0, inside the AOA. + chunk_size <- max(1L, as.integer(chunk_size)) out <- numeric(nq) dsq <- rowSums(data^2) for (s in seq.int(1L, nq, by = chunk_size)) { @@ -276,9 +321,15 @@ #' VALUES and resolved to row positions with \code{match()}; when #' \code{NULL} they are treated as positions, as before. Fold labels are #' always positional: they are one label per row by definition. +#' @param removed_ids Optional \code{..row_id} values of rows that +#' \code{prep_model_data()} removed from the training data (read from its +#' \code{"dropped"} record). They are taken out of every train and test +#' slot before the IDs are resolved, as \code{.remap_folds()} does for +#' \code{cv_*()}, and a fold left with no test row is dropped. Any other +#' unknown ID is still an error. #' @keywords internal #' @noRd -.aoa_fold_splits <- function(folds, n, row_ids = NULL) { +.aoa_fold_splits <- function(folds, n, row_ids = NULL, removed_ids = NULL) { if (is.null(folds)) return(NULL) if (is.atomic(folds) && !is.list(folds)) { @@ -286,24 +337,18 @@ stop(sprintf(paste0("area_of_applicability(): `folds` has %d labels but ", "the training data has %d rows."), length(folds), n), call. = FALSE) - # droplevels() matters: a factor subset from a larger data set keeps its - # unused levels, and each one would otherwise become an empty fold that - # inflates the reported fold count and reaches .aoa_min_dist() with no - # test rows. - f <- droplevels(as.factor(folds)) - if (anyNA(f)) - stop("area_of_applicability(): `folds` contains missing labels.", - call. = FALSE) - if (nlevels(f) < 2L) - stop("area_of_applicability(): `folds` must define at least two ", - "non-empty folds.", call. = FALSE) - # Fall through to the shared validation below rather than returning here, - # so label-built splits get the same checks as hand-built ones. - sp <- lapply(levels(f), function(lv) { - te <- which(f == lv) - list(test = te, train = setdiff(seq_len(n), te)) - }) - # which() already returns positions, so there is nothing to resolve. + # Labels are grouped and numbered by .folds_from_labels(), the helper + # every cv_*() uses, so fold k here is fold k in a cv_*() result built + # from the same labels: numbers in numeric order, a factor by its own + # used levels, anything else in C (radix) order. A copy of that rule + # here drifted: two doubles that print alike (0.3 and 0.1 + 0.2) stopped + # with R's "factor level [2] is duplicated" where cv_*() made them one + # fold. The helper also refuses missing labels and fewer than two + # non-empty folds. With ..row_id = 1..n its IDs are row positions, so + # there is nothing to resolve. Fall through to the shared validation + # below, so label-built splits get the same checks as hand-built ones. + sp <- .folds_from_labels(folds, data.frame(..row_id = seq_len(n)), + "area_of_applicability") row_ids <- NULL } else { sp <- if (is.list(folds) && !is.null(folds$folds)) folds$folds else folds @@ -319,6 +364,41 @@ "list of train/test splits, or a vector of fold labels.", call. = FALSE) + # Folds built on the layer a model was fitted from name every row of it, + # including those prep_model_data() then removed (a missing response, a + # non-finite predictor, an empty geometry). cv_*() drops such IDs from the + # splits (.remap_folds()); here they were resolved against the shorter + # training data and every one of them stopped the call with "refers to rows + # outside 1:n" -- for the same folds cv_*() had just accepted. Drop them, + # and say how many. + if (length(removed_ids) && !is.null(row_ids)) { + named <- unique(unlist(lapply(sp, function(z) c(z$train, z$test)), + use.names = FALSE)) + n_hit <- sum(named %in% removed_ids) + if (n_hit > 0L) { + sp <- lapply(sp, function(z) { + z$train <- z$train[!(z$train %in% removed_ids)] + z$test <- z$test[!(z$test %in% removed_ids)] + z + }) + no_test <- vapply(sp, function(z) length(z$test) == 0L, logical(1)) + .log_info(paste0("area_of_applicability(): `folds` name %d row(s) that ", + "prep_model_data() removed from the training data ", + "(missing or non-finite values, or an empty geometry); ", + "they were dropped from every fold%s."), + n_hit, + if (any(no_test)) + sprintf(", and the %d fold(s) left with no test row with them", + sum(no_test)) + else "") + sp <- sp[!no_test] + if (length(sp) == 0L) + stop("area_of_applicability(): no fold has a test row left once the ", + "rows prep_model_data() removed are taken out of `folds`.", + call. = FALSE) + } + } + # Every make_folds() branch emits ..row_id VALUES in its train/test slots, as # its @return documents, and those coincide with row POSITIONS only when the # training data had no pre-existing ..row_id column. cv_gwr(), cv_bayes() @@ -334,7 +414,10 @@ stop(sprintf(paste0("area_of_applicability(): fold %d's %s set names %d ", "..row_id value(s) that are not in the training data ", "(first: %s). `folds` was built on a different data ", - "set, or on rows that have since been removed."), + "set, or on rows that have since been removed other ", + "than by prep_model_data(), whose removals are ", + "dropped from the folds while the training data ", + "carries its \"dropped\" record."), j, slot, sum(is.na(pos)), format(v[is.na(pos)][1L])), call. = FALSE) as.integer(pos) @@ -349,7 +432,11 @@ stop(sprintf(paste0("area_of_applicability(): fold %d refers to rows ", "outside 1:%d. `folds` was probably built on a ", "different data set, or on data carrying its own ", - "..row_id."), j, n), call. = FALSE) + "..row_id. (Rows prep_model_data() removed are ", + "dropped from the folds when the training data ", + "carries its \"dropped\" record, as a fit's data_sf ", + "does; a subset or a re-ordering of it does not.)"), + j, n), call. = FALSE) if (length(te) == 0L) stop(sprintf("area_of_applicability(): fold %d has an empty test set.", j), call. = FALSE) @@ -382,6 +469,104 @@ } +#' Line the folds up with a training layer prep_model_data() removed rows from +#' +#' A fit's \code{data_sf} is the \code{prep_model_data()} output: rows with a +#' missing or non-finite modelling value or an empty geometry are gone, and +#' it carries no \code{..row_id} unless its input did. Folds built on the +#' layer the model was fitted FROM -- the ones passed to \code{cv_*()} -- name +#' the input's rows. The \code{"dropped"} record says which those were, so +#' the input's row IDs of the kept rows can be rebuilt: positions when the +#' input had no \code{..row_id} (make_folds() numbers the rows then), the +#' recorded IDs otherwise. +#' +#' When the training data carries \code{..row_id}, list-shaped folds are +#' resolved by ID already, and only the removed rows' IDs are needed. +#' Without it, the IDs of folds built on the training data itself are its +#' row positions, \code{1:n}; folds built on the layer fitted from name that +#' layer's rows, and so name a row past \code{n} whenever a row before its +#' end was removed (a trailing row's removal leaves the numbering the same). +#' So a fold list naming a row past \code{n} is read in the input's +#' numbering, and one that does not is left as positions. A label vector +#' with one label per input row is cut down to the kept rows; one with one +#' label per training row is left alone. +#' +#' @return A list: \code{folds}, \code{row_ids} (the training rows' IDs, or +#' the \code{row_ids} given) and \code{removed_ids} (the IDs of the removed +#' rows, or \code{NULL}). +#' @keywords internal +#' @noRd +.aoa_rows_for_folds <- function(folds, train_sf, row_ids) { + out <- list(folds = folds, row_ids = row_ids, removed_ids = NULL) + rec <- if (is.data.frame(train_sf)) .get_row_record(train_sf, "dropped") else NULL + n_rm <- suppressWarnings(as.integer(rec$n %||% 0L)) + if (is.null(rec) || length(n_rm) != 1L || is.na(n_rm) || n_rm < 1L) + return(out) + n <- as.integer(nrow(train_sf)) + n_in <- n + n_rm + kept <- setdiff(seq_len(n_in), as.integer(rec$which)) + # A record that does not add up describes other rows; ignore it. + if (length(kept) != n) return(out) + if (is.atomic(folds) && !is.list(folds)) { + if (length(folds) == n_in) { + .log_info(paste0("area_of_applicability(): `folds` has one label per row ", + "of the layer the model was fitted from; the %d label(s) ", + "of the row(s) prep_model_data() removed were dropped."), + n_rm) + out$folds <- folds[kept] + } + return(out) + } + if (!is.null(row_ids)) { + if (length(rec$row_id)) out$removed_ids <- rec$row_id + return(out) + } + sp <- if (is.list(folds) && is.list(folds$folds)) folds$folds else folds + named <- if (is.list(sp)) + suppressWarnings(as.numeric(unlist(lapply(sp, function(z) + if (is.list(z)) c(z$train, z$test)), use.names = FALSE))) + else numeric(0) + if (length(named) && any(named > n, na.rm = TRUE)) { + out$row_ids <- kept + out$removed_ids <- as.integer(rec$which) + } + out +} + + +#' The fold provenance check of cv_*(), for area_of_applicability() +#' +#' \code{.check_fold_probe()} on the training data, with its row IDs as the +#' folds are resolved against them. A fit's \code{data_sf} holds the points +#' \code{prep_model_data()} reduced its layer to, so folds built on the +#' polygons it was fitted from carry a probe taken on polygon centroids: the +#' two cannot be compared location by location, and the check is skipped +#' (logged) rather than refusing a documented workflow. +#' @keywords internal +#' @noRd +.aoa_check_fold_probe <- function(folds, train_sf, row_ids) { + probe <- tryCatch(folds$params$row_probe, error = function(e) NULL) + if (!is.list(probe) || !inherits(train_sf, "sf") || nrow(train_sf) == 0L) + return(invisible(NULL)) + tr_points <- tryCatch( + all(sf::st_geometry_type(train_sf, by_geometry = TRUE) == "POINT"), + error = function(e) NA) + if (is.logical(probe$points) && length(probe$points) == 1L && + !is.na(probe$points) && !identical(probe$points, tr_points)) { + .log_info(paste0("area_of_applicability(): `folds` were built on %s ", + "geometry and the training data has %s geometry, so their ", + "row locations cannot be compared; skipping the ", + "provenance check."), + if (probe$points) "POINT" else "non-POINT", + if (isTRUE(tr_points)) "POINT" else "non-POINT") + return(invisible(NULL)) + } + chk <- train_sf + chk[["..row_id"]] <- if (is.null(row_ids)) seq_len(nrow(train_sf)) else row_ids + .check_fold_probe(folds, chk, "area_of_applicability") +} + + #' Reference nearest-neighbour distances for the training data #' #' @keywords internal @@ -416,11 +601,15 @@ #' Outlier-removed maximum of the training dissimilarity index #' #' The threshold is the largest training DI that is not an upper outlier by the -#' usual rule, i.e. the largest value at or below \code{Q3 + 1.5 * IQR}. That -#' is the "(outlier-removed) maximum" of Meyer & Pebesma (2021). CAST obtains -#' it via \code{grDevices::boxplot.stats()}, which uses Tukey's hinges; -#' \code{stats::quantile()} returns the type-7 quantiles, and the two agree -#' closely but not exactly. +#' usual rule, i.e. the largest value at or below \code{Q3 + 1.5 * IQR}, with +#' \code{stats::quantile()}'s default (type 7) quartiles. That is the +#' "(outlier-removed) maximum" of Meyer & Pebesma (2021). CAST, the reference +#' implementation, uses the same type-7 fence since it stopped calling +#' \code{grDevices::boxplot.stats()} (whose upper whisker is this rule on +#' Tukey's hinges), but takes the FENCE itself, capped at the largest training +#' DI, as the threshold. The two agree whenever nothing lies above the fence; +#' otherwise CAST's threshold is the larger. The paper's definition is kept, +#' and the help page says how to reproduce CAST's value. #' #' @keywords internal #' @noRd @@ -479,13 +668,36 @@ #' that holds it out}. That means everything outside its own fold for random #' and block folds, and the smaller training set that buffered and NNDM folds #' actually leave (see the next section). The threshold is then the largest -#' training DI that is not an upper outlier. Prediction points at or below that -#' threshold are inside the AOA. +#' training DI that is not an upper outlier, i.e. not above the fence +#' \code{Q3 + 1.5 * IQR} of the training DI, with the quartiles of +#' \code{stats::quantile()}'s default type 7. Prediction points at or below +#' that threshold are inside the AOA. +#' +#' That is the paper's "outlier-removed maximum". \pkg{CAST}, the reference +#' implementation, computes the same fence with the same quartiles but uses the +#' fence itself as the threshold, capped at the largest training DI. The two +#' agree whenever no training DI lies above the fence (\code{n_outliers} is 0); +#' otherwise \pkg{CAST}'s threshold is the larger, and so is its AOA. (Earlier +#' \pkg{CAST} releases used \code{grDevices::boxplot.stats()}, which gives the +#' rule used here but with Tukey's hinges as the quartiles, so they can also +#' differ when the number of training points is even.) To apply the current +#' \pkg{CAST} rule to the same training DI, pass +#' \code{threshold = min(quantile(res$train_DI, 0.75) + 1.5 * IQR(res$train_DI), +#' max(res$train_DI))} for an earlier result \code{res}. #' #' The DI is invariant to the overall scale of \code{weights}: the numerator #' and the normaliser carry the same factor. Importance values can be passed #' as-is. #' +#' Each training point's reference is its nearest \emph{other} training row, so +#' an exact duplicate in predictor space (repeat visits to a site with static +#' covariates, or covariates read off a raster coarser than the sampling) has a +#' training DI of 0. Once about three quarters of the rows have a twin among +#' their reference rows the threshold is 0, and only exact copies of a +#' training row count as inside. That is logged as a caution; folds that keep +#' the duplicates together (\code{make_folds(method = "leave_location_out", +#' group_var = ...)}), or removing them, give the threshold its meaning back. +#' #' @section The fold scheme changes the answer, and should: #' With \code{folds = NULL} the training reference is each point's nearest #' neighbour anywhere in the training data, which for clustered data is very @@ -502,11 +714,14 @@ #' silently dummy-coded. Predictors whose variance is negligible \emph{relative #' to their own magnitude} (the test is #' \code{sd < sqrt(.Machine$double.eps) * max(abs(x))}, so the same variable in -#' metres and in gigametres is treated identically) are dropped, and a -#' prediction point taking a different value there is a form of extrapolation -#' this index cannot express. Without \code{weights} every predictor counts -#' equally, which overstates dissimilarity along directions the model barely -#' uses. +#' metres and in gigametres is treated identically) are dropped from the +#' distance. A prediction point taking a value there outside the training +#' range (with the same relative tolerance) is extrapolation along a direction +#' the training data never varied in: its scaled distance along it is +#' infinite, so it gets \code{DI = Inf}, is outside the AOA, and a warning +#' gives the count. A point missing that value is judged on the other +#' predictors. Without \code{weights} every predictor counts equally, which +#' overstates dissimilarity along directions the model barely uses. #' #' @section Models fitted with the coordinates as predictors: #' When \code{model} was fitted with \code{include_coords = TRUE} the model @@ -546,16 +761,38 @@ #' mean of the weights you did supply, so location counts about as much as a #' typical predictor. Naming them explicitly overrides that. An unnamed #' vector may have one value per predictor either with or without the two -#' coordinate columns. +#' coordinate columns. Weights must be finite and non-negative, so pass +#' permutation importance as \code{pmax(importance, 0)}. (A forest with no +#' out-of-bag rows, \code{replace = FALSE} with \code{sample_fraction = 1}, +#' has \code{NaN} importance, which \code{pmax()} keeps and which is +#' refused; refit it with out-of-bag rows or use \code{weights = NULL}.) +#' \code{pmax(importance, 0)} is all zero when the model found no +#' predictor useful, and then the weights cannot say anything: with a +#' single predictor any weight gives the same index and zero +#' is accepted; with several, all of them are weighted equally, as with +#' \code{weights = NULL}, and a warning says so. The coordinate default +#' above is the mean of the supplied weights, so a zero weight on the only +#' covariate of a coordinate-using model zeroes the coordinates too, and +#' that equal weighting applies. #' @param folds Cross-validation folds: a \code{\link{make_folds}} result, a #' list of \code{train}/\code{test} splits, or a vector of fold labels with #' one entry per training row. Default \code{NULL} (plain nearest neighbour). +#' The folds you passed to \code{cv_*()}, built on the layer \code{model} +#' was fitted from, may name rows that \code{prep_model_data()} removed +#' (a missing or non-finite value, an empty geometry): as in \code{cv_*()}, +#' they are dropped from the folds, and a label vector with one entry per +#' row of that layer loses theirs. Also +#' as in \code{cv_*()}, a \code{make_folds()} result built on other data -- +#' another layer, or these rows in another order -- is refused. That check +#' is skipped when the folds were built on polygons and the training data +#' are the points a fit reduced them to. #' @param threshold Optional numeric override for the DI threshold. #' @param normalizer_max_n Subsample the training data to this many points when #' computing the mean pairwise distance, which is quadratic. Default 5000. #' @param seed Seed for that subsample. Default 123. #' @param chunk_size Query rows per distance block on the dense path. Default -#' \code{NULL} (chosen from the training size). +#' \code{NULL} (chosen from the training size). Otherwise a single number of +#' at least 1; a fractional value is truncated to a whole number of rows. #' @param use_fnn Use \pkg{FNN} for nearest-neighbour search when available. #' Exposed so the dense fallback can be tested. #' @@ -566,7 +803,9 @@ #' computation ran on, which for a coordinate-using model is #' \code{newdata} after pointizing, CRS reconciliation and the addition #' of the \code{"..x"} and \code{"..y"} columns. A row whose predictors -#' are not all finite gets \code{NA} in both columns. +#' are not all finite gets \code{NA} in both columns, and a row outside +#' the training range of a predictor in \code{dropped_vars} gets +#' \code{DI = Inf} and \code{AOA = FALSE} (see \emph{Limitations}). #' \item \code{threshold}: the DI cut-off used. #' \item \code{train_DI}: the training points' own DI values. #' \item \code{normalizer}: the mean pairwise training distance. @@ -586,8 +825,10 @@ #' aside (the "outlier-removed" in its name); computed whether or not #' \code{threshold} was supplied. #' \item \code{n_train}, \code{n_new}, \code{n_inside}, -#' \code{n_outside}, \code{n_na}: row counts; \code{n_train} and -#' \code{n_new} count the rows that survived the finite-value filter. +#' \code{n_outside}, \code{n_na}: row counts. \code{n_train} counts the +#' training rows that survived the finite-value filter; \code{n_new} is +#' every row of \code{newdata}, so +#' \code{n_new = n_inside + n_outside + n_na}. #' \item \code{params} records the call: \code{folds_supplied}, #' \code{n_folds}, \code{folds_method}, \code{threshold_supplied}, #' \code{normalizer_max_n}, \code{normalizer_n_used}, @@ -672,6 +913,33 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, "installed. Install it with install.packages(\"FNN\"), or pass ", "use_fnn = FALSE to use the dense fallback.", call. = FALSE) + # chunk_size reached seq.int(1, nq, by = chunk_size) unvalidated. A computed + # value such as 1e3 / nrow(train) = 12.5 left some rows of each block at the + # 0 they were initialised with, so extrapolation read as inside the AOA; 0, + # NA or a length-2 vector failed in base R without naming the argument. + if (!is.null(chunk_size)) { + .check_scalar(chunk_size, "chunk_size", "area_of_applicability", min = 1, + max = .Machine$integer.max, what = "a single positive number") + chunk_size <- as.integer(chunk_size) + } + + # Fold train/test slots from make_folds() are ..row_id VALUES, not row + # positions; keep the IDs alongside so .aoa_fold_splits() can resolve them. + tr_meta <- if (inherits(train_sf, "sf")) sf::st_drop_geometry(train_sf) else + as.data.frame(train_sf) + tr_row_ids <- if ("..row_id" %in% names(tr_meta)) tr_meta[["..row_id"]] else NULL + removed_ids <- NULL + if (!is.null(folds)) { + fr <- .aoa_rows_for_folds(folds, train_sf, tr_row_ids) + folds <- fr$folds + tr_row_ids <- fr$row_ids + removed_ids <- fr$removed_ids + # The provenance check cv_*() make: fold splits are row IDs, so folds + # built on another layer of the same size, or on these rows in another + # order, applied silently and moved the threshold. + .aoa_check_fold_probe(folds, train_sf, tr_row_ids) + } + # A model fitted with the coordinates as predictors splits on location, so # the dissimilarity index has to measure location too. Without this, a # prediction point far outside the training extent but with ordinary @@ -708,12 +976,6 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, X_tr_full <- .aoa_matrix(train_sf, predictor_vars, "the training data") X_nw_full <- .aoa_matrix(newdata, predictor_vars, "`newdata`") - # Fold train/test slots from make_folds() are ..row_id VALUES, not row - # positions; keep the IDs alongside so .aoa_fold_splits() can resolve them. - tr_meta <- if (inherits(train_sf, "sf")) sf::st_drop_geometry(train_sf) else - as.data.frame(train_sf) - tr_row_ids <- if ("..row_id" %in% names(tr_meta)) tr_meta[["..row_id"]] else NULL - # Training rows carrying NA or Inf cannot define a reference distance. # complete.cases() alone would let an Inf through, and it would then poison # that predictor's mean and sd, so .aoa_scaling() would drop the whole @@ -741,8 +1003,8 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, if (length(dropped) > 0L) .log_warn(paste0("area_of_applicability(): dropping predictor(s) with no ", "variance in the training data: %s. A prediction point ", - "taking a different value there is extrapolation the ", - "dissimilarity index cannot represent."), + "taking a different value there is extrapolation along ", + "it, and is marked outside the AOA with DI = Inf."), paste(dropped, collapse = ", ")) used_vars <- names(sc$keep)[sc$keep] @@ -756,12 +1018,16 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, # numbers. Multiplying by sqrt(w) instead (contributing w to the squared # distance) is the other defensible reading of "weighted Euclidean" and is # NOT what is used here. - w_vec <- unname(w <- .aoa_weight_vector(weights, predictor_vars, - fill_vars = coord_vars)[used_vars]) + # The weights that matter are those of the predictors kept; if the only + # non-zero ones sat on predictors dropped above, the rest are all zero. + w_vec <- unname(w <- .aoa_equal_if_all_zero( + .aoa_weight_vector(weights, predictor_vars, + fill_vars = coord_vars)[used_vars])) Z_tr <- sweep(Z_tr, 2L, w_vec, "*") Z_nw <- sweep(Z_nw, 2L, w_vec, "*") - splits <- .aoa_fold_splits(folds, nrow(Z_tr), row_ids = tr_row_ids) + splits <- .aoa_fold_splits(folds, nrow(Z_tr), row_ids = tr_row_ids, + removed_ids = removed_ids) # What KIND of folds these are is part of what the threshold means: Meyer # and Pebesma define it from the cross-validated training DI, so a threshold @@ -792,6 +1058,26 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, as.numeric(threshold) } + # Each training row's reference is its nearest OTHER training row, so an + # exact duplicate in predictor space -- repeat measurements at a site with + # static covariates, covariates read off a raster coarser than the sampling + # -- has a training DI of 0, and random folds put twins on both sides. Once + # about three quarters of the rows have one, Q3 and the IQR are 0 and so is + # the threshold: 30 sites visited 4 times put 0 of 200 new points inside, + # against 197 after deduplication, with nothing said. The rule is applied + # as defined; the caution says why it came out that way. + if (is.null(threshold) && thr == 0) + .log_warn(paste0("area_of_applicability(): the DI threshold is 0 because ", + "%d of %d training rows have an exact duplicate in ", + "predictor space among their reference rows (training ", + "DI = 0), so only prediction points identical to a ", + "training row count as inside. Repeat measurements at a ", + "site, or covariates coarser than the sampling, do this: ", + "pass folds that keep the duplicates together ", + "(make_folds(method = \"leave_location_out\", group_var = ", + "...)), or remove the duplicate rows."), + sum(train_DI == 0), length(train_DI)) + # NA or Inf predictors in newdata give NA DI rather than a misleading number. # Same test as the training side above, deliberately: complete.cases() alone # lets an Inf through, and an Inf predictor then produces Inf - Inf = NaN in @@ -804,6 +1090,39 @@ area_of_applicability <- function(newdata, model = NULL, train_sf = NULL, DI[nw_ok] <- .aoa_min_dist(Z_nw[nw_ok, , drop = FALSE], Z_tr, use_fnn = use_fnn, chunk_size = chunk_size) / norm$value + + # A predictor dropped for having no training variance is not in the + # distance, so a prediction row taking a different value there was judged + # on the other predictors alone: a land-cover dummy that is 0 throughout the + # training region put 37 of 40 urban rows inside the AOA, while ONE urban + # training row would have kept the predictor and put 1 inside. Along that + # direction the scaled distance is (x - c) / 0, infinite, so that is the DI. + # "Different" means outside the training range by more than the relative + # tolerance .aoa_scaling() drops the predictor with; a missing value cannot + # be compared and leaves the row to the other predictors. + if (length(dropped) > 0L) { + Xd_tr <- X_tr_full[, dropped, drop = FALSE] + lo <- apply(Xd_tr, 2L, min) + hi <- apply(Xd_tr, 2L, max) + mag <- pmax(abs(lo), abs(hi)) + mag[!is.finite(mag) | mag <= 0] <- 1 + slack <- .Machine$double.eps^0.5 * mag + Xd_nw <- X_nw_full[, dropped, drop = FALSE] + off <- sweep(Xd_nw, 2L, lo - slack, "<") | sweep(Xd_nw, 2L, hi + slack, ">") + off[is.na(off)] <- FALSE + beyond <- rowSums(off) > 0L & !is.na(DI) + if (any(beyond)) { + DI[beyond] <- Inf + .warn_and_log(paste0("area_of_applicability(): %d of %d prediction ", + "row(s) take a value the training data never has on ", + "%s, dropped for having no training variance; they ", + "are extrapolation along it and are marked outside ", + "the AOA with DI = Inf."), + sum(beyond), length(DI), + paste(sQuote(dropped[colSums(off[beyond, , drop = FALSE]) > 0L]), + collapse = ", ")) + } + } inside <- DI <= thr out <- newdata @@ -920,6 +1239,13 @@ print.aoa <- function(x, ...) { cat(sprintf(" threshold : %.4f%s\n", x$threshold, if (isTRUE(x$params$threshold_supplied)) " (supplied)" else " (outlier-removed max of training DI)")) + # A zero threshold reads as "nothing is inside" with no reason given; the + # reason is duplicated training rows, and the count says how many. + n_zero <- sum(x$train_DI == 0, na.rm = TRUE) + if (!isTRUE(x$params$threshold_supplied) && isTRUE(x$threshold == 0)) + cat(sprintf(paste0(" (%d of %d training DI are 0: exact ", + "duplicates in predictor space)\n"), + n_zero, length(x$train_DI))) cat("\n") pct <- if (x$n_new > 0L) 100 * x$n_inside / x$n_new else NA_real_ @@ -927,6 +1253,9 @@ print.aoa <- function(x, ...) { x$n_inside, x$n_new, pct)) if (x$n_na > 0L) cat(sprintf(" %d with missing predictors (DI = NA)\n", x$n_na)) + n_inf <- sum(is.infinite(x$aoa$DI)) + if (n_inf > 0L) + cat(sprintf(" %d outside on a dropped predictor (DI = Inf)\n", n_inf)) if (x$n_outside > 0L) cat("\nPredictions outside the AOA are extrapolations; the ", "cross-validated\nperformance estimate does not cover them.\n", diff --git a/R/assignment.R b/R/assignment.R index 19542b4..68a5c7a 100644 --- a/R/assignment.R +++ b/R/assignment.R @@ -10,6 +10,13 @@ #' duplicating rows, so the assigned layer keeps one row per input feature #' and cell-level counts mean what they say. #' +#' The join runs in the CRS of `polygons_sf` whenever that CRS is projected, +#' so cell edges are the straight lines the cells were drawn with and overlap +#' areas are planar. A copy of `features_sf` is transformed for it, and the +#' features come back with the coordinates they arrived with. Otherwise (the +#' polygons are in lon/lat, or carry no CRS) the join runs in the CRS of +#' `features_sf`. +#' #' @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". @@ -17,31 +24,57 @@ #' polygon, carrying \code{NA} in the ID column. Default FALSE, which drops #' them. #' @param predicate Binary spatial predicate function. Default sf::st_intersects. +#' Not used when \code{largest} applies: sf then assigns polygon features by +#' overlap area and never calls the predicate. #' @param largest Logical; when \code{features_sf} is itself polygonal, keep #' the polygon with the largest overlap. Default TRUE. Ignored for point and -#' line features, and silently dropped if the \code{predicate} does not -#' support it (\code{sf::st_intersects} does). +#' line features. A feature that only touches the polygon layer (shares an +#' edge or a corner with it, with no overlap area) has no largest overlap +#' and is unassigned, in any CRS; with \code{largest = FALSE} the default +#' \code{st_intersects} counts touching, so such a feature is assigned. +#' A feature that overlaps two or more polygons by exactly the same area +#' (to 9 significant digits; a square split evenly across a cell edge) is +#' given to one of them by \code{tie_break} and counted in \code{"ties"}, +#' so the choice does not depend on the order of the polygon rows. +#' Invalid geometries (usually a self-intersecting ring), +#' whose overlap is undefined, are repaired with \code{sf::st_make_valid()} +#' for the join, with a warning, and returned as they arrived. If the +#' overlap still cannot be computed the function stops: falling back to +#' \code{predicate} and \code{tie_break} would change the rule for every +#' feature in the layer, so pass \code{largest = FALSE} to ask for that. #' @param tie_break Strategy for resolving features that match multiple -#' polygons: \code{"smallest_area"} (default) keeps the polygon with the -#' smallest area, \code{"first"} keeps the first match (original order-dependent +#' polygons (with \code{largest}, that overlap several polygons equally): +#' \code{"smallest_area"} (default) keeps the polygon with the +#' smallest area and, among polygons of equal area (a point on the shared +#' edge of two grid cells), the one whose bounding-box centre is lowest, +#' then leftmost, so the choice does not depend on the order of the rows; +#' \code{"first"} keeps the first match (original order-dependent #' behavior). #' @return An sf object with `polygon_id_col` attached, one row per input #' feature (fewer if `keep_unassigned = FALSE` dropped unmatched ones), in -#' the CRS `features_sf` arrived in. Any column of `features_sf` whose name -#' would collide with the polygon ID column is dropped before the spatial -#' join (with a warning), so re-assigning an already-assigned layer replaces -#' the old IDs and does not fail. If *no* feature falls inside any polygon +#' the CRS `features_sf` arrived in. A column of `features_sf` already +#' called `polygon_id_col` is dropped before the spatial join (with a +#' warning), so re-assigning an already-assigned layer replaces the old IDs +#' and does not fail. Every other column is kept, including one named like +#' the polygons' own ID column when that is read from a fallback such as +#' `"id"` (a site `id` joined to cells keyed by `id`). If *no* feature +#' falls inside any polygon #' the result is empty (or all-`NA` with `keep_unassigned = TRUE`) and a #' warning is raised, since the usual cause is two layers in different #' places (a CRS that could only be stamped, not reprojected). The #' attribute `"ties"` records how many features matched more than one -#' polygon and had the `tie_break` rule decide for them: a list with `n`, -#' `which` (their row positions in `features_sf`) and `rule`. A large `n` -#' means the polygon layer overlaps, and per-cell counts built from the +#' polygon (with `largest`, overlapped several by exactly the same area) +#' and had the `tie_break` rule decide for them: a list with `n`, +#' `which` (their row positions in `features_sf`), `rule` and `n_rows` +#' (the number of rows returned, which the record was made for). A large +#' `n` means the polygon layer overlaps, and per-cell counts built from the #' result depend on the rule. The record describes the rows this call -#' returned and does not survive subsetting: `joined[i, ]` is a plain layer +#' returned and does not survive subsetting: `joined[i, ]`, like +#' `dplyr::filter()`, `slice()` or `arrange()` of it, is a plain layer #' with no `"ties"` attribute, so nothing reports the parent's count -#' against row positions that no longer resolve. +#' for a different set of rows. `sf::st_drop_geometry()` keeps the record, +#' since the rows are the same; see \code{\link{[.spatialkit_rows}} for +#' what binding such data frames does. #' @examples #' library(sf) #' set.seed(1) @@ -78,8 +111,22 @@ assign_features_to_polygons <- function( tie_break <- match.arg(tie_break) orig_crs <- sf::st_crs(features_sf) - hh <- harmonize_crs(features_sf, polygons_sf) + # The join runs in the polygons' CRS whenever that is projected: it is the + # CRS the cells are drawn in, so their edges are straight and overlap areas + # planar there. Keeping the features' CRS instead pulled the package's own + # projected cells into lon/lat, bending every edge into a great-circle arc, + # and with s2 the largest-overlap join failed on a degenerate intersection + # piece -- on sf's nc counties against a 36-cell grid, 55 of 100 counties + # ended up outside their largest-overlap cell. + crs_p <- sf::st_crs(polygons_sf) + join_in_p <- !is.na(crs_p) && !isTRUE(sf::st_is_longlat(crs_p)) + hh <- harmonize_crs(features_sf, polygons_sf, + prefer = if (join_in_p) "b" else "a") f <- hh$a; p <- hh$b + # `f` is only the join's copy. The rows returned keep the geometry the + # features arrived with; a CRS-less layer is resolved into the polygons' + # CRS and returned there, as before. + f_geom <- if (is.na(orig_crs)) sf::st_geometry(f) else sf::st_geometry(features_sf) id_candidates <- c(polygon_id_col, "poly_id", "polygon_id", "id", "cell_id", "grid_id") id_col <- id_candidates[id_candidates %in% names(p)][1] @@ -88,14 +135,21 @@ assign_features_to_polygons <- function( p[[id_col]] <- seq_len(nrow(p)) } + # The polygons' ID travels through the join under a reserved name and is + # renamed to `polygon_id_col` afterwards. Under its source name, a + # features column of that name -- a site `id` joined to cells keyed by + # `id` -- collided inside st_join() and was dropped, although the result + # only ever gains `polygon_id_col`. + join_id <- "..poly_id" p_sel <- p[, id_col, drop = FALSE] + names(p_sel)[names(p_sel) == id_col] <- join_id # st_join() suffixes columns present on both sides (`poly_id.x` / # `poly_id.y`), which would defeat the rename below and leave # `polygon_id_col` absent -- silently returning zero rows. This is reachable # simply by re-assigning already-assigned points, or points that came out of # summarize_by_cell(). Drop the colliding column(s) up front instead. - collide <- intersect(unique(c(id_col, polygon_id_col)), names(f)) + collide <- intersect(unique(c(polygon_id_col, join_id)), names(f)) if (length(collide)) { .warn_and_log( "assign_features_to_polygons(): `features_sf` already carries column(s) %s, which would collide with the polygon ID column; dropping them before the spatial join. Rename them first if you need to keep them.", @@ -105,24 +159,124 @@ assign_features_to_polygons <- function( } f$`..pre_join_row_id` <- seq_len(nrow(f)) - + f_gtypes <- unique(as.character(sf::st_geometry_type(f, by_geometry = TRUE))) use_largest <- isTRUE(largest) && all(f_gtypes %in% c("POLYGON", "MULTIPOLYGON")) + if (use_largest) { + # sf measures the overlap with st_intersection(), which GEOS cannot do on + # an invalid ring: one bow-tie parcel threw a TopologyException, and a + # catch-all retry without `largest` used to swallow it and reassign EVERY + # straddling feature in the layer by `tie_break` (95 of 200 changed cell), + # with no R warning. An invalid ring has no well-defined overlap anyway + # (a bow-tie's two lobes cancel to zero area), so the copies used for the + # join are repaired, and the caller is told how many. + bad_f <- !(sf::st_is_valid(f) %in% TRUE) + bad_p <- !(sf::st_is_valid(p_sel) %in% TRUE) + if (any(bad_f) || any(bad_p)) { + .warn_and_log(paste0( + "assign_features_to_polygons(): %d of %d feature(s) and %d of %d ", + "polygon(s) have invalid geometry (usually a self-intersecting ring), ", + "so their overlap areas are undefined; they were repaired with ", + "sf::st_make_valid() for the largest-overlap join. The features are ", + "returned with the geometry they arrived with; repair them yourself ", + "to silence this."), + sum(bad_f), nrow(f), sum(bad_p), nrow(p_sel)) + if (any(bad_f)) { + g <- sf::st_geometry(f) + g[bad_f] <- .safe_make_valid(g[bad_f]) + f <- sf::st_set_geometry(f, g) + } + if (any(bad_p)) { + g <- sf::st_geometry(p_sel) + g[bad_p] <- .safe_make_valid(g[bad_p]) + p_sel <- sf::st_set_geometry(p_sel, g) + } + } + } + join_args <- list(x = f, y = p_sel, join = predicate, left = TRUE) - join_ok <- tryCatch({ - if (use_largest) join_args$largest <- TRUE - do.call(sf::st_join, join_args) - }, error = function(e) { - # Fall back without `largest` if the predicate doesn't support it - join_args$largest <- NULL - do.call(sf::st_join, join_args) - }) - joined <- join_ok - - if (!identical(id_col, polygon_id_col)) { - names(joined)[names(joined) == id_col] <- polygon_id_col + largest_ties <- integer(0) + if (use_largest) { + # With `largest = TRUE` sf never calls `predicate` (it intersects the + # layers and keeps the biggest piece), so no predicate can reject it: an + # error here is a geometry failure. Falling back to `tie_break` would + # change the rule for every feature in the layer, so stop instead. + # + # sf's st_intersection() warns "attribute variables are assumed to be + # spatially constant throughout all geometries" unless every attribute + # is flagged constant, and st_join() adds its own unflagged grouping + # columns before calling it, so every ordinary call raised it (setting + # st_agr() on the inputs does not help). Keeping one cell per feature is + # exactly that assumption, so the warning says nothing about the data; + # it alone is muffled. + joined <- tryCatch( + withCallingHandlers( + do.call(sf::st_join, c(join_args, largest = TRUE)), + warning = function(w) { + if (grepl("attribute variables are assumed to be spatially constant", + conditionMessage(w), fixed = TRUE)) + invokeRestart("muffleWarning") + }), + error = function(e) stop(sprintf(paste0( + "assign_features_to_polygons(): the largest-overlap join failed (%s). ", + "Pass largest = FALSE to assign every feature by `predicate` and ", + "`tie_break` instead%s."), + conditionMessage(e), + if (isTRUE(sf::st_is_longlat(f))) + ", or project both layers first (see ensure_projected())" else ""), + call. = FALSE)) + # sf keeps the largest intersection piece without asking whether it has + # any area, so under GEOS a feature that only shares an edge or a corner + # with the cells was assigned to one of them with zero overlap, while + # under s2 (lon/lat, s2 on) the same feature had no piece and came back + # unassigned: sf's 100 nc counties against 50 of them as cells gave 70 + # rows projected and 50 in lon/lat. A feature with no overlap has no largest + # overlap, so it is unassigned whatever the CRS. s2 already does this. + if (!(isTRUE(sf::st_is_longlat(f)) && isTRUE(sf::sf_use_s2()))) { + hit <- which(!is.na(joined[[join_id]])) + if (length(hit)) { + # "2********": the interiors meet in an area. + overlaps <- suppressMessages(sf::st_relate(f, p_sel, pattern = "2********")) + ids_p <- p_sel[[join_id]] + fi <- joined[["..pre_join_row_id"]][hit] + touch <- !vapply(seq_along(hit), function(k) + joined[[join_id]][hit[k]] %in% ids_p[overlaps[[fi[k]]]], logical(1)) + if (any(touch)) { + .log_info(paste0("assign_features_to_polygons(): %d polygon feature(s) ", + "only touch the polygon layer (no overlap area) and ", + "are left unassigned."), sum(touch)) + joined[[join_id]][hit[touch]] <- NA + } + } + } + # sf keeps which.max() of the overlap areas, so a feature split evenly + # between two cells went to whichever comes first in `polygons_sf`, and + # no tie was recorded: a 40 m square across the edge of cells 1 and 2 + # went to cell 1, or to cell 2 with the polygon rows reversed. Features + # overlapping two or more cells are measured again, and an exact tie + # (areas equal to 9 significant digits, as for the cell areas below) is + # decided by `tie_break` among the equally largest cells. + lt <- .largest_overlap_ties(f, p_sel, joined, join_id, tie_break) + if (length(lt$rows)) { + joined[[join_id]][lt$rows] <- lt$ids + largest_ties <- joined[["..pre_join_row_id"]][lt$rows] + .log_info(paste0("assign_features_to_polygons(): %d of %d polygon ", + "feature(s) overlap two or more polygons by exactly the ", + "same area; the '%s' rule chose one for each."), + length(lt$rows), nrow(f), tie_break) + } + } else { + joined <- do.call(sf::st_join, join_args) + } + # The join ran on copies (moved into the polygons' CRS, repaired); hand + # back the geometry the caller passed, in the CRS it arrived in, rather + # than a transform round trip of it. + joined <- sf::st_set_geometry(joined, f_geom[joined[["..pre_join_row_id"]]]) + + if (!identical(join_id, polygon_id_col)) { + names(joined)[names(joined) == join_id] <- polygon_id_col } if (!polygon_id_col %in% names(joined)) { stop(sprintf( @@ -150,17 +304,40 @@ assign_features_to_polygons <- function( length(tie_rows), nrow(f), tie_break) if (any(dup_mask) && identical(tie_break, "smallest_area")) { # For each duplicated feature, keep the polygon with the smallest area - # (the most specific / tightest-fitting polygon). + # (the most specific / tightest-fitting polygon). Areas are compared to + # 9 significant digits, so equal cells whose computed areas differ in the + # last bits count as equal. poly_areas <- suppressWarnings(as.numeric(sf::st_area(p))) poly_areas[!is.finite(poly_areas)] <- Inf names(poly_areas) <- as.character(p[[id_col]]) - - joined$`..poly_area` <- poly_areas[as.character(joined[[polygon_id_col]])] + + joined$`..poly_area` <- signif(poly_areas[as.character(joined[[polygon_id_col]])], 9L) joined$`..poly_area`[is.na(joined$`..poly_area`)] <- Inf - + + # Equal areas -- every cell of a regular grid, for a point on a shared + # edge -- used to fall through to row order, so the answer depended on + # the order of the polygon layer after all: edge points at x = 100 went + # to cells 1, 4, 7, or to 2, 5, 8 with the rows reversed. The candidate + # whose bounding-box centre is lowest, then leftmost, wins instead. On + # a create_grid_polygons() grid, which is numbered from the lower left a + # row at a time, that is the cell the row order picked. + tie_ids <- unique(as.character( + joined[[polygon_id_col]][joined[["..pre_join_row_id"]] %in% tie_rows])) + tie_ids <- tie_ids[!is.na(tie_ids)] + p_tie <- sf::st_geometry(p)[match(tie_ids, as.character(p[[id_col]]))] + ctr <- vapply(p_tie, function(g) { + bb <- sf::st_bbox(g) + c((bb[["xmin"]] + bb[["xmax"]]) / 2, (bb[["ymin"]] + bb[["ymax"]]) / 2) + }, numeric(2)) + ctr_x <- stats::setNames(ctr[1, ], tie_ids) + ctr_y <- stats::setNames(ctr[2, ], tie_ids) + ids_j <- as.character(joined[[polygon_id_col]]) + key_y <- unname(ctr_y[ids_j]); key_y[!is.finite(key_y)] <- Inf + key_x <- unname(ctr_x[ids_j]); key_x[!is.finite(key_x)] <- Inf + # Within each group of duplicates, keep the row with smallest area - joined <- joined[order(joined[["..pre_join_row_id"]], joined[["..poly_area"]]), , - drop = FALSE] + joined <- joined[order(joined[["..pre_join_row_id"]], joined[["..poly_area"]], + key_y, key_x), , drop = FALSE] joined <- joined[!duplicated(joined[["..pre_join_row_id"]]), , drop = FALSE] joined[["..poly_area"]] <- NULL } else { @@ -189,9 +366,9 @@ assign_features_to_polygons <- function( joined <- joined[!is.na(joined[[polygon_id_col]]), , drop = FALSE] } - if (!is.na(orig_crs)) joined <- sf::st_transform(joined, orig_crs) # Stamped and classed: the record names row positions, so it must not # survive a subset that renumbers or removes them. + tie_rows <- sort(unique(c(tie_rows, largest_ties))) joined <- .set_row_record(joined, "ties", list(n = length(tie_rows), which = as.integer(tie_rows), @@ -200,6 +377,53 @@ assign_features_to_polygons <- function( } +# Exact ties in a largest-overlap join. `joined` is st_join(largest = TRUE) +# of `f` onto `p_sel`, the polygons' ID in column `join_id`. The features +# assigned there that overlap two or more polygons are intersected with them +# again; where the largest overlap is shared (areas equal to 9 significant +# digits) the polygon is picked among the equally largest by `tie_break`: +# "smallest_area" takes the smallest polygon, then the one whose bounding-box +# centre is lowest, then leftmost, as for the predicate join; "first" takes +# the first by polygon row. Returns the rows of `joined` that had a tie and +# the ID each gets. +.largest_overlap_ties <- function(f, p_sel, joined, join_id, tie_break) { + none <- list(rows = integer(0), ids = NULL) + rows <- which(!is.na(joined[[join_id]])) + if (!length(rows)) return(none) + gf <- sf::st_geometry(f)[joined[["..pre_join_row_id"]][rows]] + gp <- sf::st_geometry(p_sel) + cand <- suppressMessages(sf::st_intersects(gf, gp)) + multi <- which(lengths(cand) >= 2L) + if (!length(multi)) return(none) + pieces <- tryCatch(suppressMessages(suppressWarnings( + sf::st_intersection(gf[multi], gp))), error = function(e) NULL) + if (is.null(pieces) || !length(pieces)) return(none) + idx <- attr(pieces, "idx") + area <- signif(suppressWarnings(as.numeric(sf::st_area(pieces))), 9L) + area[!is.finite(area)] <- 0 + out_rows <- integer(0) + out_ids <- p_sel[[join_id]][integer(0)] + for (s in split(seq_along(area), idx[, 1L])) { + top <- max(area[s]) + if (!(top > 0)) next + tied <- sort(unique(idx[s[area[s] == top], 2L])) + if (length(tied) < 2L) next + pick <- if (identical(tie_break, "first")) tied[1L] else { + ga <- signif(suppressWarnings(as.numeric(sf::st_area(gp[tied]))), 9L) + ga[!is.finite(ga)] <- Inf + ctr <- vapply(gp[tied], function(g) { + bb <- sf::st_bbox(g) + c((bb[["xmin"]] + bb[["xmax"]]) / 2, (bb[["ymin"]] + bb[["ymax"]]) / 2) + }, numeric(2)) + tied[order(ga, ctr[2, ], ctr[1, ])[1L]] + } + out_rows <- c(out_rows, rows[multi[idx[s[1L], 1L]]]) + out_ids <- c(out_ids, p_sel[[join_id]][pick]) + } + list(rows = out_rows, ids = out_ids) +} + + #' Correlation implied by a fitted gstat variogram model #' #' Converts a fitted variogram to a correlation function of distance, giving @@ -220,6 +444,16 @@ assign_features_to_polygons <- function( #' only ever produces single-component \code{Exp} or \code{Sph} models; other #' shapes reach this function through a user-built \code{sac}. #' +#' A component with a 2-D geometric anisotropy (gstat's \code{ang1} and +#' \code{anis1}, from \code{vgm(..., anis = c(angle, ratio))}) cannot be +#' evaluated at a scalar distance, so the function of distance reads it at +#' its major range, and the returned function carries an attribute +#' \code{"cor_xy"}: a function of a coordinate matrix returning the full +#' correlation matrix, with each component's separations rotated and its +#' minor axis stretched by \code{1 / anis1} as gstat does. Callers that hold +#' coordinates use that. The 3-D terms (\code{ang2}, \code{ang3}, +#' \code{anis2}) do not act on 2-D coordinates and are ignored. +#' #' There is deliberately no special case at \code{h = 0}. The nugget captures #' measurement error and variation below the sampling resolution, so two #' distinct observations each carry independent nugget noise and are less than @@ -254,7 +488,7 @@ assign_features_to_polygons <- function( return(NULL) f_i <- .vgm_shape_fns[as.character(struct$model)] - function(h) { + fn <- function(h) { num <- 0 for (i in seq_along(c_i)) num <- num + c_i[i] * f_i[[i]](h, a_i[i]) # No special case at h = 0: this is the correlation between two DISTINCT @@ -263,6 +497,32 @@ assign_features_to_polygons <- function( # the diagonal. pmin(pmax(num / total, 0), 1) } + + # A 2-D anisotropy was read as isotropic at the major range: for + # vgm(0.8, "Exp", 300, 0.2, anis = c(0, 0.2)) the correlation at 50 m + # east-west came out 0.677 where gstat's is 0.348, and the median design + # effect 14.1 against 7.7. Distance alone cannot carry a direction, so + # coordinate-holding callers get a function of the coordinates. + ang <- if ("ang1" %in% names(struct)) as.numeric(struct$ang1) else rep(0, nrow(struct)) + anis <- if ("anis1" %in% names(struct)) as.numeric(struct$anis1) else rep(1, nrow(struct)) + ang[!is.finite(ang)] <- 0 + anis[!is.finite(anis) | anis <= 0 | anis > 1] <- 1 + if (any(anis < 1)) { + attr(fn, "cor_xy") <- function(xy) { + num <- 0 + for (i in seq_along(c_i)) { + # gstat: ang1 is the major axis's direction, clockwise from north; + # the separation along the minor axis is stretched by 1 / anis1. + th <- ang[i] * pi / 180 + u <- xy[, 1] * sin(th) + xy[, 2] * cos(th) + v <- (xy[, 1] * cos(th) - xy[, 2] * sin(th)) / anis[i] + d <- as.matrix(stats::dist(cbind(u, v))) + num <- num + c_i[i] * f_i[[i]](d, a_i[i]) + } + pmin(pmax(num / total, 0), 1) + } + } + fn } # Correlation shape f(h; a) of each supported gstat family, so that the @@ -276,6 +536,22 @@ assign_features_to_polygons <- function( Gau = function(h, a) exp(-(h / a)^2) ) +# TRUE for a variogram model with a positive nugget and no structured sill +# (no structured component, or only ones of partial sill 0, of the families +# above): it implies no correlation between distinct observations. +# .vgm_correlation_fn() returns NULL for it, deliberately, since it has no +# correlation function to offer; callers that can use "uncorrelated" ask this. +.vgm_is_pure_nugget <- function(vgm_model) { + if (!is.data.frame(vgm_model) || !all(c("model", "psill") %in% names(vgm_model))) + return(FALSE) + fam <- as.character(vgm_model$model) + ps <- suppressWarnings(as.numeric(vgm_model$psill)) + if (!length(fam) || !all(fam %in% c("Nug", names(.vgm_shape_fns))) || + !all(is.finite(ps))) + return(FALSE) + sum(ps[fam == "Nug"]) > 0 && all(ps[fam != "Nug"] == 0) +} + #' Standard error of a cell mean under a design effect #' @@ -340,13 +616,18 @@ assign_features_to_polygons <- function( #' @param max_n Cells larger than this are subsampled before forming the #' \code{n x n} correlation matrix. Default 500. #' @param seed RNG seed for that subsampling. +#' @param r_bar The per-cell mean correlations, when the caller already has +#' them from \code{.cell_cor_stats_variogram()}: building every cell's +#' correlation matrix a second time only to recompute them doubled the +#' cost of \code{summarize_by_cell(deff = "variogram")}. #' @return Named numeric vector of design effects, one per cell. #' @keywords internal #' @noRd .cell_deff_variogram <- function(coords, cell_id, cor_fn, max_n = 500L, - seed = 42L) { - r_bar <- .cell_rbar_variogram(coords, cell_id, cor_fn, max_n = max_n, - seed = seed) + seed = 42L, r_bar = NULL) { + if (is.null(r_bar)) + r_bar <- .cell_rbar_variogram(coords, cell_id, cor_fn, max_n = max_n, + seed = seed) n_i <- table(factor(cell_id, levels = names(r_bar))) n_i <- as.numeric(n_i[names(r_bar)]) out <- 1 + (n_i - 1) * r_bar @@ -464,11 +745,22 @@ assign_features_to_polygons <- function( #' pairwise-distance distribution is the cell's, so the ratio transfers where #' the raw df would not. #' +#' Rows with a non-finite coordinate (an empty point) have no location to +#' correlate, so they are left out: the statistics describe the located +#' points. An anisotropic model is evaluated through its \code{"cor_xy"} +#' attribute (see \code{.vgm_correlation_fn()}). +#' #' @return Named numeric vector \code{c(rbar =, df_ratio =)}; \code{c(0, 1)} -#' when there is at most one point or no correlation function. +#' when there is at most one located point or no correlation function. #' @keywords internal #' @noRd .cor_stats_from_coords <- function(xy, cor_fn, max_n = 500L, seed = 42L) { + # An empty point's NA coordinates put NA in R and stopped the df test + # below with "missing value where TRUE/FALSE needed". + if (!is.null(xy) && length(dim(xy)) == 2L && nrow(xy) > 0L) { + located <- is.finite(xy[, 1]) & is.finite(xy[, 2]) + if (!all(located)) xy <- xy[located, , drop = FALSE] + } n_i <- nrow(xy) if (is.null(cor_fn) || is.null(n_i) || n_i <= 1L) return(c(rbar = 0, df_ratio = 1)) @@ -477,11 +769,16 @@ assign_features_to_polygons <- function( on.exit(cleanup(), add = TRUE) xy <- xy[sample.int(n_i, max_n), , drop = FALSE] } - d <- as.matrix(stats::dist(xy)) # Rebuild explicitly rather than relying on cor_fn() to preserve `dim`. # A correlation function written as, say, rep(1, length(h)) returns a bare # vector, and diag()<- would then fail. - R <- matrix(as.numeric(cor_fn(as.numeric(d))), nrow = nrow(d), ncol = ncol(d)) + cor_xy <- attr(cor_fn, "cor_xy", exact = TRUE) + R <- if (is.function(cor_xy)) { + matrix(as.numeric(cor_xy(xy)), nrow = nrow(xy), ncol = nrow(xy)) + } else { + d <- as.matrix(stats::dist(xy)) + matrix(as.numeric(cor_fn(as.numeric(d))), nrow = nrow(d), ncol = ncol(d)) + } diag(R) <- 1 n_used <- nrow(R) r_bar <- (sum(R) - n_used) / (n_used * (n_used - 1)) @@ -495,6 +792,26 @@ assign_features_to_polygons <- function( } +#' Warn that a requested design effect fell back to 1 +#' +#' \code{.warn_and_log()} with a condition class, so that a caller running +#' many summaries can catch exactly this case -- the standard errors are the +#' uncorrected ones although a correction was asked for -- with +#' \code{tryCatch(spatialkit_deff_fallback = )} or +#' \code{withCallingHandlers()}, rather than by matching message text. +#' +#' @keywords internal +#' @noRd +.warn_deff_fallback <- function(fmt, ...) { + msg <- sprintf(fmt, ...) + # raising = TRUE: the warning below shows it, so a knitted document must + # not repeat the line as a message (see .sk_console_appender()). + .sk_log(logger::WARN, msg, raising = TRUE) + warning(warningCondition(msg, class = "spatialkit_deff_fallback")) + invisible(msg) +} + + #' Summarize features by polygon/cell ID #' #' Aggregates an sf point dataset into one row per cell. By default computes @@ -528,13 +845,18 @@ assign_features_to_polygons <- function( #' #' @section Spatial autocorrelation and standard-error bias: #' By default (`deff = 1`), the `..se_*` columns are computed as -#' `sd / sqrt(n)`, which assumes observations within each cell are independent. -#' When data are spatially autocorrelated (the common case for the spatial -#' workflows this package supports), within-cell observations are typically -#' positively correlated, so the effective sample size is smaller than `n`. -#' The naive SE is therefore **anticonservative** (too small), and downstream -#' weighted regressions using `cell_weight` or `..se_*` columns will produce -#' overconfident standard errors for cells with strong intra-cell correlation. +#' `sd / sqrt(n)`, which treats the observations within each cell as +#' independent. When data are spatially autocorrelated (the common case for the +#' spatial workflows this package supports), within-cell observations are +#' typically positively correlated: they share the cell's departure from the +#' population mean, so as an estimate of the **population (grand) mean** a cell +#' mean has an effective sample size smaller than `n`. For that estimand the +#' naive SE is **anticonservative** (too small), and a downstream weighted +#' regression that uses `cell_weight` or the `..se_*` columns for population-level +#' inference will produce overconfident standard errors for cells with strong +#' intra-cell correlation. For the cell's **own** mean the naive SE is the right +#' one when the cell's points are spread through it, and the corrected SE is too +#' wide; see "What the standard error estimates" before setting `deff`. #' #' Setting `deff = "kish"` applies an approximate correction using Kish's #' design effect. Separate intra-class correlations (ICCs) are estimated for @@ -544,6 +866,23 @@ assign_features_to_polygons <- function( #' `n_i / (1 + (n_i - 1) * rho)`. This is a first-order correction that #' does not require a full spatial covariance model but does require enough #' cells and observations for a stable ICC estimate. +#' +#' A design effect estimated from the data (`"kish"` or `"variogram"`) comes +#' with a second, small-sample correction. The within-cell correlation that +#' inflates the variance of the mean to `sigma^2 * deff / n` also biases the +#' within-cell sample variance downward: under exchangeable correlation `rho` +#' (Kish's own assumption), with `deff = 1 + (n - 1) * rho`, +#' `E[s^2] = sigma^2 * (n - deff) / (n - 1)`, so `s^2` understates `sigma^2` +#' by very nearly the factor by which `deff` inflates the mean's variance, and +#' the two errors compound rather than cancel. The standard error is therefore +#' `s * sqrt(deff / n) * sqrt((n - 1) / (n - deff))`, and `NA` where +#' `deff >= n` (the cell then holds one observation's worth of information +#' and `s` carries none about `sigma`). This is the package's own derivation, +#' not taken from a reference. Measured 95% interval coverage at `n = 30` +#' over 20,000 replicates: 0.921, 0.844 and 0.628 at `rho` = 0.2, 0.5 and 0.8 +#' with `s * sqrt(deff / n)` alone, against 0.948, 0.950 and 0.949 with the +#' rescaling. +#' #' You may also pass a fixed numeric design effect (e.g. `deff = 2`) to #' uniformly inflate standard errors: an externally supplied constant is #' applied as `sd * sqrt(deff / n)`, exactly `sqrt(deff)` times the naive SE in @@ -570,7 +909,8 @@ assign_features_to_polygons <- function( #' values usually wants. For that quantity the naive `sd / sqrt(n)` is the #' better of the two on offer: measured coverage 0.95 under exchangeable #' within-cell correlation, against very nearly 1.00 for the -#' design-effect-corrected SE, which is about five times too wide. That 0.95 +#' design-effect-corrected SE, which is too wide by the factor +#' `sqrt(deff / (1 - rho))` (4.6 at 20 points a cell and `rho = 0.5`). That 0.95 #' is exact under the exchangeable model and holds under a spatial covariance #' model only when the cell's points are spread through the cell; with #' *clustered* sampling inside a cell it is anticonservative for the block @@ -594,8 +934,10 @@ assign_features_to_polygons <- function( #' is that of the part the predictors do not explain, is weaker; using it here #' dropped grand-mean coverage from 0.93 to 0.51 the moment a predictor was #' listed.) Pass `sac` explicitly when you want a different variogram, such as -#' a residual one from `estimate_sac_range(..., predictor_vars = )`, and check -#' `attr(sac, "detrended")` to know which you have. +#' a residual one from `estimate_sac_range(..., predictor_vars = )`. A `sac` +#' whose `attr(sac, "detrended")` is `TRUE` is used as given, but when it +#' corrects response columns a warning says that their standard errors are +#' understated, as [kriging_adequacy()] warns about the same mismatch. #' #' @section Confidence intervals: #' With `conf_level` set, every numeric response and predictor column gains @@ -609,7 +951,10 @@ assign_features_to_polygons <- function( #' `mean +/- qt((1 + conf_level) / 2, df) * se`, centred on the plain mean of #' the column's non-missing values whatever `agg_funs` computes, and is `NA` #' wherever the standard error is (a single observation; complete redundancy -#' under `deff`). +#' under `deff`). `..neff_*` and `..df_*` are `NA` where the column has one +#' non-missing value or none, like the standard error; `cell_weight` still +#' counts such a cell (1, or `1 / deff` for a numeric `deff`), so the two +#' differ there. #' #' The degrees of freedom are **not** `neff - 1`. The interval's spread comes #' from the within-cell sample variance, and under exchangeable correlation @@ -637,19 +982,36 @@ assign_features_to_polygons <- function( #' cells, moves the coverage with it. #' #' @param assigned_points_sf An sf object with a cell identifier column. -#' @param response_var Optional response column name for per-cell aggregation. -#' @param predictor_vars Optional predictor column names for per-cell aggregation. +#' @param response_var Optional response column name for per-cell +#' aggregation: a single character string. A name that is not a column, or +#' a column that is not numeric, is skipped with a warning. +#' @param predictor_vars Optional predictor column names for per-cell +#' aggregation. Names that are not columns, and columns that are not +#' numeric, are skipped with a warning. #' @param id_col Preferred name of the polygon/cell ID column. #' @param agg_funs Named list of aggregation functions. Default #' \code{list(mean = \(x) mean(x, na.rm = TRUE))}. Additional common options: -#' \code{median}, \code{sum}, \code{sd}. +#' \code{median}, \code{sum}, \code{sd}. A single function +#' (\code{agg_funs = median}) or a character vector of function names +#' (\code{c("median", "sum")}) is also accepted. A single function is named +#' after the expression passed: a name gives that name (\code{median}, or +#' \code{f} for a variable \code{f} holding a function), +#' \code{stats::median} gives \code{median}, and any other expression gives +#' \code{agg1}; pass a named list to choose the name. Anything else falls +#' back to the default mean with a warning. #' @param cells_sf Optional polygon sf layer to join cell geometries onto #' the output. When supplied, the return value is an sf object with #' the polygon geometry from cells_sf, with one row per cell in `cells_sf`. #' Cells that no feature fell in are kept, with `NA` summaries. Duplicate #' ID values in `cells_sf` would multiply those rows, so they are reported -#' with a warning. When NULL (default), a plain data.frame/tibble is -#' returned (previous behaviour). +#' with a warning. Its ID column is the first of `id_col`, `"poly_id"`, +#' `"polygon_id"`, `"id"`, `"cell_id"` and `"grid_id"` it carries, the +#' list and order [assign_features_to_polygons()] reads the polygons' IDs +#' from. A summarised ID that matches no cell is reported with a warning, +#' since the join drops it with its points; a `cells_sf` with none of +#' those columns, or one that is not an sf object, gives a warning and a +#' plain data frame (an error with `area = TRUE`). When NULL (default), a +#' plain data.frame/tibble is returned (previous behaviour). #' @param deff Design-effect adjustment for standard errors. One of: #' \describe{ #' \item{`1` (default)}{No adjustment; the classic IID standard error @@ -666,8 +1028,18 @@ assign_features_to_polygons <- function( #' the fit via `sac`, or it is estimated when `response_var` is given and #' 'gstat' is available. Exponential, spherical and Gaussian models are #' supported, with a nugget and with several structured components -#' (each weighted by its partial sill); a model of any other family -#' falls back to `deff = 1` with a warning naming it.} +#' (each weighted by its partial sill) and with gstat's 2-D geometric +#' anisotropy (`vgm(..., anis = c(angle, ratio))`), applied as gstat +#' applies it. A model of any other family falls back to `deff = 1` +#' with a warning naming it, and so does a request with no usable +#' model (none supplied and none could be estimated, or a rejected +#' fit that could not be replaced by an estimate); see "Value" for how +#' to detect a fallback. A model with no structured component (a pure +#' nugget) implies that distinct observations are uncorrelated, so it +#' is applied as a design effect of 1 in every cell, not treated as a +#' fallback. Points with empty +#' geometry count towards their cells' values but not towards the +#' correlation, with a warning.} #' \item{`"kish"`}{Estimate per-variable-type intra-class correlations #' (ICCs) from the grouped data using a one-way random-effects ANOVA #' decomposition (one ICC for the response variable and a separate @@ -689,24 +1061,36 @@ assign_features_to_polygons <- function( #' predictors') that sets `cell_weight` whenever a response was given. #' Requires at least 2 cells with 2+ observations and at least 2 residual #' degrees of freedom (`N - k >= 2`); the ICC is taken as 0 (no -#' correction, no `"deff_applied"` attribute) otherwise, and likewise -#' when the estimate itself comes out at or below 0.} +#' correction for that variable type) otherwise, and likewise when the +#' estimate itself comes out at or below 0. The `"deff_applied"` +#' attribute is attached when either ICC is positive, so when both are +#' 0 there is none.} #' \item{A positive number}{Applied as a uniform design effect to every #' cell, as `sd * sqrt(deff / n)`, exactly `sqrt(deff)` times the #' naive SE. Use when you have an external estimate of the design -#' effect. Anything that is not a single number `>= 1` (including a -#' value below 1, which would *shrink* the standard errors) is -#' refused with a warning and replaced by 1.} +#' effect. Anything that is not a single finite number `>= 1` +#' (including a value below 1, which would *shrink* the standard +#' errors, and `NA` or `Inf`) is refused with a warning and replaced +#' by 1.} #' } #' @param sac Optional `sac_range` object from [estimate_sac_range()], used #' when `deff = "variogram"`. Supplying one avoids re-fitting the variogram #' and lets you inspect the fit the design effect is based on. A `sac_range` -#' whose fit was *rejected* (its `status` is not `"ok"`) carries no usable -#' correlation function, so `deff` falls back to 1 with a warning and does -#' not correct by a shape that was not trusted enough to report a range. +#' whose fit was *rejected* (its value is `NA` and it carries a +#' `rejected_reason` attribute) carries no usable correlation function, so +#' it is set aside rather than correcting by a shape that was not trusted +#' enough to report a range: the variogram is then estimated as if no `sac` +#' had been given, with a plain warning saying so, or, where that is not +#' possible, `deff` falls back to 1 with the fallback warning, which names +#' the rejection. A `sac` with no `variogram_model` attribute -- a plain +#' number or a `units` object, say -- is a range without a correlation +#' function, and is set aside the same way. A `sac` fitted to residuals +#' (`attr(sac, "detrended")` `TRUE`) is used as given, with a warning when +#' it corrects response columns (see "Design effects and variable types"). #' @param deff_max_n Cells with more than this many points are subsampled #' before forming the `n x n` correlation matrix used by -#' `deff = "variogram"`. Default 500. +#' `deff = "variogram"`. Default 500. It must be a single number of at +#' least 2 when `deff = "variogram"`; anything else is an error. #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{TRUE}, @@ -725,7 +1109,12 @@ assign_features_to_polygons <- function( #' forced into one zone (14 percent), or a few degrees of latitude in Web #' Mercator (4 percent at 48N), does not. [ensure_projected()] with #' `purpose = "area"` chooses an equal-area CRS for lon/lat input; build the -#' cells in it. The measured spread is attached as `attr(, "area_error")`. +#' cells in it. Lon/lat cells are measured geodesically instead: their +#' `cell_area` is `sf::st_area()`'s area in square metres (on the sphere +#' with s2, sf's default), not a planar area in squared degrees, and the +#' distortion check passes by construction; with s2 switched off, sf needs +#' the lwgeom package for that area and the request is refused without +#' it. The measured spread is attached as `attr(, "area_error")`. #' @param conf_level Optional confidence level in (0, 1), such as `0.95`. #' When given, every numeric response and predictor column also gets #' `..neff_*`, `..df_*`, `..ci_lo_*` and `..ci_hi_*` (see "Confidence @@ -736,11 +1125,30 @@ assign_features_to_polygons <- function( #' `agg_funs` entry per variable, `..sd_*` / `..se_*` for every numeric #' response and predictor, `..neff_*` / `..df_*` / `..ci_lo_*` / #' `..ci_hi_*` for the same columns when `conf_level` is given, -#' `cell_weight`, and `cell_area` / `n_per_area` when `area = TRUE`. An -#' input column also called `n` is not allowed to shadow the count. +#' `cell_weight`, `deff_applied` when a design effect was requested (any +#' `deff` other than 1), and `cell_area` / `n_per_area` when +#' `area = TRUE`. An input column also called `n` is not allowed to shadow +#' the count. +#' +#' `deff_applied` is `TRUE` on every row when the requested correction was +#' applied (exactly when the `"deff_applied"` attribute below is attached; +#' under `"kish"`, when any standard-error column was corrected) +#' and `FALSE` when it fell back to the uncorrected standard errors: a +#' refused `deff`, a `"variogram"` request with no usable model, or +#' `"kish"` ICCs of 0 for every variable type (and `NA` on a `cells_sf` +#' row no point fell in). +#' Unlike the attribute it survives `rbind()` and +#' `dplyr::bind_rows()` of many results. A fallback is also signalled by a +#' warning of class `"spatialkit_deff_fallback"` (a Kish ICC of 0 is +#' reported on `attr(, "icc")` instead), which +#' `tryCatch(spatialkit_deff_fallback = )` catches without matching the +#' message; it is raised only when the standard errors really are the +#' uncorrected ones. #' #' When a correction was actually applied, an attribute `"deff_applied"` is -#' attached recording it: `method` plus `icc_resp`/`icc_pred` for `"kish"`, +#' attached recording it: `method` plus `icc_resp`/`icc_pred` and `deff` +#' for `"kish"` (`deff` is the primary variable's per-cell design effect, +#' all 1 when only the predictor ICC was positive), #' `deff`/`deff_rows`/`rbar`/`crs`/`max_n` for `"variogram"` (`deff` is #' the design effect at the primary variable's non-missing count per cell, #' `deff_rows` at the cell's row count, which is the vector the log line @@ -749,8 +1157,8 @@ assign_features_to_polygons <- function( #' (`deff`, `deff_rows` and `rbar` alike) is realigned to the joined row #' order, so `deff[i]` and `rbar[i]` still describe row `i`; cells with no #' observations carry `NA`. No attribute is attached when no correction was -#' applied: `deff = 1`, a `deff = "kish"` ICC of 0, or a `"variogram"` -#' request that could not be fitted. A `deff = "kish"` request always +#' applied: `deff = 1`, a `deff = "kish"` request whose ICCs are all 0, or +#' a `"variogram"` request that could not be fitted. A `deff = "kish"` request always #' records the ICCs it estimated on an attribute `"icc"` (`resp` and #' `pred`, `NA` for a variable type with no numeric column), whether or not #' they were positive enough to apply, so a result with no `"deff_applied"` @@ -759,7 +1167,9 @@ assign_features_to_polygons <- function( #' The ID column keeps its input type when `cells_sf`'s ID column and the #' summarised IDs already have the same class. When the classes differ, both #' are coerced to character in order to join (logged as a warning), and the -#' returned ID column is therefore character. +#' returned ID column is therefore character. Whole numbers are written out +#' in full for that (`"100000"`, never `"1e+05"`), so an integer and a +#' double ID of the same cell still match. #' @examples #' library(sf) #' set.seed(1) @@ -830,6 +1240,22 @@ summarize_by_cell <- function(assigned_points_sf, call. = FALSE) if (!is.logical(area) || length(area) != 1L || is.na(area)) stop("summarize_by_cell(): `area` must be TRUE or FALSE.", call. = FALSE) + # c("val", "flag") used to stop with "the condition has length > 1", and a + # non-character name was looked up and skipped without a word. + if (!is.null(response_var) && + (!is.character(response_var) || length(response_var) != 1L || + is.na(response_var) || !nzchar(response_var))) + stop("summarize_by_cell(): `response_var` must be a single column name ", + "(a character string), or NULL; list further numeric columns in ", + "`predictor_vars`.", call. = FALSE) + if (!is.null(predictor_vars) && !is.character(predictor_vars)) + stop("summarize_by_cell(): `predictor_vars` must be a character vector of ", + "column names, or NULL.", call. = FALSE) + # Whether the caller asked for a design effect at all. Only then does the + # result carry the per-row `deff_applied` column, so a default call returns + # exactly the frame it always has. + deff_requested <- !(is.numeric(deff) && length(deff) == 1L && + isTRUE(deff == 1)) # A density needs the cells, and it needs them in a CRS whose areas are # comparable. Both are checked before any summary is computed, so a # request that cannot be honoured fails at once rather than after the @@ -870,8 +1296,34 @@ summarize_by_cell <- function(assigned_points_sf, .msg(sprintf("summarize_by_cell(): using id_col = '%s'", id_col)) # --- validate agg_funs --- + # A bare function (`agg_funs = median`) or a vector of function names + # (`"median"`) is what the documented options invite, and both used to be + # replaced by the mean with only a log line: resp_mean_v = 1.228 came back + # for a median of 0.927. + if (is.function(agg_funs)) { + # Named after the expression passed; `stats::median` used to give + # resp_agg1_v where `median` gave resp_median_v. + fn_expr <- substitute(agg_funs) + fn_name <- if (is.name(fn_expr)) as.character(fn_expr) + else if (is.call(fn_expr) && length(fn_expr) == 3L && + (identical(fn_expr[[1L]], as.name("::")) || + identical(fn_expr[[1L]], as.name(":::")))) + as.character(fn_expr[[3L]]) + else "agg1" + agg_funs <- stats::setNames(list(agg_funs), fn_name) + } else if (is.character(agg_funs) && length(agg_funs) > 0L && !anyNA(agg_funs)) { + fns <- lapply(agg_funs, function(nm) + tryCatch(match.fun(nm), error = function(e) NULL)) + if (all(vapply(fns, is.function, logical(1)))) + agg_funs <- stats::setNames(fns, agg_funs) + } if (!is.list(agg_funs) || length(agg_funs) == 0L) { - .log_warn("summarize_by_cell(): invalid agg_funs; falling back to mean.") + .warn_and_log(paste0("summarize_by_cell(): `agg_funs` must be a named list ", + "of functions, a function, or the names of functions; ", + "got %s. Falling back to the mean."), + if (is.character(agg_funs)) + paste(sprintf("'%s'", agg_funs), collapse = ", ") + else paste0("an object of class ", class(agg_funs)[1L])) agg_funs <- list(mean = function(x) mean(x, na.rm = TRUE)) } if (is.null(names(agg_funs)) || any(!nzchar(names(agg_funs)))) { @@ -882,18 +1334,27 @@ summarize_by_cell <- function(assigned_points_sf, use_kish <- identical(deff, "kish") use_vgm <- identical(deff, "variogram") if (use_vgm) { + # A subsample of 0 or 1 points has no pairs: the mean correlation came out + # NaN, the design effect 1 and the SEs uncorrected, on rows still marked + # deff_applied = TRUE; NA stopped with "missing value where TRUE/FALSE + # needed". Checked only here, where the argument is used. + .check_scalar(deff_max_n, "deff_max_n", "summarize_by_cell", min = 2, + max = .Machine$integer.max) # The SE closures below do arithmetic on `deff`; the per-cell variogram # values are applied after summarising, so neutralise it here. deff <- 1 } if (!use_kish && !use_vgm) { - if (!is.numeric(deff) || length(deff) != 1L || deff < 1) { + # is.finite(): NA and NaN made the test itself NA ("missing value where + # TRUE/FALSE needed"), and Inf passed it, gave uncorrected SEs (see + # .se_with_deff()) beside a cell_weight of 0 and a record of deff = Inf. + if (!is.numeric(deff) || length(deff) != 1L || !is.finite(deff) || deff < 1) { # A real warning, not a log line: silently substituting 1 for a value the # caller chose means the standard errors are not the ones they asked for, # and nothing in the returned object records that (no `deff_applied` is # attached when deff == 1). - .warn_and_log("summarize_by_cell(): `deff` must be a single number >= 1, \"kish\" or \"variogram\"; got %s. Falling back to deff = 1, so the standard errors are the uncorrected ones.", - paste(format(deff), collapse = ", ")) + .warn_deff_fallback("summarize_by_cell(): `deff` must be a single number >= 1 (and finite), \"kish\" or \"variogram\"; got %s. Falling back to deff = 1, so the standard errors are the uncorrected ones.", + paste(format(deff), collapse = ", ")) deff <- 1 } } @@ -966,13 +1427,18 @@ summarize_by_cell <- function(assigned_points_sf, } # --- resolve numeric columns for response and predictors --- + # A column that was asked for and cannot be summarised is a warning, not a + # progress message: .msg() prints nothing under the default quiet = TRUE, + # so a misspelt response_var returned a frame with no resp_* column, a + # cell_weight equal to n and (under "kish") no design effect, without a + # word. .resolve_numeric <- function(df, cols, label) { keep <- cols[cols %in% names(df)] if (length(keep) == 0L) return(character(0)) is_num <- vapply(keep, function(nm) is.numeric(df[[nm]]), logical(1)) if (!all(is_num)) { - .msg(sprintf("summarize_by_cell(): non-numeric %s columns skipped: %s", - label, paste(keep[!is_num], collapse = ", "))) + .warn_and_log("summarize_by_cell(): %s column(s) %s are not numeric and are not summarised.", + label, paste(sprintf("'%s'", keep[!is_num]), collapse = ", ")) } keep[is_num] } @@ -984,17 +1450,17 @@ summarize_by_cell <- function(assigned_points_sf, if (response_var %in% names(df)) { resp_num <- .resolve_numeric(df, response_var, "response") } else { - .msg(sprintf("summarize_by_cell(): response_var '%s' not found; skipping.", - response_var)) + .warn_and_log("summarize_by_cell(): response_var '%s' is not a column of `assigned_points_sf`; no resp_* columns are returned.", + response_var) } } if (!is.null(predictor_vars)) { + absent <- setdiff(predictor_vars, names(df)) + if (length(absent)) + .warn_and_log("summarize_by_cell(): predictor_vars %s are not columns of `assigned_points_sf` and are not summarised.", + paste(sprintf("'%s'", absent), collapse = ", ")) present <- predictor_vars[predictor_vars %in% names(df)] - if (length(present)) { - pred_num <- .resolve_numeric(df, present, "predictor") - } else { - .msg("summarize_by_cell(): none of the requested predictor_vars are present; skipping.") - } + if (length(present)) pred_num <- .resolve_numeric(df, present, "predictor") } # --- estimate ICC for Kish correction if requested --- @@ -1060,6 +1526,13 @@ summarize_by_cell <- function(assigned_points_sf, .vgm <- vgm # list(coords, cor_fn, max_n): per-column exact path .kish <- use_kish .id <- id_col + # The ..se_, ..neff_, ..df_ and ..ci_ closures each call this for the + # same column in the same cell (summarise() runs each of them over + # every cell in turn), and on the per-column variogram path every call + # rebuilt the cell's correlation matrix: five builds per column and + # cell with conf_level set. The statistics depend only on which rows + # enter, so they are kept against those rows. + .seen <- new.env(parent = emptyenv()) function(x) { ok <- !is.na(x) n_valid <- sum(ok) @@ -1091,8 +1564,13 @@ summarize_by_cell <- function(assigned_points_sf, dr <- if (!is.null(.dfr) && g %in% names(.dfr)) .dfr[[g]] else NA_real_ } else { rows <- dplyr::cur_group_rows()[ok] - st <- .cor_stats_from_coords(.vgm$coords[rows, , drop = FALSE], + key <- paste(rows, collapse = ",") + st <- .seen[[key]] + if (is.null(st)) { + st <- .cor_stats_from_coords(.vgm$coords[rows, , drop = FALSE], .vgm$cor_fn, max_n = .vgm$max_n) + assign(key, st, envir = .seen) + } rb <- st[["rbar"]]; dr <- st[["df_ratio"]] } deff_i <- if (is.finite(rb)) min(max(1, 1 + (n_valid - 1) * rb), n_valid) @@ -1174,19 +1652,50 @@ summarize_by_cell <- function(assigned_points_sf, # the correlation function then saturated at every within-cell distance, # deff came out equal to n, cell_weight collapsed to 1 and standard errors # were inflated 40-50x. Treat it like no fit at all. + # + # What replaces it is said once it is known. This used to raise the + # classed fallback warning ("Falling back to deff = 1") right here, and + # then a variogram estimated from `response_var` was applied after all + # (deff_applied TRUE, median deff 5.2), so tryCatch() on the class threw + # a corrected result away; with the estimate rejected too, one fallback + # gave two R warnings. Now a replaced `sac` gets a plain warning below, + # and an unreplaced one is named in the single fallback warning. + no_fit <- NULL # why no model is available, for the warning below + set_aside <- NULL # why a supplied `sac` was not used + set_aside_so <- "" # and what that means, for the replacement warning if (!is.null(sac) && is.na(suppressWarnings(as.numeric(sac))[1L]) && !is.null(attr(sac, "rejected_reason"))) { - .warn_and_log(paste0("summarize_by_cell(): the supplied `sac` reports no ", - "usable range (%s), so its fitted variogram model ", - "cannot size a design effect. Falling back to ", - "deff = 1."), - as.character(attr(sac, "rejected_reason"))) + set_aside <- sprintf("the supplied `sac` reports no usable range (%s)", + as.character(attr(sac, "rejected_reason"))[1L]) + set_aside_so <- ", so its fitted variogram model cannot size a design effect" + sac <- NULL + } else if (!is.null(sac) && is.null(attr(sac, "variogram_model"))) { + # A bare range -- a number, a units object -- carries no correlation + # function, and it was passed over without a word: the design effect + # came from a variogram estimated here, and nothing said that the value + # given had not been used. + set_aside <- sprintf(paste0("the supplied `sac` (%s) carries no fitted ", + "variogram model, and a range alone cannot ", + "size a design effect"), + if (is.numeric(sac)) paste(format(sac), collapse = ", ") + else sprintf("an object of class %s", class(sac)[1L])) sac <- NULL } + # A residual variogram used for the response's own standard errors is + # used as documented, but said so: kriging_adequacy() warns about the + # same attribute on the same object. + detrended_sac <- !is.null(sac) && isTRUE(attr(sac, "detrended")) vgm_model <- attr(sac, "variogram_model") vgm_crs <- attr(sac, "crs") if (is.null(vgm_model)) { - if (!is.null(response_var) && requireNamespace("gstat", quietly = TRUE)) { + # Why there is no model, for the fallback warning below: the only + # signal used to be a log line, which spatialkit_quiet() hides and no + # tryCatch() sees, while the standard errors came back uncorrected. + if (is.null(response_var)) { + no_fit <- "there is no `response_var` to fit one to" + } else if (!requireNamespace("gstat", quietly = TRUE)) { + no_fit <- "estimating one needs the 'gstat' package, which is not installed" + } else { .msg("summarize_by_cell(): no fitted variogram supplied; estimating one.") # On the RESPONSE, not on OLS residuals. The ..se_resp_* columns are # the SE of the cell mean as an estimate of the grand mean of the @@ -1202,20 +1711,33 @@ summarize_by_cell <- function(assigned_points_sf, silent = TRUE) # Same test on the internally estimated fit: a rejected range means the # model behind it is not usable either. - if (!inherits(est, "try-error") && - !(is.na(suppressWarnings(as.numeric(est))[1L]) && - !is.null(attr(est, "rejected_reason")))) { + if (inherits(est, "try-error")) { + no_fit <- sprintf("estimate_sac_range() failed: %s", + conditionMessage(attr(est, "condition"))) + } else if (is.na(suppressWarnings(as.numeric(est))[1L]) && + !is.null(attr(est, "rejected_reason"))) { + no_fit <- sprintf(paste0("the variogram estimated from `response_var` ", + "reports no usable range (%s)"), + as.character(attr(est, "rejected_reason"))[1L]) + } else { vgm_model <- attr(est, "variogram_model") vgm_crs <- attr(est, "crs") - } else if (!inherits(est, "try-error")) { - .warn_and_log(paste0("summarize_by_cell(): the estimated variogram ", - "reports no usable range (%s), so it cannot size ", - "a design effect. Falling back to deff = 1."), - as.character(attr(est, "rejected_reason"))) + if (is.null(vgm_model)) + no_fit <- "estimate_sac_range() returned no fitted model" } } } cor_fn <- .vgm_correlation_fn(vgm_model) + if (is.null(cor_fn) && .vgm_is_pure_nugget(vgm_model)) { + # No structured component: distinct observations are uncorrelated and + # a design effect of 1 is the exact answer, not a fallback. It used to + # be reported as "the supplied model could not be read", with the + # fallback warning and deff_applied FALSE. + .log_info(paste0("summarize_by_cell(): the variogram model is a pure ", + "nugget, so distinct observations are uncorrelated and ", + "the design effect is 1 in every cell.")) + cor_fn <- function(h) 0 * h + } if (is.null(cor_fn)) { # Name the family when that is the reason: a user-built Matern or power # model used to be read as exponential without a word. @@ -1223,20 +1745,40 @@ summarize_by_cell <- function(assigned_points_sf, setdiff(unique(as.character(vgm_model$model)), c("Nug", names(.vgm_shape_fns))) else character(0) if (length(other)) { - .warn_and_log(paste0("summarize_by_cell(): deff = \"variogram\" ", - "supports exponential, spherical and Gaussian ", - "variogram models (plus a nugget); the supplied ", - "model uses %s. Falling back to deff = 1."), - paste(sQuote(other, FALSE), collapse = ", ")) + .warn_deff_fallback(paste0("summarize_by_cell(): deff = \"variogram\" ", + "supports exponential, spherical and Gaussian ", + "variogram models (plus a nugget); the supplied ", + "model uses %s. Falling back to deff = 1."), + paste(sQuote(other, FALSE), collapse = ", ")) } else { - .log_warn(paste0("summarize_by_cell(): deff = \"variogram\" requires a ", - "fitted variogram model; none was available (pass one ", - "via `sac = estimate_sac_range(...)`). Falling back to ", - "deff = 1.")) + .warn_deff_fallback(paste0("summarize_by_cell(): deff = \"variogram\" requires ", + "a fitted variogram model; none was available (%s). ", + "Pass one via `sac = estimate_sac_range(...)`. ", + "Falling back to deff = 1, so the standard errors ", + "are the uncorrected ones."), + paste(c(set_aside, + if (is.null(no_fit)) "the supplied model could not be read" + else no_fit), + collapse = "; ")) } use_vgm <- FALSE deff <- 1 } else { + if (!is.null(set_aside)) + .warn_and_log(paste0("summarize_by_cell(): %s%s. It was set aside, ", + "and the design effect uses the variogram estimated ", + "from `response_var` instead."), + set_aside, set_aside_so) + if (detrended_sac && length(resp_num)) + .warn_and_log(paste0("summarize_by_cell(): `sac` is the variogram of the ", + "residuals on predictors (detrend = \"%s\"), but the ", + "..se_resp_* columns estimate the grand mean of the ", + "response, whose own correlation is the one to correct ", + "for; a residual variogram is weaker, so those standard ", + "errors are understated. Pass a variogram of the ", + "response (estimate_sac_range() without predictor_vars) ", + "or sac = NULL."), + as.character(attr(sac, "detrend_method") %||% "ols")[1L]) # st_coordinates() returns one row per VERTEX, so any non-POINT geometry # (this function accepts POLYGON and MULTIPOINT features) would misalign # coords_mat with `df` and feed the wrong points into every cell. @@ -1262,6 +1804,19 @@ summarize_by_cell <- function(assigned_points_sf, ensure_projected(pts_for_deff) } coords_mat <- sf::st_coordinates(pts_for_deff)[, 1:2, drop = FALSE] + # An empty point has no location to correlate. It still counts towards + # its cell's values, and .cor_stats_from_coords() leaves it out of the + # correlation; it used to stop the call with "missing value where + # TRUE/FALSE needed", while deff = "kish" took the same layer. + unlocated <- !(is.finite(coords_mat[, 1]) & is.finite(coords_mat[, 2])) & + !is.na(df[[id_col]]) + if (any(unlocated)) + .warn_and_log(paste0("summarize_by_cell(): %d point(s) have empty or ", + "non-finite coordinates; their values are ", + "summarised, but the variogram design effect of ", + "their cells is computed from the located points ", + "only."), + sum(unlocated)) # Per-cell mean off-diagonal correlation, NOT a per-cell deff: the design # effect each column needs is 1 + (n_valid - 1) * rbar for ITS non-missing @@ -1270,7 +1825,7 @@ summarize_by_cell <- function(assigned_points_sf, max_n = deff_max_n) vgm_rbar <- vgm_stats$rbar vgm_deff <- .cell_deff_variogram(coords_mat, df[[id_col]], cor_fn, - max_n = deff_max_n) + max_n = deff_max_n, r_bar = vgm_rbar) vgm_bits <- list(coords = coords_mat, cor_fn = cor_fn, max_n = deff_max_n, df_ratio = vgm_stats$df_ratio) .msg(sprintf( @@ -1331,8 +1886,11 @@ summarize_by_cell <- function(assigned_points_sf, # of information about the response, not 5. (`n` still reports rows.) primary_col <- if (has_resp) resp_num[[1L]] else if (has_pred) pred_num[[1L]] else NULL n_valid_primary <- if (is.null(primary_col)) out$n else { - cnt <- tapply(!is.na(df[[primary_col]]), df[[id_col]], sum) - v <- as.numeric(cnt[as.character(out[[id_col]])]) + # exclude = NULL keeps the group of rows with no cell ID (from + # keep_unassigned = TRUE), which is a summary row too: tapply() dropped + # it, and its cell_weight came out 0 beside n = 5 and a finite SE. + cnt <- tapply(!is.na(df[[primary_col]]), factor(df[[id_col]], exclude = NULL), sum) + v <- as.numeric(cnt[match(as.character(out[[id_col]]), names(cnt))]) v[is.na(v)] <- 0 v } @@ -1352,9 +1910,14 @@ summarize_by_cell <- function(assigned_points_sf, primary_rho <- if (has_resp) max(resp_rho, 0) else if (has_pred) max(pred_rho, 0) else 0 - if (primary_rho > 0) { - deff_per_cell <- pmax(1, 1 + (n_valid_primary - 1) * primary_rho) + deff_per_cell <- pmax(1, 1 + (n_valid_primary - 1) * primary_rho) + if (primary_rho > 0) out$cell_weight <- n_valid_primary / deff_per_cell + # Recorded whenever EITHER ICC corrected its columns. Keyed on the + # primary variable alone, a clustered predictor beside an unclustered + # response had its SEs inflated 11x on rows marked deff_applied = FALSE, + # with no attribute. `deff` stays the primary variable's (all 1 then). + if (max(resp_rho, pred_rho, 0) > 0) { attr(out, "deff_applied") <- list( method = "kish", icc_resp = if (has_resp) resp_rho else NA_real_, @@ -1417,16 +1980,48 @@ summarize_by_cell <- function(assigned_points_sf, attr(out, "icc") <- list( resp = if (has_resp) as.numeric(resp_rho) else NA_real_, pred = if (has_pred) as.numeric(pred_rho) else NA_real_) - + # The same fact per row. The attribute does not survive rbind(), + # dplyr::bind_rows() or most dplyr verbs, so results combined across calls + # (a simulation, a benchmark over many layers) could not tell a row whose + # design effect fell back to 1 from one that was corrected, and a fallback + # fires when the variogram is rejected -- often when correlation is + # strongest. Only when a design effect was requested, so the default + # frame is unchanged. + if (deff_requested) + out$deff_applied <- !is.null(attr(out, "deff_applied")) + if (!is.null(cells_sf)) { if (!inherits(cells_sf, "sf")) { - .log_warn("summarize_by_cell(): cells_sf is not an sf object; returning plain data.frame.") + # A warning, not a log line: the documented return is an sf layer. + .warn_and_log("summarize_by_cell(): `cells_sf` is not an sf object; returning a plain data frame without cell geometry.") } else { - # Locate the matching ID column in cells_sf - cells_id_candidates <- unique(c(id_col, "poly_id", "polygon_id", "cell_id")) + # Locate the matching ID column in cells_sf: the candidates, in the + # order, that assign_features_to_polygons() reads the polygons' IDs + # from, so the cells are read the way the points were labelled. 'id' + # and 'grid_id' were missing here, so cells keyed by 'id' (common in a + # shapefile) were assigned cleanly and then summarised to a plain table + # with no geometry, and cells with 'id' and a differently numbered + # 'cell_id' were joined on 'cell_id', putting most summaries on the + # wrong polygons. + cells_id_candidates <- unique(c(id_col, "poly_id", "polygon_id", "id", + "cell_id", "grid_id")) cells_id_found <- cells_id_candidates[cells_id_candidates %in% names(cells_sf)] - if (length(cells_id_found) > 0L) { + if (length(cells_id_found) == 0L) { + msg <- sprintf(paste0("`cells_sf` has none of the ID columns %s, so the ", + "summaries cannot be joined to it"), + paste(sprintf("'%s'", cells_id_candidates), collapse = ", ")) + if (isTRUE(area)) + stop("summarize_by_cell(): `area = TRUE` needs the cells' areas, but ", + msg, ". Rename the cells' ID column to '", id_col, "'.", + call. = FALSE) + .warn_and_log("summarize_by_cell(): %s; returning a plain data frame without cell geometry. Rename the cells' ID column to '%s'.", + msg, id_col) + } else { cells_id <- cells_id_found[[1]] + if (cells_id != id_col) + .log_info(paste0("summarize_by_cell(): `cells_sf` has no '%s' column; ", + "joining the summaries on its '%s' column."), + id_col, cells_id) # Keep only geometry + id from cells to avoid column collisions cells_slim <- cells_sf[, cells_id, drop = FALSE] # A duplicated cell ID makes left_join() emit one summary row per @@ -1454,9 +2049,26 @@ summarize_by_cell <- function(assigned_points_sf, id_col, paste(class(cells_slim[[id_col]]), collapse = "/"), paste(class(out[[id_col]]), collapse = "/"), id_col ) - out[[id_col]] <- as.character(out[[id_col]]) - cells_slim[[id_col]] <- as.character(cells_slim[[id_col]]) + out[[id_col]] <- .id_as_character(out[[id_col]]) + cells_slim[[id_col]] <- .id_as_character(cells_slim[[id_col]]) } + # A summarised cell that matches no polygon is dropped by the join + # below, with its points. That was silent -- the coercion above lost + # every cell whose double ID R prints in scientific notation, 11 of 30 + # points in one check -- and it is also what a `cells_sf` other than + # the layer the points were assigned to looks like. + ids_out <- out[[id_col]] + unmatched <- !is.na(ids_out) & !(ids_out %in% cells_slim[[id_col]]) + if (any(unmatched)) + .warn_and_log(paste0("summarize_by_cell(): %d of the %d summarised cell ", + "ID(s) (%s) match no `cells_sf$%s`, so they and the ", + "%d point(s) in them are not in the result. Check ", + "that `cells_sf` is the layer the points were ", + "assigned to."), + sum(unmatched), sum(!is.na(ids_out)), + paste(utils::head(.id_as_character(ids_out[unmatched]), 5L), + collapse = ", "), + cells_id, sum(out$n[unmatched])) # dplyr::left_join() rebuilds attributes from the `x` template, which # silently drops "deff_applied". Save it, then re-attach it, mapping @@ -1487,7 +2099,12 @@ summarize_by_cell <- function(assigned_points_sf, # Realigning $deff alone left $rbar in pre-join order and pre-join # length, so deff[i] and rbar[i] described different cells and the # identity deff = 1 + (n-1) * rbar no longer held row-wise. - for (fld in c("deff", "deff_rows", "rbar")) { + # A fixed deff is one number, not a per-cell vector: with exactly + # one cell summarised its length matched, and deff = 2 came back + # as c(2, NA, NA, ...). + flds <- if (identical(deff_attr$method, "fixed")) character(0) + else c("deff", "deff_rows", "rbar") + for (fld in flds) { v <- deff_attr[[fld]] if (!is.null(v) && length(v) == length(pre_join_id)) { lookup <- stats::setNames(v, pre_join_id) @@ -1496,11 +2113,24 @@ summarize_by_cell <- function(assigned_points_sf, } attr(out, "deff_applied") <- deff_attr } - } else { - .log_warn("summarize_by_cell(): cells_sf has no matching ID column; returning plain data.frame.") } } } out } + + +# as.character() writes a double in scientific notation from 1e5 on +# ("1e+05") but an integer or a string in full ("100000"), so a join across +# ID classes lost every cell whose double ID R prints that way. Whole +# numbers are written out digit by digit, and anything else as +# as.character() writes it (format(scientific = FALSE) would pad every +# element to a common width). +.id_as_character <- function(x) { + if (!is.double(x) || is.object(x)) return(as.character(x)) + out <- as.character(x) + whole <- is.finite(x) & x == trunc(x) & abs(x) < 2^53 + out[whole] <- sprintf("%.0f", x[whole] + 0) # + 0 turns -0 into 0 + out +} diff --git a/R/block-size-sweep.R b/R/block-size-sweep.R index 9843045..97195dd 100644 --- a/R/block-size-sweep.R +++ b/R/block-size-sweep.R @@ -19,20 +19,36 @@ #' @section The fit budget: #' Each block size is a full cross-validation, so the cost is #' \code{length(block_sizes) * k} fits, plus \code{k} for the random -#' reference. \code{max_fits} caps that (default 60: six sizes at -#' \code{k = 5}, plus the reference). A sweep that would run past the cap +#' reference. \code{max_fits} caps that (default 60: room for up to eleven +#' sizes at \code{k = 5} plus the reference; the default six-size ladder at +#' \code{k = 5} needs at most 35). A sweep that would run past the cap #' refuses to start, naming the number of fits it would have needed. Raise #' \code{max_fits} deliberately; the RF example below takes seconds, a Bayesian #' \code{fit_fn} takes minutes per fit. #' #' @section The ladder: #' When \code{block_sizes} is \code{NULL}, \code{n_sizes} values are -#' log-spaced from a twenty-fifth to a half of the shorter side of the -#' data's extent, and any size at which the grid would hold fewer than -#' \code{k} blocks is dropped, so every point on the curve is a \code{k}-fold -#' cross-validation of the same shape. Sizes are in the units of the CRS the -#' folds are built in (\code{make_folds()}'s \code{params$crs}, metres for -#' geographic input), and the returned table records that CRS. +#' log-spaced from a twenty-fifth of the shorter side of the data's extent +#' (of the longer side when the points lie on one line parallel to an axis) +#' to the largest size, at most half that side, at which the grid still +#' holds \code{k} blocks. Half the side gives a grid two blocks across, +#' enough for \code{k} up to 4 and, for larger \code{k}, on an extent long +#' enough in the other direction; on a roughly square extent at the default +#' \code{k = 5} the top is about a third of the side. Any size at which the +#' grid would hold more than the 1,000,000 \code{make_folds()} will build is +#' dropped. The count is of grid cells: on clustered data a grid +#' of \code{k} or more cells can have fewer than \code{k} that hold points, +#' and \code{make_folds()} then lowers \code{k} at that size, which the +#' \code{k} column shows. On an extent much longer than it is wide every +#' rung can fall below the autocorrelation range while longer blocks would +#' still fit \code{k} times along the longer side; the sweep warns when +#' that happens, and \code{block_sizes} is then the way to reach past the +#' range. Sizes are in the units of the CRS the folds are built in +#' (\code{make_folds()}'s \code{params$crs}, metres for geographic input), +#' and the returned table records that CRS. Each is the \emph{minimum} block +#' edge handed to \code{make_folds()}, which fits a whole number of cells +#' across the extent, so the cells are somewhat longer than the size on the +#' axis (up to twice as long). #' #' @param data_sf An sf object with the response and predictors. #' @param response_var,predictor_vars Column names. @@ -40,8 +56,11 @@ #' as for \code{\link{cv_spatial}()}; see the example for wrapping a #' built-in backend. #' @param block_sizes Optional numeric vector of block edge lengths to sweep, -#' in the CRS units the folds are built in. Default \code{NULL}: the ladder -#' described above. +#' in the CRS units the folds are built in (plain numbers; a \code{units} +#' object is refused). Default \code{NULL}: the ladder described above. +#' A size at which the grid would hold fewer than \code{k} blocks is not +#' run, with a warning naming it and the largest size that still gives +#' \code{k} blocks; if no size is left, the call is an error. #' @param n_sizes Number of sizes in the default ladder. Default 6. #' @param k Folds per cross-validation. Default 5. #' @param metric Which column of \code{overall} to read. Default @@ -50,9 +69,12 @@ #' reference. Default \code{TRUE}. #' @param max_fits The fit budget; see above. Default 60. #' @param sac Optional \code{sac_range} from \code{\link{estimate_sac_range}()} -#' to mark on the curve. Default \code{NULL}: estimated here from the -#' response, detrended on \code{predictor_vars}, when \pkg{gstat} is -#' installed. +#' to mark on the curve, or a single number in the units of the CRS the +#' folds are built in. An \code{estimate_sac_range()} result records the +#' CRS it was fitted in; when that is not the sweep's, the range is +#' converted to the sweep's units, with a warning. Default \code{NULL}: +#' estimated here from the response, detrended on \code{predictor_vars}, +#' when \pkg{gstat} is installed. #' @param seed Seed for the fold construction at every size. #' @param quiet Suppress the progress messages. Default \code{FALSE}. #' @param ... Passed to \code{\link{cv_spatial}()} at every size @@ -65,8 +87,10 @@ #' actually built), \code{n_folds_succeeded}, \code{value} (the pooled #' metric), \code{fold_min}, \code{fold_max} and \code{fold_sd} (its spread #' across folds). Attributes: \code{metric}, \code{sac_range} (the -#' effective range, or \code{NA}), \code{crs}, \code{n_fits}, and -#' \code{results}, the full \code{cv_spatial()} result at every size. +#' effective range, or \code{NA}), \code{crs}, \code{k} (the folds +#' requested, which \code{print()} and \code{plot()} report), +#' \code{n_fits}, \code{response_var}, and \code{results}, the full +#' \code{cv_spatial()} result at every size. #' \code{plot()} draws it. #' @family cross-validation #' @seealso \code{\link{plot.block_size_sweep}()}. @@ -116,23 +140,41 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, # The extent the ladder is built over, in the CRS the folds will use. pts <- prep_model_data(data_sf, response_var, predictor_vars) bb <- sf::st_bbox(pts) + crs_lbl <- .fold_crs_label(pts) + if (is.na(crs_lbl)) crs_lbl <- "the data's CRS" w <- as.numeric(bb["xmax"] - bb["xmin"]); h <- as.numeric(bb["ymax"] - bb["ymin"]) side <- min(w, h) + # Points on one straight axis-parallel line have a zero side, and + # make_folds() blocks them along the other one without complaint; the + # sweep refused them as having "no extent". Run the ladder along the line. + if (is.finite(side) && side <= 0) side <- max(w, h) if (!is.finite(side) || side <= 0) stop("cv_block_size_sweep(): the data have no extent to build blocks over.", call. = FALSE) - if (is.null(block_sizes)) { + default_ladder <- is.null(block_sizes) + if (default_ladder) { if (!is.numeric(n_sizes) || length(n_sizes) != 1L || n_sizes < 1) stop("cv_block_size_sweep(): `n_sizes` must be a positive number.", call. = FALSE) - # The top sits a hair under half the side so that floor(side / bs) is 2 - # rather than a floating-point 1, which would drop the largest size. - block_sizes <- exp(seq(log(side / 25), log(side / 2 * (1 - 1e-9)), + # The top is the largest size, at most a hair under half the side, whose + # grid still holds k cells. Half the side itself is a 2 x 2 grid on a + # roughly square extent, which at the default k = 5 holds too few cells, + # so one rung in six was always dropped and the ladder stopped near 0.3 + # of the side, short of ranges that side / 3 blocks (a 3 x 3 grid) reach. + # The hair keeps floor(side / bs) at 2 rather than a floating-point 1. + top <- .sweep_largest_size_for_k(bb, k, cap = side / 2 * (1 - 1e-9)) + if (!is.finite(top)) top <- side / 2 * (1 - 1e-9) + block_sizes <- exp(seq(log(side / 25), log(top), length.out = as.integer(n_sizes))) } else { - if (!is.numeric(block_sizes) || !length(block_sizes) || any(!is.finite(block_sizes)) || - any(block_sizes <= 0)) - stop("cv_block_size_sweep(): `block_sizes` must be positive numbers.", call. = FALSE) + # A `units` object passes is.numeric() and then fails the comparison + # inside the units package with a message that names no argument. + if (inherits(block_sizes, "units") || !is.numeric(block_sizes) || + !length(block_sizes) || any(!is.finite(block_sizes)) || any(block_sizes <= 0)) + stop("cv_block_size_sweep(): `block_sizes` must be positive numbers, given as ", + "plain numbers in ", crs_lbl, " units; got ", + if (length(block_sizes)) paste(format(block_sizes), collapse = ", ") + else "a value of length 0", ".", call. = FALSE) block_sizes <- sort(unique(as.numeric(block_sizes))) } # Every point on the curve is a k-fold CV of the same shape: drop the sizes @@ -140,11 +182,47 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, n_blocks <- vapply(block_sizes, function(bs) { d <- .block_dims_from_size(bb, bs); as.numeric(d$nx) * as.numeric(d$ny) }, numeric(1)) + # make_folds() refuses a grid of more than .block_max_cells blocks as a + # likely unit mistake. On a thin transect the default ladder, built from + # the shorter side, starts far below that (0.08 m on a 6 km x 2 m layer: + # 1.9 million blocks), and the sweep died there telling the user to check + # the units of a `block_size` they never passed. Drop those rungs of the + # default ladder; sizes the caller chose are refused up front instead, + # before any model is fitted, naming the argument they came from. + too_fine <- n_blocks > .block_max_cells + if (any(too_fine) && !default_ladder) + stop(sprintf(paste0("cv_block_size_sweep(): `block_sizes` %s would each ", + "need a grid of more than %s blocks over the %s x %s ", + "extent (in %s units). Check that they are in those ", + "units."), + paste(signif(block_sizes[too_fine], 3), collapse = ", "), + format(.block_max_cells, big.mark = ",", scientific = FALSE), + signif(w, 3), signif(h, 3), crs_lbl), call. = FALSE) + if (any(too_fine)) + .log_info("cv_block_size_sweep(): dropping %d block size(s) whose grid would exceed %s blocks: %s.", + sum(too_fine), format(.block_max_cells, big.mark = ",", scientific = FALSE), + paste(signif(block_sizes[too_fine], 3), collapse = ", ")) dropped <- block_sizes[n_blocks < k] - block_sizes <- block_sizes[n_blocks >= k] - if (length(dropped)) + block_sizes <- block_sizes[n_blocks >= k & !too_fine] + # Sizes the caller chose are not dropped behind a log line: the table would + # simply lack rows that were asked for. The default ladder's own rungs + # (see @section The ladder) are the sweep's business and stay logged. When + # nothing is left, the error below says so instead. + if (length(dropped) && !default_ladder && length(block_sizes)) { + b_max <- .sweep_largest_size_for_k(bb, k) + .warn_and_log(paste0("cv_block_size_sweep(): `block_sizes` %s give fewer ", + "than k = %d blocks over the %s x %s extent (in %s ", + "units) and were not run%s."), + paste(signif(dropped, 3), collapse = ", "), k, + signif(w, 3), signif(h, 3), crs_lbl, + if (is.finite(b_max)) + sprintf("; the largest size whose grid holds k blocks is %s", + format(.signif_down(b_max))) + else "") + } else if (length(dropped)) { .log_info("cv_block_size_sweep(): dropping %d block size(s) whose grid holds fewer than k = %d blocks: %s.", length(dropped), k, paste(signif(dropped, 3), collapse = ", ")) + } if (!length(block_sizes)) stop("cv_block_size_sweep(): no block size leaves at least k = ", k, " blocks over the extent (", signif(w, 3), " x ", signif(h, 3), @@ -163,7 +241,38 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, # The autocorrelation range to mark: supplied, or estimated once here. sac_range <- NA_real_ if (!is.null(sac)) { - sac_range <- suppressWarnings(as.numeric(sac)) + if (inherits(sac, "units")) + stop("cv_block_size_sweep(): `sac` must be a plain number in ", crs_lbl, + " units, or an estimate_sac_range() result; got ", format(sac), ".", + call. = FALSE) + sac_range <- suppressWarnings(as.numeric(sac)[1L]) + # The marker is drawn on an axis in the sweep's CRS. A range estimated on + # a copy of the layer in another CRS was drawn as it stood: a metre range + # on a US-foot axis sat between the first two rungs instead of the third + # and fourth, with the sweep's CRS printed beside it. + from <- attr(sac, "crs") + from <- if (is.null(from)) NULL else tryCatch(sf::st_crs(from), error = function(e) NULL) + to <- sf::st_crs(pts) + if (is.finite(sac_range) && !is.null(from) && !is.na(from) && !is.na(to) && + from != to) { + conv <- if (!isTRUE(sf::st_is_longlat(from)) && !isTRUE(sf::st_is_longlat(to))) + .range_to_crs(sac_range, from, to, bb) else NA_real_ + if (is.finite(conv) && conv > 0) { + .warn_and_log(paste0("cv_block_size_sweep(): `sac` was estimated in %s, ", + "not in %s where the block sizes are measured; its ", + "range %s has been converted to %s by measuring it at ", + "the centre of the data. Estimate the range on the ", + "layer passed here to mark it exactly."), + .fold_crs_label(from), crs_lbl, format(signif(sac_range, 4)), + format(signif(conv, 4))) + sac_range <- conv + } else { + .warn_and_log(paste0("cv_block_size_sweep(): `sac` was estimated in %s, ", + "not in %s where the block sizes are measured, and ", + "could not be converted; its marker may be misplaced."), + .fold_crs_label(from), crs_lbl) + } + } } else if (requireNamespace("gstat", quietly = TRUE)) { est <- try(logger::with_log_threshold( estimate_sac_range(pts, response_var, predictor_vars = predictor_vars, @@ -172,6 +281,34 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, if (!inherits(est, "try-error")) sac_range <- suppressWarnings(as.numeric(est)) } + # The default ladder stops at half the SHORTER side at most. On an + # elongated extent that can leave every rung below the range while blocks + # as long as the range would still give k blocks along the other side: on a + # 10 km x 100 m corridor with a 1.7 km range the ladder ran from 4 to 50 m, + # the curve stayed flat near the random-fold reference, and read as "no + # leakage". The ladder is kept (see @section The ladder); say what it + # cannot show. Since the ladder's top is the largest size up to half the + # shorter side whose grid holds k cells, a range above it that still gives + # k cells can only lie past half the shorter side. The warning used to + # call the top kept rung "half the shorter side" and quote the longer side + # over k as the largest size that works, which on a square was below rungs + # already run. + if (default_ladder && length(sac_range) == 1L && is.finite(sac_range) && + sac_range > max(block_sizes)) { + at_range <- .block_dims_from_size(bb, sac_range) + if (as.numeric(at_range$nx) * as.numeric(at_range$ny) >= k) + .warn_and_log(paste0("cv_block_size_sweep(): every block size in the ", + "default ladder (up to %s, over the %s x %s extent) ", + "is below the estimated autocorrelation range (%s), ", + "so the curve cannot show the rise past it. Blocks up ", + "to %s still give k = %d blocks (the largest size ", + "whose grid does); pass `block_sizes` reaching past ", + "the range."), + format(signif(max(block_sizes), 3)), signif(w, 3), signif(h, 3), + format(signif(sac_range, 4)), + format(.signif_down(.sweep_largest_size_for_k(bb, k))), k) + } + # The folds are built here, on the layer as passed (as compare_models_cv() # does), so that make_folds()'s own record of the grid -- blocks_used, the # k actually built -- is to hand; cv_spatial() then runs on them. No @@ -229,6 +366,113 @@ cv_block_size_sweep <- function(data_sf, response_var, predictor_vars, fit_fn, } +#' The largest block size whose grid still holds k cells +#' +#' The number of cells \code{.block_dims_from_size()} gives, +#' \code{max(1, floor(w / b)) * max(1, floor(h / b))}, only falls as \code{b} +#' grows, and changes only at \code{b = w / i} or \code{b = h / j}. So the +#' largest \code{b <= cap} with at least \code{k} cells is \code{cap} itself or +#' one of those breakpoints. Only \code{i} from \code{ceiling(w / cap)} to +#' \code{max(that, k)} can matter (at \code{b = w / i} there are at least +#' \code{i} cells, so \code{w / max(i0, k)} always qualifies), and likewise +#' for \code{j}. Each candidate is taken a hair (\code{1e-9}) under its +#' breakpoint, so that \code{floor()} lands on the intended count rather than +#' one below it. +#' +#' @param bb A bbox. +#' @param k Required number of cells. +#' @param cap Largest size allowed. +#' @return A single number, or \code{NA} when the extent is empty. +#' @keywords internal +#' @noRd +.sweep_largest_size_for_k <- function(bb, k, cap = Inf) { + w <- as.numeric(bb["xmax"] - bb["xmin"]); h <- as.numeric(bb["ymax"] - bb["ymin"]) + cells <- function(b) { + d <- .block_dims_from_size(bb, b); as.numeric(d$nx) * as.numeric(d$ny) + } + if (is.finite(cap) && cap > 0 && cells(cap) >= k) return(cap) + divs <- function(len) { + if (!is.finite(len) || len <= 0) return(numeric(0)) + i0 <- max(1, ceiling(len / cap)) + len / seq(i0, max(i0, k)) * (1 - 1e-9) + } + cand <- c(divs(w), divs(h)) + cand <- cand[cand > 0 & cand <= cap] + ok <- cand[vapply(cand, cells, numeric(1)) >= k] + if (length(ok)) max(ok) else NA_real_ +} + + +#' Round a length down to three significant figures +#' +#' For a size quoted as the largest that still works: rounding it up can take +#' it past the breakpoint, so a size copied from the message would fail. +#' +#' @param x A positive number. +#' @return A number no larger than \code{x}. +#' @keywords internal +#' @noRd +.signif_down <- function(x, digits = 3L) { + if (!is.finite(x) || x <= 0) return(x) + p <- 10^(floor(log10(x)) - digits + 1L) + floor(x / p) * p +} + + +#' Which direction is better for a swept metric +#' +#' Read by the plot's caption. R-squared is better higher, and the error +#' metrics lower. An interval coverage is neither: one that covers more +#' than its nominal level is as miscalibrated as one that covers less, so a +#' \code{coverage_*} column is read by its closeness to the level in its +#' name. The name is parsed rather than matched, because the level can be +#' written at any precision (\code{coverage_97.5} for 0.975); only +#' \code{coverage_50}, \code{coverage_80} and \code{coverage_95} were +#' recognised, and as higher-is-better. +#' +#' @param metric Column name of \code{overall}. +#' @return A phrase, e.g. \code{"lower is better"}. +#' @keywords internal +#' @noRd +.sweep_better <- function(metric) { + if (grepl("^coverage_", metric)) { + lvl <- suppressWarnings(as.numeric(sub("^coverage_", "", metric))) / 100 + return(if (length(lvl) == 1L && is.finite(lvl) && lvl > 0 && lvl < 1) + sprintf("closer to %s is better", format(lvl)) + else "closer to the nominal level is better") + } + if (metric %in% c("R2", "Adj_R2")) "higher is better" else "lower is better" +} + + +#' Re-express a length measured in one projected CRS in another +#' +#' Transforms two unit segments of length \code{r} (east-west and +#' north-south), laid at the centre of \code{bb}, from \code{from} to +#' \code{to}, and returns their mean length there. Exact when the two CRSs +#' differ only in their linear unit; an approximation, good near the centre +#' of the data, when the projections differ. +#' +#' @param r Length in \code{from}'s units. +#' @param from,to Projected \code{crs} objects. +#' @param bb A bbox in \code{to}. +#' @return A single number, or \code{NA} when the transform fails. +#' @keywords internal +#' @noRd +.range_to_crs <- function(r, from, to, bb) { + tryCatch({ + ctr <- sf::st_sfc(sf::st_point(c(mean(as.numeric(bb[c("xmin", "xmax")])), + mean(as.numeric(bb[c("ymin", "ymax")])))), + crs = to) + a <- sf::st_coordinates(sf::st_transform(ctr, from))[1L, 1:2] + seg <- sf::st_transform(sf::st_sfc(sf::st_point(a), sf::st_point(a + c(r, 0)), + sf::st_point(a + c(0, r)), crs = from), to) + xy <- sf::st_coordinates(seg)[, 1:2, drop = FALSE] + mean(c(sqrt(sum((xy[2L, ] - xy[1L, ])^2)), sqrt(sum((xy[3L, ] - xy[1L, ])^2)))) + }, error = function(e) NA_real_) +} + + #' @export print.block_size_sweep <- function(x, ...) { metric <- attr(x, "metric"); r <- attr(x, "sac_range") @@ -264,7 +508,11 @@ print.block_size_sweep <- function(x, ...) { #' reference as a dashed line, and the estimated autocorrelation range as a #' vertical marker. Blocks smaller than the range leak, so the curve rises #' from the reference towards the range and plateaus beyond it; the height -#' of the rise is what the random-fold number overstated. +#' of the rise is what the random-fold number overstated. The caption says +#' which way is better: higher for \code{R2} and \code{Adj_R2}, closer to +#' the nominal level for a \code{coverage_*} column (0.975 for +#' \code{coverage_97.5}), since over-coverage is miscalibration too, and +#' lower for everything else. #' #' @param x A \code{block_size_sweep}. #' @param ... Ignored. @@ -316,7 +564,6 @@ plot.block_size_sweep <- function(x, ...) { colour = "grey40") if (is.finite(r)) p <- p + ggplot2::geom_vline(xintercept = r, linetype = "dotted", colour = "#B2182B") - minimise <- !(metric %in% c("R2", "Adj_R2", "coverage_50", "coverage_80", "coverage_95")) p + ggplot2::scale_x_log10() + ggplot2::labs( title = sprintf("Cross-validated %s against block size", metric), @@ -325,8 +572,8 @@ plot.block_size_sweep <- function(x, ...) { else "Autocorrelation range not identified; no marker drawn", caption = paste(c( if (nrow(rnd)) sprintf("Dashed: random folds, %s = %.3g (the leaky reference)", metric, rnd$value[1L]), - sprintf("Band: fold-to-fold range; %d folds per size, %d fits in total; %s is better", - attr(x, "k"), attr(x, "n_fits"), if (minimise) "lower" else "higher")), + sprintf("Band: fold-to-fold range; %d folds per size, %d fits in total; %s", + attr(x, "k"), attr(x, "n_fits"), .sweep_better(metric))), collapse = "\n"), x = sprintf("Block edge length (%s, log scale)", unit), y = metric) + ggplot2::theme_minimal() diff --git a/R/cross-validation.R b/R/cross-validation.R index 45934c1..6e1ab1e 100644 --- a/R/cross-validation.R +++ b/R/cross-validation.R @@ -27,7 +27,9 @@ #' \code{keep_idx}. \code{fold_id} is the fold's index in the ORIGINAL #' \code{folds} object, carried through so that dropping an unusable fold #' does not renumber the survivors: downstream \code{fold} columns then still -#' agree with \code{make_folds()$assignment$fold}. +#' agree with \code{make_folds()$assignment$fold}. Splits that already +#' carry a \code{fold_id} (the \code{$folds} of a \code{cv_*()} result) +#' keep it, when every one is a distinct whole number of at least 1. #' @keywords internal #' @noRd .remap_folds <- function(folds, keep_idx, k = 5L, seed = 123L) { @@ -41,13 +43,8 @@ "rows numbered, or make the IDs unique."), sum(duplicated(keep_idx))), call. = FALSE) if (is.null(folds)) { - .log_warn( - "cross-validation: no fold specification provided; falling back to random k-fold CV (k=%d). Random folds leak spatial autocorrelation and overstate out-of-sample performance.", - k - ) - warning( - "cross-validation: falling back to random k-fold CV. For spatial data, use make_folds(method='block_kfold') to avoid optimistic performance estimates.", - call. = FALSE + .warn_and_log( + "cross-validation: falling back to random k-fold CV. For spatial data, use make_folds(method='block_kfold') to avoid optimistic performance estimates." ) cleanup <- .with_seed(seed) on.exit(cleanup(), add = TRUE) @@ -103,6 +100,23 @@ # fold below removes an element from the list, and without this every later # fold would be silently renumbered, so fold_metrics$fold and # predictions$fold would no longer line up with make_folds()$assignment$fold. + # A split that already carries a fold_id keeps it. A cv_*() result's $folds + # holds the splits that survived, each with the fold_id it was reported + # under, so a dropped fold leaves a gap (1, 2, 4, 5). Numbering those by + # position relabelled every fold after the gap when the same splits were + # handed to a second cv_*() -- its fold 3 was the first run's fold 4 -- + # while fold_separation() labels them by the fold_id they carry. Carried + # ids are kept when every split has a usable, distinct one; anything else + # is numbered by position. + fold_ids <- vapply(folds, function(f) { + v <- f$fold_id + if (is.numeric(v) && length(v) == 1L && is.finite(v) && v >= 1 && + v == round(v) && v <= .Machine$integer.max) as.integer(v) + else NA_integer_ + }, integer(1)) + if (anyNA(fold_ids) || anyDuplicated(fold_ids)) + fold_ids <- seq_along(folds) + # A hand-built `folds` list is documented as accepted by every cv_*(), and # two ways of getting it wrong went entirely unremarked. Train and test # overlapping is not cross-validation at all -- the model is fitted and @@ -127,7 +141,7 @@ "trains on its own test rows is not a ", "cross-validation split; rebuild the folds with ", "make_folds()."), - j, length(ov), + fold_ids[j], length(ov), paste(utils::head(format(ov), 3L), collapse = ", ")), call. = FALSE) ent <- c(f$train, f$test) @@ -146,7 +160,7 @@ list( train = keep_idx[stats::na.omit(match(f$train, keep_idx))], test = keep_idx[stats::na.omit(match(f$test, keep_idx))], - fold_id = j + fold_id = fold_ids[j] ) }) @@ -279,12 +293,17 @@ #' #' A user metric may not reuse one of these names: it would silently #' overwrite the built-in value, and \code{compare_models_cv()} reads several -#' of them by name. +#' of them by name. \code{mean_CRPS} is here because +#' \code{compare_models_cv()} writes it into the Bayesian row of +#' \code{overall} over a user column of that name. The per-fold extras +#' (\code{CRPS}, \code{coverage_*}, \code{bandwidth}, ...) depend on the +#' backend and its arguments, so \code{.cv_fit_one_fold()} checks those as it +#' writes them. #' @keywords internal #' @noRd .cv_reserved_metric_cols <- c("fold", "n_train", "n_test", "n_pred", "RMSE", "MAE", "MAPE", "SMAPE", "R2", "Adj_R2", "n_MAPE", - "n_SMAPE", "model") + "n_SMAPE", "model", "mean_CRPS") #' Validate the `metrics` argument of the cv_*() functions #' @@ -500,27 +519,43 @@ #' \item \strong{Tolerant of dropped rows.} Per-row values, so the #' comparison is made over whichever probe rows survived the complete-case #' filter. +#' \item \strong{Independent of \code{sf_use_s2()}.} On a lon/lat layer +#' \code{st_centroid()} is spherical with s2 on and planar with it off, +#' and the two differ by up to 5e-4 degrees on county polygons, far past +#' the tolerance: folds built before \code{sf_use_s2(FALSE)} (a common +#' workaround for invalid polygons), or saved and read in a session set +#' the other way, were refused as "built from different data". The +#' centroid is now always the planar one, which is also the one that +#' does not fail on invalid geometry. Probes of this kind carry +#' \code{kind = "planar_centroid"}; one without \code{kind} was taken +#' under whatever setting was current, and is checked the same way. #' } #' #' @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. +#' @param legacy Take the centroid under the current \code{sf_use_s2()} +#' setting, as probes without a \code{kind} were taken, to check one. #' @return A list with \code{row_id} (the IDs as supplied), numeric \code{x} -#' and \code{y}, and \code{lonlat} (whether the coordinates are in -#' EPSG:4326, i.e. the input carried a CRS), or \code{NULL} when no probe -#' can be taken. +#' and \code{y}, \code{lonlat} (whether the coordinates are in EPSG:4326, +#' i.e. the input carried a CRS), \code{kind}, and \code{points} (whether +#' every geometry of \code{x} is a POINT, so that a refusal can say when +#' folds built on a pointized copy meet the polygons they came from), or +#' \code{NULL} when no probe can be taken. #' @keywords internal #' @noRd -.fold_row_probe <- function(x, max_probe = 64L) { +.fold_row_probe <- function(x, max_probe = 64L, legacy = FALSE) { tryCatch({ if (!inherits(x, "sf") || !("..row_id" %in% names(x)) || nrow(x) == 0L) return(NULL) ids <- x[["..row_id"]] take <- unique(round(seq(1, nrow(x), length.out = min(nrow(x), max_probe)))) + all_points <- all(sf::st_geometry_type(x, by_geometry = TRUE) == "POINT") g <- sf::st_geometry(x)[take] if (!all(sf::st_geometry_type(g, by_geometry = TRUE) == "POINT")) - g <- suppressWarnings(sf::st_centroid(g)) + g <- if (isTRUE(legacy)) suppressWarnings(sf::st_centroid(g)) + else .planar_centroid(g) cr <- suppressWarnings(sf::st_crs(x)) lonlat <- FALSE if (!is.na(cr)) { @@ -530,11 +565,28 @@ xy <- suppressWarnings(sf::st_coordinates(g)) if (is.null(xy) || nrow(xy) != length(take)) return(NULL) list(row_id = ids[take], x = as.numeric(xy[, 1L]), y = as.numeric(xy[, 2L]), - lonlat = lonlat) + lonlat = lonlat, + kind = if (isTRUE(legacy)) "session_centroid" else "planar_centroid", + points = all_points) }, error = function(e) NULL) } +#' The planar centroid of a geometry set, whatever \code{sf_use_s2()} says +#' +#' For \code{.fold_row_probe()}: s2 is switched off for the one call on a +#' lon/lat set and restored on exit. +#' @keywords internal +#' @noRd +.planar_centroid <- function(g) { + if (isTRUE(sf::st_is_longlat(g)) && isTRUE(sf::sf_use_s2())) { + suppressMessages(sf::sf_use_s2(FALSE)) + on.exit(suppressMessages(sf::sf_use_s2(TRUE)), add = TRUE) + } + suppressWarnings(sf::st_centroid(g)) +} + + #' Turn a vector of fold labels into train/test splits keyed by `..row_id` #' #' \code{area_of_applicability()} accepts a plain label vector (one per row); @@ -559,8 +611,18 @@ # partition is unaffected; the numbering was not reproducible. sort() with # method = "radix" is always C-collation, so the numbering is now a property # of the labels alone. - f <- factor(as.character(folds), - levels = sort(unique(as.character(folds)), method = "radix")) + # That order is for character labels only. Numbers sorted as strings run + # "1", "10", "11", "12", "2", ..., so with ten or more numeric labels (site + # IDs for leave-location-out) output fold 2 was the user's label 10, and + # area_of_applicability(), which numbers the same vector numerically, + # disagreed. Numbers are ordered as numbers -- unique() after + # as.character() because two doubles can print alike -- and a factor keeps + # the level order its owner gave it. + lv <- if (is.factor(folds)) levels(droplevels(folds)) + else if (is.numeric(folds) || is.logical(folds)) + unique(as.character(sort(unique(folds)))) + else sort(unique(as.character(folds)), method = "radix") + f <- factor(as.character(folds), levels = lv) f <- droplevels(f) if (anyNA(f)) stop(caller, "(): `folds` contains missing labels.", call. = FALSE) @@ -583,6 +645,8 @@ #' version of this package carries no probe and is passed through unchecked, #' as is one whose IDs cannot be matched (\code{NA} IDs) or whose coordinate #' space cannot be compared (one side carried a CRS and the other did not). +#' When the probe was taken on POINT geometry and the data is not, or the +#' reverse, a mismatch is refused as that, not as folds from different data. #' #' @param folds A \code{make_folds()} return value, or \code{NULL}. #' @param data_sf The sf being cross-validated, as the caller supplied it, @@ -596,7 +660,11 @@ if (is.null(probe) || is.null(probe$row_id) || length(probe$row_id) == 0L || is.null(probe$x) || anyNA(probe$row_id)) return(invisible(NULL)) - now <- .fold_row_probe(data_sf, max_probe = nrow(data_sf)) + # A probe with no `kind` predates the planar centroid and was taken under + # the sf_use_s2() setting of its day; recompute the same way, so folds + # saved by an older version are not refused for the change of method. + now <- .fold_row_probe(data_sf, max_probe = nrow(data_sf), + legacy = is.null(probe$kind)) if (is.null(now)) return(invisible(NULL)) if (!identical(isTRUE(probe$lonlat), isTRUE(now$lonlat))) { .log_info(paste0("%s(): the supplied `folds` were built on data %s a CRS ", @@ -629,6 +697,26 @@ cmp <- is.finite(dx) & is.finite(dy) bad <- sum(cmp & !(dx <= tol & dy <= tol)) ok[ok] <- cmp + # Folds built on coerce_to_points() of this very layer (or on the polygons, + # handed a pointized copy) name the same rows, but each polygon's probe + # point is its centroid while the pointized copy's is whatever point + # `pointize` chose -- st_point_on_surface() under "auto" -- so every + # non-convex feature "moved", and the refusal said the folds came from a + # different dataset. The locations cannot be compared across that change; + # say that, and what to do. A probe without `points` predates the field. + if (bad > 0L && is.logical(probe$points) && length(probe$points) == 1L && + !is.na(probe$points) && !identical(probe$points, now$points)) + stop(sprintf(paste0("%s(): the supplied `folds` were built on %s geometry ", + "and this data has %s geometry, so their row locations ", + "cannot be matched (%d of %d checked row IDs sit at a ", + "different point): the point coerce_to_points() gives ", + "a polygon is in general not the centroid compared ", + "here. Build the folds with make_folds() on the layer ", + "passed here; it reduces polygons to points itself."), + caller, + if (probe$points) "POINT" else "non-POINT", + if (isTRUE(now$points)) "POINT" else "non-POINT", + bad, sum(ok)), call. = FALSE) 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 ", @@ -642,6 +730,47 @@ } +#' Give a cv_*() boundary that has no CRS one, once, naming the caller +#' +#' A \code{cv_*()} call hands \code{boundary} to \code{prep_model_data()}, +#' which takes the data's CRS from it, and to \code{make_folds()}, which clips +#' the blocks to it. Each interpreted a CRS-less boundary on its own: a +#' lon/lat one raised two R warnings, one from each, naming +#' \code{ensure_projected()} rather than the caller or the argument. Called +#' with \code{to = NULL} before preparation, a boundary whose coordinates +#' look like lon/lat is taken as EPSG:4326 -- what \code{prep_model_data()} +#' would assume -- with one warning. Called with the prepared data as +#' \code{to} before \code{make_folds()}, a boundary still without a CRS is +#' stamped with the data's, as \code{make_folds()} would stamp it, with one +#' warning. Either way the next consumer finds a CRS and says nothing. +#' +#' @param boundary The caller's \code{boundary}, or \code{NULL}. +#' @param caller Calling function name, for the warning. +#' @param to \code{NULL}, or the prepared data whose CRS to stamp. +#' @return \code{boundary}, with a CRS where one was assumed. +#' @keywords internal +#' @noRd +.cv_boundary_crs <- function(boundary, caller, to = NULL) { + if (!(inherits(boundary, "sf") || inherits(boundary, "sfc")) || + !is.na(sf::st_crs(boundary))) + return(boundary) + if (is.null(to)) { + ll <- .looks_like_lonlat(boundary) + if (!isTRUE(ll$lonlat)) return(boundary) + .warn_and_log( + paste0("%s(): `boundary` has no CRS; its coordinates look like lon/lat ", + "(xmin=%.2f, xmax=%.2f, ymin=%.2f, ymax=%.2f), so it is taken as ", + "EPSG:4326. Set the CRS explicitly with sf::st_crs() to suppress ", + "this."), + caller, ll$bb[["xmin"]], ll$bb[["xmax"]], ll$bb[["ymin"]], ll$bb[["ymax"]]) + return(sf::st_set_crs(boundary, 4326)) + } + crs <- .crs_or_null(to) + if (is.null(crs)) return(boundary) + .transform_or_stamp(boundary, crs, what = "boundary", caller = caller) +} + + #' Fit-predict a single CV fold #' #' Encapsulates the per-fold work so it can be called sequentially or in @@ -722,10 +851,12 @@ length(y_hat), length(y_true)))) } - # Training-set mean: the correct null-model baseline for out-of-sample - # R². Using the test-set mean instead would give the null model credit - # for knowing information that was not available at prediction time, - # systematically inflating CV R². + # Training-set mean: the baseline out-of-sample R² is measured against, + # because it is the only null prediction available at prediction time. + # (The held-out rows' own mean would be a null model that knows the test + # data. It fits them at least as well as any other constant, so it gives + # the LOWER R², not a higher one; the choice is about using training + # information only.) model_metrics(newdata =) uses the same baseline. y_train <- train_df[[response_var]] y_train_mean <- mean(y_train[is.finite(y_train)], na.rm = TRUE) @@ -747,24 +878,64 @@ # A `..per_row` element is the exception: a data frame with one row per # test observation (cv_bayes() puts the posterior predictive SD there), # which goes into the prediction rows below rather than the fold stats. + # A fold_info_fn that THROWS gets what a throwing user `metrics` function + # gets: logged, its columns NA for this fold, the fold kept. Its extras + # used to be dropped without a word -- cv_bayes() given coverage_levels = + # c(50, 80, 95) lost gp_k, n_draws, CRPS and every coverage column on every + # fold with fold_status "ok" -- so the cause now also rides back as a note + # for fold_status$message. One that returns the wrong SHAPE is an error, + # again as for `metrics`: a vector where a scalar belongs died later in + # `fs[[cn]] <-` with R's "replacement has 0 rows". per_row <- NULL + note <- NULL if (!is.null(fold_info_fn)) { extra <- try(fold_info_fn(fit_obj, test_sf, y_true, y_hat), silent = TRUE) - if (!inherits(extra, "try-error") && is.list(extra)) { - if (is.data.frame(extra$..per_row) && - nrow(extra$..per_row) == length(y_true)) - per_row <- extra$..per_row + # A named vector -- the shape `metrics` accepts -- is taken as the list it + # stands for. It used to fall through every branch below: its columns + # never appeared and fold_status said "ok". as.list(NULL) is list(), so + # a NULL return stays a no-op; an unnamed vector fails the naming check. + if (!inherits(extra, "try-error") && (is.null(extra) || is.atomic(extra))) + extra <- as.list(extra) + if (inherits(extra, "try-error")) { + note <- sprintf("fold_info_fn failed: %s", .try_error_message(extra)) + .log_warn("cross-validation: fold %s: %s. Its columns are NA there.", + format(fold_lab), note) + } else if (is.list(extra)) { + if (is.data.frame(extra$..per_row)) { + .check_fold_per_row(extra$..per_row) + if (nrow(extra$..per_row) == length(y_true)) + per_row <- extra$..per_row + else + .log_warn(paste0("cross-validation: fold %s: fold_info_fn's `..per_row` ", + "has %d rows for %d test rows and was dropped."), + format(fold_lab), nrow(extra$..per_row), length(y_true)) + } extra$..per_row <- NULL + .check_fold_extras(extra, names(fs)) for (cn in names(extra)) fs[[cn]] <- extra[[cn]] + } else { + stop("cross-validation: `fold_info_fn` must return a named list (or a ", + "named vector) of per-fold values; it returned an object of class ", + class(extra)[1L], ".", call. = FALSE) } } # The user's scoring function, on the same finite pairs the built-in # metrics used. Its pooled counterpart is applied in .cv_overall_metrics(). + # Its names are checked against the columns this fold already has, not only + # against the static built-in list: the extras (CRPS, coverage_*, gp_k, + # n_draws, bandwidth, or whatever a fold_info_fn returns) are only known + # here, and a user metric of the same name overwrote them silently -- + # cv_bayes()'s predictive_coverage then reported the user's number. if (!is.null(metrics)) { um <- .apply_user_metrics(metrics, y_true, y_hat, where = sprintf("fold %s", format(fold_lab))) if (is.null(um)) um <- .na_user_metrics(metrics) + clash <- intersect(names(um), names(fs)) + if (length(clash)) + stop("`metrics` returned names that are already columns of the metrics ", + "frames: ", paste(clash, collapse = ", "), ". Use other names.", + call. = FALSE) for (cn in names(um)) fs[[cn]] <- um[[cn]] } @@ -779,7 +950,79 @@ ) if (!is.null(per_row)) pr <- cbind(pr, per_row) - list(pred_row = pr, fold_stat = fs) + list(pred_row = pr, fold_stat = fs, note = note) +} + + +#' Validate the \code{..per_row} a \code{fold_info_fn} returned +#' +#' Its columns are bound onto the fold's prediction rows, so each must be +#' named, once, with a name \code{predictions} does not already have. A +#' clash was not caught: \code{dplyr::bind_rows()} renamed both copies +#' (\code{yhat...4}, \code{yhat...6}) with only a message, and +#' \code{overall} then found no \code{yhat} and came back all \code{NA} +#' with \code{n_pred = 0}, beside finite per-fold scores. +#' +#' @param per_row The \code{..per_row} data frame. +#' @return \code{invisible(NULL)}; called for the error. +#' @keywords internal +#' @noRd +.check_fold_per_row <- function(per_row) { + nm <- names(per_row) + if (!length(nm)) return(invisible(NULL)) + if (anyNA(nm) || !all(nzchar(nm))) + stop("cross-validation: `fold_info_fn`'s `..per_row` must have a name ", + "for every column.", call. = FALSE) + if (anyDuplicated(nm)) + stop("cross-validation: `fold_info_fn`'s `..per_row` has duplicated ", + "column names: ", paste(unique(nm[duplicated(nm)]), collapse = ", "), + ".", call. = FALSE) + clash <- intersect(nm, .cv_prediction_cols) + if (length(clash)) + stop("cross-validation: `fold_info_fn`'s `..per_row` has columns that ", + "`predictions` already has: ", paste(clash, collapse = ", "), + ". Use other names.", call. = FALSE) + invisible(NULL) +} + +#' The columns every fold's prediction rows carry before any \code{..per_row} +#' @keywords internal +#' @noRd +.cv_prediction_cols <- c("..row_id", "fold", "y", "yhat", "y_train_mean") + + +#' Validate what a \code{fold_info_fn} returned, before it is written +#' +#' Every element (\code{..per_row} already removed) becomes one cell of the +#' fold's row of \code{fold_metrics}, so each must be named, once, with a +#' name that is not already a column, and hold one value. +#' +#' @param extra The list, without \code{..per_row}. +#' @param taken The column names the fold's row already has. +#' @return \code{invisible(NULL)}; called for the error. +#' @keywords internal +#' @noRd +.check_fold_extras <- function(extra, taken) { + if (!length(extra)) return(invisible(NULL)) + nm <- names(extra) + if (is.null(nm) || anyNA(nm) || !all(nzchar(nm))) + stop("cross-validation: `fold_info_fn` must return a list whose every ", + "element is named.", call. = FALSE) + if (anyDuplicated(nm)) + stop("cross-validation: `fold_info_fn` returned duplicated names: ", + paste(unique(nm[duplicated(nm)]), collapse = ", "), ".", call. = FALSE) + clash <- intersect(nm, union(taken, .cv_reserved_metric_cols)) + if (length(clash)) + stop("cross-validation: `fold_info_fn` returned names that are already ", + "columns of fold_metrics: ", paste(clash, collapse = ", "), + ". Use other names.", call. = FALSE) + bad <- nm[!vapply(extra, function(v) is.atomic(v) && length(v) == 1L, + logical(1))] + if (length(bad)) + stop("cross-validation: `fold_info_fn` must return one value per name ", + "(a data frame with one row per test row goes in `..per_row`); ", + "element '", bad[1L], "' is not a single value.", call. = FALSE) + invisible(NULL) } @@ -877,6 +1120,8 @@ #' parallel using \code{parallel::mclapply()}, which yields near-linear #' speedup on macOS and Linux. On Windows, forked parallelism is not #' available and execution falls back to sequential with a message. +#' \code{cv_gwr()} never asks for it: GWmodel's OpenMP code deadlocks in a +#' forked worker (see the comment there). #' #' @param dat_sf Prepared sf data (projected, clean). #' @param response_var Character(1). @@ -962,25 +1207,47 @@ # integer-response warning, raised in every fold, reached nobody under # parallel = 2 while the sequential run showed all four. Collect them in # the worker and re-raise in the parent, once per distinct message. + # An error that escapes .cv_fit_one_fold() -- the documented shape errors + # of `metrics` and `fold_info_fn` -- aborts a sequential run. In a worker + # it became that fold's try-error, and the run carried on without it. It + # is caught here, carried back, and raised again in the parent below. caught_worker <- function(i) { msgs <- character(0) - res <- withCallingHandlers( - fold_worker(i), - warning = function(w) { - msgs <<- c(msgs, conditionMessage(w)) - invokeRestart("muffleWarning") - }) + res <- tryCatch( + withCallingHandlers( + fold_worker(i), + warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + }), + error = function(e) list(escaped = conditionMessage(e))) # .cv_fit_one_fold() returns NULL for an unusable fold; NULL cannot # carry an attribute, so wrap the pair instead. list(res = res, fold_warnings = msgs) } + # mc.preschedule = FALSE: one fork per fold. Prescheduled, mclapply() + # hands each core a chunk of folds, copies one fold's try-error to every + # fold of its chunk and returns NULL for every fold of a core that dies, + # so a fold that succeeded was discarded, or reported with another + # fold's error, for sharing a core with a failure. k forks cost little + # next to k model fits, and the per-fold seeds are drawn above, so the + # results do not change. results <- parallel::mclapply( - seq_along(remapped_folds), caught_worker, mc.cores = cores + seq_along(remapped_folds), caught_worker, mc.cores = cores, + mc.preschedule = FALSE ) relayed <- unique(unlist(lapply(results, function(z) if (!inherits(z, "try-error")) z$fold_warnings), use.names = FALSE)) for (m in relayed) warning(m, call. = FALSE) results <- lapply(results, function(z) if (inherits(z, "try-error")) z else z$res) + esc <- which(vapply(results, function(z) + is.list(z) && !inherits(z, "try-error") && !is.null(z$escaped), logical(1))) + if (length(esc)) { + j <- esc[1L] + stop(sprintf("%s (fold %s, raised in a parallel worker)", + results[[j]]$escaped, + format(remapped_folds[[j]]$fold_id %||% j)), call. = FALSE) + } } else { results <- lapply(seq_along(remapped_folds), fold_worker) } @@ -988,11 +1255,14 @@ # One status per fold, in the folds' own order, before anything is filtered: # what each fold did is the diagnosis a caller needs when "3 of 5 folds # produced predictions" is all the console kept. mclapply() hands back a - # try-error OBJECT (not NULL) when a child errors or is killed; a fold that - # threw comes back as list(error = ); one skipped before fitting - # or after predicting as list(skip = ); a successful one carries - # pred_row and fold_stat. `$` (not `[[`) throughout, because a successful - # fold's list has no "error" element and `[[` would abort. + # try-error OBJECT when a child errors, and NULL for a child that was killed + # (out of memory, a segfault) -- a worker error, not a skip, and it was + # reported as "skipped" and left out of fit_errors; a fold that threw comes + # back as list(error = ); one skipped before fitting or after + # predicting as list(skip = ); a successful one carries pred_row and + # fold_stat, and a note when its fold_info_fn failed. `$` (not `[[`) + # throughout, because a successful fold's list has no "error" element and + # `[[` would abort. labels <- vapply(remapped_folds, function(f) as.integer(f$fold_id %||% NA), integer(1)) labels[is.na(labels)] <- seq_along(remapped_folds)[is.na(labels)] status <- character(n_folds); msg <- character(n_folds) @@ -1001,13 +1271,15 @@ if (inherits(z, "try-error")) { status[i] <- "worker_error"; msg[i] <- .try_error_message(z) } else if (is.null(z)) { - status[i] <- "skipped"; msg[i] <- "no result returned" + status[i] <- "worker_error" + msg[i] <- paste0("the parallel worker delivered no result (it was ", + "killed or crashed, for example for lack of memory)") } else if (!is.null(z$error)) { status[i] <- "error"; msg[i] <- z$error } else if (!is.null(z$skip)) { status[i] <- "skipped"; msg[i] <- z$skip } else { - status[i] <- "ok"; msg[i] <- "" + status[i] <- "ok"; msg[i] <- z$note %||% "" } } fold_status <- data.frame(fold = labels, status = status, message = msg, @@ -1058,6 +1330,61 @@ } +#' Warn when some folds, but not all, produced no predictions +#' +#' \code{overall} is pooled over the folds that succeeded, so a run that lost +#' a fold reports a score over fewer rows -- and not a random few: in spatial +#' block CV the fold that fails is usually the hardest extrapolation block +#' (the only rows of a factor level, a region no training fold covers). This +#' used to be a log line only, which \code{tryCatch()}, +#' \code{expect_warning()} and \code{options(warn = 2)} never see. Folds +#' dropped before fitting are left out of the warning: \code{.remap_folds()} +#' has already raised one for them. The all-folds-failed case is the +#' callers' own, louder warning. +#' +#' @param caller Function name the message carries. +#' @param res The list \code{.cv_run_folds()} returned. +#' @param preds The stacked prediction rows \code{overall} is pooled from. +#' @param n_rows Rows in the prepared data. +#' @param n_attempted,n_succeeded The fold counts the caller returns. +#' @keywords internal +#' @noRd +.cv_warn_failed_folds <- function(caller, res, preds, n_rows, + n_attempted, n_succeeded) { + st <- res$fold_status + bad <- if (is.data.frame(st)) st[st$status != "ok", , drop = FALSE] else NULL + if (is.null(bad) || nrow(bad) == 0L) { + if (n_succeeded < n_attempted) + .log_warn("%s(): %d of %d folds produced predictions.", + caller, n_succeeded, n_attempted) + return(invisible(NULL)) + } + .warn_and_log(paste0( + "%s(): %d of %d fold(s) failed (%s), so `overall` pools the other folds ", + "only and covers %d of the %d rows. A fold that fails is often the ", + "hardest to predict (a region or a factor level no training fold ", + "covers), so `overall` may flatter the model; `fold_status` gives each ", + "fold's cause."), + caller, nrow(bad), n_attempted, + paste(sprintf("fold %s: %s", bad$fold, bad$status), collapse = ", "), + sum(is.finite(preds$y) & is.finite(preds$yhat)), n_rows) +} + + +#' Is this the warning \code{.cv_warn_failed_folds()} raises for \code{caller}? +#' +#' For a caller that runs \code{cv_spatial()} many times and reports the +#' consequence in its own terms (\code{select_features_forward()}), so the +#' two cannot drift apart. +#' @keywords internal +#' @noRd +.is_failed_folds_warning <- function(w, caller = "cv_spatial") { + startsWith(conditionMessage(w), paste0(caller, "(): ")) && + grepl("^[^:]+: [0-9]+ of [0-9]+ fold\\(s\\) failed \\(", + conditionMessage(w)) +} + + #' The fold list without \code{.remap_folds()}'s bookkeeping attributes #' #' The dropped-fold frame, the orphan IDs and the unknown-ID count ride on the @@ -1120,8 +1447,11 @@ #' @param extent A length scale of the layer, used to pick starting ranges. #' @return \code{NULL} when no fit converged, else a list with \code{beta} #' (named trend coefficients), \code{range} (the exponential range -#' parameter), \code{nugget_prop}, \code{sigma2}, \code{n_used} and -#' \code{subsampled}. +#' parameter), \code{nugget_prop}, \code{sigma2}, \code{n_used}, +#' \code{subsampled} and \code{pair_floor}: the 30th-shortest distance +#' between the rows the fit used (after the de-duplication and the +#' subsample), the distance a range has to reach for 30 pairs of those +#' points to lie inside it. #' @keywords internal #' @noRd .reml_trend <- function(mf, fml, extent, max_n = 400L, seed = 123L) { @@ -1139,6 +1469,12 @@ subsampled <- TRUE } if (nrow(d) < 30L) return(NULL) + # The REML range is fitted to these point pairs, not to a binned variogram, + # so the shortest range it can identify is set by how many of them are + # close: 30 pairs is the usual minimum per lag (Journel and Huijbregts). + pd <- as.numeric(stats::dist(d[, c(".sac_x", ".sac_y")])) + pair_floor <- if (length(pd) >= 30L) sort(pd, partial = 30L)[30L] else NA_real_ + rm(pd) starts <- unique(pmax(extent * c(1 / 10, 1 / 30, 1 / 3), sqrt(.Machine$double.eps))) for (r0 in starts) { fit <- tryCatch( @@ -1162,7 +1498,8 @@ s2 <- as.numeric(fit$sigma)^2 if (!is.finite(rng) || rng <= 0 || !is.finite(s2) || s2 <= 0) next return(list(beta = stats::coef(fit), range = rng, nugget_prop = nug, - sigma2 = s2, n_used = nrow(d), subsampled = subsampled)) + sigma2 = s2, n_used = nrow(d), subsampled = subsampled, + pair_floor = pair_floor)) } NULL } @@ -1178,7 +1515,13 @@ #' of that mean is a decrease. Measured on 60 draws each (n = 250, tol = #' 0.15): 0 of an exponential field, 2 percent of white noise, 98 percent of a #' field with a periodic (hole-effect) component, 100 percent of a layer whose -#' variance differs between a dense cluster and the rest. An unremoved trend +#' variance differs between a dense cluster and the rest. The tolerance is +#' fixed while the noise in the short-lag bins grows as the sample shrinks, so +#' small samples trip it on ordinary fields: an exponential field with +#' effective range 300 and nugget 0.2 was refused in 7--9 of 60 draws at +#' n = 30, 3--6 at n = 50 and 0--1 at n = 100, and with range 150 in 15--16 +#' of 60 at n = 30. The refusal is the conservative outcome (geometric +#' blocks, with a warning), so it is left as it is. An unremoved trend #' is \emph{not} what produces this shape. A trend makes the variogram rise #' without reaching a sill, which the over-cutoff rejection catches, so the #' message aimed at this case must not say "trend". @@ -1210,10 +1553,14 @@ #' The nugget variance of the variogram model behind a #' \code{\link{estimate_sac_range}()} result: the semivariance at zero #' separation, i.e. measurement error plus variation at scales shorter than -#' the closest pair. It is carried as the \code{nugget} attribute of every -#' classed result, identified or rejected, because it is the number a -#' resolution criterion for a tessellation needs (the short-lag variance that -#' no cell can average away). +#' the first lag bin of the empirical variogram (gstat's bins are +#' \code{cutoff / 15} wide, about \code{max_dist / 30} at the default +#' \code{cutoff}), which can be far wider than the spacing of close pairs. +#' It is extrapolated to zero from that bin, not observed, and a fit that +#' runs into its lower bound reports exactly 0. It is carried as the +#' \code{nugget} attribute of every classed result, identified or rejected, +#' because it is the number a resolution criterion for a tessellation needs +#' (the short-lag variance that no cell can average away). #' #' @param x A \code{sac_range} object, or anything else. #' @return A single number: the nugget in the units of the response's @@ -1250,10 +1597,21 @@ sac_nugget <- function(x) { #' \emph{effective range}: for the exponential model, three times the fitted #' range parameter, which is where the semivariance reaches ~95 % of the #' sill; for the spherical model (fitted only when the exponential fit is -#' singular) the fitted range itself, which is where the spherical -#' semivariance reaches its sill exactly. Both are the distance beyond which -#' two observations are (near) uncorrelated, which is what a block or a -#' buffer has to exceed. +#' singular or does not converge) the fitted range itself, which is where the +#' spherical semivariance reaches its sill exactly. Both are the distance +#' beyond which two observations are (near) uncorrelated, which is what a +#' block or a buffer has to exceed. +#' +#' The exponential model is kept whenever it converges, without comparing it +#' with the spherical fit, and on fields smoother than exponential that makes +#' the range long. Measured on simulated fields (n = 300 on a 1000 m square, +#' 30 draws each): about 1.8--2.1 times the practical range of a Gaussian +#' covariance, and 1.3--1.4 times the range of a spherical one, while an +#' exponential field came back at 0.97 of its effective range. The error is +#' on the safe side (blocks too large, cross-validation pessimistic), and it +#' is kept on purpose: choosing the family by the smaller weighted sum of +#' squares corrects the spherical case but sends exponential fields low, to +#' about 0.82 of the truth, which is the direction that leaks. #' #' The estimate is the \strong{omnidirectional} (all-pairs) fit. Directional #' variograms are fitted as well, at 0° (N–S), 45°, 90° (E–W) and 135° @@ -1274,11 +1632,25 @@ sac_nugget <- function(x) { #' #' Where a field is \emph{known} to be anisotropic, blocks must be at least #' as large as the longest autocorrelation range to avoid leakage, and the -#' conservative choice is to size them from -#' \code{max(attr(range, "directional"))} explicitly. A ratio above 1.5 is -#' logged so the case is not missed, with that advice. Only when the -#' omnidirectional fit is itself unusable is the directional maximum returned -#' in its place, and \code{anisotropy_used} is \code{TRUE} in that case alone. +#' conservative choice is to size them from the longest directional range +#' explicitly. Read it from \code{directional_fitted}, not +#' \code{directional}: on a strongly anisotropic field the major axis is the +#' direction most likely to run past the fitted lags, which leaves it +#' \code{NA} in \code{directional}, so \code{max()} of that is \code{NA}, or +#' with \code{na.rm = TRUE} the second-longest range. Check +#' \code{directional_status} first: a major axis marked \code{"over_cutoff"} +#' has no identified range at all, and a longer \code{cutoff} or +#' \code{\link{make_folds}(method = "nndm")} is the way on. A ratio above +#' 1.5 is written to the package log at INFO level with that advice, which +#' reaches the session log file but not the console (the ratio passes 1.5 on +#' most isotropic fields too); \code{print()} shows the directional ranges +#' and the ratio, and \code{attr(range, "anisotropy")} holds it. Only when +#' the omnidirectional fit is singular or did not converge is the directional +#' maximum returned in its place, and \code{anisotropy_used} is \code{TRUE} +#' in that case alone. An omnidirectional fit that converged to a range past +#' the fitted lags is refused (see the Value section) whatever the directions +#' found: the directions that reached a sill are the shorter ones, so their +#' maximum is a lower bound, not an estimate. #' #' A direction whose fit fails, does not converge, or reports a range beyond #' the longest fitted lag is excluded and recorded as \code{NA} in the @@ -1291,10 +1663,40 @@ sac_nugget <- function(x) { #' truth, so \code{make_folds(auto_range = TRUE)} built blocks less than half #' the correlation length it reported. #' -#' A log warning is emitted when the directional maximum is used; where the -#' all-pairs estimate is available it names both the ratio and that estimate. A -#' log note is emitted instead when the directional ranges vary but the spread -#' is consistent with sampling noise. +#' The lags are binned the way \pkg{gstat} bins them by default, 15 bins out +#' to the cutoff, each \code{cutoff * max_dist / 15} wide (about 47 m on a +#' 1000 m square at the defaults). A range spanning only one or two bins is +#' resolved coarsely and comes out long: exponential fields with an effective +#' range of 60 m (n = 300 on a 1000 m square, 30 draws) returned a median of +#' 89--102 m, where the same fields binned over a 200 m cutoff gave 65--68, +#' and at a range of 300 m there was no bias. A range shorter than the +#' first bin cannot be resolved at all and can come back several times too +#' long: an effective range of 24 m (n = 1500 on a 1000 m square, 8 draws) +#' returned 93--479 m, five of them as the directional maximum, against +#' 19--32 m at \code{cutoff = 0.1}; the first bin's semivariance was 92--99 +#' percent of the fitted sill in all eight. So whenever the empirical +#' variogram is already at its sill in the first one or two bins +#' (\code{plot()} the result), run it again with a smaller \code{cutoff}, +#' whatever range was fitted. +#' +#' Nothing tests whether the layer has spatial structure at all. On white +#' noise (n = 300 on a 1000 m square, 30 draws) the estimate was a finite, +#' spurious range (57--533 m) in 8 draws and a refusal in the rest, mostly +#' as past the fitted lags or not converged, and only once as no model +#' fitted; with \code{detrend = "reml"} it was finite in 13 of 30 (21--453 +#' m), and 16 of the refusals were ranges of 0.18--12.5 m, too short for 30 +#' pairs of points to lie inside them. A +#' spurious range errs towards larger blocks, so the harm is mostly lost +#' training data, but a caller who needs to know whether there is any +#' structure should look at the variogram (\code{plot()} on the result) +#' rather than at whether the answer is \code{NA}. +#' +#' When the all-pairs fit is singular or did not converge and two or more +#' directions reached a sill, the directional maximum is returned in its +#' place (\code{anisotropy_used = TRUE}), and a log warning names the +#' directional ranges when their ratio exceeds 1.5. When the all-pairs +#' estimate is used and the directional ranges vary by more than 1.5, a log +#' note (INFO) names them instead. #' #' The returned range is in the coordinate units of the (projected) data and #' can be passed directly to \code{make_folds(block_size = ...)} so that CV @@ -1316,7 +1718,9 @@ sac_nugget <- function(x) { #' the residual autocorrelation, the part a spatial model has to handle #' once the covariates have done their work. How the trend is removed is #' set by \code{detrend}, and it matters: see "Detrending and the -#' residual-variogram bias". +#' residual-variogram bias". Rows whose response or predictor is missing +#' or infinite are left out of that fit, and so of the variogram, with a +#' logged count. #' @param n_max Maximum number of points to subsample before fitting. #' Variogram estimation is O(n²) so this keeps runtime bounded. #' @param cutoff Fraction of the maximum inter-point distance to use as the @@ -1332,7 +1736,17 @@ sac_nugget <- function(x) { #' observed lags instead of measuring a long autocorrelation range. Passing #' it to \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. +#' beyond the fitted lags. The bound does not guarantee room for two +#' blocks: at the defaults it is half the farthest-pair distance, about +#' 0.71 of the side of a square layer, and a block grid needs a range below +#' half the width of the bounding box in one direction or the other. An +#' accepted range between the two leaves +#' \code{make_folds(auto_range = TRUE)} room for a single block of that +#' size (see its \code{auto_range} argument for what it does then). On a +#' 1000 m square with an exponential field of effective range 570 (n = 300), +#' 9 of 30 draws were accepted in that band. Lowering \code{range_frac} to fit the +#' grid would turn those estimates into \code{NA} and the blocks into +#' geometric ones smaller than the range. #' @param seed RNG seed for the \code{n_max} subsample, restored afterwards so #' the caller's random stream is untouched. Default \code{123L}: the #' subsample is an internal approximation and no part of the answer, and @@ -1421,16 +1835,17 @@ sac_nugget <- function(x) { #' fitted range at all. #' #' @return A single number, of class \code{sac_range} in the first two of the -#' three shapes below and a bare \code{NA} in the third; all three behave -#' as an ordinary number. The shapes carry different attributes: +#' three shapes below and an unclassed \code{NA} in the third; all three +#' behave as an ordinary number. The shapes carry different attributes: #' \describe{ #' \item{Success}{A positive effective range in projected coordinate units, #' with the fit attached as attributes \code{directional} (the 0°, 45°, #' 90° and 135° ranges, named by azimuth; \code{NA} where that #' direction's fit was unusable), \code{anisotropy} (largest #' over smallest), \code{anisotropy_used} (logical: \code{TRUE} only when -#' the all-pairs fit was unusable and the directional maximum stands in -#' for it), \code{directional_status} (per azimuth, why a direction is +#' the all-pairs fit was singular or did not converge and the +#' directional maximum stands in for it), \code{directional_status} +#' (per azimuth, why a direction is #' \code{NA} in \code{directional}: \code{"ok"}, \code{"over_cutoff"} #' (its range ran past the largest lag fitted), \code{"not_converged"} #' or \code{"no_fit"}), \code{directional_fitted} (the range each @@ -1458,27 +1873,47 @@ sac_nugget <- function(x) { #' be taken on trust.} #' \item{Rejected range}{\code{NA_real_} when a range was fitted but is #' not identified: it exceeds \code{range_frac * cutoff * max_dist} (see -#' \code{range_frac}); or the model did not converge; or the empirical +#' \code{range_frac}), which applies to the all-pairs fit even when some +#' directions reached a sill; or too few pairs of points lie inside +#' it to identify it, because it is shorter than the shortest lag the +#' empirical variogram resolves (the mean separation in its first +#' bin) or, with \code{detrend = "reml"}, than the distance within +#' which 30 pairs of the points the REML fit used lie, when that is +#' shorter (the REML range is fitted to the point pairs, not to the +#' bins). A structure that short cannot be told from a nugget, and +#' the bound is about identification, not a test for spatial +#' structure (see above). Or the +#' model did not converge; or the empirical #' variogram \emph{decreases} with distance over its shorter lags (a #' net fall of more than 15 percent of the mean semivariance there, #' weighted by pairs), which is the shape of a periodic, hole-effect #' structure or of a variance that differs between a dense cluster and -#' the rest of the layer (an unremoved trend instead makes the variogram -#' rise without a sill, and the first test catches that); or -#' the fitted range is non-positive. It is classed \code{sac_range} as -#' well, so it prints as a bare \code{NA} without dumping its +#' the rest of the layer. Sampling noise in the short-lag bins of a +#' small sample can make that fall too: on exponential fields it +#' refused 7--9 of 60 draws at n = 30, 3--6 at n = 50 and 0--1 at +#' n = 100 (effective range 300 on a 1000 m square), and 15--16 of 60 +#' at n = 30 with a range of 150. An unremoved trend makes the +#' variogram rise instead; when it rises past the fitted lags the first +#' test catches it, but a milder trend only lengthens the fitted range +#' and passes, which is what \code{predictor_vars} is for. Last, the +#' fitted range can be non-positive. It is classed \code{sac_range} as +#' well, so it prints as \code{NA} without dumping its #' attributes, and it carries \code{max_dist}, \code{cutoff_dist}, #' \code{variogram}, \code{variogram_model} and \code{nugget} (the #' evidence for the rejection), plus \code{rejected_range} (the value #' that was refused), \code{rejected_reason} (one of #' \code{"fitted range exceeds the largest lag fitted"}, +#' \code{"fitted range is below the shortest lag fitted"}, #' \code{"variogram model did not converge"}, #' \code{"empirical variogram decreases with distance"}, #' \code{"fitted range is non-positive or non-finite"}, #' \code{"no variogram model could be fitted (singular fits)"}), \code{crs} #' (so the units the rejected number was in stay recoverable, which is -#' what \code{plot()} labels its axis from) and -#' \code{detrend_method}. It carries \code{directional}, +#' what \code{plot()} labels its axis from), +#' \code{detrend_method}, \code{reml} (as on success) and, for +#' \code{"fitted range is below the shortest lag fitted"}, +#' \code{range_floor} (the distance the refused range fell short of). +#' It carries \code{directional}, #' \code{anisotropy}, \code{anisotropy_used}, \code{directional_status}, #' \code{directional_fitted} and, with #' \code{keep_directional_fits = TRUE}, \code{directional_fits} as well: @@ -1489,14 +1924,23 @@ sac_nugget <- function(x) { #' \code{rejected_range = NA}, \code{variogram_model = NULL} and #' \code{nugget = NA}, is returned when no variogram model could be #' fitted at all (both the exponential and the spherical fit singular, -#' which is what a flat, nugget-only variogram produces); +#' which a flat, nugget-only variogram can produce, though on white +#' noise it was the outcome in only 1 of 30 draws: see above); #' \code{rejected_reason} says so and the empirical variogram is still #' attached.} -#' \item{No fit}{A bare, attribute-less \code{NA_real_} when estimation -#' could not be attempted at all: \pkg{gstat} missing, fewer than 30 -#' finite values, a variable with no variance, or a degenerate extent. -#' Without \pkg{gstat} nothing is fitted, so none of the attributes -#' above exist either.} +#' \item{No fit}{An unclassed \code{NA_real_} when estimation could not +#' be attempted at all, whose one attribute, \code{rejected_reason}, +#' says why: \code{"package 'gstat', which the variogram needs, is not +#' installed"}, \code{" points, fewer than the 30 a variogram range +#' is estimated from"}, \code{" point(s) with a finite value to +#' model, fewer than the 30 a variogram range is estimated from"}, +#' \code{"the response is constant"}, \code{"the residuals on +#' predictor_vars are constant: the predictors explain the response +#' exactly"} or \code{"the points have no extent (the largest distance +#' between them is zero or could not be computed)"}. Nothing is +#' fitted, so none of the other attributes above exist: no +#' \code{variogram}, \code{variogram_model} or \code{rejected_range}, +#' which is what tells it from a range that was fitted and refused.} #' } #' Attributes and the class do not affect \code{is.na()} or #' \code{is.finite()}, so every downstream guard treats all three the same @@ -1555,9 +1999,16 @@ estimate_sac_range <- function(points_sf, response_var, !is.finite(reml_max_n) || reml_max_n < 30) stop("estimate_sac_range(): `reml_max_n` must be a single number of at ", "least 30.", call. = FALSE) + # The early NA returns carry their reason as `rejected_reason`, so a caller + # (make_folds(auto_range = TRUE), kriging_adequacy(), summarize_by_cell()) + # can say why no range came back: the log line alone is invisible under + # spatialkit_quiet(), knitr and tryCatch(). They carry nothing else -- no + # variogram, no rejected_range -- which is what tells them from a range that + # was fitted and refused. if (!requireNamespace("gstat", quietly = TRUE)) { .log_warn("estimate_sac_range(): package 'gstat' is required for variogram estimation; returning NA.") - return(NA_real_) + return(structure(NA_real_, rejected_reason = + "package 'gstat', which the variogram needs, is not installed")) } if (!inherits(points_sf, "sf")) stop("estimate_sac_range(): `points_sf` must be an sf object.", call. = FALSE) @@ -1617,7 +2068,8 @@ estimate_sac_range <- function(points_sf, response_var, if (n < 30L) { .log_warn("estimate_sac_range(): fewer than 30 points; variogram estimate unreliable. Returning NA.") - return(NA_real_) + return(structure(NA_real_, rejected_reason = sprintf( + "%d points, fewer than the 30 a variogram range is estimated from", n))) } # Build the variable to model: raw response or OLS residuals. @@ -1669,6 +2121,22 @@ estimate_sac_range <- function(points_sf, response_var, paste(sQuote(missing_preds), collapse = ", "), " not found in the data.", call. = FALSE) fml <- stats::reformulate(predictor_vars, response_var) + # The rows the trend is fitted on: a finite response and every predictor + # present and, if numeric, finite. lm()'s na.exclude drops NA but not + # Inf, so one Inf predictor or response aborted the fit ("NA/NaN/Inf in + # 'x'") and the variogram fell back to the RAW response, a different + # estimand (2950 against 2168 with that row removed); complete.cases() let + # it into the REML fit too, which then "did not converge". + # prep_model_data() and resolution_profile() already leave such rows out. + fin <- is.finite(y) & Reduce(`&`, lapply(predictor_vars, function(v) { + x <- df[[v]] + if (is.numeric(x)) is.finite(x) else !is.na(x) + }), TRUE) + if (any(!fin)) + .log_info(paste0("estimate_sac_range(): %d of %d row(s) have a missing or ", + "non-finite response or predictor and are left out of ", + "the detrending fit and the variogram."), + sum(!fin), length(fin)) # REML: trend and covariance fitted together, so the trend is a GLS fit # under the fitted correlation and the range is the REML estimate, not a # variogram of residuals. Measured on simulated fields (n = 300, true @@ -1679,11 +2147,10 @@ estimate_sac_range <- function(points_sf, response_var, if (identical(detrend, "reml")) { xy_tr <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] df$.sac_x <- xy_tr[, 1]; df$.sac_y <- xy_tr[, 2] - # Complete rows only, chosen here rather than by na.action so the same + # Finite rows only, chosen here rather than by na.action so the same # row set can carry the coordinates alongside the model frame and the # residuals can be put back at their positions afterwards. - keep <- stats::complete.cases(df[, c(response_var, predictor_vars), drop = FALSE]) & - is.finite(df$.sac_x) & is.finite(df$.sac_y) + keep <- fin & is.finite(df$.sac_x) & is.finite(df$.sac_y) mf <- df[keep, c(response_var, predictor_vars, ".sac_x", ".sac_y"), drop = FALSE] if (sum(keep) >= 30L) { extent <- max(diff(range(xy_tr[keep, 1])), diff(range(xy_tr[keep, 2])), 1) @@ -1720,7 +2187,7 @@ estimate_sac_range <- function(points_sf, response_var, } } lm_fit <- if (is.null(reml_fit)) - try(stats::lm(fml, data = df, na.action = stats::na.exclude), silent = TRUE) + try(stats::lm(fml, data = df[fin, , drop = FALSE]), silent = TRUE) else NULL if (is.null(lm_fit)) { # REML handled the trend above; nothing to do here. @@ -1734,11 +2201,12 @@ estimate_sac_range <- function(points_sf, response_var, .try_error_message(lm_fit)) } else { resid <- stats::residuals(lm_fit) - if (length(resid) != nrow(pts)) { + if (length(resid) != sum(fin)) { .warn_and_log("estimate_sac_range(): OLS residual length (%d) does not match data rows (%d); the variogram is fitted to the RAW response instead.", - length(resid), nrow(pts)) + length(resid), sum(fin)) } else { - y <- resid + y <- rep(NA_real_, length(fin)) + y[fin] <- as.numeric(resid) detrended <- TRUE detrend_method <- "ols" } @@ -1749,7 +2217,9 @@ estimate_sac_range <- function(points_sf, response_var, pts <- pts[is.finite(pts$..sac_var), , drop = FALSE] if (nrow(pts) < 30L) { .log_warn("estimate_sac_range(): too few finite values after filtering; returning NA.") - return(NA_real_) + return(structure(NA_real_, rejected_reason = sprintf(paste0( + "%d point(s) with a finite value to model, fewer than the 30 a ", + "variogram range is estimated from"), nrow(pts)))) } # A variable with no variance has no autocorrelation structure to estimate: # every semivariance is 0, and gstat's fit returned a finite "range" (168 @@ -1760,10 +2230,12 @@ estimate_sac_range <- function(points_sf, response_var, .log_warn(paste0("estimate_sac_range(): the variable being modelled is ", "constant (zero variance%s), so it has no autocorrelation ", "range. Returning NA."), - if (!is.null(predictor_vars) && length(predictor_vars) > 0L) - " -- the OLS residuals are all zero, so the predictors explain the response exactly" + if (detrended) + " -- the residuals are all zero, so the predictors explain the response exactly" else "") - return(NA_real_) + return(structure(NA_real_, rejected_reason = if (detrended) + "the residuals on predictor_vars are constant: the predictors explain the response exactly" + else "the response is constant")) } # Empirical variogram. The lag cutoff is a fraction of the maximum @@ -1779,8 +2251,12 @@ estimate_sac_range <- function(points_sf, response_var, if (nrow(hv) < 2L) 0 else max(stats::dist(hv)) }, silent = TRUE) - if (inherits(max_dist, "try-error") || !is.finite(max_dist) || max_dist <= 0) - return(NA_real_) + if (inherits(max_dist, "try-error") || !is.finite(max_dist) || max_dist <= 0) { + .log_warn("estimate_sac_range(): the points have no extent to fit a variogram over. Returning NA.") + return(structure(NA_real_, rejected_reason = paste0( + "the points have no extent (the largest distance between them is zero ", + "or could not be computed)"))) + } cutoff_dist <- as.numeric(cutoff * max_dist) @@ -2030,6 +2506,20 @@ estimate_sac_range <- function(points_sf, response_var, iso_ok <- is.finite(iso_fit_always) && as.numeric(iso_fit_always) <= max_supported && !identical(attr(iso_fit_always, "converged"), FALSE) + # A converged all-pairs fit whose range runs past the fitted lags is not an + # unusable fit but a finding: the pooled variogram, which sees every pair, + # reached no sill. The directional maximum must not stand in for it. The + # directions that did reach a sill are by construction the SHORTER ones (a + # trend's cross-slope directions, an anisotropic field's minor axes), so + # their maximum is a lower bound on the range, not an estimate of it, and + # whether two of them happened to fit flipped the answer between NA and a + # finite range from one draw to the next: with an east-west trend on an + # exponential field of range 150, 12 of 30 draws returned 131-596 this way + # with anisotropy_used = TRUE, and 16 others NA. It goes to the rejection + # below, as the documentation always said a trend would. + iso_over <- is.finite(iso_fit_always) && + !identical(attr(iso_fit_always, "converged"), FALSE) && + as.numeric(iso_fit_always) > max_supported if (!is.null(reml_fit)) { # --- REML detrending: the range is the REML estimate --------------------- @@ -2048,7 +2538,7 @@ estimate_sac_range <- function(points_sf, response_var, vg_used <- if (inherits(vg_iso_always, "data.frame")) vg_iso_always else NULL if (dir_success) anisotropy <- max(usable, na.rm = TRUE) / min(usable, na.rm = TRUE) - } else if (dir_success) { + } else if (dir_success && !iso_over) { dir_max <- max(usable, na.rm = TRUE) anisotropy <- dir_max / min(usable, na.rm = TRUE) winner <- which.max(usable) @@ -2084,7 +2574,10 @@ estimate_sac_range <- function(points_sf, response_var, # fits is biased upward whatever hurdle is put in front of it. So the # all-pairs range is the estimate; the directional ranges are reported as # a diagnostic, and a caller who KNOWS the field is anisotropic can size - # blocks from max(attr(x, "directional")) explicitly. + # blocks from the longest directional range explicitly. Not from + # max(attr(x, "directional")): on exactly such a field the major axis is + # the direction most likely to run past the fitted lags, which makes it NA + # there and the maximum NA (or, with na.rm = TRUE, the second-longest). if (iso_ok) { effective_range <- as.numeric(iso_fit_always) vg_used <- vg_iso_always @@ -2096,14 +2589,19 @@ estimate_sac_range <- function(points_sf, response_var, "point pairs and the windows are fixed to the coordinate axes, ", "so this spread is expected on an isotropic field too; the ", "all-directions estimate (%.1f) is used. If the field is known ", - "to be anisotropic, size blocks from ", - "max(attr(range, \"directional\")) instead."), + "to be anisotropic, size blocks from the longest directional ", + "range instead: max(attr(range, \"directional_fitted\"), ", + "na.rm = TRUE), after checking attr(range, ", + "\"directional_status\"), since a direction that is not \"ok\" ", + "has no identified range."), anisotropy, paste(sprintf("%d\u00b0 = %.1f", dir_az[dir_ok], dir_ranges[dir_ok]), collapse = ", "), as.numeric(iso_fit_always)) } else { - # The isotropic fit is unusable; the directional sweep is all there is. + # The isotropic fit is singular or did not converge (one that converged + # past the fitted lags goes to the refusal instead, see `iso_over`); the + # directional sweep is all there is. aniso_used <- TRUE effective_range <- dir_max vg_used <- dir_fits[[winner]]$vg @@ -2118,10 +2616,14 @@ estimate_sac_range <- function(points_sf, response_var, } } else { # --- Isotropic variogram (fallback when directional fits fail) ---------- + # Also reached when the all-pairs fit converged past the fitted lags + # (`iso_over`), whatever the directions did, so the refusal below sees it. # The same all-pairs variogram and fit as above; it was recomputed here, # which cost a second fit and logged its failure twice. vg_iso <- vg_iso_always iso_range <- iso_fit_always + if (dir_success) + anisotropy <- max(usable, na.rm = TRUE) / min(usable, na.rm = TRUE) if (is.finite(iso_range)) { # A gstat fit that stopped at its iteration limit reports a range that is # wherever the optimiser happened to be, not a fitted parameter. Record @@ -2137,13 +2639,15 @@ estimate_sac_range <- function(points_sf, response_var, } else { # Neither directional nor isotropic succeeded. The VALUE is NA, but the # empirical variogram is still the thing to look at: both fits being - # singular is what a flat, nugget-only variogram produces -- residuals - # with no spatial structure at the lags resolved -- and returning a bare - # NA left plot(type = "variogram") unable to draw exactly that picture - # ("could not be fitted; there may be too few finite residuals"). + # singular is one thing a flat, nugget-only variogram produces -- + # residuals with no spatial structure at the lags resolved -- and + # returning a bare NA left plot(type = "variogram") unable to draw + # exactly that picture ("could not be fitted; there may be too few + # finite residuals"). Only one: on 30 draws of white noise this branch + # was reached once, and eight came back with a finite (spurious) range. .log_warn(paste0("estimate_sac_range(): no variogram model could be fitted ", "(the exponential and spherical fits are both singular, ", - "which is what a flat, nugget-only variogram produces); ", + "which a flat, nugget-only variogram can produce); ", "returning NA. The empirical variogram is attached for ", "inspection: call plot() on the returned value.")) return(structure( @@ -2173,6 +2677,12 @@ estimate_sac_range <- function(points_sf, response_var, # the semivariance at zero separation, which a resolution criterion needs # and which used to be reachable only by reading gstat's row layout. nugget_val <- .vgm_nugget_of(vgm_used) + # The REML fit's own numbers, on the refusals as on the success: a refused + # REML range is exactly where how many points it used and how much of the + # variance it put in the nugget are worth reading. + reml_attr <- if (is.null(reml_fit)) NULL else + list(n_used = reml_fit$n_used, subsampled = isTRUE(reml_fit$subsampled), + nugget_prop = reml_fit$nugget_prop, sigma2 = reml_fit$sigma2) if (!is.finite(effective_range) || effective_range <= 0) { # Classed like every other refusal, so the evidence travels with the NA; @@ -2190,6 +2700,7 @@ estimate_sac_range <- function(points_sf, response_var, directional_fits = dir_detail_out, detrended = isTRUE(detrended), detrend_method = detrend_method, + reml = reml_attr, max_dist = as.numeric(max_dist), cutoff_dist = as.numeric(cutoff_dist), crs = sf::st_crs(pts), @@ -2225,12 +2736,50 @@ estimate_sac_range <- function(points_sf, response_var, # a variance that differs between a dense cluster and the rest of the layer # (see .variogram_decreasing() for the measured rates). decreasing <- .variogram_decreasing(vg_used) + # The mirror of `over_cutoff` at the other end of the lags: a range too + # short for enough pairs of points to lie inside it is not identified, and + # the data cannot tell it from a nugget. For the variogram fits the bound + # is the shortest lag the variogram resolves (the mean separation in its + # first non-empty bin): a range below it was fitted to no bin inside it. + # The REML range is fitted to the point pairs themselves, not to the bins, + # so its bound is the distance within which the points it used have 30 + # pairs (the usual minimum per lag), capped at that first lag so that it + # never refuses what the bin bound accepts. Against the first lag alone the + # REML answer depended on a `cutoff` it never uses: 10 of 20 REML estimates + # of a true 30 m range (n = 400, 1000 m square) were refused at 14.5-28.8 + # m, and all ten came back at cutoff = 0.1; now none is refused at either. + # The cap keeps some of that dependence where the first lag is the shorter + # (a small cutoff, or a sparse layer). The bound is about identification, + # not a test for structure: iid noise can put 30 pairs inside a spurious + # range (3 of the 19 white-noise REML ranges below the first lag, n = 300, + # now pass at 21-24 m), and a true short range can fall below it. + first_lag <- if (is.data.frame(vg_used) && all(c("dist", "np") %in% names(vg_used))) { + d1 <- vg_used$dist[is.finite(vg_used$dist) & is.finite(vg_used$np) & vg_used$np > 0] + if (length(d1)) min(d1) else NA_real_ + } else NA_real_ + range_floor <- first_lag + floor_is_pairs <- FALSE + if (!is.null(reml_fit) && is.finite(reml_fit$pair_floor %||% NA_real_) && + !isTRUE(reml_fit$pair_floor >= first_lag)) { + range_floor <- reml_fit$pair_floor + floor_is_pairs <- TRUE + } + under_lag <- is.finite(range_floor) && effective_range < range_floor # Non-convergence is refused on the same terms and for the same reason: the # number is not a fitted parameter. gstat signals it with a warning and # returns anyway, which is why it needs its own test rather than riding on # the cutoff bound -- a non-converged range can land inside the bound and # would otherwise have sized a block. - if (over_cutoff || !fit_converged || decreasing) { + if (over_cutoff || !fit_converged || decreasing || under_lag) { + # What to try next. "Supply `predictor_vars`" was said of a range that + # was already of the residuals on them. REML is suggested only where it + # was not asked for (a REML fit that failed has fallen back to OLS). + detrend_advice <- if (isTRUE(detrended)) + paste0("try predictors that carry the trend (coordinate terms, for ", + "instance)", + if (identical(detrend_method, "ols") && !identical(detrend, "reml")) + " or `detrend = \"reml\"`" else "") + else "supply `predictor_vars` to detrend" if (decreasing) { .log_warn( paste0("estimate_sac_range(): the empirical variogram decreases with ", @@ -2239,9 +2788,17 @@ estimate_sac_range <- function(points_sf, response_var, "(hole-effect) structure produces, or a variance that differs ", "between a dense cluster and the rest of the layer; an ", "unremoved trend makes a variogram rise without a sill, which ", - "is a different signal. Returning NA. Inspect it with plot() on ", + "is a different signal.%s Returning NA. Inspect it with plot() on ", "the returned value, and set a block size explicitly."), - effective_range + effective_range, + # The fixed 15% tolerance does not widen with the sampling noise of + # the short-lag bins: 7-9 of 60 ordinary exponential fields were + # refused at n = 30, 0-1 at n = 100 (see .variogram_decreasing()). + if (nrow(pts) < 100L) + sprintf(paste0(" With %d points the short-lag bins are noisy enough ", + "for an ordinary field to show this shape as well."), + nrow(pts)) + else "" ) } else if (over_cutoff) { .log_warn( @@ -2249,9 +2806,36 @@ estimate_sac_range <- function(points_sf, response_var, "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 + "fit longer lags, %s, or set a block size explicitly. (A ", + "variogram that is flat from the first lag, with no spatial ", + "structure to find, can end here too: plot() the returned value ", + "to tell the two apart.)"), + effective_range, max_supported, format(range_frac), cutoff_dist, + detrend_advice + ) + } else if (fit_converged && !is.null(reml_fit)) { + .log_warn( + paste0("estimate_sac_range(): the REML range (%.3g) is shorter than ", + "%s (%.3g): fewer than 30 pairs of the %d points the REML fit ", + "used lie inside it, too few to identify a range, and a ", + "structure that short cannot be told from a nugget. Returning ", + "NA."), + effective_range, + if (floor_is_pairs) "the distance within which 30 of its point pairs lie" + else paste0("the shortest lag the variogram of the residuals resolves ", + "(the mean separation in its first bin)"), + range_floor, as.integer(reml_fit$n_used) + ) + } else if (fit_converged) { + .log_warn( + paste0("estimate_sac_range(): the fitted range (%.3g) is shorter than ", + "the shortest lag the variogram resolves (%.3g, the mean ", + "separation in its first bin), so no lag inside it was fitted ", + "and it cannot be told from a nugget. Returning NA. If the ", + "empirical variogram is at its sill from the first bin, re-run ", + "with a smaller `cutoff` (the bins are cutoff * max_dist / 15 ", + "wide); plot() the returned value to see it."), + effective_range, range_floor ) } else { .log_warn( @@ -2259,10 +2843,10 @@ estimate_sac_range <- function(points_sf, response_var, "(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: call plot() on the returned value."), - effective_range + "lags, %s, or set a block size explicitly. The empirical ", + "variogram is attached for inspection: call plot() on the ", + "returned value."), + effective_range, detrend_advice ) } # The VALUE is NA -- the range is genuinely unidentified and must not be @@ -2287,6 +2871,7 @@ estimate_sac_range <- function(points_sf, response_var, directional_fits = dir_detail_out, detrended = isTRUE(detrended), detrend_method = detrend_method, + reml = reml_attr, max_dist = as.numeric(max_dist), cutoff_dist = as.numeric(cutoff_dist), crs = sf::st_crs(pts), @@ -2298,7 +2883,12 @@ estimate_sac_range <- function(points_sf, response_var, "empirical variogram decreases with distance" else if (over_cutoff) "fitted range exceeds the largest lag fitted" - else "variogram model did not converge" + else if (fit_converged) + "fitted range is below the shortest lag fitted" + else "variogram model did not converge", + # The distance the refused range fell short of, for that refusal only. + range_floor = if (!decreasing && !over_cutoff && fit_converged) + as.numeric(range_floor) else NULL )) } @@ -2326,9 +2916,7 @@ estimate_sac_range <- function(points_sf, response_var, # numbers when it was used, so the caller can see how much of the layer # the trend was estimated on. detrend_method = detrend_method, - reml = if (is.null(reml_fit)) NULL else - list(n_used = reml_fit$n_used, subsampled = isTRUE(reml_fit$subsampled), - nugget_prop = reml_fit$nugget_prop, sigma2 = reml_fit$sigma2), + reml = reml_attr, max_dist = as.numeric(max_dist), cutoff_dist = as.numeric(cutoff_dist), # The CRS the variogram was fitted in. Its range is a length in these @@ -2358,7 +2946,12 @@ estimate_sac_range <- function(points_sf, response_var, #' summarised beneath it when one is available. A direction whose fit was #' unusable is labelled with why (\code{directional_status}) and the range #' its fit reported (\code{directional_fitted}) when the object carries -#' them, and \code{unidentified} otherwise. +#' them, and \code{unidentified} otherwise. A last line names the unit and +#' the CRS the range is a length in (\code{attr(x, "crs")}, which for +#' lon/lat input is the projected CRS the estimate chose; for a layer with +#' no CRS, it says the range is in that layer's own coordinate units), and +#' whether the variogram is of the response or of its residuals on +#' \code{predictor_vars} (\code{detrended}, \code{detrend_method}). #' #' @param x An object of class \code{sac_range}. #' @param ... Ignored. @@ -2401,6 +2994,31 @@ print.sac_range <- function(x, ...) { if (is.finite(a)) cat(sprintf(" (ratio %.2f)", a)) cat("\n") } + # What the number is a length in, and of what. Lon/lat input is fitted in a + # UTM or equal-area CRS picked for it, and a detrended estimate is the range + # of the residuals rather than of the response. Both ride as attributes, + # and not every function that takes the object reconciles them with its + # own data, so they are shown where a mismatch can be seen before the + # object is passed on. + cr <- attr(x, "crs") + dm <- attr(x, "detrend_method") + what <- if (isTRUE(attr(x, "detrended"))) + sprintf("; variogram of the residuals on predictor_vars (%s)", + if (is.character(dm) && length(dm) == 1L && !is.na(dm)) dm else "detrended") + else if (isFALSE(attr(x, "detrended"))) "; variogram of the response itself" + else "" + if (inherits(cr, "crs") && !is.na(cr)) { + u <- tryCatch(cr$units_gdal, error = function(e) NULL) + unit <- if (is.character(u) && length(u) == 1L && !is.na(u) && nzchar(u)) + switch(u, metre = "metres", kilometre = "kilometres", foot = "feet", + "US survey foot" = "US survey feet", degree = "degrees", u) + else "CRS units" + cat(sprintf(" in %s of %s%s\n", unit, .fold_crs_label(cr), what)) + } else if (inherits(cr, "crs")) { + # A layer with no CRS: the range is in its own, unnamed coordinate units, + # and whether it is of residuals matters as much as with one. + cat(sprintf(" in the coordinate units of a layer with no CRS%s\n", what)) + } invisible(x) } @@ -2508,8 +3126,9 @@ print.sac_range <- function(x, ...) { #' Create spatial cross-validation folds #' -#' Builds train/test splits using random K-fold, spatial block K-fold, or -#' buffered leave-one-out strategies. +#' Builds train/test splits by random k-fold, spatial block k-fold, +#' leave-location-out, buffered leave-one-out or nearest-neighbour distance +#' matching (NNDM) leave-one-out. #' #' For \code{block_kfold}, the default grid sizing is purely geometric and #' unrelated to the autocorrelation range of the data. When blocks are @@ -2526,15 +3145,19 @@ print.sac_range <- function(x, ...) { #' or \code{prediction_points} that carries a CRS. They are reprojected when #' the coordinates look like lon/lat and otherwise stamped without #' reprojection, with a warning either way. -#' @param k Integer; number of folds. Must be a single whole number >= 1. +#' @param k Integer; number of folds. Must be a single whole number >= 1, +#' and is required except for the two leave-one-out methods. #' A fraction, \code{NA} or a vector is an error, because a non-integer used #' to truncate silently and leave the last rows in no test set at all. #' Not every method honours it. \code{"buffered_loo"} and \code{"nndm"} are #' leave-one-out schemes and always return \code{k = n} regardless of what #' was asked for; \code{"block_kfold"} lowers it when the grid yields fewer #' than \code{k} non-empty blocks, and \code{"leave_location_out"} lowers it -#' when there are fewer than \code{k} distinct groups. Read the \code{k} -#' element of the returned list, and do not assume the requested value. A +#' when there are fewer than \code{k} distinct groups. \code{k = 1} is +#' raised to 2 by \code{"random_kfold"}, \code{"block_kfold"} and +#' \code{"leave_location_out"}, since one fold has no training set. Read +#' the \code{k} element of the returned list, and do not assume the +#' requested value. A #' reduction is written to the package log and raises no R warning, so #' \code{tryCatch(warning = )} will not see it and \code{suppressWarnings()} #' will not hide it. @@ -2542,12 +3165,19 @@ print.sac_range <- function(x, ...) { #' \code{"buffered_loo"}, \code{"leave_location_out"} or \code{"nndm"}. See #' \strong{Details} for what each one does and when it is appropriate. #' @param seed Optional integer RNG seed. -#' @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, default 3. When neither \code{block_size} -#' nor \code{block_nx}/\code{block_ny} is given, the automatic grid aims for +#' @param block_nx,block_ny Optional grid dimensions for block_kfold, each a +#' single whole number >= 1. Give both, or give one and the other is +#' derived from the extent's aspect ratio so that the blocks are roughly +#' square. Ignored when \code{block_size} or \code{auto_range} override +#' them. +#' @param block_multiplier A single positive number, default 3. When +#' neither \code{block_size} nor \code{block_nx}/\code{block_ny} is given, +#' the automatic grid aims for #' \code{block_multiplier * k} blocks over the extent (aspect-preserving), -#' so each fold holds out about \code{block_multiplier} blocks. With 1, +#' so each fold holds out about \code{block_multiplier} blocks. An extent +#' more than about \code{block_multiplier * k} times as wide as it is tall +#' (or as tall as it is wide) gets a single row (or column) of that many +#' blocks. With 1, #' every fold is one contiguous region and the score depends heavily on #' which region each fold happened to get; with many, the blocks shrink #' towards single points and the scheme drifts back towards random k-fold. @@ -2574,8 +3204,12 @@ print.sac_range <- function(x, ...) { #' request above 1,000,000 blocks is refused with an error naming the grid #' dimensions, the extent and the CRS's units. #' @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 +#' range is estimated via \code{estimate_sac_range()} (the omnidirectional, +#' all-pairs range; the directional ranges it also fits are a diagnostic +#' only, so on a field known to be anisotropic pass +#' \code{block_size = max(attr(r, "directional_fitted"), na.rm = TRUE)} +#' yourself after checking \code{attr(r, "directional_status")}, see +#' \code{\link{estimate_sac_range}}) and used as the #' minimum \code{block_size}. Requires \code{response_var}. An explicit #' \code{block_size} takes precedence. Default \code{FALSE}. Sizing #' blocks from the autocorrelation range is the recommendation of Roberts @@ -2584,19 +3218,40 @@ print.sac_range <- function(x, ...) { #' \emph{parameter} as the block size, whereas this uses the #' \emph{effective} range \code{estimate_sac_range()} returns (three #' times that parameter for an exponential fit), so its blocks are larger -#' than \pkg{blockCV}'s from the same variogram. +#' than \pkg{blockCV}'s from the same variogram. When no range is +#' identified, the geometric grid is used instead, with a warning that +#' gives the reason. An identified range above half the extent in both +#' directions leaves room for a single block, and \code{make_folds()} then +#' stops with an error naming the size, rather than return one fold with +#' an empty training set: pass a smaller \code{block_size}, or use +#' \code{method = "nndm"}. #' @param range_frac Passed through to \code{estimate_sac_range()} when #' \code{auto_range = TRUE}. A fitted range beyond the longest lag the #' empirical variogram was fitted over is rejected as unidentified, and block -#' sizing falls back to geometry, so the grid does not collapse to a single -#' block. +#' sizing falls back to geometry (with a warning). A range within that +#' bound can still be too wide for two blocks; see \code{auto_range}. #' Default 1.0. #' @param response_var Character(1) response column name. Required when -#' \code{auto_range = TRUE}. +#' \code{auto_range = TRUE}. For \code{"block_kfold"} a name that is not a +#' column of \code{points_sf} is an error, whether or not +#' \code{auto_range} is set: with it off the response still feeds the +#' leakage warning, which a misspelt name would silently disable. #' @param predictor_vars Optional character vector of predictor column names. #' Passed to \code{estimate_sac_range()} for residual variogram estimation. -#' @param boundary Optional polygonal sf/sfc for block_kfold. -#' @param buffer Positive numeric distance for buffered_loo. +#' @param boundary Optional polygonal sf/sfc for block_kfold. The grid is +#' clipped to it; a cell that the boundary only touches at a corner or +#' along an edge is not a block. A boundary without a CRS is brought into +#' the points' CRS: reprojected from EPSG:4326 when its coordinates look +#' like lon/lat, otherwise stamped, with a warning either way. The same +#' goes for \code{prediction_points} and \code{blocks}. +#' @param buffer For \code{"buffered_loo"}: a single positive number, the +#' distance within which the held-out point's neighbours are excluded from +#' its training set. Like \code{block_size} it is in the units of the CRS +#' the folds are built in (\code{params$crs}), which for geographic +#' (lon/lat) input is the metre CRS \code{\link{ensure_projected}()} +#' chooses: 0.1 means 0.1 m, not 0.1 degrees. A buffer that excludes no +#' neighbour from any fold makes the scheme plain leave-one-out, and is +#' warned about. #' @param group_var Character(1) naming a column of \code{points_sf} that #' identifies the location each observation belongs to. Required for #' \code{method = "leave_location_out"}, which keeps every observation from a @@ -2614,11 +3269,16 @@ print.sac_range <- function(x, ...) { #' plain leave-one-out. #' @param min_train For \code{method = "nndm"}: the smallest fraction of the #' data any fold's training set may be reduced to by neighbour exclusion. -#' Default \code{0.5}, as in \code{CAST::nndm()}. +#' Default \code{0.5}, as in \code{CAST::nndm()}. Where it binds, the +#' distance matching stops short and the cross-validation stays optimistic; +#' see \strong{Details}. #' @param phi For \code{method = "nndm"}: the distance up to which the two #' nearest-neighbour distance distributions are matched, in the CRS the -#' folds are built in; the exclusion never pushes a held-out point's -#' nearest neighbour beyond it. In Mila et al. (2022), and in +#' folds are built in. Matching is attempted only while a held-out +#' point's nearest-neighbour distance is at most \code{phi}; the exclusion +#' that takes it past \code{phi} is the last one, so a realised distance +#' can exceed \code{phi} by up to one neighbour step, as in +#' \code{CAST::nndm()}. In Mila et al. (2022), and in #' \code{CAST::nndm()}, \eqn{\phi} is the autocorrelation range of the #' outcome: beyond it observations are effectively independent, so #' matching is unnecessary. \code{\link{estimate_sac_range}()} gives such @@ -2640,22 +3300,47 @@ print.sac_range <- function(x, ...) { #' approaches the distribution of distances from your actual prediction #' locations to the training data. #' -#' The procedure is the paper's own (as in \code{CAST::nndm()}), and it is -#' deterministic. Let \eqn{G_{ij}} be the empirical distribution of +#' The procedure is the paper's, and it is deterministic. Let \eqn{G_{ij}} +#' be the empirical distribution of #' prediction-to-nearest-training distances and \eqn{G_j^*} the distribution #' of each held-out point's nearest remaining training point. Starting from #' plain leave-one-out, the point with the smallest \eqn{G_j^*} at which the #' realised distribution exceeds the target (\eqn{G_j^*(r) > G_{ij}(r)}) has #' its nearest training neighbour removed, and this repeats until no such -#' point remains, subject to two limits: a point's nearest-neighbour distance -#' is never pushed beyond \code{phi} (default: the largest prediction distance, -#' since a training point already further than every prediction distance has -#' nothing to match), and no fold's training set is stripped below +#' point remains, subject to two limits: a point is matched only while its +#' nearest-neighbour distance is at most \code{phi} (default: the largest +#' prediction distance, since a training point already further than every +#' prediction distance has nothing to match), so the exclusion that takes it +#' past \code{phi} is its last and a realised distance can exceed \code{phi} +#' by up to one neighbour step; and no fold's training set is stripped below #' \code{min_train} of the data. #' -#' The realised distribution is then never \emph{more optimistic} than the -#' target: \eqn{G_j^*(r) \le G_{ij}(r)} up to the granularity of the -#' neighbour distances, which is the property the method exists to deliver. +#' It differs from \code{CAST::nndm()} in two details, so the folds agree +#' closely with CAST's but not exactly. The removal rule is strict: a +#' neighbour is removed whenever the realised distribution exceeds the target, +#' whereas CAST removes one only while the realised distribution, less the +#' point about to move, is still at or above the target. The rule here +#' therefore removes up to one point more per distance value (a few percent +#' more removals in all on clustered layouts), erring on the pessimistic side. +#' And ties in \eqn{G_j^*} are broken by the points' coordinates, not by +#' their row index as in CAST, so the folds do not depend on the order of the +#' rows. +#' +#' Where neither limit binds, the realised distribution is then never +#' \emph{more optimistic} than the target: \eqn{G_j^*(r) \le G_{ij}(r)} up to +#' the granularity of the neighbour distances, which is the property the +#' method exists to deliver. Beyond \code{phi} no matching is attempted, by +#' design. \code{min_train} is different: when the prediction locations lie +#' further from the samples than a fold can be made to hold out (clustered +#' samples and a prediction domain well beyond them, the layout NNDM is meant +#' for), it stops the matching early and the realised distances stay +#' optimistic. \code{params$n_at_min_train} counts the folds that were held +#' at the floor while still closer than the target allows, and +#' \code{make_folds()} warns when that leaves more than one point's worth of +#' excess at or below \code{phi}. Lower \code{min_train} to match further, or +#' read the cross-validated score as an upper bound on performance at the +#' prediction locations. +#' #' An earlier version of this package drew one random radius per point from #' \eqn{G_{ij}} and excluded up to the order statistic \emph{closest} to it, #' which rounds down half the time: on a two-cluster layout the realised @@ -2682,7 +3367,10 @@ print.sac_range <- function(x, ...) { #' folds for k-fold cross-validation of species distribution models. #' \emph{Methods in Ecology and Evolution} \strong{10}, 225-232. #' \doi{10.1111/2041-210X.13107} -#' @param drop_empty_blocks Logical. Default TRUE. +#' @param drop_empty_blocks Logical. Default TRUE. With \code{FALSE} the +#' blocks that hold no point are kept and packed into folds too, but +#' \code{k} is still lowered to the number of blocks that hold points, so +#' no fold is left without test points. #' @param blocks Optional polygon layer (\code{sf} or \code{sfc}, POLYGON or #' MULTIPOLYGON, at least two features) to use as the blocks of #' \code{"block_kfold"} in place of the grid this function would otherwise @@ -2783,6 +3471,9 @@ print.sac_range <- function(x, ...) { #' \code{blocks[params$blocks$source_row, ]} recovers them with their own #' columns and in their own order. It runs from 1 to #' \code{params$n_blocks} and is the identity when nothing was dropped. +#' For a grid \code{params$n_blocks} is \code{grid_nx * grid_ny}, the +#' cells a \code{boundary} clips away included, and +#' \code{params$blocks_used} is the number of blocks returned. #' \code{params$block_sizes} is the number of points in each block, indexed #' by \code{block_id} (zeros are empty blocks that #' \code{drop_empty_blocks = FALSE} kept), and \code{params$fold_blocks} @@ -2795,12 +3486,12 @@ print.sac_range <- function(x, ...) { #' several, and the blocks can be drawn over the data #' (\code{\link{plot_folds}()} does so). #' -#' For the methods that work in projected space (\code{"block_kfold"}, -#' \code{"buffered_loo"} and \code{"nndm"}), \code{params} carries a +#' For \code{"block_kfold"}, \code{params} carries a #' \code{params$blocks_supplied} that says whether the blocks came from #' \code{blocks} or from a grid built here, and -#' \code{params$boundary_supplied} whether a \code{boundary} was given; -#' \code{params$row_probe} is a small sample of row IDs and coordinates +#' \code{params$boundary_supplied} whether a \code{boundary} was given. +#' Every method's \code{params} carries +#' \code{params$row_probe}, a small sample of row IDs and coordinates #' that every \code{cv_*()} compares against the data it is handed, so #' folds built from a different layer of the same size are refused, never #' applied silently. @@ -2885,18 +3576,46 @@ make_folds <- function(points_sf, k, stop("make_folds(): `k` must be a single whole number >= 1; got ", paste(format(k), collapse = ", "), ".", call. = FALSE) k <- as.integer(k) + } else if (method %in% c("random_kfold", "block_kfold", "leave_location_out")) { + # A missing or NULL k skipped the check above and died at the first + # `if (k < 2)` with R's "argument is of length zero". The two + # leave-one-out methods never read k, so only these three need it. + stop(sprintf(paste0("make_folds(): `k` (the number of folds) is required ", + "for method = \"%s\"."), method), call. = FALSE) } # block_size was tested with `is.numeric(block_size) && block_size > 0` and # anything failing that was silently ignored -- yet echoed back unchanged in # params$block_size, so a negative, zero or character value looked honoured. # NA and a length-2 vector reached the grid arithmetic and died as internal - # R errors. Validate it once, the way `k` is. + # R errors. Validate it once, the way `k` is. A `units` object passes + # is.numeric() but fails `block_size <= 0` inside the units package with a + # message that never names the argument, so it is refused here by name. if (!is.null(block_size) && - (!is.numeric(block_size) || length(block_size) != 1L || - !is.finite(block_size) || block_size <= 0)) + (inherits(block_size, "units") || !is.numeric(block_size) || + length(block_size) != 1L || !is.finite(block_size) || block_size <= 0)) stop("make_folds(): `block_size` must be a single positive number in the ", "units of the data's CRS; got ", paste(format(block_size), collapse = ", "), ".", call. = FALSE) + # block_nx/block_ny were never validated: 0, a negative, NA or a vector + # reached st_make_grid() and failed there with sf's or base R's own + # errors, and 2.7 was truncated to 2 without notice. + for (nm in c("block_nx", "block_ny")) { + v <- get(nm) + if (!is.null(v) && + (inherits(v, "units") || !is.numeric(v) || length(v) != 1L || + !is.finite(v) || v != round(v) || v < 1)) + stop(sprintf("make_folds(): `%s` must be a single whole number >= 1; got %s.", + nm, paste(format(v), collapse = ", ")), call. = FALSE) + } + # block_multiplier was never validated: NA died inside st_make_grid() on + # 'length.out', a vector silently used its largest element, and a `units` + # value was silently taken as a plain count. + if (inherits(block_multiplier, "units") || !is.numeric(block_multiplier) || + length(block_multiplier) != 1L || !is.finite(block_multiplier) || + block_multiplier <= 0) + stop("make_folds(): `block_multiplier` must be a single positive number; got ", + if (length(block_multiplier)) paste(format(block_multiplier), collapse = ", ") + else "a value of length 0", ".", call. = FALSE) # A supplied block design is refused for the other methods rather than # ignored: hexagons that silently became random folds would be the worst # outcome. The polygon check reuses .assert_sf(), which already recognises @@ -3013,7 +3732,8 @@ make_folds <- function(points_sf, k, pts <- .transform_or_stamp(pts, sf::st_crs(blocks), what = "points_sf", caller = "make_folds") if (!is.null(.crs_or_null(pts))) - blocks <- ensure_projected(blocks, .crs_or_null(pts)) + blocks <- .transform_or_stamp(blocks, sf::st_crs(pts), + what = "blocks", caller = "make_folds") blocks <- .safe_make_valid(blocks) } # A CRS-less `points_sf` leaves .crs_or_null(pts) NULL, so the boundary @@ -3027,7 +3747,13 @@ make_folds <- function(points_sf, k, what = "points_sf", caller = "make_folds") } reg <- if (!is.null(boundary)) { - b <- ensure_projected(boundary, .crs_or_null(pts)) + # A CRS-less boundary is aligned to the points as every other function + # given one aligns it: an R warning naming this function and argument. + # ensure_projected()'s stamp was a log line naming neither, invisible + # to tryCatch(), knitr and spatialkit_quiet(). + b <- if (is.null(.crs_or_null(pts))) ensure_projected(boundary) + else .transform_or_stamp(boundary, sf::st_crs(pts), + what = "boundary", caller = "make_folds") if (inherits(b, "sfc")) b <- sf::st_sf(geometry = b) b <- .safe_make_valid(sf::st_union(b)) mat <- sf::st_intersects(pts, b, sparse = FALSE) @@ -3059,7 +3785,21 @@ make_folds <- function(points_sf, k, } # --- Autocorrelation-aware block sizing --- + # A misspelt response_var was an error under auto_range = TRUE (from + # estimate_sac_range()), but with auto_range off the diagnostic-only + # estimate below swallowed it and the leakage check silently never ran. + if (!is.null(response_var)) { + if (!is.character(response_var) || length(response_var) != 1L || + is.na(response_var)) + stop("make_folds(block_kfold): `response_var` must be a single column ", + "name; got ", paste(format(response_var), collapse = ", "), ".", + call. = FALSE) + if (!(response_var %in% names(points_sf))) + stop(sprintf("make_folds(block_kfold): `response_var` '%s' is not a column of `points_sf`.", + response_var), call. = FALSE) + } sac_range <- NA_real_ + size_from_range <- FALSE if (isTRUE(auto_range) && !is.null(response_var)) { # `seed` here is make_folds()'s own, whose default is NULL -- meaning # "do not seed the FOLD assignment". Forwarding that NULL re-opened the @@ -3088,23 +3828,44 @@ make_folds <- function(points_sf, k, # auto_range sets block_size only if the caller didn't supply one if (is.null(block_size)) { block_size <- sac_range + size_from_range <- TRUE } else if (block_size < sac_range) { - .log_warn( - "make_folds(block_kfold): supplied block_size (%.1f) is smaller than the estimated autocorrelation range (%.1f). Spatial CV may still leak correlated information.", + .warn_and_log( + "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", block_size, sac_range ) - warning( - sprintf("make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", - block_size, sac_range), - call. = FALSE - ) } } else { - .log_warn("make_folds(block_kfold): auto_range requested but estimation returned NA; falling back to geometric blocks.") + # The caller asked for range-sized blocks and is not getting them. + # This was a log line only, the quietest of the three outcomes (the + # success path messages, a missing response_var warns), so under + # knitr, spatialkit_quiet or tryCatch() a CV result could not show + # that its blocks were never sized from the data. + why <- attr(sac_range, "rejected_reason") + # estimate_sac_range() attaches a rejected_reason to every NA it + # returns, including the ones it gives before fitting anything. A + # `sac_range` without one (hand-built, or saved by an older version) + # still gets a reason: the two floors that are cheap to test here, and + # the rest of the short list. + if (!(is.character(why) && length(why) == 1L && !is.na(why))) + why <- if (!requireNamespace("gstat", quietly = TRUE)) + "package 'gstat', which the variogram needs, is not installed" + else if (nrow(pts) < 30L) + sprintf("%d points, fewer than the 30 a variogram range is estimated from", + nrow(pts)) + else paste0("estimate_sac_range() returned NA before fitting: fewer ", + "than 30 finite values to model, a variable with no ", + "variance, or points with no extent; its log line says ", + "which") + .warn_and_log(paste0("make_folds(block_kfold): auto_range = TRUE, but ", + "no autocorrelation range was identified (%s); ", + "falling back to geometric blocks, which are not ", + "sized from the data. See ?estimate_sac_range, or ", + "pass `block_size`."), + why) } } else if (isTRUE(auto_range) && is.null(response_var)) { - .log_warn("make_folds(block_kfold): auto_range = TRUE but response_var is NULL; cannot estimate range. Falling back to geometric blocks.") - warning("make_folds(): auto_range requires response_var; ignoring.", call. = FALSE) + .warn_and_log("make_folds(): auto_range requires response_var; ignoring.") } else if (!is.null(response_var)) { # auto_range is off, but a response is to hand -- which it always is when # a cv_*() function built the folds -- so estimate the range for the @@ -3135,15 +3896,10 @@ make_folds <- function(points_sf, k, # below the range leaks exactly as a geometric one does. if (!isTRUE(auto_range) && is.finite(sac_range) && sac_range > 0 && block_size < sac_range) { - .log_warn( - "make_folds(block_kfold): supplied block_size (%.1f) is smaller than the estimated autocorrelation range (%.1f). Spatial CV may leak correlated information.", + .warn_and_log( + "make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", block_size, sac_range ) - warning( - sprintf("make_folds(): block_size (%.1f) < estimated autocorrelation range (%.1f). Consider increasing block_size to reduce information leakage across folds.", - block_size, sac_range), - call. = FALSE - ) } # If the caller also supplied explicit block_nx/block_ny, warn about override if (!is.null(block_nx) || !is.null(block_ny)) { @@ -3155,57 +3911,75 @@ make_folds <- function(points_sf, k, nx <- size_dims$nx ny <- size_dims$ny - # Ensure at least k blocks so each fold can get one - if (nx * ny < k) { + # Ensure at least k blocks so each fold can get one. A single block + # is refused further down, so do not announce a k it will never use. + if (nx * ny < k && nx * ny >= 2) { .log_warn( "make_folds(block_kfold): block_size produces only %d blocks (< k = %d). Reducing k to match.", nx * ny, k ) k <- max(2L, nx * ny) } - } else if (is.null(block_nx) || is.null(block_ny)) { + } else if (is.null(block_nx) && is.null(block_ny)) { w <- as.numeric(bb["xmax"] - bb["xmin"]) h <- as.numeric(bb["ymax"] - bb["ymin"]) - ratio <- if (h > 0) w / h else 1 + # Points on one horizontal line have h == 0. Treating that as a + # square (ratio 1) gave a 4 x 4 grid whose rows all collapse onto the + # line, so only 4 blocks existed and k = 5 was lowered to 4. + ratio <- if (h > 0) w / h else if (w > 0) Inf else 1 target_blocks <- max(1L, round(block_multiplier * k)) - nx <- max(1L, round(sqrt(target_blocks * ratio))) + # nx is capped at the target just as ny is floored at 1. Without the + # cap the rule was not symmetric: a tall extent got 1 x 15 blocks, + # but the same layer turned on its side got round(sqrt(15 * w/h)) + # columns -- 39 x 1 on a 10 km x 100 m corridor -- blocks less than + # half as long, and a scheme drifting towards random k-fold. + nx <- min(target_blocks, max(1L, round(sqrt(target_blocks * ratio)))) ny <- max(1L, round(max(1, target_blocks / nx))) - # Diagnostic: warn if resulting block size is small relative to SAC range - if (is.finite(sac_range) && sac_range > 0) { - cell_w <- w / nx - cell_h <- h / ny - min_cell <- min(cell_w, cell_h) + # Diagnostic: warn if resulting block size is small relative to SAC range. + # Only a dimension that is split has blocks bordering each other + # across it: a single row spans the whole height and leaks to no + # other block that way. Taking the minimum over both compared the + # range with 0 on points on a line (and with the width of a + # corridor), and the advice to pass block_size = then gave + # SHORTER blocks along it. + split_cells <- c(if (nx > 1) w / nx, if (ny > 1) h / ny) + if (is.finite(sac_range) && sac_range > 0 && length(split_cells)) { + min_cell <- min(split_cells) if (min_cell < sac_range) { - .log_warn( - "make_folds(block_kfold): geometric block size (%.1f) is smaller than the estimated autocorrelation range (%.1f). Consider setting block_size >= %.0f or auto_range = TRUE to avoid information leakage.", - min_cell, sac_range, sac_range - ) - warning( - sprintf("make_folds(): block dimension (%.1f) < autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. Pass block_size = %.0f or auto_range = TRUE.", - min_cell, sac_range, ceiling(sac_range)), - call. = FALSE + .warn_and_log( + "make_folds(): block dimension (%.1f) < autocorrelation range (%.1f). Spatial CV may leak correlated information across folds. Pass block_size = %.0f or auto_range = TRUE.", + min_cell, sac_range, ceiling(sac_range) ) } } } else { - nx <- as.integer(block_nx); ny <- as.integer(block_ny) + w <- as.numeric(bb["xmax"] - bb["xmin"]) + h <- as.numeric(bb["ymax"] - bb["ymin"]) + # Giving only one of the two used to send the call to the automatic + # grid, silently: block_nx = 10 alone gave a 3 x 4 grid. Honour the + # one given and derive the other so the blocks are roughly square. + if (is.null(block_ny)) { + nx <- as.integer(block_nx) + ny <- if (w > 0) max(1, round(nx * h / w)) else 1 + .log_info("make_folds(block_kfold): only block_nx given; block_ny = %s derived from the extent's aspect ratio.", format(ny, scientific = FALSE)) + } else if (is.null(block_nx)) { + ny <- as.integer(block_ny) + nx <- if (h > 0) max(1, round(ny * w / h)) else 1 + .log_info("make_folds(block_kfold): only block_ny given; block_nx = %s derived from the extent's aspect ratio.", format(nx, scientific = FALSE)) + } else { + nx <- as.integer(block_nx); ny <- as.integer(block_ny) + } # Diagnostic: warn if user-supplied nx/ny yield blocks smaller than SAC - if (is.finite(sac_range) && sac_range > 0) { - w <- as.numeric(bb["xmax"] - bb["xmin"]) - h <- as.numeric(bb["ymax"] - bb["ymin"]) - cell_w <- w / nx; cell_h <- h / ny - min_cell <- min(cell_w, cell_h) + # (over the dimensions that are split; see the automatic grid above). + split_cells <- c(if (nx > 1) w / nx, if (ny > 1) h / ny) + if (is.finite(sac_range) && sac_range > 0 && length(split_cells)) { + min_cell <- min(split_cells) if (min_cell < sac_range) { - .log_warn( - "make_folds(block_kfold): user-supplied grid (%dx%d) yields blocks of ~%.1f units, smaller than estimated autocorrelation range (%.1f).", - nx, ny, min_cell, sac_range - ) - warning( - sprintf("make_folds(): block_nx/block_ny yield blocks smaller than autocorrelation range (%.1f). Consider using block_size = %.0f.", - sac_range, ceiling(sac_range)), - call. = FALSE + .warn_and_log( + "make_folds(): block_nx/block_ny yield blocks smaller than autocorrelation range (%.1f). Consider using block_size = %.0f.", + sac_range, ceiling(sac_range) ) } } @@ -3219,7 +3993,10 @@ make_folds <- function(points_sf, k, # guards exactly this mistake with max_cells and names the CRS units; # blocked CV is the sibling that did not. n_cells_est <- as.numeric(nx) * as.numeric(ny) - if (is.finite(n_cells_est) && n_cells_est > .block_max_cells) { + # A block_size hundreds of orders of magnitude too small overflows the + # product to Inf, which the old `is.finite() &&` let past the guard and + # into st_make_grid()'s "result would be too long a vector". + if (!is.finite(n_cells_est) || n_cells_est > .block_max_cells) { unit_lbl <- tryCatch({ u <- sf::st_crs(reg)$units_gdal if (is.null(u) || is.na(u) || !nzchar(u)) "CRS units" else u @@ -3227,18 +4004,42 @@ make_folds <- function(points_sf, k, # %s, not %d: nx and ny are doubles from floor(), and a block_size in # the wrong unit -- the very mistake this guard exists to explain -- # gives counts past 2^31 that %d refuses with "invalid format". + fmt_count <- function(v, big = "") { + if (!is.finite(v)) "more than 1e308" + else if (v >= 1e15) format(v, digits = 3, scientific = TRUE) + else format(v, big.mark = big, scientific = FALSE) + } + extent_lbl <- sprintf("%s x %s", + format(signif(as.numeric(bb["xmax"] - bb["xmin"]), 4)), + format(signif(as.numeric(bb["ymax"] - bb["ymin"]), 4))) + # Name what produced the grid. This always blamed `block_size`, + # printing "unset" when block_nx/block_ny or the automatic grid had + # sized it -- an argument the caller never passed. + check <- if (!is.null(block_size) && size_from_range) + sprintf(paste0("The block size is the estimated autocorrelation range ", + "(%s %s) over an extent of %s; pass `block_size` ", + "yourself, or set auto_range = FALSE."), + format(as.numeric(block_size)), unit_lbl, extent_lbl) + else if (!is.null(block_size)) + sprintf(paste0("Check that `block_size` (%s) is expressed in the ", + "data's CRS units (%s) over an extent of %s; a value ", + "in the wrong unit is the usual cause."), + format(as.numeric(block_size)), unit_lbl, extent_lbl) + else if (!is.null(block_nx) || !is.null(block_ny)) + sprintf(paste0("The grid is the one `block_nx`/`block_ny` ask for over ", + "an extent of %s (%s); ask for fewer blocks."), + extent_lbl, unit_lbl) + else + sprintf(paste0("The automatic grid aims for `block_multiplier` (%s) ", + "x k (%d) blocks over an extent of %s (%s); pass a ", + "smaller `block_multiplier`."), + format(block_multiplier), k, extent_lbl, unit_lbl) stop(sprintf(paste0("make_folds(block_kfold): the requested grid is %s x ", "%s = %s cells, above the %s this function will ", - "build. Check that `block_size` (%s) is expressed in ", - "the data's CRS units (%s) over an extent of %s x %s; ", - "a value in the wrong unit is the usual cause."), - format(nx, scientific = FALSE), format(ny, scientific = FALSE), - format(n_cells_est, big.mark = ",", scientific = FALSE), + "build. %s"), + fmt_count(nx), fmt_count(ny), fmt_count(n_cells_est, ","), format(.block_max_cells, big.mark = ",", scientific = FALSE), - if (is.null(block_size)) "unset" else format(block_size), - unit_lbl, - format(signif(as.numeric(bb["xmax"] - bb["xmin"]), 4)), - format(signif(as.numeric(bb["ymax"] - bb["ymin"]), 4))), + check), call. = FALSE) } @@ -3246,14 +4047,33 @@ make_folds <- function(points_sf, k, grid <- .safe_make_valid(grid) reg_union <- .safe_make_valid(sf::st_union(reg)) grid <- suppressWarnings(sf::st_intersection(grid, reg_union)) + # Clipping to a boundary drops the cells outside it and renumbers the + # rest, so a cell's index in the full grid is carried from the "idx" + # attribute instead: that is what params$blocks$source_row promises. + # Where the boundary only touches a cell at a corner or along an edge + # the intersection is a zero-area POINT or LINESTRING, which used to be + # kept as a block of its own -- packed into a fold when empty blocks + # were kept, and able to catch a point lying exactly on the boundary as + # a one-point block. Keep the areal pieces only, unless there are none + # (points on one straight line have a region of zero area, and every + # piece of it is a line). + cell_idx <- attr(grid, "idx") + cell_idx <- if (is.matrix(cell_idx) && nrow(cell_idx) == length(grid)) + as.integer(cell_idx[, 1L]) else seq_along(grid) + areal <- sf::st_dimension(grid) %in% 2L + if (any(areal) && !all(areal)) { + grid <- grid[areal]; cell_idx <- cell_idx[areal] + } grid_sf <- sf::st_as_sf(grid) + n_blocks <- as.integer(nx * ny) } else { # The caller's polygons are the blocks. Their row order is the block # id, so `assignment` can be joined back to the layer that was passed. grid_sf <- sf::st_as_sf(blocks) nx <- NA_integer_; ny <- NA_integer_ + cell_idx <- seq_len(nrow(grid_sf)) + n_blocks <- nrow(grid_sf) } - n_blocks <- nrow(grid_sf) hits <- sf::st_intersects(pts, grid_sf) block_id <- vapply(hits, function(ix) if (length(ix)) ix[1] else NA_integer_, 1L) pts$..block_id <- block_id @@ -3317,12 +4137,12 @@ make_folds <- function(points_sf, k, # returned design cannot be tied back to the layer the caller supplied -- # and a join by row position silently mis-attributes every block after # the first gap. - block_source_row <- seq_len(nrow(grid_sf)) + block_source_row <- cell_idx if (drop_empty_blocks) { used_blocks <- sort(unique(pts$..block_id[!is.na(pts$..block_id)])) grid_sf <- grid_sf[used_blocks, , drop = FALSE] pts$..block_id <- match(pts$..block_id, used_blocks) - block_source_row <- used_blocks + block_source_row <- cell_idx[used_blocks] } if (anyNA(pts$..block_id)) { cent <- suppressWarnings(sf::st_centroid(sf::st_geometry(grid_sf))) @@ -3342,7 +4162,14 @@ make_folds <- function(points_sf, k, integer(1) ) } - B <- max(pts$..block_id, na.rm = TRUE) + # The number of blocks that hold a point, which is what k is limited by. + # This was the highest block id a point fell in: the same number once + # empty blocks are dropped and renumbered, but under + # drop_empty_blocks = FALSE only an artifact of the numbering. With two + # clusters on a 4 x 4 grid it was 16, so k = 5 was kept for 2 occupied + # blocks and three folds came back with no test points at all -- no + # warning, because the balance check skips an empty fold. + B <- length(unique(pts$..block_id[!is.na(pts$..block_id)])) # One block means one fold whose training set is empty -- blocked CV # silently degenerating into nothing at all. It happens whenever the block # size exceeds half the extent, which an accepted autocorrelation range can @@ -3374,13 +4201,18 @@ make_folds <- function(points_sf, k, "from the estimated autocorrelation range."), how), call. = FALSE) } - if (B < k) { .log_warn("make_folds(block_kfold): blocks < k; reducing k."); k <- B } + if (B < k) { + .log_warn("make_folds(block_kfold): only %d blocks hold points (blocks < k; reducing k from %d to %d).", + B, k, B) + k <- B + } - # Counted over every block in the grid, not over 1..B. B is the highest - # block id a point fell in, which under drop_empty_blocks = FALSE says - # nothing about how many blocks there are: on a layer whose points sit in - # one quadrant of an 8x8 grid, B was 27, so blocks 28-64 were packed into - # no fold at all while the 12 equally empty blocks below 27 were -- the + # Counted over every block in the grid, not over 1..B. B used to be the + # highest block id a point fell in, which under drop_empty_blocks = FALSE + # says nothing about how many blocks there are: on a layer whose points + # sit in one quadrant of an 8x8 grid, it was 27, so blocks 28-64 were + # packed into no fold at all while the 12 equally empty blocks below 27 + # were -- the # same kind of block treated two ways depending on where it fell in an # arbitrary numbering. Counting over the grid makes `fold_blocks` cover # every block `blocks` and `block_sizes` describe. It cannot move a @@ -3400,14 +4232,9 @@ make_folds <- function(points_sf, k, na.rm = TRUE) if (is.finite(sac_range) && sac_range > 0 && is.finite(block_scale) && block_scale < sac_range) { - .log_warn( - "make_folds(block_kfold): the supplied blocks have a median scale (sqrt of area) of %.1f units, smaller than the estimated autocorrelation range (%.1f).", - block_scale, sac_range - ) - warning( - sprintf("make_folds(): the supplied blocks (median scale %.1f) are smaller than the autocorrelation range (%.1f). Spatial CV may leak correlated information across folds; supply blocks at least %.0f units across.", - block_scale, sac_range, ceiling(sac_range)), - call. = FALSE + .warn_and_log( + "make_folds(): the supplied blocks (median scale %.1f) are smaller than the autocorrelation range (%.1f). Spatial CV may leak correlated information across folds; supply blocks at least %.0f units across.", + block_scale, sac_range, ceiling(sac_range) ) } } @@ -3430,7 +4257,11 @@ make_folds <- function(points_sf, k, } # The residual imbalance is checked against the tolerance and, past it, - # raised as a warning a pipeline can catch -- not only logged. + # raised as a warning a pipeline can catch -- not only logged. No fold + # can be empty here: k is at most the number of blocks holding points, + # and the packing gives each of the k largest blocks a fold of its own + # (every fold is at load 0 until it has one), so the Inf branch is only + # a guard against dividing by zero. balance_ratio <- if (min(fold_loads) > 0L) max(fold_loads) / min(fold_loads) else Inf if (min(fold_loads) > 0L && balance_ratio > balance_tol) { .warn_and_log(paste0("make_folds(block_kfold): fold size imbalance -- ", @@ -3496,8 +4327,24 @@ make_folds <- function(points_sf, k, # ---- BUFFERED LOO ---- if (method == "buffered_loo") { - if (is.null(buffer) || !is.numeric(buffer) || buffer <= 0) - stop("make_folds(buffered_loo): `buffer` (positive numeric) is required.") + # NA, numeric(0) and a vector used to reach `buffer <= 0` and die with + # base R's "missing value where TRUE/FALSE needed" or "length = 2 in + # coercion" -- and an NA is exactly what estimate_sac_range() returns + # when it identifies no range. A `units` object failed inside the units + # package without naming `buffer`. Inf is let through: the check below + # reports that it spans the data, which is the more useful message. + if (is.null(buffer) || inherits(buffer, "units") || !is.numeric(buffer) || + length(buffer) != 1L || is.na(buffer) || buffer <= 0) + stop(sprintf(paste0( + "make_folds(buffered_loo): `buffer` must be a single positive number, ", + "in the units of the CRS the folds are built in (metres for lon/lat ", + "input, which is projected first); got %s.%s"), + if (is.null(buffer)) "NULL" + else if (!length(buffer)) "a value of length 0" + else paste(format(buffer), collapse = ", "), + if (length(buffer) == 1L && is.na(buffer)) + " An NA from estimate_sac_range() means no range was identified; choose a buffer yourself." + else ""), call. = FALSE) pts <- ensure_projected(points_sf) n <- nrow(pts) # The cost is QUADRATIC in n whatever the buffer: every one of the n @@ -3543,6 +4390,23 @@ make_folds <- function(points_sf, k, "points (largest training set: %d of %d). The buffer ", "spans the data; use a smaller one, or 'block_kfold'."), format(buffer), max(n_train_each), n), call. = FALSE) + # The opposite failure: a buffer below every nearest-neighbour distance + # excludes nothing, and buffered LOO is then plain LOO -- the optimistic + # scheme it exists to replace. The usual cause is a buffer in degrees on + # lon/lat input (0.1 read as 0.1 m once the data are projected), which + # used to pass without a word. A co-located duplicate is caught by any + # positive buffer, so every nb[[i]] of length 1 means nothing was dropped. + if (all(lengths(nb) <= 1L)) { + crs_lbl <- .fold_crs_label(pts) + .warn_and_log(paste0("make_folds(buffered_loo): a buffer of %s excludes ", + "no neighbour from any fold, so this is plain ", + "leave-one-out. `buffer` is in the units of %s (the ", + "CRS the folds are built in; metres for lon/lat ", + "input), and every point is further than that from ", + "its nearest neighbour."), + format(buffer), + if (is.na(crs_lbl)) "the data's CRS" else crs_lbl) + } return(.ret(method, n, splits, .safe_tibble(row_id = pts$..row_id, fold = seq_len(n)), @@ -3602,7 +4466,14 @@ make_folds <- function(points_sf, k, pts <- ensure_projected(points_sf) n <- nrow(pts) if (n > 5000L) - stop(sprintf("make_folds(nndm): n = %d exceeds the safety threshold of 5000. Fold construction sorts distances from every point to every other (O(n^2) time), and NNDM then produces n leave-one-out folds, so the model is refitted n times. Use 'block_kfold' instead, or subset your data.", n), + stop(sprintf(paste0( + "make_folds(nndm): n = %d exceeds the safety threshold of 5000. Fold ", + "construction keeps a sorted table of up to n/2 neighbours per point ", + "(memory grows as n^2), and where min_train binds for most points it ", + "makes about n^2/2 removals at O(n) each, so the worst case is O(n^3) ", + "time (about nine minutes at n = 3000). NNDM then produces n ", + "leave-one-out folds, so the model is refitted n times. Use ", + "'block_kfold' instead, or subset your data."), n), call. = FALSE) if (n < 3L) stop("make_folds(nndm): need at least 3 points.", call. = FALSE) @@ -3633,7 +4504,11 @@ make_folds <- function(points_sf, k, pts <- .transform_or_stamp(pts, sf::st_crs(prediction_points), what = "points_sf", caller = "make_folds") } - pred <- ensure_projected(prediction_points, target_crs = .crs_or_null(pts)) + # Aligned as `boundary` is: a CRS-less layer gets the warning, naming it. + pred <- if (is.null(.crs_or_null(pts))) ensure_projected(prediction_points) + else .transform_or_stamp(prediction_points, sf::st_crs(pts), + what = "prediction_points", + caller = "make_folds") pred <- sf::st_zm(pred, drop = TRUE, what = "ZM") # Target: distance from each prediction location to its nearest training @@ -3645,20 +4520,28 @@ make_folds <- function(points_sf, k, stop("make_folds(nndm): could not compute prediction-to-training ", "distances.", call. = FALSE) - if (!is.numeric(min_train) || length(min_train) != 1L || - !is.finite(min_train) || min_train <= 0 || min_train >= 1) + # A `units` object passes is.numeric() and then fails the comparison + # inside the units package with a message that names no argument. + if (inherits(min_train, "units") || !is.numeric(min_train) || + length(min_train) != 1L || !is.finite(min_train) || min_train <= 0 || + min_train >= 1) stop("make_folds(nndm): `min_train` must be a single number in (0, 1).", call. = FALSE) if (is.null(phi)) phi <- max(g_target) - if (!is.numeric(phi) || length(phi) != 1L || !is.finite(phi) || phi < 0) - stop("make_folds(nndm): `phi` must be a single non-negative number.", - call. = FALSE) + if (inherits(phi, "units") || !is.numeric(phi) || length(phi) != 1L || + !is.finite(phi) || phi < 0) + stop("make_folds(nndm): `phi` must be a single non-negative number, in ", + "the units of the CRS the folds are built in (a plain number, not a ", + "units object).", call. = FALSE) - # ---- The paper's procedure (Mila et al. 2022; CAST::nndm) --------------- + # ---- The paper's procedure (Mila et al. 2022) ---------------------------- # Deterministic: no radii are drawn. Starting from plain LOO, the held-out # point with the SMALLEST current nearest-neighbour distance at which the # realised distribution exceeds the target has its nearest training # neighbour removed, and this repeats until no such point remains. + # CAST::nndm() tests (cnt - 1)/n >= G instead of cnt/n > G, and breaks + # ties by row index; the strict test here removes up to one point more + # per distance value, the pessimistic side (see @details). # # Implemented as a single sweep over the points in increasing order of # their current nearest-neighbour distance. Removing a neighbour only ever @@ -3683,6 +4566,11 @@ make_folds <- function(points_sf, k, if (requireNamespace("FNN", quietly = TRUE)) { kn <- FNN::get.knn(xy, k = min(k_need + 1L, n - 1L)) nn_d <- kn$nn.dist; nn_i <- kn$nn.index + # Release get.knn()'s own copy now. While it is referenced, the + # repair below and the column subset after it work on duplicates, and + # the originals -- two n x n/2 tables, a few hundred MB at the 5000 + # cap -- stayed alive beside them through the sweep and the splits. + kn <- NULL # get.knn() means to exclude the query point, but an exact tie defeats # it: with co-located points it returns the query's OWN index in place # of one of its duplicates (verified: rbind(c(0,0), c(0,0), ...) gives @@ -3737,6 +4625,7 @@ make_folds <- function(points_sf, k, G_target <- function(r) findInterval(r, g_sorted) / n_g # right-continuous ECDF removed <- integer(n) + at_floor <- logical(n) Gjstar <- nn_d[, 1L] # Ties in Gjstar -- every mutual-nearest-neighbour pair, all of a regular # grid -- are broken by a key that depends on the GEOMETRY, not on the @@ -3752,8 +4641,8 @@ make_folds <- function(points_sf, k, r <- sv[k] j <- si[k] cnt <- findInterval(r, sv) # realised count <= r - violates <- is.finite(r) && (cnt / n) > G_target(r) + 1e-12 && - r <= phi && (n - 1L - removed[j]) > rmin && + over <- is.finite(r) && (cnt / n) > G_target(r) + 1e-12 && r <= phi + violates <- over && (n - 1L - removed[j]) > rmin && removed[j] + 1L < ncol(nn_d) if (violates) { removed[j] <- removed[j] + 1L @@ -3771,10 +4660,15 @@ make_folds <- function(points_sf, k, si <- append(si, j, after = pos) n_iter <- n_iter + 1L } else { + # Still more optimistic than the target here, but min_train forbids + # stripping this fold's training set any further: the matching stops + # short for this point. Counted so it can be reported (see below). + if (over) at_floor[j] <- TRUE k <- k + 1L } } Gjstar[si] <- sv + nn_d <- NULL # only the neighbour ids are needed now splits <- vector("list", n) n_excluded <- removed @@ -3792,6 +4686,33 @@ make_folds <- function(points_sf, k, max(findInterval(rs, rs) / length(rs) - G_target(rs)) } else NA_real_ + # min_train binds where the prediction locations lie further from the + # samples than a fold can be made to hold out -- clustered samples and a + # prediction grid well beyond them, the layout NNDM is meant for. The + # realised distances then stay optimistic (one cluster predicted onto a + # 20 km grid: median 1171 m against a target of 6704 m, 96 of 100 folds + # at the floor), and the only signal was an INFO line in a log file. + # Warn when the floor left more than one point's worth of excess at or + # below phi; beyond phi no matching is attempted by design, so an excess + # there is not the floor's doing. + n_at_floor <- sum(at_floor) + excess_phi <- if (any(fin & realised <= phi)) { + rs <- sort(realised[fin]) + rp <- rs[rs <= phi] + max(findInterval(rp, rs) / length(rs) - G_target(rp)) + } else NA_real_ + if (n_at_floor > 0L && is.finite(excess_phi) && excess_phi > 1 / n + 1e-9) + .warn_and_log(paste0( + "make_folds(nndm): min_train = %s stopped the distance matching in %d ", + "of %d folds, which keep a training point closer than the prediction ", + "distances allow, so the realised distances remain more optimistic ", + "than the target (median %.4g against %.4g; largest ECDF excess ", + "%.3f). The prediction locations lie further from the samples than a ", + "fold can be made to hold out: read the CV score as an upper bound on ", + "performance there, or lower min_train."), + format(min_train), n_at_floor, n, stats::median(realised[fin]), + stats::median(g_target), excess_phi) + # Exclusion is not always needed. When prediction locations sit no further # from the training data than training points sit from each other, plain # LOO already reproduces the target distribution and nothing is removed -- @@ -3816,6 +4737,7 @@ make_folds <- function(points_sf, k, median_excluded = stats::median(n_excluded), n_removed_total = n_iter, max_ecdf_excess = max_excess, + n_at_min_train = n_at_floor, target_median = stats::median(g_target), realised_median = stats::median(realised[fin]), target_distances = g_target, @@ -3884,11 +4806,13 @@ make_folds <- function(points_sf, k, #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, #' estimate the autocorrelation range and use it as the minimum block size. #' Default \code{FALSE}. -#' @param parallel Logical or positive integer. If \code{TRUE}, -#' auto-detect the number of cores and fit folds in parallel via -#' \code{parallel::mclapply()} (macOS / Linux; falls back to sequential -#' on Windows). If an integer > 1, use that many cores. Default -#' \code{FALSE} (sequential). +#' @param parallel Accepted so that every \code{cv_*()} function takes the +#' same arguments, but the GWR folds always run one after another in this +#' R process. GWmodel is built with OpenMP, and OpenMP (GNU libgomp) +#' deadlocks \code{parallel::mclapply()}'s forked workers once a GWR has +#' been fitted in the session, for example by \code{fit_gwr_model()}, so +#' forking would hang the call. A value asking for more than one core +#' raises a warning saying so. Default \code{FALSE}. #' @param metrics Optional scoring function of your own, a #' \code{function(y, yhat)} returning a named numeric vector; its names #' become columns of \code{fold_metrics} (per fold) and \code{overall} @@ -3943,11 +4867,19 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, if (!requireNamespace("sp", quietly = TRUE)) stop("cv_gwr(): package 'sp' is required (for GWmodel interop).", call. = FALSE) + # match.arg() is the whole of kernel validation: it refuses a wrong case, + # NA or a vector, so a separate repair step after it could never run. kernel <- match.arg(kernel) - kernel <- .validate_kernel(kernel) + # An adaptive count fit_gwr_model() would refuse is refused once, here, + # instead of in every fold (which returned "all folds failed"). + if (!is.null(bandwidth) && isTRUE(adaptive)) + .check_scalar(bandwidth, "bandwidth", "cv_gwr", min = 1, + max = .Machine$integer.max, + what = "a single number of nearest neighbours when adaptive = TRUE") if (!("..row_id" %in% names(data_sf))) data_sf$`..row_id` <- seq_len(nrow(data_sf)) folds <- .folds_from_labels(folds, data_sf, "cv_gwr") + boundary <- .cv_boundary_crs(boundary, "cv_gwr") dat_sf <- prep_model_data(data_sf, response_var, predictor_vars, boundary, pointize) if (!("..row_id" %in% names(dat_sf))) stop("cv_gwr(): `prep_model_data()` must preserve `..row_id`.") @@ -3961,7 +4893,8 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, if (is.null(folds)) { message("cv_gwr(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", - seed = seed, boundary = boundary, + seed = seed, + boundary = .cv_boundary_crs(boundary, "cv_gwr", to = dat_sf), block_size = block_size, auto_range = auto_range, response_var = response_var, predictor_vars = predictor_vars) @@ -3996,6 +4929,28 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, # Passing p here would yield a per-fold Adj_R² that drastically overstates # parsimony. We set p = NULL so that per-fold Adj_R² is reported as NA, # consistent with the pooled metric and with cv_bayes(). + # + # GWR folds never fork. GWmodel is built with OpenMP, and GNU libgomp is + # not fork-safe: once any GWR has run in this session (fit_gwr_model(), a + # sequential cv_gwr(), select_gwr_variables(), a bare GWmodel::bw.gwr()) the + # parent holds an OpenMP thread pool that a forked child inherits without + # its threads, so the child's first parallel region waits on a futex for + # ever and parallel::mclapply() never returns. That was the ordinary + # fit-then-cross-validate order, and it hung with no timeout. Nothing + # visible from R says whether the pool exists, so the folds run here, one + # after another. A PSOCK cluster would avoid the fork, but its workers + # need this same spatialkit installed, which pkgload::load_all() or any + # development copy does not give them, and they cannot see what a + # `metrics` closure reads from the global environment. The other cv_*() + # keep mclapply(): ranger runs its own threads, not libgomp's. + if (.resolve_n_cores(parallel) > 1L) { + .warn_and_log(paste0( + "cv_gwr(): `parallel` is ignored and the %d folds run one after ", + "another. GWmodel runs OpenMP code, which deadlocks forked (mclapply) ", + "workers once a GWR has been fitted in the session."), + length(remapped_folds)) + parallel <- FALSE + } res <- .cv_run_folds( dat_sf = dat_sf, response_var = response_var, predictor_vars = predictor_vars, @@ -4017,12 +4972,13 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { 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) + .warn_and_log(paste0("cv_gwr(): all folds failed (all %d folds failed to ", + "produce predictions); cross-validation results ", + "contain no predictions.%s"), + n_attempted, why) + } else { + .cv_warn_failed_folds("cv_gwr", res, preds, length(keep_idx), + n_attempted, n_succeeded) } list(overall = .cv_overall_metrics(preds, metrics), fold_metrics = folds_df, @@ -4089,10 +5045,18 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' A user-supplied \code{gp_k} is respected in every fold; when omitted, the #' GP rank is auto-selected per training fold. \code{compute_loo}, #' \code{boundary}, and \code{pointize} are always overridden by the CV -#' internals. +#' internals. A categorical or ordinal \code{family} +#' (\code{brms::categorical()}, \code{cumulative}, \code{sratio}, +#' \code{cratio}, \code{acat}) is refused before anything is fitted: its +#' prediction is a probability per response category, and every score +#' here needs one number per row. #' @param summary "mean" or "median" for posterior predictions. #' @param compute_pred_intervals Logical; compute predictive intervals. -#' @param coverage_levels Numeric vector of coverage levels. +#' @param coverage_levels Numeric vector of the nominal coverage levels to +#' score, as proportions strictly between 0 and 1 (\code{0.95}, not +#' \code{95}), each given once; anything else is an error. Each becomes a +#' column \code{coverage_} of \code{fold_metrics}, named at full +#' precision (\code{0.975} gives \code{coverage_97.5}). #' @param block_size Optional minimum block edge length for spatial CV blocks #' (projected CRS units). #' @param auto_range Logical. If \code{TRUE} and \code{folds} is \code{NULL}, @@ -4103,7 +5067,12 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' \code{parallel::mclapply()} (macOS / Linux; falls back to sequential #' on Windows). If an integer > 1, use that many cores. Default #' \code{FALSE} (sequential). Bayesian folds with full MCMC runs -#' are the primary beneficiary of this option. +#' are the primary beneficiary of this option. Mind the memory: every +#' fold compiles its own Stan model, and one compilation can take several +#' GB (3.6 GB was measured), so \code{parallel = n} runs \code{n} of them +#' at once. A compiler killed for lack of memory fails its fold with +#' rstan's \code{"invalid connection"} error, which \code{fold_status} +#' records; use fewer cores if you see it. #' @param metrics Optional scoring function of your own, a #' \code{function(y, yhat)} returning a named numeric vector; its names #' become columns of \code{fold_metrics} (per fold) and \code{overall} @@ -4117,8 +5086,9 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' @return A list with \code{overall}, \code{fold_metrics}, #' \code{predictions}, \code{folds}, \code{n_folds_attempted}, #' \code{n_folds_succeeded}, \code{fold_status}, \code{orphan_rows}, -#' \code{n_unknown_ids}, \code{n_dropped}, \code{formula} and -#' \code{predictive_coverage}. +#' \code{n_unknown_ids}, \code{n_dropped}, \code{formula}, +#' \code{predictive_coverage} and \code{coverage_levels} (the nominal +#' levels, named by their \code{coverage_*} column). #' The two fold counts make a run where every fold failed visible in the #' return value itself, beyond the warning, and \code{fold_status} (one #' row per fold: \code{fold}, \code{status}, \code{message}) keeps the @@ -4132,6 +5102,14 @@ cv_gwr <- function(data_sf, response_var, predictor_vars, #' \code{compute_pred_intervals = FALSE} or the draws failed for that fold). #' \code{overall$Adj_R2} is always \code{NA}, as for every \code{cv_*()}: #' see \code{\link{cv_spatial}}. +#' \code{fold_metrics} carries, beyond the columns its siblings share, +#' \code{gp_k}, \code{gp_n_basis}, \code{n_draws}, \code{CRPS}, the +#' \code{coverage_*} columns and \code{convergence_ok}: \code{TRUE} or +#' \code{FALSE} as \code{\link{fit_bayesian_spatial_model}()} judged that +#' fold's sampler (R-hat, effective sample size, divergences), \code{NA} +#' when \code{fit_args} sets \code{check_convergence = FALSE}. A fold that +#' did not converge is scored like the others, so a run with any +#' \code{FALSE} raises one warning naming those folds. #' The \code{predictive_coverage} entries (one per #' \code{coverage_levels} value, plus \code{mean_CRPS}) are averages across #' folds \strong{weighted by each fold's \code{n_pred}}, because the per-fold @@ -4174,10 +5152,29 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, parallel = FALSE, metrics = NULL) { summary <- match.arg(summary) if (!inherits(data_sf, "sf")) stop("cv_bayes(): `data_sf` must be an sf object.") + # A categorical or ordinal family predicts a probability per response + # category, and every score here needs one number per row: predict(type = + # "epred") stops for these families, so each fold compiled and sampled a + # full model and was then discarded (k = 2 on 50 rows: 4.35 minutes for an + # empty result). Refused before anything is fitted, as + # fit_bayesian_spatial_model() refuses a factor under bernoulli(). + fam <- .brms_family_name(if (is.list(fit_args)) fit_args$family) + if (!is.na(fam) && fam %in% .brms_category_families) + stop(sprintf(paste0("cv_bayes(): the %s family gives a probability per ", + "response category, not one predicted number per row, ", + "and cross-validation here scores one number per row ", + "(RMSE, CRPS, interval coverage). Every fold would run ", + "its MCMC and then fail to be scored, so nothing is ", + "fitted. For a two-level outcome, code it as 0/1 and use ", + "brms::bernoulli()."), sQuote(fam)), call. = FALSE) metrics <- .check_metrics_fn(metrics, "cv_bayes") + # Named by column: the nominal level travels with the result from here on, + # instead of being read back from a column name. + cov_lv <- .check_coverage_levels(coverage_levels) if (!("..row_id" %in% names(data_sf))) data_sf$`..row_id` <- seq_len(nrow(data_sf)) folds <- .folds_from_labels(folds, data_sf, "cv_bayes") + boundary <- .cv_boundary_crs(boundary, "cv_bayes") dat_sf <- prep_model_data(data_sf, response_var, predictor_vars, boundary, pointize) if (!("..row_id" %in% names(dat_sf))) stop("cv_bayes(): `prep_model_data()` must preserve `..row_id`.") @@ -4192,7 +5189,8 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, if (is.null(folds)) { message("cv_bayes(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", - seed = seed, boundary = boundary, + seed = seed, + boundary = .cv_boundary_crs(boundary, "cv_bayes", to = dat_sf), block_size = block_size, auto_range = auto_range, response_var = response_var, predictor_vars = predictor_vars) @@ -4236,14 +5234,20 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, gp_k = as.integer(fit_obj$info$gp_k %||% NA_integer_), gp_n_basis = as.integer(fit_obj$info$gp_n_basis %||% NA_integer_), n_draws = NA_integer_, - CRPS = NA_real_ + CRPS = NA_real_, + # TRUE / FALSE as fit_bayesian_spatial_model() judged the fold's + # sampler (R-hat, ESS, divergences), NA when nothing was checked. A + # fold whose posterior did not converge scores like any other, so the + # table has to say which ones those are. + convergence_ok = { + v <- fit_obj$info$convergence_ok + if (is.logical(v) && length(v) == 1L) v else NA + } ) # Pre-initialise coverage columns so every fold emits the same schema # even when the posterior-draw step fails for some folds; heterogeneous # per-fold columns would otherwise break row-binding of fold_metrics. - for (cl in coverage_levels) { - extras[[sprintf("coverage_%.0f", cl * 100)]] <- NA_real_ - } + for (cn in names(cov_lv)) extras[[cn]] <- NA_real_ # Full posterior predictive draws for intervals + CRPS if (isTRUE(compute_pred_intervals)) { @@ -4251,6 +5255,10 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, predict(fit_obj, newdata = test_sf, type = "predict", draws = TRUE), silent = TRUE ) + if (inherits(ppred_draws, "try-error")) + .log_warn(paste0("cv_bayes(): the posterior predictive draws failed on a ", + "fold (%s); its coverage and CRPS are NA."), + .try_error_message(ppred_draws)) if (!inherits(ppred_draws, "try-error") && is.matrix(ppred_draws)) { extras$n_draws <- nrow(ppred_draws) # Per-row posterior predictive SD, for $predictions$yhat_sd. The @@ -4261,19 +5269,28 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, yhat_sd = apply(ppred_draws, 2L, stats::sd), stringsAsFactors = FALSE) - # Coverage at each level - for (cl in coverage_levels) { - alpha <- (1 - cl) / 2 - lwr <- apply(ppred_draws, 2L, stats::quantile, probs = alpha) - upr <- apply(ppred_draws, 2L, stats::quantile, probs = 1 - alpha) - in_interval <- y_true >= lwr & y_true <= upr - extras[[sprintf("coverage_%.0f", cl * 100)]] <- mean(in_interval, na.rm = TRUE) + # Coverage at each level, and the empirical CRPS via the NRG (energy) + # form (see .crps_energy()). In a try of their own, so that one + # failure here -- quantile() refuses a draw matrix holding an NA -- + # costs these columns and not gp_k, n_draws and yhat_sd with them. + scores <- try({ + cov <- vapply(cov_lv, function(cl) { + alpha <- (1 - cl) / 2 + lwr <- apply(ppred_draws, 2L, stats::quantile, probs = alpha) + upr <- apply(ppred_draws, 2L, stats::quantile, probs = 1 - alpha) + mean(y_true >= lwr & y_true <= upr, na.rm = TRUE) + }, numeric(1)) + list(cov = cov, + crps = mean(.crps_energy(ppred_draws, y_true), na.rm = TRUE)) + }, silent = TRUE) + if (inherits(scores, "try-error")) { + .log_warn(paste0("cv_bayes(): coverage and CRPS could not be computed ", + "from a fold's draws (%s); they are NA there."), + .try_error_message(scores)) + } else { + for (cn in names(cov_lv)) extras[[cn]] <- scores$cov[[cn]] + extras$CRPS <- scores$crps } - - # Empirical CRPS via the NRG (energy) form, vectorised over - # observations — see .crps_energy() for the formula and reference. - crps_per_obs <- .crps_energy(ppred_draws, y_true) - extras$CRPS <- mean(crps_per_obs, na.rm = TRUE) } } @@ -4310,7 +5327,8 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, SMAPE = numeric(), R2 = numeric(), Adj_R2 = numeric(), n_MAPE = integer(), n_SMAPE = integer(), CRPS = numeric(), gp_k = integer(), - gp_n_basis = integer(), n_draws = integer()) + gp_n_basis = integer(), n_draws = integer(), + convergence_ok = logical()) if (!nrow(folds_df)) for (cn in .user_metric_names(metrics)) folds_df[[cn]] <- numeric() @@ -4321,12 +5339,33 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { 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) + .warn_and_log(paste0("cv_bayes(): all folds failed (all %d folds failed to ", + "produce predictions); cross-validation results ", + "contain no predictions.%s"), + n_attempted, why) + } else { + .cv_warn_failed_folds("cv_bayes", res, preds, length(keep_idx), + n_attempted, n_succeeded) + } + + # The convergence checks log each fold's R-hat, ESS and divergences, but a + # log line is invisible under knitr, spatialkit_quiet() and tryCatch(), and + # a fold whose sampler did not converge is scored like any other: its RMSE, + # CRPS and coverage enter `overall` with nothing in the result to say so. + # One R warning per run names those folds; fold_metrics$convergence_ok + # marks them. + if (nrow(folds_df) && "convergence_ok" %in% names(folds_df)) { + bad <- which(folds_df$convergence_ok %in% FALSE) + if (length(bad)) + .warn_and_log(paste0("cv_bayes(): the sampler did not converge in %d of %d ", + "fold(s) (fold %s); their scores enter `overall` like ", + "the others but come from unreliable posteriors. ", + "fold_metrics$convergence_ok marks them and the log ", + "gives each fold's R-hat, ESS and divergences; raise ", + "`iter` (or `control = list(adapt_delta = ...)`) in ", + "`fit_args`."), + length(bad), nrow(folds_df), + paste(folds_df$fold[bad], collapse = ", ")) } list(overall = .cv_overall_metrics(preds, metrics), fold_metrics = folds_df, @@ -4355,10 +5394,49 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, if (!any(ok)) return(NA_real_) sum(v[ok] * w_all[ok]) / sum(w_all[ok]) } - cov_cols <- grep("^coverage_", names(folds_df), value = TRUE) + cov_cols <- intersect(names(cov_lv), names(folds_df)) cov_means <- vapply(cov_cols, function(cn) wm(folds_df[[cn]]), numeric(1)) c(as.list(cov_means), mean_CRPS = wm(folds_df$CRPS)) - } else NULL) + } else NULL, + # The nominal level behind each coverage column, named by column. The + # names used to be the only record, rounded to a whole percent: 0.995 + # was drawn at 1.00 by plot_calibration(), and 0.975 and 0.985 were + # both "coverage_98", one overwriting the other. + coverage_levels = cov_lv) +} + + +#' Validate cv_bayes()'s coverage_levels and name their columns +#' +#' Every level must lie strictly between 0 and 1. The column is named from +#' the level in percent at full precision (\code{coverage_95}, +#' \code{coverage_97.5}), so no two distinct levels share a column; a level +#' given twice is an error. +#' +#' @param x The \code{coverage_levels} argument. +#' @return A numeric vector of the levels, named by column. +#' @keywords internal +#' @noRd +.check_coverage_levels <- function(x) { + if (is.null(x) || (is.numeric(x) && !length(x))) + return(stats::setNames(numeric(0), character(0))) + if (!is.numeric(x) || any(!is.finite(x)) || any(x <= 0 | x >= 1)) { + hint <- if (is.numeric(x) && all(is.finite(x)) && all(x > 1 & x < 100)) + sprintf(" For percentages, divide by 100: c(%s).", + paste(as.character(x / 100), collapse = ", ")) else "" + stop(sprintf(paste0("cv_bayes(): `coverage_levels` must be numbers strictly ", + "between 0 and 1 (0.95 for a 95%% interval); got %s.%s"), + paste(as.character(x), collapse = ", "), hint), + call. = FALSE) + } + cols <- paste0("coverage_", vapply(as.numeric(x), function(cl) + format(round(cl * 100, 6), scientific = FALSE, trim = TRUE, digits = 15), + character(1))) + if (anyDuplicated(cols)) + stop(sprintf("cv_bayes(): `coverage_levels` gives the level %s more than once.", + paste(unique(as.character(x[duplicated(cols)])), + collapse = ", ")), call. = FALSE) + stats::setNames(as.numeric(x), cols) } @@ -4414,13 +5492,22 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' @param pointize Geometry coercion strategy. #' @param predict_args Extra arguments for predict(). #' @param fold_info_fn Optional \code{function(fit, test_sf, y, yhat)} -#' returning a named list of per-fold extras (a bandwidth, a tuning value, -#' anything read off the fitted object), added as columns of -#' \code{fold_metrics}. It sees the fit and the held-out layer, which +#' returning a named list (or a named vector) of per-fold extras (a +#' bandwidth, a tuning value, anything read off the fitted object), added +#' as columns of \code{fold_metrics}. It sees the fit and the held-out +#' layer, which #' \code{metrics} does not; it is applied per fold only, and its values #' are not pooled. An element \code{..per_row} that is a data frame with #' one row per held-out observation is spliced into \code{predictions} -#' instead. +#' instead (\code{NA} in the rows of a fold that returned none; one of the +#' wrong length is dropped and logged); its columns must be named, once, +#' and not reuse a column \code{predictions} already has (\code{..row_id}, +#' \code{fold}, \code{y}, \code{yhat}, \code{y_train_mean}). Every +#' other element must be named, hold one value, and not reuse a column +#' \code{fold_metrics} already has; +#' anything else is an error. A \code{fold_info_fn} that throws on a fold +#' is logged, its columns are \code{NA} for that fold, and +#' \code{fold_status$message} says so; the fold is kept. #' @param p Number of predictors for Adj R² (NULL to skip). Only meaningful #' for models with a fixed global parameter count; pass NULL for models #' with spatially varying coefficients (e.g. GWR). @@ -4433,7 +5520,10 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' auto-detect the number of cores and fit folds in parallel via #' \code{parallel::mclapply()} (macOS / Linux; falls back to sequential #' on Windows). If an integer > 1, use that many cores. Default -#' \code{FALSE} (sequential). +#' \code{FALSE} (sequential). A learner that runs OpenMP code (GWmodel, +#' or an xgboost built with GNU libgomp) can hang the forked workers once +#' it has run in the session; keep such a \code{fit_fn} sequential, as +#' \code{\link{cv_gwr}()} does. #' @param metrics Optional scoring function of your own; see \strong{Your #' own metrics} below. Default \code{NULL}: the built-in metrics only. #' @param .caller Internal. The name the messages carry, so a wrapper such as @@ -4455,7 +5545,12 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' \code{RMSE}, and \code{n_pred} counts them. #' #' The contract: every element named, names unique and not one of the -#' built-in column names, one number per name. Anything else is an error, +#' built-in column names, one number per name. The built-in names include +#' the per-fold extras of the backend or of your \code{fold_info_fn} +#' (\code{bandwidth} for \code{cv_gwr()}; \code{CRPS}, \code{coverage_*}, +#' \code{gp_k}, \code{gp_n_basis} and \code{n_draws} for \code{cv_bayes()}), +#' and \code{mean_CRPS}, which \code{compare_models_cv()} writes. Anything +#' else is an error, #' because a scoring function that returns the wrong shape is a mistake to #' surface instead of a fold to skip. A function that \emph{throws} on a #' fold is logged and its columns are \code{NA} for that fold (and for @@ -4480,15 +5575,26 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' run that happened to score \code{NA}, so compare them before trusting #' \code{overall}. \code{fold_status} is a data.frame with one row per #' fold supplied (\code{fold}, \code{status} and \code{message}), where -#' \code{status} is \code{"ok"}; \code{"error"} (the fit or its +#' \code{status} is \code{"ok"} (\code{message} is empty unless +#' \code{fold_info_fn} failed on the fold); \code{"error"} (the fit or its #' \code{predict()} threw; \code{message} is the error text); #' \code{"skipped"} (nothing scorable: too few matched rows, a prediction #' of the wrong length, or no finite observed/predicted pair); #' \code{"dropped"} (an empty test set, or fewer than two training rows, #' once incomplete rows were removed, so the fold never reached the fitter); -#' or \code{"worker_error"} (a parallel worker died). Every fold missing +#' or \code{"worker_error"} (a parallel worker died, for example killed for +#' lack of memory). Each fold runs in its own worker, so a failure costs +#' that fold only, and an error that stops a sequential run (a +#' \code{metrics} or \code{fold_info_fn} return value of the wrong shape) +#' stops a parallel one too, naming the fold. Every fold missing #' from \code{fold_metrics} has its reason there, which matters most when -#' the console output of a long run is gone. \code{orphan_rows} holds the +#' the console output of a long run is gone. When some folds, but not +#' all, end as \code{"error"}, \code{"skipped"} or \code{"worker_error"}, +#' the function warns, naming them and how many rows \code{overall} +#' covers: it is pooled over the folds that produced predictions, and the +#' fold that fails is often the hardest to predict, so it may flatter the +#' model. (A \code{"dropped"} fold has its own warning.) +#' \code{orphan_rows} holds the #' \code{..row_id}s of rows in the data that no fold names (they enter no #' training set and are never scored; non-empty only when the folds were #' built on a different or subsetted layer), and \code{n_unknown_ids} @@ -4502,7 +5608,19 @@ cv_bayes <- function(data_sf, response_var, predictor_vars, #' \code{fold_metrics}, \code{predictions} and \code{fold_status} carries #' the fold's index in the \code{folds} object that was supplied, so it #' lines up with \code{make_folds()$assignment$fold} even when some folds -#' were unusable and dropped. \code{overall$Adj_R2} is always \code{NA}: the +#' were unusable and dropped. Splits that already carry a \code{fold_id}, +#' as the \code{folds} of a \code{cv_*()} result do, keep it: handing +#' one run's \code{folds} to another labels each fold as the first run +#' and \code{\link{fold_separation}()} do, a dropped fold's gap +#' included. \code{R2} is out-of-sample \eqn{R^2}: the +#' total sum of squares is taken about the mean of the \emph{training} rows +#' (in \code{overall}, each held-out row about its own fold's training +#' mean), the null prediction available when the fold is predicted, and +#' not about the held-out rows' own mean, a null model that would know the +#' test data. On spatial blocks the two can differ widely; \code{R2} is +#' below 0 when the model predicts worse than the training mean. +#' \code{\link{model_metrics}(newdata = )} uses the same baseline. +#' \code{overall$Adj_R2} is always \code{NA}: the #' pooled out-of-sample predictions come from \code{k} separately fitted #' models and have no single parameter count to adjust for. The per-fold #' \code{fold_metrics$Adj_R2} carries the adjusted value when \code{p} is @@ -4571,6 +5689,7 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, if (!("..row_id" %in% names(data_sf))) data_sf$`..row_id` <- seq_len(nrow(data_sf)) folds <- .folds_from_labels(folds, data_sf, .caller) + boundary <- .cv_boundary_crs(boundary, .caller) dat_sf <- prep_model_data(data_sf, response_var, predictor_vars, boundary, pointize) keep_idx <- dat_sf$`..row_id` @@ -4581,7 +5700,8 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, if (is.null(folds)) { message(.caller, "(): no folds supplied -- using spatial block k-fold CV (k=", k, ").") folds <- make_folds(dat_sf, k = k, method = "block_kfold", - seed = seed, boundary = boundary, + seed = seed, + boundary = .cv_boundary_crs(boundary, .caller, to = dat_sf), block_size = block_size, auto_range = auto_range, response_var = response_var, predictor_vars = predictor_vars) @@ -4601,7 +5721,12 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, parallel = parallel, seed = seed, metrics = metrics ) - preds <- if (length(res$pred_rows)) do.call(rbind, res$pred_rows) else + # bind_rows(), as for fold_stats below: a fold whose fold_info_fn returned + # no `..per_row` (conditionally, with the wrong row count, or because it + # threw) has fewer columns, and rbind() died on that with "numbers of + # columns of arguments do not match" after every fold had been fitted. + # The missing cells are NA. + preds <- if (length(res$pred_rows)) as.data.frame(dplyr::bind_rows(res$pred_rows)) else data.frame(`..row_id` = integer(), fold = integer(), y = numeric(), yhat = numeric(), y_train_mean = numeric()) # Typed even when empty: cv_gwr() and cv_bayes() return a 0-row frame with @@ -4621,13 +5746,13 @@ cv_spatial <- function(data_sf, response_var, predictor_vars, n_succeeded <- length(res$fold_stats) if (n_succeeded == 0L && n_attempted > 0L) { why <- .cv_first_error_suffix(res) - .log_warn("%s(): all %d folds failed to produce predictions; results are empty.%s", - .caller, n_attempted, why) - warning(.caller, "(): all folds failed; cross-validation results contain ", - "no predictions.", why, call. = FALSE) - } else if (n_succeeded < n_attempted) { - .log_warn("%s(): %d of %d folds produced predictions.", - .caller, n_succeeded, n_attempted) + .warn_and_log(paste0("%s(): all folds failed (all %d folds failed to ", + "produce predictions); cross-validation results ", + "contain no predictions.%s"), + .caller, n_attempted, why) + } else { + .cv_warn_failed_folds(.caller, res, preds, length(keep_idx), + n_attempted, n_succeeded) } list(overall = .cv_overall_metrics(preds, metrics), diff --git a/R/crs-geometry.R b/R/crs-geometry.R index 14c4824..6ca9761 100644 --- a/R/crs-geometry.R +++ b/R/crs-geometry.R @@ -2,6 +2,77 @@ # CRS Selection # ----------------------------------------------------------------------------- +#' Evaluate an expression with sf's spherical engine (s2) switched on +#' +#' On lon/lat data sf hands st_area(), st_centroid(), st_union() and +#' st_sample() to s2 when \code{sf::sf_use_s2()} is TRUE. With it FALSE, +#' areas and sampling need lwgeom, which this package does not depend on +#' ("package lwgeom required" from every Voronoi tessellation, even a +#' projected one, because the stable-ID sort key is measured in lon/lat), and +#' centroids and unions become planar arithmetic on degrees, which moves the +#' centre that picks a UTM zone and prints sf's warnings past \code{quiet}. +#' The package's own measurements on the sphere therefore run with s2 on +#' whatever the session says, and the session's setting is restored on the +#' way out, error or not. Nothing is toggled when s2 is already on. +#' +#' @param expr Expression to evaluate. +#' @return The value of \code{expr}. +#' @keywords internal +#' @noRd +.with_s2 <- function(expr) { + if (isTRUE(sf::sf_use_s2())) return(expr) + suppressMessages(sf::sf_use_s2(TRUE)) + on.exit(suppressMessages(sf::sf_use_s2(FALSE)), add = TRUE) + expr +} + + +#' Centre of a lon/lat layer on the sphere +#' +#' The centroid s2 gives for the union of the layer, which is what +#' \code{.pick_local_projected_crs()} has always used with s2 on (the +#' default). Three things went wrong when it was taken with a bare +#' \code{st_centroid(st_union())}: with \code{sf_use_s2(FALSE)} the centre +#' was planar in degrees, so the UTM zone chosen for data near a zone edge +#' depended on a session option; sf's warning and message about that got past +#' \code{quiet}; and with s2 on, a polygon GEOS accepts but s2 rejects (a +#' repeated vertex, common in real shapefiles) stopped +#' \code{ensure_projected()} with "Edge 1 is degenerate" although a plain +#' \code{st_transform()} of it works. Now s2 is always used; a geometry it +#' rejects is repaired and tried again; and if that fails too, the centre is +#' the normalised mean of the vertices' unit vectors (for a point layer +#' exactly what s2 returns), which needs no valid geometry at all. +#' +#' @param x_ll An sf/sfc object in a geographic CRS. +#' @return A 1 x 2 matrix (\code{X}, \code{Y}) in degrees, possibly +#' non-finite when no centre exists (the caller falls back then). +#' @keywords internal +#' @noRd +.lonlat_centre <- function(x_ll) { + g <- sf::st_geometry(x_ll) + centre_of <- function(geom) { + ctr <- sf::st_coordinates(sf::st_centroid(sf::st_union(geom))) + if (!is.numeric(ctr) || length(ctr) < 2L) stop("no centroid") + ctr[1L, 1:2, drop = FALSE] + } + ctr <- tryCatch(.with_s2(centre_of(g)), error = function(e) NULL) + if (is.null(ctr)) + ctr <- tryCatch(.with_s2(centre_of(.safe_make_valid(g))), error = function(e) NULL) + if (is.null(ctr)) { + xy <- tryCatch(sf::st_coordinates(g)[, 1:2, drop = FALSE], + error = function(e) matrix(numeric(0), 0L, 2L)) + xy <- xy[is.finite(xy[, 1L]) & is.finite(xy[, 2L]), , drop = FALSE] + lam <- xy[, 1L] * pi / 180; phi <- xy[, 2L] * pi / 180 + v <- c(sum(cos(phi) * cos(lam)), sum(cos(phi) * sin(lam)), sum(sin(phi))) + ctr <- matrix(if (nrow(xy) && sqrt(sum(v^2)) > 1e-12) + c(atan2(v[2L], v[1L]), atan2(v[3L], sqrt(v[1L]^2 + v[2L]^2))) * 180 / pi + else c(NA_real_, NA_real_), + 1L, 2L, dimnames = list(NULL, c("X", "Y"))) + } + ctr +} + + #' Pick a sensible local projected CRS for an sf/sfc object #' #' Chooses an appropriate projected coordinate reference system for spatial @@ -24,8 +95,15 @@ #' #' Data straddling the antimeridian are detected from the one very large gap in #' the sorted longitudes and given an equal-area projection centred on the true -#' extent; only truly global coverage falls back to Web Mercator -#' (EPSG:3857), which would otherwise SPLIT a wrapped layer. +#' extent, since Web Mercator (EPSG:3857) would SPLIT a wrapped layer. Data +#' that span more than 180 degrees of longitude with no such gap surround a +#' pole; when every point also lies on one side of the equator, the layer +#' circles that pole (Antarctic stations, a pan-Arctic network) and gets a +#' Lambert azimuthal equal-area centred on it, provided that measures a +#' smaller distance error than the global fallback. Only coverage that is +#' left -- spanning both hemispheres, or a low-latitude belt the polar +#' projection fits worse -- falls back to Web Mercator (Equal Earth for +#' \code{purpose = "area"}). #' #' @param x An sf or sfc object. #' @return A list with \code{crs} (the chosen \code{sf::crs}) and @@ -35,9 +113,11 @@ #' over sampled pairs, \code{NA} where it could not be measured) and #' \code{chosen}. Where only one projection was in play (a zone kept on #' a local extent, the equal-area projection for a wrapped layer), that -#' one is measured and reported alone. \code{candidates} is \code{NULL} -#' only where no local projection was chosen: non-geographic input, no -#' finite centroid, or an extent that falls back to the global projection. +#' one is measured and reported alone; a layer circling a pole reports the +#' polar projection and the global one it was measured against. +#' \code{candidates} is \code{NULL} only where no local projection was +#' chosen: non-geographic input, no finite centroid, or an extent that +#' falls back to the global projection. #' @keywords internal #' @noRd .pick_local_projected_crs <- function(x, purpose = c("distance", "area")) { @@ -80,7 +160,9 @@ if (is.na(sf::st_crs(x_ll)) || !.is_longlat(x_ll)) return(list(crs = global_crs(), candidates = NULL)) - ctr <- sf::st_coordinates(sf::st_centroid(sf::st_union(sf::st_geometry(x_ll)))) + # On the sphere whatever sf_use_s2() says, and without failing on a polygon + # s2 rejects: see .lonlat_centre(). + ctr <- .lonlat_centre(x_ll) if (!is.numeric(ctr) || length(ctr) < 2) return(list(crs = global_crs(), candidates = NULL)) lon <- ctr[1]; lat <- ctr[2] @@ -171,6 +253,50 @@ list(wrap_crs), .crs_distance_error(x_ll, wrap_crs), 1L)) } + # No gap of 180 deg or more means the longitudes surround a pole. With + # every point on one side of the equator the layer circles THAT pole -- + # Antarctic stations, a pan-Arctic network -- and is not global coverage. + # Web Mercator splits such a layer at +/-180 and stretches it towards the + # pole: rings of Antarctic stations measured worst-case distance errors + # of 15,000-20,000% in it (a 111 km pair came out 445 km, the South Pole + # at y = -2.4e8 m), where a Lambert azimuthal centred on the pole gave + # about 2%. That projection is equal-area, so it serves purpose = "area" + # too. Its distortion grows away from the pole (about 40% for a belt + # reaching the equator), so it is measured against the global fallback + # and used only when it does better; data spanning both hemispheres never + # get here and keep the global fallback as before. + lat_min <- as.numeric(bb["ymin"]); lat_max <- as.numeric(bb["ymax"]) + if (is.finite(lat_min) && is.finite(lat_max) && (lat_min >= 0 || lat_max <= 0)) { + north <- lat_min >= 0 + polar_crs <- sf::st_crs(sprintf( + "+proj=laea +lat_0=%d +lon_0=0 +datum=WGS84 +units=m +no_defs", + if (north) 90L else -90L)) + glob <- global_crs() + glob_name <- if (purpose != "area") "Web Mercator (EPSG:3857)" else + if (grepl("eqearth", glob$input, fixed = TRUE)) "Equal Earth" else "Mollweide" + cands <- list( + list(name = sprintf("Lambert azimuthal equal-area centred on the %s Pole", + if (north) "North" else "South"), + crs = polar_crs), + list(name = glob_name, crs = glob)) + err <- vapply(cands, function(cd) .crs_distance_error(x_ll, cd$crs), numeric(1)) + if (is.finite(err[1L]) && (!is.finite(err[2L]) || err[1L] < err[2L])) { + .log_warn( + paste0(".pick_local_projected_crs(): longitude extent spans %.1f deg ", + "without straddling the antimeridian, and every point lies %s ", + "of the equator (latitude %.1f to %.1f): the layer circles the ", + "%s Pole. Using %s: measured worst-case distance error %.2f%% ", + "against %s for %s. Pass target_crs to ensure_projected() to ", + "override."), + span_lon, if (north) "north" else "south", lat_min, lat_max, + if (north) "North" else "South", cands[[1L]]$name, 100 * err[1L], + if (is.finite(err[2L])) sprintf("%.2f%%", 100 * err[2L]) else "not measurable", + cands[[2L]]$name) + return(scored(polar_crs, vapply(cands, `[[`, character(1), "name"), + lapply(cands, `[[`, "crs"), err, 1L)) + } + } + .log_warn( paste0(".pick_local_projected_crs(): longitude extent spans %.1f deg and ", "the coordinates do not straddle the antimeridian, so this is ", @@ -342,6 +468,9 @@ #' @param x_ll An sf/sfc object in a geographic CRS. Non-POINT geometry is #' reduced to representative points first, so the two distance vectors are #' the same length (\code{st_coordinates()} yields one row per vertex). +#' With fewer than \code{max_n} features the outline's vertices, densified +#' along its edges, are added to those points, so that a single study-area +#' polygon is measured across its extent rather than not at all. #' @param crs Candidate \code{sf::crs}. #' @param max_n Maximum number of points to sample. Default 40 (780 pairs). #' @return Numeric worst-case \code{|d_planar / d_geodesic - 1|}, or \code{NA} @@ -358,9 +487,84 @@ # comparison recycled, R raised "longer object length is not a multiple of # shorter object length" at the caller, every candidate scored NA, and the # selection silently fell back to the UTM zone while the log line reported - # "NA% vs NA%". Every county-polygon layer took that path. - if (!all(sf::st_geometry_type(g, by_geometry = TRUE) == "POINT")) - g <- suppressWarnings(sf::st_point_on_surface(g)) + # "NA% vs NA%". Every county-polygon layer took that path. The empty + # parts go first: one inside a line feature segfaults GEOS here (see + # .drop_empty_parts()), and tryCatch() cannot catch a crash, so any + # lon/lat line layer with a null part took ensure_projected() down. + if (!all(sf::st_geometry_type(g, by_geometry = TRUE) == "POINT")) { + g_full <- .drop_empty_parts(g) + g <- suppressWarnings(sf::st_point_on_surface(g_full)) + # GEOS reads a feature that crosses +-180 the long way round, so its + # interior point landed on the far side of the globe ((-0.5, -17) for a + # box around Fiji) and the error reported for a projection accurate to + # 0.02% on the box was 25%. Such a feature spans more than 180 degrees + # of raw longitude; take its spherical centroid instead. + bb_all <- sf::st_bbox(g_full) + if (isTRUE(sf::st_is_longlat(g_full)) && all(is.finite(bb_all)) && + bb_all[["xmax"]] - bb_all[["xmin"]] > 180) { + wide <- vapply(g_full, function(s) { + b <- sf::st_bbox(s) + isTRUE(b[["xmax"]] - b[["xmin"]] > 180) + }, logical(1)) + ctr <- if (any(wide)) + tryCatch(.with_s2(sf::st_centroid(g_full[wide])), error = function(e) NULL) + if (!is.null(ctr)) g[wide] <- ctr + } + # One point per feature is nothing to measure on a study-area outline: + # a single polygon gave one point, every candidate scored NA, and the + # selector kept the UTM zone at any extent -- a CONUS outline got zone + # 15 (13.7% worst-case error) where its vertices score Albers at 2.4%, + # and prep_model_data(boundary =) moved a whole analysis into it. A + # handful of features gives a handful of pairs, none near the edges + # where a zone distorts most. So below `max_n` points, add the + # outline's own vertices, densified along each edge until there are + # about `max_n` of them (a box has only its four corners). Layers with + # `max_n` features or more are measured as before, and so is a + # GEOMETRYCOLLECTION layer, whose vertices st_coordinates() refuses. + xy <- if (length(g) < max_n) + tryCatch(sf::st_coordinates(g_full), error = function(e) NULL) + # Only about `max_n` of these points are measured (the evenly spaced + # subsample below), so thin a detailed outline to a few times that + # first, by evenly spaced index. unique() on the whole vertex matrix, + # twice, and a ring key pasted for every vertex made the score cost + # 2.8 s per candidate on a 300,000-vertex outline (0.04 s before the + # outline was scored), and ensure_projected() 14 s. Such an outline has + # far more than `max_n` vertices, so it is not densified either way. + if (!is.null(xy) && nrow(xy) > 4L * max_n) + xy <- xy[unique(round(seq(1, nrow(xy), length.out = 4L * max_n))), , drop = FALSE] + if (!is.null(xy)) { + ring <- if (ncol(xy) > 2L) + do.call(paste, as.data.frame(xy[, -(1:2), drop = FALSE])) else rep("1", nrow(xy)) + xy <- xy[, 1:2, drop = FALSE] + ok <- is.finite(xy[, 1L]) & is.finite(xy[, 2L]) + xy <- xy[ok, , drop = FALSE]; ring <- ring[ok] + if (nrow(xy) > 0L) { + per_edge <- max(0L, ceiling(max_n / max(1L, nrow(unique(xy)))) - 1L) + if (per_edge > 0L && nrow(xy) > 1L) { + same <- ring[-1L] == ring[-length(ring)] + a <- xy[-nrow(xy), , drop = FALSE][same, , drop = FALSE] + b <- xy[-1L, , drop = FALSE][same, , drop = FALSE] + f <- rep(seq_len(per_edge) / (per_edge + 1), each = nrow(a)) + a <- a[rep(seq_len(nrow(a)), per_edge), , drop = FALSE] + b <- b[rep(seq_len(nrow(b)), per_edge), , drop = FALSE] + # Along the edge as it runs on the globe, the short way round. + # Interpolated in raw degrees, the edge of an outline from 177 to + # -178 was filled with points near longitude 0, and a box around + # Fiji reported a 164% distance error for a projection accurate to + # 0.02% on it. + dl <- b[, 1L] - a[, 1L] + dl <- ((dl + 180) %% 360) - 180 + lon <- ((a[, 1L] + f * dl + 180) %% 360) - 180 + lat <- a[, 2L] + f * (b[, 2L] - a[, 2L]) + xy <- rbind(xy, cbind(lon, lat)) + } + xy <- unique(xy) + g <- c(sf::st_geometry(g), sf::st_geometry(sf::st_as_sf( + data.frame(x = xy[, 1L], y = xy[, 2L]), coords = c("x", "y"), + crs = sf::st_crs(g)))) + } + } + } n <- length(g) if (n < 2L) return(NA_real_) if (n > max_n) g <- g[unique(round(seq(1, n, length.out = max_n)))] @@ -398,12 +602,15 @@ #' @param crs The projection to score; default the CRS of \code{x}. #' @param n Probe grid size when \code{x} has no polygons. #' @param max_n Largest number of the layer's own polygons to measure. +#' @param grid Logical; probe with the \code{n x n} grid over the bounding box +#' even when \code{x} has polygons. A single study-area polygon is one +#' probe, and one ratio has no spread to measure. #' @return Numeric worst-case \code{|ratio / median(ratio) - 1|}, or #' \code{NA} when it cannot be computed (no CRS, no area, geodesic areas #' unavailable). #' @keywords internal #' @noRd -.crs_area_error <- function(x, crs = NULL, n = 6L, max_n = 200L) { +.crs_area_error <- function(x, crs = NULL, n = 6L, max_n = 200L, grid = FALSE) { tryCatch({ if (is.null(crs)) crs <- sf::st_crs(x) if (is.na(crs) || is.na(sf::st_crs(x))) return(NA_real_) @@ -411,15 +618,29 @@ g <- g[!sf::st_is_empty(g)] if (!length(g)) return(NA_real_) types <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) - probe <- if (all(types %in% c("POLYGON", "MULTIPOLYGON"))) { + probe <- if (!isTRUE(grid) && all(types %in% c("POLYGON", "MULTIPOLYGON"))) { if (length(g) > max_n) g[unique(round(seq(1, length(g), length.out = max_n)))] else g } else { bb <- sf::st_bbox(sf::st_transform(g, crs)) sf::st_make_grid(sf::st_as_sfc(bb), n = c(n, n), what = "polygons") } probe <- sf::st_transform(probe, crs) + # Densify before going to lon/lat: s2 reads each edge as a great circle, + # and over a continental probe that is not the straight edge the planar + # area was measured on -- an Equal Earth grid over a near-global extent + # measured 10% "distortion". A projected CRS only; densifying lon/lat + # needs lwgeom. + if (!isTRUE(sf::st_is_longlat(crs))) { + pb <- sf::st_bbox(probe) + ext <- max(as.numeric(pb["xmax"] - pb["xmin"]), as.numeric(pb["ymax"] - pb["ymin"])) + if (is.finite(ext) && ext > 0) probe <- sf::st_segmentize(probe, dfMaxLength = ext / 100) + } planar <- as.numeric(sf::st_area(probe)) - geod <- as.numeric(sf::st_area(sf::st_transform(probe, 4326))) + # Geodesic areas on the sphere whatever sf_use_s2() says: with it off, sf + # asks lwgeom for them, which is not a dependency, the error became NA + # here, and summarize_by_cell(area = TRUE) then refused every grid while + # ensure_projected(purpose = "area") skipped its distortion check. + geod <- .with_s2(as.numeric(sf::st_area(sf::st_transform(probe, 4326)))) ratio <- planar / geod ok <- is.finite(ratio) & is.finite(geod) & geod > 0 if (sum(ok) < 2L) return(NA_real_) @@ -596,7 +817,9 @@ #' \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.} +#' this package is usually in. The centre is the centroid on the sphere, +#' computed with s2 whatever [sf::sf_use_s2()] is set to, so data near a +#' zone edge get the same zone in every session.} #' \item{Wide extents}{Once the data reach well beyond the roughly 3 degrees #' a UTM zone is designed for, a single zone can distort distances by #' several percent, and that error propagates straight into variogram @@ -605,16 +828,28 @@ #' a Lambert azimuthal equal-area centred on the data and (where its #' standard parallels do not degenerate) an Albers conic are each scored by #' projecting representative points of the data (a non-POINT layer is -#' reduced to points first) and comparing planar with geodesic pairwise -#' distances, and the one that distorts least is used. +#' reduced to one point per feature, plus the vertices of its outline when +#' it has fewer than 40 features, so a single study-area polygon is scored +#' too) and comparing planar with geodesic pairwise distances, and the one +#' that distorts least is used. #' The choice, both error figures and this argument are **logged** (see the #' logging note under [spatialkit_quiet()]); they are not R warnings, so #' `tryCatch(warning = )` does not see them.} #' \item{Antimeridian}{Data straddling ±180° have a bounding box wider than a #' hemisphere. The wrap is detected from the coordinates (one very large #' gap in the sorted longitudes) and an equal-area projection centred on -#' the true extent is used. Only truly global coverage falls back to -#' EPSG:3857.} +#' the true extent is used.} +#' \item{Around a pole}{Data spanning more than 180 degrees of longitude +#' with no such gap surround a pole. When every point also lies on one +#' side of the equator (Antarctic stations, a pan-Arctic network), a +#' Lambert azimuthal equal-area centred on that pole is used, provided it +#' measures a smaller distance error than the global fallback. Web +#' Mercator splits such a layer at +/-180 degrees and stretches it +#' towards the pole: a ring of Antarctic stations measured a worst-case +#' distance error near 20,000 percent in it, against about 2 percent in +#' the polar projection. Only the coverage left over, spanning both +#' hemispheres or a low-latitude belt the polar projection fits worse, +#' falls back to EPSG:3857 (Equal Earth for `purpose = "area"`).} #' \item{Missing CRS}{With no `target_crs`, a bounding box that looks like #' lon/lat means EPSG:4326 is assumed (a real warning) and the rules above #' then apply; coordinates the heuristic declines are left exactly as they @@ -835,7 +1070,8 @@ ensure_projected <- function(x, target_crs = NULL, purpose = c("distance", "area #' #' @param a,b Objects of class sf or sfc. #' @param prefer Which object's CRS to keep ("a" or "b"). -#' @param target_crs Optional target CRS to apply to both. +#' @param target_crs Optional target CRS to apply to both: anything +#' [sf::st_crs()] accepts, including an sf or sfc object, whose CRS is used. #' @param on_transform_error What to do when st_transform() fails: #' \code{"stop"} (default) raises an error immediately; #' \code{"set_crs"} falls back to st_set_crs() (UNSAFE: coordinates are @@ -859,6 +1095,12 @@ harmonize_crs <- function(a, b, prefer = c("a", "b"), target_crs = NULL, if (!inherits(b, c("sf", "sfc"))) stop("harmonize_crs(): `b` must be sf or sfc.") prefer <- match.arg(prefer) on_transform_error <- match.arg(on_transform_error) + # A layer as the target means its CRS, as it does for ensure_projected(). + # Passed through as it was, st_transform() read a multi-row sf as a list of + # candidate CRSs ("the condition has length > 1") and refused a one-row one. + # Only sf/sfc are converted here: st_crs() on a string it cannot parse + # throws before st_transform() runs, which would bypass on_transform_error. + if (inherits(target_crs, c("sf", "sfc"))) target_crs <- sf::st_crs(target_crs) crs_a <- sf::st_crs(a) crs_b <- sf::st_crs(b) @@ -970,6 +1212,68 @@ harmonize_crs <- function(a, b, prefer = c("a", "b"), target_crs = NULL, sf::st_sfc(pts, crs = sf::st_crs(x)) } + +#' Drop the EMPTY parts of multi-part geometries +#' +#' Every call to [sf::st_point_on_surface()] in the package goes through this +#' first. GEOS (3.12.1, which sf 1.0.x links) SEGFAULTS computing the +#' interior point of a non-empty geometry that holds an EMPTY line: a +#' MULTILINESTRING with an empty part beside a real one, or a +#' GEOMETRYCOLLECTION with an empty LINESTRING among its members. The R +#' session is lost, not merely the call. An empty POLYGON member does not +#' crash but is worse in its way: GEOS takes the interior point from the +#' highest dimension present, finds that dimension empty, and returns +#' POINT EMPTY for a geometry that has a line in it. +#' +#' An empty part adds no points to the geometry, so dropping it changes +#' nothing but those two failures. A feature left with no parts is EMPTY as +#' a whole, which GEOS handles (it gives POINT EMPTY). Features are never +#' removed, so the result stays aligned row for row with the input, and a +#' feature with no empty part is returned exactly as it was. +#' +#' @param x An sf or sfc object. +#' @return \code{x}, with the empty parts removed from MULTILINESTRING, +#' MULTIPOLYGON and GEOMETRYCOLLECTION features (recursively for a +#' collection's members). +#' @keywords internal +#' @noRd +.drop_empty_parts <- function(x) { + if (inherits(x, "sf")) { + g <- sf::st_geometry(x) + g2 <- .drop_empty_parts(g) + return(if (identical(g2, g)) x else sf::st_set_geometry(x, g2)) + } + multi <- c("MULTILINESTRING", "MULTIPOLYGON", "GEOMETRYCOLLECTION") + idx <- which(as.character(sf::st_geometry_type(x, by_geometry = TRUE)) %in% multi) + if (!length(idx)) return(x) + + # Emptiness read off the structure, without a GEOS call per part: a matrix + # with no rows (a LINESTRING or a ring; sf refuses NA in one), a POINT with + # no coordinates, or a list with no non-empty element (a POLYGON's rings, + # the parts of a multi-geometry, a collection's members). + is_empty <- function(s) { + if (is.list(s)) return(all(vapply(s, is_empty, logical(1)))) + length(s) == 0L || (!is.matrix(s) && all(is.na(s))) + } + has_empty <- function(s) { + if (!inherits(s, multi)) return(FALSE) + for (k in unclass(s)) if (is_empty(k) || has_empty(k)) return(TRUE) + FALSE + } + strip <- function(s) { + if (!inherits(s, multi)) return(s) + kids <- unclass(s) + if (inherits(s, "GEOMETRYCOLLECTION")) kids <- lapply(kids, strip) + structure(kids[!vapply(kids, is_empty, logical(1))], class = class(s)) + } + + # Only features that hold an empty part are rebuilt; the rest, which is + # nearly always all of them, are left exactly as they were. + for (i in idx[vapply(unclass(x)[idx], has_empty, logical(1))]) + x[[i]] <- strip(x[[i]]) + x +} + # ----------------------------------------------------------------------------- # Point Coercion # ----------------------------------------------------------------------------- @@ -979,21 +1283,31 @@ harmonize_crs <- function(a, b, prefer = c("a", "b"), target_crs = NULL, #' Converts the geometry column of an sf object to POINTs using one of several #' strategies. #' -#' LINESTRING midpoints are sampled with [sf::st_line_sample()], which yields -#' no point for an EMPTY LINESTRING. Rather than silently misaligning the -#' result (or letting sf crash), such input raises an error; drop empty -#' geometries first with `x <- x[!sf::st_is_empty(x), ]`. +#' The result has one row per row of `x`, in the same order. An EMPTY +#' geometry of any type, lines included, becomes an EMPTY POINT in its own +#' row; [prep_model_data()] and [make_folds()] then drop such rows, as they +#' drop any other empty geometry. Empty lines are never handed to +#' [sf::st_line_sample()]: it yields no midpoint for them, which would +#' misalign the result, and with sf 1.0.x an empty MULTILINESTRING (or an +#' empty part of one) crashed the R session. An empty part inside a +#' non-empty feature is ignored, so the feature gets the point its other +#' parts give; GEOS's interior point, used by `"point_on_surface"` and by +#' the temporary projection's choice of CRS, segfaulted on an empty line +#' part too. #' #' @param x An sf object. #' @param mode One of "auto", "centroid", "point_on_surface", "surface", #' "line_midpoint", "bbox_center". #' @param tmp_project Logical; temporarily project for line-based midpoints. -#' When \code{x} has no CRS and its coordinates fall inside the lon/lat -#' envelope, that temporary projection interprets them as EPSG:4326 (with a -#' warning) and the midpoints returned are geodesic ones brought back to the -#' input's numbers, not planar midpoints. Set the CRS, or pass -#' \code{tmp_project = FALSE}, for planar data. -#' @return An sf object with geometry coerced to POINTs. +#' When \code{x} has no CRS and the lon/lat heuristic of +#' \code{\link{ensure_projected}()} takes its coordinates for degrees +#' (inside the lon/lat envelope and more than one unit across, or with +#' decimal-degree precision), that temporary projection interprets them as +#' EPSG:4326 (with a warning) and the midpoints returned are geodesic ones +#' brought back to the input's numbers, not planar midpoints. Set the CRS, +#' or pass \code{tmp_project = FALSE}, for planar data. +#' @return An sf object with geometry coerced to POINTs, row for row with +#' `x`; an empty input geometry gives an empty POINT. #' @family spatial data preparation #' @examples #' library(sf) @@ -1024,35 +1338,23 @@ coerce_to_points <- function( return(sf::st_set_geometry(x, .bbox_center_sfc(x))) } - # -- direct spherical-safe ops --- + # -- direct ops --- + # Not spherical-safe, whatever this heading used to say. On lon/lat input + # st_centroid() is spherical only while sf_use_s2() is TRUE: with it FALSE + # it is planar in degrees (a box -120..-60 x 50..75 got a centre 155 km + # from the s2 one) and its warning is suppressed here. st_point_on_surface() + # is GEOS, planar in degrees under either setting. if (mode == "centroid") { return(sf::st_set_geometry(x, suppressWarnings(sf::st_centroid(g)))) } if (mode == "point_on_surface") { - return(sf::st_set_geometry(x, sf::st_point_on_surface(g))) + # Empty parts dropped first: GEOS segfaults on an empty line inside a + # non-empty feature (see .drop_empty_parts()). + return(sf::st_set_geometry(x, sf::st_point_on_surface(.drop_empty_parts(g)))) } is_ll <- .is_longlat(x) - # An EMPTY LINESTRING has no midpoint: st_line_sample() yields an empty - # MULTIPOINT that st_cast(, "POINT") silently drops (and in sf 1.0.x the - # call segfaults outright), so the sampled midpoints would no longer align - # 1:1 with the rows they are scattered back into. Reject before sampling. - .guard_empty_lines <- function(geom, idx_ls) { - empty <- which(sf::st_is_empty(geom)) - if (!length(empty)) return(invisible(NULL)) - shown <- idx_ls[empty][seq_len(min(5L, length(empty)))] - stop(sprintf( - paste0("coerce_to_points(): %d of %d LINESTRING feature(s) are EMPTY ", - "(row(s) %s%s); st_line_sample() yields no midpoint for them, ", - "which would misalign the result. Drop them first, e.g. ", - "x <- x[!sf::st_is_empty(x), ]."), - length(empty), length(idx_ls), - paste(shown, collapse = ", "), - if (length(empty) > 5L) ", ..." else "" - ), call. = FALSE) - } - # Backstop for any other way the sampled count could diverge from the number # of LINESTRING rows being filled. .check_midpoint_alignment <- function(midps, idx_ls) { @@ -1064,6 +1366,30 @@ coerce_to_points <- function( ), call. = FALSE) } + # Midpoints of the LINESTRING rows `idx_ls`, one per row, batched: project + # once, sample all, back-transform once. An EMPTY line has no midpoint: + # st_line_sample() yields an empty MULTIPOINT that st_cast(, "POINT") + # silently drops (and in sf 1.0.x the call can segfault outright), so the + # samples would no longer align 1:1 with the rows they are scattered back + # into. Empty rows never reach the sampler. They get an EMPTY POINT, as an + # empty polygon, point or collection already does, so the rows stay aligned + # and prep_model_data() and make_folds() drop them like any empty geometry. + # This used to be an error, which made a line layer with one null geometry + # the only kind of layer those "drop empty rows" paths could not clean. + .line_midpoints <- function(idx_ls) { + res <- rep(list(sf::st_point()), length(idx_ls)) + full <- which(!sf::st_is_empty(g[idx_ls])) + if (!length(full)) return(res) + g_ls_sf <- sf::st_sf(geometry = g[idx_ls[full]]) + g_ls_proj <- if (tmp_project) ensure_projected(g_ls_sf) else g_ls_sf + midps <- sf::st_line_sample(sf::st_geometry(g_ls_proj), sample = 0.5) + midps <- sf::st_cast(midps, "POINT") + midps <- .back_to_input_crs(midps, g_ls_proj, crs) + .check_midpoint_alignment(midps, full) + res[full] <- as.list(midps) + res + } + if (mode == "line_midpoint") { gtypes <- as.character(sf::st_geometry_type(g, by_geometry = TRUE)) if (any(gtypes %in% c("MULTILINESTRING", "GEOMETRYCOLLECTION"))) { @@ -1073,21 +1399,12 @@ coerce_to_points <- function( idx_other <- which(gtypes != "LINESTRING") out <- vector("list", length(g)) - # Batch all LINESTRINGs: project once, sample all, back-transform once if (length(idx_ls)) { if (is_ll && !tmp_project) { ctr <- suppressWarnings(sf::st_centroid(g[idx_ls])) out[idx_ls] <- as.list(ctr) } else { - g_ls <- g[idx_ls] - .guard_empty_lines(g_ls, idx_ls) - g_ls_sf <- sf::st_sf(geometry = g_ls) - g_ls_proj <- if (tmp_project) ensure_projected(g_ls_sf) else g_ls_sf - midps <- sf::st_line_sample(sf::st_geometry(g_ls_proj), sample = 0.5) - midps <- sf::st_cast(midps, "POINT") - midps <- .back_to_input_crs(midps, g_ls_proj, crs) - .check_midpoint_alignment(midps, idx_ls) - out[idx_ls] <- as.list(midps) + out[idx_ls] <- .line_midpoints(idx_ls) } } # Non-LINESTRING fallback to centroid @@ -1119,7 +1436,7 @@ coerce_to_points <- function( # --- POLYGON / MULTIPOLYGON: vectorized point_on_surface --- idx_poly <- which(gtypes %in% c("POLYGON", "MULTIPOLYGON")) if (length(idx_poly)) { - pos <- sf::st_point_on_surface(g[idx_poly]) + pos <- sf::st_point_on_surface(.drop_empty_parts(g[idx_poly])) out[idx_poly] <- as.list(pos) } @@ -1130,15 +1447,7 @@ coerce_to_points <- function( ctr <- suppressWarnings(sf::st_centroid(g[idx_ls])) out[idx_ls] <- as.list(ctr) } else { - g_ls <- g[idx_ls] - .guard_empty_lines(g_ls, idx_ls) - g_ls_sf <- sf::st_sf(geometry = g_ls) - g_ls_proj <- if (tmp_project) ensure_projected(g_ls_sf) else g_ls_sf - midps <- sf::st_line_sample(sf::st_geometry(g_ls_proj), sample = 0.5) - midps <- sf::st_cast(midps, "POINT") - midps <- .back_to_input_crs(midps, g_ls_proj, crs) - .check_midpoint_alignment(midps, idx_ls) - out[idx_ls] <- as.list(midps) + out[idx_ls] <- .line_midpoints(idx_ls) } } @@ -1149,16 +1458,32 @@ coerce_to_points <- function( ctr <- suppressWarnings(sf::st_centroid(g[idx_mls])) out[idx_mls] <- as.list(ctr) } else { - g_mls <- g[idx_mls] + # Empty parts are stripped before anything else sees them (see + # .drop_empty_parts()): how st_transform() and st_cast() treat an empty + # part varies across sf, GDAL and GEOS versions -- on macOS builds a + # feature holding one came back EMPTY as a whole, losing its real part. + g_mls <- .drop_empty_parts(g[idx_mls]) g_mls_sf <- sf::st_sf(geometry = g_mls) g_mls_proj <- if (tmp_project) ensure_projected(g_mls_sf) else g_mls_sf proj_geom <- sf::st_geometry(g_mls_proj) proj_crs <- sf::st_crs(g_mls_proj) for (j in seq_along(idx_mls)) { - parts <- suppressWarnings(sf::st_cast(proj_geom[j], "LINESTRING")) - if (length(parts) == 0L) { - out[[idx_mls[j]]] <- suppressWarnings(sf::st_centroid(g[idx_mls[j]]))[[1]] + # st_cast() turns an EMPTY MULTILINESTRING into ONE empty LINESTRING, + # not zero parts, and a MULTILINESTRING can also carry an empty part + # beside real ones. Either reached st_line_sample() below, which + # segfaults on an empty line in sf 1.0.x and took the R session with + # it (the usual source: a null geometry in a line layer, which + # GeoPackage and st_read()'s promote_to_multi return as + # MULTILINESTRING EMPTY). Sample only parts that have a midpoint; a + # feature with none gets an EMPTY POINT, as an empty LINESTRING does. + # The parts are read off the structure rather than st_cast(), for the + # same reason as above. + mats <- Filter(function(m) is.matrix(m) && nrow(m) > 0L, + unclass(proj_geom[[j]])) + if (length(mats) == 0L) { + out[[idx_mls[j]]] <- sf::st_point() } else { + parts <- sf::st_sfc(lapply(mats, sf::st_linestring), crs = proj_crs) lens <- as.numeric(sf::st_length(parts)) k <- if (length(lens)) which.max(lens) else 1L mp <- sf::st_line_sample(parts[k], sample = 0.5) diff --git a/R/evaluation.R b/R/evaluation.R index 3fafff3..8e81913 100644 --- a/R/evaluation.R +++ b/R/evaluation.R @@ -595,8 +595,9 @@ #' \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.} +#' cannot be rebuilt, and logs a warning (but proceeds) if the residuals +#' are not the OLS residuals on it, in which case the moments are +#' approximate.} #' } #' Both \code{"auto"} and \code{"residual"} also fall back to #' \code{"randomisation"} when the residual degrees of freedom @@ -659,8 +660,15 @@ #' so the console shows the statistic and its null without printing the #' \eqn{n \times n} \code{weights} matrix; \code{[} drops the class, and #' \code{$}, \code{[[} and \code{unlist()} are unaffected. -#' Returns \code{NULL} with a warning if computation fails (e.g. fewer -#' than 4 valid residuals). +#' A custom fit whose class has no \code{residuals()} method (which +#' \code{\link{new_spatial_fit}} calls optional) is scored on the +#' observed response minus \code{fitted()}, as \code{plot()} does for it. +#' Returns \code{NULL} with a warning if computation fails, saying why: +#' \code{residuals()} raised an error (its message is quoted), or returned +#' \code{NULL} and the response minus \code{fitted()} could not be +#' formed either (the reason is quoted), fewer than 4 valid +#' residuals, or a residual vector whose length does not match the fit's +#' \code{data_sf}. #' @references Cliff, A. D. and Ord, J. K. (1981) \emph{Spatial Processes: #' Models and Applications}. Pion, London. Section 8.3. #' @family model evaluation @@ -709,8 +717,52 @@ residual_morans_i <- function(fit, } # --- Extract residuals & coordinates --- - resid <- tryCatch(residuals(fit), error = function(e) NULL) - if (is.null(resid) || length(resid) < 4L) { + # Three failures told apart, each with its own reason. They all used to + # read "could not extract enough residuals (n < 4)" -- on a 100-row fit -- + # or, for a residual vector of the wrong length, "coordinate extraction + # failed", and the error residuals() raised was thrown away. + resid <- tryCatch(residuals(fit), error = function(e) e) + if (inherits(resid, "error")) { + .warn_and_log("residual_morans_i(): residuals() failed on this fit: %s", + conditionMessage(resid)) + return(NULL) + } + # A custom subclass without a residuals.() method -- which + # ?new_spatial_fit calls optional -- gets residuals.default(), i.e. + # fit$residuals, i.e. NULL. plot.spatial_fit() falls back to the observed + # response minus fitted() there, which is what the built-in backends' + # residuals are; this returned NULL instead, so compare_models() reported + # all-NA Moran's I columns for a fit whose residuals were strongly + # autocorrelated. Only when that cannot be formed either is there nothing + # to test. + if (is.null(resid) && is.character(fit$response_var) && + length(fit$response_var) == 1L && inherits(fit$data_sf, "sf")) { + resid <- tryCatch({ + y <- sf::st_drop_geometry(fit$data_sf)[[fit$response_var]] + if (is.null(y)) + stop(sprintf("the fit's data_sf has no column '%s'.", fit$response_var), + call. = FALSE) + as.numeric(y) - + as.numeric(.fitted_checked(fit, .caller = "residual_morans_i")) + }, error = function(e) e) + if (inherits(resid, "error")) { + .warn_and_log(paste0("residual_morans_i(): residuals() returned NULL for ", + "a fit of class %s, which has no residuals() method, ", + "and the observed response minus fitted() could not ", + "be formed either: %s"), + class(fit)[1L], + sub("^residual_morans_i\\(\\): ", "", conditionMessage(resid))) + return(NULL) + } + } + if (is.null(resid)) { + .warn_and_log(paste0("residual_morans_i(): residuals() returned NULL for a ", + "fit of class %s, which has no residuals() method; see ", + "?new_spatial_fit for the methods a custom fit needs."), + class(fit)[1L]) + return(NULL) + } + if (length(resid) < 4L) { .warn_and_log("residual_morans_i(): could not extract enough residuals (n < 4).") return(NULL) } @@ -720,10 +772,17 @@ residual_morans_i <- function(fit, sf::st_coordinates(pts)[, 1:2, drop = FALSE] }, error = function(e) NULL) - if (is.null(coords) || nrow(coords) != length(resid)) { + if (is.null(coords)) { .warn_and_log("residual_morans_i(): coordinate extraction failed.") return(NULL) } + if (nrow(coords) != length(resid)) { + .warn_and_log(paste0("residual_morans_i(): residuals() returned %d value(s) ", + "for the %d row(s) of the fit's data_sf, so they cannot ", + "be matched to locations."), + length(resid), nrow(coords)) + return(NULL) + } # Drop any non-finite residual OR non-finite coordinate. Filtering on the # residual alone left a row with an empty POINT geometry in place (its @@ -1113,9 +1172,16 @@ print.morans_i <- function(x, ...) { #' Must contain the response variable and all predictors. #' If NULL, in-sample metrics are computed. #' @param ... Extra arguments passed to predict(). +#' @inheritSection model_metrics What the metrics are computed on #' @inheritSection model_metrics Percentage errors on responses with zeros #' @return A data.frame with one row per model and columns for -#' model name and all regression metrics. +#' model name, all regression metrics, and \code{metric_basis}: what the +#' row's metrics were computed on, \code{"in-sample"} (fitted values), +#' \code{"out-of-bag"} (an \code{rf_fit}'s fitted values, see "What the +#' metrics are computed on") or \code{"newdata"}. Rows with different +#' bases do not compare like for like. An element that is not a +#' \code{spatial_fit} is skipped, with a logged warning, and has no row; +#' a list in which no element is a \code{spatial_fit} is an error. #' @family model evaluation #' @examples #' if (requireNamespace("ranger", quietly = TRUE)) { @@ -1179,10 +1245,38 @@ evaluate_insample <- function(fits, newdata = NULL, ...) { return(NULL) } met <- model_metrics(obj, newdata = newdata, ...) - cbind(data.frame(model = nm, stringsAsFactors = FALSE), met) + # What the numbers were computed on, per row. Without newdata a forest's + # fitted() values are out-of-bag and every other backend's are in-sample, + # and a table that set the two side by side unlabelled could rank the + # models the wrong way round (GWR 0.77 in-sample against RF 0.82 + # out-of-bag, where RF's in-sample RMSE was 0.40). + basis <- if (!is.null(newdata)) "newdata" + else if (isTRUE(obj$info$fitted_are_oob)) "out-of-bag" + else "in-sample" + cbind(data.frame(model = nm, stringsAsFactors = FALSE), met, + data.frame(metric_basis = basis, stringsAsFactors = FALSE)) }) - do.call(rbind, Filter(Negate(is.null), rows)) + # With every element skipped this returned NULL, not the documented + # data.frame, and said so only in the log, which spatialkit_quiet() and + # tryCatch(warning =) never see. + out <- do.call(rbind, Filter(Negate(is.null), rows)) + if (is.null(out)) .stop_no_spatial_fit("evaluate_insample", "evaluate") + out +} + + +#' Refuse a list of fits in which nothing is a spatial_fit +#' +#' @param caller The exported function's name, for the message. +#' @param verb What there is nothing to do ("evaluate", "compare"). +#' @keywords internal +#' @noRd +.stop_no_spatial_fit <- function(caller, verb) { + stop(sprintf(paste0("%s(): no element of `fits` is a spatial_fit, so there ", + "is nothing to %s. Pass fits from fit_rf_model(), ", + "fit_gwr_model(), fit_bayesian_spatial_model() or ", + "new_spatial_fit()."), caller, verb), call. = FALSE) } @@ -1193,22 +1287,40 @@ evaluate_insample <- function(fits, newdata = NULL, ...) { #' Side-by-side comparison of fitted spatial models #' #' Takes a named list of already-fit \code{spatial_fit} objects and produces -#' a tidy comparison table including in-sample metrics and model-specific -#' information criteria (AICc, LOOIC). +#' a tidy comparison table including in-sample (for a forest, out-of-bag) +#' metrics and model-specific information criteria (AICc, LOOIC). #' #' @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(). +#' @inheritSection model_metrics What the metrics are computed on #' @inheritSection model_metrics Percentage errors on responses with zeros -#' @return A data.frame comparing all models. Alongside the metrics it carries +#' @return A data.frame comparing all models. Its \code{metric_basis} +#' column says what each row's metrics were computed on (see +#' \code{\link{evaluate_insample}}); a table that mixes +#' \code{"out-of-bag"} and \code{"in-sample"} rows does not rank the +#' models, and says so in the log. \code{AICc} (GWR) and \code{LOOIC} +#' (Bayesian) are sums over the rows a model was fitted to, so each column +#' is set to \code{NA}, with a warning, when the fits carrying it were +#' fitted to different rows (a predictor with missing values drops rows, +#' for example) or to different responses (a transformed response on the +#' same rows), and the warning says which. \code{convergence_ok} is +#' \code{TRUE} or \code{FALSE} for a Bayesian fit whose convergence was +#' checked (see \code{\link{fit_bayesian_spatial_model}}) and \code{NA} +#' otherwise; a fit that did not converge is ranked like the others, so it +#' also raises a warning. Alongside the metrics it +#' carries #' \code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and #' \code{resid_morans_null}, the last of which names the null #' \code{\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. +#' choice is per-fit and governs how much the p-value is worth. A +#' significant p-value is noted in the log (not raised as an R warning): +#' positive autocorrelation as structure the model may have missed, +#' negative (\code{resid_morans_z < 0}) as the alternating residuals of a +#' model that tracks its data closely. Read the caveats in +#' \code{?residual_morans_i} before treating silence as evidence of no +#' residual structure. #' @family model evaluation #' @examples #' if (requireNamespace("ranger", quietly = TRUE)) { @@ -1240,23 +1352,23 @@ compare_models <- function(fits, newdata = NULL, ...) { fits <- stats::setNames(list(fits), class(fits)[1L]) if (!is.list(fits) || length(fits) == 0L) stop("compare_models(): `fits` must be a spatial_fit or a non-empty named list of them.") + # evaluate_insample() warns-and-skips any element that is not a spatial_fit, + # and when EVERY element is skipped it now stops -- in its own name. Say it + # here in this function's, before the call. (It used to return NULL, which + # `met_df$AICc <- NA_real_` turned into a bare list, and seq_len(nrow(NULL)) + # aborted with "argument must be coercible to non-negative integer".) + if (!any(vapply(fits, inherits, logical(1), what = "spatial_fit"))) + .stop_no_spatial_fit("compare_models", "compare") met_df <- evaluate_insample(fits, newdata = newdata, ...) # Append model-specific information criteria - # evaluate_insample() warns-and-skips any element that is not a spatial_fit - # and returns NULL when EVERY element was skipped. `met_df$AICc <- NA_real_` - # then turns that NULL into a bare list, nrow() is NULL, and seq_len(NULL) - # aborts with "argument must be coercible to non-negative integer" -- the - # same failure the comment above records as fixed for the unnamed-list case. - if (is.null(met_df) || !is.data.frame(met_df) || nrow(met_df) == 0L) - stop(paste0("compare_models(): no element of `models` is a spatial_fit, ", - "so there is nothing to compare. Pass fits from fit_rf_model(), ", - "fit_gwr_model(), fit_bayesian_spatial_model() or ", - "new_spatial_fit()."), call. = FALSE) met_df$AICc <- NA_real_ met_df$LOOIC <- NA_real_ met_df$bandwidth_is_fallback <- NA + # TRUE / FALSE as fit_bayesian_spatial_model() judged the sampler, NA for + # other backends and for a Bayesian fit whose checks were not run. + met_df$convergence_ok <- NA for (i in seq_len(nrow(met_df))) { nm <- met_df$model[i] # By index, not fits[[nm]]: name lookup returns the FIRST match, so with two @@ -1279,27 +1391,108 @@ compare_models <- function(fits, newdata = NULL, ...) { ) } } - if (inherits(obj, "bayesian_fit")) + if (inherits(obj, "bayesian_fit")) { met_df$LOOIC[i] <- obj$info$looic %||% NA_real_ + ok <- obj$info$convergence_ok + met_df$convergence_ok[i] <- if (is.logical(ok) && length(ok) == 1L) ok else NA + # The fit logged its R-hat, ESS and divergences, but a log line is + # invisible under knitr, spatialkit_quiet() and tryCatch(), and the + # row is ranked like the others. + if (isFALSE(ok)) + .warn_and_log(paste0("compare_models(): the sampler of Bayesian model ", + "'%s' did not converge (see print() on the fit, ", + "or its $info$convergence_diagnostics); its ", + "metrics and LOOIC come from an unreliable ", + "posterior."), nm) + } } + # AICc and LOOIC are sums over the observations a model was fitted to, so + # they compare only between fits of the SAME rows: a predictor with missing + # values drops rows, and model B on 50 rows showed LOOIC 32.2 against A's + # 54.8 on 70, where on B's 50 rows A scored 30.9 -- the better model read as + # 22.6 worse. loo::loo_compare() refuses that comparison; here a column + # whose fits differ in their rows is blanked, with a warning. + for (ic in c("AICc", "LOOIC")) { + has <- which(is.finite(met_df[[ic]])) + if (length(has) < 2L) next + rs <- lapply(has, function(i) .fit_rowset(fits[[match(met_df$model[i], names(fits))]])) + if (any(vapply(rs, is.null, logical(1)))) next + if (all(vapply(rs[-1L], .same_rowset, logical(1), rs[[1L]]))) next + # The fingerprint includes the response, so two fits of the same rows with + # different responses (price and log(price)) fail it too. Blanking is + # right there as well, but the warning said "different rows" and advised + # refitting on the same rows, which they already were. + if (all(vapply(rs[-1L], .same_rowset_xy, logical(1), rs[[1L]]))) { + resp <- vapply(has, function(i) { + rv <- fits[[match(met_df$model[i], names(fits))]]$response_var + if (is.character(rv) && length(rv) >= 1L) rv[1L] else NA_character_ + }, character(1)) + .warn_and_log(paste0( + "compare_models(): %s is a sum over the rows a model was fitted to, ", + "and the models carrying it were fitted to the same rows but to ", + "different responses (%s), so it is set to NA: an information ", + "criterion compares models of the same response only."), + ic, + if (length(unique(resp)) > 1L) + paste(sprintf("%s: %s", met_df$model[has], resp), collapse = ", ") + else sprintf("the values of '%s' differ between %s", resp[1L], + paste(met_df$model[has], collapse = ", "))) + met_df[[ic]] <- NA_real_ + next + } + .warn_and_log(paste0( + "compare_models(): %s is a sum over the rows a model was fitted to, and ", + "the models carrying it were fitted to different rows (%s), so it is ", + "set to NA: compared across different rows it can rank the models the ", + "wrong way round. Refit them on the same rows to compare them."), + ic, paste(sprintf("%s: n = %d", met_df$model[has], + vapply(rs, `[[`, integer(1), "n")), collapse = ", ")) + met_df[[ic]] <- NA_real_ + } + + # A table mixing out-of-bag and in-sample rows (a forest beside anything + # else, without newdata) compares unlike numbers; metric_basis says which is + # which, and this says that it matters. + if (length(unique(met_df$metric_basis)) > 1L) + .log_warn(paste0("compare_models(): the metrics mix bases (%s); ", + "out-of-bag and in-sample errors are not comparable, so ", + "use newdata or compare_models_cv() to rank these models."), + paste(sprintf("%s: %s", met_df$model, met_df$metric_basis), + collapse = ", ")) + # --- Post-fit residual spatial autocorrelation check --- moran_df <- .residual_morans_table(fits) met_df <- merge(met_df, moran_df, by = "model", all.x = TRUE, sort = FALSE) - # Emit warnings for models whose residuals still show significant - - # spatial autocorrelation (alpha = 0.05) + # Log a caution for models whose residuals still show significant spatial + # autocorrelation (alpha = 0.05, two-sided). The direction decides what it + # means, and it is read from z, not from I: E[I] is negative, so an I just + # below 0 can still be positive autocorrelation. Negative z -- residuals + # anti-correlated with their neighbours -- is what in-sample residuals of a + # GP or GWR fit that tracks the data closely look like, the opposite of + # structure the model missed, and was reported as the latter. for (i in seq_len(nrow(met_df))) { p_val <- met_df$resid_morans_p[i] I_val <- met_df$resid_morans_I[i] + z_val <- met_df$resid_morans_z[i] if (is.finite(p_val) && p_val < 0.05) { - .log_warn( - paste0("compare_models(): residuals of '%s' show significant ", - "spatial autocorrelation (Moran's I = %.4f, p = %.4g). ", - "The model may not fully capture the spatial structure."), - met_df$model[i], I_val, p_val - ) + if (is.finite(z_val) && z_val < 0) + .log_warn( + paste0("compare_models(): residuals of '%s' show significant ", + "negative spatial autocorrelation (Moran's I = %.4f, ", + "p = %.4g): neighbouring residuals alternate in sign, as ", + "in-sample residuals of a model that tracks the data closely ", + "(a GP, a small-bandwidth GWR) do. That points to ", + "over-fitting, not to missed spatial structure."), + met_df$model[i], I_val, p_val) + else + .log_warn( + paste0("compare_models(): residuals of '%s' show significant ", + "spatial autocorrelation (Moran's I = %.4f, p = %.4g). ", + "The model may not fully capture the spatial structure."), + met_df$model[i], I_val, p_val + ) } } @@ -1307,6 +1500,66 @@ compare_models <- function(fits, newdata = NULL, ...) { } +#' The rows a fit was fitted to, as a comparable fingerprint +#' +#' For \code{compare_models()}'s information-criterion check. Fits do not +#' reliably carry \code{..row_id}, so the fingerprint is the row count, the +#' sorted response and the sorted coordinates (in EPSG:4326 when the data +#' has a CRS). Sorting each margin separately keeps the comparison stable +#' under the last-digit noise of a reprojection. +#' +#' @param fit A \code{spatial_fit}. +#' @return A list, or \code{NULL} when the fit's data cannot be read. +#' @keywords internal +#' @noRd +.fit_rowset <- function(fit) { + tryCatch({ + d <- fit$data_sf + y <- as.numeric(sf::st_drop_geometry(d)[[fit$response_var]]) + g <- sf::st_geometry(d) + if (!all(sf::st_geometry_type(g, by_geometry = TRUE) == "POINT")) + g <- suppressWarnings(sf::st_centroid(g)) + lonlat <- !is.na(sf::st_crs(g)) + if (lonlat) g <- suppressWarnings(sf::st_transform(g, 4326)) + xy <- sf::st_coordinates(g) + if (!length(y) || nrow(xy) != length(y)) return(NULL) + list(n = length(y), y = sort(y, na.last = TRUE), + x1 = sort(xy[, 1L], na.last = TRUE), x2 = sort(xy[, 2L], na.last = TRUE), + lonlat = lonlat) + }, error = function(e) NULL) +} + +#' Do two \code{.fit_rowset()} fingerprints describe the same rows? +#' +#' The same rows with the same response: \code{.same_rowset_xy()} compares +#' the locations alone, so that a caller can tell a different response on the +#' same rows from different rows. +#' @keywords internal +#' @noRd +.same_rowset <- function(a, b) { + .same_rowset_xy(a, b) && + .rowset_close(a$y, b$y, 1e-10 * max(1, abs(a$y), na.rm = TRUE)) +} + +#' Do two \code{.fit_rowset()} fingerprints sit at the same locations? +#' @keywords internal +#' @noRd +.same_rowset_xy <- function(a, b) { + if (a$n != b$n || !identical(a$lonlat, b$lonlat)) return(FALSE) + tol_xy <- if (a$lonlat) 1e-6 + else 1e-9 * max(1, abs(c(a$x1, a$x2)), na.rm = TRUE) + .rowset_close(a$x1, b$x1, tol_xy) && .rowset_close(a$x2, b$x2, tol_xy) +} + +#' Two sorted margins equal within \code{tol}, \code{NA} matching \code{NA} +#' @keywords internal +#' @noRd +.rowset_close <- function(u, v, tol) { + d <- abs(u - v) + all((is.na(u) & is.na(v)) | (!is.na(d) & d <= tol)) +} + + # --------------------------------------------------------------------------- # compare_models_cv: cross-validated comparison # --------------------------------------------------------------------------- @@ -1340,7 +1593,9 @@ compare_models <- function(fits, newdata = NULL, ...) { #' a logged count (expected when rows were removed for missing values; a sign #' the folds came from other data when they were not). #' @param boundary Optional polygon sf/sfc. -#' @param pointize Geometry coercion strategy. +#' @param pointize Geometry coercion strategy. It also decides where a +#' polygon or line row falls in the shared blocks, so each row is placed by +#' the point every model is fitted at. #' @param gwr_args Extra arguments for \code{\link{cv_gwr}}. Only names that #' are formal arguments of \code{cv_gwr()} are forwarded (it has no #' \code{...}), so entries meant for \code{fit_gwr_model()} alone (e.g. @@ -1366,15 +1621,18 @@ compare_models <- function(fits, newdata = NULL, ...) { #' \code{predictor_vars}) is estimated and used as the minimum block size of #' the shared folds, as in \code{\link{make_folds}()}. Default #' \code{FALSE}: geometric blocks, as before this argument existed. Either -#' way the fold set is built once and every backend is scored on it. +#' way the fold set is built once and every backend is scored on it. When +#' it cannot be built (a \code{block_size} or estimated range that leaves a +#' single block, say) the call is an error, as it is for each backend on +#' its own; no model is scored on a design other than the one asked for. #' @param metrics Optional scoring function of your own, handed to every #' backend's \code{cv_*()}: a \code{function(y, yhat)} returning a named #' numeric vector, applied per fold and to each backend's pooled #' predictions, whose names become columns of \code{by_fold} and #' \code{overall} beside the built-in ones. See \strong{Your own metrics} -#' on \code{\link{cv_spatial}()} for the contract. Because the three -#' backends are scored on the same folds, the columns are comparable across -#' rows of \code{overall}. +#' on \code{\link{cv_spatial}()} for the contract. Because the backends +#' are scored on the same folds and, in \code{overall}, on the same rows +#' (see Value), the columns are comparable across rows of \code{overall}. #' @inheritSection model_metrics Percentage errors on responses with zeros #' @inheritSection model_metrics Which metrics survive a non-Gaussian response #' @section Coverage and CRPS in the overall table: @@ -1394,9 +1652,21 @@ compare_models <- function(fits, newdata = NULL, ...) { #' overconfident, well above it is wider than it needs to be. #' @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). -#' \code{overall} has one row per model with the pooled metrics, the +#' \code{overall} has one row per model with the pooled metrics, +#' \code{n_pred} (the rows they are computed on), the #' coverage and CRPS columns described above when a Bayesian model ran, and #' \code{model} as its last column. +#' Shared folds do not guarantee shared rows: a model that fails on a fold +#' (GWR with a fixed bandwidth across a gap in the data, say) or predicts +#' \code{NA} for some rows pools fewer rows, usually without the hardest +#' ones. When the models predicted different rows, the function warns and +#' recomputes every model's pooled metrics, your own \code{metrics} +#' included, on the rows all of them predicted, so \code{n_pred} is the same +#' on every row that has predictions; a model that predicted nothing stays +#' an \code{NA} row. Each model's metrics over all the rows it predicted +#' stay in its \code{*_cv} element and in \code{attr(overall, "all_rows")}, +#' a table of the same shape. \code{by_fold} and the Bayesian coverage and +#' CRPS columns are per fold and are not recomputed. #' Only the models that actually ran appear, so check which names are #' present; there is not always one entry per requested model, because a #' backend whose package is missing is dropped with a message. When \strong{no} requested backend @@ -1489,21 +1759,35 @@ compare_models_cv <- function( # the leakage diagnostic that compares the blocks to the estimated range. # Before they were forwarded, this -- the one function that compares models # -- was also the one whose folds could never be checked against the range. + # + # A failure to build them is an error. It used to be a log line and a + # fall-back to each backend's own DEFAULT folds, which none of them was + # handed block_size or auto_range for: block_size = 1e6 (a single block, + # which cv_rf() refuses) came back as a five-fold comparison on geometric + # blocks, and auto_range = TRUE as the small, leaky blocks it exists to + # prevent, with no R condition either way. The backends would fail on the + # same design, so say so once, here. + # + # Blocks are assigned to the points the models are fitted at. make_folds() + # reduces polygons and lines with pointize = "auto", so under another + # `pointize` it placed rows by a different point than every backend fits + # them at (119 of 150 L-shaped parcels changed fold against a standalone + # cv_gwr(pointize = "centroid")). The provenance probe stays on the geometry + # as supplied, which is what each cv_*() checks it against. if (is.null(folds)) { + pointized <- !all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT") + fold_src <- if (pointized) coerce_to_points(data_sf, pointize) else data_sf folds <- tryCatch( - make_folds(data_sf, k = k, method = "block_kfold", + make_folds(fold_src, k = k, method = "block_kfold", seed = if (is.null(seed)) 123L else seed, boundary = boundary, block_size = block_size, auto_range = auto_range, response_var = response_var, predictor_vars = predictor_vars), - error = function(e) { - .log_warn(paste0("compare_models_cv(): could not build a shared fold ", - "set (%s); each backend will build its own, so the ", - "models may not be scored on identical splits."), - conditionMessage(e)) - NULL - } - ) + error = function(e) + stop("compare_models_cv(): could not build the shared fold set, so no ", + "model can be scored on the design asked for: ", + conditionMessage(e), call. = FALSE)) + if (pointized) folds$params$row_probe <- .fold_row_probe(data_sf) } comparison_rows <- list(); by_fold_rows <- list(); cv_results <- list() @@ -1523,7 +1807,7 @@ compare_models_cv <- function( ov <- try(as.data.frame(gwr_cv$overall), silent = TRUE) if (inherits(ov, "try-error") || nrow(ov) == 0L) ov <- data.frame(RMSE = NA_real_, MAE = NA_real_, MAPE = NA_real_, SMAPE = NA_real_, - R2 = NA_real_, Adj_R2 = NA_real_) + R2 = NA_real_, Adj_R2 = NA_real_, n_pred = 0L) ov$model <- "GWR" comparison_rows[["GWR"]] <- ov bf <- try(as.data.frame(gwr_cv$fold_metrics), silent = TRUE) @@ -1544,7 +1828,7 @@ compare_models_cv <- function( ov <- try(as.data.frame(bayes_cv$overall), silent = TRUE) if (inherits(ov, "try-error") || nrow(ov) == 0L) ov <- data.frame(RMSE = NA_real_, MAE = NA_real_, MAPE = NA_real_, SMAPE = NA_real_, - R2 = NA_real_, Adj_R2 = NA_real_) + R2 = NA_real_, Adj_R2 = NA_real_, n_pred = 0L) # The calibration of the one backend that has any: coverage at each level # and mean CRPS, already pooled across folds by cv_bayes(). bind_rows() # below leaves them NA on the point-prediction rows. @@ -1577,7 +1861,7 @@ compare_models_cv <- function( ov <- try(as.data.frame(rf_cv$overall), silent = TRUE) if (inherits(ov, "try-error") || nrow(ov) == 0L) ov <- data.frame(RMSE = NA_real_, MAE = NA_real_, MAPE = NA_real_, SMAPE = NA_real_, - R2 = NA_real_, Adj_R2 = NA_real_) + R2 = NA_real_, Adj_R2 = NA_real_, n_pred = 0L) ov$model <- "RF" comparison_rows[["RF"]] <- ov bf <- try(as.data.frame(rf_cv$fold_metrics), silent = TRUE) @@ -1586,10 +1870,53 @@ compare_models_cv <- function( } } - overall <- as.data.frame(dplyr::bind_rows(comparison_rows)) # `model` last whatever order the backends ran in: a Bayesian row that came # after a GWR row would otherwise put its coverage columns after `model`. - overall <- overall[, c(setdiff(names(overall), "model"), "model"), drop = FALSE] + as_table <- function(rows) { + tab <- as.data.frame(dplyr::bind_rows(rows)) + tab[, c(setdiff(names(tab), "model"), "model"), drop = FALSE] + } + + # Shared folds are not shared rows. Each backend's `overall` pools the rows + # IT predicted, and a backend that loses a fold -- GWR with a fixed + # bandwidth across a gap in the data, a factor level one block holds alone + # -- loses the hardest rows, the extrapolation block, and looks better for + # it: GWR RMSE 1.82 on 158 rows against RF 1.95 on 200, where RF scores 0.99 + # on the same 158. When the row sets differ, every backend that predicted + # anything is re-scored on the rows all of them predicted (an all-failed + # backend stays an NA row), and the table as each reported it is kept. + ids <- lapply(cv_results, function(r) { + pr <- r$predictions + if (!is.data.frame(pr) || !nrow(pr)) return(NULL) + pr$`..row_id`[is.finite(pr$y) & is.finite(pr$yhat)] + }) + ids <- ids[lengths(ids) > 0L] + all_rows <- NULL + if (length(ids) >= 2L) { + common <- Reduce(intersect, ids) + if (!all(vapply(ids, setequal, logical(1), common))) { + lab <- c(gwr_cv = "GWR", bayes_cv = "Bayesian", rf_cv = "RF")[names(ids)] + all_rows <- as_table(comparison_rows) + .warn_and_log(paste0( + "compare_models_cv(): the models predicted different rows (%s), so ", + "`overall` scores each of them on the %d rows they all predicted: the ", + "rows a model fails on are usually the hardest, and leaving them out ", + "flatters it. Each model's own pooled metrics are in ", + "attr(overall, \"all_rows\") and its *_cv element; `by_fold` and the ", + "Bayesian coverage and CRPS columns are not re-scored."), + paste(sprintf("%s %d", lab, lengths(ids)), collapse = ", "), + length(common)) + for (nm in names(ids)) { + pr <- cv_results[[nm]]$predictions + re <- .cv_overall_metrics(pr[pr$`..row_id` %in% common, , drop = FALSE], + metrics) + for (cn in names(re)) comparison_rows[[lab[[nm]]]][[cn]] <- re[[cn]] + } + } + } + + overall <- as_table(comparison_rows) + if (!is.null(all_rows)) attr(overall, "all_rows") <- all_rows c(list(overall = overall, by_fold = dplyr::bind_rows(by_fold_rows)), cv_results) diff --git a/R/feature-selection.R b/R/feature-selection.R index 612c4aa..65538cb 100644 --- a/R/feature-selection.R +++ b/R/feature-selection.R @@ -85,9 +85,11 @@ #' @param select_on \code{"all"} (default) runs the sweep on every row of #' \code{train_sf}. \code{"split"} runs it on one spatially blocked half, #' then fits the selected set on that half and scores it on the other: -#' \code{score_holdout} is then an honest estimate of the selected model's -#' \code{metric} on data the selection never saw (the sweep's own -#' \code{score} is not; see "The score is not a performance estimate"). +#' \code{score_holdout} is then the selected model's \code{metric} on rows +#' whose response the sweep never read (the sweep's own \code{score} is +#' not; see "The score is not a performance estimate"). It is one +#' estimate from one region: the halves share a border with no buffer, so +#' rows near it are still correlated with the selection half. #' Both halves come back in \code{$split}. See the "Post-selection #' inference" section of \code{\link{determine_optimal_levels}} for the #' trade: coverage for half the sample. @@ -100,20 +102,31 @@ #' final step: the \strong{selection-internal} optimum, optimistically #' biased because it was chosen as the best of many (see the section above), #' and \code{NA} when nothing was selected. \code{history} is a data.frame -#' with \code{step}, \code{variable} and \code{score}, holding every -#' candidate evaluated at every step; when the null model could be scored it -#' also carries a \code{step = 0} row named \code{""} giving that -#' baseline, so the first variable's gain can be read off directly. +#' with \code{step}, \code{variable}, \code{score} and \code{n_pred}, +#' holding every candidate evaluated at every step; when the null model +#' could be scored it also carries a \code{step = 0} row named +#' \code{""} giving that baseline, so the first variable's gain can be +#' read off directly. Every set is scored on the same rows: those the null +#' model's cross-validation predicted or, when there is no null model, +#' those any step-1 set predicted; \code{params$n_scored} counts them (a +#' warning says so when that is fewer than all). \code{n_pred} is how many +#' rows the set's cross-validation predicted. A set that left some of the +#' scored rows unpredicted, because a fold failed for it, has \code{score} +#' \code{NA}, with a warning naming it: scored on the rows it did predict +#' it would be compared on fewer, usually easier, rows than its rivals. A +#' factor with a level found in one spatial block only is the usual case, +#' and cannot be selected. #' \code{score_holdout} is \code{NA} unless \code{select_on = "split"}, and #' then the selected set's \code{metric} when fitted on the selection half #' and predicted on the estimation half (\eqn{R^2} against the selection #' half's mean, the out-of-sample convention); \code{NA} when nothing was #' selected or the prediction failed. \code{split} is \code{NULL} or a #' list with \code{selection} and \code{estimation}, integer row positions -#' in \code{train_sf} after the completeness filter above. +#' in \code{train_sf} as passed; rows the completeness filter above dropped +#' are in neither. #' \code{params} records \code{metric}, \code{method}, \code{k}, #' \code{tol}, \code{seed}, \code{auto_range}, \code{select_on}, -#' \code{n_candidates} and \code{estimated_fits}. +#' \code{n_candidates}, \code{estimated_fits} and \code{n_scored}. #' @references #' Cawley, G. C. and Talbot, N. L. C. (2010). On over-fitting in model #' selection and subsequent selection bias in performance evaluation. @@ -197,8 +210,8 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, } # Sample splitting: the sweep sees the selection half only; the estimation - # half scores the chosen set afterwards. Positions index train_sf as it - # stands here, after the completeness filter. + # half scores the chosen set afterwards. .spatial_half_split()'s positions + # index train_sf as it stands here, after the completeness filter. split <- NULL holdout_sf <- NULL if (identical(select_on, "split")) { @@ -208,6 +221,15 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, caller = "select_features_forward") holdout_sf <- train_sf[split$estimation, , drop = FALSE] train_sf <- train_sf[split$selection, , drop = FALSE] + # Returned as positions in the layer the CALLER passed, as print() says + # and as determine_optimal_levels() returns them. They were positions + # after the completeness filter, so with 7 incomplete rows + # pts[fs$split$estimation, ] held 47 selection-half rows and 4 of the + # dropped ones: the one use of the split, estimating on rows the + # selection never saw, got rows it had seen. + kept <- which(keep) + split$selection <- kept[split$selection] + split$estimation <- kept[split$estimation] .msg(sprintf("select_features_forward(): selecting on %d points, scoring the result on the other %d.", nrow(train_sf), nrow(holdout_sf))) } @@ -260,15 +282,50 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, trimws(conditionMessage(attr(folds, "condition"))), " Adjust `method`, `k` or `block_size`.", call. = FALSE) - score_set <- function(vars) { + # Every set is scored on ONE fixed row set, `ref_ids`: the rows the null + # model predicted, or, when there is no null model (RF and GWR refuse an + # empty predictor set), the rows any step-1 candidate predicted. + # cv_spatial()'s `overall` pools whichever folds survived, so a set whose + # fit or predict failed on a fold -- a factor level found in one block + # only, the ordinary case -- was scored on fewer rows, usually the easier + # ones, and could win for that alone: a noise factor was chosen over the + # true driver (RF RMSE 2.35 on 192 rows against 2.63 on 250). A set that + # leaves a reference row unpredicted is scored NA instead, and said so. + # Rows the reference runs did not predict (a fold that fails for every set, + # from geometry rather than predictors) drop out of every score alike. + ref_ids <- NULL + run_set <- function(vars) { inner_fit <- function(tr) fit_fn(tr, vars) - res <- try(suppressMessages( - cv_spatial(train_sf, response_var, vars, fit_fn = inner_fit, - folds = folds, seed = seed)), silent = TRUE) - if (inherits(res, "try-error") || is.null(res$overall)) return(NA_real_) - val <- res$overall[[metric]] + # cv_spatial()'s own partial-failure warning is muffled: the consequence + # for the sweep is reported below, once per step, in the sweep's terms. + res <- try(withCallingHandlers( + suppressMessages( + cv_spatial(train_sf, response_var, vars, fit_fn = inner_fit, + folds = folds, seed = seed)), + warning = function(w) + if (.is_failed_folds_warning(w)) invokeRestart("muffleWarning")), + silent = TRUE) + if (inherits(res, "try-error") || !is.data.frame(res$predictions)) + return(NULL) + pr <- res$predictions + pr[is.finite(pr$y) & is.finite(pr$yhat), , drop = FALSE] + } + n_pred_of <- function(pr) if (is.null(pr)) 0L else nrow(pr) + covers_ref <- function(pr) !is.null(pr) && all(ref_ids %in% pr$`..row_id`) + score_on <- function(pr) { + if (!length(ref_ids) || !covers_ref(pr)) return(NA_real_) + val <- .cv_overall_metrics(pr[pr$`..row_id` %in% ref_ids, , drop = FALSE])[[metric]] if (is.null(val) || !is.finite(val)) NA_real_ else as.numeric(val) } + set_ref <- function(ids, from) { + ref_ids <<- ids + if (length(ids) && length(ids) < nrow(train_sf)) + .warn_and_log(paste0( + "select_features_forward(): %s predicted only %d of the %d rows, so ", + "every candidate set is scored on those %d; the rest drop out of ", + "every score alike."), + from, length(ids), nrow(train_sf), length(ids)) + } selected <- character(0) remaining <- candidate_vars @@ -291,10 +348,15 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, # LOGGER records, which no condition handler touches: every successful # RF/GWR run printed them, identical to a genuinely failed run's, even with # quiet = TRUE. Raise the console threshold for the probe alone; the file - # trace (index 1) keeps the lines, where a diagnostic belongs. - null_score <- logger::with_log_threshold( - suppressWarnings(score_set(character(0))), + # trace (index 1) keeps the lines, where a diagnostic belongs. The rows + # the null model predicts, when it can be fitted, are the rows every set + # is scored on. + null_run <- logger::with_log_threshold( + suppressWarnings(run_set(character(0))), threshold = logger::FATAL, namespace = "spatialkit", index = 2) + if (n_pred_of(null_run) > 0L) + set_ref(sort(unique(null_run$`..row_id`)), "the null (intercept-only) model") + null_score <- score_on(null_run) best <- if (is.finite(null_score)) null_score else worst if (!is.finite(null_score)) .msg("select_features_forward(): the null (intercept-only) model could not ", @@ -302,18 +364,38 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, else history[[length(history) + 1L]] <- data.frame( step = 0L, variable = "", score = unname(null_score), - stringsAsFactors = FALSE + n_pred = n_pred_of(null_run), stringsAsFactors = FALSE ) repeat { if (length(remaining) == 0L || length(selected) >= max_steps) break - step_scores <- vapply(remaining, function(v) score_set(c(selected, v)), - numeric(1)) + runs <- lapply(remaining, function(v) run_set(c(selected, v))) + if (is.null(ref_ids)) + set_ref(sort(unique(unlist(lapply(runs, `[[`, "..row_id")))), + "the step-1 candidate sets together") + step_scores <- vapply(runs, score_on, numeric(1)) + names(step_scores) <- remaining + n_pred <- vapply(runs, n_pred_of, integer(1)) history[[length(history) + 1L]] <- data.frame( step = length(selected) + 1L, variable = remaining, - score = unname(step_scores), stringsAsFactors = FALSE + score = unname(step_scores), n_pred = n_pred, stringsAsFactors = FALSE ) + # Sets that predicted some reference rows but not all. One predicting + # none has already raised cv_spatial()'s "all folds failed" warning. + short <- which(n_pred > 0L & !vapply(runs, covers_ref, logical(1))) + if (length(short)) + .warn_and_log(paste0( + "select_features_forward(): step %d: %s left some of the %d scored ", + "rows unpredicted (a fold failed: a factor level found in one block ", + "only, say), so %s scored NA rather than on fewer, easier rows."), + length(selected) + 1L, + paste(vapply(short, function(j) sprintf( + "{%s} (%d of them predicted)", + paste(c(selected, remaining[j]), collapse = ", "), + sum(ref_ids %in% runs[[j]]$`..row_id`)), character(1)), + collapse = ", "), + length(ref_ids), if (length(short) == 1L) "it is" else "they are") if (all(is.na(step_scores))) { .msg("select_features_forward(): every candidate failed to score at step ", @@ -392,11 +474,13 @@ select_features_forward <- function(train_sf, response_var, candidate_vars, score = if (length(selected) == 0L) NA_real_ else best, score_holdout = score_holdout, history = if (length(history)) do.call(rbind, history) else - data.frame(step = integer(0), variable = character(0), score = numeric(0)), + data.frame(step = integer(0), variable = character(0), score = numeric(0), + n_pred = integer(0)), params = list(metric = metric, method = method, k = k, tol = tol, seed = seed, auto_range = isTRUE(auto_range), select_on = select_on, - n_candidates = p, estimated_fits = est_fits), + n_candidates = p, estimated_fits = est_fits, + n_scored = length(ref_ids)), split = split ), class = c("feature_selection", "list")) } diff --git a/R/fold-separation.R b/R/fold-separation.R index 7c08aed..eef0773 100644 --- a/R/fold-separation.R +++ b/R/fold-separation.R @@ -25,18 +25,35 @@ #' @param data_sf The layer the folds were built on. Row identifiers are #' matched through \code{..row_id} when the layer carries one, and by row #' position otherwise, which is what \code{make_folds()} and every -#' \code{cv_*()} do. +#' \code{cv_*()} do. As in \code{cv_*()}, a \code{make_folds()} result +#' whose recorded rows sit at other locations here (folds built on another +#' layer, such as the points before +#' \code{\link{assign_features_to_polygons}()} dropped some) is refused; +#' the location check is skipped when one of the two layers is POINT and +#' the other is not. #' @param sac Optional: an \code{\link{estimate_sac_range}()} result or a -#' single number, in the CRS units of \code{data_sf}. Defaults to the range -#' the folds carry, if any. Supplying one adds the \code{within_range} -#' column and the closing verdict. +#' single number. Defaults to the range the folds carry, if any. Supplying +#' one adds the \code{within_range} column and the closing verdict. A +#' range that records its CRS (the folds' own, or an +#' \code{estimate_sac_range()} result) is compared with distances measured +#' in that CRS, whatever CRS \code{data_sf} is in. A bare number is taken +#' to be in the units the distances are otherwise measured in: those of +#' \code{data_sf} if it is projected, and for geographic (lon/lat) input +#' metres, in the CRS \code{\link{ensure_projected}()} chooses (as for +#' \code{make_folds()}'s \code{block_size}), not degrees. A \code{units} +#' object is refused. #' @return A data.frame of class \code{fold_separation}, one row per fold: -#' \code{fold}, \code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} +#' \code{fold} (the fold's number: for the \code{$folds} of a +#' \code{cv_*()} result, the \code{fold_id} its \code{fold_metrics} use, +#' which differs from the list position once a fold has been dropped), +#' \code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} #' for a scheme with no blocks), \code{min_dist} and \code{median_dist} -#' (distance from a held-out point to its nearest training point, in CRS -#' units), and \code{within_range} (the share of held-out points closer to +#' (distance from a held-out point to its nearest training point, in the +#' units of the CRS the \code{crs} attribute names), and +#' \code{within_range} (the share of held-out points closer to #' training data than \code{sac}; \code{NA} without one). Attributes: -#' \code{method}, \code{sac_range}, \code{crs} and \code{n_unknown_ids}. +#' \code{method}, \code{sac_range}, \code{crs} (the CRS the distances were +#' measured in) and \code{n_unknown_ids}. #' @family cross-validation #' @seealso \code{\link{make_folds}()} for the fold schemes and the block #' sizing this measures the outcome of; \code{\link{cv_block_size_sweep}()} @@ -46,7 +63,7 @@ #' set.seed(1) #' n <- 200 #' pts <- st_as_sf( -#' data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)), +#' data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)), #' coords = c("x", "y"), crs = 32632 #' ) #' @@ -73,11 +90,47 @@ fold_separation <- function(folds, data_sf, sac = NULL) { # would silently measure the distance between the wrong pairs of points. ids <- if ("..row_id" %in% names(data_sf)) data_sf[["..row_id"]] else seq_len(nrow(data_sf)) + # Which is what happened when the folds came from another layer: built on + # prep_model_data()'s 200 points and measured on the 195 that + # assign_features_to_polygons() kept, every row after the first dropped one + # was paired with its neighbour's folds, and within_range read 1.0 against + # 0.23-0.48 on the right layer, with nothing said. cv_*() refuse such folds + # through the probe make_folds() records; so does this. + .check_fold_provenance(folds, data_sf, "fold_separation") + + # as.numeric() strips a `units` object to its number in whatever unit it + # was written in, so 20 km became a range of 20 compared against metres. + if (inherits(sac, "units")) + stop("fold_separation(): `sac` must be a plain number in the units of the ", + "CRS the distances are measured in (metres for lon/lat input); got ", + format(sac), ".", call. = FALSE) + sac_val <- if (!is.null(sac)) suppressWarnings(as.numeric(sac)[1L]) else + suppressWarnings(as.numeric(folds$params$sac_range %||% NA_real_)[1L]) + if (!length(sac_val) || !is.finite(sac_val)) sac_val <- NA_real_ + + # A range is a length in the CRS it was measured in. The one the folds + # carry is in the folds' CRS (params$crs), and an estimate_sac_range() + # result records its own; measuring the distances in whatever CRS data_sf + # happened to arrive in compared a metre range with foot distances and + # printed a verdict about leakage that was off by a factor of 3.3. So when + # the range says where it is from, the distances are measured there. A + # bare number says nothing, and stays in data_sf's (projected) units. + rng_crs <- NULL + if (is.finite(sac_val)) { + cr <- if (!is.null(sac)) attr(sac, "crs") + else attr(folds$params$sac_range, "crs") %||% folds$params$crs + cr <- if (is.null(cr)) NULL + else tryCatch(sf::st_crs(cr), error = function(e) NULL) + if (!is.null(cr) && !is.na(cr) && !isTRUE(sf::st_is_longlat(cr))) + rng_crs <- cr + } pts <- data_sf if (!all(sf::st_geometry_type(pts, by_geometry = TRUE) == "POINT")) pts <- coerce_to_points(pts, "auto") - pts <- sf::st_zm(ensure_projected(pts), drop = TRUE, what = "ZM") + pts <- if (is.null(rng_crs)) ensure_projected(pts) else + .transform_or_stamp(pts, rng_crs, what = "data_sf", caller = "fold_separation") + pts <- sf::st_zm(pts, drop = TRUE, what = "ZM") # A distance is only meaningful between finite coordinates. xy <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] @@ -85,10 +138,6 @@ fold_separation <- function(folds, data_sf, sac = NULL) { if (!any(ok)) stop("fold_separation(): `data_sf` has no usable coordinates.", call. = FALSE) - sac_val <- if (!is.null(sac)) suppressWarnings(as.numeric(sac)[1L]) else - suppressWarnings(as.numeric(folds$params$sac_range %||% NA_real_)[1L]) - if (!length(sac_val) || !is.finite(sac_val)) sac_val <- NA_real_ - fold_blocks <- folds$params$fold_blocks unknown <- 0L @@ -102,7 +151,11 @@ fold_separation <- function(folds, data_sf, sac = NULL) { d <- if (length(te) && length(tr)) .nn_dist_to(pts[te, ], pts[tr, ]) else numeric(0) d <- d[is.finite(d)] data.frame( - fold = j, + # A cv_*() result's $folds carries each split's index in the original + # fold list as fold_id, and its fold_metrics are labelled by it. After + # a fold is dropped the list position no longer matches, and labelling + # by position paired each fold's error with another fold's distances. + fold = as.integer(s$fold_id %||% j), n_train = length(tr), n_test = length(te), n_blocks = if (is.list(fold_blocks) && length(fold_blocks) >= j) @@ -122,7 +175,7 @@ fold_separation <- function(folds, data_sf, sac = NULL) { structure(out, class = c("fold_separation", "data.frame"), method = folds$method %||% "supplied splits", sac_range = sac_val, n_unknown_ids = unknown, - crs = sf::st_crs(pts)$input %||% NA_character_) + crs = .fold_crs_label(pts)) } @@ -132,8 +185,15 @@ print.fold_separation <- function(x, ...) { cat(sprintf("Fold separation: %s, %d fold(s), %d held-out point(s)%s\n", attr(x, "method"), nrow(x), sum(x$n_test, na.rm = TRUE), if (is.na(crs)) "" else sprintf(" (%s)", crs))) - if (is.finite(sac)) - cat(sprintf(" autocorrelation range: %s\n", format(sac, digits = 4))) + # The unit of the CRS, not its identifier: "in EPSG:32617 units" named no + # unit. The CRS itself is on the line above. + if (is.finite(sac)) { + unit <- if (is.na(crs)) NA_character_ else .crs_unit_label(crs) + cat(sprintf(" autocorrelation range: %s%s\n", format(sac, digits = 4), + if (is.na(crs)) "" + else if (!is.na(unit)) sprintf(" (in %s, like the distances)", unit) + else sprintf(" (in the units of %s, like the distances)", crs))) + } df <- as.data.frame(x) df$min_dist <- signif(df$min_dist, 4) df$median_dist <- signif(df$median_dist, 4) @@ -166,17 +226,101 @@ print.fold_separation <- function(x, ...) { "(%s), and the closest is %s away. %s"), 100 * share, format(sac, digits = 4), format(signif(closest, 3)), - if (share > 0.5) - paste("Most of the hold-out is inside the range of", - "its own training data, so this score is", - "optimistic: widen the blocks.") - else if (share > 0.1) - paste("A minority leaks, which is the usual price of", - "contiguous blocks at the edges.") - else - paste("Little of the hold-out is within reach of", - "the training data.")), + .fold_separation_advice(attr(x, "method"), share)), width = 74, prefix = " "), sep = "\n") } invisible(x) } + + +#' What to make of the share of the hold-out inside the range, per fold scheme +#' +#' "Widen the blocks" was said of every scheme, including random folds, +#' leave-location-out and buffered LOO, which have no blocks, and NNDM, whose +#' folds are built to reproduce the prediction-to-data distances: a high +#' share there describes how close the prediction points sit to the data, not +#' an optimistic design. +#' @param method The fold method (\code{attr(x, "method")}). +#' @param share The share of held-out points within the range. +#' @return Character(1). +#' @keywords internal +#' @noRd +.fold_separation_advice <- function(method, share) { + method <- if (is.character(method) && length(method) == 1L && !is.na(method)) + method else "supplied splits" + if (share <= 0.1) + return("Little of the hold-out is within reach of the training data.") + if (identical(method, "nndm")) + return(paste("NNDM folds reproduce the distances from the prediction", + "points to the data, so this share describes how close the", + "prediction points themselves sit to the data, not a leak in", + "the design; compare the folds' params$realised_median with", + "params$target_median to check the match.")) + remedy <- switch(method, + block_kfold = "widen the blocks", + buffered_loo = "widen the buffer to at least the range", + "use blocked or buffered folds") + if (share > 0.5) + return(paste0("Most of the hold-out is inside the range of its own ", + "training data, so this score is optimistic: ", remedy, ".")) + if (identical(method, "block_kfold")) + return(paste("A minority leaks, which is the usual price of contiguous", + "blocks at the edges.")) + paste0("A minority leaks; to hold it out, ", remedy, ".") +} + + +#' The linear unit of a CRS, spelt for a sentence +#' +#' From a CRS label as \code{.fold_crs_label()} writes it (an +#' \code{AUTHORITY:CODE}, a proj string or a WKT), through +#' \code{sf::st_crs()$units_gdal}. +#' @param crs A CRS label. +#' @return Character(1), \code{NA} when the unit cannot be read. +#' @keywords internal +#' @noRd +.crs_unit_label <- function(crs) { + u <- tryCatch(suppressWarnings(sf::st_crs(crs)$units_gdal), + error = function(e) NULL) + if (!(is.character(u) && length(u) == 1L && !is.na(u) && nzchar(u))) + return(NA_character_) + switch(u, metre = "metres", kilometre = "kilometres", foot = "feet", + "US survey foot" = "US survey feet", degree = "degrees", u) +} + + +#' Refuse folds built on another layer, as the cv_*() functions do +#' +#' \code{.check_fold_probe()} for the fold consumers that are not +#' \code{cv_*()} (\code{fold_separation()}, \code{kriging_adequacy()}): +#' \code{data_sf} gets \code{..row_id} by position when it has none, as they +#' match fold entries. When the probe was taken on POINT geometry and +#' \code{data_sf} is not, or the reverse, the locations cannot be compared (a +#' polygon's probe point is its centroid, a pointized copy's is whatever +#' point \code{coerce_to_points()} chose), so the check is skipped with an +#' INFO line rather than refusing a layer that works today. A bare split list, +#' a label vector, or folds without a probe pass unchecked. +#' @param folds Whatever the caller was given as \code{folds}. +#' @param data_sf The layer the caller applies them to, as passed. +#' @param caller Name for the messages. +#' @return \code{invisible(NULL)}; called for the error. +#' @keywords internal +#' @noRd +.check_fold_provenance <- function(folds, data_sf, caller) { + probe <- tryCatch(folds$params$row_probe, error = function(e) NULL) + if (is.null(probe) || !inherits(data_sf, "sf") || nrow(data_sf) == 0L) + return(invisible(NULL)) + if (!("..row_id" %in% names(data_sf))) + data_sf$..row_id <- seq_len(nrow(data_sf)) + now_points <- all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT") + if (is.logical(probe$points) && length(probe$points) == 1L && + !is.na(probe$points) && !identical(probe$points, now_points)) { + .log_info(paste0("%s(): the supplied `folds` were built on %s geometry and ", + "this layer has %s geometry, so their row locations cannot ", + "be compared; skipping the provenance check."), + caller, if (probe$points) "POINT" else "non-POINT", + if (now_points) "POINT" else "non-POINT") + return(invisible(NULL)) + } + .check_fold_probe(folds, data_sf, caller) +} diff --git a/R/kriging-adequacy.R b/R/kriging-adequacy.R index 4ae0845..0178edb 100644 --- a/R/kriging-adequacy.R +++ b/R/kriging-adequacy.R @@ -13,19 +13,31 @@ #' having on a given layer is a question with a measurable answer, and this #' function measures it, changing no cell value: for every cell it reports #' the block-kriging estimate and variance implied by a fitted variogram, -#' that variance as a share of the total sill, and, where the cell has points, +#' that variance as a share of the variance the cell's mean would have with +#' no data at all, and, where the cell has points, #' whether it exceeds the design-based variance of the plain mean, #' \eqn{s^2/n}; and it scores the variogram itself by blocked #' cross-validation. #' #' @section Reading the columns: #' \describe{ -#' \item{\code{kr_ratio}}{The block-kriging variance over the total sill, -#' in \eqn{[0, 1]}. It is the coverage score, and it needs no hand-set -#' threshold in metres or point counts: as it approaches 1 the estimate -#' carries almost no information from the data and is reverting to -#' the global mean. A cell at 0.05 is well determined; a cell at 0.8 is -#' mostly prior.} +#' \item{\code{kr_ratio}}{The block-kriging variance over the cell's prior +#' variance, in \eqn{[0, 1]}. The prior variance is the variance the +#' cell's mean would have with no data at all, \eqn{\bar C(B,B)}: the +#' covariance averaged over pairs of points in the cell, on the +#' discretisation \pkg{gstat} block-kriges with, and without the nugget, +#' which averages out over a block (\pkg{gstat} leaves it out of the +#' block variance too). Each cell has its own: a cell's mean varies less +#' than a single point does, and far less once the cell is wider than the +#' range, so the point sill is not the scale. It is the coverage score, +#' and it needs no hand-set threshold in metres or point counts: as it +#' approaches 1 the estimate carries almost no information from the data +#' about the cell and is reverting to the estimated mean. Ordinary +#' kriging adds the variance of that estimated mean, so a cell the data do +#' not reach comes out at or above its prior variance and reads 1. A +#' cell at 0.05 is well determined; a cell at 0.8 is mostly prior. +#' \code{NA} when the model is a pure nugget, where a cell mean has no +#' prior variance to be a share of.} #' \item{\code{kr_exceeds_design}}{\code{TRUE} where the kriging variance is #' larger than \eqn{s^2/n} from the cell's own points: kriging is not #' earning its keep there, and that is said per cell instead of @@ -55,9 +67,14 @@ #' range. To check the nugget, pass random folds #' (\code{make_folds(method = "random_kfold")}) as \code{folds}: the #' held-out points are then close to their neighbours, where the nugget -#' decides the variance. \code{gstat::krige.cv()} computes the statistic on -#' the fold labels \code{\link{make_folds}()} built, so the folds carry the -#' same separation the package uses everywhere else. +#' decides the variance. The statistic is computed fold by fold with +#' \code{gstat::krige()} on the splits \code{\link{make_folds}()} built, each +#' held-out point kriged from that split's own training set, so the folds +#' carry the same separation the package uses everywhere else: +#' \code{"buffered_loo"} and \code{"nndm"} keep the points they exclude +#' around each held-out one out of its kriging, and \code{print()} names the +#' scheme that ran. A vector of fold labels is run as k-fold, each fold +#' kriged from all the others. #' #' @section What it said about block kriging as an aggregator: #' On the same simulated fields, with 16, 36 and 64 square cells: under @@ -79,32 +96,127 @@ #' it is estimated here from the response. The model families are the ones #' the package interprets elsewhere: exponential, spherical and Gaussian #' components with a nugget. Anything else is refused by name. A -#' model whose range was not identified (a bare \code{NA} estimate with the -#' model attached) is used with a warning: its sill was never reached by the -#' data, so the ratios rest on an extrapolation. Requires \pkg{gstat}. +#' model whose range was not identified (an \code{NA} estimate with the +#' model attached) is used with a warning that says why it was refused, and +#' the reason is kept as \code{attr(, "rejected_reason")}: a range past the +#' fitted lags means the sill was never reached and the ratios rest on an +#' extrapolation; a fit that did not converge stopped wherever the optimiser +#' halted; a variogram that falls with distance, or a range below the +#' shortest lag, describes the data poorly at some lags. +#' +#' The model has to be of the response itself. A variogram of residuals +#' (\code{estimate_sac_range(predictor_vars = ...)}, \code{attr(, +#' "detrended")} \code{TRUE}) leaves out the variance the predictors +#' explain, while the response is kriged here without them, so +#' \code{kr_var}, \code{kr_ratio} and the cross-validation statistic come out +#' too small (the statistic at 4.3--5.2 against 0.67--1.53 with a spatially +#' structured covariate); it is used with a warning. The points are put in +#' the CRS the variogram was fitted in (\code{attr(sac, "crs")}), because +#' its range is a length in that CRS's units. Requires \pkg{gstat}. +#' +#' @section The kriging neighbourhood: +#' \pkg{gstat} kriges a cell from the \code{nmax} locations nearest its +#' centre. A cell holding more locations than that would be estimated from +#' its middle alone, which describes the middle rather than the cell (in one +#' simulated case a cell of 1,500 points came out 0.43 off at +#' \code{nmax = 50}, against 0.07 from all of them and 0.02 for its plain +#' mean). So wherever the \code{nmax} locations nearest a cell's centre +#' leave out any of the cell's own locations, the cell is kriged from all of +#' its own locations plus the \code{nmax} nearest outside it; +#' \code{kr_n_used} says how many locations each cell was kriged from. The +#' cost of a kriging system grows with the cube of its size (about 1 s at +#' 2,000 locations and 17 s at 5,000), so a cell that would need more than +#' \code{max_neighbours} is left out with a warning, its \code{kr_} columns +#' \code{NA}. +#' +#' \pkg{gstat} also discretises each cell into 500 points on a regular grid +#' laid over the cell's whole bounding box, keeping those inside, so the +#' memory a cell takes grows with the ratio of that box to its area: about +#' 54 MB more for a thin diagonal strip at a ratio of 708, and 592 MB at +#' 7,072. A cell whose bounding box exceeds its area more than +#' \code{max_box_ratio} times (a sliver, parts far apart, a cell that is +#' mostly hole) is left out the same way. \code{attr(, "cells_left_out")} +#' counts both kinds, and \code{print()} says how many cells have no +#' estimate and why. +#' +#' @section Repeat measurements at one location: +#' Two observations at the same coordinates (visits to a station, records +#' geocoded to one address) make a kriging system singular, because +#' \pkg{gstat} gives them the full sill, nugget included, as their +#' covariance, as if they were one observation. The kriging and its +#' cross-validation therefore use one observation per location, the mean of +#' its replicates, with a warning; \code{n} and \code{mean} still count every +#' point. How much of the nugget \eqn{c_0} a mean of \eqn{m} replicates +#' keeps is read off the replicates: their pooled within-location variance +#' \eqn{s_w^2}, capped at \eqn{c_0}, is the part that differs from visit to +#' visit and averages down, and the rest is micro-scale variation the visits +#' share, so the mean carries error variance \eqn{c_0 - s_w^2 + s_w^2/m}. +#' That goes to \pkg{gstat} as a known measurement error (its +#' \code{weights}) on the model with the nugget set to zero. For replicates +#' that differ only by measurement error this is exactly the kriging of every +#' observation, and for identical replicates it is the kriging of one; a +#' location seen once is kriged as before. In the cross-validation a +#' location is held out whole, under the fold of its first row, and its +#' error variance is part of its standardised error. A cell or held-out +#' location \pkg{gstat} still cannot krige is reported \code{NA} with a +#' warning, and \code{print()} says how many. #' #' @param assigned_points_sf Points with a cell identifier column, as #' \code{\link{assign_features_to_polygons}()} returns. #' @param response_var The response column. -#' @param cells_sf The cell polygons, with the matching ID column. -#' @param id_col Preferred name of the ID column. Default \code{"poly_id"}. +#' @param cells_sf The cell polygons, with the matching ID column. A layer +#' with no CRS is taken to be in the points' CRS (and points with none in +#' the cells'), with a warning. +#' @param id_col Preferred name of the ID column, found as +#' \code{\link{summarize_by_cell}()} finds it: on the points the first of +#' \code{id_col}, \code{"poly_id"}, \code{"polygon_id"} and +#' \code{"cell_id"}; on the cells the first of that column, +#' \code{"poly_id"}, \code{"polygon_id"}, \code{"id"}, \code{"cell_id"} +#' and \code{"grid_id"}. IDs are matched as text, whole numbers written +#' out in full, so a double \code{1e5} matches an integer \code{100000}; +#' a point whose ID matches no cell is counted in no cell, with a +#' warning. Default \code{"poly_id"}. #' @param sac Optional \code{sac_range} carrying a variogram model. #' @param folds Optional \code{\link{make_folds}()} result on #' \code{assigned_points_sf} for the cross-validation statistic; built here -#' with \code{block_kfold} when \code{NULL}. +#' with \code{block_kfold} when \code{NULL}. As in \code{cv_*()}, folds +#' whose recorded rows sit at other locations in +#' \code{assigned_points_sf} (built on another layer, such as the points +#' before \code{\link{assign_features_to_polygons}()} dropped some) are +#' refused. #' @param k,seed Folds and seed for that construction. -#' @param nmax The largest number of neighbours each kriging system uses -#' (\code{gstat}'s \code{nmax}). Default 50. +#' @param nmax The number of neighbours each kriging system uses +#' (\code{gstat}'s \code{nmax}): the locations nearest the cell's centre, +#' or, for a cell those leave some of its own locations out of, all of its +#' own plus this many outside it (see "The kriging neighbourhood"). The +#' cross-validation kriges each held-out point from its \code{nmax} nearest +#' training locations. Default 50. +#' @param max_neighbours The largest kriging system a cell is given when its +#' neighbourhood has to grow to hold all its own locations; a cell that +#' would need more is left out (\code{kr_} columns \code{NA}) with a +#' warning. Never below \code{nmax}. Default 2000. +#' @param max_box_ratio A cell whose bounding box is more than this many +#' times its area is left out (\code{kr_} columns \code{NA}) with a +#' warning, because \pkg{gstat}'s discretisation of it costs memory in +#' proportion. Default 1000. #' @param quiet Suppress progress messages. Default \code{TRUE}. #' @return An \code{sf} object of class \code{"kriging_adequacy"}, one row #' per cell with the cell geometry and: the ID column, \code{n} (points in #' the cell), \code{mean} (the plain mean), \code{se} (its naive standard #' error), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, -#' \code{kr_exceeds_design} and \code{kr_shift}. Attributes: +#' \code{kr_exceeds_design}, \code{kr_shift} and \code{kr_n_used} (how many +#' locations the cell was kriged from; \code{NA} for a cell left out). +#' Attributes: #' \code{variogram} (the model frame), \code{sill}, \code{nugget}, -#' \code{range}, \code{range_identified}, \code{cv} (a list: +#' \code{range}, \code{range_identified}, \code{rejected_reason} (why the +#' range was refused, from \code{sac}; \code{NA} when it was identified), +#' \code{cv} (a list: #' \code{zscore_var}, \code{zscore_mean}, \code{rmse}, \code{n_pred}, -#' \code{k}, \code{method}), \code{nmax} and \code{n_points}. +#' \code{k}, \code{method}), \code{nmax}, \code{n_points} (the points +#' used), \code{n_locations} (the distinct locations among them, which +#' the kriging used) and \code{cells_left_out} (counts of cells left out, +#' named \code{shape} for \code{max_box_ratio} and \code{size} for +#' \code{max_neighbours}). #' @references #' Cressie, N. (1993). \emph{Statistics for Spatial Data}, revised edition. #' Wiley. (Block kriging, chapter 3; cross-validation of the kriging @@ -130,7 +242,9 @@ #' @export kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, id_col = "poly_id", sac = NULL, folds = NULL, - k = 5L, seed = 123L, nmax = 50L, quiet = TRUE) { + k = 5L, seed = 123L, nmax = 50L, + max_neighbours = 2000L, max_box_ratio = 1000, + quiet = TRUE) { .msg <- function(...) if (!quiet) message(...) if (!requireNamespace("gstat", quietly = TRUE)) stop("kriging_adequacy(): package 'gstat' is required.", call. = FALSE) @@ -146,23 +260,78 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, stop("kriging_adequacy(): `nmax` must be a single positive number.", call. = FALSE) # --- the ID column, as summarize_by_cell() finds it --- - id_candidates <- unique(c(id_col, "poly_id", "polygon_id", "cell_id")) - id_pts <- id_candidates[id_candidates %in% names(assigned_points_sf)] - id_cells <- id_candidates[id_candidates %in% names(cells_sf)] - if (!length(id_pts) || !length(id_cells)) - stop("kriging_adequacy(): could not find a cell ID column in both layers. ", - "Looked for: ", paste(id_candidates, collapse = ", "), ".", call. = FALSE) - id_pts <- id_pts[[1L]]; id_cells <- id_cells[[1L]] + # The same candidates in the same order: on the points the columns + # assign_features_to_polygons() writes, and on the cells, after the points' + # own column, every one it reads the polygons' IDs from. Cells keyed by + # 'id' or 'grid_id' were refused here while summarize_by_cell() joined them. + pts_candidates <- unique(c(id_col, "poly_id", "polygon_id", "cell_id")) + id_pts <- pts_candidates[pts_candidates %in% names(assigned_points_sf)] + if (!length(id_pts)) + stop("kriging_adequacy(): could not find a cell ID column in ", + "`assigned_points_sf`. Looked for: ", + paste(pts_candidates, collapse = ", "), ".", call. = FALSE) + id_pts <- id_pts[[1L]] + cells_candidates <- unique(c(id_pts, "poly_id", "polygon_id", "id", "cell_id", + "grid_id")) + id_cells <- cells_candidates[cells_candidates %in% names(cells_sf)] + if (!length(id_cells)) + stop("kriging_adequacy(): could not find a cell ID column in `cells_sf`. ", + "Looked for: ", paste(cells_candidates, collapse = ", "), ".", + call. = FALSE) + id_cells <- id_cells[[1L]] + + if (!is.numeric(max_neighbours) || length(max_neighbours) != 1L || + !is.finite(max_neighbours) || max_neighbours < 1) + stop("kriging_adequacy(): `max_neighbours` must be a single positive number.", call. = FALSE) + if (!is.numeric(max_box_ratio) || length(max_box_ratio) != 1L || + is.na(max_box_ratio) || max_box_ratio < 1) + stop("kriging_adequacy(): `max_box_ratio` must be a single number of at least 1.", + call. = FALSE) + + # Folds are row IDs, matched by position on a layer without `..row_id`. + # Built on prep_model_data()'s points and applied to the fewer that + # assign_features_to_polygons() kept, they held out the wrong points (RMSE + # 1.82 against 2.11 with folds built here) with nothing said, while cv_*() + # refuse the same folds through the probe make_folds() records. Checked on + # the layer as passed, before anything is moved or pointized. + .check_fold_provenance(folds, assigned_points_sf, "kriging_adequacy") # --- geometry: projected points, cells in the same CRS --- + # A layer with no CRS is taken to be in the other's, as passed and before + # anything is moved: the points were assigned to these cells, so they share + # a coordinate space. .align_crs() leaves a CRS-less layer as it is, and + # gstat::krige() then failed on the mismatch with an internal assertion. pts <- assigned_points_sf + cells_in <- cells_sf + pts_na <- is.na(sf::st_crs(pts)) + cells_na <- is.na(sf::st_crs(cells_in)) + if (cells_na && !pts_na) + cells_in <- .transform_or_stamp(cells_in, sf::st_crs(pts), what = "cells_sf", + caller = "kriging_adequacy") + else if (pts_na && !cells_na) + pts <- .transform_or_stamp(pts, sf::st_crs(cells_in), + what = "assigned_points_sf", + caller = "kriging_adequacy") if (!all(sf::st_geometry_type(pts, by_geometry = TRUE) == "POINT")) pts <- coerce_to_points(pts, "auto") - pts <- ensure_projected(pts) + # A supplied variogram's range is a length in the CRS it was fitted in, so + # the points go into that CRS, as summarize_by_cell() puts them. Projected + # anew here instead, a sac fitted in metres met points in km (or US feet) + # with nothing said: the variance CV statistic came out at 3.05 against 0.85. + sac_crs <- if (!is.null(sac)) attr(sac, "crs") else NULL + pts <- if (inherits(sac_crs, "crs") && !is.na(sac_crs)) + .transform_or_stamp(pts, sac_crs, what = "assigned_points_sf", + caller = "kriging_adequacy") + else ensure_projected(pts) # Row identities survive the completeness filter below, so folds built on # the layer as passed (or here, on the kept rows) map back by `..row_id`. if (!("..row_id" %in% names(pts))) pts$..row_id <- seq_len(nrow(pts)) - cells <- .align_crs(cells_sf, pts) + # Both without a CRS, and the points put in the variogram's: the cells + # follow them the same way. + cells <- if (is.na(sf::st_crs(cells_in)) && !is.na(sf::st_crs(pts))) + .transform_or_stamp(cells_in, sf::st_crs(pts), what = "cells_sf", + caller = "kriging_adequacy") + else .align_crs(cells_in, pts) cells <- .safe_make_valid(cells) z <- suppressWarnings(as.numeric(sf::st_drop_geometry(pts)[[response_var]])) ok <- is.finite(z) & !sf::st_is_empty(pts) @@ -176,14 +345,25 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, kp$..z <- z[ok] # --- the variogram model --- - if (is.null(sac)) { + sac_supplied <- !is.null(sac) + if (!sac_supplied) { .msg("kriging_adequacy(): estimating the variogram of ", response_var, " ...") sac <- estimate_sac_range(kp, "..z", seed = seed) } vm <- attr(sac, "variogram_model") - if (is.null(vm) || !is.data.frame(vm)) - stop("kriging_adequacy(): `sac` carries no variogram model (estimate_sac_range() ", - "returned a bare NA), so there is nothing to krige with.", call. = FALSE) + if (is.null(vm) || !is.data.frame(vm)) { + # Why there is none: a classed refusal says (both fits singular), and a + # bare NA is a run that could fit nothing. Blaming `sac` when none was + # passed sent the user looking at an argument they had not used. + why <- attr(sac, "rejected_reason") + why <- if (is.character(why) && length(why) == 1L && !is.na(why)) why + else "estimate_sac_range() returned a bare NA" + stop(sprintf(paste0("kriging_adequacy(): %s carries no variogram model, so ", + "there is nothing to krige with: %s."), + if (sac_supplied) "`sac`" + else sprintf("the variogram estimated here from '%s'", response_var), + why), call. = FALSE) + } fam <- as.character(vm$model) bad_fam <- setdiff(fam, c("Nug", "Exp", "Sph", "Gau")) if (length(bad_fam)) @@ -196,28 +376,170 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, if (!is.finite(sill) || sill <= 0) stop("kriging_adequacy(): the variogram model has no positive sill.", call. = FALSE) range_identified <- is.finite(suppressWarnings(as.numeric(sac))) + # Why the range was refused, kept on the result: "sill never reached" was + # said of every refusal, and a non-converged fit, a variogram that falls + # with distance and one that runs past the fitted lags are different + # findings about the model the variances rest on. + rejected_reason <- if (range_identified) NA_character_ else + as.character(attr(sac, "rejected_reason") %||% "no effective range")[1L] if (!range_identified) .warn_and_log(paste0("kriging_adequacy(): the variogram's range was not ", - "identified (%s), so its sill was never reached by the ", - "data; the kriging variances and ratios rest on an ", - "extrapolated model."), - attr(sac, "rejected_reason") %||% "no effective range") + "identified (%s), so the model the kriging variances ", + "and ratios rest on is one the data did not pin down."), + rejected_reason) + # A variogram of residuals on predictors describes what the predictors left + # over, and it is the response itself that is kriged here, with no + # predictors: the variance they explained is missing from the model. + # Measured with a spatially structured covariate: the variance of the + # standardised CV errors went from 0.67-1.53 to 4.3-5.2, and no cell was + # flagged as kriging worse than its plain mean where 2-7 had been. + if (isTRUE(attr(sac, "detrended"))) + .warn_and_log(paste0("kriging_adequacy(): `sac` is the variogram of the ", + "residuals on predictors (detrend = \"%s\"), but the ", + "response itself is kriged here, without them; the ", + "variance they explain is missing from the model, so ", + "kr_var, kr_ratio and the cross-validation statistic ", + "understate the uncertainty. Pass a variogram of the ", + "response (estimate_sac_range() without predictor_vars) ", + "or sac = NULL."), + as.character(attr(sac, "detrend_method") %||% "ols")[1L]) + + # --- one observation per location for the kriging systems --- + # gstat gives two observations at distance zero the full sill, nugget + # included, as their covariance, as if they were one, so repeat visits to a + # station make every kriging system holding them singular, and gstat + # returns NA and says so only at debug.level > 0. Each location is kriged + # from the mean of its replicates instead (the plain cell means below still + # use every point). The replicates say how much of the nugget that mean + # keeps: their pooled within-location variance is the part that differs + # between visits (capped at the nugget) and averages down by the count; the + # rest is micro-scale variation the visits share. That goes to gstat as a + # known measurement error (`weights` = 1 / variance) on the model with its + # nugget zeroed: a location seen once gets the whole nugget, as before; + # replicates differing only by measurement error give the kriging of every + # observation; identical replicates give the kriging of one. + xy <- sf::st_coordinates(kp)[, 1:2, drop = FALSE] + key <- paste(xy[, 1], xy[, 2]) + loc <- match(key, unique(key)) + first <- !duplicated(loc) + kk <- kp[first, , drop = FALSE] + vk <- vm + w <- NULL + err_var <- rep(0, nrow(kk)) # already in vk's nugget when w is NULL + if (any(!first)) { + m_loc <- tabulate(loc) + kk$..z <- as.numeric(rowsum(kp$..z, loc)) / m_loc + me <- min(sum((kp$..z - kk$..z[loc])^2) / sum(m_loc - 1L), nugget) + err_var <- nugget - me + me / m_loc + vk$psill[fam == "Nug"] <- 0 + w <- 1 / err_var + .warn_and_log(paste0("kriging_adequacy(): %d point(s) share a location with another; ", + "kriging from the mean at each of the %d distinct locations, with ", + "the part of the nugget that differs between replicates (%.3g of ", + "%.3g) divided by their count."), + sum(m_loc[loc] > 1L), nrow(kk), me, nugget) + } + + # summarize_by_cell()'s conversion: as.character() writes a double from 1e5 + # on as "1e+05", so every such point missed its integer-keyed cell and the + # cell came back with n = 0, no plain mean, and a kriging neighbourhood + # without its own points. Said, not silent, when an ID still matches no + # cell, as summarize_by_cell() says it. + ids_pts <- .id_as_character(sf::st_drop_geometry(kp)[[id_pts]]) + ids_cells <- .id_as_character(sf::st_drop_geometry(cells)[[id_cells]]) + unmatched <- !is.na(ids_pts) & !(ids_pts %in% ids_cells) + if (any(unmatched)) + .warn_and_log(paste0("kriging_adequacy(): %d of the %d point(s) with a cell ID ", + "carry one that matches no `cells_sf$%s` (%s), so they ", + "are in no cell's n, mean or se, though the kriging still ", + "uses them. Check that `cells_sf` is the layer the points ", + "were assigned to."), + sum(unmatched), sum(!is.na(ids_pts)), id_cells, + paste(utils::head(unique(ids_pts[unmatched]), 5L), collapse = ", ")) + + # --- cells gstat cannot discretise at a bounded cost --- + # gstat discretises a polygon block with spsample(n = 500, type = + # "regular"), which lays its grid over the feature's whole bounding box and + # keeps the points inside, so the memory it takes grows with the ratio of + # that box to the cell's area: +54 MB for a diagonal strip at 708, +592 MB + # at 7,072, and gigabytes beyond. A sliver, a multi-part cell with parts + # far apart or a cell that is mostly hole is left out instead, and counted. + box_ratio <- .cell_box_ratio(cells) + sliver <- !(is.finite(box_ratio) & box_ratio <= max_box_ratio) + if (any(sliver)) + .warn_and_log(paste0("kriging_adequacy(): %d cell(s) left out (kr_ columns NA): ", + "the bounding box of each is more than max_box_ratio = %s ", + "times its area (up to %s), and gstat discretises a block ", + "over its whole bounding box, at a memory cost in proportion."), + sum(sliver), format(max_box_ratio), + format(signif(max(box_ratio[sliver]), 3))) + + # --- each cell's kriging neighbourhood --- + # gstat takes the nmax locations nearest a block's centre, so a cell holding + # more than that was kriged from its middle alone: one 60 km cell of 1,500 + # points came out 0.43 off at nmax = 50 against 0.07 from all of them, and + # the plain mean it is compared with was 0.02 off. Where the nmax nearest + # the centre leave out any of the cell's own locations, it is kriged from + # all of them plus the nmax nearest outside it; elsewhere gstat's own + # neighbourhood is used unchanged. + cap <- max(as.integer(max_neighbours), as.integer(nmax)) + loc_cell <- match(ids_pts[first], ids_cells) + nb <- .cell_neighbourhoods(cells, kk, loc_cell, as.integer(nmax), cap, skip = sliver) + if (any(nb$enlarged)) + .log_info(paste0("kriging_adequacy(): %d cell(s) hold locations the nmax = %d ", + "nearest their centre leave out; each is kriged from all of its ", + "own locations plus the nmax nearest outside it (largest ", + "system: %d)."), + sum(nb$enlarged), as.integer(nmax), max(nb$n_used[nb$enlarged])) + if (any(nb$too_big)) + .warn_and_log(paste0("kriging_adequacy(): %d cell(s) left out (kr_ columns NA): ", + "kriging one from all of its own locations plus the nmax ", + "nearest outside it takes a system of up to %d, above ", + "max_neighbours = %d (the cost grows with the cube of the ", + "size). Raise max_neighbours to krige them."), + sum(nb$too_big), max(nb$size[nb$too_big]), cap) # --- block kriging onto the cells --- .msg("kriging_adequacy(): block kriging onto ", nrow(cells), " cells ...") - bk <- tryCatch( - gstat::krige(..z ~ 1, locations = kp, newdata = cells, model = vm, - nmax = as.integer(nmax), debug.level = 0), - error = function(e) - stop("kriging_adequacy(): gstat::krige() failed: ", conditionMessage(e), - call. = FALSE)) - kr_pred <- suppressWarnings(as.numeric(bk$var1.pred)) - kr_var <- suppressWarnings(as.numeric(bk$var1.var)) + .krige_cells <- function(loc, nd, wt, nmx) + tryCatch( + gstat::krige(..z ~ 1, locations = loc, newdata = nd, model = vk, + weights = wt, nmax = nmx, debug.level = 0), + error = function(e) + stop("kriging_adequacy(): gstat::krige() failed: ", conditionMessage(e), + call. = FALSE)) + kr_pred <- kr_var <- rep(NA_real_, nrow(cells)) + batch <- !sliver & !nb$enlarged & !nb$too_big + if (any(batch)) { + bk <- .krige_cells(kk, cells[batch, , drop = FALSE], w, as.integer(nmax)) + kr_pred[batch] <- suppressWarnings(as.numeric(bk$var1.pred)) + kr_var[batch] <- suppressWarnings(as.numeric(bk$var1.var)) + } + for (ci in which(nb$enlarged)) { + s <- nb$sel[[ci]] + bk <- .krige_cells(kk[s, , drop = FALSE], cells[ci, , drop = FALSE], w[s], Inf) + kr_pred[ci] <- suppressWarnings(as.numeric(bk$var1.pred)) + kr_var[ci] <- suppressWarnings(as.numeric(bk$var1.var)) + } kr_var[is.finite(kr_var) & kr_var < 0] <- 0 + # gstat answers a system it cannot solve with NA and, at debug.level 0, + # nothing else. + kriged <- batch | nb$enlarged + n_na <- sum(kriged & (!is.finite(kr_pred) | !is.finite(kr_var))) + if (n_na) + .warn_and_log(paste0("kriging_adequacy(): gstat::krige() returned no estimate for %d ", + "of %d cell(s) (a kriging system it could not solve); their ", + "kr_ columns are NA."), n_na, sum(kriged)) + # The scale for kr_ratio. kr_var is the variance of a cell MEAN, and with + # no data it levels off at the cell's own C(B,B), not at the point sill: + # divided by the sill, an empty cell far from every datum read about 0.1, + # and a large empty cell ranked below small populated ones. Not computed + # for a sliver, whose discretisation is what it was left out to avoid. + prior_var <- rep(NA_real_, nrow(cells)) + if (any(!sliver)) + prior_var[!sliver] <- .block_prior_var(cells[!sliver, , drop = FALSE], vm) # --- the plain means and their design-based variance, per cell --- - ids_pts <- as.character(sf::st_drop_geometry(kp)[[id_pts]]) - ids_cells <- as.character(sf::st_drop_geometry(cells)[[id_cells]]) n_c <- as.integer(table(factor(ids_pts, levels = ids_cells))) m_c <- tapply(kp$..z, factor(ids_pts, levels = ids_cells), mean) v_c <- tapply(kp$..z, factor(ids_pts, levels = ids_cells), stats::var) @@ -231,34 +553,51 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, out$se <- se_c out$kr_pred <- kr_pred out$kr_var <- kr_var - out$kr_ratio <- pmin(pmax(kr_var / sill, 0), 1) + out$kr_ratio <- ifelse(prior_var > 0, pmin(pmax(kr_var / prior_var, 0), 1), NA_real_) out$kr_exceeds_design <- ifelse(is.finite(s2_n), kr_var > s2_n, NA) out$kr_shift <- ifelse(is.finite(se_c) & se_c > 0, (kr_pred - out$mean) / se_c, NA_real_) + out$kr_n_used <- nb$n_used + # --- the cross-validation statistic --- if (is.null(folds)) { folds <- make_folds(kp, k = k, method = "block_kfold", seed = seed) - fold_vec <- folds$assignment$fold[match(kp$..row_id, folds$assignment$row_id)] method <- "block_kfold" } else { - fold_vec <- .fold_labels_for(folds, kp) method <- if (is.list(folds) && !is.null(folds$method)) folds$method else "supplied labels" } + # One split per fold, in locations: the ones held out, and the ones they are + # kriged from. A make_folds() result is run on its own training sets, which + # for buffered_loo and nndm leave out the points around each held-out one; + # reduced to fold labels, as they were, both ran as plain leave-one-out + # (a 250 m buffer: variance 1.02 and RMSE 0.757, identical to 1:n, against + # 0.873 and 0.944 with the buffer kept). + splits <- .location_splits(folds, kp, first) + held <- sort(unique(unlist(lapply(splits, `[[`, "test"), use.names = FALSE))) cv <- list(zscore_var = NA_real_, zscore_mean = NA_real_, rmse = NA_real_, - n_pred = 0L, k = length(unique(fold_vec[is.finite(fold_vec)])), - method = method) - keep <- is.finite(fold_vec) - if (sum(keep) >= 10L && cv$k >= 2L) { + n_pred = 0L, k = length(splits), method = method) + if (length(held) >= 10L && cv$k >= 2L) { .msg("kriging_adequacy(): cross-validating the kriging variance over ", cv$k, " folds ...") - kcv <- tryCatch( - gstat::krige.cv(..z ~ 1, kp[keep, , drop = FALSE], model = vm, - nfold = fold_vec[keep], nmax = as.integer(nmax), - debug.level = 0, verbose = FALSE), - error = function(e) { - .log_warn("kriging_adequacy(): gstat::krige.cv() failed (%s); no cross-validation statistic.", - conditionMessage(e)) - NULL - }) + # The folds are run here rather than by gstat::krige.cv(), which subsets + # the data per fold but not `weights`. With the nugget zeroed in vk, a + # held-out location's own error variance goes back into its variance. + kcv <- tryCatch({ + pred <- pvar <- rep(NA_real_, nrow(kk)) + for (s in splits) { + if (!length(s$train)) next + kf <- gstat::krige(..z ~ 1, locations = kk[s$train, , drop = FALSE], + newdata = kk[s$test, , drop = FALSE], model = vk, + weights = w[s$train], nmax = as.integer(nmax), debug.level = 0) + pred[s$test] <- suppressWarnings(as.numeric(kf$var1.pred)) + pvar[s$test] <- suppressWarnings(as.numeric(kf$var1.var)) + err_var[s$test] + } + data.frame(residual = kk$..z[held] - pred[held], + zscore = suppressWarnings((kk$..z[held] - pred[held]) / sqrt(pvar[held]))) + }, error = function(e) { + .log_warn(paste0("kriging_adequacy(): gstat::krige() failed in cross-validation (%s); ", + "no cross-validation statistic."), conditionMessage(e)) + NULL + }) if (!is.null(kcv)) { zs <- suppressWarnings(as.numeric(kcv$zscore)); zs <- zs[is.finite(zs)] res <- suppressWarnings(as.numeric(kcv$residual)); res <- res[is.finite(res)] @@ -266,6 +605,11 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, cv$zscore_mean <- if (length(zs)) mean(zs) else NA_real_ cv$rmse <- if (length(res)) sqrt(mean(res^2)) else NA_real_ cv$n_pred <- length(zs) + if (cv$n_pred < length(held)) + .warn_and_log(paste0("kriging_adequacy(): gstat::krige() returned no cross-validation ", + "prediction it could use for %d of %d held-out location(s); ", + "the statistic uses the other %d."), + length(held) - cv$n_pred, length(held), cv$n_pred) } } else { .log_warn("kriging_adequacy(): too few points or folds for the cross-validation statistic.") @@ -275,12 +619,135 @@ kriging_adequacy <- function(assigned_points_sf, response_var, cells_sf, variogram = vm, sill = sill, nugget = nugget, range = suppressWarnings(as.numeric(sac)), range_identified = range_identified, + rejected_reason = rejected_reason, cv = cv, nmax = as.integer(nmax), n_points = nrow(kp), + n_locations = nrow(kk), + cells_left_out = c(shape = sum(sliver), size = sum(nb$too_big)), response_var = response_var, class = c("kriging_adequacy", class(out))) } +#' The whole feature's bounding-box area over its net area, per cell +#' +#' What gstat's polygon discretisation costs in proportion to: +#' spsample(type = "regular") lays its grid over the feature's bounding box +#' and keeps the points inside, as sp computes it (the box of all parts +#' together, holes subtracted from the area). Inf for a cell with no area. +#' @keywords internal +#' @noRd +.cell_box_ratio <- function(cells) { + g <- sf::st_geometry(cells) + a <- suppressWarnings(as.numeric(sf::st_area(g))) + box <- vapply(g, function(x) { + b <- sf::st_bbox(x) + as.numeric((b[["xmax"]] - b[["xmin"]]) * (b[["ymax"]] - b[["ymin"]])) + }, numeric(1)) + ifelse(is.finite(a) & a > 0, box / a, Inf) +} + + +#' Which locations each cell is block-kriged from +#' +#' gstat takes the `nmax` locations nearest a block's centre (the polygon's +#' label point, sp::coordinates(), which is what predict.gstat() hands it). +#' A cell whose own locations all fall among those keeps that neighbourhood +#' and is kriged in the one batch call. One that holds a location the +#' neighbourhood leaves out is marked `enlarged` and gets `sel`: all of its +#' own locations plus the `nmax` nearest outside it; `too_big` when that +#' exceeds `cap`. `n_used` is the neighbourhood size per cell, NA for a cell +#' left out; `size` the system an enlarged or too-big cell needs. +#' @keywords internal +#' @noRd +.cell_neighbourhoods <- function(cells, kk, loc_cell, nmax, cap, skip) { + nc <- nrow(cells); nl <- nrow(kk) + n_used <- ifelse(skip, NA_integer_, min(nmax, nl)) + enlarged <- too_big <- rep(FALSE, nc) + size <- rep(NA_integer_, nc) + sel <- vector("list", nc) + own_of <- split(seq_len(nl), factor(loc_cell, levels = seq_len(nc))) + todo <- which(!skip & lengths(own_of) > 0L) + if (!length(todo)) return(list(n_used = n_used, enlarged = enlarged, + too_big = too_big, size = size, sel = sel)) + cen <- sp::coordinates(sf::as_Spatial(sf::st_set_crs( + sf::st_geometry(cells)[todo], sf::NA_crs_))) + xy <- sf::st_coordinates(kk)[, 1:2, drop = FALSE] + for (j in seq_along(todo)) { + ci <- todo[j]; own <- own_of[[ci]] + d <- sqrt((xy[, 1] - cen[j, 1])^2 + (xy[, 2] - cen[j, 2])^2) + # gstat's nmax nearest already hold every location of the cell. + if (sum(d <= max(d[own])) <= nmax) next + n_out <- min(nmax, nl - length(own)) + size[ci] <- length(own) + n_out + if (size[ci] > cap) { + too_big[ci] <- TRUE; n_used[ci] <- NA_integer_ + next + } + d[own] <- Inf + sel[[ci]] <- c(own, order(d)[seq_len(n_out)]) + enlarged[ci] <- TRUE; n_used[ci] <- size[ci] + } + list(n_used = n_used, enlarged = enlarged, too_big = too_big, size = size, sel = sel) +} + + +#' Cross-validation splits in locations, from any fold shape the package accepts +#' +#' Row indices into `kk` (one row per distinct location, `first` marking the +#' first row of each location in `pts`). A make_folds() result keeps its own +#' train sets, which for buffered_loo and nndm are not the complement of the +#' test set; fold labels become k-fold splits. A location is held out under +#' its first row and never trains the split it is held out in. Splits with +#' nothing held out are dropped. +#' @keywords internal +#' @noRd +.location_splits <- function(folds, pts, first) { + rid <- pts$..row_id[first] + is_split <- function(s) is.list(s) && !is.null(s$train) && !is.null(s$test) + sp <- if (is.list(folds) && is.list(folds$folds) && length(folds$folds) && + all(vapply(folds$folds, is_split, logical(1)))) { + lapply(folds$folds, function(s) { + te <- which(rid %in% s$test) + list(train = setdiff(which(rid %in% s$train), te), test = te) + }) + } else { + lab <- .fold_labels_for(folds, pts)[first] + ok <- which(is.finite(lab)) + lapply(unique(lab[ok]), function(f) + list(train = ok[lab[ok] != f], test = ok[lab[ok] == f])) + } + Filter(function(s) length(s$test) > 0L, sp) +} + + +#' The variance each cell's mean has with no data, \eqn{\bar C(B,B)} +#' +#' The covariance averaged over all pairs of points of the cell, on the +#' discretisation gstat's predict() gives a polygon (its default `sps.args`: +#' spsample(n = 500, type = "regular", offset = c(0.5, 0.5))), and without +#' the nugget, which gstat leaves out of block-to-block covariances. This is +#' the block-kriging variance of a cell no datum informs, before ordinary +#' kriging adds the variance of the estimated mean. 0 for a pure nugget. +#' @keywords internal +#' @noRd +.block_prior_var <- function(cells, vm) { + sv <- vm[as.character(vm$model) != "Nug", , drop = FALSE] + c0 <- sum(sv$psill) + if (!nrow(sv) || !(c0 > 0)) return(rep(0, nrow(cells))) + geo <- sf::as_Spatial(sf::st_set_crs(sf::st_geometry(cells), sf::NA_crs_)) + vapply(seq_along(geo), function(i) { + g <- sp::coordinates(sp::spsample(geo[i], n = 500, type = "regular", + offset = c(0.5, 0.5))) + m <- nrow(g) + if (m < 2L) return(c0) + # Each pair once from dist(), both orders, plus the m zero-distance pairs. + cv <- gstat::variogramLine(sv, dist_vector = as.numeric(stats::dist(g)), + covariance = TRUE)$gamma + (2 * sum(cv) + m * c0) / m^2 + }, numeric(1)) +} + + #' Fold labels for a layer, from any of the fold shapes the package accepts #' @keywords internal #' @noRd @@ -316,18 +783,45 @@ print.kriging_adequacy <- function(x, ...) { } df <- sf::st_drop_geometry(x) cv <- attr(x, "cv") - cat(sprintf("Block-kriging adequacy over %d cells (%d points, nmax %d)\n", - nrow(df), attr(x, "n_points"), attr(x, "nmax"))) + n_loc <- attr(x, "n_locations") %||% attr(x, "n_points") + pts_word <- if (n_loc < attr(x, "n_points")) "locations" else "points" + cat(sprintf("Block-kriging adequacy over %d cells (%d points%s, nmax %d)\n", + nrow(df), attr(x, "n_points"), + if (pts_word == "locations") sprintf(" at %d distinct locations", n_loc) else "", + attr(x, "nmax"))) vm <- attr(x, "variogram", exact = TRUE) cat(sprintf(" variogram: %s; sill %.3g, nugget %.3g (%.0f%%), range %s\n", paste(sprintf("%s(%.3g, %.3g)", vm$model, vm$psill, vm$range), collapse = " + "), attr(x, "sill"), attr(x, "nugget"), 100 * attr(x, "nugget") / attr(x, "sill"), if (isTRUE(attr(x, "range_identified"))) - sprintf("%.1f", attr(x, "range")) else "not identified")) + sprintf("%.1f", attr(x, "range")) + else if (is.character(attr(x, "rejected_reason")) && + !is.na(attr(x, "rejected_reason"))) + sprintf("not identified (%s)", attr(x, "rejected_reason")) + else "not identified")) + # Every line below counts only the cells with an estimate, so say first + # how many have none, and why: left out by shape or size, or unsolved. + kr_ok <- is.finite(df$kr_pred) & is.finite(df$kr_var) + if (!all(kr_ok)) { + lo <- attr(x, "cells_left_out") + n_shape <- if (length(lo) && !is.na(lo["shape"])) lo[["shape"]] else 0L + n_size <- if (length(lo) && !is.na(lo["size"])) lo[["size"]] else 0L + n_unsolved <- sum(!kr_ok) - n_shape - n_size + why <- c(if (n_shape) sprintf("%d left out as too thin or scattered for their bounding box", n_shape), + if (n_size) sprintf("%d left out as holding more locations than max_neighbours", n_size), + if (n_unsolved > 0L) { + if (n_shape + n_size) sprintf("%d whose kriging system gstat could not solve", + n_unsolved) + else "gstat could not solve their kriging systems" + }) + cat(sprintf(" no kriged estimate for %d of the %d cells (%s)\n", + sum(!kr_ok), nrow(df), paste(why, collapse = "; "))) + } r <- df$kr_ratio[is.finite(df$kr_ratio)] if (length(r)) - cat(sprintf(" kriging variance / sill: median %.3f, range %.3f-%.3f; %d cell(s) above 0.5\n", + cat(sprintf(paste0(" kriging variance / no-data variance of the cell mean (1 = nothing ", + "from the data): median %.3f, range %.3f-%.3f; %d cell(s) above 0.5\n"), stats::median(r), min(r), max(r), sum(r > 0.5))) pop <- df[is.finite(df$kr_exceeds_design), , drop = FALSE] if (nrow(pop)) @@ -337,13 +831,25 @@ print.kriging_adequacy <- function(x, ...) { if (length(sh)) cat(sprintf(" kriged minus plain mean: |shift| > 1 SE in %d of %d cell(s), > 2 SE in %d\n", sum(abs(sh) > 1), length(sh), sum(abs(sh) > 2))) - cat(sprintf(" empty cells: %d (kriged estimate and variance available for each)\n", - sum(df$n == 0L))) + n_empty <- sum(df$n == 0L) + n_empty_kr <- sum(df$n == 0L & kr_ok) + cat(sprintf(" empty cells: %d (kriged estimate and variance available for %s)\n", + n_empty, if (n_empty_kr == n_empty) "each" else sprintf("%d of them", n_empty_kr))) + # Named for the scheme that ran: every scheme used to print as "blocked + # CV", random folds and leave-one-out included. + cv_label <- switch(cv$method %||% "block_kfold", + block_kfold = "blocked CV", + random_kfold = "random k-fold CV", + buffered_loo = "buffered leave-one-out CV", + nndm = "NNDM leave-one-out CV", + leave_location_out = "leave-location-out CV", + "CV") if (is.finite(cv$zscore_var %||% NA_real_)) - cat(sprintf(paste0(" blocked CV (%s, %d folds, %d points): var of standardised ", + cat(sprintf(paste0(" %s (%s, %d folds, %d %s): var of standardised ", "error %.2f (1 = kriging variance correct; above 1 = ", "understated), mean %.2f, RMSE %.3g\n"), - cv$method, cv$k, cv$n_pred, cv$zscore_var, cv$zscore_mean, cv$rmse)) - else cat(" blocked CV: not computed\n") + cv_label, cv$method, cv$k, cv$n_pred, pts_word, cv$zscore_var, + cv$zscore_mean, cv$rmse)) + else cat(sprintf(" %s: not computed\n", cv_label)) invisible(x) } diff --git a/R/level-selection.R b/R/level-selection.R index 73c2dc0..236f206 100644 --- a/R/level-selection.R +++ b/R/level-selection.R @@ -14,6 +14,109 @@ } +#' How far a WSS curve sags below a power law, and whether that is an elbow +#' +#' Points with no cluster structure have a WSS close to \eqn{c/k}: each of +#' \eqn{k} cells covers about \eqn{1/k} of the extent, and a cell's mean +#' squared distance to its centre scales with its area. On linear axes that +#' curve is convex everywhere, and the classical chord rule lands where +#' \eqn{c/k} sags furthest below its own chord, \eqn{k = \sqrt{k_{min} +#' k_{max}}}: the ladder chooses, whatever the data. On log-log axes +#' \eqn{c/k} is a straight line, and so is any power law. The sag is +#' therefore measured there: \eqn{\log} WSS against \eqn{\log k}, as the +#' vertical distance below the straight line joining the first and last +#' \eqn{k}, in natural-log units (0.22 means the WSS is a fifth below the +#' power law through the ends). Separated clusters fall faster than a power +#' law until there is one cell per cluster and like \eqn{c/k} after, which is +#' a bend at the cluster count. +#' +#' \code{.ELBOW_MIN_SAG} is the least sag reported as an elbow: +#' \eqn{\log 1.25 \approx 0.22}. Measured with 25 k-means++ restarts, 60 to +#' 1500 points and ladders to 3--40: uniform layouts over squares, discs, +#' triangles, a 1.5:1 rectangle, an L-shape, density gradients, jittered +#' lattices and Gaussian blobs sagged at most 0.16; two to ten separated +#' clusters at least 0.6 once the ladder passed the cluster count; four +#' touching clusters 0.12--0.7, so a bend that weak can go unreported on a +#' small sample. An elongated extent also bends, at about its aspect ratio, +#' because the first cuts go across its long axis (0.1--0.2 for a 2:1 +#' rectangle, 0.2--0.45 for 4:1, 0.19 for the county centroids of North +#' Carolina): that is its shape, not clusters, and past the threshold it is +#' reported as an elbow. +#' @param k,wss Level counts (increasing, positive) and their WSS. +#' @return The sag at each \code{k}; \code{NA} throughout when fewer than +#' three levels or a non-positive WSS leave no line to measure against. +#' @keywords internal +#' @noRd +.ELBOW_MIN_SAG <- log(1.25) +.elbow_sag <- function(k, wss) { + m <- length(k) + y <- suppressWarnings(log(as.numeric(wss))) + if (m < 3L || !all(is.finite(y))) return(rep(NA_real_, m)) + x <- log(as.numeric(k)) + y[1L] + (y[m] - y[1L]) * (x - x[1L]) / (x[m] - x[1L]) - y +} + + +#' The elbow of a WSS ladder, including a fall to zero +#' +#' \code{.elbow_sag()} on the levels whose WSS is positive, and the reading +#' both callers take from it. A level whose WSS is zero has a cell on every +#' distinct location, which a ladder reaches when locations repeat (stations +#' visited many times). It has no place on log axes, and log(0) would take +#' the line with it, so it is left out of the line. But the fall to zero is +#' the sharpest bend a WSS curve can make: when the positive levels have no +#' elbow, the first zero level is the elbow, one cell per location. Its sag +#' is measured with its WSS floored at \code{.ELBOW_ZERO_TOL} of the first +#' level's, below the line through the first level and the last positive one +#' (the power law \eqn{c/k} through the first level when there is no other +#' positive one). Leaving the zero out and reading the rest used to say +#' "no cluster structure" and answer 3 on five stations visited thirty times +#' each, where one metre of jitter answered 5. +#' +#' Zero is relative: at most \code{.ELBOW_ZERO_TOL} (\eqn{10^{-12}}) of the +#' first level's WSS. k-means leaves floating-point residue where the exact +#' value is 0 (7.8e-17 at the station count of one layer of repeat visits), +#' and the log of that dragged the line down as far as log(0) would. +#' +#' @param k Levels, increasing, with \code{k[1]} the anchor of the line (1 in +#' both callers). +#' @param wss Their WSS, \code{wss[1]} the anchor's (the total sum of +#' squares at \code{k = 1}). +#' @return A list with \code{sag} (at every level; \code{NA} at a zero level +#' unless it is the elbow), \code{structured}, \code{knee} (the level of +#' greatest sag, \code{NA} when not structured) and \code{zero} (which +#' levels count as zero). +#' @keywords internal +#' @noRd +.ELBOW_ZERO_TOL <- 1e-12 +.elbow_read <- function(k, wss) { + m <- length(k) + wss <- as.numeric(wss) + w1 <- wss[1L] + zero <- if (is.finite(w1) && w1 > 0) + is.finite(wss) & wss >= 0 & wss <= .ELBOW_ZERO_TOL * w1 + else rep(FALSE, m) + sag <- rep(NA_real_, m) + sag[!zero] <- .elbow_sag(k[!zero], wss[!zero]) + structured <- any(is.finite(sag)) && max(sag, na.rm = TRUE) >= .ELBOW_MIN_SAG + if (!structured && any(zero)) { + z <- which(zero)[1L] + p <- which(!zero) + lw <- suppressWarnings(log(wss[p])) + lk <- log(as.numeric(k[p])) + if (all(is.finite(lw))) { + np <- length(p) + slope <- if (np >= 2L) (lw[np] - lw[1L]) / (lk[np] - lk[1L]) else -1 + sag[z] <- lw[1L] + slope * (log(as.numeric(k[z])) - lk[1L]) - + log(.ELBOW_ZERO_TOL * w1) + structured <- sag[z] >= .ELBOW_MIN_SAG + } + } + list(sag = sag, structured = structured, + knee = if (structured) k[which.max(sag)] else NA, zero = zero) +} + + #' Select an elbow (knee) from a WSS curve #' #' Heuristically selects the "elbow" from a vector of within-cluster sum of @@ -29,11 +132,20 @@ #' 300, 100, 60, 50, 45, 42, 40, 39, 38, 37, 36, 35, 34, 33 this rule answers #' k = 8 where Kneedle answers k = 2). #' +#' The chord is drawn on log-log axes (see \code{.elbow_sag()}), where a +#' curve with no cluster structure is straight, and a fall to a WSS of zero +#' counts as a bend (see \code{.elbow_read()}). When the sag there does not +#' reach \code{.ELBOW_MIN_SAG} the curve has no elbow: \code{structured} is +#' \code{FALSE} and \code{knee_k} is the linear-axis chord rule's answer, +#' which on such a curve is set by \code{min_k} and \code{max_k}, not by the +#' data. The caller says so. +#' #' @param wss Numeric vector of WSS indexed by k. #' @param max_k Integer upper bound on k. #' @param min_k Integer lower bound on k. #' @param return_neighbors Logical; return neighboring k values. -#' @return A list with knee_k, candidates, diagnostics. +#' @return A list with knee_k, candidates, structured (whether the curve has +#' an elbow) and diagnostics (with the log-log \code{sag} at each k). #' @keywords internal #' @noRd .elbow_from_wss <- function(wss, max_k = length(wss), min_k = 1L, @@ -59,11 +171,17 @@ unique(pmin(max_k, pmax(min_k, c(knee, knee - 1L, knee + 1L)))) } + # Read on log-log axes, with a fall to zero counted as a bend (see + # .elbow_read()). Two levels are too few for a line, but not for a fall + # to zero: two stations visited many times have their elbow at 2. + rd <- .elbow_read(k_idx, wss_k) if (length(wss_k) < 3L) { - knee_k <- floor((min_k + max_k) / 2) + knee_k <- if (rd$structured) rd$knee else floor((min_k + max_k) / 2) return(list( knee_k = knee_k, candidates = .make_candidates(knee_k), - diagnostics = list(wss = wss_k, d1 = diff(wss_k), d2 = numeric(0)) + structured = rd$structured, + diagnostics = list(wss = wss_k, d1 = diff(wss_k), d2 = numeric(0), + sag = rd$sag) )) } @@ -88,12 +206,30 @@ perp_dist <- .below_chord(k_norm, wss_norm, x1, y1, x2, y2, line_len) knee_k <- k_idx[which.max(perp_dist)] } + # The same rule on log-log axes decides. On linear axes a curve with no + # cluster structure, WSS ~ c / k, still has a point furthest below its + # chord, near sqrt(min_k * max_k), and that is what used to be returned as + # the elbow: 4 at the default max_levels = 12, 13 at 160, on any uniform + # layer. On log-log axes that curve is straight (see .elbow_sag()). The + # linear answer is kept only as the fallback, flagged, when there is no + # bend there. + # A k with a WSS of 0 (to within 1e-12 of the total) has a cell on every + # distinct location, which the sweep reaches when locations repeat. It is + # left out of the line, since log(0) would take the whole line with it, + # and when the rest of the curve has no elbow it is the elbow: the WSS + # falling to zero is the sharpest bend there is. It used to be only left + # out, and five stations visited thirty times each then had "no cluster + # structure" and got 3. Anything else that is not positive still leaves + # no line at all. + sag <- rd$sag + structured <- rd$structured + if (structured) knee_k <- rd$knee d1 <- diff(wss_k) d2 <- diff(d1) - list(knee_k = knee_k, candidates = .make_candidates(knee_k), - diagnostics = list(wss = wss_k, d1 = d1, d2 = d2)) + list(knee_k = knee_k, candidates = .make_candidates(knee_k), structured = structured, + diagnostics = list(wss = wss_k, d1 = d1, d2 = d2, sag = sag)) } @@ -114,15 +250,32 @@ idx <- integer(k) idx[1L] <- sample.int(n, 1L) if (k > 1L) { - d2 <- rowSums((xy - matrix(xy[idx[1L], ], n, ncol(xy), byrow = TRUE))^2) + # One vector per coordinate, and each draw by inverting the cumulative + # squared distance: sample.int(prob = ) sorts all n weights to draw one + # point, and the n x 2 matrices built for every distance update were the + # rest of the cost. Seeding took 73 percent of a resolution profile's + # time; measured on 5000 points it fell from 0.63 s to 0.08 s at + # k = 1000, and a profile of 3000 points from 35 s to 10 s. The draw + # has the same law, P(i) = d2[i] / sum(d2), but maps + # the random number to a different point, so it seeds different centres + # for the same seed than it did up to 2.0.0. + cols <- lapply(seq_len(ncol(xy)), function(j) xy[, j]) + dist2 <- function(i) { + s <- 0 + for (v in cols) s <- s + (v - v[i])^2 + s + } + d2 <- dist2(idx[1L]) for (j in 2:k) { - tot <- sum(d2) + cs <- cumsum(d2) + tot <- cs[n] # Every remaining point coincides with a centre: fall back to a uniform - # draw among the points not yet chosen. + # draw among the points not yet chosen. A point at distance 0 adds + # nothing to the cumulative sum, so the inversion never lands on one. idx[j] <- if (is.finite(tot) && tot > 0) - sample.int(n, 1L, prob = d2 / tot) + min(n, findInterval(stats::runif(1L) * tot, cs) + 1L) else sample(setdiff(seq_len(n), idx[seq_len(j - 1L)]), 1L) - d2 <- pmin(d2, rowSums((xy - matrix(xy[idx[j], ], n, ncol(xy), byrow = TRUE))^2)) + d2 <- pmin(d2, dist2(idx[j])) } } xy[idx, , drop = FALSE] @@ -301,9 +454,15 @@ # 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. + # These are Cliff & Ord's regression-residual moments. `resid` is by + # construction the OLS residual of the cell means on cbind(1, cell_pred), + # the case the formula is derived for, but the derivation also assumes + # errors of equal variance, and a mean over n_j points has variance + # sigma^2 / n_j. Measured under the null at 20 cells, z stayed calibrated + # on uniform, gradient and moderately clustered layouts (uniform: mean + # 0.02); next to single-point cells beside cells of 70 or more points its + # mean was 0.2 to 0.34 and it rejected 7 to 8 percent at the 5 percent + # level. Weighting the regression by n_j would remove that; it is not done. mom <- .morans_residual_moments(W = W, X = cbind(1, cell_pred[ok, , drop = FALSE]), S0 = S0, is_sparse = inherits(W, "Matrix")) # No usable moments means no usable z -- and z is what the ranking reads. @@ -319,6 +478,33 @@ #' Computes a WSS curve over k=1..K_max using k-means on projected feature #' coordinates and selects candidate k values around the elbow. #' +#' \strong{The elbow is read on log-log axes, and there may be none.} Points +#' with no cluster structure have a WSS curve close to \eqn{c/k}, and the +#' classical rule, the point furthest below the chord from the first to the +#' last k, still finds a "knee" on it on linear axes, at about +#' \eqn{\sqrt{K_{max}}}: 4 at the default \code{max_levels = 12} and 13 at +#' 160, whatever the data. On \eqn{\log k} against \eqn{\log} WSS that curve +#' is a straight line, while separated clusters fall faster than it until +#' there is one cell per cluster and like it after, a bend at the cluster +#' count. The elbow is therefore the k whose \eqn{\log} WSS sags furthest +#' below the straight line joining k = 1 and \eqn{K_{max}} on those axes, and +#' it counts as one only when the sag is at least \eqn{\log 1.25} (the WSS a +#' fifth below the power law through the ends). Measured on 60 to 1500 +#' points with ladders to 3--40, uniform layouts over squares, discs, +#' triangles, an L-shape, density gradients and jittered lattices sagged at +#' most 0.16, and two to ten separated clusters at least 0.6 once +#' \code{max_levels} passed the cluster count. With no elbow the function +#' warns and returns the linear-axis answer, which the ladder chose, not the +#' data. An elongated extent also bends, at about its aspect ratio, because +#' the first cuts go across its long axis (0.2--0.45 for a 4:1 rectangle); +#' past the threshold that bend is reported as an elbow, and it describes +#' the extent's shape rather than clusters in it. When locations repeat +#' (stations visited many times), the sweep can reach one cell per distinct +#' location, where the WSS is zero (to within \eqn{10^{-12}} of the total). +#' That \code{k} has no place on log axes and is left out of the line, but +#' the fall to zero is the sharpest bend there is: when the rest of the +#' curve has no elbow, the number of distinct locations is the elbow. +#' #' When \code{response_var} and \code{predictor_vars} are provided, the #' geometric WSS elbow is supplemented with Moran's I computed on OLS #' residuals at each candidate k. The Moran's I profile measures how much @@ -364,11 +550,19 @@ #' 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, which are 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}. +#' residual moments. The cell-level residuals are OLS residuals by +#' construction, which is the case those moments are derived for, but the +#' derivation also assumes errors of equal variance, and a cell mean over +#' \eqn{n_j} points has a variance proportional to \eqn{1/n_j}. 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}, and +#' it stayed calibrated on gradient and moderately clustered layouts; with +#' single-point cells next to cells of 70 or more points its mean rose to +#' 0.2--0.34 and its rejection rate to 7--8% at 20 cells. Where structure +#' remains, \eqn{|z|} mixes its size with the number of cells it is measured +#' on, since \eqn{\mathrm{sd}(I)} shrinks as cells are added. 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, @@ -383,44 +577,78 @@ #' whichever way rounding noise resolves it those candidates would rank first #' or last on nothing. They 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. +#' clears the floor, the whole call falls back to the geometric ranking and +#' logs a warning that says so. That is the usual outcome well past +#' \code{max_levels = 10}: the neighbourhood is the elbow plus or minus +#' \code{max(4, top_n)}, and on points with no cluster structure the elbow +#' sits near \eqn{\sqrt{K_{max}}}, so the neighbourhood reaches ten cells only +#' from about \code{max_levels = 40}. Measured on 1000 uniform points, +#' \code{max_levels} of 12, 20 and 30 all fell back, and 40 scored +#' \code{k} = 10 and 11 alone. On such a layer +#' \code{\link{resolution_profile}()}, which scores Moran's z at every level of +#' its ladder, is the model-aware view. Under \code{criterion = "combined"}, +#' an elbow below ten cells is a count Moran's I cannot score, so it cannot +#' weigh the response there: the geometric ranking is returned, with a +#' logged warning, and the diagnostics record it (see Value). (Ranking the +#' window anyway put the smallest count Moran's I scores, ten, first whatever +#' the response did.) Otherwise the candidates below the floor that sit +#' alongside candidates above it all take the last place on the Moran's I +#' axis, after every candidate it scored, while still competing on the +#' geometric axis. That axis is the elbow's own log-log sag at each +#' candidate; when the WSS curve has no elbow it is flat, every candidate +#' tied, and Moran's I alone orders them. +#' +#' \code{"combined"} is not an estimate of the number of clusters. Where the +#' elbow is at ten cells or more, Moran's I can move the pick away from it +#' when the response is still spatially structured at the elbow's +#' resolution. Use \code{"geometric"} when the cell count should follow the +#' clustering of the points, and \code{\link{resolution_profile}()} when the +#' response should drive it. +#' +#' @param data_sf An sf object. Features with empty or non-finite +#' coordinates are dropped with a warning. +#' @param max_levels Integer upper bound on levels. Default 12. The sweep +#' also stops at the number of distinct locations (k-means cannot place +#' more centres) and one short of the number of points. #' @param top_n Integer; how many candidates to return. Default 3. Under #' \code{criterion = "geometric"} the candidate set is the elbow and its two #' immediate neighbours, so at most 3 values are ever returned no matter how #' large \code{top_n} is; only the model-aware criteria can return more. #' @param sample_n Integer; subsample size for speed. Default 1500. -#' @param set_seed Integer RNG seed. Default 123. +#' @param set_seed Integer RNG seed for the subsample and the k-means++ +#' restarts; restored afterwards. Default 123. The rows are put in +#' coordinate order before either, so the answer does not depend on the +#' order they come in. #' @param response_var Optional response column name. When provided alongside #' \code{predictor_vars}, enables model-aware level selection via Moran's I #' on OLS residuals. Must be numeric or logical (logicals are read as 0/1); #' a factor or character response raises an error and is never coerced, #' because the residuals of an OLS fit to arbitrary level codes carry no -#' meaning to test for autocorrelation. +#' meaning to test for autocorrelation. Rows where it, or a predictor, is +#' missing or non-finite stay in the WSS sweep and the cells and are left +#' out of Moran's I; a logged warning gives their number. #' @param predictor_vars Optional predictor column names. Must be numeric or #' logical (logicals are read as 0/1); factor/character columns raise an #' error. #' @param criterion One of \code{"geometric"} (default when no response given), #' \code{"morans_i"} (select the k whose residual Moran's I is least -#' \emph{significant}), or \code{"combined"} (rank-average of 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}. Supplying +#' \emph{significant}), or \code{"combined"} (rank-average of the WSS +#' curve's log-log sag, the quantity the elbow is read from, and that same +#' significance). Falls back to \code{"geometric"}, +#' with a warning, when \code{response_var} or \code{predictor_vars} is not +#' given, and with a logged warning when no candidate clears the +#' nine-cell resolution floor described in \strong{Details}. A +#' \code{response_var} or \code{predictor_vars} naming a column that is not +#' in \code{data_sf} is an error. Supplying #' both \code{response_var} and \code{predictor_vars} upgrades #' \code{"geometric"} to \code{"combined"}: the selection then depends on #' the response (see "Post-selection inference"). #' @param select_on \code{"all"} (default) selects on every point; -#' \code{"split"} selects on one spatially blocked half of the points and -#' returns the other half as the set to estimate on, so that the standard -#' errors computed downstream on the chosen cells are not post-selection. -#' See "Post-selection inference". +#' \code{"split"} reads the response on one spatially blocked half of the +#' points only and returns the other half as the set to estimate on, so +#' that the standard errors computed downstream on the chosen cells are not +#' post-selection. The count is still chosen for the whole layer. See +#' "Post-selection inference". #' @section Post-selection inference: #' When the selection reads the response (here, whenever both #' \code{response_var} and \code{predictor_vars} are supplied), everything @@ -436,12 +664,21 @@ #' #' \code{select_on = "split"} is sample splitting: the layer is cut into two #' spatially blocked halves (\code{\link{make_folds}(k = 2, method = -#' "block_kfold")}), the selection runs on the first half only, and the row -#' positions of both halves come back in the \code{"split"} attribute -#' (\code{selection} and \code{estimation}). Build the tessellation on +#' "block_kfold")}), the criteria that read the response (Moran's I on the +#' cell means) read the first half only, and the row positions of both +#' halves come back in the \code{"split"} attribute (\code{selection} and +#' \code{estimation}). The WSS curve and the k-means cells still use every +#' point: they read coordinates alone, and the count is for a tessellation +#' of every point, so it is chosen on that layer's extent and clusters +#' rather than on half of them. Build the tessellation on #' every point (cells are geometry), but aggregate and fit on -#' \code{data_sf[attr(x, "split")$estimation, ]}, which the selection never -#' saw; that restores nominal coverage with no new theory. The price is +#' \code{data_sf[attr(x, "split")$estimation, ]}, whose response the +#' selection never saw. That keeps the selection's use of the response out +#' of the estimates, but only as far as the two halves are independent: the +#' split has no buffer, so points near the border between them are +#' correlated with the selection half over the autocorrelation range, and +#' coverage is nominal only when that range is short against the blocks. +#' The price is #' precision: half the points estimate, and García Rasines and Young (2023) #' show a \emph{contiguous} spatial half is less efficient than the #' exchangeable split the i.i.d. theory assumes, because the two halves are @@ -452,9 +689,21 @@ #' Selection on coordinates alone (\code{"geometric"} with no response) is #' not exposed in this way, and \code{"split"} then changes nothing but the #' attribute. +#' +#' The estimation rows cover only the estimation half's blocks, while the +#' cells cover the whole layer, so the estimation rows do not fill every +#' cell. A cell inside the selection half gets none and comes back +#' \code{NA}; a cell across the border between the halves is estimated from +#' its estimation-half points alone, and its standard error describes that +#' part, not the cell (on 400 simulated fields a nominal 95% interval covered +#' 0.97 in cells inside the estimation half and 0.88 in cells across the +#' border). Count, per cell, how many of its points are estimation rows, +#' and read inferential results only off cells whose points all are. #' @return An integer vector of candidate level counts, \strong{best first}: #' under the geometric criterion the elbow, then its lower and upper -#' neighbours; under the model-aware criteria the candidates in rank order. +#' neighbours (with a warning when the WSS curve has no elbow and the first +#' is the ladder's choice; see Details); under the model-aware criteria the +#' candidates in rank order. #' \code{k[1]} is therefore the top-ranked count on every path, and #' \code{top_n = 1} returns it alone. When #' \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is @@ -470,7 +719,10 @@ #' neighbourhood). Under \code{"combined"} it also carries the WSS of the #' re-run clustering at those \code{k} (\code{wss_eval}), the rank average #' that ordered them (\code{combined_rank}, named by \code{k}) and -#' \code{criterion = "combined"}. When the model-aware +#' \code{criterion = "combined"}; when \code{"combined"} returned the +#' geometric ranking because the elbow is below ten cells, it carries +#' \code{criterion = "geometric"} and \code{fallback} (the reason) in +#' place of \code{combined_rank}. 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), no #' diagnostics are available and the attribute is absent. Both fallbacks are @@ -542,18 +794,41 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, criterion <- match.arg(criterion) select_on <- match.arg(select_on) - has_model_vars <- !is.null(response_var) && !is.null(predictor_vars) && - response_var %in% names(data_sf) && - all(predictor_vars %in% names(data_sf)) + # A named column that is not there is an error, as it is in + # resolution_profile(). It used to count as "no model variables": a typo + # in response_var silently kept the geometric criterion that supplying both + # variables upgrades to "combined" (7 6 8 against 5 6 4 on one layer, with + # no warning and no diagnostics), and under "morans_i" or "combined" the + # log line blamed variables that had been supplied. + if (!is.null(response_var)) { + if (!is.character(response_var) || length(response_var) != 1L || is.na(response_var)) + stop("determine_optimal_levels(): `response_var` must be a single column name.", + call. = FALSE) + if (!(response_var %in% names(data_sf))) + stop(sprintf("determine_optimal_levels(): column '%s' not found.", response_var), + call. = FALSE) + } + missing_p <- setdiff(predictor_vars, names(data_sf)) + if (length(missing_p)) + stop("determine_optimal_levels(): predictor_vars ", + paste(sQuote(missing_p, FALSE), collapse = ", "), " not found.", call. = FALSE) + has_model_vars <- !is.null(response_var) && !is.null(predictor_vars) # Auto-upgrade to combined when model variables are available if (has_model_vars && criterion == "geometric") { criterion <- "combined" .log_info("determine_optimal_levels(): response_var and predictor_vars supplied; using combined criterion (geometric + Moran's I).") } - # Fall back if model variables not available for model-aware criteria + # Fall back if model variables not available for model-aware criteria. A + # warning, not a log line: the caller asked for a criterion and gets another. if (!has_model_vars && criterion != "geometric") { - .log_warn("determine_optimal_levels(): criterion='%s' requires response_var and predictor_vars; falling back to geometric.", criterion) + .warn_and_log(paste0("determine_optimal_levels(): criterion = '%s' needs both ", + "response_var and predictor_vars, and %s not given; falling ", + "back to geometric."), + criterion, + if (is.null(response_var) && is.null(predictor_vars)) "neither was" + else if (is.null(response_var)) "response_var was" + else "predictor_vars were") criterion <- "geometric" } @@ -566,25 +841,48 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, } data_sf <- ensure_projected(data_sf) - # Sample splitting: select on one spatial half, hand the other back for - # estimation. Done on the full layer, before the subsample, so the - # positions returned index `data_sf` as the caller passed it. + # A point with no coordinates has no place in a partition of the plane. + # One POINT EMPTY used to make the k = 1 WSS NA and k-means fail at every + # k, and the failure handler then returned 1 where the clean layer gave + # 2 1 3, with nothing but a log line about interpolating the WSS. + xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] + ok_xy <- if (nrow(xy) == nrow(data_sf)) is.finite(xy[, 1]) & is.finite(xy[, 2]) + else !sf::st_is_empty(data_sf) + if (!all(ok_xy)) { + .warn_and_log("determine_optimal_levels(): dropping %d point(s) with empty or non-finite coordinates.", + sum(!ok_xy)) + data_sf <- data_sf[ok_xy, , drop = FALSE] + xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] + } + + # Sample splitting: read the response on one spatial half, hand the other + # back for estimation. Done on the full layer, before the subsample, so + # the positions returned index `data_sf` as the caller passed it (rows + # dropped above excepted: they are mapped back). split <- NULL if (identical(select_on, "split")) { split <- .spatial_half_split(data_sf, seed = set_seed, caller = "determine_optimal_levels") + sel_rows <- seq_len(nrow(data_sf)) %in% split$selection + if (!all(ok_xy)) { + kept <- which(ok_xy) + split$selection <- kept[split$selection] + split$estimation <- kept[split$estimation] + } # The split exists so that a selection made on the response can be - # estimated on points it never saw. A geometric selection reads no - # response, so there is nothing for the other half to protect; it sees - # every point, as the page says, and only the attribute is added. - if (has_model_vars) data_sf <- data_sf[split$selection, , drop = FALSE] + # estimated on points it never saw, so only the Moran's I pass, which + # reads the response, is held to the selection half (`moran_rows` below). + # The WSS sweep and the k-means partitions read coordinates alone and + # keep every point: the count is for a tessellation of every point. The + # whole selection used to run on the half, and a count chosen for the + # half's extent and clusters (2 where the layer has 4) was then applied + # to the whole layer. } .with_split <- function(out) { if (!is.null(split)) attr(out, "split") <- split out } - xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] n <- nrow(xy) if (n < 3L) return(.with_split(1L)) @@ -635,20 +933,60 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, storage.mode(pred_mat) <- "double" } - if (n > sample_n) { - idx <- sample(seq_len(n), sample_n) - xy <- xy[idx, , drop = FALSE] - if (has_model_vars) { - resp_vec <- resp_vec[idx] - pred_mat <- pred_mat[idx, , drop = FALSE] - } + # The rows whose response the model-aware criteria may read: the selection + # half under select_on = "split", and only rows with a finite response and + # finite predictors. A cell mean over a row with one missing predictor was + # NA and dropped the whole cell, and how many cells that removed depended on + # the points per cell, so z was computed on a different subset of cells at + # each k: three missing values in 400 rows made every z in the window NA + # and the call fell back to the geometric ranking. + moran_rows <- if (!is.null(split) && has_model_vars) sel_rows else rep(TRUE, n) + if (has_model_vars) { + complete <- is.finite(resp_vec) & rowSums(!is.finite(pred_mat)) == 0 + if (!all(complete)) + .log_warn(paste0("determine_optimal_levels(): %d of %d row(s) have a missing or ", + "non-finite response or predictor; they stay in the WSS sweep ", + "and the cells but are left out of Moran's I."), + sum(!complete), n) + moran_rows <- moran_rows & complete } - k_max <- max(2L, min(as.integer(max_levels), nrow(xy) - 1L)) - + # Subsample from the rows in a canonical order, and hand k-means++ the + # points in that order even with no subsample to draw: both index rows, so + # the same layer with its rows permuted used to get different cells and a + # different count. Coordinates first; the response and the predictors + # break ties between repeat visits to one location. + ord <- do.call(order, c(list(xy[, 1], xy[, 2]), + if (has_model_vars) + c(list(resp_vec), + lapply(seq_len(ncol(pred_mat)), function(j) pred_mat[, j])))) + idx <- if (n > sample_n) ord[sample(seq_len(n), sample_n)] else ord + xy <- xy[idx, , drop = FALSE] + moran_rows <- moran_rows[idx] + if (has_model_vars) { + resp_vec <- resp_vec[idx] + pred_mat <- pred_mat[idx, , drop = FALSE] + } + + ml <- as.integer(max_levels) + k_max <- max(2L, min(ml, nrow(xy) - 1L)) + + # One centre per distinct location at most, which with repeat visits is + # below nrow(xy) - 1 (stats::kmeans() refuses as many centres as points). + # It was one short of the distinct locations, so five stations visited + # thirty times each could not reach k = 5. n_uniq <- nrow(unique(round(xy, 8))) - k_max <- min(k_max, n_uniq - 1L) + k_max <- min(k_max, n_uniq) if (k_max < 2L) return(.with_split(1L)) + # Which bound ended the ladder, for the messages below: they used to name + # max_levels whatever did, and on five stations at max_levels = 12 it was + # the stations. + k_max_from <- if (k_max < max(2L, ml) && k_max == n_uniq) + sprintf("the %d distinct locations", n_uniq) + else if (k_max < max(2L, ml)) + sprintf("one short of the %d points", nrow(xy)) + else if (ml < 2L) sprintf("max_levels = %d, raised to 2", ml) + else "max_levels" # Say it BEFORE the sweep: the model-aware criteria carry no information at # nine cells or fewer (see the resolution floor in Details), so with @@ -700,6 +1038,7 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, while (hi %in% failed_k && hi < k_max) hi <- hi + 1L if (hi %in% failed_k) { k_max <- lo + k_max_from <- sprintf("k-means failing from k = %d", lo + 1L) break } wss[fk] <- (wss[lo] + wss[hi]) / 2 @@ -708,6 +1047,31 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, } elbow <- .elbow_from_wss(wss, max_k = k_max, min_k = 1L, return_neighbors = TRUE) + # No bend on log-log axes: the points have no cluster structure the + # ladder can see, and the chord rule's answer is set by max_levels. It is + # still returned, because a count is what this function is for, but not + # silently: it used to be handed on as if the data had chosen it. + # A ladder of two levels has no line to test, and used to be told it fell + # in one. + if (!isTRUE(elbow$structured) && k_max < 3L) + .warn_and_log(paste0("determine_optimal_levels(): a ladder of k = 1 to %d (ended ", + "by %s) is too short to read an elbow from: it takes three ", + "levels to see a bend. k = %d is not a finding about the ", + "data; %s"), + k_max, k_max_from, elbow$knee_k, + if (identical(k_max_from, "max_levels") || ml < 2L) + "raise max_levels to 3 or more." + else "choose the count on other grounds.") + else if (!isTRUE(elbow$structured)) + .warn_and_log(paste0("determine_optimal_levels(): the WSS curve has no elbow: on ", + "log-log axes it falls in a straight line, as it does for ", + "points with no cluster structure. k = %d is where the chord ", + "rule lands on such a curve, set by the ladder (k = 1 to %d, ", + "%s) rather than by the data%s. Choose the count on ", + "other grounds, e.g. resolution_profile() with a response."), + elbow$knee_k, k_max, k_max_from, + if (criterion == "geometric") "" + else "; the model-aware criteria are evaluated around it") # A WSS curve that rises anywhere is one where some k landed in a worse # optimum than its neighbour, and the elbow read from it is partly noise. @@ -747,6 +1111,7 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, return(.with_split(unique(out))) } + # Run k-means only for the candidate k values and compute Moran's I. # The WSS of the re-run clustering is recorded (wss_eval) so that the # combined ranking below compares elbow distance and Moran's I computed @@ -760,7 +1125,10 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, if (is.null(kb)) next km <- kb$km wss_eval[k] <- km$tot.withinss - mi <- .morans_i_for_k(xy, resp_vec, pred_mat, km$cluster) + # Cells of the whole layer, means of the rows the selection may read. + mi <- .morans_i_for_k(xy[moran_rows, , drop = FALSE], resp_vec[moran_rows], + pred_mat[moran_rows, , drop = FALSE], + km$cluster[moran_rows]) moran_vals[k] <- mi[["I"]] moran_z[k] <- mi[["z"]] } @@ -769,7 +1137,30 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, 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.") + # A window that ends at nine cells or fewer cannot score anything (see + # the resolution floor in Details), and on points with no cluster + # structure the elbow sits near sqrt(max_levels), so that is the usual + # case below max_levels = 40: measured on 1000 uniform points, + # max_levels = 12, 20 and 30 all fell back, and 40 scored k = 10 and 11 + # alone. The warning used to say only that Moran's I "could not be + # computed", and the one before the sweep fires only at k_max <= 9. + if (max(eval_ks) <= 9L) { + if (k_max > 9L) + .log_warn(paste0("determine_optimal_levels(): the model-aware criteria score ", + "only the elbow's neighbourhood, k = %d to %d, and carry no ", + "information at nine cells or fewer, so criterion = '%s' ", + "falls back to the geometric ranking. On points with no ", + "cluster structure the elbow sits near sqrt(max_levels), and ", + "the neighbourhood reaches ten cells from about max_levels = ", + "40; resolution_profile() scores every level of its ladder."), + min(eval_ks), max(eval_ks), criterion) + } else { + .log_warn(paste0("determine_optimal_levels(): Moran's I could not be computed at ", + "any k from %d to %d in the elbow's neighbourhood (too few of ", + "the cells hold a row with a response, or the cell-mean ", + "regression is singular); falling back to geometric."), + max(10L, min(eval_ks)), max(eval_ks)) + } out <- as.integer(head(elbow$candidates, max(1L, as.integer(top_n)))) out[out < 1L] <- 1L; out[out > k_max] <- k_max return(.with_split(unique(out))) @@ -806,34 +1197,76 @@ determine_optimal_levels <- function(data_sf, max_levels = 12L, top_n = 3L, return(.with_split(out)) } - # --- Combined: rank-average of WSS elbow distance and |z| of Moran's I --- + # --- Combined: rank-average of the elbow's sag and |z| of Moran's I --- # |z|, not |I|: I's attainable range is set by the eigenvalues of the weights # matrix, which is rebuilt at every k, so |I| is not comparable across k. # Only rank over the evaluated neighbourhood to keep dimensions aligned; # use wss_eval so both criteria reflect the same clustering per k. - k_norm <- (eval_ks - min(eval_ks)) / max(1, max(eval_ks) - min(eval_ks)) - wss_sub <- wss_eval[eval_ks] - wss_norm <- (wss_sub - min(wss_sub)) / max(.Machine$double.eps, max(wss_sub) - min(wss_sub)) - x1 <- k_norm[1]; y1 <- wss_norm[1] - x2 <- k_norm[length(k_norm)]; y2 <- wss_norm[length(wss_norm)] - line_len <- sqrt((x2 - x1)^2 + (y2 - y1)^2) - if (line_len < .Machine$double.eps) { - perp_dist <- rep(0, length(eval_ks)) - } else { - # Signed (positive below the chord), as in .select_elbow(); see there. - perp_dist <- .below_chord(k_norm, wss_norm, x1, y1, x2, y2, line_len) + # + # The geometric axis is the log-log sag the elbow itself is read from + # (.elbow_read()), below the line from k = 1 to k_max. It was the chord + # on linear axes across the window, the rule the elbow stopped using + # because on a curve like c / k it lands near sqrt(first x last) whatever + # the data: on eight separated clusters it ranked 6 or 7 first where the + # elbow is 8. With no elbow the axis is flat, every candidate tied, and + # Moran's z alone orders the window. + # An elbow below ten cells is a count Moran's I cannot score (the nine-cell + # floor), and every candidate below the floor ranks last on its axis, so + # the rank average put the smallest count it could score (ten) first + # whatever the response did: on eight separated clusters the geometric + # call returned 8 and "combined" 10, for a response that was noise and for + # one that varied by cluster alike. Moran's I has nothing to say about the + # counts where the elbow lies, so it does not overrule it: the geometric + # ranking is returned, and the diagnostics say so. (With no elbow the + # geometric axis carries nothing and Moran's I orders the window, below.) + if (isTRUE(elbow$structured) && knee_k <= 9L) { + .log_warn(paste0("determine_optimal_levels(): the WSS elbow is at k = %d, ", + "below the ten cells Moran's I needs, so criterion = '%s' ", + "cannot weigh the response there and returns the geometric ", + "ranking. resolution_profile() scores the response at every ", + "level of its ladder."), knee_k, criterion) + out <- as.integer(head(elbow$candidates, 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, moran_z = moran_z, wss = wss[1:k_max], + wss_eval = wss_eval[1:k_max], + wss_spread = wss_spread[1:k_max], + wss_bumps = wss_bumps, nstart = nstart, + knee_k = knee_k, failed_k = failed_k, + eval_ks = eval_ks, + criterion = "geometric", + fallback = sprintf(paste0("the elbow (k = %d) is below the ten cells ", + "Moran's I needs"), knee_k) + ) + return(.with_split(out)) } - # Rank both criteria (lower rank = better) - rank_elbow <- rank(-perp_dist, ties.method = "average") # higher distance = better + n_eval <- length(eval_ks) + if (isTRUE(elbow$structured)) { + w <- wss[seq_len(k_max)] + w[eval_ks] <- wss_eval[eval_ks] + sag_w <- .elbow_read(seq_len(k_max), w)$sag[eval_ks] + rank_elbow <- rank(-sag_w, na.last = TRUE, ties.method = "average") # more sag = better + } else { + rank_elbow <- rep((n_eval + 1) / 2, n_eval) + } # |z|, not |I|: the two rank candidates differently and only |z| is - # comparable across k. See .morans_i_for_k(). + # comparable across k. See .morans_i_for_k(). A candidate with no z + # (below the nine-cell floor) takes the last place on this axis, all of + # them together: an average-rank tie gave a block of seven unscored + # candidates the mean of places 3 to 9, 6 of 9, so the more candidates + # went unscored, the lighter their penalty. 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 |z| = better + scored_z <- is.finite(abs_moran_sub) + rank_moran <- rep(as.numeric(n_eval), n_eval) + rank_moran[scored_z] <- rank(abs_moran_sub[scored_z], ties.method = "average") # lower |z| = better combined_rank <- (rank_elbow + rank_moran) / 2 - best_idx <- order(combined_rank) + # Exact ties (with a flat geometric axis, every unscored candidate) go to + # the k nearest the elbow the window was drawn around; order() alone hands + # them over smallest first, 2 and 3 on uniform points. + best_idx <- order(combined_rank, abs(eval_ks - knee_k)) out <- as.integer(eval_ks[head(best_idx, max(1L, as.integer(top_n)))]) out[out < 1L] <- 1L; out[out > k_max] <- k_max out <- unique(out) diff --git a/R/model-bayesian.R b/R/model-bayesian.R index 90fc035..bda3333 100644 --- a/R/model-bayesian.R +++ b/R/model-bayesian.R @@ -92,6 +92,39 @@ } +#' Evaluate a convergence accessor without posterior's capped-ESS warning +#' +#' \pkg{posterior} warns "The ESS has been capped to avoid unstable estimates." +#' once for every parameter whose effective sample size exceeds its draw +#' count. In a Hilbert-space GP that is most of the \code{zgp} basis weights, +#' which mix well precisely because their chains are antithetic: an +#' \code{n = 80} fit raised 41 of them from a single +#' \code{brms::neff_ratio()} call. R keeps only the first 50 warnings, so a +#' warning that mattered and came later -- loo's Pareto-k, raised after this +#' check -- was dropped. The capped value is still the one to read; only that +#' message is muffled, and every other warning passes through. Restricting +#' the check to non-\code{zgp} parameters instead would hide real flags: in the +#' fits the review ran, the only ratios below 0.1 were \code{zgp} weights. +#' +#' @param expr The call to evaluate. +#' @return The value of \code{expr}. +#' @keywords internal +#' @noRd +.muffle_ess_cap <- function(expr) { + withCallingHandlers(expr, warning = function(w) { + if (grepl("The ESS has been capped", conditionMessage(w), fixed = TRUE)) + invokeRestart("muffleWarning") + }) +} + + +# The brms families whose response is a category rather than a number, and so +# the only ones fit_bayesian_spatial_model() lets a factor or character +# response through for. +.brms_category_families <- c("categorical", "cumulative", "sratio", "cratio", + "acat") + + #' Build the brms gp() term for the spatial GP #' #' Kept separate from \code{fit_bayesian_spatial_model()} so the formula text @@ -116,6 +149,107 @@ } +#' The coefficient-level length-scale parameters brms creates for a model +#' +#' One row per \code{lscale} coefficient, with everything that addresses it: +#' \code{coef}, \code{resp}, \code{dpar} and \code{nlpar}. The address is more +#' than the \code{coef} name. A family with several distributional parameters +#' gives each its own GP -- \code{brms::categorical()} one per non-reference +#' category (\code{muhi}, \code{mumid}), a \code{brms::mixture()} one per +#' component -- under the SAME \code{coef} names, so a prior built from +#' \code{coef} alone lands every row on \code{dpar = ""} twice, and brms +#' refuses the whole model with "Duplicated prior specifications are not +#' allowed" before sampling. +#' +#' @param fml,data,family As handed to \code{brms::brm()}. +#' @return A data.frame with character columns \code{coef}, \code{resp}, +#' \code{dpar}, \code{nlpar}, or \code{NULL} when brms reports none (or +#' \code{brms::get_prior()} fails). +#' @keywords internal +#' @noRd +.lscale_coef_rows <- function(fml, data, family) { + gp_def <- tryCatch(brms::get_prior(fml, data = data, family = family), + error = function(e) NULL) + if (is.null(gp_def) || !all(c("class", "coef") %in% names(gp_def))) + return(NULL) + keep <- gp_def$class == "lscale" & nzchar(gp_def$coef) + if (!any(keep)) return(NULL) + field <- function(nm) { + v <- if (nm %in% names(gp_def)) as.character(gp_def[[nm]][keep]) + else rep("", sum(keep)) + v[is.na(v)] <- "" + v + } + unique(data.frame(coef = field("coef"), resp = field("resp"), + dpar = field("dpar"), nlpar = field("nlpar"), + stringsAsFactors = FALSE)) +} + + +#' One coefficient-level lscale prior per row of .lscale_coef_rows() +#' +#' @param spec The prior, as a Stan distribution string. +#' @param rows A (non-empty) return value of \code{.lscale_coef_rows()}. +#' @return A \code{brmsprior}. +#' @keywords internal +#' @noRd +.lscale_prior_rows <- function(spec, rows) { + Reduce(`+`, lapply(seq_len(nrow(rows)), function(i) + brms::set_prior(spec, class = "lscale", coef = rows$coef[[i]], + resp = rows$resp[[i]], dpar = rows$dpar[[i]], + nlpar = rows$nlpar[[i]]))) +} + + +#' The weakly informative slope prior, one row per distributional parameter +#' +#' \code{set_prior(spec, class = "b")} with no \code{dpar} addresses only the +#' slopes of the main parameter. A \code{brms::categorical()} or +#' \code{brms::mixture()} family has none of those -- its slopes belong to +#' \code{muhi}/\code{mumid} or \code{mu1}/\code{mu2} -- so brms refused the +#' whole model with "The following priors do not correspond to any model +#' parameter: b ~ normal(0, 5)", a prior the user never wrote. The +#' class-level \code{b} rows are therefore read back from +#' \code{brms::get_prior()}, as for the length-scale prior, and the prior is +#' set on each. A family with one \code{mu} gets the single dpar-less row it +#' always had. +#' +#' @param spec The prior, as a Stan distribution string. +#' @param fml,data,family As handed to \code{brms::brm()}. +#' @return A \code{brmsprior}; the global \code{class = "b"} row when +#' \code{brms::get_prior()} fails or reports no class-level \code{b} row. +#' @keywords internal +#' @noRd +.b_prior_rows <- function(spec, fml, data, family) { + gp_def <- tryCatch(brms::get_prior(fml, data = data, family = family), + error = function(e) NULL) + keep <- if (!is.null(gp_def) && all(c("class", "coef") %in% names(gp_def))) + gp_def$class == "b" & !nzchar(gp_def$coef) else FALSE + if (!any(keep)) return(brms::set_prior(spec, class = "b")) + field <- function(nm) { + v <- if (nm %in% names(gp_def)) as.character(gp_def[[nm]][keep]) + else rep("", sum(keep)) + v[is.na(v)] <- "" + v + } + rows <- unique(data.frame(resp = field("resp"), dpar = field("dpar"), + nlpar = field("nlpar"), stringsAsFactors = FALSE)) + Reduce(`+`, lapply(seq_len(nrow(rows)), function(i) + brms::set_prior(spec, class = "b", resp = rows$resp[[i]], + dpar = rows$dpar[[i]], nlpar = rows$nlpar[[i]]))) +} + + +#' Label lscale coefficients for a log line, with their dpar/nlpar/resp +#' @keywords internal +#' @noRd +.lscale_row_labels <- function(rows) { + where <- paste(rows$resp, rows$dpar, rows$nlpar, sep = "/") + where <- gsub("^/+|/+$", "", gsub("/{2,}", "/", where)) + paste0(sQuote(rows$coef), ifelse(nzchar(where), paste0(" (", where, ")"), "")) +} + + #' Fit a Bayesian spatial regression with a 2D Gaussian Process (via brms) #' #' Fits a regression whose residual spatial structure is modelled explicitly, as @@ -151,9 +285,11 @@ #' \code{brms::hurdle_poisson()}, \code{brms::bernoulli()} or #' \code{brms::Beta()}. Default \code{NULL}, resolved to #' \code{stats::gaussian()}. The family reaches \code{brms::brm()} -#' unchanged with the spatial GP term still in the formula, so any response -#' type brms can fit, this function can fit; see the section on -#' non-Gaussian responses and the count example below. +#' unchanged with the spatial GP term still in the formula. A factor +#' response is accepted only under \code{brms::categorical()} or an ordinal +#' family, and those fits have no single expected value per row, so several +#' methods cannot use them; see the section on non-Gaussian responses for +#' what each family supports, and the count example below. #' @param gp_k Positive integer giving the number of GP basis functions #' \emph{per dimension}, or NULL (default) to derive it from the #' length-scale/domain ratio. The fitted model carries @@ -168,7 +304,11 @@ #' NULL (default) to derive it alongside \code{gp_k}. The boundary must be #' wide enough to contain the longest plausible correlation range; a value #' that is too small truncates the domain and degrades the approximation for -#' smooth, long-range surfaces. +#' smooth, long-range surfaces. When you set \code{gp_c} and leave +#' \code{gp_k = NULL}, \code{gp_k} is derived for \emph{your} boundary: a +#' wider boundary needs more basis functions to resolve the same +#' length-scale, so raising \code{gp_c} raises the derived \code{gp_k} with +#' it, up to the cap of 50 per dimension (a capped value is logged). #' @param prior Optional brms prior specification. When NULL and #' \code{standardize_predictors = TRUE}, weakly informative #' \code{normal(0, 5)} priors are set on regression coefficients. @@ -200,9 +340,33 @@ #' @param compute_loo Logical; compute PSIS-LOO. Default TRUE. #' @param standardize_predictors Logical; center and scale numeric predictors #' before fitting. Default FALSE. When TRUE, the scaling parameters are -#' stored in the return value so predictions can be computed correctly. -#' @param check_convergence Logical; after fitting, check for divergences, -#' low ESS, and high R-hat and issue warnings. Default TRUE. +#' stored in the return value (\code{$info$predictor_scaling}, a +#' \code{center} and \code{scale} per predictor) so predictions can be +#' computed correctly. The model is then fitted on the standardised +#' predictors, so \code{coef()} reports a slope per standard deviation of +#' each predictor and an intercept at the predictor means, not the raw-unit +#' values \code{stats::lm()} would give; see \code{\link{coef.bayesian_fit}}. +#' @param check_convergence Logical; after fitting, check for divergent +#' transitions, R-hat above 1.05 and an effective-sample-size ratio below +#' 0.1. Each problem found is written to the log as a WARN line (shown on +#' the console unless \code{\link{spatialkit_quiet}()} is on), sets +#' \code{$info$convergence_ok} to \code{FALSE}, and is detailed in +#' \code{$info$convergence_diagnostics}; \code{print()} on the fit flags it. +#' The GP basis is also checked against the posterior length-scale (see +#' Details): a basis too coarse for it is logged as a WARN line, and the +#' share of draws it cannot resolve is recorded as +#' \code{$info$convergence_diagnostics$gp_lscale_below_resolution}, but it +#' does not change \code{convergence_ok} and \code{print()} does not flag +#' it. None of these are raised as R warnings by the fit itself; the +#' functions that score fits do raise one: \code{\link{cv_bayes}()} names +#' the folds whose sampler did not converge (and marks them in +#' \code{fold_metrics$convergence_ok}), and +#' \code{\link{compare_models}()} names such a model (column +#' \code{convergence_ok}). Under \pkg{rstan} the sampler raises its own +#' R-hat and ESS warnings; under \pkg{cmdstanr} nothing does, so read +#' \code{$info$convergence_ok}. \code{FALSE} skips +#' the checks and leaves \code{convergence_ok} \code{NA} (not checked). +#' Default TRUE. #' @param pointize Strategy for non-point geometry coercion. #' @param boundary Optional polygonal sf/sfc for CRS harmonization. #' @param .already_prepped Logical (internal). If \code{TRUE}, skip the @@ -246,9 +410,12 @@ #' #' After fitting, the posterior length-scale is compared against the smallest #' scale the chosen basis can resolve -#' (\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); a -#' warning is issued when more than 10% of the posterior mass falls below it, -#' which is the signal that \code{gp_k} should be raised. +#' (\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); when +#' more than 10% of the posterior mass falls below it a WARN line is logged +#' and the share is recorded as +#' \code{$info$convergence_diagnostics$gp_lscale_below_resolution}, which is +#' the signal that \code{gp_k} should be raised. This runs with the other +#' checks, so only under \code{check_convergence = TRUE}. #' #' \strong{Coordinate scaling and anisotropy.} #' Before fitting the GP, X and Y coordinates are each centred and divided by @@ -280,14 +447,18 @@ #' 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_S: the pooled centred range \code{brms::gp(c = )} multiplies; +#' gp_cmeans: the column means brms centred the scaled coordinates on; #' gp_xy_range: the training extrema of the scaled coordinates, which -#' \code{predict()} uses to pin the GP boundary; +#' \code{predict()} uses, with gp_S and gp_cmeans, to hold the GP boundary +#' at its fitted value; #' gp_lengthscale_bounds: the \code{c(lower, upper)} the length-scale prior #' 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: \code{n_divergent}, +#' convergence_ok (\code{TRUE} or \code{FALSE}, and \code{NA} when nothing +#' was checked, as under \code{check_convergence = FALSE}), +#' convergence_diagnostics: \code{n_divergent}, #' \code{max_rhat}, \code{min_neff_ratio}, and \code{rhat_failed} / #' \code{neff_failed}, the parameters that failed each check by name with #' their values (empty when none failed), which is what makes a failed @@ -297,16 +468,38 @@ #' The raw brmsfit is in \code{$engine}. #' @family model fitting #' @section Non-Gaussian responses: -#' Nothing in this function is Gaussian-specific except its default. The -#' response check is family-aware: a non-numeric response is refused only when -#' the family resolves to gaussian, so a count, binary or bounded response -#' passes straight through to brms under the family you name. Zero-inflated -#' and hurdle counts, negative binomial, Bernoulli, beta and ordinal families -#' have all been verified to reach \code{brms::brm()} with the GP term intact. +#' Nothing in this function is Gaussian-specific except its default. A +#' numeric count, binary (0/1 or logical) or bounded response passes straight +#' through to brms under the family you name; zero-inflated and hurdle +#' counts, negative binomial, Bernoulli, beta, ordinal, categorical and +#' mixture families have all been verified to reach \code{brms::brm()} with +#' the GP term intact, the length-scale prior attached to each +#' distributional parameter's GP. +#' +#' The response check is family-aware. A factor or character response is +#' accepted only under \code{brms::categorical()} or an ordinal family +#' (\code{cumulative}, \code{sratio}, \code{cratio}, \code{acat}), and refused +#' under every other family before anything is compiled; under gaussian a +#' logical response is refused too. The case to watch is a two-level factor +#' under \code{brms::bernoulli()}: brms would fit it, but +#' \code{residuals()}, \code{summary()}, \code{model_metrics()} and +#' \code{\link{cv_bayes}()} could not score a factor, so convert it to 0/1 +#' first. +#' +#' An ordinal or categorical fit has a probability per response category, not +#' one expected value per row. \code{predict()} with its default +#' \code{type = "epred"}, \code{fitted()}, \code{residuals()}, +#' \code{summary()} and \code{model_metrics()} therefore stop with a message +#' saying so, and \code{\link{cv_bayes}()} refuses the family before fitting +#' anything. \code{predict(type = "predict", draws = TRUE)} returns the +#' posterior predicted categories, as category indices, for new rows as well +#' as the training ones (the share of draws in each category estimates its +#' probability), and \code{brms::posterior_epred(fit$engine)} the +#' probabilities for the training rows. #' -#' Two things follow. First, the metrics that come back from -#' \code{\link{model_metrics}()} and the \code{cv_*()} functions are not all -#' meaningful for such a response: RMSE and MAE are, MAPE, SMAPE and R-squared +#' For the numeric families two things follow. First, the metrics that come +#' back from \code{\link{model_metrics}()} and the \code{cv_*()} functions are +#' not all meaningful for such a response: RMSE and MAE are, MAPE, SMAPE and R-squared #' are Gaussian-shaped, and for this backend \code{\link{cv_bayes}()}'s CRPS #' and interval coverage are the proper scores to read. See #' \code{\link{model_metrics}()}, section "Which metrics survive a @@ -317,10 +510,10 @@ #' #' One trap. The response check reads the family's name through #' \code{brms}'s own accessor; a family object it cannot name is treated as -#' "not gaussian" and the check is skipped entirely, without falling back -#' to the gaussian rule. A malformed \code{family} therefore buys less -#' validation, not more, and a wrong response type will surface as a Stan -#' error, with no message from this function. +#' unknown and the check is skipped entirely, without falling back to either +#' rule above. A malformed \code{family} therefore buys less validation, not +#' more, and a wrong response type will surface as a Stan error, with no +#' message from this function. #' #' @section Spatial confounding: #' A fixed-effect coefficient estimated alongside a spatial random effect is a @@ -334,7 +527,12 @@ #' the spatial field can explain, and the non-spatial one is not. Which of the #' two a user wants depends on the question, so the honest diagnostic is to #' report both side by side and leave them unadjusted: fit the same formula -#' with \code{stats::lm()} or \code{stats::glm()} and compare. +#' with \code{stats::lm()} or \code{stats::glm()} and compare. Compare like +#' with like: under \code{standardize_predictors = TRUE} the coefficients here +#' are per standard deviation of each predictor, so either fit the +#' non-spatial model on the same standardised columns or divide these slopes +#' by \code{$info$predictor_scaling[[name]]$scale} first (see +#' \code{\link{coef.bayesian_fit}}). #' #' The literature on remedies is unsettled and this function takes no side. #' Restricted spatial regression (Hughes and Haran 2013) projects the spatial @@ -511,13 +709,37 @@ fit_bayesian_spatial_model <- function( if (nrow(dat_sf) < 2L) stop(sprintf("fit_bayesian_spatial_model(): %d usable row(s) after cleaning; at least two are needed to fit a spatial GP.", nrow(dat_sf)), call. = FALSE) - if (identical(.brms_family_name(family), "gaussian") && - !is.numeric(dat_cols[[response_var]])) + fam_name <- .brms_family_name(family) + y_resp <- dat_cols[[response_var]] + if (identical(fam_name, "gaussian") && !is.numeric(y_resp)) stop(sprintf(paste0("fit_bayesian_spatial_model(): response '%s' is %s, ", "not numeric, but the family is gaussian. Convert it ", "to numeric, or pass a `family` that matches it (e.g. ", - "brms::bernoulli() for a 0/1 outcome)."), - response_var, class(dat_cols[[response_var]])[1L]), + "brms::bernoulli() for an outcome coded 0/1)."), + response_var, class(y_resp)[1L]), + call. = FALSE) + # A factor or character response under any other family that is not + # categorical or ordinal. brms fits a two-level factor under bernoulli(), so + # this used to pass, and then residuals() came back all NA, summary(), + # model_metrics() and compare_models() stopped on "response is factor", and + # cv_bayes() ran a whole fold of MCMC before aborting in the fold scoring. + # Refused here, before anything is compiled. A family whose name cannot be + # read (NA) is not checked, as documented. + if (!is.na(fam_name) && !identical(fam_name, "gaussian") && + !(is.numeric(y_resp) || is.logical(y_resp)) && + !(fam_name %in% .brms_category_families)) + stop(sprintf(paste0("fit_bayesian_spatial_model(): response '%s' is %s, ", + "not numeric, and the family is %s. Only ", + "brms::categorical() and the ordinal families (%s) ", + "take a categorical response here; convert it first, ", + "e.g. to 0/1 for brms::bernoulli() with as.integer(", + "%s == \"\"). residuals(), ", + "summary(), model_metrics() and cv_bayes() all need a ", + "numeric response to score the fit."), + response_var, class(y_resp)[1L], fam_name, + paste(setdiff(.brms_category_families, "categorical"), + collapse = ", "), + response_var), call. = FALSE) # NOTE: prep_model_data() coerces geometry to points and drops incomplete @@ -592,8 +814,18 @@ fit_bayesian_spatial_model <- function( # that scaled gp_k with sqrt(n) made the approximation cost grow as n while # adding no resolution the data supported. NULL means "derive"; an explicit # value passes through untouched, which is the contract the CV internals - # rely on when a user supplies gp_k per fold. - gp_spec <- .gp_basis_spec(cbind(dat_df[["..x"]], dat_df[["..y"]]), ls_bounds) + # rely on when a user supplies gp_k per fold. A user's gp_c is handed to the + # rule, so a derived gp_k is sized for the boundary actually used: k grows + # with c, and a gp_c raised for a long-range surface (the advice under + # @param gp_c) used to keep the k derived for the default c, a basis coarser + # than the lower length-scale bound it is sized to resolve. gp_c is + # therefore validated first, before the rule reads it. + if (!is.null(gp_c) && + (!is.numeric(gp_c) || length(gp_c) != 1L || !is.finite(gp_c) || gp_c <= 1)) + stop("fit_bayesian_spatial_model(): `gp_c` must be a single finite number > 1.", + call. = FALSE) + gp_spec <- .gp_basis_spec(cbind(dat_df[["..x"]], dat_df[["..y"]]), ls_bounds, + c = gp_c) gp_k_auto <- is.null(gp_k) if (gp_k_auto) gp_k <- gp_spec$k if (is.null(gp_c)) gp_c <- gp_spec$c @@ -604,9 +836,6 @@ fit_bayesian_spatial_model <- function( if (!is.numeric(gp_k) || length(gp_k) != 1L || !is.finite(gp_k) || gp_k < 2) stop("fit_bayesian_spatial_model(): `gp_k` must be a single finite number >= 2.", call. = FALSE) - if (!is.numeric(gp_c) || length(gp_c) != 1L || !is.finite(gp_c) || gp_c <= 1) - 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.25) .log_warn( @@ -682,7 +911,15 @@ fit_bayesian_spatial_model <- function( # makes the prior far too diffuse and the adequacy check fire on every fit. # With scale = FALSE there is exactly one coordinate scaling, ours. gp_term <- .gp_formula_term(gp_k, gp_c, gp_iso) - fml <- stats::as.formula(sprintf("%s ~ %s + %s", response_var, rhs_terms, gp_term)) + # env = globalenv(), not this frame. A formula carries its environment, and + # brms stores the formula inside the brmsfit, so the default (the frame this + # line runs in) made the fit and its $engine capture THIS frame -- which by + # the end holds the brmsfit itself (`fit`), the data twice and every + # intermediate. An environment is serialised once but a list every time it + # is met, so saveRDS() wrote the whole brmsfit twice. The formula names + # columns of the data and brms's own gp(); nothing in it needs this frame. + fml <- stats::as.formula(sprintf("%s ~ %s + %s", response_var, rhs_terms, gp_term), + env = globalenv()) # Build priors in two independent steps: # 1. Regression coefficient priors (only when no user prior and predictors @@ -693,8 +930,10 @@ fit_bayesian_spatial_model <- function( if (is.null(prior)) { prior_parts <- list() if (isTRUE(standardize_predictors) && length(predictor_vars) > 0L) { + # One row per distributional parameter's slopes (.b_prior_rows()): a + # dpar-less row matches no slope of a categorical or mixture model. prior_parts <- c(prior_parts, list( - brms::set_prior("normal(0, 5)", class = "b") + .b_prior_rows("normal(0, 5)", fml, dat_df, family) )) .log_info("fit_bayesian_spatial_model(): using weakly informative normal(0,5) priors on standardized coefficients.") } @@ -764,14 +1003,13 @@ fit_bayesian_spatial_model <- function( # 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)) + # So is each one's dpar/nlpar/resp: a categorical or mixture family repeats + # the same names once per distributional parameter (see + # .lscale_coef_rows()), and dropping that address made every such fit fail. + ls_rows <- .lscale_coef_rows(fml, dat_df, family) - ls_prior <- if (length(ls_coefs) > 0L) { - Reduce(`+`, lapply(ls_coefs, function(k) - brms::set_prior(lscale_prior_spec, class = "lscale", coef = k))) + ls_prior <- if (!is.null(ls_rows)) { + .lscale_prior_rows(lscale_prior_spec, ls_rows) } 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 @@ -797,24 +1035,46 @@ fit_bayesian_spatial_model <- function( # does what it says. is_global_ls <- prior$class == "lscale" & !nzchar(prior$coef) if (any(is_global_ls)) { - 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)) - if (length(ls_coefs) > 0L) { + ls_rows <- .lscale_coef_rows(fml, dat_df, family) + if (!is.null(ls_rows)) { + # Each global row is expanded only onto the coefficients it addresses + # -- those with its own resp/dpar/nlpar, which is how brms resolves a + # global prior itself -- and never onto one the user already gave a + # coefficient-level prior. Expanding every row onto every coef name + # turned a dpar-level prior (dpar = "mumid" on a categorical fit) into + # rows for every category at once, duplicates brms refuses. + pcol <- function(nm) { + v <- if (nm %in% names(prior)) as.character(prior[[nm]]) + else rep("", nrow(prior)) + v[is.na(v)] <- "" + v + } + p_resp <- pcol("resp"); p_dpar <- pcol("dpar"); p_nlpar <- pcol("nlpar") + row_keys <- paste(ls_rows$coef, ls_rows$resp, ls_rows$dpar, + ls_rows$nlpar, sep = "\r") + user_keys <- paste(prior$coef, p_resp, p_dpar, p_nlpar, sep = "\r")[ + prior$class == "lscale" & nzchar(prior$coef)] expanded <- NULL + done <- rep(FALSE, nrow(prior)) + targets <- character(0) for (i in which(is_global_ls)) { - for (k in ls_coefs) { - row <- brms::set_prior(prior$prior[i], class = "lscale", coef = k) - expanded <- if (is.null(expanded)) row else expanded + row - } + hit <- ls_rows$resp == p_resp[[i]] & ls_rows$dpar == p_dpar[[i]] & + ls_rows$nlpar == p_nlpar[[i]] & !(row_keys %in% user_keys) + if (!any(hit)) next + tgt <- ls_rows[hit, , drop = FALSE] + part <- .lscale_prior_rows(prior$prior[[i]], tgt) + expanded <- if (is.null(expanded)) part else expanded + part + done[i] <- TRUE + targets <- c(targets, .lscale_row_labels(tgt)) + } + if (any(done)) { + kept <- prior[!done, , drop = FALSE] + prior <- if (nrow(kept) > 0L) kept + expanded else expanded + .log_info(paste0("fit_bayesian_spatial_model(): the supplied global ", + "'lscale' prior was attached to %s so that brms uses ", + "it (a global lscale prior is otherwise discarded)."), + paste(targets, collapse = ", ")) } - kept <- prior[!is_global_ls, , drop = FALSE] - prior <- if (nrow(kept) > 0L) kept + expanded else expanded - .log_info(paste0("fit_bayesian_spatial_model(): the supplied global ", - "'lscale' prior was attached to %s so that brms uses ", - "it (a global lscale prior is otherwise discarded)."), - paste(sQuote(ls_coefs), collapse = ", ")) } else { .log_warn(paste0("fit_bayesian_spatial_model(): the supplied prior has a ", "GLOBAL 'lscale' entry, which brms discards because ", @@ -862,9 +1122,14 @@ fit_bayesian_spatial_model <- function( stop(sprintf("fit_bayesian_spatial_model(): brms fit failed: %s", as.character(fit))) # ---- Convergence diagnostics ---- - convergence_ok <- TRUE + # NA until a check has actually run. It was TRUE from the start, so + # check_convergence = FALSE returned convergence_ok = TRUE over an empty + # diagnostics list -- a verdict on checks that never happened, for a fit + # whose max R-hat was 1.28 -- and print() had nothing to caveat. + convergence_ok <- NA convergence_diagnostics <- list() if (isTRUE(check_convergence) && inherits(fit, "brmsfit")) { + convergence_ok <- TRUE # Divergent transitions np <- tryCatch(brms::nuts_params(fit), error = function(e) NULL) if (!is.null(np)) { @@ -879,9 +1144,10 @@ fit_bayesian_spatial_model <- function( } } - # R-hat + # R-hat. Both accessors run under .muffle_ess_cap(): posterior's + # "The ESS has been capped" arrives once per well-mixed basis weight. rhat_vals <- tryCatch({ - rh <- brms::rhat(fit) + rh <- .muffle_ess_cap(brms::rhat(fit)) if (is.numeric(rh)) rh else NULL }, error = function(e) NULL) @@ -912,7 +1178,7 @@ fit_bayesian_spatial_model <- function( # Effective sample size ratio neff_vals <- tryCatch({ - ne <- brms::neff_ratio(fit) + ne <- .muffle_ess_cap(brms::neff_ratio(fit)) if (is.numeric(ne)) ne else NULL }, error = function(e) NULL) @@ -965,6 +1231,8 @@ fit_bayesian_spatial_model <- function( 100 * frac_below, gp_ell_min, gp_k, gp_k^2 ) } + # Every accessor failed, so nothing was checked after all. + if (!length(convergence_diagnostics)) convergence_ok <- NA } loo_obj <- NULL; looic <- NA_real_ @@ -981,7 +1249,11 @@ fit_bayesian_spatial_model <- function( looic <- suppressWarnings(as.numeric(-2 * est["elpd_loo", "Estimate"])) } } else { - .log_warn("fit_bayesian_spatial_model(): LOO computation failed.") + # With the cause: "LOO computation failed." alone left compare_models() + # showing LOOIC NA with nothing anywhere saying why. + .log_warn(paste0("fit_bayesian_spatial_model(): LOO computation failed, ", + "so $info$looic is NA. Cause: %s"), + .try_error_message(loo_try)) } } @@ -1003,20 +1275,23 @@ fit_bayesian_spatial_model <- function( gp_lscale_prior = gp_lscale_prior_used, gp_n_basis = gp_k^2, gp_ell_min = gp_ell_min, - # The scaled-coordinate extrema of the training data, and the pooled - # centred range brms derived the boundary from. predict() needs them: - # brms 2.x stores only Xgp/dmax/cmeans in the fit's GP basis, NOT the + # The scaled-coordinate extrema of the training data, the column means + # brms centred them on, and the pooled centred range it derived the + # boundary L = c * S from. predict() needs them: brms 2.17 to 2.22 + # store only Xgp/dmax/cmeans in the fit's GP basis, NOT the # Hilbert-space boundary L, so brms:::.data_gp() RECOMPUTES # L = c * range(centred newdata) from whatever rows predict() is handed. - # Without pinning, a point's prediction depends on which other points + # Unless L is held, a point's prediction depends on which other points # share the predict() call -- predict_surface()'s chunk_size changed the # surface, and every cv_bayes() fold was scored against a basis the model - # was not fitted with. See .pin_gp_boundary_rows(). + # was not fitted with. brms >= 2.23.0 stores L and reuses it. See + # .pin_gp_boundary_rows(). gp_xy_range = list( x = range(dat_df[["..x"]], na.rm = TRUE), y = range(dat_df[["..y"]], na.rm = TRUE) ), gp_S = gp_spec$S, + gp_cmeans = gp_spec$cmeans, gp_lengthscale_bounds = ls_bounds, convergence_ok = convergence_ok, n_dropped = n_dropped, diff --git a/R/model-classes.R b/R/model-classes.R index 40610f1..7d5f8ab 100644 --- a/R/model-classes.R +++ b/R/model-classes.R @@ -199,8 +199,18 @@ print.spatial_fit <- function(x, ...) { cat(sprintf(" CRS : %s\n", .fold_crs_label(x$data_sf))) if (subclass == "gwr_fit") { - cat(sprintf(" Bandwidth: %.4g (%s, %s kernel)\n", - x$info$bandwidth, + # "%.4g" printed a fixed bandwidth of 122372 m as "1.224e+05", rounded and + # without the unit the help page tells the reader to check. A count of + # neighbours for adaptive, a distance with the CRS's unit for fixed. + bw <- suppressWarnings(as.numeric(x$info$bandwidth %||% NA_real_))[1L] + bw_txt <- if (!is.finite(bw)) "unknown" + else if (isTRUE(x$info$adaptive)) sprintf("%s neighbours", format(bw)) + else { + u <- tryCatch(sf::st_crs(x$data_sf)$units_gdal, error = function(e) NULL) + sprintf("%s %s", format(signif(bw, 6), big.mark = ",", scientific = FALSE), + if (length(u) != 1L || is.na(u) || !nzchar(u)) "CRS units" else u) + } + cat(sprintf(" Bandwidth: %s (%s, %s kernel)\n", bw_txt, if (isTRUE(x$info$adaptive)) "adaptive" else "fixed", x$info$kernel %||% "bisquare")) if (is.finite(x$info$AICc %||% NA_real_)) @@ -212,7 +222,19 @@ print.spatial_fit <- function(x, ...) { x$info$gp_n_basis %||% NA_integer_)) if (is.finite(x$info$looic %||% NA_real_)) cat(sprintf(" LOOIC : %.2f\n", x$info$looic)) - if (!isTRUE(x$info$convergence_ok)) + # The coefficients of a standardised fit are per SD of each predictor, and + # nothing coef() returns says so. + if (length(x$info$predictor_scaling) > 0L) + cat(sprintf(paste0(" Predictors standardised: %s (coef() is per SD; ", + "see $info$predictor_scaling)\n"), + paste(names(x$info$predictor_scaling), collapse = ", "))) + # NA is "not checked" (check_convergence = FALSE, or no diagnostic could be + # read), which is neither a pass nor a failure; NULL (nothing recorded) + # still reads as a failure. + cv_ok <- x$info$convergence_ok + if (length(cv_ok) == 1L && is.na(cv_ok)) + cat(" Convergence: NOT CHECKED (fitted with check_convergence = FALSE?)\n") + else if (!isTRUE(cv_ok)) cat(" ** Convergence warnings present -- see $info$convergence_diagnostics\n") } invisible(x) @@ -318,6 +340,14 @@ print.summary.spatial_fit <- function(x, ...) { else cat("\n In-sample metrics:\n") m <- x$in_sample + # The metrics use the rows with a finite fitted value, which is not always + # all of them: an rf_fit has no out-of-bag prediction for a row every tree + # sampled (ranger returns NaN), so a 5-tree forest printed "n = 200" above + # an R^2 computed on 180 rows. + n_m <- m$n %||% NA_integer_ + if (length(n_m) == 1L && is.finite(n_m) && is.finite(x$n) && n_m < x$n) + cat(sprintf(" (computed on %d of %d rows; the rest have no finite fitted value)\n", + n_m, x$n)) # ASCII on purpose: a superscript two rendered as R on every # non-UTF-8 console, and the labels were not aligned. cat(sprintf(" RMSE = %.4f\n", m$RMSE)) @@ -333,6 +363,16 @@ print.summary.spatial_fit <- function(x, ...) { sprintf(" (over %d of %d rows)", n_s, m$n) else "" cat(sprintf(" SMAPE = %.2f%%%s\n", m$SMAPE, sub)) } + # The same convergence verdict print() on the fit gives. The summary carried + # it in $info and never showed it, so metrics from a posterior that had not + # converged printed exactly like metrics from one that had. + if (identical(x$class, "bayesian_fit") && "convergence_ok" %in% names(x$info)) { + cv_ok <- x$info$convergence_ok + if (length(cv_ok) == 1L && is.na(cv_ok)) + cat("\n Convergence: NOT CHECKED (fitted with check_convergence = FALSE?)\n") + else if (!isTRUE(cv_ok)) + cat("\n ** Convergence warnings present -- see $info$convergence_diagnostics\n") + } invisible(x) } @@ -360,16 +400,32 @@ print.summary.spatial_fit <- function(x, ...) { #' That is \strong{in-sample} for a \code{gwr_fit} or a \code{bayesian_fit}, #' but \strong{out-of-bag} for an \code{rf_fit}, whose \code{fitted()} method #' returns out-of-bag predictions (see \code{\link{fit_rf_model}}). The -#' returned data.frame carries no label distinguishing the two, so check -#' \code{object$info$fitted_are_oob} before comparing numbers across backends, -#' or use \code{\link{compare_models_cv}}, which scores every backend the -#' same way. +#' data.frame \code{model_metrics()} returns carries no label distinguishing +#' the two, so check \code{object$info$fitted_are_oob} before comparing +#' numbers across backends; \code{\link{evaluate_insample}()} and +#' \code{\link{compare_models}()} record it per model in a +#' \code{metric_basis} column. \code{\link{compare_models_cv}} scores every +#' backend the same way. +#' +#' \eqn{R^2} is \eqn{1 - RSS/TSS} with the total sum of squares taken about +#' the mean of the response the model was \emph{fitted} to. In sample that +#' is the ordinary \eqn{R^2}. With \code{newdata} it is out-of-sample +#' \eqn{R^2}, the convention every \code{cv_*()} function uses: the model is +#' measured against the prediction it had to beat, the training mean, not +#' against the new rows' own mean, which it could not have known. It is +#' below 0 when the model predicts the new rows worse than the training mean +#' does, and it is \code{NA} when the response does not vary about that +#' baseline by more than rounding error (100 machine epsilons of its +#' magnitude, whatever its units). #' #' @section Percentage errors on responses with zeros: #' \code{MAPE} divides by the observed value and \code{SMAPE} by #' \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. #' Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows #' whose denominator is non-zero, and are \code{NA} when no row qualifies. +#' Non-zero is judged at the scale of the data: a denominator no larger +#' than 100 machine epsilons times the largest one counts as zero, so the +#' rule does not depend on the units of the response. #' The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; #' the \code{n} column counts finite observation/prediction pairs. Read a #' percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is @@ -408,8 +464,11 @@ print.summary.spatial_fit <- function(x, ...) { #' For the Bayesian backend, \code{\link{cv_bayes}()} additionally reports #' CRPS and interval coverage at 50, 80 and 95 percent. Both are proper #' scoring rules computed from posterior draws, so they are meaningful for any -#' \code{family} the backend accepts, and they are the numbers to compare when -#' the response is not Gaussian. When every fold fails, the +#' \code{family} that predicts one number per row (a count, a rate, a binary +#' or bounded outcome), and they are the numbers to compare when the response +#' is not Gaussian. A categorical or ordinal family predicts a probability +#' per response category instead, so \code{cv_bayes()} refuses one before +#' fitting anything. When every fold fails, the #' \code{fold_metrics} frame \code{cv_bayes()} returns carries the CRPS column #' but not the \code{coverage_*} columns, so code that reads those columns #' must tolerate their absence. @@ -462,10 +521,23 @@ model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { y_obs <- sf::st_drop_geometry(newdata)[[object$response_var]] } y_obs <- .checked_response(y_obs, object$response_var, "model_metrics") + # R² on newdata is measured against the TRAINING mean, as every cv_*() + # measures it: the null prediction the model had to beat. It used the + # held-out rows' own mean, so the same predictions scored R² -0.89 here and + # 0.35 from cv_spatial() on a trend split. In sample the two means are the + # same number. A fit whose data_sf lacks a usable response keeps the + # held-out mean. + ytm <- NULL + if (!is.null(newdata)) { + y_tr <- tryCatch(suppressWarnings(as.numeric( + sf::st_drop_geometry(object$data_sf)[[object$response_var]])), + error = function(e) NULL) + if (length(y_tr) && any(is.finite(y_tr))) ytm <- mean(y_tr[is.finite(y_tr)]) + } # Adj R² is suppressed (p = NULL) because GWR's effective parameter count # far exceeds the global predictor count, and Bayesian GP models likewise # lack a simple p. This is consistent with the CV evaluation path. - .compute_reg_metrics(y_obs, y_hat, p = NULL) + .compute_reg_metrics(y_obs, y_hat, p = NULL, y_train_mean = ytm) } # --------------------------------------------------------------------------- @@ -513,7 +585,14 @@ model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { #' Predict from a GWR spatial model #' #' When \code{newdata} is NULL, returns the in-sample fitted values. -#' Otherwise uses \code{GWmodel::gwr.predict()} on the new locations. +#' Otherwise estimates the local coefficients at each new location with +#' \code{GWmodel::gwr.basic(regression.points = )}, with the fit's kernel and +#' bandwidth (an adaptive bandwidth counts neighbours among the training +#' points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. These are the +#' values \code{GWmodel::gwr.predict()} returns, without its prediction +#' variance, which this method never returned and which costs time cubic in +#' the number of training points. Each location stands alone: one that cannot +#' be estimated does not affect the others. #' \code{newdata} is first transformed to the CRS used during fitting #' (via \code{ensure_projected()}), so predictions are computed in a #' single coordinate system regardless of the CRS newdata arrives in. @@ -524,8 +603,11 @@ model_metrics.spatial_fit <- function(object, newdata = NULL, ...) { #' is supported). NULL = fitted values. #' @param ... Ignored. #' @return Numeric vector aligned to \code{nrow(newdata)}, with \code{NA} for -#' rows dropped as missing or non-finite. If \code{GWmodel::gwr.predict()} -#' fails, every value is \code{NA} and a warning says why. CRS-less +#' rows dropped as missing or non-finite, and for locations whose local +#' regression cannot be estimated (too few training points within a fixed +#' bandwidth, or a singular local design); a warning counts those. If the +#' design matrix for \code{newdata} cannot be built, every value is +#' \code{NA} and a warning says why. CRS-less #' \code{newdata} first receives the interpretation the training data got, so #' the same rows land where they did at fit time. #' @family methods on a fitted model @@ -546,7 +628,7 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { # Align newdata to the CRS used during fitting BEFORE prep_model_data(). # prep's own ensure_projected() call has no target and would leave # already-projected newdata in *its* CRS (or auto-pick a UTM zone for - # lon/lat input independent of training), after which gwr.predict() + # lon/lat input independent of training), after which the local regressions # would silently mix coordinates from two different systems. This # mirrors predict.bayesian_fit(). # CRS-less newdata first gets the interpretation the TRAINING data got @@ -571,54 +653,57 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { newdata$..orig_row_id.. <- NULL # Degrade to an all-NA vector when nothing survived cleaning, matching - # predict.rf_fit() and predict.bayesian_fit(). Without this the .to_sp() - # call below -- which sits outside the tryCatch -- would surface a raw - # sf-to-Spatial coercion error instead. + # predict.rf_fit() and predict.bayesian_fit(). Without this a zero-row + # layer would reach the chunk loop below and come back as a warning about + # the local regressions, which are not what went wrong. if (n_new == 0L) { .log_warn(paste0("predict.gwr_fit(): every row of newdata was dropped as ", "missing or non-finite; returning %d NA(s)."), n_orig) return(rep(NA_real_, n_orig)) } - # .to_sp() uses intersect() internally, so it gracefully handles newdata - # that lacks the response column (true out-of-sample prediction). needed_cols <- unique(c(object$response_var, object$predictor_vars)) sp_train <- .to_sp(object$data_sf, needed_cols) - sp_new <- .to_sp(newdata, needed_cols) bw <- object$info$bandwidth - if (isTRUE(object$info$adaptive)) bw <- as.integer(round(bw)) - - pred_obj <- tryCatch( - suppressWarnings( - GWmodel::gwr.predict( - object$formula, data = sp_train, predictdata = sp_new, - bw = bw, kernel = object$info$kernel %||% "bisquare", - adaptive = object$info$adaptive %||% TRUE - ) - ), - 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 - } + adaptive <- object$info$adaptive %||% TRUE + if (isTRUE(adaptive)) bw <- as.integer(round(bw)) + + # One local regression per new location (see .gwr_predict_at()), not + # GWmodel::gwr.predict(), which returned every prediction as NA in three + # common cases: one location with an empty or singular window (a grid cell + # beyond a fixed bandwidth, a point inside a held-out block) threw inv()'s + # error for all of them; more than 10000 training plus new rows failed on + # "object 'DM3.given' not found", and more than 5000 training rows on "No + # regression point is fixed". It also built the n_train x n_train hat + # matrix for a prediction variance this method never returned, cubic in the + # training size, on every call and so on every cv_gwr() fold. + preds_clean <- tryCatch( + .gwr_predict_at(object$formula, sp_train, + newdata_df = sf::st_drop_geometry(newdata), + rp = sf::st_coordinates(newdata)[, 1:2, drop = FALSE], + bw = bw, kernel = object$info$kernel %||% "bisquare", + adaptive = adaptive), + error = function(e) e ) - - preds_clean <- if (is.null(pred_obj)) { - rep(NA_real_, n_new) - } else { - .extract_gwr_values(pred_obj, newdata, object$formula, n_new, - object$response_var, mode = "predict") + if (inherits(preds_clean, "error")) { + # A real warning(), not only a logger line. A logger line is invisible + # to tryCatch(warning = ), to withCallingHandlers(), to + # testthat::expect_warning() and to R CMD check, so a predict() that + # returns nothing but NA left no trace a caller could act on. + .warn_and_log(paste0("predict.gwr_fit(): the local regressions could not ", + "be evaluated, so every prediction is NA. Cause: %s"), + conditionMessage(preds_clean)) + preds_clean <- rep(NA_real_, n_new) + } else if (anyNA(preds_clean)) { + n_na <- sum(is.na(preds_clean)) + .warn_and_log(paste0("predict.gwr_fit(): %d of %d location(s) have no ", + "estimable local regression, so their predictions are ", + "NA; the other %d are unaffected. Too few training ", + "points carry weight within the %s bandwidth (%s) ", + "there, or the local design is singular."), + n_na, n_new, n_new - n_na, + if (isTRUE(adaptive)) "adaptive" else "fixed", format(bw)) } # Expand back to original length, filling dropped rows with NA. @@ -674,15 +759,16 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { } -#' Pin the GP boundary by appending the training coordinate extrema +#' Hold the GP boundary at the value the model was fitted with #' -#' brms 2.x stores \code{Xgp}, \code{dmax} and \code{cmeans} in a fit's GP -#' basis but \strong{not} the Hilbert-space boundary \code{L}, so +#' brms 2.17 to 2.22 store \code{Xgp}, \code{dmax} and \code{cmeans} in a fit's +#' GP basis but \strong{not} the Hilbert-space boundary \code{L}, so #' \code{brms:::.data_gp()} recomputes #' \code{L = c * max(1, diff(range(centred Xgp)))} from whatever rows #' \code{predict()} is handed. Every eigenfunction and eigenvalue of the #' approximation therefore moves with the newdata bounding box while the fitted -#' basis coefficients stay put. +#' basis coefficients stay put. brms 2.23.0 stores \code{L} in the basis and +#' reuses it, so there the two repairs below are unnecessary and harmless. #' #' Measured on a fitted model: \code{L} was 5.57 at fit time, 4.02 for a #' five-row \code{newdata} and 3.63 for one row; \code{predict_surface()} on the @@ -691,41 +777,58 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { #' predicts each test fold separately, scored every fold against a basis the #' model was never fitted with. #' -#' The repair is to make the pooled centred range of the rows brms sees equal -#' the training one: append two synthetic rows at the training extrema, predict, -#' then drop their columns. \code{cmeans} already comes from the stored basis, -#' so pinning the range reproduces the fitted \code{L} exactly for any newdata -#' inside the training envelope. +#' The first repair makes the pooled centred range of the rows brms sees at +#' least the training one: append two synthetic rows at the training extrema, +#' predict, then drop their columns. \code{cmeans} already comes from the +#' stored basis, so for newdata inside the training envelope that reproduces +#' the fitted \code{L} exactly. Appending rows cannot narrow the range, +#' though: one row past the pooled extremes still widened \code{L}, and with it +#' the prediction of EVERY row in the call (on brms 2.20.4 one row 100 m past +#' the bbox moved interior predictions by up to 0.08, and a grid padded 15\% +#' past it moved in-bbox cells by 0.31 on average). The second repair is for +#' that case: \code{c_scale = S_fit / S_new} (\code{.gp_c_scale()}), by which +#' \code{predict()} multiplies the \code{c} of the gp() term +#' (\code{.scale_gp_c()}), so brms rebuilds +#' \code{L = c * c_scale * S_new = c * S_fit}, the fitted value. +#' +#' Rows further than \code{L} from the training centre on either axis are +#' flagged in \code{beyond}. The Dirichlet eigenfunctions vanish at +#' \code{+/- L} and continue past it as an odd reflection of the fitted +#' surface, so a prediction there means nothing on any brms version. #' #' @param object A \code{bayesian_fit}. #' @param pred_df The prediction data.frame from #' \code{.prepare_brms_pred_df()}. -#' @return A list with \code{df} (possibly with rows appended) and \code{n_pad} -#' (how many were appended, to be dropped from the draw matrix). +#' @return A list with \code{df} (possibly with rows appended), \code{n_pad} +#' (how many were appended, to be dropped from the draw matrix), +#' \code{c_scale} (the factor for the gp() term's \code{c}; 1 when the rows +#' do not widen the range or the fit lacks what computing it needs) and +#' \code{beyond} (logical, one per row of \code{pred_df}). #' @keywords internal #' @noRd .pin_gp_boundary_rows <- function(object, pred_df) { + none <- list(df = pred_df, n_pad = 0L, c_scale = 1, + beyond = rep(FALSE, nrow(pred_df))) rng <- object$info$gp_xy_range if (is.null(rng) || !all(c("..x", "..y") %in% names(pred_df)) || !nrow(pred_df)) - return(list(df = pred_df, n_pad = 0L)) + return(none) xr <- suppressWarnings(as.numeric(rng$x)) yr <- suppressWarnings(as.numeric(rng$y)) if (length(xr) != 2L || length(yr) != 2L || !all(is.finite(c(xr, yr)))) - return(list(df = pred_df, n_pad = 0L)) + return(none) - # Warn when newdata reaches outside the training envelope: the boundary then - # has to grow past the fitted one whatever we do, and the predictions there - # are extrapolation from a basis that was not built for them. + # Say when newdata reaches outside the training envelope: with the boundary + # held, those predictions no longer depend on the other rows, but they are + # still extrapolation from a basis fitted without data there. ox <- range(pred_df[["..x"]], na.rm = TRUE) oy <- range(pred_df[["..y"]], na.rm = TRUE) if (any(is.finite(c(ox, oy))) && (ox[1L] < xr[1L] || ox[2L] > xr[2L] || oy[1L] < yr[1L] || oy[2L] > yr[2L])) .log_info(paste0("predict.bayesian_fit(): `newdata` reaches outside the ", - "training coordinate envelope, so the GP basis is ", - "evaluated beyond the boundary it was fitted with; those ", - "predictions are extrapolation.")) + "training coordinate envelope; those predictions are ", + "extrapolation.")) pad <- pred_df[c(1L, 1L), , drop = FALSE] pad[["..x"]] <- xr @@ -733,28 +836,156 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { rownames(pad) <- NULL out <- rbind(pred_df, pad) rownames(out) <- NULL - list(df = out, n_pad = 2L) + res <- list(df = out, n_pad = 2L, c_scale = 1, beyond = none$beyond) + + # The centre brms uses. A fit saved before gp_cmeans was stored gets it the + # way brms got it: from the unique training rows it was fitted on. + cm <- object$info$gp_cmeans + ed <- object$engine$data + if (is.null(cm) && is.data.frame(ed) && all(c("..x", "..y") %in% names(ed))) + cm <- colMeans(unique(cbind(ed[["..x"]], ed[["..y"]]))) + cm <- suppressWarnings(as.numeric(cm)) + S_fit <- suppressWarnings(as.numeric(object$info$gp_S)) + c_fit <- suppressWarnings(as.numeric(object$info$gp_c)) + if (length(cm) != 2L || !all(is.finite(cm)) || + length(S_fit) != 1L || !isTRUE(S_fit > 0) || + length(c_fit) != 1L || !isTRUE(c_fit > 0)) + return(res) + + L_fit <- c_fit * S_fit + res$beyond <- abs(pred_df[["..x"]] - cm[1L]) > L_fit | + abs(pred_df[["..y"]] - cm[2L]) > L_fit + res$c_scale <- .gp_c_scale(cbind(out[["..x"]], out[["..y"]]), cm, S_fit) + res +} + + +#' The factor that makes brms rebuild the fitted GP boundary from new rows +#' +#' brms 2.17 to 2.22 build \code{L = c * S_new} at predict time, where +#' \code{S_new = max(1, pooled range)} of the unique newdata rows centred on +#' the training \code{cmeans} (\code{brms:::.data_gp()}, +#' \code{brms:::choose_L()}). Handing brms \code{c * S_fit / S_new} in place +#' of \code{c} therefore gives back \code{L = c * S_fit}. Pure arithmetic, so +#' it is tested without Stan. +#' +#' @param xy Numeric matrix; its first two columns are the scaled coordinates +#' of every row brms will be handed. +#' @param cmeans Length-2 training column means. +#' @param S_fit The pooled centred training range (\code{$info$gp_S}). +#' @return \code{S_fit / S_new}; 1 when no coordinate is finite. +#' @keywords internal +#' @noRd +.gp_c_scale <- function(xy, cmeans, S_fit) { + xy <- unique(as.matrix(xy)[, 1:2, drop = FALSE]) + Xc <- sweep(xy, 2L, cmeans) + if (!any(is.finite(Xc))) return(1) + S_new <- max(1, max(Xc[is.finite(Xc)]) - min(Xc[is.finite(Xc)])) + S_fit / S_new +} + + +#' Scale the boundary factor of the gp() term in a brmsfit's formula +#' +#' brms re-reads \code{c} from the gp() term of \code{$formula} at every +#' predict call, so a copy of the fit with a rescaled \code{c} is how +#' \code{predict()} holds the boundary on brms < 2.23.0; see +#' \code{.pin_gp_boundary_rows()}. Only the terms of the right-hand-side sum +#' are searched, which is where \code{fit_bayesian_spatial_model()} puts it. +#' +#' @param model_obj A \code{brmsfit}, or anything with \code{$formula$formula}. +#' @param c_scale Positive factor. +#' @return \code{model_obj} with the gp() term's \code{c} multiplied by +#' \code{c_scale}, or \code{NULL} when there is no such term. +#' @keywords internal +#' @noRd +.scale_gp_c <- function(model_obj, c_scale) { + found <- FALSE + rw <- function(e) { + if (is.call(e) && identical(e[[1L]], as.name("gp")) && !is.null(e[["c"]])) { + e[["c"]] <- eval(e[["c"]], baseenv()) * c_scale + found <<- TRUE + } else if (is.call(e) && identical(e[[1L]], as.name("+"))) { + for (i in seq_along(e)[-1L]) e[[i]] <- rw(e[[i]]) + } + e + } + f <- model_obj$formula$formula + if (!inherits(f, "formula") || length(f) != 3L) return(NULL) + f[[3L]] <- rw(f[[3L]]) + if (!found) return(NULL) + model_obj$formula$formula <- f + model_obj } +#' Refuse a per-category posterior_epred() with a message that says why +#' +#' For an ordinal or categorical family \code{brms::posterior_epred()} returns +#' a draws x rows x categories \emph{array}: a probability per category, not +#' one expected value per row. \code{predict.bayesian_fit()} took anything +#' that was not a matrix for a failed draw, so a real \code{cumulative()} fit +#' returned all-\code{NA} predictions under "posterior draw failed", and +#' \code{fitted()} said only that it got an array where it wanted a matrix -- +#' though the fit's own documentation listed ordinal families as supported. +#' +#' @param draws What \code{posterior_epred()} returned. +#' @param engine The \code{brmsfit}, to name its family. +#' @param caller Method name for the message. +#' @param hint What to do instead, appended to the message. +#' @return \code{NULL}, invisibly, when \code{draws} is not a 3-D array. +#' @keywords internal +#' @noRd +.stop_if_category_epred <- function(draws, engine, caller, hint) { + if (!is.array(draws) || length(dim(draws)) != 3L) return(invisible(NULL)) + fam <- .brms_family_name(tryCatch(engine$family, error = function(e) NULL)) + stop(sprintf(paste0("%s(): %s gives a probability per response category, ", + "so brms::posterior_epred() returned a %s array (draws x ", + "rows x categories), not one expected value per row. %s"), + caller, + if (is.na(fam)) "this fit's family" + else sprintf("the %s family", sQuote(fam)), + paste(dim(draws), collapse = " x "), hint), call. = FALSE) +} + +# What predict.bayesian_fit() offers instead for a category family: the +# posterior predictive draws, which go through the method's own newdata +# pipeline. A draw of Y is category k with the posterior mean probability of +# k, so the share of draws in k estimates exactly what posterior_epred() +# would average to. +.category_draws_hint <- paste0( + "Use type = \"predict\", draws = TRUE for posterior draws of the predicted ", + "category (as category indices); the share of draws in each category ", + "estimates its probability. brms::posterior_epred($engine) gives the ", + "probabilities for the training rows.") + + #' Predict from a Bayesian spatial GP model #' -#' @section The GP boundary is pinned: -#' brms 2.x does not store the Hilbert-space boundary \eqn{L} in a fitted GP -#' basis, so \code{brms:::.data_gp()} recomputes it from whatever rows -#' \code{predict()} is handed, which moved every eigenfunction of the +#' @section The GP boundary is held at its fitted value: +#' brms 2.17 to 2.22 do not store the Hilbert-space boundary \eqn{L} in a +#' fitted GP basis, so \code{brms:::.data_gp()} recomputes it from whatever +#' rows \code{predict()} is handed, which moved every eigenfunction of the #' approximation with the newdata bounding box while the fitted basis #' coefficients stayed put. Two synthetic rows at the training coordinate -#' extrema are therefore appended before the posterior draw and dropped from the -#' result, reproducing the boundary the model was fitted with, so chunked, -#' fold-wise and single-call predictions agree. +#' extrema are therefore appended before the posterior draw and dropped from +#' the result, and when \code{newdata} reaches past the training range the +#' \code{c} of the \code{gp()} term is scaled down by as much as the range +#' grew, so brms rebuilds exactly the boundary the model was fitted with. A +#' prediction therefore does not depend on which other rows share the call: +#' chunked, fold-wise and single-call predictions agree, and +#' \code{\link{predict_surface}()} does not depend on \code{chunk_size}. +#' brms 2.23.0 and later store \eqn{L} and reuse it, so there \code{c} is left +#' alone and the two extra rows change nothing. #' -#' That is exact only for \code{newdata} \strong{inside} the training -#' coordinate envelope. Beyond it the boundary has to grow whatever is done, so -#' predictions there are extrapolation from a basis that was not built for them -#' \emph{and} depend on which other rows share the call, including on -#' \code{\link{predict_surface}()}'s \code{chunk_size}. A notice is written to -#' the log (not raised as a warning) when it happens. +#' Predictions outside the training coordinate envelope are extrapolation (a +#' notice is written to the log). A row further than \eqn{L} from the centre +#' of the training coordinates on either axis is past the edge of the basis, +#' where the approximate GP is an odd reflection of the fitted surface rather +#' than an estimate of anything, so it is returned as \code{NA} (a column of +#' \code{NA} with \code{draws = TRUE}) with a warning. The default boundary +#' factor puts that edge well outside the training data, so only +#' \code{newdata} reaching far past it is affected. #' #' @description #' Applies the same newdata preparation pipeline as \code{predict.gwr_fit()}: @@ -775,10 +1006,19 @@ predict.gwr_fit <- function(object, newdata = NULL, ...) { #' point summary. Default FALSE. #' @param ... Ignored. #' @return Numeric vector of length \code{nrow(newdata)}, or a -#' \code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE} (a 1-row -#' all-\code{NA} matrix if the posterior draw fails). With -#' \code{newdata = NULL} the cached \code{fitted()} values are returned only -#' for the default \code{summary = "mean"}, \code{type = "epred"}, +#' \code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. If the +#' posterior draw fails the result is all \code{NA} (a 1-row matrix for +#' \code{draws = TRUE}) and the cause is logged. An ordinal or categorical +#' family is not a failed draw and is an error under +#' \code{type = "epred"}: its expected value is a probability per response +#' category, not one number per row. Use \code{type = "predict", +#' draws = TRUE} for posterior draws of the predicted category, as category +#' indices; the share of draws in each category estimates its probability. +#' Without \code{draws = TRUE}, \code{type = "predict"} returns the mean (or +#' median) category index, an expected rank for an ordinal family and an +#' error for \code{brms::categorical()}, whose categories have no order. +#' With \code{newdata = NULL} the cached \code{fitted()} values are returned +#' only for the default \code{summary = "mean"}, \code{type = "epred"}, #' \code{draws = FALSE} combination; any other combination is recomputed #' against the training data, because the cache holds epred column means and #' nothing else. @@ -813,6 +1053,19 @@ predict.bayesian_fit <- function(object, newdata = NULL, if (!inherits(model_obj, "brmsfit")) stop("predict.bayesian_fit(): engine is not a brmsfit object.", call. = FALSE) + # type = "predict" draws category INDICES for a category family. Their + # mean (or median) is an expected rank for an ordinal family, but nothing + # at all for brms::categorical(), whose categories have no order: it came + # back as 1.46, 1.97, 1.48, ... with no word. + if (type == "predict" && !isTRUE(draws) && + identical(.brms_family_name(tryCatch(model_obj$family, + error = function(e) NULL)), + "categorical")) + stop(paste0("predict.bayesian_fit(): the 'categorical' family's categories ", + "have no order, so the ", summary, " of the predicted category ", + "indices is not a prediction. ", .category_draws_hint), + call. = FALSE) + # ---- Preprocessing: match the pipeline used during fitting ---- # Ensure newdata is in the same projected CRS that was used for training, # BEFORE prep_model_data(): prep's own ensure_projected() has no target and @@ -845,18 +1098,58 @@ predict.bayesian_fit <- function(object, newdata = NULL, # Build prediction data.frame with scaled coordinates & standardised predictors pred_df <- .prepare_brms_pred_df(object, newdata) - # Draw from posterior. The two padding rows pin the GP boundary to the one - # the model was fitted with -- see .pin_gp_boundary_rows() -- and their - # columns are dropped again immediately. - pinned <- .pin_gp_boundary_rows(object, pred_df) + # Draw from posterior. The two padding rows and, on brms < 2.23.0, the + # rescaled gp(c = ) hold the GP boundary at the one the model was fitted + # with -- see .pin_gp_boundary_rows() -- and the padding columns are dropped + # again immediately. brms >= 2.23.0 reuses the fitted boundary itself. + pinned <- .pin_gp_boundary_rows(object, pred_df) + if (pinned$c_scale < 1 && utils::packageVersion("brms") < "2.23.0") { + held <- .scale_gp_c(model_obj, pinned$c_scale) + if (is.null(held)) + .warn_and_log(paste0("predict.bayesian_fit(): `newdata` widens the GP ", + "boundary and the engine's formula has no gp(c = ) ", + "term to hold it with, so these predictions depend ", + "on which rows share the call.")) + else model_obj <- held + } + if (any(pinned$beyond)) + .warn_and_log(paste0("predict.bayesian_fit(): %d of %d row(s) of `newdata` ", + "lie beyond the GP boundary the model was fitted with ", + "(further than L = %.3g scaled units from the centre ", + "of the training coordinates), where the approximate ", + "GP means nothing; they are returned as NA."), + sum(pinned$beyond), length(pinned$beyond), + object$info$gp_c * object$info$gp_S) draw_fn <- if (type == "epred") brms::posterior_epred else brms::posterior_predict draw_mat <- try(draw_fn(model_obj, newdata = pinned$df), silent = TRUE) if (is.matrix(draw_mat) && pinned$n_pad > 0L && ncol(draw_mat) == nrow(pinned$df)) draw_mat <- draw_mat[, seq_len(ncol(draw_mat) - pinned$n_pad), drop = FALSE] - + # An ordinal or categorical epred is a draws x rows x categories array; the + # padding rows are dropped from it too, so the message below counts the + # caller's rows (it said "150 x 7 x 3" for five). + if (is.array(draw_mat) && length(dim(draw_mat)) == 3L && pinned$n_pad > 0L && + dim(draw_mat)[2L] == nrow(pinned$df)) + draw_mat <- draw_mat[, seq_len(dim(draw_mat)[2L] - pinned$n_pad), , + drop = FALSE] + if (is.matrix(draw_mat) && ncol(draw_mat) == length(pinned$beyond)) + draw_mat[, pinned$beyond] <- NA_real_ + + # Not a failed draw: an ordinal or categorical family's epred. Raised, not + # returned as NA, because no retry will produce one number per row. The + # probabilities for new rows are not offered through + # brms::posterior_epred($engine, newdata = ): the engine needs the + # scaled ..x/..y (and standardised predictors) this method builds, and it + # refused the user's newdata. The share of predicted-category draws in + # each category estimates the same posterior mean probability. + if (type == "epred") + .stop_if_category_epred(draw_mat, model_obj, "predict.bayesian_fit", + hint = .category_draws_hint) if (inherits(draw_mat, "try-error") || !is.matrix(draw_mat)) { - .log_warn("predict.bayesian_fit(): posterior draw failed.") + .log_warn("predict.bayesian_fit(): posterior draw failed: %s", + if (inherits(draw_mat, "try-error")) .try_error_message(draw_mat) + else sprintf("brms returned a %s, not a draws x rows matrix", + class(draw_mat)[1L])) # Honour the documented return shape: a matrix when draws = TRUE, so a # caller that indexes columns is not handed a vector on the failure path. return(if (draws) matrix(NA_real_, nrow = 1L, ncol = n_orig) @@ -939,13 +1232,18 @@ fitted.gwr_fit <- function(object, ...) { #' here: \code{\link{clear_fitted_cache}} on one copy empties the cache both #' share (harmless, since 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. +#' \code{data_sf} only. The entry is also tied to the engine that computed +#' it -- a refit or \code{update()} of the \code{brmsfit} is a different +#' sampling run and recomputes -- but a \code{brmsfit} edited by hand in place +#' is what \code{\link{clear_fitted_cache}} is for. The entry holds only the +#' values and a small identifier of the sampling run, so a fit saved with +#' \code{saveRDS()} after \code{fitted()} is no larger for it. #' #' @param object A \code{bayesian_fit}. #' @param ... Ignored. -#' @return Numeric vector of length \code{object$n} (all \code{NA} if the -#' posterior draw failed). +#' @return Numeric vector of length \code{object$n}. A posterior that cannot +#' be drawn is an error, as is a family with a probability per response +#' category (ordinal, categorical), which has no single fitted value per row. #' @family methods on a fitted model #' @export fitted.bayesian_fit <- function(object, ...) { @@ -966,12 +1264,13 @@ fitted.bayesian_fit <- function(object, ...) { # SAME data hash identically however different their engines are -- and # because the cache is shared by every copy of a fit, `refit <- fit; # refit$engine <- ` then read the original engine's fitted - # values back out. identical() is cheap here: for the common case it is - # the same object, which R settles by pointer. Holding the reference - # costs no memory -- the fit already holds the engine. + # values back out. It holds .fitted_engine_token(), not necessarily the + # engine itself: see there for why holding the engine doubled saveRDS(). + # identical() is cheap here: for the common case it is the same object, + # which R settles by pointer. if (is.list(hit) && identical(hit$n, object$n) && identical(hit$key, key) && - identical(hit$engine, object$engine) && + identical(hit$engine, .fitted_engine_token(object$engine)) && is.numeric(hit$values) && length(hit$values) == object$n) return(hit$values) # Stale: a copy carrying different data or a different engine, or an entry @@ -992,11 +1291,20 @@ fitted.bayesian_fit <- function(object, ...) { # An error here is an error: a posterior that cannot be drawn used to come # back as all-NA fitted values with nothing said, and summary() and # model_metrics() then reported n = 0 as though the data were missing. - # predict.bayesian_fit() has always raised; this matches it. + # (predict.bayesian_fit() differs on purpose: it documents an all-NA result + # for a failed draw on newdata, and logs the cause.) if (inherits(draws, "try-error")) stop(sprintf(paste0("fitted.bayesian_fit(): brms::posterior_epred() failed ", "on the training data: %s"), conditionMessage(attr(draws, "condition"))), call. = FALSE) + .stop_if_category_epred(draws, model_obj, "fitted.bayesian_fit", + hint = paste0("fitted(), residuals(), summary() and ", + "model_metrics() need one number per ", + "row; use predict(, type = ", + "\"predict\", draws = TRUE) for ", + "predicted categories, or ", + "brms::posterior_epred($engine) ", + "for the probabilities.")) if (!is.matrix(draws) || ncol(draws) != object$n) stop(sprintf(paste0("fitted.bayesian_fit(): brms::posterior_epred() returned ", "%s where a draws x %d matrix was expected."), @@ -1009,7 +1317,8 @@ fitted.bayesian_fit <- function(object, ...) { # 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, engine = object$engine, + list(n = object$n, key = key, + engine = .fitted_engine_token(object$engine), values = fitted_vals), envir = cache) } @@ -1018,6 +1327,34 @@ fitted.bayesian_fit <- function(object, ...) { } +#' What a fitted() cache entry keeps to tell one engine from another +#' +#' The entry must belong to the engine that produced it (see +#' \code{fitted.bayesian_fit}), and it used to hold the engine itself. That +#' costs nothing in memory, but \code{serialize()} tracks environments by +#' reference and lists not at all, so \code{saveRDS()} on a fit whose cache was +#' warm -- after any \code{summary()}, \code{residuals()} or +#' \code{model_metrics()} -- wrote the whole brmsfit a second time: a 40 MB +#' engine saved as 80 MB before \code{fitted()} and 120 MB after. +#' +#' A brmsfit carries a stanfit, and every stanfit carries an environment +#' (\code{@.MISC}) that rstan's sampler, and brms's reader for CmdStan output, +#' create afresh for each run. Copies of the engine share it, a refit or an +#' \code{update()} gets a new one, and it is serialised once however many +#' references point at it, so it tells engines apart as well as the engine +#' does and adds nothing to a saved fit. Any other engine (a custom backend, +#' a test double) is its own token, as before. +#' +#' @param engine The fit's \code{$engine}. +#' @return An environment, or \code{engine}. +#' @keywords internal +#' @noRd +.fitted_engine_token <- function(engine) { + misc <- tryCatch(engine$fit@.MISC, error = function(e) NULL) + if (is.environment(misc)) misc else engine +} + + #' Cheap fingerprint of the training data a cached fitted() was computed from #' #' Covers exactly what \code{.prepare_brms_pred_df()} reads: the attribute @@ -1213,10 +1550,29 @@ coef.gwr_fit <- function(object, ...) { #' already absorbed the spatially structured part of the signal, so these are #' effects net of location. #' +#' @section Standardised predictors: +#' The summaries are on the scale the model was fitted on. A fit made with +#' \code{standardize_predictors = TRUE} was fitted on centred and scaled +#' numeric predictors, so each slope is the change in the linear predictor per +#' \emph{standard deviation} of its predictor and the intercept is its value +#' at the predictor \emph{means}, not the raw-unit numbers \code{stats::lm()} +#' reports on the same formula. Nothing on the returned matrix says so; +#' \code{print()} on the fit does, and the centre and scale of each predictor +#' are in \code{object$info$predictor_scaling}. To put a slope back in raw +#' units divide its \code{Estimate}, \code{Est.Error} and interval bounds by +#' that predictor's \code{scale}. The intercept's \code{Estimate} follows by +#' linearity (subtract each raw-unit slope times its predictor's +#' \code{center}), but its \code{Est.Error} and interval depend on the +#' posterior covariance of the coefficients: transform the draws from +#' \code{brms::as_draws_df(object$engine)} for those, or refit without +#' standardising. +#' #' @param object A \code{bayesian_fit} object. #' @param ... Ignored. #' @return A matrix of fixed-effect posterior summaries, as returned by -#' \code{brms::fixef()}. Never \code{NULL}: a missing 'brms' or a failing +#' \code{brms::fixef()}, on the fitted scale (per standard deviation of each +#' predictor under \code{standardize_predictors = TRUE}; see above). Never +#' \code{NULL}: a missing 'brms' or a failing #' \code{fixef()} call errors, following the \code{coef()} contract described #' in \code{\link{new_spatial_fit}}. #' @family methods on a fitted model diff --git a/R/model-gwr.R b/R/model-gwr.R index 6c97da1..3e2efa1 100644 --- a/R/model-gwr.R +++ b/R/model-gwr.R @@ -2,47 +2,17 @@ # Internal helpers # ----------------------------------------------------------------------------- -#' Validate a GWR kernel name -#' -#' 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 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 -#' @noRd -.validate_kernel <- function(kernel) { - valid <- c("bisquare", "gaussian", "tricube", "boxcar", "exponential") - kernel <- tolower(kernel) - if (!kernel %in% valid) { - .log_warn("fit_gwr_model(): unknown kernel '%s'; falling back to 'bisquare'.", kernel) - kernel <- "bisquare" - } - kernel -} - - #' Coerce an sf object to SpatialPointsDataFrame for GWmodel #' -#' GWmodel's core functions (gwr.basic, bw.gwr, gwr.predict) currently +#' GWmodel's core functions (gwr.basic, bw.gwr, gwr.model.selection) currently #' require Spatial* inputs. Unlike the archived spgwr package, GWmodel is #' actively maintained and may gain native sf support in the future; #' centralizing the coercion here makes a future migration trivial. #' #' @param data_sf An sf object with POINT geometry. #' @param keep_cols Character vector of column names to retain. NULL = all. -#' @return A SpatialPointsDataFrame. +#' @return A SpatialPointsDataFrame with two coordinate columns (any Z or M +#' is dropped). #' @keywords internal #' @noRd .to_sp <- function(data_sf, keep_cols = NULL) { @@ -52,10 +22,144 @@ keep_cols <- intersect(keep_cols, names(data_sf)) data_sf <- data_sf[, keep_cols, drop = FALSE] } + # GWmodel is strictly 2-D: gw.dist() rejects a third coordinate column for + # the data points and reshapes regression points with matrix(, ncol = 2). + # prep_model_data() already drops Z/M; this covers the callers that skip it + # (fit_gwr_model(.already_prepped = TRUE)) and a fit made before it did. + data_sf <- .drop_zm(data_sf) methods::as(data_sf, "Spatial") } +#' Is GWmodel's AICc outside its domain? +#' +#' GWmodel's AICc (Hurvich et al. 1998, its C++ \code{gwr_diag1()} and +#' \code{AICc_rss1()}) is +#' \deqn{n \log(RSS/n) + n \log(2\pi) + n (n + tr S) / (n - 2 - tr S),} +#' defined only for \eqn{tr S < n - 2}. Past that point the penalty changes +#' sign, and a (near-)interpolating fit scores a huge NEGATIVE AICc that ranks +#' it first everywhere it is compared. GWmodel's AIC from the same fit is +#' \eqn{n \log(RSS/n) + n \log(2\pi) + n + tr S}, so +#' \eqn{AICc - AIC = (n + tr S)(2 + tr S) / (n - 2 - tr S)}: AICc exceeds AIC +#' exactly when the denominator is positive. The domain is therefore read off +#' GWmodel's own two numbers, without the hat-matrix trace (which gwr.basic() +#' does not return, and which \code{enp = 2 tr S - tr S'S} is not). An +#' infinite AICc (a residual sum of squares of exactly 0, or +#' \eqn{tr S = n - 2}) is outside the domain too. +#' +#' @param aic,aicc Numeric vectors of equal length, GWmodel's AIC and AICc. +#' @return Logical vector: \code{TRUE} where AICc is known to be undefined, +#' \code{FALSE} where it is defined or cannot be checked (\code{NA} AIC). +#' @keywords internal +#' @noRd +.gwr_aicc_undefined <- function(aic, aicc) { + aic <- suppressWarnings(as.numeric(aic)) + aicc <- suppressWarnings(as.numeric(aicc)) + is.infinite(aicc) | (is.finite(aic) & is.finite(aicc) & aicc <= aic) +} + + +#' GWmodel's hat-matrix trace, recovered from its AIC +#' +#' \code{AIC - (n log(RSS/n) + n log(2 pi) + n)}; see +#' \code{.gwr_aicc_undefined()}. For messages only: it loses precision when +#' the residual sum of squares is tiny, and is \code{NA} when it is zero. +#' @keywords internal +#' @noRd +.gwr_trace_s <- function(aic, rss, n) { + tr <- suppressWarnings(as.numeric(aic) - + (n * log(as.numeric(rss) / n) + n * log(2 * pi) + n)) + if (length(tr) == 1L && is.finite(tr)) tr else NA_real_ +} + + +#' Smallest adaptive bandwidth that leaves every local fit a residual df +#' +#' GWmodel's bisquare and tricube kernels give the k-th nearest neighbour, +#' which sets the adaptive distance, a weight of exactly zero, so an adaptive +#' bandwidth of k fits each window on k - 1 points. A floor of +#' \code{n_params + 1} therefore made every window an exact interpolator for +#' those two kernels (tr S = n, R2 = 1, AICc near -n^2/2). The boxcar keeps +#' the k-th neighbour and the Gaussian and exponential kernels weight every +#' point, so \code{n_params + 1} leaves them one residual degree of freedom. +#' No floor keeps tr S below n - 2 at small n; \code{.gwr_aicc_undefined()} +#' is the guard for that. +#' +#' @param n_params Parameters in the local model, the intercept included. +#' @param kernel The kernel name. +#' @return Integer. +#' @keywords internal +#' @noRd +.gwr_min_adaptive_bw <- function(n_params, kernel) { + as.integer(n_params) + if (kernel %in% c("bisquare", "tricube")) 2L else 1L +} + + +#' Warn when a fixed GWR bandwidth is tiny against the data's extent +#' +#' A fixed bandwidth is a length in the CRS the fit runs in, and that is not +#' necessarily the CRS the caller was looking at: prep_model_data() projects +#' geographic input, so 0.2 "degrees" becomes 0.2 metres and every local +#' regression is empty. Shared by \code{fit_gwr_model()} and +#' \code{gwr_model_selection()}, whose sweep otherwise died on GWmodel's bare +#' "inv(): matrix is singular" with nothing about the bandwidth. +#' +#' @param dat The prepared sf layer the fit runs on. +#' @param bandwidth The supplied fixed bandwidth. +#' @param fn Name of the calling function, for the message. +#' @return Invisibly \code{NULL}; called for the warning. +#' @keywords internal +#' @noRd +.gwr_warn_tiny_fixed_bw <- function(dat, bandwidth, fn) { + fit_units <- tryCatch(sf::st_crs(dat)$units_gdal, error = function(e) NULL) + extent_x <- suppressWarnings(tryCatch({ + bb <- sf::st_bbox(dat); as.numeric(bb[["xmax"]] - bb[["xmin"]]) + }, error = function(e) NA_real_)) + if (length(extent_x) == 1L && is.finite(extent_x) && extent_x > 0 && + as.numeric(bandwidth) < extent_x / 1e4) { + .warn_and_log(paste0("%s(): a fixed bandwidth of %s is less ", + "than a ten-thousandth of the data's extent (%s %s ", + "across). The bandwidth is a distance in the CRS the ", + "fit runs in (%s), which prep_model_data() may have ", + "chosen -- geographic input is projected first, so a ", + "value in degrees is read as metres. Every local ", + "window is likely to be empty."), + fn, format(as.numeric(bandwidth)), format(signif(extent_x, 4)), + if (is.null(fit_units) || is.na(fit_units)) "unit" + else fit_units, + tryCatch(sf::st_crs(dat)$input, error = function(e) "unknown")) + } + invisible(NULL) +} + + +#' The explanation appended to GWmodel's "matrix is singular" +#' +#' One exactly singular window makes Armadillo's \code{inv()} throw and +#' GWmodel stop the whole call; the bare message names neither the window nor +#' the cause. Used by \code{fit_gwr_model()} (with the survey's count of +#' singular windows) and by \code{gwr_model_selection()} (without one). +#' +#' @param n_sing Number of singular windows the survey found, or 0 when +#' there was no survey. +#' @return A character string starting with " -- ". +#' @keywords internal +#' @noRd +.gwr_singular_hint <- function(n_sing = 0L) { + paste0(" -- at least one local window's design is singular, and ", + "GWmodel stops the whole fit rather than return that window. ", + if (isTRUE(n_sing > 0L)) + sprintf("The collinearity survey found %d singular window(s). ", + as.integer(n_sing)) else "", + "Typical causes are a predictor that is constant inside a ", + "window (a regional indicator, say), a bandwidth that leaves a ", + "window fewer observations than parameters (a fixed bandwidth in ", + "the wrong units, for one), and neighbours tied at the kernel's ", + "edge (a regular grid), which the bisquare and tricube kernels give ", + "weight 0; use a larger bandwidth or drop the predictor.") +} + + #' Compute a sensible fallback bandwidth from spatial data #' #' For adaptive mode, returns an integer (number of nearest neighbours). @@ -92,9 +196,11 @@ #' Extract fitted or predicted values from a GWmodel GWR result #' #' **Unified extraction function** used by \code{fitted.gwr_fit()} (in-sample -#' evaluation) and \code{predict.gwr_fit()} (prediction at new locations), both -#' in R/model-classes.R. Replaces the previously duplicated -#' .extract_gwr_fitted() and .extract_gwr_predictions() functions. +#' evaluation, R/model-classes.R). \code{predict.gwr_fit()} used it too, on +#' a \code{gwr.predict()} result (\code{mode = "predict"}); it now computes +#' its predictions itself (see \code{.gwr_predict_at()}). Replaces the +#' previously duplicated .extract_gwr_fitted() and .extract_gwr_predictions() +#' functions. #' #' Implements four strategies in order: #' 1. Look for a direct prediction/fitted column in the SDF. @@ -274,7 +380,8 @@ #' #' @param data_sf An sf object with response, predictors, and geometries. #' @param response_var Response column name. -#' @param predictor_vars Predictor column names. +#' @param predictor_vars Predictor column names (numeric columns; a name given +#' twice counts once). #' @param adaptive Logical; use adaptive bandwidth. Default TRUE. When TRUE, #' bandwidth is an integer number of nearest neighbours. When FALSE, #' bandwidth is a fixed distance in CRS units. @@ -290,7 +397,19 @@ #' smaller than a ten-thousandth of the data's extent raises a warning naming #' the extent and the CRS the fit runs in: every local window is then likely #' to be empty, which used to produce a fit whose coefficients were all -#' \code{NaN} with nothing raised anywhere. +#' \code{NaN} with nothing raised anywhere. With \code{adaptive = TRUE} +#' the count is rounded, and one too small for the model is raised, with a +#' warning, to the smallest that gives every local regression more points +#' of non-zero weight than parameters: the number of predictors plus 3 for +#' the bisquare and tricube kernels (which give the farthest neighbour in a +#' window weight 0), plus 2 for the others. That floor is enough unless +#' several neighbours tie at the kernel's edge (a regular grid), which +#' leaves a window fewer weighted points; then use a larger bandwidth. +#' A count above the number of +#' observations is capped at it, with a warning (a distance meant for +#' \code{adaptive = FALSE}, most often). \code{bw.gwr()} searches adaptive +#' bandwidths from 20 neighbours up, so below 20 observations its choice is +#' capped the same way, with a warning, and is not an optimised bandwidth. #' @param kernel Kernel function type. One of "bisquare" (default), #' "gaussian", "tricube", "boxcar", "exponential". #' @param .already_prepped Logical (internal). If \code{TRUE}, skip the @@ -300,56 +419,89 @@ #' default \code{FALSE}. #' #' @section Collinearity diagnostics: -#' The function computes the **scaled condition index** of the design and -#' warns when it exceeds 30, the conventional threshold, which Wheeler & -#' Tiefelsdorf (2005) carry over to the local designs of GWR. The index is -#' the ratio of the largest to the smallest singular value after each column -#' is scaled to unit length (Belsley, Kuh & Welsch 1980). Scaling makes the -#' index independent of the predictors' units; \code{kappa()} on the raw matrix -#' is not, and a threshold on it is a threshold on nothing in particular. -#' A **global** index is computed on the full design (intercept plus -#' predictors). -#' In addition, a **local** spot-check is performed at up to 30 locations: -#' every location when there are 30 or fewer, otherwise 30 spread evenly over -#' the extent (evenly spaced ranks of the observations ordered by x, then y), -#' so the diagnostic is reproducible, draws no random numbers, does not depend -#' on the row order of the data, and the count is not configurable. For each -#' sampled point the nearest neighbours within the bandwidth window (the -#' bandwidth the model is actually fitted with, not a stand-in) are selected -#' and the condition number of that local design sub-matrix is evaluated. -#' That sub-matrix is the predictors **plus an -#' intercept column**, matching the design GWmodel fits, and is unweighted; the -#' global condition number is computed on the predictors alone, so the two -#' numbers are not directly comparable. An indicator that is constant inside a -#' window is collinear with the intercept and with nothing else, which is why -#' the intercept has to be there. A non-finite condition number counts as -#' extreme: `kappa()` returns `Inf` for an exactly singular design, which is the -#' worst case, not an exempt one. -#' -#' A warning is issued whenever **any** sampled location has a singular or -#' near-singular local design; the wording reports a percentage when more than -#' 25% of sampled locations are affected and a count otherwise. Both are real -#' R warnings, not log lines. +#' The function computes **scaled condition indices** of the design and +#' warns when one exceeds 30, the conventional threshold, which Wheeler & +#' Tiefelsdorf (2005) carry over to the local designs of GWR. An index is +#' the ratio of the largest to the smallest singular value (from an SVD) after +#' each column is scaled (Belsley, Kuh & Welsch 1980); an exactly singular +#' design gives `Inf`, which counts as the worst case, not an exempt one. +#' Scaling makes the index independent of the predictors' units; +#' \code{kappa()} on the raw matrix is not, and a threshold on it is a +#' threshold on nothing in particular. #' -#' After the fit, the local coefficient surfaces are scanned and a further -#' warning counts local regressions that came back non-finite. Their windows -#' were singular. `fitted()`, `residuals()`, `summary()` and -#' [model_metrics()] all drop those rows, so when this warning fires the -#' metrics describe only the part of the study area that fitted. +#' A **global** index is computed on the predictors centred at their means +#' (with the intercept, which centring makes orthogonal to them), and kept as +#' `info$condition_index`. It measures how nearly the predictors are +#' collinear with one another over the whole study area; it is 1 for a single +#' predictor, and a change of origin (degrees C or kelvin, a year or years +#' since 2000) does not move it. +#' +#' **Local** indices are then computed at **every** location, on the design +#' the local regression there inverts: each row weighted by the square root +#' of its kernel weight at the bandwidth the model is fitted with (supplied or +#' selected), with rows of negligible weight dropped. A window left with +#' fewer rows than columns counts as singular. Two indices are kept for each +#' window, as columns of `info$local_collinearity`: +#' \describe{ +#' \item{\code{cn}}{Belsley's index of the intercept plus the predictors, +#' scaled to unit length but not centred. A predictor whose values in the +#' window are far from 0 against their spread (a year, a temperature in +#' kelvin) is collinear with the intercept and raises it: the local +#' intercept is then an extrapolation to 0 and is ill-determined, but the +#' slopes are not. It is what GWmodel's own solve sees.} +#' \item{\code{cn_slopes}}{The index for the slopes: the predictors centred at +#' their weighted mean in the window and each divided by its standard +#' deviation over the whole study area. It is 1 when the predictors vary +#' as much, and as independently, inside the window as they do across the +#' study area; it grows as a predictor becomes nearly constant inside the +#' window (a regional covariate) or two predictors move together there. +#' It does not depend on the predictors' origin or units.} +#' } +#' A window's slopes count as collinear when `cn_slopes` is above 30 or +#' singular, or when `cn` is above 1e6, where GWmodel's uncentred solve starts +#' to lose precision in the slopes too. Those windows are counted in +#' `info$n_local_collinear`. A predictor that is constant, or nearly so, +#' inside a window is caught this way whether it is alone or has company, so a +#' single predictor is surveyed too. #' -#' Because the local spot-check examines only a subset of locations, it may not -#' detect every problematic neighbourhood. Users working with highly clustered -#' data or near-collinear predictors should consider a full local-collinearity -#' audit as a post-fit diagnostic. +#' A warning is issued whenever **any** location has collinear slopes; the +#' wording reports a percentage when more than 25% of locations are affected +#' and a count otherwise. Both are real R warnings, not log lines. +#' Coefficients at a near-singular window are unstable and can be implausibly +#' large. An **exactly** singular window (an indicator that is constant +#' inside it, or fewer observations than parameters) makes GWmodel stop, so +#' the fit fails with an error that says so; the window is not returned as +#' `NaN`. A window with only `cn` above 30 raises no warning: +#' `plot(fit, type = "coefficients", term = "Intercept")` masks it, and slope +#' maps do not. Centre such a predictor if you want an interpretable local +#' intercept. +#' +#' After the fit, the local coefficient surfaces are scanned and a further +#' warning counts local regressions that came back non-finite. GWmodel +#' returns those where the kernel weights are undefined: with an adaptive +#' bandwidth of `k`, a location where `k` or more observations share the same +#' coordinates has a kernel of zero width, and every kernel but the boxcar +#' divides 0 by 0 there. The warning names that cause when it applies. +#' `fitted()`, `residuals()`, `summary()` and [model_metrics()] all drop those +#' rows, so when this warning fires the metrics describe only the part of the +#' study area that fitted. #' #' @return A \code{gwr_fit} object (inherits from \code{spatial_fit}). #' Supports \code{predict()}, \code{fitted()}, \code{residuals()}, #' \code{coef()}, \code{summary()}, and \code{model_metrics()}. #' Model-specific metadata lives in \code{$info}: bandwidth, adaptive, -#' kernel, AICc, \code{bandwidth_is_fallback} (\code{TRUE} when automatic +#' kernel, AICc (\code{NA}, with a warning, where GWmodel's AICc is +#' undefined: its effective number of parameters \eqn{tr(S)} is not below +#' \eqn{n - 2}, the local regressions all but interpolate the data, and the +#' large negative value GWmodel reports would rank the fit above any +#' other), \code{bandwidth_is_fallback} (\code{TRUE} when automatic #' selection failed and the arbitrary fallback was used), -#' \code{condition_index}, \code{local_collinearity}, -#' \code{n_local_collinear}, \code{n_local_singular}, +#' \code{condition_index} (the global index), \code{local_collinearity} +#' (one row per observation: \code{row}, \code{x}, \code{y}, +#' \code{n_window}, \code{cn} and \code{cn_slopes}; see +#' \strong{Collinearity diagnostics}), \code{n_local_collinear} (the +#' locations whose slopes count as collinear), \code{n_local_singular} +#' (the locations whose local coefficients came back non-finite), #' \code{nonfinite_coef} (a logical matrix, one row per observation and #' one column per term, with \code{Intercept} first, \code{TRUE} where the #' local coefficient came back non-finite, so the count in @@ -391,9 +543,7 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, stop("fit_gwr_model(): package 'sp' is required (for GWmodel interop).", call. = FALSE) # 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.) + # past it. kernel <- match.arg(kernel) # prep_model_data() accepts character(0) so an intercept-only spatial GP can @@ -404,6 +554,13 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, stop("fit_gwr_model(): `predictor_vars` must name at least one predictor; ", "there are no local coefficients to estimate otherwise.", call. = FALSE) + # A name given twice is one term: the formula collapses it, so the fit was + # right, but the collinearity checks ran on the duplicated matrix and warned + # "exactly singular" and "100% of locations collinear" (Inf condition + # index), plot(type = "coefficients") then masked every location, and + # n_params counted the name twice. gwr_model_selection() already collapses + # its candidates the same way. + predictor_vars <- unique(predictor_vars) # `bandwidth` is used unchecked below (twice: in the local-collinearity # spot-check and as the fitted bandwidth), and the clamping block further @@ -455,23 +612,23 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, stop("fit_gwr_model(): geometry must be POINT after prep. ", "Run prep_model_data() (or coerce_to_points()) first.", call. = FALSE) - # 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. + # A factor or character predictor is refused. This began as a guard for + # predict(): gwr.basic() builds its design with model.matrix(), so a factor + # fits cleanly, while GWmodel's gwr.predict() indexes the prediction frame + # by the raw variable names and failed with "non-numeric argument to binary + # operator", which predict.gwr_fit() turned into all NA. predict.gwr_fit() + # no longer calls gwr.predict(), but the refusal stays: gwr_model_selection() + # refuses the same columns on this function's account, and accepting them + # is a change of its own. Reject the column here, where it can be named. 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 ", + "GWmodel would fit a factor or character predictor as ", + "one local coefficient per contrast column; this ", + "package's GWR functions take numeric predictors only. ", + "Encode the column as numeric indicator ", "column(s) yourself, and pass those as predictors."), paste(sQuote(non_num), collapse = ", ")), call. = FALSE) @@ -515,6 +672,18 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # guard: it used to bypass it (the guard sat behind is.numeric()) and fit a # Gaussian GWR to a binary outcome without a word. if (is.logical(resp_vals)) resp_vals <- as.numeric(resp_vals) + # A factor or character response is refused here, as fit_rf_model() and + # fit_bayesian_spatial_model() refuse it. Past this point it reached + # bw.gwr(), failed there twice with "Not compatible with requested type", + # drew the arbitrary-fallback warning, and then stopped in gwr.basic() with + # "'x' must contain finite values only", none of which names the column. + if (!is.numeric(resp_vals)) + stop(sprintf(paste0("fit_gwr_model(): response '%s' is not numeric (it is ", + "%s). GWR here is a Gaussian regression: convert a ", + "number stored as text with as.numeric() first; for a ", + "categorical outcome use GWmodel::ggwr.basic()."), + response_var, class(resp_vals)[1L]), + call. = FALSE) if (is.numeric(resp_vals)) { usable <- resp_vals[is.finite(resp_vals)] n_usable <- length(usable) @@ -578,20 +747,34 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } } local_collinearity <- NULL - if (length(predictor_vars) >= 2L) { + # One numeric predictor is enough to survey. The design is cbind(1, xmat), + # and a predictor that is (nearly) constant inside a window is collinear + # with the INTERCEPT -- the case the local survey exists for. Gating on two + # predictors skipped it: a regional covariate nearly constant within each + # cluster gave local slopes of -97 to 221 around a true 3 with no warning, + # while adding a noise predictor to the same data warned at every location. + if (length(predictor_vars) >= 1L) { num_preds <- predictor_vars[vapply(pred_df[predictor_vars], is.numeric, logical(1))] - if (length(num_preds) >= 2L) { + if (length(num_preds) >= 1L) { xmat <- as.matrix(pred_df[, num_preds, drop = FALSE]) # The scaled condition INDEX (Belsley), thresholded at the literature's # 30 -- not kappa() on the raw matrix at 1e6, which depends on the # predictors' units and let a design with condition index 1322 through. - # The global design includes the intercept, as the local windows do. - cn <- .condition_index(cbind(1, xmat)) + # The predictors are CENTRED first. Uncentred, a predictor far from 0 + # against its spread (kelvin, a year) is collinear with the intercept, + # so the same field in kelvin warned "collinearity risk" (index 230) + # where in degrees C it did not, although every slope is the same. The + # centred index is the standard one: 1 for a single predictor, and above + # 30 only when predictors move together over the study area. A + # predictor constant over the whole data set is a zero column here + # (Inf). Collinearity with the intercept INSIDE a window is the local + # survey's job. + cn <- .condition_index(cbind(1, sweep(xmat, 2L, colMeans(xmat)))) # A non-finite condition number is an EXACTLY singular design -- the worst # case there is -- and `is.finite(cn) && ...` silently let it through. if (!is.finite(cn) || cn > 30) { .warn_and_log( - "fit_gwr_model(): global design (intercept + predictors) has scaled condition index %s, above the conventional 30 (collinearity risk). Note: local collinearity within bandwidth windows may be substantially worse than this global value.", + "fit_gwr_model(): global predictors (centred) have scaled condition index %s, above the conventional 30 (collinearity risk). Note: local collinearity within bandwidth windows may be substantially worse than this global value.", if (is.finite(cn)) sprintf("%.0f", cn) else "infinite (exactly singular)" ) } @@ -630,26 +813,8 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, # regression is empty -- all coefficients NaN, all fitted values NA, # summary() reporting n = 0 -- with nothing raised anywhere. Say so at the # moment the mismatch is visible. - if (!is.null(bandwidth) && !adaptive) { - fit_units <- tryCatch(sf::st_crs(dat)$units_gdal, error = function(e) NULL) - extent_x <- suppressWarnings({ - bb <- sf::st_bbox(dat); as.numeric(bb[["xmax"]] - bb[["xmin"]]) - }) - if (is.finite(extent_x) && extent_x > 0 && - as.numeric(bandwidth) < extent_x / 1e4) { - .warn_and_log(paste0("fit_gwr_model(): a fixed bandwidth of %s is less ", - "than a ten-thousandth of the data's extent (%s %s ", - "across). The bandwidth is a distance in the CRS the ", - "fit runs in (%s), which prep_model_data() may have ", - "chosen -- geographic input is projected first, so a ", - "value in degrees is read as metres. Every local ", - "window is likely to be empty."), - format(as.numeric(bandwidth)), format(signif(extent_x, 4)), - if (is.null(fit_units) || is.na(fit_units)) "unit" - else fit_units, - tryCatch(sf::st_crs(dat)$input, error = function(e) "unknown")) - } - } + if (!is.null(bandwidth) && !adaptive) + .gwr_warn_tiny_fixed_bw(dat, bandwidth, "fit_gwr_model") if (is.null(bandwidth)) { # .gwr_quietly(): bw.gwr() writes its golden-section search trace with bare # cat(), which neither suppressMessages() nor suppressWarnings() touches. @@ -694,14 +859,59 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, max = .Machine$integer.max, what = "a single number of nearest neighbours when adaptive = TRUE") bw <- as.integer(round(bw)) - min_bw <- n_params + 1L + # n_params + 1 left bisquare and tricube windows with n_params points + # (their bw-th neighbour has weight 0), so a small supplied bandwidth was + # clamped onto an exact interpolator: R2 = 1 and an AICc of -15033 that + # compare_models() ranked first. See .gwr_min_adaptive_bw(). Capped at + # n_obs: with n = p + 2 there is no larger window, and the AICc guard + # below reports what is left. + min_bw <- min(.gwr_min_adaptive_bw(n_params, kernel), n_obs) max_bw <- n_obs if (bw < min_bw) { - .log_warn("fit_gwr_model(): adaptive bandwidth %d too small for %d params; clamping to %d.", - bw, n_params, min_bw) + # A warning, not a log line: the fit is not at the bandwidth the caller + # asked for. The fallback's own warning already names its clamp. + if (bandwidth_is_fallback) + .log_warn("fit_gwr_model(): adaptive bandwidth %d too small for %d params; clamping to %d.", + bw, n_params, min_bw) + else + .warn_and_log(paste0("fit_gwr_model(): an adaptive bandwidth of %d ", + "neighbours is too small for %d parameters with ", + "the %s kernel (a local regression needs more ", + "points with non-zero weight than parameters); ", + "using %d.%s"), + bw, n_params, kernel, min_bw, + if (kernel %in% c("bisquare", "tricube")) + paste0(" That is enough unless several neighbours tie ", + "at the kernel's edge (a regular grid), which ", + "gives them weight 0 too; then use a larger ", + "bandwidth.") else "") bw <- min_bw } - if (bw > max_bw) bw <- max_bw + # Capped at n, as before, but no longer in silence. A supplied count + # above n is most often a distance passed with adaptive left at TRUE: + # 1500 (metres) on 200 points became a near-global fit whose local slopes + # varied half as much as the intended one's. And bw.gwr() searches + # adaptive bandwidths from 20 up to n, a reversed range below 20 points, + # so its choice there exceeds n and the fit is not at the bandwidth it + # chose. The fallback's own warning already names its clamp. + if (bw > max_bw) { + if (!is.null(bandwidth)) + .warn_and_log(paste0("fit_gwr_model(): an adaptive bandwidth of %d ", + "neighbours exceeds the %d observations; using ", + "%d. With adaptive = TRUE the bandwidth is a ", + "count of neighbours; for a distance in CRS ", + "units, set adaptive = FALSE."), + bw, n_obs, n_obs) + else if (!bandwidth_is_fallback) + .warn_and_log(paste0("fit_gwr_model(): GWmodel::bw.gwr() searches ", + "adaptive bandwidths from 20 neighbours up to n, ", + "a range that is empty for %d observations, and ", + "returned %d; using %d. Neither is an optimised ", + "bandwidth: with this few observations, supply ", + "`bandwidth`."), + n_obs, bw, n_obs) + bw <- max_bw + } } # The fallback warning is issued AFTER the clamp, not before it. The clamp @@ -741,24 +951,37 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } # --- Fit GWR --- + # One exactly singular window makes Armadillo's inv() throw "matrix is + # singular", and gwr.basic() stops the whole fit; it never returns such a + # window as NaN. The bare message names neither the window nor the cause, + # while the survey above has just counted the singular windows, so say both. fit <- tryCatch( GWmodel::gwr.basic(formula = fml, data = sp_dat, bw = bw, kernel = kernel, adaptive = adaptive), error = function(e) { - stop(sprintf("fit_gwr_model(): GWR fit failed: %s", conditionMessage(e)), + msg <- conditionMessage(e) + n_sing <- if (is.null(local_cn_df)) 0L else sum(is.infinite(local_cn_df$cn)) + hint <- if (!grepl("singular", msg, fixed = TRUE)) "" else + .gwr_singular_hint(n_sing) + stop(sprintf("fit_gwr_model(): GWR fit failed: %s%s", msg, hint), call. = FALSE) } ) - - # A local regression whose design is singular comes back as NaN rather than - # as an error, and nothing downstream says so: fitted(), residuals(), - # summary() and model_metrics() all drop the non-finite rows, so a fit in - # which 182 of 200 local regressions failed reported n = 18 and R2 = 0.96 as - # though that were the whole model. Count them and say so. + + # A non-finite local coefficient comes back without an error, and nothing + # downstream says so: fitted(), residuals(), summary() and model_metrics() + # all drop the non-finite rows, so a fit in which 182 of 200 local + # regressions failed reported n = 18 and R2 = 0.96 as though that were the + # whole model. Count them and say so. The cause is NOT a singular window + # (that stops the fit above) but undefined kernel weights: an adaptive + # bandwidth whose bw-th nearest neighbour is at distance zero -- bw or more + # observations at one location -- gives every kernel but the boxcar 0/0. + # The survey saw those windows as empty (n_window 0), which is how the + # warning can name the cause instead of guessing. # The per-row, per-term mask of non-finite local coefficients is kept # (`info$nonfinite_coef`), not only its row count: the count says how many - # windows are singular, the mask says which, and which term. NULL when the - # coefficient table could not be read. + # local regressions failed, the mask says which, and which term. NULL when + # the coefficient table could not be read. nonfinite_mask <- tryCatch({ sdf <- fit$SDF if (is.null(sdf)) NULL else { @@ -775,20 +998,64 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, } } }, error = function(e) NULL) - n_bad_local <- if (is.null(nonfinite_mask)) 0L else - sum(apply(nonfinite_mask, 1L, any)) - if (n_bad_local > 0L) + bad_rows <- if (is.null(nonfinite_mask)) logical(0) else + apply(nonfinite_mask, 1L, any) + n_bad_local <- sum(bad_rows) + if (n_bad_local > 0L) { + n_zero_width <- if (isTRUE(adaptive) && !is.null(local_cn_df) && + nrow(local_cn_df) == length(bad_rows)) + sum(bad_rows & local_cn_df$n_window == 0L, na.rm = TRUE) else 0L + cause <- if (n_zero_width > 0L) + sprintf(paste0(" -- at %d of them %d or more observations share one ", + "location, so the adaptive kernel has zero width and its ", + "weights are 0/0. Use a bandwidth larger than the most ", + "observations at any one location, or aggregate repeat ", + "observations first"), n_zero_width, as.integer(bw)) + else " (undefined kernel weights or a numerically degenerate local design)" .warn_and_log(paste0("fit_gwr_model(): %d of %d local regression(s) ", - "returned non-finite coefficients -- their windows are ", - "singular. fitted(), residuals() and every metric are ", - "computed from the %d that succeeded, so they describe ", - "part of the study area only."), - n_bad_local, n_obs, n_obs - n_bad_local) + "returned non-finite coefficients%s. fitted(), ", + "residuals() and every metric are computed from the ", + "%d that succeeded, so they describe part of the ", + "study area only."), + n_bad_local, n_obs, cause, n_obs - n_bad_local) + } # AICc extraction AICc_val <- NA_real_ if (!is.null(fit$GW.diagnostic) && !is.null(fit$GW.diagnostic$AICc)) { AICc_val <- suppressWarnings(as.numeric(fit$GW.diagnostic$AICc)) + # Outside its domain (tr S >= n - 2) GWmodel's AICc is a large negative + # number, -15033 for a 100-point fit whose windows interpolate, and + # compare_models() and print() took it as the best fit there is. Report + # NA and say why; see .gwr_aicc_undefined(). + AIC_val <- suppressWarnings(as.numeric(fit$GW.diagnostic$AIC %||% NA_real_)) + if (length(AICc_val) == 1L && length(AIC_val) == 1L && + isTRUE(.gwr_aicc_undefined(AIC_val, AICc_val))) { + trS <- .gwr_trace_s(AIC_val, fit$GW.diagnostic$RSS.gw %||% NA_real_, + n_obs) + # "Use a larger bandwidth" cannot be followed once an adaptive one is + # already every observation: the remedy is then fewer parameters, more + # data, or a kernel that does not give the farthest point weight 0. + remedy <- if (isTRUE(adaptive) && bw >= n_obs) + sprintf(paste0("Even the widest adaptive window (all %d observations) ", + "leaves too few residual degrees of freedom for %d ", + "parameters: use fewer predictors, more observations, ", + "or a gaussian or exponential kernel."), + n_obs, n_params) + else + sprintf("The bandwidth (%s%s) is too small for %d parameters; use a larger one.", + format(bw), if (adaptive) " neighbours" else "", n_params) + .warn_and_log(paste0("fit_gwr_model(): AICc is undefined for this fit ", + "and is reported as NA. Its effective number of ", + "parameters, tr(S) = %s, is not below n - 2 = %d, ", + "so the local regressions (nearly) interpolate the ", + "data, and there GWmodel's AICc formula turns ", + "negative: its value (%s) would rank this fit above ", + "better ones. %s"), + if (is.na(trS)) "?" else format(round(trS, 2)), + n_obs - 2L, format(signif(AICc_val, 6)), remedy) + AICc_val <- NA_real_ + } } new_spatial_fit( @@ -804,16 +1071,20 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, kernel = kernel, AICc = AICc_val, bandwidth_is_fallback = bandwidth_is_fallback, - # The global scaled condition index of the design (intercept + - # numeric predictors), NA with fewer than two numeric predictors; the - # number to compare across candidate predictor sets. + # The global scaled condition index of the centred numeric predictors + # (with the intercept); the number to compare across candidate + # predictor sets. NA only when there is no numeric predictor, which + # the non-numeric refusal above makes unreachable. condition_index = global_cn, - # One row per observation: the scaled condition index of the - # kernel-weighted local design at that location, NULL when there is - # nothing to be collinear (fewer than two numeric predictors). + # One row per observation: the two condition indices (cn, with the + # intercept and uncentred; cn_slopes, for the slopes) of the + # kernel-weighted local design at that location. NULL only when + # there is no numeric predictor to survey. local_collinearity = local_cn_df, + # The locations whose SLOPES are collinear; an ill-determined + # intercept alone (cn > 30 only) is not counted. n_local_collinear = if (is.null(local_cn_df)) NA_integer_ else - sum(!is.finite(local_cn_df$cn) | local_cn_df$cn > 30), + sum(.gwr_slopes_collinear(local_cn_df)), n_local_singular = n_bad_local, # One row per observation, one column per term (Intercept first): # TRUE where GWmodel returned a non-finite local coefficient. @@ -826,56 +1097,93 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' Kernel weights of GWmodel's five kernels #' -#' The same definitions \code{GWmodel::gw.weight()} uses, so the weighted -#' local design surveyed below is the one \code{gwr.basic()} inverts. -#' For an adaptive bandwidth \code{bw} is a neighbour count and the kernel's -#' distance parameter is the distance to the \code{bw}-th nearest point. +#' The same definitions, written the same way, as \code{GWmodel::gw.weight()} +#' (its C++ \code{gw_weight_*()}), so the weighted local design surveyed below +#' is the one \code{gwr.basic()} inverts. For an adaptive bandwidth \code{bw} +#' is a neighbour count and the kernel's distance parameter is the distance to +#' the \code{bw}-th nearest point; a count above \code{length(d)} widens the +#' kernel to \code{bw / length(d)} times the largest distance, as GWmodel does. +#' +#' Two details are GWmodel's and matter. The truncated kernels test +#' \code{d > h}, so a point exactly at the kernel's edge is inside a boxcar +#' window (weight 1) and on the rim of a bisquare or tricube one (weight 0). +#' And a zero-width kernel (\code{h = 0}: the \code{bw} nearest points share +#' one location) is not an indicator of those points: every kernel but the +#' boxcar gives them \code{0/0 = NaN}, which is where GWmodel's non-finite +#' local coefficients come from. #' #' @param d Numeric vector of distances from the regression point. #' @param bw Bandwidth: a distance, or a neighbour count when adaptive. #' @param kernel One of the validated kernel names. #' @param adaptive Logical. -#' @return Numeric weights, one per element of \code{d}. +#' @return Numeric weights, one per element of \code{d} (\code{NaN} where +#' GWmodel's are). #' @keywords internal #' @noRd .gw_kernel_weights <- function(d, bw, kernel, adaptive) { h <- if (isTRUE(adaptive)) { - k <- min(max(1L, as.integer(round(bw))), length(d)) - sort(d, partial = k)[k] + k <- max(1L, as.integer(round(bw))) + if (k <= length(d)) sort(d, partial = k)[k] else k / length(d) * max(d) } else as.numeric(bw) - if (!is.finite(h) || h <= 0) return(as.numeric(d == 0)) - u <- d / h + # The spelling below is GWmodel's, not a simplification of it: d / h would + # give the same weights for h > 0 but not GWmodel's NaN for h = 0. switch(kernel, - gaussian = exp(-0.5 * u^2), - exponential = exp(-u), - bisquare = ifelse(u < 1, (1 - u^2)^2, 0), - tricube = ifelse(u < 1, (1 - u^3)^3, 0), - boxcar = as.numeric(u < 1), - ifelse(u < 1, (1 - u^2)^2, 0)) + gaussian = exp(d^2 / (-2 * h^2)), + exponential = exp(-d / h), + tricube = ifelse(d > h, 0, (1 - d^3 / h^3)^3), + boxcar = ifelse(d > h, 0, 1), + ifelse(d > h, 0, (1 - d^2 / h^2)^2)) # bisquare } #' Survey the local collinearity of every fitting window #' -#' At each observation, forms the kernel-weighted local design -#' \eqn{W^{1/2} X} (intercept included) that the local regression there -#' inverts, and computes its scaled condition index. Two things this -#' deliberately does differently from the global check: -#' \itemize{ -#' \item The intercept column is included (\code{cbind(1, xmat)}). GWmodel -#' fits an intercept, and the case this survey exists for (an indicator -#' that is constant inside a window) is collinear with the INTERCEPT and -#' with nothing else, so a check on the predictors alone cannot see it. -#' \item A non-finite condition number counts as extreme. \code{kappa()} -#' returns \code{Inf} for an exactly singular matrix, and -#' \code{is.finite(cn) && cn > 1e6} discarded precisely the worst case. +#' At each observation, forms the kernel-weighted local design that the local +#' regression there inverts, and computes two condition indices of it. +#' \describe{ +#' \item{\code{cn}}{Belsley's scaled condition index of \eqn{W^{1/2} X}, +#' intercept included (\code{cbind(1, xmat)}), columns scaled to unit +#' length but not centred. This is the design GWmodel inverts, and the +#' literature's local index (Wheeler 2007; +#' \code{GWmodel::gwr.collin.diagno()} computes the same). It is right +#' about the INTERCEPT: a predictor whose values in the window are far +#' from 0 against their spread makes the local intercept an extrapolation +#' to 0. It is wrong about the slopes: a slope's precision, +#' \eqn{\sigma^2 / \sum w (x - \bar{x}_w)^2}, does not depend on where the +#' predictor's origin is, yet the same field in kelvin scored a median 454 +#' where in degrees C it scored 27.} +#' \item{\code{cn_slopes}}{The index for the slopes. The predictors are +#' centred at their weighted mean in the window, which makes them exactly +#' orthogonal to the intercept (so no origin enters), and each is divided +#' by its standard deviation over the whole data, so the reference scale +#' is the study area's own spread: \eqn{Z = \sqrt{w / \sum w}\, +#' (x - \bar{x}_w) / s}, row by row. The index is +#' \code{max(1, d_max) / min(1, d_min)} over the singular values \code{d} +#' of \eqn{Z}: 1 when the window's predictors vary as much, and as +#' independently, as across the study area. It is large when a predictor +#' is (nearly) constant inside the window -- a regional covariate, +#' collinear with the intercept and nothing else -- and when two +#' predictors move together there. The centring has to be LOCAL: centred +#' at the global mean, a cluster whose covariate sits at the global mean +#' scored near 1 although its local slope was undetermined. Over the +#' whole data the index reduces to the standard centred scaled condition +#' index.} #' } +#' A non-finite index counts as extreme. \code{kappa()} returns \code{Inf} +#' for an exactly singular matrix, and \code{is.finite(cn) && cn > 1e6} +#' discarded precisely the worst case. See \code{.gwr_slopes_collinear()} +#' for how the two indices are combined. +#' #' The weights are the kernel's own (Wheeler and Tiefelsdorf 2005 diagnose #' GWR collinearity on the weighted design), so a bisquare window's edge #' points, which contribute almost nothing to the fit, contribute almost #' nothing here either; rows with negligible weight are dropped before the -#' SVD. Every location is surveyed, not a sample: the map of coefficients -#' needs a value at each, and the survey's cost is the same order as the fit's. +#' SVD. So are rows whose weight is undefined (\code{NaN}, a zero-width +#' adaptive kernel at co-located points), and a window left with fewer rows +#' than columns counts as singular (\code{Inf}) in both indices: GWmodel +#' returns non-finite coefficients there. Every location is surveyed, not a +#' sample: the map of coefficients needs a value at each, and the survey's +#' cost is the same order as the fit's. #' #' @param coords Matrix of coordinates, one row per observation. #' @param xmat Numeric matrix of the numeric predictors. @@ -883,53 +1191,229 @@ fit_gwr_model <- function(data_sf, response_var, predictor_vars, #' @param bw The bandwidth the model is fitted with. #' @param kernel The kernel name. #' @return A data.frame with one row per observation: \code{row}, \code{x}, -#' \code{y}, \code{n_window} (points with non-negligible weight) and -#' \code{cn} (the scaled condition index, \code{Inf} when singular). +#' \code{y}, \code{n_window} (points with non-negligible weight), \code{cn} +#' (the uncentred scaled condition index with the intercept) and +#' \code{cn_slopes} (the slope index), each \code{Inf} when singular. #' @keywords internal #' @noRd .gwr_local_collinearity <- function(coords, xmat, adaptive, bw, kernel) { n_obs <- nrow(coords) out <- data.frame(row = seq_len(n_obs), x = coords[, 1], y = coords[, 2], - n_window = NA_integer_, cn = NA_real_) - if (!is.matrix(xmat) || ncol(xmat) < 2L || n_obs < 1L) return(out) + n_window = NA_integer_, cn = NA_real_, cn_slopes = NA_real_) + # One predictor is enough: X below adds the intercept, and a predictor + # constant inside a window is collinear with it. + if (!is.matrix(xmat) || ncol(xmat) < 1L || n_obs < 1L) return(out) if (is.null(bw) || !is.finite(bw)) return(out) X <- cbind(1, xmat) + # The slope index's reference scale: each predictor's spread over the + # whole data. A predictor with none has no slope to estimate anywhere. + s_glob <- apply(xmat, 2L, stats::sd) + s_ok <- all(is.finite(s_glob) & s_glob > 0) for (i in seq_len(n_obs)) { d <- sqrt((coords[, 1] - coords[i, 1])^2 + (coords[, 2] - coords[i, 2])^2) w <- .gw_kernel_weights(d, bw, kernel, adaptive) keep <- which(is.finite(w) & w > 1e-8) out$n_window[i] <- length(keep) - out$cn[i] <- if (length(keep) < ncol(X)) Inf else - .condition_index(sqrt(w[keep]) * X[keep, , drop = FALSE]) + if (length(keep) < ncol(X)) { + out$cn[i] <- Inf + out$cn_slopes[i] <- Inf + next + } + out$cn[i] <- .condition_index(sqrt(w[keep]) * X[keep, , drop = FALSE]) + out$cn_slopes[i] <- .gwr_slope_index(w[keep], xmat[keep, , drop = FALSE], + s_glob, s_ok) } out } +#' The origin-free condition index of a window's slopes +#' +#' See \code{.gwr_local_collinearity()}. A predictor that is exactly +#' constant inside the window is singular (\code{Inf}) outright: after +#' centring its column is rounding noise, whose size depends on the value it +#' is constant at. +#' +#' @param w Positive kernel weights of the window's rows. +#' @param xk The window's rows of the predictor matrix. +#' @param s_glob Each predictor's standard deviation over the whole data. +#' @param s_ok Whether every \code{s_glob} is finite and positive. +#' @return A number of at least 1, or \code{Inf}. +#' @keywords internal +#' @noRd +.gwr_slope_index <- function(w, xk, s_glob, + s_ok = all(is.finite(s_glob) & s_glob > 0)) { + if (!isTRUE(s_ok) || nrow(xk) < ncol(xk) + 1L) return(Inf) + if (any(apply(xk, 2L, function(v) max(v) == min(v)))) return(Inf) + ww <- w / sum(w) + z <- sqrt(ww) * sweep(sweep(xk, 2L, colSums(ww * xk)), 2L, s_glob, "/") + sv <- tryCatch(svd(z, nu = 0, nv = 0)$d, error = function(e) NULL) + if (is.null(sv) || !length(sv) || any(!is.finite(sv))) return(Inf) + if (min(sv) <= .Machine$double.eps * max(1, sv)) return(Inf) + max(1, max(sv)) / min(1, min(sv)) +} + + +#' Which windows' local slopes count as collinear +#' +#' A window's slopes are collinear when their own index (\code{cn_slopes}) is +#' above 30 or singular, or when the uncentred index with the intercept +#' (\code{cn}) is above 1e6. The second condition is numerical, not +#' statistical: GWmodel inverts the uncentred \eqn{X^\top W X}, whose +#' condition number is about \code{cn^2}, and shifting a predictor's origin +#' until \code{cn} reached 1.6e6 moved its local slopes by 0.4\% of their +#' spread, 1.6e7 by 25\%, and 1.6e8 made GWmodel stop with "matrix is +#' singular". A survey without \code{cn_slopes} (a fit made before it +#' existed) falls back to \code{cn > 30}. \code{NA} (a survey that did not +#' run) counts as collinear, as it always has. +#' +#' @param lc A survey, as \code{.gwr_local_collinearity()} returns it. +#' @return Logical vector, one element per row of \code{lc}. +#' @keywords internal +#' @noRd +.gwr_slopes_collinear <- function(lc) { + cn <- lc$cn + if (is.null(lc$cn_slopes)) return(!is.finite(cn) | cn > 30) + cs <- lc$cn_slopes + !is.finite(cs) | cs > 30 | !is.finite(cn) | cn > 1e6 +} + + #' Warn about the local collinearity survey's findings #' #' The two messages the sampled spot-check used to raise, now on the exact -#' fraction of locations. +#' fraction of locations, and about the slopes (\code{.gwr_slopes_collinear()}): +#' a window whose only problem is an ill-determined intercept (\code{cn} +#' above 30, slopes fine) is logged, not warned about. #' @keywords internal #' @noRd .gwr_local_collinearity_warn <- function(local_cn_df) { if (is.null(local_cn_df) || !nrow(local_cn_df) || all(is.na(local_cn_df$cn))) return(invisible(NULL)) n <- nrow(local_cn_df) - n_extreme <- sum(!is.finite(local_cn_df$cn) | local_cn_df$cn > 30) + slope_bad <- .gwr_slopes_collinear(local_cn_df) + n_extreme <- sum(slope_bad) frac <- n_extreme / n + # What happens at those windows is said as GWmodel does it: a near-singular + # window returns implausibly large coefficients, an exactly singular one + # makes Armadillo's inv() throw and GWmodel stop the whole fit. Non-finite + # coefficients come from undefined kernel weights, not from singularity, and + # the post-fit warning names that cause. if (frac > 0.25) { .warn_and_log( - "fit_gwr_model(): local collinearity: %.0f%% of %d locations have a collinear local design (scaled condition index of the kernel-weighted window > 30, or singular) at the bandwidth in use. Local regressions there are unstable and their coefficients may come back non-finite or implausibly large; plot(fit, type = \"coefficients\") masks them.", + "fit_gwr_model(): local collinearity: %.0f%% of %d locations have a collinear local design (the predictors, centred in the kernel-weighted window, have scaled condition index > 30 against their spread over the study area, or the window is singular) at the bandwidth in use. Local regressions there are unstable and their coefficients may be implausibly large, and an exactly singular window makes GWmodel stop the fit; plot(fit, type = \"coefficients\") masks them.", frac * 100, n ) } else if (n_extreme > 0L) { .warn_and_log( - "fit_gwr_model(): local collinearity: %d of %d locations have a collinear local design (scaled condition index of the kernel-weighted window > 30, or singular) at the bandwidth in use.", + "fit_gwr_model(): local collinearity: %d of %d locations have a collinear local design (the predictors, centred in the kernel-weighted window, have scaled condition index > 30 against their spread over the study area, or the window is singular) at the bandwidth in use.", n_extreme, n ) } + # The intercept alone: a predictor far from 0 against its local spread. + # That says nothing about the slopes, so it is not a warning; the Intercept + # map masks those locations. + n_int <- sum(!slope_bad & (!is.finite(local_cn_df$cn) | local_cn_df$cn > 30)) + if (n_int > 0L) + .log_info(paste0("fit_gwr_model(): the local intercept is an extrapolation ", + "at %d of %d locations (a predictor's local values are far ", + "from 0 against their spread: condition index with the ", + "intercept > 30). The slopes there are not affected; centre ", + "the predictor to map an interpretable intercept."), + n_int, n) invisible(NULL) } +#' GWR predictions at new locations, one local regression each +#' +#' Estimates the local coefficients at every row of \code{rp} and returns +#' \eqn{x^\top\hat\beta(u)}. The coefficients are GWmodel's own and are +#' bit-identical to those \code{GWmodel::gwr.predict()} computed: the same +#' \code{gw.dist()} distances, the same kernel weights (an adaptive bandwidth +#' counts neighbours among the TRAINING points) and the same Armadillo +#' \code{inv(X'WX) X'Wy}. They come from +#' \code{gwr.basic(regression.points = )}, which stops at the coefficients, +#' in chunks. One empty or singular window makes Armadillo's \code{inv()} +#' throw and takes its whole call with it, so a chunk that throws is redone +#' one location at a time with the call \code{gwr.predict()} made per point, +#' \code{gw_reg_1()}, and only the windows that really are singular come back +#' \code{NA}. +#' +#' @param formula The fitted model formula. +#' @param sp_train SpatialPointsDataFrame of the training data, 2-D. +#' @param newdata_df data.frame of the new rows, with the predictors. +#' @param rp Two-column numeric matrix of the new rows' coordinates, in the +#' training CRS. +#' @param bw,kernel,adaptive The fit's bandwidth settings. +#' @param max_cells Largest training-by-chunk distance matrix, in cells. +#' @return Numeric vector, one value per row of \code{rp}: \code{NA} where +#' the local regression cannot be estimated. +#' @keywords internal +#' @noRd +.gwr_predict_at <- function(formula, sp_train, newdata_df, rp, bw, kernel, + adaptive, max_cells = 4e6) { + mf <- stats::model.frame(formula, data = sp_train@data, + drop.unused.levels = TRUE) + tt <- stats::terms(mf) + X <- stats::model.matrix(tt, mf) + y <- as.numeric(stats::model.response(mf)) + k <- ncol(X) + + # The design at the new rows, from the fitted terms and factor levels, so + # that its columns are the coefficients' columns in the same order (a + # duplicated predictor name, for one, gives one column, not two). na.pass + # keeps the rows aligned with `rp`. + tt_new <- stats::delete.response(tt) + X_new <- stats::model.matrix(tt_new, stats::model.frame( + tt_new, newdata_df, na.action = stats::na.pass, + xlev = stats::.getXlevels(tt, mf))) + if (nrow(X_new) != nrow(rp) || ncol(X_new) != k) + stop(sprintf(paste0("the design matrix for newdata is %d x %d, but the ", + "model has %d term(s) for %d location(s)."), + nrow(X_new), ncol(X_new), k, nrow(rp)), call. = FALSE) + + dp <- sp::coordinates(sp_train) + n_rp <- nrow(rp) + beta <- matrix(NA_real_, n_rp, k) + # The distance matrix is computed here with gw.dist(), as gwr.predict() did, + # and passed in: above 5000 training plus new points gwr.basic() switches to + # computing distances inside its C++ loop, and its coefficients then differ + # from gwr.predict()'s in the last bit. Chunks are sized to keep the + # matrix under `max_cells`. + chunk <- max(1L, min(1000L, as.integer(max_cells %/% nrow(dp)))) + for (s in seq.int(1L, n_rp, by = chunk)) { + idx <- s:min(s + chunk - 1L, n_rp) + rp_i <- rp[idx, , drop = FALSE] + d_i <- GWmodel::gw.dist(dp.locat = dp, rp.locat = rp_i) + g <- tryCatch( + suppressWarnings(GWmodel::gwr.basic( + formula, data = sp_train, regression.points = rp_i, bw = bw, + kernel = kernel, adaptive = adaptive, dMat = d_i)), + error = function(e) NULL) + if (!is.null(g)) { + beta[idx, ] <- as.matrix(g$SDF@data[, seq_len(k), drop = FALSE]) + next + } + # The matrix form of gw.weight() sorts each column once; the vector form + # re-sorts the distances for every element. + w_i <- GWmodel::gw.weight(d_i, bw, kernel, adaptive) + for (j in seq_along(idx)) { + b <- tryCatch(GWmodel::gw_reg_1(X, y, w_i[, j])$beta, + error = function(e) NULL) + if (!is.null(b)) beta[idx[j], ] <- b + } + } + + # Summed term by term in double precision, the order GWmodel's gw_fitted() + # uses, so the values equal gwr.predict()'s and, at the training locations, + # fitted()'s to the bit. rowSums() accumulates in long double and differs + # from both in the last place. + yhat <- X_new[, 1L] * beta[, 1L] + for (j in seq_len(k)[-1L]) yhat <- yhat + X_new[, j] * beta[, j] + yhat <- unname(yhat) + yhat[!is.finite(yhat)] <- NA_real_ + yhat +} + + diff --git a/R/model-prep.R b/R/model-prep.R index cb3de44..82aa5bc 100644 --- a/R/model-prep.R +++ b/R/model-prep.R @@ -6,6 +6,8 @@ #' backend can use. All non-POINT geometries (including MULTIPOINT) are #' coerced to representative points via \code{coerce_to_points()}, so #' downstream coordinate extraction always aligns one row per observation. +#' Any Z or M coordinate (POINT Z from a GPS, a GeoPackage or KML) is +#' dropped, because every backend works in 2-D map distance. #' #' The response may not appear in \code{predictor_vars}. Using it as its own #' predictor is leakage no backend catches: an out-of-bag R^2 near 1 in the @@ -34,20 +36,27 @@ #' @param require_response Logical; if FALSE the response column is not #' required to be present (useful for out-of-sample prediction where the #' response is unknown). Default TRUE. -#' @return An sf object with POINT geometry, cleaned of rows carrying missing -#' or non-finite values in the modelling columns or in the coordinates. What +#' @return An sf object with 2-D (XY) POINT geometry, cleaned of rows +#' carrying missing or non-finite values in the modelling columns or in the +#' coordinates. What #' was removed is recorded on the attribute \code{"dropped"}, a list with #' \code{n} (rows dropped), \code{n_geometry} (how many of them for an #' empty or non-finite geometry), \code{which} (their positions in #' \code{data_sf}), \code{row_id} (their \code{..row_id} values when the #' layer carries that column, else \code{NULL}) and \code{reason} (one per #' dropped row: \code{"geometry"}, \code{"missing"} or -#' \code{"non_finite"}, in that order of precedence when several apply). +#' \code{"non_finite"}, in that order of precedence when several apply), +#' plus \code{n_rows}, the number of rows returned, which the record was +#' made for. #' Every fit stores \code{n} as \code{$info$n_dropped}. The record #' describes the rows this call returned and does not survive subsetting: -#' \code{clean[i, ]} is a plain layer with no \code{"dropped"} attribute, -#' and a fit given such a subset with \code{.already_prepped = TRUE} reports -#' \code{n_dropped = 0} even when the parent layer dropped rows. The CRS is +#' \code{clean[i, ]}, like \code{dplyr::filter()}, \code{slice()} or +#' \code{arrange()} of it, is a plain layer with no \code{"dropped"} +#' attribute, and a fit given such a subset with \code{.already_prepped = +#' TRUE} reports \code{n_dropped = 0} even when the parent layer dropped +#' rows. \code{sf::st_drop_geometry()} keeps the record, since the rows are +#' the same; see \code{\link{[.spatialkit_rows}} for what binding such data +#' frames does. The CRS is #' projected whenever one can be established. A CRS-less layer is decided by #' the lon/lat heuristic (see \code{\link{ensure_projected}}): if its bounding #' box fits the lon/lat envelope \emph{and} it either spans more than one unit @@ -140,6 +149,16 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, data_sf <- coerce_to_points(data_sf, pointize) } + # Drop any Z or M coordinate. Every backend works in 2-D map distance, but + # POINT Z is ordinary input (GPS and GeoPackage elevations, KML's altitude, + # PointZ shapefiles) and the sf -> sp coercion GWmodel needs keeps the third + # column. GWmodel then refused the data ("Please input correct coordinates + # of data points"), fitted on 3-D distances above 2500 rows, and in + # predict() on POINT Z newdata reshaped XYZ with matrix(, ncol = 2) into the + # wrong prediction locations, with no error. make_folds(), + # estimate_sac_range() and the fold-separation check already drop ZM. + data_sf <- .drop_zm(data_sf) + if (!is.null(boundary)) { bnd <- if (inherits(boundary, "sfc")) sf::st_as_sf(boundary) else boundary if (!inherits(bnd, "sf")) @@ -221,6 +240,28 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, } +#' Drop the Z and M coordinates of a POINT layer, when it has any +#' +#' Tested on the coordinates themselves. A POINT is a numeric vector of two +#' values (XY), three (XYZ or XYM) or four (XYZM), so a third coordinate on +#' any row shows as more than two values per feature. sf's +#' \code{z_range}/\code{m_range} attributes are not enough: sf does not set +#' them on points built with \code{st_as_sf(coords = c("x", "y", "z"))}. And +#' \code{sf::st_zm()} rebuilds every geometry with an R call each, too slow to +#' spend on every 2-D layer a \code{predict()} call prepares. +#' +#' @param x An sf object with POINT geometry. +#' @return \code{x}, with XY geometry. +#' @keywords internal +#' @noRd +.drop_zm <- function(x) { + g <- sf::st_geometry(x) + if (length(unlist(g, use.names = FALSE)) > 2L * length(g)) + x <- sf::st_zm(x, drop = TRUE, what = "ZM") + x +} + + #' Heuristic length-scale bounds for a squared-exponential GP #' #' Computes sensible prior bounds for the GP length-scale parameter \eqn{\ell} @@ -231,6 +272,15 @@ prep_model_data <- function(data_sf, response_var, predictor_vars, #' #' Subsamples large datasets to avoid O(n^2) memory and time cost. #' +#' These are the bounds a length-scale \emph{prior} is calibrated over, not +#' the scales a fitted model can resolve: that depends on the basis size +#' (\code{gp_k} in \code{\link{fit_bayesian_spatial_model}()}, which reports +#' it as \code{$info$gp_ell_min}). Both bounds are fixed fractions of the +#' spread of pairwise distances, so they do not shrink as points are added to +#' the same area. A surface whose range sits below what the basis resolves +#' needs a larger \code{gp_k}: more points help the data identify a short +#' range, but they make neither these bounds nor the derived basis finer. +#' #' @param coords_xy Numeric matrix or data.frame of coordinates with at least #' two columns; the first two are used, and replicated rows are collapsed #' before the distance quantiles are taken. \code{brms::gp()} defaults to @@ -354,15 +404,23 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { #' @param max_basis Integer cap on the TOTAL basis count (\code{k^2}). The #' per-dimension ceiling is derived from this as \code{floor(sqrt(max_basis))}, #' so there is a single cap, with no second one to contradict it. -#' @return A list with \code{k} (integer, per dimension), \code{c} (numeric), +#' @param c Optional boundary factor, already validated, that \code{k} must be +#' sized for; \code{NULL} (default) derives it here. \code{k} grows with +#' \code{c}, so a caller that fixes the boundary must size the basis for +#' \emph{that} boundary: the \code{k} derived for the default \code{c} cannot +#' resolve the lower bound inside a wider one. +#' @return A list with \code{k} (integer, per dimension), \code{c} (numeric; +#' the \code{c} argument when one was given), #' \code{S} (numeric; the pooled full range of the column-centred coordinates #' AFTER collapsing replicated rows, i.e. exactly what \code{brms::gp(c = )} -#' multiplies under its default \code{gr = TRUE}) and \code{capped} -#' (logical). +#' multiplies under its default \code{gr = TRUE}), \code{capped} +#' (logical) and \code{cmeans} (the column means the coordinates were +#' centred on, which brms stores in the fit's GP basis and centres every +#' later \code{newdata} on). #' @keywords internal #' @noRd .gp_basis_spec <- function(coords_xy, ls_bounds, - k_min = 10L, max_basis = 2500L) { + k_min = 10L, max_basis = 2500L, c = NULL) { # Reproduce brms::choose_L()'s domain measure exactly: centre each column, # then take the range over the POOLED matrix. na.rm mirrors brms. xy <- as.matrix(coords_xy)[, 1:2, drop = FALSE] @@ -376,7 +434,8 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { # same factor. Mirror the reduction. xy <- xy[!duplicated(xy), , drop = FALSE] if (!nrow(xy)) xy <- matrix(0, nrow = 1L, ncol = 2L) - Xc <- sweep(xy, 2L, colMeans(xy, na.rm = TRUE)) + cmeans <- colMeans(xy, na.rm = TRUE) + Xc <- sweep(xy, 2L, cmeans) S <- suppressWarnings( max(1, max(Xc, na.rm = TRUE) - min(Xc, na.rm = TRUE))) if (!is.finite(S) || S <= 0) S <- 1 @@ -387,7 +446,11 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { # 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) + # A caller's own c replaces the derived one BEFORE k is sized from it: k was + # once always sized for the derived c, so gp_c = 3 on a layer whose derived + # c was 1.63 kept k = 23 where the rule gives 43, and the basis could not + # resolve the lower length-scale bound it was supposed to. + c_val <- if (is.null(c)) max(3.2 * r_hi, 1.25) else as.numeric(c) k_raw <- ceiling(1.75 * c_val / r_lo) k_max <- as.integer(floor(sqrt(max_basis))) @@ -395,7 +458,7 @@ gp_lengthscale_bounds <- function(coords_xy, q_small = 0.25, max_n = 1000L) { capped <- k_raw > k_max list(k = as.integer(k_val), c = as.numeric(c_val), - S = as.numeric(S), capped = capped) + S = as.numeric(S), capped = capped, cmeans = as.numeric(cmeans)) } diff --git a/R/model-rf.R b/R/model-rf.R index d18fc04..24e1f7a 100644 --- a/R/model-rf.R +++ b/R/model-rf.R @@ -84,9 +84,10 @@ #' \code{ranger} matches factor predictors by level, so a level that was not #' present when the forest was grown has no split to follow. Depending on the #' ranger version this either errors or, as in ranger 0.16, silently returns a -#' plausible-looking number. An error there reaches \code{predict.rf_fit()}'s -#' \code{tryCatch}, which turns it into an all-\code{NA} vector plus one log -#' line. Both are worse than an error naming the level. +#' plausible-looking number. An error there used to reach +#' \code{predict.rf_fit()}'s \code{tryCatch}, which turned it into an +#' all-\code{NA} vector plus one log line (it now raises ranger's reason, which +#' does not name the column). Both are worse than an error naming the level. #' #' @param X Prediction frame from \code{.rf_frame()}. #' @param train_X Training frame from \code{.rf_frame()}. @@ -186,6 +187,18 @@ #' do not compare the two directly. \code{\link{compare_models_cv}} exists for #' that. #' +#' A row that every tree sampled has no out-of-bag prediction, and ranger +#' reports \code{NaN} for it. That is every row under \code{replace = FALSE} +#' with \code{sample_fraction = 1}, and a few under a small \code{num_trees}. +#' The fit warns with the count; \code{fitted()} and \code{residuals()} are +#' \code{NaN} on those rows, and \code{summary()} says how many rows its +#' metrics were computed on. With no row out of bag at all, the OOB error +#' (\code{NA} in \code{$info$oob_rmse} and \code{$info$oob_r_squared}) and +#' the permutation importance (\code{NaN}) are undefined too, and +#' \code{print()} says so. \code{\link{cv_rf}()} scores its fold forests on +#' the held-out rows, never out of bag, so it warns once with the number of +#' folds affected rather than once per fold. +#' #' @param data_sf An sf object with response, predictors and geometry. #' @param response_var Response column name. #' @param predictor_vars Predictor column names. @@ -211,6 +224,9 @@ #' (default) uses ranger's rule: all rows when \code{replace = TRUE}, #' 0.632 (the expected share of distinct rows in a bootstrap sample) #' when \code{replace = FALSE}. A single number in (0, 1] overrides it. +#' \code{replace = FALSE} with \code{sample_fraction = 1} grows every tree +#' on every row, so nothing is out of bag: the fit warns, and see +#' \strong{What fitted() returns}. #' @param seed Seed passed to ranger. Default 123. #' @param num_threads Threads for ranger. Default \code{NULL} means #' \code{getOption("mc.cores", 1L)}: one thread unless the session has @@ -257,7 +273,9 @@ #' #' @seealso \code{\link{cv_rf}} for a spatially blocked performance estimate, #' \code{\link{area_of_applicability}}, which can take -#' \code{weights = pmax(fit$info$importance, 0)}. +#' \code{weights = pmax(fit$info$importance, 0)} when that importance is +#' finite (it is \code{NaN} when no row is out of bag; see "What +#' fitted() returns"). #' @family model fitting #' @examples #' if (requireNamespace("ranger", quietly = TRUE)) { @@ -395,16 +413,67 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, # numeric(0) that as.numeric(NULL) produces -- see ?.num1. oob_mse <- .num1(fit$prediction.error) + # A row every tree sampled has no out-of-bag prediction, and ranger returns + # NaN for it: every row under replace = FALSE with sample_fraction = 1 + # (each tree is grown on all of them), a few under a small num_trees. Then + # fitted() and residuals() are NaN there, summary() and model_metrics() score + # the remaining rows while summary() heads its output "n = ", + # and with no row out of bag at all the OOB error and the permutation + # importance are NaN as well -- all with nothing said. The forest itself is + # sound and predict(newdata =) and cv_rf() are unaffected, so warn rather + # than refuse. + # + # Not for a cv_rf() fold forest (.already_prepped = TRUE): cv_rf() scores + # predict() on the held-out rows and never reads a fold forest's out-of-bag + # predictions, so this fired once per fold about nothing the run used -- + # and told the user to score the forest with cv_rf() from inside cv_rf(). + # cv_rf() counts the folds itself and says it once (.rf_cv_oob_note()). + oob_pred <- fit$predictions + n_no_oob <- if (is.numeric(oob_pred) && length(oob_pred) == nrow(X)) + sum(!is.finite(oob_pred)) else 0L + fold_fit <- isTRUE(.already_prepped) + if (!fold_fit && n_no_oob == nrow(X)) { + .warn_and_log(paste0("fit_rf_model(): no row is out of bag for any tree ", + "(%s), so fitted(), residuals(), the out-of-bag error%s ", + "are undefined (NaN) and summary() and model_metrics() ", + "have nothing to score.%s Use replace = TRUE or a ", + "sample_fraction below 1, or score the forest with ", + "cv_rf()."), + if (!isTRUE(replace) && sample_fraction >= 1) + "replace = FALSE with sample_fraction = 1 grows every tree on every row" + else sprintf("%d tree(s)", as.integer(num_trees)), + if (identical(importance, "permutation")) + " and the permutation importance" else "", + # pmax(NaN, 0) is NaN, so the weights ?fit_rf_model + # suggests for area_of_applicability() are refused too. + if (identical(importance, "permutation")) + paste0(" area_of_applicability() cannot be weighted by ", + "that importance either: pass weights = NULL.") + else "") + } else if (!fold_fit && n_no_oob > 0L) { + .warn_and_log(paste0("fit_rf_model(): %d of %d rows were sampled by every ", + "one of the %d tree(s) and so have no out-of-bag ", + "prediction: fitted() and residuals() are NaN there, ", + "and summary(), model_metrics() and the out-of-bag ", + "error use the other %d. Raise num_trees to cover ", + "every row."), + n_no_oob, nrow(X), as.integer(num_trees), nrow(X) - n_no_oob) + } + new_spatial_fit( subclass = "rf_fit", engine = fit, # Show the coordinates in the formula when they are predictors, so # print()ing the fit does not hide them. It is display-only: the forest is - # built through ranger's x/y interface, never from this formula. + # built through ranger's x/y interface, never from this formula. Hence + # env = globalenv(): reformulate()'s default is this frame, which holds the + # forest (`fit`, `rr`), the data and the predictor frame, and a formula + # serialises its environment -- so saveRDS() on an rf_fit wrote the forest + # out a second time (1.62 MB for a 100-tree forest of 0.72 MB). formula = stats::reformulate( termlabels = if (isTRUE(include_coords)) c(predictor_vars, "..x", "..y") else predictor_vars, - response = response_var), + response = response_var, env = globalenv()), response_var = response_var, predictor_vars = predictor_vars, data_sf = dat, @@ -427,6 +496,86 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, } +#' Out-of-bag coverage of the cv_rf() fold forests, reported once per run +#' +#' \code{fit_rf_model()} does not warn about rows no tree left out of bag +#' when it grows a fold forest (\code{.already_prepped = TRUE}): cv_rf() +#' scores \code{predict()} on the held-out rows and never reads a fold +#' forest's out-of-bag predictions. It warned once per fold, and told the +#' user to score the forest with cv_rf() from inside cv_rf(). What the folds +#' share is still worth one warning, because a forest grown on all the data +#' with the same settings has the same gap. +#' +#' The counts travel back through \code{cv_spatial()}'s \code{fold_info_fn} +#' as two \code{fold_metrics} columns, which \code{.rf_cv_oob_note()} takes +#' out again. Warnings cannot carry them: one raised in a forked worker +#' reaches the parent only once per distinct text, so under +#' \code{parallel = TRUE} the folds could not be counted. +#' +#' @param fit_obj A fold's \code{rf_fit}. +#' @param res The \code{cv_spatial()} result. +#' @param dots The arguments cv_rf() passes to \code{fit_rf_model()}. +#' @return \code{.rf_fold_oob_info()}: a list of two counts. +#' \code{.rf_cv_oob_note()}: \code{res} without the two columns. +#' @keywords internal +#' @noRd +.rf_fold_oob_info <- function(fit_obj, ...) { + p <- fit_obj$engine$predictions + n <- if (is.numeric(p) && is.null(dim(p))) length(p) else 0L + list(..rf_n_no_oob = if (n > 0L) as.integer(sum(!is.finite(p))) else 0L, + ..rf_n_fit = as.integer(n)) +} + +# The run's half of .rf_fold_oob_info(): see there. +.rf_cv_oob_note <- function(res, dots) { + fm <- res$fold_metrics + if (!is.data.frame(fm) || + !all(c("..rf_n_no_oob", "..rf_n_fit") %in% names(fm))) + return(res) + none <- fm$..rf_n_no_oob + n <- fm$..rf_n_fit + fm$..rf_n_no_oob <- NULL + fm$..rf_n_fit <- NULL + res$fold_metrics <- fm + ok <- is.finite(none) & is.finite(n) & n > 0 + n_all <- sum(ok & none == n) + n_some <- sum(ok & none > 0 & none < n) + if (n_all > 0L) { + # The one cause fit_rf_model() can name; anything else (an `inbag` + # through `...`, say) is the caller's own doing. + sf <- dots[["sample_fraction"]] + whole <- isFALSE(dots[["replace"]]) && is.numeric(sf) && isTRUE(sf >= 1) + imp <- dots[["importance"]] + .warn_and_log(paste0("cv_rf(): no training row was out of bag for any ", + "tree in %d of %d fold forest(s)%s. The ", + "cross-validation is unaffected, because it scores ", + "each forest on its held-out fold; but a forest grown ", + "on all the data with the same settings has no ", + "%s.%s"), + n_all, nrow(fm), + if (whole) paste0(" (replace = FALSE with sample_fraction = ", + "1 grows every tree on every row)") else "", + if (is.null(imp) || identical(imp, "permutation")) + paste0("out-of-bag error, fitted() values or permutation ", + "importance") + else "out-of-bag error or fitted() values", + if (whole) paste0(" Use replace = TRUE or a sample_fraction ", + "below 1 for those.") else "") + } else if (n_some > 0L) { + .warn_and_log(paste0("cv_rf(): in %d of %d fold forest(s) some training ", + "rows were sampled by every tree and have no ", + "out-of-bag prediction. The cross-validation is ", + "unaffected, because it scores each forest on its ", + "held-out fold; but a forest grown on all the data ", + "with the same num_trees may leave rows without one ", + "too. Raise num_trees if you will read its out-of-bag ", + "error or fitted() values."), + n_some, nrow(fm)) + } + res +} + + #' Cross-validate a random forest with spatial folds #' #' Thin wrapper over \code{\link{cv_spatial}} that refits a \code{ranger} @@ -469,8 +618,9 @@ fit_rf_model <- function(data_sf, response_var, predictor_vars, #' and so on. \code{data_sf}, \code{response_var}, \code{predictor_vars} #' and \code{.already_prepped} are set by this function and must not be #' passed here (every fold would fail with "matched by multiple actual -#' arguments"). A \code{seed} given here overrides the per-fold draw -#' described above. +#' arguments"). \code{seed} is this function's own argument and never +#' reaches \code{fit_rf_model()} through here; see \code{seed} above for +#' growing every fold's forest from one fixed seed. #' @inheritSection model_metrics Percentage errors on responses with zeros #' @return The \code{\link{cv_spatial}} result. #' @family cross-validation @@ -513,7 +663,10 @@ cv_rf <- function(data_sf, response_var, predictor_vars, folds = NULL, k = 5, # session's mc.cores opt-in for itself, so parallel = 4 with mc.cores = 8 # meant 32 threads. One thread per worker unless the caller says otherwise. dots <- list(...) - n_workers <- .resolve_n_cores(parallel) + # Quietly: cv_spatial() resolves `parallel` again below and says what it + # does with it (a request above the machine's core count is capped, with a + # message), so resolving it here aloud printed that message twice. + n_workers <- suppressMessages(.resolve_n_cores(parallel)) if (n_workers > 1L && !("num_threads" %in% names(dots))) dots$num_threads <- 1L fit_fn <- function(train_sf) @@ -526,12 +679,16 @@ cv_rf <- function(data_sf, response_var, predictor_vars, folds = NULL, k = 5, # cv_spatial(), and through `...` it reached ranger() as an unused argument. # `metrics` is named for the same reason as `pointize`: it belongs to # cv_spatial(), and through `...` it would reach ranger(). - cv_spatial(data_sf, response_var, predictor_vars, fit_fn = fit_fn, - .caller = "cv_rf", - folds = folds, k = k, seed = seed, boundary = boundary, - pointize = pointize, - block_size = block_size, auto_range = auto_range, - parallel = parallel, metrics = metrics) + # fold_info_fn carries each fold forest's out-of-bag count back, for one + # warning per run in place of one per fold; see .rf_fold_oob_info(). + res <- cv_spatial(data_sf, response_var, predictor_vars, fit_fn = fit_fn, + .caller = "cv_rf", + folds = folds, k = k, seed = seed, boundary = boundary, + pointize = pointize, + block_size = block_size, auto_range = auto_range, + parallel = parallel, metrics = metrics, + fold_info_fn = .rf_fold_oob_info) + .rf_cv_oob_note(res, dots) } @@ -563,14 +720,20 @@ cv_rf <- function(data_sf, response_var, predictor_vars, folds = NULL, k = 5, #' \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{seed} defaults to a constant: an unset \code{seed} makes +#' those. So is anything \code{ranger}'s predict method itself refuses, +#' such as \code{type = "quantiles"} on a forest grown without +#' \code{quantreg = TRUE} or \code{type = "se"} without +#' \code{keep.inbag = TRUE}: the error names ranger's reason. +#' \code{seed} defaults to a constant: 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. +#' rows dropped as incomplete (so all \code{NA}, with a WARN line in the +#' log, when every row is). A failure inside \code{ranger}'s predict +#' method is an error, not an all-\code{NA} vector. #' @family methods on a fitted model #' @export predict.rf_fit <- function(object, newdata = NULL, ...) { @@ -596,6 +759,17 @@ predict.rf_fit <- function(object, newdata = NULL, ...) { newdata$..orig_row_id.. <- NULL n_new <- nrow(newdata) + # Nothing survived cleaning: every row is NA, as for any other dropped row + # (and as predict.gwr_fit() and predict.bayesian_fit() do). ranger would + # otherwise be handed a zero-row frame and fail with a reason about + # `sample_fraction`, which predict_surface() turns into an abort for a chunk + # that merely lies outside the covariates' coverage. + if (n_new == 0L) { + .log_warn(paste0("predict.rf_fit(): every row of newdata was dropped as ", + "missing or non-finite; returning %d NA(s)."), n_orig) + return(rep(NA_real_, n_orig)) + } + include_coords <- isTRUE(object$info$include_coords) X <- .rf_frame(newdata, object$predictor_vars, include_coords, .caller = "predict.rf_fit") @@ -624,14 +798,20 @@ predict.rf_fit <- function(object, newdata = NULL, ...) { # core when num.threads is unset. if (!("num.threads" %in% names(dots))) dots$num.threads <- .sanitize_core_count(getOption("mc.cores", 1L)) - p <- tryCatch( - 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)) - NULL - } - ) + # A failure is an error naming ranger's reason. It was caught, logged and + # returned as an all-NA vector, so type = "quantiles" on a forest grown + # without quantreg = TRUE, and type = "se" without keep.inbag = TRUE, both of + # which the documentation promises are rejected, came back as NA with no R + # condition, and model_metrics(newdata =) then reported n = 0. Every caller + # already handles an error: the cv_*() fold loop records it as the fold's + # cause, and predict_surface() stops naming the rows. + rr <- .call_capturing_stderr(function() + do.call(stats::predict, c(list(object$engine, data = X), dots))$predictions) + if (!is.null(rr$error)) + stop(sprintf("predict.rf_fit(): ranger's predict() failed: %s", + sub("^Error:\\s*", "", .stderr_reason(rr$error, rr$stderr))), + call. = FALSE) + p <- rr$value # predict.all = TRUE and type = "quantiles" make ranger return a matrix. # as.numeric() would flatten it column-major into a vector of the wrong # length, which .expand_predictions() would then either reject or (at the @@ -753,14 +933,27 @@ print.rf_fit <- function(x, ...) { # which is not NULL, so is.finite() would error and sprintf() would print # nothing at all. oob_rmse <- .num1(x$info$oob_rmse) - if (is.finite(oob_rmse)) + # A forest with no row out of bag (replace = FALSE, sample_fraction = 1) + # has no OOB error and NaN permutation importance. The OOB line used to + # vanish and the importance line to print empty, because sort() drops NaN. + oob_p <- x$engine$predictions + no_oob <- is.numeric(oob_p) && length(oob_p) > 0L && !any(is.finite(oob_p)) + if (is.finite(oob_rmse)) { cat(sprintf(" OOB RMSE: %.4f OOB R^2: %.4f\n", oob_rmse, .num1(x$info$oob_r_squared))) + } else if (no_oob) { + cat(" OOB RMSE: undefined (no row is out of bag)\n") + } imp <- x$info$importance if (!is.null(imp) && length(imp) > 0L) { - top <- utils::head(sort(imp, decreasing = TRUE), 5L) + imp_ok <- imp[is.finite(imp)] cat(sprintf(" Importance (%s): %s\n", x$info$importance_type, - paste(sprintf("%s=%.4g", names(top), top), collapse = ", "))) + if (!length(imp_ok)) { + if (no_oob) "undefined (no row is out of bag)" else "undefined" + } else { + top <- utils::head(sort(imp_ok, decreasing = TRUE), 5L) + paste(sprintf("%s=%.4g", names(top), top), collapse = ", ") + })) } cat("\n OOB is a random hold-out and is optimistic under spatial\n") cat(" autocorrelation; use cv_rf() for a spatial estimate.\n") diff --git a/R/model-selection-gwr.R b/R/model-selection-gwr.R index 1e528d2..8452d47 100644 --- a/R/model-selection-gwr.R +++ b/R/model-selection-gwr.R @@ -98,6 +98,36 @@ } +#' The uncorrected-AIC column of GWmodel's diagnostic table, or NULL +#' +#' Needed to tell a defined AICc from one outside its domain (see +#' \code{.gwr_aicc_undefined()}). Found by name in a labelled table, or as +#' column 2 of the documented four-column \code{c(bandwidth, AIC, AICc, RSS)} +#' layout when AICc was read positionally from column 3. \code{NULL} for any +#' other shape, so an unrecognised table is never guarded on a guessed column. +#' +#' @param gwr_df The diagnostic table. +#' @param crit What \code{.gwr_ms_criterion()} returned for it. +#' @return Numeric vector, one value per model, or \code{NULL}. +#' @keywords internal +#' @noRd +.gwr_ms_aic_column <- function(gwr_df, crit) { + if (is.null(dim(gwr_df))) return(NULL) + is_df <- is.data.frame(gwr_df) + cn <- if (is_df) names(gwr_df) else colnames(gwr_df) + col <- NA_integer_ + if (!is.null(cn)) { + hit <- which(toupper(trimws(cn)) == "AIC") + if (length(hit)) col <- as.integer(hit[[1L]]) + } + if (is.na(col) && !isTRUE(crit$by_name) && isTRUE(crit$shape_ok) && + identical(as.integer(crit$column), 3L)) + col <- 2L + if (is.na(col)) return(NULL) + suppressWarnings(as.numeric(if (is_df) gwr_df[[col]] else gwr_df[, col])) +} + + #' Normalise GWmodel's model list into character vectors of predictors #' #' Handles the three shapes the element can take: a two-element list of the @@ -293,19 +323,59 @@ # the full model underdetermined, and GWmodel would fail partway through. if (isTRUE(adaptive)) { bw <- as.integer(round(bw)) - min_bw <- n_cand + 2L - if (min_bw > n_obs) + if (n_cand + 2L > n_obs) stop(sprintf(paste0("gwr_model_selection(): %d observations cannot ", "support a local fit of %d candidate predictors ", "plus an intercept."), n_obs, n_cand), call. = FALSE) + # The full model has n_cand + 1 parameters. n_cand + 2 left bisquare and + # tricube windows with n_cand + 1 points (their bw-th neighbour has weight + # 0), an exact interpolator whose AICc of about -n^2/2 put it first; see + # .gwr_min_adaptive_bw(). Capped at n_obs, as the stop above allows, and + # the AICc guard in gwr_model_selection() deals with what is left. + min_bw <- min(.gwr_min_adaptive_bw(n_cand + 1L, kernel), n_obs) if (bw < min_bw) { - .log_warn("gwr_model_selection(): adaptive bandwidth %d is too small for the full %d-predictor model; clamping to %d.", - bw, n_cand, min_bw) + # A warning: every model in the sweep is fitted at a bandwidth the + # caller did not ask for. + .warn_and_log(paste0("gwr_model_selection(): an adaptive bandwidth of ", + "%d neighbours is too small for the full ", + "%d-predictor model with the %s kernel; using %d.%s"), + bw, n_cand, kernel, min_bw, + if (kernel %in% c("bisquare", "tricube")) + paste0(" That is enough unless several neighbours tie ", + "at the kernel's edge (a regular grid), which ", + "gives them weight 0 too; then use a larger ", + "bandwidth.") else "") bw <- min_bw } - if (bw > n_obs) bw <- as.integer(n_obs) + # Capped at n, and said: a supplied count above n is most often a + # distance meant for adaptive = FALSE, and bw.gwr() searches from 20 up + # to n, so below 20 points its choice exceeds n. See fit_gwr_model(). + if (bw > n_obs) { + if (identical(bandwidth_source, "supplied")) + .warn_and_log(paste0("gwr_model_selection(): an adaptive bandwidth of ", + "%d neighbours exceeds the %d observations; using ", + "%d. With adaptive = TRUE the bandwidth is a count ", + "of neighbours; for a distance in CRS units, set ", + "adaptive = FALSE."), + bw, n_obs, n_obs) + else if (!identical(bandwidth_source, "fallback")) + .warn_and_log(paste0("gwr_model_selection(): GWmodel::bw.gwr() ", + "searches adaptive bandwidths from 20 neighbours ", + "up to n, a range that is empty for %d ", + "observations, and returned %d; using %d. Neither ", + "is an optimised bandwidth: with this few ", + "observations, supply `bandwidth`."), + n_obs, bw, n_obs) + bw <- as.integer(n_obs) + } } + # A supplied fixed bandwidth in the wrong units (degrees read as metres) + # empties every window, and the sweep then died on GWmodel's bare "inv(): + # matrix is singular"; fit_gwr_model() says what is wrong, and so does this. + if (!isTRUE(adaptive) && identical(bandwidth_source, "supplied")) + .gwr_warn_tiny_fixed_bw(dat, bw, "gwr_model_selection") + # A FIXED bandwidth needs the distance matrix. Without one, # gwr.model.selection() sets dMat <- matrix(0, 0, 0) and then asserts # stopifnot(bw > min(dMat)); min() of an empty matrix is Inf, so the @@ -342,9 +412,12 @@ if (!is.null(dMat)) ms_args$dMat <- dMat res <- tryCatch( .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) + error = function(e) { + msg <- conditionMessage(e) + stop(sprintf("gwr_model_selection(): gwr.model.selection() failed: %s%s", + msg, if (grepl("singular", msg, fixed = TRUE)) + .gwr_singular_hint() else ""), call. = FALSE) + } ) if (!is.list(res) || length(res) < 2L) @@ -418,7 +491,19 @@ #' \code{adaptive = TRUE}; otherwise a distance in the units of the #' **projected** CRS the sweep runs in, which \code{prep_model_data()} may #' have chosen for you. Geographic input is projected before the bandwidth -#' is used, so a value in degrees would be read as metres. +#' is used, so a value in degrees would be read as metres; a fixed +#' bandwidth below a ten-thousandth of the data's extent raises a warning +#' saying so, as in \code{\link{fit_gwr_model}()}. An adaptive +#' count too small for the full model is raised, with a warning, to the +#' number of candidates plus 3 for the bisquare and tricube kernels (which +#' give the farthest neighbour in a window weight 0), plus 2 for the others. +#' That floor is enough unless several neighbours tie at the kernel's edge +#' (a regular grid), which leaves a window fewer weighted points; then use +#' a larger bandwidth. An adaptive count below 1 or above R's largest +#' integer is refused, as in \code{\link{fit_gwr_model}()}. +#' One above the number of observations is capped at it, with a warning; +#' below 20 observations that includes \code{bw.gwr()}'s choice, since its +#' adaptive search starts at 20 neighbours. #' @param adaptive Logical; adaptive (nearest-neighbour) bandwidth. Default #' \code{TRUE}. #' @param kernel Weighting kernel. One of \code{"bisquare"} (default), @@ -441,7 +526,11 @@ #' @return An object of class \code{gwr_model_selection}, a list with: #' \code{best} (character vector of the selected predictors); #' \code{table} (ranked data.frame of every model evaluated, with columns -#' \code{rank}, \code{n_vars}, \code{variables} and \code{criterion}); +#' \code{rank}, \code{n_vars}, \code{variables} and \code{criterion}; +#' \code{criterion} is \code{NA}, and the model ranked last, where GWmodel +#' could not evaluate it or where AICc is undefined because the model's +#' effective number of parameters \eqn{tr(S)} is not below \eqn{n - 2}, +#' which raises a warning); #' \code{criterion} (label for the criterion actually read, noting when it #' had to be located positionally); #' \code{criterion_by_name} (logical: whether that column was found by @@ -518,9 +607,7 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, stop("gwr_model_selection(): `response_var` must be a single column name.", call. = FALSE) # 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.) + # value never gets past it. kernel <- match.arg(kernel) bw_approach <- match.arg(bw_approach) @@ -543,6 +630,16 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, else "a distance in the CRS units of `data_sf`"), call. = FALSE) + # The same range check fit_gwr_model() applies to an adaptive count. + # Without it a count above .Machine$integer.max (a distance passed with + # adaptive left at TRUE) became NA in the engine's as.integer() and the + # clamp stopped with a bare "missing value where TRUE/FALSE needed", and a + # count below 1 was rounded to "0 neighbours" and raised, where + # fit_gwr_model() refuses it. + if (!is.null(bandwidth) && isTRUE(adaptive)) + .check_scalar(bandwidth, "bandwidth", "gwr_model_selection", min = 1, + max = .Machine$integer.max, + what = "a single number of nearest neighbours when adaptive = TRUE") candidate_vars <- unique(as.character(candidate_vars)) missing_v <- setdiff(c(response_var, candidate_vars), names(data_sf)) @@ -600,6 +697,39 @@ gwr_model_selection <- function(data_sf, response_var, candidate_vars, varsets <- .gwr_ms_varsets(eng$model_list, response_var) crit <- .gwr_ms_criterion(eng$gwr_df, criterion = "AICc") + # A model whose AICc is outside its domain (tr S >= n - 2: its local fits + # interpolate the data) gets a large negative AICc from GWmodel, and the + # sweep ranked it first: at n = 60 a model of `a` plus three noise + # variables won with -66689. Set those to NA so they rank last, and say so. + # GWmodel picked its own forward steps on the same numbers, which the + # warning says too. Unguarded when the AIC column cannot be located. + aic <- .gwr_ms_aic_column(eng$gwr_df, crit) + if (!is.null(aic) && length(aic) == length(crit$values)) { + undef <- !is.na(crit$values) & .gwr_aicc_undefined(aic, crit$values) + if (any(undef)) { + crit$values[undef] <- NA_real_ + # No larger adaptive bandwidth exists once it is every observation. + at_n <- isTRUE(adaptive) && + isTRUE(suppressWarnings(as.numeric(eng$bandwidth)) >= nrow(dat)) + .warn_and_log(paste0("gwr_model_selection(): AICc is undefined for %d ", + "of %d model(s) at bandwidth %s and they are ranked ", + "last: their effective number of parameters tr(S) ", + "is not below n - 2 = %d, so their local fits ", + "(nearly) interpolate the data. GWmodel chose its ", + "forward steps on the same values, so the sweep ", + "past them may not follow the best path. %s"), + sum(undef), length(undef), format(eng$bandwidth), + nrow(dat) - 2L, + if (at_n) + sprintf(paste0("Even the widest adaptive window (all %d ", + "observations) leaves too few residual ", + "degrees of freedom for them: use fewer ", + "candidates, more observations, or a ", + "gaussian or exponential kernel."), + nrow(dat)) + else "Use a larger bandwidth.") + } + } tab <- .gwr_ms_table(varsets, crit$values, minimise = TRUE) # GWmodel builds GWR.df with rbind() over unnamed vectors, so it never diff --git a/R/plotting-diagnostics.R b/R/plotting-diagnostics.R index b8c1bd8..61cd804 100644 --- a/R/plotting-diagnostics.R +++ b/R/plotting-diagnostics.R @@ -29,7 +29,11 @@ #' \code{overall} when it carries the metric, from #' \code{predictive_coverage} for \code{cv_bayes()}'s coverage and CRPS #' columns, and not at all for a per-fold extra that has no pooled -#' counterpart (a bandwidth), in which case the caption says so. +#' counterpart (a bandwidth) or for a count (\code{n_pred}, +#' \code{n_MAPE}, \code{n_SMAPE}), whose \code{overall} value is the +#' total over the folds; the caption says which. A model with no finite +#' per-fold value gets no panel and no pooled line, and the caption +#' names it. #' #' @param cv The list returned by \code{\link{cv_spatial}()}, #' \code{\link{cv_gwr}()}, \code{\link{cv_bayes}()}, \code{\link{cv_rf}()} @@ -108,15 +112,28 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { df <- df[is.finite(df$value), , drop = FALSE] df$fold <- factor(df$fold, levels = sort(unique(df$fold))) df$model <- factor(df$model, levels = unique(df$model)) + # A model with no finite per-fold value has no panel. factor() turned its + # pooled row into NA, which the finite-value filter kept, so its line was + # drawn in another model's panel or in a third panel labelled NA. + # A model is named as not drawn whether or not it has a pooled value: RF's + # `bandwidth` is NA in every fold and in `overall`, and it vanished + # unmentioned. + pooled$model <- as.character(pooled$model) + no_folds <- unique(pooled$model[!(pooled$model %in% levels(df$model))]) pooled$model <- factor(pooled$model, levels = levels(df$model)) - pooled <- pooled[is.finite(pooled$value), , drop = FALSE] + pooled <- pooled[!is.na(pooled$model) & is.finite(pooled$value), , drop = FALSE] n_models <- nlevels(df$model) title <- sprintf("%s by fold", metric) caption <- if (nrow(pooled)) "Dashed line: the pooled value from `overall`" + else if (metric %in% .cv_count_metrics) + sprintf("No pooled value: `%s` is a count per fold; `overall` holds the total", metric) else sprintf("No pooled value: `%s` is a per-fold quantity with no counterpart in `overall`", metric) + if (length(no_folds)) + caption <- paste0(caption, sprintf("\nNot drawn: %s (no finite per-fold `%s`)", + paste(no_folds, collapse = ", "), metric)) size_aes <- if (any(is.finite(df$n_pred))) ggplot2::aes(size = .data$n_pred) else NULL p <- ggplot2::ggplot(df, ggplot2::aes(x = .data$fold, y = .data$value)) @@ -127,7 +144,9 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { ggplot2::scale_size_continuous(name = "Held-out rows", range = c(1.5, 5)) + ggplot2::labs(title = title, x = "Fold", y = metric, caption = caption) + ggplot2::theme_minimal() - if (n_models > 1L) + # A compare_models_cv() result is faceted even when one model is left, so + # the strip still says which model the points are. + if (n_models > 1L || identical(what, "compare_models_cv()")) # One panel per model, stacked on a shared fold axis, with room between # the panels and a full-size strip label (see .plot_sweep() for why). p <- p + ggplot2::facet_wrap(~ model, ncol = 1L, scales = "fixed") + @@ -136,10 +155,17 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { p } +# Count columns of `overall` that are totals over the folds: overall$n_pred, +# n_MAPE and n_SMAPE count the pooled prediction rows, so each is the SUM of +# the per-fold counts, not a pooled value on the per-fold scale. Drawn as +# the pooled line, n_pred sat at 150 against folds of 30. +.cv_count_metrics <- c("n_pred", "n_MAPE", "n_SMAPE") + #' The pooled value of a metric for a single cv_*() result #' @keywords internal #' @noRd .pooled_metric_one <- function(cv, ov, metric) { + if (metric %in% .cv_count_metrics) return(NA_real_) if (nrow(ov) >= 1L && metric %in% names(ov)) { val <- suppressWarnings(as.numeric(ov[[metric]][1L])) if (is.finite(val)) return(val) @@ -158,6 +184,7 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { .pooled_metric_by_model <- function(cmp, ov, metric) { models <- as.character(ov$model) vals <- vapply(seq_along(models), function(i) { + if (metric %in% .cv_count_metrics) return(NA_real_) if (metric %in% names(ov)) { v <- suppressWarnings(as.numeric(ov[[metric]][i])) if (is.finite(v)) return(v) @@ -185,12 +212,20 @@ plot_cv_metrics <- function(cv, metric = "RMSE", ...) { #' of applicability; it does not say whether the rest sit comfortably inside #' or crowd against the threshold, nor how far outside the outsiders are. #' This draws the dissimilarity index of the prediction locations against -#' that of the cross-validated training data, with the threshold marked, so -#' the prediction set can be read as mostly inside, marginal or largely -#' outside. The training curve is the reference the threshold was derived -#' from: the threshold is the largest cross-validated training DI inside an -#' outlier fence, so the curve reaches it exactly when no training value was -#' fenced off and runs past it, by the tail the fence removed, when some were. +#' that of the training data, with the threshold marked, so the prediction +#' set can be read as mostly inside, marginal or largely outside. The +#' training DI is cross-validated over the \code{folds} passed to +#' \code{\link{area_of_applicability}()}, or without them is each training +#' point's distance to its nearest other training point; the legend and the +#' caption say which. The training curve is the reference the threshold was +#' derived from: the threshold is the largest training DI inside an outlier +#' fence, so the curve reaches it exactly when no training value was fenced +#' off and runs past it, by the tail the fence removed, when some were. +#' A prediction location outside on a predictor dropped for having no +#' training variance has \code{DI = Inf}: it counts in the prediction curve, +#' which then tops out below 1, and the caption says how many are off the +#' axis. A location with a missing predictor (\code{DI = NA}) is neither +#' inside nor outside; it is left out of the curve and the caption counts it. #' #' @param x An \code{aoa} object from \code{\link{area_of_applicability}()}. #' @param type \code{"ecdf"} (default), the two empirical distribution @@ -226,24 +261,45 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { if (!inherits(x, "aoa") || is.null(x$aoa) || !("DI" %in% names(x$aoa))) stop("plot.aoa(): `x` must be the object returned by area_of_applicability().", call. = FALSE) - di_new <- suppressWarnings(as.numeric(sf::st_drop_geometry(x$aoa)$DI)) + di_all <- suppressWarnings(as.numeric(sf::st_drop_geometry(x$aoa)$DI)) di_tr <- suppressWarnings(as.numeric(x$train_DI)) thr <- as.numeric(x$threshold) - di_new <- di_new[is.finite(di_new)] + # DI = Inf is a row outside on a predictor dropped for having no training + # variance: definitively outside, but not on any axis. Filtering it out + # with the NA rows made the prediction curve reach 1 over the finite rows, + # so it read as nearly everything inside while the subtitle counted those + # rows outside. They stay in the curve's denominator and the caption + # names them; NA rows (a missing predictor) are neither inside nor outside. + n_inf <- sum(is.infinite(di_all)) + n_na <- sum(is.na(di_all)) + di_new <- di_all[is.finite(di_all)] di_tr <- di_tr[is.finite(di_tr)] - if (!length(di_new)) - stop("plot.aoa(): no finite dissimilarity index at any prediction location ", - "(every row had a missing or non-finite predictor).", call. = FALSE) + n_all <- x$n_new %||% length(di_all) + if (!length(di_new)) { + if (n_inf == 0L) + stop("plot.aoa(): no finite dissimilarity index at any prediction location ", + "(every row had a missing or non-finite predictor).", call. = FALSE) + stop(sprintf(paste0("plot.aoa(): no finite dissimilarity index to plot: %d of ", + "%d prediction locations are outside on a predictor dropped ", + "for having no training variance (DI = Inf)%s."), + n_inf, n_all, + if (n_na) sprintf(" and %d %s a missing predictor (DI = NA)", n_na, + if (n_na == 1L) "has" else "have") + else ""), call. = FALSE) + } + # Without folds the training DI is each point's distance to its nearest + # other training point, not a cross-validated one; a legend hard-coded to + # "cross-validated" contradicted the caption beneath it. + tr_set <- if (isTRUE(x$params$folds_supplied)) "Training (cross-validated)" + else "Training (nearest other training point)" df <- rbind( data.frame(set = "Prediction locations", DI = di_new, stringsAsFactors = FALSE), - if (length(di_tr)) data.frame(set = "Training (cross-validated)", DI = di_tr, + if (length(di_tr)) data.frame(set = tr_set, DI = di_tr, stringsAsFactors = FALSE) ) - df$set <- factor(df$set, levels = c("Training (cross-validated)", "Prediction locations")) + df$set <- factor(df$set, levels = c(tr_set, "Prediction locations")) - n_all <- x$n_new %||% length(di_new) - share_out <- if (length(di_new)) mean(di_new > thr) else NA_real_ # Where the prediction set sits relative to the threshold: the fraction # inside, and how close the inside ones run to the edge. q_in <- if (any(di_new <= thr)) stats::quantile(di_new[di_new <= thr], 0.9) / thr else NA_real_ @@ -255,20 +311,61 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { if (is.finite(q_in)) sprintf("\n90%% of those inside sit below %.0f%% of the threshold", 100 * q_in) else "") + # .aoa_folds_label() is phrased for print()'s parenthesis ("from fold + # labels; method unknown"), which read "over from fold labels; method + # unknown folds" spliced in here. Without folds each training point's + # reference is its nearest neighbour among ALL other training rows, never + # farther than the nearest outside its own fold, so the threshold is small + # and the AOA conservative (?area_of_applicability), not optimistic. + fm <- x$params$folds_method + cv_line <- if (!isTRUE(x$params$folds_supplied)) { + if (isTRUE(x$params$threshold_supplied)) + "Training DI not cross-validated (no folds)" + else paste("Training DI not cross-validated (no folds),", + "so the threshold is small\nand the AOA conservative") + } else if (!is.character(fm) || length(fm) != 1L || is.na(fm)) + "Training DI cross-validated (fold method unknown)" + else if (identical(fm, "labels")) + "Training DI cross-validated over folds given as labels (method unknown)" + else if (identical(fm, "splits")) + "Training DI cross-validated over folds given as train/test splits (method unknown)" + else sprintf("Training DI cross-validated over %s folds", fm) caption <- sprintf("Threshold %s\n%s", if (isTRUE(x$params$threshold_supplied)) "supplied" else "from the training DI", - if (isTRUE(x$params$folds_supplied)) - sprintf("Training DI cross-validated over %s folds", - .aoa_folds_label(x$params$folds_method)) - else paste("Training DI not cross-validated (no folds),", - "so the threshold is optimistic")) + cv_line) + if (n_inf) + caption <- paste0(caption, sprintf(paste0( + "\n%d prediction location%s outside on a dropped predictor (DI = Inf) ", + "%s off the axis"), n_inf, if (n_inf == 1L) "" else "s", + if (n_inf == 1L) "is" else "are")) + if (n_na) + caption <- paste0(caption, sprintf( + "\n%d with a missing predictor (DI = NA) %s not drawn", n_na, + if (n_na == 1L) "is" else "are")) if (type == "ecdf") { - p <- ggplot2::ggplot(df, ggplot2::aes(x = .data$DI, colour = .data$set)) + - ggplot2::stat_ecdf(geom = "step", linewidth = 0.8) + + # The curves are computed here rather than by stat_ecdf(), which drops + # non-finite x: the prediction curve counts the DI = Inf rows in its + # denominator (they sit at +Inf), so it tops out at the finite share and + # its height at the threshold is n_inside / (n_new - n_na). The padding + # at -Inf and Inf is stat_ecdf()'s, so the steps still run edge to edge. + ecdf_steps <- function(v, denom, set) { + at <- c(-Inf, sort(unique(v)), Inf) + data.frame(set = set, DI = at, + share = stats::ecdf(v)(at) * length(v) / denom, + stringsAsFactors = FALSE) + } + steps <- rbind( + ecdf_steps(di_new, length(di_new) + n_inf, "Prediction locations"), + if (length(di_tr)) ecdf_steps(di_tr, length(di_tr), tr_set) + ) + steps$set <- factor(steps$set, levels = levels(df$set)) + p <- ggplot2::ggplot(steps, ggplot2::aes(x = .data$DI, y = .data$share, + colour = .data$set)) + + ggplot2::geom_step(linewidth = 0.8) + ggplot2::geom_vline(xintercept = thr, linetype = "dashed", colour = "#B2182B") + - ggplot2::scale_colour_manual(values = c("Training (cross-validated)" = "grey45", - "Prediction locations" = "#2166AC"), + ggplot2::scale_colour_manual(values = stats::setNames(c("grey45", "#2166AC"), + c(tr_set, "Prediction locations")), name = NULL) + ggplot2::labs(title = "Dissimilarity index: prediction locations against training", subtitle = subtitle, caption = caption, @@ -312,8 +409,9 @@ plot.aoa <- function(x, type = c("ecdf", "histogram"), ...) { #' systematic over-confidence (points below the line) or intervals wider than #' they need to be (above it) are read at a glance. Three levels is a thin #' curve; pass \code{coverage_levels = seq(0.1, 0.9, by = 0.1)} to -#' \code{cv_bayes()} for a full one. The levels are read off the column -#' names, so whatever was computed is drawn. +#' \code{cv_bayes()} for a full one. Each level is drawn at the nominal value +#' \code{cv_bayes()} records in \code{coverage_levels}, so whatever was +#' computed is drawn where it belongs (0.975 at 0.975, not rounded). #' #' @param cv The list returned by \code{\link{cv_bayes}()}, or a #' \code{\link{compare_models_cv}()} result that ran the Bayesian backend @@ -347,12 +445,24 @@ plot_calibration <- function(cv, ...) { stop("plot_calibration(): `cv` must be the list returned by cv_bayes(), or a ", "compare_models_cv() result whose Bayesian backend ran.", call. = FALSE) fm <- as.data.frame(cv$fold_metrics) - cov_cols <- grep("^coverage_[0-9]+$", names(fm), value = TRUE) + # The nominal levels come from cv_bayes()'s `coverage_levels`, named by + # column. They used to be read back from the column names, which were + # rounded to a whole percent (0.995 was drawn at 1.00); the names are the + # fallback, for a result from before that element existed, now read at + # whatever precision they carry. + lv <- cv$coverage_levels + if (is.numeric(lv) && length(lv) && !is.null(names(lv))) { + lv <- lv[names(lv) %in% names(fm)] + cov_cols <- names(lv) + nominal <- unname(as.numeric(lv)) + } else { + cov_cols <- grep("^coverage_[0-9]+(\\.[0-9]+)?$", names(fm), value = TRUE) + nominal <- as.numeric(sub("^coverage_", "", cov_cols)) / 100 + } if (!length(cov_cols)) stop("plot_calibration(): the result carries no coverage_* columns; ", "cv_bayes() computes them when compute_pred_intervals = TRUE and at ", "least one fold produced posterior predictive draws.", call. = FALSE) - nominal <- as.numeric(sub("^coverage_", "", cov_cols)) / 100 per_fold <- do.call(rbind, lapply(seq_along(cov_cols), function(j) { data.frame(fold = fm$fold, nominal = nominal[j], @@ -361,10 +471,14 @@ plot_calibration <- function(cv, ...) { stringsAsFactors = FALSE) })) per_fold <- per_fold[is.finite(per_fold$observed), , drop = FALSE] + # cv_bayes() creates the columns whether or not it computes them, so an + # all-NA set has two causes, and naming only the draws sent a user who had + # passed compute_pred_intervals = FALSE looking for a sampler failure. if (!nrow(per_fold)) - stop("plot_calibration(): coverage is NA in every fold (the posterior ", - "predictive draws failed everywhere), so there is nothing to draw.", - call. = FALSE) + stop("plot_calibration(): coverage is NA in every fold, so there is ", + "nothing to draw: either cv_bayes() ran with compute_pred_intervals = ", + "FALSE, or the posterior predictive draws failed in every fold (see ", + "the log).", call. = FALSE) pc <- cv$predictive_coverage pooled <- data.frame(nominal = nominal, observed = vapply(cov_cols, function(cn) { @@ -425,7 +539,7 @@ plot_calibration <- function(cv, ...) { #' @param df Data frame with columns \code{x}, \code{y}, \code{panel} #' (facet; one level for a single panel) and optionally \code{label} #' (text at the point) and \code{role} (\code{"candidate"} points are drawn -#' faint, everything else full). +#' faint, \code{"rejected"} ones hollow on the path, everything else full). #' @param chosen Data frame with \code{panel}, \code{x}, \code{y}: the point #' the rule picked in each panel (may have zero rows). #' @param flat Optional data frame with \code{panel}, \code{xmin}, @@ -458,9 +572,15 @@ plot_calibration <- function(cv, ...) { if (connect && nrow(main)) p <- p + ggplot2::geom_line(data = main, ggplot2::aes(x = .data$x, y = .data$y), colour = "grey30") - if (nrow(main)) - p <- p + ggplot2::geom_point(data = main, ggplot2::aes(x = .data$x, y = .data$y), - colour = "grey30", size = 2) + # A "rejected" point (scored and on the path, but not taken) is drawn + # hollow, in the same layer, so every scored point is still drawn once. + if (nrow(main)) { + main$shape <- ifelse(main$role == "rejected", 21, 19) + p <- p + ggplot2::geom_point(data = main, + ggplot2::aes(x = .data$x, y = .data$y, shape = .data$shape), + colour = "grey30", fill = "white", size = 2) + + ggplot2::scale_shape_identity() + } if (!is.null(main$label) && any(nzchar(main$label))) p <- p + ggplot2::geom_text(data = main[nzchar(main$label), , drop = FALSE], ggplot2::aes(x = .data$x, y = .data$y, label = .data$label), @@ -519,14 +639,15 @@ plot_calibration <- function(cv, ...) { #' library(sf) #' # The same field as ?resolution_profile: an exponential covariance with #' # range parameter 200 and a nugget of 0.6 on a unit sill. -#' set.seed(2) +#' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) #' D <- as.matrix(dist(xy)) #' xy$z <- as.numeric(t(chol(exp(-D / 200) + diag(0.6, n))) %*% rnorm(n)) #' pts <- st_as_sf(xy, coords = c("x", "y"), crs = 32632) #' prof <- resolution_profile(pts, response_var = "z", n_levels = 12) -#' print(plot(prof)) # all four criteria, one panel each +#' print(plot(prof)) # one panel per criterion it scored: no +#' # elbow on these uniform points #' plot(prof, criteria = c("cp", "wss")) # Cp beside the raw WSS curve #' } #' @export @@ -627,7 +748,10 @@ plot.resolution_profile <- function(x, criteria = NULL, tol = 0.02, ...) { #' step and keeps the best; its \code{history} holds all of them. This draws #' the accepted variable's score at each step as the path, every other #' candidate's score at that step as a faint point, and the step at which the -#' selection stopped in red. The picture then says whether the last variable +#' selection stopped in red. When it stopped because no candidate cleared +#' \code{tol}, the path runs one step further to the best of the rejected +#' candidates, drawn hollow and labelled "not added", so the stop reads as a +#' flattening rather than a cut. The picture then says whether the last variable #' was a clear gain or the first that happened to clear \code{tol}, and #' whether the runner-up would have done as well. The scores are the #' selection's own cross-validated criterion, optimistically biased by the @@ -675,7 +799,9 @@ plot.feature_selection <- function(x, ...) { # The accepted variable at step s is selected[s]; the path runs through # its score. Steps past n_sel were scored and rejected (nothing cleared # tol), and their best candidate is drawn as part of the path too, so the - # stop is visible as a flattening rather than as a cut. + # stop is visible as a flattening rather than as a cut -- but hollow and + # labelled "not added": drawn and named like the others, a candidate that + # improved the score by less than tol read as a variable in the model. h$role <- "candidate" h$label <- "" path_rows <- integer(0) @@ -686,8 +812,11 @@ plot.feature_selection <- function(x, ...) { else { pick <- idx[if (minimise) which.min(h$score[idx]) else which.max(h$score[idx])] } if (length(pick) == 1L && !is.na(pick)) path_rows <- c(path_rows, pick) } + rejected <- path_rows[h$step[path_rows] > n_sel] h$role[path_rows] <- "path" + h$role[rejected] <- "rejected" h$label[path_rows] <- h$variable[path_rows] + h$label[rejected] <- paste(h$variable[rejected], "(not added)") df <- data.frame(panel = metric, x = h$step, y = as.numeric(h$score), role = h$role, label = h$label, stringsAsFactors = FALSE) chosen <- if (n_sel > 0L && n_sel %in% h$step) { diff --git a/R/plotting-fits.R b/R/plotting-fits.R index 7f7252c..ebe63bc 100644 --- a/R/plotting-fits.R +++ b/R/plotting-fits.R @@ -40,7 +40,11 @@ #' checks most likely to reveal a problem (is there structure left in the #' residuals, and where is it) had to be written by hand each time. #' -#' @param x A \code{spatial_fit}. +#' @param x A \code{spatial_fit}. The residuals drawn are +#' \code{residuals(x)}; for a custom subclass with no \code{residuals()} +#' method (optional, see \code{\link{new_spatial_fit}()}) they are the +#' response minus \code{fitted(x)}, which is what the built-in backends' +#' methods return. #' @param type One of: #' \describe{ #' \item{\code{"residuals"}}{Residuals mapped at the training locations. @@ -55,10 +59,12 @@ #' dashed fit. The gap between the two curves is the spatial structure #' the model absorbed: a residual sill well below the response sill #' means most of it, two curves that coincide mean none. When both -#' effective ranges were identified the caption gives the residual sill -#' as a share of the response sill and the two ranges; when either -#' variogram reached no sill the caption says so and compares nothing, -#' because a sill the data never reached is not a number to divide by. +#' effective ranges were identified over the same point pairs the caption +#' gives the residual sill as a share of the response sill and the two +#' ranges; when either variogram has no identified range, or the two +#' are not over the same pairs, the caption says so and compares +#' nothing: a sill the data never reached is not a number to divide by, +#' and one direction's sill is not comparable with all directions'. #' The residual range is expected to come out shorter and the residual #' sill lower even when the model is right, because residuals of a #' fitted trend understate the variogram (see @@ -66,16 +72,24 @@ #' residual-variogram bias"). #' The distance axis is labelled in the units of the CRS the variogram #' was actually fitted in, which is not necessarily the fit's own CRS -#' (lon/lat data are projected first). A single-direction fit names its -#' azimuth in the title; a fit that identified no range says why in the -#' subtitle, since the overlaid model line is then not a fit to believe. +#' (lon/lat data are projected first). Each curve is the variogram +#' \code{estimate_sac_range()} returns for its variable: all point pairs, +#' or, when the all-pairs fit was unusable, the widest of four directions, +#' which is named with its azimuth (in the title for the residuals, in the +#' caption for the response). A fit that identified no range says why in +#' the subtitle, since the overlaid model line is then not a fit to believe. #' Requires 'gstat'.} #' \item{\code{"coefficients"}}{For a GWR fit only: the local coefficient #' of one \code{term} mapped at the training locations, which is the #' reason to fit GWR at all. Locations where the local design is -#' collinear (the kernel-weighted window's scaled condition index is -#' above 30, or the window is singular) are drawn hollow and grey -#' (\code{mask = TRUE}), because the smooth surface a naive map draws +#' collinear for that term are drawn hollow and grey +#' (\code{mask = TRUE}): for a slope, where the kernel-weighted +#' window's slope condition index (\code{cn_slopes}, predictors +#' centred in the window) is above 30 or the window is singular, or +#' where the index with the intercept (\code{cn}) is above 1e6; for +#' the Intercept, where \code{cn} is above 30 (a predictor far from 0 +#' against its local spread makes the local intercept an +#' extrapolation). They are masked because the smooth surface a naive map draws #' over them is the picture of an unstable estimate, not of a #' relationship; the subtitle counts them. The condition indices are #' the fit's \code{info$local_collinearity}, computed for every @@ -90,8 +104,8 @@ #' map, one of the names \code{coef(x)} returns. Default \code{NULL}: the #' first predictor. Ignored by the other types. #' @param mask For \code{type = "coefficients"}: whether to draw locations -#' whose local design is collinear (scaled condition index of the -#' kernel-weighted window above 30, or singular) as hollow grey points +#' whose local design is collinear for that term (see +#' \code{type = "coefficients"}) as hollow grey points #' instead of colouring them by a coefficient that is not to be believed #' there. Default \code{TRUE}. Locations whose coefficient is non-finite #' are masked either way. @@ -133,6 +147,15 @@ plot.spatial_fit <- function(x, type = c("residuals", "observed_predicted", return(.plot_gwr_coefficients(x, term = term, mask = mask)) res <- try(stats::residuals(x), silent = TRUE) + # A custom subclass without a residuals.() method -- which + # ?new_spatial_fit calls optional -- gets residuals.default(), i.e. + # x$residuals, i.e. NULL, and every type but "coefficients" stopped here. + # The built-in backends' residuals are the observed response minus + # fitted(), and fitted() is the method a custom subclass must define; when + # it is missing too, .fitted_checked() says which method to write. + if (is.null(res) && is.character(x$response_var) && inherits(x$data_sf, "sf")) + res <- as.numeric(sf::st_drop_geometry(x$data_sf)[[x$response_var]]) - + as.numeric(.fitted_checked(x, .caller = "plot.spatial_fit")) if (inherits(res, "try-error") || !is.numeric(res)) stop("plot.spatial_fit(): could not extract residuals from this fit.", call. = FALSE) @@ -252,14 +275,30 @@ plot.spatial_fit <- function(x, type = c("residuals", "observed_predicted", paste(sQuote(names(cf)), collapse = ", ")), call. = FALSE) vals <- suppressWarnings(as.numeric(cf[[term]])) lc <- x$info$local_collinearity - cn_bad <- if (is.data.frame(lc) && nrow(lc) == nrow(dat)) - (!is.finite(lc$cn) | lc$cn > 30) else rep(FALSE, nrow(dat)) + # Each term is masked by the index that speaks for it. The intercept by + # Belsley's uncentred index with the intercept (`cn`): a predictor far from + # 0 against its local spread makes the local intercept an extrapolation. A + # slope by the slope index (see .gwr_slopes_collinear()), which does not + # depend on the predictor's origin: masking slopes on `cn` hid the whole + # map of a temperature in kelvin, identical to the one in degrees C that + # was drawn. A fit made before `cn_slopes` existed falls back to `cn`. + is_intercept <- identical(term, "Intercept") && !("Intercept" %in% x$predictor_vars) + cn_bad <- if (is.data.frame(lc) && nrow(lc) == nrow(dat)) { + if (is_intercept) (!is.finite(lc$cn) | lc$cn > 30) + else .gwr_slopes_collinear(lc) + } else rep(FALSE, nrow(dat)) non_finite <- !is.finite(vals) masked <- non_finite | (isTRUE(mask) & cn_bad) if (all(masked)) stop("plot.spatial_fit(type = \"coefficients\"): every location is masked ", "(non-finite coefficient, or a collinear local design at all of them); ", - "there is no surface to draw.", call. = FALSE) + "there is no surface to draw.", + if (is_intercept && !all(non_finite)) + paste0(" The local intercept is an extrapolation to predictor values ", + "of 0 wherever a predictor's local values are far from 0 ", + "against their spread; centre the predictors to map it, or ", + "pass mask = FALSE.") else "", + call. = FALSE) dat$.coef <- vals dat$.masked <- masked @@ -280,16 +319,27 @@ plot.spatial_fit <- function(x, type = c("residuals", "observed_predicted", ggplot2::scale_colour_viridis_c(name = term) } n_cn <- sum(cn_bad & !non_finite); n_nf <- sum(non_finite) + surveyed <- is.data.frame(lc) && nrow(lc) == nrow(dat) + # With mask = FALSE the collinear windows are drawn as if reliable, and the + # subtitle has to say so even when a non-finite coefficient elsewhere sends + # it down the "masked" branch; that branch used to drop the note. And a + # clean survey is not a missing one: mask = FALSE on a well-conditioned fit + # fell through to "Collinearity not surveyed". + unmasked_cn <- if (!isTRUE(mask) && n_cn) + sprintf("mask = FALSE: %d location(s) with a collinear local design are drawn as if reliable", n_cn) subtitle <- if (any(masked)) - sprintf("%d of %d locations masked (hollow):\n%s", sum(masked), nrow(dat), - paste(c(if (isTRUE(mask) && n_cn) sprintf("%d with a collinear local design (condition index > 30)", n_cn), - if (n_nf) sprintf("%d with a non-finite coefficient", n_nf)), - collapse = "; ")) - else if (isTRUE(mask) && is.data.frame(lc)) + paste(c(sprintf("%d of %d locations masked (hollow):\n%s", sum(masked), nrow(dat), + paste(c(if (isTRUE(mask) && n_cn) + sprintf("%d with a collinear local design (%s > 30)", n_cn, + if (is_intercept) "condition index with the intercept" + else "slope condition index"), + if (n_nf) sprintf("%d with a non-finite coefficient", n_nf)), + collapse = "; ")), + unmasked_cn), collapse = "\n") + else if (!is.null(unmasked_cn)) unmasked_cn + else if (surveyed) "No location masked: every local design is well conditioned" - else if (!isTRUE(mask) && any(cn_bad)) - sprintf("mask = FALSE: %d location(s) with a collinear local design are drawn as if reliable", sum(cn_bad)) - else "Collinearity not surveyed (fewer than two numeric predictors)" + else "Collinearity not surveyed (no numeric predictor, or a fit made before the survey)" p + ggplot2::labs( title = sprintf("Local coefficient of %s", term), subtitle = subtitle, @@ -356,9 +406,13 @@ plot.sac_range <- function(x, ...) { "estimate_sac_range().", call. = FALSE) if (is.null(attr(x, "variogram", exact = TRUE))) stop("plot.sac_range(): this estimate carries no empirical variogram to ", - "draw. estimate_sac_range() returns a bare NA, with nothing attached, ", - "when the input has too few usable points or the variogram could not ", - "be computed at all.", call. = FALSE) + "draw. estimate_sac_range() returns NA with only a ", + "`rejected_reason` attached when it stops before computing one: ", + "too few usable points, no variance or extent, or gstat missing", + {r <- attr(x, "rejected_reason", exact = TRUE) + if (is.character(r) && length(r) == 1L && !is.na(r)) + sprintf(" (here: %s)", r) else ""}, + ".", call. = FALSE) .draw_sac_variogram(x, what = "Empirical variogram") } @@ -403,16 +457,18 @@ plot.sac_range <- function(x, ...) { # estimate_sac_range() returns the single azimuth with the widest range -- # about a quarter of the point pairs -- and calling that plainly by `what` # overstates the structure for the plot whose whole purpose is to show how - # much there is. - vg_title <- what - if (isTRUE(attr(sac, "anisotropy_used"))) { - dir_r <- attr(sac, "directional") - az <- if (!is.null(dir_r) && length(dir_r)) - names(dir_r)[which.max(replace(dir_r, is.na(dir_r), -Inf))] else NA - vg_title <- if (is.na(az)) sprintf("%s (widest direction only)", what) - else sprintf("%s, %s\u00b0 \u00b1 22.5\u00b0 (the widest of four directions)", - what, az) + # much there is. NA: all pairs; "": one direction, azimuth unknown. + azimuth_of <- function(s) { + if (!isTRUE(attr(s, "anisotropy_used"))) return(NA_character_) + dir_r <- attr(s, "directional") + if (is.null(dir_r) || !length(dir_r) || is.null(names(dir_r))) return("") + names(dir_r)[which.max(replace(dir_r, is.na(dir_r), -Inf))] } + az <- azimuth_of(sac) + vg_title <- if (is.na(az)) what + else if (!nzchar(az)) sprintf("%s (widest direction only)", what) + else sprintf("%s, %s\u00b0 \u00b1 22.5\u00b0 (the widest of four directions)", + what, az) p <- ggplot2::ggplot(vg, ggplot2::aes(x = .data$dist, y = .data$gamma)) + ggplot2::geom_point(ggplot2::aes(size = .data$np), alpha = 0.7) + @@ -449,14 +505,35 @@ plot.sac_range <- function(x, ...) { colour = "grey35", linetype = "dashed", linewidth = 0.8) } + # Each curve is whichever variogram estimate_sac_range() returned for its + # variable: all pairs, or the widest single direction when the all-pairs + # fit was unusable -- which a response carrying a trend often is while + # its residuals are not. The overlay was labelled plainly as the + # response whichever it was, and its sill and range set against an + # all-pairs residual curve over four times as many pairs. + ov_az <- azimuth_of(overlay) + dir_label <- function(a) if (!nzchar(a)) "the widest direction only" + else sprintf("the %s\u00b0 \u00b1 22.5\u00b0 direction only", a) + if (!is.na(ov_az)) + overlay_label <- sprintf("%s, %s", overlay_label, dir_label(ov_az)) + same_pairs <- identical(az, ov_az) && !identical(az, "") # The sills are compared only when BOTH ranges were identified: a model # whose range ran past the lags fitted has a sill the data never reached, # and a ratio of two such numbers reads as a finding while being noise. sill_of <- function(m) if (is.data.frame(m) && "psill" %in% names(m)) sum(as.numeric(m$psill), na.rm = TRUE) else NA_real_ s_res <- sill_of(vm); s_resp <- sill_of(ovm) - both_ok <- is.finite(sac) && is.finite(overlay) && + both_ok <- same_pairs && is.finite(sac) && is.finite(overlay) && is.finite(s_res) && is.finite(s_resp) && s_resp > 0 + # A range can be missing for several reasons (no sill within the lags, a + # fit that did not converge, a falling or flat variogram), so the clause + # says only that none was identified. "Reached no identified sill" + # described every case as a still-rising curve. The residual reason is + # in the subtitle; the response's appears nowhere else, so it is named. + ov_reason <- attr(overlay, "rejected_reason") + ov_why <- if (is.character(ov_reason) && length(ov_reason) == 1L && + !is.na(ov_reason) && nzchar(ov_reason)) + sprintf(" (%s)", ov_reason) else "" overlay_caption <- paste(c( sprintf("Hollow points, dashed line: %s. Filled points, solid line: %s.", overlay_label, tolower(what)), @@ -464,12 +541,20 @@ plot.sac_range <- function(x, ...) { sprintf("Residual sill is %.0f%% of the response sill; effective ranges %.0f (residuals) and %.0f (response).", 100 * s_res / s_resp, as.numeric(sac), as.numeric(overlay)) else sprintf("Sills not compared: %s.", - if (!is.finite(sac) && !is.finite(overlay)) - "neither variogram reached an identified sill" + if (!same_pairs) + sprintf(paste0("the two variograms are not over the same ", + "point pairs (residuals: %s; response: %s)"), + if (is.na(az)) "all directions" else dir_label(az), + if (is.na(ov_az)) "all directions" else dir_label(ov_az)) + else if (!is.finite(sac) && !is.finite(overlay)) + sprintf("neither variogram has an identified range%s", + if (nzchar(ov_why)) + sprintf(" (response: %s)", ov_reason) else "") else if (!is.finite(sac)) - "the residual variogram reached no identified sill" + "the residual variogram has no identified range" else if (!is.finite(overlay)) - "the response variogram reached no identified sill" + sprintf("the response variogram has no identified range%s", + ov_why) else "a variogram model could not be fitted") ), collapse = "\n") p <- p + ggplot2::labs(caption = .wrap_label(overlay_caption, 72)) @@ -508,12 +593,45 @@ plot.sac_range <- function(x, ...) { "(%.0f) is not identified (periodic structure, or a ", "variance that differs across the layer)."), attr(sac, "rejected_range")) + else if (identical(reason, "fitted range exceeds the largest lag fitted") && + isTRUE(attr(sac, "rejected_range") <= attr(sac, "cutoff_dist"))) + # The bound is range_frac x the largest lag, and the estimate does + # not record range_frac. A refused range at or below the largest + # lag can only have been refused by a range_frac below 1, and + # "exceeds the largest lag fitted (651) ... never reached a sill" + # was then false on both counts for a range of 646. + sprintf(paste0("No effective range: the fitted range (%.0f) is ", + "within the largest lag fitted (%.0f) but above the ", + "share of it that `range_frac` accepts."), + attr(sac, "rejected_range"), + attr(sac, "cutoff_dist")) else if (identical(reason, "fitted range exceeds the largest lag fitted")) sprintf(paste0("No effective range: the fitted range (%.0f) ", "exceeds the largest lag fitted (%.0f), so the ", "variogram never reached a sill."), attr(sac, "rejected_range"), attr(sac, "cutoff_dist")) + else if (identical(reason, "fitted range is below the shortest lag fitted") && + is.numeric(attr(sac, "rejected_range"))) { + # The distance the range fell short of is recorded on the refusal: + # the first lag of this variogram, or for a REML range the distance + # within which 30 pairs of its points lie, when that is shorter. + # An older object without it is captioned from the first lag. + first_lag <- suppressWarnings(min(vg$dist[is.finite(vg$dist) & vg$np > 0])) + fl <- attr(sac, "range_floor") %||% first_lag + if (is.numeric(fl) && length(fl) == 1L && is.finite(fl) && + is.finite(first_lag) && fl < first_lag) + sprintf(paste0("No effective range: the fitted range (%.3g) is ", + "below %.3g, the distance within which 30 pairs of ", + "the points the REML fit used lie, too few to ", + "identify it."), + attr(sac, "rejected_range"), fl) + else + sprintf(paste0("No effective range: the fitted range (%.3g) is ", + "below the shortest lag fitted (%.3g), so no lag ", + "inside it was fitted."), + attr(sac, "rejected_range"), fl) + } else # A reason this method does not know by name: say it verbatim rather # than caption it with another case's sentence. @@ -583,15 +701,43 @@ plot_folds <- function(folds, points_sf, boundary = NULL, blocks = TRUE) { stop("plot_folds(): no points matched the fold assignment; were `folds` ", "built from a different layer?", call. = FALSE) + # coord_sf() brings layers that carry a CRS into one, but a CRS-less layer + # beside one that has a CRS aborts at PRINT time with sf's bare "cannot + # transform sfc object with missing crs". make_folds() produces that mix + # itself: it projects CRS-less lon/lat points to a UTM zone, and stamps + # CRS-less points with a boundary's CRS, so the blocks it stores carry a CRS + # the very layer the folds came from does not. So a CRS-less layer is + # brought into the points' CRS, or failing that the one the folds were built + # in, or the first layer's that has one -- reprojected from lon/lat when its + # coordinates look like degrees, and stamped with a warning otherwise, as + # make_folds() did. + blk <- folds$params$blocks + if (!(isTRUE(blocks) && inherits(blk, "sf") && nrow(blk) > 0L)) blk <- NULL + plot_crs <- sf::st_crs(dat) + if (is.na(plot_crs) && is.character(folds$params$crs) && + length(folds$params$crs) == 1L && !is.na(folds$params$crs)) + plot_crs <- tryCatch(sf::st_crs(folds$params$crs), + error = function(e) sf::NA_crs_) + for (lyr in list(blk, boundary)) { + if (!is.na(plot_crs)) break + if (!is.null(lyr)) + plot_crs <- tryCatch(sf::st_crs(lyr), error = function(e) sf::NA_crs_) + } + align <- function(x, what) { + if (is.null(x) || is.na(plot_crs) || !is.na(sf::st_crs(x))) return(x) + .transform_or_stamp(x, plot_crs, what = what, caller = "plot_folds") + } + dat <- align(dat, "points_sf") + blk <- align(blk, "folds$params$blocks") + if (!is.null(boundary)) boundary <- align(boundary, "boundary") + p <- ggplot2::ggplot() if (!is.null(boundary)) p <- p + ggplot2::geom_sf(data = sf::st_geometry(boundary), fill = NA, colour = "grey60") # The block design, when the folds carry it (block_kfold): outlines under - # the points, in the CRS the folds were built in -- coord_sf() brings the - # layers to one CRS. - blk <- folds$params$blocks - if (isTRUE(blocks) && inherits(blk, "sf") && nrow(blk) > 0L) + # the points. + if (!is.null(blk)) p <- p + ggplot2::geom_sf(data = sf::st_geometry(blk), fill = NA, colour = "grey45", linewidth = 0.25) p + @@ -611,8 +757,17 @@ plot_folds <- function(folds, points_sf, boundary = NULL, blocks = TRUE) { prm <- folds$params fin <- function(v) length(v) == 1L && is.finite(suppressWarnings(as.numeric(v))) num <- function(v) format(signif(as.numeric(v), 3), big.mark = ",") - units <- if (is.character(prm$crs) && length(prm$crs) == 1L && nzchar(prm$crs)) - sprintf(" (%s units)", prm$crs) else "" + # make_folds() records NA_character_ for points without a CRS, and + # nzchar(NA) is TRUE: the subtitle read "Block size 300 (NA units)". + # prm$crs identifies the CRS (an EPSG code, else the proj string or the + # whole WKT); the subtitle wants its linear unit, as .draw_sac_variogram() + # gives it. Printed as it was, a CRS with no EPSG code put a 1,300-character + # WKT into the subtitle. + u <- if (is.character(prm$crs) && length(prm$crs) == 1L && + !is.na(prm$crs) && nzchar(prm$crs)) + tryCatch(sf::st_crs(prm$crs)$units_gdal, error = function(e) NULL) + units <- if (is.character(u) && length(u) == 1L && !is.na(u) && nzchar(u)) + sprintf(" (%s)", u) else "" switch(as.character(folds$method), random_kfold = "Random folds: a held-out point's neighbours stay in the training set", diff --git a/R/plotting.R b/R/plotting.R index 28e59bf..09beb24 100644 --- a/R/plotting.R +++ b/R/plotting.R @@ -8,7 +8,11 @@ #' @param seeds_sf Optional sf/sfc point layer of seed locations. #' @param features_sf Optional sf/sfc layer of additional features. #' @param fill_col Name of the COLUMN in \code{tessellation_sf} to map to fill; -#' \code{NULL} for no fill. \code{fill_col} and \code{label_col} name +#' \code{NULL} for no fill. A numeric column gets a continuous scale, as +#' does a Date or POSIXct column (on a date or time axis) and a +#' \code{units} or \code{difftime} column (drawn as numbers, with the unit +#' in the legend title); anything else a discrete one. +#' \code{fill_col} and \code{label_col} name #' columns, while \code{outline_col}, \code{features_col}, #' \code{seeds_col} and \code{boundary_col} are colours. #' @param palette Viridis palette name. Default "viridis". @@ -22,8 +26,13 @@ #' @param boundary_col,boundary_size Colour and line width of the boundary #' outline. #' @param labels Logical; draw per-cell labels. Default FALSE. -#' @param label_col Name of the COLUMN holding the label text. Default -#' \code{"grid_id"}. +#' @param label_col Name of the COLUMN holding the label text. Default +#' \code{NULL}: the first of \code{"grid_id"}, \code{"cell_id"}, +#' \code{"poly_id"}, \code{"polygon_id"} and \code{"id"} the layer has, so +#' the cells of \code{\link{build_tessellation}()} (\code{cell_id}) and the +#' output of \code{\link{summarize_by_cell}()} (\code{poly_id}) are +#' labelled without naming one. A \code{units} or \code{difftime} column +#' is drawn formatted, with its unit. #' @param label_size Label text size. Default 2.7. #' @param legend Logical; show fill legend. Default TRUE. #' @param legend_title Optional legend title. @@ -81,7 +90,7 @@ plot_tessellation_map <- function(tessellation_sf, boundary_col = "#111111", boundary_size = 0.6, labels = FALSE, - label_col = "grid_id", + label_col = NULL, label_size = 2.7, legend = TRUE, legend_title = NULL, @@ -116,6 +125,17 @@ plot_tessellation_map <- function(tessellation_sf, } .check_lim(xlim, "xlim") .check_lim(ylim, "ylim") + # A vector reached `&&` and if() below and failed with R's bare + # "'length = 2' in coercion to 'logical(1)'". + .check_col <- function(v, nm) { + if (is.null(v)) return(invisible(NULL)) + if (!is.character(v) || length(v) != 1L || is.na(v)) + stop(sprintf("plot_tessellation_map(): `%s` must be a single column name.", + nm), call. = FALSE) + invisible(NULL) + } + .check_col(fill_col, "fill_col") + .check_col(label_col, "label_col") # --- pick plot CRS --- plot_crs <- if (!is.null(target_crs)) sf::st_crs(target_crs) else sf::st_crs(tessellation_sf) @@ -169,8 +189,19 @@ plot_tessellation_map <- function(tessellation_sf, if (!is.null(fill_col) && !has_fill) .log_warn("plot_tessellation_map(): fill_col '%s' not found; drawing an unfilled outline map.", paste(as.character(fill_col), collapse = ", ")) + fill_unit <- NULL if (has_fill) { - tess$`..__fill__` <- tess[[fill_col]] + fill_vals <- tess[[fill_col]] + # An st_area() column (class units) passed is.numeric() below and then + # broke the viridis scale's arithmetic, and a difftime failed it and was + # given a discrete scale -- both only when the plot was printed. Both are + # numbers with a unit: drawn as numbers, the unit goes in the legend. + if (inherits(fill_vals, c("units", "difftime"))) { + fill_unit <- tryCatch(as.character(units(fill_vals))[1L], + error = function(e) NULL) + fill_vals <- as.numeric(fill_vals) + } + tess$`..__fill__` <- fill_vals p <- p + ggplot2::geom_sf( data = tess, mapping = ggplot2::aes(fill = .data[["..__fill__"]]), @@ -200,27 +231,58 @@ plot_tessellation_map <- function(tessellation_sf, # Labels if (isTRUE(labels)) { - if (!label_col %in% names(tess)) { + # The default used to be "grid_id", a column nothing in the package + # produces: Voronoi and triangle cells carry cell_id, grids poly_id and + # cell_id, and summarize_by_cell() output poly_id, so labels = TRUE drew + # no labels on any of them. "grid_id" stays first so a layer that has + # one is labelled as before. + id_candidates <- c("grid_id", "cell_id", "poly_id", "polygon_id", "id") + if (is.null(label_col)) + label_col <- id_candidates[id_candidates %in% names(tess)][1L] + if (is.na(label_col)) { + .log_warn("plot_tessellation_map(): no ID column (%s) to label and no `label_col` given; skipping labels.", + paste(id_candidates, collapse = ", ")) + } else if (!label_col %in% names(tess)) { .log_warn("plot_tessellation_map(): label_col '%s' not found; skipping labels.", label_col) } else if (nrow(tess) > 0L && !all(sf::st_is_empty(tess))) { - centers <- suppressWarnings(sf::st_point_on_surface(tess)) - centers$`..__lab__` <- tess[[label_col]] + centers <- suppressWarnings(sf::st_point_on_surface(.drop_empty_parts(tess))) + # An st_area() label column (class units) failed at print with "units + # package is not attached", as a units fill column once did; drawn as + # text, a units or difftime value keeps its unit. + lab <- tess[[label_col]] + if (inherits(lab, c("units", "difftime"))) lab <- format(lab, trim = TRUE) + centers$`..__lab__` <- lab + # The label points are computed above; geom_sf_text()'s default + # fun.geometry ran st_point_on_surface() on them again at print, which + # warned on every lon/lat layer. p <- p + ggplot2::geom_sf_text( - data = centers, ggplot2::aes(label = .data[["..__lab__"]]), size = label_size + data = centers, ggplot2::aes(label = .data[["..__lab__"]]), size = label_size, + fun.geometry = sf::st_geometry ) } } # Fill scale if (has_fill) { - lab <- legend_title %||% fill_col - is_cont <- is.numeric(tess$`..__fill__`) + lab <- legend_title %||% + if (length(fill_unit) == 1L && !is.na(fill_unit) && nzchar(fill_unit)) + sprintf("%s [%s]", fill_col, fill_unit) else fill_col + # A Date or POSIXct column is continuous but not numeric, so it used to get + # the discrete scale and fail at print with "Continuous value supplied to + # a discrete scale". It needs the continuous scale on a date or time axis. + fill_trans <- if (inherits(tess$`..__fill__`, "Date")) "date" + else if (inherits(tess$`..__fill__`, "POSIXct")) "time" else NULL + is_cont <- is.numeric(tess$`..__fill__`) || !is.null(fill_trans) if (is_cont) { - p <- p + ggplot2::scale_fill_viridis_c( - option = palette, na.value = na_fill, name = lab, - guide = if (legend) "colourbar" else "none" - ) + sc_args <- list(option = palette, na.value = na_fill, name = lab, + guide = if (legend) "colourbar" else "none") + # ggplot2 3.5.0 renamed continuous_scale()'s `trans` to `transform` and + # deprecates the old name. + if (!is.null(fill_trans)) + sc_args[[if ("transform" %in% names(formals(ggplot2::continuous_scale))) + "transform" else "trans"]] <- fill_trans + p <- p + do.call(ggplot2::scale_fill_viridis_c, sc_args) } else { p <- p + ggplot2::scale_fill_viridis_d( option = palette, na.value = na_fill, name = lab, diff --git a/R/predict-surface.R b/R/predict-surface.R index a8a9252..025e474 100644 --- a/R/predict-surface.R +++ b/R/predict-surface.R @@ -77,9 +77,19 @@ # were unreachable. Build the axis explicitly instead. .axis <- function(lo, hi) { lo <- as.numeric(lo); hi <- as.numeric(hi) - n <- floor((hi - lo) / cell_size) - if (!is.finite(n) || n < 1L) return(lo + (hi - lo) / 2) # one centred cell - lo + cell_size / 2 + seq.int(0L, n - 1L) * cell_size + # Enough cells to cover the extent, centred on it. floor() cells anchored + # at the lower bound left the remainder -- up to a cell wide -- uncovered + # on the east and north: cell_size = 100 on a 980 x 956 extent covered + # 900 x 900, and 14 of 120 training points lay in no cell. The grid now + # overhangs the box by less than one cell, split evenly on both sides, so + # every centre stays inside it. The relative tolerance keeps an exact + # multiple exact: 0.3 / 0.1 is 2.9999999999999996, and a ratio a hair + # above an integer must not gain a column either. + r <- (hi - lo) / cell_size + n <- ceiling(r - sqrt(.Machine$double.eps) * max(1, r)) + if (!is.finite(n) || n < 1L) n <- 1L # a cell wider than the extent + offset <- (hi - lo - n * cell_size) / 2 + lo + offset + cell_size / 2 + seq.int(0L, n - 1L) * cell_size } xs <- .axis(bb[["xmin"]], bb[["xmax"]]) ys <- .axis(bb[["ymin"]], bb[["ymax"]]) @@ -115,33 +125,55 @@ #' is given the interpretation the training data got (the assumption recorded #' on the fit), with a warning, and then reprojected. Otherwise a CRS-less #' grid can land thousands of kilometres from the covariates and every cell -#' takes the same nearest feature. +#' takes the same nearest feature. A grid still without a CRS after that +#' is treated as \code{boundary} is: taken as EPSG:4326 and reprojected +#' when its coordinates look like lon/lat, otherwise stamped with the fit's +#' CRS, with a warning either way. A grid of polygons +#' (\code{\link{create_grid_polygons}()} output, say) is reduced to one +#' representative point per cell, as \code{\link{coerce_to_points}()} does, +#' so covariates are taken at the location predicted for; \code{boundary} +#' then keeps the cells whose point falls inside it. #' @param cell_size Grid resolution in CRS units. Ignored when \code{grid} is #' supplied; when \code{NULL}, derived from \code{n_cells}. A value that #' would produce more than 5,000,000 cells is refused, naming the implied -#' count and the CRS units. The usual cause is a value in the wrong unit. A -#' \code{cell_size} wider than the extent yields a single centred cell. +#' count and the CRS units. The usual cause is a value in the wrong unit. +#' The grid is centred on the training bounding box and covers it: when the +#' extent is not a whole number of cells, it overhangs the box by less than +#' one cell, split evenly between the two sides. A \code{cell_size} wider +#' than the extent yields a single centred cell. #' @param n_cells Approximate cell count used to derive \code{cell_size}. #' Default 10000. Must be a single positive finite number and at most #' 5,000,000; anything else is an error. Also ignored when \code{grid} is #' supplied. The grid you pass is used verbatim. #' @param boundary Optional polygonal \code{sf}/\code{sfc}; grid points outside #' it are dropped. Put through the same CRS replay and reprojection as -#' \code{grid}. +#' \code{grid}. One still without a CRS after the replay is taken as +#' EPSG:4326 and reprojected when its coordinates look like lon/lat, and +#' is otherwise stamped with the fit's CRS, with a warning either way. #' @param covariates Optional \code{sf} layer carrying the model's predictors. #' Required when the model has predictors and \code{grid} does not already -#' contain them. Values are taken from the nearest feature. +#' contain them. Values are taken from the nearest feature. Aligned to +#' the fit's CRS as \code{grid} is, with the same warning when it has no +#' CRS. #' @param chunk_size Rows per prediction call. Default 5000. A pure -#' performance knob for the GWR and random-forest backends, whose rows do not -#' interact. For a \code{bayesian_fit} it is also that, \emph{provided} the -#' grid stays inside the training extent. Beyond it the GP boundary has to -#' grow and predictions depend on which rows share the call; see +#' performance knob: rows do not interact, and for a \code{bayesian_fit} the +#' GP boundary is held at its fitted value whatever the chunk holds; see #' \code{\link{predict.bayesian_fit}}. #' @param se Logical; also return a standard-error/posterior-SD column where the -#' backend supports it. Default FALSE. -#' @param ... Passed to \code{predict()}. +#' backend supports it. Default FALSE. For a \code{bayesian_fit} this is +#' the SD of the posterior draws \code{predict()} returns, and those are of +#' the expected value by default (\code{type = "epred"}): the uncertainty +#' of the mean surface, not of a new observation, which also carries the +#' observation noise. For the predictive SD, the one that goes with +#' prediction intervals and \code{cv_bayes()}'s calibration, pass +#' \code{type = "predict"} as well. +#' @param ... Passed to \code{predict()}, e.g. \code{type = "predict"} for a +#' \code{bayesian_fit}. Not \code{draws}, which this function sets itself +#' and refuses here. #' @return An \code{sf} POINT layer with a \code{.pred} column (and -#' \code{.pred_se} when \code{se = TRUE} and available). For an +#' \code{.pred_se} when \code{se = TRUE} and available; one a supplied +#' \code{grid} already carried, from an earlier surface, is removed +#' otherwise). For an #' auto-generated grid the resolution is attached as attribute #' \code{"cell_size"}. For a user-supplied \code{grid} it is only whatever #' \code{"cell_size"} attribute that object already carried. That is usually @@ -180,11 +212,42 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, if (!inherits(object, "spatial_fit")) stop("predict_surface(): `object` must be a spatial_fit.", call. = FALSE) + # `draws` is this function's to set: it asks for the draw matrix itself when + # se = TRUE. Passed through `...` it reached predict() too, and a backend + # that honours it returned an n_draws x n matrix that as.numeric() flattened + # into .pred column by column -- cell 1's draws, then cell 2's -- with only + # a cryptic length warning; with se = TRUE the duplicated argument failed + # inside try() and was reported as a backend without draws. A prefix + # counts, since R's argument matching would complete it. + dot_nms <- names(list(...)) + if (!is.null(dot_nms) && any(nzchar(dot_nms) & startsWith("draws", dot_nms))) + stop("predict_surface(): `draws` cannot be passed through `...`; ", + "predict_surface() requests the posterior draws itself when se = TRUE ", + "and returns their SD as .pred_se. For the draw matrix, call ", + "predict(object, newdata = grid, draws = TRUE).", call. = FALSE) + train <- object$data_sf if (!inherits(train, "sf")) stop("predict_surface(): the fit carries no training geometry.", call. = FALSE) target_crs <- sf::st_crs(train) + # A `grid` or `covariates` layer still without a CRS once the fit's own + # assumption has been replayed is aligned to the fit's CRS as `boundary` + # is, and as the other functions align such a layer: reprojected from + # EPSG:4326 when it looks like lon/lat, otherwise stamped, either way with + # an R warning naming this function and the argument. ensure_projected() + # stamped it with a log line naming neither, which knitr, + # spatialkit_quiet() and tryCatch() never show -- and a wrongly stamped + # layer puts every covariate lookup in the wrong place. A layer the + # replay marked as belonging to a CRS-less fit's own space is left there. + .align_to_fit <- function(x, what) { + if (is.na(sf::st_crs(x)) && !is.null(.crs_or_null(target_crs)) && + !identical(attr(x, "crs_assumed"), "none")) + .transform_or_stamp(x, target_crs, what = what, caller = "predict_surface") + else + ensure_projected(x, target_crs = .crs_or_null(target_crs)) + } + # ---- grid ---------------------------------------------------------------- if (is.null(grid)) { grid <- .make_prediction_grid(sf::st_bbox(train), target_crs, @@ -205,7 +268,18 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, # handed every cell the same covariate row and the whole surface collapsed # to one constant -- silently, with no error anywhere. grid <- .replay_crs_assumption(grid, train, "predict_surface", "grid") - grid <- ensure_projected(grid, target_crs = .crs_or_null(target_crs)) + grid <- .align_to_fit(grid, "grid") + # A polygon grid -- create_grid_polygons() output, say -- was used as it + # was. st_nearest_feature() then gave each cell whichever covariate point + # inside it the spatial index returned first, not the one at its centre, + # while predict() pointized the cell by itself, so the covariates and the + # location predicted at no longer matched: predictions off by up to 2.6 on + # a 0-30 response, and a row shuffle of `covariates` moved them by up to + # 4.7. Reduce it to representative points first, as + # area_of_applicability() does, so the surface is the POINT layer the + # manual promises. + if (!all(sf::st_geometry_type(grid, by_geometry = TRUE) == "POINT")) + grid <- coerce_to_points(grid, "auto") } res <- attr(grid, "cell_size") @@ -213,7 +287,13 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, if (!is.null(boundary)) { bnd <- .replay_crs_assumption(sf::st_geometry(boundary), train, "predict_surface", "boundary") - bnd <- ensure_projected(bnd, target_crs = .crs_or_null(target_crs)) + # A boundary still without a CRS is aligned to the fit's as other + # functions align one: an R warning naming this function and argument. + # ensure_projected()'s stamp was a log line naming neither. + bnd <- if (is.null(.crs_or_null(target_crs))) + ensure_projected(bnd) + else .transform_or_stamp(bnd, target_crs, what = "boundary", + caller = "predict_surface") keep <- lengths(sf::st_intersects(grid, bnd)) > 0L grid <- grid[keep, , drop = FALSE] if (nrow(grid) == 0L) @@ -245,7 +325,7 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, covariates <- .replay_crs_assumption(covariates, train, "predict_surface", "covariates") - covariates <- ensure_projected(covariates, target_crs = .crs_or_null(target_crs)) + covariates <- .align_to_fit(covariates, "covariates") nn <- sf::st_nearest_feature(grid, covariates) cdf <- sf::st_drop_geometry(covariates)[nn, missing_preds, drop = FALSE] for (cn in missing_preds) grid[[cn]] <- cdf[[cn]] @@ -310,6 +390,14 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, if (inherits(p, "try-error")) stop("predict_surface(): prediction failed on rows ", s, "-", e, ": ", as.character(p), call. = FALSE) + # One value per row, or the assignment below recycles or truncates + # whatever came back into .pred without a word that means anything. + if (length(p) != length(idx)) + stop(sprintf(paste0("predict_surface(): predict() returned %d value(s) ", + "for the %d rows %d-%d; expected one per row. Check ", + "what the backend's predict() returns for the ", + "arguments passed through `...`."), + length(p), length(idx), s, e), call. = FALSE) preds_vec[idx] <- as.numeric(p) } } @@ -319,7 +407,10 @@ predict_surface <- function(object, grid = NULL, cell_size = NULL, "expose posterior draws; returning predictions only.")) grid$.pred <- preds_vec - if (isTRUE(se) && se_ok) grid$.pred_se <- se_vec + # A grid that is an earlier surface carries that model's .pred_se. It was + # kept whenever this call did not replace it -- beside the new .pred, and + # even after the log said "returning predictions only". + grid$.pred_se <- if (isTRUE(se) && se_ok) se_vec else NULL attr(grid, "cell_size") <- res grid diff --git a/R/resolution-profile.R b/R/resolution-profile.R index 6e86262..93d826c 100644 --- a/R/resolution-profile.R +++ b/R/resolution-profile.R @@ -33,6 +33,51 @@ } +#' Mean correlation between two random points in a polygon +#' +#' The domain term of Krige's relation, \eqn{\bar r(V)}, over the study area +#' itself rather than its bounding box: quadrature on a regular grid of about +#' \eqn{q^2} points clipped to \code{domain}. The profile measures the +#' domain's area on the convex hull, and a bounding box that the hull fills +#' only partly (a diagonal strip, a triangle) spreads the pairs further apart +#' than the domain does, which made \eqn{\bar r(V)} too small, the +#' between-cell variance too large and reliability too high at coarse levels. +#' Measured on 600 points in a 3000 x 120 strip, reliability picked 8 cells +#' axis-aligned and 2 rotated by 45 degrees (10 and 8 on a square), while +#' the hull's area did not move; over the hull both orientations pick 6 +#' (10 on the square). The grid is isotropic, where \code{.rbar_rect()}'s +#' \eqn{q \times q} grid on a thin rectangle is 25 times coarser along it +#' than across. +#' +#' @param cor_fn Correlation function of distance. +#' @param domain A polygon (sfc) in the coordinate units of \code{cor_fn}. +#' @param area Its area. +#' @param q Grid points per side of a square of the same area. +#' @return A scalar in \eqn{[0, 1]}; the bounding box's value when too few +#' grid points fall inside (a domain with next to no area). +#' @keywords internal +#' @noRd +.rbar_domain <- function(cor_fn, domain, area, q = 20L) { + bb <- sf::st_bbox(domain) + w <- as.numeric(bb[["xmax"]] - bb[["xmin"]]); h <- as.numeric(bb[["ymax"]] - bb[["ymin"]]) + if (!is.finite(area) || area <= 0 || !is.finite(w) || !is.finite(h) || w <= 0 || h <= 0) + return(.rbar_rect(cor_fn, w, h, q)) + # Spacing for about q^2 points inside the domain, but never more than 40 + # q^2 grid nodes over the box, so a sliver of a hull costs no more than a + # point-in-polygon test on 16,000 points. + s <- max(sqrt(area) / q, sqrt(w * h / (40 * q^2))) + gx <- seq(bb[["xmin"]] + s / 2, bb[["xmax"]], by = s) + gy <- seq(bb[["ymin"]] + s / 2, bb[["ymax"]], by = s) + g <- as.matrix(expand.grid(x = gx, y = gy)) + inside <- lengths(sf::st_intersects( + sf::st_as_sf(as.data.frame(g), coords = c("x", "y"), crs = sf::st_crs(domain)), + domain)) > 0L + if (sum(inside) < 10L) return(.rbar_rect(cor_fn, w, h, q)) + r <- as.numeric(cor_fn(as.numeric(stats::dist(g[inside, , drop = FALSE])))) + mean(r[is.finite(r)]) +} + + #' Analytic reliability of cell means at a candidate resolution #' #' Krige's additivity relation splits the point-support variance of a field @@ -110,26 +155,67 @@ #' logarithmically, because cell diameter scales as \eqn{L^{-1/2}}: a unit #' step wastes fits at large \eqn{L} and starves resolution at small. The #' ladder runs from a floor to a ceiling the data impose. The ceiling is -#' \code{floor(n / min_cell_n)}: cells with fewer than \code{min_cell_n} points +#' \code{floor(n / min_cell_n)}, with \eqn{n} every point of the layer (not +#' the subsample): cells with fewer than \code{min_cell_n} points #' on average have too little support, and Moran's z is not computable at -#' nine cells or fewer in any case. The floor is +#' nine cells or fewer in any case. It is also held to the number of +#' distinct locations, one cell on each, and to one short of the number of +#' points, which \code{stats::kmeans()} needs. The floor is #' \code{ceiling(area / range^2)} when an autocorrelation range is available: #' cells wider than the range average over more than one patch of the field. #' When the floor exceeds the ceiling the data cannot support a tessellation #' that respects their own correlation structure; that is reported as a #' finding (a logged warning, and \code{attr(x, "bounds")$supported} is #' \code{FALSE}) and the ladder runs from 2 to the ceiling anyway, so the -#' profile still shows what each level costs. +#' profile still shows what each level costs. On a layer larger than +#' \code{sample_n} the ceiling is also held to half the subsample (two +#' subsample points per cell, the least a fitted cell can be scored on); +#' \code{ceiling_from} is then \code{"sample_n"}, a floor above that is logged +#' with a request to raise \code{sample_n}, and it does not make +#' \code{supported} \code{FALSE}. +#' +#' The floor moves with the range estimate, and the ceiling with \eqn{n}, so +#' two profiles of similar data (the folds of a cross-validation, say) can +#' sit on either side of the point where the floor applies: one ladder then +#' starts at the floor and the other at 2, and the criteria that sit near +#' the bottom of the ladder (\code{reliability}, which routinely peaks at the +#' floor, and \code{elbow}) can differ between them by a factor of 10 or +#' more. To compare profiles, pass the same \code{levels} to each, or +#' \code{range_floor = FALSE} to start every ladder at 2 while the floor is +#' still reported. #' #' @section The criteria, and how each behaved when measured: #' \describe{ -#' \item{\code{elbow}}{The signed distance of the WSS curve below the chord -#' from its first to its last level, the classical elbow statistic -#' (larger is better). Geometry only; it knows nothing of the response.} +#' \item{\code{elbow}}{How far the WSS curve sags below a power law: on +#' log-log axes, \eqn{\log} WSS below the straight line from \eqn{k = 1} +#' (the total sum of squares) to the last level, in natural-log units +#' (larger is better). Points with no cluster structure have a WSS close +#' to \eqn{c/k}, which is straight on those axes, so the column is +#' \code{NA} at every level unless the largest sag reaches +#' \eqn{\log 1.25}, and the print says there is no elbow (the rule and its +#' calibration are in \code{\link{determine_optimal_levels}}). The +#' classical chord on linear axes found a "knee" on such a layer anyway, +#' at about \eqn{\sqrt{L_{first} L_{last}}}, where the ladder's ends put +#' it. A level whose WSS is 0 (to within \eqn{10^{-12}} of the total), +#' one cell on every distinct location, which the ladder reaches when +#' locations repeat, is left out of the line; when the other levels have +#' no elbow, that fall to zero is the elbow, and its sag is measured with +#' the WSS floored at \eqn{10^{-12}} of the total, which puts it far +#' above any other level's. Geometry only; it knows nothing of the +#' response.} #' \item{\code{cp}}{Mallows' \eqn{C_p} of the piecewise-constant #' approximation of the response (or of its OLS residuals on #' \code{predictor_vars}) by cell means: \eqn{RSS(L)/n + 2 \tau^2 L / n}, #' with \eqn{\tau^2} the nugget of the fitted variogram (lower is better). +#' It estimates the error of predicting a new observation by the mean of +#' its cell. When the cells are fitted to a subsample of \eqn{m} of the +#' \eqn{N} points with a response, the penalty is split between the two: +#' \eqn{RSS(L)/m + \tau^2 L_m / m + \tau^2 L / N}, where the first two +#' terms estimate the approximation error from the subsample (adding back +#' the optimism of its own cell means, over the \eqn{L_m} cells its scored +#' points fall in) and the last is the variance of cell means built from +#' all \eqn{N}, which is what the tessellation will carry. With no +#' subsample it is the formula above. #' \strong{Measured on simulated exponential fields (600 points on a #' 1000-unit extent, sill 1, 20 replicates): with a nugget of 0.3 its #' minimum sat at the support ceiling in every replicate at effective @@ -139,7 +225,10 @@ #' small to stop it, so \eqn{C_p} says "as fine as the support allows" #' and \code{min_cell_n} is what is choosing; \code{select_resolution()} #' says so when that happens. It becomes a genuine interior criterion -#' only when the nugget is a large share of the sill.} +#' only when the nugget is a large share of the sill. With a nugget of 0 +#' (under \eqn{10^{-4}} of the sill; usually a fit clipped at its lower +#' bound) the penalty is 0 and \eqn{C_p} descends to the ceiling whatever +#' the field; the profile warns.} #' \item{\code{moran_z}}{The standardised deviate of Moran's I on the #' residuals of the cell means regressed on the cell-mean predictors (an #' intercept alone when there are none): how much spatial structure the @@ -150,14 +239,18 @@ #' \item{\code{reliability}}{The between-cell signal's share of the spread #' in the cell means, from the fitted variogram alone via Krige's #' additivity relation (Cressie 1996), for square cells of the level's -#' average area with the level's average point count (larger is better). +#' average area holding the level's average share of the layer's points +#' with a response (larger is better). #' This is the shrinkage factor of Fay and Herriot (1979). It has an #' interior optimum, and a broad one: validated against the empirical #' reliability of true block means on simulated fields, the analytic and #' empirical optima agreed to within a level or two where the empirical #' estimate was stable, and the band within 2 percent of the maximum #' spanned a factor of 3--6 in \eqn{L}. Read the flat region, not the -#' argmax. \code{NA} without a usable variogram.} +#' argmax. The domain term is taken over the convex hull the area is +#' measured on, so rotating the layer does not move it. \code{NA} +#' without a usable variogram, and when the variogram's range was +#' rejected (see \code{sac}).} #' } #' \code{cp} and \code{reliability} answer different questions: how well the #' cells represent the field, and whether the cell values are distinguishable @@ -165,52 +258,97 @@ #' them is made knowingly. #' #' @param data_sf An sf object of points (other geometries are reduced to -#' representative points). +#' representative points). Features with empty or non-finite coordinates +#' are dropped with a warning. #' @param response_var Optional response column name (numeric or logical). #' Enables \code{cp} and \code{moran_z}. A variogram estimated from it also -#' sets the floor of the ladder and \code{reliability}. +#' sets the floor of the ladder and \code{reliability}. Rows where it, or a +#' predictor, is missing or non-finite stay in the geometry and are left out +#' of the OLS fit, the RSS, \code{cp} and \code{moran_z}; a logged warning +#' gives their number. #' @param predictor_vars Optional predictor column names (numeric or #' logical). With them, \code{cp} scores the OLS residuals of the response #' on the predictors, the variogram is estimated from those residuals, and #' \code{moran_z} regresses the cell means on the cell-mean predictors. #' @param levels Optional integer vector of level counts to score, replacing -#' the ladder; values below 2, or at or above the number of distinct -#' locations, are dropped (k-means cannot place more centres than there are -#' distinct points). +#' the ladder; values below 2, above the number of distinct locations, or +#' at or above the number of points, are dropped (k-means cannot place more +#' centres than there are distinct points, and \code{stats::kmeans()} +#' refuses as many centres as points). #' @param n_levels Number of levels on the ladder. Default 20. #' @param min_cell_n Minimum average number of points per cell that a level #' must keep; sets the ceiling. Default 9. -#' @param sample_n Points are subsampled to this many before anything is -#' fitted, as in \code{determine_optimal_levels()}. Default 1500. The -#' support columns describe the subsample. +#' @param sample_n Points are subsampled to this many before the k-means +#' fits, as in \code{determine_optimal_levels()}. Default 1500. The +#' columns read off the fitted cells (\code{wss}, the \code{cell_} columns, +#' \code{rss}, \code{moran_i}, \code{moran_z}) describe the subsample; the +#' bounds, \code{supported}, the variance term of \code{cp} and +#' \code{reliability} describe every point of the layer, so the answer does +#' not change with \code{sample_n} except through the fits. #' @param nstart k-means++ restarts per level. Default 25. #' @param seed RNG seed for the subsample and the restarts; restored -#' afterwards. Default 123. +#' afterwards. Default 123. The rows are put in coordinate order before +#' either, so the profile does not depend on the order they come in. #' @param sac Optional \code{sac_range} object from #' \code{\link{estimate_sac_range}()} to take the range, nugget and #' correlation function from. Pass one fitted with \code{detrend = -#' "reml"}, say, or on a residual field of your choosing. When +#' "reml"}, say. It must describe the variable the profile scores: the +#' raw response without \code{predictor_vars}, the residuals on them with; +#' a sac whose \code{detrended} attribute says otherwise is used with a +#' warning. Its range is read in its own CRS (\code{attr(sac, "crs")}), +#' to which the points are transformed first, so the area, the floor and +#' \code{cell_diam_median} are then in that CRS's units. A sac whose +#' range was rejected (\code{NA} with a \code{rejected_reason}) gives +#' \code{cp} its nugget, with a warning, and leaves \code{reliability} +#' \code{NA}, since that needs the range; one whose model did not converge, +#' or whose range is below the shortest lag fitted (a structure that +#' cannot be told from a nugget, so the nugget is not identified either), +#' gives neither. Under \code{select_on = "split"} the sac must come from +#' the selection half alone: run the profile once without it, fit the sac +#' on \code{data_sf[attr(p, "split")$selection, ]} and pass it to a second +#' call with the same \code{seed}, which makes the same split. When #' \code{NULL} and a response is given, one is estimated on the subsample -#' with the same \code{predictor_vars}. +#' (its selection half under \code{"split"}) with the same +#' \code{predictor_vars}. A plain number is taken as the range alone, in +#' the units of the CRS the profile is computed in (metres for lon/lat +#' input): it sets the floor, and \code{cp} and \code{reliability}, which +#' need a fitted model, are \code{NA}. A \code{units} object is refused +#' rather than read as a number in whatever unit it was written in. #' @param select_on \code{"all"} (default) profiles every point; -#' \code{"split"} profiles one spatially blocked half and returns the other -#' half as the set to estimate on, in the \code{"split"} attribute. See -#' the "Post-selection inference" section of +#' \code{"split"} reads the response on one spatially blocked half only +#' (the OLS fit, the variogram, \code{rss}, \code{cp} and \code{moran_z}) +#' and returns the other half as the set to estimate on, in the +#' \code{"split"} attribute. The cells, \code{wss}, \code{elbow}, and the +#' extent and point counts behind the bounds, \code{cp}'s variance term and +#' \code{reliability} still come from every point, because the +#' tessellation the count is for is built on every point: the levels are +#' cell counts for the whole layer, and the estimation half's response +#' never touches them. See the "Post-selection inference" section of #' \code{\link{determine_optimal_levels}}; the profile reads the response #' whenever \code{response_var} is given. +#' @param range_floor \code{TRUE} (default) starts the ladder at the range +#' floor when the data support it; \code{FALSE} starts it at 2 whatever +#' the range, and the floor is only reported in the bounds and the print. +#' Use \code{FALSE} to compare profiles whose range estimates differ (see +#' "The ladder and its bounds"). #' @return A data.frame of class \code{resolution_profile} with one row per #' level and columns \code{levels}, \code{wss}, \code{wss_spread} (relative #' spread of WSS across the restarts), \code{elbow}, \code{cell_n_min}, #' \code{cell_n_median}, \code{cell_diam_median} (twice the median RMS -#' radius of the cells, in coordinate units), \code{rss}, \code{cp}, +#' radius of the cells, in coordinate units: about 0.8 of the side of a +#' square cell of the same area, and less for finer cells, so a size to +#' compare levels by rather than a width), \code{rss}, \code{cp}, #' \code{moran_i}, \code{moran_z} and \code{reliability}; columns a missing #' input leaves undefined are \code{NA}. Attributes: \code{bounds} (a list -#' with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"} -#' or \code{"distinct locations"}, whichever bound it), \code{supported}, -#' \code{area}, \code{range}, \code{n}, \code{n_distinct}, -#' \code{min_cell_n}), \code{variogram} (a list with -#' \code{nugget}, \code{psill}, \code{range}, \code{model}; \code{NULL} -#' when none was usable), \code{variable} (\code{"response"}, +#' with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"}, +#' \code{"distinct locations"} or \code{"sample_n"}, whichever bound it), +#' \code{supported}, \code{area}, \code{range}, \code{n} (the points in the +#' layer), \code{n_sample} (the points the k-means fits ran on), +#' \code{n_distinct}, \code{min_cell_n}, \code{range_floor}), +#' \code{variogram} (a list with \code{nugget}, \code{psill}, \code{range} +#' (\code{NA} when rejected), \code{model} and \code{detrended} (whether +#' the sac says it is a variogram of residuals; \code{NA} when it does not +#' say); \code{NULL} when none was usable), \code{variable} (\code{"response"}, #' \code{"residuals"} or \code{NA}), \code{wss_bumps}, \code{nstart}, #' \code{sac} (the range object used) and, with \code{select_on = #' "split"}, \code{split} (a \code{spatialkit_split}: \code{selection} @@ -241,7 +379,7 @@ #' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough #' # noise for Mallows' Cp to have an interior optimum rather than descend #' # to the ceiling. -#' set.seed(2) +#' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) #' D <- as.matrix(dist(xy)) @@ -256,10 +394,13 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NULL, levels = NULL, n_levels = 20L, min_cell_n = 9L, sample_n = 1500L, nstart = 25L, seed = 123L, - sac = NULL, select_on = c("all", "split")) { + sac = NULL, select_on = c("all", "split"), + range_floor = TRUE) { select_on <- match.arg(select_on) if (!inherits(data_sf, "sf")) stop("resolution_profile(): `data_sf` must be an sf object.", call. = FALSE) + if (!is.logical(range_floor) || length(range_floor) != 1L || is.na(range_floor)) + stop("resolution_profile(): `range_floor` must be TRUE or FALSE.", call. = FALSE) if (!is.numeric(min_cell_n) || length(min_cell_n) != 1L || !is.finite(min_cell_n) || min_cell_n < 1) stop("resolution_profile(): `min_cell_n` must be a single number >= 1.", call. = FALSE) @@ -277,6 +418,18 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU has_pred <- !is.null(predictor_vars) && length(predictor_vars) > 0L if (has_pred && !has_resp) stop("resolution_profile(): `predictor_vars` needs a `response_var`.", call. = FALSE) + # as.numeric() strips a `units` object to its number in whatever unit it + # was written in, so set_units(1.5, "km") became a range of 1.5 CRS units + # (metres): a floor of 41 million cells, with nothing said. Refused by + # name, as fold_separation() and cv_block_size_sweep() refuse it; and a + # character string, which as.numeric() also read, with it. + if (!is.null(sac) && (inherits(sac, "units") || !is.numeric(sac))) + stop("resolution_profile(): `sac` must be an estimate_sac_range() result, ", + "or a plain number in the units of the CRS the profile is computed ", + "in (metres for lon/lat input); got ", + if (inherits(sac, "units")) format(sac) + else sprintf("an object of class %s", class(sac)[1L]), + ".", call. = FALSE) if (!all(sf::st_geometry_type(data_sf, by_geometry = TRUE) == "POINT")) data_sf <- coerce_to_points(data_sf, "auto") @@ -284,8 +437,10 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] ok_xy <- is.finite(xy[, 1]) & is.finite(xy[, 2]) if (!all(ok_xy)) { - .log_warn("resolution_profile(): dropping %d point(s) with empty or non-finite coordinates.", - sum(!ok_xy)) + # An R warning, as in determine_optimal_levels(): a log line alone could + # not be caught, and spatialkit_quiet() hid it. + .warn_and_log("resolution_profile(): dropping %d point(s) with empty or non-finite coordinates.", + sum(!ok_xy)) data_sf <- data_sf[ok_xy, , drop = FALSE] xy <- xy[ok_xy, , drop = FALSE] } @@ -294,18 +449,55 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU # Sample splitting, on the full layer before the subsample, so the # positions index `data_sf` as passed (rows dropped above excepted). + # The cells are geometry, and the tessellation the count is for is built on + # every point, so the partitions, the WSS and the bounds keep the whole + # layer; only what reads the response is held to the selection half + # (`in_sel`, below). The profile used to run on the half alone, and the + # count it chose for the half's extent, point count and clusters was then + # applied to the whole layer. split <- NULL + in_sel <- NULL if (identical(select_on, "split")) { split <- .spatial_half_split(data_sf, seed = seed, caller = "resolution_profile") + in_sel <- seq_len(nrow(xy)) %in% split$selection if (!all(ok_xy)) { # Positions refer to the layer after the drop; map them back. kept <- which(ok_xy) split$selection <- kept[split$selection] split$estimation <- kept[split$estimation] - keep_sel <- match(split$selection, kept) - } else keep_sel <- split$selection - data_sf <- data_sf[keep_sel, , drop = FALSE] - xy <- xy[keep_sel, , drop = FALSE] + } + # The split cannot tell which rows a supplied variogram was fitted on, and + # the floor, Cp's penalty and reliability all come from it: one fitted on + # the whole layer carries the estimation half's response into the choice. + if (!is.null(sac)) + .log_warn(paste0("resolution_profile(): select_on = \"split\" with a supplied ", + "`sac`: it sets the floor, Cp's penalty and reliability, so it ", + "must be fitted on the selection half alone, ", + "data_sf[attr(x, \"split\")$selection, ] (the split is the same ", + "for the same layer and seed). One fitted on the whole layer lets ", + "the estimation half's response steer the count.")) + } + + # A supplied variogram's range is a length in the CRS it was fitted in + # (estimate_sac_range() records it as attr(sac, "crs")), and the area, the + # floor and every distance below are measured in data_sf's. Read in another + # projection it moved the floor, the verdict and the reliability optimum + # without a word: a range in US feet put the floor of a metre layer at 2 + # where the same range in metres put it at 8. Work in the variogram's CRS, + # as summarize_by_cell() does. After the split, so the halves are the ones + # a first call without the sac returned; a sac with no recorded, or a + # geographic, CRS is taken as it is. + sac_crs <- if (!is.null(sac)) attr(sac, "crs") else NULL + if (inherits(sac_crs, "crs") && !is.na(sac_crs) && !isTRUE(sf::st_is_longlat(sac_crs)) && + !is.na(sf::st_crs(data_sf)) && !isTRUE(sf::st_crs(data_sf) == sac_crs)) { + .log_info("resolution_profile(): working in the CRS of `sac` (%s), in which its range is a length.", + sac_crs$input %||% "unnamed") + data_sf <- .transform_or_stamp(data_sf, sac_crs, what = "data_sf", + caller = "resolution_profile") + xy <- sf::st_coordinates(data_sf)[, 1:2, drop = FALSE] + if (!all(is.finite(xy))) + stop("resolution_profile(): some points have no coordinates in the CRS of `sac`.", + call. = FALSE) } resp <- NULL; pred <- NULL @@ -335,43 +527,101 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU cleanup <- .with_seed(seed) on.exit(cleanup(), add = TRUE) - # Subsample, keeping everything aligned. - n_all <- nrow(xy) - if (n_all > sample_n) { - idx <- sample(seq_len(n_all), sample_n) - xy <- xy[idx, , drop = FALSE] - data_sf <- data_sf[idx, , drop = FALSE] - if (has_resp) resp <- resp[idx] - if (has_pred) pred <- pred[idx, , drop = FALSE] + # Rows the response criteria can read: a finite response and, with + # predictors, finite predictors. The rest stay in the geometry. + resp_ok <- NULL + if (has_resp) { + resp_ok <- is.finite(resp) + if (has_pred) resp_ok <- resp_ok & apply(is.finite(pred), 1L, all) + if (!all(resp_ok)) + .log_warn(paste0("resolution_profile(): %d of %d row(s) have a missing or ", + "non-finite %s; they stay in the geometry but are left out ", + "of the OLS fit, the RSS, Cp and Moran's z."), + sum(!resp_ok), length(resp_ok), + if (has_pred) "response or predictor" else "response") } + + # The bounds describe the layer the cells will be built on and aggregated + # over, so they are read off every point: the extent, the distinct + # locations and the number of points that carry a response. Only the + # k-means work below runs on the subsample. The support ceiling, the + # verdict, Cp's penalty and the reliability used to take n from the + # subsample, which capped every layer larger than sample_n at + # floor(sample_n / min_cell_n) cells and made the answer depend on sample_n. + n_all <- nrow(xy) + n_resp <- if (has_resp) sum(resp_ok) else n_all + hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(data_sf))) + area <- suppressWarnings(as.numeric(sf::st_area(hull))) + bb <- sf::st_bbox(data_sf) + bbw <- as.numeric(bb["xmax"] - bb["xmin"]); bbh <- as.numeric(bb["ymax"] - bb["ymin"]) + if (!is.finite(area) || area <= 0) area <- bbw * bbh + # duplicated() on a complex vector, because unique() on an n x 2 matrix + # pastes every row into a string: 0.01 s against 5 s at a million points. + n_uniq_all <- sum(!duplicated(complex(real = round(xy[, 1], 8), + imaginary = round(xy[, 2], 8)))) + + # Subsample, keeping everything aligned, from the rows in a canonical order: + # the subsample and every k-means++ draw index rows, so the same layer with + # its rows permuted used to get different cells and a different count (a + # WSS 2.6 percent apart and Cp picks of 222, 173 and 135 cells over + # permutations of one 2000-point layer). Coordinates first; the response + # and the predictors break ties between repeat visits to one location. + # Every point is reordered even with no subsample to draw. + ord <- do.call(order, c(list(xy[, 1], xy[, 2]), + if (has_resp) list(resp), + if (has_pred) lapply(seq_len(ncol(pred)), function(j) pred[, j]))) + idx <- if (n_all > sample_n) ord[sample(seq_len(n_all), sample_n)] else ord + xy <- xy[idx, , drop = FALSE] + data_sf <- data_sf[idx, , drop = FALSE] + if (has_resp) { resp <- resp[idx]; resp_ok <- resp_ok[idx] } + if (has_pred) pred <- pred[idx, , drop = FALSE] + if (!is.null(in_sel)) in_sel <- in_sel[idx] n <- nrow(xy) # The variable the cells have to represent: the response, or what the # predictors leave of it. Rows with a non-finite value drop out of the RSS - # and the Moran statistic but stay in the geometry. + # and the Moran statistic but stay in the geometry, and so, under + # select_on = "split", do the rows of the estimation half. variable <- NA_character_ y <- NULL if (has_resp) { - y <- resp + use <- if (is.null(in_sel)) resp_ok else resp_ok & in_sel + y <- rep(NA_real_, n) + y[use] <- resp[use] variable <- "response" if (has_pred) { - fit <- try(stats::lm.fit(x = cbind(1, pred), y = resp), silent = TRUE) - ok_rows <- is.finite(resp) & apply(is.finite(pred), 1L, all) - if (!inherits(fit, "try-error") && sum(ok_rows) > ncol(pred) + 1L) { - fit <- stats::lm.fit(x = cbind(1, pred[ok_rows, , drop = FALSE]), y = resp[ok_rows]) - y <- rep(NA_real_, n); y[ok_rows] <- fit$residuals + # Fitted on the complete rows only. lm.fit() refuses any NA, and a + # first fit on every row turned one missing value into "the OLS fit + # failed": the raw response, trend and all, was then scored against a + # variogram estimate_sac_range() had fitted to the residuals. + fit <- if (sum(use) > ncol(pred) + 1L) + try(stats::lm.fit(x = cbind(1, pred[use, , drop = FALSE]), y = resp[use]), + silent = TRUE) + if (!is.null(fit) && !inherits(fit, "try-error")) { + y[use] <- fit$residuals variable <- "residuals" } else { - .log_warn("resolution_profile(): the OLS fit on `predictor_vars` failed; scoring the raw response.") + .log_warn(paste0("resolution_profile(): the OLS fit on `predictor_vars` failed ", + "on the %d complete row(s); scoring the raw response."), + sum(use)) } } } - # Variogram: supplied, or estimated on the subsample. + # Variogram: supplied, or estimated on the subsample (its selection half + # under select_on = "split": the range reads the response). vg <- NULL + # The messages below name the variogram as the caller knows it: their own + # `sac`, or the one estimated here. They said "`sac`" either way, and + # told a caller who had passed none to pass a different one. + sac_given <- !is.null(sac) + sac_what <- if (sac_given) "`sac`" + else "the variogram estimated from `response_var` (attr(, \"sac\"))" if (is.null(sac) && has_resp && requireNamespace("gstat", quietly = TRUE)) { sac <- tryCatch( - suppressWarnings(estimate_sac_range(data_sf, response_var, + suppressWarnings(estimate_sac_range(if (is.null(in_sel)) data_sf + else data_sf[in_sel, , drop = FALSE], + response_var, predictor_vars = if (has_pred) predictor_vars else NULL, seed = seed)), error = function(e) { @@ -383,40 +633,126 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU range_eff <- NA_real_ if (!is.null(sac)) { vm <- attr(sac, "variogram_model") - r <- suppressWarnings(as.numeric(sac)) - if (length(r) == 1L && is.finite(r) && r > 0) range_eff <- r + r <- suppressWarnings(as.numeric(sac))[1L] + if (is.finite(r) && r > 0) range_eff <- r + # A REJECTED range (NA with a `rejected_reason`) still carries its fitted + # model, as evidence for the rejection, and that model used to be read as + # if it had been accepted: reliability then took a correlation function + # whose range could be many times the extent, which pins its optimum to + # the first level, and nothing said so. summarize_by_cell() refuses such + # a model outright. Here the nugget, fitted at the short lags, still + # serves Cp; the correlation function, which is the unidentified range, + # does not. Two refusals are whole. A fit that did not converge: its + # nugget is where the optimiser stopped. A range below the shortest lag: + # the structure cannot be told from a nugget, so the split between the + # two is exactly what is not identified. On white noise detrended by + # REML that model's nugget was 6e-7 on a sill of 0.99, and Cp, with no + # penalty, ran to the support ceiling (7 cells with the nugget at 0.98). + rejected <- attr(sac, "rejected_reason") + rejected <- if (!is.finite(r) && length(rejected)) as.character(rejected)[1L] else NULL cor_fn <- if (is.data.frame(vm)) .vgm_correlation_fn(vm) else NULL if (!is.null(cor_fn)) { vg <- list(nugget = .vgm_nugget_of(vm), psill = sum(as.numeric(vm$psill[as.character(vm$model) != "Nug"])), - range = range_eff, model = vm, cor_fn = cor_fn) + range = range_eff, model = vm, cor_fn = cor_fn, + detrended = if (length(attr(sac, "detrended")) == 1L) + as.logical(attr(sac, "detrended")) else NA) if (!is.finite(vg$nugget)) vg$nugget <- 0 if (!is.finite(vg$psill) || vg$psill <= 0) vg <- NULL } - if (is.null(vg)) + if (!is.null(vg) && !is.null(rejected)) { + if (grepl("converge", rejected, fixed = TRUE)) { + .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s); ", + "its nugget and sill are where the optimiser stopped, not ", + "fitted values, so `cp` and `reliability` are NA."), + sac_what, rejected) + vg <- NULL + } else if (grepl("shortest lag", rejected, fixed = TRUE)) { + .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s): ", + "a structure that dies out before the closest pairs of ", + "points cannot be told from a nugget, so its nugget (%.3g) ", + "is not identified either, and `cp` and `reliability` ", + "are NA."), + sac_what, rejected, vg$nugget) + vg <- NULL + } else { + .warn_and_log(paste0("resolution_profile(): %s reports no usable range (%s). ", + "`cp` still takes its nugget (%.3g), fitted at the short lags; ", + "`reliability` needs the range and is NA."), + sac_what, rejected, vg$nugget) + vg$cor_fn <- NULL + } + } else if (is.null(vg)) { .log_info("resolution_profile(): the variogram carries no usable model; `cp` and `reliability` are NA.") + } + # A nugget of 0 is usually the fit's lower bound, not an estimate (gstat + # does not warn when it clips there), and with it Cp's penalty is 0: Cp + # is the RSS alone and falls with every finer level to the ceiling, + # whatever the field. Zero to within 1e-4 of the sill: a REML fit stops + # short of its bound, and a nugget of 6e-7 on a sill of 0.99 slipped past + # a test for exactly 0. + if (has_resp && !is.null(vg) && vg$nugget <= 1e-4 * (vg$nugget + vg$psill)) + .warn_and_log(paste0("resolution_profile(): the variogram's nugget is 0 (%.2g ", + "against a sill of %.3g), so Cp has ", + "no penalty and falls as the cells get finer: its minimum ", + "will sit at or near the finest level whatever the field. ", + "A zero nugget is usually the fit's lower bound; %s"), + vg$nugget, vg$nugget + vg$psill, + if (sac_given) "check it with plot() on the sac, or pass one whose nugget you trust." + else paste0("check it with plot(attr(, \"sac\")), or pass a ", + "`sac` whose nugget you trust.")) + # The variogram has to describe the variable the profile scores. A + # residual variogram's nugget put into Cp for the raw response (or the + # reverse) moved the Cp pick from 2-4 cells to the ceiling of 44 in five + # of five simulated fields, silently. A hand-built sac that does not say + # which it is cannot be checked. + if (!is.null(vg) && !is.na(vg$detrended) && !is.na(variable) && + !identical(vg$detrended, identical(variable, "residuals"))) + .warn_and_log(paste0("resolution_profile(): %s is a variogram of %s, but the ", + "profile scores %s, so `cp` and `reliability` take their ", + "nugget, sill and range from a different variable. Pass a ", + "`sac` fitted to %s."), + sac_what, + if (vg$detrended) "detrended residuals" else "the raw response", + if (identical(variable, "residuals")) + "the OLS residuals on `predictor_vars`" else "the raw response", + if (identical(variable, "residuals")) + "the same residuals (predictor_vars as here)" + else "the raw response (no predictor_vars)") } - # Bounds. - hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(data_sf))) - area <- suppressWarnings(as.numeric(sf::st_area(hull))) - bb <- sf::st_bbox(data_sf) - bbw <- as.numeric(bb["xmax"] - bb["xmin"]); bbh <- as.numeric(bb["ymax"] - bb["ymin"]) - if (!is.finite(area) || area <= 0) area <- bbw * bbh + # Bounds. `area`, `n_uniq_all` and `n_all` are the layer's (see above); + # `n_uniq` is the subsample's, the locations k-means can place centres on. n_uniq <- nrow(unique(round(xy, 8))) - by_support <- floor(n / min_cell_n) - # The ceiling is the smaller of what the point count supports and what the - # distinct locations allow (k-means cannot place more centres than there - # are distinct points). Which one bound it is recorded, because the print - # and the "bound is choosing" notes name it. - ceiling_L <- max(2L, as.integer(min(by_support, n_uniq - 1L))) - ceiling_from <- if (by_support <= n_uniq - 1L) "min_cell_n" else "distinct locations" + if (n == n_all) n_uniq_all <- n_uniq + by_support <- floor(n_all / min_cell_n) + # The ceiling is the smallest of what the layer's point count supports, + # what its distinct locations allow and, when the fits run on a subsample, + # what the subsample can fit: two of its points per cell. k-means can put + # a centre on every distinct location but no more, and stats::kmeans() + # refuses as many centres as points, so that bound is the distinct + # locations when some repeat and one short of the points when none do. It + # used to be one short of the distinct locations in every case, which + # dropped k = 5 on five stations visited thirty times each. Which bound + # holds is recorded, because the print and the "bound is choosing" notes + # name it. + k_cap_all <- min(n_uniq_all, n_all - 1L) + k_cap_fit <- min(n_uniq, n - 1L) + data_ceiling <- min(by_support, k_cap_all) + fit_cap <- if (n < n_all) min(floor(n / 2), k_cap_fit) else Inf + ceiling_L <- max(2L, as.integer(min(data_ceiling, fit_cap))) + ceiling_from <- if (fit_cap < data_ceiling) "sample_n" + else if (by_support <= k_cap_all) "min_cell_n" + else "distinct locations" # Kept as a double until the comparison: a short range on a continental # extent puts area / range^2 past .Machine$integer.max, and as.integer() of # that is NA, which turned the "not supported" branch into an abort. floor_raw <- if (is.finite(range_eff) && range_eff > 0) max(2, ceiling(area / range_eff^2)) else 2 - supported <- floor_raw <= ceiling_L + # The verdict is about the data, so it is taken against the layer's + # ceiling; a subsample too small to reach the floor is a setting to change, + # and is said separately. + supported <- floor_raw <= max(2, data_ceiling) floor_L <- if (floor_raw <= .Machine$integer.max) as.integer(floor_raw) else NA_integer_ if (!supported) .log_warn(paste0("resolution_profile(): cells no wider than the autocorrelation ", @@ -425,23 +761,38 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU "support a tessellation that respects their own ", "correlation structure; the profile runs from 2 to %d so ", "the cost of each level is still visible."), - range_eff, floor_raw, n, min_cell_n, ceiling_L, ceiling_L) - lo <- if (supported) floor_L else 2L + range_eff, floor_raw, n_all, min_cell_n, + max(2L, as.integer(data_ceiling)), ceiling_L) + else if (floor_raw > ceiling_L) + .log_warn(paste0("resolution_profile(): cells no wider than the autocorrelation ", + "range (%.0f) need at least %.0f of them, which the %d points ", + "support, but k-means on the %d-point subsample can fit at ", + "most %d; raise `sample_n`. The profile runs from 2 to %d."), + range_eff, floor_raw, n_all, n, ceiling_L, ceiling_L) + # With range_floor = FALSE the ladder starts at 2 whatever the range, and the + # floor is only reported. The range is re-estimated on every subset, and a + # floor that applies on one fold and not on the next starts their ladders + # at 225 and at 2: reliability and the elbow, which sit near the bottom, + # then moved 10-15 times between folds of one benchmark while Cp did not. + lo <- if (range_floor && supported && floor_raw <= ceiling_L) floor_L else 2L if (is.null(levels)) { levels <- unique(as.integer(round(exp(seq(log(lo), log(ceiling_L), length.out = max(2L, as.integer(n_levels))))))) levels <- sort(unique(c(lo, levels, ceiling_L))) } else { levels <- sort(unique(as.integer(levels))) - levels <- levels[levels >= 2L & levels <= n_uniq - 1L] + levels <- levels[levels >= 2L & levels <= k_cap_fit] if (!length(levels)) stop("resolution_profile(): no usable value in `levels`.", call. = FALSE) } bounds <- list(floor = floor_L, ceiling = ceiling_L, ceiling_from = ceiling_from, - supported = supported, area = area, range = range_eff, n = n, - n_distinct = n_uniq, min_cell_n = min_cell_n) + supported = supported, area = area, range = range_eff, n = n_all, + n_sample = n, n_distinct = n_uniq_all, min_cell_n = min_cell_n, + range_floor = range_floor) - rbar_V <- if (!is.null(vg)) .rbar_rect(vg$cor_fn, bbw, bbh) else NA_real_ + # Over the hull the area is measured on, not its bounding box (see + # .rbar_domain()); reliability needs an identified range. + rbar_V <- if (!is.null(vg$cor_fn)) .rbar_domain(vg$cor_fn, hull, area) else NA_real_ pred_for_moran <- if (has_pred) pred else matrix(numeric(0), nrow = n, ncol = 0L) # The sweep. @@ -468,33 +819,60 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU out$cell_diam_median[i] <- 2 * stats::median(rad[sizes >= 2L]) if (!is.null(y)) { okr <- is.finite(y) - if (sum(okr) > L) { + m_ok <- sum(okr) + L_ok <- length(unique(km$cluster[okr])) # cells holding a scored row + if (m_ok > L_ok) { cm <- stats::ave(y[okr], km$cluster[okr]) out$rss[i] <- sum((y[okr] - cm)^2) + # Cp for the cells of the whole layer, estimated from the subsample. + # RSS / m + tau^2 L_ok / m estimates the approximation error plus + # tau^2 (it adds back the optimism of the subsample's own cell means, + # tau^2 per cell); tau^2 L / N is the sampling variance of cell means + # built from the layer's N rows with a response. With no subsample + # (m = N, L_ok = L) it is Mallows' RSS / n + 2 tau^2 L / n. if (!is.null(vg)) - out$cp[i] <- out$rss[i] / sum(okr) + 2 * vg$nugget * L / sum(okr) + out$cp[i] <- out$rss[i] / m_ok + vg$nugget * (L_ok / m_ok + L / n_resp) } mi <- .morans_i_for_k(xy[okr, , drop = FALSE], y[okr], pred_for_moran[okr, , drop = FALSE], km$cluster[okr]) out$moran_i[i] <- mi[["I"]] out$moran_z[i] <- mi[["z"]] } - if (!is.null(vg)) - out$reliability[i] <- .reliability_at(L, area, n, vg$nugget, vg$psill, + # The layer's point count: the cell means are built from every point, + # not from the subsample the partition was fitted on. + if (!is.null(vg$cor_fn)) + out$reliability[i] <- .reliability_at(L, area, n_resp, vg$nugget, vg$psill, vg$cor_fn, rbar_V) } - # Elbow distance over the ladder, and the bumps on it. + # The elbow over the ladder, and the bumps on it. The sag of log WSS below + # the straight line from k = 1 to the last level on log-log axes (see + # .elbow_sag()); NA at every level when the curve has no elbow. On linear + # axes the chord from the first level to the last always has a point + # furthest below it, at about sqrt(first x last level) on a layer with no + # cluster structure, so min_cell_n and the range floor chose the "elbow", + # and a geometry-only profile handed that count to build_tessellation(). + # Anchored at k = 1, whose WSS is the total sum of squares and exact, + # rather than at the first level: the ladder often starts at the range + # floor, and a uniform square's WSS sits above c / k at k = 2 (two halves + # keep 5/8 of the total, not 1/2), so a chord from 2 finds a "knee" at its + # four quadrants. fin <- is.finite(out$wss) - if (sum(fin) >= 3L) { - k_norm <- (levels[fin] - min(levels[fin])) / max(1, diff(range(levels[fin]))) - w <- out$wss[fin] - wss_norm <- (w - min(w)) / max(.Machine$double.eps, max(w) - min(w)) - x1 <- k_norm[1L]; y1 <- wss_norm[1L] - x2 <- k_norm[length(k_norm)]; y2 <- wss_norm[length(wss_norm)] - line_len <- sqrt((x2 - x1)^2 + (y2 - y1)^2) - out$elbow[fin] <- if (line_len < .Machine$double.eps) 0 else - .below_chord(k_norm, wss_norm, x1, y1, x2, y2, line_len) + # A level with a WSS of 0 (to within 1e-12 of the total) has a cell on + # every distinct location. It is left out of the line, which log(0) would + # take with it, and when the rest of the curve has no elbow it is the + # elbow, the fall to zero being the sharpest bend there is (see + # .elbow_read()). Leaving it out alone made five stations visited thirty + # times each a layer with no elbow. + if (any(fin)) { + tss <- sum(sweep(xy, 2L, colMeans(xy))^2) + rd <- .elbow_read(c(1L, levels[fin]), c(tss, out$wss[fin])) + if (rd$structured) + out$elbow[fin] <- rd$sag[-1L] + else if (sum(!rd$zero[-1L]) >= 2L) + .log_info(paste0("resolution_profile(): the WSS curve has no elbow (on log-log ", + "axes it falls in a straight line, as it does for points with ", + "no cluster structure); `elbow` is NA.")) } wss_bumps <- .wss_bumps(out$wss[fin]) if (wss_bumps > 0L) @@ -506,7 +884,8 @@ resolution_profile <- function(data_sf, response_var = NULL, predictor_vars = NU structure(out, class = c("resolution_profile", "data.frame"), bounds = bounds, - variogram = if (is.null(vg)) NULL else vg[c("nugget", "psill", "range", "model")], + variogram = if (is.null(vg)) NULL + else vg[c("nugget", "psill", "range", "model", "detrended")], variable = variable, wss_bumps = wss_bumps, nstart = nstart, @@ -542,17 +921,32 @@ print.resolution_profile <- function(x, digits = 3L, ...) { print(as.data.frame(unclass(x)), row.names = FALSE) return(invisible(x)) } - cat("Resolution profile:", nrow(x), "levels on", b$n, "points\n") - cat(sprintf(" ladder : %d to %d cells (floor %s, ceiling %d from %s)%s\n", + # `n` is the layer; the k-means fits may have run on a subsample of it. + n_fit <- b$n_sample %||% b$n + cat("Resolution profile:", nrow(x), "levels on", b$n, + if (isTRUE(n_fit < b$n)) sprintf("points (k-means fitted to a subsample of %d)\n", n_fit) + else "points\n") + cat(sprintf(" ladder : %d to %d cells (floor %s, ceiling %d%s)%s\n", min(x$levels), max(x$levels), if (!is.finite(b$range)) "2 (no range)" - else if (is.na(b$floor)) sprintf("beyond integer range from range %.0f", b$range) - else sprintf("%d from range %.0f", b$floor, b$range), + else paste0(if (is.na(b$floor)) sprintf("beyond integer range from range %.0f", b$range) + else sprintf("%d from range %.0f", b$floor, b$range), + if (isFALSE(b$range_floor)) ", not applied" else ""), b$ceiling, - if (identical(b$ceiling_from, "distinct locations")) - sprintf("%d distinct locations", b$n_distinct %||% NA_integer_) - else sprintf("min_cell_n = %d", b$min_cell_n), - if (isTRUE(b$supported)) "" else " -- floor above ceiling: not supported")) + # With no location repeated the cap is one short of the points + # (stats::kmeans() needs fewer centres than points), and "from + # 30 distinct locations" named a number that did not bind. + if (identical(b$ceiling_from, "distinct locations") && + isTRUE(b$ceiling < (b$n_distinct %||% NA_integer_))) + sprintf(", one short of the %d points", b$n) + else if (identical(b$ceiling_from, "distinct locations")) + sprintf(" from %d distinct locations", b$n_distinct %||% NA_integer_) + else if (identical(b$ceiling_from, "sample_n")) + sprintf(" from the %d-point subsample", n_fit) + else sprintf(" from min_cell_n = %d", b$min_cell_n), + if (!isTRUE(b$supported)) " -- floor above ceiling: not supported" + else if (isTRUE(b$floor > b$ceiling)) " -- floor above ceiling: raise sample_n" + else "")) vg <- attr(x, "variogram", exact = TRUE) cat(sprintf(" variogram : %s\n", if (is.null(vg)) "none usable (cp and reliability are NA)" else @@ -561,9 +955,12 @@ print.resolution_profile <- function(x, digits = 3L, ...) { cat(sprintf(" scored on : %s; %d k-means++ restarts per level; WSS rises at %d step(s)\n", if (is.na(attr(x, "variable"))) "geometry only" else attr(x, "variable"), attr(x, "nstart"), attr(x, "wss_bumps"))) + if (all(c("elbow", "wss") %in% names(x)) && !any(is.finite(x$elbow)) && + sum(is.finite(x$wss)) >= 2L) + cat(" elbow : none; the WSS curve falls as it does with no cluster structure\n") sp <- attr(x, "split") if (!is.null(sp)) - cat(sprintf(" split : selected on %d points; estimate on the other %d (attr \"split\")\n", + cat(sprintf(" split : response read on %d points; estimate on the other %d (attr \"split\")\n", length(sp$selection), length(sp$estimation))) cat("\n") tab <- as.data.frame(unclass(x)) @@ -671,7 +1068,8 @@ print.resolution_profile <- function(x, digits = 3L, ...) { #' \code{at_ceiling} and \code{at_floor} (logical: the optimum is the last #' or first of the levels this criterion was scored at, which for #' \code{moran_z} starts above nine cells), \code{edge} (which bound that -#' is, in words: the support ceiling, the range floor, the ladder's own end, +#' is, in words: the support ceiling, the subsample's ceiling, the range +#' floor, the ladder's own end, #' or the first or last level the criterion is computable at; \code{NA} for #' an interior optimum), \code{n_levels} and \code{values} (the criterion #' at every level, \code{NA} where it could not be computed). @@ -683,7 +1081,7 @@ print.resolution_profile <- function(x, digits = 3L, ...) { #' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough #' # noise for Mallows' Cp to have an interior optimum rather than descend #' # to the ceiling. -#' set.seed(2) +#' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) #' D <- as.matrix(dist(xy)) @@ -735,8 +1133,12 @@ select_resolution <- function(profile, criterion, switch(criterion, cp = " (it needs a response and a usable variogram)", - reliability = " (it needs a usable variogram)", + reliability = " (it needs a usable variogram with an identified range)", moran_z = " (it needs a response and more than nine cells)", + elbow = paste0(" (the WSS curve has no elbow: on log-log axes it ", + "falls in a straight line, as it does for points ", + "with no cluster structure, so the geometry names ", + "no cell count)"), "")), call. = FALSE) maximise <- criterion %in% c("reliability", "elbow") lv <- profile$levels @@ -780,8 +1182,13 @@ select_resolution <- function(profile, if (max(scored) < max(ladder)) return("the last level the criterion is computable at") if (is.list(bounds) && identical(as.integer(max(ladder)), as.integer(bounds$ceiling))) - return(if (identical(bounds$ceiling_from, "distinct locations")) - "the support ceiling (one short of the distinct locations)" + return(if (identical(bounds$ceiling_from, "distinct locations") && + isTRUE(bounds$ceiling < (bounds$n_distinct %||% NA_integer_))) + "the support ceiling (one short of the points, the most k-means can fit)" + else if (identical(bounds$ceiling_from, "distinct locations")) + "the support ceiling (as many cells as the distinct locations allow)" + else if (identical(bounds$ceiling_from, "sample_n")) + "the subsample's ceiling (two subsample points per cell; raise sample_n)" else "the support ceiling (n / min_cell_n)") return("the last level of the ladder") } @@ -789,6 +1196,7 @@ select_resolution <- function(profile, if (min(scored) > min(ladder)) return("the first level the criterion is computable at") if (is.list(bounds) && isTRUE(bounds$supported) && is.finite(bounds$range %||% NA) && + !isFALSE(bounds$range_floor) && identical(as.integer(min(ladder)), as.integer(bounds$floor))) return("the range floor (area / range^2)") return("the first level of the ladder") @@ -807,6 +1215,8 @@ print.resolution_selection <- function(x, ...) { if (!is.na(edge)) { hint <- if (grepl("min_cell_n", edge, fixed = TRUE)) " Lower min_cell_n to see whether the criterion keeps going." + else if (grepl("raise sample_n", edge, fixed = TRUE)) + " Raise sample_n to see whether the criterion keeps going." else if (grepl("range floor", edge, fixed = TRUE)) " Fewer cells would be wider than the range and average over more than one patch of the field." else "" @@ -885,7 +1295,7 @@ print.resolution_selection <- function(x, ...) { #' # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough #' # noise for Mallows' Cp to have an interior optimum rather than descend #' # to the ceiling. -#' set.seed(2) +#' set.seed(4) #' n <- 400 #' xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) #' D <- as.matrix(dist(xy)) @@ -954,7 +1364,8 @@ summary.resolution_profile <- function(object, criteria = NULL, tol = 0.02, ...) "profile resolution_profile() returned.", call. = FALSE) stop("summary.resolution_profile(): no criterion is finite at any level. ", "cp and reliability need a usable variogram, moran_z a response and ", - "more than nine cells; a geometry-only profile carries elbow alone.", + "more than nine cells; a geometry-only profile carries elbow alone, ", + "and elbow is NA when the WSS curve has no elbow.", call. = FALSE) } @@ -1118,10 +1529,18 @@ print.resolution_summary <- function(x, ...) { usable <- Filter(function(cn) cn %in% names(x) && any(is.finite(suppressWarnings(as.numeric(x[[cn]])))), c("cp", "reliability", "elbow", "moran_z")) + # A geometry-only profile of a layer with no cluster structure lands here + # too: its elbow is NA rather than the sqrt(first x last level) the + # linear chord rule used to hand on as if the data had chosen it. if (!length(usable)) stop(sprintf(paste0("%s(): `%s` is a resolution profile with no criterion finite at ", - "any level, so no cell count can be read off it."), - caller, arg), call. = FALSE) + "any level, so no cell count can be read off it.%s"), + caller, arg, + if (is.na(attr(x, "variable") %||% NA_character_)) + paste0(" It is geometry-only, and its WSS curve has no elbow: the ", + "points have no cluster structure to choose a count. Pass a ", + "number, or profile with a `response_var`.") + else ""), call. = FALSE) sel <- select_resolution(x, criterion = usable[[1L]]) n <- sel$best from <- sprintf("resolution_profile() read with select_resolution(criterion = \"%s\")%s", diff --git a/R/seeding.R b/R/seeding.R index 882b653..c7e795a 100644 --- a/R/seeding.R +++ b/R/seeding.R @@ -31,8 +31,13 @@ #' not join the distance calculation and dominate it; rows with empty or #' non-finite coordinates are dropped with a warning, so they never reach #' `stats::kmeans()`, which fails on them without naming a cause. A lon/lat -#' cloud is projected before clustering. -#' @param kmeans_nstart Integer; nstart for kmeans(). Default 10. +#' cloud, or one with no CRS whose coordinates look like lon/lat (the +#' heuristic [ensure_projected()] applies, with its warning), is projected +#' before clustering. +#' @param kmeans_nstart Integer; nstart for kmeans(). Default 10. The +#' partition is [stats::kmeans()], not the best-of-25 k-means++ run that +#' [resolution_profile()] scored a count on, so it is not that partition; +#' see [voronoi_seeds_kmeans()]. #' @param kmeans_iter Integer; iter.max for kmeans(). Default 100. #' @param set_seed Optional integer RNG seed. #' @return An sf POINT object with seed_id and method columns. With @@ -87,7 +92,13 @@ get_voronoi_seeds <- function(boundary = NULL, cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) - boundary_union <- function(b) sf::st_union(.safe_make_valid(b)) + # On the sphere for a lon/lat boundary, whatever sf_use_s2() says: with it + # off, sf printed "although coordinates are longitude/latitude, st_union + # assumes that they are planar" on every random or k-means seeding. + boundary_union <- function(b) { + b <- .safe_make_valid(b) + if (.is_longlat(b)) .with_s2(sf::st_union(b)) else sf::st_union(b) + } out <- switch( method, @@ -126,8 +137,16 @@ get_voronoi_seeds <- function(boundary = NULL, # If cloud is in lon/lat, project to a local CRS before k-means so # that clustering is distance-faithful (k-means in degrees is # distorted except in very small areas). + # A cloud with no CRS gets the lon/lat heuristic every other entry point + # applies (ensure_projected() warns when it fires). .is_longlat() alone + # is FALSE for a missing CRS, so CRS-less degrees were clustered as if + # they were metres -- 800 points 89 km wide and 111 km tall were split + # east-west instead of north-south -- while build_tessellation() + # projected the very same points. + cloud_crs <- sf::st_crs(cloud) cloud_for_km <- cloud - cloud_is_ll <- .is_longlat(cloud) + cloud_is_ll <- .is_longlat(cloud) || + (is.na(cloud_crs) && isTRUE(.looks_like_lonlat(cloud)$lonlat)) if (cloud_is_ll) { cloud_for_km <- ensure_projected(cloud) .log_info("get_voronoi_seeds(kmeans): projecting cloud from lon/lat before k-means clustering.") @@ -175,10 +194,12 @@ get_voronoi_seeds <- function(boundary = NULL, crs = sf::st_crs(cloud_for_km) ) s <- sf::st_sf(seed_id = seq_len(k_use), method = "kmeans", geometry = centers_sfc) - # Transform back to original cloud CRS if we projected for k-means - if (cloud_is_ll && !identical(sf::st_crs(s), sf::st_crs(cloud))) { - s <- sf::st_transform(s, sf::st_crs(cloud)) - } + # Back to the cloud's own coordinates if we projected for k-means: its + # CRS, or for a CRS-less cloud the degrees it was given in, CRS-less + # again (st_transform() to a missing CRS is an error). + if (cloud_is_ll) + sf::st_geometry(s) <- .back_to_input_crs(sf::st_geometry(s), cloud_for_km, + cloud_crs) # Which cloud points fed which seed, and how tight each cluster is: # `cluster` is one seed_id per clustered cloud row (`rows` gives those # rows' positions in the cloud, since unusable rows were dropped). @@ -219,17 +240,33 @@ get_voronoi_seeds <- function(boundary = NULL, #' @keywords internal #' @noRd .robust_st_sample <- function(geom, n) { - pts <- try(sf::st_sample(geom, size = n, type = "random", exact = TRUE), + # st_sample() sizes its draw from st_area(), which on lon/lat input needs + # lwgeom (not a dependency) when sf_use_s2() is FALSE: random and k-means + # seeding on a lon/lat boundary failed with "package lwgeom required". + if (.is_longlat(geom) && !isTRUE(sf::sf_use_s2())) + return(.with_s2(.robust_st_sample(geom, n))) + # Without lwgeom (not a dependency) sf warns "coordinate ranges not computed + # along great circles; install package lwgeom to get rid of this warning" + # on every lon/lat draw, so every random or k-means seeding on a lon/lat + # boundary raised it, once or twice, in the ordinary case. Only that + # warning is muffled; the draw is the same. + st_sample_quiet <- function(...) withCallingHandlers( + sf::st_sample(...), + warning = function(w) + if (grepl("coordinate ranges not computed along great circles", + conditionMessage(w), fixed = TRUE)) + invokeRestart("muffleWarning")) + pts <- try(st_sample_quiet(geom, size = n, type = "random", exact = TRUE), silent = TRUE) if (inherits(pts, "try-error")) { - pts <- sf::st_sample(geom, size = n, type = "random") + pts <- st_sample_quiet(geom, size = n, type = "random") } # Pad or trim to exactly n max_attempts <- 10L attempt <- 0L while (length(pts) < n && attempt < max_attempts) { attempt <- attempt + 1L - extra <- sf::st_sample(geom, size = n - length(pts), type = "random") + extra <- st_sample_quiet(geom, size = n - length(pts), type = "random") pts <- c(pts, extra) } if (length(pts) > n) pts <- pts[seq_len(n)] @@ -245,15 +282,28 @@ get_voronoi_seeds <- function(boundary = NULL, #' 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. +#' none. Reach for this when you want cells that follow the data, so that +#' counts per cell vary far less than on a fixed grid over clustered points +#' (k-means does not equalise them, it minimises the spread of points around +#' each centre), which is what keeps per-cell aggregates in +#' [summarize_by_cell()] from resting on one or two observations. Use +#' [voronoi_seeds_random()] instead when you want coverage of the study area +#' rather than of the data, and [get_voronoi_seeds()] to pick between them by +#' name. #' #' Lon/lat input is projected first so the k-means distances are metric and not -#' degrees. Rows with empty or non-finite coordinates are dropped with a -#' warning, and `k` is clamped to the number of distinct positions. +#' degrees; so is input with no CRS whose coordinates look like lon/lat (the +#' heuristic [ensure_projected()] applies, with its warning), and the seeds +#' come back in the input's own coordinates. Rows with empty or non-finite +#' coordinates are dropped with a warning, and `k` is clamped to the number of +#' distinct positions. +#' +#' The partition is [stats::kmeans()] (Hartigan-Wong) with `nstart` random +#' starts. [resolution_profile()] and [determine_optimal_levels()] score each +#' count on a different run, by default the best of 25 k-means++ restarts, +#' which usually reaches a lower within-cluster sum of squares; the seeds for +#' a chosen count are therefore not the partition that count was scored on. +#' Raising `nstart` narrows the gap but does not close it. #' #' @param points_sf An sf object with POINT geometries. #' @param k Integer; requested number of clusters, treated as an upper bound @@ -261,7 +311,13 @@ get_voronoi_seeds <- function(boundary = NULL, #' of distinct point positions and `nrow(points_sf) - 1`, because k-means can #' produce neither more centres than there are distinct points nor as many #' centres as there are rows. Check `nrow()` on the result. -#' @param set_seed Optional integer RNG seed. Default 456. +#' @param set_seed Optional integer RNG seed. Default 456, so a call gives the +#' same seeds every time whatever the session's random-number state; an +#' outer [set.seed()] does not change them, and the caller's random-number +#' stream is left as it was. Pass `NULL` to draw the k-means starts from +#' the session's stream instead (the default of [get_voronoi_seeds()]). +#' @param nstart Number of random starts for [stats::kmeans()]; the best is +#' kept. Default 10. #' @return An sf object of **at most** `k` cluster-centre POINTs (fewer when #' `k` exceeds the number of distinct positions), with `seed_id` and #' `method = "kmeans"` columns matching [get_voronoi_seeds()]. @@ -277,7 +333,7 @@ get_voronoi_seeds <- function(boundary = NULL, #' nrow(seeds) # at most 8: one seed per non-empty cluster #' seeds # the cluster centres, as an sf POINT layer in the points' CRS #' @export -voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { +voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456, nstart = 10) { .assert_sf(points_sf, "POINT", "points_sf") # `k` was never validated here, unlike get_voronoi_seeds(), which routes # `n` through .resolve_cell_count(): k = NA or a length-2 vector aborted on @@ -288,9 +344,18 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { max = .Machine$integer.max, what = "a single positive number of seeds") - # Project to metric CRS if lon/lat to make k-means distance-faithful + .check_scalar(nstart, "nstart", "voronoi_seeds_kmeans", min = 1, + max = .Machine$integer.max, + what = "a single positive number of k-means restarts") + + # Project to metric CRS if lon/lat to make k-means distance-faithful. A + # CRS-less layer gets the lon/lat heuristic ensure_projected() applies + # everywhere else (with its warning); .is_longlat() is FALSE for a missing + # CRS, so CRS-less degrees used to be clustered as if they were metres. + crs_in <- sf::st_crs(points_sf) pts_for_km <- points_sf - pts_is_ll <- .is_longlat(points_sf) + pts_is_ll <- .is_longlat(points_sf) || + (is.na(crs_in) && isTRUE(.looks_like_lonlat(points_sf)$lonlat)) if (pts_is_ll) { pts_for_km <- ensure_projected(points_sf) } @@ -326,12 +391,16 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) - km <- stats::kmeans(coords, centers = k_use, iter.max = 50, nstart = 10) + km <- stats::kmeans(coords, centers = k_use, iter.max = 50, + nstart = as.integer(nstart)) cent <- as.data.frame(km$centers); names(cent) <- c("x", "y") result <- sf::st_as_sf(cent, coords = c("x", "y"), crs = sf::st_crs(pts_for_km)) - # Transform back to original CRS if we projected + # Back to the input's own coordinates if we projected: its CRS, or for a + # CRS-less layer the degrees it was given in, CRS-less again + # (st_transform() to a missing CRS is an error). if (pts_is_ll) { - result <- sf::st_transform(result, sf::st_crs(points_sf)) + sf::st_geometry(result) <- .back_to_input_crs(sf::st_geometry(result), + pts_for_km, crs_in) } # Same output contract as get_voronoi_seeds(), so the three seeding # functions are drop-in interchangeable. @@ -352,16 +421,22 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { #' 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. +#' Seeds are drawn uniformly inside the polygon. When a draw falls short of `k` +#' it is topped up with further uniform draws from the same polygon, so the +#' result has exactly `k` seeds; only a geometry that still yields too few +#' after ten top-ups returns fewer, and that shortfall is logged. #' #' @param boundary An sf or sfc polygonal object. #' @param k Integer; number of random seeds. -#' @param set_seed Integer RNG seed. Default 456. -#' @return An sf object of **at most** `k` random POINTs (rejection sampling -#' inside an awkward geometry can fall short of `k`, which is warned about), -#' with `seed_id` and `method = "random"` columns matching +#' @param set_seed Optional integer RNG seed. Default `NULL`: the seeds are +#' drawn from the session's random-number stream, so consecutive calls give +#' different seedings and [set.seed()] before a call makes it reproducible. +#' Pass a number to get the same seeds whatever that stream holds; the +#' caller's stream is then left as it was. The default used to be 456, +#' which made every call return the same "random" seeding, even inside a +#' loop over [set.seed()]. +#' @return An sf object of `k` random POINTs (fewer only in the degenerate +#' case above), with `seed_id` and `method = "random"` columns matching #' [get_voronoi_seeds()]. #' @family tessellation #' @examples @@ -369,11 +444,15 @@ voronoi_seeds_kmeans <- function(points_sf, k, set_seed = 456) { #' bnd <- st_sf(geometry = st_sfc(st_polygon(list(rbind( #' c(0, 0), c(100, 0), c(100, 100), c(0, 100), c(0, 0) #' ))), crs = 32632)) +#' set.seed(1) #' seeds <- voronoi_seeds_random(bnd, k = 10) -#' nrow(seeds) # at most 10: a seed that lands outside the boundary is dropped +#' nrow(seeds) # 10 #' seeds +#' # Another call is another seeding; set_seed pins one. +#' identical(st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7)), +#' st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7))) #' @export -voronoi_seeds_random <- function(boundary, k, set_seed = 456) { +voronoi_seeds_random <- function(boundary, k, set_seed = NULL) { # `k` was never validated here, unlike get_voronoi_seeds(), which routes # `n` through .resolve_cell_count(): k = NA or a length-2 vector aborted on # the clamp below, k above .Machine$integer.max became NA through @@ -388,7 +467,10 @@ voronoi_seeds_random <- function(boundary, k, set_seed = 456) { cleanup <- .with_seed(set_seed) on.exit(cleanup(), add = TRUE) - geom <- sf::st_union(boundary) + # On the sphere for lon/lat, as in get_voronoi_seeds(): with s2 off sf + # otherwise printed its planar-union message on every call. + geom <- if (.is_longlat(boundary)) .with_s2(sf::st_union(boundary)) else + sf::st_union(boundary) pts <- .robust_st_sample(geom, k) out <- sf::st_sf(geometry = pts) |> sf::st_set_crs(sf::st_crs(boundary)) # Same output contract as get_voronoi_seeds(), so the three seeding diff --git a/R/select-on.R b/R/select-on.R index 9170e04..896acf6 100644 --- a/R/select-on.R +++ b/R/select-on.R @@ -6,42 +6,125 @@ #' Split a point layer into two spatially blocked halves #' #' \code{make_folds(k = 2, method = "block_kfold")} on the layer, so the two -#' halves are made of spatial blocks rather than of interleaved points: a -#' selection made on one half does not borrow its neighbours' values from the -#' other. Fold 1 is the selection half, fold 2 the estimation half. Rows -#' \code{make_folds()} drops (empty or non-finite geometry) belong to neither. +#' halves are made of spatial blocks rather than of interleaved points: far +#' fewer selection points sit next to an estimation point than under a random +#' half. Blocking reduces the dependence between the halves; it does not +#' remove it. The halves share a border, and under spatial autocorrelation +#' the points on either side of it are still correlated: on the tests' +#' \code{so_field(300)} (fitted range 253), 85\% of the estimation points lie +#' within the range of a selection point (93\% within the true range of 300; +#' the median distance to the nearest one is 141, against 36 for a random +#' half). No buffer is cut between +#' the halves. A buffer as wide as the range would discard about 85\% of +#' that estimation half, and a narrower one would be an arbitrary fraction of +#' a range the split does not estimate; the finite-sample exposure that +#' remains is the price of splitting a contiguous layer in two. Fold 1 is +#' the selection half, fold 2 the estimation half. Rows \code{make_folds()} +#' drops (empty or non-finite geometry) belong to neither. +#' +#' The blocks are the default grid of \code{make_folds()} (three per half) +#' unless a block design is passed through \code{...}. That grid is fixed by +#' the layer's extent, so the seed does not change the partition: it decides +#' only which of the two sides is the selection half (and breaks ties in the +#' packing of equal blocks). When the default grid leaves fewer than 10 +#' points in a half -- a small layer, or a small group far from the rest, +#' which always lands in a block of its own -- the split is retried on +#' finer grids (16, 36, then 100 blocks) and the first that gives both halves +#' 10 points is used, with a warning: finer blocks lengthen the border the +#' halves share. A block design passed through \code{...} is used as given. #' #' @param data_sf The layer, already reduced to points. #' @param seed Seed for the block assignment. #' @param caller Name for messages. -#' @return A list with \code{selection} and \code{estimation} (integer row -#' positions in \code{data_sf}), \code{method} and \code{seed}. +#' @param ... Block design passed to \code{make_folds()}: \code{block_nx}, +#' \code{block_ny}, \code{block_size}, \code{blocks}, \code{balance_tol}. +#' @return A list of class \code{"spatialkit_split"} with \code{selection} +#' and \code{estimation} (integer row positions in \code{data_sf}), +#' \code{method}, \code{seed}, \code{grid} (the block grid, \code{"nx x ny"}) +#' and \code{n_blocks} (the blocks of it that hold points), +#' \code{balance} (the larger half's size over the smaller's; the default +#' grid accepts up to 3, and clustered layers reach 2 routinely) and +#' \code{extent} (the bounding box of each half, in \code{data_sf}'s CRS). #' @keywords internal #' @noRd -.spatial_half_split <- function(data_sf, seed = 123L, caller = "select_on") { +.spatial_half_split <- function(data_sf, seed = 123L, caller = "select_on", ...) { n <- nrow(data_sf) if (n < 20L) stop(sprintf("%s(): select_on = \"split\" needs at least 20 points to make two spatial halves; got %d.", caller, n), call. = FALSE) - f <- tryCatch( - suppressMessages(make_folds(data_sf, k = 2L, method = "block_kfold", - seed = if (is.null(seed)) 123L else seed)), - error = function(e) - stop(sprintf("%s(): could not split the layer into two spatial halves: %s", - caller, conditionMessage(e)), call. = FALSE)) - a <- f$assignment - # Row IDs are positions unless the layer carried its own `..row_id`. - pos <- if ("..row_id" %in% names(data_sf)) match(a$row_id, data_sf$..row_id) else - as.integer(a$row_id) - ok <- is.finite(pos) & pos >= 1L & pos <= n - sel <- sort(pos[ok & a$fold == 1L]) - est <- sort(pos[ok & a$fold != 1L]) - if (length(sel) < 10L || length(est) < 10L) + seed <- if (is.null(seed)) 123L else seed + design <- list(...) + + # One make_folds() call, with the warnings it raises held back: a split + # that is then retried on a finer grid must not leave behind the first + # attempt's advice, and the kept attempt's warnings are raised as before. + attempt <- function(extra, retry = FALSE) { + held <- list() + f <- withCallingHandlers( + tryCatch( + suppressMessages(do.call(make_folds, c(list(data_sf, k = 2L, + method = "block_kfold", + seed = seed), + design, extra))), + error = function(e) { + if (retry) return(NULL) # a finer grid that fails is no help + stop(sprintf("%s(): could not split the layer into two spatial halves: %s", + caller, conditionMessage(e)), call. = FALSE) + }), + warning = function(w) { + held[[length(held) + 1L]] <<- w + invokeRestart("muffleWarning") + }) + if (is.null(f)) return(list(sel = integer(0), est = integer(0), + n_blocks = NA_integer_, grid = NA_character_, + warnings = list())) + a <- f$assignment + # Row IDs are positions unless the layer carried its own `..row_id`. + pos <- if ("..row_id" %in% names(data_sf)) match(a$row_id, data_sf$..row_id) else + as.integer(a$row_id) + ok <- is.finite(pos) & pos >= 1L & pos <= n + list(sel = sort(pos[ok & a$fold == 1L]), est = sort(pos[ok & a$fold != 1L]), + n_blocks = as.integer(f$params$blocks_used %||% NA_integer_), + grid = paste(f$params$grid_nx %||% NA, f$params$grid_ny %||% NA, sep = " x "), + warnings = held) + } + too_small <- function(r) length(r$sel) < 10L || length(r$est) < 10L + + r <- attempt(list()) + first <- r + # A remote group of fewer than 10 points always sat alone in a block of the + # six-block default grid, so the call stopped although a finer grid splits + # the same layer 131 / 127; nothing the caller could pass would reach it. + # Finer blocks lengthen the border the halves share, so the retries are + # few, capped, and announced, and a design the caller chose is not second- + # guessed. + if (too_small(r) && !length(design)) { + for (mult in c(8, 18, 50)) { # about 16, 36 and 100 blocks + r <- attempt(list(block_multiplier = mult), retry = TRUE) + if (!too_small(r)) break + } + if (!too_small(r)) + .warn_and_log(paste0("%s(): the default six-block split left %d and %d points ", + "in the two halves (at least 10 each are needed), so ", + "it was made on a finer %s grid instead. The ", + "halves then share a longer border, and more of the ", + "estimation points lie close to selection points."), + caller, length(first$sel), length(first$est), r$grid) + } + if (too_small(r)) stop(sprintf(paste0("%s(): the spatial split left %d and %d points in the two ", - "halves; at least 10 each are needed."), - caller, length(sel), length(est)), call. = FALSE) - structure(list(selection = sel, estimation = est, method = "block_kfold", - seed = if (is.null(seed)) 123L else seed), + "halves; at least 10 each are needed%s."), + caller, length(first$sel), length(first$est), + if (!length(design)) ", and grids of up to 100 blocks did no better" else ""), + call. = FALSE) + for (w in r$warnings) warning(w) + + sizes <- c(length(r$sel), length(r$est)) + extent <- lapply(list(selection = r$sel, estimation = r$est), function(i) + sf::st_bbox(sf::st_geometry(data_sf)[i])) + structure(list(selection = r$sel, estimation = r$est, method = "block_kfold", + seed = seed, grid = r$grid, n_blocks = r$n_blocks, + balance = max(sizes) / min(sizes), extent = extent), class = "spatialkit_split") } diff --git a/R/spatialkit-package.R b/R/spatialkit-package.R index 3e884aa..e1a4cd2 100644 --- a/R/spatialkit-package.R +++ b/R/spatialkit-package.R @@ -81,17 +81,16 @@ #' \code{make_folds(method = "nndm")} and their \code{min_train = 0.5}: #' Mila et al. (2022). #' \item The area-of-applicability threshold as the outlier-removed maximum -#' of the training dissimilarity, with importance weights applied directly, -#' without taking their square root, matching the reference -#' implementation: Meyer and Pebesma (2021). +#' of the training dissimilarity, as the paper defines it (the reference +#' implementation, CAST, uses the outlier fence itself, which is larger +#' whenever a training value lies above it), with importance weights +#' applied directly, without taking their square root, as CAST does: +#' Meyer and Pebesma (2021). #' \item The effective range of an exponential variogram as three times its #' range parameter, and the identifiability guard against ranges beyond #' half the maximum separation, in \code{estimate_sac_range()}. #' \item Cliff and Ord moments for the residual Moran's I in #' \code{residual_morans_i()}, with \code{null = "auto"}. -#' \item The small-sample rescaling applied with every data-derived design -#' effect in \code{summarize_by_cell()}, whose derivation and measured -#' coverage are on that help page. #' } #' #' Defaults that were chosen, and are defensible, but do not rest on a @@ -120,6 +119,11 @@ #' length-scale in \code{fit_bayesian_spatial_model()}, which is this #' package's own operationalisation of a check the reference recommends, #' not a figure from the paper. +#' \item The small-sample rescaling applied with every data-derived design +#' effect in \code{summarize_by_cell()}: the package's own derivation from +#' Kish's exchangeable-correlation model, not taken from a reference. +#' The derivation and its measured coverage are in the section "Spatial +#' autocorrelation and standard-error bias" of that help page. #' } #' #' @section Where to start: diff --git a/R/stable-ids-cache.R b/R/stable-ids-cache.R index 07fecdc..90e88f9 100644 --- a/R/stable-ids-cache.R +++ b/R/stable-ids-cache.R @@ -29,9 +29,16 @@ #' function says so rather than quietly sorting in the input's own CRS. The #' sort key is rounded to 7 decimal degrees (about 1 cm) before ordering, so #' the floating-point noise of a round trip through a different projection -#' cannot reverse two neighbouring cells. Set to NULL to sort in the input -#' CRS, which gives IDs that are reproducible but not comparable across -#' projections. +#' does not usually reverse two neighbouring cells. It can where two cells' +#' centres lie within about that step of the same longitude, as fine cells +#' stacked north-south near a projection's central meridian do: 36 of 2,500 +#' 100 m cells straddling a UTM central meridian changed ID after a +#' transform to EPSG:3035. No rounding step removes that, so to match cells +#' computed in different projections, join them on geometry rather than on +#' the ID. The key is computed on the sphere (s2) whether or not +#' \code{sf::sf_use_s2()} is on, so the session setting does not change the +#' IDs. Set to NULL to sort in the input CRS, which gives IDs that are +#' reproducible but not comparable across projections. #' @return An sf polygon layer re-ordered with sequential IDs in id_col. #' Non-polygonal rows are **dropped** (with a warning), so the result can #' have fewer rows than the input; if no polygonal rows remain, an error is @@ -61,7 +68,8 @@ ensure_stable_poly_id <- function(polygons_sf, # Normalize to sf if (inherits(polygons_sf, "sfc")) polygons_sf <- sf::st_as_sf(polygons_sf) if (!inherits(polygons_sf, "sf")) - stop("ensure_stable_poly_id(): `polygons_sf` must be an sf/sfc object.") + stop(paste0("ensure_stable_poly_id(): `polygons_sf` must be an sf/sfc object", + .tess_hint(polygons_sf, "$cells"), ".")) # Keep only polygon rows gtypes <- as.character(sf::st_geometry_type(polygons_sf, by_geometry = TRUE)) @@ -90,6 +98,19 @@ ensure_stable_poly_id <- function(polygons_sf, # 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. + # + # The key is measured in lon/lat, where sf routes st_centroid() and + # st_area() to s2, or with sf_use_s2(FALSE) to lwgeom (not a dependency: + # every Voronoi tessellation, projected ones included, died with "package + # lwgeom required") and to planar arithmetic on degrees, which differs from + # the spherical centroid by far more than the rounding step below, so a few + # near-tied cells took different IDs in s2-on and s2-off sessions (4 of + # 2,000 Voronoi cells). s2 is switched on for this function only and + # restored on exit, so the key is the same whatever sf_use_s2() says. + if (!isTRUE(sf::sf_use_s2())) { + suppressMessages(sf::sf_use_s2(TRUE)) + on.exit(suppressMessages(sf::sf_use_s2(FALSE)), add = TRUE) + } sort_sf <- polygons_sf if (!is.null(transform_for_sort) && !is.na(sf::st_crs(sort_sf))) sort_sf <- tryCatch( @@ -119,7 +140,7 @@ ensure_stable_poly_id <- function(polygons_sf, # Representative points — all paths produce an sfc_POINT vector rep_sfc <- switch(method, centroid = suppressWarnings(sf::st_geometry(sf::st_centroid(sort_sf))), - surface_point = sf::st_geometry(sf::st_point_on_surface(sort_sf)), + surface_point = sf::st_geometry(sf::st_point_on_surface(.drop_empty_parts(sort_sf))), bbox_center = { geoms <- sf::st_geometry(sort_sf) sf::st_sfc( @@ -152,6 +173,11 @@ ensure_stable_poly_id <- function(polygons_sf, # the failure the function exists to prevent. 7 decimals is about a # centimetre of longitude; the transform_for_sort default puts the key in # degrees, and the tie-break on area then index keeps the result total. + # Rounding moves the problem to the step boundaries rather than removing + # it: two cells whose longitudes differ by less than a step (fine cells in + # one column near a central meridian) can still round apart in one CRS and + # together in another -- 36 of 2,500 100 m cells did via EPSG:3035, and 6 + # decimals is no better -- which is why the documentation says "usually". kx <- round(xy[, 1], 7L) ky <- round(xy[, 2], 7L) ord <- do.call(order, list(kx, ky, signif(area, 9L), idx0)) @@ -183,14 +209,16 @@ ensure_stable_poly_id <- function(polygons_sf, #' @noRd .cache_key <- function(boundary, type, target_cells, ..., version = .spatialkit_version()) { + # The CRS's full WKT, not its `input` name. A layer read from a file with + # a custom CRS reports a generic name such as "unknown", so two different + # site-centred CRSs with the same local boundary coordinates shared a key, + # and the second site was handed the first one's grid, 11,000 km away. + # The cost is a rebuild when one CRS arrives written two ways (an EPSG + # code and the equivalent proj string). crs_obj <- sf::st_crs(boundary) - crs_token <- if (!is.null(crs_obj) && !is.na(crs_obj)) { - inp <- crs_obj$input - eps <- crs_obj$epsg - if (!is.null(inp) && !is.na(inp) && nzchar(as.character(inp))) as.character(inp) - else if (!is.null(eps) && !is.na(eps)) as.character(eps) - else "NA_CRS" - } else "NA_CRS" + crs_token <- if (!is.null(crs_obj) && !is.na(crs_obj) && + !is.null(crs_obj$wkt) && nzchar(crs_obj$wkt)) crs_obj$wkt + else "NA_CRS" # Use binary (WKB) digest for geometry — much faster than WKT for complex shapes geom_hash <- tryCatch( @@ -276,7 +304,9 @@ ensure_stable_poly_id <- function(polygons_sf, #' so repeated calls with the same inputs return instantly. #' #' @param boundary An sf or sfc polygonal object. -#' @param target_cells Approximate desired number of cells. +#' @param target_cells Approximate desired number of cells. Default `NULL`, +#' as in [create_grid_polygons()], so the grid can be sized by `cellsize` +#' or `n` passed through `...` instead. #' @param type Grid type: `"square"` (the default) or `"hex"`, matching #' [create_grid_polygons()]. #' @param ... Additional arguments forwarded to create_grid_polygons(). @@ -313,7 +343,7 @@ ensure_stable_poly_id <- function(polygons_sf, #' all(g2$poly_id == g$poly_id[same_cell]) #' @export create_grid_polygons_cached <- function(boundary, - target_cells, + target_cells = NULL, type = c("square", "hex"), ..., cache_env = .gmt_cache, @@ -327,8 +357,11 @@ create_grid_polygons_cached <- function(boundary, bnd <- if (inherits(boundary, "sfc")) sf::st_as_sf(boundary) else boundary if (!inherits(bnd, "sf")) - stop("create_grid_polygons_cached(): 'boundary' must be sf/sfc POLYGON/MULTIPOLYGON.") - bnd <- ensure_projected(bnd) + stop(paste0("create_grid_polygons_cached(): 'boundary' must be sf/sfc POLYGON/MULTIPOLYGON", + .tess_hint(bnd, "$boundary"), ".")) + # The same projection create_grid_polygons() makes, so a cached grid is laid + # in the CRS an uncached one would be (see .project_for_grid()). + bnd <- .project_for_grid(bnd, "create_grid_polygons_cached") key <- .cache_key(bnd, type, target_cells, ...) diff --git a/R/tessellation.R b/R/tessellation.R index 2b60712..53d9162 100644 --- a/R/tessellation.R +++ b/R/tessellation.R @@ -1,21 +1,255 @@ +# ----------------------------------------------------------------------------- +# CRS handling shared by the tessellation builders +# ----------------------------------------------------------------------------- + +#' Give a CRS-less points layer or boundary the other one's CRS +#' +#' When exactly one of the two has a CRS, the other is interpreted from it +#' the way harmonize_crs() does, warning either way: coordinates that look +#' like lon/lat are taken as EPSG:4326 and reprojected, anything else is +#' stamped. Before this, the builders handed sf two layers in different CRSs +#' and every method stopped with sf's bare "st_crs(x) == st_crs(y) is not +#' TRUE": UTM points read from a CSV with a UTM boundary, or projected points +#' with a boundary read from a file that lost its .prj. A CRS-less points +#' layer that does not look like lon/lat cannot be put in a GEOGRAPHIC +#' boundary's CRS -- stamping degrees onto UTM numbers is wrong -- so that is +#' refused with a message that says what to do. The mirror case, a CRS-less +#' boundary given with points in a GEOGRAPHIC CRS, is read in that CRS when +#' its coordinates fit the lon/lat envelope and refused otherwise (see +#' .crsless_boundary_as_lonlat()); the builders settle it before they project +#' the points, so the boundary is read in the points' own CRS and not in the +#' projected one picked for them. +#' +#' @param points,boundary sf layers; \code{boundary} may be \code{NULL}. +#' @param caller Function name for the messages. +#' @return A list with \code{points} and \code{boundary}. +#' @keywords internal +#' @noRd +.resolve_crsless_pair <- function(points, boundary, caller) { + if (is.null(boundary)) return(list(points = points, boundary = boundary)) + pcrs <- sf::st_crs(points) + bcrs <- sf::st_crs(boundary) + if (is.na(bcrs) && !is.na(pcrs)) { + boundary <- if (isTRUE(sf::st_is_longlat(pcrs))) + .crsless_boundary_as_lonlat(boundary, pcrs, caller) + else + .transform_or_stamp(boundary, pcrs, "boundary", caller) + } else if (is.na(pcrs) && !is.na(bcrs)) { + if (isTRUE(sf::st_is_longlat(bcrs)) && !isTRUE(.looks_like_lonlat(points)$lonlat)) + stop(sprintf(paste0( + "%s(): `points_sf` has no CRS and its coordinates do not look like ", + "lon/lat, but `boundary` is in a geographic CRS (%s), so the two ", + "cannot be placed in one space. Set the CRS of `points_sf` with ", + "sf::st_crs(), or pass a boundary in the points' own projected CRS."), + caller, .fold_crs_label(bcrs)), call. = FALSE) + points <- .transform_or_stamp(points, bcrs, "points_sf", caller) + attr(points, "crs_assumed") <- NULL + } + list(points = points, boundary = boundary) +} + + +#' Read a CRS-less boundary in the lon/lat CRS of the points it came with +#' +#' The points are in (or were taken as) a geographic CRS, so a CRS-less +#' boundary given with them is in degrees too if it can be: when its +#' bounding box fits the lon/lat envelope it is given the points' CRS. The +#' full lon/lat heuristic is not asked, because the points settle what +#' .looks_like_lonlat() has to guess: a one-degree tile with integer corners +#' fails that heuristic, and was stamped with the UTM zone picked for the +#' points instead, which read it as a one-metre square (every point outside +#' it, all 50 indexed NA). A boundary outside the envelope is in some other +#' unit, and the CRS it is in cannot be known: stamping the points' projected +#' working CRS on it was right only when that zone happened to be the user's. +#' That, and stamping degrees on it (a metre polygon then transformed to +#' nothing and was refused as "not polygonal"), are refused with an error +#' naming both layers. +#' +#' @param boundary CRS-less sf/sfc polygon layer. +#' @param crs_ll The points' geographic \code{sf::crs}. +#' @param caller Function name for the messages. +#' @param assumed Logical; the points had no CRS either and were taken as +#' lon/lat. The boundary is then given the same assumption without a +#' warning of its own (the points' warning names it), as before. +#' @return \code{boundary} with \code{crs_ll} set. +#' @keywords internal +#' @noRd +.crsless_boundary_as_lonlat <- function(boundary, crs_ll, caller, assumed = FALSE) { + bb <- .looks_like_lonlat(boundary)$bb + in_env <- is.null(bb) || + (bb[["xmin"]] >= -180 && bb[["xmax"]] <= 180 && + bb[["ymin"]] >= -90 && bb[["ymax"]] <= 90) + if (!in_env) + stop(sprintf(paste0( + "%s(): `boundary` has no CRS and its coordinates (xmin=%.6g, xmax=%.6g, ", + "ymin=%.6g, ymax=%.6g) are not lon/lat, but `points_sf` %s, so the two ", + "cannot be placed in one space. Set the CRS of `boundary`%s with ", + "sf::st_crs()."), + caller, bb[["xmin"]], bb[["xmax"]], bb[["ymin"]], bb[["ymax"]], + if (assumed) "has no CRS either and was taken as lon/lat (EPSG:4326)" + else sprintf("is in a geographic CRS (%s)", .fold_crs_label(crs_ll)), + if (assumed) " and of `points_sf`" else ""), + call. = FALSE) + if (!assumed && !is.null(bb)) + .warn_and_log(paste0( + "%s(): `boundary` has no CRS; its coordinates look like lon/lat (they fit ", + "the lon/lat envelope: xmin=%.2f, xmax=%.2f, ymin=%.2f, ymax=%.2f) and ", + "`points_sf` is in %s, so the boundary is taken to be in that CRS. Set ", + "the boundary's CRS explicitly with sf::st_crs() to suppress this."), + caller, bb[["xmin"]], bb[["xmax"]], bb[["ymin"]], bb[["ymax"]], + .fold_crs_label(crs_ll)) + sf::st_set_crs(boundary, crs_ll) +} + + +#' Refuse a `boundary` that is not an sf/sfc layer, naming a tessellation +#' +#' A whole build_tessellation() result passed as `boundary` got a warning +#' about stamping a CRS followed by sf's bare "no applicable method for +#' 'st_crs<-' applied to an object of class \"list\"". .assert_sf() already +#' recognises that list elsewhere; say the same here. +#' +#' @param boundary The argument (may be \code{NULL}). +#' @param caller Function name for the message. +#' @param label Argument name for the message. +#' @keywords internal +#' @noRd +.check_boundary_arg <- function(boundary, caller, label = "boundary") { + if (is.null(boundary) || inherits(boundary, c("sf", "sfc"))) return(invisible()) + stop(sprintf("%s(): `%s` must be an sf or sfc polygon layer%s.", caller, label, + .tess_hint(boundary, "$boundary")), + call. = FALSE) +} + +#' The ".assert_sf()" hint for a whole build_tessellation() result +#' @param x The argument. +#' @param slot The component to name ("$cells" or "$boundary"). +#' @return The hint, with a leading space, or "". +#' @keywords internal +#' @noRd +.tess_hint <- function(x, slot = "$cells") { + if (!inherits(x, c("sf", "sfc")) && is.list(x) && !is.null(x$cells)) + sprintf(" (this looks like a build_tessellation() result; pass its `%s`)", slot) + else "" +} + + +#' Is `crs` a geographic (lon/lat) CRS? +#' @keywords internal +#' @noRd +.is_geographic_crs <- function(crs) { + cc <- tryCatch(sf::st_crs(crs), error = function(e) sf::NA_crs_) + !is.na(cc) && isTRUE(sf::st_is_longlat(cc)) +} + + +#' Return a layer built in a projected CRS in the geographic CRS asked for +#' +#' A geographic \code{crs} names the CRS a tessellation is returned in; the +#' cells are built in metres (see build_tessellation()). Long edges are +#' densified first, to a hundredth of the layer's extent, so a straight edge +#' in the working projection keeps its course in lon/lat instead of being +#' read as a great circle between its two ends. +#' +#' @param x sf layer (or \code{NULL}). +#' @param crs_out The geographic \code{sf::crs}, or \code{NULL} for no change. +#' @keywords internal +#' @noRd +.to_output_crs <- function(x, crs_out) { + if (is.null(x) || is.null(crs_out)) return(x) + bb <- sf::st_bbox(x) + ext <- max(as.numeric(bb["xmax"] - bb["xmin"]), as.numeric(bb["ymax"] - bb["ymin"])) + if (is.finite(ext) && ext > 0) x <- sf::st_segmentize(x, dfMaxLength = ext / 100) + sf::st_transform(x, crs_out) +} + + +#' Project a lon/lat boundary for a grid of equal-area cells +#' +#' The CRS ensure_projected() picks for distances, unless that CRS distorts +#' areas across the boundary by more than \code{.area_error_tol}, in which +#' case the equal-area choice (\code{purpose = "area"}) is used. A UTM zone +#' on a local extent is within a quarter of a percent and is kept, so local +#' grids are unchanged; Web Mercator over near-global extents (whole cells +#' differing five-fold in area) and a zone stretched past its width are not. +#' Projected input is returned as it is. Used by create_grid_polygons() and +#' create_grid_polygons_cached(), so the two lay a grid in the same CRS, and +#' (through .equal_area_grid_crs()) by build_tessellation(). +#' +#' @param boundary sf polygon layer. +#' @param caller Function name for the log line. +#' @keywords internal +#' @noRd +.project_for_grid <- function(boundary, caller = "create_grid_polygons") { + crs0 <- sf::st_crs(boundary) + proj <- ensure_projected(boundary) + lonlat <- .is_longlat(boundary) || + (is.na(crs0) && identical(attr(proj, "crs_assumed"), "EPSG:4326")) + if (!lonlat) return(proj) + src <- if (is.na(crs0)) sf::st_set_crs(boundary, 4326) else boundary + eq <- .equal_area_grid_crs(proj, src, caller) + if (is.null(eq)) return(proj) + if (is.na(crs0)) attr(eq, "crs_assumed") <- "EPSG:4326" + eq +} + + +#' The equal-area layer to lay a grid in, when the distance CRS will not do +#' +#' @param proj The boundary in the automatically chosen (distance) CRS. +#' @param src The same boundary in lon/lat. +#' @param caller Function name for the log line. +#' @return \code{NULL} when the CRS of \code{proj} distorts areas across it by +#' no more than \code{.area_error_tol}; otherwise \code{src} projected with +#' \code{ensure_projected(purpose = "area")}, after a logged warning. +#' @keywords internal +#' @noRd +.equal_area_grid_crs <- function(proj, src, caller) { + err <- .crs_area_error(proj, grid = TRUE) + if (!is.finite(err) || err <= .area_error_tol) return(NULL) + eq <- ensure_projected(src, purpose = "area") + .log_warn(paste0("%s(): %s distorts areas across this boundary by up to %.1f%%, ", + "so its cells would not be equal-area; laying the grid in %s ", + "(ensure_projected(purpose = \"area\")) instead. Pass `crs` ", + "to choose the CRS yourself."), + caller, .fold_crs_label(proj), 100 * err, .fold_crs_label(eq)) + eq +} + # ----------------------------------------------------------------------------- # Clip Target # ----------------------------------------------------------------------------- #' 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 +#' Resolves a single polygon to tessellate within. With a `boundary` it is +#' that boundary (optionally buffered by `expand`); without one it is the +#' axis-aligned bounding box of `points_sf` (the rectangle in the working +#' CRS), again optionally buffered, or a small buffer around the points when +#' they all share one x or one y, or nearly so (the short side of their +#' bounding box below a millionth of the long side). Reach for it to build the +#' `boundary` that +#' `method = "hex"` and `"square"` require, 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. #' +#' It is not the target [build_tessellation()] derives on its own: +#' `method = "voronoi"` without a boundary clips to the convex hull of the +#' points buffered by 2 percent of its diagonal, and there `expand` is always +#' a distance. A bounding box over a non-rectangular point cloud includes +#' corners with no data, so a hex or square grid laid over it has cells that +#' hold no points; pass the study-area polygon when there is one. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometry. -#' @param boundary Optional polygonal sf object. +#' @param boundary Optional polygonal sf object. One with no CRS, given with +#' points that have one, is interpreted in the points' own CRS, with a +#' warning. With points in a projected CRS it is read as [harmonize_crs()] +#' does: coordinates that look like lon/lat are taken as EPSG:4326 and +#' reprojected, anything else is stamped with the points' CRS. With lon/lat +#' points it is read as lon/lat when its coordinates fit the lon/lat +#' envelope, and refused with an error otherwise. #' @param expand Numeric expansion distance or fraction (0–1 = fraction of #' extent). Absolute values are expressed in the units of the CRS the clip #' target is built in. Because [sf::st_buffer()] interprets `dist` as @@ -36,13 +270,14 @@ #' data.frame(x = 5e5 + runif(30, 0, 100), y = 5e6 + runif(30, 0, 100)), #' coords = c("x", "y"), crs = 32632 #' ) -#' # No boundary: the convex hull, expanded by 10% of the extent -#' hull <- clip_target_for(pts, expand = 0.1, quiet = TRUE) -#' st_area(hull) +#' # No boundary: the bounding box, expanded by 10% of the extent +#' box <- clip_target_for(pts, expand = 0.1, quiet = TRUE) +#' st_area(box) #' @export clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALSE) { .msg <- function(...) if (!quiet) message(...) .assert_sf(points_sf, c("POINT", "MULTIPOINT"), "points_sf") + .check_boundary_arg(boundary, "clip_target_for") # .expand_distance() below TOLERATES a malformed `expand` by returning 0, # which turned `expand = c(0.05, 0.05)` into a silent no-op -- the returned # bbox was byte-identical to expand = 0, with no condition raised -- and a @@ -66,7 +301,13 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS # st_buffer() reads `dist` as METRES, so the two disagree by five orders of # magnitude. Project to a local projected CRS first so the distance that is # computed and the distance that is buffered share the same units. The - # boundary is aligned to the projected points immediately below. + # boundary is aligned to the projected points immediately below. A + # CRS-less one is read in the points' OWN lon/lat CRS first: read in the + # projected CRS picked for them, a one-degree tile with integer corners + # became a one-metre box near the zone's origin. + if (!is.null(boundary) && .is_longlat(points_sf) && is.na(sf::st_crs(boundary))) + boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(points_sf), + "clip_target_for") if (.is_longlat(points_sf)) { .msg("clip_target_for(): input is lon/lat; projecting to a local projected ", "CRS so `expand` is measured in projected units. The returned clip ", @@ -77,6 +318,12 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS crs_pts <- sf::st_crs(points_sf) if (!is.null(boundary)) { + # .align_crs() leaves a CRS-less boundary as it is, so the target came + # back with no CRS -- and for lon/lat points, in degrees, with `expand = + # 20` buffering by 20 degrees rather than 20 metres. Interpret it in the + # points' (projected) CRS instead, as build_tessellation() does. + if (is.na(sf::st_crs(boundary)) && !is.na(crs_pts)) + boundary <- .transform_or_stamp(boundary, crs_pts, "boundary", "clip_target_for") boundary <- .align_crs(boundary, points_sf) if (!any(sf::st_geometry_type(boundary) %in% c("POLYGON", "MULTIPOLYGON"))) stop("clip_target_for(): `boundary` must be polygonal.") @@ -90,8 +337,17 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS if (length(pts_geom) == 0) stop("clip_target_for(): `points_sf` is empty.") bb <- sf::st_bbox(pts_geom) - zero_w <- isTRUE(all.equal(as.numeric(bb$xmin), as.numeric(bb$xmax))) - zero_h <- isTRUE(all.equal(as.numeric(bb$ymin), as.numeric(bb$ymax))) + # Degenerate RELATIVE to the extent, not only when all.equal() calls the two + # ends equal: points on a transect with sub-millimetre numerical scatter + # gave a 1000 x 1e-6 sliver, over which a hex or square grid sized by a + # count needed 166,536 cells for 25, or stopped at `max_cells`. + dx <- as.numeric(bb$xmax - bb$xmin) + dy <- as.numeric(bb$ymax - bb$ymin) + span <- max(dx, dy) + zero_w <- isTRUE(all.equal(as.numeric(bb$xmin), as.numeric(bb$xmax))) || + isTRUE(dx <= 1e-6 * span) + zero_h <- isTRUE(all.equal(as.numeric(bb$ymin), as.numeric(bb$ymax))) || + isTRUE(dy <= 1e-6 * span) if (zero_w || zero_h) { .msg("clip_target_for(): degenerate bbox; using small buffer around points.") @@ -218,20 +474,55 @@ clip_target_for <- function(points_sf, boundary = NULL, expand = 0, quiet = FALS #' 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. +#' The generators are the points' vertices, not the features. A MULTIPOINT +#' feature with several vertices therefore gets one cell per vertex, and its +#' `index` entry is the smallest `cell_id` among the cells it touches; the +#' others are referenced by no feature. Other functions in the package +#' ([prep_model_data()], [make_folds()]) reduce such a feature to its +#' centroid instead, so cast to POINT, or take centroids, first if one cell +#' per feature is what you want. +#' +#' @param points_sf An sf object with POINT/MULTIPOINT geometries. Points with +#' no CRS whose coordinates look like lon/lat (the heuristic +#' [ensure_projected()] applies, with its warning) are taken as EPSG:4326 +#' and projected, as lon/lat points are. +#' @param boundary Optional polygonal sf object. When exactly one of +#' `points_sf` and `boundary` has a CRS, the other is interpreted in it, with +#' a warning. CRS-less points, and a CRS-less boundary given with projected +#' points, are read as [harmonize_crs()] does (lon/lat-looking coordinates +#' are reprojected from EPSG:4326, others are stamped); CRS-less points that +#' do not look like lon/lat cannot take a geographic boundary's CRS, and are +#' refused with an error. A CRS-less boundary given with lon/lat points (or +#' with CRS-less points taken as lon/lat) is read as lon/lat when its +#' coordinates fit the lon/lat envelope, and refused with an error +#' otherwise. +#' @param expand Numeric; absolute distance, in the working CRS's units, by +#' which the boundary (or the hull derived from the points) is grown before +#' the diagram is built. With `clip = TRUE` the cells are clipped to the +#' grown boundary, so they reach `expand` beyond the study area, and a point +#' up to `expand` outside it gets a cell and an `index` value. The grown +#' boundary is the one returned as `boundary`. #' @param clip Logical; intersect cells with boundary. -#' @param keep_duplicates Logical; keep coincident points for graph construction. -#' @param crs Optional target CRS. +#' @param keep_duplicates Logical. Has no effect on the result: coincident +#' points are merged before the diagram is built either way, so they share +#' one cell and all of them are indexed to it. +#' @param crs Optional target CRS: anything [sf::st_crs()] accepts, including +#' an sf or sfc layer, whose CRS is used. A projected CRS is the working +#' CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned +#' in: the cells are built in the local projected CRS [ensure_projected()] +#' picks for the points, so they are nearest-point cells on the ground, and +#' are then transformed, with long edges densified. #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. #' @return A list with \code{cells}, \code{index}, \code{boundary}, #' \code{method} and \code{params}. \code{index} holds one \code{cell_id} #' per row of \code{points_sf}, and \code{NA} for a point that falls outside -#' every cell, which means outside the study area, so a summary built from it -#' counts only the points the tessellation actually covers. +#' every cell, which means outside the study area (grown by \code{expand} +#' when it is positive), so a summary built from it counts only the points +#' the tessellation actually covers. \code{boundary} is the boundary the +#' cells were built in: the one supplied or derived, grown by +#' \code{expand}. #' @family tessellation #' @examples #' library(sf) @@ -249,17 +540,56 @@ create_voronoi_polygons <- function( keep_duplicates = FALSE, crs = NULL, quiet = FALSE ) { .assert_sf(points_sf, c("POINT", "MULTIPOINT"), "points_sf") + .check_boundary_arg(boundary, "create_voronoi_polygons") if (nrow(points_sf) < 1) stop("create_voronoi_polygons(): `points_sf` has no rows.") .msg <- function(...) if (!quiet) message(...) + # A layer as `crs` means its CRS (as ensure_projected(target_crs =) reads + # it); passed on as it was, it stopped with "the condition has length > 1". + if (inherits(crs, c("sf", "sfc"))) crs <- sf::st_crs(crs) pts <- points_sf + crs_out <- NULL if (!is.null(crs)) { pts <- .transform_or_stamp(pts, crs, "points_sf", "create_voronoi_polygons") if (!is.null(boundary)) boundary <- .transform_or_stamp(boundary, crs, "boundary", "create_voronoi_polygons") + # A geographic `crs` is where the cells are RETURNED, not where they are + # built: st_voronoi() on degrees is not a nearest-point partition (at + # 55N, 21% of sampled locations sat in another point's cell) and s2 read + # the degree-sized hull buffer below as metres. + if (.is_geographic_crs(crs)) { + crs_out <- sf::st_crs(pts) + pts <- ensure_projected(pts) + if (!is.null(boundary)) boundary <- .align_crs(boundary, pts) + } } else { - if (.is_longlat(pts)) pts <- ensure_projected(pts) - if (!is.null(boundary)) boundary <- .align_crs(boundary, pts) + # A CRS-less boundary with lon/lat points is read in the points' own CRS + # BEFORE they are projected (see .crsless_boundary_as_lonlat()). + if (!is.null(boundary) && .is_longlat(pts) && is.na(sf::st_crs(boundary))) + boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(pts), + "create_voronoi_polygons") + # CRS-less points get the lon/lat heuristic every other entry point + # applies: .is_longlat() is FALSE for a missing CRS, so CRS-less degrees + # were tessellated as planar, silently (18% of locations at 55N in a + # cell that was not their nearest point's), while build_tessellation() + # projected the very same points. + if (.is_longlat(pts) || is.na(sf::st_crs(pts))) pts <- ensure_projected(pts) + if (!is.null(boundary)) { + # A CRS-less boundary with points just taken as lon/lat gets the same + # assumption, when its coordinates allow it, as in build_tessellation(). + if (identical(attr(pts, "crs_assumed"), "EPSG:4326") && + is.na(sf::st_crs(boundary))) + boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(4326), + "create_voronoi_polygons", + assumed = TRUE) + # One side with no CRS takes the other's (.align_crs() leaves it as it + # is, and sf then refused the pair with its bare CRS-mismatch error). + pair <- .resolve_crsless_pair(pts, boundary, "create_voronoi_polygons") + pts <- pair$points; boundary <- pair$boundary + # CRS-less lon/lat points that just took a geographic boundary's CRS. + if (.is_longlat(pts)) pts <- ensure_projected(pts) + boundary <- .align_crs(boundary, pts) + } } if (is.null(boundary)) { @@ -329,9 +659,13 @@ create_voronoi_polygons <- function( attr(index, "snapped") <- NULL list( - cells = cells, + cells = .to_output_crs(cells, crs_out), index = index, - boundary = boundary, + # The boundary the cells were built in and clipped to. With expand > 0 + # that is the grown one: returning the ungrown input described a study + # area the cells overhang by `expand` (1.93 km^2 of cells against a + # returned 1 km^2) and in which indexed points lay outside. + boundary = .to_output_crs(boundary_expanded, crs_out), method = "voronoi", params = list(clip = clip, expand = expand, keep_duplicates = keep_duplicates, snapped = snapped) @@ -360,9 +694,15 @@ create_voronoi_polygons <- function( #' #' @param boundary Polygonal sf or sfc object. #' @param target_cells Optional approximate desired number of cells. The cell -#' \emph{size} is derived from it as \code{sqrt(area / target_cells)}, so -#' square grids get square cells; for hex grids the count is adjusted for -#' hexagonal packing density. The word "approximate" is load bearing: a +#' \emph{size} is derived from it as \code{sqrt(area / target_cells)}, where +#' \code{area} is that of the boundary's bounding box, so square grids get +#' square cells; for hex grids the count is adjusted for hexagonal packing +#' density and the size rounded so that a whole number of hexagon widths +#' spans the longer side of the box. The size does not depend on which way +#' the boundary lies; the count can, because hexagon rows are 0.87 +#' \code{cellsize} apart while columns are \code{cellsize} apart (about 10 +#' percent on a moderately elongated box, up to 1.7 times on a strip +#' narrower than one hexagon). The word "approximate" is load bearing: a #' grid of square cells over an elongated bounding box needs more of them #' than a grid of rectangles would (a 1000 x 1 strip at #' \code{target_cells = 9} yields cells of side 10.5 and about 95 of them), @@ -385,9 +725,20 @@ create_voronoi_polygons <- function( #' 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 -#' grid; a message reports this unless `quiet = TRUE`. +#' @param crs Optional target CRS: anything [sf::st_crs()] accepts, including +#' an sf or sfc layer, whose CRS is used. When `NULL` (default) a lon/lat +#' boundary is projected with [ensure_projected()], which changes the CRS of the returned +#' grid; a message reports this unless `quiet = TRUE`. When that CRS would +#' distort cell areas across the boundary by more than 1 percent (Web +#' Mercator over a near-global extent, a UTM zone stretched well past its +#' width), `ensure_projected(purpose = "area")` is used instead, with a +#' logged warning, so the cells stay equal-area; a local extent keeps its +#' UTM zone. A geographic `crs` (EPSG:4326, say) is the CRS the grid is +#' returned in: a grid sized by `target_cells` or `n` is laid in that +#' projected CRS and then transformed, with long edges densified. A +#' `cellsize` is in the units of `crs`, so with a geographic `crs` it is in +#' degrees and the grid is laid in degrees, as asked; such cells are not +#' equal-area. #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. @@ -423,19 +774,33 @@ create_grid_polygons <- function( .as_sf <- function(x) { if (inherits(x, "sf")) return(x) if (inherits(x, "sfc")) return(sf::st_sf(geometry = x)) - stop("create_grid_polygons(): 'boundary' must be an sf or sfc object.") + stop(paste0("create_grid_polygons(): 'boundary' must be an sf or sfc object", + .tess_hint(x, "$boundary"), ".")) } boundary <- .as_sf(boundary) + # A layer as `crs` means its CRS; passed on as it was, it stopped with "the + # condition has length > 1". + if (inherits(crs, c("sf", "sfc"))) crs <- sf::st_crs(crs) if (!all(as.character(sf::st_geometry_type(boundary, by_geometry = TRUE)) %in% c("POLYGON", "MULTIPOLYGON"))) stop("create_grid_polygons(): 'boundary' must be polygonal (POLYGON/MULTIPOLYGON).") + crs_out <- NULL if (!is.null(crs)) { boundary <- .transform_or_stamp(boundary, crs, "boundary", "create_grid_polygons") + # A geographic `crs` is where the grid is RETURNED. Laid in degrees the + # cells were neither square nor equal-area, and clipping them under s2 + # often stopped with "Edge 0 is degenerate" or left points inside the + # boundary with no cell. An explicit `cellsize` is in the units of + # `crs`, degrees, so a grid sized by it is still laid in degrees. + if (.is_geographic_crs(crs) && is.null(cellsize)) { + crs_out <- sf::st_crs(boundary) + boundary <- .project_for_grid(boundary) + } } else { crs_before <- sf::st_crs(boundary) - boundary <- ensure_projected(boundary) + boundary <- .project_for_grid(boundary) if (!identical(crs_before, sf::st_crs(boundary))) .msg("create_grid_polygons(): projecting `boundary` to a local projected ", "CRS; the returned grid uses that CRS. Pass `crs` to control it.") @@ -527,7 +892,19 @@ create_grid_polygons <- function( cellsize <- c(w / nx, h / ny) } } else { - cellsize <- c(w / nx, h / ny) + # st_make_grid() builds hexagons from cellsize[1] alone, and that was + # w / nx: the WIDTH of the box over a column count rounded, and floored + # at 1, from the aspect ratio. A tall narrow boundary therefore got + # hexagons about as wide as the whole box -- a 1 x 1000 strip at target + # 9 gave 1734 of them where the same strip lying flat gave 89. Count + # along the LONGER side instead. For a boundary at least as wide as it + # is tall that is exactly w / nx, so those grids are unchanged; a tall + # one now gets hexagons of the same size as its lying-down twin (the + # counts still differ, since hexagon rows and columns are spaced + # differently). + long <- max(w, h) + side <- long / max(1L, round(sqrt(effective_target * long / min(w, h)))) + cellsize <- c(side, side) } } @@ -555,18 +932,40 @@ create_grid_polygons <- function( # first (hex cells are ~15% smaller, so the estimate is inflated by that). n_est <- ceiling(w / cellsize[1L]) * ceiling(h / cellsize[2L]) if (identical(type, "hex")) n_est <- n_est / (sqrt(3) / 2) - if (is.finite(max_cells) && n_est > max_cells) + if (is.finite(max_cells) && n_est > max_cells) { + # Name the argument that set the size. The advice about the units of + # `cellsize` was given when the size had been derived from `target_cells` + # (build_tessellation()'s `approx_n_cells`) or `n`, which the caller had + # passed instead: a count of 25 over a near-degenerate sliver. + advice <- if (cellsize_supplied) { + sprintf(paste0("Check that `cellsize` is in the boundary's CRS units ", + "(%s), or raise `max_cells` if the count is intended."), + sf::st_crs(boundary)$units_gdal %||% "unknown") + } else if (!is.null(target_cells)) { + sprintf(paste0("That size was derived from `target_cells` = %s ", + "(`approx_n_cells` in build_tessellation())%s. Pass ", + "`cellsize`, or raise `max_cells` if the count is intended."), + format(target_cells), + if (n_est > 2 * target_cells) + paste0(": square or hexagonal cells over a very elongated ", + "bounding box need far more of them than the count asked for") + else "") + } else { + sprintf(paste0("That size was derived from `n` = %s. Pass a smaller `n` ", + "or a `cellsize`, or raise `max_cells` if the count is ", + "intended."), + paste(n, collapse = " x ")) + } stop(sprintf(paste0("create_grid_polygons(): a cell size of %s x %s on a ", "boundary of %s x %s would produce about %s cells, above ", - "`max_cells` = %s. Check that `cellsize` is in the ", - "boundary's CRS units (%s), or raise `max_cells` if the ", - "count is intended."), + "`max_cells` = %s. %s"), format(cellsize[1L], digits = 4), format(cellsize[2L], digits = 4), format(w, digits = 4), format(h, digits = 4), format(n_est, big.mark = ",", scientific = FALSE, digits = 3), format(max_cells, big.mark = ",", scientific = FALSE), - sf::st_crs(boundary)$units_gdal %||% "unknown"), + advice), call. = FALSE) + } grid_args <- list(x = env, what = "polygons", square = identical(type, "square")) @@ -612,7 +1011,7 @@ create_grid_polygons <- function( grid_sf <- grid_sf[keep, , drop = FALSE] grid_sf$poly_id <- seq_len(nrow(grid_sf)) } - grid_sf + .to_output_crs(grid_sf, crs_out) } # ----------------------------------------------------------------------------- @@ -642,6 +1041,12 @@ create_grid_polygons <- function( #' \code{\link{determine_optimal_levels}()} will suggest a cell count from the #' spatial structure of the data. #' +#' \code{"voronoi"} and \code{"triangles"} are built on the points' vertices: +#' a MULTIPOINT feature with several vertices gets one cell (or triangle +#' corner) per vertex, and its \code{index} entry is the smallest +#' \code{cell_id} among the cells it touches. See +#' \code{\link{create_voronoi_polygons}()}. +#' #' @param points_sf An sf object with POINT/MULTIPOINT geometry. #' @param boundary Polygonal sf/sfc study area. **Required** for #' `method = "hex"` and `method = "square"`, which have no extent of their @@ -649,7 +1054,18 @@ create_grid_polygons <- function( #' 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`. +#' `clip = TRUE`. When exactly one of `points_sf` and `boundary` has a CRS, +#' the other is interpreted in it, with a warning. CRS-less points, and a +#' CRS-less boundary given with projected points, are read as +#' [harmonize_crs()] does; CRS-less points that do not look like lon/lat +#' cannot take a geographic boundary's CRS and are refused with an error. A +#' CRS-less boundary given with lon/lat points is read as lon/lat when its +#' coordinates fit the lon/lat envelope, and refused with an error +#' otherwise. When neither has one, both are read by the lon/lat heuristic +#' of [ensure_projected()]: taken as EPSG:4326 and projected when the points +#' look like degrees (a boundary whose coordinates do not fit the lon/lat +#' envelope is then refused with an error), otherwise left in the same +#' unnamed planar space. #' @param method One of "voronoi", "triangles", "hex", "square". #' @param approx_n_cells Approximate number of cells. Read by #' \code{method = "hex"} and \code{"square"} only: \code{"voronoi"} grows @@ -666,18 +1082,50 @@ create_grid_polygons <- function( #' \code{select_resolution()} at its default criterion). The count used #' is returned as \code{params$approx_n_cells} and where it came from as #' \code{params$approx_n_cells_from} (\code{NULL} for a plain number). +#' A count read off a profile or selection is a number of k-means cells: +#' every one occupied, and small where the points are dense. A lattice +#' lays that many equal cells over the whole boundary, so on clustered +#' points many of them hold no point (about half, on six clusters in a +#' square); on evenly spread points it matches. \code{params$cells_occupied} +#' and \code{params$cells_empty} report how the points filled the grid, and +#' a count that came from a profile or selection warns when fewer than +#' three quarters of it are occupied. For cells that follow the points, +#' seed a Voronoi tessellation with +#' \code{get_voronoi_seeds(method = "kmeans", n = , sample_points = )}. #' @param cellsize Numeric cell size, in the units of the working CRS. Read by #' \code{method = "hex"} and \code{"square"} only; the other two methods warn #' that it was ignored. When both \code{cellsize} and \code{approx_n_cells} #' are given, \code{cellsize} wins and \code{approx_n_cells} is ignored with -#' a logged warning; supply one or the other. -#' @param expand Buffer distance for the Voronoi envelope. Applied by +#' a logged warning; supply one or the other. With a geographic \code{crs} +#' it is in that CRS's degrees, and the grid is laid in degrees. +#' @param expand Buffer distance, in the working CRS's units, by which the +#' Voronoi boundary is grown before the diagram is built. Applied by #' `method = "voronoi"` only; the `"hex"`, `"square"` and `"triangles"` #' methods ignore it (the value you passed is still echoed back in -#' `params$expand`). +#' `params$expand`). With `clip = TRUE` the cells are clipped to the grown +#' boundary, which is the one returned as `boundary`: cells reach `expand` +#' beyond the study area, and a point up to `expand` outside it is indexed. #' @param clip Logical; clip to boundary. -#' @param keep_duplicates Logical; keep duplicate points. -#' @param crs Optional target CRS. +#' @param keep_duplicates Logical. Has no effect on the cells or the index: +#' coincident points are merged before a Voronoi diagram or a Delaunay +#' triangulation is built either way, and every one of them is indexed to +#' the cell they share. +#' @param crs Optional target CRS: anything [sf::st_crs()] accepts, including +#' an sf or sfc layer, whose CRS is used. A projected CRS is the working +#' CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned +#' in: the cells are built in the local projected CRS [ensure_projected()] +#' picks for the points, indexed there, and then transformed with long edges +#' densified, so Voronoi cells are nearest-point cells on the ground and +#' grid cells are laid in metres rather than degrees. The exception is a hex +#' or square grid sized by `cellsize`, which is in degrees and so is laid in +#' degrees. Whenever that local CRS is picked for lon/lat points, or +#' CRS-less ones taken as lon/lat (no `crs`, or a geographic one), a hex or +#' square grid with a boundary is laid in it unless it +#' distorts areas across the boundary by more than 1 percent (Web Mercator +#' over a near-global extent, say); the grid is then laid, and the points +#' indexed, in the equal-area CRS `ensure_projected(purpose = "area")` picks +#' for the boundary, with a logged warning, as [create_grid_polygons()] +#' does, so the cells stay equal-area. #' @param quiet Logical; suppress this function's progress \code{message()}s. #' It does not silence R warnings, nor the package's console log echo #' (see \code{\link{spatialkit_quiet}} for that). Default \code{FALSE}. @@ -693,12 +1141,15 @@ create_grid_polygons <- function( #' sitting exactly on a shared edge, and leaves points outside the study #' area as `NA`. A summary built from `index` therefore counts only the #' points the tessellation actually covers.} -#' \item{`boundary`}{The boundary used (possibly derived and/or reprojected).} +#' \item{`boundary`}{The boundary used (possibly derived and/or +#' reprojected, and for `"voronoi"` grown by `expand`).} #' \item{`method`}{The method actually used.} #' \item{`params`}{The parameters the tessellation was built with, plus #' `snapped`, the record of that nearest-cell repair: a list with `n`, #' `which` (row positions in `points_sf`) and `distance` (how far -#' outside every cell each sat, in CRS units).} +#' outside every cell each sat, in CRS units). For `"hex"` and +#' `"square"` also `cells_occupied` and `cells_empty`, the number of +#' cells that hold at least one point and that hold none.} #' } #' @family tessellation #' @examples @@ -719,7 +1170,26 @@ build_tessellation <- function( ) { .msg <- function(...) if (!quiet) message(...) method <- match.arg(method) - .assert_sf(points_sf, c("POINT", "MULTIPOINT"), "points_sf") + # Polygon or line features are refused here, although make_folds(), + # resolution_profile() and the other steps of the pipeline reduce them to + # points on their own: say how to proceed, not only what was found. + tryCatch(.assert_sf(points_sf, c("POINT", "MULTIPOINT"), "points_sf", + caller = "build_tessellation"), + error = function(e) { + gt <- if (inherits(points_sf, "sf")) + as.character(sf::st_geometry_type(points_sf, by_geometry = TRUE)) + hint <- if (any(gt %in% c("POLYGON", "MULTIPOLYGON", "LINESTRING", + "MULTILINESTRING"))) + paste0(" Reduce polygon or line features to points first, e.g. ", + "coerce_to_points(points_sf, \"auto\"), as make_folds() ", + "and resolution_profile() do.") + else "" + stop(paste0(conditionMessage(e), hint), call. = FALSE) + }) + .check_boundary_arg(boundary, "build_tessellation") + # A layer as `crs` means its CRS (as ensure_projected(target_crs =) reads + # it); passed on as it was, it stopped with "the condition has length > 1". + if (inherits(crs, c("sf", "sfc"))) crs <- sf::st_crs(crs) # The level-selection step's own answer is accepted here, so the count # need not be carried between the two calls by hand. @@ -735,21 +1205,22 @@ build_tessellation <- function( # case -- with nothing to say 25 had been asked for. Warn rather than stop: # the call still produces a valid tessellation, just not the one intended. # - # The `params` clause is voronoi-only on purpose. That branch returns - # create_voronoi_polygons()'s own list, which has no slot for either - # argument; the triangles branch does echo `approx_n_cells` back (but not - # `cellsize`), so claiming otherwise for it would be false. + # Neither method records the ignored request in `params`: the voronoi + # branch returns create_voronoi_polygons()'s own list, which has no slot + # for either argument, and the triangles branch no longer echoes + # `approx_n_cells` back (a count that sized nothing, beside the "count + # used" the documentation says `params$approx_n_cells` holds). if (!method %in% c("hex", "square")) { ignored <- c(if (!is.null(approx_n_cells)) "approx_n_cells", if (!is.null(cellsize)) "cellsize") if (length(ignored) > 0L) .warn_and_log( - "build_tessellation(method = \"%s\") ignores the grid-sizing %s %s. %s", + "build_tessellation(method = \"%s\") ignores the grid-sizing %s %s. `params` does not record the request either. %s", method, if (length(ignored) > 1L) "arguments" else "argument", paste(sprintf("`%s`", ignored), collapse = " and "), if (identical(method, "voronoi")) - paste("`params` does not record the request either. Voronoi grows", + paste("Voronoi grows", "one cell per input point: to control the cell count, place", "seeds with get_voronoi_seeds() and tessellate those, or use", "method = \"hex\" or \"square\".") @@ -760,10 +1231,36 @@ build_tessellation <- function( } # --- CRS handling --- + crs_out <- NULL + # Set when the working CRS is one ensure_projected() picked for lon/lat + # points: a hex or square grid then gets the equal-area check below. + lonlat_work <- FALSE + boundary_ll <- NULL # the boundary before alignment, for that check + pts_out <- NULL # the points in `crs_out`, for the triangles + projected_msg <- FALSE if (!is.null(crs)) { points_sf <- .transform_or_stamp(points_sf, crs, "points_sf", "build_tessellation") if (!is.null(boundary)) boundary <- .transform_or_stamp(boundary, crs, "boundary", "build_tessellation") + # A geographic `crs` names the CRS the result is RETURNED in; the cells + # are built in metres. st_voronoi(), st_make_grid() and the hull buffer + # all work on raw coordinates, so in degrees Voronoi cells stopped being + # a nearest-point partition (21% of sampled locations at 55N sat in + # another point's cell), grid cells were neither square nor equal-area, + # and clipping them under s2 often stopped with "Edge 0 is degenerate" + # or gave points inside the boundary an NA index. Build in the local + # projected CRS, index there, and transform at the end (finish() below). + # An explicit `cellsize` is in the units of `crs`, degrees, so a lattice + # sized by it is still laid in degrees, as asked. + if (.is_geographic_crs(crs) && + !(method %in% c("hex", "square") && !is.null(cellsize))) { + crs_out <- sf::st_crs(points_sf) + pts_out <- points_sf + boundary_ll <- boundary + points_sf <- ensure_projected(points_sf) + lonlat_work <- TRUE + if (!is.null(boundary)) boundary <- .align_crs(boundary, points_sf) + } } else { # ONE decision for points and boundary together. A CRS-less layer goes # through the same lon/lat heuristic as everywhere else; if it is taken as @@ -774,25 +1271,78 @@ build_tessellation <- function( # were, boundary projected inside create_grid_polygons() -- put grid and # points in different CRSs and hex/square died in st_intersects() on # input that voronoi/triangles accepted. - if (.is_longlat(points_sf)) { - .msg("build_tessellation(): projecting points to a local UTM CRS.") + lonlat_in <- .is_longlat(points_sf) + # A CRS-less boundary given with lon/lat points is read in the points' OWN + # CRS, before they are projected. Resolved afterwards, against the + # projected CRS picked for them, a one-degree tile with integer corners + # (which the lon/lat heuristic declines) was stamped with that UTM zone, + # read as a one-metre square, and every point was indexed NA. + if (!is.null(boundary) && lonlat_in && is.na(sf::st_crs(boundary))) + boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(points_sf), + "build_tessellation") + if (lonlat_in || is.na(sf::st_crs(points_sf))) points_sf <- ensure_projected(points_sf) - } else if (is.na(sf::st_crs(points_sf))) { - points_sf <- ensure_projected(points_sf) - } + projected_msg <- lonlat_in + assumed <- attr(points_sf, "crs_assumed") + lonlat_work <- lonlat_in || identical(assumed, "EPSG:4326") if (!is.null(boundary)) { - assumed <- attr(points_sf, "crs_assumed") - if (!is.null(assumed) && is.na(sf::st_crs(boundary))) - boundary <- sf::st_set_crs(boundary, sf::st_crs(assumed)) + # Only a POSITIVE assumption is a CRS. ensure_projected() records + # "none" for CRS-less points it left planar, and st_crs("none") is an + # error ("invalid crs: none"), so every method failed on CRS-less + # planar points with a CRS-less boundary -- including the documented + # boundary = clip_target_for(pts) -- and such data could not be gridded + # at all. Left alone, the two stay in the same unnamed space. The + # positive assumption is given to the boundary only when its + # coordinates can be degrees: one in metres was stamped EPSG:4326, + # transformed to nothing, and refused as "not polygonal". + if (identical(assumed, "EPSG:4326") && is.na(sf::st_crs(boundary))) + boundary <- .crsless_boundary_as_lonlat(boundary, sf::st_crs(4326), + "build_tessellation", assumed = TRUE) + # One side with no CRS takes the other's; .align_crs() leaves a + # CRS-less side as it is, and sf then stopped every method with its + # bare "st_crs(x) == st_crs(y) is not TRUE". + pair <- .resolve_crsless_pair(points_sf, boundary, "build_tessellation") + points_sf <- pair$points; boundary <- pair$boundary + if (lonlat_work) boundary_ll <- boundary boundary <- .align_crs(boundary, points_sf) } } + finish <- function(res) { + if (is.null(crs_out)) return(res) + res$cells <- .to_output_crs(res$cells, crs_out) + res$boundary <- .to_output_crs(res$boundary, crs_out) + res + } if (!is.null(boundary)) { if (!any(sf::st_geometry_type(boundary) %in% c("POLYGON", "MULTIPOLYGON"))) stop("build_tessellation(): `boundary` must be polygonal.") boundary <- .safe_make_valid(boundary) } + # A lattice over lon/lat data is laid where create_grid_polygons() would lay + # it: in the CRS picked for the points unless that CRS distorts areas across + # the boundary by more than .area_error_tol, and then in the equal-area one. + # The CRS picked for the points is a DISTANCE choice, and handed to + # create_grid_polygons() as `crs` it skipped that check: on a near-global + # boundary the hexagons were laid in Web Mercator, whole cells differing + # 5.75-fold in true area, where create_grid_polygons() on the same boundary + # used Equal Earth (0.7%). The points are indexed in the same CRS. + if (lonlat_work && method %in% c("hex", "square") && !is.null(boundary)) { + src <- if (!is.null(boundary_ll) && .is_longlat(boundary_ll)) boundary_ll + else sf::st_transform(boundary, 4326) + eq <- .equal_area_grid_crs(boundary, src, "build_tessellation") + if (!is.null(eq)) { + boundary <- .safe_make_valid(eq) + attr(boundary, "crs_choice") <- NULL + points_sf <- sf::st_transform(points_sf, sf::st_crs(eq)) + } + } + # Named after the choice is made: the message said "a local UTM CRS" + # whatever ensure_projected() had picked (Albers for North Carolina). + if (projected_msg) + .msg(sprintf("build_tessellation(): projecting points to %s.", + .fold_crs_label(points_sf))) + # A CRS-less `points_sf` yields NA_crs_, which is a list rather than NULL and # so is not treated as "no CRS supplied" downstream -- create_voronoi_polygons() # would call st_transform() on a CRS-less object and fail. Normalise to NULL. @@ -801,11 +1351,11 @@ build_tessellation <- function( # ---- Voronoi ---- if (identical(method, "voronoi")) { - return(create_voronoi_polygons( + return(finish(create_voronoi_polygons( points_sf = points_sf, boundary = boundary, expand = expand, clip = clip, keep_duplicates = keep_duplicates, crs = crs_arg, quiet = quiet - )) + ))) } # ---- Hex / Square ---- @@ -841,14 +1391,37 @@ build_tessellation <- function( snapped <- attr(index, "snapped") attr(index, "snapped") <- NULL - return(list( + # How the points filled the lattice. A count read off resolution_profile() + # or select_resolution() is a number of k-means cells: all occupied, small + # where the points are dense. The same number of EQUAL cells over the + # boundary leaves the gaps between clusters empty -- on six clusters in a + # square, 33 of 77 hexagons held a point for a profile count of 56 -- and + # nothing said so. Report occupancy always, and warn when a count that + # came from a profile or selection leaves under three quarters occupied + # (evenly spread points fill 1.2 times the count). + occupied <- length(unique(index[!is.na(index)])) + if (!is.null(approx_n_cells_from) && is.null(cellsize) && + occupied < 0.75 * approx_n_cells) + .warn_and_log(paste0( + "build_tessellation(method = \"%s\"): %d of the %d cells hold a point, ", + "against %s cells from %s. That count is of k-means cells, every one ", + "occupied and dense where the points are; a lattice of equal cells ", + "over clustered points leaves many empty. For cells that follow the ", + "points, place seeds with get_voronoi_seeds(method = \"kmeans\", n = ", + ", sample_points = ) and use method = ", + "\"voronoi\"."), + method, occupied, nrow(grid), format(approx_n_cells), approx_n_cells_from) + + return(finish(list( cells = grid, index = index, boundary = boundary, method = method, params = list(approx_n_cells = approx_n_cells, approx_n_cells_from = approx_n_cells_from, cellsize = cellsize, clip = clip, keep_duplicates = keep_duplicates, - expand = expand, snapped = snapped) - )) + expand = expand, snapped = snapped, + cells_occupied = occupied, + cells_empty = nrow(grid) - occupied) + ))) } # ---- Delaunay triangles ---- @@ -856,10 +1429,47 @@ build_tessellation <- function( pts <- if (isTRUE(keep_duplicates)) points_sf else .dedup_points(points_sf) if (nrow(pts) < 3L) stop("build_tessellation(triangles): need at least 3 unique points.") coords <- sf::st_coordinates(pts)[, 1:2, drop = FALSE] + # An EMPTY point (a null geometry read from a file) is an all-NA row here, + # and the rank check below stopped on it with R's "NA/NaN/Inf in foreign + # function call (arg 1)", where the other methods index it NA. Only the + # coordinates are filtered: for MULTIPOINT input they are one row per + # vertex, so they cannot index `pts`, which is used below only for its + # CRS and for st_union(), which drops empty points anyway. + coords <- coords[stats::complete.cases(coords) & is.finite(coords[, 1L]) & + is.finite(coords[, 2L]), , drop = FALSE] + if (nrow(coords) < 3L) + stop("build_tessellation(triangles): need at least 3 unique points.") + # Points on one line have no triangulation. qhull returned a 0 x 3 + # matrix without an error, the fallback below then logged that + # delaunayn() had failed, which it had not, and the call returned no cells + # and an index of NAs (a single transect, 10 points on y = 0.5x). Say so, + # as the three-point rule above does. + if (qr(scale(coords, scale = FALSE))$rank < 2L) + stop("build_tessellation(triangles): the points are collinear, so their ", + "Delaunay triangulation is empty. Use method = \"voronoi\", which ", + "handles points on a line.", call. = FALSE) tri_sfc <- NULL + why_geos <- "package 'geometry' is not installed" if (requireNamespace("geometry", quietly = TRUE)) { - tri_idx <- try(geometry::delaunayn(coords), silent = TRUE) + # Centre the points before qhull sees them. It triangulates by lifting + # each point onto x^2 + y^2, and at projected magnitudes (a UTM + # northing near 5e6, or 9e6 south of the equator) the lift has no + # precision left to separate points a few metres apart: they were + # dropped as "coplanar" and never became vertices, with nothing said. + # 200 points over 100 m at (5e5, 5e6) gave 26 triangles instead of 386, + # yet every point still fell in one. Translation does not change the + # Delaunay triangulation. The shift is the bbox midpoint, not the + # mean: min and max do not depend on row order, so a permuted layer + # hands qhull bit-identical coordinates and gets the same triangles + # and cell_ids, as before. Rings below use the original coordinates, + # so the output coordinates are untouched. + ctr <- (apply(coords, 2L, min) + apply(coords, 2L, max)) / 2 + tri_idx <- try(geometry::delaunayn(sweep(coords, 2L, ctr)), silent = TRUE) + why_geos <- if (inherits(tri_idx, "try-error")) + sprintf("geometry::delaunayn() failed (%s)", + trimws(conditionMessage(attr(tri_idx, "condition")))) + else "geometry::delaunayn() returned no triangles" if (!inherits(tri_idx, "try-error") && length(tri_idx)) { polys <- vector("list", nrow(tri_idx)) for (i in seq_len(nrow(tri_idx))) { @@ -879,15 +1489,23 @@ build_tessellation <- function( } if (is.null(tri_sfc)) { - .log_warn( - "build_tessellation(triangles): package 'geometry' unavailable or delaunayn() failed. Falling back to GEOS via sf::st_triangulate() instead of qhull; the result is still the Delaunay triangulation of the input points, but degenerate (e.g. co-circular) configurations may be resolved differently." - ) + # Name the reason that applies: the message used to blame a missing + # package or a failure whichever had happened. + .log_warn(paste0( + "build_tessellation(triangles): %s. Falling back to GEOS via ", + "sf::st_triangulate() instead of qhull; the result is still the ", + "Delaunay triangulation of the input points, but degenerate (e.g. ", + "co-circular) configurations may be resolved differently."), why_geos) # st_triangulate() accepts a MULTIPOINT and returns the true Delaunay # triangulation of it. Triangulating the convex-hull POLYGON instead # (as this used to) discards every interior point. tri_sfc <- sf::st_triangulate(sf::st_union(sf::st_geometry(pts))) tri_sfc <- sf::st_collection_extract(tri_sfc, "POLYGON", warn = FALSE) tri_sfc <- sf::st_sfc(tri_sfc, crs = sf::st_crs(pts)) + if (length(tri_sfc) == 0L) + stop("build_tessellation(triangles): the Delaunay triangulation of ", + "these points is empty (they are collinear to within rounding). ", + "Use method = \"voronoi\".", call. = FALSE) } tri_sf <- sf::st_sf(geometry = .safe_make_valid(tri_sfc)) @@ -909,13 +1527,28 @@ build_tessellation <- function( snapped <- attr(index, "snapped") attr(index, "snapped") <- NULL - return(list( + # `approx_n_cells` sized nothing here (the call warned that it was + # ignored), so it is not recorded as the count used; see the warning. + res <- finish(list( cells = tri_sf, index = index, boundary = boundary, method = "triangles", - params = list(clip = clip, approx_n_cells = approx_n_cells, - approx_n_cells_from = approx_n_cells_from, - keep_duplicates = keep_duplicates, expand = expand, - snapped = snapped) + params = list(clip = clip, keep_duplicates = keep_duplicates, + expand = expand, snapped = snapped) )) + # The corners of a triangle are the points themselves. After the round + # trip through the working projection they sit ~1e-14 degrees off the + # input points, and on the returned lon/lat layer a spatial join no longer + # reproduced `index`: 6 of 150 points touched no triangle and 74 were + # outside the one indexed. Put the corners back on the input points. + # sf refuses st_snap() on lon/lat, so it runs on the bare numbers: at a + # tolerance of 1e-10 degrees (about 10 micrometres) planar and + # geodesic distance do not differ. + if (!is.null(pts_out) && nrow(res$cells) > 0L) { + anchor <- sf::st_union(sf::st_set_crs(sf::st_geometry(pts_out), NA)) + g <- sf::st_snap(sf::st_set_crs(sf::st_geometry(res$cells), NA), anchor, + tolerance = 1e-10) + sf::st_geometry(res$cells) <- sf::st_set_crs(.safe_make_valid(g), crs_out) + } + return(res) } stop("build_tessellation(): unknown method.") diff --git a/R/utils.R b/R/utils.R index 0430a9e..2915366 100644 --- a/R/utils.R +++ b/R/utils.R @@ -79,9 +79,14 @@ ll$bb[["ymin"]], ll$bb[["ymax"]]) return(sf::st_transform(sf::st_set_crs(x, 4326), crs)) } + # Named by its label: most callers have no `crs` argument, so "the + # supplied `crs`" sent the reader looking for one they had not passed. + lbl <- tryCatch(sf::st_crs(crs)$input, error = function(e) NULL) + lbl <- if (is.character(lbl) && length(lbl) == 1L && !is.na(lbl) && nzchar(lbl)) + sprintf("the target CRS ('%s')", lbl) else "the target CRS" .warn_and_log( - "%s(): `%s` has no CRS and its coordinates do not look like lon/lat, so it cannot be reprojected; stamping the supplied `crs` WITHOUT reprojection. Verify the coordinates are already expressed in that CRS, or set the input CRS with sf::st_crs().", - caller, what) + "%s(): `%s` has no CRS and its coordinates do not look like lon/lat, so it cannot be reprojected; stamping %s WITHOUT reprojection. Verify the coordinates are already expressed in that CRS, or set the input CRS with sf::st_crs().", + caller, what, lbl) return(sf::st_set_crs(x, crs)) } sf::st_transform(x, crs) @@ -100,11 +105,37 @@ } +# The one place the package hands a line to logger. Every helper formats its +# message with sprintf() first, so it is marked skip_formatter(): no formatter +# on any index -- including one logger copied into this namespace from a +# user's global configuration -- gets to read a `%` or a `{` in it as syntax. +# And a log line is never worth the computation that produced it. An +# appender that fails (a session temp directory deleted under the file trace, +# a user's own appender that throws) is swallowed here rather than aborting +# the caller, so the R warning .warn_and_log() raises next still arrives. +# `raising` tells the console appender that the line is about to be raised as +# an R warning too; see .sk_console_appender() in zzz.R. +.sk_log_state <- new.env(parent = emptyenv()) +.sk_log <- function(level, msg, raising = FALSE) { + .sk_log_state$raising <- raising + on.exit(.sk_log_state$raising <- FALSE, add = TRUE) + tryCatch(logger::log_level(level, logger::skip_formatter(msg), + namespace = "spatialkit"), + error = function(e) NULL) + invisible(msg) +} + + #' Structured warning via logger #' @keywords internal #' @noRd .log_warn <- function(fmt, ...) { - logger::log_warn(sprintf(fmt, ...), namespace = "spatialkit") + # A caution that is also raised as an R warning goes through + # .warn_and_log(), which marks its line `raising`, so a knitted document + # shows it once, as the warning, rather than as a message and a warning. + # A line logged here is a caution only, and reaches the document as a + # message (see .sk_console_appender()). + .sk_log(logger::WARN, sprintf(fmt, ...)) } # A warning about a CHOICE, logged once per session under `key`. A choice @@ -177,7 +208,10 @@ #' @noRd .warn_and_log <- function(fmt, ...) { msg <- sprintf(fmt, ...) - logger::log_warn(msg, namespace = "spatialkit") + # Logged first, so the trace keeps the line even when the caller catches + # the warning with tryCatch(); .sk_log() cannot fail, so the warning + # always follows. + .sk_log(logger::WARN, msg, raising = TRUE) warning(msg, call. = FALSE) invisible(msg) } @@ -187,7 +221,7 @@ #' @keywords internal #' @noRd .log_info <- function(fmt, ...) { - logger::log_info(sprintf(fmt, ...), namespace = "spatialkit") + .sk_log(logger::INFO, sprintf(fmt, ...)) } @@ -345,7 +379,12 @@ #' `MAPE` and `SMAPE` were averaged over: both have a denominator that can be #' zero, and each drops the rows where its own denominator vanishes (`MAPE` #' where `y == 0`, `SMAPE` where `|y| + |yhat| == 0`), returning `NA` only -#' when no row qualifies. `n_MAPE` and `n_SMAPE` are the row counts each was +#' when no row qualifies. "Zero" is relative to the data, as for every +#' metric here: a denominator no larger than `100 * .Machine$double.eps` +#' times the largest one, and, for `R2`, a total sum of squares whose RMS +#' deviation is no larger than that fraction of the RMS of `y` (then `R2` +#' is `NA`). The result therefore does not depend on the response's units. +#' `n_MAPE` and `n_SMAPE` are the row counts each was #' actually averaged over, so that a percentage error over a subset is #' labelled as one; they equal `n` whenever no row was dropped, and are `0` #' in the empty frame. They sit last so that code addressing the first seven @@ -383,16 +422,28 @@ rmse <- sqrt(rss / n) mae <- mean(abs(y - yhat)) - nz <- abs(y) > .Machine$double.eps * 100 + # "Zero" means zero at the scale of the data, 100 machine epsilons of its + # magnitude, for every metric. The thresholds were absolute (1e-14 for a + # denominator, var(y) > 2.2e-16 for R2), so a response in small units -- + # sd below about 1.5e-8 -- lost its R2 while RMSE and MAE were fine, and + # select_features_forward(metric = "R2") then selected nothing. A constant + # response still has a TSS of exactly 0 (or of rounding noise, below the + # threshold), so its R2 stays NA. + tol <- 100 * .Machine$double.eps + nz <- abs(y) > tol * max(abs(y)) mape <- if (any(nz)) mean(abs((y[nz] - yhat[nz]) / y[nz])) * 100 else NA_real_ denom <- abs(y) + abs(yhat) - smape_ok <- denom > .Machine$double.eps * 100 + smape_ok <- denom > tol * max(denom) smape <- if (any(smape_ok)) { mean(2 * abs(y[smape_ok] - yhat[smape_ok]) / denom[smape_ok]) * 100 } else NA_real_ - r2 <- if (tss > .Machine$double.eps * n) 1 - rss / tss else NA_real_ + # TSS against the squared magnitude of y: R2 needs the spread about the + # baseline to exceed rounding, i.e. an RMS deviation above tol times the + # RMS of y. (Relative to sum(y^2) itself, not squared tol, it would turn + # R2 NA for an ordinary response on a large offset, 1e8 +- 0.1.) + r2 <- if (tss > tol^2 * sum(y^2)) 1 - rss / tss else NA_real_ adj_r2 <- NA_real_ if (!is.null(p) && is.finite(r2) && n > (p + 1L)) { @@ -641,19 +692,36 @@ # for "sf": methods::as(x, "Spatial") -- which .to_sp() calls on its way into # GWmodel -- and terra::vect() and friends look the class up in the S4 table, # and an unregistered class ahead of "sf" fails them with "no method or -# default for coercing". Registering only the chain up to "sf" is deliberate: -# sf itself registers c("sf", "data.frame"), and naming "data.frame" here as -# well is rejected as inconsistent with that. +# default for coercing". The class now goes after "sf" (see below), but a +# layer built by an earlier version, read back from an .rds, has it first. +# Registering only the chain up to "sf" is deliberate: sf itself registers +# c("sf", "data.frame"), and naming "data.frame" here as well is rejected as +# inconsistent with that. setOldClass(c("spatialkit_rows", "sf")) .row_record_attrs <- c("dropped", "ties") # Attach `value` as the `which` record of `x`, stamped and classed. +# +# The class goes right after "sf", not ahead of it. vctrs -- behind +# dplyr::bind_rows(), vctrs::vec_rbind() and dplyr::union_all() -- reads the +# first class, and an unknown one ahead of "sf" sent two layers with the same +# record (bind_rows(a, a), or two equal-sized batches) down its same-type +# path into its sf restore method, which failed with 'attr(obj, "sf_column") +# does not point to a geometry column'. After "sf", vctrs binds an sf, and +# the result carries no record: it describes neither input's rows. `[` +# still removes the record, reaching `[.spatialkit_rows` through the +# NextMethod() in sf's own `[` method, as it always did for the output of +# sf::st_transform(), which puts "sf" first. .set_row_record <- function(x, which, value) { value$n_rows <- as.integer(nrow(x)) attr(x, which) <- value - if (!inherits(x, "spatialkit_rows")) - class(x) <- c("spatialkit_rows", class(x)) + if (!inherits(x, "spatialkit_rows")) { + cl <- class(x) + at <- match("sf", cl) + class(x) <- if (is.na(at)) c("spatialkit_rows", cl) + else append(cl, "spatialkit_rows", after = at) + } x } @@ -677,10 +745,24 @@ setOldClass(c("spatialkit_rows", "sf")) #' attribute recording what happened to its rows (\code{"dropped"} and #' \code{"ties"} respectively). Those records describe the rows the layer was #' built with, and \code{[} on an \code{sf} object copies attributes through -#' unchanged, which would leave a subset reporting its parent's numbers with -#' row positions that no longer resolve. Subsetting therefore returns a plain -#' layer with the record removed; read the record from the layer the function -#' returned, before subsetting it. +#' unchanged, which would leave a subset reporting its parent's numbers for a +#' different set of rows. Subsetting therefore returns a plain layer with the +#' record removed, and so do the \pkg{dplyr} verbs that select or reorder +#' rows (\code{filter()}, \code{slice()}, \code{arrange()}, +#' \code{distinct()}); read the record from the layer the function returned, +#' before subsetting it. Binding such layers (\code{rbind()}, +#' \code{dplyr::bind_rows()}) likewise returns a plain \code{sf} layer. +#' +#' Each record carries \code{n_rows}, the number of rows it was made for. +#' \code{sf::st_drop_geometry()} keeps the rows, and with them the record: it +#' returns a data frame of class \code{c("spatialkit_rows", "data.frame")}. +#' Binding such data frames with +#' \code{rbind()} or \code{dplyr::bind_rows()} keeps the first one's record +#' and class, so the record then describes only the first input's rows: its +#' \code{n_rows} no longer equals \code{nrow()} of the result. The +#' package's own readers ignore a record whose \code{n_rows} does not match; +#' when reading \code{attr(x, "dropped")} or \code{attr(x, "ties")} yourself +#' from a layer that has been through such steps, check it the same way. #' #' @param x A layer returned by \code{\link{prep_model_data}()} or #' \code{\link{assign_features_to_polygons}()}. @@ -710,6 +792,20 @@ setOldClass(c("spatialkit_rows", "sf")) y } +# dplyr's row verbs -- filter(), slice(), arrange(), distinct() -- reach the +# data through dplyr_row_slice(), not `[`, and kept the record: filter(a, +# v >= 3) on 5 rows returned 3 rows still reporting ties$n = 3. They drop it +# as `[` does. sf's own dplyr methods strip "sf" from the class and call +# NextMethod(), so this runs for an sf layer too. Registered in .onLoad() +# on dplyr's generic. +.dplyr_row_slice_spatialkit_rows <- function(data, i, ...) { + y <- NextMethod() + if (!is.data.frame(y)) return(y) + for (nm in .row_record_attrs) attr(y, nm) <- NULL + class(y) <- setdiff(class(y), "spatialkit_rows") + y +} + # --------------------------------------------------------------------------- # Diagnoses written to stderr by compiled code @@ -739,14 +835,21 @@ setOldClass(c("spatialkit_rows", "sf")) # wrote to stderr. Anything written by a call that SUCCEEDED is passed # straight through to stderr afterwards, so ordinary progress and warning # output from compiled code is not swallowed. -.call_capturing_stderr <- function(fun) { +.call_capturing_stderr <- function(fun, path = tempfile("spatialkit-stderr-")) { err <- NULL if (!identical(as.integer(sink.number(type = "message")), 2L)) { val <- tryCatch(fun(), error = function(e) { err <<- e; NULL }) return(list(value = val, error = err, stderr = character(0))) } - path <- tempfile("spatialkit-stderr-") - con <- file(path, open = "wt") + # A session temp directory deleted under a running session leaves nowhere + # to divert to, and file() then failed the whole call with "cannot open the + # connection". Run it undiverted instead, as when a sink is active. + con <- tryCatch(suppressWarnings(file(path, open = "wt")), + error = function(e) NULL) + if (is.null(con)) { + val <- tryCatch(fun(), error = function(e) { err <<- e; NULL }) + return(list(value = val, error = err, stderr = character(0))) + } open <- TRUE # Restore the stream whatever happens, an interrupt included: leaving a # session with its messages diverted to a deleted temp file would silence diff --git a/R/zzz.R b/R/zzz.R index 00c723c..6d06fe7 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -3,7 +3,7 @@ # Set up default logging in a package-specific namespace so we never # overwrite the user's global logger configuration -- and, the other way # round, so the user's global configuration cannot break ours (see the - # formatter note below). + # notes below). # Users can reconfigure the spatialkit namespace after loading -- but note # that logger::log_appender() and log_threshold() BOTH default to index = 1, # so the two-line recipe below without an index touches only the temp-file @@ -14,34 +14,129 @@ # logger::log_threshold(logger::FATAL, namespace = "spatialkit", index = 2) # spatialkit_quiet() does the second of those for you. - # The FORMATTER is pinned, not inherited. logger seeds a new namespace - # from the user's global one, so the appender/threshold lines below left - # the formatter to be whatever the user had set -- and every helper in - # utils.R hands logger an ALREADY-formatted string. Under the default - # formatter_glue a `{` in a message was re-evaluated (a fold error reading - # "diverged at {iter=3}" logged as "diverged at 3"); under a user's - # formatter_sprintf every message containing a literal `%` -- the CRS - # distortion figures, the GWR collinearity percentage -- hard-errored with - # "too few arguments", and because .warn_and_log() logs before it warns, - # the R warning the manual promises died with it. formatter_paste does no - # interpolation, so the message logged is the message written. - logger::log_formatter(logger::formatter_paste, namespace = "spatialkit") + # EVERY setting of both indices is pinned, not inherited. logger seeds a + # new namespace by copying the user's whole global configuration -- every + # index, each with its formatter, layout, appender and threshold -- and the + # lines below overwrite only what they name. Pinning the formatter on + # index 1 alone left index 2 with the user's: someone who had configured two + # global indices before loading the package got formatter_sprintf or + # formatter_glue on the console echo, and a `%` or a `{` in a message + # ("fold 2 skipped: object 'cov_{x' not found") aborted the function that + # logged it, taking the R warning .warn_and_log() promises with it. The + # helpers in utils.R also mark every message skip_formatter(), so no + # formatter on any index sees it; formatter_paste, which does no + # interpolation, is the second line of defence. + for (i in 1:2) { + logger::log_formatter(logger::formatter_paste, namespace = "spatialkit", + index = i) + logger::log_layout(logger::layout_simple, namespace = "spatialkit", + index = i) + } # Index 1: full INFO+ trace to a session temp file (detailed diagnostics). - log_path <- file.path(tempdir(), "spatialkit_model_log.log") - logger::log_appender(logger::appender_file(log_path), - namespace = "spatialkit", index = 1) + # The path is resolved per line, not here; see .sk_file_appender(). + logger::log_appender(.sk_file_appender(), namespace = "spatialkit", + index = 1) logger::log_threshold(logger::INFO, namespace = "spatialkit", index = 1) # Index 2: WARN+ to the console so that important problems (skipped CV # folds, failed predictions returning NA, extraction failures, ...) are # actually visible to interactive users instead of only landing in a - # temp file nobody reads. - logger::log_appender(logger::appender_console, - namespace = "spatialkit", index = 2) + # temp file nobody reads. While a document is knitted the line is also + # sent as an R message; see .sk_console_appender(). + logger::log_appender(.sk_console_appender, namespace = "spatialkit", + index = 2) logger::log_threshold(logger::WARN, namespace = "spatialkit", index = 2) + + # Indices 3 and up can only have been copied from the user's global + # configuration, and they kept the user's appenders: spatialkit's WARN and + # INFO lines landed in the user's own log files. + .sk_logger_drop_copied_indices("spatialkit") + + # dplyr's row verbs drop a layer's row record as `[` does (see + # .dplyr_row_slice_spatialkit_rows() in utils.R). dplyr is imported, so + # its namespace is loaded; guarded all the same, so that loading never + # fails on its account. + tryCatch(registerS3method("dplyr_row_slice", "spatialkit_rows", + .dplyr_row_slice_spatialkit_rows, + envir = asNamespace("dplyr")), + error = function(e) NULL) +} + + +# The temp-file trace (index 1). The path is resolved when a line is written, +# not when the package loads. A session temp directory deleted under a +# running session -- an OS cleaner, or unlink(tempdir()) -- used to turn every +# call that logs into "cannot open the connection", and because +# .warn_and_log() logs before it warns, a documented R warning became that +# error; tempdir(check = TRUE), R's own recovery, did not help, because the +# old path was fixed at load time. The directory is recreated if it has gone +# (R's tempdir() still names it, so R still cleans it up at exit), and a line +# that still cannot be written is dropped: the trace is a diagnostic, never a +# reason for the computation to fail. The "generator" attribute is what +# logger's getter reports for the appender, as it does for appender_file(). +.sk_file_appender <- function(path = function() + file.path(tempdir(), "spatialkit_model_log.log")) { + force(path) + structure(function(lines) { + tryCatch(suppressWarnings({ + f <- path() + if (!dir.exists(dirname(f))) + dir.create(dirname(f), recursive = TRUE, showWarnings = FALSE) + cat(lines, sep = "\n", file = f, append = TRUE) + }), error = function(e) NULL) + invisible(NULL) + }, generator = ".sk_file_appender()") +} + +# The console echo (index 2). logger's appender_console writes to stderr with +# cat(), which knitr does not capture, so in a knitted R Markdown, Quarto or +# pkgdown document every log-only caution vanished while the R warnings next +# to it were shown. The line still goes to stderr exactly as before, and +# while knitr is running it is ALSO sent as an R message, which the document +# shows and the chunk option `message = FALSE` hides; nothing that reached the +# console before is lost. A line that is about to be raised as an R warning +# as well -- .warn_and_log() and .warn_deff_fallback() -- is not repeated as +# a message, since the document already shows the warning. +.sk_console_appender <- function(lines) { + cat(lines, file = stderr(), sep = "\n") + if (isTRUE(getOption("knitr.in.progress")) && !isTRUE(.sk_log_state$raising)) + message(paste(lines, collapse = "\n")) + invisible(NULL) +} + +# Reduce the namespace to the two indices above. logger 0.2.2 has no public +# way to count or delete indices (later releases export delete_logger_index()), +# but its getter answers for any index past the last with the LAST index's +# settings. Index 2's appender is this package's own function, so reading it +# back at index 3 means there is no index 3. Without delete_logger_index() an +# extra index is switched off instead: a no-op appender, and a threshold below +# FATAL, which no log line meets. logger 0.2.2's setters cannot address an +# index above 5, so neither can this. +.sk_logger_drop_copied_indices <- function(ns) { + appender_at <- function(k) logger::log_appender(namespace = ns, index = k) + has_index <- function(k) !identical(appender_at(k), appender_at(k - 1L)) + del <- tryCatch(getExportedValue("logger", "delete_logger_index"), + error = function(e) NULL) + if (is.function(del)) { + n <- 0L + while (has_index(3L) && n < 100L) { + del(namespace = ns, index = 3L) + n <- n + 1L + } + return(invisible(NULL)) + } + off <- structure(0L, level = "OFF", class = "loglevel") + for (k in 3:5) { + if (!has_index(k)) break + logger::log_appender(.sk_log_off, namespace = ns, index = k) + logger::log_threshold(off, namespace = ns, index = k) + } + invisible(NULL) } +.sk_log_off <- function(lines) invisible(NULL) + #' @noRd .onUnload <- function(libpath) { # logger keeps the "spatialkit" namespace alive after unloadNamespace(), @@ -73,6 +168,15 @@ #' and \code{tryCatch(warning = )} do not see them. Conditions the package #' raises as real R warnings are unaffected by this function. #' +#' While a document is being knitted (R Markdown, Quarto, a \pkg{pkgdown} +#' article) the console echo is also sent as an R message, because +#' \pkg{knitr} does not capture what is written to the console's error stream +#' and the cautions would otherwise be missing from the output. They appear +#' as \code{## WARN [...]} lines, and the chunk option \code{message = FALSE}, +#' like \code{suppressMessages()}, keeps them out of the document. A line the +#' package also raises as an R warning is not repeated, since the document +#' shows the warning. Outside \pkg{knitr} nothing changes. +#' #' @param quiet \code{TRUE} (default) silences the console echo; #' \code{FALSE} restores the package default, WARN+. A \pkg{logger} #' threshold (\code{logger::ERROR}, or the value a previous call returned) diff --git a/README.Rmd b/README.Rmd index 5bdbd62..7b54848 100644 --- a/README.Rmd +++ b/README.Rmd @@ -53,12 +53,15 @@ different boundaries. `spatialkit` lets the data draw the boundaries. `get_voronoi_seeds()` places seeds by k-means on the point cloud, so cell density follows sampling density. -`determine_optimal_levels()` and `resolution_profile()` read a cell count out of -the spatial structure of the observations. `build_tessellation()` produces +`resolution_profile()` scores every candidate cell count against the spatial +structure of the observations, and `determine_optimal_levels()` reads one off +their clustering when they have any. `build_tessellation()` produces Voronoi, hex, square or Delaunay cells clipped to your study area, with IDs that stay stable when the input row order changes. `summarize_by_cell()` aggregates -onto them and corrects the cell-level standard errors for within-cell -autocorrelation, which on a correlated field roughly doubles them. +onto them with a count and a standard error for every cell mean. When the cell +means stand in for a population mean, it corrects those standard errors for +within-cell autocorrelation, which on a correlated field can double them or +more. Redrawing boundaries is easy. Knowing whether the result means anything is the hard part, so the second half of the package is the evidence layer. Three model @@ -73,12 +76,15 @@ metres to a function expecting degrees. How many cells is a decision with visible consequences. The same field below is cut at three resolutions beside the raw observations: too coarse blurs the -hotspot, too fine chases noise with near-empty cells, and the selected count -keeps the trend without tracing the sampling pattern. -`vignette("resolution")` covers how that number is chosen and the four criteria -that disagree about it. +hotspot, too fine chases noise with near-empty cells, and the middle count, the +one `resolution_profile()` rates most reliable, keeps the trend without tracing +the sampling pattern. It is a reading, not a verdict: the reliability of the +cell means stays within 2 percent of its best from 3 to 25 cells here, and the +sites are spread evenly, so there is no elbow for `determine_optimal_levels()` +to find. `vignette("resolution")` covers how that number is chosen and the four +criteria that disagree about it. -![Raw observations and the same spatial field tessellated at three resolutions, including the automatically selected one](https://raw.githubusercontent.com/elkronos/gis_modeling_toolkit/main/man/figures/readme-resolution.png) +![Raw observations and the same spatial field tessellated at three resolutions, including the count resolution_profile() rates most reliable](https://raw.githubusercontent.com/elkronos/gis_modeling_toolkit/main/man/figures/readme-resolution.png) The number a random fold reports on autocorrelated data is the reason the evidence layer exists. Random folds put a test point's neighbours in the @@ -125,7 +131,8 @@ message naming it. | `sp`, `GWmodel` | `fit_gwr_model()`, `cv_gwr()` | | `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()`, `cv_bayes()` | | `geometry` | Delaunay triangle tessellations | -| `ggplot2`, `patchwork` | every `plot_*()` function and `plot()` method | +| `ggplot2` | every `plot_*()` function and `plot()` method | +| `patchwork` | the combined panels in `vignette("spatialkit_nc_demo")` and its script | | `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers | | `loo` | PSIS-LOO for the Bayesian backend | | `nlme` | REML detrending in `estimate_sac_range()` | @@ -144,7 +151,7 @@ library(spatialkit) set.seed(42) n <- 400 -xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) +xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$w <- rnorm(n) # Mostly a smooth spatial field, with a weak measured predictor on top. @@ -166,11 +173,14 @@ populated <- st_drop_geometry(cells)[cells$n > 1 & !is.na(cells$n), ] head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z")], 4) ``` -Every aggregate arrives with a count and a standard error, and `deff = "kish"` -widens that error by the design effect of the within-cell correlation; the -uncorrected version assumes the points in a cell are independent. A lattice laid -over an irregular point cloud leaves some cells with one observation or none, -which is why `n` travels with every row. +Every aggregate arrives with a count and a standard error. `deff = "kish"` makes +that the standard error of each cell mean as an estimate of the population mean, +widened by the design effect of the within-cell correlation. For a map of the +cells' own values leave `deff` at 1: the uncorrected standard error is the right +one for a cell's own mean when its points are spread through it +(`?summarize_by_cell` says which to use when). A lattice laid over an irregular +point cloud leaves some cells with one observation or none, which is why `n` +travels with every row. Now score a model. The learner below is a cubic trend surface in the coordinates, which is a realistic thing to fit and also the leakage mechanism @@ -283,7 +293,7 @@ an afternoon comparing them: | Backend | Reach for it when you want | Cost | |---|---|---| | **GWR** (`fit_gwr_model()`, `GWmodel` + `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers "the elevation effect is strong in the west and absent in the east" | moderate; grows quickly with n | -| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces, CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | +| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | | **Random forest** (`fit_rf_model()`, `ranger`) | **nonlinearity and interactions** without specifying them, and no inference: you get permutation importance in place of coefficients | far the lowest; the one to prototype with | Two things that are not backend choices. First, none of them fixes bad folds. @@ -372,8 +382,11 @@ typo, a case difference, or a column renamed by `read.csv()`'s **`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 +Everything here is regression, with one exception: +`fit_bayesian_spatial_model()` takes a factor or character response under +`brms::categorical()` or an ordinal family (see "Non-Gaussian responses" in +`?fit_bayesian_spatial_model`). Anywhere else 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 an `"NA"` string if that produces `NA`s. `fit_gwr_model()` additionally refuses an integer-coded two-valued response and points at `GWmodel::ggwr.basic()`. @@ -410,13 +423,18 @@ same reason. matrix, which is why it stops here. `install.packages(c("FNN", "Matrix"))`, both of them. +**`compare_models_cv(): no recognised model requested.`** +None of the names in `models` is `"GWR"`, `"Bayesian"` or `"RF"`, which are +matched exactly, case included. The `ignoring unknown model(s)` warning printed +with the error names the ones it ignored. + **`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. +At least one requested name was recognised, but every recognised backend is +uninstalled: each prints `dropping (package/function unavailable)` above +the error, and any unrecognised names are named in a warning printed with it. +Install the backend, or request one you have. -**`cv_*(): all folds failed; cross-validation results contain no predictions.`** +**`cv_*(): all folds failed (all N folds failed to produce predictions); ...`** This is a warning: `$overall` comes back all-`NA` with `n_pred = 0`. The per-fold `WARN` lines name the cause, most often a missing backend, sometimes a degenerate training slice or a predictor constant within a fold. Compare @@ -426,16 +444,26 @@ score computed from fewer folds than you asked for. **`estimate_sac_range()` returned `NA`.** The range was not identified, so nothing is reported. `attr(x, "rejected_reason")` -names which of the five refusals it was, `?estimate_sac_range` says what each +names which of the six refusals it was, `?estimate_sac_range` says what each one means, and `plot()` on the returned object draws the variogram behind it. `vignette("spatial-cross-validation")` covers what an `NA` there leaves you to decide about the block size. -**`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 -`vignette("resolution")`. +**`determine_optimal_levels(): the model-aware criteria score only the elbow's +neighbourhood, k = ... to ..., and carry no information at nine cells or +fewer`** (or, before the sweep, `max_levels leaves k_max = ...`). +Every candidate around the elbow sat at nine cells or fewer, where Moran's I is +arithmetically degenerate, so the call fell back to the geometric ranking. On +points with no cluster structure that is the usual outcome below about +`max_levels = 40`; `resolution_profile()` scores Moran's z at every level of +its ladder. See `vignette("resolution")`. + +**`determine_optimal_levels(): Moran's I could not be computed at any k from +... to ... in the elbow's neighbourhood`** +The candidates did pass nine cells, but too few of the cells hold a row with a +response and every predictor, or the regression of the cell means on the +predictors is singular (a predictor constant or collinear across cells). Check +for missing values first. **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 @@ -451,11 +479,13 @@ 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: +`cv_bayes()`, `cv_rf()` and `cv_spatial()` accept a `parallel` argument for +fold-level parallelism via `parallel::mclapply()` (macOS/Linux; falls back to +sequential on Windows with a message). `cv_gwr()` accepts it too but always +runs its folds one after another, with a warning if you ask for more: GWmodel +runs OpenMP code, which deadlocks forked workers once a GWR has been fitted in +the session. Parallel folds matter most for `cv_bayes()`, where every fold is a +full MCMC run: ```r # cv_bayes() needs `brms`. Without it every fold fails and you get an empty @@ -466,11 +496,13 @@ cv <- cv_bayes(site, "price", "elev", k = 5, parallel = TRUE) # auto-detect cor #> WARN cross-validation: fold 1 fit failed; skipping. #> Cause: fit_bayesian_spatial_model(): package 'brms' is required. #> ... (once per fold) -#> WARN cv_bayes(): all 5 folds failed to produce predictions; results are -#> empty. First error: fit_bayesian_spatial_model(): package 'brms' is required. +#> WARN cv_bayes(): all folds failed (all 5 folds failed to produce +#> predictions); cross-validation results contain no predictions. First error: +#> fit_bayesian_spatial_model(): package 'brms' is required. #> Warning message: -#> cv_bayes(): all folds failed; cross-validation results contain no -#> predictions. First error: fit_bayesian_spatial_model(): package 'brms' is required. +#> cv_bayes(): all folds failed (all 5 folds failed to produce predictions); +#> cross-validation results contain no predictions. First error: +#> fit_bayesian_spatial_model(): package 'brms' is required. cv <- cv_rf(site, "price", "elev", k = 5, parallel = 4L) # explicit count ``` @@ -506,8 +538,9 @@ memoise, so both are cached: ### 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 -touches your global logger configuration. +to the console. Logging is scoped to the `"spatialkit"` namespace: it never +touches your global logger configuration, and a global configuration set up +before the package loads does not carry over into it. The two are separate `logger` appenders: **index 1** is the temp file (INFO+), **index 2** is the console echo (WARN+). Both `logger::log_appender()` and @@ -529,6 +562,11 @@ 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. +knitr does not capture the console's error stream, so while a document is +being knitted (R Markdown, Quarto, pkgdown) the console echo is also sent as an +R message. The logged cautions then appear in the output next to the warnings, +and the chunk option `message = FALSE` keeps them out of it. + ## Development ```r @@ -543,8 +581,8 @@ used is recorded in `DESCRIPTION`); `devtools::document()` reproduces them. The README figures are generated from actual package output; regenerate them with `Rscript dev/make_readme_figures.R`. `readme-resolution.png` labels the -cell count `determine_optimal_levels()` chose for that data, so it goes stale -whenever that function's answer changes and must be rebuilt alongside it. +cell count `resolution_profile()` rates most reliable on that data, so it goes +stale whenever that criterion's answer changes and must be rebuilt alongside it. The test suite covers the geometry/tessellation pipeline, every exported function, and targeted regression tests for the statistical internals (Moran's diff --git a/README.md b/README.md index aabb869..c97ebd6 100644 --- a/README.md +++ b/README.md @@ -39,13 +39,16 @@ support materially different conclusions under different boundaries. `spatialkit` lets the data draw the boundaries. `get_voronoi_seeds()` places seeds by k-means on the point cloud, so cell density follows -sampling density. `determine_optimal_levels()` and -`resolution_profile()` read a cell count out of the spatial structure of -the observations. `build_tessellation()` produces Voronoi, hex, square +sampling density. `resolution_profile()` scores every candidate cell +count against the spatial structure of the observations, and +`determine_optimal_levels()` reads one off their clustering when they +have any. `build_tessellation()` produces Voronoi, hex, square or Delaunay cells clipped to your study area, with IDs that stay stable when the input row order changes. `summarize_by_cell()` aggregates onto -them and corrects the cell-level standard errors for within-cell -autocorrelation, which on a correlated field roughly doubles them. +them with a count and a standard error for every cell mean. When the +cell means stand in for a population mean, it corrects those standard +errors for within-cell autocorrelation, which on a correlated field can +double them or more. Redrawing boundaries is easy. Knowing whether the result means anything is the hard part, so the second half of the package is the evidence @@ -67,17 +70,21 @@ methods aggregating it over North Carolina How many cells is a decision with visible consequences. The same field below is cut at three resolutions beside the raw observations: too coarse blurs the hotspot, too fine chases noise with near-empty cells, -and the selected count keeps the trend without tracing the sampling -pattern. `vignette("resolution")` covers how that number is chosen and -the four criteria that disagree about it. +and the middle count, the one `resolution_profile()` rates most +reliable, keeps the trend without tracing the sampling pattern. It is a +reading, not a verdict: the reliability of the cell means stays within 2 +percent of its best from 3 to 25 cells here, and the sites are spread +evenly, so there is no elbow for `determine_optimal_levels()` to find. +`vignette("resolution")` covers how that number is chosen and the four +criteria that disagree about it.
+alt="Raw observations and the same spatial field tessellated at three resolutions, including the count resolution_profile() rates most reliable" /> +field tessellated at three resolutions, including the count +resolution_profile() rates most reliable
The number a random fold reports on autocorrelated data is the reason @@ -132,7 +139,8 @@ produces a message naming it. | `sp`, `GWmodel` | `fit_gwr_model()`, `cv_gwr()` | | `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()`, `cv_bayes()` | | `geometry` | Delaunay triangle tessellations | -| `ggplot2`, `patchwork` | every `plot_*()` function and `plot()` method | +| `ggplot2` | every `plot_*()` function and `plot()` method | +| `patchwork` | the combined panels in `vignette("spatialkit_nc_demo")` and its script | | `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran’s I on large layers | | `loo` | PSIS-LOO for the Bayesian backend | | `nlme` | REML detrending in `estimate_sac_range()` | @@ -150,7 +158,7 @@ library(spatialkit) set.seed(42) n <- 400 -xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) +xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$w <- rnorm(n) # Mostly a smooth spatial field, with a weak measured predictor on top. @@ -177,12 +185,15 @@ head(populated[, c("poly_id", "n", "resp_mean_z", "..se_resp_z")], 4) #> 5 5 14 0.0554452 0.7258217 ``` -Every aggregate arrives with a count and a standard error, and -`deff = "kish"` widens that error by the design effect of the -within-cell correlation; the uncorrected version assumes the points in a -cell are independent. A lattice laid over an irregular point cloud -leaves some cells with one observation or none, which is why `n` travels -with every row. +Every aggregate arrives with a count and a standard error. +`deff = "kish"` makes that the standard error of each cell mean as an +estimate of the population mean, widened by the design effect of the +within-cell correlation. For a map of the cells’ own values leave `deff` +at 1: the uncorrected standard error is the right one for a cell’s own +mean when its points are spread through it (`?summarize_by_cell` says +which to use when). A lattice laid over an irregular point cloud leaves +some cells with one observation or none, which is why `n` travels with +every row. Now score a model. The learner below is a cubic trend surface in the coordinates, which is a realistic thing to fit and also the leakage @@ -303,7 +314,7 @@ afternoon comparing them: | Backend | Reach for it when you want | Cost | |------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------------------------------------------------| | **GWR** (`fit_gwr_model()`, `GWmodel` + `sp`) | spatially varying **coefficients** you can interpret and map. Only this backend answers “the elevation effect is strong in the west and absent in the east” | moderate; grows quickly with n | -| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces, CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | +| **Bayesian spatial GP** (`fit_bayesian_spatial_model()`, `brms`) | calibrated **uncertainty**: posterior predictive intervals, `se = TRUE` surfaces (the SD of the mean surface; add `type = "predict"` for the predictive SD), CRPS. Also the natural spatial null: `predictor_vars = character(0)` fits an intercept-only GP, which asks how much of the surface is spatial structure and how much is covariate effect | far the highest; every CV fold is a full MCMC run | | **Random forest** (`fit_rf_model()`, `ranger`) | **nonlinearity and interactions** without specifying them, and no inference: you get permutation importance in place of coefficients | far the lowest; the one to prototype with | Two things that are not backend choices. First, none of them fixes bad @@ -394,8 +405,11 @@ 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 +Everything here is regression, with one exception: +`fit_bayesian_spatial_model()` takes a factor or character response under +`brms::categorical()` or an ordinal family (see “Non-Gaussian responses” in +`?fit_bayesian_spatial_model`). Anywhere else 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 an `"NA"` string if that produces `NA`s. `fit_gwr_model()` additionally refuses an integer-coded two-valued response and points at `GWmodel::ggwr.basic()`. @@ -430,13 +444,18 @@ above 5,000,000 grid cells for the same reason. x n matrix, which is why it stops here. `install.packages(c("FNN", "Matrix"))`, both of them. -**`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. +**`compare_models_cv(): no recognised model requested.`** None of the +names in `models` is `"GWR"`, `"Bayesian"` or `"RF"`, which are matched +exactly, case included. The `ignoring unknown model(s)` warning printed +with the error names the ones it ignored. -**`cv_*(): all folds failed; cross-validation results contain no predictions.`** +**`compare_models_cv(): no viable models.`** At least one requested name +was recognised, but every recognised backend is uninstalled: each prints +`dropping (package/function unavailable)` above the error, and +any unrecognised names are named in a warning printed with it. Install +the backend, or request one you have. + +**`cv_*(): all folds failed (all N folds failed to produce predictions); ...`** This is a warning: `$overall` comes back all-`NA` with `n_pred = 0`. The per-fold `WARN` lines name the cause, most often a missing backend, sometimes a degenerate training slice or a predictor constant within a @@ -447,15 +466,24 @@ asked for. **`estimate_sac_range()` returned `NA`.** The range was not identified, so nothing is reported. `attr(x, "rejected_reason")` names which of the -five refusals it was, `?estimate_sac_range` says what each one means, +six refusals it was, `?estimate_sac_range` says what each one means, and `plot()` on the returned object draws the variogram behind it. `vignette("spatial-cross-validation")` covers what an `NA` there leaves you to decide about the block size. -**`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 -`vignette("resolution")`. +**`determine_optimal_levels(): the model-aware criteria score only the elbow's neighbourhood, k = ... to ..., and carry no information at nine cells or fewer`** +(or, before the sweep, `max_levels leaves k_max = ...`). Every candidate +around the elbow sat at nine cells or fewer, where Moran’s I is +arithmetically degenerate, so the call fell back to the geometric +ranking. On points with no cluster structure that is the usual outcome +below about `max_levels = 40`; `resolution_profile()` scores Moran’s z +at every level of its ladder. See `vignette("resolution")`. + +**`determine_optimal_levels(): Moran's I could not be computed at any k from ... to ... in the elbow's neighbourhood`** +The candidates did pass nine cells, but too few of the cells hold a row +with a response and every predictor, or the regression of the cell +means on the predictors is singular (a predictor constant or collinear +across cells). Check for missing values first. **Distances, bandwidths or block sizes look absurd.** Check the working CRS first: `st_crs(x)$units_gdal`. A block size that made sense in @@ -471,11 +499,13 @@ 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: +`cv_bayes()`, `cv_rf()` and `cv_spatial()` accept a `parallel` argument +for fold-level parallelism via `parallel::mclapply()` (macOS/Linux; falls +back to sequential on Windows with a message). `cv_gwr()` accepts it too +but always runs its folds one after another, with a warning if you ask +for more: GWmodel runs OpenMP code, which deadlocks forked workers once a +GWR has been fitted in the session. Parallel folds matter most for +`cv_bayes()`, where every fold is a full MCMC run: ``` r # cv_bayes() needs `brms`. Without it every fold fails and you get an empty @@ -486,11 +516,13 @@ cv <- cv_bayes(site, "price", "elev", k = 5, parallel = TRUE) # auto-detect cor #> WARN cross-validation: fold 1 fit failed; skipping. #> Cause: fit_bayesian_spatial_model(): package 'brms' is required. #> ... (once per fold) -#> WARN cv_bayes(): all 5 folds failed to produce predictions; results are -#> empty. First error: fit_bayesian_spatial_model(): package 'brms' is required. +#> WARN cv_bayes(): all folds failed (all 5 folds failed to produce +#> predictions); cross-validation results contain no predictions. First error: +#> fit_bayesian_spatial_model(): package 'brms' is required. #> Warning message: -#> cv_bayes(): all folds failed; cross-validation results contain no -#> predictions. First error: fit_bayesian_spatial_model(): package 'brms' is required. +#> cv_bayes(): all folds failed (all 5 folds failed to produce predictions); +#> cross-validation results contain no predictions. First error: +#> fit_bayesian_spatial_model(): package 'brms' is required. cv <- cv_rf(site, "price", "elev", k = 5, parallel = 4L) # explicit count ``` @@ -530,8 +562,10 @@ to memoise, so both are cached: ### 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 touches your global logger configuration. +echoed to the console. Logging is scoped to the `"spatialkit"` namespace: +it never touches your global logger configuration, and a global +configuration set up before the package loads does not carry over into +it. The two are separate `logger` appenders: **index 1** is the temp file (INFO+), **index 2** is the console echo (WARN+). Both @@ -554,6 +588,12 @@ 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. +knitr does not capture the console’s error stream, so while a document +is being knitted (R Markdown, Quarto, pkgdown) the console echo is also +sent as an R message. The logged cautions then appear in the output next +to the warnings, and the chunk option `message = FALSE` keeps them out +of it. + ## Development ``` r @@ -569,9 +609,9 @@ reproduces them. The README figures are generated from actual package output; regenerate them with `Rscript dev/make_readme_figures.R`. `readme-resolution.png` -labels the cell count `determine_optimal_levels()` chose for that data, -so it goes stale whenever that function’s answer changes and must be -rebuilt alongside it. +labels the cell count `resolution_profile()` rates most reliable on that +data, so it goes stale whenever that criterion’s answer changes and must +be rebuilt alongside it. The test suite covers the geometry/tessellation pipeline, every exported function, and targeted regression tests for the statistical internals diff --git a/_pkgdown.yml b/_pkgdown.yml index 51e14ce..950f7b0 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -22,7 +22,8 @@ navbar: href: articles/getting-started.html # Articles, in the order to read them. The fifth vignette is the end-to-end -# run; the three between it and "Getting started" each take one topic. +# run and the sixth, on reporting, covers what leaves the session; the three +# between "Getting started" and the end-to-end run each take one topic. articles: - title: Get started navbar: ~ diff --git a/cran-comments.md b/cran-comments.md index 6d785d4..339d104 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -78,22 +78,27 @@ cleanly. * Optional model backends (`GWmodel`, `brms`, `ranger`) and other heavy dependencies live in Suggests and are used strictly conditionally. All package - code, examples, tests **and the vignette** guard their use with + code, examples, tests **and the six vignettes** guard their use with `requireNamespace()` and skip or degrade gracefully when the package is - absent. The vignette resolves every optional backend in its setup chunk and - 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`. It has been built both with every optional - backend present and with `GWmodel` absent, and re-builds cleanly either way. - -* Exactly two examples are wrapped in `\dontrun{}`: `fit_bayesian_spatial_model()` - and `cv_bayes()`. These are the "missing additional software" case the CRAN - cookbook gives for `\dontrun{}`: both compile a Stan model, which needs a - working C++ toolchain (or a CmdStan build) that neither this package nor - `brms` can supply, and then run minutes of MCMC. Each block opens with a - comment saying so, and `brms` itself wraps its own fitting examples the same - way. + absent. Each vignette resolves the optional packages it uses in its setup + chunk and gates the relevant chunks on the result. Where every chunk depends + on a package -- `ggplot2` in the North Carolina demo; `gstat` and `ggplot2` + in the resolution, diagnostics and spatial cross-validation vignettes -- the + gate is global, so on a machine without it the vignette builds as code + without output rather than failing `R CMD build`. The `R-CMD-check.yaml` + matrix builds the vignettes with the hard dependencies plus `ggplot2` and + `gstat` (and what `gstat` pulls in), so the chunks gated on `GWmodel`, + `ranger`, `geometry` or `patchwork` are skipped there; the pkgdown workflow + builds them with every package they gate on. + +* Exactly three examples are wrapped in `\dontrun{}`: + `fit_bayesian_spatial_model()`, `cv_bayes()` and `plot_calibration()`, whose + example has to run `cv_bayes()` to have something to plot. These are the + "missing additional software" case the CRAN cookbook gives for `\dontrun{}`: + all three compile a Stan model, which needs a working C++ toolchain (or a + CmdStan build) that neither this package nor `brms` can supply, and then run + minutes of MCMC. Each block opens with a comment saying so, and `brms` itself + wraps its own fitting examples the same way. `\donttest{}` would be the wrong tag here rather than a more conservative one: `--run-donttest` is exercised on several CRAN platforms, so tagging @@ -124,8 +129,7 @@ cleanly. sample under a constant seed, now draws no random numbers at all. Where `seed` is `NULL`, nothing is seeded and nothing is restored: unseeded functions advance the caller's stream the way - any other unseeded R function does, rather than re-initialising it. That - distinction is the subject of fix 5 above. + any other unseeded R function does, rather than re-initialising it. * Core use is bounded. No function defaults to `parallel::detectCores()`: `fit_bayesian_spatial_model(cores = )` and `fit_rf_model(num_threads = )` diff --git a/dev/commit-split.sh b/dev/commit-split.sh deleted file mode 100644 index 46902df..0000000 --- a/dev/commit-split.sh +++ /dev/null @@ -1,302 +0,0 @@ -#!/usr/bin/env bash -# --------------------------------------------------------------------------- -# Split the post-1.0.0 working tree into reviewable commits. -# -# Run from the package root: bash dev/commit-split.sh -# -# Notes before you run it: -# * It creates a branch first; main is left where it is. -# * Each group is skipped if nothing is staged for it, so a path that does -# not exist (or was never modified) is harmless. -# * Only the FINAL commit is a verified state. The intermediate ones are -# grouped for reviewability, not bisectability -- a test file may land one -# commit before or after the code it exercises. If you need every commit -# green, squash instead. -# * Nothing here contacts CRAN or pushes anywhere. -# --------------------------------------------------------------------------- -set -euo pipefail - -BRANCH="${1:-dev-2.0.0}" - -if [ ! -f DESCRIPTION ]; then - echo "Run this from the package root." >&2; exit 1 -fi - -echo "=== working tree before anything is staged ===" -git status --porcelain -echo -read -r -p "Proceed? [y/N] " reply -case "$reply" in y|Y) ;; *) echo "aborted."; exit 0 ;; esac -echo - -current=$(git rev-parse --abbrev-ref HEAD) -echo "current branch: $current" -if [ "$current" != "$BRANCH" ]; then - git checkout -b "$BRANCH" -fi - -TRAILER=$'\n\nCo-Authored-By: Claude Opus 5 \nClaude-Session: https://claude.ai/code/session_014DkVoswUXWntSsYAJsxgPw' - -commit_group () { - local subject="$1"; shift - local body="$1"; shift - git add -A -- "$@" 2>/dev/null || true - if git diff --cached --quiet; then - echo " (nothing staged) skip: $subject" - return 0 - fi - printf '%s\n\n%s%s\n' "$subject" "$body" "$TRAILER" | git commit -q -F - - echo " committed: $subject" -} - -# --- 1 --------------------------------------------------------------------- -commit_group \ -"Correct the GP length-scale prior and derive the basis count" \ -"brms::gp() defaults to scale = TRUE, which rescales its covariates so the -maximum pairwise distance is 1 and reports lscale in that space. The package -standardised coordinates itself and derived the prior in those units, so the -two normalisations differed by roughly the maximum pairwise distance and the -prior was about five times too diffuse -- producing rejected initial values on -most chains. The GP term now sets scale = FALSE so there is one scaling. - -Separately, gp_k was chosen from n rather than from spatial structure. Because -gp() builds a tensor grid, gp(x, y, k = k) carries k^2 basis functions, and the -old rule reduced to max(15, floor(sqrt(n))) -- making the basis count -identically n. It is now derived from the length-scale-to-domain ratio -following Riutort-Mayol et al. (2023). - -Measured on the same field and seeds, n = 2000: gp_k 44 -> 24, basis -1936 -> 576, cross-validated R-squared 0.9269 -> 0.9272 (unchanged within -noise), elapsed 10908s -> 1186s. At n = 300 the basis is larger than before -(289 -> 529) and the fit slower: a correction, not an optimisation." \ - R/model-bayesian.R R/model-prep.R \ - tests/testthat/test-gp-basis.R tests/testthat/test-lscale-prior.R - -# --- 2 --------------------------------------------------------------------- -commit_group \ -"Stop forcing continental extents into a single UTM zone" \ -"Transverse Mercator scale error grows quadratically with distance from the -central meridian, so data spanning the contiguous US in one zone carried -distance errors of several percent. Those errors were silent and propagated -into variogram ranges, block sizes, GWR bandwidth and GP length-scales. - -Extents reaching more than 5 degrees from the candidate zone's central meridian -now get an equal-area projection centred on the data. The trigger measures -longitude offset only: latitude span does not drive TM error, and cos(lat) -shrinks it, so a tall narrow strip is fine under UTM and worse under LAEA. - -Measured over CONUS: median distance error 1.525% -> 0.249%, max 11.68% -> -2.43%." \ - R/crs-geometry.R \ - tests/testthat/test-crs-selection.R tests/testthat/test-crs-projection.R \ - dev/verify-crs-distortion.R - -# --- 3 --------------------------------------------------------------------- -commit_group \ -"Make parallel CV reproducible; add fold methods and SAC guards" \ -".cv_run_folds() called mclapply() without seeding the fork streams, so each -worker seeded itself from the time and PID. One seed per fold is now drawn in -the parent, making each fold's stream a function of (seed, fold index) alone. - -make_folds() gains leave_location_out (repeated measurements at a site stay in -one fold) and nndm (Milà et al. 2022 distance matching, sizing each exclusion -so training-to-test distances reproduce the distances from actual prediction -locations). - -estimate_sac_range() now rejects a fitted range that exceeds the longest lag -the variogram was fitted over -- such a range is unidentified rather than long, -and block sizing from it yields one block covering everything. - -Also fixed here, from the full-tree audit: an on.exit() name collision that -silently replaced the caller's RNG stream; a %d format applied to a median that -is not always integral; MULTIPOINT accepted without coercion, so per-vertex -st_coordinates() rows misaligned every fold; a single block producing an empty -training set; mclapply() try-error objects surviving the NULL filter; and -cv_spatial() staying silent when every fold failed." \ - R/cross-validation.R \ - tests/testthat/test-cv-parallel.R tests/testthat/test-fold-methods.R \ - tests/testthat/test-sac-range.R tests/testthat/test-fold-construction.R \ - tests/testthat/test-make-folds-row-ids.R tests/testthat/test-core-count.R \ - tests/testthat/helper-bootlm.R tests/testthat/helper-logging.R - -# --- 4 --------------------------------------------------------------------- -commit_group \ -"Add a variogram design effect; make the kNN fallback reachable" \ -"summarize_by_cell() gains deff = 'variogram', computing a per-cell design -effect from a fitted variogram rather than one pooled intra-class correlation. -For n points with correlation matrix R the effective sample size of the mean is -n^2 / sum(R), so deff = sum(R)/n. This generalises the Kish option -- a constant -off-diagonal correlation recovers 1 + (n-1)rho exactly -- but lets correlation -decay with distance, which is the point of having fitted a variogram. - -.build_knn_weights() takes its backend availability as parameters rather than -calling requireNamespace() directly, so the dense fallback and its size guard -can be exercised on a machine that has FNN installed. The test for that -fallback had been skipping silently." \ - R/evaluation.R R/assignment.R \ - tests/testthat/test-knn-weights.R tests/testthat/test-deff-variogram.R \ - tests/testthat/test-summarize-by-cell.R tests/testthat/test-morans-weights.R \ - tests/testthat/test-morans-variance.R - -# --- 5 --------------------------------------------------------------------- -commit_group \ -"Add predict_surface(), plot() for spatial_fit, and plot_folds()" \ -"predict() required newdata to be built by hand, which made producing a map -- -the most common thing wanted from a fitted spatial model -- more work than it -should be. predict_surface() builds the grid, joins covariates by nearest -feature, clips to a boundary, predicts in chunks and returns sf. Chunking -matters for bayesian_fit, where the draw matrix is n_draws x n_newdata. - -plot() on a spatial_fit gives residuals mapped at the training locations, -observed-vs-predicted, and the residual variogram with the fitted model and -effective range overlaid -- so the variogram fit can be judged rather than -trusted. plot_folds() maps a fold scheme, which is the fastest way to see -whether blocks actually separate the data or are smaller than the -autocorrelation range and therefore leaking." \ - R/predict-surface.R R/plotting-fits.R \ - tests/testthat/test-predict-surface.R tests/testthat/test-plotting-fits.R \ - tests/testthat/helper-lmfit.R - -# --- 6 --------------------------------------------------------------------- -commit_group \ -"Add forward feature selection and GWR model selection" \ -"select_features_forward() selects predictors against a spatially blocked -inner-fold score. The blocking is the whole justification: random inner folds -inside blocked outer folds select variables that look predictive only because -nearby points leak between train and test, and the outer loop then reports -honest-looking numbers for a dishonestly chosen feature set. method therefore -defaults to block_kfold and warns otherwise. - -gwr_model_selection() wraps GWmodel::gwr.model.selection() and returns a ranked -table instead of two loosely-coupled lists. It is the fast in-sample -counterpart -- same forward search, scored by AICc rather than by a blocked -estimate. Both limitations are documented rather than hidden: one bandwidth is -shared across candidate models, and the null model is never evaluated, so the -result always names at least one predictor. - -GWmodel does not label its diagnostic table, so the AICc column is read -positionally (as GWmodel's own documentation does) and the result records which -way it was found. Its progress output is discarded by default: it is written -with bare cat(), so no suppressMessages() touches it, and it scales with the -square of the candidate count." \ - R/feature-selection.R R/model-selection-gwr.R \ - tests/testthat/test-feature-selection.R \ - tests/testthat/test-gwr-model-selection.R - -# --- 7 --------------------------------------------------------------------- -commit_group \ -"Add area_of_applicability()" \ -"Implements the dissimilarity index and area of applicability of Meyer & -Pebesma (2021). A fitted model returns a number for any location, including -locations whose predictors look nothing like anything it trained on. Those -predictions are extrapolations dressed as interpolations, and a -cross-validation score says nothing about them -- the held-out folds came from -the same predictor distribution as the training data. - -Predictors are centred and scaled with the TRAINING data's statistics, never -the prediction data's, which would re-centre a far-away block and make it look -familiar. Weighting follows CAST, the reference implementation: the scaled -column is multiplied by the weight, contributing w^2 to the squared distance. - -Pass the folds you actually validated with. Without them the reference is each -point's nearest neighbour anywhere, which for clustered data is very close, -giving a conservative AOA. Buffered and NNDM folds contribute the training set -they actually left available rather than 'everything outside the fold', so the -exclusion they exist to enforce is not silently undone." \ - R/area-of-applicability.R \ - tests/testthat/test-area-of-applicability.R - -# --- 8 --------------------------------------------------------------------- -commit_group \ -"Add a ranger random forest backend" \ -"fit_rf_model() and cv_rf() return an rf_fit that works with cv_spatial(), -predict_surface(), area_of_applicability() and plot() like any other backend. -Three choices are opinionated because each is where an RF spatial model usually -goes wrong. - -include_coords defaults to FALSE. Giving a forest x and y lets it reproduce the -training surface by memorising location, then fail badly off it; random CV does -not catch that, which is how the practice became common (Meyer et al. 2019). - -fitted() returns out-of-bag predictions, following the RF packages' own -convention. It matters because summary() calls fitted() to compute R-squared, -and in-sample forest predictions are near-memorisation, so the alternative is a -summary reporting a fictitious number. The cost is that summary() means -something different here than for a gwr_fit; compare_models_cv() is the -like-for-like path. - -The OOB error is reported but labelled everywhere as a random hold-out, and so -optimistic under spatial autocorrelation for the same reason random k-fold is. -Importance defaults to permutation rather than impurity, which is biased toward -continuous and high-cardinality predictors (Strobl et al. 2007)." \ - R/model-rf.R tests/testthat/test-model-rf.R - -# --- 9 --------------------------------------------------------------------- -commit_group \ -"Regroup the test suite by subject" \ -"test-fixes-misc.R and test-fixes-round2.R were named after the review round -that produced them; test-core.R held CRS handling, regression metrics, grid -geometry, fold construction, cell summaries, Moran's I weights and GWR -bandwidth in one file. Renaming alone would have produced a different lie, so -the 36 tests are regrouped by subject into files whose names describe their -contents, each opening with a comment on why the group exists. - -No test was added or removed in the move: 36 in, 36 out." \ - tests/testthat/ - -# --- 10 -------------------------------------------------------------------- -commit_group \ -"Harden the dev scripts against measuring the installed package" \ -"library(spatialkit) loads the INSTALLED package. devtools::test() loads from -source, so a working tree can be many changes ahead and a dev script using -library() silently measures the wrong code -- which is what happened, costing a -five-hour baseline run that reported gp_k = 44 at n = 2000 (exactly the rule -this branch replaces). - -All dev scripts now load via pkgload::load_all(), print the namespace path they -loaded from, and say whether it is the working tree. The namespace path is the -ground truth; packageVersion() is not, since after load_all() it may still -report the installed DESCRIPTION. - -dev/baseline-accuracy.R now checks its acceptance criteria at runtime instead -of leaving them in a trailing comment -- it detects gp_k == floor(sqrt(n)) -specifically, because those numbers look entirely plausible otherwise. -dev/check-gp-live.R is new: one small fit, about two minutes, answering whether -the GP fix is live in the fit path before committing hours to the full -baseline." \ - dev/ .github/ - -# --- 11 -------------------------------------------------------------------- -commit_group \ -"Update generated docs, DESCRIPTION and release notes" \ -"Regenerate NAMESPACE and man/ for the new exports and S3 methods. Add ranger -to Suggests and raise the testthat floor to 3.1.5 for expect_no_error(). - -NEWS.md documents everything relative to 1.0.0, the released version. Its -heading carries a parseable version because R's NEWS reader keys entries off -it: a heading like '(development version)' makes R CMD check report 'No news -entries found'. - -cran-comments.md is marked draft and rewritten against 1.0.0; the previous text -described a 1.1.0 submission fixing three defects, and the tree now holds around -thirty changes. Everything unverified is an explicit placeholder so it cannot -quietly become a false claim. - -R CMD check: 0 errors, 0 warnings, 0 notes on R 4.6.1 / macOS. -devtools::test(): 856 passing, 1 skip." \ - NAMESPACE man/ DESCRIPTION NEWS.md cran-comments.md README.md - -# --- anything left --------------------------------------------------------- -# Deliberately NOT auto-committed: this script was written without sight of the -# working tree, so a catch-all `git add -A .` could sweep in .Rhistory, .rds -# baselines, .DS_Store or anything else not covered by .gitignore. -leftover=$(git status --porcelain) -if [ -n "$leftover" ]; then - echo - echo "=== NOT committed -- review and handle these yourself ===" - printf '%s\n' "$leftover" -fi - -echo -echo "done. review with: git log --oneline ${current}..HEAD" -echo "undo everything with: git checkout ${current} && git branch -D ${BRANCH}" diff --git a/dev/fix-ci.sh b/dev/fix-ci.sh deleted file mode 100644 index 969f348..0000000 --- a/dev/fix-ci.sh +++ /dev/null @@ -1,217 +0,0 @@ -#!/usr/bin/env bash -# --------------------------------------------------------------------------- -# Rewrite the two CI workflows. The file bridge cannot write .github/workflows -# (workflow files execute code, so remote writes to them are blocked), hence a -# script. -# -# bash dev/fix-ci.sh -# -# Changes, both files: -# * setup-r gains extra-repositories for the stan-dev universe. cmdstanr is -# in Suggests and is NOT on CRAN; R CMD check honours DESCRIPTION's -# Additional_repositories but pak does not, so dependency resolution failed -# with "Can't find package called cmdstanr" before any R code ran. -# * _R_CHECK_FORCE_SUGGESTS_: false, so an optional backend that will not -# install on one platform skips its tests instead of failing the run. -# * actions/checkout v4 -> v5 (Node 20 deprecation warning). -# --------------------------------------------------------------------------- -set -euo pipefail -[ -f DESCRIPTION ] || { echo "Run from the package root." >&2; exit 1; } -mkdir -p .github/workflows - -cat > .github/workflows/R-CMD-check.yaml <<'SKEOF' -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -on: - push: - branches: [main, master] - pull_request: - workflow_dispatch: - -name: R-CMD-check - -permissions: read-all - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: macos-latest, r: 'release'} - - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - # Every Suggests use in this package is requireNamespace()-guarded, - # so an optional backend that will not install on one platform should - # skip its tests, not fail the run. - _R_CHECK_FORCE_SUGGESTS_: false - - steps: - - uses: actions/checkout@v5 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true - # Load-bearing: cmdstanr is in Suggests and is NOT on CRAN. R CMD - # check honours DESCRIPTION's Additional_repositories, but pak -- - # which setup-r-dependencies uses to resolve Suggests -- does not, - # so without this the dependency graph fails to solve with - # "Can't find package called cmdstanr" before any R code runs. - extra-repositories: 'https://stan-dev.r-universe.dev' - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::rcmdcheck - needs: check - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' - - # --------------------------------------------------------------------------- - # Optional backends live in Suggests and are guarded by requireNamespace(). - # Without this job the matrix above skips most model tests, so a green - # matrix would prove very little. GWmodel / gstat / FNN / Matrix are cheap - # enough to install on every push; brms + Stan is not (see nightly workflow). - # --------------------------------------------------------------------------- - backends: - runs-on: ubuntu-latest - name: ubuntu-latest (release, with optional backends) - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - # Every Suggests use in this package is requireNamespace()-guarded, - # so an optional backend that will not install on one platform should - # skip its tests, not fail the run. - _R_CHECK_FORCE_SUGGESTS_: false - - steps: - - uses: actions/checkout@v5 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: 'release' - use-public-rspm: true - # Load-bearing: cmdstanr is in Suggests and is NOT on CRAN. R CMD - # check honours DESCRIPTION's Additional_repositories, but pak -- - # which setup-r-dependencies uses to resolve Suggests -- does not, - # so without this the dependency graph fails to solve with - # "Can't find package called cmdstanr" before any R code runs. - extra-repositories: 'https://stan-dev.r-universe.dev' - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: | - any::rcmdcheck - any::sp - any::GWmodel - any::gstat - any::FNN - any::Matrix - any::geometry - needs: check - - - name: Confirm optional backends are installed - run: | - for (p in c("sp", "GWmodel", "gstat", "FNN", "Matrix", "geometry")) { - if (!requireNamespace(p, quietly = TRUE)) - stop("Backend package not installed: ", p) - } - cat("All optional backends present.\n") - shell: Rscript {0} - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' -SKEOF - -cat > .github/workflows/check-brms.yaml <<'SKEOF' -# Weekly check with the brms / Stan backend installed. -# -# brms pulls in a Stan toolchain and compiles models, which takes minutes per -# run -- too slow for every push. The main R-CMD-check workflow therefore -# skips every brms-guarded code path. This workflow closes that gap on a -# schedule, and can be triggered by hand before a CRAN submission. -on: - schedule: - - cron: '0 6 * * 1' # Mondays 06:00 UTC - workflow_dispatch: - -name: check-brms - -permissions: read-all - -jobs: - check-brms: - runs-on: ubuntu-latest - name: ubuntu-latest (release, with brms) - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - # Every Suggests use in this package is requireNamespace()-guarded, - # so an optional backend that will not install on one platform should - # skip its tests, not fail the run. - _R_CHECK_FORCE_SUGGESTS_: false - - steps: - - uses: actions/checkout@v5 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: 'release' - use-public-rspm: true - # Load-bearing: cmdstanr is in Suggests and is NOT on CRAN. R CMD - # check honours DESCRIPTION's Additional_repositories, but pak -- - # which setup-r-dependencies uses to resolve Suggests -- does not, - # so without this the dependency graph fails to solve with - # "Can't find package called cmdstanr" before any R code runs. - extra-repositories: 'https://stan-dev.r-universe.dev' - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: | - any::rcmdcheck - any::brms - any::loo - any::sp - any::GWmodel - any::gstat - any::FNN - any::Matrix - needs: check - - - name: Confirm brms is installed - run: | - if (!requireNamespace("brms", quietly = TRUE)) - stop("brms not installed; this workflow has no purpose without it.") - cat("brms ", as.character(utils::packageVersion("brms")), "\n") - shell: Rscript {0} - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' -SKEOF - -echo "wrote both workflows." -git --no-pager diff --stat -- .github/workflows/ || true diff --git a/dev/make_readme_figures.R b/dev/make_readme_figures.R index d77fb80..dc2f24f 100644 --- a/dev/make_readme_figures.R +++ b/dev/make_readme_figures.R @@ -12,18 +12,26 @@ # Run from the package root: # Rscript dev/make_readme_figures.R # -# Requires: sf, ggplot2 (and devtools if spatialkit is not installed). +# Requires: sf, ggplot2, and pkgload (or an installed spatialkit). +# +# The figures are drawn by the working tree, loaded with pkgload::load_all(), +# as the other dev scripts are; an installed spatialkit is used only when +# pkgload is missing, and then the figures show that release, not the code +# in front of you. # --------------------------------------------------------------------------- suppressPackageStartupMessages({ - if (requireNamespace("spatialkit", quietly = TRUE)) { - library(spatialkit) + if (file.exists("DESCRIPTION") && requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all(".", quiet = TRUE) } else { - devtools::load_all(".", quiet = TRUE) + library(spatialkit) } library(sf) library(ggplot2) }) +cat("spatialkit loaded from: ", + tryCatch(getNamespaceInfo(asNamespace("spatialkit"), "path"), + error = function(e) NA_character_), "\n", sep = "") dir.create("man/figures", showWarnings = FALSE, recursive = TRUE) set.seed(42) @@ -131,22 +139,24 @@ p2 <- ggplot(cv_pts) + ggsave("man/figures/readme-spatial-cv.png", p2, width = 8.5, height = 7, dpi = 150, bg = "white") -# --- Figure 3: resolution sweep, with the selected k labelled --------------- -# determine_optimal_levels() is asked for the combined criterion (a geometric -# WSS elbow plus Moran's I on OLS residuals of val ~ west), but on this data -# every candidate in the elbow neighbourhood sits below the nine-cell floor -# where Moran's I on a complete k-NN graph is arithmetically degenerate, so it -# falls back to the geometric ranking and logs a warning. The label therefore -# names the elbow's choice. See "How many cells?" in README.md. -# The first element of the returned vector is the best-ranked cell count. -k_sel <- determine_optimal_levels(pts, max_levels = 15, - response_var = "val", - predictor_vars = "west")[1] +# --- Figure 3: resolution sweep, with the chosen k labelled ----------------- +# The middle count is read off resolution_profile() by the reliability of the +# cell means, and the label names that criterion. determine_optimal_levels() +# used to supply it, but these sites are spread evenly: its WSS curve has no +# elbow, and it warns that the count it returns (4 at max_levels = 15) was set +# by the ladder rather than by the data. Reliability's flat region on this +# field is wide (within 2 percent of the optimum from 3 to 25 cells), and the +# README says so rather than presenting the count as the answer. The +# profile's warning about a zero nugget concerns Cp, which is not read here. +prof_res <- suppressWarnings(resolution_profile(pts, response_var = "val", + predictor_vars = "west", + n_levels = 12)) +k_sel <- select_resolution(prof_res, criterion = "reliability")$best ks <- sort(unique(c(max(2, k_sel - 3), k_sel, 60))) if (length(ks) < 3) ks <- sort(unique(c(ks, 12))) labels <- vapply(ks, function(k) { - if (k == k_sel) sprintf("k = %d (chosen by determine_optimal_levels)", k) + if (k == k_sel) sprintf("k = %d (most reliable, resolution_profile)", k) else sprintf("k = %d", k) }, character(1)) diff --git a/dev/render_vignette.R b/dev/render_vignette.R index e16cf72..2a59eb5 100644 --- a/dev/render_vignette.R +++ b/dev/render_vignette.R @@ -27,15 +27,16 @@ cat("spatialkit loaded from: ", error = function(e) NA_character_), "\n", sep = "") # -- 2. Dependencies --------------------------------------------------------- -# 'sp' and 'GWmodel' are Suggests, and the vignette degrades gracefully when -# they are absent -- but it degrades by SKIPPING the GWR fit and the -# cross-validation, which are exactly the sections whose metric output this -# render exists to verify. A render without them would show no metric lines -# and look identical to a broken accessor. So they are required here even -# though they are optional for the package. +# 'sp', 'GWmodel' and 'ranger' are Suggests, and the vignette degrades +# gracefully when they are absent -- but it degrades by SKIPPING the GWR fit +# (sp, GWmodel) and the cross-validation contrast (ranger), which are exactly +# the sections whose metric output this render exists to verify. A render +# without them would show no metric lines and look identical to a broken +# accessor. So they are required here even though they are optional for +# the package. required <- c("sf", "dplyr", "ggplot2", "logger", "digest", "knitr", "rmarkdown", - "sp", "GWmodel") + "sp", "GWmodel", "ranger") optional <- c("geometry", # true Delaunay; otherwise falls back to the hull "patchwork") # the 3-panel side-by-side comparison @@ -85,8 +86,11 @@ rmarkdown::render( html <- readLines(file.path("docs", "spatialkit_nc_demo.html"), warn = FALSE, encoding = "UTF-8") html <- paste(html, collapse = "\n") +# One line from the GWR chunk and the sentence the cross-validation contrast +# writes under its table. Keep these in step with the vignette: a pattern for +# a line it no longer prints fails every render, right or wrong. ok <- TRUE -for (pat in c("Bandwidth: [0-9]", "CV RMSE: [0-9]")) { +for (pat in c("Bandwidth: [0-9]", "Random folds report R2 = [0-9]")) { if (!grepl(pat, html)) { ok <- FALSE cat(sprintf("FAIL: no rendered output matching /%s/\n", pat)) @@ -97,4 +101,6 @@ if (ok) { } else { cat("\nThe metric lines are still empty. Either an accessor is wrong or the", "\nGWR/CV chunks were skipped. Check the render before committing.\n") + # A non-zero exit under Rscript; source()d interactively, leave the session. + if (!interactive()) quit(status = 1) } diff --git a/inst/CITATION b/inst/CITATION index ea58145..5b0ea28 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -1,7 +1,20 @@ ## The version is read from the installed DESCRIPTION, so it cannot go stale. -## DESCRIPTION carries no Date field; fall back to the current year. -year <- if (!is.null(meta$Date) && nzchar(meta$Date)) - sub("-.*", "", meta$Date) else format(Sys.Date(), "%Y") +## The year is looked up the way utils::citation() does it: the CRAN +## publication date, then a Date field (DESCRIPTION has none), then the date +## R CMD build packaged the source, which a GitHub install normally has since +## remotes and pak build the package before installing it. Only an install +## straight from a source directory records none of them and falls back to +## the current year. [[ ]] matches exactly: meta$Date would silently pick up +## Date/Publication by partial matching. +year <- NA_character_ +for (field in c("Date/Publication", "Date", "Packaged")) { + value <- trimws(as.character(meta[[field]]))[1L] + if (!is.na(value) && grepl("^[0-9]{4}-", value)) { + year <- substr(value, 1L, 4L) + break + } +} +if (is.na(year)) year <- format(Sys.Date(), "%Y") bibentry( bibtype = "Manual", diff --git a/inst/scripts/02-resolution.R b/inst/scripts/02-resolution.R index 7ca65dd..9b20583 100644 --- a/inst/scripts/02-resolution.R +++ b/inst/scripts/02-resolution.R @@ -29,8 +29,11 @@ if (!skip_without("ggplot2", "the variogram")) { step("02.2", "Candidate cell counts, cheapest first") # determine_optimal_levels() only looks at geometry: it clusters the points and -# reports the level counts where the within-cluster spread stops improving. -# Seconds, not minutes, and it is the right first move. +# reads the elbow of the within-cluster spread on log-log axes. Seconds, not +# minutes. These points are spread evenly, so there is no elbow to read, and +# the call warns that the count it still returns was set by max_levels rather +# than by the data. That warning is the finding: here the count has to come +# from the profile in 02.3. lv <- determine_optimal_levels(pts, max_levels = 40) cat(" geometric candidates:", paste(lv, collapse = ", "), "\n") @@ -57,10 +60,13 @@ for (cr in c("cp", "reliability", "elbow", "moran_z")) { cat(sprintf(" %-12s not available on this profile\n", cr)) next } - # `at_floor` / `at_ceiling` mean the optimum is the end of the ladder, so the - # ladder chose and the criterion did not. Widen n_levels and run it again. - edge <- if (isTRUE(s$at_floor)) " <- at the floor of the ladder" - else if (isTRUE(s$at_ceiling)) " <- at the ceiling of the ladder" else "" + # `edge` names the bound an optimum sits on: the range floor, the support + # ceiling, or the first level the criterion can be computed at (above nine + # cells for moran_z). There the bound chose and the criterion did not. + # n_levels only sets how many rungs fall between the ends, so it cannot move + # them: lower min_cell_n to move the ceiling, or set range_floor = FALSE (or + # pass `levels`) to move the floor, and run it again. + edge <- if (!is.na(s$edge)) paste0(" <- at ", s$edge) else "" # The flat region is a SET: it can skip a rung, so printing its first two # members as "a to b" both truncated it and implied the levels between were # in it. Name the others, or count them when there are too many to read. @@ -75,8 +81,9 @@ cat(" Pick one before you look, and say which one you picked.\n") if (!skip_without("ggplot2", "the profile plot")) { look_for("where the curves stop moving. A criterion whose optimum sits at ", - "the first or last level of the ladder did not choose: the ladder ", - "did. Widen n_levels and run it again.") + "the first or last level it was scored at did not choose: the bound ", + "did, and the caption says which. Lower min_cell_n to move the ", + "ceiling, or set range_floor = FALSE to move the floor, and run it again.") show_plot(plot(prof), "02-profile.png", height = 7) } @@ -88,22 +95,39 @@ prof_split <- resolution_profile(pts, response_var = "z", n_levels = 16, select_on = "split") sp <- attr(prof_split, "split") if (!is.null(sp)) print(sp) -b_all <- select_resolution(prof, "reliability")$best -b_split <- select_resolution(prof_split, "reliability")$best -cat(sprintf(" select_on = 'all' -> %d cells\n", b_all)) -cat(sprintf(" select_on = 'split' -> %d cells\n", b_split)) -if (b_all == b_split) { - cat(" They agree, so the choice did not depend on the rows you will test on.\n") +# Where each pick sits is computed, not assumed: a pick on the range floor +# moves with the range, and the split estimates the range on half the points. +s_all <- select_resolution(prof, "reliability") +s_split <- select_resolution(prof_split, "reliability") +pick_line <- function(lab, s, p) + cat(sprintf(" select_on = %-7s -> %d cells (range floor %s)%s\n", lab, s$best, + format(attr(p, "bounds")$floor), + if (!is.na(s$edge)) paste0(", at ", s$edge) else "")) +pick_line("'all'", s_all, prof) +pick_line("'split'", s_split, prof_split) +on_floor <- grepl("range floor", c(s_all$edge, s_split$edge), fixed = TRUE) +if (s_all$best == s_split$best) { + cat(" They agree here.\n") +} else if (all(on_floor)) { + cat(" Both picks sit on the range floor, and the floor moved because the\n", + " split estimates the range on the selection half alone. The difference\n", + " is that range estimate, not a sign that the choice was tuned.\n", sep = "") } else { - cat(" They disagree, so the resolution was tuned to rows you were planning\n", - " to test on, and the test is no longer independent of the choice.\n", - sep = "") + cat(" They differ, partly because the split's criteria and range read half\n", + " the points, so the difference alone does not measure the tuning.\n", sep = "") } +cat(" What the split buys: the estimation half's response never enters the\n", + " choice. What it does not: rows near the border between the halves are\n", + " still correlated with the selection half, so the halves are not\n", + " independent.\n", sep = "") step("02.6", "What the chosen resolution looks like") if (!skip_without("ggplot2", "the maps")) { bnd <- tour_boundary(pts) - chosen <- select_resolution(prof, "elbow")$best + # Cp, the default criterion: these evenly spread points have no elbow (see + # 02.2), so the elbow names no count to draw. + s_cp <- select_resolution(prof, "cp") + chosen <- s_cp$best for (k in sort(unique(c(min(prof$levels), chosen, max(prof$levels))))) { seeds <- get_voronoi_seeds(boundary = bnd, method = "kmeans", n = k, sample_points = pts, set_seed = 1) @@ -112,7 +136,8 @@ if (!skip_without("ggplot2", "the maps")) { cel <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), "z", cells_sf = tess$cells, deff = 1) note <- if (k == chosen) - "the elbow pick: enough cells to show the field, few enough to fill." + paste0("the Cp pick", if (!is.na(s_cp$edge)) paste0(" (at ", s_cp$edge, ")") else "", + ": enough cells to show the field, few enough to fill.") else if (k == min(prof$levels)) "the coarsest level: every cell is well filled, but there is barely a map left." else diff --git a/inst/scripts/07-surface-aoa.R b/inst/scripts/07-surface-aoa.R index 372cfe2..876c9a7 100644 --- a/inst/scripts/07-surface-aoa.R +++ b/inst/scripts/07-surface-aoa.R @@ -13,7 +13,7 @@ bnd <- tour_boundary(pts) # Train on the western half only. `slope` runs west to east in this fixture, so # the eastern half is genuinely new ground in predictor space, not just on the # map -- which is the situation the area of applicability exists to detect. -west <- pts[sf::st_coordinates(pts)[, 1] < 500, ] +west <- pts[sf::st_coordinates(pts)[, 1] < 5e5 + 500, ] # x runs 5e5 to 5e5 + 1000 ws_fit <- function(train_sf, ...) { new_spatial_fit(subclass = "ws_fit", engine = stats::lm(z ~ elev + slope, diff --git a/inst/scripts/08-feature-select.R b/inst/scripts/08-feature-select.R index 1df79e7..ee6fe40 100644 --- a/inst/scripts/08-feature-select.R +++ b/inst/scripts/08-feature-select.R @@ -19,7 +19,11 @@ pts$junk1 <- stats::rnorm(nrow(pts)) pts$junk2 <- stats::rnorm(nrow(pts)) pts$junk3 <- stats::rnorm(nrow(pts)) cands <- c("elev", "slope", "noise", "junk1", "junk2", "junk3") -BS <- 300 # block size, comfortably wider than the estimated range +# Block size: a little UNDER the range script 02 estimates on z (about 357), +# because the 1000-unit square holds only four blocks of 360, fewer than the +# five folds, and the half-layer of 08.5 only two. Blocks this size still leak +# a little across their edges, so the scores below are somewhat optimistic. +BS <- 300 xy <- sf::st_coordinates(pts) cat(sprintf(" slope has no effect on z by construction, yet cor(slope, z) = %.2f,\n", @@ -115,7 +119,9 @@ cat(" Set it from what would matter in the application, not from what leaves\n" step("08.5", "The honest score for a selected model") # The cross-validation that drove the search cannot also measure the winner. # `select_on = "split"` runs the search on half the data, spatially split, and -# leaves the other half untouched to score with. +# holds the other half out of the search to score with. Held out is not +# independent: the halves share a border, and rows near it are still +# correlated with the half the search saw. # (It warns about fold imbalance: half the rows means uneven counts per block.) sel_sp <- select_features_forward(pts, "z", cands, fit_fn = lm_on, k = 5, method = "block_kfold", block_size = BS, @@ -125,10 +131,13 @@ print(sel_sp$split) cat(sprintf(" selected on the search half : %s\n", paste(sel_sp$selected, collapse = ", "))) cat(sprintf(" score on the search half : %.3f\n", sel_sp$score)) -cat(sprintf(" score on the untouched half : %.3f", sel_sp$score_holdout)) +cat(sprintf(" score on the held-out half : %.3f", sel_sp$score_holdout)) cat(sprintf(" (%.0f%% worse)\n", 100 * (sel_sp$score_holdout / sel_sp$score - 1))) -cat(" That difference is the selection effect, measured rather than assumed.\n") +cat(" Part of that gap is the selection effect. Part is that the two scores\n", + " come from different rows, a different region and a different amount of\n", + " training data, so the gap is one estimate, not a measurement of it.\n", + sep = "") step("08.6", "Two runs, two answers, one write-up") cat(sprintf(" searched on all %d rows : %s\n", nrow(pts), diff --git a/inst/scripts/09-gwr.R b/inst/scripts/09-gwr.R index 390070f..978e204 100644 --- a/inst/scripts/09-gwr.R +++ b/inst/scripts/09-gwr.R @@ -38,10 +38,14 @@ step("09.3", "Check for local collinearity before believing any of it") # Two predictors that are globally independent can be nearly collinear inside a # small neighbourhood. Where that happens the local coefficients are unstable # and their signs are arbitrary. -cat(sprintf(" local condition number above threshold: %d of %d fits\n", +# n_local_collinear counts the locations whose local SLOPES are collinear (a +# slope condition index above 30); n_local_singular counts the locations whose +# coefficients came back non-finite, which is undefined kernel weights (several +# observations at one point), not a singular window: that stops the fit. +cat(sprintf(" locations with collinear local slopes: %d of %d\n", gw$info$n_local_collinear, nrow(cf))) -cat(sprintf(" locally singular: %d, non-finite coefficients: %d\n", - gw$info$n_local_singular, sum(gw$info$nonfinite_coef))) +cat(sprintf(" locations with non-finite coefficients (undefined kernel weights): %d\n", + gw$info$n_local_singular)) if (gw$info$n_local_collinear > 0) cat(" Widen the bandwidth or drop a predictor before reading the maps.\n") diff --git a/inst/scripts/10-bayes.R b/inst/scripts/10-bayes.R index e4eaf17..bac9d6d 100644 --- a/inst/scripts/10-bayes.R +++ b/inst/scripts/10-bayes.R @@ -22,15 +22,22 @@ sub <- pts[sample(nrow(pts), 100), ] cat(sprintf(" running on %d of %d points to keep the sampling tractable\n", nrow(sub), nrow(pts))) -step("10.1", "How fine a length-scale can the basis even represent?") +step("10.1", "What length-scales the prior expects, before fitting") # The GP is approximated by a basis expansion, and `gp_k` sets how many terms -# it gets. Too few and the model cannot represent short-range structure no -# matter what the data say. Check the bounds BEFORE fitting; it costs nothing. +# it gets per axis. Too few and the model cannot represent short-range +# structure no matter what the data say. +# gp_lengthscale_bounds() gives the range the length-scale PRIOR is calibrated +# over. They are not the scales the basis resolves: that depends on gp_k, and +# the fit reports it in 10.3. The lower bound is a fixed fraction of the +# pairwise distances (their 25th percentile / 2.45), so it does not move with +# n, and neither does the gp_k derived from it. bounds <- gp_lengthscale_bounds(sf::st_coordinates(sub)) -cat(sprintf(" resolvable length-scales: %.0f to %.0f CRS units\n", +cat(sprintf(" length-scale prior calibrated over %.0f to %.0f CRS units\n", bounds["lower"], bounds["upper"])) -cat(" A field whose true range sits below the lower bound needs more points,\n", - " not a bigger gp_k.\n", sep = "") +cat(" A field whose true range sits below the scale the basis resolves needs a\n", + " bigger gp_k: neither these bounds nor the derived basis grow finer with\n", + " n, though denser sampling still helps the data identify a short range.\n", + sep = "") step("10.2", "Fit it") t0 <- Sys.time() @@ -53,13 +60,19 @@ cat(sprintf(" basis : gp_k %d -> %d functions\n", bf$info$gp_k, bf$info$gp_n_basis)) cat(sprintf(" finest scale : %.2f in scaled units = %.0f CRS units\n", bf$info$gp_ell_min, ell_crs)) +# gp_k = 12 is below the 20-25 the rule derives when gp_k is left NULL, to +# keep the fit fast, so this basis may not reach the prior's lower bound. +cat(sprintf(" prior's lower : %.0f CRS units (10.1) -- %s\n", bounds["lower"], + if (ell_crs > bounds["lower"]) + "finer than this basis resolves; a larger gp_k would reach it" + else "within what this basis resolves")) if (!is.null(bf$info$looic)) cat(sprintf(" LOOIC : %.1f\n", bf$info$looic)) cd <- bf$info$convergence_diagnostics if (!is.null(cd) && length(cd)) cat(" diagnostics :", paste(utils::head(names(cd), 6), collapse = ", "), "\n") -cat(" The message about length-scale draws below the resolvable scale is the\n", - " one to act on: raise gp_k and refit, or accept that the short-range\n", +cat(" The logged WARN line about length-scale draws below the resolvable scale\n", + " is the one to act on: raise gp_k and refit, or accept that the short-range\n", " structure is outside this model's reach and say so.\n", sep = "") step("10.4", "What it buys: an interval per prediction") diff --git a/inst/scripts/_common.R b/inst/scripts/_common.R index ea50a50..33a4f0d 100644 --- a/inst/scripts/_common.R +++ b/inst/scripts/_common.R @@ -97,6 +97,12 @@ tour_points <- function(n = 400, a = 80, seed = 42) { # applicability in script 07 have something to find. Scripts 01 to 06 ignore # the column. xy$slope <- 2 * xy$x / 1000 + stats::rnorm(n, sd = 0.2) + # Move the square into UTM zone 32N, the CRS it is stamped with: x from + # 500000 and y from 5000000. At 0 to 1000 it would sit on the equator west + # of the zone. Every result is computed in planar units, so the shift only + # changes the coordinates the scripts print. + xy$x <- xy$x + 5e5 + xy$y <- xy$y + 5e6 sf::st_as_sf(xy[, c("x", "y", "elev", "noise", "slope", "z")], coords = c("x", "y"), crs = 32632) } diff --git a/man/area_of_applicability.Rd b/man/area_of_applicability.Rd index 6f46711..9ea5d43 100644 --- a/man/area_of_applicability.Rd +++ b/man/area_of_applicability.Rd @@ -42,11 +42,32 @@ expected to supply importances for them: any you leave out default to the mean of the weights you did supply, so location counts about as much as a typical predictor. Naming them explicitly overrides that. An unnamed vector may have one value per predictor either with or without the two -coordinate columns.} +coordinate columns. Weights must be finite and non-negative, so pass +permutation importance as \code{pmax(importance, 0)}. (A forest with no +out-of-bag rows, \code{replace = FALSE} with \code{sample_fraction = 1}, +has \code{NaN} importance, which \code{pmax()} keeps and which is +refused; refit it with out-of-bag rows or use \code{weights = NULL}.) +\code{pmax(importance, 0)} is all zero when the model found no +predictor useful, and then the weights cannot say +anything: with a single predictor any weight gives the same index and zero +is accepted; with several, all of them are weighted equally, as with +\code{weights = NULL}, and a warning says so. The coordinate default +above is the mean of the supplied weights, so a zero weight on the only +covariate of a coordinate-using model zeroes the coordinates too, and +that equal weighting applies.} \item{folds}{Cross-validation folds: a \code{\link{make_folds}} result, a list of \code{train}/\code{test} splits, or a vector of fold labels with -one entry per training row. Default \code{NULL} (plain nearest neighbour).} +one entry per training row. Default \code{NULL} (plain nearest neighbour). +The folds you passed to \code{cv_*()}, built on the layer \code{model} +was fitted from, may name rows that \code{prep_model_data()} removed +(a missing or non-finite value, an empty geometry): as in \code{cv_*()}, +they are dropped from the folds, and a label vector with one entry per +row of that layer loses theirs. Also +as in \code{cv_*()}, a \code{make_folds()} result built on other data -- +another layer, or these rows in another order -- is refused. That check +is skipped when the folds were built on polygons and the training data +are the points a fit reduced them to.} \item{threshold}{Optional numeric override for the DI threshold.} @@ -56,7 +77,8 @@ computing the mean pairwise distance, which is quadratic. Default 5000.} \item{seed}{Seed for that subsample. Default 123.} \item{chunk_size}{Query rows per distance block on the dense path. Default -\code{NULL} (chosen from the training size).} +\code{NULL} (chosen from the training size). Otherwise a single number of +at least 1; a fractional value is truncated to a whole number of rows.} \item{use_fnn}{Use \pkg{FNN} for nearest-neighbour search when available. Exposed so the dense fallback can be tested.} @@ -69,7 +91,9 @@ and a logical \code{AOA} column added. This is the object the computation ran on, which for a coordinate-using model is \code{newdata} after pointizing, CRS reconciliation and the addition of the \code{"..x"} and \code{"..y"} columns. A row whose predictors -are not all finite gets \code{NA} in both columns. +are not all finite gets \code{NA} in both columns, and a row outside +the training range of a predictor in \code{dropped_vars} gets +\code{DI = Inf} and \code{AOA = FALSE} (see \emph{Limitations}). \item \code{threshold}: the DI cut-off used. \item \code{train_DI}: the training points' own DI values. \item \code{normalizer}: the mean pairwise training distance. @@ -89,8 +113,10 @@ traced to the predictor that put it outside. aside (the "outlier-removed" in its name); computed whether or not \code{threshold} was supplied. \item \code{n_train}, \code{n_new}, \code{n_inside}, -\code{n_outside}, \code{n_na}: row counts; \code{n_train} and -\code{n_new} count the rows that survived the finite-value filter. +\code{n_outside}, \code{n_na}: row counts. \code{n_train} counts the +training rows that survived the finite-value filter; \code{n_new} is +every row of \code{newdata}, so +\code{n_new = n_inside + n_outside + n_na}. \item \code{params} records the call: \code{folds_supplied}, \code{n_folds}, \code{folds_method}, \code{threshold_supplied}, \code{normalizer_max_n}, \code{normalizer_n_used}, @@ -134,12 +160,35 @@ each point's nearest neighbour \emph{among the training rows of the fold that holds it out}. That means everything outside its own fold for random and block folds, and the smaller training set that buffered and NNDM folds actually leave (see the next section). The threshold is then the largest -training DI that is not an upper outlier. Prediction points at or below that -threshold are inside the AOA. +training DI that is not an upper outlier, i.e. not above the fence +\code{Q3 + 1.5 * IQR} of the training DI, with the quartiles of +\code{stats::quantile()}'s default type 7. Prediction points at or below +that threshold are inside the AOA. + +That is the paper's "outlier-removed maximum". \pkg{CAST}, the reference +implementation, computes the same fence with the same quartiles but uses the +fence itself as the threshold, capped at the largest training DI. The two +agree whenever no training DI lies above the fence (\code{n_outliers} is 0); +otherwise \pkg{CAST}'s threshold is the larger, and so is its AOA. (Earlier +\pkg{CAST} releases used \code{grDevices::boxplot.stats()}, which gives the +rule used here but with Tukey's hinges as the quartiles, so they can also +differ when the number of training points is even.) To apply the current +\pkg{CAST} rule to the same training DI, pass +\code{threshold = min(quantile(res$train_DI, 0.75) + 1.5 * IQR(res$train_DI), +max(res$train_DI))} for an earlier result \code{res}. The DI is invariant to the overall scale of \code{weights}: the numerator and the normaliser carry the same factor. Importance values can be passed as-is. + +Each training point's reference is its nearest \emph{other} training row, so +an exact duplicate in predictor space (repeat visits to a site with static +covariates, or covariates read off a raster coarser than the sampling) has a +training DI of 0. Once about three quarters of the rows have a twin among +their reference rows the threshold is 0, and only exact copies of a +training row count as inside. That is logged as a caution; folds that keep +the duplicates together (\code{make_folds(method = "leave_location_out", +group_var = ...)}), or removing them, give the threshold its meaning back. } \section{The fold scheme changes the answer, and should}{ @@ -161,11 +210,14 @@ Predictors must be numeric; categorical variables are refused and never silently dummy-coded. Predictors whose variance is negligible \emph{relative to their own magnitude} (the test is \code{sd < sqrt(.Machine$double.eps) * max(abs(x))}, so the same variable in -metres and in gigametres is treated identically) are dropped, and a -prediction point taking a different value there is a form of extrapolation -this index cannot express. Without \code{weights} every predictor counts -equally, which overstates dissimilarity along directions the model barely -uses. +metres and in gigametres is treated identically) are dropped from the +distance. A prediction point taking a value there outside the training +range (with the same relative tolerance) is extrapolation along a direction +the training data never varied in: its scaled distance along it is +infinite, so it gets \code{DI = Inf}, is outside the AOA, and a warning +gives the count. A point missing that value is judged on the other +predictors. Without \code{weights} every predictor counts equally, which +overstates dissimilarity along directions the model barely uses. } \section{Models fitted with the coordinates as predictors}{ diff --git a/man/assign_features_to_polygons.Rd b/man/assign_features_to_polygons.Rd index b55d39b..7cbeb8d 100644 --- a/man/assign_features_to_polygons.Rd +++ b/man/assign_features_to_polygons.Rd @@ -25,36 +25,62 @@ assign_features_to_polygons( polygon, carrying \code{NA} in the ID column. Default FALSE, which drops them.} -\item{predicate}{Binary spatial predicate function. Default sf::st_intersects.} +\item{predicate}{Binary spatial predicate function. Default sf::st_intersects. +Not used when \code{largest} applies: sf then assigns polygon features by +overlap area and never calls the predicate.} \item{largest}{Logical; when \code{features_sf} is itself polygonal, keep the polygon with the largest overlap. Default TRUE. Ignored for point and -line features, and silently dropped if the \code{predicate} does not -support it (\code{sf::st_intersects} does).} +line features. A feature that only touches the polygon layer (shares an +edge or a corner with it, with no overlap area) has no largest overlap +and is unassigned, in any CRS; with \code{largest = FALSE} the default +\code{st_intersects} counts touching, so such a feature is assigned. +A feature that overlaps two or more polygons by exactly the same area +(to 9 significant digits; a square split evenly across a cell edge) is +given to one of them by \code{tie_break} and counted in \code{"ties"}, +so the choice does not depend on the order of the polygon rows. +Invalid geometries (usually a self-intersecting ring), +whose overlap is undefined, are repaired with \code{sf::st_make_valid()} +for the join, with a warning, and returned as they arrived. If the +overlap still cannot be computed the function stops: falling back to +\code{predicate} and \code{tie_break} would change the rule for every +feature in the layer, so pass \code{largest = FALSE} to ask for that.} \item{tie_break}{Strategy for resolving features that match multiple -polygons: \code{"smallest_area"} (default) keeps the polygon with the -smallest area, \code{"first"} keeps the first match (original order-dependent +polygons (with \code{largest}, that overlap several polygons equally): +\code{"smallest_area"} (default) keeps the polygon with the +smallest area and, among polygons of equal area (a point on the shared +edge of two grid cells), the one whose bounding-box centre is lowest, +then leftmost, so the choice does not depend on the order of the rows; +\code{"first"} keeps the first match (original order-dependent behavior).} } \value{ An sf object with \code{polygon_id_col} attached, one row per input feature (fewer if \code{keep_unassigned = FALSE} dropped unmatched ones), in -the CRS \code{features_sf} arrived in. Any column of \code{features_sf} whose name -would collide with the polygon ID column is dropped before the spatial -join (with a warning), so re-assigning an already-assigned layer replaces -the old IDs and does not fail. If \emph{no} feature falls inside any polygon +the CRS \code{features_sf} arrived in. A column of \code{features_sf} already +called \code{polygon_id_col} is dropped before the spatial join (with a +warning), so re-assigning an already-assigned layer replaces the old IDs +and does not fail. Every other column is kept, including one named like +the polygons' own ID column when that is read from a fallback such as +\code{"id"} (a site \code{id} joined to cells keyed by \code{id}). If \emph{no} feature +falls inside any polygon the result is empty (or all-\code{NA} with \code{keep_unassigned = TRUE}) and a warning is raised, since the usual cause is two layers in different places (a CRS that could only be stamped, not reprojected). The attribute \code{"ties"} records how many features matched more than one -polygon and had the \code{tie_break} rule decide for them: a list with \code{n}, -\code{which} (their row positions in \code{features_sf}) and \code{rule}. A large \code{n} -means the polygon layer overlaps, and per-cell counts built from the +polygon (with \code{largest}, overlapped several by exactly the same area) +and had the \code{tie_break} rule decide for them: a list with \code{n}, +\code{which} (their row positions in \code{features_sf}), \code{rule} and \code{n_rows} +(the number of rows returned, which the record was made for). A large +\code{n} means the polygon layer overlaps, and per-cell counts built from the result depend on the rule. The record describes the rows this call -returned and does not survive subsetting: \code{joined[i, ]} is a plain layer +returned and does not survive subsetting: \code{joined[i, ]}, like +\code{dplyr::filter()}, \code{slice()} or \code{arrange()} of it, is a plain layer with no \code{"ties"} attribute, so nothing reports the parent's count -against row positions that no longer resolve. +for a different set of rows. \code{sf::st_drop_geometry()} keeps the record, +since the rows are the same; see \code{\link{[.spatialkit_rows}} for +what binding such data frames does. } \description{ Joins an sf layer of input features to a polygon layer via spatial join. @@ -67,6 +93,13 @@ 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. + +The join runs in the CRS of \code{polygons_sf} whenever that CRS is projected, +so cell edges are the straight lines the cells were drawn with and overlap +areas are planar. A copy of \code{features_sf} is transformed for it, and the +features come back with the coordinates they arrived with. Otherwise (the +polygons are in lon/lat, or carry no CRS) the join runs in the CRS of +\code{features_sf}. } \examples{ library(sf) diff --git a/man/build_tessellation.Rd b/man/build_tessellation.Rd index 630bff7..a551864 100644 --- a/man/build_tessellation.Rd +++ b/man/build_tessellation.Rd @@ -26,7 +26,18 @@ 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}.} +\code{clip = TRUE}. When exactly one of \code{points_sf} and \code{boundary} has a CRS, +the other is interpreted in it, with a warning. CRS-less points, and a +CRS-less boundary given with projected points, are read as +\code{\link[=harmonize_crs]{harmonize_crs()}} does; CRS-less points that do not look like lon/lat +cannot take a geographic boundary's CRS and are refused with an error. A +CRS-less boundary given with lon/lat points is read as lon/lat when its +coordinates fit the lon/lat envelope, and refused with an error +otherwise. When neither has one, both are read by the lon/lat heuristic +of \code{\link[=ensure_projected]{ensure_projected()}}: taken as EPSG:4326 and projected when the points +look like degrees (a boundary whose coordinates do not fit the lon/lat +envelope is then refused with an error), otherwise left in the same +unnamed planar space.} \item{method}{One of "voronoi", "triangles", "hex", "square".} @@ -44,24 +55,56 @@ vector of ranked candidates from \code{\link{determine_optimal_levels}()} (its \code{$best}), or a \code{\link{resolution_profile}()} (read with \code{select_resolution()} at its default criterion). The count used is returned as \code{params$approx_n_cells} and where it came from as -\code{params$approx_n_cells_from} (\code{NULL} for a plain number).} +\code{params$approx_n_cells_from} (\code{NULL} for a plain number). +A count read off a profile or selection is a number of k-means cells: +every one occupied, and small where the points are dense. A lattice +lays that many equal cells over the whole boundary, so on clustered +points many of them hold no point (about half, on six clusters in a +square); on evenly spread points it matches. \code{params$cells_occupied} +and \code{params$cells_empty} report how the points filled the grid, and +a count that came from a profile or selection warns when fewer than +three quarters of it are occupied. For cells that follow the points, +seed a Voronoi tessellation with +\code{get_voronoi_seeds(method = "kmeans", n = , sample_points = )}.} \item{cellsize}{Numeric cell size, in the units of the working CRS. Read by \code{method = "hex"} and \code{"square"} only; the other two methods warn that it was ignored. When both \code{cellsize} and \code{approx_n_cells} are given, \code{cellsize} wins and \code{approx_n_cells} is ignored with -a logged warning; supply one or the other.} +a logged warning; supply one or the other. With a geographic \code{crs} +it is in that CRS's degrees, and the grid is laid in degrees.} -\item{expand}{Buffer distance for the Voronoi envelope. Applied by +\item{expand}{Buffer distance, in the working CRS's units, by which the +Voronoi boundary is grown before the diagram is built. Applied by \code{method = "voronoi"} only; the \code{"hex"}, \code{"square"} and \code{"triangles"} methods ignore it (the value you passed is still echoed back in -\code{params$expand}).} +\code{params$expand}). With \code{clip = TRUE} the cells are clipped to the grown +boundary, which is the one returned as \code{boundary}: cells reach \code{expand} +beyond the study area, and a point up to \code{expand} outside it is indexed.} \item{clip}{Logical; clip to boundary.} -\item{keep_duplicates}{Logical; keep duplicate points.} +\item{keep_duplicates}{Logical. Has no effect on the cells or the index: +coincident points are merged before a Voronoi diagram or a Delaunay +triangulation is built either way, and every one of them is indexed to +the cell they share.} -\item{crs}{Optional target CRS.} +\item{crs}{Optional target CRS: anything \code{\link[sf:st_crs]{sf::st_crs()}} accepts, including +an sf or sfc layer, whose CRS is used. A projected CRS is the working +CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned +in: the cells are built in the local projected CRS \code{\link[=ensure_projected]{ensure_projected()}} +picks for the points, indexed there, and then transformed with long edges +densified, so Voronoi cells are nearest-point cells on the ground and +grid cells are laid in metres rather than degrees. The exception is a hex +or square grid sized by \code{cellsize}, which is in degrees and so is laid in +degrees. Whenever that local CRS is picked for lon/lat points, or +CRS-less ones taken as lon/lat (no \code{crs}, or a geographic one), a hex or +square grid with a boundary is laid in it unless it +distorts areas across the boundary by more than 1 percent (Web Mercator +over a near-global extent, say); the grid is then laid, and the points +indexed, in the equal-area CRS \code{ensure_projected(purpose = "area")} picks +for the boundary, with a logged warning, as \code{\link[=create_grid_polygons]{create_grid_polygons()}} +does, so the cells stay equal-area.} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo @@ -80,12 +123,15 @@ median cell width of a cell is snapped to it. That covers points sitting exactly on a shared edge, and leaves points outside the study area as \code{NA}. A summary built from \code{index} therefore counts only the points the tessellation actually covers.} -\item{\code{boundary}}{The boundary used (possibly derived and/or reprojected).} +\item{\code{boundary}}{The boundary used (possibly derived and/or +reprojected, and for \code{"voronoi"} grown by \code{expand}).} \item{\code{method}}{The method actually used.} \item{\code{params}}{The parameters the tessellation was built with, plus \code{snapped}, the record of that nearest-cell repair: a list with \code{n}, \code{which} (row positions in \code{points_sf}) and \code{distance} (how far -outside every cell each sat, in CRS units).} +outside every cell each sat, in CRS units). For \code{"hex"} and +\code{"square"} also \code{cells_occupied} and \code{cells_empty}, the number of +cells that hold at least one point and that hold none.} } } \description{ @@ -110,6 +156,12 @@ axis-aligned artefacts of squares and have uniform neighbour distances. interpolation and adjacency work; it is not meant as an aggregation unit. \code{\link{determine_optimal_levels}()} will suggest a cell count from the spatial structure of the data. + +\code{"voronoi"} and \code{"triangles"} are built on the points' vertices: +a MULTIPOINT feature with several vertices gets one cell (or triangle +corner) per vertex, and its \code{index} entry is the smallest +\code{cell_id} among the cells it touches. See +\code{\link{create_voronoi_polygons}()}. } \examples{ library(sf) diff --git a/man/clip_target_for.Rd b/man/clip_target_for.Rd index 25f0054..d80327b 100644 --- a/man/clip_target_for.Rd +++ b/man/clip_target_for.Rd @@ -9,7 +9,13 @@ clip_target_for(points_sf, boundary = NULL, expand = 0, quiet = FALSE) \arguments{ \item{points_sf}{An sf object with POINT/MULTIPOINT geometry.} -\item{boundary}{Optional polygonal sf object.} +\item{boundary}{Optional polygonal sf object. One with no CRS, given with +points that have one, is interpreted in the points' own CRS, with a +warning. With points in a projected CRS it is read as \code{\link[=harmonize_crs]{harmonize_crs()}} +does: coordinates that look like lon/lat are taken as EPSG:4326 and +reprojected, anything else is stamped with the points' CRS. With lon/lat +points it is read as lon/lat when its coordinates fit the lon/lat +envelope, and refused with an error otherwise.} \item{expand}{Numeric expansion distance or fraction (0–1 = fraction of extent). Absolute values are expressed in the units of the CRS the clip @@ -28,16 +34,27 @@ the layer is returned in the automatically selected local projected CRS, not the input CRS; a message reports this unless \code{quiet = TRUE}. } \description{ -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 +Resolves a single polygon to tessellate within. With a \code{boundary} it is +that boundary (optionally buffered by \code{expand}); without one it is the +axis-aligned bounding box of \code{points_sf} (the rectangle in the working +CRS), again optionally buffered, or a small buffer around the points when +they all share one x or one y, or nearly so (the short side of their +bounding box below a millionth of the long side). Reach for it to build the +\code{boundary} that +\code{method = "hex"} and \code{"square"} require, 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. } +\details{ +It is not the target \code{\link[=build_tessellation]{build_tessellation()}} derives on its own: +\code{method = "voronoi"} without a boundary clips to the convex hull of the +points buffered by 2 percent of its diagonal, and there \code{expand} is always +a distance. A bounding box over a non-rectangular point cloud includes +corners with no data, so a hex or square grid laid over it has cells that +hold no points; pass the study-area polygon when there is one. +} \examples{ library(sf) set.seed(1) @@ -45,9 +62,9 @@ pts <- st_as_sf( data.frame(x = 5e5 + runif(30, 0, 100), y = 5e6 + runif(30, 0, 100)), coords = c("x", "y"), crs = 32632 ) -# No boundary: the convex hull, expanded by 10\% of the extent -hull <- clip_target_for(pts, expand = 0.1, quiet = TRUE) -st_area(hull) +# No boundary: the bounding box, expanded by 10\% of the extent +box <- clip_target_for(pts, expand = 0.1, quiet = TRUE) +st_area(box) } \seealso{ Other spatial data preparation: diff --git a/man/coef.bayesian_fit.Rd b/man/coef.bayesian_fit.Rd index e820c60..2d5b45a 100644 --- a/man/coef.bayesian_fit.Rd +++ b/man/coef.bayesian_fit.Rd @@ -13,7 +13,9 @@ } \value{ A matrix of fixed-effect posterior summaries, as returned by -\code{brms::fixef()}. Never \code{NULL}: a missing 'brms' or a failing +\code{brms::fixef()}, on the fitted scale (per standard deviation of each +predictor under \code{standardize_predictors = TRUE}; see above). Never +\code{NULL}: a missing 'brms' or a failing \code{fixef()} call errors, following the \code{coef()} contract described in \code{\link{new_spatial_fit}}. } @@ -26,6 +28,25 @@ 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. } +\section{Standardised predictors}{ + +The summaries are on the scale the model was fitted on. A fit made with +\code{standardize_predictors = TRUE} was fitted on centred and scaled +numeric predictors, so each slope is the change in the linear predictor per +\emph{standard deviation} of its predictor and the intercept is its value +at the predictor \emph{means}, not the raw-unit numbers \code{stats::lm()} +reports on the same formula. Nothing on the returned matrix says so; +\code{print()} on the fit does, and the centre and scale of each predictor +are in \code{object$info$predictor_scaling}. To put a slope back in raw +units divide its \code{Estimate}, \code{Est.Error} and interval bounds by +that predictor's \code{scale}. The intercept's \code{Estimate} follows by +linearity (subtract each raw-unit slope times its predictor's +\code{center}), but its \code{Est.Error} and interval depend on the +posterior covariance of the coefficients: transform the draws from +\code{brms::as_draws_df(object$engine)} for those, or refit without +standardising. +} + \seealso{ Other methods on a fitted model: \code{\link{coef.gwr_fit}()}, diff --git a/man/coerce_to_points.Rd b/man/coerce_to_points.Rd index 683eee2..373e9a9 100644 --- a/man/coerce_to_points.Rd +++ b/man/coerce_to_points.Rd @@ -18,24 +18,34 @@ coerce_to_points( "line_midpoint", "bbox_center".} \item{tmp_project}{Logical; temporarily project for line-based midpoints. -When \code{x} has no CRS and its coordinates fall inside the lon/lat -envelope, that temporary projection interprets them as EPSG:4326 (with a -warning) and the midpoints returned are geodesic ones brought back to the -input's numbers, not planar midpoints. Set the CRS, or pass -\code{tmp_project = FALSE}, for planar data.} +When \code{x} has no CRS and the lon/lat heuristic of +\code{\link{ensure_projected}()} takes its coordinates for degrees +(inside the lon/lat envelope and more than one unit across, or with +decimal-degree precision), that temporary projection interprets them as +EPSG:4326 (with a warning) and the midpoints returned are geodesic ones +brought back to the input's numbers, not planar midpoints. Set the CRS, +or pass \code{tmp_project = FALSE}, for planar data.} } \value{ -An sf object with geometry coerced to POINTs. +An sf object with geometry coerced to POINTs, row for row with +\code{x}; an empty input geometry gives an empty POINT. } \description{ Converts the geometry column of an sf object to POINTs using one of several strategies. } \details{ -LINESTRING midpoints are sampled with \code{\link[sf:st_line_sample]{sf::st_line_sample()}}, which yields -no point for an EMPTY LINESTRING. Rather than silently misaligning the -result (or letting sf crash), such input raises an error; drop empty -geometries first with \code{x <- x[!sf::st_is_empty(x), ]}. +The result has one row per row of \code{x}, in the same order. An EMPTY +geometry of any type, lines included, becomes an EMPTY POINT in its own +row; \code{\link[=prep_model_data]{prep_model_data()}} and \code{\link[=make_folds]{make_folds()}} then drop such rows, as they +drop any other empty geometry. Empty lines are never handed to +\code{\link[sf:st_line_sample]{sf::st_line_sample()}}: it yields no midpoint for them, which would +misalign the result, and with sf 1.0.x an empty MULTILINESTRING (or an +empty part of one) crashed the R session. An empty part inside a +non-empty feature is ignored, so the feature gets the point its other +parts give; GEOS's interior point, used by \code{"point_on_surface"} and by +the temporary projection's choice of CRS, segfaulted on an empty line +part too. } \examples{ library(sf) diff --git a/man/compare_models.Rd b/man/compare_models.Rd index 269fabf..270a18f 100644 --- a/man/compare_models.Rd +++ b/man/compare_models.Rd @@ -15,26 +15,71 @@ unique; see \code{\link{evaluate_insample}}.} \item{...}{Extra arguments passed to predict().} } \value{ -A data.frame comparing all models. Alongside the metrics it carries +A data.frame comparing all models. Its \code{metric_basis} +column says what each row's metrics were computed on (see +\code{\link{evaluate_insample}}); a table that mixes +\code{"out-of-bag"} and \code{"in-sample"} rows does not rank the +models, and says so in the log. \code{AICc} (GWR) and \code{LOOIC} +(Bayesian) are sums over the rows a model was fitted to, so each column +is set to \code{NA}, with a warning, when the fits carrying it were +fitted to different rows (a predictor with missing values drops rows, +for example) or to different responses (a transformed response on the +same rows), and the warning says which. \code{convergence_ok} is +\code{TRUE} or \code{FALSE} for a Bayesian fit whose convergence was +checked (see \code{\link{fit_bayesian_spatial_model}}) and \code{NA} +otherwise; a fit that did not converge is ranked like the others, so it +also raises a warning. Alongside the metrics it +carries \code{resid_morans_I}, \code{resid_morans_z}, \code{resid_morans_p} and \code{resid_morans_null}, the last of which names the null \code{\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. +choice is per-fit and governs how much the p-value is worth. A +significant p-value is noted in the log (not raised as an R warning): +positive autocorrelation as structure the model may have missed, +negative (\code{resid_morans_z < 0}) as the alternating residuals of a +model that tracks its data closely. Read the 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 -a tidy comparison table including in-sample metrics and model-specific -information criteria (AICc, LOOIC). +a tidy comparison table including in-sample (for a forest, out-of-bag) +metrics and model-specific information criteria (AICc, LOOIC). } +\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}, +but \strong{out-of-bag} for an \code{rf_fit}, whose \code{fitted()} method +returns out-of-bag predictions (see \code{\link{fit_rf_model}}). The +data.frame \code{model_metrics()} returns carries no label distinguishing +the two, so check \code{object$info$fitted_are_oob} before comparing +numbers across backends; \code{\link{evaluate_insample}()} and +\code{\link{compare_models}()} record it per model in a +\code{metric_basis} column. \code{\link{compare_models_cv}} scores every +backend the same way. + +\eqn{R^2} is \eqn{1 - RSS/TSS} with the total sum of squares taken about +the mean of the response the model was \emph{fitted} to. In sample that +is the ordinary \eqn{R^2}. With \code{newdata} it is out-of-sample +\eqn{R^2}, the convention every \code{cv_*()} function uses: the model is +measured against the prediction it had to beat, the training mean, not +against the new rows' own mean, which it could not have known. It is +below 0 when the model predicts the new rows worse than the training mean +does, and it is \code{NA} when the response does not vary about that +baseline by more than rounding error (100 machine epsilons of its +magnitude, whatever its units). +} + \section{Percentage errors on responses with zeros}{ \code{MAPE} divides by the observed value and \code{SMAPE} by \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/compare_models_cv.Rd b/man/compare_models_cv.Rd index 638de24..1de290a 100644 --- a/man/compare_models_cv.Rd +++ b/man/compare_models_cv.Rd @@ -55,7 +55,9 @@ the folds came from other data when they were not).} \item{boundary}{Optional polygon sf/sfc.} -\item{pointize}{Geometry coercion strategy.} +\item{pointize}{Geometry coercion strategy. It also decides where a +polygon or line row falls in the shared blocks, so each row is placed by +the point every model is fitted at.} \item{gwr_args}{Extra arguments for \code{\link{cv_gwr}}. Only names that are formal arguments of \code{cv_gwr()} are forwarded (it has no @@ -88,23 +90,38 @@ the autocorrelation range of the response (detrended on \code{predictor_vars}) is estimated and used as the minimum block size of the shared folds, as in \code{\link{make_folds}()}. Default \code{FALSE}: geometric blocks, as before this argument existed. Either -way the fold set is built once and every backend is scored on it.} +way the fold set is built once and every backend is scored on it. When +it cannot be built (a \code{block_size} or estimated range that leaves a +single block, say) the call is an error, as it is for each backend on +its own; no model is scored on a design other than the one asked for.} \item{metrics}{Optional scoring function of your own, handed to every backend's \code{cv_*()}: a \code{function(y, yhat)} returning a named numeric vector, applied per fold and to each backend's pooled predictions, whose names become columns of \code{by_fold} and \code{overall} beside the built-in ones. See \strong{Your own metrics} -on \code{\link{cv_spatial}()} for the contract. Because the three -backends are scored on the same folds, the columns are comparable across -rows of \code{overall}.} +on \code{\link{cv_spatial}()} for the contract. Because the backends +are scored on the same folds and, in \code{overall}, on the same rows +(see Value), the columns are comparable across rows of \code{overall}.} } \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). -\code{overall} has one row per model with the pooled metrics, the +\code{overall} has one row per model with the pooled metrics, +\code{n_pred} (the rows they are computed on), the coverage and CRPS columns described above when a Bayesian model ran, and \code{model} as its last column. +Shared folds do not guarantee shared rows: a model that fails on a fold +(GWR with a fixed bandwidth across a gap in the data, say) or predicts +\code{NA} for some rows pools fewer rows, usually without the hardest +ones. When the models predicted different rows, the function warns and +recomputes every model's pooled metrics, your own \code{metrics} +included, on the rows all of them predicted, so \code{n_pred} is the same +on every row that has predictions; a model that predicted nothing stays +an \code{NA} row. Each model's metrics over all the rows it predicted +stay in its \code{*_cv} element and in \code{attr(overall, "all_rows")}, +a table of the same shape. \code{by_fold} and the Bayesian coverage and +CRPS columns are per fold and are not recomputed. Only the models that actually ran appear, so check which names are present; there is not always one entry per requested model, because a backend whose package is missing is dropped with a message. When \strong{no} requested backend @@ -141,6 +158,9 @@ overconfident, well above it is wider than it needs to be. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is @@ -176,8 +196,11 @@ be read as a rough summary rather than a score. For the Bayesian backend, \code{\link{cv_bayes}()} additionally reports CRPS and interval coverage at 50, 80 and 95 percent. Both are proper scoring rules computed from posterior draws, so they are meaningful for any -\code{family} the backend accepts, and they are the numbers to compare when -the response is not Gaussian. When every fold fails, the +\code{family} that predicts one number per row (a count, a rate, a binary +or bounded outcome), and they are the numbers to compare when the response +is not Gaussian. A categorical or ordinal family predicts a probability +per response category instead, so \code{cv_bayes()} refuses one before +fitting anything. When every fold fails, the \code{fold_metrics} frame \code{cv_bayes()} returns carries the CRPS column but not the \code{coverage_*} columns, so code that reads those columns must tolerate their absence. diff --git a/man/create_grid_polygons.Rd b/man/create_grid_polygons.Rd index 1ce09c6..b9754c6 100644 --- a/man/create_grid_polygons.Rd +++ b/man/create_grid_polygons.Rd @@ -20,9 +20,15 @@ create_grid_polygons( \item{boundary}{Polygonal sf or sfc object.} \item{target_cells}{Optional approximate desired number of cells. The cell -\emph{size} is derived from it as \code{sqrt(area / target_cells)}, so -square grids get square cells; for hex grids the count is adjusted for -hexagonal packing density. The word "approximate" is load bearing: a +\emph{size} is derived from it as \code{sqrt(area / target_cells)}, where +\code{area} is that of the boundary's bounding box, so square grids get +square cells; for hex grids the count is adjusted for hexagonal packing +density and the size rounded so that a whole number of hexagon widths +spans the longer side of the box. The size does not depend on which way +the boundary lies; the count can, because hexagon rows are 0.87 +\code{cellsize} apart while columns are \code{cellsize} apart (about 10 +percent on a moderately elongated box, up to 1.7 times on a strip +narrower than one hexagon). The word "approximate" is load bearing: a grid of square cells over an elongated bounding box needs more of them than a grid of rectangles would (a 1000 x 1 strip at \code{target_cells = 9} yields cells of side 10.5 and about 95 of them), @@ -50,9 +56,20 @@ corner, covering only part of the boundary.} \item{clip}{Logical; clip grid to boundary.} -\item{crs}{Optional target CRS. When \code{NULL} (default) the boundary is -projected with \code{\link[=ensure_projected]{ensure_projected()}}, which changes the CRS of the returned -grid; a message reports this unless \code{quiet = TRUE}.} +\item{crs}{Optional target CRS: anything \code{\link[sf:st_crs]{sf::st_crs()}} accepts, including +an sf or sfc layer, whose CRS is used. When \code{NULL} (default) a lon/lat +boundary is projected with \code{\link[=ensure_projected]{ensure_projected()}}, which changes the CRS of the returned +grid; a message reports this unless \code{quiet = TRUE}. When that CRS would +distort cell areas across the boundary by more than 1 percent (Web +Mercator over a near-global extent, a UTM zone stretched well past its +width), \code{ensure_projected(purpose = "area")} is used instead, with a +logged warning, so the cells stay equal-area; a local extent keeps its +UTM zone. A geographic \code{crs} (EPSG:4326, say) is the CRS the grid is +returned in: a grid sized by \code{target_cells} or \code{n} is laid in that +projected CRS and then transformed, with long edges densified. A +\code{cellsize} is in the units of \code{crs}, so with a geographic \code{crs} it is in +degrees and the grid is laid in degrees, as asked; such cells are not +equal-area.} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo diff --git a/man/create_grid_polygons_cached.Rd b/man/create_grid_polygons_cached.Rd index 25e1fd6..0708199 100644 --- a/man/create_grid_polygons_cached.Rd +++ b/man/create_grid_polygons_cached.Rd @@ -6,7 +6,7 @@ \usage{ create_grid_polygons_cached( boundary, - target_cells, + target_cells = NULL, type = c("square", "hex"), ..., cache_env = .gmt_cache, @@ -16,7 +16,9 @@ create_grid_polygons_cached( \arguments{ \item{boundary}{An sf or sfc polygonal object.} -\item{target_cells}{Approximate desired number of cells.} +\item{target_cells}{Approximate desired number of cells. Default \code{NULL}, +as in \code{\link[=create_grid_polygons]{create_grid_polygons()}}, so the grid can be sized by \code{cellsize} +or \code{n} passed through \code{...} instead.} \item{type}{Grid type: \code{"square"} (the default) or \code{"hex"}, matching \code{\link[=create_grid_polygons]{create_grid_polygons()}}.} diff --git a/man/create_voronoi_polygons.Rd b/man/create_voronoi_polygons.Rd index 2721190..b48d792 100644 --- a/man/create_voronoi_polygons.Rd +++ b/man/create_voronoi_polygons.Rd @@ -15,17 +15,42 @@ create_voronoi_polygons( ) } \arguments{ -\item{points_sf}{An sf object with POINT/MULTIPOINT geometries.} +\item{points_sf}{An sf object with POINT/MULTIPOINT geometries. Points with +no CRS whose coordinates look like lon/lat (the heuristic +\code{\link[=ensure_projected]{ensure_projected()}} applies, with its warning) are taken as EPSG:4326 +and projected, as lon/lat points are.} -\item{boundary}{Optional polygonal sf object.} +\item{boundary}{Optional polygonal sf object. When exactly one of +\code{points_sf} and \code{boundary} has a CRS, the other is interpreted in it, with +a warning. CRS-less points, and a CRS-less boundary given with projected +points, are read as \code{\link[=harmonize_crs]{harmonize_crs()}} does (lon/lat-looking coordinates +are reprojected from EPSG:4326, others are stamped); CRS-less points that +do not look like lon/lat cannot take a geographic boundary's CRS, and are +refused with an error. A CRS-less boundary given with lon/lat points (or +with CRS-less points taken as lon/lat) is read as lon/lat when its +coordinates fit the lon/lat envelope, and refused with an error +otherwise.} -\item{expand}{Numeric; absolute buffer distance for the envelope.} +\item{expand}{Numeric; absolute distance, in the working CRS's units, by +which the boundary (or the hull derived from the points) is grown before +the diagram is built. With \code{clip = TRUE} the cells are clipped to the +grown boundary, so they reach \code{expand} beyond the study area, and a point +up to \code{expand} outside it gets a cell and an \code{index} value. The grown +boundary is the one returned as \code{boundary}.} \item{clip}{Logical; intersect cells with boundary.} -\item{keep_duplicates}{Logical; keep coincident points for graph construction.} +\item{keep_duplicates}{Logical. Has no effect on the result: coincident +points are merged before the diagram is built either way, so they share +one cell and all of them are indexed to it.} -\item{crs}{Optional target CRS.} +\item{crs}{Optional target CRS: anything \code{\link[sf:st_crs]{sf::st_crs()}} accepts, including +an sf or sfc layer, whose CRS is used. A projected CRS is the working +CRS. A geographic one (EPSG:4326, say) is the CRS the result is returned +in: +the cells are built in the local projected CRS \code{\link[=ensure_projected]{ensure_projected()}} +picks for the points, so they are nearest-point cells on the ground, and +are then transformed, with long edges densified.} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo @@ -35,8 +60,11 @@ It does not silence R warnings, nor the package's console log echo A list with \code{cells}, \code{index}, \code{boundary}, \code{method} and \code{params}. \code{index} holds one \code{cell_id} per row of \code{points_sf}, and \code{NA} for a point that falls outside -every cell, which means outside the study area, so a summary built from it -counts only the points the tessellation actually covers. +every cell, which means outside the study area (grown by \code{expand} +when it is positive), so a summary built from it counts only the points +the tessellation actually covers. \code{boundary} is the boundary the +cells were built in: the one supplied or derived, grown by +\code{expand}. } \description{ Assigns every location in the study area to its nearest input point, giving @@ -54,6 +82,14 @@ 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. + +The generators are the points' vertices, not the features. A MULTIPOINT +feature with several vertices therefore gets one cell per vertex, and its +\code{index} entry is the smallest \code{cell_id} among the cells it touches; the +others are referenced by no feature. Other functions in the package +(\code{\link[=prep_model_data]{prep_model_data()}}, \code{\link[=make_folds]{make_folds()}}) reduce such a feature to its +centroid instead, so cast to POINT, or take centroids, first if one cell +per feature is what you want. } \examples{ library(sf) diff --git a/man/cv_bayes.Rd b/man/cv_bayes.Rd index b67db6c..5801f83 100644 --- a/man/cv_bayes.Rd +++ b/man/cv_bayes.Rd @@ -58,13 +58,21 @@ different posteriors even on identical \code{folds}. A \code{seed} in A user-supplied \code{gp_k} is respected in every fold; when omitted, the GP rank is auto-selected per training fold. \code{compute_loo}, \code{boundary}, and \code{pointize} are always overridden by the CV -internals.} +internals. A categorical or ordinal \code{family} +(\code{brms::categorical()}, \code{cumulative}, \code{sratio}, +\code{cratio}, \code{acat}) is refused before anything is fitted: its +prediction is a probability per response category, and every score +here needs one number per row.} \item{summary}{"mean" or "median" for posterior predictions.} \item{compute_pred_intervals}{Logical; compute predictive intervals.} -\item{coverage_levels}{Numeric vector of coverage levels.} +\item{coverage_levels}{Numeric vector of the nominal coverage levels to +score, as proportions strictly between 0 and 1 (\code{0.95}, not +\code{95}), each given once; anything else is an error. Each becomes a +column \code{coverage_} of \code{fold_metrics}, named at full +precision (\code{0.975} gives \code{coverage_97.5}).} \item{block_size}{Optional minimum block edge length for spatial CV blocks (projected CRS units).} @@ -78,7 +86,12 @@ auto-detect the number of cores and fit folds in parallel via \code{parallel::mclapply()} (macOS / Linux; falls back to sequential on Windows). If an integer > 1, use that many cores. Default \code{FALSE} (sequential). Bayesian folds with full MCMC runs -are the primary beneficiary of this option.} +are the primary beneficiary of this option. Mind the memory: every +fold compiles its own Stan model, and one compilation can take several +GB (3.6 GB was measured), so \code{parallel = n} runs \code{n} of them +at once. A compiler killed for lack of memory fails its fold with +rstan's \code{"invalid connection"} error, which \code{fold_status} +records; use fewer cores if you see it.} \item{metrics}{Optional scoring function of your own, a \code{function(y, yhat)} returning a named numeric vector; its names @@ -93,8 +106,9 @@ and \code{CRPS}, which this function computes itself.} A list with \code{overall}, \code{fold_metrics}, \code{predictions}, \code{folds}, \code{n_folds_attempted}, \code{n_folds_succeeded}, \code{fold_status}, \code{orphan_rows}, -\code{n_unknown_ids}, \code{n_dropped}, \code{formula} and -\code{predictive_coverage}. +\code{n_unknown_ids}, \code{n_dropped}, \code{formula}, +\code{predictive_coverage} and \code{coverage_levels} (the nominal +levels, named by their \code{coverage_*} column). The two fold counts make a run where every fold failed visible in the return value itself, beyond the warning, and \code{fold_status} (one row per fold: \code{fold}, \code{status}, \code{message}) keeps the @@ -108,6 +122,14 @@ that give the coverage below (\code{NA} when \code{compute_pred_intervals = FALSE} or the draws failed for that fold). \code{overall$Adj_R2} is always \code{NA}, as for every \code{cv_*()}: see \code{\link{cv_spatial}}. +\code{fold_metrics} carries, beyond the columns its siblings share, +\code{gp_k}, \code{gp_n_basis}, \code{n_draws}, \code{CRPS}, the +\code{coverage_*} columns and \code{convergence_ok}: \code{TRUE} or +\code{FALSE} as \code{\link{fit_bayesian_spatial_model}()} judged that +fold's sampler (R-hat, effective sample size, divergences), \code{NA} +when \code{fit_args} sets \code{check_convergence = FALSE}. A fold that +did not converge is scored like the others, so a run with any +\code{FALSE} raises one warning naming those folds. The \code{predictive_coverage} entries (one per \code{coverage_levels} value, plus \code{mean_CRPS}) are averages across folds \strong{weighted by each fold's \code{n_pred}}, because the per-fold @@ -139,6 +161,9 @@ has settled. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is @@ -174,8 +199,11 @@ be read as a rough summary rather than a score. For the Bayesian backend, \code{\link{cv_bayes}()} additionally reports CRPS and interval coverage at 50, 80 and 95 percent. Both are proper scoring rules computed from posterior draws, so they are meaningful for any -\code{family} the backend accepts, and they are the numbers to compare when -the response is not Gaussian. When every fold fails, the +\code{family} that predicts one number per row (a count, a rate, a binary +or bounded outcome), and they are the numbers to compare when the response +is not Gaussian. A categorical or ordinal family predicts a probability +per response category instead, so \code{cv_bayes()} refuses one before +fitting anything. When every fold fails, the \code{fold_metrics} frame \code{cv_bayes()} returns carries the CRPS column but not the \code{coverage_*} columns, so code that reads those columns must tolerate their absence. diff --git a/man/cv_block_size_sweep.Rd b/man/cv_block_size_sweep.Rd index 541eb2b..17a43af 100644 --- a/man/cv_block_size_sweep.Rd +++ b/man/cv_block_size_sweep.Rd @@ -31,8 +31,11 @@ as for \code{\link{cv_spatial}()}; see the example for wrapping a built-in backend.} \item{block_sizes}{Optional numeric vector of block edge lengths to sweep, -in the CRS units the folds are built in. Default \code{NULL}: the ladder -described above.} +in the CRS units the folds are built in (plain numbers; a \code{units} +object is refused). Default \code{NULL}: the ladder described above. +A size at which the grid would hold fewer than \code{k} blocks is not +run, with a warning naming it and the largest size that still gives +\code{k} blocks; if no size is left, the call is an error.} \item{n_sizes}{Number of sizes in the default ladder. Default 6.} @@ -47,9 +50,12 @@ reference. Default \code{TRUE}.} \item{max_fits}{The fit budget; see above. Default 60.} \item{sac}{Optional \code{sac_range} from \code{\link{estimate_sac_range}()} -to mark on the curve. Default \code{NULL}: estimated here from the -response, detrended on \code{predictor_vars}, when \pkg{gstat} is -installed.} +to mark on the curve, or a single number in the units of the CRS the +folds are built in. An \code{estimate_sac_range()} result records the +CRS it was fitted in; when that is not the sweep's, the range is +converted to the sweep's units, with a warning. Default \code{NULL}: +estimated here from the response, detrended on \code{predictor_vars}, +when \pkg{gstat} is installed.} \item{seed}{Seed for the fold construction at every size.} @@ -67,8 +73,10 @@ reference), \code{method}, \code{blocks_used}, \code{k} (the folds actually built), \code{n_folds_succeeded}, \code{value} (the pooled metric), \code{fold_min}, \code{fold_max} and \code{fold_sd} (its spread across folds). Attributes: \code{metric}, \code{sac_range} (the -effective range, or \code{NA}), \code{crs}, \code{n_fits}, and -\code{results}, the full \code{cv_spatial()} result at every size. +effective range, or \code{NA}), \code{crs}, \code{k} (the folds +requested, which \code{print()} and \code{plot()} report), +\code{n_fits}, \code{response_var}, and \code{results}, the full +\code{cv_spatial()} result at every size. \code{plot()} draws it. } \description{ @@ -87,8 +95,9 @@ the model. Each block size is a full cross-validation, so the cost is \code{length(block_sizes) * k} fits, plus \code{k} for the random -reference. \code{max_fits} caps that (default 60: six sizes at -\code{k = 5}, plus the reference). A sweep that would run past the cap +reference. \code{max_fits} caps that (default 60: room for up to eleven +sizes at \code{k = 5} plus the reference; the default six-size ladder at +\code{k = 5} needs at most 35). A sweep that would run past the cap refuses to start, naming the number of fits it would have needed. Raise \code{max_fits} deliberately; the RF example below takes seconds, a Bayesian \code{fit_fn} takes minutes per fit. @@ -97,12 +106,27 @@ refuses to start, naming the number of fits it would have needed. Raise \section{The ladder}{ When \code{block_sizes} is \code{NULL}, \code{n_sizes} values are -log-spaced from a twenty-fifth to a half of the shorter side of the -data's extent, and any size at which the grid would hold fewer than -\code{k} blocks is dropped, so every point on the curve is a \code{k}-fold -cross-validation of the same shape. Sizes are in the units of the CRS the -folds are built in (\code{make_folds()}'s \code{params$crs}, metres for -geographic input), and the returned table records that CRS. +log-spaced from a twenty-fifth of the shorter side of the data's extent +(of the longer side when the points lie on one line parallel to an axis) +to the largest size, at most half that side, at which the grid still +holds \code{k} blocks. Half the side gives a grid two blocks across, +enough for \code{k} up to 4 and, for larger \code{k}, on an extent long +enough in the other direction; on a roughly square extent at the default +\code{k = 5} the top is about a third of the side. Any size at which the +grid would hold more than the 1,000,000 \code{make_folds()} will build is +dropped. The count is of grid cells: on clustered data a grid +of \code{k} or more cells can have fewer than \code{k} that hold points, +and \code{make_folds()} then lowers \code{k} at that size, which the +\code{k} column shows. On an extent much longer than it is wide every +rung can fall below the autocorrelation range while longer blocks would +still fit \code{k} times along the longer side; the sweep warns when +that happens, and \code{block_sizes} is then the way to reach past the +range. Sizes are in the units of the CRS the folds are built in +(\code{make_folds()}'s \code{params$crs}, metres for geographic input), +and the returned table records that CRS. Each is the \emph{minimum} block +edge handed to \code{make_folds()}, which fits a whole number of cells +across the extent, so the cells are somewhat longer than the size on the +axis (up to twice as long). } \examples{ diff --git a/man/cv_gwr.Rd b/man/cv_gwr.Rd index ca7da41..f3de553 100644 --- a/man/cv_gwr.Rd +++ b/man/cv_gwr.Rd @@ -70,11 +70,13 @@ spatial autocorrelation range.} estimate the autocorrelation range and use it as the minimum block size. Default \code{FALSE}.} -\item{parallel}{Logical or positive integer. If \code{TRUE}, -auto-detect the number of cores and fit folds in parallel via -\code{parallel::mclapply()} (macOS / Linux; falls back to sequential -on Windows). If an integer > 1, use that many cores. Default -\code{FALSE} (sequential).} +\item{parallel}{Accepted so that every \code{cv_*()} function takes the +same arguments, but the GWR folds always run one after another in this +R process. GWmodel is built with OpenMP, and OpenMP (GNU libgomp) +deadlocks \code{parallel::mclapply()}'s forked workers once a GWR has +been fitted in the session, for example by \code{fit_gwr_model()}, so +forking would hang the call. A value asking for more than one core +raises a warning saying so. Default \code{FALSE}.} \item{metrics}{Optional scoring function of your own, a \code{function(y, yhat)} returning a named numeric vector; its names @@ -124,6 +126,9 @@ folds. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/cv_rf.Rd b/man/cv_rf.Rd index 3ee8020..2346268 100644 --- a/man/cv_rf.Rd +++ b/man/cv_rf.Rd @@ -66,8 +66,9 @@ fitting; passed to \code{\link{cv_spatial}}. Default \code{"auto"}.} and so on. \code{data_sf}, \code{response_var}, \code{predictor_vars} and \code{.already_prepped} are set by this function and must not be passed here (every fold would fail with "matched by multiple actual -arguments"). A \code{seed} given here overrides the per-fold draw -described above.} +arguments"). \code{seed} is this function's own argument and never +reaches \code{fit_rf_model()} through here; see \code{seed} above for +growing every fold's forest from one fixed seed.} } \value{ The \code{\link{cv_spatial}} result. @@ -84,6 +85,9 @@ the training set. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/cv_spatial.Rd b/man/cv_spatial.Rd index 397dcb3..323e281 100644 --- a/man/cv_spatial.Rd +++ b/man/cv_spatial.Rd @@ -63,13 +63,22 @@ Built via \code{block_kfold} when \code{NULL}.} \item{predict_args}{Extra arguments for predict().} \item{fold_info_fn}{Optional \code{function(fit, test_sf, y, yhat)} -returning a named list of per-fold extras (a bandwidth, a tuning value, -anything read off the fitted object), added as columns of -\code{fold_metrics}. It sees the fit and the held-out layer, which +returning a named list (or a named vector) of per-fold extras (a +bandwidth, a tuning value, anything read off the fitted object), added +as columns of \code{fold_metrics}. It sees the fit and the held-out +layer, which \code{metrics} does not; it is applied per fold only, and its values are not pooled. An element \code{..per_row} that is a data frame with one row per held-out observation is spliced into \code{predictions} -instead.} +instead (\code{NA} in the rows of a fold that returned none; one of the +wrong length is dropped and logged); its columns must be named, once, +and not reuse a column \code{predictions} already has (\code{..row_id}, +\code{fold}, \code{y}, \code{yhat}, \code{y_train_mean}). Every +other element must be named, hold one value, and not reuse a column +\code{fold_metrics} already has; +anything else is an error. A \code{fold_info_fn} that throws on a fold +is logged, its columns are \code{NA} for that fold, and +\code{fold_status$message} says so; the fold is kept.} \item{p}{Number of predictors for Adj R² (NULL to skip). Only meaningful for models with a fixed global parameter count; pass NULL for models @@ -86,7 +95,10 @@ Default \code{FALSE}.} auto-detect the number of cores and fit folds in parallel via \code{parallel::mclapply()} (macOS / Linux; falls back to sequential on Windows). If an integer > 1, use that many cores. Default -\code{FALSE} (sequential).} +\code{FALSE} (sequential). A learner that runs OpenMP code (GWmodel, +or an xgboost built with GNU libgomp) can hang the forked workers once +it has run in the session; keep such a \code{fit_fn} sequential, as +\code{\link{cv_gwr}()} does.} \item{metrics}{Optional scoring function of your own; see \strong{Your own metrics} below. Default \code{NULL}: the built-in metrics only.} @@ -105,15 +117,26 @@ counts are reported deliberately: a run that happened to score \code{NA}, so compare them before trusting \code{overall}. \code{fold_status} is a data.frame with one row per fold supplied (\code{fold}, \code{status} and \code{message}), where -\code{status} is \code{"ok"}; \code{"error"} (the fit or its +\code{status} is \code{"ok"} (\code{message} is empty unless +\code{fold_info_fn} failed on the fold); \code{"error"} (the fit or its \code{predict()} threw; \code{message} is the error text); \code{"skipped"} (nothing scorable: too few matched rows, a prediction of the wrong length, or no finite observed/predicted pair); \code{"dropped"} (an empty test set, or fewer than two training rows, once incomplete rows were removed, so the fold never reached the fitter); -or \code{"worker_error"} (a parallel worker died). Every fold missing +or \code{"worker_error"} (a parallel worker died, for example killed for +lack of memory). Each fold runs in its own worker, so a failure costs +that fold only, and an error that stops a sequential run (a +\code{metrics} or \code{fold_info_fn} return value of the wrong shape) +stops a parallel one too, naming the fold. Every fold missing from \code{fold_metrics} has its reason there, which matters most when -the console output of a long run is gone. \code{orphan_rows} holds the +the console output of a long run is gone. When some folds, but not +all, end as \code{"error"}, \code{"skipped"} or \code{"worker_error"}, +the function warns, naming them and how many rows \code{overall} +covers: it is pooled over the folds that produced predictions, and the +fold that fails is often the hardest to predict, so it may flatter the +model. (A \code{"dropped"} fold has its own warning.) +\code{orphan_rows} holds the \code{..row_id}s of rows in the data that no fold names (they enter no training set and are never scored; non-empty only when the folds were built on a different or subsetted layer), and \code{n_unknown_ids} @@ -127,7 +150,19 @@ fitted. The \code{fold} column of \code{fold_metrics}, \code{predictions} and \code{fold_status} carries the fold's index in the \code{folds} object that was supplied, so it lines up with \code{make_folds()$assignment$fold} even when some folds -were unusable and dropped. \code{overall$Adj_R2} is always \code{NA}: the +were unusable and dropped. Splits that already carry a \code{fold_id}, +as the \code{folds} of a \code{cv_*()} result do, keep it: handing +one run's \code{folds} to another labels each fold as the first run +and \code{\link{fold_separation}()} do, a dropped fold's gap +included. \code{R2} is out-of-sample \eqn{R^2}: the +total sum of squares is taken about the mean of the \emph{training} rows +(in \code{overall}, each held-out row about its own fold's training +mean), the null prediction available when the fold is predicted, and +not about the held-out rows' own mean, a null model that would know the +test data. On spatial blocks the two can differ widely; \code{R2} is +below 0 when the model predicts worse than the training mean. +\code{\link{model_metrics}(newdata = )} uses the same baseline. +\code{overall$Adj_R2} is always \code{NA}: the pooled out-of-sample predictions come from \code{k} separately fitted models and have no single parameter count to adjust for. The per-fold \code{fold_metrics$Adj_R2} carries the adjusted value when \code{p} is @@ -172,7 +207,12 @@ pairs the built-in metrics use reach the function (both \code{y} and \code{RMSE}, and \code{n_pred} counts them. The contract: every element named, names unique and not one of the -built-in column names, one number per name. Anything else is an error, +built-in column names, one number per name. The built-in names include +the per-fold extras of the backend or of your \code{fold_info_fn} +(\code{bandwidth} for \code{cv_gwr()}; \code{CRPS}, \code{coverage_*}, +\code{gp_k}, \code{gp_n_basis} and \code{n_draws} for \code{cv_bayes()}), +and \code{mean_CRPS}, which \code{compare_models_cv()} writes. Anything +else is an error, because a scoring function that returns the wrong shape is a mistake to surface instead of a fold to skip. A function that \emph{throws} on a fold is logged and its columns are \code{NA} for that fold (and for @@ -194,6 +234,9 @@ across the rows of its \code{overall}. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/determine_optimal_levels.Rd b/man/determine_optimal_levels.Rd index c1f9257..29449c8 100644 --- a/man/determine_optimal_levels.Rd +++ b/man/determine_optimal_levels.Rd @@ -17,9 +17,12 @@ determine_optimal_levels( ) } \arguments{ -\item{data_sf}{An sf object.} +\item{data_sf}{An sf object. Features with empty or non-finite +coordinates are dropped with a warning.} -\item{max_levels}{Integer upper bound on levels. Default 12.} +\item{max_levels}{Integer upper bound on levels. Default 12. The sweep +also stops at the number of distinct locations (k-means cannot place +more centres) and one short of the number of points.} \item{top_n}{Integer; how many candidates to return. Default 3. Under \code{criterion = "geometric"} the candidate set is the elbow and its two @@ -28,14 +31,19 @@ large \code{top_n} is; only the model-aware criteria can return more.} \item{sample_n}{Integer; subsample size for speed. Default 1500.} -\item{set_seed}{Integer RNG seed. Default 123.} +\item{set_seed}{Integer RNG seed for the subsample and the k-means++ +restarts; restored afterwards. Default 123. The rows are put in +coordinate order before either, so the answer does not depend on the +order they come in.} \item{response_var}{Optional response column name. When provided alongside \code{predictor_vars}, enables model-aware level selection via Moran's I on OLS residuals. Must be numeric or logical (logicals are read as 0/1); a factor or character response raises an error and is never coerced, because the residuals of an OLS fit to arbitrary level codes carry no -meaning to test for autocorrelation.} +meaning to test for autocorrelation. Rows where it, or a predictor, is +missing or non-finite stay in the WSS sweep and the cells and are left +out of Moran's I; a logged warning gives their number.} \item{predictor_vars}{Optional predictor column names. Must be numeric or logical (logicals are read as 0/1); factor/character columns raise an @@ -43,24 +51,31 @@ error.} \item{criterion}{One of \code{"geometric"} (default when no response given), \code{"morans_i"} (select the k whose residual Moran's I is least -\emph{significant}), or \code{"combined"} (rank-average of 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}. Supplying +\emph{significant}), or \code{"combined"} (rank-average of the WSS +curve's log-log sag, the quantity the elbow is read from, and that same +significance). Falls back to \code{"geometric"}, +with a warning, when \code{response_var} or \code{predictor_vars} is not +given, and with a logged warning when no candidate clears the +nine-cell resolution floor described in \strong{Details}. A +\code{response_var} or \code{predictor_vars} naming a column that is not +in \code{data_sf} is an error. Supplying both \code{response_var} and \code{predictor_vars} upgrades \code{"geometric"} to \code{"combined"}: the selection then depends on the response (see "Post-selection inference").} \item{select_on}{\code{"all"} (default) selects on every point; -\code{"split"} selects on one spatially blocked half of the points and -returns the other half as the set to estimate on, so that the standard -errors computed downstream on the chosen cells are not post-selection. -See "Post-selection inference".} +\code{"split"} reads the response on one spatially blocked half of the +points only and returns the other half as the set to estimate on, so +that the standard errors computed downstream on the chosen cells are not +post-selection. The count is still chosen for the whole layer. See +"Post-selection inference".} } \value{ An integer vector of candidate level counts, \strong{best first}: under the geometric criterion the elbow, then its lower and upper -neighbours; under the model-aware criteria the candidates in rank order. +neighbours (with a warning when the WSS curve has no elbow and the first +is the ladder's choice; see Details); under the model-aware criteria the +candidates in rank order. \code{k[1]} is therefore the top-ranked count on every path, and \code{top_n = 1} returns it alone. When \code{criterion != "geometric"}, an attribute \code{"diagnostics"} is @@ -76,7 +91,10 @@ model-aware pass actually scored (\code{eval_ks}, the elbow's neighbourhood). Under \code{"combined"} it also carries the WSS of the re-run clustering at those \code{k} (\code{wss_eval}), the rank average that ordered them (\code{combined_rank}, named by \code{k}) and -\code{criterion = "combined"}. When the model-aware +\code{criterion = "combined"}; when \code{"combined"} returned the +geometric ranking because the elbow is below ten cells, it carries +\code{criterion = "geometric"} and \code{fallback} (the reason) in +place of \code{combined_rank}. 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), no diagnostics are available and the attribute is absent. Both fallbacks are @@ -93,6 +111,33 @@ Computes a WSS curve over k=1..K_max using k-means on projected feature coordinates and selects candidate k values around the elbow. } \details{ +\strong{The elbow is read on log-log axes, and there may be none.} Points +with no cluster structure have a WSS curve close to \eqn{c/k}, and the +classical rule, the point furthest below the chord from the first to the +last k, still finds a "knee" on it on linear axes, at about +\eqn{\sqrt{K_{max}}}: 4 at the default \code{max_levels = 12} and 13 at +160, whatever the data. On \eqn{\log k} against \eqn{\log} WSS that curve +is a straight line, while separated clusters fall faster than it until +there is one cell per cluster and like it after, a bend at the cluster +count. The elbow is therefore the k whose \eqn{\log} WSS sags furthest +below the straight line joining k = 1 and \eqn{K_{max}} on those axes, and +it counts as one only when the sag is at least \eqn{\log 1.25} (the WSS a +fifth below the power law through the ends). Measured on 60 to 1500 +points with ladders to 3--40, uniform layouts over squares, discs, +triangles, an L-shape, density gradients and jittered lattices sagged at +most 0.16, and two to ten separated clusters at least 0.6 once +\code{max_levels} passed the cluster count. With no elbow the function +warns and returns the linear-axis answer, which the ladder chose, not the +data. An elongated extent also bends, at about its aspect ratio, because +the first cuts go across its long axis (0.2--0.45 for a 4:1 rectangle); +past the threshold that bend is reported as an elbow, and it describes +the extent's shape rather than clusters in it. When locations repeat +(stations visited many times), the sweep can reach one cell per distinct +location, where the WSS is zero (to within \eqn{10^{-12}} of the total). +That \code{k} has no place on log axes and is left out of the line, but +the fall to zero is the sharpest bend there is: when the rest of the +curve has no elbow, the number of distinct locations is the elbow. + When \code{response_var} and \code{predictor_vars} are provided, the geometric WSS elbow is supplemented with Moran's I computed on OLS residuals at each candidate k. The Moran's I profile measures how much @@ -138,11 +183,19 @@ 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, which are 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}. +residual moments. The cell-level residuals are OLS residuals by +construction, which is the case those moments are derived for, but the +derivation also assumes errors of equal variance, and a cell mean over +\eqn{n_j} points has a variance proportional to \eqn{1/n_j}. 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}, and +it stayed calibrated on gradient and moderately clustered layouts; with +single-point cells next to cells of 70 or more points its mean rose to +0.2--0.34 and its rejection rate to 7--8\% at 20 cells. Where structure +remains, \eqn{|z|} mixes its size with the number of cells it is measured +on, since \eqn{\mathrm{sd}(I)} shrinks as cells are added. 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, @@ -157,12 +210,33 @@ deviate is \eqn{0/0}: it carries no information about the tessellation, and whichever way rounding noise resolves it those candidates would rank first or last on nothing. They 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. +clears the floor, the whole call falls back to the geometric ranking and +logs a warning that says so. That is the usual outcome well past +\code{max_levels = 10}: the neighbourhood is the elbow plus or minus +\code{max(4, top_n)}, and on points with no cluster structure the elbow +sits near \eqn{\sqrt{K_{max}}}, so the neighbourhood reaches ten cells only +from about \code{max_levels = 40}. Measured on 1000 uniform points, +\code{max_levels} of 12, 20 and 30 all fell back, and 40 scored +\code{k} = 10 and 11 alone. On such a layer +\code{\link{resolution_profile}()}, which scores Moran's z at every level of +its ladder, is the model-aware view. Under \code{criterion = "combined"}, +an elbow below ten cells is a count Moran's I cannot score, so it cannot +weigh the response there: the geometric ranking is returned, with a +logged warning, and the diagnostics record it (see Value). (Ranking the +window anyway put the smallest count Moran's I scores, ten, first whatever +the response did.) Otherwise the candidates below the floor that sit +alongside candidates above it all take the last place on the Moran's I +axis, after every candidate it scored, while still competing on the +geometric axis. That axis is the elbow's own log-log sag at each +candidate; when the WSS curve has no elbow it is flat, every candidate +tied, and Moran's I alone orders them. + +\code{"combined"} is not an estimate of the number of clusters. Where the +elbow is at ten cells or more, Moran's I can move the pick away from it +when the response is still spatially structured at the elbow's +resolution. Use \code{"geometric"} when the cell count should follow the +clustering of the points, and \code{\link{resolution_profile}()} when the +response should drive it. } \section{Post-selection inference}{ @@ -180,12 +254,21 @@ downstream standard errors are computed over. \code{select_on = "split"} is sample splitting: the layer is cut into two spatially blocked halves (\code{\link{make_folds}(k = 2, method = -"block_kfold")}), the selection runs on the first half only, and the row -positions of both halves come back in the \code{"split"} attribute -(\code{selection} and \code{estimation}). Build the tessellation on +"block_kfold")}), the criteria that read the response (Moran's I on the +cell means) read the first half only, and the row positions of both +halves come back in the \code{"split"} attribute (\code{selection} and +\code{estimation}). The WSS curve and the k-means cells still use every +point: they read coordinates alone, and the count is for a tessellation +of every point, so it is chosen on that layer's extent and clusters +rather than on half of them. Build the tessellation on every point (cells are geometry), but aggregate and fit on -\code{data_sf[attr(x, "split")$estimation, ]}, which the selection never -saw; that restores nominal coverage with no new theory. The price is +\code{data_sf[attr(x, "split")$estimation, ]}, whose response the +selection never saw. That keeps the selection's use of the response out +of the estimates, but only as far as the two halves are independent: the +split has no buffer, so points near the border between them are +correlated with the selection half over the autocorrelation range, and +coverage is nominal only when that range is short against the blocks. +The price is precision: half the points estimate, and García Rasines and Young (2023) show a \emph{contiguous} spatial half is less efficient than the exchangeable split the i.i.d. theory assumes, because the two halves are @@ -196,6 +279,16 @@ the split needs no distributional assumption, which is why it comes first. Selection on coordinates alone (\code{"geometric"} with no response) is not exposed in this way, and \code{"split"} then changes nothing but the attribute. + +The estimation rows cover only the estimation half's blocks, while the +cells cover the whole layer, so the estimation rows do not fill every +cell. A cell inside the selection half gets none and comes back +\code{NA}; a cell across the border between the halves is estimated from +its estimation-half points alone, and its standard error describes that +part, not the cell (on 400 simulated fields a nominal 95\% interval covered +0.97 in cells inside the estimation half and 0.88 in cells across the +border). Count, per cell, how many of its points are estimation rows, +and read inferential results only off cells whose points all are. } \examples{ diff --git a/man/ensure_projected.Rd b/man/ensure_projected.Rd index f57822e..dbd58a5 100644 --- a/man/ensure_projected.Rd +++ b/man/ensure_projected.Rd @@ -70,7 +70,9 @@ extent of the data. It is \strong{not} always UTM: \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.} +this package is usually in. The centre is the centroid on the sphere, +computed with s2 whatever \code{\link[sf:s2]{sf::sf_use_s2()}} is set to, so data near a +zone edge get the same zone in every session.} \item{Wide extents}{Once the data reach well beyond the roughly 3 degrees a UTM zone is designed for, a single zone can distort distances by several percent, and that error propagates straight into variogram @@ -79,16 +81,28 @@ projection is actually best is then \strong{measured, not assumed}: the zone, a Lambert azimuthal equal-area centred on the data and (where its standard parallels do not degenerate) an Albers conic are each scored by projecting representative points of the data (a non-POINT layer is -reduced to points first) and comparing planar with geodesic pairwise -distances, and the one that distorts least is used. +reduced to one point per feature, plus the vertices of its outline when +it has fewer than 40 features, so a single study-area polygon is scored +too) and comparing planar with geodesic pairwise distances, and the one +that distorts least is used. The choice, both error figures and this argument are \strong{logged} (see the logging note under \code{\link[=spatialkit_quiet]{spatialkit_quiet()}}); they are not R warnings, so \code{tryCatch(warning = )} does not see them.} \item{Antimeridian}{Data straddling ±180° have a bounding box wider than a hemisphere. The wrap is detected from the coordinates (one very large gap in the sorted longitudes) and an equal-area projection centred on -the true extent is used. Only truly global coverage falls back to -EPSG:3857.} +the true extent is used.} +\item{Around a pole}{Data spanning more than 180 degrees of longitude +with no such gap surround a pole. When every point also lies on one +side of the equator (Antarctic stations, a pan-Arctic network), a +Lambert azimuthal equal-area centred on that pole is used, provided it +measures a smaller distance error than the global fallback. Web +Mercator splits such a layer at +/-180 degrees and stretches it +towards the pole: a ring of Antarctic stations measured a worst-case +distance error near 20,000 percent in it, against about 2 percent in +the polar projection. Only the coverage left over, spanning both +hemispheres or a low-latitude belt the polar projection fits worse, +falls back to EPSG:3857 (Equal Earth for \code{purpose = "area"}).} \item{Missing CRS}{With no \code{target_crs}, a bounding box that looks like lon/lat means EPSG:4326 is assumed (a real warning) and the rules above then apply; coordinates the heuristic declines are left exactly as they diff --git a/man/ensure_stable_poly_id.Rd b/man/ensure_stable_poly_id.Rd index a394804..6d47908 100644 --- a/man/ensure_stable_poly_id.Rd +++ b/man/ensure_stable_poly_id.Rd @@ -28,9 +28,16 @@ whichever projection it arrives in), so if the transform fails the function says so rather than quietly sorting in the input's own CRS. The sort key is rounded to 7 decimal degrees (about 1 cm) before ordering, so the floating-point noise of a round trip through a different projection -cannot reverse two neighbouring cells. Set to NULL to sort in the input -CRS, which gives IDs that are reproducible but not comparable across -projections.} +does not usually reverse two neighbouring cells. It can where two cells' +centres lie within about that step of the same longitude, as fine cells +stacked north-south near a projection's central meridian do: 36 of 2,500 +100 m cells straddling a UTM central meridian changed ID after a +transform to EPSG:3035. No rounding step removes that, so to match cells +computed in different projections, join them on geometry rather than on +the ID. The key is computed on the sphere (s2) whether or not +\code{sf::sf_use_s2()} is on, so the session setting does not change the +IDs. Set to NULL to sort in the input CRS, which gives IDs that are +reproducible but not comparable across projections.} } \value{ An sf polygon layer re-ordered with sequential IDs in id_col. diff --git a/man/estimate_sac_range.Rd b/man/estimate_sac_range.Rd index 815c118..cc17eeb 100644 --- a/man/estimate_sac_range.Rd +++ b/man/estimate_sac_range.Rd @@ -36,7 +36,9 @@ trend on these predictors is removed first and the variogram describes the residual autocorrelation, the part a spatial model has to handle once the covariates have done their work. How the trend is removed is set by \code{detrend}, and it matters: see "Detrending and the -residual-variogram bias".} +residual-variogram bias". Rows whose response or predictor is missing +or infinite are left out of that fit, and so of the variogram, with a +logged count.} \item{n_max}{Maximum number of points to subsample before fitting. Variogram estimation is O(n²) so this keeps runtime bounded.} @@ -55,7 +57,17 @@ variogram never reaches a sill, and such a value extrapolates past the observed lags instead of measuring a long autocorrelation range. Passing it to \code{make_folds(auto_range = TRUE)} would collapse the block grid to a single block. Default 1.0; raise it to accept ranges extrapolated -beyond the fitted lags.} +beyond the fitted lags. The bound does not guarantee room for two +blocks: at the defaults it is half the farthest-pair distance, about +0.71 of the side of a square layer, and a block grid needs a range below +half the width of the bounding box in one direction or the other. An +accepted range between the two leaves +\code{make_folds(auto_range = TRUE)} room for a single block of that +size (see its \code{auto_range} argument for what it does then). On a +1000 m square with an exponential field of effective range 570 (n = 300), +9 of 30 draws were accepted in that band. Lowering \code{range_frac} to fit the +grid would turn those estimates into \code{NA} and the blocks into +geometric ones smaller than the range.} \item{seed}{RNG seed for the \code{n_max} subsample, restored afterwards so the caller's random stream is untouched. Default \code{123L}: the @@ -97,16 +109,17 @@ attribute. Set \code{TRUE} to inspect the directional curves.} } \value{ A single number, of class \code{sac_range} in the first two of the -three shapes below and a bare \code{NA} in the third; all three behave -as an ordinary number. The shapes carry different attributes: +three shapes below and an unclassed \code{NA} in the third; all three +behave as an ordinary number. The shapes carry different attributes: \describe{ \item{Success}{A positive effective range in projected coordinate units, with the fit attached as attributes \code{directional} (the 0°, 45°, 90° and 135° ranges, named by azimuth; \code{NA} where that direction's fit was unusable), \code{anisotropy} (largest over smallest), \code{anisotropy_used} (logical: \code{TRUE} only when -the all-pairs fit was unusable and the directional maximum stands in -for it), \code{directional_status} (per azimuth, why a direction is +the all-pairs fit was singular or did not converge and the +directional maximum stands in for it), \code{directional_status} +(per azimuth, why a direction is \code{NA} in \code{directional}: \code{"ok"}, \code{"over_cutoff"} (its range ran past the largest lag fitted), \code{"not_converged"} or \code{"no_fit"}), \code{directional_fitted} (the range each @@ -134,27 +147,47 @@ parameters) and \code{nugget} (that model's nugget variance; see be taken on trust.} \item{Rejected range}{\code{NA_real_} when a range was fitted but is not identified: it exceeds \code{range_frac * cutoff * max_dist} (see -\code{range_frac}); or the model did not converge; or the empirical +\code{range_frac}), which applies to the all-pairs fit even when some +directions reached a sill; or too few pairs of points lie inside +it to identify it, because it is shorter than the shortest lag the +empirical variogram resolves (the mean separation in its first +bin) or, with \code{detrend = "reml"}, than the distance within +which 30 pairs of the points the REML fit used lie, when that is +shorter (the REML range is fitted to the point pairs, not to the +bins). A structure that short cannot be told from a nugget, and +the bound is about identification, not a test for spatial +structure (see above). Or the +model did not converge; or the empirical variogram \emph{decreases} with distance over its shorter lags (a net fall of more than 15 percent of the mean semivariance there, weighted by pairs), which is the shape of a periodic, hole-effect structure or of a variance that differs between a dense cluster and -the rest of the layer (an unremoved trend instead makes the variogram -rise without a sill, and the first test catches that); or -the fitted range is non-positive. It is classed \code{sac_range} as -well, so it prints as a bare \code{NA} without dumping its +the rest of the layer. Sampling noise in the short-lag bins of a +small sample can make that fall too: on exponential fields it +refused 7--9 of 60 draws at n = 30, 3--6 at n = 50 and 0--1 at +n = 100 (effective range 300 on a 1000 m square), and 15--16 of 60 +at n = 30 with a range of 150. An unremoved trend makes the +variogram rise instead; when it rises past the fitted lags the first +test catches it, but a milder trend only lengthens the fitted range +and passes, which is what \code{predictor_vars} is for. Last, the +fitted range can be non-positive. It is classed \code{sac_range} as +well, so it prints as \code{NA} without dumping its attributes, and it carries \code{max_dist}, \code{cutoff_dist}, \code{variogram}, \code{variogram_model} and \code{nugget} (the evidence for the rejection), plus \code{rejected_range} (the value that was refused), \code{rejected_reason} (one of \code{"fitted range exceeds the largest lag fitted"}, +\code{"fitted range is below the shortest lag fitted"}, \code{"variogram model did not converge"}, \code{"empirical variogram decreases with distance"}, \code{"fitted range is non-positive or non-finite"}, \code{"no variogram model could be fitted (singular fits)"}), \code{crs} (so the units the rejected number was in stay recoverable, which is -what \code{plot()} labels its axis from) and -\code{detrend_method}. It carries \code{directional}, +what \code{plot()} labels its axis from), +\code{detrend_method}, \code{reml} (as on success) and, for +\code{"fitted range is below the shortest lag fitted"}, +\code{range_floor} (the distance the refused range fell short of). +It carries \code{directional}, \code{anisotropy}, \code{anisotropy_used}, \code{directional_status}, \code{directional_fitted} and, with \code{keep_directional_fits = TRUE}, \code{directional_fits} as well: @@ -165,14 +198,23 @@ past the fitted lags alike. The same shape, with \code{rejected_range = NA}, \code{variogram_model = NULL} and \code{nugget = NA}, is returned when no variogram model could be fitted at all (both the exponential and the spherical fit singular, -which is what a flat, nugget-only variogram produces); +which a flat, nugget-only variogram can produce, though on white +noise it was the outcome in only 1 of 30 draws: see above); \code{rejected_reason} says so and the empirical variogram is still attached.} -\item{No fit}{A bare, attribute-less \code{NA_real_} when estimation -could not be attempted at all: \pkg{gstat} missing, fewer than 30 -finite values, a variable with no variance, or a degenerate extent. -Without \pkg{gstat} nothing is fitted, so none of the attributes -above exist either.} +\item{No fit}{An unclassed \code{NA_real_} when estimation could not +be attempted at all, whose one attribute, \code{rejected_reason}, +says why: \code{"package 'gstat', which the variogram needs, is not +installed"}, \code{" points, fewer than the 30 a variogram range +is estimated from"}, \code{" point(s) with a finite value to +model, fewer than the 30 a variogram range is estimated from"}, +\code{"the response is constant"}, \code{"the residuals on +predictor_vars are constant: the predictors explain the response +exactly"} or \code{"the points have no extent (the largest distance +between them is zero or could not be computed)"}. Nothing is +fitted, so none of the other attributes above exist: no +\code{variogram}, \code{variogram_model} or \code{rejected_range}, +which is what tells it from a range that was fitted and refused.} } Attributes and the class do not affect \code{is.na()} or \code{is.finite()}, so every downstream guard treats all three the same @@ -183,10 +225,21 @@ Fits exponential (or spherical) variogram models and returns the \emph{effective range}: for the exponential model, three times the fitted range parameter, which is where the semivariance reaches ~95 \% of the sill; for the spherical model (fitted only when the exponential fit is -singular) the fitted range itself, which is where the spherical -semivariance reaches its sill exactly. Both are the distance beyond which -two observations are (near) uncorrelated, which is what a block or a -buffer has to exceed. +singular or does not converge) the fitted range itself, which is where the +spherical semivariance reaches its sill exactly. Both are the distance +beyond which two observations are (near) uncorrelated, which is what a +block or a buffer has to exceed. + +The exponential model is kept whenever it converges, without comparing it +with the spherical fit, and on fields smoother than exponential that makes +the range long. Measured on simulated fields (n = 300 on a 1000 m square, +30 draws each): about 1.8--2.1 times the practical range of a Gaussian +covariance, and 1.3--1.4 times the range of a spherical one, while an +exponential field came back at 0.97 of its effective range. The error is +on the safe side (blocks too large, cross-validation pessimistic), and it +is kept on purpose: choosing the family by the smaller weighted sum of +squares corrects the spherical case but sends exponential fields low, to +about 0.82 of the truth, which is the direction that leaks. } \details{ The estimate is the \strong{omnidirectional} (all-pairs) fit. Directional @@ -208,11 +261,25 @@ rotation. Where a field is \emph{known} to be anisotropic, blocks must be at least as large as the longest autocorrelation range to avoid leakage, and the -conservative choice is to size them from -\code{max(attr(range, "directional"))} explicitly. A ratio above 1.5 is -logged so the case is not missed, with that advice. Only when the -omnidirectional fit is itself unusable is the directional maximum returned -in its place, and \code{anisotropy_used} is \code{TRUE} in that case alone. +conservative choice is to size them from the longest directional range +explicitly. Read it from \code{directional_fitted}, not +\code{directional}: on a strongly anisotropic field the major axis is the +direction most likely to run past the fitted lags, which leaves it +\code{NA} in \code{directional}, so \code{max()} of that is \code{NA}, or +with \code{na.rm = TRUE} the second-longest range. Check +\code{directional_status} first: a major axis marked \code{"over_cutoff"} +has no identified range at all, and a longer \code{cutoff} or +\code{\link{make_folds}(method = "nndm")} is the way on. A ratio above +1.5 is written to the package log at INFO level with that advice, which +reaches the session log file but not the console (the ratio passes 1.5 on +most isotropic fields too); \code{print()} shows the directional ranges +and the ratio, and \code{attr(range, "anisotropy")} holds it. Only when +the omnidirectional fit is singular or did not converge is the directional +maximum returned in its place, and \code{anisotropy_used} is \code{TRUE} +in that case alone. An omnidirectional fit that converged to a range past +the fitted lags is refused (see the Value section) whatever the directions +found: the directions that reached a sill are the shorter ones, so their +maximum is a lower bound, not an estimate. A direction whose fit fails, does not converge, or reports a range beyond the longest fitted lag is excluded and recorded as \code{NA} in the @@ -225,10 +292,40 @@ the range: with a 50\% nugget the fitted range came back at about 0.45 of the truth, so \code{make_folds(auto_range = TRUE)} built blocks less than half the correlation length it reported. -A log warning is emitted when the directional maximum is used; where the -all-pairs estimate is available it names both the ratio and that estimate. A -log note is emitted instead when the directional ranges vary but the spread -is consistent with sampling noise. +The lags are binned the way \pkg{gstat} bins them by default, 15 bins out +to the cutoff, each \code{cutoff * max_dist / 15} wide (about 47 m on a +1000 m square at the defaults). A range spanning only one or two bins is +resolved coarsely and comes out long: exponential fields with an effective +range of 60 m (n = 300 on a 1000 m square, 30 draws) returned a median of +89--102 m, where the same fields binned over a 200 m cutoff gave 65--68, +and at a range of 300 m there was no bias. A range shorter than the +first bin cannot be resolved at all and can come back several times too +long: an effective range of 24 m (n = 1500 on a 1000 m square, 8 draws) +returned 93--479 m, five of them as the directional maximum, against +19--32 m at \code{cutoff = 0.1}; the first bin's semivariance was 92--99 +percent of the fitted sill in all eight. So whenever the empirical +variogram is already at its sill in the first one or two bins +(\code{plot()} the result), run it again with a smaller \code{cutoff}, +whatever range was fitted. + +Nothing tests whether the layer has spatial structure at all. On white +noise (n = 300 on a 1000 m square, 30 draws) the estimate was a finite, +spurious range (57--533 m) in 8 draws and a refusal in the rest, mostly +as past the fitted lags or not converged, and only once as no model +fitted; with \code{detrend = "reml"} it was finite in 13 of 30 (21--453 +m), and 16 of the refusals were ranges of 0.18--12.5 m, too short for 30 +pairs of points to lie inside them. A +spurious range errs towards larger blocks, so the harm is mostly lost +training data, but a caller who needs to know whether there is any +structure should look at the variogram (\code{plot()} on the result) +rather than at whether the answer is \code{NA}. + +When the all-pairs fit is singular or did not converge and two or more +directions reached a sill, the directional maximum is returned in its +place (\code{anisotropy_used = TRUE}), and a log warning names the +directional ranges when their ratio exceeds 1.5. When the all-pairs +estimate is used and the directional ranges vary by more than 1.5, a log +note (INFO) names them instead. The returned range is in the coordinate units of the (projected) data and can be passed directly to \code{make_folds(block_size = ...)} so that CV diff --git a/man/evaluate_insample.Rd b/man/evaluate_insample.Rd index a325292..c0c5c5a 100644 --- a/man/evaluate_insample.Rd +++ b/man/evaluate_insample.Rd @@ -22,19 +22,53 @@ If NULL, in-sample metrics are computed.} } \value{ A data.frame with one row per model and columns for -model name and all regression metrics. +model name, all regression metrics, and \code{metric_basis}: what the +row's metrics were computed on, \code{"in-sample"} (fitted values), +\code{"out-of-bag"} (an \code{rf_fit}'s fitted values, see "What the +metrics are computed on") or \code{"newdata"}. Rows with different +bases do not compare like for like. An element that is not a +\code{spatial_fit} is skipped, with a logged warning, and has no row; +a list in which no element is a \code{spatial_fit} is an error. } \description{ Accepts a single \code{spatial_fit} object or a named list of them. Does NOT refit. Uses \code{fitted()} for in-sample and \code{predict()} for new data. } +\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}, +but \strong{out-of-bag} for an \code{rf_fit}, whose \code{fitted()} method +returns out-of-bag predictions (see \code{\link{fit_rf_model}}). The +data.frame \code{model_metrics()} returns carries no label distinguishing +the two, so check \code{object$info$fitted_are_oob} before comparing +numbers across backends; \code{\link{evaluate_insample}()} and +\code{\link{compare_models}()} record it per model in a +\code{metric_basis} column. \code{\link{compare_models_cv}} scores every +backend the same way. + +\eqn{R^2} is \eqn{1 - RSS/TSS} with the total sum of squares taken about +the mean of the response the model was \emph{fitted} to. In sample that +is the ordinary \eqn{R^2}. With \code{newdata} it is out-of-sample +\eqn{R^2}, the convention every \code{cv_*()} function uses: the model is +measured against the prediction it had to beat, the training mean, not +against the new rows' own mean, which it could not have known. It is +below 0 when the model predicts the new rows worse than the training mean +does, and it is \code{NA} when the response does not vary about that +baseline by more than rounding error (100 machine epsilons of its +magnitude, whatever its units). +} + \section{Percentage errors on responses with zeros}{ \code{MAPE} divides by the observed value and \code{SMAPE} by \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/figures/readme-resolution.png b/man/figures/readme-resolution.png index 8d8c845..2c458a0 100644 Binary files a/man/figures/readme-resolution.png and b/man/figures/readme-resolution.png differ diff --git a/man/fit_bayesian_spatial_model.Rd b/man/fit_bayesian_spatial_model.Rd index 1e6870a..1102c48 100644 --- a/man/fit_bayesian_spatial_model.Rd +++ b/man/fit_bayesian_spatial_model.Rd @@ -46,9 +46,11 @@ as \code{brms::zero_inflated_poisson()}, \code{brms::negbinomial()}, \code{brms::hurdle_poisson()}, \code{brms::bernoulli()} or \code{brms::Beta()}. Default \code{NULL}, resolved to \code{stats::gaussian()}. The family reaches \code{brms::brm()} -unchanged with the spatial GP term still in the formula, so any response -type brms can fit, this function can fit; see the section on -non-Gaussian responses and the count example below.} +unchanged with the spatial GP term still in the formula. A factor +response is accepted only under \code{brms::categorical()} or an ordinal +family, and those fits have no single expected value per row, so several +methods cannot use them; see the section on non-Gaussian responses for +what each family supports, and the count example below.} \item{gp_k}{Positive integer giving the number of GP basis functions \emph{per dimension}, or NULL (default) to derive it from the @@ -59,7 +61,11 @@ length-scale/domain ratio. The fitted model carries NULL (default) to derive it alongside \code{gp_k}. The boundary must be wide enough to contain the longest plausible correlation range; a value that is too small truncates the domain and degrades the approximation for -smooth, long-range surfaces.} +smooth, long-range surfaces. When you set \code{gp_c} and leave +\code{gp_k = NULL}, \code{gp_k} is derived for \emph{your} boundary: a +wider boundary needs more basis functions to resolve the same +length-scale, so raising \code{gp_c} raises the derived \code{gp_k} with +it, up to the cap of 50 per dimension (a capped value is logged).} \item{gp_iso}{Logical; passed to \code{brms::gp(iso = )}. \code{FALSE} (the default) fits a separate length-scale per coordinate axis, letting the @@ -108,10 +114,34 @@ exactly the setting the divergence warning tells you to raise.} \item{standardize_predictors}{Logical; center and scale numeric predictors before fitting. Default FALSE. When TRUE, the scaling parameters are -stored in the return value so predictions can be computed correctly.} - -\item{check_convergence}{Logical; after fitting, check for divergences, -low ESS, and high R-hat and issue warnings. Default TRUE.} +stored in the return value (\code{$info$predictor_scaling}, a +\code{center} and \code{scale} per predictor) so predictions can be +computed correctly. The model is then fitted on the standardised +predictors, so \code{coef()} reports a slope per standard deviation of +each predictor and an intercept at the predictor means, not the raw-unit +values \code{stats::lm()} would give; see \code{\link{coef.bayesian_fit}}.} + +\item{check_convergence}{Logical; after fitting, check for divergent +transitions, R-hat above 1.05 and an effective-sample-size ratio below +0.1. Each problem found is written to the log as a WARN line (shown on +the console unless \code{\link{spatialkit_quiet}()} is on), sets +\code{$info$convergence_ok} to \code{FALSE}, and is detailed in +\code{$info$convergence_diagnostics}; \code{print()} on the fit flags it. +The GP basis is also checked against the posterior length-scale (see +Details): a basis too coarse for it is logged as a WARN line, and the +share of draws it cannot resolve is recorded as +\code{$info$convergence_diagnostics$gp_lscale_below_resolution}, but it +does not change \code{convergence_ok} and \code{print()} does not flag +it. None of these are raised as R warnings by the fit itself; the +functions that score fits do raise one: \code{\link{cv_bayes}()} names +the folds whose sampler did not converge (and marks them in +\code{fold_metrics$convergence_ok}), and +\code{\link{compare_models}()} names such a model (column +\code{convergence_ok}). Under \pkg{rstan} the sampler raises its own +R-hat and ESS warnings; under \pkg{cmdstanr} nothing does, so read +\code{$info$convergence_ok}. \code{FALSE} skips +the checks and leaves \code{convergence_ok} \code{NA} (not checked). +Default TRUE.} \item{pointize}{Strategy for non-point geometry coercion.} @@ -132,14 +162,18 @@ 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_S: the pooled centred range \code{brms::gp(c = )} multiplies; +gp_cmeans: the column means brms centred the scaled coordinates on; gp_xy_range: the training extrema of the scaled coordinates, which -\code{predict()} uses to pin the GP boundary; +\code{predict()} uses, with gp_S and gp_cmeans, to hold the GP boundary +at its fitted value; gp_lengthscale_bounds: the \code{c(lower, upper)} the length-scale prior 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: \code{n_divergent}, +convergence_ok (\code{TRUE} or \code{FALSE}, and \code{NA} when nothing +was checked, as under \code{check_convergence = FALSE}), +convergence_diagnostics: \code{n_divergent}, \code{max_rhat}, \code{min_neff_ratio}, and \code{rhat_failed} / \code{neff_failed}, the parameters that failed each check by name with their values (empty when none failed), which is what makes a failed @@ -203,9 +237,12 @@ normalisation would leave every length-scale quantity in the wrong units. After fitting, the posterior length-scale is compared against the smallest scale the chosen basis can resolve -(\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); a -warning is issued when more than 10\% of the posterior mass falls below it, -which is the signal that \code{gp_k} should be raised. +(\code{1.75 * gp_c * S / gp_k}, stored as \code{$info$gp_ell_min}); when +more than 10\% of the posterior mass falls below it a WARN line is logged +and the share is recorded as +\code{$info$convergence_diagnostics$gp_lscale_below_resolution}, which is +the signal that \code{gp_k} should be raised. This runs with the other +checks, so only under \code{check_convergence = TRUE}. \strong{Coordinate scaling and anisotropy.} Before fitting the GP, X and Y coordinates are each centred and divided by @@ -232,16 +269,38 @@ strategy, and \code{$info$gp_iso} records which kernel was used. } \section{Non-Gaussian responses}{ -Nothing in this function is Gaussian-specific except its default. The -response check is family-aware: a non-numeric response is refused only when -the family resolves to gaussian, so a count, binary or bounded response -passes straight through to brms under the family you name. Zero-inflated -and hurdle counts, negative binomial, Bernoulli, beta and ordinal families -have all been verified to reach \code{brms::brm()} with the GP term intact. - -Two things follow. First, the metrics that come back from -\code{\link{model_metrics}()} and the \code{cv_*()} functions are not all -meaningful for such a response: RMSE and MAE are, MAPE, SMAPE and R-squared +Nothing in this function is Gaussian-specific except its default. A +numeric count, binary (0/1 or logical) or bounded response passes straight +through to brms under the family you name; zero-inflated and hurdle +counts, negative binomial, Bernoulli, beta, ordinal, categorical and +mixture families have all been verified to reach \code{brms::brm()} with +the GP term intact, the length-scale prior attached to each +distributional parameter's GP. + +The response check is family-aware. A factor or character response is +accepted only under \code{brms::categorical()} or an ordinal family +(\code{cumulative}, \code{sratio}, \code{cratio}, \code{acat}), and refused +under every other family before anything is compiled; under gaussian a +logical response is refused too. The case to watch is a two-level factor +under \code{brms::bernoulli()}: brms would fit it, but +\code{residuals()}, \code{summary()}, \code{model_metrics()} and +\code{\link{cv_bayes}()} could not score a factor, so convert it to 0/1 +first. + +An ordinal or categorical fit has a probability per response category, not +one expected value per row. \code{predict()} with its default +\code{type = "epred"}, \code{fitted()}, \code{residuals()}, +\code{summary()} and \code{model_metrics()} therefore stop with a message +saying so, and \code{\link{cv_bayes}()} refuses the family before fitting +anything. \code{predict(type = "predict", draws = TRUE)} returns the +posterior predicted categories, as category indices, for new rows as well +as the training ones (the share of draws in each category estimates its +probability), and \code{brms::posterior_epred(fit$engine)} the +probabilities for the training rows. + +For the numeric families two things follow. First, the metrics that come +back from \code{\link{model_metrics}()} and the \code{cv_*()} functions are +not all meaningful for such a response: RMSE and MAE are, MAPE, SMAPE and R-squared are Gaussian-shaped, and for this backend \code{\link{cv_bayes}()}'s CRPS and interval coverage are the proper scores to read. See \code{\link{model_metrics}()}, section "Which metrics survive a @@ -252,10 +311,10 @@ for a Gaussian response, and its help page says how. One trap. The response check reads the family's name through \code{brms}'s own accessor; a family object it cannot name is treated as -"not gaussian" and the check is skipped entirely, without falling back -to the gaussian rule. A malformed \code{family} therefore buys less -validation, not more, and a wrong response type will surface as a Stan -error, with no message from this function. +unknown and the check is skipped entirely, without falling back to either +rule above. A malformed \code{family} therefore buys less validation, not +more, and a wrong response type will surface as a Stan error, with no +message from this function. } \section{Spatial confounding}{ @@ -271,7 +330,12 @@ Ver Hoef 2022): the spatial coefficient is the effect \emph{net of} whatever the spatial field can explain, and the non-spatial one is not. Which of the two a user wants depends on the question, so the honest diagnostic is to report both side by side and leave them unadjusted: fit the same formula -with \code{stats::lm()} or \code{stats::glm()} and compare. +with \code{stats::lm()} or \code{stats::glm()} and compare. Compare like +with like: under \code{standardize_predictors = TRUE} the coefficients here +are per standard deviation of each predictor, so either fit the +non-spatial model on the same standardised columns or divide these slopes +by \code{$info$predictor_scaling[[name]]$scale} first (see +\code{\link{coef.bayesian_fit}}). The literature on remedies is unsettled and this function takes no side. Restricted spatial regression (Hughes and Haran 2013) projects the spatial diff --git a/man/fit_gwr_model.Rd b/man/fit_gwr_model.Rd index 5fd50c0..7187108 100644 --- a/man/fit_gwr_model.Rd +++ b/man/fit_gwr_model.Rd @@ -19,7 +19,8 @@ fit_gwr_model( \item{response_var}{Response column name.} -\item{predictor_vars}{Predictor column names.} +\item{predictor_vars}{Predictor column names (numeric columns; a name given +twice counts once).} \item{adaptive}{Logical; use adaptive bandwidth. Default TRUE. When TRUE, bandwidth is an integer number of nearest neighbours. When FALSE, @@ -37,7 +38,19 @@ If NULL (default), bandwidth is selected automatically via smaller than a ten-thousandth of the data's extent raises a warning naming the extent and the CRS the fit runs in: every local window is then likely to be empty, which used to produce a fit whose coefficients were all -\code{NaN} with nothing raised anywhere.} +\code{NaN} with nothing raised anywhere. With \code{adaptive = TRUE} +the count is rounded, and one too small for the model is raised, with a +warning, to the smallest that gives every local regression more points +of non-zero weight than parameters: the number of predictors plus 3 for +the bisquare and tricube kernels (which give the farthest neighbour in a +window weight 0), plus 2 for the others. That floor is enough unless +several neighbours tie at the kernel's edge (a regular grid), which +leaves a window fewer weighted points; then use a larger bandwidth. +A count above the number of +observations is capped at it, with a warning (a distance meant for +\code{adaptive = FALSE}, most often). \code{bw.gwr()} searches adaptive +bandwidths from 20 neighbours up, so below 20 observations its choice is +capped the same way, with a warning, and is not an optimised bandwidth.} \item{kernel}{Kernel function type. One of "bisquare" (default), "gaussian", "tricube", "boxcar", "exponential".} @@ -53,10 +66,18 @@ A \code{gwr_fit} object (inherits from \code{spatial_fit}). Supports \code{predict()}, \code{fitted()}, \code{residuals()}, \code{coef()}, \code{summary()}, and \code{model_metrics()}. Model-specific metadata lives in \code{$info}: bandwidth, adaptive, -kernel, AICc, \code{bandwidth_is_fallback} (\code{TRUE} when automatic +kernel, AICc (\code{NA}, with a warning, where GWmodel's AICc is +undefined: its effective number of parameters \eqn{tr(S)} is not below +\eqn{n - 2}, the local regressions all but interpolate the data, and the +large negative value GWmodel reports would rank the fit above any +other), \code{bandwidth_is_fallback} (\code{TRUE} when automatic selection failed and the arbitrary fallback was used), -\code{condition_index}, \code{local_collinearity}, -\code{n_local_collinear}, \code{n_local_singular}, +\code{condition_index} (the global index), \code{local_collinearity} +(one row per observation: \code{row}, \code{x}, \code{y}, +\code{n_window}, \code{cn} and \code{cn_slopes}; see +\strong{Collinearity diagnostics}), \code{n_local_collinear} (the +locations whose slopes count as collinear), \code{n_local_singular} +(the locations whose local coefficients came back non-finite), \code{nonfinite_coef} (a logical matrix, one row per observation and one column per term, with \code{Intercept} first, \code{TRUE} where the local coefficient came back non-finite, so the count in @@ -71,47 +92,72 @@ bandwidth. } \section{Collinearity diagnostics}{ -The function computes the \strong{scaled condition index} of the design and -warns when it exceeds 30, the conventional threshold, which Wheeler & -Tiefelsdorf (2005) carry over to the local designs of GWR. The index is -the ratio of the largest to the smallest singular value after each column -is scaled to unit length (Belsley, Kuh & Welsch 1980). Scaling makes the -index independent of the predictors' units; \code{kappa()} on the raw matrix -is not, and a threshold on it is a threshold on nothing in particular. -A \strong{global} index is computed on the full design (intercept plus -predictors). -In addition, a \strong{local} spot-check is performed at up to 30 locations: -every location when there are 30 or fewer, otherwise 30 spread evenly over -the extent (evenly spaced ranks of the observations ordered by x, then y), -so the diagnostic is reproducible, draws no random numbers, does not depend -on the row order of the data, and the count is not configurable. For each -sampled point the nearest neighbours within the bandwidth window (the -bandwidth the model is actually fitted with, not a stand-in) are selected -and the condition number of that local design sub-matrix is evaluated. -That sub-matrix is the predictors \strong{plus an -intercept column}, matching the design GWmodel fits, and is unweighted; the -global condition number is computed on the predictors alone, so the two -numbers are not directly comparable. An indicator that is constant inside a -window is collinear with the intercept and with nothing else, which is why -the intercept has to be there. A non-finite condition number counts as -extreme: \code{kappa()} returns \code{Inf} for an exactly singular design, which is the -worst case, not an exempt one. +The function computes \strong{scaled condition indices} of the design and +warns when one exceeds 30, the conventional threshold, which Wheeler & +Tiefelsdorf (2005) carry over to the local designs of GWR. An index is +the ratio of the largest to the smallest singular value (from an SVD) after +each column is scaled (Belsley, Kuh & Welsch 1980); an exactly singular +design gives \code{Inf}, which counts as the worst case, not an exempt one. +Scaling makes the index independent of the predictors' units; +\code{kappa()} on the raw matrix is not, and a threshold on it is a +threshold on nothing in particular. -A warning is issued whenever \strong{any} sampled location has a singular or -near-singular local design; the wording reports a percentage when more than -25\% of sampled locations are affected and a count otherwise. Both are real -R warnings, not log lines. +A \strong{global} index is computed on the predictors centred at their means +(with the intercept, which centring makes orthogonal to them), and kept as +\code{info$condition_index}. It measures how nearly the predictors are +collinear with one another over the whole study area; it is 1 for a single +predictor, and a change of origin (degrees C or kelvin, a year or years +since 2000) does not move it. -After the fit, the local coefficient surfaces are scanned and a further -warning counts local regressions that came back non-finite. Their windows -were singular. \code{fitted()}, \code{residuals()}, \code{summary()} and -\code{\link[=model_metrics]{model_metrics()}} all drop those rows, so when this warning fires the -metrics describe only the part of the study area that fitted. +\strong{Local} indices are then computed at \strong{every} location, on the design +the local regression there inverts: each row weighted by the square root +of its kernel weight at the bandwidth the model is fitted with (supplied or +selected), with rows of negligible weight dropped. A window left with +fewer rows than columns counts as singular. Two indices are kept for each +window, as columns of \code{info$local_collinearity}: +\describe{ +\item{\code{cn}}{Belsley's index of the intercept plus the predictors, +scaled to unit length but not centred. A predictor whose values in the +window are far from 0 against their spread (a year, a temperature in +kelvin) is collinear with the intercept and raises it: the local +intercept is then an extrapolation to 0 and is ill-determined, but the +slopes are not. It is what GWmodel's own solve sees.} +\item{\code{cn_slopes}}{The index for the slopes: the predictors centred at +their weighted mean in the window and each divided by its standard +deviation over the whole study area. It is 1 when the predictors vary +as much, and as independently, inside the window as they do across the +study area; it grows as a predictor becomes nearly constant inside the +window (a regional covariate) or two predictors move together there. +It does not depend on the predictors' origin or units.} +} +A window's slopes count as collinear when \code{cn_slopes} is above 30 or +singular, or when \code{cn} is above 1e6, where GWmodel's uncentred solve starts +to lose precision in the slopes too. Those windows are counted in +\code{info$n_local_collinear}. A predictor that is constant, or nearly so, +inside a window is caught this way whether it is alone or has company, so a +single predictor is surveyed too. -Because the local spot-check examines only a subset of locations, it may not -detect every problematic neighbourhood. Users working with highly clustered -data or near-collinear predictors should consider a full local-collinearity -audit as a post-fit diagnostic. +A warning is issued whenever \strong{any} location has collinear slopes; the +wording reports a percentage when more than 25\% of locations are affected +and a count otherwise. Both are real R warnings, not log lines. +Coefficients at a near-singular window are unstable and can be implausibly +large. An \strong{exactly} singular window (an indicator that is constant +inside it, or fewer observations than parameters) makes GWmodel stop, so +the fit fails with an error that says so; the window is not returned as +\code{NaN}. A window with only \code{cn} above 30 raises no warning: +\code{plot(fit, type = "coefficients", term = "Intercept")} masks it, and slope +maps do not. Centre such a predictor if you want an interpretable local +intercept. + +After the fit, the local coefficient surfaces are scanned and a further +warning counts local regressions that came back non-finite. GWmodel +returns those where the kernel weights are undefined: with an adaptive +bandwidth of \code{k}, a location where \code{k} or more observations share the same +coordinates has a kernel of zero width, and every kernel but the boxcar +divides 0 by 0 there. The warning names that cause when it applies. +\code{fitted()}, \code{residuals()}, \code{summary()} and \code{\link[=model_metrics]{model_metrics()}} all drop those +rows, so when this warning fires the metrics describe only the part of the +study area that fitted. } \examples{ diff --git a/man/fit_rf_model.Rd b/man/fit_rf_model.Rd index eaaf57c..a436397 100644 --- a/man/fit_rf_model.Rd +++ b/man/fit_rf_model.Rd @@ -55,7 +55,10 @@ the setting is recorded in \code{$info} and printed with the fit.} \item{sample_fraction}{Fraction of rows drawn for each tree. \code{NULL} (default) uses ranger's rule: all rows when \code{replace = TRUE}, 0.632 (the expected share of distinct rows in a bootstrap sample) -when \code{replace = FALSE}. A single number in (0, 1] overrides it.} +when \code{replace = FALSE}. A single number in (0, 1] overrides it. +\code{replace = FALSE} with \code{sample_fraction = 1} grows every tree +on every row, so nothing is out of bag: the fit warns, and see +\strong{What fitted() returns}.} \item{seed}{Seed passed to ranger. Default 123.} @@ -136,6 +139,18 @@ consequence is that \code{summary()} means something different here than for a \code{gwr_fit} or \code{bayesian_fit}, whose fitted values are in-sample: do not compare the two directly. \code{\link{compare_models_cv}} exists for that. + +A row that every tree sampled has no out-of-bag prediction, and ranger +reports \code{NaN} for it. That is every row under \code{replace = FALSE} +with \code{sample_fraction = 1}, and a few under a small \code{num_trees}. +The fit warns with the count; \code{fitted()} and \code{residuals()} are +\code{NaN} on those rows, and \code{summary()} says how many rows its +metrics were computed on. With no row out of bag at all, the OOB error +(\code{NA} in \code{$info$oob_rmse} and \code{$info$oob_r_squared}) and +the permutation importance (\code{NaN}) are undefined too, and +\code{print()} says so. \code{\link{cv_rf}()} scores its fold forests on +the held-out rows, never out of bag, so it warns once with the number of +folds affected rather than once per fold. } \examples{ @@ -167,7 +182,9 @@ solution. \emph{BMC Bioinformatics} 8, 25. \doi{10.1186/1471-2105-8-25} \seealso{ \code{\link{cv_rf}} for a spatially blocked performance estimate, \code{\link{area_of_applicability}}, which can take -\code{weights = pmax(fit$info$importance, 0)}. +\code{weights = pmax(fit$info$importance, 0)} when that importance is +finite (it is \code{NaN} when no row is out of bag; see "What +fitted() returns"). Other model fitting: \code{\link{fit_bayesian_spatial_model}()}, diff --git a/man/fitted.bayesian_fit.Rd b/man/fitted.bayesian_fit.Rd index 493db21..05cb2a7 100644 --- a/man/fitted.bayesian_fit.Rd +++ b/man/fitted.bayesian_fit.Rd @@ -12,8 +12,9 @@ \item{...}{Ignored.} } \value{ -Numeric vector of length \code{object$n} (all \code{NA} if the -posterior draw failed). +Numeric vector of length \code{object$n}. A posterior that cannot +be drawn is an error, as is a family with a probability per response +category (ordinal, categorical), which has no single fitted value per row. } \description{ Posterior expectation at the training locations: the column means of @@ -48,8 +49,12 @@ 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, since 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. +\code{data_sf} only. The entry is also tied to the engine that computed +it -- a refit or \code{update()} of the \code{brmsfit} is a different +sampling run and recomputes -- but a \code{brmsfit} edited by hand in place +is what \code{\link{clear_fitted_cache}} is for. The entry holds only the +values and a small identifier of the sampling run, so a fit saved with +\code{saveRDS()} after \code{fitted()} is no larger for it. } \seealso{ diff --git a/man/fold_separation.Rd b/man/fold_separation.Rd index 2b2b546..116a64e 100644 --- a/man/fold_separation.Rd +++ b/man/fold_separation.Rd @@ -13,21 +13,38 @@ element (a list of \code{train}/\code{test} splits).} \item{data_sf}{The layer the folds were built on. Row identifiers are matched through \code{..row_id} when the layer carries one, and by row position otherwise, which is what \code{make_folds()} and every -\code{cv_*()} do.} +\code{cv_*()} do. As in \code{cv_*()}, a \code{make_folds()} result +whose recorded rows sit at other locations here (folds built on another +layer, such as the points before +\code{\link{assign_features_to_polygons}()} dropped some) is refused; +the location check is skipped when one of the two layers is POINT and +the other is not.} \item{sac}{Optional: an \code{\link{estimate_sac_range}()} result or a -single number, in the CRS units of \code{data_sf}. Defaults to the range -the folds carry, if any. Supplying one adds the \code{within_range} -column and the closing verdict.} +single number. Defaults to the range the folds carry, if any. Supplying +one adds the \code{within_range} column and the closing verdict. A +range that records its CRS (the folds' own, or an +\code{estimate_sac_range()} result) is compared with distances measured +in that CRS, whatever CRS \code{data_sf} is in. A bare number is taken +to be in the units the distances are otherwise measured in: those of +\code{data_sf} if it is projected, and for geographic (lon/lat) input +metres, in the CRS \code{\link{ensure_projected}()} chooses (as for +\code{make_folds()}'s \code{block_size}), not degrees. A \code{units} +object is refused.} } \value{ A data.frame of class \code{fold_separation}, one row per fold: -\code{fold}, \code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} +\code{fold} (the fold's number: for the \code{$folds} of a +\code{cv_*()} result, the \code{fold_id} its \code{fold_metrics} use, +which differs from the list position once a fold has been dropped), +\code{n_train}, \code{n_test}, \code{n_blocks} (\code{NA} for a scheme with no blocks), \code{min_dist} and \code{median_dist} -(distance from a held-out point to its nearest training point, in CRS -units), and \code{within_range} (the share of held-out points closer to +(distance from a held-out point to its nearest training point, in the +units of the CRS the \code{crs} attribute names), and +\code{within_range} (the share of held-out points closer to training data than \code{sac}; \code{NA} without one). Attributes: -\code{method}, \code{sac_range}, \code{crs} and \code{n_unknown_ids}. +\code{method}, \code{sac_range}, \code{crs} (the CRS the distances were +measured in) and \code{n_unknown_ids}. } \description{ Blocked cross-validation exists to put distance between a test point and @@ -56,7 +73,7 @@ library(sf) set.seed(1) n <- 200 pts <- st_as_sf( - data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)), + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)), coords = c("x", "y"), crs = 32632 ) diff --git a/man/get_voronoi_seeds.Rd b/man/get_voronoi_seeds.Rd index 8780fe4..51e8fcb 100644 --- a/man/get_voronoi_seeds.Rd +++ b/man/get_voronoi_seeds.Rd @@ -47,9 +47,14 @@ the first two coordinate columns are clustered, so a Z or M dimension does not join the distance calculation and dominate it; rows with empty or non-finite coordinates are dropped with a warning, so they never reach \code{stats::kmeans()}, which fails on them without naming a cause. A lon/lat -cloud is projected before clustering.} +cloud, or one with no CRS whose coordinates look like lon/lat (the +heuristic \code{\link[=ensure_projected]{ensure_projected()}} applies, with its warning), is projected +before clustering.} -\item{kmeans_nstart}{Integer; nstart for kmeans(). Default 10.} +\item{kmeans_nstart}{Integer; nstart for kmeans(). Default 10. The +partition is \code{\link[stats:kmeans]{stats::kmeans()}}, not the best-of-25 k-means++ run that +\code{\link[=resolution_profile]{resolution_profile()}} scored a count on, so it is not that partition; +see \code{\link[=voronoi_seeds_kmeans]{voronoi_seeds_kmeans()}}.} \item{kmeans_iter}{Integer; iter.max for kmeans(). Default 100.} diff --git a/man/gp_lengthscale_bounds.Rd b/man/gp_lengthscale_bounds.Rd index 24063a0..e9c7c5c 100644 --- a/man/gp_lengthscale_bounds.Rd +++ b/man/gp_lengthscale_bounds.Rd @@ -37,6 +37,15 @@ The "effective range" where correlation drops to ~5\% is } \details{ Subsamples large datasets to avoid O(n^2) memory and time cost. + +These are the bounds a length-scale \emph{prior} is calibrated over, not +the scales a fitted model can resolve: that depends on the basis size +(\code{gp_k} in \code{\link{fit_bayesian_spatial_model}()}, which reports +it as \code{$info$gp_ell_min}). Both bounds are fixed fractions of the +spread of pairwise distances, so they do not shrink as points are added to +the same area. A surface whose range sits below what the basis resolves +needs a larger \code{gp_k}: more points help the data identify a short +range, but they make neither these bounds nor the derived basis finer. } \examples{ set.seed(1) diff --git a/man/gwr_model_selection.Rd b/man/gwr_model_selection.Rd index 5462f97..2cec1ec 100644 --- a/man/gwr_model_selection.Rd +++ b/man/gwr_model_selection.Rd @@ -36,7 +36,19 @@ model containing every candidate. Integer neighbour count when \code{adaptive = TRUE}; otherwise a distance in the units of the \strong{projected} CRS the sweep runs in, which \code{prep_model_data()} may have chosen for you. Geographic input is projected before the bandwidth -is used, so a value in degrees would be read as metres.} +is used, so a value in degrees would be read as metres; a fixed +bandwidth below a ten-thousandth of the data's extent raises a warning +saying so, as in \code{\link{fit_gwr_model}()}. An adaptive +count too small for the full model is raised, with a warning, to the +number of candidates plus 3 for the bisquare and tricube kernels (which +give the farthest neighbour in a window weight 0), plus 2 for the others. +That floor is enough unless several neighbours tie at the kernel's edge +(a regular grid), which leaves a window fewer weighted points; then use +a larger bandwidth. An adaptive count below 1 or above R's largest +integer is refused, as in \code{\link{fit_gwr_model}()}. +One above the number of observations is capped at it, with a warning; +below 20 observations that includes \code{bw.gwr()}'s choice, since its +adaptive search starts at 20 neighbours.} \item{adaptive}{Logical; adaptive (nearest-neighbour) bandwidth. Default \code{TRUE}.} @@ -67,7 +79,11 @@ progress.} An object of class \code{gwr_model_selection}, a list with: \code{best} (character vector of the selected predictors); \code{table} (ranked data.frame of every model evaluated, with columns -\code{rank}, \code{n_vars}, \code{variables} and \code{criterion}); +\code{rank}, \code{n_vars}, \code{variables} and \code{criterion}; +\code{criterion} is \code{NA}, and the model ranked last, where GWmodel +could not evaluate it or where AICc is undefined because the model's +effective number of parameters \eqn{tr(S)} is not below \eqn{n - 2}, +which raises a warning); \code{criterion} (label for the criterion actually read, noting when it had to be located positionally); \code{criterion_by_name} (logical: whether that column was found by diff --git a/man/harmonize_crs.Rd b/man/harmonize_crs.Rd index 82ba9ec..9291611 100644 --- a/man/harmonize_crs.Rd +++ b/man/harmonize_crs.Rd @@ -17,7 +17,8 @@ harmonize_crs( \item{prefer}{Which object's CRS to keep ("a" or "b").} -\item{target_crs}{Optional target CRS to apply to both.} +\item{target_crs}{Optional target CRS to apply to both: anything +\code{\link[sf:st_crs]{sf::st_crs()}} accepts, including an sf or sfc object, whose CRS is used.} \item{on_transform_error}{What to do when st_transform() fails: \code{"stop"} (default) raises an error immediately; diff --git a/man/kriging_adequacy.Rd b/man/kriging_adequacy.Rd index 7a72a24..a722330 100644 --- a/man/kriging_adequacy.Rd +++ b/man/kriging_adequacy.Rd @@ -14,6 +14,8 @@ kriging_adequacy( k = 5L, seed = 123L, nmax = 50L, + max_neighbours = 2000L, + max_box_ratio = 1000, quiet = TRUE ) } @@ -23,20 +25,48 @@ kriging_adequacy( \item{response_var}{The response column.} -\item{cells_sf}{The cell polygons, with the matching ID column.} +\item{cells_sf}{The cell polygons, with the matching ID column. A layer +with no CRS is taken to be in the points' CRS (and points with none in +the cells'), with a warning.} -\item{id_col}{Preferred name of the ID column. Default \code{"poly_id"}.} +\item{id_col}{Preferred name of the ID column, found as +\code{\link{summarize_by_cell}()} finds it: on the points the first of +\code{id_col}, \code{"poly_id"}, \code{"polygon_id"} and +\code{"cell_id"}; on the cells the first of that column, +\code{"poly_id"}, \code{"polygon_id"}, \code{"id"}, \code{"cell_id"} +and \code{"grid_id"}. IDs are matched as text, whole numbers written +out in full, so a double \code{1e5} matches an integer \code{100000}; +a point whose ID matches no cell is counted in no cell, with a +warning. Default \code{"poly_id"}.} \item{sac}{Optional \code{sac_range} carrying a variogram model.} \item{folds}{Optional \code{\link{make_folds}()} result on \code{assigned_points_sf} for the cross-validation statistic; built here -with \code{block_kfold} when \code{NULL}.} +with \code{block_kfold} when \code{NULL}. As in \code{cv_*()}, folds +whose recorded rows sit at other locations in +\code{assigned_points_sf} (built on another layer, such as the points +before \code{\link{assign_features_to_polygons}()} dropped some) are +refused.} \item{k, seed}{Folds and seed for that construction.} -\item{nmax}{The largest number of neighbours each kriging system uses -(\code{gstat}'s \code{nmax}). Default 50.} +\item{nmax}{The number of neighbours each kriging system uses +(\code{gstat}'s \code{nmax}): the locations nearest the cell's centre, +or, for a cell those leave some of its own locations out of, all of its +own plus this many outside it (see "The kriging neighbourhood"). The +cross-validation kriges each held-out point from its \code{nmax} nearest +training locations. Default 50.} + +\item{max_neighbours}{The largest kriging system a cell is given when its +neighbourhood has to grow to hold all its own locations; a cell that +would need more is left out (\code{kr_} columns \code{NA}) with a +warning. Never below \code{nmax}. Default 2000.} + +\item{max_box_ratio}{A cell whose bounding box is more than this many +times its area is left out (\code{kr_} columns \code{NA}) with a +warning, because \pkg{gstat}'s discretisation of it costs memory in +proportion. Default 1000.} \item{quiet}{Suppress progress messages. Default \code{TRUE}.} } @@ -45,11 +75,19 @@ An \code{sf} object of class \code{"kriging_adequacy"}, one row per cell with the cell geometry and: the ID column, \code{n} (points in the cell), \code{mean} (the plain mean), \code{se} (its naive standard error), \code{kr_pred}, \code{kr_var}, \code{kr_ratio}, -\code{kr_exceeds_design} and \code{kr_shift}. Attributes: +\code{kr_exceeds_design}, \code{kr_shift} and \code{kr_n_used} (how many +locations the cell was kriged from; \code{NA} for a cell left out). +Attributes: \code{variogram} (the model frame), \code{sill}, \code{nugget}, -\code{range}, \code{range_identified}, \code{cv} (a list: +\code{range}, \code{range_identified}, \code{rejected_reason} (why the +range was refused, from \code{sac}; \code{NA} when it was identified), +\code{cv} (a list: \code{zscore_var}, \code{zscore_mean}, \code{rmse}, \code{n_pred}, -\code{k}, \code{method}), \code{nmax} and \code{n_points}. +\code{k}, \code{method}), \code{nmax}, \code{n_points} (the points +used), \code{n_locations} (the distinct locations among them, which +the kriging used) and \code{cells_left_out} (counts of cells left out, +named \code{shape} for \code{max_box_ratio} and \code{size} for +\code{max_neighbours}). } \description{ \code{\link{summarize_by_cell}()} aggregates by plain means inside cell @@ -59,7 +97,8 @@ and a variance for every cell, thin or empty. Whether that is worth having on a given layer is a question with a measurable answer, and this function measures it, changing no cell value: for every cell it reports the block-kriging estimate and variance implied by a fitted variogram, -that variance as a share of the total sill, and, where the cell has points, +that variance as a share of the variance the cell's mean would have with +no data at all, and, where the cell has points, whether it exceeds the design-based variance of the plain mean, \eqn{s^2/n}; and it scores the variogram itself by blocked cross-validation. @@ -67,12 +106,23 @@ cross-validation. \section{Reading the columns}{ \describe{ -\item{\code{kr_ratio}}{The block-kriging variance over the total sill, -in \eqn{[0, 1]}. It is the coverage score, and it needs no hand-set -threshold in metres or point counts: as it approaches 1 the estimate -carries almost no information from the data and is reverting to -the global mean. A cell at 0.05 is well determined; a cell at 0.8 is -mostly prior.} +\item{\code{kr_ratio}}{The block-kriging variance over the cell's prior +variance, in \eqn{[0, 1]}. The prior variance is the variance the +cell's mean would have with no data at all, \eqn{\bar C(B,B)}: the +covariance averaged over pairs of points in the cell, on the +discretisation \pkg{gstat} block-kriges with, and without the nugget, +which averages out over a block (\pkg{gstat} leaves it out of the +block variance too). Each cell has its own: a cell's mean varies less +than a single point does, and far less once the cell is wider than the +range, so the point sill is not the scale. It is the coverage score, +and it needs no hand-set threshold in metres or point counts: as it +approaches 1 the estimate carries almost no information from the data +about the cell and is reverting to the estimated mean. Ordinary +kriging adds the variance of that estimated mean, so a cell the data do +not reach comes out at or above its prior variance and reads 1. A +cell at 0.05 is well determined; a cell at 0.8 is mostly prior. +\code{NA} when the model is a pure nugget, where a cell mean has no +prior variance to be a share of.} \item{\code{kr_exceeds_design}}{\code{TRUE} where the kriging variance is larger than \eqn{s^2/n} from the cell's own points: kriging is not earning its keep there, and that is said per cell instead of @@ -104,9 +154,14 @@ sill whatever the nugget, so the blocked statistic checks the sill and range. To check the nugget, pass random folds (\code{make_folds(method = "random_kfold")}) as \code{folds}: the held-out points are then close to their neighbours, where the nugget -decides the variance. \code{gstat::krige.cv()} computes the statistic on -the fold labels \code{\link{make_folds}()} built, so the folds carry the -same separation the package uses everywhere else. +decides the variance. The statistic is computed fold by fold with +\code{gstat::krige()} on the splits \code{\link{make_folds}()} built, each +held-out point kriged from that split's own training set, so the folds +carry the same separation the package uses everywhere else: +\code{"buffered_loo"} and \code{"nndm"} keep the points they exclude +around each held-out one out of its kriging, and \code{print()} names the +scheme that ran. A vector of fold labels is run as k-fold, each fold +kriged from all the others. } \section{What it said about block kriging as an aggregator}{ @@ -132,9 +187,74 @@ result carrying one (\code{attr(, "variogram_model")}); when \code{NULL} it is estimated here from the response. The model families are the ones the package interprets elsewhere: exponential, spherical and Gaussian components with a nugget. Anything else is refused by name. A -model whose range was not identified (a bare \code{NA} estimate with the -model attached) is used with a warning: its sill was never reached by the -data, so the ratios rest on an extrapolation. Requires \pkg{gstat}. +model whose range was not identified (an \code{NA} estimate with the +model attached) is used with a warning that says why it was refused, and +the reason is kept as \code{attr(, "rejected_reason")}: a range past the +fitted lags means the sill was never reached and the ratios rest on an +extrapolation; a fit that did not converge stopped wherever the optimiser +halted; a variogram that falls with distance, or a range below the +shortest lag, describes the data poorly at some lags. + +The model has to be of the response itself. A variogram of residuals +(\code{estimate_sac_range(predictor_vars = ...)}, \code{attr(, +"detrended")} \code{TRUE}) leaves out the variance the predictors +explain, while the response is kriged here without them, so +\code{kr_var}, \code{kr_ratio} and the cross-validation statistic come out +too small (the statistic at 4.3--5.2 against 0.67--1.53 with a spatially +structured covariate); it is used with a warning. The points are put in +the CRS the variogram was fitted in (\code{attr(sac, "crs")}), because +its range is a length in that CRS's units. Requires \pkg{gstat}. +} + +\section{The kriging neighbourhood}{ + +\pkg{gstat} kriges a cell from the \code{nmax} locations nearest its +centre. A cell holding more locations than that would be estimated from +its middle alone, which describes the middle rather than the cell (in one +simulated case a cell of 1,500 points came out 0.43 off at +\code{nmax = 50}, against 0.07 from all of them and 0.02 for its plain +mean). So wherever the \code{nmax} locations nearest a cell's centre +leave out any of the cell's own locations, the cell is kriged from all of +its own locations plus the \code{nmax} nearest outside it; +\code{kr_n_used} says how many locations each cell was kriged from. The +cost of a kriging system grows with the cube of its size (about 1 s at +2,000 locations and 17 s at 5,000), so a cell that would need more than +\code{max_neighbours} is left out with a warning, its \code{kr_} columns +\code{NA}. + +\pkg{gstat} also discretises each cell into 500 points on a regular grid +laid over the cell's whole bounding box, keeping those inside, so the +memory a cell takes grows with the ratio of that box to its area: about +54 MB more for a thin diagonal strip at a ratio of 708, and 592 MB at +7,072. A cell whose bounding box exceeds its area more than +\code{max_box_ratio} times (a sliver, parts far apart, a cell that is +mostly hole) is left out the same way. \code{attr(, "cells_left_out")} +counts both kinds, and \code{print()} says how many cells have no +estimate and why. +} + +\section{Repeat measurements at one location}{ + +Two observations at the same coordinates (visits to a station, records +geocoded to one address) make a kriging system singular, because +\pkg{gstat} gives them the full sill, nugget included, as their +covariance, as if they were one observation. The kriging and its +cross-validation therefore use one observation per location, the mean of +its replicates, with a warning; \code{n} and \code{mean} still count every +point. How much of the nugget \eqn{c_0} a mean of \eqn{m} replicates +keeps is read off the replicates: their pooled within-location variance +\eqn{s_w^2}, capped at \eqn{c_0}, is the part that differs from visit to +visit and averages down, and the rest is micro-scale variation the visits +share, so the mean carries error variance \eqn{c_0 - s_w^2 + s_w^2/m}. +That goes to \pkg{gstat} as a known measurement error (its +\code{weights}) on the model with the nugget set to zero. For replicates +that differ only by measurement error this is exactly the kriging of every +observation, and for identical replicates it is the kriging of one; a +location seen once is kriged as before. In the cross-validation a +location is held out whole, under the fold of its first row, and its +error variance is part of its standardised error. A cell or held-out +location \pkg{gstat} still cannot krige is reported \code{NA} with a +warning, and \code{print()} says how many. } \examples{ diff --git a/man/make_folds.Rd b/man/make_folds.Rd index 029b848..41df84f 100644 --- a/man/make_folds.Rd +++ b/man/make_folds.Rd @@ -37,15 +37,19 @@ or \code{prediction_points} that carries a CRS. They are reprojected when the coordinates look like lon/lat and otherwise stamped without reprojection, with a warning either way.} -\item{k}{Integer; number of folds. Must be a single whole number >= 1. +\item{k}{Integer; number of folds. Must be a single whole number >= 1, +and is required except for the two leave-one-out methods. A fraction, \code{NA} or a vector is an error, because a non-integer used to truncate silently and leave the last rows in no test set at all. Not every method honours it. \code{"buffered_loo"} and \code{"nndm"} are leave-one-out schemes and always return \code{k = n} regardless of what was asked for; \code{"block_kfold"} lowers it when the grid yields fewer than \code{k} non-empty blocks, and \code{"leave_location_out"} lowers it -when there are fewer than \code{k} distinct groups. Read the \code{k} -element of the returned list, and do not assume the requested value. A +when there are fewer than \code{k} distinct groups. \code{k = 1} is +raised to 2 by \code{"random_kfold"}, \code{"block_kfold"} and +\code{"leave_location_out"}, since one fold has no training set. Read +the \code{k} element of the returned list, and do not assume the +requested value. A reduction is written to the package log and raises no R warning, so \code{tryCatch(warning = )} will not see it and \code{suppressWarnings()} will not hide it.} @@ -56,13 +60,20 @@ will not hide it.} \item{seed}{Optional integer RNG seed.} -\item{block_nx, block_ny}{Optional grid dimensions for block_kfold. -Ignored when \code{block_size} or \code{auto_range} override them.} +\item{block_nx, block_ny}{Optional grid dimensions for block_kfold, each a +single whole number >= 1. Give both, or give one and the other is +derived from the extent's aspect ratio so that the blocks are roughly +square. Ignored when \code{block_size} or \code{auto_range} override +them.} -\item{block_multiplier}{Numeric, default 3. When neither \code{block_size} -nor \code{block_nx}/\code{block_ny} is given, the automatic grid aims for +\item{block_multiplier}{A single positive number, default 3. When +neither \code{block_size} nor \code{block_nx}/\code{block_ny} is given, +the automatic grid aims for \code{block_multiplier * k} blocks over the extent (aspect-preserving), -so each fold holds out about \code{block_multiplier} blocks. With 1, +so each fold holds out about \code{block_multiplier} blocks. An extent +more than about \code{block_multiplier * k} times as wide as it is tall +(or as tall as it is wide) gets a single row (or column) of that many +blocks. With 1, every fold is one contiguous region and the score depends heavily on which region each fold happened to get; with many, the blocks shrink towards single points and the scheme drifts back towards random k-fold. @@ -91,8 +102,12 @@ request above 1,000,000 blocks is refused with an error naming the grid dimensions, the extent and the CRS's units.} \item{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 +range is estimated via \code{estimate_sac_range()} (the omnidirectional, +all-pairs range; the directional ranges it also fits are a diagnostic +only, so on a field known to be anisotropic pass +\code{block_size = max(attr(r, "directional_fitted"), na.rm = TRUE)} +yourself after checking \code{attr(r, "directional_status")}, see +\code{\link{estimate_sac_range}}) and used as the minimum \code{block_size}. Requires \code{response_var}. An explicit \code{block_size} takes precedence. Default \code{FALSE}. Sizing blocks from the autocorrelation range is the recommendation of Roberts @@ -101,17 +116,26 @@ et al. (2017) and what \pkg{blockCV} (Valavi et al. 2019) automates. \emph{parameter} as the block size, whereas this uses the \emph{effective} range \code{estimate_sac_range()} returns (three times that parameter for an exponential fit), so its blocks are larger -than \pkg{blockCV}'s from the same variogram.} +than \pkg{blockCV}'s from the same variogram. When no range is +identified, the geometric grid is used instead, with a warning that +gives the reason. An identified range above half the extent in both +directions leaves room for a single block, and \code{make_folds()} then +stops with an error naming the size, rather than return one fold with +an empty training set: pass a smaller \code{block_size}, or use +\code{method = "nndm"}.} \item{range_frac}{Passed through to \code{estimate_sac_range()} when \code{auto_range = TRUE}. A fitted range beyond the longest lag the empirical variogram was fitted over is rejected as unidentified, and block -sizing falls back to geometry, so the grid does not collapse to a single -block. +sizing falls back to geometry (with a warning). A range within that +bound can still be too wide for two blocks; see \code{auto_range}. Default 1.0.} \item{response_var}{Character(1) response column name. Required when -\code{auto_range = TRUE}.} +\code{auto_range = TRUE}. For \code{"block_kfold"} a name that is not a +column of \code{points_sf} is an error, whether or not +\code{auto_range} is set: with it off the response still feeds the +leakage warning, which a misspelt name would silently disable.} \item{group_var}{Character(1) naming a column of \code{points_sf} that identifies the location each observation belongs to. Required for @@ -133,25 +157,45 @@ plain leave-one-out.} \item{predictor_vars}{Optional character vector of predictor column names. Passed to \code{estimate_sac_range()} for residual variogram estimation.} -\item{boundary}{Optional polygonal sf/sfc for block_kfold.} - -\item{buffer}{Positive numeric distance for buffered_loo.} +\item{boundary}{Optional polygonal sf/sfc for block_kfold. The grid is +clipped to it; a cell that the boundary only touches at a corner or +along an edge is not a block. A boundary without a CRS is brought into +the points' CRS: reprojected from EPSG:4326 when its coordinates look +like lon/lat, otherwise stamped, with a warning either way. The same +goes for \code{prediction_points} and \code{blocks}.} + +\item{buffer}{For \code{"buffered_loo"}: a single positive number, the +distance within which the held-out point's neighbours are excluded from +its training set. Like \code{block_size} it is in the units of the CRS +the folds are built in (\code{params$crs}), which for geographic +(lon/lat) input is the metre CRS \code{\link{ensure_projected}()} +chooses: 0.1 means 0.1 m, not 0.1 degrees. A buffer that excludes no +neighbour from any fold makes the scheme plain leave-one-out, and is +warned about.} \item{min_train}{For \code{method = "nndm"}: the smallest fraction of the data any fold's training set may be reduced to by neighbour exclusion. -Default \code{0.5}, as in \code{CAST::nndm()}.} +Default \code{0.5}, as in \code{CAST::nndm()}. Where it binds, the +distance matching stops short and the cross-validation stays optimistic; +see \strong{Details}.} \item{phi}{For \code{method = "nndm"}: the distance up to which the two nearest-neighbour distance distributions are matched, in the CRS the -folds are built in; the exclusion never pushes a held-out point's -nearest neighbour beyond it. In Mila et al. (2022), and in +folds are built in. Matching is attempted only while a held-out +point's nearest-neighbour distance is at most \code{phi}; the exclusion +that takes it past \code{phi} is the last one, so a realised distance +can exceed \code{phi} by up to one neighbour step, as in +\code{CAST::nndm()}. In Mila et al. (2022), and in \code{CAST::nndm()}, \eqn{\phi} is the autocorrelation range of the outcome: beyond it observations are effectively independent, so matching is unnecessary. \code{\link{estimate_sac_range}()} gives such a value. Default \code{NULL} = the largest prediction-to-training distance, which matches everywhere (\code{CAST}'s \code{phi = "max"}).} -\item{drop_empty_blocks}{Logical. Default TRUE.} +\item{drop_empty_blocks}{Logical. Default TRUE. With \code{FALSE} the +blocks that hold no point are kept and packed into folds too, but +\code{k} is still lowered to the number of blocks that hold points, so +no fold is left without test points.} \item{blocks}{Optional polygon layer (\code{sf} or \code{sfc}, POLYGON or MULTIPOLYGON, at least two features) to use as the blocks of @@ -198,6 +242,9 @@ the full \code{grid_nx} by \code{grid_ny} grid, or the row of the \code{blocks[params$blocks$source_row, ]} recovers them with their own columns and in their own order. It runs from 1 to \code{params$n_blocks} and is the identity when nothing was dropped. +For a grid \code{params$n_blocks} is \code{grid_nx * grid_ny}, the +cells a \code{boundary} clips away included, and +\code{params$blocks_used} is the number of blocks returned. \code{params$block_sizes} is the number of points in each block, indexed by \code{block_id} (zeros are empty blocks that \code{drop_empty_blocks = FALSE} kept), and \code{params$fold_blocks} @@ -210,12 +257,12 @@ it is made of, a fold can be seen to be one contiguous region or several, and the blocks can be drawn over the data (\code{\link{plot_folds}()} does so). -For the methods that work in projected space (\code{"block_kfold"}, -\code{"buffered_loo"} and \code{"nndm"}), \code{params} carries a +For \code{"block_kfold"}, \code{params} carries a \code{params$blocks_supplied} that says whether the blocks came from \code{blocks} or from a grid built here, and -\code{params$boundary_supplied} whether a \code{boundary} was given; -\code{params$row_probe} is a small sample of row IDs and coordinates +\code{params$boundary_supplied} whether a \code{boundary} was given. +Every method's \code{params} carries +\code{params$row_probe}, a small sample of row IDs and coordinates that every \code{cv_*()} compares against the data it is handed, so folds built from a different layer of the same size are refused, never applied silently. @@ -233,8 +280,9 @@ 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 -buffered leave-one-out strategies. +Builds train/test splits by random k-fold, spatial block k-fold, +leave-location-out, buffered leave-one-out or nearest-neighbour distance +matching (NNDM) leave-one-out. } \details{ For \code{block_kfold}, the default grid sizing is purely geometric and @@ -260,22 +308,47 @@ buffer, so that the resulting training-to-test distance distribution approaches the distribution of distances from your actual prediction locations to the training data. -The procedure is the paper's own (as in \code{CAST::nndm()}), and it is -deterministic. Let \eqn{G_{ij}} be the empirical distribution of +The procedure is the paper's, and it is deterministic. Let \eqn{G_{ij}} +be the empirical distribution of prediction-to-nearest-training distances and \eqn{G_j^*} the distribution of each held-out point's nearest remaining training point. Starting from plain leave-one-out, the point with the smallest \eqn{G_j^*} at which the realised distribution exceeds the target (\eqn{G_j^*(r) > G_{ij}(r)}) has its nearest training neighbour removed, and this repeats until no such -point remains, subject to two limits: a point's nearest-neighbour distance -is never pushed beyond \code{phi} (default: the largest prediction distance, -since a training point already further than every prediction distance has -nothing to match), and no fold's training set is stripped below +point remains, subject to two limits: a point is matched only while its +nearest-neighbour distance is at most \code{phi} (default: the largest +prediction distance, since a training point already further than every +prediction distance has nothing to match), so the exclusion that takes it +past \code{phi} is its last and a realised distance can exceed \code{phi} +by up to one neighbour step; and no fold's training set is stripped below \code{min_train} of the data. -The realised distribution is then never \emph{more optimistic} than the -target: \eqn{G_j^*(r) \le G_{ij}(r)} up to the granularity of the -neighbour distances, which is the property the method exists to deliver. +It differs from \code{CAST::nndm()} in two details, so the folds agree +closely with CAST's but not exactly. The removal rule is strict: a +neighbour is removed whenever the realised distribution exceeds the target, +whereas CAST removes one only while the realised distribution, less the +point about to move, is still at or above the target. The rule here +therefore removes up to one point more per distance value (a few percent +more removals in all on clustered layouts), erring on the pessimistic side. +And ties in \eqn{G_j^*} are broken by the points' coordinates, not by +their row index as in CAST, so the folds do not depend on the order of the +rows. + +Where neither limit binds, the realised distribution is then never +\emph{more optimistic} than the target: \eqn{G_j^*(r) \le G_{ij}(r)} up to +the granularity of the neighbour distances, which is the property the +method exists to deliver. Beyond \code{phi} no matching is attempted, by +design. \code{min_train} is different: when the prediction locations lie +further from the samples than a fold can be made to hold out (clustered +samples and a prediction domain well beyond them, the layout NNDM is meant +for), it stops the matching early and the realised distances stay +optimistic. \code{params$n_at_min_train} counts the folds that were held +at the floor while still closer than the target allows, and +\code{make_folds()} warns when that leaves more than one point's worth of +excess at or below \code{phi}. Lower \code{min_train} to match further, or +read the cross-validated score as an upper bound on performance at the +prediction locations. + An earlier version of this package drew one random radius per point from \eqn{G_{ij}} and excluded up to the order statistic \emph{closest} to it, which rounds down half the time: on a two-cluster layout the realised diff --git a/man/model_metrics.Rd b/man/model_metrics.Rd index 10205af..e75dbf8 100644 --- a/man/model_metrics.Rd +++ b/man/model_metrics.Rd @@ -50,10 +50,23 @@ 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}, but \strong{out-of-bag} for an \code{rf_fit}, whose \code{fitted()} method returns out-of-bag predictions (see \code{\link{fit_rf_model}}). The -returned data.frame carries no label distinguishing the two, so check -\code{object$info$fitted_are_oob} before comparing numbers across backends, -or use \code{\link{compare_models_cv}}, which scores every backend the -same way. +data.frame \code{model_metrics()} returns carries no label distinguishing +the two, so check \code{object$info$fitted_are_oob} before comparing +numbers across backends; \code{\link{evaluate_insample}()} and +\code{\link{compare_models}()} record it per model in a +\code{metric_basis} column. \code{\link{compare_models_cv}} scores every +backend the same way. + +\eqn{R^2} is \eqn{1 - RSS/TSS} with the total sum of squares taken about +the mean of the response the model was \emph{fitted} to. In sample that +is the ordinary \eqn{R^2}. With \code{newdata} it is out-of-sample +\eqn{R^2}, the convention every \code{cv_*()} function uses: the model is +measured against the prediction it had to beat, the training mean, not +against the new rows' own mean, which it could not have known. It is +below 0 when the model predicts the new rows worse than the training mean +does, and it is \code{NA} when the response does not vary about that +baseline by more than rounding error (100 machine epsilons of its +magnitude, whatever its units). } \section{Percentage errors on responses with zeros}{ @@ -62,6 +75,9 @@ same way. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is @@ -97,8 +113,11 @@ be read as a rough summary rather than a score. For the Bayesian backend, \code{\link{cv_bayes}()} additionally reports CRPS and interval coverage at 50, 80 and 95 percent. Both are proper scoring rules computed from posterior draws, so they are meaningful for any -\code{family} the backend accepts, and they are the numbers to compare when -the response is not Gaussian. When every fold fails, the +\code{family} that predicts one number per row (a count, a rate, a binary +or bounded outcome), and they are the numbers to compare when the response +is not Gaussian. A categorical or ordinal family predicts a probability +per response category instead, so \code{cv_bayes()} refuses one before +fitting anything. When every fold fails, the \code{fold_metrics} frame \code{cv_bayes()} returns carries the CRPS column but not the \code{coverage_*} columns, so code that reads those columns must tolerate their absence. diff --git a/man/plot.aoa.Rd b/man/plot.aoa.Rd index 65fa3b2..2972cef 100644 --- a/man/plot.aoa.Rd +++ b/man/plot.aoa.Rd @@ -23,12 +23,20 @@ A \code{ggplot} object. of applicability; it does not say whether the rest sit comfortably inside or crowd against the threshold, nor how far outside the outsiders are. This draws the dissimilarity index of the prediction locations against -that of the cross-validated training data, with the threshold marked, so -the prediction set can be read as mostly inside, marginal or largely -outside. The training curve is the reference the threshold was derived -from: the threshold is the largest cross-validated training DI inside an -outlier fence, so the curve reaches it exactly when no training value was -fenced off and runs past it, by the tail the fence removed, when some were. +that of the training data, with the threshold marked, so the prediction +set can be read as mostly inside, marginal or largely outside. The +training DI is cross-validated over the \code{folds} passed to +\code{\link{area_of_applicability}()}, or without them is each training +point's distance to its nearest other training point; the legend and the +caption say which. The training curve is the reference the threshold was +derived from: the threshold is the largest training DI inside an outlier +fence, so the curve reaches it exactly when no training value was fenced +off and runs past it, by the tail the fence removed, when some were. +A prediction location outside on a predictor dropped for having no +training variance has \code{DI = Inf}: it counts in the prediction curve, +which then tops out below 1, and the caption says how many are off the +axis. A location with a missing predictor (\code{DI = NA}) is neither +inside nor outside; it is left out of the curve and the caption counts it. } \examples{ if (requireNamespace("ggplot2", quietly = TRUE)) { diff --git a/man/plot.block_size_sweep.Rd b/man/plot.block_size_sweep.Rd index bce3ee9..34d4fa6 100644 --- a/man/plot.block_size_sweep.Rd +++ b/man/plot.block_size_sweep.Rd @@ -20,7 +20,11 @@ each block size, the fold-to-fold range as a band, the random-fold reference as a dashed line, and the estimated autocorrelation range as a vertical marker. Blocks smaller than the range leak, so the curve rises from the reference towards the range and plateaus beyond it; the height -of the rise is what the random-fold number overstated. +of the rise is what the random-fold number overstated. The caption says +which way is better: higher for \code{R2} and \code{Adj_R2}, closer to +the nominal level for a \code{coverage_*} column (0.975 for +\code{coverage_97.5}), since over-coverage is miscalibration too, and +lower for everything else. } \examples{ if (requireNamespace("ranger", quietly = TRUE) && diff --git a/man/plot.feature_selection.Rd b/man/plot.feature_selection.Rd index 5672d33..80b3df8 100644 --- a/man/plot.feature_selection.Rd +++ b/man/plot.feature_selection.Rd @@ -19,7 +19,10 @@ A \code{ggplot} object. step and keeps the best; its \code{history} holds all of them. This draws the accepted variable's score at each step as the path, every other candidate's score at that step as a faint point, and the step at which the -selection stopped in red. The picture then says whether the last variable +selection stopped in red. When it stopped because no candidate cleared +\code{tol}, the path runs one step further to the best of the rejected +candidates, drawn hollow and labelled "not added", so the stop reads as a +flattening rather than a cut. The picture then says whether the last variable was a clear gain or the first that happened to clear \code{tol}, and whether the runner-up would have done as well. The scores are the selection's own cross-validated criterion, optimistically biased by the diff --git a/man/plot.resolution_profile.Rd b/man/plot.resolution_profile.Rd index 596bd67..ae641ab 100644 --- a/man/plot.resolution_profile.Rd +++ b/man/plot.resolution_profile.Rd @@ -40,14 +40,15 @@ if (requireNamespace("gstat", quietly = TRUE) && library(sf) # The same field as ?resolution_profile: an exponential covariance with # range parameter 200 and a nugget of 0.6 on a unit sill. - set.seed(2) + set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$z <- as.numeric(t(chol(exp(-D / 200) + diag(0.6, n))) \%*\% rnorm(n)) pts <- st_as_sf(xy, coords = c("x", "y"), crs = 32632) prof <- resolution_profile(pts, response_var = "z", n_levels = 12) - print(plot(prof)) # all four criteria, one panel each + print(plot(prof)) # one panel per criterion it scored: no + # elbow on these uniform points plot(prof, criteria = c("cp", "wss")) # Cp beside the raw WSS curve } } diff --git a/man/plot.spatial_fit.Rd b/man/plot.spatial_fit.Rd index 3fa8d3e..a5a3647 100644 --- a/man/plot.spatial_fit.Rd +++ b/man/plot.spatial_fit.Rd @@ -14,7 +14,11 @@ ) } \arguments{ -\item{x}{A \code{spatial_fit}.} +\item{x}{A \code{spatial_fit}. The residuals drawn are +\code{residuals(x)}; for a custom subclass with no \code{residuals()} +method (optional, see \code{\link{new_spatial_fit}()}) they are the +response minus \code{fitted(x)}, which is what the built-in backends' +methods return.} \item{type}{One of: \describe{ @@ -30,10 +34,12 @@ response itself on the same points and lags, drawn hollow with a dashed fit. The gap between the two curves is the spatial structure the model absorbed: a residual sill well below the response sill means most of it, two curves that coincide mean none. When both -effective ranges were identified the caption gives the residual sill -as a share of the response sill and the two ranges; when either -variogram reached no sill the caption says so and compares nothing, -because a sill the data never reached is not a number to divide by. +effective ranges were identified over the same point pairs the caption +gives the residual sill as a share of the response sill and the two +ranges; when either variogram has no identified range, or the two are +not over the same pairs, the caption says so and compares nothing: a sill the +data never reached is not a number to divide by, and one direction's +sill is not comparable with all directions'. The residual range is expected to come out shorter and the residual sill lower even when the model is right, because residuals of a fitted trend understate the variogram (see @@ -41,16 +47,24 @@ fitted trend understate the variogram (see residual-variogram bias"). The distance axis is labelled in the units of the CRS the variogram was actually fitted in, which is not necessarily the fit's own CRS -(lon/lat data are projected first). A single-direction fit names its -azimuth in the title; a fit that identified no range says why in the -subtitle, since the overlaid model line is then not a fit to believe. +(lon/lat data are projected first). Each curve is the variogram +\code{estimate_sac_range()} returns for its variable: all point pairs, +or, when the all-pairs fit was unusable, the widest of four directions, +which is named with its azimuth (in the title for the residuals, in the +caption for the response). A fit that identified no range says why in +the subtitle, since the overlaid model line is then not a fit to believe. Requires 'gstat'.} \item{\code{"coefficients"}}{For a GWR fit only: the local coefficient of one \code{term} mapped at the training locations, which is the reason to fit GWR at all. Locations where the local design is -collinear (the kernel-weighted window's scaled condition index is -above 30, or the window is singular) are drawn hollow and grey -(\code{mask = TRUE}), because the smooth surface a naive map draws +collinear for that term are drawn hollow and grey +(\code{mask = TRUE}): for a slope, where the kernel-weighted +window's slope condition index (\code{cn_slopes}, predictors +centred in the window) is above 30 or the window is singular, or +where the index with the intercept (\code{cn}) is above 1e6; for +the Intercept, where \code{cn} is above 30 (a predictor far from 0 +against its local spread makes the local intercept an +extrapolation). They are masked because the smooth surface a naive map draws over them is the picture of an unstable estimate, not of a relationship; the subtitle counts them. The condition indices are the fit's \code{info$local_collinearity}, computed for every @@ -68,8 +82,8 @@ map, one of the names \code{coef(x)} returns. Default \code{NULL}: the first predictor. Ignored by the other types.} \item{mask}{For \code{type = "coefficients"}: whether to draw locations -whose local design is collinear (scaled condition index of the -kernel-weighted window above 30, or singular) as hollow grey points +whose local design is collinear for that term (see +\code{type = "coefficients"}) as hollow grey points instead of colouring them by a coefficient that is not to be believed there. Default \code{TRUE}. Locations whose coefficient is non-finite are masked either way.} diff --git a/man/plot_calibration.Rd b/man/plot_calibration.Rd index 12cd7e0..fb67c31 100644 --- a/man/plot_calibration.Rd +++ b/man/plot_calibration.Rd @@ -26,8 +26,9 @@ with the diagonal, one point per level for the fold-weighted pooled value systematic over-confidence (points below the line) or intervals wider than they need to be (above it) are read at a glance. Three levels is a thin curve; pass \code{coverage_levels = seq(0.1, 0.9, by = 0.1)} to -\code{cv_bayes()} for a full one. The levels are read off the column -names, so whatever was computed is drawn. +\code{cv_bayes()} for a full one. Each level is drawn at the nominal value +\code{cv_bayes()} records in \code{coverage_levels}, so whatever was +computed is drawn where it belongs (0.975 at 0.975, not rounded). } \examples{ \dontrun{ diff --git a/man/plot_cv_metrics.Rd b/man/plot_cv_metrics.Rd index 2944152..82b4b26 100644 --- a/man/plot_cv_metrics.Rd +++ b/man/plot_cv_metrics.Rd @@ -40,7 +40,11 @@ refused with a message saying why rather than drawn as an empty panel: \code{overall} when it carries the metric, from \code{predictive_coverage} for \code{cv_bayes()}'s coverage and CRPS columns, and not at all for a per-fold extra that has no pooled -counterpart (a bandwidth), in which case the caption says so. +counterpart (a bandwidth) or for a count (\code{n_pred}, +\code{n_MAPE}, \code{n_SMAPE}), whose \code{overall} value is the +total over the folds; the caption says which. A model with no finite +per-fold value gets no panel and no pooled line, and the caption +names it. } \examples{ if (requireNamespace("ranger", quietly = TRUE) && diff --git a/man/plot_tessellation_map.Rd b/man/plot_tessellation_map.Rd index 4bb4503..03254db 100644 --- a/man/plot_tessellation_map.Rd +++ b/man/plot_tessellation_map.Rd @@ -22,7 +22,7 @@ plot_tessellation_map( boundary_col = "#111111", boundary_size = 0.6, labels = FALSE, - label_col = "grid_id", + label_col = NULL, label_size = 2.7, legend = TRUE, legend_title = NULL, @@ -46,7 +46,11 @@ plot_tessellation_map( \item{features_sf}{Optional sf/sfc layer of additional features.} \item{fill_col}{Name of the COLUMN in \code{tessellation_sf} to map to fill; -\code{NULL} for no fill. \code{fill_col} and \code{label_col} name +\code{NULL} for no fill. A numeric column gets a continuous scale, as +does a Date or POSIXct column (on a date or time axis) and a +\code{units} or \code{difftime} column (drawn as numbers, with the unit +in the legend title); anything else a discrete one. +\code{fill_col} and \code{label_col} name columns, while \code{outline_col}, \code{features_col}, \code{seeds_col} and \code{boundary_col} are colours.} @@ -69,8 +73,13 @@ outline.} \item{labels}{Logical; draw per-cell labels. Default FALSE.} -\item{label_col}{Name of the COLUMN holding the label text. Default -\code{"grid_id"}.} +\item{label_col}{Name of the COLUMN holding the label text. Default +\code{NULL}: the first of \code{"grid_id"}, \code{"cell_id"}, +\code{"poly_id"}, \code{"polygon_id"} and \code{"id"} the layer has, so +the cells of \code{\link{build_tessellation}()} (\code{cell_id}) and the +output of \code{\link{summarize_by_cell}()} (\code{poly_id}) are +labelled without naming one. A \code{units} or \code{difftime} column +is drawn formatted, with its unit.} \item{label_size}{Label text size. Default 2.7.} diff --git a/man/predict.bayesian_fit.Rd b/man/predict.bayesian_fit.Rd index f144209..4a5105a 100644 --- a/man/predict.bayesian_fit.Rd +++ b/man/predict.bayesian_fit.Rd @@ -32,9 +32,18 @@ point summary. Default FALSE.} } \value{ Numeric vector of length \code{nrow(newdata)}, or a -\code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE} (a 1-row -all-\code{NA} matrix if the posterior draw fails). With -\code{newdata = NULL} the cached \code{fitted()} values are returned only +\code{n_draws x nrow(newdata)} matrix when \code{draws = TRUE}. If the +posterior draw fails the result is all \code{NA} (a 1-row matrix for +\code{draws = TRUE}) and the cause is logged. An ordinal or categorical +family is not a failed draw and is an error under +\code{type = "epred"}: its expected value is a probability per response +category, not one number per row. Use \code{type = "predict", +draws = TRUE} for posterior draws of the predicted category, as category +indices; the share of draws in each category estimates its probability. +Without \code{draws = TRUE}, \code{type = "predict"} returns the mean (or +median) category index, an expected rank for an ordinal family and an +error for \code{brms::categorical()}, whose categories have no order. +With \code{newdata = NULL} the cached \code{fitted()} values are returned only for the default \code{summary = "mean"}, \code{type = "epred"}, \code{draws = FALSE} combination; any other combination is recomputed against the training data, because the cache holds epred column means and @@ -48,23 +57,31 @@ missing or non-finite values are dropped. Coordinate scaling and predictor standardisation stored at fit time are then applied before delegating to \code{brms::posterior_epred()} or \code{brms::posterior_predict()}. } -\section{The GP boundary is pinned}{ +\section{The GP boundary is held at its fitted value}{ -brms 2.x does not store the Hilbert-space boundary \eqn{L} in a fitted GP -basis, so \code{brms:::.data_gp()} recomputes it from whatever rows -\code{predict()} is handed, which moved every eigenfunction of the +brms 2.17 to 2.22 do not store the Hilbert-space boundary \eqn{L} in a +fitted GP basis, so \code{brms:::.data_gp()} recomputes it from whatever +rows \code{predict()} is handed, which moved every eigenfunction of the approximation with the newdata bounding box while the fitted basis coefficients stayed put. Two synthetic rows at the training coordinate -extrema are therefore appended before the posterior draw and dropped from the -result, reproducing the boundary the model was fitted with, so chunked, -fold-wise and single-call predictions agree. +extrema are therefore appended before the posterior draw and dropped from +the result, and when \code{newdata} reaches past the training range the +\code{c} of the \code{gp()} term is scaled down by as much as the range +grew, so brms rebuilds exactly the boundary the model was fitted with. A +prediction therefore does not depend on which other rows share the call: +chunked, fold-wise and single-call predictions agree, and +\code{\link{predict_surface}()} does not depend on \code{chunk_size}. +brms 2.23.0 and later store \eqn{L} and reuse it, so there \code{c} is left +alone and the two extra rows change nothing. -That is exact only for \code{newdata} \strong{inside} the training -coordinate envelope. Beyond it the boundary has to grow whatever is done, so -predictions there are extrapolation from a basis that was not built for them -\emph{and} depend on which other rows share the call, including on -\code{\link{predict_surface}()}'s \code{chunk_size}. A notice is written to -the log (not raised as a warning) when it happens. +Predictions outside the training coordinate envelope are extrapolation (a +notice is written to the log). A row further than \eqn{L} from the centre +of the training coordinates on either axis is past the edge of the basis, +where the approximate GP is an odd reflection of the fitted surface rather +than an estimate of anything, so it is returned as \code{NA} (a column of +\code{NA} with \code{draws = TRUE}) with a warning. The default boundary +factor puts that edge well outside the training data, so only +\code{newdata} reaching far past it is affected. } \seealso{ diff --git a/man/predict.gwr_fit.Rd b/man/predict.gwr_fit.Rd index 8504a14..9008481 100644 --- a/man/predict.gwr_fit.Rd +++ b/man/predict.gwr_fit.Rd @@ -17,14 +17,24 @@ is supported). NULL = fitted values.} } \value{ Numeric vector aligned to \code{nrow(newdata)}, with \code{NA} for -rows dropped as missing or non-finite. If \code{GWmodel::gwr.predict()} -fails, every value is \code{NA} and a warning says why. CRS-less +rows dropped as missing or non-finite, and for locations whose local +regression cannot be estimated (too few training points within a fixed +bandwidth, or a singular local design); a warning counts those. If the +design matrix for \code{newdata} cannot be built, every value is +\code{NA} and a warning says why. CRS-less \code{newdata} first receives the interpretation the training data got, so the same rows land where they did at fit time. } \description{ When \code{newdata} is NULL, returns the in-sample fitted values. -Otherwise uses \code{GWmodel::gwr.predict()} on the new locations. +Otherwise estimates the local coefficients at each new location with +\code{GWmodel::gwr.basic(regression.points = )}, with the fit's kernel and +bandwidth (an adaptive bandwidth counts neighbours among the training +points), and returns \eqn{x^\top\hat\beta(u)}{x'beta(u)}. These are the +values \code{GWmodel::gwr.predict()} returns, without its prediction +variance, which this method never returned and which costs time cubic in +the number of training points. Each location stands alone: one that cannot +be estimated does not affect the others. \code{newdata} is first transformed to the CRS used during fitting (via \code{ensure_projected()}), so predictions are computed in a single coordinate system regardless of the CRS newdata arrives in. diff --git a/man/predict.rf_fit.Rd b/man/predict.rf_fit.Rd index c60f19a..85ee58f 100644 --- a/man/predict.rf_fit.Rd +++ b/man/predict.rf_fit.Rd @@ -28,7 +28,11 @@ as 0/1, so either form is accepted for one.)} \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{seed} defaults to a constant: an unset \code{seed} makes +those. So is anything \code{ranger}'s predict method itself refuses, +such as \code{type = "quantiles"} on a forest grown without +\code{quantreg = TRUE} or \code{type = "se"} without +\code{keep.inbag = TRUE}: the error names ranger's reason. +\code{seed} defaults to a constant: 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 @@ -37,7 +41,9 @@ predictions; pass your own if you need one.} } \value{ Numeric vector, aligned to \code{nrow(newdata)} with \code{NA} for -rows dropped as incomplete. +rows dropped as incomplete (so all \code{NA}, with a WARN line in the +log, when every row is). A failure inside \code{ranger}'s predict +method is an error, not an all-\code{NA} vector. } \description{ With \code{newdata = NULL} this returns \strong{out-of-bag} predictions, not diff --git a/man/predict_surface.Rd b/man/predict_surface.Rd index 75c7b41..5b7ba9f 100644 --- a/man/predict_surface.Rd +++ b/man/predict_surface.Rd @@ -26,13 +26,23 @@ at least one row. It is brought into the fit's CRS first: a CRS-less grid is given the interpretation the training data got (the assumption recorded on the fit), with a warning, and then reprojected. Otherwise a CRS-less grid can land thousands of kilometres from the covariates and every cell -takes the same nearest feature.} +takes the same nearest feature. A grid still without a CRS after that +is treated as \code{boundary} is: taken as EPSG:4326 and reprojected +when its coordinates look like lon/lat, otherwise stamped with the fit's +CRS, with a warning either way. A grid of polygons +(\code{\link{create_grid_polygons}()} output, say) is reduced to one +representative point per cell, as \code{\link{coerce_to_points}()} does, +so covariates are taken at the location predicted for; \code{boundary} +then keeps the cells whose point falls inside it.} \item{cell_size}{Grid resolution in CRS units. Ignored when \code{grid} is supplied; when \code{NULL}, derived from \code{n_cells}. A value that would produce more than 5,000,000 cells is refused, naming the implied -count and the CRS units. The usual cause is a value in the wrong unit. A -\code{cell_size} wider than the extent yields a single centred cell.} +count and the CRS units. The usual cause is a value in the wrong unit. +The grid is centred on the training bounding box and covers it: when the +extent is not a whole number of cells, it overhangs the box by less than +one cell, split evenly between the two sides. A \code{cell_size} wider +than the extent yields a single centred cell.} \item{n_cells}{Approximate cell count used to derive \code{cell_size}. Default 10000. Must be a single positive finite number and at most @@ -41,27 +51,39 @@ supplied. The grid you pass is used verbatim.} \item{boundary}{Optional polygonal \code{sf}/\code{sfc}; grid points outside it are dropped. Put through the same CRS replay and reprojection as -\code{grid}.} +\code{grid}. One still without a CRS after the replay is taken as +EPSG:4326 and reprojected when its coordinates look like lon/lat, and +is otherwise stamped with the fit's CRS, with a warning either way.} \item{covariates}{Optional \code{sf} layer carrying the model's predictors. Required when the model has predictors and \code{grid} does not already -contain them. Values are taken from the nearest feature.} +contain them. Values are taken from the nearest feature. Aligned to +the fit's CRS as \code{grid} is, with the same warning when it has no +CRS.} \item{chunk_size}{Rows per prediction call. Default 5000. A pure -performance knob for the GWR and random-forest backends, whose rows do not -interact. For a \code{bayesian_fit} it is also that, \emph{provided} the -grid stays inside the training extent. Beyond it the GP boundary has to -grow and predictions depend on which rows share the call; see +performance knob: rows do not interact, and for a \code{bayesian_fit} the +GP boundary is held at its fitted value whatever the chunk holds; see \code{\link{predict.bayesian_fit}}.} \item{se}{Logical; also return a standard-error/posterior-SD column where the -backend supports it. Default FALSE.} +backend supports it. Default FALSE. For a \code{bayesian_fit} this is +the SD of the posterior draws \code{predict()} returns, and those are of +the expected value by default (\code{type = "epred"}): the uncertainty +of the mean surface, not of a new observation, which also carries the +observation noise. For the predictive SD, the one that goes with +prediction intervals and \code{cv_bayes()}'s calibration, pass +\code{type = "predict"} as well.} -\item{...}{Passed to \code{predict()}.} +\item{...}{Passed to \code{predict()}, e.g. \code{type = "predict"} for a +\code{bayesian_fit}. Not \code{draws}, which this function sets itself +and refuses here.} } \value{ An \code{sf} POINT layer with a \code{.pred} column (and -\code{.pred_se} when \code{se = TRUE} and available). For an +\code{.pred_se} when \code{se = TRUE} and available; one a supplied +\code{grid} already carried, from an earlier surface, is removed +otherwise). For an auto-generated grid the resolution is attached as attribute \code{"cell_size"}. For a user-supplied \code{grid} it is only whatever \code{"cell_size"} attribute that object already carried. That is usually diff --git a/man/prep_model_data.Rd b/man/prep_model_data.Rd index 688e4bb..635c547 100644 --- a/man/prep_model_data.Rd +++ b/man/prep_model_data.Rd @@ -36,20 +36,27 @@ required to be present (useful for out-of-sample prediction where the response is unknown). Default TRUE.} } \value{ -An sf object with POINT geometry, cleaned of rows carrying missing -or non-finite values in the modelling columns or in the coordinates. What +An sf object with 2-D (XY) POINT geometry, cleaned of rows +carrying missing or non-finite values in the modelling columns or in the +coordinates. What was removed is recorded on the attribute \code{"dropped"}, a list with \code{n} (rows dropped), \code{n_geometry} (how many of them for an empty or non-finite geometry), \code{which} (their positions in \code{data_sf}), \code{row_id} (their \code{..row_id} values when the layer carries that column, else \code{NULL}) and \code{reason} (one per dropped row: \code{"geometry"}, \code{"missing"} or -\code{"non_finite"}, in that order of precedence when several apply). +\code{"non_finite"}, in that order of precedence when several apply), +plus \code{n_rows}, the number of rows returned, which the record was +made for. Every fit stores \code{n} as \code{$info$n_dropped}. The record describes the rows this call returned and does not survive subsetting: -\code{clean[i, ]} is a plain layer with no \code{"dropped"} attribute, -and a fit given such a subset with \code{.already_prepped = TRUE} reports -\code{n_dropped = 0} even when the parent layer dropped rows. The CRS is +\code{clean[i, ]}, like \code{dplyr::filter()}, \code{slice()} or +\code{arrange()} of it, is a plain layer with no \code{"dropped"} +attribute, and a fit given such a subset with \code{.already_prepped = +TRUE} reports \code{n_dropped = 0} even when the parent layer dropped +rows. \code{sf::st_drop_geometry()} keeps the record, since the rows are +the same; see \code{\link{[.spatialkit_rows}} for what binding such data +frames does. The CRS is projected whenever one can be established. A CRS-less layer is decided by the lon/lat heuristic (see \code{\link{ensure_projected}}): if its bounding box fits the lon/lat envelope \emph{and} it either spans more than one unit @@ -66,6 +73,8 @@ geometry is empty or whose coordinates are not finite, which no model backend can use. All non-POINT geometries (including MULTIPOINT) are coerced to representative points via \code{coerce_to_points()}, so downstream coordinate extraction always aligns one row per observation. +Any Z or M coordinate (POINT Z from a GPS, a GeoPackage or KML) is +dropped, because every backend works in 2-D map distance. } \details{ The response may not appear in \code{predictor_vars}. Using it as its own diff --git a/man/print.sac_range.Rd b/man/print.sac_range.Rd index 4e1dc27..77b48d6 100644 --- a/man/print.sac_range.Rd +++ b/man/print.sac_range.Rd @@ -19,7 +19,12 @@ Prints the effective range as a plain number, with the directional fit summarised beneath it when one is available. A direction whose fit was unusable is labelled with why (\code{directional_status}) and the range its fit reported (\code{directional_fitted}) when the object carries -them, and \code{unidentified} otherwise. +them, and \code{unidentified} otherwise. A last line names the unit and +the CRS the range is a length in (\code{attr(x, "crs")}, which for +lon/lat input is the projected CRS the estimate chose; for a layer with +no CRS, it says the range is in that layer's own coordinate units), and +whether the variogram is of the response or of its residuals on +\code{predictor_vars} (\code{detrended}, \code{detrend_method}). } \seealso{ Other print methods: diff --git a/man/residual_morans_i.Rd b/man/residual_morans_i.Rd index 81f6a36..02d0520 100644 --- a/man/residual_morans_i.Rd +++ b/man/residual_morans_i.Rd @@ -52,8 +52,9 @@ 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.} +cannot be rebuilt, and logs a warning (but proceeds) if the residuals +are not the OLS residuals on it, in which case the moments are +approximate.} } Both \code{"auto"} and \code{"residual"} also fall back to \code{"randomisation"} when the residual degrees of freedom @@ -119,8 +120,15 @@ The list is classed \code{"morans_i"} and has a \code{print()} method, so the console shows the statistic and its null without printing the \eqn{n \times n} \code{weights} matrix; \code{[} drops the class, and \code{$}, \code{[[} and \code{unlist()} are unaffected. -Returns \code{NULL} with a warning if computation fails (e.g. fewer -than 4 valid residuals). +A custom fit whose class has no \code{residuals()} method (which +\code{\link{new_spatial_fit}} calls optional) is scored on the +observed response minus \code{fitted()}, as \code{plot()} does for it. +Returns \code{NULL} with a warning if computation fails, saying why: +\code{residuals()} raised an error (its message is quoted), or returned +\code{NULL} and the response minus \code{fitted()} could not be +formed either (the reason is quoted), fewer than 4 valid +residuals, or a residual vector whose length does not match the fit's +\code{data_sf}. } \description{ Given a \code{spatial_fit} object, extracts the residuals and the diff --git a/man/resolution_profile.Rd b/man/resolution_profile.Rd index afa72ab..39fb6f5 100644 --- a/man/resolution_profile.Rd +++ b/man/resolution_profile.Rd @@ -15,16 +15,21 @@ resolution_profile( nstart = 25L, seed = 123L, sac = NULL, - select_on = c("all", "split") + select_on = c("all", "split"), + range_floor = TRUE ) } \arguments{ \item{data_sf}{An sf object of points (other geometries are reduced to -representative points).} +representative points). Features with empty or non-finite coordinates +are dropped with a warning.} \item{response_var}{Optional response column name (numeric or logical). Enables \code{cp} and \code{moran_z}. A variogram estimated from it also -sets the floor of the ladder and \code{reliability}.} +sets the floor of the ladder and \code{reliability}. Rows where it, or a +predictor, is missing or non-finite stay in the geometry and are left out +of the OLS fit, the RSS, \code{cp} and \code{moran_z}; a logged warning +gives their number.} \item{predictor_vars}{Optional predictor column names (numeric or logical). With them, \code{cp} scores the OLS residuals of the response @@ -32,52 +37,94 @@ on the predictors, the variogram is estimated from those residuals, and \code{moran_z} regresses the cell means on the cell-mean predictors.} \item{levels}{Optional integer vector of level counts to score, replacing -the ladder; values below 2, or at or above the number of distinct -locations, are dropped (k-means cannot place more centres than there are -distinct points).} +the ladder; values below 2, above the number of distinct locations, or +at or above the number of points, are dropped (k-means cannot place more +centres than there are distinct points, and \code{stats::kmeans()} +refuses as many centres as points).} \item{n_levels}{Number of levels on the ladder. Default 20.} \item{min_cell_n}{Minimum average number of points per cell that a level must keep; sets the ceiling. Default 9.} -\item{sample_n}{Points are subsampled to this many before anything is -fitted, as in \code{determine_optimal_levels()}. Default 1500. The -support columns describe the subsample.} +\item{sample_n}{Points are subsampled to this many before the k-means +fits, as in \code{determine_optimal_levels()}. Default 1500. The +columns read off the fitted cells (\code{wss}, the \code{cell_} columns, +\code{rss}, \code{moran_i}, \code{moran_z}) describe the subsample; the +bounds, \code{supported}, the variance term of \code{cp} and +\code{reliability} describe every point of the layer, so the answer does +not change with \code{sample_n} except through the fits.} \item{nstart}{k-means++ restarts per level. Default 25.} \item{seed}{RNG seed for the subsample and the restarts; restored -afterwards. Default 123.} +afterwards. Default 123. The rows are put in coordinate order before +either, so the profile does not depend on the order they come in.} \item{sac}{Optional \code{sac_range} object from \code{\link{estimate_sac_range}()} to take the range, nugget and correlation function from. Pass one fitted with \code{detrend = - "reml"}, say, or on a residual field of your choosing. When + "reml"}, say. It must describe the variable the profile scores: the +raw response without \code{predictor_vars}, the residuals on them with; +a sac whose \code{detrended} attribute says otherwise is used with a +warning. Its range is read in its own CRS (\code{attr(sac, "crs")}), +to which the points are transformed first, so the area, the floor and +\code{cell_diam_median} are then in that CRS's units. A sac whose +range was rejected (\code{NA} with a \code{rejected_reason}) gives +\code{cp} its nugget, with a warning, and leaves \code{reliability} +\code{NA}, since that needs the range; one whose model did not converge, +or whose range is below the shortest lag fitted (a structure that +cannot be told from a nugget, so the nugget is not identified either), +gives neither. Under \code{select_on = "split"} the sac must come from +the selection half alone: run the profile once without it, fit the sac +on \code{data_sf[attr(p, "split")$selection, ]} and pass it to a second +call with the same \code{seed}, which makes the same split. When \code{NULL} and a response is given, one is estimated on the subsample -with the same \code{predictor_vars}.} +(its selection half under \code{"split"}) with the same +\code{predictor_vars}. A plain number is taken as the range alone, in +the units of the CRS the profile is computed in (metres for lon/lat +input): it sets the floor, and \code{cp} and \code{reliability}, which +need a fitted model, are \code{NA}. A \code{units} object is refused +rather than read as a number in whatever unit it was written in.} \item{select_on}{\code{"all"} (default) profiles every point; -\code{"split"} profiles one spatially blocked half and returns the other -half as the set to estimate on, in the \code{"split"} attribute. See -the "Post-selection inference" section of +\code{"split"} reads the response on one spatially blocked half only +(the OLS fit, the variogram, \code{rss}, \code{cp} and \code{moran_z}) +and returns the other half as the set to estimate on, in the +\code{"split"} attribute. The cells, \code{wss}, \code{elbow}, and the +extent and point counts behind the bounds, \code{cp}'s variance term and +\code{reliability} still come from every point, because the +tessellation the count is for is built on every point: the levels are +cell counts for the whole layer, and the estimation half's response +never touches them. See the "Post-selection inference" section of \code{\link{determine_optimal_levels}}; the profile reads the response whenever \code{response_var} is given.} + +\item{range_floor}{\code{TRUE} (default) starts the ladder at the range +floor when the data support it; \code{FALSE} starts it at 2 whatever +the range, and the floor is only reported in the bounds and the print. +Use \code{FALSE} to compare profiles whose range estimates differ (see +"The ladder and its bounds").} } \value{ A data.frame of class \code{resolution_profile} with one row per level and columns \code{levels}, \code{wss}, \code{wss_spread} (relative spread of WSS across the restarts), \code{elbow}, \code{cell_n_min}, \code{cell_n_median}, \code{cell_diam_median} (twice the median RMS -radius of the cells, in coordinate units), \code{rss}, \code{cp}, +radius of the cells, in coordinate units: about 0.8 of the side of a +square cell of the same area, and less for finer cells, so a size to +compare levels by rather than a width), \code{rss}, \code{cp}, \code{moran_i}, \code{moran_z} and \code{reliability}; columns a missing input leaves undefined are \code{NA}. Attributes: \code{bounds} (a list -with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"} -or \code{"distinct locations"}, whichever bound it), \code{supported}, -\code{area}, \code{range}, \code{n}, \code{n_distinct}, -\code{min_cell_n}), \code{variogram} (a list with -\code{nugget}, \code{psill}, \code{range}, \code{model}; \code{NULL} -when none was usable), \code{variable} (\code{"response"}, +with \code{floor}, \code{ceiling}, \code{ceiling_from} (\code{"min_cell_n"}, +\code{"distinct locations"} or \code{"sample_n"}, whichever bound it), +\code{supported}, \code{area}, \code{range}, \code{n} (the points in the +layer), \code{n_sample} (the points the k-means fits ran on), +\code{n_distinct}, \code{min_cell_n}, \code{range_floor}), +\code{variogram} (a list with \code{nugget}, \code{psill}, \code{range} +(\code{NA} when rejected), \code{model} and \code{detrended} (whether +the sac says it is a variogram of residuals; \code{NA} when it does not +say); \code{NULL} when none was usable), \code{variable} (\code{"response"}, \code{"residuals"} or \code{NA}), \code{wss_bumps}, \code{nstart}, \code{sac} (the range object used) and, with \code{select_on = "split"}, \code{split} (a \code{spatialkit_split}: \code{selection} @@ -106,28 +153,69 @@ level as the best of \code{nstart} k-means++ restarts (see logarithmically, because cell diameter scales as \eqn{L^{-1/2}}: a unit step wastes fits at large \eqn{L} and starves resolution at small. The ladder runs from a floor to a ceiling the data impose. The ceiling is -\code{floor(n / min_cell_n)}: cells with fewer than \code{min_cell_n} points +\code{floor(n / min_cell_n)}, with \eqn{n} every point of the layer (not +the subsample): cells with fewer than \code{min_cell_n} points on average have too little support, and Moran's z is not computable at -nine cells or fewer in any case. The floor is +nine cells or fewer in any case. It is also held to the number of +distinct locations, one cell on each, and to one short of the number of +points, which \code{stats::kmeans()} needs. The floor is \code{ceiling(area / range^2)} when an autocorrelation range is available: cells wider than the range average over more than one patch of the field. When the floor exceeds the ceiling the data cannot support a tessellation that respects their own correlation structure; that is reported as a finding (a logged warning, and \code{attr(x, "bounds")$supported} is \code{FALSE}) and the ladder runs from 2 to the ceiling anyway, so the -profile still shows what each level costs. +profile still shows what each level costs. On a layer larger than +\code{sample_n} the ceiling is also held to half the subsample (two +subsample points per cell, the least a fitted cell can be scored on); +\code{ceiling_from} is then \code{"sample_n"}, a floor above that is logged +with a request to raise \code{sample_n}, and it does not make +\code{supported} \code{FALSE}. + +The floor moves with the range estimate, and the ceiling with \eqn{n}, so +two profiles of similar data (the folds of a cross-validation, say) can +sit on either side of the point where the floor applies: one ladder then +starts at the floor and the other at 2, and the criteria that sit near +the bottom of the ladder (\code{reliability}, which routinely peaks at the +floor, and \code{elbow}) can differ between them by a factor of 10 or +more. To compare profiles, pass the same \code{levels} to each, or +\code{range_floor = FALSE} to start every ladder at 2 while the floor is +still reported. } \section{The criteria, and how each behaved when measured}{ \describe{ -\item{\code{elbow}}{The signed distance of the WSS curve below the chord -from its first to its last level, the classical elbow statistic -(larger is better). Geometry only; it knows nothing of the response.} +\item{\code{elbow}}{How far the WSS curve sags below a power law: on +log-log axes, \eqn{\log} WSS below the straight line from \eqn{k = 1} +(the total sum of squares) to the last level, in natural-log units +(larger is better). Points with no cluster structure have a WSS close +to \eqn{c/k}, which is straight on those axes, so the column is +\code{NA} at every level unless the largest sag reaches +\eqn{\log 1.25}, and the print says there is no elbow (the rule and its +calibration are in \code{\link{determine_optimal_levels}}). The +classical chord on linear axes found a "knee" on such a layer anyway, +at about \eqn{\sqrt{L_{first} L_{last}}}, where the ladder's ends put +it. A level whose WSS is 0 (to within \eqn{10^{-12}} of the total), +one cell on every distinct location, which the ladder reaches when +locations repeat, is left out of the line; when the other levels have +no elbow, that fall to zero is the elbow, and its sag is measured with +the WSS floored at \eqn{10^{-12}} of the total, which puts it far +above any other level's. Geometry only; it knows nothing of the +response.} \item{\code{cp}}{Mallows' \eqn{C_p} of the piecewise-constant approximation of the response (or of its OLS residuals on \code{predictor_vars}) by cell means: \eqn{RSS(L)/n + 2 \tau^2 L / n}, with \eqn{\tau^2} the nugget of the fitted variogram (lower is better). +It estimates the error of predicting a new observation by the mean of +its cell. When the cells are fitted to a subsample of \eqn{m} of the +\eqn{N} points with a response, the penalty is split between the two: +\eqn{RSS(L)/m + \tau^2 L_m / m + \tau^2 L / N}, where the first two +terms estimate the approximation error from the subsample (adding back +the optimism of its own cell means, over the \eqn{L_m} cells its scored +points fall in) and the last is the variance of cell means built from +all \eqn{N}, which is what the tessellation will carry. With no +subsample it is the formula above. \strong{Measured on simulated exponential fields (600 points on a 1000-unit extent, sill 1, 20 replicates): with a nugget of 0.3 its minimum sat at the support ceiling in every replicate at effective @@ -137,7 +225,10 @@ approximation keeps improving as cells shrink and the penalty is too small to stop it, so \eqn{C_p} says "as fine as the support allows" and \code{min_cell_n} is what is choosing; \code{select_resolution()} says so when that happens. It becomes a genuine interior criterion -only when the nugget is a large share of the sill.} +only when the nugget is a large share of the sill. With a nugget of 0 +(under \eqn{10^{-4}} of the sill; usually a fit clipped at its lower +bound) the penalty is 0 and \eqn{C_p} descends to the ceiling whatever +the field; the profile warns.} \item{\code{moran_z}}{The standardised deviate of Moran's I on the residuals of the cell means regressed on the cell-mean predictors (an intercept alone when there are none): how much spatial structure the @@ -148,14 +239,18 @@ where structure remains. \code{NA} at nine cells or fewer.} \item{\code{reliability}}{The between-cell signal's share of the spread in the cell means, from the fitted variogram alone via Krige's additivity relation (Cressie 1996), for square cells of the level's -average area with the level's average point count (larger is better). +average area holding the level's average share of the layer's points +with a response (larger is better). This is the shrinkage factor of Fay and Herriot (1979). It has an interior optimum, and a broad one: validated against the empirical reliability of true block means on simulated fields, the analytic and empirical optima agreed to within a level or two where the empirical estimate was stable, and the band within 2 percent of the maximum spanned a factor of 3--6 in \eqn{L}. Read the flat region, not the -argmax. \code{NA} without a usable variogram.} +argmax. The domain term is taken over the convex hull the area is +measured on, so rotating the layer does not move it. \code{NA} +without a usable variogram, and when the variogram's range was +rejected (see \code{sac}).} } \code{cp} and \code{reliability} answer different questions: how well the cells represent the field, and whether the cell values are distinguishable @@ -170,7 +265,7 @@ if (requireNamespace("gstat", quietly = TRUE)) { # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough # noise for Mallows' Cp to have an interior optimum rather than descend # to the ceiling. - set.seed(2) + set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) diff --git a/man/sac_nugget.Rd b/man/sac_nugget.Rd index 667b54c..a0cb03c 100644 --- a/man/sac_nugget.Rd +++ b/man/sac_nugget.Rd @@ -19,10 +19,14 @@ fits were all singular, or an object that is not a \code{sac_range}). The nugget variance of the variogram model behind a \code{\link{estimate_sac_range}()} result: the semivariance at zero separation, i.e. measurement error plus variation at scales shorter than -the closest pair. It is carried as the \code{nugget} attribute of every -classed result, identified or rejected, because it is the number a -resolution criterion for a tessellation needs (the short-lag variance that -no cell can average away). +the first lag bin of the empirical variogram (gstat's bins are +\code{cutoff / 15} wide, about \code{max_dist / 30} at the default +\code{cutoff}), which can be far wider than the spacing of close pairs. +It is extrapolated to zero from that bin, not observed, and a fit that +runs into its lower bound reports exactly 0. It is carried as the +\code{nugget} attribute of every classed result, identified or rejected, +because it is the number a resolution criterion for a tessellation needs +(the short-lag variance that no cell can average away). } \examples{ if (requireNamespace("gstat", quietly = TRUE)) { diff --git a/man/select_features_forward.Rd b/man/select_features_forward.Rd index 29bf8b7..191f2f7 100644 --- a/man/select_features_forward.Rd +++ b/man/select_features_forward.Rd @@ -80,9 +80,11 @@ caution above exists to prevent, so the leakage warning \item{select_on}{\code{"all"} (default) runs the sweep on every row of \code{train_sf}. \code{"split"} runs it on one spatially blocked half, then fits the selected set on that half and scores it on the other: -\code{score_holdout} is then an honest estimate of the selected model's -\code{metric} on data the selection never saw (the sweep's own -\code{score} is not; see "The score is not a performance estimate"). +\code{score_holdout} is then the selected model's \code{metric} on rows +whose response the sweep never read (the sweep's own \code{score} is +not; see "The score is not a performance estimate"). It is one +estimate from one region: the halves share a border with no buffer, so +rows near it are still correlated with the selection half. Both halves come back in \code{$split}. See the "Post-selection inference" section of \code{\link{determine_optimal_levels}} for the trade: coverage for half the sample.} @@ -97,20 +99,31 @@ A list of class \code{"feature_selection"} (so that final step: the \strong{selection-internal} optimum, optimistically biased because it was chosen as the best of many (see the section above), and \code{NA} when nothing was selected. \code{history} is a data.frame -with \code{step}, \code{variable} and \code{score}, holding every -candidate evaluated at every step; when the null model could be scored it -also carries a \code{step = 0} row named \code{""} giving that -baseline, so the first variable's gain can be read off directly. +with \code{step}, \code{variable}, \code{score} and \code{n_pred}, +holding every candidate evaluated at every step; when the null model +could be scored it also carries a \code{step = 0} row named +\code{""} giving that baseline, so the first variable's gain can be +read off directly. Every set is scored on the same rows: those the null +model's cross-validation predicted or, when there is no null model, +those any step-1 set predicted; \code{params$n_scored} counts them (a +warning says so when that is fewer than all). \code{n_pred} is how many +rows the set's cross-validation predicted. A set that left some of the +scored rows unpredicted, because a fold failed for it, has \code{score} +\code{NA}, with a warning naming it: scored on the rows it did predict +it would be compared on fewer, usually easier, rows than its rivals. A +factor with a level found in one spatial block only is the usual case, +and cannot be selected. \code{score_holdout} is \code{NA} unless \code{select_on = "split"}, and then the selected set's \code{metric} when fitted on the selection half and predicted on the estimation half (\eqn{R^2} against the selection half's mean, the out-of-sample convention); \code{NA} when nothing was selected or the prediction failed. \code{split} is \code{NULL} or a list with \code{selection} and \code{estimation}, integer row positions -in \code{train_sf} after the completeness filter above. +in \code{train_sf} as passed; rows the completeness filter above dropped +are in neither. \code{params} records \code{metric}, \code{method}, \code{k}, \code{tol}, \code{seed}, \code{auto_range}, \code{select_on}, -\code{n_candidates} and \code{estimated_fits}. +\code{n_candidates}, \code{estimated_fits} and \code{n_scored}. } \description{ Selects predictors by repeatedly adding whichever candidate most improves a diff --git a/man/select_resolution.Rd b/man/select_resolution.Rd index ca83500..ca922f5 100644 --- a/man/select_resolution.Rd +++ b/man/select_resolution.Rd @@ -29,7 +29,8 @@ which can skip a rung), \code{criterion}, \code{value} (the optimum), \code{at_ceiling} and \code{at_floor} (logical: the optimum is the last or first of the levels this criterion was scored at, which for \code{moran_z} starts above nine cells), \code{edge} (which bound that -is, in words: the support ceiling, the range floor, the ladder's own end, +is, in words: the support ceiling, the subsample's ceiling, the range +floor, the ladder's own end, or the first or last level the criterion is computable at; \code{NA} for an interior optimum), \code{n_levels} and \code{values} (the criterion at every level, \code{NA} where it could not be computed). @@ -54,7 +55,7 @@ if (requireNamespace("gstat", quietly = TRUE)) { # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough # noise for Mallows' Cp to have an interior optimum rather than descend # to the ceiling. - set.seed(2) + set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) diff --git a/man/spatialkit-package.Rd b/man/spatialkit-package.Rd index 8422dc5..c701d1a 100644 --- a/man/spatialkit-package.Rd +++ b/man/spatialkit-package.Rd @@ -94,17 +94,16 @@ the length-scale-to-domain ratio in \code{make_folds(method = "nndm")} and their \code{min_train = 0.5}: Mila et al. (2022). \item The area-of-applicability threshold as the outlier-removed maximum -of the training dissimilarity, with importance weights applied directly, -without taking their square root, matching the reference -implementation: Meyer and Pebesma (2021). +of the training dissimilarity, as the paper defines it (the reference +implementation, CAST, uses the outlier fence itself, which is larger +whenever a training value lies above it), with importance weights +applied directly, without taking their square root, as CAST does: +Meyer and Pebesma (2021). \item The effective range of an exponential variogram as three times its range parameter, and the identifiability guard against ranges beyond half the maximum separation, in \code{estimate_sac_range()}. \item Cliff and Ord moments for the residual Moran's I in \code{residual_morans_i()}, with \code{null = "auto"}. -\item The small-sample rescaling applied with every data-derived design -effect in \code{summarize_by_cell()}, whose derivation and measured -coverage are on that help page. } Defaults that were chosen, and are defensible, but do not rest on a @@ -133,6 +132,11 @@ and the figure sits in the gap. length-scale in \code{fit_bayesian_spatial_model()}, which is this package's own operationalisation of a check the reference recommends, not a figure from the paper. +\item The small-sample rescaling applied with every data-derived design +effect in \code{summarize_by_cell()}: the package's own derivation from +Kish's exchangeable-correlation model, not taken from a reference. +The derivation and its measured coverage are in the section "Spatial +autocorrelation and standard-error bias" of that help page. } } diff --git a/man/spatialkit_quiet.Rd b/man/spatialkit_quiet.Rd index d1b8e46..16f324d 100644 --- a/man/spatialkit_quiet.Rd +++ b/man/spatialkit_quiet.Rd @@ -30,6 +30,15 @@ This helper names the right index. These are log records, not R conditions: \code{suppressWarnings()} and \code{tryCatch(warning = )} do not see them. Conditions the package raises as real R warnings are unaffected by this function. + +While a document is being knitted (R Markdown, Quarto, a \pkg{pkgdown} +article) the console echo is also sent as an R message, because +\pkg{knitr} does not capture what is written to the console's error stream +and the cautions would otherwise be missing from the output. They appear +as \code{## WARN [...]} lines, and the chunk option \code{message = FALSE}, +like \code{suppressMessages()}, keeps them out of the document. A line the +package also raises as an R warning is not repeated, since the document +shows the warning. Outside \pkg{knitr} nothing changes. } \examples{ old <- spatialkit_quiet() # console echo off diff --git a/man/sub-.spatialkit_rows.Rd b/man/sub-.spatialkit_rows.Rd index 1a90e10..21c087b 100644 --- a/man/sub-.spatialkit_rows.Rd +++ b/man/sub-.spatialkit_rows.Rd @@ -23,10 +23,25 @@ subset that is not a data frame (a single column taken with attribute recording what happened to its rows (\code{"dropped"} and \code{"ties"} respectively). Those records describe the rows the layer was built with, and \code{[} on an \code{sf} object copies attributes through -unchanged, which would leave a subset reporting its parent's numbers with -row positions that no longer resolve. Subsetting therefore returns a plain -layer with the record removed; read the record from the layer the function -returned, before subsetting it. +unchanged, which would leave a subset reporting its parent's numbers for a +different set of rows. Subsetting therefore returns a plain layer with the +record removed, and so do the \pkg{dplyr} verbs that select or reorder +rows (\code{filter()}, \code{slice()}, \code{arrange()}, +\code{distinct()}); read the record from the layer the function returned, +before subsetting it. Binding such layers (\code{rbind()}, +\code{dplyr::bind_rows()}) likewise returns a plain \code{sf} layer. +} +\details{ +Each record carries \code{n_rows}, the number of rows it was made for. +\code{sf::st_drop_geometry()} keeps the rows, and with them the record: it +returns a data frame of class \code{c("spatialkit_rows", "data.frame")}. +Binding such data frames with +\code{rbind()} or \code{dplyr::bind_rows()} keeps the first one's record +and class, so the record then describes only the first input's rows: its +\code{n_rows} no longer equals \code{nrow()} of the result. The +package's own readers ignore a record whose \code{n_rows} does not match; +when reading \code{attr(x, "dropped")} or \code{attr(x, "ties")} yourself +from a layer that has been through such steps, check it the same way. } \examples{ library(sf) diff --git a/man/summarize_by_cell.Rd b/man/summarize_by_cell.Rd index 6e8305e..5c0fb81 100644 --- a/man/summarize_by_cell.Rd +++ b/man/summarize_by_cell.Rd @@ -22,23 +22,40 @@ summarize_by_cell( \arguments{ \item{assigned_points_sf}{An sf object with a cell identifier column.} -\item{response_var}{Optional response column name for per-cell aggregation.} +\item{response_var}{Optional response column name for per-cell +aggregation: a single character string. A name that is not a column, or +a column that is not numeric, is skipped with a warning.} -\item{predictor_vars}{Optional predictor column names for per-cell aggregation.} +\item{predictor_vars}{Optional predictor column names for per-cell +aggregation. Names that are not columns, and columns that are not +numeric, are skipped with a warning.} \item{id_col}{Preferred name of the polygon/cell ID column.} \item{agg_funs}{Named list of aggregation functions. Default \code{list(mean = \(x) mean(x, na.rm = TRUE))}. Additional common options: -\code{median}, \code{sum}, \code{sd}.} +\code{median}, \code{sum}, \code{sd}. A single function +(\code{agg_funs = median}) or a character vector of function names +(\code{c("median", "sum")}) is also accepted. A single function is named +after the expression passed: a name gives that name (\code{median}, or +\code{f} for a variable \code{f} holding a function), +\code{stats::median} gives \code{median}, and any other expression gives +\code{agg1}; pass a named list to choose the name. Anything else falls +back to the default mean with a warning.} \item{cells_sf}{Optional polygon sf layer to join cell geometries onto the output. When supplied, the return value is an sf object with the polygon geometry from cells_sf, with one row per cell in \code{cells_sf}. Cells that no feature fell in are kept, with \code{NA} summaries. Duplicate ID values in \code{cells_sf} would multiply those rows, so they are reported -with a warning. When NULL (default), a plain data.frame/tibble is -returned (previous behaviour).} +with a warning. Its ID column is the first of \code{id_col}, \code{"poly_id"}, +\code{"polygon_id"}, \code{"id"}, \code{"cell_id"} and \code{"grid_id"} it carries, the +list and order \code{\link[=assign_features_to_polygons]{assign_features_to_polygons()}} reads the polygons' IDs +from. A summarised ID that matches no cell is reported with a warning, +since the join drops it with its points; a \code{cells_sf} with none of +those columns, or one that is not an sf object, gives a warning and a +plain data frame (an error with \code{area = TRUE}). When NULL (default), a +plain data.frame/tibble is returned (previous behaviour).} \item{deff}{Design-effect adjustment for standard errors. One of: \describe{ @@ -56,8 +73,18 @@ cells get larger and Kish's single-\code{rho} assumption degrades. Supply the fit via \code{sac}, or it is estimated when \code{response_var} is given and 'gstat' is available. Exponential, spherical and Gaussian models are supported, with a nugget and with several structured components -(each weighted by its partial sill); a model of any other family -falls back to \code{deff = 1} with a warning naming it.} +(each weighted by its partial sill) and with gstat's 2-D geometric +anisotropy (\code{vgm(..., anis = c(angle, ratio))}), applied as gstat +applies it. A model of any other family falls back to \code{deff = 1} +with a warning naming it, and so does a request with no usable +model (none supplied and none could be estimated, or a rejected +fit that could not be replaced by an estimate); see "Value" for how +to detect a fallback. A model with no structured component (a pure +nugget) implies that distinct observations are uncorrelated, so it +is applied as a design effect of 1 in every cell, not treated as a +fallback. Points with empty +geometry count towards their cells' values but not towards the +correlation, with a warning.} \item{\code{"kish"}}{Estimate per-variable-type intra-class correlations (ICCs) from the grouped data using a one-way random-effects ANOVA decomposition (one ICC for the response variable and a separate @@ -79,26 +106,38 @@ columns or vice versa, and it is the response's ICC (not the predictors') that sets \code{cell_weight} whenever a response was given. Requires at least 2 cells with 2+ observations and at least 2 residual degrees of freedom (\code{N - k >= 2}); the ICC is taken as 0 (no -correction, no \code{"deff_applied"} attribute) otherwise, and likewise -when the estimate itself comes out at or below 0.} +correction for that variable type) otherwise, and likewise when the +estimate itself comes out at or below 0. The \code{"deff_applied"} +attribute is attached when either ICC is positive, so when both are +0 there is none.} \item{A positive number}{Applied as a uniform design effect to every cell, as \code{sd * sqrt(deff / n)}, exactly \code{sqrt(deff)} times the naive SE. Use when you have an external estimate of the design -effect. Anything that is not a single number \verb{>= 1} (including a -value below 1, which would \emph{shrink} the standard errors) is -refused with a warning and replaced by 1.} +effect. Anything that is not a single finite number \verb{>= 1} +(including a value below 1, which would \emph{shrink} the standard +errors, and \code{NA} or \code{Inf}) is refused with a warning and replaced +by 1.} }} \item{sac}{Optional \code{sac_range} object from \code{\link[=estimate_sac_range]{estimate_sac_range()}}, used when \code{deff = "variogram"}. Supplying one avoids re-fitting the variogram and lets you inspect the fit the design effect is based on. A \code{sac_range} -whose fit was \emph{rejected} (its \code{status} is not \code{"ok"}) carries no usable -correlation function, so \code{deff} falls back to 1 with a warning and does -not correct by a shape that was not trusted enough to report a range.} +whose fit was \emph{rejected} (its value is \code{NA} and it carries a +\code{rejected_reason} attribute) carries no usable correlation function, so +it is set aside rather than correcting by a shape that was not trusted +enough to report a range: the variogram is then estimated as if no \code{sac} +had been given, with a plain warning saying so, or, where that is not +possible, \code{deff} falls back to 1 with the fallback warning, which names +the rejection. A \code{sac} with no \code{variogram_model} attribute -- a plain +number or a \code{units} object, say -- is a range without a correlation +function, and is set aside the same way. A \code{sac} fitted to residuals +(\code{attr(sac, "detrended")} \code{TRUE}) is used as given, with a warning when +it corrects response columns (see "Design effects and variable types").} \item{deff_max_n}{Cells with more than this many points are subsampled before forming the \verb{n x n} correlation matrix used by -\code{deff = "variogram"}. Default 500.} +\code{deff = "variogram"}. Default 500. It must be a single number of at +least 2 when \code{deff = "variogram"}; anything else is an error.} \item{quiet}{Logical; suppress this function's progress \code{message()}s. It does not silence R warnings, nor the package's console log echo @@ -125,7 +164,12 @@ percent and the request goes through; the conterminous United States forced into one zone (14 percent), or a few degrees of latitude in Web Mercator (4 percent at 48N), does not. \code{\link[=ensure_projected]{ensure_projected()}} with \code{purpose = "area"} chooses an equal-area CRS for lon/lat input; build the -cells in it. The measured spread is attached as \code{attr(, "area_error")}.} +cells in it. Lon/lat cells are measured geodesically instead: their +\code{cell_area} is \code{sf::st_area()}'s area in square metres (on the sphere +with s2, sf's default), not a planar area in squared degrees, and the +distortion check passes by construction; with s2 switched off, sf needs +the lwgeom package for that area and the request is refused without +it. The measured spread is attached as \code{attr(, "area_error")}.} } \value{ A tibble/data.frame (or sf if cells_sf given) with per-cell @@ -133,11 +177,30 @@ summaries: the ID column, \code{n} (rows in the cell), one column per \code{agg_funs} entry per variable, \verb{..sd_*} / \verb{..se_*} for every numeric response and predictor, \verb{..neff_*} / \verb{..df_*} / \verb{..ci_lo_*} / \verb{..ci_hi_*} for the same columns when \code{conf_level} is given, -\code{cell_weight}, and \code{cell_area} / \code{n_per_area} when \code{area = TRUE}. An -input column also called \code{n} is not allowed to shadow the count. +\code{cell_weight}, \code{deff_applied} when a design effect was requested (any +\code{deff} other than 1), and \code{cell_area} / \code{n_per_area} when +\code{area = TRUE}. An input column also called \code{n} is not allowed to shadow +the count. + +\code{deff_applied} is \code{TRUE} on every row when the requested correction was +applied (exactly when the \code{"deff_applied"} attribute below is attached; +under \code{"kish"}, when any standard-error column was corrected) +and \code{FALSE} when it fell back to the uncorrected standard errors: a +refused \code{deff}, a \code{"variogram"} request with no usable model, or +\code{"kish"} ICCs of 0 for every variable type (and \code{NA} on a \code{cells_sf} +row no point fell in). +Unlike the attribute it survives \code{rbind()} and +\code{dplyr::bind_rows()} of many results. A fallback is also signalled by a +warning of class \code{"spatialkit_deff_fallback"} (a Kish ICC of 0 is +reported on \code{attr(, "icc")} instead), which +\code{tryCatch(spatialkit_deff_fallback = )} catches without matching the +message; it is raised only when the standard errors really are the +uncorrected ones. When a correction was actually applied, an attribute \code{"deff_applied"} is -attached recording it: \code{method} plus \code{icc_resp}/\code{icc_pred} for \code{"kish"}, +attached recording it: \code{method} plus \code{icc_resp}/\code{icc_pred} and \code{deff} +for \code{"kish"} (\code{deff} is the primary variable's per-cell design effect, +all 1 when only the predictor ICC was positive), \code{deff}/\code{deff_rows}/\code{rbar}/\code{crs}/\code{max_n} for \code{"variogram"} (\code{deff} is the design effect at the primary variable's non-missing count per cell, \code{deff_rows} at the cell's row count, which is the vector the log line @@ -146,8 +209,8 @@ When \code{cells_sf} is supplied, \emph{every} per-cell vector in that attribute (\code{deff}, \code{deff_rows} and \code{rbar} alike) is realigned to the joined row order, so \code{deff[i]} and \code{rbar[i]} still describe row \code{i}; cells with no observations carry \code{NA}. No attribute is attached when no correction was -applied: \code{deff = 1}, a \code{deff = "kish"} ICC of 0, or a \code{"variogram"} -request that could not be fitted. A \code{deff = "kish"} request always +applied: \code{deff = 1}, a \code{deff = "kish"} request whose ICCs are all 0, or +a \code{"variogram"} request that could not be fitted. A \code{deff = "kish"} request always records the ICCs it estimated on an attribute \code{"icc"} (\code{resp} and \code{pred}, \code{NA} for a variable type with no numeric column), whether or not they were positive enough to apply, so a result with no \code{"deff_applied"} @@ -156,7 +219,9 @@ still says what the ICC came out as. The ID column keeps its input type when \code{cells_sf}'s ID column and the summarised IDs already have the same class. When the classes differ, both are coerced to character in order to join (logged as a warning), and the -returned ID column is therefore character. +returned ID column is therefore character. Whole numbers are written out +in full for that (\code{"100000"}, never \code{"1e+05"}), so an integer and a +double ID of the same cell still match. } \description{ Aggregates an sf point dataset into one row per cell. By default computes @@ -192,13 +257,18 @@ Pass it as the \code{weights} argument of a downstream regression. \section{Spatial autocorrelation and standard-error bias}{ By default (\code{deff = 1}), the \verb{..se_*} columns are computed as -\code{sd / sqrt(n)}, which assumes observations within each cell are independent. -When data are spatially autocorrelated (the common case for the spatial -workflows this package supports), within-cell observations are typically -positively correlated, so the effective sample size is smaller than \code{n}. -The naive SE is therefore \strong{anticonservative} (too small), and downstream -weighted regressions using \code{cell_weight} or \verb{..se_*} columns will produce -overconfident standard errors for cells with strong intra-cell correlation. +\code{sd / sqrt(n)}, which treats the observations within each cell as +independent. When data are spatially autocorrelated (the common case for the +spatial workflows this package supports), within-cell observations are +typically positively correlated: they share the cell's departure from the +population mean, so as an estimate of the \strong{population (grand) mean} a cell +mean has an effective sample size smaller than \code{n}. For that estimand the +naive SE is \strong{anticonservative} (too small), and a downstream weighted +regression that uses \code{cell_weight} or the \verb{..se_*} columns for population-level +inference will produce overconfident standard errors for cells with strong +intra-cell correlation. For the cell's \strong{own} mean the naive SE is the right +one when the cell's points are spread through it, and the corrected SE is too +wide; see "What the standard error estimates" before setting \code{deff}. Setting \code{deff = "kish"} applies an approximate correction using Kish's design effect. Separate intra-class correlations (ICCs) are estimated for @@ -208,6 +278,23 @@ adjustment, and each cell's effective sample size is reduced to \code{n_i / (1 + (n_i - 1) * rho)}. This is a first-order correction that does not require a full spatial covariance model but does require enough cells and observations for a stable ICC estimate. + +A design effect estimated from the data (\code{"kish"} or \code{"variogram"}) comes +with a second, small-sample correction. The within-cell correlation that +inflates the variance of the mean to \code{sigma^2 * deff / n} also biases the +within-cell sample variance downward: under exchangeable correlation \code{rho} +(Kish's own assumption), with \code{deff = 1 + (n - 1) * rho}, +\code{E[s^2] = sigma^2 * (n - deff) / (n - 1)}, so \code{s^2} understates \code{sigma^2} +by very nearly the factor by which \code{deff} inflates the mean's variance, and +the two errors compound rather than cancel. The standard error is therefore +\code{s * sqrt(deff / n) * sqrt((n - 1) / (n - deff))}, and \code{NA} where +\code{deff >= n} (the cell then holds one observation's worth of information +and \code{s} carries none about \code{sigma}). This is the package's own derivation, +not taken from a reference. Measured 95\% interval coverage at \code{n = 30} +over 20,000 replicates: 0.921, 0.844 and 0.628 at \code{rho} = 0.2, 0.5 and 0.8 +with \code{s * sqrt(deff / n)} alone, against 0.948, 0.950 and 0.949 with the +rescaling. + You may also pass a fixed numeric design effect (e.g. \code{deff = 2}) to uniformly inflate standard errors: an externally supplied constant is applied as \code{sd * sqrt(deff / n)}, exactly \code{sqrt(deff)} times the naive SE in @@ -236,7 +323,8 @@ over that cell), which is what a cell-level map or a regression on cell values usually wants. For that quantity the naive \code{sd / sqrt(n)} is the better of the two on offer: measured coverage 0.95 under exchangeable within-cell correlation, against very nearly 1.00 for the -design-effect-corrected SE, which is about five times too wide. That 0.95 +design-effect-corrected SE, which is too wide by the factor +\code{sqrt(deff / (1 - rho))} (4.6 at 20 points a cell and \code{rho = 0.5}). That 0.95 is exact under the exchangeable model and holds under a spatial covariance model only when the cell's points are spread through the cell; with \emph{clustered} sampling inside a cell it is anticonservative for the block @@ -262,8 +350,10 @@ correct for is the response's own. (A residual variogram, whose correlation is that of the part the predictors do not explain, is weaker; using it here dropped grand-mean coverage from 0.93 to 0.51 the moment a predictor was listed.) Pass \code{sac} explicitly when you want a different variogram, such as -a residual one from \code{estimate_sac_range(..., predictor_vars = )}, and check -\code{attr(sac, "detrended")} to know which you have. +a residual one from \code{estimate_sac_range(..., predictor_vars = )}. A \code{sac} +whose \code{attr(sac, "detrended")} is \code{TRUE} is used as given, but when it +corrects response columns a warning says that their standard errors are +understated, as \code{\link[=kriging_adequacy]{kriging_adequacy()}} warns about the same mismatch. } \section{Confidence intervals}{ @@ -279,7 +369,10 @@ not an interval for the cell's own block average. The interval is \verb{mean +/- qt((1 + conf_level) / 2, df) * se}, centred on the plain mean of the column's non-missing values whatever \code{agg_funs} computes, and is \code{NA} wherever the standard error is (a single observation; complete redundancy -under \code{deff}). +under \code{deff}). \verb{..neff_*} and \verb{..df_*} are \code{NA} where the column has one +non-missing value or none, like the standard error; \code{cell_weight} still +counts such a cell (1, or \code{1 / deff} for a numeric \code{deff}), so the two +differ there. The degrees of freedom are \strong{not} \code{neff - 1}. The interval's spread comes from the within-cell sample variance, and under exchangeable correlation diff --git a/man/summary.resolution_profile.Rd b/man/summary.resolution_profile.Rd index ab61f8e..7ee66aa 100644 --- a/man/summary.resolution_profile.Rd +++ b/man/summary.resolution_profile.Rd @@ -73,7 +73,7 @@ if (requireNamespace("gstat", quietly = TRUE)) { # 600 m) on a 1 km square, with a nugget of 0.6 on a unit sill: enough # noise for Mallows' Cp to have an interior optimum rather than descend # to the ceiling. - set.seed(2) + set.seed(4) n <- 400 xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) diff --git a/man/summary.spatial_fit.Rd b/man/summary.spatial_fit.Rd index 39b0d05..16b84da 100644 --- a/man/summary.spatial_fit.Rd +++ b/man/summary.spatial_fit.Rd @@ -44,6 +44,9 @@ exceeds the global predictor count, and a GP model has no simple \code{p}. \eqn{|y| + |\hat{y}|}, so neither is defined where its denominator is zero. Neither returns \code{Inf} or \code{NaN}. Both are averaged over the rows whose denominator is non-zero, and are \code{NA} when no row qualifies. +Non-zero is judged at the scale of the data: a denominator no larger +than 100 machine epsilons times the largest one counts as zero, so the +rule does not depend on the units of the response. The \code{n_MAPE} and \code{n_SMAPE} columns record how many rows that was; the \code{n} column counts finite observation/prediction pairs. Read a percentage error next to its count: when \code{n_MAPE < n}, \code{MAPE} is diff --git a/man/voronoi_seeds_kmeans.Rd b/man/voronoi_seeds_kmeans.Rd index 16d7959..67be3fa 100644 --- a/man/voronoi_seeds_kmeans.Rd +++ b/man/voronoi_seeds_kmeans.Rd @@ -4,7 +4,7 @@ \alias{voronoi_seeds_kmeans} \title{K-means seed generation from point coordinates} \usage{ -voronoi_seeds_kmeans(points_sf, k, set_seed = 456) +voronoi_seeds_kmeans(points_sf, k, set_seed = 456, nstart = 10) } \arguments{ \item{points_sf}{An sf object with POINT geometries.} @@ -15,7 +15,14 @@ of distinct point positions and \code{nrow(points_sf) - 1}, because k-means can produce neither more centres than there are distinct points nor as many centres as there are rows. Check \code{nrow()} on the result.} -\item{set_seed}{Optional integer RNG seed. Default 456.} +\item{set_seed}{Optional integer RNG seed. Default 456, so a call gives the +same seeds every time whatever the session's random-number state; an +outer \code{\link[=set.seed]{set.seed()}} does not change them, and the caller's random-number +stream is left as it was. Pass \code{NULL} to draw the k-means starts from +the session's stream instead (the default of \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}).} + +\item{nstart}{Number of random starts for \code{\link[stats:kmeans]{stats::kmeans()}}; the best is +kept. Default 10.} } \value{ An sf object of \strong{at most} \code{k} cluster-centre POINTs (fewer when @@ -26,16 +33,29 @@ An sf object of \strong{at most} \code{k} cluster-centre POINTs (fewer when 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. +none. Reach for this when you want cells that follow the data, so that +counts per cell vary far less than on a fixed grid over clustered points +(k-means does not equalise them, it minimises the spread of points around +each centre), which is what keeps per-cell aggregates in +\code{\link[=summarize_by_cell]{summarize_by_cell()}} from resting on one or two observations. Use +\code{\link[=voronoi_seeds_random]{voronoi_seeds_random()}} instead when you want coverage of the study area +rather than of the data, and \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}} to pick between them by +name. } \details{ Lon/lat input is projected first so the k-means distances are metric and not -degrees. Rows with empty or non-finite coordinates are dropped with a -warning, and \code{k} is clamped to the number of distinct positions. +degrees; so is input with no CRS whose coordinates look like lon/lat (the +heuristic \code{\link[=ensure_projected]{ensure_projected()}} applies, with its warning), and the seeds +come back in the input's own coordinates. Rows with empty or non-finite +coordinates are dropped with a warning, and \code{k} is clamped to the number of +distinct positions. + +The partition is \code{\link[stats:kmeans]{stats::kmeans()}} (Hartigan-Wong) with \code{nstart} random +starts. \code{\link[=resolution_profile]{resolution_profile()}} and \code{\link[=determine_optimal_levels]{determine_optimal_levels()}} score each +count on a different run, by default the best of 25 k-means++ restarts, +which usually reaches a lower within-cluster sum of squares; the seeds for +a chosen count are therefore not the partition that count was scored on. +Raising \code{nstart} narrows the gap but does not close it. } \examples{ library(sf) diff --git a/man/voronoi_seeds_random.Rd b/man/voronoi_seeds_random.Rd index 3c15fc3..d76d1f8 100644 --- a/man/voronoi_seeds_random.Rd +++ b/man/voronoi_seeds_random.Rd @@ -4,19 +4,24 @@ \alias{voronoi_seeds_random} \title{Random seed generation within a polygonal boundary} \usage{ -voronoi_seeds_random(boundary, k, set_seed = 456) +voronoi_seeds_random(boundary, k, set_seed = NULL) } \arguments{ \item{boundary}{An sf or sfc polygonal object.} \item{k}{Integer; number of random seeds.} -\item{set_seed}{Integer RNG seed. Default 456.} +\item{set_seed}{Optional integer RNG seed. Default \code{NULL}: the seeds are +drawn from the session's random-number stream, so consecutive calls give +different seedings and \code{\link[=set.seed]{set.seed()}} before a call makes it reproducible. +Pass a number to get the same seeds whatever that stream holds; the +caller's stream is then left as it was. The default used to be 456, +which made every call return the same "random" seeding, even inside a +loop over \code{\link[=set.seed]{set.seed()}}.} } \value{ -An sf object of \strong{at most} \code{k} random POINTs (rejection sampling -inside an awkward geometry can fall short of \code{k}, which is warned about), -with \code{seed_id} and \code{method = "random"} columns matching +An sf object of \code{k} random POINTs (fewer only in the degenerate +case above), with \code{seed_id} and \code{method = "random"} columns matching \code{\link[=get_voronoi_seeds]{get_voronoi_seeds()}}. } \description{ @@ -30,18 +35,23 @@ 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. +Seeds are drawn uniformly inside the polygon. When a draw falls short of \code{k} +it is topped up with further uniform draws from the same polygon, so the +result has exactly \code{k} seeds; only a geometry that still yields too few +after ten top-ups returns fewer, and that shortfall is logged. } \examples{ library(sf) bnd <- st_sf(geometry = st_sfc(st_polygon(list(rbind( c(0, 0), c(100, 0), c(100, 100), c(0, 100), c(0, 0) ))), crs = 32632)) +set.seed(1) seeds <- voronoi_seeds_random(bnd, k = 10) -nrow(seeds) # at most 10: a seed that lands outside the boundary is dropped +nrow(seeds) # 10 seeds +# Another call is another seeding; set_seed pins one. +identical(st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7)), + st_coordinates(voronoi_seeds_random(bnd, k = 10, set_seed = 7))) } \seealso{ Other tessellation: diff --git a/tests/testthat/helper-logging.R b/tests/testthat/helper-logging.R index 313aec8..baf68ad 100644 --- a/tests/testthat/helper-logging.R +++ b/tests/testthat/helper-logging.R @@ -2,11 +2,12 @@ # --------------------------------------------------------------------------- # Capture spatialkit's log output. # -# The package logs through logger::log_warn() / log_info() into the -# "spatialkit" namespace (see R/zzz.R): index 1 appends INFO+ to a temp file, -# index 2 sends WARN+ to appender_console. Neither raises an R condition, so -# expect_warning() and expect_message() do NOT see these lines -- an assertion -# written that way passes vacuously whether or not the message is emitted. +# The package logs through logger into the "spatialkit" namespace (see +# R/zzz.R): index 1 appends INFO+ to a temp file, index 2 sends WARN+ to the +# console's error stream (an R message only while knitr is running, which a +# test is not). Neither raises an R condition, so expect_warning() and +# expect_message() do NOT see these lines -- an assertion written that way +# passes vacuously whether or not the message is emitted. # # capture_spatialkit_log() temporarily installs a recording appender and # returns the emitted lines, so tests can assert on them for real. @@ -18,12 +19,13 @@ capture_spatialkit_log <- function(expr, level = logger::INFO) { # Register the restore FIRST. If either mutation below (or `expr` itself) # throws, the recording appender must not be left installed -- it would # swallow every subsequent test's log output for the rest of the session and - # silently disable appender_console. + # silently disable the console echo. # - # Restores the configuration .onLoad() installs (R/zzz.R: appender_console at - # WARN on index 2) rather than round-tripping through the getter. + # Restores the configuration .onLoad() installs (R/zzz.R: the package's own + # console appender at WARN on index 2) rather than round-tripping through + # the getter. on.exit({ - logger::log_appender(logger::appender_console, + logger::log_appender(spatialkit:::.sk_console_appender, namespace = "spatialkit", index = 2) logger::log_threshold(logger::WARN, namespace = "spatialkit", index = 2) }, add = TRUE) diff --git a/tests/testthat/helper-review2-folds.R b/tests/testthat/helper-review2-folds.R new file mode 100644 index 0000000..39fd1ea --- /dev/null +++ b/tests/testthat/helper-review2-folds.R @@ -0,0 +1,16 @@ +# tests/testthat/helper-review2-folds.R +# --------------------------------------------------------------------------- +# Shared by the second-review tests of make_folds(), fold_separation() and +# cv_block_size_sweep(). +# --------------------------------------------------------------------------- + +r2_pts <- function(x, y, crs = 32632, ...) { + sf::st_as_sf(data.frame(x = x, y = y, ...), coords = c("x", "y"), crs = crs) +} +r2_fit <- function(train_sf) lm_spatial_fit(train_sf, "z", "a") +r2_quiet <- function(expr) { + # Keep the console clear of the package's own WARN lines; R conditions + # still reach the expectations. + logger::with_log_threshold(expr, threshold = logger::FATAL, + namespace = "spatialkit", index = 2) +} diff --git a/tests/testthat/test-area-of-applicability.R b/tests/testthat/test-area-of-applicability.R index 73b7d00..e6871c4 100644 --- a/tests/testthat/test-area-of-applicability.R +++ b/tests/testthat/test-area-of-applicability.R @@ -135,7 +135,12 @@ test_that(".aoa_weight_vector rejects unusable weights", { expect_error(.aoa_weight_vector(c(1, 2, 3), v), "one value per predictor") expect_error(.aoa_weight_vector(c(a = 1), v), "no entry for") expect_error(.aoa_weight_vector(c(a = 1, b = -1), v), "non-negative") - expect_error(.aoa_weight_vector(c(a = 0, b = 0), v), "all .weights. are zero") + # All-zero weights -- pmax(importance, 0) of a model that found no useful + # predictor -- are no longer refused: they are weighted equally, with a + # warning (test-review2-aoa.R). + expect_warning(w0 <- .aoa_weight_vector(c(a = 0, b = 0), v), + "every weight is zero") + expect_equal(w0, c(a = 1, b = 1)) expect_error(.aoa_weight_vector(c(a = "x", b = "y"), v), "must be numeric") expect_error(.aoa_weight_vector(c(a = 1, b = NA_real_), v), "finite") }) diff --git a/tests/testthat/test-audit-pass5.R b/tests/testthat/test-audit-pass5.R index c5aedcc..6ef4da6 100644 --- a/tests/testthat/test-audit-pass5.R +++ b/tests/testthat/test-audit-pass5.R @@ -195,7 +195,11 @@ test_that("nndm excludes a held-out point's co-located duplicate", { grid <- sf::st_as_sf(data.frame(x = c(-500, 900), y = 0), coords = c("x", "y"), crs = 3857) - f <- suppressMessages(make_folds(pts, method = "nndm", prediction_points = grid)) + # Six points against targets 500 away: every fold reaches min_train while + # still closer than the target, which make_folds() now says. + expect_warning( + f <- suppressMessages(make_folds(pts, method = "nndm", prediction_points = grid)), + "stopped the distance matching") D <- as.matrix(sf::st_distance(pts)); units(D) <- NULL expect_false(2L %in% f$folds[[1]]$train) # the twin is excluded @@ -224,7 +228,11 @@ test_that("nndm honours min_train exactly when n * min_train is fractional", { grid <- sf::st_as_sf(data.frame(x = c(-8000, 9000), y = c(-8000, 9000)), coords = c("x", "y"), crs = 3857) - f <- suppressMessages(make_folds(pts, method = "nndm", prediction_points = grid)) + # Reaching the floor is the point of this layout, so the floor warning is + # expected. + expect_warning( + f <- suppressMessages(make_folds(pts, method = "nndm", prediction_points = grid)), + "stopped the distance matching") sizes <- vapply(f$folds, function(z) length(z$train), integer(1)) # The rule is (n - 1 - removed) > n * min_train, so the smallest permitted # training set is 37 -- floor() left the matrix one column short and stopped @@ -498,13 +506,13 @@ test_that("a rejected sac cannot size a design effect", { nugget = 0), crs = sf::st_crs(32632)) - # Two: the supplied `sac` is refused, and the internal re-estimate on this - # small fixture is refused too. + # The supplied `sac` is refused, and the internal re-estimate on this small + # fixture is refused too: one fallback, so one warning, naming both. expect_warning( - expect_warning(out <- summarize_by_cell(pts, response_var = "resp", - deff = "variogram", sac = fake), - "no usable range"), - "no usable range") + out <- summarize_by_cell(pts, response_var = "resp", + deff = "variogram", sac = fake), + "supplied `sac` reports no usable range.*estimated from `response_var` reports no usable range", + class = "spatialkit_deff_fallback") expect_null(attr(out, "deff_applied")) iid <- summarize_by_cell(pts, response_var = "resp", deff = 1) expect_equal(out[["..se_resp_resp"]], iid[["..se_resp_resp"]], tolerance = 1e-10) @@ -530,8 +538,12 @@ test_that("duplicate cell IDs are reported", { pts <- .p5_assigned(nc = 3, np = 10) cells <- .p5_cells(nc = 3) cells$poly_id[3] <- 2L - expect_warning(summarize_by_cell(pts, response_var = "resp", cells_sf = cells), - "duplicated value") + # Renumbering cell 3 as 2 also leaves the points summarised under ID 3 + # with no cell, which is reported too. + expect_warning( + expect_warning(summarize_by_cell(pts, response_var = "resp", cells_sf = cells), + "duplicated value"), + "match no `cells_sf\\$poly_id`") }) @@ -719,10 +731,13 @@ test_that("the local collinearity check sees the intercept and singular windows" adaptive = TRUE, bandwidth = 20))))) # And quiet where there is nothing to report: a bandwidth wide enough to span - # the clusters gives every window both values of `urban`. + # the clusters gives every window both values of `urban`. .warns() swallows + # errors, so the fit is captured and checked: a fit that failed before the + # survey would also raise no warning, and pass for the wrong reason. expect_false(any(grepl("collinear local design", - .warns(fit_gwr_model(d, "z", c("a", "urban"), - adaptive = TRUE, bandwidth = 199))))) + .warns(fit199 <- fit_gwr_model(d, "z", c("a", "urban"), + adaptive = TRUE, bandwidth = 199))))) + expect_s3_class(fit199, "gwr_fit") # The intercept is what makes the constant indicator collinear, so a check on # the predictors alone cannot see it -- assert the arithmetic directly rather @@ -819,9 +834,13 @@ test_that("an implausible fixed bandwidth is called out", { .warns(fit_gwr_model(d, "z", "a", bandwidth = 0.2, adaptive = FALSE))))) # A bandwidth in the units the fit actually runs in draws no such warning. + # Captured and checked, since .warns() swallows errors: a fit that failed + # before the check would also raise no warning. expect_false(any(grepl("ten-thousandth", - .warns(fit_gwr_model(d, "z", "a", bandwidth = 5000, - adaptive = FALSE))))) + .warns(fit5k <- fit_gwr_model(d, "z", "a", + bandwidth = 5000, + adaptive = FALSE))))) + expect_s3_class(fit5k, "gwr_fit") }) diff --git a/tests/testthat/test-audit-pass6.R b/tests/testthat/test-audit-pass6.R index 7191170..dc043df 100644 --- a/tests/testthat/test-audit-pass6.R +++ b/tests/testthat/test-audit-pass6.R @@ -744,8 +744,11 @@ test_that("summarize_by_cell(deff = 'variogram') corrects the response SE with t explicit <- summarize_by_cell(pts, "z", predictor_vars = "p", deff = "variogram", sac = sac_resp) expect_equal(with_pred[["..se_resp_z"]], explicit[["..se_resp_z"]], tolerance = 1e-10) - residual <- summarize_by_cell(pts, "z", predictor_vars = "p", deff = "variogram", - sac = sac_resid) + # Used as given, but with a warning that the response SEs are understated. + expect_warning( + residual <- summarize_by_cell(pts, "z", predictor_vars = "p", deff = "variogram", + sac = sac_resid), + "residuals on predictors") expect_false(isTRUE(all.equal(with_pred[["..se_resp_z"]], residual[["..se_resp_z"]], tolerance = 1e-6))) }) diff --git a/tests/testthat/test-audit-pass7.R b/tests/testthat/test-audit-pass7.R index c0b6a91..dd4951f 100644 --- a/tests/testthat/test-audit-pass7.R +++ b/tests/testthat/test-audit-pass7.R @@ -46,7 +46,8 @@ test_that("residual_morans_i() validates k instead of silently collapsing it", { fit2 <- new_spatial_fit("t7fit", engine = lm(value ~ p1, data = sf::st_drop_geometry(d2)), formula = value ~ p1, response_var = "value", predictor_vars = "p1", data_sf = d2) - mi <- residual_morans_i(fit2) + # The dropped row is announced, and the warning is part of the contract. + expect_warning(mi <- residual_morans_i(fit2), "dropping 1 row") expect_true(is.finite(mi$observed)) expect_equal(mi$n, n - 1L) }) @@ -134,7 +135,7 @@ test_that("compare_models() says so when nothing is a spatial_fit", { # `met_df$AICc <- NA_real_` turned that into a bare list, after which # seq_len(nrow(NULL)) aborted with "argument must be coercible to # non-negative integer". - expect_error(compare_models(list(a = 1, b = 2)), "no element of `models`") + expect_error(compare_models(list(a = 1, b = 2)), "no element of `fits`") }) test_that("a fitted-value cache entry belongs to the engine that produced it", { diff --git a/tests/testthat/test-block-size-sweep.R b/tests/testthat/test-block-size-sweep.R index d6f435a..6cb0a42 100644 --- a/tests/testthat/test-block-size-sweep.R +++ b/tests/testthat/test-block-size-sweep.R @@ -52,21 +52,25 @@ test_that("the ladder respects the fit budget and the k-block floor", { expect_error(cv_block_size_sweep(pts, "z", "a", fit_fn = sweep_fit, k = 4, n_sizes = 20, quiet = TRUE), "20 block sizes x 4 folds \\+ 4 for the random reference = 84") - # With k = 5 the two-by-two grid at the top of the ladder holds too few - # blocks and is dropped before the budget is counted. + # With k = 5 the ladder tops out at the largest size whose grid still holds + # five cells (a 3 x 3 grid on this square), not at a 2 x 2 grid that would + # be dropped, so every one of the 20 sizes counts against the budget. expect_error(cv_block_size_sweep(pts, "z", "a", fit_fn = sweep_fit, k = 5, n_sizes = 20, quiet = TRUE), - "17 block sizes x 5 folds") - # Sizes whose grid holds fewer than k blocks are dropped (logged), and a - # ladder with nothing left is an error naming the extent. + "20 block sizes x 5 folds") + # Sizes the caller passed whose grid holds fewer than k blocks are not run, + # with a warning (and a log line), and a ladder with nothing left is an + # error naming the extent. lines <- capture_spatialkit_log( - sw <- cv_block_size_sweep(pts, "z", "a", fit_fn = sweep_fit, k = 4, - block_sizes = c(150, 600), include_random = FALSE, - sac = NA, quiet = TRUE), + expect_warning( + sw <- cv_block_size_sweep(pts, "z", "a", fit_fn = sweep_fit, k = 4, + block_sizes = c(150, 600), include_random = FALSE, + sac = NA, quiet = TRUE), + "`block_sizes` 600 give fewer than k = 4 blocks"), level = logger::INFO) expect_equal(nrow(sw), 1L) expect_equal(sw$block_size, 150) - expect_true(log_has(lines, "dropping 1 block size")) + expect_true(log_has(lines, "`block_sizes` 600 give fewer than k = 4 blocks")) expect_error(cv_block_size_sweep(pts, "z", "a", fit_fn = sweep_fit, k = 4, block_sizes = 600, quiet = TRUE), "no block size leaves at least k = 4 blocks") diff --git a/tests/testthat/test-build-tessellation.R b/tests/testthat/test-build-tessellation.R index efde4ae..910ea1b 100644 --- a/tests/testthat/test-build-tessellation.R +++ b/tests/testthat/test-build-tessellation.R @@ -449,15 +449,14 @@ test_that("build_tessellation() warns when a grid-sizing argument is ignored", { approx_n_cells = 9, quiet = TRUE)), "one triangle per neighbouring triple") - # The "`params` does not record it" clause belongs to voronoi alone: that - # branch returns create_voronoi_polygons()'s list, which has no slot for the - # argument, while the triangles branch echoes `approx_n_cells` back. An - # earlier form of this warning said it for both and was false for triangles. - expect_equal(tri$params$approx_n_cells, 9) + # Neither method records the ignored request in `params`, and both say so. + # The triangles branch used to echo `approx_n_cells` back, a count that + # sized nothing beside the "count used" the documentation promises there. + expect_null(tri$params$approx_n_cells) w_tri <- testthat::capture_warnings( suppressMessages(build_tessellation(pts, boundary = bnd, method = "triangles", approx_n_cells = 9, quiet = TRUE))) - expect_false(any(grepl("params", w_tri, fixed = TRUE))) + expect_match(w_tri, "`params` does not record the request") w_vor <- testthat::capture_warnings( suppressMessages(build_tessellation(pts, boundary = bnd, method = "voronoi", approx_n_cells = 9, quiet = TRUE))) diff --git a/tests/testthat/test-fold-methods.R b/tests/testthat/test-fold-methods.R index baf68dc..dd660cd 100644 --- a/tests/testthat/test-fold-methods.R +++ b/tests/testthat/test-fold-methods.R @@ -152,10 +152,12 @@ test_that("nndm leaves LOO alone when it already matches the target", { expect_true(all(vapply(f$folds, function(z) length(z$train), integer(1)) >= 2L)) }) -# A hand-coded transcription of the paper's algorithm (Mila et al. 2022, as -# in CAST::nndm): recompute both ECDFs after every removal and push the -# smallest violator. Slow but obviously correct, so the package's sweep can -# be held to it. +# A hand-coded transcription of the paper's algorithm (Mila et al. 2022): +# recompute both ECDFs after every removal and push the smallest violator. +# Slow but obviously correct, so the package's sweep can be held to it. The +# violation test is the package's strict one (realised ECDF > target); +# CAST::nndm() instead removes only while (count - 1)/n >= target, one point +# fewer per distance value, so this is not a transcription of CAST. # # Ties in the smallest violator -- every mutual-nearest-neighbour pair shares # one distance, and pushed points pile up at one cluster-to-cluster distance @@ -288,7 +290,12 @@ test_that("nndm is deterministic and honours min_train and phi", { # min_train caps how far any training set can be stripped ... for (mt in c(0.5, 0.8)) { - f <- make_folds(fx$pts, method = "nndm", prediction_points = fx$grid, min_train = mt) + # At 0.8 the floor stops the matching short, which is warned about. + f <- withCallingHandlers( + make_folds(fx$pts, method = "nndm", prediction_points = fx$grid, min_train = mt), + warning = function(w) if (mt > 0.5 && grepl("stopped the distance matching", + conditionMessage(w))) + invokeRestart("muffleWarning")) expect_true(all(vapply(f$folds, function(z) length(z$train), integer(1)) >= mt * 80 - 1)) expect_equal(f$params$min_train, mt) } diff --git a/tests/testthat/test-followups-convergence-crs.R b/tests/testthat/test-followups-convergence-crs.R new file mode 100644 index 0000000..bb9bff3 --- /dev/null +++ b/tests/testthat/test-followups-convergence-crs.R @@ -0,0 +1,152 @@ +# tests/testthat/test-followups-convergence-crs.R +# --------------------------------------------------------------------------- +# A Bayesian fit whose sampler did not converge is flagged where fits are +# scored (cv_bayes(), compare_models()), not only in the log; and +# predict_surface() aligns a CRS-less `grid` or `covariates` with an R +# warning, as it does `boundary`. The Bayesian backend is mocked with +# helper-lmfit.R's lm fit, so no Stan toolchain is needed. +# --------------------------------------------------------------------------- + +.fu_pts <- function(n = 60, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 5 + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +# The lm stand-in, carrying the convergence verdict fit_bayesian_spatial_model() +# records in $info$convergence_ok. +.fu_fit <- function(d, ok) { + f <- lm_spatial_fit(d, "z", "w") + f$info$convergence_ok <- ok + f +} + +test_that("cv_bayes() marks folds whose sampler did not converge and warns once", { + d <- .fu_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + verdicts <- c(TRUE, FALSE, TRUE) + i <- 0L + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) { + i <<- i + 1L + .fu_fit(data_sf, verdicts[i]) + }, + .package = "spatialkit") + + ws <- character(0) + cv <- withCallingHandlers( + suppressMessages(cv_bayes(d, "z", "w", folds = f, seed = 1)), + warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + + expect_true("convergence_ok" %in% names(cv$fold_metrics)) + expect_identical(cv$fold_metrics$convergence_ok, verdicts) + conv <- grep("did not converge", ws, value = TRUE) + expect_length(conv, 1L) + expect_match(conv, "in 1 of 3 fold\\(s\\) \\(fold 2\\)") + expect_match(conv, "fold_metrics$convergence_ok", fixed = TRUE) +}) + +test_that("cv_bayes() stays quiet when every fold converged or none was checked", { + d <- .fu_pts() + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + for (ok in list(TRUE, NA)) { + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) .fu_fit(data_sf, ok), + .package = "spatialkit") + ws <- character(0) + cv <- withCallingHandlers( + suppressMessages(cv_bayes(d, "z", "w", folds = f, seed = 1)), + warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + expect_identical(cv$fold_metrics$convergence_ok, rep(ok, 3L)) + expect_false(any(grepl("did not converge", ws))) + } +}) + +test_that("an all-failed cv_bayes() run still has the convergence_ok column", { + d <- .fu_pts() + local_mocked_bindings( + fit_bayesian_spatial_model = function(...) stop("no fit here"), + .package = "spatialkit") + cv <- suppressWarnings(suppressMessages(cv_bayes(d, "z", "w", k = 3, seed = 1))) + expect_true("convergence_ok" %in% names(cv$fold_metrics)) + expect_type(cv$fold_metrics$convergence_ok, "logical") +}) + +test_that("compare_models() carries convergence_ok and warns about a non-converged fit", { + d <- .fu_pts() + as_bayes <- function(f) { + class(f) <- c(class(f)[1L], "bayesian_fit", class(f)[-1L]) + f + } + fits <- list(ok = as_bayes(.fu_fit(d, TRUE)), + bad = as_bayes(.fu_fit(d, FALSE)), + unknown = as_bayes(.fu_fit(d, NA)), + plain = lm_spatial_fit(d, "z", "w")) + ws <- character(0) + cmp <- withCallingHandlers( + compare_models(fits), + warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + got <- stats::setNames(cmp$convergence_ok, cmp$model) + expect_identical(unname(got[c("ok", "bad", "unknown", "plain")]), + c(TRUE, FALSE, NA, NA)) + conv <- grep("did not converge", ws, value = TRUE) + expect_length(conv, 1L) + expect_match(conv, "'bad'", fixed = TRUE) +}) + +test_that("predict_surface() warns when it stamps or reprojects a CRS-less grid or covariates", { + d <- .fu_pts() + fit <- lm_spatial_fit(d, "z", "w") + + # Projected-looking coordinates without a CRS: stamped with the fit's CRS. + grid <- sf::st_as_sf(data.frame(x = 5e5 + c(100, 500, 900), + y = 5e6 + c(100, 500, 900), w = 0), + coords = c("x", "y")) + expect_warning(s <- predict_surface(fit, grid = grid), + "predict_surface\\(\\): `grid` has no CRS.*stamping") + expect_equal(sf::st_crs(s), sf::st_crs(d)) + expect_equal(nrow(s), 3L) + + # The same for the covariates layer, named as such. + g2 <- sf::st_as_sf(data.frame(x = 5e5 + c(200, 700), y = 5e6 + c(300, 800)), + coords = c("x", "y"), crs = 32632) + cov <- sf::st_as_sf(data.frame(x = 5e5 + c(200, 700), y = 5e6 + c(300, 800), + w = c(1, 2)), + coords = c("x", "y")) + expect_warning(s2 <- predict_surface(fit, grid = g2, covariates = cov), + "predict_surface\\(\\): `covariates` has no CRS.*stamping") + expect_equal(s2$w, c(1, 2)) + + # Lon/lat-looking coordinates are reprojected from EPSG:4326, with a warning. + ll <- sf::st_coordinates(sf::st_transform(g2, 4326)) + g3 <- sf::st_as_sf(data.frame(x = ll[, 1], y = ll[, 2], w = 0), + coords = c("x", "y")) + expect_warning(s3 <- predict_surface(fit, grid = g3), + "predict_surface\\(\\): `grid` has no CRS; its coordinates look like lon/lat") + expect_equal(unname(sf::st_coordinates(s3)), unname(sf::st_coordinates(g2)), + tolerance = 1e-3) + + # A grid that has a CRS is used without any such warning. + ws <- character(0) + withCallingHandlers(predict_surface(fit, grid = sf::st_set_crs(grid, 32632)), + warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + expect_false(any(grepl("has no CRS", ws))) +}) diff --git a/tests/testthat/test-gp-boundary.R b/tests/testthat/test-gp-boundary.R new file mode 100644 index 0000000..19df66c --- /dev/null +++ b/tests/testthat/test-gp-boundary.R @@ -0,0 +1,236 @@ +# tests/testthat/test-gp-boundary.R +# --------------------------------------------------------------------------- +# predict.bayesian_fit() holds the HSGP boundary L at its fitted value. +# +# brms 2.17 to 2.22 rebuild L = c * max(1, pooled range of the unique newdata +# rows centred on the training cmeans) at every predict call. Appending the +# training extrema (.pin_gp_boundary_rows()) can only widen that range, so one +# row past the training envelope widened L and moved the prediction of EVERY +# row in the call, and predict_surface() depended on chunk_size. The repair +# hands brms c * S_fit / S_new instead of c. The arithmetic is tested here +# without Stan; the last two tests fit a real model and are opt-in, like +# test-bayes-smoke.R. +# --------------------------------------------------------------------------- + +# brms:::choose_L() applied the way brms:::.data_gp() applies it. +brms_L <- function(xy, cmeans, c) { + Xc <- sweep(unique(as.matrix(xy)[, 1:2, drop = FALSE]), 2L, cmeans) + c * max(1, max(Xc) - min(Xc)) +} + +gpb_train_xy <- function(n = 60, seed = 3) { + set.seed(seed) + xy <- cbind(runif(n, -2, 1.5), runif(n, -1, 2.5)) + rbind(xy, xy[1:5, ]) # replicated locations, as brms sees them +} + +gpb_fake_fit <- function(xy, c = 1.6, store_cmeans = TRUE) { + spec <- spatialkit:::.gp_basis_spec(xy, c(lower = 0.3, upper = 1)) + info <- list(gp_c = c, gp_S = spec$S, + gp_xy_range = list(x = range(xy[, 1]), y = range(xy[, 2]))) + if (store_cmeans) info$gp_cmeans <- spec$cmeans + structure(list(info = info, + engine = list(data = data.frame(..x = xy[, 1], ..y = xy[, 2], + a = 0))), + class = c("bayesian_fit", "spatial_fit")) +} + +test_that(".gp_basis_spec returns the centre brms uses", { + xy <- gpb_train_xy() + spec <- spatialkit:::.gp_basis_spec(xy, c(lower = 0.3, upper = 1)) + u <- unique(xy) + expect_equal(spec$cmeans, unname(colMeans(u))) + expect_equal(brms_L(xy, spec$cmeans, 1), spec$S) +}) + +test_that(".gp_c_scale makes brms rebuild the fitted L from any rows", { + xy <- gpb_train_xy() + spec <- spatialkit:::.gp_basis_spec(xy, c(lower = 0.3, upper = 1)) + c_fit <- 1.6 + L_fit <- brms_L(xy, spec$cmeans, c_fit) + expect_equal(L_fit, c_fit * spec$S) + + set.seed(9) + cases <- list( + wider = rbind(xy, c(4, 0.5)), # one row far out + both = rbind(xy[1:3, ], c(-5, 6), c(-5, 6)), # widened, duplicated + narrow = matrix(c(0.1, 0.2, 0.15, 0.25), 2), # range < 1: brms's floor + single = matrix(c(0.3, 0.4), 1), + training = xy + ) + for (nm in names(cases)) { + nd <- cases[[nm]] + s <- spatialkit:::.gp_c_scale(nd, spec$cmeans, spec$S) + expect_equal(brms_L(nd, spec$cmeans, c_fit * s), L_fit, tolerance = 1e-12, + info = nm) + } + expect_identical(spatialkit:::.gp_c_scale(xy, spec$cmeans, spec$S), 1) + expect_identical(spatialkit:::.gp_c_scale(matrix(NA_real_, 1, 2), + spec$cmeans, spec$S), 1) +}) + +test_that(".pin_gp_boundary_rows scales c only when the rows widen the range", { + xy <- gpb_train_xy() + fit <- gpb_fake_fit(xy) + inside <- data.frame(a = 0, ..x = c(0, 0.5), ..y = c(1, 0)) + p_in <- spatialkit:::.pin_gp_boundary_rows(fit, inside) + expect_identical(p_in$n_pad, 2L) + expect_identical(p_in$c_scale, 1) # the padding rows alone are exact + expect_identical(p_in$beyond, c(FALSE, FALSE)) + + out <- rbind(inside, data.frame(a = 0, ..x = 3, ..y = 3)) + p_out <- spatialkit:::.pin_gp_boundary_rows(fit, out) + expect_lt(p_out$c_scale, 1) + expect_equal(brms_L(cbind(p_out$df$..x, p_out$df$..y), fit$info$gp_cmeans, + fit$info$gp_c * p_out$c_scale), + fit$info$gp_c * fit$info$gp_S, tolerance = 1e-12) + + # A fit saved before gp_cmeans was stored reads the centre off the brmsfit's + # data, as brms did, and gets the same answer. + old <- gpb_fake_fit(xy, store_cmeans = FALSE) + expect_equal(spatialkit:::.pin_gp_boundary_rows(old, out)[c("c_scale", "beyond")], + p_out[c("c_scale", "beyond")]) +}) + +test_that(".pin_gp_boundary_rows flags rows beyond +/- L of the training centre", { + xy <- gpb_train_xy() + fit <- gpb_fake_fit(xy) + cm <- fit$info$gp_cmeans + L <- fit$info$gp_c * fit$info$gp_S + nd <- data.frame(a = 0, + ..x = cm[1] + c(0, 0.99 * L, 1.01 * L, 0, -1.2 * L), + ..y = cm[2] + c(0, 0, 0, -1.01 * L, 0)) + expect_identical(spatialkit:::.pin_gp_boundary_rows(fit, nd)$beyond, + c(FALSE, FALSE, TRUE, TRUE, TRUE)) +}) + +test_that(".scale_gp_c rescales c in the gp() term the package builds, and nothing else", { + f <- stats::as.formula(paste("resp ~ z + w +", + spatialkit:::.gp_formula_term(12L, 1.5))) + obj <- list(formula = list(formula = f), other = 1) + got <- spatialkit:::.scale_gp_c(obj, 0.5) + gp_call <- got$formula$formula[[3L]][[3L]] + expect_identical(gp_call[[1L]], as.name("gp")) + expect_identical(gp_call[["c"]], 0.75) + gp_call[["c"]] <- 1.5 + expect_identical(gp_call, f[[3L]][[3L]]) # k, scale, iso untouched + expect_identical(got$formula$formula[[2L]], f[[2L]]) + expect_identical(got$other, 1) + + expect_null(spatialkit:::.scale_gp_c(list(formula = list(formula = resp ~ z)), 0.5)) +}) + + +# --------------------------------------------------------------------------- +# Real brms. Opt-in via SPATIALKIT_TEST_BRMS; see test-bayes-smoke.R. +# --------------------------------------------------------------------------- + +gpb_points <- function(n = 50, seed = 11) { + set.seed(seed) + x <- runif(n, 0, 1000) + y <- runif(n, 0, 1000) + a <- rnorm(n) + # A surface with real spatial structure, so the GP term carries the fit. + resp <- 2 * sin(x / 250) + 1.5 * cos(y / 300) + 0.5 * a + rnorm(n, sd = 0.3) + sf::st_as_sf(data.frame(x = x, y = y, a = a, resp = resp), + coords = c("x", "y"), crs = 32632) +} + +gpb_cache <- new.env(parent = emptyenv()) +gpb_fit <- function() { + if (is.null(gpb_cache$fit)) { + fit <- NULL + utils::capture.output( + suppressWarnings(suppressMessages( + fit <- fit_bayesian_spatial_model( + gpb_points(), response_var = "resp", predictor_vars = "a", + chains = 1, iter = 300, warmup = 150, cores = 1, + compute_loo = FALSE, check_convergence = FALSE, seed = 4321) + )), + type = "output" + ) + gpb_cache$fit <- fit + } + gpb_cache$fit +} + +gpb_sf <- function(x, y) { + sf::st_as_sf(data.frame(x = x, y = y, a = 0), coords = c("x", "y"), crs = 32632) +} + +test_that("an out-of-envelope row does not move the other rows' predictions", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan smoke tests") + skip_if_not_installed("brms") + + fit <- gpb_fit() + bb <- sf::st_bbox(fit$data_sf) + ix <- c(500, 300, 700); iy <- c(500, 700, 250) + far_x <- bb[["xmax"]] + 0.1 * (bb[["xmax"]] - bb[["xmin"]]) + far_y <- bb[["ymax"]] + 0.1 * (bb[["ymax"]] - bb[["ymin"]]) + + # The far row must widen the range brms builds L from, or this proves nothing. + cs <- fit$info$coord_scaling + tr <- cbind(fit$engine$data$..x, fit$engine$data$..y) + cm <- colMeans(unique(tr)) + far_c <- c((far_x - cs$x_center) / cs$x_scale, + (far_y - cs$y_center) / cs$y_scale) - cm + expect_gt(max(far_c), max(sweep(tr, 2L, cm))) + + p_inner <- suppressMessages(predict(fit, newdata = gpb_sf(ix, iy))) + p_alone <- vapply(1:3, function(i) + suppressMessages(predict(fit, newdata = gpb_sf(ix[i], iy[i]))), numeric(1)) + p_far <- suppressMessages(predict(fit, newdata = gpb_sf(c(ix, far_x), + c(iy, far_y)))) + d_far <- suppressMessages(predict(fit, newdata = gpb_sf(c(ix, far_x), + c(iy, far_y)), + draws = TRUE)) + d_inner <- suppressMessages(predict(fit, newdata = gpb_sf(ix, iy), draws = TRUE)) + + expect_true(all(is.finite(p_far))) + expect_equal(p_alone, p_inner, tolerance = 1e-10) + # Before the fix these moved by ~1e-2 on a response of SD ~1.5. + expect_equal(p_far[1:3], p_inner, tolerance = 1e-10) + expect_equal(d_far[, 1:3], d_inner, tolerance = 1e-10) + # In-sample prediction is untouched. + expect_equal(suppressMessages(predict(fit, newdata = fit$data_sf)), fitted(fit), + tolerance = 1e-10) + + # A row past the edge of the basis is NA, with a warning, and still moves + # nothing else. + L <- fit$info$gp_c * fit$info$gp_S + wx <- cs$x_center + (cm[1] + 1.1 * L) * cs$x_scale + expect_warning( + p_wall <- suppressMessages(predict(fit, newdata = gpb_sf(c(ix, wx), c(iy, 500)))), + "^predict\\.bayesian_fit\\(\\): 1 of 4 row\\(s\\) of `newdata` lie beyond the GP boundary") + expect_true(is.na(p_wall[4])) + expect_equal(p_wall[1:3], p_inner, tolerance = 1e-10) +}) + +test_that("predict_surface() on a grid past the training bbox does not depend on chunk_size", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan smoke tests") + skip_if_not_installed("brms") + + fit <- gpb_fit() + bb <- sf::st_bbox(fit$data_sf) + w <- bb[["xmax"]] - bb[["xmin"]]; h <- bb[["ymax"]] - bb[["ymin"]] + g <- expand.grid(x = seq(bb[["xmin"]] - 0.15 * w, bb[["xmax"]] + 0.15 * w, + length.out = 16), + y = seq(bb[["ymin"]] - 0.15 * h, bb[["ymax"]] + 0.15 * h, + length.out = 16)) + grid <- gpb_sf(g$x, g$y) + inb <- g$x >= bb[["xmin"]] & g$x <= bb[["xmax"]] & + g$y >= bb[["ymin"]] & g$y <= bb[["ymax"]] + + one <- suppressMessages(predict_surface(fit, grid = grid, chunk_size = 1e6))$.pred + many <- suppressMessages(predict_surface(fit, grid = grid, chunk_size = 23))$.pred + in_bb <- suppressMessages(predict_surface(fit, grid = grid[inb, ], + chunk_size = 1e6))$.pred + + expect_true(all(is.finite(one))) + expect_equal(many, one, tolerance = 1e-10) + expect_equal(one[inb], in_bb, tolerance = 1e-10) +}) diff --git a/tests/testthat/test-gwr-bandwidth.R b/tests/testthat/test-gwr-bandwidth.R index 3c0c639..14c8bcd 100644 --- a/tests/testthat/test-gwr-bandwidth.R +++ b/tests/testthat/test-gwr-bandwidth.R @@ -93,7 +93,11 @@ test_that("a successful bandwidth selection is not labelled a fallback", { kernel = "bisquare", adaptive = TRUE))) expect_equal(auto$info$bandwidth, ref) expect_true(is.finite(auto$info$AICc)) - small <- fit_gwr_model(dat, "y", "x1", bandwidth = 5, adaptive = TRUE) + # Four-point windows: the local collinearity survey (which covers a single + # predictor, since the intercept is in every design) flags a couple of them. + small <- suppressWarnings( + fit_gwr_model(dat, "y", "x1", bandwidth = 5, adaptive = TRUE)) + expect_true(is.finite(small$info$AICc)) expect_lt(auto$info$AICc, small$info$AICc) }) @@ -125,19 +129,21 @@ test_that("fit_gwr_model fits a two-valued NON-INTEGER response with a warning", 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), + # 60 neighbours of 60 points: the widest adaptive window. (300 was capped + # to 60 in silence; a count above n now warns.) + expect_warning(fit <- fit_gwr_model(censored, "z", "a", bandwidth = 60), "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), + expect_warning(fit_gwr_model(censored, "z", "a", bandwidth = 60), "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), + expect_error(fit_gwr_model(binary, "z", "a", bandwidth = 60), "is binary \\(2 distinct values") - expect_error(fit_gwr_model(binary, "z", "a", bandwidth = 300), + expect_error(fit_gwr_model(binary, "z", "a", bandwidth = 60), "family = 'binomial'") }) @@ -151,7 +157,7 @@ test_that("the two-valued response guard sits behind the GWmodel requirement", { "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), + expect_error(fit_gwr_model(.gwr2v_points(z), "z", "a", bandwidth = 60), "package 'GWmodel' is required") } }) diff --git a/tests/testthat/test-gwr-local-collinearity.R b/tests/testthat/test-gwr-local-collinearity.R index 81149a0..bf356ab 100644 --- a/tests/testthat/test-gwr-local-collinearity.R +++ b/tests/testthat/test-gwr-local-collinearity.R @@ -41,14 +41,16 @@ lc_clusters <- function(seed = 5) { test_that("the kernel weights are GWmodel's definitions", { w <- spatialkit:::.gw_kernel_weights d <- c(0, 50, 100, 150) - expect_equal(w(d, 100, "boxcar", FALSE), c(1, 1, 0, 0)) + # GWmodel's boxcar keeps a point exactly at the edge (d <= h), so a grid + # with a fixed boxcar bandwidth equal to the spacing fits 3-5 point windows. + expect_equal(w(d, 100, "boxcar", FALSE), c(1, 1, 1, 0)) expect_equal(w(d, 100, "bisquare", FALSE), c(1, (1 - 0.25)^2, 0, 0)) expect_equal(w(d, 100, "tricube", FALSE), c(1, (1 - 0.125)^3, 0, 0)) expect_equal(w(d, 100, "gaussian", FALSE), exp(-0.5 * (d / 100)^2)) expect_equal(w(d, 100, "exponential", FALSE), exp(-d / 100)) # Adaptive: the distance parameter is the bw-th nearest distance. expect_equal(w(d, 3, "bisquare", TRUE), c(1, (1 - 0.25)^2, 0, 0)) - expect_equal(w(d, 4, "boxcar", TRUE), c(1, 1, 1, 0)) + expect_equal(w(d, 4, "boxcar", TRUE), c(1, 1, 1, 1)) }) test_that("the survey is the weighted condition index at every location", { @@ -57,7 +59,7 @@ test_that("the survey is the weighted condition index at every location", { xm <- as.matrix(sf::st_drop_geometry(pts)[, c("a", "b")]) sv <- spatialkit:::.gwr_local_collinearity(xy, xm, adaptive = TRUE, bw = 40, kernel = "bisquare") expect_equal(nrow(sv), nrow(pts)) - expect_equal(names(sv), c("row", "x", "y", "n_window", "cn")) + expect_equal(names(sv), c("row", "x", "y", "n_window", "cn", "cn_slopes")) expect_true(all(sv$n_window == 39L)) # the 40th neighbour has weight 0 expect_true(all(is.finite(sv$cn) & sv$cn >= 1)) for (i in c(1L, 77L, 200L)) { @@ -67,9 +69,12 @@ test_that("the survey is the weighted condition index at every location", { } # A window with fewer usable rows than columns is singular, not NA. expect_true(all(is.infinite(spatialkit:::.gwr_local_collinearity(xy[1:3, ], xm[1:3, ], TRUE, 2, "boxcar")$cn))) - # Nothing to survey with one predictor. + # One predictor is surveyed too: the design is the intercept plus it. one <- spatialkit:::.gwr_local_collinearity(xy, xm[, 1, drop = FALSE], TRUE, 40, "bisquare") - expect_true(all(is.na(one$cn))) + expect_true(all(is.finite(one$cn) & one$cn >= 1)) + d <- sqrt((xy[, 1] - xy[77, 1])^2 + (xy[, 2] - xy[77, 2])^2) + h <- sort(d)[40]; w <- ifelse(d / h < 1, (1 - (d / h)^2)^2, 0); keep <- w > 1e-8 + expect_equal(one$cn[77], spatialkit:::.condition_index(sqrt(w[keep]) * cbind(1, xm[, 1])[keep, ])) }) test_that("fit_gwr_model() keeps the survey and the global index on the fit", { @@ -84,18 +89,26 @@ test_that("fit_gwr_model() keeps the survey and the global index on the fit", { expect_equal(fit$info$n_local_collinear, 0L) expect_equal(fit$info$n_local_singular, 0L) expect_true(is.finite(fit$info$condition_index)) + # The global index is on the centred predictors. + xab <- as.matrix(sf::st_drop_geometry(pts)[, c("a", "b")]) expect_equal(fit$info$condition_index, - spatialkit:::.condition_index(cbind(1, as.matrix(sf::st_drop_geometry(pts)[, c("a", "b")])))) + spatialkit:::.condition_index(cbind(1, sweep(xab, 2L, colMeans(xab))))) # It is the survey at the bandwidth actually used. ref <- spatialkit:::.gwr_local_collinearity(sf::st_coordinates(pts), as.matrix(sf::st_drop_geometry(pts)[, c("a", "b")]), TRUE, 60, "bisquare") expect_equal(lc$cn, ref$cn) - # One predictor: nothing surveyed, NA index. + # One predictor: surveyed as well, since the intercept is in every design. fit1 <- suppressWarnings(suppressMessages(fit_gwr_model(pts, "z", "a", adaptive = TRUE, bandwidth = 60))) - expect_null(fit1$info$local_collinearity) - expect_true(is.na(fit1$info$condition_index)) - expect_true(is.na(fit1$info$n_local_collinear)) + expect_s3_class(fit1$info$local_collinearity, "data.frame") + expect_equal(fit1$info$local_collinearity$cn, + spatialkit:::.gwr_local_collinearity(sf::st_coordinates(pts), + as.matrix(sf::st_drop_geometry(pts)[, "a", drop = FALSE]), + TRUE, 60, "bisquare")$cn) + expect_equal(fit1$info$condition_index, + spatialkit:::.condition_index(cbind(1, pts$a - mean(pts$a)))) + expect_equal(fit1$info$condition_index, 1) + expect_equal(fit1$info$n_local_collinear, 0L) }) test_that("the collinearity warning is the exact fraction, and quiet when there is nothing", { diff --git a/tests/testthat/test-gwr-model-selection.R b/tests/testthat/test-gwr-model-selection.R index 026668f..44e0051 100644 --- a/tests/testthat/test-gwr-model-selection.R +++ b/tests/testthat/test-gwr-model-selection.R @@ -332,6 +332,40 @@ test_that("gwr_model_selection keeps partially-failed sweeps but ranks failures expect_true(all(is.na(sel$table$criterion[3:6]))) }) +test_that("gwr_model_selection ranks a model whose AICc is below its AIC last", { + # GWmodel's AICc exceeds its AIC exactly when tr(S) < n - 2, the formula's + # domain; outside it an interpolating model scores a huge negative AICc. + # The table is GWmodel's unlabelled c(bandwidth, AIC, AICc, RSS). + aicc <- c(120, 118, 125, 110, 119, -5000) + aic <- c(100, 100, 100, 100, 100, 60) + eng <- function(...) { + ml <- list(list("z", "a"), list("z", "b"), list("z", "cc"), + list("z", c("a", "b")), list("z", c("a", "cc")), + list("z", c("a", "b", "cc"))) + m <- cbind(30, aic, aicc, 1) + colnames(m) <- NULL + list(model_list = ml, gwr_df = m, bandwidth = 30, + bandwidth_source = "supplied", used_dmat = FALSE, + raw = list(ml, m)) + } + pts <- mk_sel_pts() + expect_warning( + sel <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, + .engine = eng), + "AICc is undefined for 1 of 6 model\\(s\\) at bandwidth 30") + expect_identical(sel$best, c("a", "b")) + expect_true(is.na(sel$table$criterion[6])) + expect_identical(sel$table$variables[6], "a + b + cc") + # A table whose AIC column cannot be located is left as it is; a labelled + # one is read by name. + two <- unname(cbind(aic, aicc)) + expect_null(.gwr_ms_aic_column(two, .gwr_ms_criterion(two))) + lab <- cbind(bw = 30, AIC = aic, AICc = aicc) + expect_identical(.gwr_ms_aic_column(lab, .gwr_ms_criterion(lab)), aic) + expect_identical(.gwr_aicc_undefined(c(1, 5, NA, 2, 3), c(2, 5, 9, -Inf, NA)), + c(FALSE, TRUE, FALSE, TRUE, FALSE)) +}) + test_that("print.gwr_model_selection shows the ranking and states the caveats", { pts <- mk_sel_pts() sel <- gwr_model_selection(pts, "z", c("a", "b", "cc"), bandwidth = 30, @@ -405,7 +439,7 @@ test_that("gwr_model_selection selects a bandwidth when none is supplied", { expect_identical(nrow(sel$table), 3L) # 2 + 1 expect_match(sel$bandwidth_source, "bw\\.gwr") expect_true(is.finite(sel$bandwidth)) - expect_gte(sel$bandwidth, 4L) # n_cand + 2 floor + expect_gte(sel$bandwidth, 5L) # bisquare floor, n_cand + 3 expect_lte(sel$bandwidth, 60L) expect_true("a" %in% sel$best) }) diff --git a/tests/testthat/test-kriging-adequacy.R b/tests/testthat/test-kriging-adequacy.R index 469128e..c163590 100644 --- a/tests/testthat/test-kriging-adequacy.R +++ b/tests/testthat/test-kriging-adequacy.R @@ -1,8 +1,9 @@ # tests/testthat/test-kriging-adequacy.R # --------------------------------------------------------------------------- # kriging_adequacy(): per-cell block-kriging variance from a fitted -# variogram, its ratio to the sill, the comparison with s^2/n, and the -# blocked cross-validation statistic of the kriging variance. +# variogram, its ratio to the cell's no-data variance, the comparison with +# s^2/n, the blocked cross-validation statistic of the kriging variance, and +# repeat measurements at one location. # --------------------------------------------------------------------------- ka_field <- function(n = 240, seed = 1, psill = 0.8, nugget = 0.2, a = 100) { @@ -35,7 +36,7 @@ test_that("the diagnostics are computed per cell and the CV statistic is near 1 expect_true(all(is.finite(df$kr_pred))) expect_true(all(df$kr_var >= 0)) expect_true(all(df$kr_ratio >= 0 & df$kr_ratio <= 1)) - # A well-sampled cell's block variance is a small share of the sill. + # A well-sampled cell's block variance is a small share of its no-data variance. expect_lt(stats::median(df$kr_ratio), 0.2) # The plain means agree with summarize_by_cell()'s. sm <- summarize_by_cell(asg, response_var = "z") @@ -153,3 +154,361 @@ test_that("print() survives a subset that no longer carries the fitted summary", expect_output(print(bare), "blocked CV: not computed") }) + +# gstat's own variance of a cell mean with no data, C(B,B) on its own +# discretisation and nugget handling: simple kriging from one datum so far +# away that its covariance with every cell is exactly zero. +ka_gstat_prior <- function(cells, vm) { + far <- sf::st_sf(z = 0, geometry = sf::st_sfc(sf::st_point(c(1e9, 1e9)), + crs = sf::st_crs(cells))) + as.numeric(gstat::krige(z ~ 1, far, cells, model = vm, beta = 0, debug.level = 0)$var1.var) +} + +test_that("kr_ratio is over each cell's no-data variance, so a cell the data do not reach reads 1", { + skip_if_not_installed("gstat") + # kr_var is the variance of a cell MEAN; it was divided by the point sill, + # which a cell mean never reaches, so empty cells 130-410 m beyond a 90 m + # effective range read about 0.1 and print() said no cell was above 0.5. + set.seed(11); n <- 240 + x <- runif(n, 0, 500); y <- runif(n, 0, 1000) # the western half only + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(0.8 * exp(-d / 30) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(pts, cells) + vm <- gstat::vgm(psill = 0.8, "Exp", range = 30, nugget = 0.2) + ka <- kriging_adequacy(asg, "z", cells, sac = structure(90, class = "sac_range", + variogram_model = vm), + k = 4, seed = 1) + df <- sf::st_drop_geometry(ka) + empty <- df$n == 0L + expect_equal(sum(empty), 8L) + expect_true(all(df$kr_var[empty] < 0.2)) # far below the point sill of 1 + expect_true(all(df$kr_ratio[empty] > 0.99)) + expect_true(all(df$kr_ratio[!empty] < min(df$kr_ratio[empty]))) + # The denominator is the cell's C(B,B) as gstat block-kriges it. + prior <- ka_gstat_prior(cells, vm) + expect_equal(df$kr_ratio, pmin(df$kr_var / prior, 1), tolerance = 1e-5) + expect_output(print(ka), sprintf("no-data variance of the cell mean .* %d cell\\(s\\) above 0.5", + sum(df$kr_ratio > 0.5))) + expect_gte(sum(df$kr_ratio > 0.5), 8L) +}) + +test_that("a large empty cell ranks above small populated ones on kr_ratio", { + skip_if_not_installed("gstat") + # With unequal cells, as Voronoi and Delaunay tessellations make them, the + # ratio over the sill ranked a 600 x 1000 m cell with no data below + # populated 100 m cells, because a big cell's mean varies little. + set.seed(4); n <- 300 + x <- runif(n, 0, 400); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(0.8 * exp(-d / 100) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + sq <- function(x0, x1, y0, y1) sf::st_polygon(list(rbind(c(x0, y0), c(x1, y0), c(x1, y1), + c(x0, y1), c(x0, y0)))) + small <- sf::st_make_grid(sf::st_sfc(sq(0, 400, 0, 1000), crs = 32632), cellsize = 100) + cells <- sf::st_sf(poly_id = seq_len(length(small) + 1L), + geometry = c(small, sf::st_sfc(sq(400, 1000, 0, 1000), crs = 32632))) + asg <- assign_features_to_polygons(pts, cells) + df <- sf::st_drop_geometry(kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), k = 4, seed = 1)) + big <- df$poly_id == nrow(cells) + expect_equal(df$n[big], 0L) + expect_gt(df$kr_ratio[big], 0.99) + expect_true(all(df$kr_ratio[!big] < 0.5)) + expect_gt(df$kr_ratio[big], max(df$kr_ratio[!big])) +}) + + +# Stations visited three times: a smooth field sampled at 80 sites, each visit +# with its own measurement error of variance `me_var`. +ka_revisits <- function(me_var, seed = 5) { + st <- ka_field(n = 80, seed = seed, nugget = 0) + set.seed(seed + 1) + v <- rbind(st, st, st) + v$z <- v$z + stats::rnorm(nrow(v), sd = sqrt(me_var)) + v +} + +test_that("repeat visits to a station are kriged from their means instead of coming back NA", { + skip_if_not_installed("gstat") + # Two observations at one location get the full sill as their covariance in + # gstat, so every kriging system holding a pair was singular: 80 stations x + # 3 visits gave NA in all 16 cells and no CV prediction, with no warning. + rv <- ka_revisits(me_var = 0.4) # visits differ by more than the 0.2 nugget + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(rv, cells) + vm <- attr(ka_true_sac(), "variogram_model") + expect_warning(ka <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), k = 4, + seed = 1, nmax = 1000), + "240 point\\(s\\) share a location .* 80 distinct locations") + df <- sf::st_drop_geometry(ka) + expect_true(all(is.finite(df$kr_pred)) && all(is.finite(df$kr_var))) + expect_equal(sum(df$n), 240L) # plain means use every visit + expect_equal(attr(ka, "n_points"), 240L) + expect_equal(attr(ka, "n_locations"), 80L) + expect_equal(attr(ka, "cv")$n_pred, 80L) + expect_true(is.finite(attr(ka, "cv")$zscore_var)) + # With the whole nugget differing between visits, kriging the 80 means is + # kriging all 240 visits with the nugget as their measurement error. + bk <- gstat::krige(z ~ 1, rv, cells, model = vm[vm$model != "Nug", ], + weights = rep(1 / 0.2, nrow(rv)), debug.level = 0) + expect_equal(df$kr_pred, as.numeric(bk$var1.pred), tolerance = 1e-8) + expect_equal(df$kr_var, as.numeric(bk$var1.var), tolerance = 1e-8) + expect_output(print(ka), "240 points at 80 distinct locations") + expect_output(print(ka), "4 folds, 80 locations") +}) + +test_that("identical repeat records change nothing the kriging reports", { + skip_if_not_installed("gstat") + # A mean of identical replicates is one observation, nugget and all. + pts <- ka_field(n = 120, seed = 7) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + lab <- rep(1:4, length.out = nrow(pts)) + one <- kriging_adequacy(assign_features_to_polygons(pts, cells), "z", cells, + sac = ka_true_sac(), folds = lab) + expect_warning(two <- kriging_adequacy(assign_features_to_polygons(rbind(pts, pts), cells), + "z", cells, sac = ka_true_sac(), folds = c(lab, lab)), + "share a location") + a <- sf::st_drop_geometry(one); b <- sf::st_drop_geometry(two) + expect_equal(b$n, 2L * a$n) + # To 1e-6: gstat's block variance from a model nugget and from the same + # variance passed as a measurement error agree to about 1e-7, not to 1e-15. + expect_equal(b[c("mean", "kr_pred", "kr_var", "kr_ratio")], a[c("mean", "kr_pred", "kr_var", "kr_ratio")], + tolerance = 1e-6) + expect_equal(attr(two, "cv")[c("zscore_var", "zscore_mean", "rmse", "n_pred")], + attr(one, "cv")[c("zscore_var", "zscore_mean", "rmse", "n_pred")], tolerance = 1e-6) +}) + +test_that("a kriging system gstat cannot solve raises a warning and print() counts it", { + skip_if_not_installed("gstat") + # gstat answers a singular system with NA, and at debug.level 0 says + # nothing; print() then claimed an estimate for every empty cell. Points a + # micrometre from ten others under a nugget-free Gaussian model are singular + # without sharing a location. + pts <- ka_field(n = 60, seed = 3) + xy <- sf::st_coordinates(pts) + twin <- sf::st_as_sf(data.frame(x = xy[1:10, 1] + 1e-6, y = xy[1:10, 2], z = pts$z[1:10] + 0.1), + coords = c("x", "y"), crs = 32632) + cells <- create_grid_polygons(ka_bnd, target_cells = 64, type = "square") + asg <- assign_features_to_polygons(rbind(pts, twin), cells) + sac <- structure(170, class = "sac_range", variogram_model = gstat::vgm(1, "Gau", 100)) + w <- character() + ka <- withCallingHandlers( + kriging_adequacy(asg, "z", cells, sac = sac, k = 4, seed = 1), + warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }) + df <- sf::st_drop_geometry(ka) + n_na <- sum(!is.finite(df$kr_pred)) + expect_gt(n_na, 0L) + expect_true(any(grepl(sprintf("returned no estimate for %d of 64 cell", n_na), w))) + expect_true(any(grepl("no cross-validation prediction it could use", w))) + expect_output(print(ka), sprintf("no kriged estimate for %d of the 64 cells", n_na)) + n_empty_kr <- sum(df$n == 0L & is.finite(df$kr_pred)) + expect_lt(n_empty_kr, sum(df$n == 0L)) + expect_output(print(ka), sprintf("available for %d of them", n_empty_kr)) +}) + + + +# --------------------------------------------------------------------------- +# Round 2 of the review. +# --------------------------------------------------------------------------- + +# The standardised errors of kriging each split's held-out points from that +# split's own training rows, by hand. +ka_manual_cv <- function(pts, splits, vm, nmax = 50) { + unlist(lapply(splits, function(s) { + kf <- gstat::krige(z ~ 1, pts[s$train, ], pts[s$test, ], model = vm, + nmax = nmax, debug.level = 0) + (pts$z[s$test] - kf$var1.pred) / sqrt(kf$var1.var) + })) +} + +test_that("buffered leave-one-out and NNDM folds keep the points they exclude out of the kriging", { + skip_if_not_installed("gstat") + # Their exclusion zones live only in each split's train set, and the fold + # labels passed on were 1:n, so both ran as plain leave-one-out and + # print() called it blocked CV. + vm <- attr(ka_true_sac(), "variogram_model") + pts <- ka_field(n = 120, seed = 9) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(pts, cells) + fb <- suppressWarnings(make_folds(asg, k = 1, method = "buffered_loo", buffer = 250, seed = 1)) + expect_lt(mean(lengths(lapply(fb$folds, `[[`, "train"))), nrow(asg) - 1) + ka <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = fb) + cv <- attr(ka, "cv") + zs <- ka_manual_cv(asg, fb$folds, vm) + expect_equal(cv$zscore_var, stats::var(zs), tolerance = 1e-10) + expect_equal(cv$n_pred, nrow(asg)) + expect_equal(cv$k, nrow(asg)) + expect_identical(cv$method, "buffered_loo") + loo <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = seq_len(nrow(asg))) + expect_gt(abs(cv$rmse - attr(loo, "cv")$rmse), 0.01) + expect_output(print(ka), "buffered leave-one-out CV (buffered_loo, 120 folds", fixed = TRUE) + expect_output(print(loo), " CV (supplied labels", fixed = TRUE) + + # NNDM on a clustered sample predicted over the whole square. + set.seed(13) + cx <- runif(8, 100, 900); cy <- runif(8, 100, 900) + x <- pmin(pmax(rep(cx, each = 15) + rnorm(120, sd = 30), 1), 999) + y <- pmin(pmax(rep(cy, each = 15) + rnorm(120, sd = 30), 1), 999) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(0.8 * exp(-d / 100) + diag(0.2 + 1e-8, 120))) %*% rnorm(120)) + cl <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + acl <- assign_features_to_polygons(cl, cells) + pp <- sf::st_as_sf(sf::st_make_grid(ka_bnd, n = 12, what = "centers")) + fn <- suppressWarnings(make_folds(acl, k = 1, method = "nndm", prediction_points = pp, seed = 1)) + skip_if(sum(lengths(lapply(fn$folds, `[[`, "train"))) == nrow(acl) * (nrow(acl) - 1L), + "NNDM excluded no neighbours on this draw") + kn <- kriging_adequacy(acl, "z", cells, sac = ka_true_sac(), folds = fn) + expect_equal(attr(kn, "cv")$zscore_var, stats::var(ka_manual_cv(acl, fn$folds, vm)), + tolerance = 1e-10) + expect_output(print(kn), "NNDM leave-one-out CV (nndm", fixed = TRUE) +}) + +test_that("the points are kriged in the CRS the variogram was fitted in", { + skip_if_not_installed("gstat") + # The range is a length in attr(sac, "crs"); a sac fitted in metres met + # points in km and was read as 100 km. + pts <- ka_field(n = 150, seed = 8) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(pts, cells) + sac <- ka_true_sac(); attr(sac, "crs") <- sf::st_crs(32632) + lab <- rep(1:4, length.out = nrow(asg)) + m <- kriging_adequacy(asg, "z", cells, sac = sac, folds = lab) + km <- sf::st_crs("+proj=utm +zone=32 +datum=WGS84 +units=km +no_defs") + k <- kriging_adequacy(sf::st_transform(asg, km), "z", sf::st_transform(cells, km), + sac = sac, folds = lab) + a <- sf::st_drop_geometry(m); b <- sf::st_drop_geometry(k) + expect_equal(b$kr_pred, a$kr_pred, tolerance = 1e-6) + expect_equal(b$kr_var, a$kr_var, tolerance = 1e-6) + expect_equal(attr(k, "cv")$zscore_var, attr(m, "cv")$zscore_var, tolerance = 1e-6) + expect_equal(sf::st_crs(k), sf::st_crs(32632)) +}) + +test_that("a variogram of residuals is used with a warning that it understates the variance", { + skip_if_not_installed("gstat") + pts <- ka_field(n = 120, seed = 10) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(pts, cells) + sac <- ka_true_sac() + attr(sac, "detrended") <- TRUE; attr(sac, "detrend_method") <- "ols" + lab <- rep(1:4, length.out = nrow(asg)) + expect_warning(kriging_adequacy(asg, "z", cells, sac = sac, folds = lab), + "variogram of the residuals on predictors .*understate") + attr(sac, "detrended") <- FALSE + expect_no_warning(kriging_adequacy(asg, "z", cells, sac = sac, folds = lab)) +}) + +test_that("why a range was not identified is kept on the result and said as it is", { + skip_if_not_installed("gstat") + # Every refusal was explained as a sill never reached, and only a TRUE/FALSE + # was kept, so a non-converged fit could not be told from the others. + pts <- ka_field(n = 120, seed = 10) + cells <- create_grid_polygons(ka_bnd, target_cells = 16, type = "square") + asg <- assign_features_to_polygons(pts, cells) + lab <- rep(1:4, length.out = nrow(asg)) + unid <- structure(NA_real_, class = "sac_range", + variogram_model = attr(ka_true_sac(), "variogram_model"), + rejected_reason = "variogram model did not converge") + w <- character() + ka <- withCallingHandlers(kriging_adequacy(asg, "z", cells, sac = unid, folds = lab), + warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }) + expect_true(any(grepl("range was not identified \\(variogram model did not converge\\)", w))) + expect_false(any(grepl("sill was never reached", w))) + expect_identical(attr(ka, "rejected_reason"), "variogram model did not converge") + expect_output(print(ka), "range not identified (variogram model did not converge)", fixed = TRUE) + ok <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = lab) + expect_identical(attr(ok, "rejected_reason"), NA_character_) +}) + +test_that("a cell holding more locations than nmax is kriged from all of them, not its middle", { + skip_if_not_installed("gstat") + # gstat takes the nmax locations nearest a block's centre, so a cell with + # more than nmax points was kriged from its central few. + vm <- attr(ka_true_sac(), "variogram_model") + pts <- ka_field(n = 300, seed = 12) + sq <- function(x0, x1, y0, y1) sf::st_polygon(list(rbind(c(x0, y0), c(x1, y0), c(x1, y1), + c(x0, y1), c(x0, y0)))) + small <- sf::st_make_grid(sf::st_sfc(sq(600, 1000, 0, 1000), crs = 32632), cellsize = 200) + cells <- sf::st_sf(poly_id = seq_len(length(small) + 1L), + geometry = c(sf::st_sfc(sq(0, 600, 0, 1000), crs = 32632), small)) + asg <- assign_features_to_polygons(pts, cells) + lab <- rep(1:3, length.out = nrow(asg)) + ka <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = lab, nmax = 30) + df <- sf::st_drop_geometry(ka) + expect_gt(df$n[1], 30L) + expect_equal(df$kr_n_used[1], df$n[1] + 30L) + # Its own points plus the 30 nearest its centre outside it, all used. + xy <- sf::st_coordinates(asg) + cen <- sp::coordinates(sf::as_Spatial(sf::st_geometry(cells)[1])) + own <- asg$poly_id == 1L + d <- sqrt((xy[, 1] - cen[1, 1])^2 + (xy[, 2] - cen[1, 2])^2); d[own] <- Inf + sel <- c(which(own), order(d)[1:30]) + bk <- gstat::krige(z ~ 1, asg[sel, ], cells[1, ], model = vm, debug.level = 0) + expect_equal(df$kr_pred[1], as.numeric(bk$var1.pred), tolerance = 1e-10) + expect_equal(df$kr_var[1], as.numeric(bk$var1.var), tolerance = 1e-10) + mid <- gstat::krige(z ~ 1, asg, cells[1, ], model = vm, nmax = 30, debug.level = 0) + expect_gt(abs(df$kr_pred[1] - mid$var1.pred), 1e-3) + # Cells whose own points all lie among the 30 nearest their centre keep + # gstat's own neighbourhood. + keep <- df$kr_n_used == 30L + expect_gt(sum(keep), 5L) + gs <- gstat::krige(z ~ 1, asg, cells[which(keep), ], model = vm, nmax = 30, debug.level = 0) + expect_equal(df$kr_pred[keep], as.numeric(gs$var1.pred), tolerance = 1e-10) + # A system above max_neighbours is left out with a warning, and counted. + expect_warning(small_cap <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = lab, + nmax = 30, max_neighbours = 100), + "1 cell\\(s\\) left out .*max_neighbours = 100") + sc <- sf::st_drop_geometry(small_cap) + expect_true(is.na(sc$kr_pred[1]) && is.na(sc$kr_n_used[1]) && is.na(sc$kr_ratio[1])) + expect_equal(sc$kr_pred[-1], df$kr_pred[-1]) + expect_equal(attr(small_cap, "cells_left_out")[["size"]], 1L) + expect_output(print(small_cap), "no kriged estimate for 1 of the 11 cells \\(1 left out as holding") + expect_error(kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), max_neighbours = 0), + "`max_neighbours` must be") +}) + +test_that("a cell whose bounding box dwarfs its area is left out instead of discretised", { + skip_if_not_installed("gstat") + # gstat lays its 500-point grid over a cell's whole bounding box, so a + # sliver's memory grows with box / area: +592 MB at 7,072. + sq <- sf::st_polygon(list(rbind(c(0, 0), c(1000, 0), c(1000, 1000), c(0, 1000), c(0, 0)))) + strip <- sf::st_buffer(sf::st_linestring(rbind(c(0, 0), c(1000, 1000))), 5) + rest <- sf::st_cast(sf::st_sfc(sf::st_difference(sq, strip)), "POLYGON") + cells <- sf::st_sf(poly_id = seq_len(length(rest) + 1L), + geometry = sf::st_sfc(c(list(sf::st_intersection(strip, sq)), as.list(rest)), + crs = 32632)) + ratio <- spatialkit:::.cell_box_ratio(cells) + expect_gt(ratio[1], 50); expect_lt(ratio[1], 1000) + expect_true(all(ratio[-1] < 3)) + pts <- ka_field(n = 150, seed = 14) + asg <- assign_features_to_polygons(pts, cells) + lab <- rep(1:3, length.out = nrow(asg)) + # Under the default bound the strip is kriged like any other cell ... + all_in <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = lab) + expect_true(all(is.finite(sf::st_drop_geometry(all_in)$kr_pred))) + expect_equal(attr(all_in, "cells_left_out"), c(shape = 0L, size = 0L)) + # ... and above a tighter one it is left out, with a warning and a count. + expect_warning(ka <- kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), folds = lab, + max_box_ratio = 50), + "1 cell\\(s\\) left out .*max_box_ratio = 50") + df <- sf::st_drop_geometry(ka) + expect_true(is.na(df$kr_pred[1]) && is.na(df$kr_var[1]) && is.na(df$kr_ratio[1])) + expect_equal(df$kr_pred[-1], sf::st_drop_geometry(all_in)$kr_pred[-1]) + expect_equal(attr(ka, "cells_left_out")[["shape"]], 1L) + expect_output(print(ka), "1 left out as too thin or scattered") + # Parts far apart and a cell that is mostly hole score the same way. + far <- sf::st_multipolygon(list( + list(rbind(c(0, 0), c(10, 0), c(10, 10), c(0, 10), c(0, 0))), + list(rbind(c(990, 0), c(1000, 0), c(1000, 10), c(990, 10), c(990, 0))))) + holed <- sf::st_polygon(list(rbind(c(0, 0), c(100, 0), c(100, 100), c(0, 100), c(0, 0)), + rbind(c(5, 5), c(5, 95), c(95, 95), c(95, 5), c(5, 5)))) + r2 <- spatialkit:::.cell_box_ratio(sf::st_sf(geometry = sf::st_sfc(far, holed, crs = 32632))) + expect_equal(r2, c(1000 * 10 / 200, 100^2 / (100^2 - 90^2))) + expect_error(kriging_adequacy(asg, "z", cells, sac = ka_true_sac(), max_box_ratio = 0.5), + "`max_box_ratio` must be") +}) diff --git a/tests/testthat/test-level-selection.R b/tests/testthat/test-level-selection.R index 9ab4f85..fb1920c 100644 --- a/tests/testthat/test-level-selection.R +++ b/tests/testthat/test-level-selection.R @@ -41,6 +41,11 @@ test_that(".elbow_from_wss finds a hand-placed knee", { # implementation. later <- c(100, 90, 80, 70, 60, 50, 10, 9, 8, 7) expect_equal(eb(later)$knee_k, 7L) + # (On log-log axes that shoulder-then-cliff curve sags only 0.06 below its + # chord, short of an elbow, so 7 is the flagged linear-axis answer; a + # k-means WSS curve does not have a shoulder like that.) + expect_false(eb(later)$structured) + expect_true(eb(.knee_curve)$structured) earlier <- c(100, 20, 19, 18, 17, 16, 15, 14, 13, 12) expect_equal(eb(earlier)$knee_k, 2L) }) @@ -65,9 +70,12 @@ test_that("determine_optimal_levels() puts the elbow first on the geometric path }) test_that(".elbow_from_wss is invariant to an affine rescaling of WSS", { - # Both axes are min-max normalised before the perpendicular distance is - # taken, so a * wss + b (a > 0) cannot move the knee. WSS is in squared CRS - # units, so this is what makes the answer independent of the projection. + # The elbow is read on log-log axes, where a * wss (a > 0) is a shift and + # cannot move it; WSS is in squared CRS units, so this is what makes the + # answer independent of the projection. A shift b can flatten the log-log + # bend below the threshold, and then the linear-axis answer is returned, + # which min-max normalisation makes invariant to both; on this curve the + # two readings agree. eb <- spatialkit:::.elbow_from_wss base <- eb(.knee_curve)$knee_k for (a in c(1e-6, 0.5, 1000)) { diff --git a/tests/testthat/test-plotting-diagnostics.R b/tests/testthat/test-plotting-diagnostics.R index 33eb2ea..2c05763 100644 --- a/tests/testthat/test-plotting-diagnostics.R +++ b/tests/testthat/test-plotting-diagnostics.R @@ -134,7 +134,7 @@ test_that("plot.aoa draws both distributions and the threshold", { expect_no_error(ggplot2::ggplot_build(ph)) expect_true(all(c("GeomBar", "GeomPath", "GeomVline") %in% layer_geoms(ph))) - # No folds: the caption says the threshold is optimistic. + # No folds: the caption says the training DI was not cross-validated. aoa0 <- area_of_applicability(new, train_sf = pts, predictor_vars = c("a", "b")) expect_match(plot(aoa0)$labels$caption, "not cross-validated") expect_error(plot.aoa(list(a = 1)), "must be the object returned by area_of_applicability") diff --git a/tests/testthat/test-plotting-fits.R b/tests/testthat/test-plotting-fits.R index 6f7833d..d4c90c4 100644 --- a/tests/testthat/test-plotting-fits.R +++ b/tests/testthat/test-plotting-fits.R @@ -313,7 +313,10 @@ test_that("plot_folds' subtitle describes the scheme that was built", { expect_false(grepl("[Bb]lock", sub(fr))) fb <- make_folds(pts, k = 4, method = "block_kfold", block_size = 300, seed = 1) expect_match(sub(fb), "Block size 300") - expect_match(sub(fb), as.character(fb$params$crs), fixed = TRUE) + # The unit of the CRS the folds were built in, not its identifier + # ("EPSG:3857 units", or a whole WKT for a CRS with no EPSG code). + expect_match(sub(fb), "Block size 300 (metre)", fixed = TRUE) + expect_false(grepl(as.character(fb$params$crs), sub(fb), fixed = TRUE)) # Two lines: one long one is clipped at the width these are drawn at, and # neither line is long enough to clip on its own. lines <- strsplit(sub(fb), "\n", fixed = TRUE)[[1]] diff --git a/tests/testthat/test-predict-surface.R b/tests/testthat/test-predict-surface.R index e156a2a..5dea940 100644 --- a/tests/testthat/test-predict-surface.R +++ b/tests/testthat/test-predict-surface.R @@ -172,12 +172,16 @@ test_that(".make_prediction_grid returns cell CENTRES, not corners", { 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. + # A cell size that does not divide the extent evenly still covers it, and + # the grid stays symmetric about the box: 100 / 30 -> 4 cells spanning 120, + # overhanging by 10 on each side, centres 5, 35, 65, 95. (Three cells + # anchored at the lower bound left the top 10 uncovered.) 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) + expect_equal(xs2, c(5, 35, 65, 95)) + expect_equal(min(xs2) - bb[["xmin"]], bb[["xmax"]] - max(xs2)) + expect_lte(min(xs2) - 30 / 2, bb[["xmin"]]) + expect_gte(max(xs2) + 30 / 2, bb[["xmax"]]) # A cell wider than the extent collapses to one point at the centre of the # box, not at its corner. diff --git a/tests/testthat/test-regression-metrics.R b/tests/testthat/test-regression-metrics.R index fa3720f..805eac0 100644 --- a/tests/testthat/test-regression-metrics.R +++ b/tests/testthat/test-regression-metrics.R @@ -1,9 +1,10 @@ # =========================================================================== # .compute_reg_metrics(): the shared metric calculator behind summary(), # model_metrics() and every cross-validation path. The y_train_mean tests -# matter because R-squared against the WRONG baseline is the classic way to -# report a flattering number: out-of-sample R-squared must be measured -# against the training mean, not the test fold's own mean. +# pin the baseline: out-of-sample R-squared is measured against the training +# mean, the only null prediction available at prediction time, not against +# the test fold's own mean (which knows the test data, and so gives the +# lower R-squared of the two). # =========================================================================== test_that(".compute_reg_metrics matches hand-computed values", { diff --git a/tests/testthat/test-regressions.R b/tests/testthat/test-regressions.R index afe215b..55db4bc 100644 --- a/tests/testthat/test-regressions.R +++ b/tests/testthat/test-regressions.R @@ -131,9 +131,12 @@ test_that(".remap_folds drops folds left with fewer than two training rows", { # --------------------------------------------------------------------------- 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 + # Out-of-sample R^2 is measured against the TRAINING mean, the null + # prediction available when the fold is predicted. The held-out data's + # OWN mean is a null model that knows where the held-out block sits; it + # fits those rows at least as well as any other constant, so it gives the + # LOWER R^2 -- the training baseline is chosen for using training + # information only, not for being the conservative one. cv_spatial() # 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 diff --git a/tests/testthat/test-resolution-profile.R b/tests/testthat/test-resolution-profile.R index c1b5a26..0034e86 100644 --- a/tests/testthat/test-resolution-profile.R +++ b/tests/testthat/test-resolution-profile.R @@ -76,17 +76,23 @@ test_that("25 k-means++ restarts leave the WSS curve monotone where 5 random one test_that("determine_optimal_levels warns before the sweep when no k can clear the floor", { pts <- rp_field(120, with_pred = TRUE) - lines <- capture_spatialkit_log( + # Uniform locations also have no WSS elbow, which is an R warning of its + # own; it is not the one under test here. + lines <- capture_spatialkit_log(suppressWarnings( out <- determine_optimal_levels(pts, max_levels = 6, response_var = "z", - predictor_vars = "w", criterion = "morans_i")) + predictor_vars = "w", criterion = "morans_i"))) expect_true(log_has(lines, "nine cells or fewer")) expect_true(log_has(lines, "Raise max_levels")) expect_type(out, "integer") - # With room above the floor the warning is not raised. - quiet <- capture_spatialkit_log( + # With room above the floor the warning before the sweep is not raised. + # These points have no cluster structure, so the elbow sits near + # sqrt(14) and its neighbourhood still ends below ten cells: the fallback + # is then said with that reason, not as "could not be computed". + quiet <- capture_spatialkit_log(suppressWarnings( determine_optimal_levels(pts, max_levels = 14, response_var = "z", - predictor_vars = "w", criterion = "morans_i")) - expect_false(log_has(quiet, "nine cells or fewer")) + predictor_vars = "w", criterion = "morans_i"))) + expect_false(log_has(quiet, "max_levels leaves k_max")) + expect_true(log_has(quiet, "score only the elbow's neighbourhood")) }) test_that("determine_optimal_levels reports the restart budget and bumps in its diagnostics", { @@ -277,8 +283,20 @@ test_that("resolution_profile is reproducible from its seed and subsamples large b <- resolution_profile(pts, n_levels = 5, seed = 11) expect_identical(a$wss, b$wss) sub <- resolution_profile(pts, n_levels = 5, sample_n = 120) - expect_identical(attr(sub, "bounds")$n, 120L) - expect_identical(attr(sub, "bounds")$ceiling, 13L) + # The fits run on 120 points, but the support ceiling is the layer's, + # floor(200 / 9) = 22, not the subsample's floor(120 / 9) = 13: sample_n + # is a speed setting, not a bound on the answer. + expect_identical(attr(sub, "bounds")$n, 200L) + expect_identical(attr(sub, "bounds")$n_sample, 120L) + expect_identical(attr(sub, "bounds")$ceiling, 22L) + expect_identical(attr(sub, "bounds")$ceiling_from, "min_cell_n") + expect_output(print(sub), "on 200 points \\(k-means fitted to a subsample of 120\\)") + # A subsample too small to fit that many cells holds the ceiling to two of + # its points per cell, and says which bound is choosing. + tiny <- resolution_profile(pts, n_levels = 4, sample_n = 30, min_cell_n = 3) + expect_identical(attr(tiny, "bounds")$ceiling, 15L) + expect_identical(attr(tiny, "bounds")$ceiling_from, "sample_n") + expect_output(print(tiny), "ceiling 15 from the 30-point subsample") }) @@ -303,8 +321,15 @@ test_that("select_resolution reads the optimum and the flat region off each crit expect_true(all(prof$reliability[prof$levels %in% s_rel$flat] >= max(prof$reliability) * 0.98)) expect_identical(s_rel$at_floor, s_rel$best == min(prof$levels)) - s_el <- select_resolution(prof, "elbow") - expect_identical(s_el$best, prof$levels[which.max(prof$elbow)]) + # Uniform locations have no WSS elbow, and the column says so rather than + # offering the chord rule's sqrt(first x last level) as one ... + expect_true(all(is.na(prof$elbow))) + expect_error(select_resolution(prof, "elbow"), "no elbow") + # ... while clustered ones have one, and select_resolution() reads it. + cl <- resolution_profile(sf::st_as_sf(as.data.frame(rp_clustered(400)), + coords = 1:2, crs = 32632), n_levels = 8) + s_el <- select_resolution(cl, "elbow") + expect_identical(s_el$best, cl$levels[which.max(cl$elbow)]) s_z <- select_resolution(prof, "moran_z", tol = 0.1) ok <- is.finite(prof$moran_z) @@ -323,7 +348,8 @@ test_that("select_resolution refuses a criterion that is NA everywhere, and bad expect_error(select_resolution(geo, "cp"), "NA at every level.*response") expect_error(select_resolution(geo, "reliability"), "NA at every level") expect_error(select_resolution(geo, "moran_z"), "NA at every level") - expect_s3_class(select_resolution(geo, "elbow"), "resolution_selection") + # Uniform locations: the WSS curve has no elbow either. + expect_error(select_resolution(geo, "elbow"), "NA at every level.*no elbow") expect_error(select_resolution(geo, "elbow", tol = -1), "non-negative") expect_error(select_resolution(data.frame(levels = 1:3), "elbow"), "must come from") }) @@ -407,8 +433,15 @@ test_that("summary() puts every criterion's pick in one table", { test_that("summary() reports only the criteria a profile can score", { skip_if_not_installed("gstat") - pts <- rp_field(n = 250) + # Clustered locations, so the WSS curve has an elbow: on uniform ones it + # has none, and a geometry-only profile then has no criterion at all. + set.seed(6) + pts <- sf::st_as_sf(data.frame(rp_clustered(250), z = rnorm(250)), + coords = 1:2, crs = 32632) geo <- suppressWarnings(suppressMessages(resolution_profile(pts, n_levels = 6))) + flat <- suppressWarnings(suppressMessages(resolution_profile(rp_field(n = 250), + n_levels = 6))) + expect_error(summary(flat), "elbow is NA when the WSS curve has no elbow") # No response: cp, reliability and moran_z are NA at every level, so the # default is the one criterion that is not. @@ -438,8 +471,12 @@ test_that("summary() reports only the criteria a profile can score", { expect_error(summary(geo, criteria = factor("elbow")), "character vector") expect_error(summary(geo, criteria = c("elbow", "elbow")), "repeats") + vm <- data.frame(model = c("Nug", "Exp"), psill = c(0.5, 1), range = c(0, 50), + stringsAsFactors = FALSE) + sac <- structure(150, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) prof <- suppressWarnings(suppressMessages( - resolution_profile(rp_field(n = 250), response_var = "z", n_levels = 8))) + resolution_profile(pts, response_var = "z", sac = sac, n_levels = 8))) expect_identical(summary(prof, criteria = c("elbow", "cp"))$criterion, c("elbow", "cp")) expect_output(print(summary(prof)), "^Resolution picks: ") @@ -567,7 +604,10 @@ test_that("a band is read as a set everywhere it is reported", { levels = unique(round(exp(seq(log(4), log(60), length.out = 12))))))) expect_true(max(wide$levels) / min(wide$levels) > 8) - for (cn in c("cp", "reliability", "elbow", "moran_z")) { + # Every criterion the profile scored. The fixture's locations are uniform, + # so its WSS curve has no elbow and `elbow` is NA throughout. + for (cn in Filter(function(cn) any(is.finite(wide[[cn]])), + c("cp", "reliability", "elbow", "moran_z"))) { w <- drawn(wide, cn) sw <- select_resolution(wide, cn) expect_identical(nrow(w$rects), diff --git a/tests/testthat/test-return-accounting.R b/tests/testthat/test-return-accounting.R index 0e627a2..cf6781b 100644 --- a/tests/testthat/test-return-accounting.R +++ b/tests/testthat/test-return-accounting.R @@ -213,7 +213,9 @@ test_that("the dropped record does not survive subsetting the layer", { pred = c(1, 2, 3, 4, Inf, 6, 7, 8)), coords = c("x", "y"), crs = 32632) out <- suppressWarnings(prep_model_data(d, "resp", "pred")) - expect_identical(class(out), c("spatialkit_rows", "sf", "data.frame")) + # After "sf", so that vctrs (dplyr::bind_rows()) sees an sf; see + # test-review2-assignment.R. + expect_identical(class(out), c("sf", "spatialkit_rows", "data.frame")) expect_identical(attr(out, "dropped")$n, 2L) # Every shape of `[` leaves a plain layer with no record: the positions in # `which` do not survive the renumbering, and `n` is not a fact about the @@ -246,11 +248,12 @@ test_that("the dropped record does not survive subsetting the layer", { }) test_that("a layer carrying a record still satisfies S4 dispatch written for sf", { - # The class sits ahead of "sf", and S4 looks a class up in its own table - # rather than walking the S3 vector, so without setOldClass() every S4 - # method written for "sf" -- methods::as(x, "Spatial") on the way into - # GWmodel, terra::vect(), sp's coercions -- fails a prepared layer with - # "no method or default for coercing". + # The class sat ahead of "sf" (and still does on a layer saved by an + # earlier version), and S4 looks a class up in its own table rather than + # walking the S3 vector, so without setOldClass() every S4 method written + # for "sf" -- methods::as(x, "Spatial") on the way into GWmodel, + # terra::vect(), sp's coercions -- failed a prepared layer with "no method + # or default for coercing". d <- sf::st_as_sf(data.frame(x = 1:8, y = 8:1, resp = c(1, 2, NA, 4, 5, 6, 7, 8), pred = c(1, 2, 3, 4, Inf, 6, 7, 8)), diff --git a/tests/testthat/test-review-assignment.R b/tests/testthat/test-review-assignment.R new file mode 100644 index 0000000..5da4ae7 --- /dev/null +++ b/tests/testthat/test-review-assignment.R @@ -0,0 +1,153 @@ +# =========================================================================== +# assign_features_to_polygons(largest = TRUE): regressions from the review. +# +# The largest-overlap join used to sit in a catch-all tryCatch that retried +# WITHOUT `largest` on any error. No predicate ever rejects `largest` (sf +# ignores `join` on that path), so the retry only fired on geometry failures, +# and then every straddling feature in the layer was assigned by `tie_break` +# instead of by overlap, with no R warning. +# =========================================================================== + +.rv_sq <- function(x0, y0, x1, y1) { + sf::st_polygon(list(rbind(c(x0, y0), c(x1, y0), c(x1, y1), c(x0, y1), + c(x0, y0)))) +} + +# Two 10 x 10 cells side by side, equal areas, so a tie-break on area alone +# falls to the first cell. +.rv_two_cells <- function(second = .rv_sq(10, 0, 20, 10)) { + sf::st_sf(poly_id = c(1L, 2L), + geometry = sf::st_sfc(.rv_sq(0, 0, 10, 10), second, crs = 32632)) +} + +# A self-crossing ring: GEOS cannot intersect it (TopologyException). +.rv_bowtie <- sf::st_polygon(list(rbind(c(1, 1), c(3, 3), c(3, 1), c(1, 3), + c(1, 1)))) + +# Collect every R warning `expr` raises while returning its value. +.rv_warnings <- function(expr) { + ws <- character(0) + val <- withCallingHandlers(expr, warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + list(value = val, warnings = ws) +} + + +test_that("one invalid feature does not switch the layer to tie-break assignment", { + # x 7..14: 3 units of width in cell 1, 4 in cell 2. + straddler <- sf::st_sfc(.rv_sq(7, 2, 14, 5), crs = 32632) + x <- sf::st_sf(v = 1:2, + geometry = c(straddler, sf::st_sfc(.rv_bowtie, crs = 32632))) + expect_false(all(sf::st_is_valid(x))) + + lines <- capture_spatialkit_log( + res <- .rv_warnings(assign_features_to_polygons(x, .rv_two_cells()))) + out <- res$value + + # The valid straddler keeps its largest-overlap cell. It used to go to + # cell 1: the bow-tie made GEOS throw, the whole join was rerun without + # `largest`, and the equal-area tie-break took the first match. + expect_equal(out$poly_id[out$v == 1L], 2L) + # The bow-tie lies wholly in cell 1 either way. + expect_equal(out$poly_id[out$v == 2L], 1L) + expect_equal(attr(out, "ties")$n, 0L) + # The repair is announced as a real R warning, with the count. + expect_true(any(grepl("1 of 2 feature\\(s\\) and 0 of 2 polygon\\(s\\) have invalid geometry", + res$warnings))) + expect_true(log_has(lines, "repaired with sf::st_make_valid\\(\\)")) + # The repair is for the join only: the caller's geometry comes back as it + # arrived. + expect_identical(sf::st_geometry(out)[[2]], .rv_bowtie) + expect_false(sf::st_is_valid(sf::st_geometry(out)[2])) +}) + + +test_that("an invalid cell is repaired for the join instead of dropping `largest`", { + # Cell 2 is a bow-tie with lobes left and right of (15, 5); its shoelace + # area cancels to 0, so the old fallback's smallest-area tie-break always + # picked it. Repaired, the straddler x 6..13 has 12 units in cell 1 and + # 8.5 in cell 2's left lobe. + bow_cell <- sf::st_polygon(list(rbind(c(10, 0), c(20, 10), c(20, 0), + c(10, 10), c(10, 0)))) + cells <- .rv_two_cells(second = bow_cell) + x <- sf::st_sf(v = 1L, geometry = sf::st_sfc(.rv_sq(6, 2, 13, 5), crs = 32632)) + + lines <- capture_spatialkit_log( + res <- .rv_warnings(assign_features_to_polygons(x, cells))) + + expect_equal(res$value$poly_id, 1L) + expect_true(any(grepl("0 of 1 feature\\(s\\) and 1 of 2 polygon\\(s\\) have invalid geometry", + res$warnings))) +}) + + +test_that("a largest-overlap join that still fails stops instead of falling back", { + # After repair nothing in sf's largest path should throw, but when it does + # (s2 on a degenerate intersection piece, say) the answer must not be + # recomputed under a different rule for the whole layer. + real_st_join <- sf::st_join + local_mocked_bindings( + st_join = function(x, y, ..., largest = FALSE) { + if (isTRUE(largest)) stop("TopologyException: simulated") + real_st_join(x, y, ..., largest = largest) + }, + .package = "sf" + ) + x <- sf::st_sf(v = 1L, geometry = sf::st_sfc(.rv_sq(7, 2, 14, 5), crs = 32632)) + + expect_error(suppressWarnings(assign_features_to_polygons(x, .rv_two_cells())), + "largest-overlap join failed \\(TopologyException: simulated\\).*largest = FALSE") + # Asking for the tie-break rule explicitly still works. + expect_equal(suppressWarnings( + assign_features_to_polygons(x, .rv_two_cells(), largest = FALSE))$poly_id, 1L) +}) + + +# Evaluate `code` with sf_use_s2() set to `on`, restoring the session's value. +.rv_with_s2 <- function(on, code) { + was <- suppressMessages(sf::sf_use_s2(on)) + on.exit(suppressMessages(sf::sf_use_s2(was)), add = TRUE) + force(code) +} + +test_that("lon/lat features are assigned in the cells' projected CRS", { + # Two 200 km cells in Web Mercator sharing a horizontal edge near 45N. The + # features used to stay in lon/lat and the cells were moved to them, where + # s2 reads that edge as a great-circle arc bulging about 0.8 km north + # mid-way; with s2 off the largest-overlap join needed lwgeom and failed. + y0 <- 5621521 # ~45N in EPSG:3857 + w <- 2e5 / cos(pi / 4) # 200 km of ground + mid <- w / 2 + cells <- sf::st_sf(poly_id = c(1L, 2L), + geometry = sf::st_sfc(.rv_sq(0, y0 - w, w, y0), + .rv_sq(0, y0, w, y0 + w), + crs = 3857)) + # 1200 of its 2000 units of height lie in cell 2, drawn in the cells' CRS. + feat_ll <- sf::st_transform( + sf::st_sf(v = 1L, geometry = sf::st_sfc( + .rv_sq(mid - 5000, y0 - 800, mid + 5000, y0 + 1200), crs = 3857)), + 4326) + # Points 500 units either side of the edge. + pts_ll <- sf::st_transform( + sf::st_sf(v = 1:2, geometry = sf::st_sfc(sf::st_point(c(mid, y0 + 500)), + sf::st_point(c(mid, y0 - 500)), + crs = 3857)), + 4326) + + for (s2 in c(TRUE, FALSE)) { + .rv_with_s2(s2, { + out <- suppressWarnings(assign_features_to_polygons(feat_ll, cells)) + pts <- assign_features_to_polygons(pts_ll, cells) + }) + # Under s2 the old code put the polygon, and the point inside cell 2, in + # cell 1. + expect_equal(out$poly_id, 2L, info = paste("s2 =", s2)) + expect_equal(pts$poly_id, c(2L, 1L), info = paste("s2 =", s2)) + # Only a copy was moved into the cells' CRS: the caller's coordinates come + # back untouched, not as a transform round trip. + expect_identical(sf::st_geometry(out), sf::st_geometry(feat_ll)) + expect_identical(sf::st_geometry(pts), sf::st_geometry(pts_ll)) + } +}) diff --git a/tests/testthat/test-review-cv.R b/tests/testthat/test-review-cv.R new file mode 100644 index 0000000..b5fb55d --- /dev/null +++ b/tests/testthat/test-review-cv.R @@ -0,0 +1,342 @@ +# tests/testthat/test-review-cv.R +# --------------------------------------------------------------------------- +# Regressions from the review of the CV runners, forward selection and +# compare_models_cv(): a parallel cv_gwr() that hung, partial fold failures +# that were only logged, and scores compared across different row sets. +# --------------------------------------------------------------------------- + +.rv_gwr_pts <- function(n = 90, seed = 21) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + elev = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$price <- 10 + 2 * d$elev + rnorm(n, 0, 0.5) + d +} + + +# --------------------------------------------------------------------------- +# cv_gwr(parallel = n) after a GWR fit +# --------------------------------------------------------------------------- + +test_that("cv_gwr(parallel = 2) returns after a GWR has been fitted in the session", { + # GWmodel is built with OpenMP. Once fit_gwr_model() had run, GNU + # libgomp's thread pool lived in the parent, every mclapply() child blocked + # on a futex at its first OpenMP region, and cv_gwr(parallel = 2) never + # returned. Run in a child R process under `timeout` so a regression fails + # here (status 124) instead of hanging the whole suite. + skip_on_cran() + skip_on_os("windows") + skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") + skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") + skip_if(!nzchar(Sys.which("timeout")), "coreutils `timeout` not found") + + # Load the same spatialkit this session has: the installed copy, or the + # source tree pkgload::load_all() put in place. + ns_path <- getNamespaceInfo(asNamespace("spatialkit"), "path") + installed <- file.exists(file.path(ns_path, "Meta", "package.rds")) + if (!installed) skip_if_not_installed("pkgload") + load_line <- if (installed) + sprintf("suppressMessages(library(spatialkit, lib.loc = %s))", + deparse(dirname(ns_path))) + else + sprintf("suppressMessages(pkgload::load_all(%s, quiet = TRUE))", + deparse(ns_path)) + + script <- tempfile(fileext = ".R") + on.exit(unlink(script), add = TRUE) + writeLines(c( + load_line, + "logger::log_threshold(logger::FATAL, namespace = 'spatialkit', index = 2)", + "set.seed(21); n <- 90", + "d <- sf::st_as_sf(", + " data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000),", + " elev = rnorm(n)),", + " coords = c('x', 'y'), crs = 32632)", + "d$price <- 10 + 2 * d$elev + rnorm(n, 0, 0.5)", + "invisible(suppressWarnings(suppressMessages(fit_gwr_model(d, 'price', 'elev'))))", + "seq_res <- suppressWarnings(suppressMessages(", + " cv_gwr(d, 'price', 'elev', k = 3, seed = 7)))", + "w <- character(0)", + "par_res <- withCallingHandlers(suppressMessages(", + " cv_gwr(d, 'price', 'elev', k = 3, seed = 7, parallel = 2L)),", + " warning = function(x) {", + " w <<- c(w, conditionMessage(x)); invokeRestart('muffleWarning') })", + "cat('RESULT', par_res$n_folds_succeeded,", + " isTRUE(all.equal(par_res$overall, seq_res$overall)),", + " any(grepl('OpenMP', w)), '\\n')" + ), script) + + rscript <- file.path(R.home("bin"), "Rscript") + # `timeout` makes itself a process-group leader and signals the group, so + # any forked worker stuck in libgomp dies with the R process. R_TESTS is + # cleared because R CMD check points it at a startup file relative to the + # tests directory, which the child would fail to source. + out <- suppressWarnings(system2( + "timeout", c("-k", "10", "150", shQuote(rscript), shQuote(script)), + stdout = TRUE, stderr = TRUE, env = "R_TESTS=")) + status <- attr(out, "status") + if (is.null(status)) status <- 0L + expect_identical(as.integer(status), 0L, + label = paste0("child R exit status (124 = hung and killed); output:\n", + paste(utils::tail(out, 15L), collapse = "\n"))) + # All three folds scored, identical to the sequential run, and a warning + # that says why the folds did not fork. + expect_true(any(grepl("^RESULT 3 TRUE TRUE", out)), + label = paste(utils::tail(out, 15L), collapse = "\n")) +}) + + +test_that("compare_models_cv(gwr_args = list(parallel = 2)) never forks GWR folds", { + # The same hang reached through compare_models_cv(). mclapply() is + # replaced by a stub that errors, so the old code fails here at once + # instead of hanging on the GWR fits earlier tests have left in the session. + skip_on_os("windows") + skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") + skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") + + d <- .rv_gwr_pts() + invisible(suppressWarnings(suppressMessages(fit_gwr_model(d, "price", "elev")))) + ref <- suppressWarnings(suppressMessages( + compare_models_cv(d, "price", "elev", models = "GWR", k = 3, seed = 7, + quiet = TRUE))) + local_mocked_bindings( + mclapply = function(...) stop("GWR folds were forked"), + .package = "parallel") + expect_warning( + res <- suppressMessages( + compare_models_cv(d, "price", "elev", models = "GWR", k = 3, seed = 7, + quiet = TRUE, gwr_args = list(parallel = 2L))), + "cv_gwr\\(\\): `parallel` is ignored.*OpenMP") + expect_identical(res$gwr_cv$n_folds_succeeded, 3L) + expect_equal(res$overall, ref$overall) +}) + + +# --------------------------------------------------------------------------- +# Some folds fail: a real R warning, not only a log line +# --------------------------------------------------------------------------- + +# 100 points; zone "core" exists only east of x = 800, and those rows are fold +# 1 of a label vector, so no training set holds the level and every learner's +# predict() fails on that fold. +.rv_zone_pts <- function(n = 100, seed = 5) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- sf::st_as_sf(data.frame(x = x, y = y, w = rnorm(n)), + coords = c("x", "y"), crs = 3857) + d$zone <- factor(ifelse(x > 800, "core", sample(c("a", "b"), n, TRUE))) + d$z <- d$w + rnorm(n) + d$lab <- ifelse(x > 800, 1L, sample(2:4, n, TRUE)) + d +} + +.rv_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + +test_that("cv_spatial() warns when some folds fail, naming them and the rows scored", { + # overall was pooled over the surviving folds -- here without the one block + # holding the level -- with only a logger line to say so. + d <- .rv_zone_pts() + n_core <- sum(d$lab == 1L) + fitf <- function(tr) lm_spatial_fit(tr, "z", c("w", "zone")) + expect_warning( + cv <- cv_spatial(d, "z", c("w", "zone"), fit_fn = fitf, folds = d$lab), + sprintf(paste0("^cv_spatial\\(\\): 1 of 4 fold\\(s\\) failed \\(fold 1: ", + "error\\), so `overall` pools the other folds only and ", + "covers %d of the 100 rows"), 100L - n_core)) + expect_identical(cv$overall$n_pred, 100L - n_core) + expect_identical(cv$fold_status$status, c("error", "ok", "ok", "ok")) +}) + +test_that("cv_rf() raises the same warning under its own name", { + skip_if_not_installed("ranger") + d <- .rv_zone_pts() + expect_warning( + cv <- cv_rf(d, "z", c("w", "zone"), folds = d$lab, num_trees = 30, seed = 1), + "^cv_rf\\(\\): 1 of 4 fold\\(s\\) failed \\(fold 1: error\\)") + expect_identical(cv$n_folds_succeeded, 3L) +}) + +test_that("a fold dropped before fitting is not warned about twice", { + # .remap_folds() already raises a warning for a fold that never reaches the + # fitter; the new one names only the folds that failed there. + d <- .rv_zone_pts() + d$lab[d$lab == 4L] <- 5L # labels 1, 2, 3, 5 ... + d$lab[which(d$lab == 3L)[1:3]] <- 4L # ... and a small fold 4 + d$w[d$lab == 4L] <- NA # whose rows prep drops + fitf <- function(tr) lm_spatial_fit(tr, "z", c("w", "zone")) + r <- .rv_warnings(suppressMessages( + cv_spatial(d, "z", c("w", "zone"), fit_fn = fitf, folds = d$lab))) + expect_length(r$warnings, 2L) + expect_match(r$warnings[1], "1 of 5 fold\\(s\\) dropped before fitting") + expect_match(r$warnings[2], paste0("^cv_spatial\\(\\): 1 of 5 fold\\(s\\) ", + "failed \\(fold 1: error\\), so")) + expect_identical(r$value$fold_status$status, + c("error", "ok", "ok", "dropped", "ok")) + # Only a fold dropped before fitting: the one warning it always had. + d2 <- .rv_zone_pts() + d2$w[d2$lab == 1L] <- NA + r2 <- .rv_warnings(suppressMessages( + cv_spatial(d2, "z", "w", fit_fn = function(tr) lm_spatial_fit(tr, "z", "w"), + folds = d2$lab))) + expect_length(r2$warnings, 1L) + expect_match(r2$warnings, "dropped before fitting") +}) + + +# --------------------------------------------------------------------------- +# select_features_forward(): every candidate set scored on the same rows +# --------------------------------------------------------------------------- + +# The response is driven by `a`; land cover `lc` is noise whose level "C" sits +# only in the north-east corner, which is also where the response is noisiest. +# Under block CV the fold holding the corner cannot be predicted by any set +# containing `lc`, so such a set used to be scored on the 192 easier rows. +.rv_corner_pts <- function(n = 250, seed = 10) { + set.seed(seed) + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + d <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + corner <- xy[, 1] > 800 & xy[, 2] > 800 + d$lc <- factor(ifelse(corner, "C", sample(c("A", "B"), n, TRUE))) + d$z <- 2 * d$a + rnorm(n, 0, ifelse(corner, 12, 1)) + d +} + +test_that("select_features_forward() does not let a set win by losing a fold", { + # With lm and a null model: `a` was selected, then `lc` was accepted at step + # 2 because {a, lc} scored RMSE 0.94 on 192 rows against 2.33 for {a} on 250. + d <- .rv_corner_pts() + fitf <- function(tr, vars) lm_spatial_fit(tr, "z", vars) + r <- .rv_warnings(select_features_forward(d, "z", c("a", "lc"), fitf, + k = 5, seed = 1, quiet = TRUE)) + sel <- r$value + expect_identical(sel$selected, "a") + expect_identical(sel$params$n_scored, 250L) + h <- sel$history + expect_true("n_pred" %in% names(h)) + expect_identical(h$n_pred[h$variable == ""], 250L) + expect_identical(h$n_pred[h$step == 1L & h$variable == "a"], 250L) + # Every set holding `lc` predicted 192 rows and is NA, not a score. + lc_rows <- h[h$variable == "lc", ] + expect_true(all(lc_rows$n_pred == 192L)) + expect_true(all(is.na(lc_rows$score))) + # One warning per step from the sweep, naming the set; cv_spatial()'s own + # partial-failure warning is not repeated for every candidate. + expect_length(r$warnings, 2L) + expect_match(r$warnings[1], paste0("^select_features_forward\\(\\): step 1: ", + "\\{lc\\} \\(192 of them predicted\\)")) + expect_match(r$warnings[2], "step 2: \\{a, lc\\} \\(192 of them predicted\\)") +}) + +test_that("with no null model the rows every step-1 set predicted are the reference", { + # RF refuses an empty predictor set, so the reference is the union of the + # step-1 candidates' rows: `lc` is still NA and `a` is chosen. It used to + # be the other way round (RMSE 2.35 on 192 rows beat 2.63 on 250). + skip_if_not_installed("ranger") + d <- .rv_corner_pts() + fitf <- function(tr, vars) fit_rf_model(tr, "z", vars, num_trees = 100, seed = 1) + expect_warning( + sel <- select_features_forward(d, "z", c("a", "lc"), fitf, k = 5, seed = 1, + quiet = TRUE, max_vars = 1), + "step 1: \\{lc\\}") + expect_identical(sel$selected, "a") + expect_identical(sel$params$n_scored, 250L) + expect_identical(sel$history$n_pred, c(250L, 192L)) +}) + + +# --------------------------------------------------------------------------- +# compare_models_cv(): backends compared on the same rows +# --------------------------------------------------------------------------- + +test_that("compare_models_cv() re-scores the models on the rows they all predicted", { + # GWR with a fixed bandwidth cannot reach the outlying valley block, so it + # lost that fold -- the hardest rows -- and its pooled RMSE (1.81 on 158 + # rows) beat RF's (1.95 on 200) although RF scored 0.99 on the same 158. + skip_if_not_installed("ranger") + skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") + set.seed(4); n <- 200 + xy <- rbind(cbind(runif(150, 0, 600), runif(150, 0, 1000)), + cbind(runif(50, 850, 1000), runif(50, 0, 1000))) + d <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2], a = runif(n, -2, 2)), + coords = c("x", "y"), crs = 32632) + d$z <- 10 + 3 * sign(d$a) + rnorm(n, 0, 0.3) + mae <- function(y, yhat) c(MedAE = stats::median(abs(y - yhat))) + r <- .rv_warnings(suppressMessages(compare_models_cv( + d, "z", "a", models = c("RF", "GWR"), k = 5, seed = 1, quiet = TRUE, + metrics = mae, rf_args = list(num_trees = 100), + gwr_args = list(adaptive = FALSE, bandwidth = 300)))) + cmp <- r$value + expect_true(any(grepl(paste0("^compare_models_cv\\(\\): the models predicted ", + "different rows \\(GWR [0-9]+, RF 200\\)"), + r$warnings))) + gp <- cmp$gwr_cv$predictions; rp <- cmp$rf_cv$predictions + common <- intersect(gp$`..row_id`[is.finite(gp$yhat)], rp$`..row_id`) + expect_lt(length(common), 200L) + ov <- cmp$overall + expect_identical(ov$n_pred, rep(length(common), 2L)) + # Each row is exactly the backend's metrics over the common rows ... + for (m in c("GWR", "RF")) { + p <- if (m == "GWR") gp else rp + ref <- spatialkit:::.cv_overall_metrics(p[p$`..row_id` %in% common, ], mae) + got <- ov[ov$model == m, names(ref)] + rownames(got) <- NULL + expect_equal(got, ref, info = m) + } + # ... and what each reported over its own rows is kept beside it. + all_rows <- attr(ov, "all_rows") + expect_identical(all_rows$model, ov$model) + expect_equal(all_rows$RMSE[all_rows$model == "RF"], cmp$rf_cv$overall$RMSE) + expect_identical(all_rows$n_pred[all_rows$model == "RF"], 200L) +}) + +test_that("compare_models_cv() re-scores the point metrics only, and says so", { + # A stand-in Bayesian backend that lost the last fold: its point metrics and + # the user metric are recomputed on the shared rows; coverage and CRPS, + # which are per fold, are carried as they came; by_fold is untouched. + skip_if_not_installed("ranger") + pts <- surf_test_points(60, seed = 4) + fake_bayes <- function(data_sf, response_var, predictor_vars, folds = NULL, ...) { + lost <- folds$folds[[3]]$test + keep <- !(data_sf$..row_id %in% lost) + y <- sf::st_drop_geometry(data_sf)[[response_var]][keep] + pr <- data.frame(`..row_id` = data_sf$..row_id[keep], fold = 1L, y = y, + yhat = y + 0.1, y_train_mean = mean(y), check.names = FALSE) + fm <- data.frame(fold = 1:2, n_pred = c(20L, 20L), RMSE = c(0.1, 0.1)) + list(overall = spatialkit:::.cv_overall_metrics(pr, list(...)$metrics), + fold_metrics = fm, predictions = pr, folds = folds, + n_folds_attempted = 3L, n_folds_succeeded = 2L, + predictive_coverage = list(coverage_95 = 0.9, mean_CRPS = 0.2)) + } + local_mocked_bindings(cv_bayes = fake_bayes, + .model_available = function(model_name) TRUE, + .package = "spatialkit") + mae <- function(y, yhat) c(MedAE = stats::median(abs(y - yhat))) + expect_warning( + res <- compare_models_cv(pts, "z", "w", models = c("RF", "Bayesian"), k = 3, + rf_args = list(num_trees = 40), quiet = TRUE, + metrics = mae), + "different rows \\(Bayesian [0-9]+, RF 60\\)") + ov <- res$overall + n_common <- nrow(res$bayes_cv$predictions) + expect_identical(ov$n_pred, rep(n_common, 2L)) + rp <- res$rf_cv$predictions + rp <- rp[rp$`..row_id` %in% res$bayes_cv$predictions$`..row_id`, ] + expect_equal(ov$RMSE[ov$model == "RF"], sqrt(mean((rp$y - rp$yhat)^2))) + expect_equal(ov$MedAE[ov$model == "RF"], stats::median(abs(rp$y - rp$yhat))) + expect_identical(ov$coverage_95[ov$model == "Bayesian"], 0.9) + expect_identical(ov$mean_CRPS[ov$model == "Bayesian"], 0.2) + expect_equal(attr(ov, "all_rows")$RMSE[ov$model == "RF"], res$rf_cv$overall$RMSE) + expect_identical(nrow(res$by_fold), 2L + nrow(res$rf_cv$fold_metrics)) +}) diff --git a/tests/testthat/test-review-gwr.R b/tests/testthat/test-review-gwr.R new file mode 100644 index 0000000..03a813a --- /dev/null +++ b/tests/testthat/test-review-gwr.R @@ -0,0 +1,186 @@ +# =========================================================================== +# GWR regressions from the adversarial review. +# =========================================================================== + +skip_if_not_installed("GWmodel") +skip_if_not_installed("sp") + + +# --------------------------------------------------------------------------- +# POINT Z / M geometry. GWmodel is strictly 2-D: gw.dist() refuses a third +# data coordinate and reshapes prediction points with matrix(, ncol = 2), so +# an elevation that survived into the sp object scrambled predict()'s +# locations, failed or silently 3-D-ified the fit, and put 3-D distances +# into gwr_model_selection(). +# --------------------------------------------------------------------------- + +# The same 120 stations as a 2-D layer and with an elevation (0-3000 m). +.rg_xyz <- function(n = 120, seed = 3) { + set.seed(seed) + x <- runif(n, 0, 2000); y <- runif(n, 0, 2000) + df <- data.frame(x = 5e5 + x, y = 5e6 + y, zel = runif(n, 0, 3000), + a = rnorm(n), b = rnorm(n)) + df$v <- 1 + (x / 1000) * df$a + rnorm(n, 0, 0.3) + list(d2 = sf::st_as_sf(df, coords = c("x", "y"), crs = 32632), + d3 = sf::st_as_sf(df, coords = c("x", "y", "zel"), crs = 32632)) +} + +test_that("prep_model_data() returns XY points for POINT Z and POINT M input", { + xyz <- .rg_xyz() + xy <- sf::st_coordinates(prep_model_data(xyz$d2, "v", "a")) + p3 <- prep_model_data(xyz$d3, "v", "a") + expect_identical(colnames(sf::st_coordinates(p3)), c("X", "Y")) + expect_identical(sf::st_coordinates(p3), xy) + + pm <- sf::st_sf(sf::st_drop_geometry(xyz$d2), + geometry = sf::st_sfc(lapply(seq_len(nrow(xy)), function(i) + sf::st_point(c(xy[i, ], 7), dim = "XYM")), crs = 32632)) + expect_identical(sf::st_coordinates(prep_model_data(pm, "v", "a")), xy) +}) + +test_that("predict() on POINT Z newdata predicts at the XY locations", { + xyz <- .rg_xyz() + fit <- suppressWarnings(fit_gwr_model(xyz$d2, "v", "a", bandwidth = 30)) + # A constant altitude (KML's 0) scrambled the locations just the same. + xy <- sf::st_coordinates(xyz$d2) + d0 <- sf::st_as_sf(data.frame(sf::st_drop_geometry(xyz$d2), + X = xy[, 1], Y = xy[, 2], Z = 0), + coords = c("X", "Y", "Z"), crs = 32632) + expect_identical(predict(fit, newdata = xyz$d3), predict(fit, newdata = xyz$d2)) + expect_identical(predict(fit, newdata = d0), predict(fit, newdata = xyz$d2)) +}) + +test_that("fit_gwr_model() fits POINT Z data on 2-D distances", { + xyz <- .rg_xyz() + f2 <- suppressWarnings(fit_gwr_model(xyz$d2, "v", "a", bandwidth = 30)) + f3 <- suppressWarnings(fit_gwr_model(xyz$d3, "v", "a", bandwidth = 30)) + expect_identical(coef(f3), coef(f2)) + expect_identical(f3$info$AICc, f2$info$AICc) + + # .already_prepped = TRUE skips prep_model_data(), so .to_sp() has to drop + # the elevation itself -- for the fit and again for predict()'s training set. + f3p <- suppressWarnings(fit_gwr_model(xyz$d3, "v", "a", bandwidth = 30, + .already_prepped = TRUE)) + expect_identical(coef(f3p), coef(f2)) + expect_identical(predict(f3p, newdata = xyz$d2[1:10, ]), + predict(f2, newdata = xyz$d2[1:10, ])) +}) + +test_that("gwr_model_selection() and cv_gwr() use 2-D distances on POINT Z data", { + xyz <- .rg_xyz() + s3 <- suppressWarnings(gwr_model_selection(xyz$d3, "v", c("a", "b"), bandwidth = 30)) + s2 <- suppressWarnings(gwr_model_selection(xyz$d2, "v", c("a", "b"), bandwidth = 30)) + expect_identical(s3$table, s2$table) + + folds <- make_folds(xyz$d2, k = 3, method = "block_kfold", seed = 7) + cv3 <- suppressWarnings(suppressMessages( + cv_gwr(xyz$d3, "v", "a", folds = folds, bandwidth = 30))) + cv2 <- suppressWarnings(suppressMessages( + cv_gwr(xyz$d2, "v", "a", folds = folds, bandwidth = 30))) + expect_equal(cv3$n_folds_succeeded, 3L) + expect_identical(cv3$predictions, cv2$predictions) +}) + + +# --------------------------------------------------------------------------- +# predict() at new locations. GWmodel::gwr.predict() returned EVERY value as +# NA when one location's window was empty or singular (inv() threw for the +# whole call), when nrow(train) + nrow(newdata) > 10000 ('DM3.given' not +# found) and when nrow(train) > 5000 ("No regression point is fixed"). +# --------------------------------------------------------------------------- + +.rg_pts <- function(n = 150, seed = 9, extent = 1000) { + set.seed(seed) + x <- runif(n, 0, extent); y <- runif(n, 0, extent) + df <- data.frame(x = 5e5 + x, y = 5e6 + y, a = rnorm(n)) + df$v <- 1 + (x / (extent / 2)) * df$a + rnorm(n, 0, 0.3) + sf::st_as_sf(df, coords = c("x", "y"), crs = 32632) +} + +test_that("one empty fixed-bandwidth window makes only its own prediction NA", { + d <- .rg_pts() + fit <- suppressWarnings(fit_gwr_model(d, "v", "a", adaptive = FALSE, + bandwidth = 300)) + # 20 locations inside the data and, 11th, one 400 m beyond its edge, where + # no training point lies within the bandwidth. + set.seed(1) + nd <- sf::st_as_sf( + data.frame(x = 5e5 + c(runif(10, 100, 900), 1400, runif(10, 100, 900)), + y = 5e6 + c(runif(10, 100, 900), 500, runif(10, 100, 900)), + a = rnorm(21)), + coords = c("x", "y"), crs = 32632) + p_in <- predict(fit, newdata = nd[-11, ]) + expect_false(anyNA(p_in)) + expect_warning(p_all <- predict(fit, newdata = nd), + "1 of 21 location\\(s\\) have no estimable local regression") + expect_true(is.na(p_all[11])) + # The others are the values they get without the bad location, to the bit. + expect_identical(p_all[-11], p_in) +}) + +test_that("fixed-bandwidth block CV scores the held-out points it can reach", { + d <- .rg_pts(n = 200, seed = 10, extent = 2000) + folds <- make_folds(d, k = 4, method = "block_kfold", block_size = 700, + seed = 1) + cv <- suppressWarnings(suppressMessages( + cv_gwr(d, "v", "a", folds = folds, adaptive = FALSE, bandwidth = 400))) + expect_equal(cv$n_folds_succeeded, cv$n_folds_attempted) + expect_gt(cv$overall$n_pred, 0) +}) + +test_that("predict() fills a 100 x 100 grid (train + newdata > 10000 rows)", { + d <- .rg_pts(n = 150, seed = 4) + fit <- suppressWarnings(fit_gwr_model(d, "v", "a", bandwidth = 40)) + gx <- seq(5, 995, length.out = 100) + set.seed(2) + g <- sf::st_as_sf(data.frame(x = 5e5 + rep(gx, 100), + y = 5e6 + rep(gx, each = 100), + a = rnorm(1e4)), + coords = c("x", "y"), crs = 32632) + p <- predict(fit, newdata = g) + expect_length(p, 1e4) + expect_false(anyNA(p)) + some <- c(1:50, 9951:1e4) + expect_identical(p[some], predict(fit, newdata = g[some, ])) +}) + +test_that("predict() works with more than 5000 training rows", { + d <- .rg_pts(n = 5200, seed = 12, extent = 5000) + # A GWR fit of 5200 rows takes minutes; predict() needs only the data and + # the settings, so hand it those. + fit <- new_spatial_fit("gwr_fit", engine = list(), formula = v ~ a, + response_var = "v", predictor_vars = "a", data_sf = d, + info = list(bandwidth = 60, adaptive = TRUE, + kernel = "bisquare")) + nd <- d[c(7, 1000, 4000), ] + nd$a <- c(-1, 0.5, 2) + p <- predict(fit, newdata = nd) + # Local least squares by hand: bisquare weights on the distance to the + # 60th-nearest TRAINING point. + xy <- sf::st_coordinates(d) + X <- cbind(1, d$a) + hand <- vapply(1:3, function(i) { + xy0 <- sf::st_coordinates(nd)[i, ] + dd <- sqrt((xy[, 1] - xy0[1])^2 + (xy[, 2] - xy0[2])^2) + w <- spatialkit:::.gw_kernel_weights(dd, 60, "bisquare", TRUE) + b <- solve(crossprod(X, w * X), crossprod(X, w * d$v)) + sum(c(1, nd$a[i]) * b) + }, numeric(1)) + expect_equal(p, hand, tolerance = 1e-10) +}) + +test_that("predict() keeps fitted() at the training points and NA rows in place", { + # Not regressions -- the gwr.predict() path got these right too -- but what + # its replacement has to preserve. + d <- .rg_pts(n = 120, seed = 3) + for (ad in c(TRUE, FALSE)) { + fit <- suppressWarnings(fit_gwr_model(d, "v", "a", adaptive = ad, + bandwidth = if (ad) 30 else 400)) + expect_identical(predict(fit, newdata = d), unname(fitted(fit))) + } + nd <- d[1:12, ] + nd$a[c(2, 9)] <- c(NA, Inf) + p <- predict(fit, newdata = nd) + expect_identical(which(is.na(p)), c(2L, 9L)) + expect_identical(p[-c(2, 9)], predict(fit, newdata = nd[-c(2, 9), ])) +}) diff --git a/tests/testthat/test-review-resolution.R b/tests/testthat/test-review-resolution.R new file mode 100644 index 0000000..ba20a14 --- /dev/null +++ b/tests/testthat/test-review-resolution.R @@ -0,0 +1,237 @@ +# tests/testthat/test-review-resolution.R +# --------------------------------------------------------------------------- +# Regressions from the review of the resolution step: resolution_profile() +# and determine_optimal_levels(). +# --------------------------------------------------------------------------- + +# A hand-made sac_range, so the variogram-based columns exist without gstat +# and without the time an estimate takes. +rr_sac <- function(pts, range = 1500, nugget = 1, psill = 1) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(pts)) +} + + +test_that("one missing response or predictor value does not switch the profile to the raw response", { + # The response is the predictor plus white noise, and the predictor carries + # a strong east-west trend: the residuals have no structure, the raw + # response a great deal. One NA used to make the first lm.fit() on every + # row fail, and the profile then scored the raw response. + set.seed(10) + n <- 300 + d <- data.frame(x = runif(n, 0, 10000), y = runif(n, 0, 10000)) + d$p <- d$x / 1000 + rnorm(n) + d$z <- 3 * d$p + rnorm(n) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + sac <- rr_sac(pts) + clean <- resolution_profile(pts, "z", "p", levels = c(10, 20, 40), sac = sac) + expect_identical(attr(clean, "variable"), "residuals") + for (col in c("z", "p")) { + holed <- pts + holed[[col]][17] <- NA + lines <- capture_spatialkit_log( + prof <- resolution_profile(holed, "z", "p", levels = c(10, 20, 40), sac = sac)) + expect_identical(attr(prof, "variable"), "residuals", info = col) + expect_true(log_has(lines, "1 of 300 row"), info = col) + expect_false(log_has(lines, "OLS fit on `predictor_vars` failed"), info = col) + # One row fewer of the same residuals: the RSS barely moves. The raw + # response's RSS was several times larger. + expect_equal(prof$rss, clean$rss, tolerance = 0.05, info = col) + expect_equal(prof$cp, clean$cp, tolerance = 0.05, info = col) + } +}) + + +test_that("a layer larger than sample_n is bounded, judged and scored on all its points", { + # 1200 points on a 10 km square, fitted on a 300-point subsample. A range + # of 1200 puts the floor at ceiling(1e8 / 1200^2) = 70 cells, which the + # layer supports (floor(1200 / 9) = 133) and the subsample alone did not + # (floor(300 / 9) = 33): the profile used to call these data unsupported, + # run its ladder from 2 to 33, and hand a count of at most 33 to the + # tessellation of all 1200 points. + set.seed(3) + N <- 1200 + d <- data.frame(x = runif(N, 0, 10000), y = runif(N, 0, 10000), z = rnorm(N)) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + sac <- rr_sac(pts, range = 1200, nugget = 0.5, psill = 1) + lines <- capture_spatialkit_log( + prof <- resolution_profile(pts, "z", sac = sac, n_levels = 4, nstart = 3, + sample_n = 300)) + b <- attr(prof, "bounds") + expect_identical(b$n, 1200L) + expect_identical(b$n_sample, 300L) + expect_identical(b$ceiling, 133L) + expect_identical(b$ceiling_from, "min_cell_n") + expect_true(b$supported) + expect_false(log_has(lines, "cannot support")) + expect_identical(min(prof$levels), b$floor) + expect_identical(max(prof$levels), 133L) + expect_output(print(prof), "on 1200 points") + # The bounds do not move with sample_n. + b2 <- attr(resolution_profile(pts, "z", sac = sac, n_levels = 4, nstart = 3, + sample_n = 600), "bounds") + expect_identical(b2[c("floor", "ceiling", "supported", "n")], + b[c("floor", "ceiling", "supported", "n")]) + # Reliability is for cells holding the layer's points, not the subsample's. + vm <- attr(sac, "variogram_model") + cf <- spatialkit:::.vgm_correlation_fn(vm) + # The domain term over the hull the area is measured on (review round 2). + hull <- sf::st_convex_hull(sf::st_union(sf::st_geometry(pts))) + rbV <- spatialkit:::.rbar_domain(cf, hull, b$area) + expect_equal(prof$reliability, + vapply(prof$levels, spatialkit:::.reliability_at, numeric(1), + area = b$area, n_total = 1200, nugget = 0.5, psill = 1, + cor_fn = cf, rbar_V = rbV)) + # Cp: the subsample's RSS with its own optimism added back, plus the + # variance of cell means built from all 1200 points. Every subsample cell + # holds a scored row here, so L_m = L. + expect_equal(prof$cp, prof$rss / 300 + 0.5 * (prof$levels / 300 + prof$levels / 1200)) +}) + + +test_that("select_on = 'split' chooses a count for the layer it is applied to", { + # Four clusters at the corners of a 10 km square. Every spatial half holds + # two of them, and determine_optimal_levels(select_on = "split") used to + # run on that half and answer 2, which the documented workflow then + # applied to a tessellation of all four clusters. + set.seed(1) + cen <- expand.grid(cx = c(1000, 9000), cy = c(1000, 9000)) + g <- rep(1:4, each = 60) + d <- data.frame(x = rnorm(240, cen$cx[g], 300), y = rnorm(240, cen$cy[g], 300), + a = rnorm(240), b = rnorm(240)) + d$z <- d$a + rnorm(240) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + all <- suppressWarnings(determine_optimal_levels( + pts, max_levels = 12, response_var = "z", predictor_vars = c("a", "b"), set_seed = 1)) + spl <- suppressWarnings(determine_optimal_levels( + pts, max_levels = 12, response_var = "z", predictor_vars = c("a", "b"), + select_on = "split", set_seed = 1)) + expect_identical(as.integer(all[1]), 4L) + expect_identical(as.integer(spl[1]), 4L) +}) + + +test_that("select_on = 'split' reads the selection half's response on the whole layer's cells", { + # The Moran pass is the only step that reads the response. Record what it + # is handed: the selection half's rows, labelled by k-means cells fitted to + # every point. On the half's own partition every level would label the + # half's rows with all k cells; on the whole layer's, a spatial half falls + # in only some of them. + set.seed(8) + n <- 200 + d <- data.frame(x = runif(n, 0, 5000), y = runif(n, 0, 5000), w = rnorm(n)) + d$z <- 2 * d$w + rnorm(n) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + seen <- list() + local_mocked_bindings( + .morans_i_for_k = function(xy, response, predictors, cluster_ids) { + seen[[length(seen) + 1L]] <<- list(resp = response, cl = cluster_ids) + c(I = NA_real_, z = NA_real_) + }, + .package = "spatialkit") + out <- suppressWarnings(determine_optimal_levels( + pts, max_levels = 12, response_var = "z", predictor_vars = "w", + criterion = "morans_i", select_on = "split", set_seed = 2)) + sel <- attr(out, "split")$selection + expect_true(length(seen) > 0L) + # The rows arrive in the canonical (coordinate) order the sweep uses, so + # compare them as a set. + for (s in seen) expect_identical(sort(s$resp), sort(pts$z[sel])) + ks <- vapply(seen, function(s) max(s$cl), integer(1)) + used <- vapply(seen, function(s) length(unique(s$cl)), integer(1)) + expect_true(any(used < ks)) +}) + + +test_that("a split profile is bounded on the whole layer and reads one half's response", { + # Three clusters of 210, 60 and 30 points. Profiled on its selection half, + # the split used to take the half's hull (1.6e6 against 4.6e7 m^2), the + # half's point count and the half's clusters, and so bounded and judged a + # different layer from the one the count was applied to. + set.seed(10) + mk <- function(n, cx, cy) data.frame(x = rnorm(n, cx, 150), y = rnorm(n, cy, 150)) + d <- rbind(mk(210, 2000, 2000), mk(60, 8000, 3000), mk(30, 5000, 8000)) + d$z <- 0.0002 * d$x + rnorm(300) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + sac <- rr_sac(pts, range = 1500, nugget = 1, psill = 0.5) + prof <- function(p, ...) resolution_profile(p, "z", sac = sac, n_levels = 5, nstart = 5, ...) + all <- prof(pts) + spl <- suppressWarnings(prof(pts, select_on = "split")) + keys <- c("floor", "ceiling", "ceiling_from", "supported", "area", "n", "n_distinct") + expect_identical(attr(spl, "bounds")[keys], attr(all, "bounds")[keys]) + expect_identical(spl$levels, all$levels) + expect_identical(spl$wss, all$wss) + # The estimation half's response is never read; the selection half's is. + s <- attr(spl, "split") + pts_e <- pts; pts_e$z[s$estimation] <- rnorm(length(s$estimation), 50, 20) + spl_e <- suppressWarnings(prof(pts_e, select_on = "split")) + expect_identical(spl_e[c("rss", "cp", "moran_z")], spl[c("rss", "cp", "moran_z")]) + pts_s <- pts; pts_s$z[s$selection] <- rnorm(length(s$selection), 50, 20) + spl_s <- suppressWarnings(prof(pts_s, select_on = "split")) + expect_false(isTRUE(all.equal(spl_s$rss, spl$rss))) +}) + + +test_that("a WSS curve that falls like c / k has no elbow", { + # The linear-axis chord rule answers sqrt(k_min * k_max) on c / k, here 4, + # and that used to be returned as the knee. + eb <- spatialkit:::.elbow_from_wss(1000 / (1:12)) + expect_false(eb$structured) + expect_true(all(abs(eb$diagnostics$sag) < 1e-12)) + # A bend at the cluster count on the same scale is one. + bent <- spatialkit:::.elbow_from_wss(c(1000, 400, 150, 60 * 4 / (4:12))) + expect_true(bent$structured) + expect_identical(bent$knee_k, 4L) +}) + + +test_that("determine_optimal_levels() warns when uniform points have no elbow", { + set.seed(3) + n <- 400 + pts <- sf::st_as_sf(data.frame(x = runif(n, 0, 10000), y = runif(n, 0, 10000)), + coords = c("x", "y"), crs = 32632) + for (ml in c(12, 40)) { + expect_warning(k <- determine_optimal_levels(pts, max_levels = ml), + "no elbow.*set by the ladder") + expect_type(k, "integer") + } +}) + + +test_that("determine_optimal_levels() finds 2 to 8 separated clusters without a warning", { + # At the default max_levels = 12 the linear chord rule answered 3 or 4 for + # eight clusters: the fall of the between-cluster WSS outweighed the knee. + for (K in c(2L, 3L, 4L, 8L)) { + set.seed(K) + ctr <- expand.grid(x = seq(0, by = 2500, length.out = 4), y = c(0, 2500))[seq_len(K), ] + g <- rep(seq_len(K), each = 40) + pts <- sf::st_as_sf(data.frame(x = ctr$x[g] + rnorm(40 * K, sd = 100), + y = ctr$y[g] + rnorm(40 * K, sd = 100)), + coords = c("x", "y"), crs = 32632) + expect_no_warning(k <- determine_optimal_levels(pts, max_levels = 12)) + expect_identical(k[1], K, info = paste("K =", K)) + } +}) + + +test_that("a geometry-only profile of uniform points names no cell count", { + set.seed(5) + n <- 600 + pts <- sf::st_as_sf(data.frame(x = runif(n, 0, 10000), y = runif(n, 0, 10000)), + coords = c("x", "y"), crs = 32632) + prof <- resolution_profile(pts, n_levels = 8, nstart = 5) + expect_true(all(is.na(prof$elbow))) + expect_output(print(prof), "elbow : none") + expect_error(select_resolution(prof, "elbow"), "no elbow") + # build_tessellation() used to read the chord rule's sqrt(first x last + # level) off this profile, 16 to 18 cells on any large uniform layer. + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + expect_error(build_tessellation(pts, boundary = bnd, method = "hex", + approx_n_cells = prof, quiet = TRUE), + "no cluster structure") + expect_error(get_voronoi_seeds(bnd, method = "kmeans", n = prof, + sample_points = pts, set_seed = 1), + "no cluster structure") +}) diff --git a/tests/testthat/test-review-tessellation.R b/tests/testthat/test-review-tessellation.R new file mode 100644 index 0000000..3c13461 --- /dev/null +++ b/tests/testthat/test-review-tessellation.R @@ -0,0 +1,406 @@ +# =========================================================================== +# Regressions from the adversarial review of the tessellation slice: +# +# * coerce_to_points(mode = "auto") segfaulted R on an EMPTY +# MULTILINESTRING (st_cast() gives one empty part, and st_line_sample() +# on it crashes in sf 1.0.x), and refused an EMPTY LINESTRING outright. +# * build_tessellation(method = "triangles") handed raw UTM-sized +# coordinates to qhull, which lost the precision to make nearby points +# vertices. +# * .pick_local_projected_crs() sent circumpolar lon/lat data to Web +# Mercator as if they were global coverage. +# * st_point_on_surface() segfaulted R (GEOS 3.12.1) on a non-empty feature +# holding an EMPTY line part, which ensure_projected() reached for any +# lon/lat line layer. +# =========================================================================== + + +# --------------------------------------------------------------------------- +# Empty lines in coerce_to_points() +# --------------------------------------------------------------------------- + +# Run `code` in a fresh R process that loads this same copy of spatialkit and +# return its exit status, its output and whatever it saved as `res`. The +# regression being guarded is a SEGFAULT: run in this process, a relapse +# would kill the whole test run instead of failing one test. +.rt_run_child <- function(code) { + ns_path <- getNamespaceInfo(asNamespace("spatialkit"), "path") + installed <- file.exists(file.path(ns_path, "Meta", "package.rds")) + load_line <- if (installed) { + sprintf("suppressPackageStartupMessages(library(spatialkit, lib.loc = %s))", + deparse(dirname(ns_path))) + } else { + sprintf("suppressMessages(pkgload::load_all(%s, quiet = TRUE))", + deparse(ns_path)) + } + script <- tempfile(fileext = ".R") + out <- tempfile(fileext = ".rds") + on.exit(unlink(c(script, out)), add = TRUE) + writeLines(c(sprintf(".libPaths(%s)", paste(deparse(.libPaths()), collapse = "")), + load_line, + code, + sprintf("saveRDS(res, %s)", deparse(out))), + script) + output <- suppressWarnings(system2(file.path(R.home("bin"), "Rscript"), + c("--vanilla", shQuote(script)), + stdout = TRUE, stderr = TRUE)) + status <- attr(output, "status") + list(status = if (is.null(status)) 0L else as.integer(status), + output = output, + res = if (file.exists(out)) readRDS(out) else NULL) +} + + +test_that("coerce_to_points turns empty lines into empty POINTs instead of crashing", { + child <- .rt_run_child(c( + "seg <- function(x0, y0, x1, y1) rbind(c(x0, y0), c(x1, y1))", + "mls <- function(...) sf::st_multilinestring(list(...))", + "try_ <- function(expr) tryCatch(expr, error = function(e) conditionMessage(e))", + "res <- list()", + # An empty MULTILINESTRING between two real ones, projected. + "x <- sf::st_sf(id = 1:3, geometry = sf::st_sfc(", + " mls(seg(0, 0, 10, 0)), sf::st_multilinestring(), mls(seg(0, 0, 0, 20)),", + " crs = 32617))", + "res$mls_proj <- try_(coerce_to_points(x, 'auto'))", + # The same in lon/lat, projected temporarily (the default). + "x_ll <- sf::st_sf(id = 1:3, geometry = sf::st_sfc(", + " mls(seg(-80, 35, -79, 35)), sf::st_multilinestring(),", + " mls(seg(-80, 35, -80, 36)), crs = 4326))", + "res$mls_ll <- try_(suppressWarnings(coerce_to_points(x_ll, 'auto')))", + # A layer of one empty row. + "res$mls_one <- try_(coerce_to_points(x[2, ], 'auto'))", + # An empty PART beside a real one: the empty part used to be sampled + # whenever it came first among parts of equal (zero) length. + "x_part <- sf::st_sf(id = 1:2, geometry = sf::st_sfc(", + " sf::st_multilinestring(list(matrix(numeric(0), 0, 2), seg(0, 0, 10, 0))),", + " sf::st_multilinestring(list(matrix(numeric(0), 0, 2), seg(3, 4, 3, 4))),", + " crs = 32617))", + "res$mls_part <- try_(coerce_to_points(x_part, 'auto'))", + # An empty LINESTRING, in both modes that sample lines. + "x_ls <- sf::st_sf(id = 1:3, geometry = sf::st_sfc(", + " sf::st_linestring(seg(0, 0, 10, 0)), sf::st_linestring(),", + " sf::st_linestring(seg(0, 0, 0, 20)), crs = 32617))", + "res$ls_auto <- try_(coerce_to_points(x_ls, 'auto'))", + "res$ls_mid <- try_(coerce_to_points(x_ls, 'line_midpoint'))", + # The documented cleaning path: prep_model_data() drops empty rows, but + # it pointizes first, so this is where a GeoPackage null geometry crashed. + "d <- x; d$y <- c(1, 2, 3); d$x1 <- c(0.1, 0.5, 0.9)", + "res$prep <- try_(prep_model_data(d, 'y', 'x1'))" + )) + + expect_equal(child$status, 0L, + info = paste(utils::tail(child$output, 25), collapse = "\n")) + res <- child$res + expect_type(res, "list") + if (!is.list(res)) return(invisible()) + + xy <- function(p) unname(sf::st_coordinates(p)[, 1:2, drop = FALSE]) + for (nm in c("mls_proj", "mls_ll", "mls_one", "mls_part", "ls_auto", + "ls_mid", "prep")) { + expect_s3_class(res[[nm]], "sf") + } + if (!all(vapply(res, inherits, logical(1), "sf"))) return(invisible()) + + # Row for row with the input: the empty feature is an empty POINT in its + # own row (st_coordinates() gives it an NA row), and its neighbours get + # their true midpoints. + for (nm in c("mls_proj", "ls_auto", "ls_mid")) { + got <- res[[nm]] + expect_equal(got$id, 1:3, info = nm) + expect_true(all(sf::st_geometry_type(got) == "POINT"), info = nm) + expect_equal(sf::st_is_empty(got), c(FALSE, TRUE, FALSE), info = nm) + expect_equal(xy(got)[c(1, 3), ], rbind(c(5, 0), c(0, 10)), info = nm) + } + + ll <- res$mls_ll + expect_equal(sf::st_is_empty(ll), c(FALSE, TRUE, FALSE)) + expect_equal(sf::st_crs(ll), sf::st_crs(4326)) + expect_equal(xy(ll)[c(1, 3), ], rbind(c(-79.5, 35), c(-80, 35.5)), + tolerance = 1e-4) + + expect_equal(nrow(res$mls_one), 1L) + expect_true(sf::st_is_empty(res$mls_one)) + + # The real part is the one sampled; a zero-length part gives its point. + expect_false(any(sf::st_is_empty(res$mls_part))) + expect_equal(xy(res$mls_part), rbind(c(5, 0), c(3, 4))) + + # prep_model_data() drops the empty row and says why. + expect_equal(nrow(res$prep), 2L) + expect_equal(res$prep$y, c(1, 3)) + expect_equal(attr(res$prep, "dropped")$n_geometry, 1L) + expect_equal(attr(res$prep, "dropped")$which, 2L) +}) + + +# --------------------------------------------------------------------------- +# Delaunay triangles at UTM-sized coordinates +# --------------------------------------------------------------------------- + +.rt_utm_points <- function(n, x0, y0, ext = 100, seed = 42) { + set.seed(seed) + sf::st_as_sf(data.frame(x = x0 + stats::runif(n, 0, ext), + y = y0 + stats::runif(n, 0, ext)), + coords = c("x", "y"), crs = 32632) +} + +# One key per triangle from its vertex coordinates, independent of the order +# its vertices are listed in. +.rt_tri_key <- function(cells) { + vapply(seq_len(nrow(cells)), function(i) { + m <- sf::st_coordinates(cells[i, ])[1:3, 1:2] + paste(sort(sprintf("%.17g_%.17g", m[, 1], m[, 2])), collapse = "|") + }, character(1)) +} + + +test_that("triangles makes every point a vertex at UTM-sized coordinates", { + skip_if_not_installed("geometry") + # qhull lifts points onto x^2 + y^2; with raw northings near 5e6 (and 9e6 + # south of the equator) points a few metres apart were dropped as coplanar. + # 200 points over 100 m gave a few dozen triangles instead of ~386, with + # every point still indexed into one, so nothing looked wrong. + n <- 200L + for (off in list(c(5e5, 5e6), c(5e5, 9.9e6))) { + pts <- .rt_utm_points(n, off[1], off[2]) + res <- build_tessellation(pts, method = "triangles", quiet = TRUE) + lab <- sprintf("offset (%g, %g)", off[1], off[2]) + + # Euler: a Delaunay triangulation of n points in general position with h + # of them on the hull has 2n - h - 2 triangles. + h <- nrow(sf::st_coordinates( + sf::st_convex_hull(sf::st_union(sf::st_geometry(pts))))) - 1L + expect_equal(nrow(res$cells), 2L * n - h - 2L, info = lab) + + # Every input point is a vertex, at its own coordinates exactly: the + # centring is undone by building rings from the original coordinates, + # not by adding the shift back. + key <- function(m) sprintf("%.17g_%.17g", m[, 1], m[, 2]) + vtx <- key(sf::st_coordinates(res$cells)[, 1:2, drop = FALSE]) + inp <- key(sf::st_coordinates(pts)) + expect_true(all(inp %in% vtx), info = lab) + expect_true(all(vtx %in% inp), info = lab) + + # The same points moved to the origin triangulate identically. + shifted <- sf::st_set_geometry(pts, sf::st_geometry(pts) - off) + sf::st_crs(shifted) <- sf::st_crs(pts) + ref <- build_tessellation(shifted, method = "triangles", quiet = TRUE) + expect_equal(nrow(res$cells), nrow(ref$cells), info = lab) + expect_equal(sum(as.numeric(sf::st_area(res$cells))), + sum(as.numeric(sf::st_area(ref$cells))), tolerance = 1e-8, + info = lab) + } +}) + + +test_that("triangle cell_ids do not depend on the input row order", { + skip_if_not_installed("geometry") + # Not a regression of the old code (qhull's output order does not follow + # the input order for points in general position), but the centring must + # not break it: the shift is the bbox midpoint, which a permutation leaves + # bit-identical, where a mean could differ in its last bits. + pts <- .rt_utm_points(150L, 5e5, 5e6, seed = 7) + set.seed(8) + perm <- sample(nrow(pts)) + a <- build_tessellation(pts, method = "triangles", quiet = TRUE) + b <- build_tessellation(pts[perm, ], method = "triangles", quiet = TRUE) + expect_identical(.rt_tri_key(a$cells), .rt_tri_key(b$cells)) + expect_identical(a$cells$cell_id, b$cells$cell_id) + expect_identical(a$index[perm], b$index) +}) + + +# --------------------------------------------------------------------------- +# Circumpolar lon/lat data +# --------------------------------------------------------------------------- + +.rt_ring <- function(lat_lo, lat_hi, n = 40L, seed = 2) { + set.seed(seed) + sf::st_as_sf(data.frame(lon = stats::runif(n, -180, 180), + lat = stats::runif(n, lat_lo, lat_hi)), + coords = c("lon", "lat"), crs = 4326) +} + + +test_that("circumpolar data get a pole-centred equal-area projection, not Web Mercator", { + ant <- .rt_ring(-80, -65) + lines <- capture_spatialkit_log(out <- ensure_projected(ant)) + p4 <- sf::st_crs(out)$proj4string + expect_match(p4, "+proj=laea", fixed = TRUE) + expect_match(p4, "+lat_0=-90", fixed = TRUE) + expect_true(log_has(lines, "circles the South Pole")) + expect_false(log_has(lines, "global coverage")) + + # The choice is measured, and the figures travel with the result. + ch <- attr(out, "crs_choice") + expect_s3_class(ch, "data.frame") + expect_equal(nrow(ch), 2L) + expect_match(ch$name[ch$chosen], "South Pole") + expect_lt(ch$distance_error[ch$chosen], 0.05) + expect_gt(ch$distance_error[!ch$chosen], 1) # Web Mercator: >100% + + # The quantity that matters: a 1-degree pair along a meridian at 75S is + # about 111 km, and Web Mercator made it about 445 km. + pair <- sf::st_as_sf(data.frame(lon = c(0, 0), lat = c(-75, -76)), + coords = c("lon", "lat"), crs = 4326) + d_true <- as.numeric(sf::st_distance(pair)[1, 2]) + d_proj <- as.numeric(stats::dist(sf::st_coordinates( + sf::st_transform(pair, sf::st_crs(out))))) + expect_lt(abs(d_proj / d_true - 1), 0.02) + + # A station AT the pole: Web Mercator put it at y = -2.4e8 m. + sp <- rbind(ant, sf::st_as_sf(data.frame(lon = 0, lat = -90), + coords = c("lon", "lat"), crs = 4326)) + xy <- sf::st_coordinates(ensure_projected(sp)) + expect_true(all(is.finite(xy))) + expect_lt(max(abs(xy)), 1e7) + + # The Arctic gets the North Pole. + arc <- ensure_projected(.rt_ring(66, 84)) + expect_match(sf::st_crs(arc)$proj4string, "+lat_0=90", fixed = TRUE) + + # purpose = "area": the polar Lambert azimuthal is equal-area, so it is the + # answer there too, in place of Equal Earth. + ant_area <- ensure_projected(ant, purpose = "area") + expect_match(sf::st_crs(ant_area)$proj4string, "+proj=laea", fixed = TRUE) + expect_match(sf::st_crs(ant_area)$proj4string, "+lat_0=-90", fixed = TRUE) + + # And it reaches the tessellation: Voronoi cells are built in it. + tess <- build_tessellation(.rt_ring(66, 84, n = 30L), method = "voronoi", + quiet = TRUE) + expect_match(sf::st_crs(tess$cells)$proj4string, "+lat_0=90", fixed = TRUE) +}) + + +test_that("global coverage and low-latitude belts keep the global fallback", { + # Both hemispheres: global coverage, unchanged. + set.seed(3) + glob <- sf::st_as_sf(data.frame(lon = stats::runif(80, -170, 170), + lat = stats::runif(80, -60, 70)), + coords = c("lon", "lat"), crs = 4326) + gl <- capture_spatialkit_log(g_out <- ensure_projected(glob)) + expect_equal(sf::st_crs(g_out)$epsg, 3857L) + expect_null(attr(g_out, "crs_choice")) + expect_true(log_has(gl, "global coverage")) + expect_match(sf::st_crs(ensure_projected(glob, purpose = "area"))$proj4string, + "eqearth|moll") + + # One hemisphere, but a low-latitude belt that does not wrap round the + # antimeridian: the polar projection measures worse than Web Mercator + # there, so it is not used. + set.seed(4) + belt <- sf::st_as_sf(data.frame(lon = stats::runif(60, -100, 100), + lat = stats::runif(60, 0, 20)), + coords = c("lon", "lat"), crs = 4326) + expect_equal(sf::st_crs(ensure_projected(belt))$epsg, 3857L) +}) + + +# --------------------------------------------------------------------------- +# Empty parts inside non-empty features +# --------------------------------------------------------------------------- + +test_that("an empty part inside a line feature no longer crashes the interior point", { + # GEOS segfaults computing the interior point of a non-empty feature that + # holds an EMPTY line: a MULTILINESTRING with an empty part beside a real + # one, or a GEOMETRYCOLLECTION with an empty LINESTRING member. + # .crs_distance_error() reduces every lon/lat line layer to such points, so + # plain ensure_projected() took the session down, and with it + # coerce_to_points(mode = "auto") at its default tmp_project = TRUE. Run + # in a child process for the same reason as the empty-line test above. + child <- .rt_run_child(c( + "e2 <- matrix(numeric(0), 0, 2)", + "try_ <- function(expr) tryCatch(expr, error = function(e) conditionMessage(e))", + "ln <- function(x0, y0, d) rbind(c(x0, y0), c(x0 + d, y0), c(x0 + 2 * d, y0))", + "res <- list()", + # lon/lat: reached through .crs_distance_error(). + "ll <- sf::st_sf(id = 1:3, geometry = sf::st_sfc(", + " sf::st_multilinestring(list(ln(-80, 35, 0.1))),", + " sf::st_multilinestring(list(e2, ln(-79, 35.5, 0.1))),", + " sf::st_multilinestring(list(ln(-78, 36, 0.1))), crs = 4326))", + "res$ep_mls <- try_(ensure_projected(ll))", + "res$ctp_mls <- try_(coerce_to_points(ll, 'auto'))", + "gc_ll <- sf::st_sf(id = 1:3, geometry = sf::st_sfc(", + " sf::st_geometrycollection(list(sf::st_point(c(-80, 35)))),", + " sf::st_geometrycollection(list(sf::st_linestring(), sf::st_point(c(-79, 35.5)))),", + " sf::st_geometrycollection(list(sf::st_point(c(-78, 36)))), crs = 4326))", + "res$ep_gc <- try_(ensure_projected(gc_ll))", + # coerce_to_points(mode = 'point_on_surface'), projected. + "pr <- sf::st_sf(id = 1:4, geometry = sf::st_sfc(", + " sf::st_multilinestring(list(e2, ln(0, 0, 5))),", + " sf::st_geometrycollection(list(sf::st_linestring(), sf::st_point(c(3, 4)))),", + " sf::st_geometrycollection(list(sf::st_multilinestring(list(e2, ln(0, 10, 5))))),", + # No crash here, but GEOS read the empty POLYGON as the feature's + # dimension and returned POINT EMPTY for a feature with a line in it. + " sf::st_geometrycollection(list(sf::st_polygon(), sf::st_linestring(ln(0, 20, 5)))),", + " crs = 32617))", + "res$pos <- try_(coerce_to_points(pr, 'point_on_surface'))" + )) + + expect_equal(child$status, 0L, + info = paste(utils::tail(child$output, 25), collapse = "\n")) + res <- child$res + expect_type(res, "list") + if (!is.list(res)) return(invisible()) + for (nm in c("ep_mls", "ctp_mls", "ep_gc", "pos")) expect_s3_class(res[[nm]], "sf") + if (!all(vapply(res, inherits, logical(1), "sf"))) return(invisible()) + + # The projection was measured on the real parts, not given up on. + for (nm in c("ep_mls", "ep_gc")) { + expect_false(sf::st_is_longlat(res[[nm]]), info = nm) + expect_equal(nrow(res[[nm]]), 3L, info = nm) + ch <- attr(res[[nm]], "crs_choice") + expect_true(is.data.frame(ch) && all(is.finite(ch$distance_error)), info = nm) + } + + # Row for row, and the empty part changes nothing: the midpoint of the + # longest (only real) part, back in lon/lat. + ctp <- res$ctp_mls + expect_equal(ctp$id, 1:3) + expect_false(any(sf::st_is_empty(ctp))) + expect_equal(unname(sf::st_coordinates(ctp)[2, ]), c(-78.9, 35.5), tolerance = 1e-4) + + # The interior point of each feature is the one it has without its empty + # parts: the middle vertex of a three-vertex line, the point itself. + pos <- res$pos + expect_equal(pos$id, 1:4) + expect_false(any(sf::st_is_empty(pos))) + expect_equal(unname(sf::st_coordinates(pos)), + rbind(c(5, 0), c(3, 4), c(5, 10), c(5, 20))) +}) + + +test_that(".drop_empty_parts removes empty parts only, and keeps every row", { + e2 <- matrix(numeric(0), 0, 2) + ln <- rbind(c(0, 0), c(1, 1)) + sq <- rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)) + g <- sf::st_sfc( + sf::st_multilinestring(list(e2, ln)), + sf::st_geometrycollection(list(sf::st_linestring(), sf::st_point(c(2, 2)))), + sf::st_geometrycollection(list(sf::st_multilinestring(list(e2, ln)))), + sf::st_multipolygon(list(list(), list(sq))), + sf::st_multilinestring(list(e2, e2)), + sf::st_point(c(5, 5)), + crs = 32632) + out <- .drop_empty_parts(g) + + expect_length(out, length(g)) + expect_equal(sf::st_crs(out), sf::st_crs(g)) + expect_equal(as.character(sf::st_geometry_type(out)), + as.character(sf::st_geometry_type(g))) + expect_equal(sf::st_as_text(out), + c("MULTILINESTRING ((0 0, 1 1))", + "GEOMETRYCOLLECTION (POINT (2 2))", + "GEOMETRYCOLLECTION (MULTILINESTRING ((0 0, 1 1)))", + "MULTIPOLYGON (((0 0, 1 0, 1 1, 0 1, 0 0)))", + "MULTILINESTRING EMPTY", + "POINT (5 5)")) + + # Nothing to drop: the very same object back, sf or sfc, so the polygon + # callers (stable ids, plot labels) see no change at all. + clean <- sf::st_sfc(sf::st_multilinestring(list(ln)), sf::st_polygon(list(sq)), + crs = 4326) + expect_identical(.drop_empty_parts(clean), clean) + clean_sf <- sf::st_sf(a = 1:2, geometry = clean) + expect_identical(.drop_empty_parts(clean_sf), clean_sf) +}) diff --git a/tests/testthat/test-review2-aoa.R b/tests/testthat/test-review2-aoa.R new file mode 100644 index 0000000..4b61cd1 --- /dev/null +++ b/tests/testthat/test-review2-aoa.R @@ -0,0 +1,197 @@ +# tests/testthat/test-review2-aoa.R +# --------------------------------------------------------------------------- +# area_of_applicability(): a fractional chunk_size, duplicated training rows, +# a predictor dropped for zero variance, and all-zero importance weights. +# --------------------------------------------------------------------------- + +r2_aoa_pts <- function(n, a = stats::rnorm(n), b = stats::rnorm(n), seed = NULL) { + if (!is.null(seed)) set.seed(seed) + sf::st_as_sf( + data.frame(x = seq_len(n) * 10, y = seq_len(n) * 5, a = a, b = b), + coords = c("x", "y"), crs = 32632 + ) +} + + +test_that("a fractional chunk_size cannot leave dense-path DI values at zero", { + set.seed(11) + tr <- r2_aoa_pts(80) + # 25 prediction points far outside the training predictor range. + nd <- r2_aoa_pts(25, a = stats::runif(25, 8, 12), b = stats::runif(25, 8, 12)) + ref <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + use_fnn = FALSE) + expect_identical(ref$n_inside, 0L) + + # 2.5 used to give fractional block starts, leaving every fifth row at its + # initial DI of 0 -- inside the AOA -- and 16 training DI of 0 that moved + # the threshold. + for (cs in c(2.5, 1.5, 12.5)) { + res <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + use_fnn = FALSE, chunk_size = cs) + expect_identical(res$n_inside, 0L) + expect_true(all(res$aoa$DI > 0)) + expect_equal(res$aoa$DI, ref$aoa$DI, tolerance = 1e-10) + expect_equal(res$train_DI, ref$train_DI, tolerance = 1e-10) + expect_equal(res$threshold, ref$threshold, tolerance = 1e-10) + } + + # Values that cannot be a row count are refused by name. + for (bad in list(0, NA_real_, c(10, 20), "10", -3, Inf)) + expect_error(area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "b"), + use_fnn = FALSE, chunk_size = bad), + "area_of_applicability\\(\\): `chunk_size` must be") +}) + + +test_that("a zero threshold from duplicated training rows is explained", { + set.seed(5) + # 30 sites visited four times each, with covariates that do not change + # between visits: every training row has an exact twin. + site <- data.frame(a = stats::rnorm(30), b = stats::rnorm(30)) + rep_rows <- site[rep(seq_len(30), each = 4), ] + tr <- r2_aoa_pts(120, a = rep_rows$a, b = rep_rows$b) + tr$site <- rep(seq_len(30), each = 4) + nd <- r2_aoa_pts(200, a = stats::rnorm(200), b = stats::rnorm(200)) + + lines <- capture_spatialkit_log( + res <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"))) + expect_identical(res$threshold, 0) + expect_identical(res$n_inside, 0L) + expect_true(log_has(lines, "DI threshold is 0 because 120 of 120 training rows have an exact duplicate")) + expect_true(log_has(lines, "leave_location_out")) + out <- utils::capture.output(print(res)) + expect_true(any(grepl("120 of 120 training DI are 0: exact duplicates", out, + fixed = TRUE))) + + # Folds that keep a site's visits together give the threshold its meaning + # back, and say nothing. + fo <- make_folds(tr, k = 5, method = "leave_location_out", group_var = "site", + seed = 1) + lines2 <- capture_spatialkit_log( + res2 <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + folds = fo)) + expect_gt(res2$threshold, 0) + expect_gt(res2$n_inside, 150L) + expect_false(log_has(lines2, "DI threshold is 0")) + expect_false(any(grepl("exact duplicates", + utils::capture.output(print(res2)), fixed = TRUE))) + + # A threshold the caller supplied is theirs; nothing to explain. + lines3 <- capture_spatialkit_log( + area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + threshold = 0.5)) + expect_false(log_has(lines3, "DI threshold is 0")) +}) + + +test_that("a prediction row that differs on a zero-variance predictor is outside", { + set.seed(7) + # A land-cover dummy that is 0 everywhere in the training region. + tr <- r2_aoa_pts(150) + tr$urban <- 0 + nd <- r2_aoa_pts(80) + nd$urban <- rep(c(0, 1), each = 40) + nd$urban[80] <- NA # cannot be compared: left to the other predictors + + expect_warning( + res <- area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "b", "urban")), + "39 of 80 prediction row\\(s\\) take a value the training data never has on .*urban") + expect_identical(res$dropped_vars, "urban") + urb <- which(nd$urban == 1) + expect_true(all(is.infinite(res$aoa$DI[urb]))) + expect_false(any(res$aoa$AOA[urb])) + expect_identical(res$n_inside + res$n_outside + res$n_na, 80L) + expect_gte(res$n_outside, 39L) + + # Rows that agree with the training constant, or lack the value, are judged + # on the other predictors exactly as before. + ref <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b")) + keep <- c(1:40, 80) + expect_equal(res$aoa$DI[keep], ref$aoa$DI[keep], tolerance = 1e-12) + expect_true(is.finite(res$aoa$DI[80])) + expect_true(any(grepl("39 outside on a dropped predictor (DI = Inf)", + utils::capture.output(print(res)), fixed = TRUE))) + + # Nothing differs, nothing is said. + nd0 <- nd[1:40, ] + expect_no_warning( + res0 <- area_of_applicability(nd0, train_sf = tr, + predictor_vars = c("a", "b", "urban"))) + expect_false(any(is.infinite(res0$aoa$DI))) +}) + + +test_that("all-zero importance weights give an AOA instead of an error", { + set.seed(9) + tr <- r2_aoa_pts(60) + nd <- r2_aoa_pts(30, a = c(stats::rnorm(20), stats::rnorm(10, 6))) + + # One predictor whose permutation importance was not positive: the index is + # invariant to the weight's scale, so zero is accepted and changes nothing. + ref1 <- area_of_applicability(nd, train_sf = tr, predictor_vars = "a") + expect_no_warning( + one <- area_of_applicability(nd, train_sf = tr, predictor_vars = "a", + weights = pmax(c(a = -0.002), 0))) + expect_equal(one$aoa$DI, ref1$aoa$DI, tolerance = 1e-12) + expect_identical(one$aoa$AOA, ref1$aoa$AOA) + + # Several predictors, all zero: weighted equally, and said so. + ref2 <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b")) + expect_warning( + two <- area_of_applicability(nd, train_sf = tr, predictor_vars = c("a", "b"), + weights = c(a = 0, b = 0)), + "every weight is zero \\(a, b\\)") + expect_equal(two$aoa$DI, ref2$aoa$DI, tolerance = 1e-12) + expect_equal(unname(two$weights), c(1, 1)) + + # The only non-zero weight sat on a predictor dropped for zero variance: + # what is left is one predictor weighted zero, which cannot matter either. + tr$const <- 3; nd$const <- 3 + expect_no_warning( + dropped <- area_of_applicability(nd, train_sf = tr, + predictor_vars = c("a", "const"), + weights = c(a = 0, const = 1))) + expect_equal(dropped$aoa$DI, ref1$aoa$DI, tolerance = 1e-12) + + # Negative weights are still refused, with the advice that now works. + expect_error(area_of_applicability(nd, train_sf = tr, predictor_vars = "a", + weights = c(a = -1)), + "pmax\\(importance, 0\\)") +}) + + +test_that("fold labels are numbered by the rule cv_*() uses", { + splits <- spatialkit:::.aoa_fold_splits + tests_of <- function(sp) lapply(sp, `[[`, "test") + + # Numbers in numeric order: fold 3 is label 10. + expect_identical(tests_of(splits(rep(c(10, 2, 1), each = 3), 9)), + list(7:9, 4:6, 1:3)) + # A factor by its own levels, even when they are not sorted. + expect_identical(tests_of(splits(factor(c("s", "s", "n", "n"), + levels = c("s", "n")), 4)), + list(1:2, 3:4)) + # Anything else in C (radix) order, whatever the session's collation. + lab <- c("north", "North", "south", "South") + expect_identical(tests_of(splits(lab, 4)), list(2L, 4L, 1L, 3L)) + # ... which is how cv_*() numbers the same labels. + cv <- spatialkit:::.folds_from_labels(lab, data.frame(..row_id = 1:4), + "cv_spatial") + expect_identical(tests_of(cv), tests_of(splits(lab, 4))) +}) + + +test_that("character fold labels do not follow the session's collation", { + # as.factor() sorted under LC_COLLATE, which puts "north" before "North" + # in en_US and after it in C. Only testable where en_US is installed. + ok <- suppressWarnings(tryCatch({ + withr::local_collate("en_US.UTF-8") + grepl("en_US", Sys.getlocale("LC_COLLATE")) + }, error = function(e) FALSE)) + skip_if_not(ok, "the en_US.UTF-8 collation is not available") + lab <- c("north", "North", "south", "South") + expect_identical(lapply(spatialkit:::.aoa_fold_splits(lab, 4), `[[`, "test"), + list(2L, 4L, 1L, 3L)) +}) diff --git a/tests/testthat/test-review2-assignment.R b/tests/testthat/test-review2-assignment.R new file mode 100644 index 0000000..3218218 --- /dev/null +++ b/tests/testthat/test-review2-assignment.R @@ -0,0 +1,506 @@ +# =========================================================================== +# Regressions from the second review of assignment, aggregation, stable IDs +# and the spatial half-split. Every test here failed on the code before the +# fix it names. +# =========================================================================== + +# Collect every R warning `expr` raises (message and class) while returning +# its value. +.r2_warnings <- function(expr) { + msgs <- character(0); classes <- list() + val <- withCallingHandlers(expr, warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + classes <<- c(classes, list(class(w))) + invokeRestart("muffleWarning") + }) + list(value = val, warnings = msgs, classes = classes) +} + +.r2_sq <- function(x0, y0, s = 10) { + sf::st_polygon(list(rbind(c(x0, y0), c(x0 + s, y0), c(x0 + s, y0 + s), + c(x0, y0 + s), c(x0, y0)))) +} + +# Four cells of five points, with a response. +.r2_points <- function() { + set.seed(1) + sf::st_as_sf(data.frame(x = runif(20, 0, 200), y = runif(20, 0, 200), + v = rnorm(20), poly_id = rep(1:4, each = 5)), + coords = c("x", "y"), crs = 32632) +} + +# Six cells of 25 points on a correlated Gaussian field (as in +# test-summarize-by-cell.R). +.r2_field <- function() { + set.seed(77) + n <- 150 + x <- rep(seq(0, 500, length.out = 6), each = 25) + runif(n, 0, 60) + y <- runif(n, 0, 60) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 40) + diag(1e-6, n))) %*% rnorm(n)) + sf::st_as_sf(data.frame(x = x, y = y, z = z, poly_id = rep(1:6, each = 25)), + coords = c("x", "y"), crs = 32632) +} + +.r2_sac <- function(model = data.frame(model = c("Nug", "Exp"), + psill = c(0.2, 0.8), + range = c(0, 40))) { + structure(120, class = c("sac_range", "numeric"), variogram_model = model, + crs = sf::st_crs(32632)) +} + + +# --- summarize_by_cell(): design effects ------------------------------------ + +test_that("a non-finite numeric deff falls back to 1 with the classed warning", { + pts <- .r2_points() + for (bad in list(NA_real_, NaN, Inf)) { + # NA and NaN used to stop with "missing value where TRUE/FALSE needed"; + # Inf passed the check and gave uncorrected SEs beside cell_weight 0. + expect_warning( + out <- summarize_by_cell(pts, "v", deff = bad), + "must be a single number >= 1", class = "spatialkit_deff_fallback") + expect_equal(out$cell_weight, out$n) + expect_null(attr(out, "deff_applied")) + expect_identical(out$deff_applied, rep(FALSE, 4)) + } +}) + +test_that("deff_applied marks each row, and survives binding results together", { + pts <- .r2_points() + # The default frame is unchanged: no column. + expect_false("deff_applied" %in% names(summarize_by_cell(pts, "v"))) + fixed <- summarize_by_cell(pts, "v", deff = 2) + expect_identical(fixed$deff_applied, rep(TRUE, 4)) + expect_false(is.null(attr(fixed, "deff_applied"))) + fell <- suppressWarnings(summarize_by_cell(pts, "v", deff = 0.5)) + expect_identical(fell$deff_applied, rep(FALSE, 4)) + # Combined, the attribute is at best the first result's (bind_rows()) or + # gone (rbind()); the column describes every row. + expect_identical(dplyr::bind_rows(fixed, fell)$deff_applied, + rep(c(TRUE, FALSE), each = 4)) + expect_identical(rbind(fell, fixed)$deff_applied, + rep(c(FALSE, TRUE), each = 4)) +}) + +test_that("a rejected sac falls back with the classed warning and FALSE rows", { + pts <- .r2_field() + rejected <- structure(NA_real_, class = c("sac_range", "numeric"), + rejected_reason = "fitted range exceeds the largest lag fitted", + variogram_model = data.frame(model = "Exp", psill = 1, + range = 1e6)) + expect_warning( + out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", + sac = rejected), + "fitted range exceeds", class = "spatialkit_deff_fallback") + expect_identical(out$deff_applied, rep(FALSE, 6)) + # Caught by class, without matching the message. + caught <- tryCatch( + summarize_by_cell(pts, predictor_vars = "z", deff = "variogram", + sac = rejected), + spatialkit_deff_fallback = function(w) "caught") + expect_identical(caught, "caught") + # Joined to cells, an empty cell carries NA rather than a verdict. + cells <- sf::st_sf(poly_id = 1:7, + geometry = sf::st_sfc(lapply(0:6, function(i) .r2_sq(100 * i, 0, 60)), + crs = 32632)) + ok <- summarize_by_cell(pts, "z", deff = "variogram", sac = .r2_sac(), + cells_sf = cells) + expect_identical(ok$deff_applied, c(rep(TRUE, 6), NA)) +}) + +test_that("a variogram fallback with no fit reports why, as an R warning", { + pts <- .r2_field() + skip_if_not_installed("gstat") + # 25 points: estimate_sac_range() returns no model. This fell back to + # deff = 1 with only a log line. + res <- .r2_warnings(summarize_by_cell(pts[1:25, ], "z", deff = "variogram")) + hit <- vapply(res$classes, function(k) "spatialkit_deff_fallback" %in% k, logical(1)) + expect_true(any(hit)) + expect_match(res$warnings[hit][1], "requires a fitted variogram model") + expect_false(any(res$value$deff_applied)) +}) + +test_that("each cell's correlation matrix is built once, not once per column statistic", { + pts <- .r2_field() + sac <- .r2_sac() + n_builds <- 0L + real <- spatialkit:::.cor_stats_from_coords + local_mocked_bindings(.cor_stats_from_coords = function(...) { + n_builds <<- n_builds + 1L + real(...) + }) + summarize_by_cell(pts, "z", deff = "variogram", sac = sac) + # One per cell; the design effect at the row count reuses them (it used to + # rebuild all six). + expect_identical(n_builds, 6L) + + n_builds <- 0L + p2 <- pts + p2$z[c(1, 30, 60)] <- NA # one missing value in cells 1, 2 and 3 + p2$w <- p2$z + 1 + summarize_by_cell(p2, "z", predictor_vars = "w", deff = "variogram", + sac = sac, conf_level = 0.95) + # 6 for the cells, then per column the three incomplete cells once each + # (z and w), and cell_weight's three: 15. The se/neff/df/ci closures used + # to rebuild each of those five times: 45. + expect_identical(n_builds, 15L) +}) + +test_that("an empty point no longer stops deff = 'variogram'", { + pts <- .r2_field() + g <- sf::st_geometry(pts) + g[5] <- sf::st_point() + empty <- pts + sf::st_geometry(empty) <- g + res <- .r2_warnings(summarize_by_cell(empty, "z", deff = "variogram", + sac = .r2_sac())) + expect_true(any(grepl("1 point\\(s\\) have empty or non-finite coordinates", + res$warnings))) + out <- res$value + expect_true(all(out$deff_applied)) + # Its value still counts in its cell; the other cells are untouched. + expect_identical(out$n[1], 25L) + expect_equal(out$resp_mean_z[1], mean(pts$z[1:25])) + ref <- summarize_by_cell(pts, "z", deff = "variogram", sac = .r2_sac()) + expect_equal(out[["..se_resp_z"]][-1], ref[["..se_resp_z"]][-1]) + # The design effect of cell 1 is 1 + (25 - 1) * rbar over its 24 located + # points. + cor_fn <- spatialkit:::.vgm_correlation_fn(attr(.r2_sac(), "variogram_model")) + xy <- sf::st_coordinates(pts)[setdiff(1:25, 5), 1:2] + R <- matrix(cor_fn(as.numeric(as.matrix(stats::dist(xy)))), 24, 24) + diag(R) <- 1 + rbar <- (sum(R) - 24) / (24 * 23) + expect_equal(attr(out, "deff_applied")$deff[1], 1 + 24 * rbar) +}) + +test_that("an anisotropic variogram is evaluated in its own geometry", { + # vgm(0.8, "Exp", 300, 0.2, anis = c(0, 0.2)): the major axis runs north, + # the east-west range is 60. gstat's variogramLine() gives correlations of + # 0.348 / 0.151 / 0.029 east-west at 50 / 100 / 200 m, and 0.677 / 0.573 / + # 0.411 north-south. Read as isotropic, every direction got the latter. + m <- data.frame(model = c("Nug", "Exp"), psill = c(0.2, 0.8), + range = c(0, 300), ang1 = 0, anis1 = c(1, 0.2)) + fn <- spatialkit:::.vgm_correlation_fn(m) + cor_xy <- attr(fn, "cor_xy") + expect_true(is.function(cor_xy)) + xy <- rbind(c(0, 0), c(50, 0), c(100, 0), c(200, 0), c(0, 50), c(0, 200)) + R <- cor_xy(xy) + expect_equal(unname(R[1, 2:4]), 0.8 * exp(-c(50, 100, 200) / 60)) + expect_equal(unname(R[1, 5:6]), 0.8 * exp(-c(50, 200) / 300)) + # Rotated: the major axis 30 degrees east of north. + m2 <- transform(m, ang1 = 30, anis1 = c(1, 0.5)) + cx <- attr(spatialkit:::.vgm_correlation_fn(m2), "cor_xy") + along <- rbind(c(0, 0), 100 * c(sin(pi / 6), cos(pi / 6))) + across <- rbind(c(0, 0), 100 * c(cos(pi / 6), -sin(pi / 6))) + expect_equal(cx(along)[1, 2], 0.8 * exp(-100 / 300)) + expect_equal(cx(across)[1, 2], 0.8 * exp(-100 / 150)) + # An isotropic model carries no such attribute, so nothing else changes. + expect_null(attr(spatialkit:::.vgm_correlation_fn(m[, 1:3]), "cor_xy")) + + # summarize_by_cell() uses it: one cell of points strung out east-west. + pts <- sf::st_as_sf(data.frame(x = seq(0, 450, by = 50), y = 0, v = 1:10, + poly_id = 1L), + coords = c("x", "y"), crs = 32632) + sac <- structure(300, class = c("sac_range", "numeric"), + variogram_model = m, crs = sf::st_crs(32632)) + out <- summarize_by_cell(pts, "v", deff = "variogram", sac = sac) + d <- as.matrix(stats::dist(cbind(seq(0, 450, by = 50), 0))) + R <- 0.8 * exp(-d / 60); diag(R) <- 1 + expect_equal(attr(out, "deff_applied")$deff, sum(R) / 10) +}) + + +# --- summarize_by_cell(): inputs and the join onto cells_sf ------------------ + +test_that("a response_var that cannot be summarised is a warning, not a silent skip", { + pts <- .r2_points() + expect_warning(out <- summarize_by_cell(pts, "vall"), + "response_var 'vall' is not a column") + expect_false(any(grepl("^resp_", names(out)))) + pts$flag <- pts$v > 0 + expect_warning(summarize_by_cell(pts, "flag"), "'flag' are not numeric") + expect_warning(summarize_by_cell(pts, "v", predictor_vars = c("v", "nope")), + "predictor_vars 'nope' are not columns") + # Two names used to stop with "the condition has length > 1". + expect_error(summarize_by_cell(pts, c("v", "flag")), + "`response_var` must be a single column name") +}) + +test_that("a double ID of 100000 still joins an integer cell ID", { + cells <- sf::st_sf(poly_id = c(99999L, 100000L, 100001L), + geometry = sf::st_sfc(.r2_sq(0, 0), .r2_sq(10, 0), + .r2_sq(20, 0), crs = 32632)) + set.seed(2) + pts <- sf::st_as_sf(data.frame(x = runif(30, 0, 30), y = runif(30, 0, 10), + v = rnorm(30)), + coords = c("x", "y"), crs = 32632) + a <- assign_features_to_polygons(pts, cells) + a$poly_id <- as.double(a$poly_id) # as from a GeoPackage Integer64 field + res <- .r2_warnings(summarize_by_cell(a, "v", cells_sf = cells)) + out <- res$value + # as.character(1e5) is "1e+05": that cell came back NA and its 11 points + # were lost, with no R warning. + expect_identical(out$poly_id, c("99999", "100000", "100001")) + expect_identical(sum(out$n), 30L) + expect_length(res$warnings, 0L) + expect_identical(spatialkit:::.id_as_character(c(1e5, 2.5, NA, -0)), + c("100000", "2.5", NA, "0")) +}) + +test_that("summarised IDs that match no cell are reported", { + pts <- .r2_points() + cells <- sf::st_sf(poly_id = 1:3, + geometry = sf::st_sfc(lapply(0:2, function(i) .r2_sq(10 * i, 0)), + crs = 32632)) + expect_warning(out <- summarize_by_cell(pts, "v", cells_sf = cells), + "1 of the 4 summarised cell ID\\(s\\) \\(4\\) match no") + expect_identical(nrow(out), 3L) +}) + +test_that("cells keyed by 'id' are joined like assign_features_to_polygons() reads them", { + cells <- sf::st_sf(id = 1:3, cell_id = 3:1, + geometry = sf::st_sfc(.r2_sq(0, 0), .r2_sq(10, 0), + .r2_sq(20, 0), crs = 32632)) + set.seed(3) + pts <- sf::st_as_sf(data.frame(x = c(runif(4, 0, 10), runif(6, 10, 20), + runif(8, 20, 30)), + y = runif(18, 0, 10), v = rnorm(18)), + coords = c("x", "y"), crs = 32632) + a <- assign_features_to_polygons(pts, cells) # takes the 'id' column + out <- summarize_by_cell(a, "v", cells_sf = cells, area = TRUE) + expect_s3_class(out, "sf") + # Joined on 'id', not on the differently numbered 'cell_id': each count + # sits on its own polygon. + expect_identical(out$n, c(4L, 6L, 8L)) + expect_equal(sf::st_coordinates(sf::st_centroid(sf::st_geometry(out)))[, 1], + c(5, 15, 25)) + expect_true(all(c("cell_area", "n_per_area") %in% names(out))) + + # No ID column at all: a warning and a plain table, or an error when an + # area was asked for. It used to be one log line and a plain table. + nocol <- cells[, "geometry"] + expect_warning(plain <- summarize_by_cell(a, "v", cells_sf = nocol), + "has none of the ID columns") + expect_false(inherits(plain, "sf")) + expect_error(summarize_by_cell(a, "v", cells_sf = nocol, area = TRUE), + "`area = TRUE` needs the cells' areas") + expect_warning(summarize_by_cell(a, "v", cells_sf = sf::st_drop_geometry(cells)), + "`cells_sf` is not an sf object") +}) + +test_that("agg_funs takes a bare function or function names", { + pts <- .r2_points() + med <- tapply(pts$v, pts$poly_id, median) + out <- summarize_by_cell(pts, "v", agg_funs = median) + # It used to become the mean, with only a log line. + expect_equal(out$resp_median_v, as.numeric(med)) + out2 <- summarize_by_cell(pts, "v", agg_funs = c("median", "sum")) + expect_equal(out2$resp_median_v, as.numeric(med)) + expect_equal(out2$resp_sum_v, as.numeric(tapply(pts$v, pts$poly_id, sum))) + expect_warning(out3 <- summarize_by_cell(pts, "v", agg_funs = 3), + "Falling back to the mean") + expect_true("resp_mean_v" %in% names(out3)) +}) + + +# --- assign_features_to_polygons() ------------------------------------------ + +test_that("a polygon feature that only touches the cells is unassigned, in any CRS", { + cells <- sf::st_sf(poly_id = 1:2, + geometry = sf::st_sfc(.r2_sq(0, 0), .r2_sq(10, 0), crs = 32632)) + feats <- sf::st_sf(v = 1:4, geometry = sf::st_sfc( + .r2_sq(20, 0), # shares cell 2's east edge + .r2_sq(-5, 10, 5), # meets cell 1 at the corner (0, 10) + .r2_sq(6, 2, 7), # 4 units in cell 1, 3 in cell 2 + .r2_sq(12, 2, 3), # inside cell 2 + crs = 32632)) + # (sf's own intersection says its attributes are assumed constant.) + quiet_assign <- function(...) suppressWarnings(assign_features_to_polygons(...)) + out <- quiet_assign(feats, cells, keep_unassigned = TRUE) + # The first two were assigned with zero overlap under GEOS. + expect_identical(out$poly_id, c(NA, NA, 1L, 2L)) + expect_identical(nrow(quiet_assign(feats, cells)), 2L) + # s2 already said so in lon/lat; the two now agree. + ll <- quiet_assign(sf::st_transform(feats, 4326), + sf::st_transform(cells, 4326), keep_unassigned = TRUE) + expect_identical(ll$poly_id, out$poly_id) + # largest = FALSE is the predicate's answer, which counts touching. + by_pred <- assign_features_to_polygons(feats, cells, largest = FALSE) + expect_identical(by_pred$poly_id, c(2L, 1L, 1L, 2L)) +}) + +test_that("equal-area ties go to the same cell whatever the row order", { + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox( + c(xmin = 5e5, ymin = 5e6, xmax = 5e5 + 300, ymax = 5e6 + 300), + crs = sf::st_crs(32632)))) + g <- create_grid_polygons(bnd, cellsize = 100, quiet = TRUE) + # Points on the shared edges: x = 100 and 200 at mid-row, y = 100 at + # mid-column, and one corner shared by four cells. + xy <- rbind(cbind(5e5 + 100, 5e6 + c(50, 150, 250)), + cbind(5e5 + 200, 5e6 + c(50, 150, 250)), + cbind(5e5 + c(50, 150, 250), 5e6 + 100), + c(5e5 + 100, 5e6 + 100)) + pts <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2]), + coords = c("x", "y"), crs = 32632) + fwd <- assign_features_to_polygons(pts, g) + rev <- assign_features_to_polygons(pts, g[rev(seq_len(nrow(g))), ]) + shf <- assign_features_to_polygons(pts, g[c(5, 9, 1, 3, 7, 2, 8, 4, 6), ]) + expect_identical(attr(fwd, "ties")$n, 10L) + # Reversing the rows used to hand every one of these points to the other + # cell. + expect_identical(rev$poly_id, fwd$poly_id) + expect_identical(shf$poly_id, fwd$poly_id) + # The cell below or to the left of the edge: on this grid, numbered from + # the lower left a row at a time, what the row order picked before. + ctr <- sf::st_coordinates(sf::st_centroid(sf::st_geometry(g))) + won <- ctr[match(fwd$poly_id, g$poly_id), ] + expect_true(all(won[1:6, "X"] < xy[1:6, 1])) + expect_true(all(won[7:10, "Y"] < xy[7:10, 2])) +}) + + +# --- the row-record class ---------------------------------------------------- + +test_that("layers carrying a row record bind with dplyr and vctrs", { + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox( + c(xmin = 5e5, ymin = 5e6, xmax = 5e5 + 300, ymax = 5e6 + 300), + crs = sf::st_crs(32632)))) + g <- create_grid_polygons(bnd, cellsize = 100, quiet = TRUE) + set.seed(4) + mk <- function() sf::st_as_sf(data.frame(x = 5e5 + runif(10, 0, 300), + y = 5e6 + runif(10, 0, 300), + v = rnorm(10)), + coords = c("x", "y"), crs = 32632) + a1 <- assign_features_to_polygons(mk(), g) + a2 <- assign_features_to_polygons(mk(), g) + expect_true(inherits(a1, "spatialkit_rows")) + # Same size, same (empty) ties record: vctrs took its same-type path and + # failed with 'attr(obj, "sf_column") does not point to a geometry column'. + b <- dplyr::bind_rows(a1, a2) + expect_s3_class(b, "sf") + expect_identical(nrow(b), 20L) + expect_null(attr(b, "ties")) # it describes neither input's rows + expect_identical(nrow(dplyr::bind_rows(list(y1 = a1, y2 = a2), .id = "year")), 20L) + expect_identical(nrow(vctrs::vec_rbind(a1, a2)), 20L) + expect_identical(nrow(dplyr::union_all(a1, a1)), 20L) + d <- sf::st_as_sf(data.frame(x = 1:8, y = 8:1, resp = c(1, 2, NA, 4:8), pred = 1:8), + coords = c("x", "y"), crs = 32632) + p <- suppressWarnings(prep_model_data(d, "resp", "pred")) + expect_identical(nrow(dplyr::bind_rows(p, p)), 14L) + # `[` still removes the record. + expect_null(attr(a1[1:3, ], "ties")) + expect_false(inherits(a1[1:3, ], "spatialkit_rows")) +}) + + +# --- stable IDs and the grid cache ------------------------------------------ + +test_that("two CRSs with the same generic name do not share a cached grid", { + # What a custom CRS read back from a GeoPackage or shapefile looks like: + # sf names it "unknown", whatever it is. + named_unknown <- function(lon, lat) structure(list( + input = "unknown", + wkt = sf::st_crs(sprintf("+proj=aeqd +lat_0=%s +lon_0=%s +datum=WGS84 +units=m", + lat, lon))$wkt), class = "crs") + sq <- sf::st_polygon(list(rbind(c(-5000, -5000), c(5000, -5000), c(5000, 5000), + c(-5000, 5000), c(-5000, -5000)))) + site_a <- sf::st_sf(geometry = sf::st_sfc(sq, crs = named_unknown(10, 50))) + site_b <- sf::st_sf(geometry = sf::st_sfc(sq, crs = named_unknown(-100, 40))) + env <- new.env(parent = emptyenv()) + ga <- create_grid_polygons_cached(site_a, target_cells = 16, cache_env = env) + gb <- create_grid_polygons_cached(site_b, target_cells = 16, cache_env = env) + # Site B was handed site A's grid, centred 11,000 km away. + expect_true(sf::st_crs(gb) == sf::st_crs(site_b)) + centre <- sf::st_coordinates(sf::st_centroid(sf::st_transform(sf::st_union(gb), 4326))) + expect_equal(unname(centre[1, ]), c(-100, 40), tolerance = 1e-6) + expect_length(ls(env), 2L) +}) + +test_that("create_grid_polygons_cached() can be sized by cellsize or n", { + bnd <- sf::st_sf(geometry = sf::st_sfc(.r2_sq(0, 0, 100), crs = 32632)) + env <- new.env(parent = emptyenv()) + # Both stopped with 'argument "target_cells" is missing, with no default'. + by_size <- create_grid_polygons_cached(bnd, cellsize = 25, cache_env = env) + expect_identical(nrow(by_size), nrow(create_grid_polygons(bnd, cellsize = 25))) + by_n <- create_grid_polygons_cached(bnd, n = 5, cache_env = env) + expect_identical(nrow(by_n), 25L) +}) + +test_that("stable IDs do not depend on whether s2 is switched on", { + # A triangle whose spherical centroid lies at longitude 9.745 and whose + # planar (degree) centroid lies at 9.667, and a small square at 9.70 + # between the two: the two ways of taking the centroid order them + # differently. + tri <- sf::st_polygon(list(rbind(c(9, 60), c(11, 60), c(9, 70), c(9, 60)))) + sq <- sf::st_polygon(list(rbind(c(9.69, 40), c(9.71, 40), c(9.71, 40.02), + c(9.69, 40.02), c(9.69, 40)))) + lyr <- sf::st_sf(name = c("tri", "sq"), geometry = sf::st_sfc(tri, sq, crs = 4326)) + on_ids <- ensure_stable_poly_id(lyr) + expect_identical(on_ids$name, c("sq", "tri")) + # With s2 off the key was planar and, without lwgeom, st_area() stopped + # the call. + old <- suppressMessages(sf::sf_use_s2(FALSE)) + on.exit(suppressMessages(sf::sf_use_s2(old)), add = TRUE) + off_ids <- ensure_stable_poly_id(lyr) + expect_false(sf::sf_use_s2()) # restored + expect_identical(off_ids$name, on_ids$name) + expect_identical(off_ids$poly_id, on_ids$poly_id) +}) + + +# --- the spatial half-split -------------------------------------------------- + +# A town of 250 points and a village of 8, 20 km away. +.r2_town <- function() { + set.seed(2) + d <- rbind(data.frame(x = rnorm(250, 3000, 400), y = rnorm(250, 3000, 400)), + data.frame(x = c(20000, 20500, 21000, 19800, 20200, 20900, 20400, 19900), + y = c(15000, 15300, 14800, 15500, 15100, 14900, 15200, 15400))) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + +test_that("a small remote group no longer stops the split", { + pts <- .r2_town() + # The village always sat alone in a block of the default grid, and the + # call stopped: "left 250 and 8 points in the two halves". + res <- .r2_warnings(spatialkit:::.spatial_half_split(pts, seed = 1, caller = "t")) + sp <- res$value + expect_true(any(grepl("left 250 and 8 points .* finer .* grid instead", res$warnings))) + # The first attempt's advice to use smaller blocks is not passed on for a + # split that was then made on smaller blocks. + expect_false(any(grepl("ratio 31.25", res$warnings))) + expect_true(length(sp$selection) >= 10L && length(sp$estimation) >= 10L) + expect_length(intersect(sp$selection, sp$estimation), 0L) + expect_setequal(c(sp$selection, sp$estimation), seq_len(nrow(pts))) + # A design the caller chose is used as given, and refused as before. + expect_error(suppressWarnings(spatialkit:::.spatial_half_split( + pts, seed = 1, caller = "t", block_nx = 2, block_ny = 3)), + "at least 10 each are needed") +}) + +test_that("the split records how uneven its halves are and where they lie", { + set.seed(3) + cl <- rbind(data.frame(x = rnorm(200, 0, 50), y = rnorm(200, 0, 50)), + data.frame(x = rnorm(60, 2000, 50), y = rnorm(60, 0, 50)), + data.frame(x = rnorm(40, 1000, 50), y = rnorm(40, 1500, 50))) + pts <- sf::st_as_sf(cl, coords = c("x", "y"), crs = 32632) + sp <- spatialkit:::.spatial_half_split(pts, seed = 1, caller = "t") + # Whole clusters land in one half: 200 against 100, accepted by the + # default tolerance of 3 and, until now, reported nowhere. + expect_equal(sp$balance, 2) + expect_identical(sp$grid, "3 x 2") + bb <- sf::st_bbox(sf::st_geometry(pts)[sp$estimation]) + expect_equal(sp$extent$estimation, bb) + # The grid is fixed by the extent, so the seed only decides which side + # selects: the partition is one of two orientations of the same cut. + cuts <- unique(lapply(1:6, function(s) { + h <- spatialkit:::.spatial_half_split(pts, seed = s, caller = "t") + sort(c(min(h$selection), min(h$estimation))) + })) + expect_length(cuts, 1L) + # A block design passed through `...` reaches make_folds(). + sp4 <- spatialkit:::.spatial_half_split(pts, seed = 1, caller = "t", + block_nx = 4, block_ny = 4) + expect_identical(sp4$grid, "4 x 4") +}) diff --git a/tests/testthat/test-review2-bayes-brms.R b/tests/testthat/test-review2-bayes-brms.R new file mode 100644 index 0000000..8f12e6c --- /dev/null +++ b/tests/testthat/test-review2-bayes-brms.R @@ -0,0 +1,86 @@ +# Real-sampler counterparts of the mocked tests in test-review2-bayes-rf.R. +# Opt-in via SPATIALKIT_TEST_BRMS, like test-bayes-smoke.R, and for the same +# reasons: each test compiles a Stan model. Kept to two tiny fits. + +.r2bb_skip <- function() { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") +} + +.r2bb_pts <- function(n = 40, seed = 20240817) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); z <- rnorm(n) + resp <- 0.004 * x + 1.5 * z + rnorm(n, sd = 0.5) + d <- sf::st_as_sf(data.frame(x = x, y = y, z = z, resp = resp), + coords = c("x", "y"), crs = 32632) + d$cat3 <- cut(d$resp, stats::quantile(d$resp, c(0, 1/3, 2/3, 1)), + include.lowest = TRUE, labels = c("lo", "mid", "hi")) + d +} + +.r2bb_fit <- function(pts, ...) { + fit <- NULL + warns <- character(0) + utils::capture.output( + withCallingHandlers( + suppressMessages( + fit <- fit_bayesian_spatial_model(pts, predictor_vars = "z", + chains = 1, iter = 200, warmup = 100, + cores = 1, compute_loo = FALSE, + seed = 1234, gp_k = 6, ...)), + warning = function(w) { + warns <<- c(warns, conditionMessage(w)) + invokeRestart("muffleWarning") + }), + type = "output") + list(fit = fit, warnings = warns) +} + +test_that("a categorical fit samples, and predict() says what it can return", { + .r2bb_skip() + pts <- .r2bb_pts() + # This fit used to fail before sampling: the automatic length-scale prior + # dropped the dpar and brms refused the duplicated rows. + r <- .r2bb_fit(pts, response_var = "cat3", family = brms::categorical(), + check_convergence = FALSE) + fit <- r$fit + expect_s3_class(fit, "bayesian_fit") + expect_identical(fit$info$convergence_ok, NA) + expect_match(fit$info$gp_lscale_prior, "inv_gamma|normal") + + nd <- .r2bb_pts(n = 5, seed = 99) + expect_error(suppressMessages(predict(fit, newdata = nd)), + "probability per response category") + expect_error(fitted(fit), "probability per response category") + d <- suppressMessages(predict(fit, newdata = nd, type = "predict", draws = TRUE)) + expect_true(is.matrix(d)) + expect_identical(ncol(d), 5L) + expect_true(all(d %in% 1:3)) +}) + +test_that("a checked gaussian fit is quiet about capped ESS and saves its engine once", { + .r2bb_skip() + pts <- .r2bb_pts() + r <- .r2bb_fit(pts, response_var = "resp", check_convergence = TRUE) + fit <- r$fit + expect_false(any(grepl("ESS has been capped", r$warnings, fixed = TRUE))) + expect_true(is.logical(fit$info$convergence_ok) && + !is.na(fit$info$convergence_ok)) + + sz <- function(x) length(serialize(x, NULL)) + engine_sz <- sz(fit$engine) + before <- sz(fit) + # The formula's environment was the fitting frame, which holds the brmsfit + # again, so a saved fit was about twice its engine. + expect_lt(before, 1.25 * engine_sz) + invisible(fitted(fit)) + # And the fitted-value cache held the engine itself: another copy. + expect_lt(sz(fit) - before, 0.05 * engine_sz) + # The cache still answers for this engine: an entry keyed to it is found. + hit <- get(".fitted_values", envir = fit$info$.cache) + expect_true(identical(hit$engine, + spatialkit:::.fitted_engine_token(fit$engine))) + expect_true(is.environment(hit$engine)) +}) diff --git a/tests/testthat/test-review2-bayes-rf.R b/tests/testthat/test-review2-bayes-rf.R new file mode 100644 index 0000000..fa925df --- /dev/null +++ b/tests/testthat/test-review2-bayes-rf.R @@ -0,0 +1,454 @@ +# Regression tests for the second review's Bayesian and random-forest +# findings. Nothing here compiles a Stan model: brms::brm() and the +# posterior accessors are replaced by recorders, while everything in front of +# the sampler -- brms::get_prior(), validate_prior() and this package's own +# checks -- runs for real. The real-sampler counterparts are in +# test-review2-bayes-brms.R, behind SPATIALKIT_TEST_BRMS. + +.r2b_pts <- function(n = 60, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + rnorm(n) + d$cat3 <- factor(sample(c("lo", "mid", "hi"), n, TRUE), + levels = c("lo", "mid", "hi")) + d$ord3 <- factor(d$cat3, ordered = TRUE) + d$bin <- as.integer(d$z > 0) + d$pres <- factor(ifelse(d$bin == 1L, "present", "absent")) + d +} + +# fit_bayesian_spatial_model() with brms::brm() replaced by a recorder that +# returns `engine`. The mock lives in this helper's frame, so it is gone by +# the time the fit is returned. +.r2b_capture_fit <- function(..., + engine = structure(list(), class = "r2b_stub"), + check_convergence = FALSE) { + cap <- new.env() + local_mocked_bindings( + brm = function(...) { cap$args <- list(...); engine }, + .package = "brms") + fit <- fit_bayesian_spatial_model(..., compute_loo = FALSE, + check_convergence = check_convergence) + list(fit = fit, args = cap$args) +} + +.r2b_quiet <- function(expr) suppressMessages(expr) + + +# --------------------------------------------------------------------------- +# models MED-2: a user's gp_c sizes the derived gp_k +# --------------------------------------------------------------------------- + +test_that(".gp_basis_spec() sizes k for the boundary factor it is given", { + set.seed(1) + xy <- scale(cbind(runif(200), runif(200))) + b <- gp_lengthscale_bounds(xy) + def <- spatialkit:::.gp_basis_spec(xy, b) + S <- def$S + r_lo <- b[["lower"]] / S + rule <- function(cc) min(max(ceiling(1.75 * cc / r_lo), 10L), 50L) + + # The default is unchanged. + expect_identical(def$k, as.integer(rule(def$c))) + # A wider boundary gets the k the rule gives for IT, not the default's k. + s3 <- spatialkit:::.gp_basis_spec(xy, b, c = 3) + expect_identical(s3$c, 3) + expect_identical(s3$k, as.integer(rule(3))) + expect_gt(s3$k, def$k) + expect_false(s3$capped) + # ...up to the cap, which is then reported. + s5 <- spatialkit:::.gp_basis_spec(xy, b, c = 5) + expect_identical(s5$k, 50L) + expect_true(s5$capped) + # A narrower one gets fewer. + s13 <- spatialkit:::.gp_basis_spec(xy, b, c = 1.3) + expect_lte(s13$k, def$k) +}) + +test_that("fit_bayesian_spatial_model(gp_c = ) derives gp_k for that gp_c", { + skip_if_not_installed("brms") + d <- .r2b_pts(n = 200, seed = 3) + base <- .r2b_quiet(.r2b_capture_fit(d, "z", "a"))$fit + wide <- .r2b_quiet(.r2b_capture_fit(d, "z", "a", gp_c = 3))$fit + expect_identical(wide$info$gp_c, 3) + # The rule, from the numbers the fit itself records. + r_lo <- wide$info$gp_lengthscale_bounds[["lower"]] / wide$info$gp_S + expect_identical(wide$info$gp_k, + as.integer(min(max(ceiling(1.75 * 3 / r_lo), 10), 50))) + expect_gt(wide$info$gp_k, base$info$gp_k) + # So the resolvable scale stays where the default basis put it, instead of + # coarsening in proportion to gp_c. + expect_lt(wide$info$gp_ell_min, 1.1 * base$info$gp_ell_min) + # An explicit gp_k still passes through untouched. + fixed <- .r2b_quiet(.r2b_capture_fit(d, "z", "a", gp_c = 3, gp_k = 12))$fit + expect_identical(fixed$info$gp_k, 12L) + # And an invalid gp_c is refused before the rule reads it. + expect_error(.r2b_capture_fit(d, "z", "a", gp_c = "3"), "`gp_c` must be") + expect_error(.r2b_capture_fit(d, "z", "a", gp_c = 0.5), "`gp_c` must be") +}) + + +# --------------------------------------------------------------------------- +# gaps G1.4: the length-scale prior keeps its dpar +# --------------------------------------------------------------------------- + +test_that("a categorical fit's automatic lscale prior validates in brms", { + skip_if_not_installed("brms") + d <- .r2b_pts() + r <- .r2b_quiet(.r2b_capture_fit(d, "cat3", "a", family = brms::categorical(), + gp_k = 5)) + pr <- r$args$prior + ls <- as.data.frame(pr)[pr$class == "lscale", ] + # One row per coefficient PER category, each addressed by its dpar. The + # prior used to carry the coef names only, so every row landed on dpar "" + # twice and brms refused the model before sampling. + expect_setequal(unique(ls$dpar), c("mumid", "muhi")) + expect_false(any(duplicated(ls[, c("coef", "dpar")]))) + expect_no_error(suppressWarnings(brms::validate_prior( + pr, formula = r$args$formula, data = r$args$data, family = r$args$family))) +}) + +test_that("a mixture fit's automatic lscale prior validates in brms", { + skip_if_not_installed("brms") + d <- .r2b_pts() + r <- .r2b_quiet(.r2b_capture_fit( + d, "z", "a", family = brms::mixture(stats::gaussian(), stats::gaussian()), + gp_k = 5)) + pr <- r$args$prior + expect_setequal(unique(pr$dpar[pr$class == "lscale"]), c("mu1", "mu2")) + expect_no_error(suppressWarnings(brms::validate_prior( + pr, formula = r$args$formula, data = r$args$data, family = r$args$family))) +}) + +test_that("a user's dpar-level lscale prior is expanded onto its own dpar only", { + skip_if_not_installed("brms") + d <- .r2b_pts() + up <- brms::set_prior("normal(0, 1)", class = "lscale", dpar = "mumid") + + brms::set_prior("normal(0, 2)", class = "lscale", dpar = "muhi", + coef = "gp..x..y..y") + r <- .r2b_quiet(.r2b_capture_fit(d, "cat3", "a", family = brms::categorical(), + gp_k = 5, prior = up)) + pr <- as.data.frame(r$args$prior) + ls <- pr[pr$class == "lscale", ] + # mumid's two coefficients get the dpar-level prior; muhi keeps the one + # coefficient-level row it was given and nothing else. + expect_setequal(ls$coef[ls$dpar == "mumid"], c("gp..x..y..x", "gp..x..y..y")) + expect_true(all(ls$prior[ls$dpar == "mumid"] == "normal(0, 1)")) + expect_identical(ls$prior[ls$dpar == "muhi"], "normal(0, 2)") + expect_false(any(ls$dpar == "")) + expect_no_error(suppressWarnings(brms::validate_prior( + r$args$prior, formula = r$args$formula, data = r$args$data, + family = r$args$family))) + + # A global prior alongside a coefficient-level one for the same parameter is + # not expanded on top of it (that duplicate was refused as well). + up2 <- brms::set_prior("normal(0, 1)", class = "lscale") + + brms::set_prior("normal(0, 3)", class = "lscale", coef = "gp..x..y..x") + r2 <- .r2b_quiet(.r2b_capture_fit(d, "z", "a", gp_k = 5, prior = up2)) + ls2 <- as.data.frame(r2$args$prior) + ls2 <- ls2[ls2$class == "lscale", ] + expect_identical(ls2$prior[ls2$coef == "gp..x..y..x"], "normal(0, 3)") + expect_identical(ls2$prior[ls2$coef == "gp..x..y..y"], "normal(0, 1)") + expect_no_error(suppressWarnings(brms::validate_prior( + r2$args$prior, formula = r2$args$formula, data = r2$args$data, + family = r2$args$family))) +}) + + +# --------------------------------------------------------------------------- +# gaps G1.5: a factor response is refused unless the family is categorical +# --------------------------------------------------------------------------- + +test_that("a factor response under bernoulli is refused before anything is fitted", { + skip_if_not_installed("brms") + d <- .r2b_pts() + called <- FALSE + local_mocked_bindings(brm = function(...) { called <<- TRUE; stop("reached brm") }, + .package = "brms") + expect_error( + .r2b_quiet(fit_bayesian_spatial_model(d, "pres", "a", + family = brms::bernoulli())), + "response 'pres' is factor, not numeric, and the family is bernoulli") + expect_false(called) + expect_error( + .r2b_quiet(fit_bayesian_spatial_model(d, "pres", "a", family = poisson())), + "the family is poisson") + expect_false(called) +}) + +test_that("the categorical, ordinal and numeric-binary cases still reach brms", { + skip_if_not_installed("brms") + d <- .r2b_pts() + d$lgl <- d$bin == 1L + ok <- function(resp, family) { + r <- .r2b_quiet(.r2b_capture_fit(d, resp, "a", family = family, gp_k = 5)) + expect_false(is.null(r$args), info = resp) + } + ok("cat3", brms::categorical()) + ok("ord3", brms::cumulative()) + ok("bin", brms::bernoulli()) + ok("lgl", brms::bernoulli()) +}) + + +# --------------------------------------------------------------------------- +# models MED-3 (Bayesian): a per-category epred is an error, not "draw failed" +# --------------------------------------------------------------------------- + +.r2b_ordinal_fit <- function(d) { + new_spatial_fit( + "bayesian_fit", + engine = structure(list(family = list(family = "cumulative")), + class = "brmsfit"), + formula = ord3 ~ a, response_var = "ord3", predictor_vars = "a", + data_sf = d, + info = list(coord_scaling = list(x_center = 5e5, x_scale = 300, + y_center = 5e6, y_scale = 300))) +} + +test_that("predict() and fitted() on an ordinal fit say why they cannot answer", { + skip_if_not_installed("brms") + d <- .r2b_pts(n = 40) + nd <- d[1:5, ] + fit <- .r2b_ordinal_fit(d) + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) + array(0.3, dim = c(20L, nrow(newdata), 3L)), + posterior_predict = function(object, newdata, ...) + matrix(2, nrow = 20L, ncol = nrow(newdata)), + .package = "brms") + + # It used to log "posterior draw failed" and return five NAs. + expect_error(.r2b_quiet(predict(fit, newdata = nd)), + "cumulative.*probability per response category.*type = \"predict\"") + expect_error(.r2b_quiet(predict(fit, newdata = nd, draws = TRUE)), + "probability per response category") + expect_error(fitted(fit), "probability per response category") + expect_error(residuals(fit), "probability per response category") + # type = "predict" is unaffected. + p <- .r2b_quiet(predict(fit, newdata = nd, type = "predict")) + expect_equal(p, rep(2, 5)) +}) + + +# --------------------------------------------------------------------------- +# models MED-3 (RF): a failing ranger predict is an error, not NA +# --------------------------------------------------------------------------- + +.r2b_rf_pts <- function(n = 200, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a - d$b + rnorm(n, 0, 0.3) + d +} + +test_that("predict.rf_fit() raises ranger's reason instead of returning NA", { + skip_if_not_installed("ranger") + d <- .r2b_rf_pts() + fit <- fit_rf_model(d, "z", c("a", "b"), num_trees = 50) + nd <- d[1:10, ] + expect_error(predict(fit, nd, type = "se"), + "predict.rf_fit\\(\\): ranger's predict\\(\\) failed: .*keep.inbag") + expect_error(predict(fit, nd, type = "quantiles"), + "predict.rf_fit\\(\\): ranger's predict\\(\\) failed: .*quantreg") + # model_metrics() used to report n = 0 from the NA vector. + expect_error(model_metrics(fit, newdata = nd, type = "se"), "keep.inbag") + # The documented matrix rejection is unchanged. + fq <- fit_rf_model(d, "z", c("a", "b"), num_trees = 50, quantreg = TRUE) + expect_error(predict(fq, nd, type = "quantiles"), "matrix rather than one value") + # And an ordinary prediction still works. + expect_true(all(is.finite(predict(fit, nd)))) +}) + + +# --------------------------------------------------------------------------- +# models LOW-5: a forest with rows out of no tree's bag says so +# --------------------------------------------------------------------------- + +test_that("fit_rf_model() warns when rows have no out-of-bag prediction", { + skip_if_not_installed("ranger") + d <- .r2b_rf_pts() + expect_warning( + f0 <- fit_rf_model(d, "z", c("a", "b"), num_trees = 30, replace = FALSE, + sample_fraction = 1), + "no row is out of bag.*replace = FALSE with sample_fraction = 1.*permutation importance") + expect_true(all(is.nan(fitted(f0)))) + + expect_warning(f5 <- fit_rf_model(d, "z", c("a", "b"), num_trees = 5), + "rows were sampled by every one of the 5 tree") + n_bad <- sum(!is.finite(fitted(f5))) + expect_gt(n_bad, 0L) + # summary() heads its output with the fit's n; the metric count now follows. + txt <- paste(utils::capture.output(print(summary(f5))), collapse = "\n") + expect_match(txt, sprintf("computed on %d of %d rows", nrow(d) - n_bad, nrow(d)), + fixed = TRUE) + + # A forest that covers every row is silent. + expect_no_warning(fit_rf_model(d, "z", c("a", "b"), num_trees = 100)) +}) + + +# --------------------------------------------------------------------------- +# gaps G1.8: an unchecked fit does not claim convergence; LOO says why +# --------------------------------------------------------------------------- + +test_that("check_convergence = FALSE leaves convergence_ok NA, and print() says so", { + skip_if_not_installed("brms") + d <- .r2b_pts() + fit <- .r2b_quiet(.r2b_capture_fit(d, "z", "a", gp_k = 5))$fit + expect_identical(fit$info$convergence_ok, NA) + expect_length(fit$info$convergence_diagnostics, 0L) + txt <- paste(utils::capture.output(print(fit)), collapse = "\n") + expect_match(txt, "Convergence: NOT CHECKED", fixed = TRUE) + expect_false(grepl("Convergence warnings present", txt, fixed = TRUE)) +}) + +test_that("a failed LOO is logged with its cause", { + skip_if_not_installed("brms") + d <- .r2b_pts() + logged <- character(0) + local_mocked_bindings( + .log_warn = function(fmt, ...) logged <<- c(logged, sprintf(fmt, ...)), + .package = "spatialkit") + local_mocked_bindings( + brm = function(...) structure(list(), class = "r2b_stub"), + loo = function(...) stop("injected loo cause 7731"), + .package = "brms") + fit <- .r2b_quiet(fit_bayesian_spatial_model(d, "z", "a", gp_k = 5, + check_convergence = FALSE, + compute_loo = TRUE)) + expect_true(is.na(fit$info$looic)) + expect_true(any(grepl("LOO computation failed.*injected loo cause 7731", + logged))) +}) + + +# --------------------------------------------------------------------------- +# gaps G1.9: posterior's capped-ESS warning does not crowd out the others +# --------------------------------------------------------------------------- + +test_that("the convergence check muffles only posterior's capped-ESS warning", { + skip_if_not_installed("brms") + d <- .r2b_pts() + pars <- c("b_a", "sdgp_gpa", paste0("zgp_", 1:60)) + local_mocked_bindings( + brm = function(...) structure(list(), class = "brmsfit"), + nuts_params = function(...) + data.frame(Parameter = "divergent__", Value = 0), + rhat = function(...) stats::setNames(rep(1.001, length(pars)), pars), + neff_ratio = function(...) { + for (i in 1:60) + warning("The ESS has been capped to avoid unstable estimates.", + call. = FALSE) + warning("some other warning 5520", call. = FALSE) + stats::setNames(rep(0.8, length(pars)), pars) + }, + .package = "brms") + seen <- character(0) + fit <- withCallingHandlers( + .r2b_quiet(fit_bayesian_spatial_model(d, "z", "a", gp_k = 5, + compute_loo = FALSE)), + warning = function(w) { + seen <<- c(seen, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + expect_false(any(grepl("ESS has been capped", seen, fixed = TRUE))) + expect_true("some other warning 5520" %in% seen) + # The values themselves are still read. + expect_equal(fit$info$convergence_diagnostics$min_neff_ratio, 0.8) + expect_true(isTRUE(fit$info$convergence_ok)) +}) + + +# --------------------------------------------------------------------------- +# models LOW-4: a saved fit carries its engine once +# --------------------------------------------------------------------------- + +test_that("an rf_fit's formula does not drag the fitting frame into saveRDS()", { + skip_if_not_installed("ranger") + d <- .r2b_rf_pts() + fit <- fit_rf_model(d, "z", c("a", "b"), num_trees = 100) + sz <- function(x) length(serialize(x, NULL)) + # The formula's environment was the fitting frame, which holds the forest + # again: 1.62 MB for a 0.72 MB forest. + expect_lt(sz(fit), 1.2 * (sz(fit$engine) + sz(fit$data_sf))) +}) + +test_that("a bayesian_fit's formula does not drag the fitting frame into saveRDS()", { + skip_if_not_installed("brms") + d <- .r2b_pts() + big <- structure(list(payload = stats::rnorm(2e5)), class = "r2b_stub") + fit <- .r2b_quiet(.r2b_capture_fit(d, "z", "a", gp_k = 5, engine = big))$fit + sz <- function(x) length(serialize(x, NULL)) + expect_lt(sz(fit), 1.2 * sz(fit$engine) + 2 * sz(fit$data_sf)) +}) + +test_that("a warm fitted() cache does not write the engine a second time", { + skip_if_not_installed("brms") + d <- .r2b_pts(n = 30) + # A stand-in for the stanfit a brmsfit carries: what identifies a sampling + # run is the environment rstan and brms create for each one (with an empty + # parent, as theirs have, so serialising it does not drag this frame along). + methods::setClass("r2b_fake_stanfit", representation(.MISC = "environment"), + where = environment()) + mk_engine <- function() structure( + list(fit = methods::new("r2b_fake_stanfit", + .MISC = new.env(parent = emptyenv())), + payload = stats::rnorm(2e5)), + class = "brmsfit") + e1 <- mk_engine() + fit <- new_spatial_fit("bayesian_fit", engine = e1, formula = z ~ a, + response_var = "z", predictor_vars = "a", data_sf = d) + calls <- 0L + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) { + calls <<- calls + 1L + matrix(1, nrow = 4L, ncol = nrow(newdata)) + }, + .package = "brms") + sz <- function(x) length(serialize(x, NULL)) + before <- sz(fit) + expect_equal(fitted(fit), rep(1, 30)) + after <- sz(fit) + # Was before + the whole engine (the entry held it); now the n values and a + # small identifier. + expect_lt(after - before, 0.1 * sz(e1)) + # Still a hit for the same engine... + fitted(fit) + expect_identical(calls, 1L) + # ...and also after a round trip through serialisation. + rt <- unserialize(serialize(fit, NULL)) + expect_equal(fitted(rt), rep(1, 30)) + expect_identical(calls, 1L) + # A copy carrying a different engine still misses (test-audit-pass7.R has + # the list-engine version of this). + cp <- fit + cp$engine <- mk_engine() + fitted(cp) + expect_identical(calls, 2L) +}) + + +# --------------------------------------------------------------------------- +# models LOW-6: a standardised fit says its coefficients are per SD +# --------------------------------------------------------------------------- + +test_that("print() on a standardised bayesian_fit names the scaled predictors", { + d <- .r2b_pts(n = 20) + fit <- new_spatial_fit( + "bayesian_fit", engine = list(), formula = z ~ a, response_var = "z", + predictor_vars = "a", data_sf = d, + info = list(gp_k = 10L, gp_n_basis = 100L, convergence_ok = TRUE, + predictor_scaling = list(a = list(center = 0.1, scale = 0.9)))) + txt <- paste(utils::capture.output(print(fit)), collapse = "\n") + expect_match(txt, "Predictors standardised: a (coef() is per SD", fixed = TRUE) + fit$info$predictor_scaling <- NULL + txt <- paste(utils::capture.output(print(fit)), collapse = "\n") + expect_false(grepl("standardised", txt, fixed = TRUE)) +}) diff --git a/tests/testthat/test-review2-cv.R b/tests/testthat/test-review2-cv.R new file mode 100644 index 0000000..cf2b57c --- /dev/null +++ b/tests/testthat/test-review2-cv.R @@ -0,0 +1,356 @@ +# tests/testthat/test-review2-cv.R +# --------------------------------------------------------------------------- +# Regressions from the second review of the CV runners, cv_bayes()'s +# coverage levels and plot_calibration(). Each test names the finding it +# closes. The Bayesian backend is mocked with helper-lmfit.R's lm fit, whose +# predict(draws = TRUE) returns a draw matrix, so no Stan toolchain is +# needed. +# --------------------------------------------------------------------------- + +.r2_pts <- function(n = 90, seed = 1, extent = 1000) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, extent), y = runif(n, 0, extent), w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 5 + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +.r2_lm <- function(tr) lm_spatial_fit(tr, "z", "w") + +.r2_mock_bayes <- function(env = parent.frame()) { + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) + lm_spatial_fit(data_sf, response_var, predictor_vars), + .package = "spatialkit", .env = env) +} + + +# --------------------------------------------------------------------------- +# FP9 / plotting L10: coverage levels named at full precision and carried +# explicitly; coverage_levels validated +# --------------------------------------------------------------------------- + +test_that("cv_bayes() keeps close coverage levels apart and plots them where they belong", { + skip_if_not_installed("ggplot2") + .r2_mock_bayes() + d <- .r2_pts(60, seed = 2) + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + lv <- c(0.5, 0.975, 0.985, 0.995) + cv <- suppressWarnings(cv_bayes(d, "z", "w", folds = f, seed = 1, + coverage_levels = lv)) + # 0.975 and 0.985 were both "coverage_98", one overwriting the other, and + # 0.995 became "coverage_100". + cols <- c("coverage_50", "coverage_97.5", "coverage_98.5", "coverage_99.5") + expect_true(all(cols %in% names(cv$fold_metrics))) + expect_equal(cv$coverage_levels, stats::setNames(lv, cols)) + expect_setequal(setdiff(names(cv$predictive_coverage), "mean_CRPS"), cols) + # The plot reads the nominal level from coverage_levels, not a rounded name. + p <- plot_calibration(cv) + pooled <- p$layers[[4]]$data + expect_equal(sort(pooled$nominal), lv) + # The default levels keep their familiar names. + cv0 <- suppressWarnings(cv_bayes(d, "z", "w", folds = f, seed = 1)) + expect_named(cv0$coverage_levels, c("coverage_50", "coverage_80", "coverage_95")) +}) + +test_that("cv_bayes() refuses coverage levels outside (0, 1) or given twice", { + # c(50, 80, 95) made alpha negative, quantile() threw inside the fold + # extras, and every fold silently lost CRPS, n_draws and coverage (MED-2). + # Mocked, so a regression here costs a quick lm CV rather than Stan fits. + .r2_mock_bayes() + d <- .r2_pts(30, seed = 3) + expect_error(cv_bayes(d, "z", "w", coverage_levels = c(50, 80, 95)), + "strictly between 0 and 1.*divide by 100: c\\(0.5, 0.8, 0.95\\)") + expect_error(cv_bayes(d, "z", "w", coverage_levels = c(0.5, 1.2)), + "strictly between 0 and 1") + expect_error(cv_bayes(d, "z", "w", coverage_levels = c(0.5, NA)), + "strictly between 0 and 1") + expect_error(cv_bayes(d, "z", "w", coverage_levels = c(0.9, 0.5, 0.9)), + "gives the level 0.9 more than once") +}) + + +# --------------------------------------------------------------------------- +# plotting L5: the all-NA coverage message names both causes +# --------------------------------------------------------------------------- + +test_that("plot_calibration() names compute_pred_intervals = FALSE as a cause", { + skip_if_not_installed("ggplot2") + .r2_mock_bayes() + d <- .r2_pts(45, seed = 4) + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + cv <- suppressWarnings(cv_bayes(d, "z", "w", folds = f, seed = 1, + compute_pred_intervals = FALSE)) + expect_error(plot_calibration(cv), "compute_pred_intervals = FALSE") +}) + + +# --------------------------------------------------------------------------- +# cv-runners MED-2: a fold_info_fn that throws is logged and recorded +# --------------------------------------------------------------------------- + +test_that("a fold_info_fn that throws is logged and named in fold_status", { + d <- .r2_pts(60, seed = 5) + lab <- rep(1:3, each = 20) + info <- function(fit, test_sf, y, yhat) { + if (21L %in% test_sf$..row_id) stop("boom on the middle fold") + list(n_coef = length(stats::coef(fit$engine))) + } + lines <- capture_spatialkit_log( + cv <- cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, + fold_info_fn = info)) + expect_equal(cv$n_folds_succeeded, 3L) + expect_equal(cv$fold_status$status, rep("ok", 3)) + expect_match(cv$fold_status$message[2], "fold_info_fn failed: boom on the middle fold") + expect_identical(cv$fold_status$message[c(1, 3)], c("", "")) + expect_equal(cv$fold_metrics$n_coef, c(2, NA, 2)) + expect_true(log_has(lines, "fold 2: fold_info_fn failed: boom")) +}) + +test_that("cv_bayes() keeps gp_k and n_draws when coverage cannot be computed", { + # quantile() refuses a draw matrix with an NA; that used to throw away + # every extra of the fold, n_draws included, with nothing logged. + registerS3method("predict", "r2_nadraws", + function(object, newdata = NULL, draws = FALSE, ...) { + mu <- predict.lmsurf_fit(object, newdata = newdata) + if (!isTRUE(draws)) return(mu) + m <- rbind(mu - 1, mu, mu + 1) + m[1, 1] <- NA + m + }) + local_mocked_bindings( + fit_bayesian_spatial_model = function(data_sf, response_var, predictor_vars, + ..., seed = 123) { + fit <- lm_spatial_fit(data_sf, response_var, predictor_vars) + fit$info$gp_k <- 7L + class(fit) <- c("r2_nadraws", class(fit)) + fit + }, + .package = "spatialkit") + d <- .r2_pts(45, seed = 6) + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + lines <- capture_spatialkit_log( + cv <- suppressWarnings(cv_bayes(d, "z", "w", folds = f, seed = 1))) + expect_equal(cv$fold_metrics$n_draws, rep(3L, 3)) + expect_equal(cv$fold_metrics$gp_k, rep(7L, 3)) + expect_true(all(is.na(cv$fold_metrics$coverage_95))) + expect_true(log_has(lines, "coverage and CRPS could not be computed")) +}) + + +# --------------------------------------------------------------------------- +# cv-runners MED-3: ..per_row on some folds only +# --------------------------------------------------------------------------- + +test_that("cv_spatial() stacks folds whose fold_info_fn gave ..per_row on some folds only", { + d <- .r2_pts(90, seed = 7) + lab <- rep(1:3, each = 30) + info <- function(fit, test_sf, y, yhat) { + if (31L %in% test_sf$..row_id) return(list()) # fold 2: none + list(..per_row = data.frame(abs_err = abs(y - yhat))) + } + cv <- cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, + fold_info_fn = info) + expect_equal(nrow(cv$predictions), 90L) + p <- cv$predictions + expect_true(all(is.na(p$abs_err[p$fold == 2L]))) + expect_equal(p$abs_err[p$fold != 2L], abs(p$y - p$yhat)[p$fold != 2L]) + + # One of the wrong length is dropped, and the log says so. + bad <- function(fit, test_sf, y, yhat) list(..per_row = data.frame(e = 1:2)) + lines <- capture_spatialkit_log( + cv2 <- cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, + fold_info_fn = bad)) + expect_false("e" %in% names(cv2$predictions)) + expect_true(log_has(lines, "`..per_row` has 2 rows for 30 test rows")) +}) + + +# --------------------------------------------------------------------------- +# cv-runners MED-4: numeric fold labels numbered in numeric order +# --------------------------------------------------------------------------- + +test_that("numeric fold labels keep their numeric order, a factor its own", { + d <- .r2_pts(240, seed = 8) + lab <- as.integer(cut(sf::st_coordinates(d)[, 1], 12)) + cv <- cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab) + p <- cv$predictions + # Output fold i is the user's label i; with string order fold 2 was label 10. + expect_identical(as.integer(p$fold), lab[p$..row_id]) + expect_identical(cv$fold_metrics$n_test, + as.integer(table(factor(lab, levels = 1:12)))) + # A factor's own level order is the numbering. + rev_lab <- factor(lab, levels = 12:1) + cv_f <- cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = rev_lab) + pf <- cv_f$predictions + expect_identical(as.integer(pf$fold), 13L - lab[pf$..row_id]) +}) + + +# --------------------------------------------------------------------------- +# cv-runners MED-5: parallel runs match sequential ones on failures +# --------------------------------------------------------------------------- + +test_that("an error that stops a sequential run stops a parallel one too", { + skip_on_cran() + skip_on_os("windows") + skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") + d <- .r2_pts(80, seed = 9) + lab <- rep(1:4, each = 20) + # A non-scalar extra on fold 2. Sequentially this died with R's + # "replacement has 0 rows"; in parallel it took fold 4 down with it and + # the run carried on. + info <- function(fit, test_sf, y, yhat) + list(k = if (21L %in% test_sf$..row_id) numeric(0) else 1) + expect_error(cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, + fold_info_fn = info), + "element 'k' is not a single value") + expect_error(suppressMessages( + cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, + fold_info_fn = info, parallel = 2)), + "element 'k' is not a single value.*fold 2, raised in a parallel worker") + # The documented shape error of a user metric, which parallel runs dropped. + dup <- function(y, yhat) c(a = 1, a = 2) + expect_error(suppressMessages( + cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = lab, metrics = dup, + parallel = 2)), + "duplicated names: a") +}) + +test_that("a killed parallel worker costs its own fold only, as a worker_error", { + # Prescheduled mclapply() gave each core a chunk of folds and returned NULL + # for every fold of a core that died: folds 2 AND 4 came back "skipped". + # Run in a child R under `timeout`, since the fit kills its own process. + skip_on_cran() + skip_on_os("windows") + skip_if(parallel::detectCores() < 2L, "fewer than two cores: nothing forks") + skip_if(!nzchar(Sys.which("timeout")), "coreutils `timeout` not found") + ns_path <- getNamespaceInfo(asNamespace("spatialkit"), "path") + installed <- file.exists(file.path(ns_path, "Meta", "package.rds")) + if (!installed) skip_if_not_installed("pkgload") + load_line <- if (installed) + sprintf("suppressMessages(library(spatialkit, lib.loc = %s))", + deparse(dirname(ns_path))) + else + sprintf("suppressMessages(pkgload::load_all(%s, quiet = TRUE))", + deparse(ns_path)) + helper <- normalizePath(test_path("helper-lmfit.R")) + script <- tempfile(fileext = ".R") + on.exit(unlink(script), add = TRUE) + writeLines(c( + load_line, + sprintf("source(%s)", deparse(helper)), + "logger::log_threshold(logger::FATAL, namespace = 'spatialkit', index = 2)", + "set.seed(9); n <- 80", + "d <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000),", + " w = rnorm(n)), coords = c('x', 'y'), crs = 32632)", + "d$z <- 2 * d$w + rnorm(n)", + "parent <- Sys.getpid()", + "fit_fn <- function(tr) {", + " if (!(21L %in% tr$..row_id) && Sys.getpid() != parent)", + " tools::pskill(Sys.getpid(), tools::SIGKILL)", + " lm_spatial_fit(tr, 'z', 'w')", + "}", + "cv <- suppressWarnings(suppressMessages(cv_spatial(d, 'z', 'w',", + " fit_fn = fit_fn, folds = rep(1:4, each = 20), parallel = 2)))", + "cat('RESULT', cv$fold_status$status, '\\n')" + ), script) + rscript <- file.path(R.home("bin"), "Rscript") + out <- suppressWarnings(system2( + "timeout", c("-k", "10", "120", shQuote(rscript), shQuote(script)), + stdout = TRUE, stderr = TRUE, env = "R_TESTS=")) + res <- grep("^RESULT", out, value = TRUE) + expect_identical(trimws(res), "RESULT ok worker_error ok ok", + label = paste(utils::tail(out, 15L), collapse = "\n")) +}) + + +# --------------------------------------------------------------------------- +# cv-runners LOW-7: a user metric or a fold_info_fn may not overwrite a column +# --------------------------------------------------------------------------- + +test_that("user metrics named like the backend's extras are refused", { + .r2_mock_bayes() + d <- .r2_pts(45, seed = 10) + f <- make_folds(d, k = 3, method = "random_kfold", seed = 1) + # predictive_coverage used to report the user's 999 as the mean CRPS. + expect_error(suppressWarnings( + cv_bayes(d, "z", "w", folds = f, metrics = function(y, yhat) c(CRPS = 999))), + "already columns of the metrics frames: CRPS") + expect_error(suppressWarnings( + cv_bayes(d, "z", "w", folds = f, + metrics = function(y, yhat) c(coverage_95 = 0.1))), + "already columns of the metrics frames: coverage_95") + # mean_CRPS is written by compare_models_cv() over a user column. + expect_error(cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = f, + metrics = function(y, yhat) c(mean_CRPS = 1)), + "already columns of the metrics frames: mean_CRPS") + # A user metric may not overwrite a fold_info_fn extra either ... + info <- function(fit, test_sf, y, yhat) list(tuned = 1) + expect_error(cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = f, + fold_info_fn = info, + metrics = function(y, yhat) c(tuned = 2)), + "already columns of the metrics frames: tuned") + # ... nor a fold_info_fn a built-in column. + expect_error(cv_spatial(d, "z", "w", fit_fn = .r2_lm, folds = f, + fold_info_fn = function(fit, test_sf, y, yhat) + list(RMSE = -5)), + "`fold_info_fn` returned names that are already columns of fold_metrics: RMSE") +}) + + +# --------------------------------------------------------------------------- +# gaps G2.4: saved folds on lon/lat polygons survive an sf_use_s2() toggle +# --------------------------------------------------------------------------- + +test_that("folds on lon/lat polygons are accepted after sf_use_s2() is toggled", { + nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) + nc$z <- nc$BIR74 / 1000; nc$a <- nc$NWBIR74 / 1000 + old <- sf::sf_use_s2() + withr::defer(suppressMessages(sf::sf_use_s2(old))) + fit_fn <- function(tr) lm_spatial_fit(tr, "z", "a") + run <- function(f) suppressWarnings(suppressMessages( + cv_spatial(nc, "z", "a", fit_fn = fit_fn, folds = f))) + + # suppressWarnings(): sf warns that point-on-surface is approximate on + # lon/lat data with s2 off, which is beside the point here. + suppressMessages(sf::sf_use_s2(TRUE)) + f_on <- suppressWarnings(make_folds(nc, k = 3, method = "random_kfold", seed = 1)) + suppressMessages(sf::sf_use_s2(FALSE)) + f_off <- suppressWarnings(make_folds(nc, k = 3, method = "random_kfold", seed = 1)) + expect_equal(run(f_on)$n_folds_succeeded, 3L) # built on, used off + suppressMessages(sf::sf_use_s2(TRUE)) + expect_equal(run(f_off)$n_folds_succeeded, 3L) # built off, used on + expect_identical(sf::sf_use_s2(), TRUE) # the probe restored it + + # Different data is still refused. + shuffled <- nc[c(2:100, 1), ] + expect_error(suppressWarnings(suppressMessages( + cv_spatial(shuffled, "z", "a", fit_fn = fit_fn, folds = f_on))), + "built from different data") + + # A probe saved before `kind` existed is checked the old way, not refused. + legacy <- f_on + legacy$params$row_probe$kind <- NULL + sf_ids <- nc; sf_ids$..row_id <- seq_len(nrow(nc)) + old_probe <- spatialkit:::.fold_row_probe(sf_ids, legacy = TRUE) + legacy$params$row_probe$x <- old_probe$x + legacy$params$row_probe$y <- old_probe$y + expect_equal(run(legacy)$n_folds_succeeded, 3L) +}) + + +# --------------------------------------------------------------------------- +# first-pass FP15: cv_gwr() no longer calls the dead .validate_kernel() +# --------------------------------------------------------------------------- + +test_that("cv_gwr() validates its kernel with match.arg() alone", { + skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") + src <- paste(deparse(body(cv_gwr)), collapse = " ") + expect_false(grepl(".validate_kernel", src, fixed = TRUE)) + expect_error(cv_gwr(.r2_pts(20), "z", "w", kernel = "Gaussian"), + "should be one of") +}) diff --git a/tests/testthat/test-review2-eval.R b/tests/testthat/test-review2-eval.R new file mode 100644 index 0000000..ad0e7b2 --- /dev/null +++ b/tests/testthat/test-review2-eval.R @@ -0,0 +1,253 @@ +# tests/testthat/test-review2-eval.R +# --------------------------------------------------------------------------- +# Regressions from the second review of the metrics, compare_models(), +# compare_models_cv(), residual_morans_i() and forward selection. Each test +# names the finding it closes. +# --------------------------------------------------------------------------- + +.r2e_pts <- function(n = 90, seed = 1, extent = 1000) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, extent), y = runif(n, 0, extent), w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 5 + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +.r2e_lm <- function(tr) lm_spatial_fit(tr, "z", "w") + +.r2e_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + + +# --------------------------------------------------------------------------- +# evaluation MED-LOW-3: one R2 baseline for newdata and cross-validation +# --------------------------------------------------------------------------- + +test_that("model_metrics(newdata =) scores R2 against the training mean, as CV does", { + d <- .r2e_pts(200, seed = 11) + x <- sf::st_coordinates(d)[, 1] + d$z <- 0.01 * x + d$w + rnorm(200, 0, 0.3) # a trend w cannot explain + tr <- which(x < 600); te <- which(x >= 600) + fit <- lm_spatial_fit(d[tr, ], "z", "w") + mm <- model_metrics(fit, newdata = d[te, ]) + yh <- predict(fit, newdata = d[te, ]) + expect_equal(mm$R2, 1 - sum((d$z[te] - yh)^2) / sum((d$z[te] - mean(d$z[tr]))^2)) + # The same predictions through cv_spatial() on the same single split. + cv <- cv_spatial(d, "z", "w", fit_fn = .r2e_lm, + folds = list(list(train = tr, test = te))) + expect_equal(cv$predictions$yhat, unname(yh)) + expect_equal(mm$R2, cv$overall$R2) + # In sample the two means coincide: the ordinary R2. + ins <- model_metrics(fit) + expect_equal(ins$R2, summary(fit$engine)$r.squared) +}) + + +# --------------------------------------------------------------------------- +# evaluation LOW-4 / aoa-utils L6: scale-relative tolerances +# --------------------------------------------------------------------------- + +test_that("R2 and MAPE do not depend on the units of the response", { + set.seed(12) + y <- rnorm(100, 5, 1); yhat <- y + rnorm(100, 0, 0.3) + ref <- spatialkit:::.compute_reg_metrics(y, yhat) + for (s in c(1e-9, 1e-15, 1e6)) { + m <- spatialkit:::.compute_reg_metrics(y * s, yhat * s) + expect_equal(m$R2, ref$R2, info = format(s)) + expect_equal(m$MAPE, ref$MAPE, info = format(s)) + expect_identical(m$n_MAPE, 100L, info = format(s)) + } + # A large offset with an ordinary spread keeps its R2 ... + big <- spatialkit:::.compute_reg_metrics(1e8 + y / 10, 1e8 + yhat / 10) + expect_equal(big$R2, ref$R2, tolerance = 1e-6) + # ... and a constant response still has none. + expect_true(is.na(spatialkit:::.compute_reg_metrics(rep(5e-9, 4), + 5e-9 * c(1, 1.1, 0.9, 1))$R2)) +}) + +test_that("select_features_forward(metric = 'R2') works on a response in small units", { + d <- .r2e_pts(120, seed = 13) + d$a <- rnorm(120); d$b <- rnorm(120) + d$z <- (3 * d$a + rnorm(120, 0, 0.5)) * 1e-9 + fs <- suppressWarnings(select_features_forward( + d, "z", c("a", "b"), fit_fn = function(tr, v) lm_spatial_fit(tr, "z", v), + k = 3, metric = "R2", quiet = TRUE)) + expect_true("a" %in% fs$selected) + expect_true(is.finite(fs$score)) +}) + + +# --------------------------------------------------------------------------- +# evaluation LOW-5: evaluate_insample() and compare_models() label the basis +# --------------------------------------------------------------------------- + +test_that("evaluate_insample() says whether each row is in-sample, out-of-bag or newdata", { + d <- .r2e_pts(60, seed = 14) + f_in <- lm_spatial_fit(d, "z", "w") + f_oob <- f_in; f_oob$info$fitted_are_oob <- TRUE + out <- evaluate_insample(list(lm = f_in, forest = f_oob)) + expect_identical(out$metric_basis, c("in-sample", "out-of-bag")) + expect_identical(evaluate_insample(list(lm = f_in), newdata = d[1:20, ])$metric_basis, + "newdata") + lines <- capture_spatialkit_log( + cmp <- suppressWarnings(compare_models(list(lm = f_in, forest = f_oob)))) + expect_identical(cmp$metric_basis[match(c("lm", "forest"), cmp$model)], + c("in-sample", "out-of-bag")) + expect_true(log_has(lines, "the metrics mix bases")) +}) + + +# --------------------------------------------------------------------------- +# gaps G1.2: information criteria compared only on the same rows +# --------------------------------------------------------------------------- + +test_that("compare_models() blanks LOOIC for fits on different rows, with a warning", { + d <- .r2e_pts(70, seed = 15) + stub <- function(data, looic) { + fit <- lm_spatial_fit(data, "z", "w") + fit$info$looic <- looic + class(fit) <- c("lmsurf_fit", "bayesian_fit", "spatial_fit") + fit + } + a <- stub(d, 54.8); b <- stub(d[1:50, ], 32.2) + res <- .r2e_warnings(compare_models(list(A = a, B = b))) + expect_true(any(grepl("LOOIC is a sum over the rows.*A: n = 70, B: n = 50", + res$warnings))) + expect_true(all(is.na(res$value$LOOIC))) + # The same rows, in another order: comparable, kept, no such warning. + b2 <- stub(d[70:1, ], 55.1) + res2 <- .r2e_warnings(compare_models(list(A = a, B = b2))) + expect_false(any(grepl("LOOIC is a sum", res2$warnings))) + expect_equal(res2$value$LOOIC[match(c("A", "B"), res2$value$model)], c(54.8, 55.1)) +}) + + +# --------------------------------------------------------------------------- +# gaps G1.10: negative residual autocorrelation is not "missed structure" +# --------------------------------------------------------------------------- + +test_that("compare_models() reads significantly negative Moran's I as over-fitting", { + set.seed(5) + gx <- rep(1:10, each = 10); gy <- rep(1:10, 10) + pts <- sf::st_as_sf(data.frame(x = gx * 100 + runif(100, -5, 5), + y = gy * 100 + runif(100, -5, 5), w = rnorm(100)), + coords = c("x", "y"), crs = 32632) + pts$z <- rnorm(100) + fit <- lm_spatial_fit(pts, "z", "w") + # Residuals alternating in sign column by column: anti-correlated. + registerS3method("residuals", "r2_altresid", function(object, ...) { + xy <- sf::st_coordinates(object$data_sf) + (-1)^round(xy[, 1] / 100) + stats::rnorm(nrow(xy), 0, 0.1) + }) + class(fit) <- c("r2_altresid", class(fit)) + lines <- capture_spatialkit_log(cmp <- compare_models(list(alt = fit))) + expect_lt(cmp$resid_morans_z, 0) + expect_lt(cmp$resid_morans_p, 0.05) + expect_true(log_has(lines, "significant negative spatial autocorrelation.*over-fitting")) + expect_false(log_has(lines, "may not fully capture")) +}) + + +# --------------------------------------------------------------------------- +# gaps G6.8: residual_morans_i() says why it has no residuals +# --------------------------------------------------------------------------- + +test_that("residual_morans_i() reports why the residuals could not be used", { + d <- .r2e_pts(100, seed = 16) + fit <- new_spatial_fit(subclass = "r2_nomethod", engine = NULL, + formula = z ~ w, response_var = "z", + predictor_vars = "w", data_sf = d) + expect_warning(out <- residual_morans_i(fit), "has no residuals\\(\\) method") + expect_null(out) + + registerS3method("residuals", "r2_throws", + function(object, ...) stop("engine lost its QR")) + thrower <- fit; class(thrower) <- c("r2_throws", class(fit)) + expect_warning(residual_morans_i(thrower), + "residuals\\(\\) failed on this fit: engine lost its QR") + + registerS3method("residuals", "r2_short", + function(object, ...) rep(0.1, nrow(object$data_sf) - 1L)) + short <- fit; class(short) <- c("r2_short", class(fit)) + expect_warning(residual_morans_i(short), + "returned 99 value\\(s\\) for the 100 row\\(s\\)") +}) + + +# --------------------------------------------------------------------------- +# first-pass FP6: a shared fold set that cannot be built is an error +# --------------------------------------------------------------------------- + +test_that("compare_models_cv() errors when the requested blocks cannot be built", { + skip_if_not_installed("ranger") + d <- .r2e_pts(90, seed = 17) + # One block covers everything. It used to fall back to each backend's + # default five-fold blocks, with no R condition. + expect_error(suppressMessages( + compare_models_cv(d, "z", "w", models = "RF", k = 3, block_size = 1e6, + rf_args = list(num_trees = 20), quiet = TRUE)), + "compare_models_cv\\(\\): could not build the shared fold set") +}) + + +# --------------------------------------------------------------------------- +# first-pass FP10: shared blocks placed by the caller's pointize +# --------------------------------------------------------------------------- + +test_that("compare_models_cv() assigns polygon rows to blocks by `pointize`", { + skip_if_not_installed("ranger") + set.seed(3) + n <- 80 + ell <- function(x0, y0, s) sf::st_polygon(list(rbind( + c(x0, y0), c(x0 + s, y0), c(x0 + s, y0 + s / 4), c(x0 + s / 4, y0 + s / 4), + c(x0 + s / 4, y0 + s), c(x0, y0 + s), c(x0, y0)))) + xs <- runif(n, 0, 900); ys <- runif(n, 0, 900); ss <- runif(n, 40, 120) + d <- sf::st_sf(a = rnorm(n), geometry = sf::st_sfc( + lapply(seq_len(n), function(i) ell(xs[i], ys[i], ss[i])), crs = 32632)) + d$z <- 2 * d$a + rnorm(n, 0, 0.3) + fold_of <- function(ff) { + out <- integer(n) + for (j in seq_along(ff)) out[ff[[j]]$test] <- j + out + } + for (pz in c("centroid", "auto")) { + res <- suppressWarnings(suppressMessages( + compare_models_cv(d, "z", "a", models = "RF", k = 3, pointize = pz, + rf_args = list(num_trees = 20), quiet = TRUE))) + ref <- suppressWarnings(suppressMessages( + make_folds(coerce_to_points(d, pz), k = 3, method = "block_kfold", + seed = 123))) + expect_identical(fold_of(res$rf_cv$folds), + ref$assignment$fold[order(ref$assignment$row_id)], + info = pz) + # The provenance probe is still taken on the polygons. + expect_equal(res$rf_cv$n_folds_succeeded, 3L, info = pz) + } +}) + + +# --------------------------------------------------------------------------- +# gaps G4.6: select_features_forward()'s split indexes the layer as passed +# --------------------------------------------------------------------------- + +test_that("select_features_forward()'s split positions index the caller's layer", { + d <- .r2e_pts(200, seed = 18) + d$a <- rnorm(200); d$b <- rnorm(200) + d$z <- 2 * d$a + rnorm(200, 0, 0.5) + d$b[c(3, 40, 77, 120, 150, 181, 199)] <- NA + fs <- suppressWarnings(select_features_forward( + d, "z", c("a", "b"), fit_fn = function(tr, v) lm_spatial_fit(tr, "z", v), + k = 3, quiet = TRUE, select_on = "split")) + both <- c(fs$split$selection, fs$split$estimation) + complete <- which(!is.na(d$b)) + # Every complete row in exactly one half, and no dropped row in either. + expect_setequal(both, complete) + expect_false(anyDuplicated(both) > 0L) + expect_false(anyNA(d$b[fs$split$estimation])) +}) diff --git a/tests/testthat/test-review2-fold-separation.R b/tests/testthat/test-review2-fold-separation.R new file mode 100644 index 0000000..0dd710a --- /dev/null +++ b/tests/testthat/test-review2-fold-separation.R @@ -0,0 +1,43 @@ +# tests/testthat/test-review2-fold-separation.R +# --------------------------------------------------------------------------- +# Second review round: fold_separation(). Each test fails on the code before +# the fix. Helpers are in helper-review2-folds.R. +# --------------------------------------------------------------------------- + +# ---- fold_separation() ----------------------------------------------------- + +test_that("fold_separation labels folds by the fold_id a cv_*() result carries", { + set.seed(1) + d <- r2_pts(runif(150, 0, 1000), runif(150, 0, 1000), a = rnorm(150)) + d$z <- d$a + rnorm(150) + f <- make_folds(d, k = 5, method = "block_kfold", seed = 1) + d$z[f$folds[[1]]$test] <- NA # fold 1 has nothing to score + cv <- suppressWarnings(r2_quiet(cv_spatial(d, "z", "a", fit_fn = r2_fit, folds = f))) + s <- fold_separation(cv$folds, d) + expect_identical(s$fold, as.integer(cv$fold_metrics$fold)) # 2 3 4 5, not 1 2 3 4 + m <- merge(as.data.frame(cv$fold_metrics), as.data.frame(s), by = "fold") + expect_identical(m$n_test.x, m$n_test.y) +}) + +test_that("fold_separation measures a recorded range in the CRS it was recorded in", { + set.seed(1) + d <- r2_pts(7e5 + runif(80, 0, 2000), 3.95e6 + runif(80, 0, 2000), crs = 32617) + f <- make_folds(d, k = 4, method = "block_kfold", seed = 1) + f$params$sac_range <- structure(600, class = "sac_range", crs = sf::st_crs(32617)) + a <- fold_separation(f, d) + b <- fold_separation(f, sf::st_transform(d, 2264)) # the same layer in US feet + expect_equal(b$within_range, a$within_range, tolerance = 1e-6) + expect_equal(attr(b, "crs"), "EPSG:32617") + # The folds' own CRS is used when the range carries none. + f$params$sac_range <- 600 + b2 <- fold_separation(f, sf::st_transform(d, 2264)) + expect_equal(b2$within_range, a$within_range, tolerance = 1e-6) + # A bare number stays in data_sf's own units, as documented. + b3 <- fold_separation(f$folds, sf::st_transform(d, 2264), sac = 600) + expect_equal(attr(b3, "crs"), "EPSG:2264") + # The CRS's unit, not its identifier ("in EPSG:32617 units" named none). + expect_output(print(a), "(in metres, like the distances)", fixed = TRUE) + expect_output(print(b3), "(in US survey feet, like the distances)", fixed = TRUE) + expect_error(fold_separation(f, d, sac = units::set_units(0.6, km)), + "`sac` must be a plain number") +}) diff --git a/tests/testthat/test-review2-folds.R b/tests/testthat/test-review2-folds.R new file mode 100644 index 0000000..37a5ea2 --- /dev/null +++ b/tests/testthat/test-review2-folds.R @@ -0,0 +1,212 @@ +# tests/testthat/test-review2-folds.R +# --------------------------------------------------------------------------- +# Second review round: make_folds(). Each test fails on the code before +# the fix. Helpers are in helper-review2-folds.R. +# --------------------------------------------------------------------------- + +# ---- block_kfold: k and the blocks that hold points ------------------------ + +test_that("drop_empty_blocks = FALSE lowers k to the blocks that hold points", { + # Two clusters on a 4 x 4 grid: 2 occupied blocks, but the highest occupied + # block id is 16, so k = 5 used to be kept and three folds came back with + # no test points and no warning. + set.seed(1) + xy <- rbind(cbind(rnorm(30, 100, 20), rnorm(30, 100, 20)), + cbind(rnorm(30, 900, 20), rnorm(30, 900, 20))) + p <- r2_pts(xy[, 1], xy[, 2]) + lines <- capture_spatialkit_log( + f <- make_folds(p, k = 5, method = "block_kfold", block_nx = 4, block_ny = 4, + drop_empty_blocks = FALSE, seed = 1)) + expect_equal(f$k, 2L) + expect_length(f$folds, 2L) + expect_true(all(lengths(lapply(f$folds, `[[`, "test")) > 0L)) + expect_true(is.finite(f$params$balance_ratio)) + expect_true(log_has(lines, "only 2 blocks hold points")) + # The empty blocks are still kept and packed. + expect_equal(f$params$blocks_used, 16L) + expect_identical(sort(unlist(f$params$fold_blocks)), 1:16) + + # All points in one of several blocks is the single-block case, not a fold + # scheme with an empty training set. + bnd <- sf::st_sfc(sf::st_polygon(list(rbind(c(0, 0), c(4000, 0), c(4000, 4000), + c(0, 4000), c(0, 0)))), crs = 32632) + one <- r2_pts(runif(20, 100, 300), runif(20, 100, 300)) + expect_error(make_folds(one, k = 3, method = "block_kfold", boundary = bnd, + block_nx = 4, block_ny = 4, drop_empty_blocks = FALSE), + "single block") +}) + + +# ---- block_kfold: the automatic grid --------------------------------------- + +test_that("the automatic grid is the same for a corridor and for it turned on its side", { + set.seed(1) + u <- runif(150, 0, 10000); v <- runif(150, 0, 100) + ew <- make_folds(r2_pts(5e5 + u, 5e6 + v), k = 5, method = "block_kfold", seed = 1) + ns <- make_folds(r2_pts(5e5 + v, 5e6 + u), k = 5, method = "block_kfold", seed = 1) + # block_multiplier * k = 15 blocks either way; 39 x 1 before. + expect_equal(c(ew$params$grid_nx, ew$params$grid_ny), c(15, 1)) + expect_equal(c(ns$params$grid_nx, ns$params$grid_ny), c(1, 15)) + expect_equal(ew$k, ns$k) + # A square keeps its aspect-preserving grid. + sq <- make_folds(r2_pts(runif(150, 0, 1000), runif(150, 0, 1000)), k = 5, + method = "block_kfold", seed = 1) + expect_equal(c(sq$params$grid_nx, sq$params$grid_ny), c(4, 4)) +}) + +test_that("points on one horizontal line get a row of blocks, not a collapsed square grid", { + set.seed(2) + h <- r2_pts(5e5 + runif(150, 0, 6000), rep(5e6, 150)) + f <- make_folds(h, k = 5, method = "block_kfold", seed = 1) + expect_equal(c(f$params$grid_nx, f$params$grid_ny), c(15, 1)) + expect_equal(f$k, 5L) # was lowered to 4 +}) + + +# ---- block_kfold: block_nx / block_ny -------------------------------------- + +test_that("one grid dimension is honoured and the other derived; bad ones are refused", { + set.seed(3) + d <- r2_pts(runif(200, 0, 1000), runif(200, 0, 2000)) + f <- make_folds(d, k = 4, method = "block_kfold", block_nx = 10, seed = 1) + expect_equal(f$params$grid_nx, 10) # was ignored: a 3 x 4 grid + expect_equal(f$params$grid_ny, 20) + f <- make_folds(d, k = 4, method = "block_kfold", block_ny = 4, seed = 1) + expect_equal(c(f$params$grid_nx, f$params$grid_ny), c(2, 4)) + for (v in list(0, -2, NA, c(2, 3), 2.7, "3")) + expect_error(make_folds(d, k = 4, method = "block_kfold", block_nx = v, + block_ny = 3), + "`block_nx` must be a single whole number >= 1") + expect_error(make_folds(d, k = 4, method = "block_kfold", block_nx = 3, + block_ny = NA), + "`block_ny` must be a single whole number >= 1") +}) + +test_that("a units object is refused by name for block_size", { + d <- r2_pts(runif(50, 0, 1000), runif(50, 0, 1000)) + expect_error(make_folds(d, k = 3, method = "block_kfold", + block_size = units::set_units(1, km)), + "`block_size` must be a single positive number") +}) + + +# ---- block_kfold: boundary clipping ---------------------------------------- + +test_that("with a boundary, source_row indexes the full grid and zero-area pieces are not blocks", { + tri <- sf::st_sfc(sf::st_polygon(list(rbind(c(0, 0), c(1000, 0), c(0, 1000), + c(0, 0)))), crs = 32632) + set.seed(1) + pts <- sf::st_sf(geometry = sf::st_sample(tri, 400)) + f <- make_folds(pts, k = 3, method = "block_kfold", block_nx = 4, block_ny = 4, + boundary = tri, seed = 1, drop_empty_blocks = FALSE) + pr <- f$params + expect_equal(pr$n_blocks, 16L) + expect_true(all(as.numeric(sf::st_area(pr$blocks)) > 0)) + expect_equal(pr$blocks_used, 10L) + # Cells 8, 11 and 12 touch the hypotenuse only at a corner, and 14-16 lie + # outside it; the clipped list numbered them 1..13 instead. + expect_identical(pr$blocks$source_row, c(1:7, 9L, 10L, 13L)) + full <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox(tri)), n = c(4, 4)) + inside <- sf::st_within(sf::st_centroid(sf::st_geometry(pr$blocks)), full) + expect_identical(vapply(inside, `[`, integer(1), 1L), pr$blocks$source_row) + + # A point exactly on a grid vertex that lies on the boundary joins an + # areal block, not a one-point POINT block of its own. + tri2 <- sf::st_sfc(sf::st_polygon(list(rbind(c(1000, 0), c(1000, 1000), c(0, 1000), + c(1000, 0)))), crs = 32632) + p2 <- sf::st_sf(geometry = c(sf::st_sample(tri2, 200), + sf::st_sfc(sf::st_point(c(500, 500)), crs = 32632))) + f2 <- make_folds(p2, k = 3, method = "block_kfold", block_nx = 4, block_ny = 4, + boundary = tri2, seed = 1) + blk <- f2$params$blocks[f2$assignment$block_id[nrow(p2)], ] + expect_gt(as.numeric(sf::st_area(blk)), 0) + expect_true(all(sf::st_dimension(f2$params$blocks) == 2L)) +}) + + +# ---- argument validation --------------------------------------------------- + +test_that("k is required by the k-fold methods and named when missing", { + d <- r2_pts(runif(40, 0, 1000), runif(40, 0, 1000), g = rep(1:4, 10)) + expect_error(make_folds(d, method = "block_kfold"), + "`k` \\(the number of folds\\) is required for method = \"block_kfold\"") + expect_error(make_folds(d, k = NULL, method = "random_kfold"), + "`k` .* is required for method = \"random_kfold\"") + expect_error(make_folds(d, k = NULL, method = "leave_location_out", group_var = "g"), + "`k` .* is required") + # The leave-one-out methods never read it. + expect_equal(make_folds(d, method = "buffered_loo", buffer = 50)$k, 40L) +}) + +test_that("an invalid buffer is refused by name", { + d <- r2_pts(runif(40, 0, 1000), runif(40, 0, 1000)) + for (b in list(NA_real_, numeric(0), c(100, 200), NULL, "100", -1, + units::set_units(1, km))) + expect_error(make_folds(d, k = 1, method = "buffered_loo", buffer = b), + "`buffer` must be a single positive number") + # An NA -- what estimate_sac_range() returns when nothing is identified -- + # says so. + expect_error(make_folds(d, k = 1, method = "buffered_loo", buffer = NA_real_), + "no range was identified") +}) + +test_that("a buffer that excludes no neighbour is warned about", { + # 0.1 on lon/lat input is 0.1 m once projected: plain LOO. + set.seed(1) + ll <- r2_pts(10 + runif(80, 0, 1), 50 + runif(80, 0, 1), crs = 4326) + expect_warning( + f <- r2_quiet(make_folds(ll, k = 1, method = "buffered_loo", buffer = 0.1)), + "excludes no neighbour from any fold, so this is plain leave-one-out") + expect_true(all(lengths(lapply(f$folds, `[[`, "train")) == 79L)) + # A buffer that does exclude something is not. + expect_no_warning(r2_quiet(make_folds(ll, k = 1, method = "buffered_loo", + buffer = 20000))) +}) + + +# ---- auto_range fallback --------------------------------------------------- + +test_that("auto_range falling back to geometric blocks is a warning naming the reason", { + skip_if_not_installed("gstat") + set.seed(4); n <- 120 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- r2_pts(x, y, z = 0.01 * x + rnorm(n, 0, 0.1)) # an unremoved trend + expect_warning( + f <- r2_quiet(make_folds(d, k = 4, method = "block_kfold", auto_range = TRUE, + range_frac = 1e-6, response_var = "z", seed = 1)), + "no autocorrelation range was identified \\(fitted range exceeds the largest lag fitted\\); falling back to geometric blocks") + expect_null(f$params$block_size) +}) + + +# ---- nndm ------------------------------------------------------------------ + +test_that("nndm warns when min_train leaves the folds more optimistic than the target", { + # One cluster predicted onto a 20 km grid: 96 of 100 folds are held at the + # floor with a training point far closer than the prediction distances. + set.seed(1) + p <- r2_pts(rnorm(100, 10000, 800), rnorm(100, 10000, 800)) + g <- r2_pts(rep(seq(0, 20000, by = 1000), 21), rep(seq(0, 20000, by = 1000), each = 21)) + expect_warning( + f <- r2_quiet(make_folds(p, method = "nndm", prediction_points = g)), + "min_train = 0.5 stopped the distance matching in 96 of 100 folds") + expect_equal(f$params$n_at_min_train, 96L) + expect_gt(f$params$max_ecdf_excess, 0.5) + # Limiting the matching with phi is a choice, not the floor: no warning. + expect_no_warning( + f_phi <- r2_quiet(make_folds(p, method = "nndm", prediction_points = g, phi = 500))) + expect_equal(f_phi$params$n_at_min_train, 0L) + # Nor where the target is reachable. + set.seed(2) + u <- r2_pts(runif(100, 0, 10000), runif(100, 0, 10000)) + g2 <- r2_pts(rep(seq(0, 10000, by = 500), 21), rep(seq(0, 10000, by = 500), each = 21)) + expect_no_warning(fu <- r2_quiet(make_folds(u, method = "nndm", prediction_points = g2))) + expect_equal(fu$params$n_at_min_train, 0L) +}) + +test_that("the nndm size guard states the worst-case cost", { + set.seed(1) + big <- r2_pts(runif(5001, 0, 1e4), runif(5001, 0, 1e4)) + expect_error(make_folds(big, method = "nndm", prediction_points = big[1:10, ]), + "worst case is O\\(n\\^3\\) time") +}) diff --git a/tests/testthat/test-review2-gwr.R b/tests/testthat/test-review2-gwr.R new file mode 100644 index 0000000..de6bfb7 --- /dev/null +++ b/tests/testthat/test-review2-gwr.R @@ -0,0 +1,305 @@ +# =========================================================================== +# GWR regressions from the second adversarial review. +# =========================================================================== + +skip_if_not_installed("GWmodel") +skip_if_not_installed("sp") + +# Every warning raised while evaluating `expr`, muffled, beside its value (or +# the error message, as a character string, when it failed). +.r2_catch <- function(expr) { + w <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w) +} + +# Four clusters of 50; `soil` is a regional covariate all but constant inside +# each (0.5 or 1.5 plus noise of SD 0.01), so any window inside one cluster is +# near-collinear with the intercept. With `exact = TRUE` it is exactly +# constant, a 0/1 indicator. +.r2_clusters <- function(exact = FALSE, seed = 5) { + set.seed(seed) + cl <- rep(1:4, each = 50) + lev <- if (exact) c(0, 1, 0, 1) else c(0.5, 1.5, 0.5, 1.5) + d <- sf::st_as_sf(data.frame( + x = c(runif(50, 0, 100), runif(50, 400, 500), runif(50, 0, 100), runif(50, 400, 500)), + y = c(runif(50, 0, 100), runif(50, 0, 100), runif(50, 400, 500), runif(50, 400, 500)), + a = rnorm(200), + soil = lev[cl] + if (exact) 0 else rnorm(200, 0, 0.01)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + 3 * d$soil + rnorm(200, 0, 0.2) + d +} + + +# --------------------------------------------------------------------------- +# A single predictor is collinear with the intercept inside a window too, and +# the survey used to skip it (fewer than two numeric predictors). +# --------------------------------------------------------------------------- + +test_that("a one-predictor GWR is surveyed for local collinearity", { + d <- .r2_clusters() + r <- .r2_catch(fit_gwr_model(d, "z", "soil", adaptive = TRUE, bandwidth = 20)) + expect_s3_class(r$value, "gwr_fit") + # The local slopes of soil run to hundreds around a true 3; that has to be + # said, as it is when a second predictor is present. + expect_gt(max(abs(coef(r$value)$soil)), 30) + expect_true(any(grepl("100% of 200 locations have a collinear local design", + r$warnings))) + expect_equal(r$value$info$n_local_collinear, 200L) + expect_s3_class(r$value$info$local_collinearity, "data.frame") + # The global index is on the centred predictors: 1 for a single one. + expect_equal(r$value$info$condition_index, + .condition_index(cbind(1, d$soil - mean(d$soil)))) + expect_equal(r$value$info$condition_index, 1) +}) + + +# --------------------------------------------------------------------------- +# The survey's kernel weights are GWmodel's, edge and zero width included, and +# the messages say what a singular window and a non-finite coefficient are. +# --------------------------------------------------------------------------- + +test_that("the survey's kernel weights equal GWmodel::gw.weight()", { + d <- c(0, 0, 50, 100, 100, 150) + for (k in c("bisquare", "gaussian", "tricube", "boxcar", "exponential")) { + # Fixed, with points exactly at the kernel's edge. + expect_identical(.gw_kernel_weights(d, 100, k, FALSE), + GWmodel::gw.weight(d, 100, k, FALSE), info = k) + # Adaptive, the 4th neighbour at 100 and a tie there. + expect_identical(.gw_kernel_weights(d, 4, k, TRUE), + GWmodel::gw.weight(d, 4, k, TRUE), info = k) + # Zero width: the 2 nearest share one location. NaN except for the boxcar. + expect_identical(.gw_kernel_weights(d, 2, k, TRUE), + GWmodel::gw.weight(d, 2, k, TRUE), info = k) + # More neighbours than points: GWmodel widens the kernel. + expect_equal(.gw_kernel_weights(d, 9, k, TRUE), + GWmodel::gw.weight(d, 9, k, TRUE), info = k) + } + expect_true(all(is.nan(.gw_kernel_weights(d, 2, "bisquare", TRUE)[1:2]))) +}) + +test_that("a fixed boxcar bandwidth equal to the grid spacing is not called singular", { + set.seed(3) + g <- expand.grid(x = seq(0, 1500, by = 100), y = seq(0, 1500, by = 100)) + g$a <- rnorm(nrow(g)); g$b <- rnorm(nrow(g)) + g$z <- 1 + 2 * g$a - g$b + rnorm(nrow(g), 0, 0.3) + d <- sf::st_as_sf(g, coords = c("x", "y"), crs = 32632) + r <- .r2_catch(fit_gwr_model(d, "z", c("a", "b"), adaptive = FALSE, + bandwidth = 100, kernel = "boxcar")) + expect_s3_class(r$value, "gwr_fit") + expect_false(any(grepl("collinear local design", r$warnings))) + # The survey's windows are GWmodel's: 3 points at a corner, 5 inside. + W <- GWmodel::gw.weight(as.matrix(stats::dist(g[, c("x", "y")])), 100, + "boxcar", FALSE) + expect_equal(r$value$info$local_collinearity$n_window, + as.integer(colSums(W > 0))) +}) + +test_that("an exactly singular window stops the fit with the cause named", { + d <- .r2_clusters(exact = TRUE) + r <- .r2_catch(fit_gwr_model(d, "z", c("a", "soil"), adaptive = TRUE, + bandwidth = 20)) + expect_type(r$value, "character") + expect_match(r$value, "^fit_gwr_model\\(\\): GWR fit failed: inv\\(\\)") + expect_match(r$value, "local window's design is singular") + expect_match(r$value, "survey found [0-9]+ singular window") + # The collinearity warning before it does not promise NaN coefficients. + expect_true(any(grepl("an exactly singular window makes GWmodel stop the fit", + r$warnings))) +}) + +test_that("non-finite coefficients at co-located points are blamed on the zero-width kernel", { + set.seed(2) + sx <- runif(40, 0, 1000); sy <- runif(40, 0, 1000) + dd <- data.frame(x = rep(sx, each = 4), y = rep(sy, each = 4)) + dd$a <- rnorm(160); dd$b <- rnorm(160) + dd$z <- 1 + 2 * dd$a - dd$b + rnorm(160, 0, 0.3) + d <- sf::st_as_sf(dd, coords = c("x", "y"), crs = 32632) + # Four neighbours for three parameters: the Gaussian's floor, and every + # site's four observations are its four nearest. + r <- .r2_catch(fit_gwr_model(d, "z", c("a", "b"), adaptive = TRUE, + bandwidth = 4, kernel = "gaussian")) + expect_s3_class(r$value, "gwr_fit") + expect_equal(r$value$info$bandwidth, 4) + expect_equal(r$value$info$n_local_singular, 160L) + # The survey sees the same windows GWmodel does: undefined, not fine. + expect_equal(r$value$info$n_local_collinear, 160L) + nf <- grep("returned non-finite coefficients", r$warnings, value = TRUE) + expect_length(nf, 1L) + expect_match(nf, "at 160 of them 4 or more observations share one location") + expect_no_match(nf, "windows are singular") + # A boxcar kernel keeps the co-located points (weight 1), and fits. + rb <- .r2_catch(fit_gwr_model(d, "z", c("a", "b"), adaptive = TRUE, + bandwidth = 4, kernel = "boxcar")) + expect_equal(rb$value$info$n_local_singular, 0L) + expect_false(any(grepl("non-finite coefficients", rb$warnings))) +}) + + +# --------------------------------------------------------------------------- +# GWmodel's AICc is defined only for tr(S) < n - 2. Past it the penalty +# changes sign and a (near-)interpolating fit scores a huge negative AICc, +# which compare_models() and gwr_model_selection() ranked first. The adaptive +# floor used to land bisquare and tricube fits exactly there. +# --------------------------------------------------------------------------- + +.r2_pts <- function(n, seed, vars = c("a", "b", "c")) { + set.seed(seed) + df <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + for (v in vars) df[[v]] <- rnorm(n) + sf::st_as_sf(df, coords = c("x", "y"), crs = 32632) +} + +test_that("a too-small adaptive bandwidth is raised past the interpolating floor, with a warning", { + d <- .r2_pts(100, 21) + d$v <- 1 + d$a + 0.5 * d$b + rnorm(100) + # 4 parameters; bisquare windows of k neighbours fit on k - 1 points, so 5 + # (the old floor) interpolated every window: R2 = 1, AICc = -15033. + r <- .r2_catch(fit_gwr_model(d, "v", c("a", "b", "c"), bandwidth = 2)) + expect_s3_class(r$value, "gwr_fit") + expect_true(any(grepl(paste0("adaptive bandwidth of 2 neighbours is too ", + "small for 4 parameters with the bisquare ", + "kernel.*using 6"), r$warnings))) + expect_equal(r$value$info$bandwidth, 6) + expect_true(is.finite(r$value$info$AICc)) + expect_gt(r$value$info$AICc, 0) + # The Gaussian weights every point, so parameters + 1 is enough there. + rg <- .r2_catch(fit_gwr_model(d, "v", c("a", "b", "c"), bandwidth = 2, + kernel = "gaussian")) + expect_equal(rg$value$info$bandwidth, 5) + expect_true(any(grepl("using 5\\.$", rg$warnings))) +}) + +test_that("fit_gwr_model() reports an undefined AICc as NA, and compare_models() does not rank it", { + d <- .r2_pts(25, 1, c("a", "b")) + d$v <- 1 + d$a + rnorm(25) + # Five neighbours clear the floor for 3 parameters, but tr(S) = 23.7 is past + # n - 2 = 23, where GWmodel's AICc is -1687. + r <- .r2_catch(fit_gwr_model(d, "v", c("a", "b"), bandwidth = 5)) + expect_s3_class(r$value, "gwr_fit") + expect_lt(r$value$engine$GW.diagnostic$AICc, 0) + expect_true(is.na(r$value$info$AICc)) + w <- grep("AICc is undefined", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "tr\\(S\\) = 23\\.[0-9]+, is not below n - 2 = 23") + # The recovered trace is GWmodel's own. + g <- r$value$engine$GW.diagnostic + expect_equal(.gwr_trace_s(g$AIC, g$RSS.gw, 25), + g$AIC - (25 * log(g$RSS.gw / 25) + 25 * log(2 * pi) + 25)) + wide <- suppressWarnings(fit_gwr_model(d, "v", c("a", "b"), bandwidth = 20)) + expect_true(is.finite(wide$info$AICc)) + cmp <- suppressWarnings(compare_models(list(small = r$value, wide = wide))) + expect_true(is.na(cmp$AICc[cmp$model == "small"])) + expect_equal(cmp$AICc[cmp$model == "wide"], wide$info$AICc) +}) + +test_that("gwr_model_selection() ranks a model with an undefined AICc last", { + d <- .r2_pts(30, 3, c("a", "n1", "n2")) + d$v <- 1 + d$a + rnorm(30, 0, 0.5) + # At 6 neighbours the three-variable model has tr(S) = 28.5 > n - 2 = 28 and + # a GWmodel AICc of -3871, which made it the selected model. + r <- .r2_catch(gwr_model_selection(d, "v", c("a", "n1", "n2"), bandwidth = 6)) + sel <- r$value + expect_s3_class(sel, "gwr_model_selection") + expect_lt(min(sel$raw[[2]][, 3]), 0) + expect_identical(sel$best, "a") + expect_true(any(grepl("AICc is undefined for 1 of 6 model\\(s\\) at bandwidth 6", + r$warnings))) + expect_true(is.na(sel$table$criterion[6])) + expect_identical(sel$table$n_vars[6], 3L) + expect_true(all(is.finite(sel$table$criterion[1:5]))) +}) + +test_that("gwr_model_selection() warns when it raises a too-small adaptive bandwidth", { + d <- .r2_pts(60, 5, c("a", paste0("n", 1:4))) + d$z <- 2 * d$a + rnorm(60, 0, 0.5) + # Six parameters in the full model: bisquare needs 8 neighbours. + r <- .r2_catch(gwr_model_selection(d, "z", c("a", paste0("n", 1:4)), + bandwidth = 4)) + expect_s3_class(r$value, "gwr_model_selection") + expect_identical(r$value$bandwidth, 8L) + expect_true(any(grepl(paste0("adaptive bandwidth of 4 neighbours is too ", + "small for the full 5-predictor model with the ", + "bisquare kernel; using 8"), r$warnings))) +}) + + +# --------------------------------------------------------------------------- +# An adaptive bandwidth above n was capped at n in silence: a distance passed +# with adaptive left at TRUE, and bw.gwr()'s choice below 20 points, whose +# search range [20, n] is then reversed. +# --------------------------------------------------------------------------- + +test_that("an adaptive bandwidth above n is capped with a warning that suggests adaptive = FALSE", { + set.seed(7) + dd <- data.frame(x = runif(200, 0, 5000), y = runif(200, 0, 5000), a = rnorm(200)) + dd$z <- (1 + 3 * dd$x / 5000) * dd$a + rnorm(200, 0, 0.3) + d <- sf::st_as_sf(dd, coords = c("x", "y"), crs = 32632) + r <- .r2_catch(fit_gwr_model(d, "z", "a", bandwidth = 1500)) + expect_equal(r$value$info$bandwidth, 200) + w <- grep("exceeds the 200 observations", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "adaptive bandwidth of 1500 neighbours.*set adaptive = FALSE") + # n itself is a valid count and says nothing. + r200 <- .r2_catch(fit_gwr_model(d, "z", "a", bandwidth = 200)) + expect_false(any(grepl("exceeds", r200$warnings))) + + s <- .r2_pts(14, 1, c("a", "b")) + s$z <- 1 + s$a + rnorm(14, 0, 0.3) + rs <- .r2_catch(gwr_model_selection(s, "z", c("a", "b"), bandwidth = 50)) + expect_identical(rs$value$bandwidth, 14L) + expect_true(any(grepl("adaptive bandwidth of 50 neighbours exceeds the 14 observations", + rs$warnings))) +}) + +test_that("below 20 points, capping bw.gwr()'s choice at n is said", { + set.seed(1) + n <- 12 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = a, + z = 1 + (x / 1000) * a + rnorm(n, 0, 0.3)), + coords = c("x", "y"), crs = 32617) + r <- .r2_catch(fit_gwr_model(d, "z", "a")) + expect_equal(r$value$info$bandwidth, 12) + expect_false(r$value$info$bandwidth_is_fallback) + expect_true(any(grepl(paste0("bw\\.gwr\\(\\) searches adaptive bandwidths ", + "from 20 neighbours up to n, a range that is ", + "empty for 12 observations, and returned [0-9]+; ", + "using 12"), r$warnings))) + + s <- .r2_pts(14, 1, c("a", "b")) + s$z <- 1 + s$a + rnorm(14, 0, 0.3) + rs <- .r2_catch(gwr_model_selection(s, "z", c("a", "b"))) + expect_identical(rs$value$bandwidth, 14L) + expect_true(any(grepl("empty for 14 observations", rs$warnings))) +}) + + +# --------------------------------------------------------------------------- +# A predictor named twice is one term, and the collinearity checks and the +# coefficient map treated it as two perfectly collinear ones. +# --------------------------------------------------------------------------- + +test_that("a predictor named twice is fitted, surveyed and mapped once", { + set.seed(1) + n <- 120 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- sf::st_as_sf(data.frame(x = x, y = y, a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32617) + d$z <- 1 + (x / 1000) * d$a + 0.5 * d$b + rnorm(n, 0, 0.3) + dup <- .r2_catch(fit_gwr_model(d, "z", c("a", "b", "a"), bandwidth = 40)) + ok <- .r2_catch(fit_gwr_model(d, "z", c("a", "b"), bandwidth = 40)) + expect_identical(dup$warnings, ok$warnings) + expect_false(any(grepl("singular|collinear", dup$warnings))) + expect_identical(dup$value$predictor_vars, c("a", "b")) + expect_equal(dup$value$info$condition_index, ok$value$info$condition_index) + expect_equal(dup$value$info$n_local_collinear, 0L) + expect_identical(coef(dup$value), coef(ok$value)) + skip_if_not_installed("ggplot2") + expect_s3_class(plot(dup$value, type = "coefficients"), "ggplot") +}) diff --git a/tests/testthat/test-review2-logging.R b/tests/testthat/test-review2-logging.R new file mode 100644 index 0000000..2c5f627 --- /dev/null +++ b/tests/testthat/test-review2-logging.R @@ -0,0 +1,174 @@ +# tests/testthat/test-review2-logging.R +# --------------------------------------------------------------------------- +# The package's own logger setup (R/zzz.R) and the helpers that write to it +# (R/utils.R): a user's logger configuration cannot break or tap it, a deleted +# session temp directory cannot turn a log line into an error, and a knitted +# document shows the cautions that are only logged. +# --------------------------------------------------------------------------- + +# logger keeps every namespace's configuration in one internal environment. +# Tests that rebuild the "spatialkit" namespace, or change the user's global +# one, save both entries first and put them back afterwards. +.logger_namespaces <- function() get("namespaces", envir = asNamespace("logger")) + +local_logger_state <- function(env = parent.frame()) { + ns <- .logger_namespaces() + saved_global <- get("global", envir = ns) + saved_sk <- get("spatialkit", envir = ns) + withr::defer({ + assign("global", saved_global, envir = ns) + assign("spatialkit", saved_sk, envir = ns) + }, envir = env) + invisible(NULL) +} + +read_or_empty <- function(f) if (file.exists(f)) readLines(f) else character(0) + + +test_that("a global logger configuration made before loading neither breaks nor taps spatialkit's log", { + local_logger_state() + ns <- .logger_namespaces() + f2 <- withr::local_tempfile() + f3 <- withr::local_tempfile() + # A user who configured logging BEFORE library(spatialkit): sprintf + # formatting, a second index writing to a file, a third one to another. + logger::log_formatter(logger::formatter_sprintf) + logger::log_appender(logger::appender_file(f2), index = 2) + logger::log_formatter(logger::formatter_sprintf, index = 2) + logger::log_appender(logger::appender_file(f3), index = 3) + logger::log_formatter(logger::formatter_glue, index = 3) + global_before <- get("global", envir = ns) + + # As if the package were loading for the first time: logger then seeds the + # namespace by copying all three of the user's indices. + rm("spatialkit", envir = ns) + spatialkit:::.onLoad(NULL, "spatialkit") + expect_identical(get("global", envir = ns), global_before) + + # The console echo inherited formatter_sprintf, so a `%` in a message + # aborted the caller ("too few arguments") and the promised R warning never + # arrived; formatter_glue on index 3 did the same for a `{`. + lines <- capture_spatialkit_log({ + expect_warning( + spatialkit:::.warn_and_log("fold 2 skipped: %s", + "object 'cov_{x' not found; 14% done"), + "fold 2 skipped: object 'cov_{x' not found; 14% done", fixed = TRUE) + expect_no_error(spatialkit:::.log_warn("distortion %.1f%% over {the} extent", 14)) + expect_no_error(spatialkit:::.log_info("an INFO line with %s", "50% {x}")) + }) + expect_true(log_has(lines, "cov_\\{x' not found; 14% done")) + expect_true(log_has(lines, "distortion 14.0% over \\{the\\} extent")) + + # And the user's own log files receive nothing from spatialkit. + expect_identical(read_or_empty(f2), character(0)) + expect_identical(read_or_empty(f3), character(0)) + + # Re-running the setup on the namespace it built is harmless. + expect_no_error(spatialkit:::.onLoad(NULL, "spatialkit")) + capture_spatialkit_log( + expect_warning(spatialkit:::.warn_and_log("again %s", "5% {y}"), + "again 5% {y}", fixed = TRUE)) + expect_identical(read_or_empty(f3), character(0)) +}) + + +test_that("a log line that cannot be written never costs the caller its warning", { + # A session temp directory deleted under the file trace made every call that + # logs fail with "cannot open the connection"; .warn_and_log() logs before + # it warns, so the R warning the manual promises became that error. + withr::defer(logger::log_appender(spatialkit:::.sk_file_appender(), + namespace = "spatialkit", index = 1)) + + # The package's own trace pointed somewhere that cannot be written: the + # line is dropped there and still reaches the console echo. + unwritable <- file.path(withr::local_tempfile(lines = "a file"), "x", "t.log") + logger::log_appender(spatialkit:::.sk_file_appender(function() unwritable), + namespace = "spatialkit", index = 1) + lines <- capture_spatialkit_log({ + expect_warning(spatialkit:::.warn_and_log("%s(): dropped %d row(s)", "f", 3L), + "f(): dropped 3 row(s)", fixed = TRUE) + expect_no_error(spatialkit:::.log_warn("still %s", "logging")) + expect_no_error(spatialkit:::.log_info("and %s", "informing")) + }) + expect_true(log_has(lines, "f\\(\\): dropped 3 row\\(s\\)")) + expect_true(log_has(lines, "still logging")) + + # An appender that throws outright -- one a user installed, say -- costs + # the log line, never the computation or the warning. + logger::log_appender(function(lines) stop("cannot open the connection"), + namespace = "spatialkit", index = 1) + expect_warning(spatialkit:::.warn_and_log("%s(): dropped %d row(s)", "g", 4L), + "g(): dropped 4 row(s)", fixed = TRUE) + expect_no_error(spatialkit:::.log_warn("still %s", "running")) + expect_no_error(spatialkit:::.log_info("and %s", "informing")) +}) + + +test_that("the temp-file trace recreates its deleted directory and never throws", { + dir <- withr::local_tempdir() + f <- file.path(dir, "session", "trace.log") + app <- spatialkit:::.sk_file_appender(function() f) + app("first") + expect_identical(readLines(f), "first") + unlink(file.path(dir, "session"), recursive = TRUE) + expect_no_error(app("second")) + expect_identical(readLines(f), "second") + # A path that cannot be written at all loses the line, quietly. + blocked <- file.path(f, "not-a-directory", "trace.log") + expect_silent(spatialkit:::.sk_file_appender(function() blocked)("third")) + expect_false(file.exists(blocked)) + + # The package's own trace follows tempdir() when a line is written rather + # than holding the path it saw at load time, and logger's getter still + # reports it as the call that generated it. + expect_true(is.call(logger::log_appender(namespace = "spatialkit", index = 1))) +}) + + +test_that("capturing a backend's stderr falls back when there is nowhere to divert it", { + skip_if(!identical(as.integer(sink.number(type = "message")), 2L), + "the message stream is already diverted") + gone <- file.path(withr::local_tempdir(), "deleted", "stderr.txt") + res <- spatialkit:::.call_capturing_stderr(function() 42, path = gone) + expect_identical(res$value, 42) + expect_null(res$error) + res <- spatialkit:::.call_capturing_stderr(function() stop("boom"), path = gone) + expect_match(conditionMessage(res$error), "boom") + expect_identical(as.integer(sink.number(type = "message")), 2L) +}) + + +test_that("while a document is knitted, a logged caution also reaches it as a message", { + # knitr does not capture stderr, which is where the console echo writes, so + # a knitted report showed the package's R warnings but none of its logged + # cautions. + withr::local_options(knitr.in.progress = TRUE) + app <- spatialkit:::.sk_console_appender + # The stderr copy is unchanged; the message is additional. + err <- utils::capture.output( + expect_message(app("WARN [t] a caution"), "WARN [t] a caution", fixed = TRUE), + type = "message") + expect_identical(err, "WARN [t] a caution") + + # Through the package's own helper and default configuration. + utils::capture.output( + expect_message(spatialkit:::.log_warn("%s(): 5%% of {cells} empty", "f"), + "f(): 5% of {cells} empty", fixed = TRUE), + type = "message") + + # A line that is also raised as an R warning is not repeated as a message: + # the document shows the warning already. + utils::capture.output( + expect_no_message(expect_warning(spatialkit:::.warn_and_log("raised once"), + "raised once")), + type = "message") +}) + + +test_that("outside knitr the console echo is not a message", { + withr::local_options(knitr.in.progress = NULL) + err <- utils::capture.output( + expect_no_message(spatialkit:::.log_warn("plain %s", "console")), + type = "message") + expect_true(any(grepl("plain console", err, fixed = TRUE))) +}) diff --git a/tests/testthat/test-review2-plotting.R b/tests/testthat/test-review2-plotting.R new file mode 100644 index 0000000..0e8b93e --- /dev/null +++ b/tests/testthat/test-review2-plotting.R @@ -0,0 +1,391 @@ +# tests/testthat/test-review2-plotting.R +# --------------------------------------------------------------------------- +# Second review pass over the plotting functions: plots that failed only when +# printed, labels that said something the data did not, and a pooled line +# drawn in the wrong panel. Each test builds the plot with +# ggplot2::ggplot_build() and reads what is drawn, since a ggplot object is +# built lazily and constructing one proves nothing. +# --------------------------------------------------------------------------- + +layer_geoms_r2 <- function(p) vapply(p$layers, function(l) class(l$geom)[1L], character(1)) + +r2_points <- function(n = 60, crs = 32632, seed = 1) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + z = rnorm(n)), + coords = c("x", "y"), crs = crs) +} + + +# ---- plot_tessellation_map() --------------------------------------------- + +test_that("labels = TRUE labels the package's own cells without naming a column", { + skip_if_not_installed("ggplot2") + # The default label_col was "grid_id", which no function produces, so + # labels = TRUE drew nothing on Voronoi cells, grids or summarize_by_cell() + # output. + pts <- r2_points() + tess <- build_tessellation(pts, method = "voronoi", quiet = TRUE) + p <- plot_tessellation_map(tess$cells, labels = TRUE) + expect_true("GeomText" %in% layer_geoms_r2(p)) + txt <- ggplot2::layer_data(p, which(layer_geoms_r2(p) == "GeomText")) + expect_equal(sort(as.numeric(txt$label)), sort(tess$cells$cell_id)) + + cells <- summarize_by_cell(assign_features_to_polygons(pts, tess$cells), + response_var = "z", cells_sf = tess$cells) + expect_false("cell_id" %in% names(cells)) + p2 <- plot_tessellation_map(cells, labels = TRUE) + txt2 <- ggplot2::layer_data(p2, which(layer_geoms_r2(p2) == "GeomText")) + expect_equal(sort(as.numeric(txt2$label)), sort(cells$poly_id)) + + # A grid_id column still wins, and an explicit label_col is honoured. + cells$grid_id <- paste0("g", cells$poly_id) + p3 <- plot_tessellation_map(cells, labels = TRUE) + expect_true(all(grepl("^g", ggplot2::layer_data(p3, 2L)$label))) + p4 <- plot_tessellation_map(cells, labels = TRUE, label_col = "n") + expect_equal(sort(ggplot2::layer_data(p4, 2L)$label), sort(cells$n)) +}) + +test_that("labels = TRUE on a layer with no ID column draws no labels and logs why", { + skip_if_not_installed("ggplot2") + g <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox( + c(xmin = 0, ymin = 0, xmax = 1000, ymax = 1000), crs = sf::st_crs(32632))), n = c(2, 2)) + cells <- sf::st_sf(v = 1:4, geometry = g) + lines <- capture_spatialkit_log(p <- plot_tessellation_map(cells, labels = TRUE)) + expect_false("GeomText" %in% layer_geoms_r2(p)) + expect_true(log_has(lines, "no ID column")) +}) + +test_that("a units, Date, POSIXct or difftime fill column draws instead of failing at print", { + skip_if_not_installed("ggplot2") + # The scale was chosen with is.numeric(): Date, POSIXct and difftime got a + # discrete scale ("Continuous value supplied to a discrete scale") and an + # st_area() column a continuous one whose arithmetic failed on units -- + # both only once the plot was built. + g <- sf::st_make_grid(sf::st_as_sfc(sf::st_bbox( + c(xmin = 0, ymin = 0, xmax = 1000, ymax = 1000), crs = sf::st_crs(32632))), n = c(3, 3)) + cells <- sf::st_sf(id = seq_along(g), geometry = g) + cells$area <- sf::st_area(cells) * seq(0.5, 1.5, length.out = 9) + cells$when <- as.Date("2024-01-01") + 0:8 + cells$stamp <- as.POSIXct("2024-01-01", tz = "UTC") + 3600 * (0:8) + cells$lag <- as.difftime(1:9, units = "days") + for (col in c("area", "when", "stamp", "lag")) { + p <- plot_tessellation_map(cells, fill_col = col) + expect_no_error(b <- ggplot2::ggplot_build(p)) + fills <- b$data[[1]]$fill + # A continuous scale: nine values, nine different colours, none NA. + expect_equal(length(unique(fills)), 9L, label = col) + expect_false(anyNA(fills), label = col) + } + # The unit goes in the legend title; an explicit title is left alone. + expect_identical(plot_tessellation_map(cells, fill_col = "area")$scales$get_scales("fill")$name, + "area [m^2]") + expect_identical(plot_tessellation_map(cells, fill_col = "lag")$scales$get_scales("fill")$name, + "lag [days]") + expect_identical(plot_tessellation_map(cells, fill_col = "area", legend_title = "A")$scales$get_scales("fill")$name, + "A") + # A Date legend is labelled with dates ("Jan 01" in English), not with the + # day counts (19723) a numeric scale would print. + b <- ggplot2::ggplot_build(plot_tessellation_map(cells, fill_col = "when")) + labs <- b$plot$scales$get_scales("fill")$get_labels() + expect_gt(length(labs), 1L) + expect_false(any(grepl("^[0-9.e+]+$", labs))) +}) + + +# ---- plot_folds() -------------------------------------------------------- + +test_that("plot_folds draws the layer the folds came from when only the blocks carry a CRS", { + skip_if_not_installed("ggplot2") + # make_folds() projects CRS-less lon/lat points to a UTM zone, so its blocks + # carry a CRS the points do not; coord_sf() then aborted at print with + # "cannot transform sfc object with missing crs". + set.seed(1); n <- 80 + ll <- sf::st_as_sf(data.frame(x = 10 + runif(n, 0, 0.01), y = 45 + runif(n, 0, 0.01)), + coords = c("x", "y")) + f <- suppressWarnings(make_folds(ll, k = 5, method = "block_kfold", block_size = 300)) + expect_false(is.na(sf::st_crs(f$params$blocks))) + expect_warning(p <- plot_folds(f, ll), "plot_folds\\(\\): `points_sf` has no CRS; its coordinates look like lon/lat") + expect_no_error(b <- ggplot2::ggplot_build(p)) + # The points are reprojected onto the blocks, not stamped as metres. + blk <- sf::st_bbox(b$data[[1]]$geometry); pt <- sf::st_bbox(b$data[[2]]$geometry) + expect_true(pt[["xmin"]] >= blk[["xmin"]] && pt[["xmax"]] <= blk[["xmax"]] && + pt[["ymin"]] >= blk[["ymin"]] && pt[["ymax"]] <= blk[["ymax"]]) + expect_equal(nrow(b$data[[2]]), n) +}) + +test_that("plot_folds aligns a CRS-less boundary or CRS-less points to the other layers", { + skip_if_not_installed("ggplot2") + pts <- r2_points(n = 80) + f <- make_folds(pts, k = 5, method = "block_kfold", block_size = 300, seed = 1) + bnd <- sf::st_as_sf(sf::st_as_sfc(sf::st_bbox(pts))) + bnd_na <- sf::st_set_crs(bnd, NA) + expect_warning(p <- plot_folds(f, pts, boundary = bnd_na), "`boundary` has no CRS") + expect_no_error(b <- ggplot2::ggplot_build(p)) + expect_length(b$data, 3L) + + # CRS-less points whose folds took a boundary's CRS inside make_folds(). + pts_na <- sf::st_set_crs(pts, NA) + f2 <- suppressWarnings(make_folds(pts_na, k = 5, method = "block_kfold", + block_size = 300, boundary = bnd, seed = 1)) + expect_warning(p2 <- plot_folds(f2, pts_na), "`points_sf` has no CRS") + expect_no_error(ggplot2::ggplot_build(p2)) + # CRS-less points and folds, a boundary with a CRS. + f3 <- suppressWarnings(make_folds(pts_na, k = 5, method = "block_kfold", + block_size = 300, seed = 1)) + p3 <- suppressWarnings(plot_folds(f3, pts_na, boundary = bnd)) + expect_no_error(ggplot2::ggplot_build(p3)) + # No layer with a CRS: drawn as they are, with nothing to warn about. + expect_no_warning(p4 <- plot_folds(f3, pts_na)) + expect_no_error(ggplot2::ggplot_build(p4)) +}) + +test_that("plot_folds' subtitle gives no unit for folds built without a CRS", { + skip_if_not_installed("ggplot2") + # make_folds() records NA_character_ as the CRS and nzchar(NA) is TRUE, so + # the subtitle read "Block size 300 (NA units)". + pts_na <- sf::st_set_crs(r2_points(n = 80), NA) + fb <- suppressWarnings(make_folds(pts_na, k = 4, method = "block_kfold", + block_size = 300, seed = 1)) + expect_true(is.na(fb$params$crs)) + sub_b <- plot_folds(fb, pts_na)$labels$subtitle + expect_match(sub_b, "Block size 300\n") + expect_false(grepl("NA units", sub_b)) + fl <- suppressWarnings(make_folds(pts_na, k = 80, method = "buffered_loo", buffer = 150)) + sub_l <- plot_folds(fl, pts_na)$labels$subtitle + expect_identical(sub_l, "Leave-one-out with a 150 buffer") +}) + + +# ---- plot.aoa() ----------------------------------------------------------- + +test_that("plot.aoa's legend says what the training DI is", { + skip_if_not_installed("ggplot2") + set.seed(2); n <- 200 + train <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + new <- sf::st_as_sf(data.frame(x = 5e5 + runif(100, 0, 1000), y = 5e6 + runif(100, 0, 1000), + a = rnorm(100, mean = 2), b = rnorm(100)), + coords = c("x", "y"), crs = 32632) + legend_of <- function(p) { + b <- ggplot2::ggplot_build(p) + sc <- b$plot$scales$get_scales("colour") + list(labels = sc$get_labels(), colours = unique(b$data[[1]]$colour)) + } + # No folds: the training DI is the distance to the nearest other training + # point, and the caption already said so; the legend said "cross-validated". + a0 <- area_of_applicability(new, train_sf = train, predictor_vars = c("a", "b")) + l0 <- legend_of(plot(a0)) + expect_true("Training (nearest other training point)" %in% l0$labels) + expect_false(any(grepl("cross-validated", l0$labels))) + # Both curves keep their colours (a manual scale keyed on a stale name + # would draw one of them in NA). + expect_setequal(l0$colours, c("grey45", "#2166AC")) + f <- make_folds(train, k = 5, method = "block_kfold", block_size = 300, seed = 1) + a1 <- area_of_applicability(new, train_sf = train, predictor_vars = c("a", "b"), folds = f) + l1 <- legend_of(plot(a1)) + expect_true("Training (cross-validated)" %in% l1$labels) + expect_setequal(l1$colours, c("grey45", "#2166AC")) +}) + + +# ---- plot_cv_metrics() ----------------------------------------------------- + +test_that("plot_cv_metrics draws no pooled line for a model without per-fold values", { + skip_if_not_installed("ggplot2") + # factor(pooled$model, levels = ...) turned such a model into NA, and its + # line was drawn in another model's panel, or in a third panel labelled NA. + cmp <- list( + by_fold = data.frame(model = rep(c("GWR", "RF"), each = 4), fold = rep(1:4, 2), + RMSE = c(NA, NA, NA, NA, 3.1, 3.9, 3.5, 4.0), + n_pred = 25, stringsAsFactors = FALSE), + overall = data.frame(model = c("GWR", "RF"), RMSE = c(1.84, 3.66), + stringsAsFactors = FALSE)) + p <- plot_cv_metrics(cmp, "RMSE") + b <- ggplot2::ggplot_build(p) + hl <- b$data[[which(layer_geoms_r2(p) == "GeomHline")]] + expect_equal(hl$yintercept, 3.66) + expect_match(p$labels$caption, "Not drawn: GWR \\(no finite per-fold `RMSE`\\)") + + # A pooled row for a model absent from the per-fold table: no NA panel. + cmp$by_fold$RMSE[1:4] <- c(1.5, 2, 1.9, 2.1) + cmp$overall <- rbind(cmp$overall, data.frame(model = "Extra", RMSE = 5)) + p2 <- plot_cv_metrics(cmp, "RMSE") + b2 <- ggplot2::ggplot_build(p2) + expect_equal(nrow(b2$layout$layout), 2L) + expect_false(anyNA(b2$layout$layout$model)) + hl2 <- b2$data[[which(layer_geoms_r2(p2) == "GeomHline")]] + expect_setequal(hl2$yintercept, c(1.84, 3.66)) + expect_match(p2$labels$caption, "Not drawn: Extra") +}) + + +# ---- plot.feature_selection() --------------------------------------------- + +test_that("the rejected last step is drawn hollow and labelled as not added", { + skip_if_not_installed("ggplot2") + # In the shape select_features_forward() returns: a and b accepted, and c, + # the best candidate at step 3, improved the score by less than tol. + sel <- structure(list( + selected = c("a", "b"), + history = data.frame(step = c(0L, 1L, 1L, 1L, 2L, 2L, 3L), + variable = c("(intercept)", "a", "b", "c", "b", "c", "c"), + score = c(3.0, 2.0, 2.6, 2.9, 1.50, 1.95, 1.49), + stringsAsFactors = FALSE), + params = list(metric = "RMSE", k = 3, method = "block_kfold")), + class = c("feature_selection", "list")) + p <- plot(sel) + b <- ggplot2::ggplot_build(p) + geoms <- layer_geoms_r2(p) + txt <- b$data[[which(geoms == "GeomText")]] + expect_identical(txt$label[order(txt$x)], c("(intercept)", "a", "b", "c (not added)")) + # The path points: filled at the accepted steps, hollow at the rejected one, + # and each scored candidate still drawn once. + path_layer <- which(geoms == "GeomPoint")[2L] + path <- b$data[[path_layer]] + expect_equal(path$shape[order(path$x)], c(19, 19, 19, 21)) + n_pts <- sum(vapply(b$data[which(geoms == "GeomPoint")], nrow, integer(1))) + expect_equal(n_pts, nrow(sel$history) + 1L) # + the chosen marker + # The chosen step is still the last accepted one. + chosen <- b$data[[utils::tail(which(geoms == "GeomPoint"), 1L)]] + expect_equal(chosen$x, 2) +}) + + +# ---- plot.spatial_fit() --------------------------------------------------- + +test_that("plot.spatial_fit draws a custom fit that has no residuals() method", { + skip_if_not_installed("ggplot2") + # ?new_spatial_fit calls residuals() methods optional; without one, + # residuals.default() returned NULL and every type but "coefficients" + # stopped with "could not extract residuals". + pts <- surf_test_points(n = 70) + engine <- stats::lm(z ~ w, sf::st_drop_geometry(pts)) + # With neither method, the error names the one a custom subclass must have. + bare <- new_spatial_fit("r2nomethods_fit", engine, z ~ w, "z", "w", pts) + expect_error(plot(bare, type = "residuals"), "Define a fitted.r2nomethods_fit\\(\\) method") + fit <- new_spatial_fit("r2noresid_fit", engine, z ~ w, "z", "w", pts) + registerS3method("fitted", "r2noresid_fit", + function(object, ...) as.numeric(stats::fitted(object$engine))) + expect_null(stats::residuals(fit)) + p <- plot(fit, type = "residuals") + expect_no_error(b <- ggplot2::ggplot_build(p)) + expect_equal(nrow(b$data[[1]]), 70L) + expect_equal(p$data$.resid, as.numeric(stats::residuals(engine)), tolerance = 1e-10) + po <- plot(fit, type = "observed_predicted") + bo <- ggplot2::ggplot_build(po) + expect_equal(sort(bo$data[[2]]$x), sort(pts$z), tolerance = 1e-8) +}) + +test_that("the residual and response variograms are compared only over the same pairs", { + skip_if_not_installed("ggplot2") + skip_if_not_installed("gstat") + # estimate_sac_range() returns the widest single direction when the + # all-pairs fit is unusable -- as it often is for a response with a trend + # whose residuals are fine -- and that overlay was labelled plainly as the + # response, its sill set against the all-pairs residual curve's. + set.seed(5); n <- 200 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 50) + diag(1e-4, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 3857) + sac <- estimate_sac_range(pts, "z") + expect_true(is.finite(sac)) + expect_false(isTRUE(attr(sac, "anisotropy_used"))) + one_dir <- function(s, widest) { + attr(s, "anisotropy_used") <- TRUE + attr(s, "directional") <- c(`0` = 40, `45` = NA, `90` = 40, `135` = 40) + attr(s, "directional")[widest] <- 60 + s + } + deg <- "\u00b0 \u00b1 22.5\u00b0" + draw <- function(main, ov) .draw_sac_variogram(main, what = "Residual variogram", + overlay = ov, overlay_label = "Response (z)") + cap <- function(p) gsub("\n", " ", p$labels$caption) + + # All-pairs residuals, one-direction response. + p1 <- draw(sac, one_dir(sac, "90")) + expect_no_error(ggplot2::ggplot_build(p1)) + expect_match(cap(p1), paste0("Response \\(z\\), the 90", deg, " direction only")) + expect_match(cap(p1), "Sills not compared: the two variograms are not over the same point pairs") + expect_false(grepl("Residual sill is", cap(p1))) + # One-direction residuals, all-pairs response. + p2 <- draw(one_dir(sac, "0"), sac) + expect_match(p2$labels$title, paste0("Residual variogram, 0", deg)) + expect_match(cap(p2), "Sills not compared: the two variograms are not over the same point pairs") + # Different directions are not the same pairs either; the same direction is. + expect_match(cap(draw(one_dir(sac, "0"), one_dir(sac, "90"))), "Sills not compared") + expect_match(cap(draw(one_dir(sac, "90"), one_dir(sac, "90"))), "Residual sill is [0-9]+% of the response sill") + # Both all-pairs: compared, as before. + expect_match(cap(draw(sac, sac)), "Residual sill is 100% of the response sill") +}) + +test_that("the no-sill subtitle does not claim a range range_frac refused ran past the lags", { + skip_if_not_installed("ggplot2") + skip_if_not_installed("gstat") + # range_frac < 1 refuses a range below the largest lag fitted; the subtitle + # printed that lag as the bound and said the variogram never reached a sill. + set.seed(3); n <- 250 + xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + D <- as.matrix(stats::dist(xy)) + xy$z <- as.numeric(t(chol(exp(-D / 150) + diag(0.5, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) + r <- suppressWarnings(estimate_sac_range(pts, "z", range_frac = 0.1)) + expect_identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_true(attr(r, "rejected_range") <= attr(r, "cutoff_dist")) + sub <- gsub("\n", " ", plot(r)$labels$subtitle) + expect_false(grepl("never reached a sill", sub)) + expect_match(sub, "within the largest lag fitted .* `range_frac` accepts") + # A range past the largest lag keeps the sill wording. + r_over <- r + attr(r_over, "rejected_range") <- 2 * attr(r, "cutoff_dist") + expect_match(gsub("\n", " ", plot(r_over)$labels$subtitle), + "exceeds the largest lag fitted .* never reached a sill") +}) + + +# ---- plot(type = "coefficients") on a GWR fit ------------------------------ + +test_that("the GWR coefficient subtitle is right with mask = FALSE", { + skip_if_not_installed("ggplot2") + skip_if_not_installed("GWmodel") + skip_if_not_installed("sp") + # A clean survey is not a missing one. + set.seed(3); n <- 200 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); a <- rnorm(n); b <- rnorm(n) + pts <- sf::st_as_sf(data.frame(x = x, y = y, a = a, b = b, + z = (1 + 2 * x / 1000) * a - b + rnorm(n, 0, 0.3)), + coords = c("x", "y"), crs = 32632) + fit <- suppressWarnings(fit_gwr_model(pts, "z", c("a", "b"), adaptive = TRUE, bandwidth = 60)) + expect_true(is.data.frame(fit$info$local_collinearity)) + expect_identical(fit$info$n_local_collinear, 0L) + s0 <- plot(fit, type = "coefficients", mask = FALSE)$labels$subtitle + expect_false(grepl("not surveyed", s0)) + expect_match(s0, "every local design is well conditioned") + + # Collinear windows and a non-finite coefficient: mask = FALSE still says + # the collinear windows are drawn as if reliable. + set.seed(5); cl <- rep(1:4, each = 50) + d <- sf::st_as_sf(data.frame( + x = c(runif(50, 0, 100), runif(50, 400, 500), runif(50, 0, 100), runif(50, 400, 500)), + y = c(runif(50, 0, 100), runif(50, 0, 100), runif(50, 400, 500), runif(50, 400, 500)), + a = rnorm(200), soil = c(0.5, 1.5, 0.5, 1.5)[cl] + rnorm(200, 0, 0.01)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + 3 * d$soil + rnorm(200, 0, 0.2) + f70 <- suppressWarnings(fit_gwr_model(d, "z", c("a", "soil"), adaptive = TRUE, bandwidth = 70)) + f70$engine$SDF@data$a[1:3] <- NaN + # A slope map is masked by the slope flag (cn_slopes, or cn above 1e6). + cn_bad <- with(f70$info$local_collinearity, + !is.finite(cn_slopes) | cn_slopes > 30 | !is.finite(cn) | cn > 1e6) + n_cn <- sum(cn_bad[-(1:3)]) + expect_gt(n_cn, 0L) + s1 <- plot(f70, type = "coefficients", term = "a", mask = FALSE)$labels$subtitle + expect_match(s1, "^3 of 200 locations masked") + expect_match(s1, "3 with a non-finite coefficient") + expect_match(s1, sprintf("mask = FALSE: %d location\\(s\\) with a collinear local design are drawn as if reliable", n_cn)) + # mask = TRUE is unchanged. + s2 <- plot(f70, type = "coefficients", term = "a")$labels$subtitle + expect_match(s2, sprintf("^%d of 200 locations masked", n_cn + 3L)) + expect_false(grepl("mask = FALSE", s2)) +}) diff --git a/tests/testthat/test-review2-predict-surface.R b/tests/testthat/test-review2-predict-surface.R new file mode 100644 index 0000000..d4fd39d --- /dev/null +++ b/tests/testthat/test-review2-predict-surface.R @@ -0,0 +1,111 @@ +# tests/testthat/test-review2-predict-surface.R +# --------------------------------------------------------------------------- +# predict_surface(): a polygon grid, `draws` passed through `...`, the grid's +# floating-point column count, and a stale .pred_se on a reused surface. +# Uses the lm-backed spatial_fit from helper-lmfit.R. +# --------------------------------------------------------------------------- + +# Covariate points on a 20-unit lattice offset by 3, so no grid-cell centre is +# equidistant from two of them and the nearest one is unambiguous. +r2_lattice <- function() { + xy <- expand.grid(x = seq(3, 1000, by = 20), y = seq(3, 1000, by = 20)) + pts <- sf::st_as_sf(xy, coords = c("x", "y"), crs = 3857, remove = FALSE) + pts$t <- pts$y / 200 + set.seed(2) + pts$z <- 3 * pts$t + stats::rnorm(nrow(pts), 0, 0.1) + pts +} + + +test_that("a polygon grid takes covariates at each cell's point and returns points", { + cov <- r2_lattice() + fit <- lm_spatial_fit(cov, predictor_vars = "t") + polys <- sf::st_sf(geometry = sf::st_make_grid( + sf::st_as_sfc(sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 1000, ymax = 1000), + crs = sf::st_crs(3857))), n = c(5, 5))) + + s_poly <- predict_surface(fit, grid = polys, covariates = cov) + s_pts <- predict_surface(fit, grid = coerce_to_points(polys, "auto"), + covariates = cov) + expect_true(all(sf::st_geometry_type(s_poly) == "POINT")) + expect_identical(nrow(s_poly), 25L) + # The cell's covariate is the one nearest its representative point, not an + # arbitrary point inside it: the bottom-left cell's centre is at y = 100, so + # t is about 0.5, where the old path could hand it anything from 0 to 1. + expect_equal(s_poly$t, s_pts$t) + expect_equal(s_poly$.pred, s_pts$.pred) + expect_true(all(abs(s_poly$t - sf::st_coordinates(s_poly)[, 2] / 200) < 0.1)) + + # And the answer no longer depends on the row order of `covariates`. + set.seed(4) + shuffled <- cov[sample(nrow(cov)), ] + expect_equal(predict_surface(fit, grid = polys, covariates = shuffled)$.pred, + s_poly$.pred) +}) + + +test_that("`draws` passed through `...` is refused rather than flattened into .pred", { + pts <- surf_test_points() + fit <- lm_spatial_fit(pts) + expect_error(predict_surface(fit, n_cells = 50, draws = TRUE), + "`draws` cannot be passed through `...`") + expect_error(predict_surface(fit, n_cells = 50, dr = TRUE), + "`draws` cannot be passed through `...`") + expect_error(predict_surface(fit, n_cells = 50, se = TRUE, draws = TRUE), + "`draws` cannot be passed through `...`") +}) + + +test_that("a backend returning the wrong number of values is an error", { + pts <- surf_test_points() + fit <- lm_spatial_fit(pts) + class(fit) <- c("r2_badlen_fit", class(fit)) + registerS3method("predict", "r2_badlen_fit", + function(object, newdata = NULL, ...) rep(1, 2L * nrow(newdata))) + expect_error(predict_surface(fit, n_cells = 50), + "returned \\d+ value\\(s\\) for the \\d+ rows") +}) + + +test_that("the automatic grid does not lose a column to floating-point rounding", { + grid_fn <- spatialkit:::.make_prediction_grid + crs <- sf::st_crs(32632) + # 0.3 / 0.1 is 2.9999999999999996, and floor() dropped the third column. + bb <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 0.3, ymax = 0.3), crs = crs) + g <- grid_fn(bb, crs, cell_size = 0.1) + expect_equal(sort(unique(g$..grid_x)), c(0.05, 0.15, 0.25)) + expect_identical(nrow(g), 9L) + + # At the default n_cells a square's cell size is its width / 100, and the + # same rounding gave 99 columns for some widths (2.11 among them). + for (w in c(2.11, 2.48, 3.59, 11.36)) { + bb <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = w, ymax = w), crs = crs) + g <- grid_fn(bb, crs, n_cells = 10000) + expect_identical(length(unique(g$..grid_x)), 100L) + expect_identical(length(unique(g$..grid_y)), 100L) + } + + # A width that is NOT a multiple gets enough cells to cover it, centred: + # 100 / 30 is 4 cells, overhanging by 10 on each side. + bb <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 100, ymax = 100), crs = crs) + expect_equal(sort(unique(grid_fn(bb, crs, cell_size = 30)$..grid_x)), + c(5, 35, 65, 95)) +}) + + +test_that("a reused surface does not keep the previous model's .pred_se", { + pts <- surf_test_points() + fit_a <- lm_spatial_fit(pts) + fit_b <- lm_spatial_fit(pts, predictor_vars = "w") + s1 <- predict_surface(fit_a, n_cells = 100, se = TRUE, covariates = pts) + expect_true(".pred_se" %in% names(s1)) + + s2 <- predict_surface(fit_b, grid = s1, covariates = pts) + expect_false(".pred_se" %in% names(s2)) + expect_false(isTRUE(all.equal(s2$.pred, s1$.pred))) + + # Asked for again, it is this model's. + s3 <- predict_surface(fit_b, grid = s1, covariates = pts, se = TRUE) + expect_true(".pred_se" %in% names(s3)) + expect_false(isTRUE(all.equal(s3$.pred_se, s1$.pred_se))) +}) diff --git a/tests/testthat/test-review2-resolution.R b/tests/testthat/test-review2-resolution.R new file mode 100644 index 0000000..17d5390 --- /dev/null +++ b/tests/testthat/test-review2-resolution.R @@ -0,0 +1,251 @@ +# tests/testthat/test-review2-resolution.R +# --------------------------------------------------------------------------- +# Regressions from the second review of the resolution step: +# resolution_profile() and determine_optimal_levels(). +# --------------------------------------------------------------------------- + +# A hand-made sac_range, so the variogram-based columns exist without gstat. +r2_sac <- function(range, nugget = 1, psill = 1, crs = sf::st_crs(32632), ...) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, range / 3), stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = crs, ...) +} + +r2_pts <- function(n = 300, seed = 1, ext = 1000, x0 = 5e5, y0 = 5e6, crs = 32632) { + set.seed(seed) + d <- data.frame(x = x0 + runif(n, 0, ext), y = y0 + runif(n, 0, ext), w = rnorm(n)) + d$z <- d$w + rnorm(n) + sf::st_as_sf(d, coords = c("x", "y"), crs = crs) +} + +# Every R warning an expression raises, muffled. +r2_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(c) { + w <<- c(w, conditionMessage(c)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + + +test_that("one empty point does not turn determine_optimal_levels() into 1", { + set.seed(1) + pts <- sf::st_as_sf( + data.frame(x = 5e5 + c(runif(25, 0, 10), runif(25, 90, 100)), + y = 5e6 + c(runif(25, 0, 10), runif(25, 90, 100))), + coords = c("x", "y"), crs = 32632) + clean <- determine_optimal_levels(pts, max_levels = 6) + holed <- rbind(pts[1:10, ], sf::st_sf(geometry = sf::st_sfc(sf::st_point(), crs = 32632)), + pts[11:50, ]) + out <- r2_warnings(determine_optimal_levels(holed, max_levels = 6)) + expect_identical(out$value, clean) + expect_true(any(grepl("dropping 1 point", out$warnings))) + # Under a split the positions index the layer as passed: the empty row is + # in neither half, and every other row is in one. + set.seed(2) + d <- data.frame(x = runif(80, 0, 1000), y = runif(80, 0, 1000), w = rnorm(80)) + d$z <- d$w + rnorm(80) + p80 <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + p81 <- rbind(p80[1:40, ], sf::st_sf(w = 0, z = 0, + geometry = sf::st_sfc(sf::st_point(), crs = 32632)), + p80[41:80, ]) + sp <- attr(suppressWarnings(determine_optimal_levels(p81, max_levels = 6, + select_on = "split")), "split") + expect_setequal(c(sp$selection, sp$estimation), setdiff(seq_len(81), 41L)) +}) + + +test_that("a few missing predictor values do not take Moran's z away from determine_optimal_levels()", { + # Three NAs in 400 rows used to make every cell mean holding one NA and the + # whole window fall back to the geometric ranking. + pts <- r2_pts(400, seed = 2) + holed <- pts + holed$w[c(5, 50, 150)] <- NA + dol <- function(p) suppressWarnings(determine_optimal_levels( + p, max_levels = 40, response_var = "z", predictor_vars = "w", criterion = "morans_i")) + a <- dol(pts); b <- dol(holed) + da <- attr(a, "diagnostics"); db <- attr(b, "diagnostics") + expect_false(is.null(db)) + ks <- da$eval_ks[is.finite(da$moran_z[da$eval_ks])] + expect_gt(length(ks), 0L) + expect_true(all(is.finite(db$moran_z[ks]))) + expect_equal(db$moran_z[ks], da$moran_z[ks], tolerance = 0.2) + lines <- capture_spatialkit_log(dol(holed)) + expect_true(log_has(lines, "3 of 400 row")) +}) + + +test_that("a misspelt column is an error in determine_optimal_levels(), and a missing one a warning", { + pts <- r2_pts(200) + expect_error(determine_optimal_levels(pts, response_var = "Z", predictor_vars = "w"), + "column 'Z' not found") + expect_error(determine_optimal_levels(pts, response_var = "z", predictor_vars = c("w", "Elev")), + "Elev.*not found") + out <- r2_warnings(determine_optimal_levels(pts, max_levels = 6, response_var = "z", + criterion = "morans_i")) + expect_true(any(grepl("predictor_vars were not given", out$warnings))) + expect_null(attr(out$value, "diagnostics")) +}) + + +test_that("repeat visits let the ladder reach one cell per location", { + # Five stations visited thirty times each: k-means can put a cell on every + # station (WSS 0), which the cap one short of the locations used to drop. + st <- data.frame(x = 5e5 + c(0, 1000, 0, 1000, 500), y = 5e6 + c(0, 0, 1000, 1000, 500)) + d <- st[rep(1:5, each = 30), ] + set.seed(3) + d$z <- rnorm(150) + rep(1:5, each = 30) + pp <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + prof <- resolution_profile(pp, "z", levels = 2:5, nstart = 3, sac = r2_sac(300)) + expect_identical(prof$levels, 2:5) + expect_identical(prof$wss[4], 0) + expect_true(is.finite(prof$cp[4])) + b <- attr(resolution_profile(pp, min_cell_n = 1, n_levels = 4, nstart = 3), "bounds") + expect_identical(b$ceiling, 5L) + expect_identical(b$ceiling_from, "distinct locations") + # Without repeats the cap stays one short of the points, which + # stats::kmeans() needs. + expect_identical(resolution_profile(r2_pts(20), levels = 2:20, nstart = 2)$levels, 2:19) + # determine_optimal_levels() reaches k = 5 as well, and reads the fall of + # the WSS to zero there as the elbow: one cell per station, where it used + # to warn that the stations had no cluster structure. + out <- r2_warnings(determine_optimal_levels(pp, max_levels = 12)) + expect_identical(out$value[1L], 5L) + expect_false(any(grepl("no elbow", out$warnings))) +}) + + +test_that("reliability does not move when the layer is rotated", { + # A 3000 x 120 strip: its bounding box is 21 times the hull's area once it + # is turned 45 degrees, and reliability's domain term used to be read off + # the box (argmax 8 axis-aligned, 2 rotated). + strip <- function(theta) { + set.seed(1) + u <- cbind(runif(600, -1500, 1500), runif(600, -60, 60)) + R <- matrix(c(cos(theta), sin(theta), -sin(theta), cos(theta)), 2) + xy <- u %*% t(R) + sf::st_as_sf(data.frame(x = 5e5 + xy[, 1], y = 5e6 + xy[, 2], z = rnorm(600)), + coords = c("x", "y"), crs = 32632) + } + sac <- r2_sac(90, nugget = 2, psill = 1) + lv <- c(2, 4, 8, 16, 32) + a <- resolution_profile(strip(0), "z", sac = sac, levels = lv, nstart = 2) + b <- resolution_profile(strip(pi / 4), "z", sac = sac, levels = lv, nstart = 2) + expect_equal(b$reliability, a$reliability, tolerance = 0.02) + expect_identical(select_resolution(a, "reliability")$best, + select_resolution(b, "reliability")$best) +}) + + +test_that("a sac is read in its own CRS", { + skip_if_not(!is.na(sf::st_crs(2263))) + # The same range in metres (UTM 18N) and in US feet (NY Long Island state + # plane) on the same points: the feet version put the floor at 2 where + # the metre version put it at 8. + pts <- r2_pts(300, seed = 4, ext = 5000, x0 = 583000, y0 = 4507000, crs = 32618) + m <- resolution_profile(pts, "z", sac = r2_sac(1800, crs = sf::st_crs(32618)), + n_levels = 4, nstart = 2) + ft <- resolution_profile(pts, "z", sac = r2_sac(1800 / 0.3048006, crs = sf::st_crs(2263)), + n_levels = 4, nstart = 2) + expect_identical(attr(ft, "bounds")$floor, attr(m, "bounds")$floor) + expect_gt(attr(m, "bounds")$floor, 2L) + expect_equal(ft$reliability, m$reliability, tolerance = 0.01) +}) + + +test_that("a rejected range gives cp its nugget and reliability nothing, and says so", { + pts <- r2_pts(300) + rej <- r2_sac(NA_real_, nugget = 0.5) + attr(rej, "variogram_model")$range[2] <- 3000 + attr(rej, "rejected_reason") <- "fitted range exceeds the largest lag fitted" + out <- r2_warnings(resolution_profile(pts, "z", sac = rej, n_levels = 4, nstart = 2)) + prof <- out$value + expect_true(any(grepl("fitted range exceeds the largest lag fitted", out$warnings))) + expect_true(all(is.finite(prof$cp))) + expect_true(all(is.na(prof$reliability))) + expect_equal(attr(prof, "variogram")$nugget, 0.5) + expect_error(select_resolution(prof, "reliability"), "identified range") + # A model that did not converge gives neither. + attr(rej, "rejected_reason") <- "variogram model did not converge" + out <- r2_warnings(resolution_profile(pts, "z", sac = rej, n_levels = 4, nstart = 2)) + expect_true(any(grepl("did not converge", out$warnings))) + expect_true(all(is.na(out$value$cp)) && all(is.na(out$value$reliability))) +}) + + +test_that("a zero nugget, and a sac of the other variable, are warned about", { + pts <- r2_pts(300) + out <- r2_warnings(resolution_profile(pts, "z", sac = r2_sac(300, nugget = 0), + n_levels = 4, nstart = 2)) + expect_true(any(grepl("nugget is 0", out$warnings))) + # A residual variogram applied to the raw response, and the reverse. + det <- r2_sac(300, detrended = TRUE) + out <- r2_warnings(resolution_profile(pts, "z", sac = det, n_levels = 4, nstart = 2)) + expect_true(any(grepl("variogram of detrended residuals", out$warnings))) + expect_true(isTRUE(attr(out$value, "variogram")$detrended)) + raw <- r2_sac(300, detrended = FALSE) + out <- r2_warnings(resolution_profile(pts, "z", "w", sac = raw, n_levels = 4, nstart = 2)) + expect_true(any(grepl("variogram of the raw response", out$warnings))) + # Matching, or unlabelled, raises nothing. + expect_length(r2_warnings(resolution_profile(pts, "z", "w", sac = det, n_levels = 4, + nstart = 2))$warnings, 0L) + expect_length(r2_warnings(resolution_profile(pts, "z", sac = r2_sac(300), n_levels = 4, + nstart = 2))$warnings, 0L) +}) + + +test_that("a sac supplied under select_on = 'split' is flagged", { + pts <- r2_pts(200) + lines <- capture_spatialkit_log( + resolution_profile(pts, "z", sac = r2_sac(300), n_levels = 4, nstart = 2, + select_on = "split")) + expect_true(log_has(lines, "must be fitted on the selection half")) +}) + + +test_that("row order does not change the profile or the count", { + pts <- r2_pts(300, seed = 6) + set.seed(9) + perm <- sample(nrow(pts)) + sac <- r2_sac(300, nugget = 0.5) + a <- resolution_profile(pts, "z", sac = sac, n_levels = 6, nstart = 3) + b <- resolution_profile(pts[perm, ], "z", sac = sac, n_levels = 6, nstart = 3) + expect_identical(b$wss, a$wss) + expect_equal(b$cp, a$cp) + # A layer larger than sample_n draws the same subsample either way. + c1 <- resolution_profile(pts, n_levels = 4, nstart = 2, sample_n = 150) + c2 <- resolution_profile(pts[perm, ], n_levels = 4, nstart = 2, sample_n = 150) + expect_identical(c2$wss, c1$wss) + d1 <- suppressWarnings(determine_optimal_levels(pts, max_levels = 8)) + d2 <- suppressWarnings(determine_optimal_levels(pts[perm, ], max_levels = 8)) + expect_identical(d2, d1) +}) + + +test_that("k-means++ seeding draws in proportion to the squared distance", { + # Four points on a line; the first centre is uniform, the second is drawn + # with probability d2 / sum(d2): 0.374, 0.167, 0.459 by hand. + xy <- cbind(c(0, 1, 3, 3), 0) + set.seed(2) + second <- replicate(4000, spatialkit:::.kmeanspp_centers(xy, 2)[2, 1]) + p <- as.numeric(table(factor(second, levels = c(0, 1, 3)))) / 4000 + expect_equal(p, c(0.374, 0.167, 0.459), tolerance = 0.06) + # A point already chosen (distance 0) is never drawn again. + for (i in 1:50) expect_length(unique(spatialkit:::.kmeanspp_centers(xy, 3)[, 1]), 3L) +}) + + +test_that("range_floor = FALSE starts the ladder at 2 and still reports the floor", { + pts <- r2_pts(300) + sac <- r2_sac(250) + on <- resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2) + off <- resolution_profile(pts, "z", sac = sac, n_levels = 5, nstart = 2, range_floor = FALSE) + expect_gt(attr(on, "bounds")$floor, 2L) + expect_identical(min(on$levels), attr(on, "bounds")$floor) + expect_identical(min(off$levels), 2L) + expect_identical(attr(off, "bounds")$floor, attr(on, "bounds")$floor) + expect_false(attr(off, "bounds")$range_floor) + expect_output(print(off), "not applied") + expect_error(resolution_profile(pts, range_floor = NA), "TRUE or FALSE") +}) diff --git a/tests/testthat/test-review2-sweep.R b/tests/testthat/test-review2-sweep.R new file mode 100644 index 0000000..da46473 --- /dev/null +++ b/tests/testthat/test-review2-sweep.R @@ -0,0 +1,100 @@ +# tests/testthat/test-review2-sweep.R +# --------------------------------------------------------------------------- +# Second review round: cv_block_size_sweep(). Each test fails on the code before +# the fix. Helpers are in helper-review2-folds.R. +# --------------------------------------------------------------------------- + +# ---- cv_block_size_sweep() ------------------------------------------------- + +r2_sweep_layer <- function(x, y, seed = 1) { + set.seed(seed) + p <- r2_pts(x, y, a = rnorm(length(x))) + p$z <- sin(sf::st_coordinates(p)[, 1] / 500) + 0.5 * p$a + rnorm(length(x), 0, 0.2) + p +} + +test_that("the sweep runs on points along one axis-parallel line", { + set.seed(1) + p <- r2_sweep_layer(5e5 + runif(60, 0, 6000), rep(5e6, 60)) + sw <- r2_quiet(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 3, n_sizes = 4, + sac = NA, quiet = TRUE)) # "no extent" before + expect_gt(sum(sw$method == "block_kfold"), 0L) + expect_true(all(sw$k == 3L)) +}) + +test_that("the default ladder on a thin transect skips grids make_folds() would refuse", { + set.seed(1) + # A 6000 x 3 m transect. The ladder's lower rung, 0.12 m, is a + # 50000 x 25 grid of 1.25 million blocks, which used to abort the sweep with + # an error about the units of a `block_size` nobody passed. + p <- r2_sweep_layer(5e5 + c(0, 6000, runif(58, 0, 6000)), 5e6 + c(0, 3, runif(58, 0, 3))) + sw <- r2_quiet(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 5, n_sizes = 2, + sac = NA, quiet = TRUE)) + blk <- sw[sw$method == "block_kfold", ] + expect_equal(nrow(blk), 1L) + expect_equal(blk$block_size, 1.5, tolerance = 1e-6) + # Sizes the caller chose are refused up front, naming the argument. + expect_error(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, sac = NA, quiet = TRUE, + block_sizes = c(0.001, 100)), + "`block_sizes` 0.001 would each need a grid of more than") +}) + +test_that("the sweep warns when the default ladder cannot reach the range", { + # A 5 km x 200 m corridor: the ladder stops at 100 m, while 1000 m blocks + # would still give 5 along its length. + set.seed(1) + p <- r2_sweep_layer(5e5 + runif(60, 0, 5000), 5e6 + runif(60, 0, 200)) + expect_warning( + r2_quiet(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 4, n_sizes = 2, + sac = 1000, quiet = TRUE)), + "every block size in the default ladder .* is below the estimated autocorrelation range") + # Not on a square, where no longer block would still give k blocks. + sq <- r2_sweep_layer(runif(60, 0, 1000), runif(60, 0, 1000)) + expect_no_warning( + r2_quiet(cv_block_size_sweep(sq, "z", "a", fit_fn = r2_fit, k = 4, n_sizes = 3, + sac = 900, quiet = TRUE))) +}) + +test_that("a sac estimated in another CRS is converted to the sweep's units", { + set.seed(1) + d <- r2_pts(7e5 + runif(60, 0, 2000), 3.95e6 + runif(60, 0, 2000), crs = 32617, + a = rnorm(60)) + d$z <- d$a + rnorm(60) + sac_m <- structure(600, class = "sac_range", crs = sf::st_crs(32617)) + expect_warning( + sw <- r2_quiet(cv_block_size_sweep(sf::st_transform(d, 2264), "z", "a", + fit_fn = r2_fit, k = 3, n_sizes = 2, + sac = sac_m, quiet = TRUE)), + "`sac` was estimated in EPSG:32617, not in EPSG:2264") + # 600 m is 1968.5 US survey feet. + expect_equal(attr(sw, "sac_range"), 600 / 0.3048006, tolerance = 1e-3) + # The same CRS, or no CRS recorded: used as given. + sw2 <- r2_quiet(cv_block_size_sweep(d, "z", "a", fit_fn = r2_fit, k = 3, n_sizes = 2, + sac = sac_m, quiet = TRUE)) + expect_equal(attr(sw2, "sac_range"), 600) + expect_error(cv_block_size_sweep(d, "z", "a", fit_fn = r2_fit, k = 3, n_sizes = 2, + sac = units::set_units(600, m), quiet = TRUE), + "`sac` must be a plain number") +}) + +test_that("the plot reads every coverage column by closeness to its nominal level", { + skip_if_not_installed("ggplot2") + # cv_bayes() names coverage columns at full precision (coverage_97.5), and + # a `metrics` function can add any; only coverage_50/80/95 were + # recognised, and as higher-is-better, so every other level was captioned + # "lower is better". Over-coverage is miscalibration too. + set.seed(1) + p <- r2_sweep_layer(runif(60, 0, 1000), runif(60, 0, 1000)) + cov <- function(y, yhat) c(coverage_97.5 = mean(abs(y - yhat) < 2 * stats::sd(y)), + coverage_95 = mean(abs(y - yhat) < 1.96 * stats::sd(y))) + caption <- function(metric) { + sw <- r2_quiet(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 3, n_sizes = 2, + sac = NA, quiet = TRUE, metric = metric, + metrics = cov)) + plot(sw)$labels$caption + } + expect_match(caption("coverage_97.5"), "closer to 0.975 is better") + expect_match(caption("coverage_95"), "closer to 0.95 is better") + expect_match(caption("RMSE"), "lower is better") + expect_match(caption("R2"), "higher is better") +}) diff --git a/tests/testthat/test-review2-tessellation.R b/tests/testthat/test-review2-tessellation.R new file mode 100644 index 0000000..ffde3f9 --- /dev/null +++ b/tests/testthat/test-review2-tessellation.R @@ -0,0 +1,422 @@ +# =========================================================================== +# Regressions from the second adversarial review of tessellation, CRS +# selection and seeding. Each section says what used to go wrong. +# =========================================================================== + + +.r2_sq <- function(x0, y0, s, crs = sf::NA_crs_) { + sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(x0, y0), c(x0 + s, y0), c(x0 + s, y0 + s), c(x0, y0 + s), c(x0, y0)))), + crs = crs)) +} + +.r2_box_ll <- function(x0, x1, y0, y1) { + sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(x0, y0), c(x1, y0), c(x1, y1), c(x0, y1), c(x0, y0)))), crs = 4326)) +} + +# 30 points over a kilometre at UTM-sized coordinates, with no CRS. +.r2_pts_na <- function(n = 30L, seed = 1) { + set.seed(seed) + sf::st_as_sf(data.frame(x = 5e5 + stats::runif(n, 0, 1000), + y = 5e6 + stats::runif(n, 0, 1000)), + coords = c("x", "y")) +} + +# Evaluate `code` with sf_use_s2() set to `on`, restoring the session's value. +.r2_with_s2 <- function(on, code) { + was <- suppressMessages(sf::sf_use_s2(on)) + on.exit(suppressMessages(sf::sf_use_s2(was)), add = TRUE) + force(code) +} + + +# --------------------------------------------------------------------------- +# Choosing the projection +# --------------------------------------------------------------------------- + +test_that("ensure_projected() accepts a lon/lat polygon s2 rejects", { + # A repeated vertex is valid for GEOS and a plain st_transform(), but s2's + # st_centroid(st_union()) stopped with "Edge 1 is degenerate". + rep_v <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(8, 47), c(9, 47), c(9, 47), c(9, 48), c(8, 48), c(8, 47)))), crs = 4326)) + expect_equal(sf::st_crs(ensure_projected(rep_v))$epsg, 32632L) + expect_false(sf::st_is_longlat(ensure_projected(rep_v, purpose = "area"))) + g <- create_grid_polygons(rep_v, target_cells = 20, quiet = TRUE) + expect_gt(nrow(g), 0L) +}) + + +test_that("a single study-area polygon is scored, not left to the UTM fallback", { + # One polygon reduced to one point: every candidate scored NA and CONUS + # stayed in UTM zone 15 (13% worst-case distance error). + conus <- .r2_box_ll(-124, -67, 25, 49) + out <- ensure_projected(conus) + ch <- attr(out, "crs_choice") + expect_true(all(is.finite(ch$distance_error))) + expect_false(grepl("UTM", ch$name[ch$chosen])) + expect_lt(ch$distance_error[ch$chosen], 0.05) + expect_gt(ch$distance_error[grepl("UTM", ch$name)], 0.05) +}) + + +test_that("the UTM zone does not depend on sf_use_s2()", { + # Two clusters whose centroid on the sphere lies west of -78 (zone 17) and + # whose planar centroid in degrees lies east of it (zone 18). + two <- sf::st_as_sf(data.frame(x = c(-78.6, -78.59, -77.2, -77.19), + y = c(0, 0.01, 60, 60.01)), + coords = c("x", "y"), crs = 4326) + z_on <- .r2_with_s2(TRUE, sf::st_crs(ensure_projected(two))$epsg) + z_off <- .r2_with_s2(FALSE, sf::st_crs(ensure_projected(two))$epsg) + expect_identical(z_on, 32617L) + expect_identical(z_off, z_on) +}) + + +test_that("with s2 off, lon/lat input raises none of sf's centroid conditions", { + pts_ll <- sf::st_as_sf(data.frame(x = c(9.1, 9.2, 9.15, 9.3), + y = c(48.7, 48.8, 48.75, 48.72)), + coords = c("x", "y"), crs = 4326) + .r2_with_s2(FALSE, { + expect_no_warning(expect_no_message(clip_target_for(pts_ll, quiet = TRUE))) + expect_no_warning(expect_no_message(ensure_projected(pts_ll))) + }) +}) + + +test_that("grids over a near-global boundary are equal-area; local ones keep UTM", { + glob <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + cbind(seq(-170, 170, 10), -60), cbind(seq(170, -170, -10), 70), c(-170, -60)))), + crs = 4326)) + # Web Mercator, which the distance choice falls back to here, made the + # full cells' true areas differ almost five-fold. + g <- create_grid_polygons(glob, target_cells = 100, quiet = TRUE) + expect_false(grepl("+proj=merc", sf::st_crs(g)$proj4string, fixed = TRUE)) + expect_lt(.crs_area_error(g), 0.01) + # The cached builder lays the same grid in the same CRS. + gc <- create_grid_polygons_cached(glob, target_cells = 100, cache_env = new.env()) + expect_equal(sf::st_crs(gc), sf::st_crs(g)) + + # A local boundary is unchanged: its zone. + loc <- create_grid_polygons(.r2_box_ll(9, 10, 47, 48), target_cells = 50, quiet = TRUE) + expect_equal(sf::st_crs(loc)$epsg, 32632L) +}) + + +# --------------------------------------------------------------------------- +# sf_use_s2(FALSE) without lwgeom +# --------------------------------------------------------------------------- + +test_that("with s2 off the package needs no lwgeom", { + set.seed(1) + pts <- sf::st_as_sf(data.frame(x = 5e5 + stats::runif(15, 0, 100), + y = 5e6 + stats::runif(15, 0, 100)), + coords = c("x", "y"), crs = 32632) + bnd <- .r2_sq(0, 0, 100, crs = 32632) + bnd_ll <- .r2_box_ll(8, 9, 47, 48) + on <- .r2_with_s2(TRUE, list( + ids = ensure_stable_poly_id(create_grid_polygons(bnd, target_cells = 9)))) + .r2_with_s2(FALSE, { + expect_equal(nrow(create_voronoi_polygons(pts, quiet = TRUE)$cells), 15L) + expect_equal(nrow(build_tessellation(pts, method = "voronoi", quiet = TRUE)$cells), 15L) + ids <- ensure_stable_poly_id(create_grid_polygons(bnd, target_cells = 9)) + # The same IDs as with s2 on: the sort key is measured the same way. + expect_identical(sf::st_as_text(sf::st_geometry(ids)), + sf::st_as_text(sf::st_geometry(on$ids))) + expect_equal(nrow(create_grid_polygons_cached(bnd, target_cells = 9, + cache_env = new.env())), 9L) + expect_true(is.finite(.crs_area_error(create_grid_polygons(bnd, target_cells = 9)))) + expect_equal(nrow(suppressWarnings(voronoi_seeds_random(bnd_ll, k = 5, set_seed = 1))), 5L) + expect_equal(nrow(suppressWarnings( + get_voronoi_seeds(bnd_ll, method = "kmeans", n = 3, set_seed = 1))), 3L) + # And the session's setting is left as it was. + expect_false(sf::sf_use_s2()) + }) +}) + + +# --------------------------------------------------------------------------- +# One of points and boundary without a CRS +# --------------------------------------------------------------------------- + +test_that("CRS-less planar points tessellate with a CRS-less boundary", { + # ensure_projected() marks planar CRS-less input crs_assumed = "none", and + # build_tessellation() read that as a CRS: st_crs("none") is an error, so + # every method failed, including the documented clip_target_for() pattern, + # and CRS-less planar data could not be gridded at all. + pts <- .r2_pts_na() + bnd <- clip_target_for(pts, quiet = TRUE) + for (m in c("voronoi", "triangles", "hex", "square")) { + tess <- build_tessellation(pts, boundary = bnd, method = m, quiet = TRUE, + approx_n_cells = if (m %in% c("hex", "square")) 20) + expect_gt(nrow(tess$cells), 0L) + expect_true(is.na(sf::st_crs(tess$cells)), info = m) + expect_false(anyNA(tess$index), info = m) + } +}) + + +test_that("a CRS-less boundary takes the points' CRS in every builder", { + pts <- sf::st_set_crs(.r2_pts_na(), 32632) + bnd <- .r2_sq(5e5 - 10, 5e6 - 10, 1020) # same numbers, no CRS + + # create_voronoi_polygons() died on sf's "st_crs(x) == st_crs(y) is not TRUE". + expect_warning(v <- create_voronoi_polygons(pts, boundary = bnd, quiet = TRUE), + "stamping") + expect_equal(nrow(v$cells), 30L) + expect_equal(sf::st_crs(v$cells), sf::st_crs(32632)) + + # clip_target_for() returned a target with no CRS. + expect_warning(tgt <- clip_target_for(pts, boundary = bnd, quiet = TRUE), "stamping") + expect_equal(sf::st_crs(tgt), sf::st_crs(32632)) + + # build_tessellation(method = "triangles") failed like create_voronoi_polygons(). + expect_warning(tri <- build_tessellation(pts, boundary = bnd, method = "triangles", + quiet = TRUE), "stamping") + expect_gt(nrow(tri$cells), 0L) + + # Lon/lat points with a CRS-less lon/lat boundary: the target came back in + # degrees with no CRS, and expand = 20 buffered by 20 degrees. + pts_ll <- sf::st_transform(pts, 4326) + bnd_ll <- sf::st_set_crs(sf::st_transform(sf::st_set_crs(bnd, 32632), 4326), NA) + expect_warning(tgt_ll <- clip_target_for(pts_ll, boundary = bnd_ll, expand = 20, + quiet = TRUE), "look like lon/lat") + expect_false(is.na(sf::st_crs(tgt_ll))) + expect_false(sf::st_is_longlat(tgt_ll)) + bb <- sf::st_bbox(sf::st_transform(tgt_ll, 32632)) + expect_equal(as.numeric(bb["xmax"] - bb["xmin"]), 1020 + 2 * 20, tolerance = 1e-3) +}) + + +test_that("CRS-less points take a projected boundary's CRS, and refuse a geographic one", { + pts <- .r2_pts_na() # UTM numbers from a CSV + bnd <- .r2_sq(5e5 - 10, 5e6 - 10, 1020, crs = 32632) + for (m in c("voronoi", "triangles", "hex", "square")) { + expect_warning( + tess <- build_tessellation(pts, boundary = bnd, method = m, quiet = TRUE, + approx_n_cells = if (m %in% c("hex", "square")) 20), + "stamping", info = m) + expect_equal(sf::st_crs(tess$cells), sf::st_crs(32632), info = m) + expect_false(anyNA(tess$index), info = m) + } + expect_warning(v <- create_voronoi_polygons(pts, boundary = bnd, quiet = TRUE), + "stamping") + expect_equal(nrow(v$cells), 30L) + + # Stamping degrees on UTM numbers would be wrong: refused, with a reason. + expect_error( + suppressWarnings(build_tessellation(pts, boundary = sf::st_transform(bnd, 4326), + method = "voronoi", quiet = TRUE)), + "has no CRS and its coordinates do not look like lon/lat") +}) + + +# --------------------------------------------------------------------------- +# A geographic `crs` +# --------------------------------------------------------------------------- + +test_that("a geographic crs returns cells built in metres", { + set.seed(3) + pts <- sf::st_as_sf(data.frame(x = stats::runif(150, 10, 14), + y = stats::runif(150, 53, 57)), + coords = c("x", "y"), crs = 4326) + + # Voronoi: every location in a cell is nearest (on the ground) to that + # cell's point. Built in degrees, about 20% were not. + tv <- build_tessellation(pts, method = "voronoi", crs = 4326, quiet = TRUE) + expect_equal(sf::st_crs(tv$cells), sf::st_crs(4326)) + cc <- sf::st_coordinates(sf::st_centroid(sf::st_geometry(tv$cells))) + expect_true(all(abs(cc[, 1]) <= 180 & abs(cc[, 2]) <= 90)) + probe <- sf::st_as_sf(expand.grid(x = seq(10.2, 13.8, by = 0.1), + y = seq(53.2, 56.8, by = 0.1)), + coords = c("x", "y"), crs = 4326) + hit <- sf::st_intersects(probe, tv$cells) + one <- lengths(hit) == 1L + cell <- tv$cells$cell_id[unlist(hit[one])] + near <- sf::st_nearest_feature(sf::st_transform(probe[one, ], 32632), + sf::st_transform(pts, 32632)) + expect_lt(mean(tv$index[near] != cell), 0.01) + + # Grids sized by a count: no s2 "degenerate edge" error, and every point + # inside the boundary has a cell. + bnd <- .r2_box_ll(10, 14, 53, 57) + for (m in c("hex", "square")) { + tg <- build_tessellation(pts, boundary = bnd, method = m, approx_n_cells = 80, + crs = 4326, quiet = TRUE) + expect_equal(sf::st_crs(tg$cells), sf::st_crs(4326), info = m) + expect_false(anyNA(tg$index), info = m) + } + # create_grid_polygons(): the grid laid in the projected CRS it picks on its + # own, returned in lon/lat, rather than a different grid laid in degrees. + g <- create_grid_polygons(bnd, target_cells = 50, crs = 4326, quiet = TRUE) + ref <- create_grid_polygons(bnd, target_cells = 50, quiet = TRUE) + expect_equal(sf::st_crs(g), sf::st_crs(4326)) + expect_equal(nrow(g), nrow(ref)) + expect_equal(sort(as.numeric(sf::st_area(sf::st_transform(g, sf::st_crs(ref))))), + sort(as.numeric(sf::st_area(ref))), tolerance = 1e-4) +}) + + +# --------------------------------------------------------------------------- +# Grid sizing, expand, collinear points +# --------------------------------------------------------------------------- + +test_that("hex cell size does not depend on which way the boundary lies", { + # st_make_grid() sizes hexagons by cellsize[1], which was w / nx: a tall + # strip got hexagons as wide as the whole strip, 1734 of them against 89. + rect <- function(w, h) sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(0, 0), c(w, 0), c(w, h), c(0, h), c(0, 0)))), crs = 32632)) + hex_area <- function(g) max(as.numeric(sf::st_area(g))) # a whole hexagon + for (d in list(c(1000, 1, 9), c(3000, 1000, 100), c(5000, 700, 30))) { + flat <- create_grid_polygons(rect(d[1], d[2]), target_cells = d[3], type = "hex", + clip = FALSE) + tall <- create_grid_polygons(rect(d[2], d[1]), target_cells = d[3], type = "hex", + clip = FALSE) + expect_equal(hex_area(tall), hex_area(flat), tolerance = 1e-9, + info = paste(d, collapse = " x ")) + } + # The count follows (hexagons are not symmetric under a quarter turn, so + # not exactly): 89 and 103 for the strip. + flat <- nrow(create_grid_polygons(rect(1000, 1), target_cells = 9, type = "hex")) + tall <- nrow(create_grid_polygons(rect(1, 1000), target_cells = 9, type = "hex")) + expect_lt(max(flat, tall) / min(flat, tall), 1.3) + + # A boundary at least as wide as it is tall keeps the grid it had. + g <- create_grid_polygons(rect(3000, 1000), target_cells = 100, type = "hex") + eff <- 100 * sqrt(3) / 2 + expect_equal(hex_area(g), sqrt(3) / 2 * (3000 / round(sqrt(eff * 3)))^2, + tolerance = 1e-9) +}) + + +test_that("voronoi with expand > 0 returns the grown boundary its cells fill", { + sq <- .r2_sq(0, 0, 1000, crs = 32632) + set.seed(5) + p <- sf::st_as_sf(rbind(data.frame(x = stats::runif(30, 0, 1000), + y = stats::runif(30, 0, 1000)), + data.frame(x = c(-100, 1150), y = c(500, 500))), + coords = c("x", "y"), crs = 32632) + tess <- build_tessellation(p, boundary = sq, expand = 200, quiet = TRUE) + expect_false(anyNA(tess$index)) # the two outside points lie within 200 m + expect_equal(as.numeric(sum(sf::st_area(tess$boundary))), + as.numeric(sum(sf::st_area(tess$cells))), tolerance = 1e-6) + expect_gt(as.numeric(sum(sf::st_area(tess$boundary))), 1.5e6) + # expand = 0 is unchanged. + t0 <- build_tessellation(p, boundary = sq, quiet = TRUE) + expect_equal(as.numeric(sf::st_area(t0$boundary)), 1e6) +}) + + +test_that("collinear points are refused for triangles, not returned empty", { + col <- sf::st_as_sf(data.frame(x = 5e5 + 0:9 * 10, y = 5e6 + 0:9 * 5), + coords = c("x", "y"), crs = 32632) + expect_error(build_tessellation(col, method = "triangles", quiet = TRUE), + "collinear") + # Voronoi handles a transect. + v <- build_tessellation(col, method = "voronoi", quiet = TRUE) + expect_equal(nrow(v$cells), 10L) + # One point off the line is enough. + col2 <- col; sf::st_geometry(col2)[[5]] <- sf::st_point(c(5e5 + 40, 5e6 + 21)) + expect_gt(nrow(build_tessellation(col2, method = "triangles", quiet = TRUE)$cells), 0L) +}) + + +# --------------------------------------------------------------------------- +# Lattices from a profile's count +# --------------------------------------------------------------------------- + +test_that("a lattice sized by a selection reports and warns about empty cells", { + set.seed(21) + ctrs <- matrix(stats::runif(12, 1000, 9000), ncol = 2) + xy <- do.call(rbind, lapply(1:6, function(i) + cbind(stats::rnorm(100, ctrs[i, 1], 300), stats::rnorm(100, ctrs[i, 2], 300)))) + clustered <- sf::st_as_sf(data.frame(x = xy[, 1], y = xy[, 2]), + coords = c("x", "y"), crs = 32632) + sel <- structure(list(best = 56, criterion = "cp", edge = NA_character_), + class = "resolution_selection") + bnd <- clip_target_for(clustered, quiet = TRUE) + expect_warning( + tess <- build_tessellation(clustered, boundary = bnd, method = "hex", + approx_n_cells = sel, quiet = TRUE), + "of the .* cells hold a point") + expect_lt(tess$params$cells_occupied, 0.75 * 56) + expect_equal(tess$params$cells_occupied + tess$params$cells_empty, nrow(tess$cells)) + + # Evenly spread points fill the lattice: no warning. + set.seed(22) + even <- sf::st_as_sf(data.frame(x = stats::runif(600, 0, 10000), + y = stats::runif(600, 0, 10000)), + coords = c("x", "y"), crs = 32632) + expect_no_warning(t2 <- build_tessellation(even, boundary = clip_target_for(even, quiet = TRUE), + method = "hex", approx_n_cells = sel, + quiet = TRUE)) + expect_gte(t2$params$cells_occupied, 0.75 * 56) + # A plain number records occupancy but does not warn. + expect_no_warning(t3 <- build_tessellation(clustered, boundary = bnd, method = "hex", + approx_n_cells = 56, quiet = TRUE)) + expect_true(is.numeric(t3$params$cells_occupied)) +}) + + +# --------------------------------------------------------------------------- +# Seeding +# --------------------------------------------------------------------------- + +test_that("k-means seeding projects CRS-less lon/lat points like everything else", { + set.seed(11) + ll <- data.frame(x = stats::runif(800, 0, 1.6), y = stats::runif(800, 60, 61)) + p_na <- sf::st_as_sf(ll, coords = c("x", "y")) + p_ll <- sf::st_as_sf(ll, coords = c("x", "y"), crs = 4326) + ref <- sf::st_coordinates(voronoi_seeds_kmeans(p_ll, k = 2, set_seed = 1)) + + expect_warning(s_na <- voronoi_seeds_kmeans(p_na, k = 2, set_seed = 1), "EPSG:4326") + expect_true(is.na(sf::st_crs(s_na))) + expect_equal(unname(sf::st_coordinates(s_na)), unname(ref), tolerance = 1e-9) + + expect_warning(g_na <- get_voronoi_seeds(method = "kmeans", n = 2, sample_points = p_na, + set_seed = 1), "EPSG:4326") + expect_true(is.na(sf::st_crs(g_na))) + expect_equal(unname(sf::st_coordinates(g_na)), unname(ref), tolerance = 1e-9) +}) + + +test_that("voronoi_seeds_random() gives another seeding per call unless pinned", { + bnd <- .r2_sq(0, 0, 100, crs = 32632) + xy <- function(s) sf::st_coordinates(s) + set.seed(1); a <- voronoi_seeds_random(bnd, k = 5) + set.seed(2); b <- voronoi_seeds_random(bnd, k = 5) + set.seed(1); a2 <- voronoi_seeds_random(bnd, k = 5) + expect_false(identical(xy(a), xy(b))) + expect_identical(xy(a), xy(a2)) + expect_identical(xy(voronoi_seeds_random(bnd, k = 5, set_seed = 7)), + xy(voronoi_seeds_random(bnd, k = 5, set_seed = 7))) + expect_null(formals(voronoi_seeds_random)$set_seed) +}) + + +test_that("voronoi_seeds_kmeans() takes nstart", { + set.seed(4) + pts <- sf::st_as_sf(data.frame(x = stats::runif(200, 0, 1000), + y = stats::runif(200, 0, 1000)), + coords = c("x", "y"), crs = 32632) + expect_equal(nrow(voronoi_seeds_kmeans(pts, k = 6, nstart = 1)), 6L) + expect_equal(nrow(voronoi_seeds_kmeans(pts, k = 6, nstart = 25)), 6L) + expect_error(voronoi_seeds_kmeans(pts, k = 6, nstart = 0), "nstart") +}) + + +# --------------------------------------------------------------------------- +# harmonize_crs() +# --------------------------------------------------------------------------- + +test_that("harmonize_crs() takes a layer as target_crs", { + set.seed(1) + a <- sf::st_set_crs(.r2_pts_na(), 32632) + b <- sf::st_transform(a[1:5, ], 4326) + ref <- sf::st_transform(a[1:3, ], 3035) + for (tgt in list(ref, ref[1, ], sf::st_geometry(ref))) { + h <- harmonize_crs(a, b, target_crs = tgt) + expect_equal(sf::st_crs(h$a)$epsg, 3035L) + expect_equal(sf::st_crs(h$b)$epsg, 3035L) + } +}) diff --git a/tests/testthat/test-review3-S1-resolution.R b/tests/testthat/test-review3-S1-resolution.R new file mode 100644 index 0000000..4435275 --- /dev/null +++ b/tests/testthat/test-review3-S1-resolution.R @@ -0,0 +1,280 @@ +# tests/testthat/test-review3-S1-resolution.R +# --------------------------------------------------------------------------- +# Regressions from the third review of the resolution step: +# determine_optimal_levels(), resolution_profile() and their messages. +# --------------------------------------------------------------------------- + +# Every R warning an expression raises, muffled. +r3_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(c) { + w <<- c(w, conditionMessage(c)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + +# `reps` visits to each location in `xy` (metres, offset into UTM 32N). +r3_visits <- function(xy, reps, z = NULL) { + i <- rep(seq_len(nrow(xy)), each = reps) + d <- data.frame(x = 5e5 + xy[i, 1], y = 5e6 + xy[i, 2]) + if (!is.null(z)) d$z <- z + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + +r3_stations <- cbind(c(0, 1000, 5000, 9000, 9500), c(0, 8000, 2000, 500, 9000)) + +# A hand-made sac_range, so the variogram-based columns exist without gstat. +r3_sac <- function(range, nugget = 1, psill = 1, ...) { + vm <- data.frame(model = c("Nug", "Exp"), psill = c(nugget, psill), + range = c(0, if (is.finite(range)) range / 3 else 100), + stringsAsFactors = FALSE) + structure(range, class = c("sac_range", "numeric"), variogram_model = vm, + crs = sf::st_crs(32632), ...) +} + +r3_pts <- function(n = 200, seed = 1) { + set.seed(seed) + d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + d$z <- rnorm(n) + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + + +test_that("a WSS that falls to zero is the elbow when the rest has none", { + eb <- spatialkit:::.elbow_from_wss + # A curve like c / k to k = 4, then zero: one cell per location at k = 5. + w <- c(1000 / (1:4), 0) + out <- eb(w) + expect_true(out$structured) + expect_identical(out$knee_k, 5L) + # Zero is relative: k-means leaves floating-point residue where the exact + # value is 0, and the log of that dragged the line down as log(0) would. + expect_identical(eb(c(1000 / (1:4), 7.8e-17))$knee_k, 5L) + # Two levels are too few for a line, but not for a fall to zero. + two <- eb(c(10, 0)) + expect_true(two$structured) + expect_identical(two$knee_k, 2L) + # Without a zero nothing changes: two levels, no elbow, the midpoint. + expect_false(eb(c(5, 3))$structured) + expect_equal(eb(c(5, 3))$knee_k, 1) + # An elbow in the positive part keeps its place ahead of a later zero. + bent <- eb(c(1000, 400, 150, 60 * 4 / (4:12), 0)) + expect_true(bent$structured) + expect_identical(bent$knee_k, 4L) +}) + + +test_that("repeat visits to five stations give one cell per station", { + # Five stations visited thirty times each: the WSS reaches 0 at k = 5, and + # the level used to be dropped from the elbow, which then said "no cluster + # structure" and answered 3 (1 m of jitter answered 5). + pts <- r3_visits(r3_stations, 30) + out <- r3_warnings(determine_optimal_levels(pts, max_levels = 12)) + expect_identical(out$value[1L], 5L) + expect_false(any(grepl("no elbow", out$warnings))) + # The same with coordinates that are not whole metres. + frac <- r3_visits(r3_stations + 0.123456, 30) + expect_identical(suppressWarnings(determine_optimal_levels(frac, max_levels = 12))[1L], 5L) + # Two stations visited thirty times each: 2, not the 1 a two-level ladder gave. + expect_identical(suppressWarnings(determine_optimal_levels(r3_visits(r3_stations[1:2, ], 30)))[1L], + 2L) + # The profile's elbow column names the same count. + prof <- resolution_profile(pts, min_cell_n = 1, n_levels = 4, nstart = 3) + expect_identical(prof$levels, 2:5) + expect_true(is.finite(prof$elbow[prof$levels == 5L])) + expect_identical(select_resolution(prof, "elbow")$best, 5L) +}) + + +test_that("two clusters of repeat-visited stations keep their elbow at 2", { + # Twenty stations in two groups, ten visits each: the WSS at k = 20 is + # floating-point residue (7.8e-17), which used to drag the whole log-log + # line down and, at max_levels = 30, report no cluster structure. + set.seed(2) + st <- rbind(cbind(runif(10, 0, 500), runif(10, 0, 500)), + cbind(runif(10, 8000, 8500), runif(10, 8000, 8500))) + pts <- r3_visits(st, 10) + for (ml in c(12, 30)) { + out <- r3_warnings(determine_optimal_levels(pts, max_levels = ml)) + expect_identical(out$value[1L], 2L, info = ml) + expect_false(any(grepl("no elbow", out$warnings)), info = ml) + } +}) + + +test_that("the no-elbow warnings name the bound that ended the ladder", { + set.seed(1) + two <- sf::st_as_sf( + data.frame(x = 5e5 + c(runif(25, 0, 10), runif(25, 90, 100)), + y = 5e6 + c(runif(25, 0, 10), runif(25, 90, 100))), + coords = c("x", "y"), crs = 32632) + # A two-level ladder has no line to test: it used to be told it fell in a + # straight line "as it does for points with no cluster structure". + out <- r3_warnings(determine_optimal_levels(two, max_levels = 2)) + expect_true(any(grepl("too short to read an elbow.*raise max_levels", out$warnings))) + expect_false(any(grepl("no cluster structure", out$warnings))) + out <- r3_warnings(determine_optimal_levels(two, max_levels = 1)) + expect_true(any(grepl("max_levels = 1, raised to 2", out$warnings))) + # With three levels the elbow is there. + expect_length(r3_warnings(determine_optimal_levels(two, max_levels = 3))$warnings, 0L) + # A ladder ended by the points, not by max_levels, says so. + set.seed(5) + few <- sf::st_as_sf(data.frame(x = 5e5 + runif(12, 0, 1000), y = 5e6 + runif(12, 0, 1000)), + coords = c("x", "y"), crs = 32632) + out <- r3_warnings(determine_optimal_levels(few, max_levels = 40)) + expect_true(any(grepl("k = 1 to 11, one short of the 12 points", out$warnings))) + expect_false(any(grepl("max_levels\\)", out$warnings))) +}) + + +test_that("combined returns the geometric ranking when the elbow is below ten cells", { + # Six separated clusters: the elbow is 6, a count Moran's I cannot score + # (the nine-cell floor). Ranking the window anyway put the smallest count + # it scores, ten, first whatever the response did. + set.seed(3) + K <- 6; n <- 360 + cen <- cbind(c(0, 6000, 12000, 0, 6000, 12000), c(0, 0, 0, 7000, 7000, 7000)) + cl <- rep(seq_len(K), length.out = n) + d <- data.frame(x = 5e5 + cen[cl, 1] + rnorm(n, 0, 250), + y = 5e6 + cen[cl, 2] + rnorm(n, 0, 250), p = rnorm(n)) + d$z <- d$p + rnorm(n) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + geo <- determine_optimal_levels(pts, max_levels = 30) + expect_identical(geo[1L], 6L) + lines <- capture_spatialkit_log( + k <- suppressWarnings(determine_optimal_levels(pts, max_levels = 30, + response_var = "z", predictor_vars = "p"))) + dg <- attr(k, "diagnostics") + expect_identical(dg$knee_k, 6L) + expect_identical(as.integer(k), as.integer(geo)) + expect_identical(dg$criterion, "geometric") + expect_match(dg$fallback, "below the ten cells Moran's I needs") + expect_null(dg$combined_rank) + expect_true(log_has(lines, "the WSS elbow is at k = 6, below the ten cells")) +}) + + +test_that("combined ranks geometry on the log-log sag and unscored candidates last", { + # Twelve separated clusters: the elbow is 12, its window 8 to 16, and 8 + # and 9 sit below the nine-cell floor. The linear chord across the window + # used to rank a k next to the window's own middle first. + set.seed(1) + K <- 12; n <- 720 + cen <- cbind(rep(c(0, 6000, 12000, 18000), 3), rep(c(0, 7000, 14000), each = 4)) + cl <- rep(seq_len(K), length.out = n) + d <- data.frame(x = 5e5 + cen[cl, 1] + rnorm(n, 0, 250), + y = 5e6 + cen[cl, 2] + rnorm(n, 0, 250), p = rnorm(n)) + d$z <- d$p + rnorm(n) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + expect_identical(determine_optimal_levels(pts, max_levels = 30)[1L], 12L) + k <- suppressWarnings(determine_optimal_levels(pts, max_levels = 30, + response_var = "z", predictor_vars = "p")) + dg <- attr(k, "diagnostics") + expect_identical(dg$knee_k, 12L) + expect_identical(dg$criterion, "combined") + cr <- dg$combined_rank + ks <- as.integer(names(cr)) + scored <- is.finite(dg$moran_z[ks]) + expect_true(any(scored) && any(!scored)) + # Every unscored candidate takes the last place on the Moran axis, so a + # scored one comes first ... + expect_true(k[1L] %in% ks[scored]) + # ... and the unscored rank behind the elbow on the rank average. + expect_true(all(cr[!scored] > cr[ks == 12L])) +}) + + +test_that("combined on points with no elbow is ordered by Moran's z alone", { + set.seed(7) + n <- 800 + d <- data.frame(x = 5e5 + runif(n, 0, 1e4), y = 5e6 + runif(n, 0, 1e4), p = rnorm(n)) + d$z <- d$p + rnorm(n) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + k <- suppressWarnings(determine_optimal_levels(pts, max_levels = 40, + response_var = "z", predictor_vars = "p")) + dg <- attr(k, "diagnostics") + cr <- dg$combined_rank + ks <- as.integer(names(cr)) + scored <- is.finite(dg$moran_z[ks]) + expect_true(any(scored)) + # A flat geometric axis: every unscored candidate is tied ... + expect_length(unique(cr[!scored]), 1L) + # ... behind every scored one, which come in order of |z|. + expect_true(max(cr[scored]) < min(cr[!scored])) + sk <- ks[scored] + expect_identical(k[seq_along(sk)], sk[order(abs(dg$moran_z[sk]))]) + # Ties go to the candidates nearest the elbow the window was drawn around. + expect_identical(k[length(sk) + 1L], dg$knee_k) +}) + + +test_that("resolution_profile() drops points with no coordinates with an R warning", { + pts <- r3_pts(60) + holed <- rbind(pts[1:10, ], sf::st_sf(z = 0, geometry = sf::st_sfc(sf::st_point(), crs = 32632)), + pts[11:60, ]) + out <- r3_warnings(resolution_profile(holed, n_levels = 3, nstart = 2)) + expect_true(any(grepl("resolution_profile\\(\\): dropping 1 point", out$warnings))) + expect_identical(attr(out$value, "bounds")$n, 60L) +}) + + +test_that("a range below the shortest lag gives cp and reliability nothing", { + # That refusal means the structure cannot be told from a nugget, so the + # nugget is not identified either; on white noise detrended by REML it was + # 6e-7 on a sill of 0.99 and Cp ran to the support ceiling. + pts <- r3_pts(200) + rej <- r3_sac(NA_real_, nugget = 6e-7, psill = 0.99) + attr(rej, "rejected_reason") <- "fitted range is below the shortest lag fitted" + out <- r3_warnings(resolution_profile(pts, "z", sac = rej, n_levels = 4, nstart = 2)) + expect_true(any(grepl("below the shortest lag fitted.*not identified", out$warnings))) + expect_true(all(is.na(out$value$cp)) && all(is.na(out$value$reliability))) + expect_null(attr(out$value, "variogram")) + # The other refusals keep their rule: a range past the lags still gives Cp + # its nugget. + attr(rej, "rejected_reason") <- "fitted range exceeds the largest lag fitted" + attr(rej, "variogram_model")$psill[1] <- 0.5 + out <- r3_warnings(resolution_profile(pts, "z", sac = rej, n_levels = 4, nstart = 2)) + expect_true(all(is.finite(out$value$cp))) +}) + + +test_that("a nugget next to zero is warned about like a nugget of zero", { + pts <- r3_pts(200) + out <- r3_warnings(resolution_profile(pts, "z", sac = r3_sac(300, nugget = 6e-7, psill = 0.99), + n_levels = 4, nstart = 2)) + expect_true(any(grepl("nugget is 0 \\(6e-07 against a sill of 0.99\\)", out$warnings))) + # A nugget that is a real share of the sill raises nothing. + expect_length(r3_warnings(resolution_profile(pts, "z", sac = r3_sac(300, nugget = 0.01), + n_levels = 4, nstart = 2))$warnings, 0L) +}) + + +test_that("warnings about the variogram estimated here do not blame a `sac` argument", { + skip_if_not_installed("gstat") + pts <- r3_pts(200) + rej <- r3_sac(NA_real_, nugget = 0.5) + attr(rej, "rejected_reason") <- "fitted range exceeds the largest lag fitted" + local_mocked_bindings(estimate_sac_range = function(...) rej) + out <- r3_warnings(resolution_profile(pts, "z", n_levels = 4, nstart = 2)) + expect_true(any(grepl("the variogram estimated from `response_var`", out$warnings, + fixed = TRUE))) + expect_false(any(grepl("`sac` reports", out$warnings, fixed = TRUE))) + # A supplied one is still called `sac`. + out <- r3_warnings(resolution_profile(pts, "z", sac = rej, n_levels = 4, nstart = 2)) + expect_true(any(grepl("`sac` reports no usable range", out$warnings, fixed = TRUE))) +}) + + +test_that("a ceiling one short of the points is not credited to the distinct locations", { + pts <- r3_pts(30) + prof <- resolution_profile(pts, min_cell_n = 1, n_levels = 4, nstart = 2) + b <- attr(prof, "bounds") + expect_identical(b$ceiling, 29L) + expect_output(print(prof), "ceiling 29, one short of the 30 points") + expect_match(spatialkit:::.ladder_edge(29L, prof$levels, prof$levels, b), + "one short of the points") + # With repeat visits the distinct locations do bind, and say so. + rep5 <- resolution_profile(r3_visits(r3_stations, 30), min_cell_n = 1, n_levels = 4, + nstart = 2) + expect_output(print(rep5), "ceiling 5 from 5 distinct locations") +}) diff --git a/tests/testthat/test-review3-S2-tessellation.R b/tests/testthat/test-review3-S2-tessellation.R new file mode 100644 index 0000000..617ef23 --- /dev/null +++ b/tests/testthat/test-review3-S2-tessellation.R @@ -0,0 +1,329 @@ +# tests/testthat/test-review3-S2-tessellation.R +# --------------------------------------------------------------------------- +# Regressions from the third review of tessellation, CRS selection and +# seeding. Each test names the finding it closes and says what used to go +# wrong. +# --------------------------------------------------------------------------- + +.r3s2_box <- function(x0, x1, y0, y1, crs = sf::NA_crs_) { + sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(rbind( + c(x0, y0), c(x1, y0), c(x1, y1), c(x0, y1), c(x0, y0)))), crs = crs)) +} + +.r3s2_pts <- function(n, x0, x1, y0, y1, crs = sf::NA_crs_, seed = 1) { + set.seed(seed) + sf::st_as_sf(data.frame(x = stats::runif(n, x0, x1), y = stats::runif(n, y0, y1)), + coords = c("x", "y"), crs = crs) +} + +.r3s2_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-1: hex/square lattices over lon/lat data +# --------------------------------------------------------------------------- + +test_that("build_tessellation() lays a near-global lattice in the CRS create_grid_polygons() picks", { + # A near-global boundary: the distance CRS for the points is Web Mercator, + # whose full hexagons differed 5.75-fold in true area, while + # create_grid_polygons() on the same boundary used Equal Earth. (Vertices + # every 5 degrees, so the outline does not read as a band across 180.) + lon <- seq(-170, 170, by = 5); lat <- seq(-60, 70, by = 5) + ring <- rbind(cbind(lon, -60), cbind(170, lat[-1]), cbind(rev(lon)[-1], 70), + cbind(-170, rev(lat)[-1])) + bnd <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(ring)), crs = 4326)) + pts <- .r3s2_pts(80, -165, 165, -55, 65, crs = 4326, seed = 3) + ref <- create_grid_polygons(bnd, target_cells = 60, type = "hex", quiet = TRUE) + expect_match(sf::st_crs(ref)$proj4string, "eqearth") + for (m in c("hex", "square")) { + tb <- build_tessellation(pts, bnd, method = m, approx_n_cells = 60, quiet = TRUE) + expect_equal(sf::st_crs(tb$cells), sf::st_crs(ref), info = m) + expect_equal(sf::st_crs(tb$boundary), sf::st_crs(ref), info = m) + expect_false(anyNA(tb$index), info = m) + } + # The same grid as create_grid_polygons() lays. + th <- build_tessellation(pts, bnd, method = "hex", approx_n_cells = 60, quiet = TRUE) + expect_equal(nrow(th$cells), nrow(ref)) + # Returned in lon/lat on request, and still laid equal-area. + tg <- build_tessellation(pts, bnd, method = "hex", approx_n_cells = 60, + crs = 4326, quiet = TRUE) + expect_equal(sf::st_crs(tg$cells), sf::st_crs(4326)) + expect_equal(nrow(tg$cells), nrow(ref)) + expect_false(anyNA(tg$index)) + + # A local extent keeps the points' UTM zone. + loc <- build_tessellation(.r3s2_pts(40, 9.1, 9.9, 47.1, 47.9, crs = 4326), + .r3s2_box(9, 10, 47, 48, crs = 4326), method = "hex", + approx_n_cells = 20, quiet = TRUE) + expect_equal(sf::st_crs(loc$cells)$epsg, 32632L) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-2: an EMPTY point with method = "triangles" +# --------------------------------------------------------------------------- + +test_that("an empty point is indexed NA by the triangulation, not an abort", { + set.seed(7) + g <- sf::st_sfc(c(lapply(1:20, function(i) + sf::st_point(c(5e5 + stats::runif(1, 0, 1000), 5e6 + stats::runif(1, 0, 1000)))), + list(sf::st_point())), crs = 32632) + pts <- sf::st_sf(id = 1:21, geometry = g) + bnd <- .r3s2_box(5e5, 5e5 + 1000, 5e6, 5e6 + 1000, crs = 32632) + # Stopped with "NA/NaN/Inf in foreign function call (arg 1)". + for (b in list(bnd, NULL)) { + tri <- build_tessellation(pts, b, method = "triangles", quiet = TRUE) + expect_gt(nrow(tri$cells), 0L) + expect_length(tri$index, 21L) + expect_true(is.na(tri$index[21])) + expect_false(anyNA(tri$index[1:20])) + } + # Two real points and an empty one are still too few. + expect_error(build_tessellation(pts[c(1, 2, 21), ], method = "triangles", quiet = TRUE), + "at least 3 unique points") +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-3: near-degenerate extents and the max_cells message +# --------------------------------------------------------------------------- + +test_that("clip_target_for() buffers a transect with sub-millimetre scatter", { + set.seed(2) + p <- sf::st_as_sf(data.frame(x = seq(0, 1000, length.out = 30), + y = stats::runif(30, 0, 1e-6)), + coords = c("x", "y"), crs = 32632) + ct <- clip_target_for(p, quiet = TRUE) + bb <- sf::st_bbox(ct) + # Was a 1000 x 9e-7 sliver, over which a count of 25 built 166,536 squares. + expect_gt(as.numeric(bb["ymax"] - bb["ymin"]), 1) + sq <- build_tessellation(p, ct, method = "square", approx_n_cells = 25, quiet = TRUE) + expect_lt(nrow(sq$cells), 100L) +}) + +test_that("the max_cells error names the argument that set the cell size", { + sliver <- .r3s2_box(0, 1000, 0, 1.8e-8, crs = 32632) + e <- tryCatch(create_grid_polygons(sliver, target_cells = 25, quiet = TRUE), + error = conditionMessage) + expect_match(e, "max_cells") + expect_match(e, "`target_cells` = 25", fixed = TRUE) + expect_no_match(e, "Check that `cellsize`", fixed = TRUE) + sq <- .r3s2_box(0, 1000, 0, 1000, crs = 32632) + expect_error(create_grid_polygons(sq, n = 2000, quiet = TRUE), "derived from `n` = 2000 x 2000") + expect_error(create_grid_polygons(sq, cellsize = 0.5, quiet = TRUE), + "Check that `cellsize` is in the boundary's CRS units") +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-4 / -14: a CRS-less boundary with lon/lat points +# --------------------------------------------------------------------------- + +test_that("a CRS-less degree tile is read in the lon/lat points' CRS, not the projected one", { + pts <- .r3s2_pts(50, 10.1, 10.9, 50.1, 50.9, crs = 4326, seed = 8) + tile <- .r3s2_box(10, 11, 50, 51) # integer corners: the heuristic declines it + expect_false(.looks_like_lonlat(tile)$lonlat) + # It was stamped with the UTM zone picked for the points: a one-metre square, + # every point indexed NA. + for (m in c("voronoi", "hex")) { + w <- .r3s2_warnings(build_tessellation(pts, tile, method = m, quiet = TRUE, + approx_n_cells = if (m == "hex") 20)) + expect_true(any(grepl("look like lon/lat", w$warnings)), info = m) + expect_false(anyNA(w$value$index), info = m) + expect_false(sf::st_is_longlat(w$value$cells), info = m) + } + v <- suppressWarnings(create_voronoi_polygons(pts, tile, quiet = TRUE)) + expect_false(anyNA(v$index)) + tgt <- suppressWarnings(clip_target_for(pts, tile, quiet = TRUE)) + expect_true(all(lengths(sf::st_intersects(sf::st_transform(pts, sf::st_crs(tgt)), tgt)) > 0)) +}) + +test_that("a CRS-less boundary in metres with lon/lat points is refused, naming both", { + pts <- .r3s2_pts(30, -1.9, -1.1, 52.1, 52.9, crs = 4326) + bng <- sf::st_set_crs(sf::st_transform(.r3s2_box(-2, -1, 52, 53, crs = 4326), 27700), NA) + for (m in c("voronoi", "hex")) + expect_error(build_tessellation(pts, bng, method = m, quiet = TRUE, + approx_n_cells = if (m == "hex") 20), + "cannot be placed in one space", info = m) + expect_error(create_voronoi_polygons(pts, bng, quiet = TRUE), "cannot be placed in one space") + expect_error(clip_target_for(pts, bng, quiet = TRUE), "cannot be placed in one space") +}) + +test_that("CRS-less lon/lat points with a CRS-less boundary in metres are refused (S2-14)", { + pts <- .r3s2_pts(60, 12.2, 13.8, 54.2, 55.8, seed = 5) + bnd <- sf::st_set_crs(sf::st_transform(.r3s2_box(12, 14, 54, 56, crs = 4326), 32633), NA) + # Was stamped EPSG:4326, transformed to nothing, and refused as "not polygonal". + for (m in c("voronoi", "hex")) + expect_error(suppressWarnings(build_tessellation(pts, bnd, method = m, quiet = TRUE, + approx_n_cells = if (m == "hex") 20)), + "has no CRS either and was taken as lon/lat", info = m) + # A CRS-less lon/lat boundary still takes the same assumption. + ok <- suppressWarnings(build_tessellation(pts, .r3s2_box(12, 14, 54, 56), + method = "voronoi", quiet = TRUE)) + expect_equal(sf::st_crs(ok$cells)$epsg, 32633L) + expect_false(anyNA(ok$index)) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-5: create_voronoi_polygons() and CRS-less degrees +# --------------------------------------------------------------------------- + +test_that("create_voronoi_polygons() applies the lon/lat heuristic to CRS-less points", { + pts <- .r3s2_pts(60, 12.2, 13.8, 54.2, 55.8, seed = 5) + # Built silently in degrees before, with CRS NA. + expect_warning(v <- create_voronoi_polygons(pts, quiet = TRUE), "assuming EPSG:4326") + bt <- suppressWarnings(build_tessellation(pts, method = "voronoi", quiet = TRUE)) + expect_equal(sf::st_crs(v$cells), sf::st_crs(bt$cells)) + expect_false(sf::st_is_longlat(v$cells)) + expect_identical(v$index, bt$index) + # And with a CRS-less boundary, the same result as build_tessellation(). + bnd <- .r3s2_box(12, 14, 54, 56) + v2 <- suppressWarnings(create_voronoi_polygons(pts, bnd, quiet = TRUE)) + b2 <- suppressWarnings(build_tessellation(pts, bnd, method = "voronoi", quiet = TRUE)) + expect_equal(sf::st_crs(v2$cells), sf::st_crs(b2$cells)) + expect_identical(v2$index, b2$index) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-7: triangles returned in a geographic crs +# --------------------------------------------------------------------------- + +test_that("every point lies in its indexed triangle on the returned lon/lat layer", { + pts <- .r3s2_pts(80, 9, 11, 54, 56, crs = 4326, seed = 4) + res <- build_tessellation(pts, method = "triangles", crs = 4326, quiet = TRUE) + expect_equal(sf::st_crs(res$cells), sf::st_crs(4326)) + hit <- sf::st_intersects(pts, res$cells) + expect_true(all(lengths(hit) > 0)) + expect_true(all(mapply(function(h, id) id %in% res$cells$cell_id[h], hit, res$index))) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-8 / -9: scoring a projection on an outline +# --------------------------------------------------------------------------- + +test_that("a detailed outline is scored on a bounded sample", { + n <- 1e5 + th <- seq(0, 2 * pi, length.out = n) + ring <- cbind(10 + 8 * cos(th), 50 + 3 * sin(th)); ring[n, ] <- ring[1, ] + poly <- sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(ring)), crs = 4326)) + e <- .crs_distance_error(poly, sf::st_crs(32632)) + expect_true(is.finite(e)) + expect_lt(e, 0.05) +}) + +test_that("an outline across the antimeridian is measured along its own edges", { + fiji <- .r3s2_box(177, -178, -19, -15, crs = 4326) + ch <- attr(ensure_projected(fiji), "crs_choice") + # Reported 164%: the 177 -> -178 edge was filled with points near 0E. + expect_lt(ch$distance_error[ch$chosen], 0.01) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-11: the projection message names the CRS +# --------------------------------------------------------------------------- + +test_that("build_tessellation() names the CRS it projects to", { + pts <- .r3s2_pts(20, 9.1, 9.9, 47.1, 47.9, crs = 4326) + msgs <- testthat::capture_messages(build_tessellation(pts, method = "voronoi")) + expect_true(any(grepl("projecting points to EPSG:32632", msgs, fixed = TRUE))) + expect_false(any(grepl("local UTM CRS", msgs, fixed = TRUE))) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-13: an sf layer as `crs` +# --------------------------------------------------------------------------- + +test_that("the builders take a layer's CRS as `crs`", { + pts <- .r3s2_pts(30, 9, 10, 50, 51, crs = 4326, seed = 10) + ref <- sf::st_transform(pts, 32632) + # Stopped with "the condition has length > 1". + a <- build_tessellation(pts, method = "voronoi", crs = ref, quiet = TRUE) + b <- build_tessellation(pts, method = "voronoi", crs = 32632, quiet = TRUE) + expect_identical(a$index, b$index) + expect_equal(sf::st_crs(a$cells), sf::st_crs(32632)) + v <- create_voronoi_polygons(pts, crs = sf::st_geometry(ref), quiet = TRUE) + expect_equal(sf::st_crs(v$cells), sf::st_crs(32632)) + box <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(ref))) + g <- create_grid_polygons(box, target_cells = 9, crs = ref[1, ], quiet = TRUE) + expect_equal(sf::st_crs(g), sf::st_crs(32632)) +}) + + +# --------------------------------------------------------------------------- +# S2-TESSELLATION-15: lon/lat seeding without lwgeom +# --------------------------------------------------------------------------- + +test_that("random and k-means seeding on a lon/lat boundary raise no lwgeom warning", { + # Looked up with system.file() rather than requireNamespace(), which R CMD + # check counts as a use of a package DESCRIPTION would have to declare. + skip_if(nzchar(system.file(package = "lwgeom")), + "with lwgeom installed sf does not warn") + bnd <- .r3s2_box(9, 11, 54, 56, crs = 4326) + for (s2 in c(TRUE, FALSE)) { + was <- suppressMessages(sf::sf_use_s2(s2)) + expect_no_warning(r <- voronoi_seeds_random(bnd, 5, set_seed = 1)) + expect_no_warning(k <- get_voronoi_seeds(bnd, method = "kmeans", n = 5, set_seed = 1)) + # With s2 off sf also printed its planar-union message. + expect_no_message(get_voronoi_seeds(bnd, method = "random", n = 5, set_seed = 1)) + suppressMessages(sf::sf_use_s2(was)) + expect_equal(nrow(r), 5L) + expect_equal(nrow(k), 5L) + } +}) + + +# --------------------------------------------------------------------------- +# S11-contracts-13 / -17 / -18 +# --------------------------------------------------------------------------- + +test_that("build_tessellation() says how to proceed with polygon features", { + nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)[1:5, ] + e <- tryCatch(build_tessellation(nc, method = "voronoi", quiet = TRUE), + error = conditionMessage) + expect_match(e, "geometry must be one of: POINT, MULTIPOINT", fixed = TRUE) + expect_match(e, "coerce_to_points(points_sf, \"auto\")", fixed = TRUE) +}) + +test_that("a whole build_tessellation() result is named where a polygon layer is expected", { + pts <- .r3s2_pts(20, 5e5, 5e5 + 100, 5e6, 5e6 + 100, crs = 32632) + tess <- build_tessellation(pts, method = "voronoi", quiet = TRUE) + hint <- "this looks like a build_tessellation() result" + # These stopped with sf's "no applicable method for 'st_crs<-' applied to + # an object of class \"list\"" after a warning about stamping a CRS. + for (f in list(function() build_tessellation(pts, tess, method = "voronoi", quiet = TRUE), + function() create_voronoi_polygons(pts, tess, quiet = TRUE), + function() clip_target_for(pts, tess, quiet = TRUE))) { + w <- character(0) + e <- tryCatch(withCallingHandlers(f(), warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }), error = conditionMessage) + expect_match(e, hint, fixed = TRUE) + expect_match(e, "`$boundary`", fixed = TRUE) + expect_length(w, 0L) + } + expect_error(create_grid_polygons(tess, target_cells = 9, quiet = TRUE), hint, fixed = TRUE) + expect_error(create_grid_polygons_cached(tess, target_cells = 9, cache_env = new.env()), + hint, fixed = TRUE) + expect_error(ensure_stable_poly_id(tess), "pass its `$cells`", fixed = TRUE) +}) + +test_that("triangles do not record the approx_n_cells they ignored", { + skip_if_not_installed("geometry") + pts <- .r3s2_pts(20, 0, 1, 0, 1, crs = 32632) + w <- .r3s2_warnings(build_tessellation(pts, method = "triangles", + approx_n_cells = 20, quiet = TRUE)) + expect_null(w$value$params$approx_n_cells) + expect_null(w$value$params$approx_n_cells_from) + expect_true(any(grepl("`params` does not record the request", w$warnings, fixed = TRUE))) +}) diff --git a/tests/testthat/test-review3-S3-assignment.R b/tests/testthat/test-review3-S3-assignment.R new file mode 100644 index 0000000..ee37849 --- /dev/null +++ b/tests/testthat/test-review3-S3-assignment.R @@ -0,0 +1,345 @@ +# =========================================================================== +# Regressions from the third review of assignment and aggregation +# (assign_features_to_polygons(), summarize_by_cell(), the row records and +# the knitr echo of the log). Every test here failed on the code before the +# fix it names. +# =========================================================================== + +# Every R warning (message and class) and R message `expr` raises, with its +# value. The console echo written to stderr is swallowed. +.r3_conditions <- function(expr) { + w_msg <- character(0); w_cls <- list(); n_msg <- 0L + utils::capture.output( + val <- withCallingHandlers(expr, + warning = function(w) { + w_msg <<- c(w_msg, conditionMessage(w)) + w_cls <<- c(w_cls, list(class(w))) + invokeRestart("muffleWarning") + }, + message = function(m) { + n_msg <<- n_msg + 1L + invokeRestart("muffleMessage") + }), + type = "message") + list(value = val, warnings = w_msg, classes = w_cls, messages = n_msg) +} + +.r3_is_fallback <- function(res) + vapply(res$classes, function(k) "spatialkit_deff_fallback" %in% k, logical(1)) + +.r3_sq <- function(x0, y0, s) { + sf::st_polygon(list(rbind(c(x0, y0), c(x0 + s, y0), c(x0 + s, y0 + s), + c(x0, y0 + s), c(x0, y0)))) +} + +# A 3 x 3 grid of 100 m cells, numbered from the lower left a row at a time. +.r3_grid <- function() { + sf::st_sf(poly_id = 1:9, + geometry = sf::st_sfc(lapply(0:8, function(k) + .r3_sq(5e5 + (k %% 3) * 100, 5e6 + (k %/% 3) * 100, 100)), + crs = 32632)) +} + +# Six cells of 25 points on a correlated Gaussian field. +.r3_field <- function() { + set.seed(77) + n <- 150 + x <- rep(seq(0, 500, length.out = 6), each = 25) + runif(n, 0, 60) + y <- runif(n, 0, 60) + z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(cbind(x, y))) / 40) + + diag(1e-6, n))) %*% rnorm(n)) + sf::st_as_sf(data.frame(x = x, y = y, z = z, w = z + rnorm(n), + poly_id = rep(1:6, each = 25)), + coords = c("x", "y"), crs = 32632) +} + +.r3_sac <- function(model = data.frame(model = c("Nug", "Exp"), + psill = c(0.2, 0.8), range = c(0, 40)), + ...) { + structure(120, class = c("sac_range", "numeric"), variogram_model = model, + crs = sf::st_crs(32632), ...) +} + +.r3_rejected <- function(reason = "fitted range exceeds the largest lag fitted") { + structure(NA_real_, class = c("sac_range", "numeric"), + rejected_reason = reason, + variogram_model = data.frame(model = "Exp", psill = 1, range = 1e6), + crs = sf::st_crs(32632)) +} + + +# --- summarize_by_cell(): a rejected `sac` ----------------------------------- + +test_that("a rejected sac replaced by an estimate is not reported as a fallback", { + skip_if_not_installed("gstat") + pts <- .r3_field() + # The internal estimate succeeds. The rejected sac used to raise the + # classed fallback warning ("Falling back to deff = 1") although the + # estimate was then applied. + local_mocked_bindings(estimate_sac_range = function(...) .r3_sac()) + res <- .r3_conditions(summarize_by_cell(pts, "z", deff = "variogram", + sac = .r3_rejected())) + expect_false(any(.r3_is_fallback(res))) + expect_length(res$warnings, 1L) + expect_match(res$warnings, "no usable range \\(fitted range exceeds") + expect_match(res$warnings, "estimated from `response_var` instead") + expect_true(all(res$value$deff_applied)) + expect_identical(attr(res$value, "deff_applied")$method, "variogram") + # tryCatch() on the class no longer throws the corrected result away. + kept <- suppressWarnings(tryCatch( + summarize_by_cell(pts, "z", deff = "variogram", sac = .r3_rejected()), + spatialkit_deff_fallback = function(w) "caught")) + expect_s3_class(kept, "data.frame") +}) + +test_that("a rejected sac that cannot be replaced gives one fallback warning naming both reasons", { + skip_if_not_installed("gstat") + pts <- .r3_field() + local_mocked_bindings(estimate_sac_range = function(...) + .r3_rejected("variogram model did not converge")) + res <- .r3_conditions(summarize_by_cell(pts, "z", deff = "variogram", + sac = .r3_rejected())) + expect_length(res$warnings, 1L) + expect_true(.r3_is_fallback(res)) + expect_match(res$warnings, "supplied `sac` reports no usable range \\(fitted range exceeds") + expect_match(res$warnings, "estimated from `response_var` reports no usable range \\(variogram model did not converge") + expect_false(any(res$value$deff_applied)) + + # No response to estimate from: the rejection is still named. + res2 <- .r3_conditions(summarize_by_cell(pts, predictor_vars = "z", + deff = "variogram", + sac = .r3_rejected())) + expect_length(res2$warnings, 1L) + expect_true(.r3_is_fallback(res2)) + expect_match(res2$warnings, "fitted range exceeds.*no `response_var`") +}) + + +# --- summarize_by_cell(): a detrended `sac` ---------------------------------- + +test_that("a residual (detrended) sac correcting response SEs is warned about", { + pts <- .r3_field() + res <- .r3_sac(detrended = TRUE, detrend_method = "ols") + # Used as given, as documented, but no longer in silence. + expect_warning(out <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = res), + "residuals on predictors \\(detrend = \"ols\"\\).*understated") + expect_true(all(out$deff_applied)) + quiet <- summarize_by_cell(pts, "z", "w", deff = "variogram", sac = .r3_sac()) + expect_equal(out[["..se_resp_z"]], quiet[["..se_resp_z"]]) + # Nothing to warn about without response columns, or with a response variogram. + expect_no_warning(summarize_by_cell(pts, predictor_vars = "w", deff = "variogram", + sac = res)) + expect_no_warning(summarize_by_cell(pts, "z", deff = "variogram", + sac = .r3_sac(detrended = FALSE))) +}) + + +# --- summarize_by_cell(): the design-effect record --------------------------- + +test_that("deff = 'kish' records a correction made to the predictor SEs only", { + set.seed(5) + n <- 400 + pts <- sf::st_as_sf(data.frame(x = runif(n, 0, 200), y = runif(n, 0, 200)), + coords = c("x", "y"), crs = 32632) + xy <- sf::st_coordinates(pts) + pts$poly_id <- 1L + (xy[, 1] %/% 50) + 4L * (xy[, 2] %/% 50) + pts$v <- rnorm(n) # response: unclustered + pts$p <- rnorm(16, sd = 2)[pts$poly_id] + rnorm(n) # predictor: clustered + naive <- summarize_by_cell(pts, "v", "p") + k <- summarize_by_cell(pts, "v", "p", deff = "kish") + expect_identical(attr(k, "icc")$resp, 0) + expect_gt(attr(k, "icc")$pred, 0.5) + # The predictor SEs were inflated about elevenfold; the rows used to say + # deff_applied = FALSE, with no attribute. + expect_gt(stats::median(k$..se_pred_p / naive$..se_pred_p), 5) + expect_true(all(k$deff_applied)) + rec <- attr(k, "deff_applied") + expect_identical(rec$method, "kish") + expect_gt(rec$icc_pred, 0.5) + # `deff` and cell_weight belong to the primary variable, the response. + expect_equal(rec$deff, rep(1, nrow(k))) + expect_equal(k$cell_weight, k$n) +}) + +test_that("a pure-nugget variogram is applied as deff = 1, not reported as a fallback", { + pts <- .r3_field() + nug <- .r3_sac(model = data.frame(model = "Nug", psill = 1, range = 0)) + expect_no_warning(out <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug)) + naive <- summarize_by_cell(pts, "z") + expect_true(all(out$deff_applied)) + expect_equal(out[["..se_resp_z"]], naive[["..se_resp_z"]]) + expect_equal(attr(out, "deff_applied")$rbar, rep(0, nrow(out))) + # So is a structured component with no sill. + nug2 <- .r3_sac(model = data.frame(model = c("Nug", "Exp"), psill = c(1, 0), + range = c(0, 40))) + expect_no_warning(out2 <- summarize_by_cell(pts, "z", deff = "variogram", sac = nug2)) + expect_true(all(out2$deff_applied)) +}) + +test_that("deff_max_n must be a number of at least 2 for deff = 'variogram'", { + pts <- .r3_field() + for (bad in list(1L, 0L, NA, c(10, 20))) { + # 1 and 0 returned uncorrected SEs marked deff_applied = TRUE; NA stopped + # with "missing value where TRUE/FALSE needed". + expect_error(summarize_by_cell(pts, "z", deff = "variogram", sac = .r3_sac(), + deff_max_n = bad), + "`deff_max_n` must be") + } + # Unused, so unchecked, by every other deff. + expect_no_error(summarize_by_cell(pts, "z", deff = "kish", deff_max_n = 0)) +}) + +test_that("the rows with no cell ID get a cell_weight like any other group", { + set.seed(4) + pts <- sf::st_as_sf(data.frame(x = 5e5 + runif(40, -100, 300), + y = 5e6 + runif(40, 0, 300), v = rnorm(40)), + coords = c("x", "y"), crs = 32632) + a <- assign_features_to_polygons(pts, .r3_grid(), keep_unassigned = TRUE) + s <- summarize_by_cell(a, "v") + na_row <- which(is.na(s$poly_id)) + expect_length(na_row, 1L) + expect_gt(s$n[na_row], 0) + # It was 0 beside n = 5 and a finite SE. + expect_equal(s$cell_weight, s$n) +}) + +test_that("a fixed deff stays a scalar on the record when one cell is summarised", { + pts <- sf::st_as_sf(data.frame(x = 5e5 + c(10, 20, 30), y = 5e6 + c(10, 20, 30), + v = c(1, 2, 4)), + coords = c("x", "y"), crs = 32632) + grid <- .r3_grid() + out <- summarize_by_cell(assign_features_to_polygons(pts, grid), "v", + cells_sf = grid, deff = 2) + # It came back as c(2, NA, NA, ...). + expect_identical(attr(out, "deff_applied"), list(method = "fixed", deff = 2)) +}) + +test_that("agg_funs = pkg::fn is named after the function", { + pts <- .r3_field() + out <- summarize_by_cell(pts, "z", agg_funs = stats::median) + expect_true("resp_median_z" %in% names(out)) + expect_false("resp_agg1_z" %in% names(out)) +}) + + +# --- assign_features_to_polygons() ------------------------------------------ + +test_that("the features' own column named like the polygons' fallback ID column is kept", { + cells <- .r3_grid() + names(cells)[names(cells) == "poly_id"] <- "id" + pts <- sf::st_as_sf(data.frame(id = c("site-A", "site-B", "site-C"), + x = 5e5 + c(10, 150, 250), y = 5e6 + c(10, 150, 250), + v = 1:3), + coords = c("x", "y"), crs = 32632) + # The site IDs were dropped, with a warning about a collision that the + # result never had. + expect_no_warning(a <- assign_features_to_polygons(pts, cells)) + expect_identical(a$id, c("site-A", "site-B", "site-C")) + expect_identical(a$poly_id, c(1L, 5L, 9L)) + # A column named `polygon_id_col` is still replaced, with the warning. + expect_warning(b <- assign_features_to_polygons(a, cells), "'poly_id'") + expect_identical(b$id, a$id) + expect_identical(b$poly_id, a$poly_id) +}) + +test_that("an exact tie in overlap area does not depend on the polygon row order", { + grid <- .r3_grid() + # A 40 m square split evenly across the edge of cells 1 and 2, and a 20 m + # square split evenly among cells 1, 2, 4 and 5. + f <- sf::st_sf(fid = 1:3, geometry = sf::st_sfc( + .r3_sq(5e5 + 80, 5e6 + 10, 40), .r3_sq(5e5 + 130, 5e6 + 130, 60), + .r3_sq(5e5 + 90, 5e6 + 90, 20), crs = 32632)) + fwd <- assign_features_to_polygons(f, grid) + rev <- assign_features_to_polygons(f, grid[9:1, ]) + # Reversed rows used to give cells 2 and 5, and ties$n was 0. + expect_identical(fwd$poly_id, c(1L, 5L, 1L)) + expect_identical(rev$poly_id, fwd$poly_id) + expect_identical(attr(fwd, "ties")$n, 2L) + expect_identical(attr(fwd, "ties")$which, c(1L, 3L)) + expect_identical(attr(rev, "ties")$which, c(1L, 3L)) + # "first" keeps the polygon row order, as documented, and still counts. + first <- assign_features_to_polygons(f, grid[9:1, ], tie_break = "first") + expect_identical(first$poly_id, c(2L, 5L, 5L)) + expect_identical(attr(first, "ties")$n, 2L) +}) + +test_that("a largest-overlap assignment does not leak sf's attribute warning", { + grid <- .r3_grid() + f <- sf::st_sf(fid = 1:2, geometry = sf::st_sfc( + .r3_sq(5e5 + 10, 5e6 + 10, 30), .r3_sq(5e5 + 130, 5e6 + 130, 60), crs = 32632)) + # "attribute variables are assumed to be spatially constant throughout all + # geometries" came with every call. + expect_no_warning(a <- assign_features_to_polygons(f, grid)) + expect_identical(a$poly_id, c(1L, 5L)) +}) + + +# --- the row records --------------------------------------------------------- + +test_that("dplyr's row verbs drop a row record as `[` does", { + grid <- .r3_grid() + e <- sf::st_as_sf(data.frame(x = 5e5 + c(100, 20, 200, 60, 150), + y = 5e6 + c(50, 20, 150, 60, 200), v = 1:5), + coords = c("x", "y"), crs = 32632) + a <- assign_features_to_polygons(e, grid) + expect_identical(attr(a, "ties")$n_rows, 5L) + # filter() on 5 rows returned 3 rows still reporting the parent's ties. + for (r in list(dplyr::filter(a, v >= 3), dplyr::slice(a, 1:3), + dplyr::arrange(a, dplyr::desc(v)))) { + expect_null(attr(r, "ties")) + expect_s3_class(r, "sf") + expect_false(inherits(r, "spatialkit_rows")) + } + # The same for prep_model_data()'s record. + dat <- sf::st_as_sf(data.frame(x = 1:5, y = 5:1, resp = c(1, 2, NA, 4, 5), + pred = c(1, 2, 3, 4, Inf)), + coords = c("x", "y"), crs = 32632) + clean <- prep_model_data(dat, "resp", "pred") + expect_null(attr(dplyr::filter(clean, resp > 1), "dropped")) + # And for a geometry-free frame carrying a record (what st_drop_geometry() + # of such a layer is). + d <- spatialkit:::.set_row_record(data.frame(v = 1:5), "ties", + list(n = 1L, which = 2L, rule = "first")) + expect_null(attr(dplyr::filter(d, v >= 3), "ties")) + expect_false(inherits(dplyr::filter(d, v >= 3), "spatialkit_rows")) + # Binding such frames keeps the first one's record, as documented; its + # stamp no longer matches, so the package's readers ignore it. + expect_identical(attr(rbind(d, d), "ties")$n_rows, 5L) + expect_null(spatialkit:::.get_row_record(rbind(d, d), "ties")) +}) + + +# --- the knitr echo of the log ---------------------------------------------- + +test_that("under knitr a caution raised as a warning is not repeated as a message", { + old <- spatialkit_quiet(FALSE) + withr::defer(spatialkit_quiet(old)) + withr::local_options(knitr.in.progress = TRUE) + set.seed(1) + pts <- sf::st_as_sf(data.frame(x = runif(20, 0, 200), y = runif(20, 0, 200), + v = rnorm(20), poly_id = rep(1:4, each = 5)), + coords = c("x", "y"), crs = 32632) + # A design-effect fallback: it was a message and a warning. + res <- .r3_conditions(summarize_by_cell(pts, "v", deff = 0.5)) + expect_identical(res$messages, 0L) + expect_length(res$warnings, 1L) + # The cross-validation cautions that are also R warnings (they used to be + # a .log_warn() followed by a warning()): the random-folds fallback. + res <- .r3_conditions(spatialkit:::.remap_folds(NULL, 1:20)) + expect_identical(res$messages, 0L) + expect_length(res$warnings, 1L) + # A caution that is only logged still reaches the document. + log_only <- function() { spatialkit:::.log_warn("only logged %d", 1L); invisible(NULL) } + res <- .r3_conditions(log_only()) + expect_identical(res$messages, 1L) + expect_length(res$warnings, 0L) + # A log line and a separate warning() are two conditions. + apart <- function() { + spatialkit:::.log_warn("logged %d", 2L) + x <- 1 + warning("raised") + } + res <- .r3_conditions(apart()) + expect_identical(res$messages, 1L) + expect_length(res$warnings, 1L) +}) diff --git a/tests/testthat/test-review3-S4-range-kriging.R b/tests/testthat/test-review3-S4-range-kriging.R new file mode 100644 index 0000000..6e28e32 --- /dev/null +++ b/tests/testthat/test-review3-S4-range-kriging.R @@ -0,0 +1,295 @@ +# tests/testthat/test-review3-S4-range-kriging.R +# --------------------------------------------------------------------------- +# Regressions from the third review of estimate_sac_range(), its print() and +# plot() methods, and kriging_adequacy(). Each test names the finding it +# closes. +# --------------------------------------------------------------------------- + +# n points on a 1000 m square in EPSG:32632, a white-noise covariate `cov`, +# and z = 0.5 * cov plus an exponential field with range parameter `rp` +# (effective range 3 * rp) and a 0.2 nugget; rp = NULL gives white noise. +.r3s4_field <- function(seed, n = 300, rp = 10) { + set.seed(seed) + d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + if (is.null(rp)) { + d$z <- rnorm(n); d$cov <- rnorm(n) + } else { + D <- as.matrix(stats::dist(d)); d$cov <- rnorm(n) + d$z <- 0.5 * d$cov + as.numeric(t(chol(exp(-D / rp) + diag(0.2, n))) %*% rnorm(n)) + } + sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) +} + +# The white-noise REML refusal of test-sac-range.R (seed 7, 0.27 m), fitted +# once for the tests that read it. +.r3s4_wn <- local({ + val <- NULL + function() { + if (is.null(val)) { + set.seed(7) + n <- 300 + d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + z = rnorm(n), w = rnorm(n)) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log( + r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml"))) + val <<- list(r = r, lines = lines, xy = as.matrix(d[, c("x", "y")])) + } + val + } +}) + +.r3s4_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + +.r3s4_first_lag <- function(r) { + vg <- attr(r, "variogram") + min(vg$dist[vg$np > 0]) +} + + +# --------------------------------------------------------------------------- +# S4-RANGE-KRIGING-1: the REML floor is set by the point pairs, not the bins +# --------------------------------------------------------------------------- + +test_that("a REML range the point pairs support is returned, and the same at any cutoff", { + # A true effective range of 30 m on 300 points: the REML fit returned 21.0 + # m and it was refused as below the first bin of the diagnostic variogram + # (30 m at cutoff = 0.5), while at cutoff = 0.1 (first bin 6 m) the same + # REML number came back. + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + pts <- .r3s4_field(9, n = 300, rp = 10) + r5 <- estimate_sac_range(pts, "z", "cov", detrend = "reml") + r1 <- estimate_sac_range(pts, "z", "cov", detrend = "reml", cutoff = 0.1) + expect_true(is.finite(r5)) + expect_equal(as.numeric(r1), as.numeric(r5)) + # Shorter than the first bin, which alone used to refuse it ... + expect_lt(as.numeric(r5), .r3s4_first_lag(r5)) + # ... and longer than the distance within which 30 pairs of its points lie. + d30 <- sort(as.numeric(stats::dist(sf::st_coordinates(pts))))[30] + expect_gt(as.numeric(r5), d30) + expect_null(attr(r5, "range_floor")) +}) + +test_that("a REML range below 30 pairs is refused, says so, and keeps the REML numbers", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + wn <- .r3s4_wn() + r <- wn$r + expect_true(is.na(r)) + expect_s3_class(r, "sac_range") + expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") + # The floor is the 30th-shortest distance between the 300 points the fit + # used (all of them: no duplicates, n <= reml_max_n), below the first lag. + d30 <- sort(as.numeric(stats::dist(wn$xy)))[30] + expect_equal(attr(r, "range_floor"), d30) + expect_lt(attr(r, "range_floor"), .r3s4_first_lag(r)) + expect_lt(attr(r, "rejected_range"), attr(r, "range_floor")) + # The warning names that reference, not a white-noise verdict. + expect_true(log_has(wn$lines, "fewer than 30 pairs of the 300 points the REML fit used")) + expect_true(log_has(wn$lines, "within which 30 of its point pairs lie")) + expect_false(log_has(wn$lines, "no spatial structure")) + # The refusal carries the REML fit's own numbers, as the success does. + rm <- attr(r, "reml") + expect_type(rm, "list") + expect_identical(rm$n_used, 300L) + expect_false(rm$subsampled) + expect_true(all(c("nugget_prop", "sigma2") %in% names(rm))) +}) + +test_that("the gstat-path floor refusal points at a smaller cutoff", { + # Not reachable on ordinary data (the binned fit did not go below the first + # lag on white noise or on 60 m fields), so the fit is stubbed to return a + # 6 m effective range on a field whose variogram rises normally. + skip_if_not_installed("gstat") + pts <- .r3s4_field(2, n = 150, rp = 100) + local_mocked_bindings( + fit.variogram = function(object, model, ...) { + m <- gstat::vgm(psill = 1, model = "Exp", range = 2, nugget = 0.2) + attr(m, "singular") <- FALSE + attr(m, "SSErr") <- 1 + m + }, + .package = "gstat") + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z")) + expect_true(is.na(r)) + expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") + expect_equal(attr(r, "range_floor"), .r3s4_first_lag(r)) + expect_null(attr(r, "reml")) + expect_true(log_has(lines, "shorter than the shortest lag the variogram resolves")) + expect_true(log_has(lines, "re-run with a smaller `cutoff`")) +}) + + +# --------------------------------------------------------------------------- +# S4-RANGE-KRIGING-12: no "supply predictor_vars" for a detrended estimate +# --------------------------------------------------------------------------- + +test_that("the past-the-lags advice fits whether the variogram was detrended", { + skip_if_not_installed("gstat") + set.seed(1); n <- 300 + d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + d$w <- rnorm(n); d$z <- (d$x - 5e5) / 200 + 0.3 * d$w + rnorm(n, sd = 0.3) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log( + r <- suppressWarnings(estimate_sac_range(pts, "z", predictor_vars = "w"))) + skip_if(!identical(attr(r, "rejected_reason"), + "fitted range exceeds the largest lag fitted"), + "the trend did not carry the fit past the lags on this platform") + expect_true(log_has(lines, "try predictors that carry the trend")) + expect_true(log_has(lines, "detrend = \"reml\"")) + expect_false(log_has(lines, "supply `predictor_vars`")) + # Without predictors the advice to supply them stands. + lines0 <- capture_spatialkit_log( + r0 <- suppressWarnings(estimate_sac_range(pts, "z"))) + skip_if(!identical(attr(r0, "rejected_reason"), + "fitted range exceeds the largest lag fitted"), + "the trend did not carry the fit past the lags on this platform") + expect_true(log_has(lines0, "supply `predictor_vars` to detrend")) +}) + + +# --------------------------------------------------------------------------- +# S4-RANGE-KRIGING-10: print() on a CRS-less estimate says what it is in +# --------------------------------------------------------------------------- + +test_that("print() names the units of a CRS-less estimate and what was modelled", { + skip_if_not_installed("gstat") + pts <- .r3s4_field(3, n = 150, rp = 100) + r <- suppressWarnings(estimate_sac_range(sf::st_set_crs(pts, NA), "z")) + out <- utils::capture.output(print(r)) + expect_true(any(grepl("in the coordinate units of a layer with no CRS; variogram of the response itself", + out, fixed = TRUE))) + # A hand-built object that records no CRS at all prints the number only. + bare <- structure(300, class = c("sac_range", "numeric")) + expect_identical(utils::capture.output(print(bare)), "300 ") +}) + + +# --------------------------------------------------------------------------- +# S4-RANGE-KRIGING-11: plot() captions the floor refusal with its numbers +# --------------------------------------------------------------------------- + +test_that("plot() captions the floor refusal with the refused range and the floor", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + skip_if_not_installed("ggplot2") + r <- .r3s4_wn()$r + sub <- gsub("\n", " ", plot(r)$labels$subtitle, fixed = TRUE) + expect_match(sub, sprintf("the fitted range (%.3g) is below %.3g", attr(r, "rejected_range"), + attr(r, "range_floor")), fixed = TRUE) + expect_match(sub, "30 pairs", fixed = TRUE) + # On the variogram path (or an object without the floor recorded) it is + # the first lag that is named. + gs <- r + attr(gs, "range_floor") <- NULL + attr(gs, "reml") <- NULL + sub2 <- gsub("\n", " ", plot(gs)$labels$subtitle, fixed = TRUE) + expect_match(sub2, sprintf("is below the shortest lag fitted (%.3g)", .r3s4_first_lag(r)), + fixed = TRUE) +}) + + +# --------------------------------------------------------------------------- +# kriging_adequacy(): S4-RANGE-KRIGING-8, -9 and S3-ASSIGNMENT-3 +# --------------------------------------------------------------------------- + +.r3s4_ka_setup <- function() { + set.seed(1) + n <- 200 + x <- 5e5 + runif(n, 0, 1000); y <- 5e6 + runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(0.8 * exp(-d / 100) + diag(0.2, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox(pts))) + cells <- create_grid_polygons(bnd, target_cells = 16, type = "square") + list(pts = pts, cells = cells, asg = assign_features_to_polygons(pts, cells)) +} + +test_that("kriging_adequacy() says why there is no variogram model, and whose", { + skip_if_not_installed("gstat") + s <- .r3s4_ka_setup() + sing <- structure(NA_real_, class = c("sac_range", "numeric"), + rejected_reason = "no variogram model could be fitted (singular fits)") + expect_error(kriging_adequacy(s$asg, "z", s$cells, sac = sing), + "`sac` carries no variogram model.*no variogram model could be fitted \\(singular fits\\)") + # No `sac` passed: the estimate made here is named, not the argument. + flat <- s$asg; flat$z <- 1 + err <- tryCatch(suppressWarnings(kriging_adequacy(flat, "z", s$cells)), + error = conditionMessage) + expect_match(err, "the variogram estimated here from 'z' carries no variogram model", + fixed = TRUE) + # The estimate's own reason, now that its early NA returns carry one. + expect_match(err, "nothing to krige with: the response is constant", fixed = TRUE) + expect_false(grepl("`sac`", err, fixed = TRUE)) +}) + +test_that("kriging_adequacy() takes CRS-less cells, or points, to be in the other layer's CRS", { + skip_if_not_installed("gstat") + s <- .r3s4_ka_setup() + # A variogram fitted in kilometres: the points go into that CRS, and the + # cells must follow from the points' own metres, not be labelled km. + sac_km <- estimate_sac_range(sf::st_transform(s$pts, "+proj=utm +zone=32 +units=km"), "z") + base <- kriging_adequacy(s$asg, "z", s$cells, sac = sac_km, k = 4) + w <- .r3s4_warnings(kriging_adequacy(s$asg, "z", sf::st_set_crs(s$cells, NA), + sac = sac_km, k = 4)) + expect_true(any(grepl("`cells_sf` has no CRS", w$warnings, fixed = TRUE))) + expect_equal(w$value$kr_var, base$kr_var) + expect_equal(w$value$n, base$n) + # The reverse: points without a CRS, cells with one. + w2 <- .r3s4_warnings(kriging_adequacy(sf::st_set_crs(s$asg, NA), "z", s$cells, + sac = sac_km, k = 4)) + expect_true(any(grepl("`assigned_points_sf` has no CRS", w2$warnings, fixed = TRUE))) + expect_equal(w2$value$kr_var, base$kr_var) +}) + +test_that("kriging_adequacy() matches cell IDs as summarize_by_cell() does", { + skip_if_not_installed("gstat") + sq <- function(x0, y0, s) sf::st_polygon(list(rbind(c(x0, y0), c(x0 + s, y0), + c(x0 + s, y0 + s), c(x0, y0 + s), c(x0, y0)))) + grid <- sf::st_sf(poly_id = 1:16, geometry = sf::st_sfc(lapply(0:15, function(k) + sq(5e5 + (k %% 4) * 100, 5e6 + (k %/% 4) * 100, 100)), crs = 32632)) + set.seed(11); n <- 200; x <- runif(n, 0, 400); y <- runif(n, 0, 400) + z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(cbind(x, y))) / 80) + diag(1e-6, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, z = z), coords = c("x", "y"), crs = 32632) + sac <- structure(240, class = c("sac_range", "numeric"), + variogram_model = gstat::vgm(1, "Exp", 80, 0.05), crs = sf::st_crs(32632)) + + # Integer cell IDs from 1e5 up against the assigned layer's IDs read back + # as double: "1e+05" missed "100000", and those cells came back with n = 0. + g2 <- grid; g2$poly_id <- g2$poly_id * 100000L + a2 <- assign_features_to_polygons(pts, g2); a2$poly_id <- as.double(a2$poly_id) + sm <- suppressWarnings(summarize_by_cell(a2, "z", cells_sf = g2)) + w <- .r3s4_warnings(kriging_adequacy(a2, "z", g2, sac = sac)) + expect_false(any(grepl("match no", w$warnings))) + k2 <- w$value + expect_equal(sum(k2$n), n) + expect_equal(k2$n, sm$n[match(as.character(k2$poly_id), sm$poly_id)]) + expect_true(all(k2$n > 0L)) + + # Cells keyed by 'id', which summarize_by_cell() joins. + gid <- grid; names(gid)[names(gid) == "poly_id"] <- "id" + a <- assign_features_to_polygons(pts, gid) + kid <- kriging_adequacy(a, "z", gid, sac = sac) + expect_s3_class(kid, "kriging_adequacy") + expect_true("id" %in% names(kid)) + expect_equal(sum(kid$n), n) + + # A point whose ID matches no cell is said, not dropped silently. + a3 <- assign_features_to_polygons(pts, grid) + w3 <- .r3s4_warnings(kriging_adequacy(a3, "z", grid[-1, ], sac = sac)) + expect_true(any(grepl(sprintf("%d of the %d point\\(s\\) with a cell ID carry one that matches no", + sum(a3$poly_id == 1L), n), w3$warnings))) + expect_equal(sum(w3$value$n), n - sum(a3$poly_id == 1L)) + + # Neither layer has an ID column it knows: both lists are named. + none <- grid; names(none)[names(none) == "poly_id"] <- "zone" + expect_error(kriging_adequacy(a3, "z", none, sac = sac), + "`cells_sf`. Looked for: poly_id, polygon_id, id, cell_id, grid_id", fixed = TRUE) +}) diff --git a/tests/testthat/test-review3-S5-folds.R b/tests/testthat/test-review3-S5-folds.R new file mode 100644 index 0000000..910a227 --- /dev/null +++ b/tests/testthat/test-review3-S5-folds.R @@ -0,0 +1,248 @@ +# tests/testthat/test-review3-S5-folds.R +# --------------------------------------------------------------------------- +# Third review round: make_folds() and cv_block_size_sweep(). Each test +# fails on the code before the fix, except the one that pins the ladder +# where it did not change. Helpers are in helper-review2-folds.R. +# --------------------------------------------------------------------------- + +r3_collect_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + +r3_sweep_layer <- function(x, y, seed = 1) { + set.seed(seed) + p <- r2_pts(x, y, a = rnorm(length(x))) + p$z <- sin(sf::st_coordinates(p)[, 1] / 500) + 0.5 * p$a + rnorm(length(x), 0, 0.2) + p +} + +r3_cells <- function(bb, b) { + d <- spatialkit:::.block_dims_from_size(bb, b) + as.numeric(d$nx) * as.numeric(d$ny) +} + + +# ---- cv_block_size_sweep(): the default ladder's top ----------------------- + +test_that("the default ladder at k = 5 keeps all its sizes on a square and reaches side / 3", { + # The ladder used to top out at half the shorter side, a 2 x 2 grid of four + # cells, which k = 5 always dropped: five cross-validations for n_sizes = 6, + # the last at ~0.30 of the side. A range between that and side / 3 (a + # 3 x 3 grid) then drew a warning that called the 0.30 rung "half the + # shorter side" and said only blocks up to the longer side / k -- smaller + # than rungs already run -- still gave k blocks. + set.seed(4) + p <- r3_sweep_layer(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000)) + bb <- sf::st_bbox(p) + side <- min(bb["xmax"] - bb["xmin"], bb["ymax"] - bb["ymin"]) + res <- r3_collect_warnings(r2_quiet( + cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 5, n_sizes = 6, + sac = 0.31 * as.numeric(side), quiet = TRUE))) + expect_length(res$warnings, 0L) + sw <- res$value + blk <- sw[sw$method == "block_kfold", ] + expect_equal(nrow(blk), 6L) + expect_equal(attr(sw, "n_fits"), 35L) + top <- max(blk$block_size) + expect_gt(top, as.numeric(side) / 3.05) + expect_lte(top, as.numeric(side) / 2) + expect_gte(r3_cells(bb, top), 5) + expect_true(all(blk$k == 5L)) +}) + +test_that("the ladder's top is unchanged where half the side already gives k blocks", { + set.seed(4) + p <- r3_sweep_layer(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000)) + bb <- sf::st_bbox(p) + side <- as.numeric(min(bb["xmax"] - bb["xmin"], bb["ymax"] - bb["ymin"])) + sw <- r2_quiet(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 4, n_sizes = 3, + include_random = FALSE, sac = NA, quiet = TRUE)) + expect_equal(max(sw$block_size), side / 2 * (1 - 1e-9)) + expect_equal(min(sw$block_size), side / 25) +}) + +test_that("the ladder warning on a corridor names the rung run and a size that gives k blocks", { + set.seed(1) + p <- r3_sweep_layer(5e5 + runif(60, 0, 5000), 5e6 + runif(60, 0, 200)) + bb <- sf::st_bbox(p) + res <- r3_collect_warnings(r2_quiet( + cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 4, n_sizes = 2, + sac = 1000, quiet = TRUE))) + expect_length(res$warnings, 1L) + msg <- res$warnings + top_run <- max(res$value$block_size, na.rm = TRUE) + expect_match(msg, sprintf("default ladder \\(up to %s, over the ", + format(signif(top_run, 3)))) + expect_no_match(msg, "half the shorter side") + b <- as.numeric(sub(".*Blocks up to ([0-9.e+]+) still give k = 4 blocks.*", "\\1", msg)) + expect_true(is.finite(b)) + expect_gt(b, 1000) # past the range, so the advice works + expect_gte(r3_cells(bb, b), 4) # and the size it names gives k blocks + expect_lt(r3_cells(bb, b * 1.05), 4) # and is close to the largest that does +}) + + +# ---- cv_block_size_sweep(): sizes the caller chose ------------------------- + +test_that("user block_sizes that give fewer than k blocks are warned about, naming a size that works", { + set.seed(4) + p <- r3_sweep_layer(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000)) + bb <- sf::st_bbox(p) + res <- r3_collect_warnings(r2_quiet( + cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 5, + block_sizes = c(100, 200, 400, 600), include_random = FALSE, + sac = NA, quiet = TRUE))) + expect_equal(res$value$block_size, c(100, 200)) + expect_length(res$warnings, 1L) + expect_match(res$warnings, "`block_sizes` 400, 600 give fewer than k = 5 blocks") + b <- as.numeric(sub(".*the largest size whose grid holds k blocks is ([0-9.]+).*", "\\1", + res$warnings)) + expect_gte(r3_cells(bb, b), 5) + expect_lt(r3_cells(bb, b * 1.05), 5) +}) + +test_that("a units object for block_sizes is refused by name", { + set.seed(4) + p <- r3_sweep_layer(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000)) + expect_error(cv_block_size_sweep(p, "z", "a", fit_fn = r2_fit, k = 3, + block_sizes = units::set_units(c(100, 200), m), + sac = NA, quiet = TRUE), + "`block_sizes` must be positive numbers, given as plain numbers in EPSG:32632 units") +}) + + +# ---- make_folds(): the leakage diagnostic on a single row of blocks -------- + +test_that("a single row of blocks is compared with the range along the row only", { + skip_if_not_installed("gstat") + # Points on a 10 km line. The one row spans the whole (zero) height and + # borders no other block across it; min(w / nx, h / ny) compared the range + # with 0 and warned on every call, and its advice (block_size = range) + # shortened the blocks along the line. + set.seed(11) + n <- 300 + x <- sort(runif(n, 0, 10000)) + z <- as.numeric(t(chol(exp(-as.matrix(stats::dist(x)) / 50) + diag(1e-6, n))) %*% rnorm(n)) + p <- r2_pts(5e5 + x, rep(5e6, n), z = z) + r <- suppressWarnings(as.numeric(estimate_sac_range(p, "z"))) + skip_if_not(is.finite(r) && r > 260 && r < 650, "range outside the fixture's window") + # Automatic grid: 15 x 1, blocks 667 m long, longer than the range. + res <- r3_collect_warnings(r2_quiet( + make_folds(p, k = 5, method = "block_kfold", response_var = "z", seed = 1))) + expect_equal(c(res$value$params$grid_nx, res$value$params$grid_ny), c(15, 1)) + expect_length(res$warnings, 0L) + # block_nx: 1000 m blocks are silent, 250 m blocks warn. + res <- r3_collect_warnings(r2_quiet( + make_folds(p, k = 5, method = "block_kfold", response_var = "z", block_nx = 10, seed = 1))) + expect_length(res$warnings, 0L) + res <- r3_collect_warnings(r2_quiet( + make_folds(p, k = 5, method = "block_kfold", response_var = "z", block_nx = 40, seed = 1))) + expect_length(res$warnings, 1L) + expect_match(res$warnings, "block_nx/block_ny yield blocks smaller than autocorrelation range") + + # A 10 km x 100 m corridor: the 15 x 1 grid is compared along its length. + set.seed(11) + y <- runif(n, 0, 100) + z2 <- as.numeric(t(chol(exp(-as.matrix(stats::dist(cbind(x, y))) / 50) + + diag(1e-6, n))) %*% rnorm(n)) + cp <- r2_pts(5e5 + x, 5e6 + y, z = z2) + res <- r3_collect_warnings(r2_quiet( + make_folds(cp, k = 5, method = "block_kfold", response_var = "z", seed = 1))) + expect_equal(c(res$value$params$grid_nx, res$value$params$grid_ny), c(15, 1)) + expect_false(any(grepl("block dimension", res$warnings))) +}) + + +# ---- make_folds(): a single block ------------------------------------------ + +test_that("a block size that leaves one block stops without announcing a lowered k", { + set.seed(2) + p <- r2_pts(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000)) + lines <- capture_spatialkit_log( + expect_error(make_folds(p, k = 5, method = "block_kfold", block_size = 600, seed = 1), + "the block size \\(600\\) produces a single block"), + level = logger::INFO) + expect_false(log_has(lines, "Reducing k to match")) + # Two blocks or more still lower k, and say so. + lines <- capture_spatialkit_log( + f <- make_folds(p, k = 5, method = "block_kfold", block_size = 400, seed = 1), + level = logger::INFO) + expect_true(log_has(lines, "block_size produces only 4 blocks \\(< k = 5\\). Reducing k")) + expect_equal(f$k, 4L) +}) + + +# ---- make_folds(): the 1,000,000-block guard ------------------------------- + +test_that("the grid guard names the argument that produced the grid, and refuses an overflow", { + set.seed(1) + p <- r2_pts(5e5 + runif(100, 0, 1000), 5e6 + runif(100, 0, 1000)) + e <- expect_error(make_folds(p, k = 5, method = "block_kfold", block_nx = 2000, + block_ny = 1000), + "2000 x 1000 = 2,000,000 cells, above the 1,000,000 this function will build") + expect_match(conditionMessage(e), "`block_nx`/`block_ny`") + expect_no_match(conditionMessage(e), "block_size|unset") + e <- expect_error(make_folds(p, k = 5, method = "block_kfold", block_multiplier = 1e6), + "above the 1,000,000 this function will build") + expect_match(conditionMessage(e), "`block_multiplier` \\(1e\\+06\\) x k \\(5\\)") + expect_no_match(conditionMessage(e), "unset") + # nx * ny overflowed to Inf and slipped past the guard into st_make_grid(). + expect_error(make_folds(p, k = 5, method = "block_kfold", block_size = 1e-200), + "= more than 1e308 cells, above the 1,000,000 this function will build. Check that `block_size` \\(1e-200\\)") +}) + + +# ---- argument validation --------------------------------------------------- + +test_that("phi, min_train and block_multiplier are refused by name", { + set.seed(1) + p <- r2_pts(5e5 + runif(100, 0, 2000), 5e6 + runif(100, 0, 1000)) + pp <- sf::st_as_sf(sf::st_make_grid(p, n = c(10, 5), what = "centers")) + expect_error(make_folds(p, method = "nndm", prediction_points = pp, + phi = units::set_units(100, m)), + "`phi` must be a single non-negative number") + expect_error(make_folds(p, method = "nndm", prediction_points = pp, + min_train = units::set_units(0.5, 1)), + "`min_train` must be a single number in \\(0, 1\\)") + for (bm in list(NA, c(1, 3), units::set_units(3, 1), "3", -1, 0, Inf, numeric(0))) + expect_error(make_folds(p, k = 5, method = "block_kfold", block_multiplier = bm), + "`block_multiplier` must be a single positive number", + info = paste(format(bm), collapse = ",")) + # A valid fractional multiplier is still honoured. + expect_equal(make_folds(p, k = 4, method = "block_kfold", + block_multiplier = 2.5)$params$block_multiplier, 2.5) +}) + +test_that("a misspelt response_var is an error for block_kfold whether or not auto_range is set", { + set.seed(1) + p <- r2_pts(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000), z = rnorm(60)) + expect_error(make_folds(p, k = 5, method = "block_kfold", response_var = "nope", seed = 1), + "`response_var` 'nope' is not a column of `points_sf`") + expect_error(make_folds(p, k = 5, method = "block_kfold", response_var = "nope", + auto_range = TRUE, seed = 1), + "`response_var` 'nope' is not a column of `points_sf`") + expect_error(make_folds(p, k = 5, method = "block_kfold", response_var = c("z", "z"), seed = 1), + "`response_var` must be a single column name") + # The methods that never read it still ignore it. + expect_equal(make_folds(p, k = 5, method = "random_kfold", response_var = "nope", seed = 1)$k, 5L) +}) + + +# ---- make_folds(auto_range = TRUE): the fallback warning's reason ---------- + +test_that("the auto_range fallback warning says why a bare NA came back", { + skip_if_not_installed("gstat") + set.seed(1) + p20 <- r2_pts(5e5 + runif(20, 0, 1000), 5e6 + runif(20, 0, 1000), z = rnorm(20)) + expect_warning(r2_quiet(make_folds(p20, k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1)), + "no autocorrelation range was identified \\(20 points, fewer than the 30") + pc <- r2_pts(5e5 + runif(60, 0, 1000), 5e6 + runif(60, 0, 1000), z = rep(1, 60)) + expect_warning(r2_quiet(make_folds(pc, k = 3, method = "block_kfold", auto_range = TRUE, + response_var = "z", seed = 1)), + "no autocorrelation range was identified \\(the response is constant\\)") +}) diff --git a/tests/testthat/test-review3-S6-cv-eval.R b/tests/testthat/test-review3-S6-cv-eval.R new file mode 100644 index 0000000..bfda81a --- /dev/null +++ b/tests/testthat/test-review3-S6-cv-eval.R @@ -0,0 +1,284 @@ +# tests/testthat/test-review3-S6-cv-eval.R +# --------------------------------------------------------------------------- +# Regressions from the third review of the CV runners and the model +# evaluation functions. Each test names the finding it closes. The models +# are helper-lmfit.R's lm fit or a small custom subclass, so no optional +# backend is needed except where skipped. +# --------------------------------------------------------------------------- + +.r3_pts <- function(n = 80, seed = 1, extent = 1000) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = runif(n, 0, extent), y = runif(n, 0, extent), w = rnorm(n)), + coords = c("x", "y"), crs = 32632) + # A trend w cannot explain, so the residuals carry spatial structure. + d$z <- 5 + 0.004 * sf::st_coordinates(d)[, 1] + 2 * d$w + rnorm(n, 0, 0.5) + d +} + +.r3_lm <- function(tr) lm_spatial_fit(tr, "z", "w") + +.r3_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(x) { + w <<- c(w, conditionMessage(x)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-1: residual Moran's I for a custom fit without residuals() +# --------------------------------------------------------------------------- + +test_that("residual_morans_i() scores a fit with fitted() but no residuals() on y - fitted", { + d <- .r3_pts(80, seed = 1) + # The documented minimum: predict() and fitted(), no residuals() method. + registerS3method("fitted", "r3_fitonly", + function(object, ...) as.numeric(stats::fitted(object$engine))) + registerS3method("predict", "r3_fitonly", function(object, newdata = NULL, ...) + as.numeric(stats::predict(object$engine, sf::st_drop_geometry(newdata)))) + bare <- new_spatial_fit(subclass = "r3_fitonly", + engine = stats::lm(z ~ w, sf::st_drop_geometry(d)), + formula = z ~ w, response_var = "z", + predictor_vars = "w", data_sf = d) + full <- lm_spatial_fit(d, "z", "w") # has a residuals() method + expect_no_warning(mi <- residual_morans_i(bare)) + ref <- residual_morans_i(full) + expect_s3_class(mi, "morans_i") + expect_equal(mi$observed, ref$observed) + expect_equal(mi$z, ref$z) + expect_gt(mi$z, 3) # the trend left behind + + # compare_models() now reports it instead of all-NA columns. + cmp <- .r3_warnings(compare_models(list(bare = bare))) + expect_false(any(grepl("residuals\\(\\) returned NULL", cmp$warnings))) + expect_equal(cmp$value$resid_morans_I, ref$observed) + expect_false(is.na(cmp$value$resid_morans_null)) +}) + +test_that("residual_morans_i() still says why when neither residuals() nor fitted() exists", { + d <- .r3_pts(60, seed = 2) + fit <- new_spatial_fit(subclass = "r3_nothing", engine = NULL, + formula = z ~ w, response_var = "z", + predictor_vars = "w", data_sf = d) + expect_warning(out <- residual_morans_i(fit), + "has no residuals\\(\\) method, and the observed response minus fitted\\(\\) could not be formed either: fitted\\(\\) returned NULL") + expect_null(out) +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-2: a cv_*() result's folds keep their fold_id when re-used +# --------------------------------------------------------------------------- + +test_that("re-feeding a cv result's folds keeps the labels after a dropped fold", { + d <- .r3_pts(80, seed = 3) + f <- make_folds(d, k = 5, method = "random_kfold", seed = 1) + holed <- d + holed$z[f$folds[[3]]$test] <- NA # fold 3 loses every test row + cv1 <- suppressWarnings(cv_spatial(holed, "z", "w", fit_fn = .r3_lm, folds = f)) + expect_identical(cv1$fold_metrics$fold, c(1L, 2L, 4L, 5L)) + cv2 <- suppressWarnings(cv_spatial(holed, "z", "w", fit_fn = .r3_lm, + folds = cv1$folds)) + expect_identical(cv2$fold_metrics$fold, c(1L, 2L, 4L, 5L)) + expect_equal(cv2$fold_metrics$RMSE, cv1$fold_metrics$RMSE) + expect_identical(sort(unique(cv2$predictions$fold)), c(1L, 2L, 4L, 5L)) + expect_identical(cv2$fold_status$fold, c(1L, 2L, 4L, 5L)) + expect_identical(vapply(cv2$folds, `[[`, integer(1), "fold_id"), c(1L, 2L, 4L, 5L)) + # ... which is what fold_separation() calls them. + fs <- fold_separation(cv1$folds, holed) + expect_identical(as.integer(fs$fold), cv2$fold_metrics$fold) +}) + +test_that("splits without a usable, distinct fold_id are numbered by position", { + d <- .r3_pts(60, seed = 4) + lab <- rep(1:3, each = 20) + sp <- lapply(1:3, function(j) list(train = which(lab != j), test = which(lab == j), + fold_id = 7L)) # all the same + cv <- cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = sp) + expect_identical(cv$fold_metrics$fold, 1:3) + sp[[1]]$fold_id <- NULL; sp[[2]]$fold_id <- 8L; sp[[3]]$fold_id <- 9L + cv <- cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = sp) + expect_identical(cv$fold_metrics$fold, 1:3) + # A carried id also names the fold in the train/test overlap error. + bad <- list(list(train = 1:40, test = 35:60, fold_id = 4L), + list(train = 21:60, test = 1:20, fold_id = 6L)) + expect_error(cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = bad), + "fold 4 has 6 row ID\\(s\\) in BOTH") +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-3: a ..per_row column may not reuse a predictions column +# --------------------------------------------------------------------------- + +test_that("fold_info_fn's ..per_row may not reuse a column predictions has", { + d <- .r3_pts(60, seed = 5) + lab <- rep(1:3, each = 20) + for (col in c("yhat", "fold", "y", "..row_id", "y_train_mean")) { + info <- function(fit, test_sf, y, yhat) { + pr <- data.frame(v = yhat + 0); names(pr) <- col; list(..per_row = pr) + } + expect_error(cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, + fold_info_fn = info), + paste0("`..per_row` has columns that `predictions` already has: ", + col, "."), fixed = TRUE) + } + dup <- function(fit, test_sf, y, yhat) + list(..per_row = data.frame(a = y, a = yhat, check.names = FALSE)) + expect_error(cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, + fold_info_fn = dup), "duplicated column names: a") + # A new name is spliced in and `overall` is pooled as usual. + ok <- function(fit, test_sf, y, yhat) list(..per_row = data.frame(ae = abs(y - yhat))) + cv <- cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, fold_info_fn = ok) + expect_equal(cv$predictions$ae, abs(cv$predictions$y - cv$predictions$yhat)) + expect_identical(cv$overall$n_pred, 60L) +}) + +test_that("a ..per_row name clash stops a parallel run too", { + skip_on_os("windows") + skip_on_cran() + skip_if(isTRUE(parallel::detectCores(logical = TRUE) < 2L)) + d <- .r3_pts(60, seed = 6) + info <- function(fit, test_sf, y, yhat) list(..per_row = data.frame(yhat = yhat)) + expect_error(suppressMessages( + cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = rep(1:2, each = 30), + fold_info_fn = info, parallel = 2)), + "already has: yhat.*raised in a parallel worker") +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-4: fold_info_fn returning a named vector, or something else +# --------------------------------------------------------------------------- + +test_that("fold_info_fn may return a named vector; anything else not a list is an error", { + d <- .r3_pts(60, seed = 7) + lab <- rep(1:3, each = 20) + vec <- function(fit, test_sf, y, yhat) + c(slope = unname(stats::coef(fit$engine)[2]), n_te = length(y)) + cv <- cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, fold_info_fn = vec) + expect_true(all(c("slope", "n_te") %in% names(cv$fold_metrics))) + expect_equal(cv$fold_metrics$n_te, c(20, 20, 20)) + expect_true(all(is.finite(cv$fold_metrics$slope))) + + # NULL is still "no extras". + cv0 <- cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, + fold_info_fn = function(...) NULL) + expect_identical(cv0$fold_status$status, rep("ok", 3)) + + expect_error(cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, + fold_info_fn = function(...) new.env()), + "must return a named list \\(or a named vector\\).*class environment") + expect_error(cv_spatial(d, "z", "w", fit_fn = .r3_lm, folds = lab, + fold_info_fn = function(...) 3), + "every element is named") +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-5: folds built on a pointized copy of a polygon layer +# --------------------------------------------------------------------------- + +test_that("folds built on a pointized copy are refused for the geometry, not the data", { + d <- .r3_pts(60, seed = 8) + xy <- sf::st_coordinates(d) + ell <- function(x, y) sf::st_polygon(list(rbind( + c(x, y), c(x + 60, y), c(x + 60, y + 15), c(x + 15, y + 15), + c(x + 15, y + 60), c(x, y + 60), c(x, y)))) + poly <- sf::st_sf(sf::st_drop_geometry(d), + geometry = sf::st_sfc(lapply(seq_len(nrow(xy)), function(i) + ell(xy[i, 1], xy[i, 2])), crs = 32632)) + pp <- coerce_to_points(poly, "auto") # st_point_on_surface() + f_pts <- make_folds(pp, k = 3, method = "random_kfold", seed = 1) + expect_true(f_pts$params$row_probe$points) + err <- tryCatch(cv_spatial(poly, "z", "w", fit_fn = .r3_lm, folds = f_pts), + error = conditionMessage) + expect_match(err, "built on POINT geometry and this data has non-POINT geometry") + expect_match(err, "make_folds\\(\\) on the layer passed here") + expect_no_match(err, "different data") + + # The remedy the message names works. + f_poly <- make_folds(poly, k = 3, method = "random_kfold", seed = 1) + expect_false(f_poly$params$row_probe$points) + expect_no_error(cv_spatial(poly, "z", "w", fit_fn = .r3_lm, folds = f_poly)) + + # A probe from before the field keeps the old refusal. + legacy <- f_pts + legacy$params$row_probe$points <- NULL + expect_error(cv_spatial(poly, "z", "w", fit_fn = .r3_lm, folds = legacy), + "built from different data") +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-7: an information criterion across different responses +# --------------------------------------------------------------------------- + +test_that("compare_models() names a different response, not different rows", { + d <- .r3_pts(70, seed = 9) + d$lz <- log(d$z - min(d$z) + 1) + stub <- function(data, resp, looic) { + fit <- lm_spatial_fit(data, resp, "w") + fit$info$looic <- looic + class(fit) <- c("lmsurf_fit", "bayesian_fit", "spatial_fit") + fit + } + a <- stub(d, "z", 54.8); b <- stub(d, "lz", 12.1) + res <- .r3_warnings(compare_models(list(raw = a, logged = b))) + expect_true(any(grepl(paste0("LOOIC .* fitted to the same rows but to different ", + "responses \\(raw: z, logged: lz\\)"), res$warnings))) + expect_false(any(grepl("Refit them on the same rows", res$warnings))) + expect_true(all(is.na(res$value$LOOIC))) + + # The same column name holding other values says that instead. + d2 <- d; d2$z <- 2 * d2$z + res2 <- .r3_warnings(compare_models(list(raw = a, doubled = stub(d2, "z", 60)))) + expect_true(any(grepl("the values of 'z' differ between raw, doubled", + res2$warnings))) + # Different rows keep their own message. + res3 <- .r3_warnings(compare_models(list(raw = a, sub = stub(d[1:50, ], "z", 30)))) + expect_true(any(grepl("different rows \\(raw: n = 70, sub: n = 50\\)", + res3$warnings))) +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-8: nothing to evaluate is an error, naming `fits` +# --------------------------------------------------------------------------- + +test_that("evaluate_insample() errors when no element is a spatial_fit", { + expect_error(suppressWarnings( + evaluate_insample(list(a = 1, b = stats::lm(dist ~ speed, datasets::cars)))), + "evaluate_insample\\(\\): no element of `fits` is a spatial_fit") + expect_error(compare_models(list(a = 1, b = "x")), + "compare_models\\(\\): no element of `fits` is a spatial_fit") + # A mixed list still skips the stranger and scores the fit. + d <- .r3_pts(40, seed = 10) + out <- evaluate_insample(list(fit = lm_spatial_fit(d, "z", "w"), junk = 1)) + expect_s3_class(out, "data.frame") + expect_identical(out$model, "fit") +}) + + +# --------------------------------------------------------------------------- +# S6-CV-EVAL-9: cv_rf(parallel = more than the machine has) says so once +# --------------------------------------------------------------------------- + +test_that("cv_rf() prints the worker cap message once", { + skip_if_not_installed("ranger") + skip_on_os("windows") + skip_on_cran() # forks the folds + d <- .r3_pts(45, seed = 11) + n_machine <- parallel::detectCores(logical = TRUE) + skip_if(is.na(n_machine)) + msgs <- character(0) + withCallingHandlers( + cv_rf(d, "z", "w", folds = rep(1:3, each = 15), num_trees = 60, seed = 1, + parallel = n_machine + 5L), + message = function(m) { + msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") + }) + expect_identical(sum(grepl("workers requested on a machine with", msgs)), 1L) +}) diff --git a/tests/testthat/test-review3-S7-gwr-classes.R b/tests/testthat/test-review3-S7-gwr-classes.R new file mode 100644 index 0000000..faaa23b --- /dev/null +++ b/tests/testthat/test-review3-S7-gwr-classes.R @@ -0,0 +1,310 @@ +# =========================================================================== +# GWR regressions from the third review (slice S7: GWR and the fit classes). +# =========================================================================== + +# Every warning raised while evaluating `expr`, muffled, beside its value (or +# the error message, as a character string, when it failed). +.r3_catch <- function(expr) { + w <- character(0) + val <- tryCatch( + withCallingHandlers(suppressMessages(expr), warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }), + error = function(e) conditionMessage(e)) + list(value = val, warnings = w) +} + +# A smooth temperature field, in degrees C and in kelvin: the same predictor +# with a different origin, so every local slope is the same in both. +.r3_temperature <- function() { + set.seed(1); n <- 200 + x <- runif(n, 0, 10000); y <- runif(n, 0, 10000) + tC <- 15 + 4 * sin(x / 3000) + 3 * cos(y / 2500) + rnorm(n, 0, 1) + d <- sf::st_as_sf(data.frame(x = 5e5 + x, y = 5e6 + y, tC = tC, + tK = tC + 273.15, nz = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$yield <- 50 - 0.8 * d$tC + rnorm(n, 0, 1) + d +} + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-1: the collinearity verdict on the slopes must not depend on +# a predictor's origin (degrees C vs kelvin), while a regional covariate that +# is nearly constant inside a window is still caught. +# --------------------------------------------------------------------------- + +test_that("the slope index is origin- and unit-free and matches its definition", { + set.seed(11); n <- 150 + xy <- cbind(runif(n, 0, 1000), runif(n, 0, 1000)) + xm <- cbind(a = rnorm(n, 5, 2), b = rnorm(n)) + s0 <- .gwr_local_collinearity(xy, xm, TRUE, 30, "bisquare") + expect_named(s0, c("row", "x", "y", "n_window", "cn", "cn_slopes")) + expect_true(all(is.finite(s0$cn_slopes) & s0$cn_slopes >= 1)) + # A shift of origin and a change of units move `cn` but not `cn_slopes`. + xs <- cbind(a = xm[, "a"] * 1000 + 1e5, b = xm[, "b"] - 40) + s1 <- .gwr_local_collinearity(xy, xs, TRUE, 30, "bisquare") + expect_equal(s1$cn_slopes, s0$cn_slopes, tolerance = 1e-8) + expect_gt(median(s1$cn), 10 * median(s0$cn)) + # By hand at one location: locally centred, globally scaled, weighted. + i <- 17L + d <- sqrt((xy[, 1] - xy[i, 1])^2 + (xy[, 2] - xy[i, 2])^2) + w <- .gw_kernel_weights(d, 30, "bisquare", TRUE); k <- which(w > 1e-8) + ww <- w[k] / sum(w[k]) + z <- sqrt(ww) * sweep(sweep(xm[k, ], 2, colSums(ww * xm[k, ])), 2, + apply(xm, 2, sd), "/") + sv <- svd(z)$d + expect_equal(s0$cn_slopes[i], max(1, max(sv)) / min(1, min(sv))) + # A predictor exactly constant inside the window is singular outright. + expect_identical(.gwr_slope_index(c(1, 1, 1, 1), cbind(c(3, 3, 3, 3), 1:4), + c(1, 1)), Inf) +}) + +test_that("a regional covariate is still flagged, including a cluster at the global mean", { + # Three clusters at 0.5 / 1.0 / 1.5 (plus noise of SD 0.01). Centring at + # the GLOBAL mean would score the middle cluster near 1, although its local + # slope is undetermined; the slope index centres in the window. + set.seed(6); cl <- rep(1:3, each = 60) + xy <- cbind(c(0, 400, 800)[cl] + runif(180, 0, 100), runif(180, 0, 100)) + soil <- c(0.5, 1.0, 1.5)[cl] + rnorm(180, 0, 0.01) + s <- .gwr_local_collinearity(xy, cbind(soil = soil), TRUE, 20, "bisquare") + flagged <- tapply(.gwr_slopes_collinear(s), cl, sum) + expect_true(all(flagged >= 55)) + expect_gte(flagged[[2L]], 55) +}) + +test_that("a far-from-zero origin flags the slopes only where GWmodel's solve degrades", { + set.seed(1); n <- 200 + x <- runif(n, 0, 10000); y <- runif(n, 0, 10000) + el <- 500 + 150 * sin(x / 3000) + 100 * cos(y / 2500) + rnorm(n, 0, 5) + # Elevation in metres: the old uncentred rule flagged most windows. + s <- .gwr_local_collinearity(cbind(x, y), cbind(el), TRUE, 30, "bisquare") + expect_gt(sum(!is.finite(s$cn) | s$cn > 30), 100) + expect_equal(sum(.gwr_slopes_collinear(s)), 0L) + # Shifted until the uncentred index passes 1e6: flagged, on `cn` alone. + s7 <- .gwr_local_collinearity(cbind(x, y), cbind(el + 1e7), TRUE, 30, "bisquare") + expect_equal(s7$cn_slopes, s$cn_slopes, tolerance = 1e-6) + expect_gt(sum(.gwr_slopes_collinear(s7)), 0L) + expect_true(all(s7$cn[.gwr_slopes_collinear(s7)] > 1e6)) + # A survey made before cn_slopes existed falls back to cn > 30. + old <- s[, c("row", "x", "y", "n_window", "cn")] + expect_identical(.gwr_slopes_collinear(old), !is.finite(old$cn) | old$cn > 30) +}) + +test_that("the same field in degrees C and in kelvin gets the same verdict and a drawable map", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + d <- .r3_temperature() + rC <- .r3_catch(fit_gwr_model(d, "yield", "tC", bandwidth = 30)) + rK <- .r3_catch(fit_gwr_model(d, "yield", "tK", bandwidth = 30)) + expect_s3_class(rC$value, "gwr_fit"); expect_s3_class(rK$value, "gwr_fit") + # The slopes are the same surface ... + expect_lt(max(abs(coef(rC$value)$tC - coef(rK$value)$tK)), 1e-6) + # ... so neither fit warns, globally or locally. + expect_length(rC$warnings, 0L) + expect_length(rK$warnings, 0L) + expect_identical(rC$value$info$n_local_collinear, rK$value$info$n_local_collinear) + expect_identical(rK$value$info$n_local_collinear, 0L) + expect_equal(rK$value$info$condition_index, 1) + expect_equal(rK$value$info$local_collinearity$cn_slopes, + rC$value$info$local_collinearity$cn_slopes, tolerance = 1e-8) + # The intercept-inclusive index is kept, and it does see the kelvin origin. + expect_true(all(rK$value$info$local_collinearity$cn > 30)) + # The kelvin slope map is drawn, with nothing masked (it used to be refused). + skip_if_not_installed("ggplot2") + pK <- plot(rK$value, type = "coefficients", term = "tK") + expect_match(pK$labels$subtitle, "No location masked") + # The Intercept map is masked by the intercept-inclusive index. + lcC <- rC$value$info$local_collinearity + n_int <- sum(!is.finite(lcC$cn) | lcC$cn > 30) + expect_gt(n_int, 0L) + pI <- plot(rC$value, type = "coefficients", term = "Intercept") + expect_match(pI$labels$subtitle, + sprintf("^%d of 200 locations masked.*%d with a collinear local design \\(condition index with the intercept > 30\\)", + n_int, n_int)) + pC <- plot(rC$value, type = "coefficients", term = "tC") + expect_match(pC$labels$subtitle, "No location masked") + # Every intercept masked: refused, and the message says what to do. + expect_error(plot(rK$value, type = "coefficients", term = "Intercept"), + "centre the predictors to map it") +}) + +test_that("a far-from-zero predictor beside a second one no longer draws the global warning", { + # v2.0.0 already warned on this for two or more predictors. + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + d <- .r3_temperature() + rK <- .r3_catch(fit_gwr_model(d, "yield", c("tK", "nz"), bandwidth = 30)) + rC <- .r3_catch(fit_gwr_model(d, "yield", c("tC", "nz"), bandwidth = 30)) + expect_false(any(grepl("global predictors|collinear local design", rK$warnings))) + expect_equal(rK$value$info$condition_index, rC$value$info$condition_index) + expect_lt(rK$value$info$condition_index, 30) + expect_identical(rK$value$info$n_local_collinear, rC$value$info$n_local_collinear) + # Two predictors that really move together still warn globally. + d$tC2 <- d$tC + rnorm(nrow(d), 0, 0.01) + r2 <- .r3_catch(fit_gwr_model(d, "yield", c("tC", "tC2"), bandwidth = 60)) + expect_true(any(grepl("global predictors \\(centred\\) have scaled condition index", + r2$warnings))) +}) + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-3: the adaptive floor is not enough when neighbours tie at +# the kernel's edge (a regular grid); the warning and the fit error say so. +# --------------------------------------------------------------------------- + +test_that("the floor warning and the singular-fit error name ties at the kernel's edge", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + set.seed(2) + g <- expand.grid(x = 5e5 + (0:9) * 100, y = 5e6 + (0:9) * 100) + g$a <- rnorm(100); g$z <- 1 + 2 * g$a + rnorm(100) + d <- sf::st_as_sf(g, coords = c("x", "y"), crs = 32632) + r <- .r3_catch(fit_gwr_model(d, "z", "a", bandwidth = 2)) + expect_true(any(grepl("using 4\\. That is enough unless several neighbours tie at the kernel's edge", + r$warnings))) + expect_type(r$value, "character") + expect_match(r$value, "neighbours tied at the kernel's edge \\(a regular grid\\)") + # Kernels that keep the edge point are not told about ties. + rg <- .r3_catch(fit_gwr_model(d, "z", "a", bandwidth = 2, kernel = "gaussian")) + expect_false(any(grepl("tie at the kernel's edge", rg$warnings))) +}) + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-4: one range check for an adaptive count in all three GWR +# entry points, before anything is fitted. +# --------------------------------------------------------------------------- + +test_that("gwr_model_selection() refuses an adaptive count below 1 or above R's integers", { + set.seed(1); n <- 60 + dat <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + dat$z <- 1 + 2 * dat$a + rnorm(n) + never <- function(...) stop("engine reached") + expect_error(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 3e9, .engine = never), + "`bandwidth` must be a single number of nearest neighbours when adaptive = TRUE and at most 2147483647") + expect_error(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 0.5, .engine = never), + "`bandwidth` must be a single number of nearest neighbours when adaptive = TRUE and at least 1; got 0.5") + # A fixed distance below 1 is a distance, not a count, and passes. + expect_error(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 0.5, + adaptive = FALSE, .engine = never), + "engine reached") +}) + +test_that("cv_gwr() refuses an adaptive count below 1 up front, not in every fold", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + set.seed(1); n <- 60 + dat <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + dat$z <- 1 + 2 * dat$a + rnorm(n) + expect_error(cv_gwr(dat, "z", "a", bandwidth = 0.5, k = 3), + "^cv_gwr\\(\\): `bandwidth` must be a single number of nearest neighbours when adaptive = TRUE and at least 1") + expect_error(cv_gwr(dat, "z", "a", bandwidth = 3e9, k = 3), + "^cv_gwr\\(\\): `bandwidth` .* at most 2147483647") +}) + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-5: "use a larger bandwidth" is not advice when the adaptive +# bandwidth is already every observation. +# --------------------------------------------------------------------------- + +test_that("the undefined-AICc warning gives advice that can be followed", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + set.seed(4); n <- 4 + dat <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + dat$z <- 1 + 2 * dat$a + rnorm(n) + r <- .r3_catch(fit_gwr_model(dat, "z", c("a", "b"))) + w <- grep("AICc is undefined", r$warnings, value = TRUE) + expect_length(w, 1L) + expect_match(w, "Even the widest adaptive window \\(all 4 observations\\) leaves too few residual degrees of freedom for 3 parameters") + expect_no_match(w, "use a larger one") + rs <- .r3_catch(gwr_model_selection(dat, "z", c("a", "b"))) + ws <- grep("AICc is undefined", rs$warnings, value = TRUE) + expect_length(ws, 1L) + expect_match(ws, "Even the widest adaptive window \\(all 4 observations\\)") + expect_no_match(ws, "Use a larger bandwidth") + # Below n, a larger bandwidth is still the advice. + set.seed(1); n <- 25 + d2 <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d2$v <- 1 + d2$a + rnorm(n) + r2 <- .r3_catch(fit_gwr_model(d2, "v", c("a", "b"), bandwidth = 5)) + w2 <- grep("AICc is undefined", r2$warnings, value = TRUE) + expect_length(w2, 1L) + expect_match(w2, "The bandwidth \\(5 neighbours\\) is too small for 3 parameters; use a larger one\\.") +}) + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-6: gwr_model_selection() says what fit_gwr_model() says +# about a fixed bandwidth in the wrong units, and about a singular window. +# --------------------------------------------------------------------------- + +test_that("gwr_model_selection() warns about a tiny fixed bandwidth and explains a singular window", { + expect_match(.gwr_singular_hint(), "^ -- at least one local window's design is singular") + expect_no_match(.gwr_singular_hint(), "survey found") + expect_match(.gwr_singular_hint(3L), "The collinearity survey found 3 singular window") + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + set.seed(1); n <- 60 + dat <- sf::st_as_sf(data.frame(x = -80 + runif(n, 0, 0.5), y = 35 + runif(n, 0, 0.5), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 4326) + dat$z <- 1 + 2 * dat$a + rnorm(n) + r <- .r3_catch(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 0.2, + adaptive = FALSE)) + expect_true(any(grepl("^gwr_model_selection\\(\\): a fixed bandwidth of 0.2 is less than a ten-thousandth", + r$warnings))) + # What GWmodel then does with empty windows is a backend property; when it + # is the singular-matrix error, the error explains it. + if (is.character(r$value) && grepl("singular", r$value)) + expect_match(r$value, "local window's design is singular") + # A bandwidth in the units the sweep runs in draws no such warning. + ok <- .r3_catch(gwr_model_selection(dat, "z", c("a", "b"), bandwidth = 20000, + adaptive = FALSE)) + expect_s3_class(ok$value, "gwr_model_selection") + expect_false(any(grepl("ten-thousandth", ok$warnings))) +}) + + +# --------------------------------------------------------------------------- +# S7-GWR-CLASSES-8: print() shows a fixed bandwidth in full, with its unit. +# --------------------------------------------------------------------------- + +test_that("print() shows a fixed bandwidth with its unit and an adaptive one as neighbours", { + pts <- surf_test_points(30) # EPSG:3857, metres + gwr <- new_spatial_fit( + "gwr_fit", engine = list(), formula = z ~ w, response_var = "z", + predictor_vars = "w", data_sf = pts, + info = list(bandwidth = 122372.3, adaptive = FALSE, kernel = "bisquare", + AICc = NA_real_, bandwidth_is_fallback = FALSE)) + txt <- paste(utils::capture.output(print(gwr)), collapse = "\n") + expect_match(txt, "Bandwidth: 122,372 metre (fixed, bisquare kernel)", fixed = TRUE) + expect_no_match(txt, "e+05", fixed = TRUE) + gwr$info$bandwidth <- 42; gwr$info$adaptive <- TRUE + txt2 <- paste(utils::capture.output(print(gwr)), collapse = "\n") + expect_match(txt2, "Bandwidth: 42 neighbours (adaptive, bisquare kernel)", fixed = TRUE) +}) + + +# --------------------------------------------------------------------------- +# S10-DOCS-PKG-7: a character or factor response is refused with a message +# naming it, as README and getting-started say, before any bandwidth search. +# --------------------------------------------------------------------------- + +test_that("fit_gwr_model() refuses a non-numeric response up front", { + skip_if_not_installed("GWmodel"); skip_if_not_installed("sp") + s <- surf_test_points(60) + s$zc <- as.character(round(s$z, 3)) + r <- .r3_catch(fit_gwr_model(s, "zc", "w")) + expect_type(r$value, "character") + expect_match(r$value, "^fit_gwr_model\\(\\): response 'zc' is not numeric \\(it is character\\)") + expect_length(r$warnings, 0L) # no failed search, no fallback bandwidth + s$zf <- factor(sample(c("lo", "hi"), nrow(s), replace = TRUE)) + rf <- .r3_catch(fit_gwr_model(s, "zf", "w")) + expect_match(rf$value, "response 'zf' is not numeric \\(it is factor\\)") + expect_length(rf$warnings, 0L) +}) diff --git a/tests/testthat/test-review3-S8-bayes-rf.R b/tests/testthat/test-review3-S8-bayes-rf.R new file mode 100644 index 0000000..df20800 --- /dev/null +++ b/tests/testthat/test-review3-S8-bayes-rf.R @@ -0,0 +1,362 @@ +# Regression tests for the third review's Bayesian and random-forest findings +# (slice S8). The Bayesian tests replace brms::brm() and the posterior +# accessors with recorders, as test-review2-bayes-rf.R does; the one +# real-sampler test at the end is opt-in via SPATIALKIT_TEST_BRMS. + +.r3b_rf_pts <- function(n = 80, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a - d$b + rnorm(n, 0, 0.3) + d +} + +.r3b_pts <- function(n = 60, seed = 1) { + set.seed(seed) + d <- sf::st_as_sf( + data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n)), + coords = c("x", "y"), crs = 32632) + d$z <- 2 * d$a + rnorm(n) + d$cat3 <- factor(sample(c("lo", "mid", "hi"), n, TRUE), + levels = c("lo", "mid", "hi")) + d$ord3 <- factor(d$cat3, ordered = TRUE) + d +} + +# Every R warning an expression raises, muffled and returned with its value. +.r3b_warnings <- function(expr) { + ws <- character(0) + val <- withCallingHandlers(expr, warning = function(w) { + ws <<- c(ws, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + list(value = val, warnings = ws) +} + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-1: predict.rf_fit() on newdata with no complete row +# --------------------------------------------------------------------------- + +test_that("predict.rf_fit() returns all NA when every newdata row is incomplete", { + skip_if_not_installed("ranger") + d <- .r3b_rf_pts() + fit <- fit_rf_model(d, "z", c("a", "b"), num_trees = 50) + nd <- d[1:4, ] + nd$a <- NA_real_ + # It stopped with ranger's "sample_fraction too small, no observations + # sampled", from a zero-row frame. + expect_equal(predict(fit, newdata = nd), rep(NA_real_, 4)) + m <- model_metrics(fit, newdata = nd) + expect_identical(m$n, 0L) + # A failure inside ranger is still an error. + expect_error(predict(fit, d[1:4, ], type = "se"), "keep.inbag") +}) + +test_that("predict_surface() on an rf_fit survives a chunk with no complete row", { + skip_if_not_installed("ranger") + d <- .r3b_rf_pts() + fit <- fit_rf_model(d, "z", c("a", "b"), num_trees = 50) + set.seed(2) + g <- sf::st_as_sf( + data.frame(x = 5e5 + seq(0, 950, length.out = 20), y = 5e6 + 500, + a = c(rep(NA, 10), rnorm(10)), b = rnorm(20)), + coords = c("x", "y"), crs = 32632) + out <- predict_surface(fit, grid = g, chunk_size = 10) + expect_true(all(is.na(out$.pred[1:10]))) + expect_true(all(is.finite(out$.pred[11:20]))) + expect_equal(out$.pred[11:20], predict(fit, newdata = g[11:20, ])) +}) + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-6: cv_rf() says the out-of-bag gap once, not once per fold +# --------------------------------------------------------------------------- + +test_that("cv_rf() warns once about fold forests with no out-of-bag row", { + skip_if_not_installed("ranger") + d <- .r3b_rf_pts() + r <- .r3b_warnings(suppressMessages( + cv_rf(d, "z", c("a", "b"), k = 4, num_trees = 30, replace = FALSE, + sample_fraction = 1))) + # One per fold before, each ending "or score the forest with cv_rf()". + expect_length(r$warnings, 1L) + expect_match(r$warnings, + paste0("cv_rf\\(\\): no training row was out of bag for any ", + "tree in 4 of 4 fold forest\\(s\\) \\(replace = FALSE ", + "with sample_fraction = 1")) + expect_match(r$warnings, "cross-validation is unaffected") + expect_match(r$warnings, "fitted() values or permutation importance. Use", + fixed = TRUE) + expect_false(grepl("score the forest with cv_rf", r$warnings, fixed = TRUE)) + # The fold counts rode in fold_metrics and are gone again. + expect_false(any(startsWith(names(r$value$fold_metrics), "..rf_"))) + expect_identical(r$value$n_folds_succeeded, 4L) + expect_true(all(is.finite(r$value$predictions$yhat))) + + # Impurity importance does not depend on out-of-bag rows. + ri <- .r3b_warnings(suppressMessages( + cv_rf(d, "z", c("a", "b"), k = 4, num_trees = 30, replace = FALSE, + sample_fraction = 1, importance = "impurity"))) + expect_length(ri$warnings, 1L) + expect_match(ri$warnings, "has no out-of-bag error or fitted() values. Use", + fixed = TRUE) +}) + +test_that("cv_rf() counts fold forests with some rows out of no tree's bag", { + skip_if_not_installed("ranger") + d <- .r3b_rf_pts() + # Three bootstrap trees leave a quarter of the rows in every tree's sample. + r <- .r3b_warnings(suppressMessages( + cv_rf(d, "z", c("a", "b"), k = 4, num_trees = 3))) + expect_length(r$warnings, 1L) + expect_match(r$warnings, + "cv_rf\\(\\): in 4 of 4 fold forest\\(s\\) some training rows") + expect_false(any(startsWith(names(r$value$fold_metrics), "..rf_"))) + # A forest that covers every row says nothing. + expect_no_warning(suppressMessages( + cv_rf(d, "z", c("a", "b"), k = 4, num_trees = 50))) + # fit_rf_model() called directly still warns, with its own advice. + expect_warning(fit_rf_model(d, "z", c("a", "b"), num_trees = 30, + replace = FALSE, sample_fraction = 1), + "or score the forest with cv_rf\\(\\)") +}) + +test_that("cv_rf(parallel = 2) counts the folds the workers fitted", { + skip_if_not_installed("ranger") + skip_on_os("windows") + skip_on_cran() + d <- .r3b_rf_pts() + # A warning raised in a forked worker reaches the parent once per distinct + # text, so the count has to travel with the fold's result. + r <- .r3b_warnings(suppressMessages( + cv_rf(d, "z", c("a", "b"), k = 4, num_trees = 30, replace = FALSE, + sample_fraction = 1, parallel = 2))) + expect_length(r$warnings, 1L) + expect_match(r$warnings, "in 4 of 4 fold forest") +}) + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-9: print() on a forest with no out-of-bag row +# --------------------------------------------------------------------------- + +test_that("print.rf_fit() says the OOB error and importance are undefined", { + skip_if_not_installed("ranger") + d <- .r3b_rf_pts() + f0 <- suppressWarnings(fit_rf_model(d, "z", c("a", "b"), num_trees = 30, + replace = FALSE, sample_fraction = 1)) + expect_true(is.na(f0$info$oob_rmse)) + expect_true(all(is.nan(f0$info$importance))) + txt <- paste(utils::capture.output(print(f0)), collapse = "\n") + # The importance line printed empty and the OOB line was missing. + expect_match(txt, "OOB RMSE: undefined (no row is out of bag)", fixed = TRUE) + expect_match(txt, "Importance (permutation): undefined (no row is out of bag)", + fixed = TRUE) + # An ordinary forest prints its numbers as before. + f1 <- fit_rf_model(d, "z", c("a", "b"), num_trees = 50) + txt <- paste(utils::capture.output(print(f1)), collapse = "\n") + expect_match(txt, "OOB RMSE: [0-9.]+ OOB R\\^2") + expect_match(txt, "Importance \\(permutation\\): a=[-0-9.e]+, b=") +}) + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-2: the standardize_predictors slope prior keeps its dpar +# --------------------------------------------------------------------------- + +.r3b_capture_fit <- function(...) { + cap <- new.env() + local_mocked_bindings( + brm = function(...) { cap$args <- list(...); structure(list(), class = "r3b_stub") }, + .package = "brms") + fit <- fit_bayesian_spatial_model(..., compute_loo = FALSE, + check_convergence = FALSE) + list(fit = fit, args = cap$args) +} + +.r3b_validates <- function(args) { + expect_no_error(suppressWarnings(brms::validate_prior( + args$prior, formula = args$formula, data = args$data, + family = args$family))) +} + +test_that("standardize_predictors' slope prior validates for categorical and mixture fits", { + skip_if_not_installed("brms") + d <- .r3b_pts() + # brms refused both before compiling: "The following priors do not + # correspond to any model parameter: b ~ normal(0, 5)". + rc <- suppressMessages(.r3b_capture_fit( + d, "cat3", "a", family = brms::categorical(), gp_k = 5, + standardize_predictors = TRUE)) + pr <- as.data.frame(rc$args$prior) + b <- pr[pr$class == "b", ] + expect_setequal(b$dpar, c("mumid", "muhi")) + expect_true(all(b$prior == "normal(0, 5)")) + .r3b_validates(rc$args) + + rm <- suppressMessages(.r3b_capture_fit( + d, "z", "a", family = brms::mixture(stats::gaussian(), stats::gaussian()), + gp_k = 5, standardize_predictors = TRUE)) + pr <- as.data.frame(rm$args$prior) + expect_setequal(pr$dpar[pr$class == "b"], c("mu1", "mu2")) + .r3b_validates(rm$args) + + # A family with one mu keeps the single global row it always had. + rg <- suppressMessages(.r3b_capture_fit(d, "z", "a", gp_k = 5, + standardize_predictors = TRUE)) + pr <- as.data.frame(rg$args$prior) + b <- pr[pr$class == "b", ] + expect_identical(nrow(b), 1L) + expect_identical(b$dpar, "") + expect_identical(b$coef, "") + .r3b_validates(rg$args) + ro <- suppressMessages(.r3b_capture_fit(d, "ord3", "a", + family = brms::cumulative(), gp_k = 5, + standardize_predictors = TRUE)) + .r3b_validates(ro$args) +}) + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-3: cv_bayes() refuses a category family before any MCMC +# --------------------------------------------------------------------------- + +test_that("cv_bayes() refuses a categorical or ordinal family before fitting", { + skip_if_not_installed("brms") + d <- .r3b_pts() + calls <- 0L + local_mocked_bindings( + fit_bayesian_spatial_model = function(...) { + calls <<- calls + 1L + stop("mock fit 4417") + }, + .package = "spatialkit") + # Every fold used to compile and sample, and then fail its scoring. + expect_error(cv_bayes(d, "ord3", "a", k = 2, + fit_args = list(family = brms::cumulative())), + "cv_bayes\\(\\): the .cumulative. family gives a probability per response category") + expect_error(cv_bayes(d, "cat3", "a", k = 2, + fit_args = list(family = brms::categorical())), + "the .categorical. family") + expect_error(cv_bayes(d, "ord3", "a", k = 2, + fit_args = list(family = brms::acat)), + "the .acat. family") + expect_identical(calls, 0L) + + # A numeric family still reaches the fits. + suppressWarnings(suppressMessages( + cv_bayes(d, "z", "a", k = 2, fit_args = list(family = stats::poisson())))) + expect_gt(calls, 0L) +}) + + +# --------------------------------------------------------------------------- +# S8-BAYES-RF-7 and -8: what predict() says for a category family +# --------------------------------------------------------------------------- + +.r3b_category_fit <- function(d, family, resp) { + new_spatial_fit( + "bayesian_fit", + engine = structure(list(family = list(family = family)), + class = "brmsfit"), + formula = stats::as.formula(paste(resp, "~ a")), response_var = resp, + predictor_vars = "a", data_sf = d, + info = list(coord_scaling = list(x_center = 5e5, x_scale = 300, + y_center = 5e6, y_scale = 300), + # Enough for .pin_gp_boundary_rows() to append its two rows. + gp_xy_range = list(x = c(-2, 2), y = c(-2, 2)))) +} + +test_that("the per-category epred error counts the caller's rows", { + skip_if_not_installed("brms") + d <- .r3b_pts(n = 40) + fit <- .r3b_category_fit(d, "cumulative", "ord3") + seen <- integer(0) + local_mocked_bindings( + posterior_epred = function(object, newdata, ...) { + seen <<- c(seen, nrow(newdata)) + array(0.3, dim = c(20L, nrow(newdata), 3L)) + }, + .package = "brms") + err <- tryCatch(suppressMessages(predict(fit, newdata = d[1:5, ])), + error = conditionMessage) + # brms was handed the two boundary rows as well ... + expect_identical(seen, 7L) + # ... which the message counted: "20 x 7 x 3" for five rows. + expect_match(err, "returned a 20 x 5 x 3 array", fixed = TRUE) + # The hint offers what works on new rows, not posterior_epred(newdata = ), + # which the engine refuses without the scaled coordinates. + expect_match(err, "type = \"predict\", draws = TRUE", fixed = TRUE) + expect_match(err, "share of draws in each category", fixed = TRUE) + expect_false(grepl("newdata = )", err, fixed = TRUE)) +}) + +test_that("predict(type = \"predict\") without draws is refused for categorical()", { + skip_if_not_installed("brms") + d <- .r3b_pts(n = 40) + nd <- d[1:5, ] + local_mocked_bindings( + posterior_predict = function(object, newdata, ...) + matrix(rep(c(1, 3), length.out = 20L * nrow(newdata)), nrow = 20L), + .package = "brms") + cat_fit <- .r3b_category_fit(d, "categorical", "cat3") + # The mean of unordered category indices came back as a number. + expect_error(suppressMessages(predict(cat_fit, newdata = nd, type = "predict")), + "'categorical' family's categories have no order, so the mean") + expect_error(suppressMessages(predict(cat_fit, newdata = nd, type = "predict", + summary = "median")), + "so the median of the predicted category indices") + dr <- suppressMessages(predict(cat_fit, newdata = nd, type = "predict", + draws = TRUE)) + expect_true(is.matrix(dr)) + expect_identical(dim(dr), c(20L, 5L)) + # An ordinal family's mean index is an expected rank, and still returned. + ord_fit <- .r3b_category_fit(d, "cumulative", "ord3") + expect_equal(suppressMessages(predict(ord_fit, newdata = nd, type = "predict")), + rep(2, 5)) +}) + + +# --------------------------------------------------------------------------- +# Real sampler (opt-in): a standardised categorical fit samples, and its +# predict() messages count the caller's rows +# --------------------------------------------------------------------------- + +test_that("a categorical fit with standardize_predictors = TRUE samples", { + skip_on_cran() + skip_if(!nzchar(Sys.getenv("SPATIALKIT_TEST_BRMS")), + "set SPATIALKIT_TEST_BRMS=true to run the Stan tests") + skip_if_not_installed("brms") + set.seed(20240817) + n <- 40 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000); z <- rnorm(n) + resp <- 0.004 * x + 1.5 * z + rnorm(n, sd = 0.5) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z, resp = resp), + coords = c("x", "y"), crs = 32632) + pts$cat3 <- cut(pts$resp, stats::quantile(pts$resp, c(0, 1/3, 2/3, 1)), + include.lowest = TRUE, labels = c("lo", "mid", "hi")) + fit <- NULL + utils::capture.output(suppressWarnings(suppressMessages( + fit <- fit_bayesian_spatial_model(pts, "cat3", "z", + family = brms::categorical(), + standardize_predictors = TRUE, + chains = 1, iter = 300, cores = 1, + compute_loo = FALSE, seed = 1234, + gp_k = 6, check_convergence = FALSE))), + type = "output") + expect_s3_class(fit, "bayesian_fit") + expect_false(is.null(fit$info$predictor_scaling$z)) + nd <- pts[1:5, ] + expect_error(suppressMessages(predict(fit, newdata = nd)), + "returned a 150 x 5 x 3 array") + expect_error(suppressMessages(predict(fit, newdata = nd, type = "predict")), + "categories have no order") + dr <- suppressMessages(predict(fit, newdata = nd, type = "predict", + draws = TRUE)) + expect_identical(dim(dr), c(150L, 5L)) + expect_true(all(dr %in% 1:3)) +}) diff --git a/tests/testthat/test-review3-S9-aoa-plot.R b/tests/testthat/test-review3-S9-aoa-plot.R new file mode 100644 index 0000000..084a5cb --- /dev/null +++ b/tests/testthat/test-review3-S9-aoa-plot.R @@ -0,0 +1,343 @@ +# tests/testthat/test-review3-S9-aoa-plot.R +# --------------------------------------------------------------------------- +# Third review pass over the area of applicability, the prediction grid and +# the plots: rows outside on a dropped predictor that the AOA plot left out, +# a grid that did not cover the training extent, fold labels that crashed +# area_of_applicability(), a weights hint that could not work, and captions +# and subtitles that said something the data did not. +# --------------------------------------------------------------------------- + +r3_layer_geoms <- function(p) unname(vapply(p$layers, function(l) class(l$geom)[1L], character(1))) + +# 60 training rows with a zero-variance land-cover dummy, and 40 prediction +# rows of which the last 10 take a value the training data never has on it. +r3_aoa_dropped <- function(lc_new = rep(0:1, c(30, 10)), na_first = TRUE) { + set.seed(1) + train <- sf::st_as_sf(data.frame(x = runif(60), y = runif(60), a = rnorm(60), + b = rnorm(60), lc = 0), + coords = c("x", "y"), crs = 32632) + new <- sf::st_as_sf(data.frame(x = runif(40), y = runif(40), a = rnorm(40), + b = rnorm(40), lc = lc_new), + coords = c("x", "y"), crs = 32632) + if (na_first) new$a[1] <- NA + suppressWarnings(area_of_applicability(new, train_sf = train, + predictor_vars = c("a", "b", "lc"))) +} + + +# ---- plot.aoa(): DI = Inf and DI = NA rows --------------------------------- + +test_that("plot.aoa counts DI = Inf rows in the prediction curve and names them", { + skip_if_not_installed("ggplot2") + res <- r3_aoa_dropped() + n_inf <- sum(is.infinite(res$aoa$DI)) + expect_identical(n_inf, 10L) + expect_identical(res$n_na, 1L) + p <- plot(res) + b <- ggplot2::ggplot_build(p) + # The step layer stays first and grouped by set. + expect_identical(r3_layer_geoms(p)[1L], "GeomStep") + expect_equal(length(unique(b$data[[1]]$group)), 2L) + pred <- b$data[[1]][b$data[[1]]$colour == "#2166AC", ] + # Its height at the threshold is the share inside among the rows with a DI; + # the Inf rows used to be dropped, and the curve read 0.97 inside where + # the subtitle counted 11 of 40 outside. + at_thr <- max(pred$y[pred$x <= res$threshold]) + expect_equal(at_thr, res$n_inside / (res$n_new - res$n_na)) + # It tops out at the finite share, not at 1. + n_fin <- res$n_new - res$n_na - n_inf + expect_equal(max(pred$y), n_fin / (n_fin + n_inf)) + # The training curve still reaches 1. + tr <- b$data[[1]][b$data[[1]]$colour == "grey45", ] + expect_equal(max(tr$y), 1) + cap <- p$labels$caption + expect_match(cap, "10 prediction locations outside on a dropped predictor \\(DI = Inf\\) are off the axis") + expect_match(cap, "1 with a missing predictor \\(DI = NA\\) is not drawn") + expect_no_error(ggplot2::ggplot_build(plot(res, type = "histogram"))) + expect_match(plot(res, type = "histogram")$labels$caption, "DI = Inf") +}) + +test_that("plot.aoa gives the true reason when every row is outside on a dropped predictor", { + skip_if_not_installed("ggplot2") + res <- r3_aoa_dropped(lc_new = rep(1, 40), na_first = FALSE) + expect_true(all(is.infinite(res$aoa$DI))) + expect_error(plot(res), "40 of 40 prediction locations are outside on a predictor dropped") + expect_error(plot(res), "DI = Inf") + expect_false(tryCatch(plot(res), error = function(e) + grepl("missing or non-finite predictor", conditionMessage(e)))) +}) + +test_that("plot.aoa draws no DI = Inf or NA caption lines when there are none", { + skip_if_not_installed("ggplot2") + res <- r3_aoa_dropped(lc_new = rep(0, 40), na_first = FALSE) + p <- plot(res) + expect_false(grepl("DI = Inf|DI = NA", p$labels$caption)) + pred <- ggplot2::ggplot_build(p)$data[[1]] + expect_equal(max(pred$y[pred$colour == "#2166AC"]), 1) +}) + + +# ---- plot.aoa(): the fold line of the caption -------------------------------- + +test_that("plot.aoa's caption reads correctly for every kind of fold input", { + skip_if_not_installed("ggplot2") + set.seed(2); n <- 120 + train <- sf::st_as_sf(data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + new <- train[1:20, ] + aoa_with <- function(folds) area_of_applicability(new, train_sf = train, + predictor_vars = c("a", "b"), + folds = folds) + # No folds: the threshold is small and the AOA conservative, as + # ?area_of_applicability says; the caption called it optimistic. + cap0 <- plot(aoa_with(NULL))$labels$caption + expect_match(cap0, "not cross-validated") + expect_match(cap0, "conservative") + expect_false(grepl("optimistic", cap0)) + # Labels and bare splits read "over from fold labels; method unknown folds". + cap_l <- plot(aoa_with(rep(1:4, 30)))$labels$caption + expect_match(cap_l, "cross-validated over folds given as labels \\(method unknown\\)") + f <- make_folds(train, k = 4, method = "block_kfold", block_size = 300, seed = 1) + cap_s <- plot(aoa_with(f$folds))$labels$caption + expect_match(cap_s, "cross-validated over folds given as train/test splits \\(method unknown\\)") + for (cap in c(cap_l, cap_s)) expect_false(grepl("over from|unknown folds", cap)) + expect_match(plot(aoa_with(f))$labels$caption, "cross-validated over block_kfold folds") +}) + + +# ---- area_of_applicability(): fold labels and weights ------------------------ + +test_that("numeric fold labels that print alike are grouped as cv_*() groups them", { + set.seed(3); n <- 40 + tr <- sf::st_as_sf(data.frame(x = runif(n), y = runif(n), a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + # 0.3 and 0.1 + 0.2 differ in the last bits and print alike: one fold in + # cv_*(); area_of_applicability() stopped with "factor level [2] is + # duplicated". + lab <- rep(c(0.3, 0.1 + 0.2, 0.5, 0.7), each = 10) + expect_false(identical(0.3, 0.1 + 0.2)) + expect_no_error(res <- area_of_applicability(tr[1:5, ], train_sf = tr, + predictor_vars = c("a", "b"), + folds = lab)) + expect_identical(res$params$n_folds, 3L) + tests_of <- function(sp) lapply(sp, `[[`, "test") + aoa_sp <- spatialkit:::.aoa_fold_splits(lab, n) + cv_sp <- spatialkit:::.folds_from_labels(lab, data.frame(..row_id = seq_len(n)), + "cv_spatial") + expect_identical(tests_of(aoa_sp), tests_of(cv_sp)) + expect_identical(tests_of(aoa_sp), list(1:20, 21:30, 31:40)) + # The refusals are unchanged. + expect_error(spatialkit:::.aoa_fold_splits(c(1, NA, 2, 2), 4), + "area_of_applicability\\(\\): `folds` contains missing labels") + expect_error(spatialkit:::.aoa_fold_splits(rep(1, 4), 4), + "area_of_applicability\\(\\): `folds` must define at least two") + expect_error(spatialkit:::.aoa_fold_splits(1:3, 4), "has 3 labels but the training data has 4 rows") +}) + +test_that("a NaN weight is refused with its cause, not with the pmax() advice", { + set.seed(4); n <- 40 + tr <- sf::st_as_sf(data.frame(x = runif(n), y = runif(n), a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + aoa_w <- function(w) area_of_applicability(tr[1:5, ], train_sf = tr, + predictor_vars = c("a", "b"), weights = w) + # pmax(NaN, 0) is NaN, so the advice reproduced the error it came with. + expect_error(aoa_w(c(a = NaN, b = 1)), "`weights` is NaN for .a.\\. .*no row is out of bag") + expect_error(aoa_w(c(a = NaN, b = 1)), "weights = NULL") + err <- tryCatch(aoa_w(c(a = NaN, b = 1)), error = conditionMessage) + expect_false(grepl("so pass pmax\\(importance, 0\\)", err)) + # Inf and NA are named without the out-of-bag story. + err_inf <- tryCatch(aoa_w(c(a = 1, b = Inf)), error = conditionMessage) + expect_match(err_inf, "`weights` is not finite for .b.\\.$") + expect_match(tryCatch(aoa_w(c(a = NA, b = 1)), error = conditionMessage), + "`weights` is not finite for .a.") + # A negative weight keeps the advice that works for it. + expect_error(aoa_w(c(a = -0.1, b = 1)), "pmax\\(importance, 0\\)") +}) + +test_that("the NaN importance of a forest with no out-of-bag rows gets the NaN message", { + skip_if_not_installed("ranger") + set.seed(1); n <- 60 + tr <- sf::st_as_sf(data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000), + a = rnorm(n), b = rnorm(n)), + coords = c("x", "y"), crs = 32632) + tr$z <- tr$a + rnorm(n) + fit <- suppressWarnings(suppressMessages( + fit_rf_model(tr, "z", c("a", "b"), num_trees = 20, seed = 1, + replace = FALSE, sample_fraction = 1))) + w <- pmax(fit$info$importance, 0) + expect_true(all(is.nan(w))) + expect_error(area_of_applicability(tr, model = fit, weights = w), + "is NaN for .a., .b.\\. Permutation importance is NaN when no row is out of bag") +}) + + +# ---- predict_surface(): the grid covers the training extent ------------------ + +test_that("the automatic grid covers every training point and is centred on the box", { + pts <- surf_test_points(n = 120) + fit <- lm_spatial_fit(pts) + bb <- sf::st_bbox(pts) + P <- sf::st_coordinates(pts) + for (cs in c(100, 334, 77.7)) { + g <- predict_surface(fit, cell_size = cs, covariates = pts) + xy <- sf::st_coordinates(g) + ux <- sort(unique(xy[, 1])); uy <- sort(unique(xy[, 2])) + # floor() cells from xmin left up to a cell uncovered on the east and + # north: 14 of 120 training points in no cell at cell_size = 100. + inside <- P[, 1] >= min(ux) - cs / 2 & P[, 1] <= max(ux) + cs / 2 & + P[, 2] >= min(uy) - cs / 2 & P[, 2] <= max(uy) + cs / 2 + expect_true(all(inside), label = sprintf("cell_size %s", cs)) + # Symmetric about the box, every centre inside it, spacing exact. + expect_equal(min(ux) - bb[["xmin"]], bb[["xmax"]] - max(ux), tolerance = 1e-8) + expect_equal(min(uy) - bb[["ymin"]], bb[["ymax"]] - max(uy), tolerance = 1e-8) + expect_gt(min(ux), bb[["xmin"]]); expect_lt(max(ux), bb[["xmax"]]) + expect_true(all(abs(diff(ux) - cs) < 1e-6)) + # The overhang is less than one cell. + expect_lt(length(ux) * cs - (bb[["xmax"]] - bb[["xmin"]]), cs) + } + # An exact multiple gains no column: 1000 / 100 is 10, 0.3 / 0.1 is 3. + grid_fn <- spatialkit:::.make_prediction_grid + crs <- sf::st_crs(32632) + bb1 <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 1000, ymax = 500), crs = crs) + g1 <- grid_fn(bb1, crs, cell_size = 100) + expect_equal(sort(unique(g1$..grid_x)), seq(50, 950, by = 100)) + expect_equal(sort(unique(g1$..grid_y)), seq(50, 450, by = 100)) + bb2 <- sf::st_bbox(c(xmin = 0, ymin = 0, xmax = 0.3, ymax = 0.3), crs = crs) + expect_identical(length(unique(grid_fn(bb2, crs, cell_size = 0.1)$..grid_x)), 3L) +}) + + +# ---- plot_folds(): the unit in the subtitle --------------------------------- + +test_that("plot_folds' subtitle gives the CRS's linear unit, not its identifier", { + skip_if_not_installed("ggplot2") + set.seed(1); n <- 80 + xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) + p4 <- "+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=500000 +y_0=0 +ellps=GRS80 +units=m +no_defs" + pts_p4 <- sf::st_as_sf(xy, coords = c("x", "y"), crs = p4) + pts_wkt <- sf::st_set_crs(sf::st_set_crs(pts_p4, NA), sf::st_crs(sf::st_crs(pts_p4)$wkt)) + pts_epsg <- sf::st_as_sf(xy, coords = c("x", "y"), crs = 32632) + sub_of <- function(pts, ...) { + f <- suppressWarnings(make_folds(pts, seed = 1, ...)) + plot_folds(f, pts)$labels$subtitle + } + # The proj string, the whole ~1300-character WKT, or "EPSG:32632 units". + for (pts in list(pts_p4, pts_wkt, pts_epsg)) { + sub <- sub_of(pts, k = 5, method = "block_kfold", block_size = 300) + expect_match(sub, "^Block size 300 \\(metre\\)\n") + expect_lt(nchar(sub), 120) + } + expect_identical(sub_of(pts_epsg, method = "buffered_loo", buffer = 100), + "Leave-one-out with a 100 buffer (metre)") +}) + + +# ---- plot_tessellation_map(): labels ---------------------------------------- + +test_that("plot_tessellation_map labels lon/lat cells quietly and draws a units label", { + skip_if_not_installed("ggplot2") + set.seed(1) + pts <- sf::st_as_sf(data.frame(x = 5e5 + runif(40, 0, 1000), y = 5e6 + runif(40, 0, 1000)), + coords = c("x", "y"), crs = 32632) + cells <- build_tessellation(pts, method = "voronoi", quiet = TRUE)$cells + # geom_sf_text() ran st_point_on_surface() again on the label points at + # print, which warned for every lon/lat layer. + p_ll <- plot_tessellation_map(sf::st_transform(cells, 4326), labels = TRUE) + expect_no_warning(b_ll <- ggplot2::ggplot_build(p_ll)) + txt <- b_ll$data[[which(r3_layer_geoms(p_ll) == "GeomText")]] + expect_equal(nrow(txt), nrow(cells)) + # An st_area() label failed at print: "units package is not attached". + cells$area <- sf::st_area(cells) + p_u <- plot_tessellation_map(cells, labels = TRUE, label_col = "area") + expect_no_error(b_u <- ggplot2::ggplot_build(p_u)) + lab <- b_u$data[[which(r3_layer_geoms(p_u) == "GeomText")]]$label + expect_true(all(grepl("\\[m\\^2\\]$", lab))) + cells$lag <- as.difftime(seq_len(nrow(cells)), units = "days") + p_d <- plot_tessellation_map(cells, labels = TRUE, label_col = "lag") + expect_no_error(ggplot2::ggplot_build(p_d)) + # A vector of names is refused by name, not with R's coercion error. + expect_error(plot_tessellation_map(cells, fill_col = c("area", "cell_id")), + "`fill_col` must be a single column name") + expect_error(plot_tessellation_map(cells, labels = TRUE, label_col = c("area", "cell_id")), + "`label_col` must be a single column name") + expect_error(plot_tessellation_map(cells, fill_col = NA_character_), + "`fill_col` must be a single column name") +}) + + +# ---- plot_cv_metrics(): counts and unnamed models ------------------------------ + +test_that("plot_cv_metrics draws no pooled line for a count column", { + skip_if_not_installed("ggplot2") + # overall$n_pred is the total over the folds: the line sat at 150 against + # folds of 30. + cv <- list( + fold_metrics = data.frame(fold = 1:5, n_pred = c(30, 30, 32, 28, 30), + RMSE = c(1, 1.2, 0.9, 1.1, 1), n_MAPE = c(30, 30, 32, 28, 30)), + overall = data.frame(RMSE = 1.04, n_pred = 150L, n_MAPE = 150L)) + for (m in c("n_pred", "n_MAPE")) { + p <- plot_cv_metrics(cv, m) + expect_false("GeomHline" %in% r3_layer_geoms(p)) + expect_match(p$labels$caption, sprintf("No pooled value: `%s` is a count per fold; `overall` holds the total", m)) + expect_no_error(ggplot2::ggplot_build(p)) + } + # RMSE is unchanged. + b <- ggplot2::ggplot_build(p <- plot_cv_metrics(cv, "RMSE")) + expect_equal(b$data[[which(r3_layer_geoms(p) == "GeomHline")]]$yintercept, 1.04) +}) + +test_that("plot_cv_metrics names a model with no per-fold values and keeps the survivor's strip", { + skip_if_not_installed("ggplot2") + # RF's bandwidth is NA in every fold and in `overall`; it vanished + # unmentioned, and with one model left no strip said which one was drawn. + cmp <- list( + by_fold = data.frame(model = rep(c("GWR", "RF"), each = 3), fold = rep(1:3, 2), + bandwidth = c(40, 42, 41, NA, NA, NA), n_pred = 25, + stringsAsFactors = FALSE), + overall = data.frame(model = c("GWR", "RF"), RMSE = c(1.8, 1.7), + stringsAsFactors = FALSE)) + p <- plot_cv_metrics(cmp, "bandwidth") + expect_match(p$labels$caption, "No pooled value") + expect_match(p$labels$caption, "Not drawn: RF \\(no finite per-fold `bandwidth`\\)") + expect_s3_class(p$facet, "FacetWrap") + b <- ggplot2::ggplot_build(p) + expect_identical(as.character(b$layout$layout$model), "GWR") + # A single cv_*() result still has no strip. + cv <- list(fold_metrics = data.frame(fold = 1:3, RMSE = c(1, 2, 3)), + overall = data.frame(RMSE = 2)) + expect_false(inherits(plot_cv_metrics(cv, "RMSE")$facet, "FacetWrap")) +}) + + +# ---- plot.spatial_fit(type = "variogram"): the no-range clause ---------------- + +test_that("the overlay caption says no range was identified, and why for the response", { + skip_if_not_installed("ggplot2") + skip_if_not_installed("gstat") + set.seed(5); n <- 120 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 80) + diag(1e-4, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 3857) + sac <- estimate_sac_range(pts, "z") + skip_if_not(is.finite(sac)) + no_range <- function(s, reason) { + s[1L] <- NA_real_ + attr(s, "rejected_reason") <- reason + s + } + draw <- function(main, ov) .draw_sac_variogram(main, what = "Residual variogram", + overlay = ov, overlay_label = "Response (z)") + cap <- function(p) gsub("\n", " ", p$labels$caption) + # A non-converged response fit was captioned as "reached no identified + # sill", as if the curve were still rising. + c1 <- cap(draw(sac, no_range(sac, "variogram model did not converge"))) + expect_match(c1, "Sills not compared: the response variogram has no identified range \\(variogram model did not converge\\)") + expect_false(grepl("reached no", c1)) + c2 <- cap(draw(no_range(sac, NULL), sac)) + expect_match(c2, "Sills not compared: the residual variogram has no identified range\\.") + c3 <- cap(draw(no_range(sac, NULL), + no_range(sac, "empirical variogram decreases with distance"))) + expect_match(c3, "neither variogram has an identified range \\(response: empirical variogram decreases with distance\\)") +}) diff --git a/tests/testthat/test-review3-final-A.R b/tests/testthat/test-review3-final-A.R new file mode 100644 index 0000000..2426101 --- /dev/null +++ b/tests/testthat/test-review3-final-A.R @@ -0,0 +1,281 @@ +# tests/testthat/test-review3-final-A.R +# --------------------------------------------------------------------------- +# Third review, final pass: folds for area_of_applicability() after +# prep_model_data() removed rows, and their provenance; a boundary without a +# CRS in make_folds(), cv_*() and predict_surface(); a `sac` that is a bare +# range in resolution_profile() and summarize_by_cell(); and cross-validation +# cautions raised with .warn_and_log() instead of a log line and a warning. +# --------------------------------------------------------------------------- + +# 120 points on a 1 km square with a response, two predictors and a spatial +# trend, in a projected CRS. +.fa_pts <- function(n = 120, seed = 3) { + set.seed(seed) + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + a <- rnorm(n); b <- rnorm(n) + sf::st_as_sf(data.frame(x = x, y = y, a = a, b = b, + z = a + 0.002 * x + rnorm(n, 0, 0.3)), + coords = c("x", "y"), crs = 32632) +} + +# Conditions an expression raises, muffled: warning messages and classes, and +# the number of messages. +.fa_conditions <- function(expr) { + w_msg <- character(0); w_cls <- list(); n_msg <- 0L + val <- withCallingHandlers(expr, + warning = function(w) { + w_msg <<- c(w_msg, conditionMessage(w)) + w_cls <<- c(w_cls, list(class(w))) + invokeRestart("muffleWarning") + }, + message = function(m) { + n_msg <<- n_msg + 1L + invokeRestart("muffleMessage") + }) + list(value = val, warnings = w_msg, classes = w_cls, messages = n_msg) +} + +.fa_quiet <- function(expr) { + logger::with_log_threshold(expr, threshold = logger::FATAL, + namespace = "spatialkit", index = 2) +} + + +# --- area_of_applicability(): folds after prep_model_data() dropped rows ---- + +test_that("area_of_applicability() takes the folds cv_*() takes when prep_model_data() dropped a row", { + pts <- .fa_pts() + pts$z[50] <- NA + folds <- make_folds(pts, k = 4, method = "block_kfold", seed = 1) + prep <- .fa_quiet(prep_model_data(pts, "z", c("a", "b"))) + expect_identical(nrow(prep), 119L) + fit <- lm_spatial_fit(prep, "z", c("a", "b")) + new <- pts[1:5, ] + + # It stopped with "fold 1 refers to rows outside 1:119" -- for the folds + # cv_*() accepts on the same layer. + lines <- capture_spatialkit_log( + res <- area_of_applicability(new, model = fit, folds = folds)) + expect_true(log_has(lines, "name 1 row\\(s\\) that prep_model_data\\(\\) removed")) + + # The same threshold as the folds with that row taken out by hand, as + # positions in the model's training data. + kept <- setdiff(seq_len(nrow(pts)), 50L) + by_hand <- lapply(folds$folds, function(s) + list(train = match(setdiff(s$train, 50L), kept), + test = match(setdiff(s$test, 50L), kept))) + ref <- area_of_applicability(new, model = fit, folds = by_hand) + expect_equal(res$threshold, ref$threshold) + expect_equal(res$train_DI, ref$train_DI) + + # A label vector with one label per row of the layer fitted from. + lab <- area_of_applicability(new, model = fit, folds = folds$assignment$fold) + expect_equal(lab$threshold, ref$threshold) + # The bare splits, which name row 120, past the 119 training rows. + bare <- area_of_applicability(new, model = fit, folds = folds$folds) + expect_equal(bare$threshold, ref$threshold) + + # Folds built on the model's own training data are positions in it, and + # are still read that way: the same threshold as on the layer without its + # record, which `[` removes. + f_own <- make_folds(prep, k = 4, method = "block_kfold", seed = 1) + own <- area_of_applicability(new, model = fit, folds = f_own) + plain <- prep[seq_len(nrow(prep)), ] + expect_null(attr(plain, "dropped")) + expect_equal(own$threshold, + area_of_applicability(new, train_sf = plain, + predictor_vars = c("a", "b"), + folds = f_own)$threshold) + + # The layer's own ..row_id is honoured the same way. + p2 <- pts + p2$..row_id <- 1000L + seq_len(nrow(p2)) + f2 <- make_folds(p2, k = 4, method = "block_kfold", seed = 1) + fit2 <- lm_spatial_fit(.fa_quiet(prep_model_data(p2, "z", c("a", "b"))), + "z", c("a", "b")) + expect_equal(area_of_applicability(new, model = fit2, folds = f2)$threshold, + ref$threshold) +}) + +test_that("a fold ID naming a row the data never had is still refused", { + pts <- .fa_pts() + pts$z[50] <- NA + folds <- make_folds(pts, k = 4, method = "block_kfold", seed = 1) + fit <- lm_spatial_fit(.fa_quiet(prep_model_data(pts, "z", c("a", "b"))), + "z", c("a", "b")) + folds$folds[[1]]$test <- c(folds$folds[[1]]$test, 999L) + expect_error(area_of_applicability(pts[1:5, ], model = fit, folds = folds), + "names 1 ..row_id value\\(s\\) that are not in the training data \\(first: 999\\)") +}) + +test_that("area_of_applicability() refuses folds built on other rows, as cv_*() do", { + pts <- .fa_pts() + prep <- .fa_quiet(prep_model_data(pts, "z", c("a", "b"))) + fb <- make_folds(prep, k = 4, method = "block_kfold", seed = 1) + ok <- area_of_applicability(prep[1:5, ], + model = lm_spatial_fit(prep, "z", c("a", "b")), + folds = fb) + expect_true(is.finite(ok$threshold)) + # The same rows in another order: every fold ID now names another point. + sorted <- prep[order(prep$z), ] + expect_error( + area_of_applicability(prep[1:5, ], + model = lm_spatial_fit(sorted, "z", c("a", "b")), + folds = fb), + "built from different data") + # A bare list of splits carries no probe and is read as positions, as before. + expect_no_error( + area_of_applicability(prep[1:5, ], + model = lm_spatial_fit(sorted, "z", c("a", "b")), + folds = fb$folds)) +}) + +test_that("folds built on polygons still apply to a fit on the points they were reduced to", { + pts <- .fa_pts() + polys <- sf::st_sf(sf::st_drop_geometry(pts), + geometry = sf::st_geometry(sf::st_buffer(pts, 10))) + f_poly <- make_folds(polys, k = 4, method = "block_kfold", seed = 1) + prep <- .fa_quiet(prep_model_data(polys, "z", c("a", "b"))) + expect_true(all(sf::st_geometry_type(prep) == "POINT")) + fit <- lm_spatial_fit(prep, "z", c("a", "b")) + lines <- capture_spatialkit_log( + res <- area_of_applicability(prep[1:5, ], model = fit, folds = f_poly)) + expect_true(is.finite(res$threshold)) + expect_true(log_has(lines, "skipping the provenance check")) +}) + + +# --- a boundary without a CRS ------------------------------------------------ + +test_that("make_folds() warns about a CRS-less boundary, prediction_points and blocks, naming them", { + pts <- .fa_pts() + bnd <- sf::st_set_crs(sf::st_as_sf(sf::st_as_sfc(sf::st_bbox(pts))), NA) + # Named by the function and the argument, and the CRS stamped by its label: + # "the supplied `crs`" named an argument make_folds() does not have. + expect_warning( + f <- .fa_quiet(make_folds(pts, k = 4, method = "block_kfold", seed = 1, + boundary = bnd)), + "make_folds\\(\\): `boundary` has no CRS.*stamping the target CRS \\('EPSG:32632'\\) WITHOUT reprojection") + ref <- make_folds(pts, k = 4, method = "block_kfold", seed = 1, + boundary = sf::st_set_crs(bnd, 32632)) + expect_identical(f$assignment$fold, ref$assignment$fold) + + blk <- sf::st_set_crs(sf::st_make_grid(bnd, n = c(3, 3)), NA) + expect_warning( + .fa_quiet(make_folds(pts, k = 4, method = "block_kfold", seed = 1, + blocks = sf::st_sf(geometry = blk))), + "make_folds\\(\\): `blocks` has no CRS") + + grid <- sf::st_set_crs(sf::st_as_sf(sf::st_sample(sf::st_as_sfc(sf::st_bbox(pts)), + 64, type = "regular")), NA) + expect_warning( + .fa_quiet(make_folds(pts[1:60, ], method = "nndm", prediction_points = grid)), + "make_folds\\(\\): `prediction_points` has no CRS") +}) + +test_that("cv_*() warn once about a CRS-less lon/lat boundary, naming the caller", { + pts <- .fa_pts() + bll <- sf::st_set_crs(sf::st_transform( + sf::st_as_sf(sf::st_buffer(sf::st_as_sfc(sf::st_bbox(pts)), 50)), 4326), NA) + # prep_model_data() and make_folds() each warned about it, and neither + # named cv_spatial() or `boundary`. + res <- .fa_conditions(.fa_quiet( + cv_spatial(pts, "z", "a", fit_fn = function(tr) lm_spatial_fit(tr, "z", "a"), + k = 3, boundary = bll))) + expect_length(res$warnings, 1L) + expect_match(res$warnings, "^cv_spatial\\(\\): `boundary` has no CRS; its coordinates look like lon/lat") + expect_identical(res$value$overall$n_pred, nrow(pts)) + + # A planar one is stamped with the data's CRS, with one warning naming the + # caller rather than make_folds(). + bnd <- sf::st_set_crs(sf::st_as_sf(sf::st_as_sfc(sf::st_bbox(pts))), NA) + res <- .fa_conditions(.fa_quiet( + cv_spatial(pts, "z", "a", fit_fn = function(tr) lm_spatial_fit(tr, "z", "a"), + k = 3, boundary = bnd))) + expect_length(res$warnings, 1L) + expect_match(res$warnings, "^cv_spatial\\(\\): `boundary` has no CRS and its coordinates do not look like lon/lat") +}) + +test_that("predict_surface() warns about a CRS-less boundary, naming it", { + pts <- surf_test_points(n = 60) + fit <- lm_spatial_fit(pts, "z", "w") + bnd <- sf::st_set_crs(sf::st_as_sfc(sf::st_bbox(pts)), NA) + expect_warning( + g <- .fa_quiet(predict_surface(fit, n_cells = 100, covariates = pts, + boundary = bnd)), + "predict_surface\\(\\): `boundary` has no CRS") + expect_gt(nrow(g), 0L) +}) + + +# --- `sac` as a bare range --------------------------------------------------- + +test_that("resolution_profile() refuses a units `sac` and a character one by name", { + skip_if_not_installed("units") + pts <- .fa_pts() + # set_units(1.5, "km") was read as a range of 1.5 m: a floor of millions of + # cells, with nothing said. + expect_error(resolution_profile(pts, "z", sac = units::set_units(1.5, "km"), + n_levels = 4), + "`sac` must be an estimate_sac_range\\(\\) result.*got 1\\.5 \\[km\\]") + expect_error(resolution_profile(pts, "z", sac = "300", n_levels = 4), + "got an object of class character") +}) + +test_that("summarize_by_cell() says so when a `sac` without a model is set aside", { + pts <- .fa_pts() + pts$poly_id <- rep(1:6, each = 20) + # With no response to estimate a variogram from, the fallback warning names + # the value that could not be used. + res <- .fa_conditions(.fa_quiet( + summarize_by_cell(pts, deff = "variogram", sac = 300))) + expect_length(res$warnings, 1L) + expect_true("spatialkit_deff_fallback" %in% res$classes[[1L]]) + expect_match(res$warnings, "supplied `sac` \\(300\\) carries no fitted variogram model") + + skip_if_not_installed("gstat") + # With one, the value was ignored and a variogram estimated without a word. + res <- .fa_conditions(.fa_quiet( + summarize_by_cell(pts, "z", deff = "variogram", sac = 300))) + hit <- grepl("supplied `sac` \\(300\\) carries no fitted variogram model", res$warnings) + expect_identical(sum(hit), 1L) + expect_match(res$warnings[hit], "It was set aside, and the design effect uses the variogram estimated from `response_var` instead") + expect_false("spatialkit_deff_fallback" %in% res$classes[[which(hit)]]) +}) + + +# --- cautions raised once ---------------------------------------------------- + +test_that("make_folds() cautions are logged and raised with the same text, once under knitr", { + old <- spatialkit_quiet(FALSE) + withr::defer(spatialkit_quiet(old)) + pts <- .fa_pts() + lines <- capture_spatialkit_log( + expect_warning(make_folds(pts, k = 4, method = "block_kfold", seed = 1, + auto_range = TRUE), + "make_folds(): auto_range requires response_var; ignoring.", + fixed = TRUE)) + expect_true(log_has(lines, "auto_range requires response_var; ignoring")) + + withr::local_options(knitr.in.progress = TRUE) + res <- .fa_conditions(utils::capture.output( + f <- make_folds(pts, k = 4, method = "block_kfold", seed = 1, + auto_range = TRUE), + type = "message")) + expect_identical(res$messages, 0L) + expect_length(res$warnings, 1L) +}) + +test_that("an all-failed cross-validation logs the text it warns with", { + pts <- .fa_pts() + fails <- function(tr) stop("no fit here") + lines <- capture_spatialkit_log( + expect_warning(suppressMessages(cv_spatial(pts, "z", "a", fit_fn = fails, k = 3)), + paste0("cv_spatial(): all folds failed (all 3 folds failed to ", + "produce predictions); cross-validation results ", + "contain no predictions. First error:"), + fixed = TRUE)) + expect_true(log_has(lines, paste0("cv_spatial\\(\\): all folds failed \\(all 3 folds ", + "failed to produce predictions\\); cross-validation ", + "results contain no predictions\\. First error:"))) +}) diff --git a/tests/testthat/test-review3-final-B.R b/tests/testthat/test-review3-final-B.R new file mode 100644 index 0000000..2f25f63 --- /dev/null +++ b/tests/testthat/test-review3-final-B.R @@ -0,0 +1,195 @@ +# tests/testthat/test-review3-final-B.R +# --------------------------------------------------------------------------- +# Third review round, final pass B: fold provenance in fold_separation() and +# kriging_adequacy(), non-finite rows and the reasons for an early NA in +# estimate_sac_range(), fold_separation()'s print(), and the NaN-importance +# note in fit_rf_model(). Each test fails on the code before the fix, +# except the one that pins the polygon workflow the new provenance check must +# leave working. Helpers are in helper-review2-folds.R. +# --------------------------------------------------------------------------- + +rfb_collect_warnings <- function(expr) { + w <- character(0) + val <- withCallingHandlers(expr, warning = function(cnd) { + w <<- c(w, conditionMessage(cnd)); invokeRestart("muffleWarning") + }) + list(value = val, warnings = w) +} + +# A small exponential field with a smooth covariate, so both the OLS and the +# REML detrending have something to remove. +rfb_field <- function(n = 80, seed = 3) { + set.seed(seed) + x <- 5e5 + runif(n, 0, 1000); y <- 5e6 + runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + cv <- as.numeric(t(chol(exp(-d / 300) + diag(1e-6, n))) %*% rnorm(n)) + e <- as.numeric(t(chol(exp(-d / 100) + diag(0.1, n))) %*% rnorm(n)) + r2_pts(x, y, cv = cv, z = 1 + 2 * cv + e) +} + + +# ---- S11-contracts-2: folds from another layer are refused ----------------- + +test_that("fold_separation() refuses folds whose rows sit elsewhere in data_sf", { + set.seed(1) + p <- r2_pts(runif(60, 0, 1000), runif(60, 0, 1000)) + f <- make_folds(p, k = 3, method = "random_kfold", seed = 1) + # One row fewer: by position every later row is its neighbour's. + expect_error(fold_separation(f, p[-5, ], sac = 200), + "fold_separation\\(\\): the supplied `folds` were built from different data") + # The layer the folds were built on, in another CRS, is the same layer. + expect_s3_class(fold_separation(f, sf::st_transform(p, 3857)), "fold_separation") + # A bare split list carries no probe and is measured as before. + expect_s3_class(fold_separation(f$folds, p[-5, ]), "fold_separation") +}) + +test_that("fold_separation() skips the location check across POINT and non-POINT", { + # Triangles: the point coerce_to_points() gives one is not its centroid, + # which is what the probe records, so without the skip the pointized copy + # of the layer the folds were built on was refused. + tri <- sf::st_sf(geometry = sf::st_sfc(unlist(lapply(0:5, function(i) lapply(0:5, function(j) { + x <- 20 * i; y <- 20 * j + sf::st_polygon(list(rbind(c(x, y), c(x + 10, y), c(x, y + 10), c(x, y)))) + })), recursive = FALSE), crs = 32632)) + f <- make_folds(tri, k = 3, method = "random_kfold", seed = 1) + pt <- coerce_to_points(tri, "auto") + s_pt <- fold_separation(f, pt) + expect_equal(s_pt$min_dist, fold_separation(f, tri)$min_dist) +}) + +test_that("kriging_adequacy() refuses folds built before assignment dropped points", { + skip_if_not_installed("gstat") + set.seed(2) + n <- 80 + pts <- r2_pts(5e5 + runif(n, 0, 1000), 5e6 + runif(n, 0, 1000), z = rnorm(n)) + bnd <- sf::st_sf(geometry = sf::st_as_sfc(sf::st_bbox( + c(xmin = 5e5 + 100, ymin = 5e6 + 100, xmax = 5e5 + 1000, ymax = 5e6 + 1000), + crs = 32632))) + cells <- create_grid_polygons(bnd, target_cells = 9, type = "square") + asg <- suppressWarnings(assign_features_to_polygons(pts, cells)) + expect_lt(nrow(asg), nrow(pts)) + f <- make_folds(pts, k = 3, method = "random_kfold", seed = 1) + expect_error(kriging_adequacy(asg, "z", cells, folds = f), + "kriging_adequacy\\(\\): the supplied `folds` were built from different data") +}) + + +# ---- S11-contracts-4: non-finite rows are left out of the detrending ------- + +test_that("one Inf predictor or response leaves the row out instead of the detrending", { + skip_if_not_installed("gstat") + p <- rfb_field() + p_na <- p; p_na$cv[5] <- NA + p_inf <- p; p_inf$cv[5] <- Inf + p_yinf <- p; p_yinf$z[5] <- Inf + r_na <- estimate_sac_range(p_na, "z", predictor_vars = "cv") + expect_true(is.finite(r_na)) + expect_true(attr(r_na, "detrended")) + expect_no_warning(r_inf <- estimate_sac_range(p_inf, "z", predictor_vars = "cv")) + expect_true(attr(r_inf, "detrended")) + expect_identical(attr(r_inf, "detrend_method"), "ols") + expect_equal(as.numeric(r_inf), as.numeric(r_na)) + expect_no_warning(r_yinf <- estimate_sac_range(p_yinf, "z", predictor_vars = "cv")) + expect_true(attr(r_yinf, "detrended")) + expect_equal(as.numeric(r_yinf), as.numeric(r_na)) +}) + +test_that("a -Inf predictor under detrend = 'reml' is left out, not 'did not converge'", { + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + p <- rfb_field() + p_na <- p; p_na$cv[5] <- NA + p_inf <- p; p_inf$cv[5] <- -Inf + r_na <- estimate_sac_range(p_na, "z", predictor_vars = "cv", detrend = "reml") + expect_identical(attr(r_na, "detrend_method"), "reml") + expect_no_warning(r_inf <- estimate_sac_range(p_inf, "z", predictor_vars = "cv", + detrend = "reml")) + expect_identical(attr(r_inf, "detrend_method"), "reml") + expect_equal(as.numeric(r_inf), as.numeric(r_na)) +}) + + +# ---- S5-FOLDS-9: an early NA says why --------------------------------------- + +test_that("estimate_sac_range()'s early NA returns carry a rejected_reason and nothing else", { + skip_if_not_installed("gstat") + reason_of <- function(r) { + r <- r2_quiet(r) + expect_true(is.na(r)) + expect_false(inherits(r, "sac_range")) + expect_identical(names(attributes(r)), "rejected_reason") + attr(r, "rejected_reason") + } + set.seed(1) + p20 <- r2_pts(5e5 + runif(20, 0, 1000), 5e6 + runif(20, 0, 1000), z = rnorm(20)) + expect_identical(reason_of(estimate_sac_range(p20, "z")), + "20 points, fewer than the 30 a variogram range is estimated from") + + p <- rfb_field(n = 60) + pc <- p; pc$z <- 3 + expect_identical(reason_of(estimate_sac_range(pc, "z")), "the response is constant") + pe <- p; pe$z <- 2 * pe$cv + 1 # the predictor explains it exactly + expect_match(reason_of(estimate_sac_range(pe, "z", predictor_vars = "cv")), + "^the residuals on predictor_vars are constant") + pf <- p; pf$z[1:40] <- NA + expect_identical(reason_of(estimate_sac_range(pf, "z")), + paste0("20 point(s) with a finite value to model, fewer than ", + "the 30 a variogram range is estimated from")) + ps <- r2_pts(rep(5e5, 40), rep(5e6, 40), z = rnorm(40)) + expect_match(reason_of(estimate_sac_range(ps, "z")), "^the points have no extent") + + # make_folds(auto_range = TRUE) names it in its warning. + res <- rfb_collect_warnings(r2_quiet(make_folds( + pf, k = 3, method = "block_kfold", auto_range = TRUE, response_var = "z", seed = 1))) + expect_true(any(grepl("no autocorrelation range was identified (20 point(s) with a finite value", + res$warnings, fixed = TRUE))) +}) + + +# ---- S11-contracts-7: the verdict fits the fold scheme ---------------------- + +test_that("fold_separation()'s verdict names a remedy the fold scheme has", { + adv <- spatialkit:::.fold_separation_advice + expect_match(adv("block_kfold", 0.9), "optimistic: widen the blocks\\.$") + expect_match(adv("block_kfold", 0.3), "contiguous blocks at the edges") + expect_match(adv("buffered_loo", 0.9), "widen the buffer") + for (m in c("random_kfold", "leave_location_out", "supplied splits", NA)) { + expect_no_match(adv(m, 0.9), "blocks") + expect_match(adv(m, 0.9), "use blocked or buffered folds") + expect_no_match(adv(m, 0.3), "contiguous blocks") + } + expect_no_match(adv("nndm", 0.9), "optimistic") + expect_match(adv("nndm", 0.9), "prediction points") + expect_match(adv("nndm", 0.05), "Little of the hold-out") + + set.seed(1) + p <- r2_pts(runif(60, 0, 1000), runif(60, 0, 1000)) + flatten <- function(x) gsub("\\s+", " ", paste(x, collapse = " ")) + rnd <- make_folds(p, k = 3, method = "random_kfold", seed = 1) + out <- flatten(utils::capture.output(print(fold_separation(rnd, p, sac = 500)))) + expect_match(out, "closer to a training point") + expect_no_match(out, "widen the blocks") + grid <- sf::st_as_sf(sf::st_make_grid(p, n = c(8, 8), what = "centers")) + nn <- r2_quiet(suppressWarnings(make_folds(p, k = 5, method = "nndm", + prediction_points = grid))) + out_nn <- flatten(utils::capture.output(print(fold_separation(nn, p, sac = 500)))) + expect_match(out_nn, "closer to a training point") + expect_no_match(out_nn, "optimistic") + expect_no_match(out_nn, "widen the blocks") +}) + + +# ---- fit_rf_model(): the all-NaN warning names the AOA weights ------------ + +test_that("a forest with no out-of-bag rows says its importance cannot weight the AOA", { + skip_if_not_installed("ranger") + set.seed(1) + d <- r2_pts(runif(40, 0, 1000), runif(40, 0, 1000), a = rnorm(40), b = rnorm(40)) + d$z <- d$a + rnorm(40) + res <- rfb_collect_warnings(r2_quiet(suppressMessages( + fit_rf_model(d, "z", c("a", "b"), num_trees = 20, seed = 1, + replace = FALSE, sample_fraction = 1)))) + expect_true(any(grepl(paste0("no row is out of bag.*area_of_applicability\\(\\) ", + "cannot be weighted by that importance either: ", + "pass weights = NULL"), res$warnings))) +}) diff --git a/tests/testthat/test-sac-range.R b/tests/testthat/test-sac-range.R index 4dbbe04..c0e7783 100644 --- a/tests/testthat/test-sac-range.R +++ b/tests/testthat/test-sac-range.R @@ -245,10 +245,13 @@ test_that("make_folds(auto_range) falls back when the range is unidentified", { skip_if_not_installed("gstat") pts <- sac_test_field() - lines <- capture_spatialkit_log( - f <- make_folds(pts, k = 4, method = "block_kfold", auto_range = TRUE, - range_frac = 1e-6, response_var = "z", seed = 1) - ) + # The fallback is an R warning as well as a log line. + expect_warning( + lines <- capture_spatialkit_log( + f <- make_folds(pts, k = 4, method = "block_kfold", auto_range = TRUE, + range_frac = 1e-6, response_var = "z", seed = 1) + ), + "falling back to geometric blocks") expect_true(log_has(lines, "falling back to geometric blocks")) # ... and the grid is still a real grid, not one block. @@ -743,3 +746,133 @@ test_that("the directional variograms are attached only on request", { auto_range = TRUE, seed = 1))) expect_null(attr(fo$params$sac_range, "directional_fits")) }) + + +# --------------------------------------------------------------------------- +# Round 2 of the review: what the estimate refuses, and what it says. +# --------------------------------------------------------------------------- + +test_that("an all-pairs fit past the fitted lags is refused even when two directions reached a sill", { + # An exponential field of effective range 150 under an east-west trend: the + # pooled variogram rises past the fitted lags (3125 against 672), but the + # directions across the slope reach a sill. Their maximum came back as the + # range, 430, with anisotropy_used = TRUE and nothing on the console -- + # while the documentation said a trend is caught by the fitted-lag bound. + # Whether two directions happened to fit flipped the answer between NA and + # a finite range from draw to draw (12 of 30 went this way). + skip_if_not_installed("gstat") + set.seed(11) + n <- 300 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 50) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + 4 * x / 1000 + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) + st <- attr(r, "directional_status") + # The path under test needs two directions that reached a sill; that is a + # property of this draw on this platform's gstat, not of the code. + skip_if(sum(st == "ok") < 2L, "fewer than two directions reached a sill on this platform") + expect_true(is.na(r)) + expect_s3_class(r, "sac_range") + expect_identical(attr(r, "rejected_reason"), "fitted range exceeds the largest lag fitted") + expect_gt(attr(r, "rejected_range"), attr(r, "cutoff_dist")) + expect_false(attr(r, "anisotropy_used")) + # The directions are still reported, and so is their spread. + expect_equal(sum(is.finite(attr(r, "directional"))), sum(st == "ok")) + expect_true(is.finite(attr(r, "anisotropy"))) + expect_true(log_has(lines, "exceeds the largest lag")) + expect_false(log_has(lines, "Using the maximum")) +}) + +test_that("a REML range shorter than the shortest lag is refused, not returned", { + # White noise, detrended by REML: the fit returned an effective range of + # 0.27 m with a nugget proportion of 0.99, on points whose closest pairs are + # metres apart and whose first variogram lag is about 30 m. Passed as a + # block size it asked for a 3642 x 3676 grid, refused as a unit mistake. + skip_if_not_installed("gstat") + skip_if_not_installed("nlme") + set.seed(7) + n <- 300 + d <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000), + z = rnorm(n), w = rnorm(n)) + pts <- sf::st_as_sf(d, coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log( + r <- suppressWarnings(estimate_sac_range(pts, "z", "w", detrend = "reml"))) + expect_true(is.na(r)) + expect_s3_class(r, "sac_range") + expect_identical(attr(r, "rejected_reason"), "fitted range is below the shortest lag fitted") + vg <- attr(r, "variogram") + expect_lt(attr(r, "rejected_range"), min(vg$dist[vg$np > 0])) + expect_identical(attr(r, "detrend_method"), "reml") + # The REML floor: the distance within which 30 pairs of its points lie + # (about 15 m here), capped at that first lag. + expect_true(log_has(lines, "shorter than the distance within which 30 of its point pairs lie")) + # And a field with a real range is untouched by the bound. + ok <- estimate_sac_range(sac_test_field(), "z", seed = 1) + expect_true(is.finite(ok)) + vg_ok <- attr(ok, "variogram") + expect_gt(as.numeric(ok), min(vg_ok$dist[vg_ok$np > 0])) +}) + +test_that("print() says what the range is a length in, and of what", { + # A bare number: for lon/lat input the unit and CRS were chosen by the + # estimate, and a detrended range is of the residuals, and neither showed. + skip_if_not_installed("gstat") + fld <- sac_test_field() + r <- estimate_sac_range(fld, "z", seed = 1) + out <- utils::capture.output(print(r)) + expect_match(out[1], "^[0-9]") # still leads with the number + expect_true(any(grepl("in metres of EPSG:3857; variogram of the response itself", out, + fixed = TRUE))) + set.seed(2); fld$w <- rnorm(nrow(fld)) + rd <- estimate_sac_range(fld, "z", "w", seed = 1) + expect_output(print(rd), "variogram of the residuals on predictor_vars (ols)", fixed = TRUE) + # A refusal says it too, and still dumps nothing. + rej <- suppressWarnings(estimate_sac_range(fld, "z", range_frac = 1e-6, seed = 1)) + printed <- paste(utils::capture.output(print(rej)), collapse = "\n") + expect_match(printed, "^NA") + expect_match(printed, "EPSG:3857", fixed = TRUE) + expect_false(grepl("np|dist|gamma|psill", printed)) +}) + +test_that("the anisotropy note points at the directional ranges that stay usable", { + # The note advised max(attr(range, "directional")), which is NA whenever + # any direction ran past the fitted lags -- on an anisotropic field, most + # often the major axis. + skip_if_not_installed("gstat") + set.seed(1) + n <- 200 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y * 4))) + z <- as.numeric(t(chol(exp(-d / 100) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- estimate_sac_range(pts, "z", seed = 1)) + skip_if(!(is.finite(attr(r, "anisotropy")) && attr(r, "anisotropy") > 1.5), + "the directional ranges did not vary by more than 1.5 on this platform") + expect_true(log_has(lines, "directional ranges vary")) + expect_true(log_has(lines, "directional_fitted")) + expect_true(log_has(lines, "directional_status")) + expect_false(log_has(lines, "max\\(attr\\(range, \"directional\"\\)\\)")) +}) + +test_that("a small sample refused as 'decreases with distance' says sampling noise can do it", { + # 30 points of an ordinary exponential field: the short-lag bins are noisy + # enough to fall by 15%, and the refusal named only a periodic structure or + # a cluster whose variance differs. + skip_if_not_installed("gstat") + set.seed(2) + n <- 30 + x <- runif(n, 0, 1000); y <- runif(n, 0, 1000) + d <- as.matrix(stats::dist(cbind(x, y))) + z <- as.numeric(t(chol(exp(-d / 50) + diag(0.2 + 1e-8, n))) %*% rnorm(n)) + pts <- sf::st_as_sf(data.frame(x = x, y = y, z = z), coords = c("x", "y"), crs = 32632) + lines <- capture_spatialkit_log(r <- suppressWarnings(estimate_sac_range(pts, "z"))) + skip_if(!identical(attr(r, "rejected_reason"), "empirical variogram decreases with distance"), + "this draw's short lags did not fall on this platform") + expect_true(log_has(lines, "With 30 points the short-lag bins are noisy")) + # A large sample is not told that. + big <- capture_spatialkit_log(suppressWarnings(estimate_sac_range(sac_test_field(), "z", + range_frac = 1e-6))) + expect_false(log_has(big, "short-lag bins are noisy")) + expect_true(log_has(big, "flat from the first lag")) +}) diff --git a/tests/testthat/test-select-on.R b/tests/testthat/test-select-on.R index e5c3290..8bf9995 100644 --- a/tests/testthat/test-select-on.R +++ b/tests/testthat/test-select-on.R @@ -53,32 +53,35 @@ test_that(".spatial_half_split makes two disjoint, exhaustive, spatially blocked expect_output(print(sp), "Spatial half-split") }) -test_that("determine_optimal_levels(select_on = 'split') selects on one half and returns both", { +test_that("determine_optimal_levels(select_on = 'split') reads one half's response and returns both", { pts <- so_field(300) - out <- determine_optimal_levels(pts, max_levels = 8, response_var = "z", - predictor_vars = "w", select_on = "split") + # The fixture's locations are uniform, so every call warns that the WSS + # curve has no elbow; that is not what this test is about. + dol <- function(...) suppressWarnings(determine_optimal_levels(...)) + out <- dol(pts, max_levels = 8, response_var = "z", predictor_vars = "w", + select_on = "split") sp <- attr(out, "split") expect_s3_class(sp, "spatialkit_split") expect_setequal(c(sp$selection, sp$estimation), seq_len(300)) - # The selection is the one made on the selection half alone. - half <- determine_optimal_levels(pts[sp$selection, ], max_levels = 8, - response_var = "z", predictor_vars = "w") - expect_identical(as.integer(out), as.integer(half)) + # The count is for a tessellation of every point, so the WSS curve and the + # cells use every point; only Moran's I is held to the selection half. + # With max_levels = 8 no candidate clears the nine-cell floor, the call + # falls back to the geometric elbow, and that is the whole layer's elbow. + # (It used to be the selection half's, chosen for half the extent.) + expect_identical(as.integer(out), as.integer(dol(pts, max_levels = 8))) # The default path is unchanged and carries no split. - all_pts <- determine_optimal_levels(pts, max_levels = 8, response_var = "z", - predictor_vars = "w") + all_pts <- dol(pts, max_levels = 8, response_var = "z", predictor_vars = "w") expect_null(attr(all_pts, "split")) - # The geometric path with a split: same integer vector, plus the attribute. - geo <- determine_optimal_levels(pts, max_levels = 6, select_on = "split") + # The geometric path with a split reads no response and sees every point: + # same integer vector as without, plus the attribute. + geo <- dol(pts, max_levels = 6, select_on = "split") expect_type(geo, "integer") expect_s3_class(attr(geo, "split"), "spatialkit_split") - expect_identical(as.integer(geo), - as.integer(determine_optimal_levels(pts[attr(geo, "split")$selection, ], - max_levels = 6))) + expect_identical(as.integer(geo), as.integer(dol(pts, max_levels = 6))) expect_error(determine_optimal_levels(pts, select_on = "half"), "'arg' should be one of") }) -test_that("resolution_profile(select_on = 'split') profiles the selection half", { +test_that("resolution_profile(select_on = 'split') reads the selection half's response", { skip_if_not_installed("gstat") pts <- so_field(400) prof <- resolution_profile(pts, response_var = "z", predictor_vars = "w", @@ -86,7 +89,10 @@ test_that("resolution_profile(select_on = 'split') profiles the selection half", sp <- attr(prof, "split") expect_s3_class(sp, "spatialkit_split") expect_setequal(c(sp$selection, sp$estimation), seq_len(400)) - expect_identical(attr(prof, "bounds")$n, length(sp$selection)) + # The levels are cell counts for the whole layer, so its bounds are the + # layer's: every point, floor(400 / 9) = 44 at most. + expect_identical(attr(prof, "bounds")$n, 400L) + expect_identical(attr(prof, "bounds")$ceiling, 44L) expect_output(print(prof), "estimate on the other") expect_null(attr(resolution_profile(pts, n_levels = 4), "split")) }) diff --git a/tests/testthat/test-sf-empty-parts.R b/tests/testthat/test-sf-empty-parts.R new file mode 100644 index 0000000..4478bc4 --- /dev/null +++ b/tests/testthat/test-sf-empty-parts.R @@ -0,0 +1,41 @@ +# sf 1.0-18 changed st_is_empty(): a multi-part geometry now counts as empty +# when its FIRST part is empty, so MULTILINESTRING (EMPTY, (0 0, 10 0)) is +# "empty" there and not in earlier sf. st_cast() consults it, and +# coerce_to_points() returned an EMPTY POINT for such a feature on current +# sf, losing its real part. The newer rule is emulated here so the test +# bites on any installed sf. + +.sf118_is_empty <- function(x) { + g <- sf::st_geometry(x) + vapply(unclass(g), function(item) { + if (inherits(item, "POINT")) return(all(is.na(item))) + if (length(item) == 0L) return(TRUE) + if (is.list(item)) { + f <- item[[1]] + return(length(f) == 0L || (is.list(f) && length(f[[1]]) == 0L)) + } + FALSE + }, logical(1)) +} + +test_that("a line whose first part is empty keeps its real part under sf >= 1.0-18", { + local_mocked_bindings(st_is_empty = .sf118_is_empty, .package = "sf") + seg <- function(x0, y0, x1, y1) rbind(c(x0, y0), c(x1, y1)) + e2 <- matrix(numeric(0), 0, 2) + + x <- sf::st_sf(id = 1:2, geometry = sf::st_sfc( + sf::st_multilinestring(list(e2, seg(0, 0, 10, 0))), + sf::st_multilinestring(list(e2, seg(3, 4, 3, 4))), crs = 32617)) + expect_true(all(sf::st_is_empty(x))) # the emulation is in force + got <- coerce_to_points(x, "auto") + expect_equal(unname(sf::st_coordinates(got)), rbind(c(5, 0), c(3, 4))) + + ln <- function(x0, y0, d) rbind(c(x0, y0), c(x0 + d, y0), c(x0 + 2 * d, y0)) + ll <- sf::st_sf(id = 1:3, geometry = sf::st_sfc( + sf::st_multilinestring(list(ln(-80, 35, 0.1))), + sf::st_multilinestring(list(e2, ln(-79, 35.5, 0.1))), + sf::st_multilinestring(list(ln(-78, 36, 0.1))), crs = 4326)) + got <- suppressWarnings(coerce_to_points(ll, "auto")) + expect_equal(unname(sf::st_coordinates(got)[2, ]), c(-78.9, 35.5), + tolerance = 1e-4) +}) diff --git a/tests/testthat/test-spatial-fit-s3.R b/tests/testthat/test-spatial-fit-s3.R index 1982da9..bbe283b 100644 --- a/tests/testthat/test-spatial-fit-s3.R +++ b/tests/testthat/test-spatial-fit-s3.R @@ -80,7 +80,7 @@ test_that("print.spatial_fit labels and details a gwr_fit", { txt <- .s3_printed(gwr) expect_match(txt, " spatial model fit", fixed = TRUE) - expect_match(txt, "Bandwidth: 37.5 (adaptive, gaussian kernel)", fixed = TRUE) + expect_match(txt, "Bandwidth: 37.5 neighbours (adaptive, gaussian kernel)", fixed = TRUE) expect_match(txt, "AICc : 412.25", fixed = TRUE) # A fixed bandwidth says "fixed", and the kernel defaults to bisquare. @@ -248,8 +248,10 @@ test_that("model_metrics scores fitted values or newdata predictions", { # The out-of-sample numbers really come from predict() on newdata. yh <- predict(fit, newdata = test) expect_equal(oos$RMSE, sqrt(sum((test$z - yh)^2) / nrow(test))) + # Out-of-sample R2 is measured against the TRAINING mean, as in every + # cv_*() (see test-review2-cv.R). expect_equal(oos$R2, 1 - sum((test$z - yh)^2) / - sum((test$z - mean(test$z))^2)) + sum((test$z - mean(train$z))^2)) expect_false(isTRUE(all.equal(ins$RMSE, oos$RMSE))) # newdata without the response cannot be scored, and says why. diff --git a/tests/testthat/test-summarize-by-cell.R b/tests/testthat/test-summarize-by-cell.R index bd10117..fbd59e1 100644 --- a/tests/testthat/test-summarize-by-cell.R +++ b/tests/testthat/test-summarize-by-cell.R @@ -619,12 +619,17 @@ test_that("summarize_by_cell falls back to deff = 1 with no fitted variogram", { # without uninstalling anything -- when nothing supplies a variogram to fit. pts <- .vgm_cell_points() + # A real R warning, classed, as well as the log line: the standard errors + # come back uncorrected although a correction was asked for. lines <- capture_spatialkit_log( - out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram") + expect_warning( + out <- summarize_by_cell(pts, predictor_vars = "z", deff = "variogram"), + "requires a fitted variogram model", class = "spatialkit_deff_fallback") ) expect_true(log_has(lines, "requires a fitted variogram model")) expect_true(log_has(lines, "Falling back to deff = 1")) expect_null(attr(out, "deff_applied")) + expect_false(any(out$deff_applied)) iid <- summarize_by_cell(pts, predictor_vars = "z", deff = 1) expect_equal(out[["..se_pred_z"]], iid[["..se_pred_z"]]) @@ -634,7 +639,10 @@ test_that("summarize_by_cell falls back to deff = 1 with no fitted variogram", { lines2 <- capture_spatialkit_log({ local_mocked_bindings( estimate_sac_range = function(...) stop("gstat unavailable")) - out2 <- summarize_by_cell(pts, response_var = "z", deff = "variogram") + expect_warning( + out2 <- summarize_by_cell(pts, response_var = "z", deff = "variogram"), + "estimate_sac_range\\(\\) failed: gstat unavailable", + class = "spatialkit_deff_fallback") }) expect_true(log_has(lines2, "requires a fitted variogram model")) expect_null(attr(out2, "deff_applied")) @@ -850,9 +858,12 @@ test_that("conf_level = NULL leaves the frame exactly as it was", { out <- summarize_by_cell(pts, response_var = "y", predictor_vars = "e", deff = dv) expect_length(.interval_cols(out), 0L) + # A requested design effect adds its per-row `deff_applied` flag, with + # or without conf_level; the default deff = 1 frame has none. expect_named(out, c("poly_id", "n", "resp_mean_y", "..sd_resp_y", "..se_resp_y", "pred_mean_e", "..sd_pred_e", - "..se_pred_e", "cell_weight")) + "..se_pred_e", "cell_weight", + if (!identical(dv, 1)) "deff_applied")) } }) diff --git a/vignettes/diagnostics.Rmd b/vignettes/diagnostics.Rmd index 60bc6a0..451e0cb 100644 --- a/vignettes/diagnostics.Rmd +++ b/vignettes/diagnostics.Rmd @@ -68,7 +68,7 @@ library(spatialkit) set.seed(11) n <- 350 -xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) +xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) field <- as.numeric(t(chol(exp(-D / 70) + diag(1e-8, n))) %*% rnorm(n)) xy$a <- rnorm(n) @@ -80,8 +80,9 @@ pts <- st_as_sf(xy, coords = c("x", "y"), crs = 32632) ```{r learner} lm_fit <- function(train_sf, response_var = "z", predictor_vars = c("a", "b")) { d <- st_drop_geometry(train_sf) - fml <- as.formula(paste(response_var, "~", - paste(predictor_vars, collapse = " + "))) + # With no predictors the model is intercept-only: "z ~ 1", not "z ~ ". + rhs <- if (length(predictor_vars)) paste(predictor_vars, collapse = " + ") else "1" + fml <- as.formula(paste(response_var, "~", rhs)) new_spatial_fit( subclass = "lmsurf_fit", engine = lm(fml, data = d), @@ -138,8 +139,11 @@ explained. ## 2. Standard errors on aggregated values Aggregate the points into cells and the naive standard error of each cell mean -is \(s/\sqrt{n}\), which assumes the points in a cell are independent. On an -autocorrelated field they are not, and the effective sample size is smaller than +is \(s/\sqrt{n}\), which treats the points in a cell as independent. For the +cell's own mean that is the right standard error when the points are spread +through the cell. For the cell mean as an estimate of the population (grand) +mean it is not: on an autocorrelated field the points in a cell share the +cell's departure from that mean, and the effective sample size is smaller than the count. ```{r cells} @@ -173,9 +177,12 @@ ik <- median(kish$..se_resp_z / iid$..se_resp_z, na.rm = TRUE) iv <- median(vgm$..se_resp_z / iid$..se_resp_z, na.rm = TRUE) cat(sprintf(paste("The median cell's standard error is %.2f times wider under", "`kish` and %.2f times wider under `variogram` than the", - "independent-sampling one. A confidence interval built on the", - "naive number is about half the width it should be on this", - "field.\n"), ik, iv)) + "independent-sampling one. As an estimate of the population", + "mean, a confidence interval built on the naive number is", + "about half the width it should be on this field. For the", + "cell's own mean the naive standard error is the right one,", + "and section 3 (`kriging_adequacy()`) covers that", + "quantity.\n"), ik, iv)) ``` `deff = "kish"` estimates an intra-class correlation from the within-cell and @@ -241,7 +248,7 @@ aoa <- area_of_applicability(gp, model = fit) aoa ``` -```{r aoa-plot, fig.height=4.5, fig.alt="Cumulative distribution of the dissimilarity index. The prediction locations rise far more slowly than the cross-validated training points, and most of them sit beyond the dashed threshold, so the cross-validated score does not apply to most of the grid."} +```{r aoa-plot, fig.height=4.5, fig.alt="Cumulative distribution of the dissimilarity index. The prediction locations rise far more slowly than the training points, each measured to its nearest other training point since no folds were passed, and most of them sit beyond the dashed threshold, so the cross-validated score does not apply to most of the grid."} plot(aoa) ``` @@ -263,27 +270,42 @@ c(inside = sum(inside), outside_or_unknown = sum(!inside)) **Coordinates as predictors.** A model given `x` and `y` can reproduce the training surface by memorising location, and random folds will not detect it. -`fit_rf_model(include_coords = TRUE)` warns for this reason. Score any such -model with blocked folds, and read `vignette("spatial-cross-validation")` for -what the blocking has to be wide enough to do. +`fit_rf_model(include_coords = TRUE)` logs a caution (once per session) for +this reason. Score any such model with blocked folds, and read +`vignette("spatial-cross-validation")` for what the blocking has to be wide +enough to do. **Selection outside the fold.** Choosing predictors on the whole data set and then cross-validating the chosen set gives the selection a look at every test row. `select_features_forward()` does the selection inside the resampling, and -it takes the fold scheme as an argument for the same reason the outer loop does: +it takes the fold scheme as an argument for the same reason the outer loop does. +Blocked folds only keep test rows apart from training rows if the blocks are at +least as wide as the autocorrelation range. `make_folds()` estimates that range +for what the candidates leave unexplained, about 330 m on this field, and warns +when the blocks are narrower. The default grid here has blocks about 250 m +across, so `block_size = 400` is passed: ```{r selection} # select_features_forward() calls fit_fn(train_sf, vars), so the learner above -# needs an adapter that puts `vars` in the predictor slot. +# needs an adapter that puts `vars` in the predictor slot. Step 0 fits it with +# no predictors at all, which is why lm_fit() builds "z ~ 1" for an empty set. sel_fn <- function(train_sf, vars) lm_fit(train_sf, "z", vars) sel <- select_features_forward(pts, "z", c("a", "b"), fit_fn = sel_fn, - k = 4, method = "block_kfold", seed = 1) + k = 4, method = "block_kfold", + block_size = 400, seed = 1) sel$selected +sel$history ``` +`history` has one row per candidate scored at each step. Step 0 is the +intercept-only model, so `a` had to beat it to be added, and at step 2 adding +the noise variable `b` made the cross-validated RMSE slightly worse, so the +selection stopped at `a`. With `tol` set, a candidate has to improve the score +by more than `tol`, from step 1 on. + Its inner folds default to the scheme you pass. Passing `random_kfold` there -produces a warning, because a leaky inner loop can select a variable for being +logs a caution, because a leaky inner loop can select a variable for being spatially close to the response and an honest outer loop will then report a respectable number for a dishonestly chosen feature set. diff --git a/vignettes/getting-started.Rmd b/vignettes/getting-started.Rmd index f2fb513..bf251c4 100644 --- a/vignettes/getting-started.Rmd +++ b/vignettes/getting-started.Rmd @@ -67,7 +67,8 @@ cat( "| `sp`, `GWmodel` | `fit_gwr_model()` and `cv_gwr()` |\n", "| `brms` (plus a Stan toolchain) | `fit_bayesian_spatial_model()` and `cv_bayes()` |\n", "| `geometry` | Delaunay triangle tessellations |\n", -"| `ggplot2`, `patchwork` | every `plot_*()` function and every `plot()` method |\n", +"| `ggplot2` | every `plot_*()` function and every `plot()` method |\n", +"| `patchwork` | only the stacked panels in `vignette(\"spatialkit_nc_demo\")` and `example_nc_demo.R` |\n", "| `FNN`, `Matrix` | sparse k-nearest-neighbour weights for Moran's I on large layers |\n", sep = "") ``` @@ -187,8 +188,8 @@ Four more things about the data, each handled without stopping you: before a fit, and the count is logged; `prep_model_data()` is the function that does it and `attr(x, "dropped")` says which rows. - Two observations at the same coordinates are fine for models and folds; - a Voronoi tessellation keeps one seed per location - (`build_tessellation(keep_duplicates = )` says what to do with the rest). + a Voronoi tessellation keeps one seed per location, and every point at + that location is indexed to its cell. - A point outside the boundary you tessellate gets no cell: `tess$index` is `NA` for it and `assign_features_to_polygons()` leaves it out unless you ask for it back with `keep_unassigned = TRUE`. @@ -219,10 +220,9 @@ tess <- build_tessellation(obs, boundary = boundary, method = "hex", # 3. Put every observation in a cell. asg <- assign_features_to_polygons(obs, tess$cells) -# 4. Aggregate, with standard errors corrected for within-cell correlation. -# cells_sf attaches the geometry so the result maps; deff = "kish" is the -# correction. -cells <- summarize_by_cell(asg, "rate", cells_sf = tess$cells, deff = "kish") +# 4. Aggregate, with a count and a standard error for every cell mean. +# cells_sf attaches the geometry so the result maps. +cells <- summarize_by_cell(asg, "rate", cells_sf = tess$cells) c(best_level = lv[1], cells = nrow(tess$cells)) tess$params$approx_n_cells_from @@ -240,6 +240,14 @@ with one observation has a standard error of `NA`, because one number has no spread, and an empty cell has `n = NA`: both are kept, because a region with nothing in it is a fact about the map. +At the default `deff = 1` the standard error is the one for each cell's own +mean, which is what a map of the regions reports, and it is right when a cell's +points are spread through it. `deff = "kish"` or `"variogram"` gives instead the +standard error of a cell mean as an estimate of the population mean, widened +for the correlation among the points in a cell. Use that when the cell means +feed a claim about the population rather than about the cells themselves; +`?summarize_by_cell` says which is which. + Two ID columns can appear on a cell layer. Every tessellation carries `cell_id`, derived from the geometry, so it is the same for the same cell whatever order the points came in. The hex and square grids also carry @@ -248,9 +256,10 @@ and `summarize_by_cell()` take `polygon_id_col` and `id_col` to name either, and fall back through both when neither is named. Eight cells, four of them slivers at the state's edge with no county inside, -is coarse. That is what the elbow finds on a hundred points, and -`vignette("resolution")` is where to argue with it: `resolution_profile()` -scores every cell count on four criteria at once. +is coarse. A hundred county centroids spread fairly evenly have no elbow to +find, and the call warns that `max_levels` chose this count rather than the +data. `vignette("resolution")` is where to argue with it: +`resolution_profile()` scores every cell count on four criteria at once. ```{r map, eval=has_ggplot, fig.height=4.5, fig.alt="North Carolina covered by four large hexagonal cells shaded by their mean SIDS rate, plus four unshaded slivers at the edges that hold no county. The western cell has the lowest mean, about 1.5 per thousand, and the small southern cell the highest, about 2.8."} plot_tessellation_map(cells, boundary = boundary, fill_col = "resp_mean_rate", @@ -404,7 +413,7 @@ source(file.path(dir, "03-folds.R")) | **nugget, sill, range** | the variogram's value at zero distance (noise), the value it levels off at (total variance), and the distance at which it gets there; the *effective* range is where it reaches 95 percent of the sill | | **autocorrelation range** | that effective range: beyond it two observations are nearly independent, which is what a block or a buffer has to exceed | | **block** | a square of the study area used to build a fold; a fold holds out whole blocks | -| **design effect (`deff`)** | how many times larger a cell mean's variance is than the independent-sample formula says, because the points in a cell are correlated; `n / deff` is the effective sample size | +| **design effect (`deff`)** | how many times larger a cell mean's variance, as an estimate of the population mean, is than the independent-sample formula says, because the points in a cell are correlated; `n / deff` is the effective sample size for that estimate. The cell's own mean needs no such correction when its points are spread through the cell | | **flat region** | the cell counts a resolution criterion cannot distinguish from its optimum; a set, not an interval | | **support ceiling, range floor** | the most cells the point count allows (`n / min_cell_n`) and the fewest the autocorrelation range allows (`area / range^2`); a criterion whose optimum sits on either is being chosen for by that bound | | **dissimilarity index (DI)** | how far a prediction location's predictors sit from the training data, on the scale of the training data's own spread; the area of applicability is where DI stays below what cross-validation saw | diff --git a/vignettes/reporting.Rmd b/vignettes/reporting.Rmd index 2290e63..6781b5b 100644 --- a/vignettes/reporting.Rmd +++ b/vignettes/reporting.Rmd @@ -170,7 +170,9 @@ not is portable: a file that has been reprojected, re-sorted and re-read elsewhere has no memory of how it was built. `ensure_stable_poly_id()` derives an ID from the geometry itself, in a common CRS, so the same region gets the same ID from whoever computes it, in whatever projection the file is in by -then. +then. The exception is fine cells stacked within about a centimetre of the +same longitude, which a reprojection can swap (see `?ensure_stable_poly_id`); +regions this size are nowhere near it. ```{r stable-ids} regions$src <- seq_len(nrow(regions)) @@ -370,8 +372,12 @@ no idea what it was computed over. For the aggregates themselves, report the standard error that comes with each cell mean rather than the mean alone. `summarize_by_cell()` computes it with -the observation count beside it, and `deff` corrects it for within-cell -autocorrelation. A cell mean from two observations and one from thirteen are +the observation count beside it. For per-region values like the map above, +that is the default `deff = 1` standard error used here (or the block-kriging +variance, `kr_var`, from `kriging_adequacy()`). A `deff` setting widens it for +within-cell autocorrelation, which is right only when the regional means feed +a claim about the population (here statewide) mean; `?summarize_by_cell` says +which is which. A cell mean from two observations and one from thirteen are different claims, and printed side by side they look identical. ```{r se-example} diff --git a/vignettes/resolution.Rmd b/vignettes/resolution.Rmd index abf7a0e..d0c112e 100644 --- a/vignettes/resolution.Rmd +++ b/vignettes/resolution.Rmd @@ -67,9 +67,12 @@ runs on the hard dependencies; it is the quick answer and the one cell count on a ladder against four criteria at once and needs gstat for two of them. `select_resolution()` reads one criterion off that profile, and `summary()` on the profile reads all four side by side. If the cells will feed -a model, the profile is the one to use; if you need a count now and the data -are all you have, the elbow is defensible and this article says where it -falls short. +a model, the profile is the one to use. If you need a count now and the data +are all you have, the elbow is defensible when the points cluster, and this +article says where it falls short. On points spread evenly there is no elbow +to read, and both functions say so: the profile leaves its `elbow` column +empty, and `determine_optimal_levels()` warns that the count it still returns +was chosen by the ends of its ladder, not by the data. The argument that says "how many" is spelled differently by the function it belongs to: `max_levels` bounds the elbow's ladder, `n_levels` sets the @@ -90,7 +93,7 @@ library(spatialkit) set.seed(42) n <- 500 -xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) +xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$z <- as.numeric(t(chol(exp(-D / 100) + diag(1e-8, n))) %*% rnorm(n)) + rnorm(n, sd = 1) @@ -106,6 +109,12 @@ lv <- determine_optimal_levels(pts, max_levels = 40) lv ``` +This fixture's points are uniform, so their within-cluster sum of squares falls +like `c / k` all the way down and bends nowhere of its own. The call warns that +it found no elbow and that `max_levels` chose `lv`: a larger `max_levels` would +give a larger answer. Read an elbow only off points that cluster; here the +profile below is the better guide. + `lv[1]` is what `get_voronoi_seeds()` takes as `n`, and what `build_tessellation()` takes as `approx_n_cells` for its `"hex"` and `"square"` methods. Voronoi has no cell count to set: it grows one cell per point you hand @@ -114,8 +123,8 @@ tessellate them. The last section shows the two calls in order. Two things to know about this function before you rely on it. Its `criterion = "morans_i"` and `criterion = "combined"` settings need both -`response_var` and `predictor_vars`; give it only a response and it logs a -warning and falls back to `"geometric"`. And its ladder runs from 1 to +`response_var` and `predictor_vars`; give it only a response and it warns +and falls back to `"geometric"`. And its ladder runs from 1 to `max_levels` with no lower bound from the spatial correlation of the data, so it can prefer cells wider than the field's own correlation range. The profile below does impose that bound, which is why the two can disagree. @@ -133,10 +142,12 @@ prof ``` One row per level. `cell_n_median` and `cell_diam_median` are usually the first -two columns worth reading: how many points a typical cell holds, and how wide it -is in CRS units. The width is the number you can compare against something you -already know about your own data, such as the spacing of a sampling grid or the -size of a field. +two columns worth reading: how many points a typical cell holds, and how big it +is in CRS units. `cell_diam_median` is twice the median root-mean-square +distance of a cell's points from its centre, about 0.8 of the side of a square +cell of the same area, so compare it against something you already know about +your own data, such as the spacing of a sampling grid or the size of a field, +with that factor in mind. ### The four criteria @@ -144,7 +155,7 @@ size of a field. cat( "| criterion | measures | needs | direction |\n", "|---|---|---|---|\n", -"| `elbow` | how far the within-cluster sum of squares curve bends below its own chord | coordinates only | larger |\n", +"| `elbow` | how far the log of the within-cluster sum of squares sags below a power law (the straight log-log line from one cell to the last level); `NA` at every level when the points have no cluster structure | coordinates only | larger |\n", "| `cp` | Mallows' \\(C_p\\) of the piecewise-constant approximation of the response by cell means | a response, and a variogram for the nugget | smaller |\n", "| `moran_z` | spatial structure surviving in the residuals of the cell means | a response | nearer zero |\n", "| `reliability` | the share of the spread in the cell means that is signal, not sampling noise | a variogram | larger |\n", @@ -157,7 +168,7 @@ the field, and whether the cell values can be told apart from noise. `moran_z` is the diagnostic, and a large deviate says the cells are still leaving spatial pattern on the table. -```{r plot-profile, fig.height=8, fig.alt="Four stacked panels, one per criterion, against the number of cells on a shared axis. Mallows' Cp falls from 10 to 39 cells and then flattens, reliability declines steadily from 10 cells on, the elbow statistic peaks at 22 cells, and the absolute Moran's z is lowest at 10, 16 and 25 cells before climbing past 30. A red dot and dotted line mark each criterion's choice, and shaded bands the levels within tolerance of it. The bands are two or three levels wide, two of them have gaps, and no level sits inside all four."} +```{r plot-profile, fig.height=8, fig.alt="Three stacked panels, one per criterion the profile could score, against the number of cells on a shared axis; there is no elbow panel because these uniform points have no elbow. Mallows' Cp falls from 10 to 49 cells and turns up at 55, reliability declines steadily from 10 cells on, and the absolute Moran's z is lowest at 20 cells and climbs past 30. A red dot and dotted line mark each criterion's choice, and shaded bands the levels within tolerance of it. The bands are one to three levels wide, none has a gap, and no level sits inside all three."} plot(prof) ``` @@ -275,10 +286,10 @@ The ladder runs between two bounds the data impose, both recorded on the profile str(attr(prof, "bounds")) ``` -The ceiling is `floor(n / min_cell_n)`, or one short of the number of distinct -locations when that is smaller; `ceiling_from` says which. Past it the average -cell holds too few points to estimate anything from, or k-means has more -centres to place than distinct points. The floor is `ceiling(area / range^2)`, from +The ceiling is `floor(n / min_cell_n)`, or the number of distinct locations +when that is smaller (one short of it when no location repeats); `ceiling_from` +says which. Past it the average cell holds too few points to estimate anything +from, or k-means has more centres to place than distinct points. The floor is `ceiling(area / range^2)`, from the fitted autocorrelation range: cells wider than the range average over more than one patch of the field, mixing values the field itself keeps apart. @@ -305,18 +316,28 @@ sp The split is spatially blocked, not random, and records the method and seed that produced it. A random half would put neighbours of every selection point in the estimation set, and on an autocorrelated field that leaks the structure you are -choosing against. - -Choose from `prof_split`, then aggregate the rows in `sp$estimation`. The cost is -power: half the data gives a noisier profile and a wider band, and the ladder -itself gets shorter because the ceiling scales with `n`. +choosing against. Blocking reduces that leak without removing it: the two halves +share a border, and points on either side of it within the correlation range +are still correlated, so read the separation as a large improvement on a random +half rather than as independence. + +Choose from `prof_split`, then aggregate the rows in `sp$estimation`. The cells +on the ladder are still drawn on every point, so the count it picks is a count +for the whole layer, and the ladder is as long as the full profile's. Only the +steps that read the response (the variogram, `cp`, `moran_z`) use the +selection half. The cost is power: those criteria see half the data, so the +profile is noisier and the band wider. The estimation rows also fill only +their own half of the layer: a cell inside the selection half gets none of +them, and a cell across the border between the halves is estimated from the +part of it on the estimation side. Read standard errors only off cells whose +points are all estimation rows. ```{r split-ladder} unlist(attr(prof_split, "bounds")[c("floor", "ceiling", "n", "supported")]) ``` -On a layer of a few hundred points that shortening can leave very little ladder, -which is a useful answer in itself. +The floor can differ from the full profile's, because it comes from the range +estimated on the selection half. ## Next diff --git a/vignettes/spatial-cross-validation.Rmd b/vignettes/spatial-cross-validation.Rmd index ba8b277..049dee6 100644 --- a/vignettes/spatial-cross-validation.Rmd +++ b/vignettes/spatial-cross-validation.Rmd @@ -111,7 +111,7 @@ over a 1000-unit square: ```{r fixture} set.seed(7) n <- 400 -xy <- data.frame(x = runif(n, 0, 1000), y = runif(n, 0, 1000)) +xy <- data.frame(x = 5e5 + runif(n, 0, 1000), y = 5e6 + runif(n, 0, 1000)) D <- as.matrix(dist(xy)) xy$z <- as.numeric(t(chol(exp(-D / 60) + diag(1e-8, n))) %*% rnorm(n)) + rnorm(n, sd = 0.3) @@ -203,9 +203,9 @@ prints the directional summary; `as.numeric()` above keeps the output to the two numbers. When the variogram identifies no range, `estimate_sac_range()` returns `NA` with -the reason attached, `auto_range` logs that it is falling back to geometric +the reason attached, `auto_range` warns that it is falling back to geometric blocks, and you are back to choosing a size yourself. An `NA` there is a finding -about the data. `?estimate_sac_range` lists the five reasons and what each one +about the data. `?estimate_sac_range` lists the reasons and what each one means; `plot()` on the returned object draws the variogram that produced it. ## Sizing it by measurement diff --git a/vignettes/spatialkit_nc_demo.Rmd b/vignettes/spatialkit_nc_demo.Rmd index 0f3c0b1..bdc97fa 100644 --- a/vignettes/spatialkit_nc_demo.Rmd +++ b/vignettes/spatialkit_nc_demo.Rmd @@ -263,8 +263,11 @@ head(as.data.frame(cell_stats)[, c("cell_id", "n", "resp_mean_y", "..sd_resp_y", "..se_resp_y")]) ``` -The `..se_*` columns are **IID** standard errors at the default `deff = 1`, -which is anticonservative when points inside a cell are spatially correlated. +The `..se_*` columns are **IID** standard errors at the default `deff = 1`. +That is the right standard error for each cell's own mean, the value a +choropleth shows, when the points are spread through the cell. As a standard +error for the population (grand) mean it is anticonservative when points inside +a cell are spatially correlated. For that population-level use, `deff = "kish"` applies Kish's design-effect correction from an estimated intra-class correlation, and `attr(., "deff_applied")` records what was used: @@ -383,10 +386,13 @@ axes, so nothing built from them is invariant to rotating the layer. The all-pairs fit is the estimate whenever it is usable; the directional maximum stands in for it only when the all-pairs fit fails, and the `anisotropy_used` attribute is `TRUE` in that case alone. If you *know* the field is anisotropic, -size blocks from `max(attr(sac, "directional"))` explicitly. It returns `NA` -(still classed `sac_range`, so it prints as a bare `NA`) when the empirical -variogram never reaches a sill, because an unidentified range must not be used -to size blocks. +size blocks from the longest directional range explicitly: +`max(attr(sac, "directional_fitted"), na.rm = TRUE)`, after checking +`attr(sac, "directional_status")`, since `directional` is `NA` for a direction +that ran past the fitted lags, which on such a field is often the long one. It +returns `NA` (still classed `sac_range`, so it prints as `NA`) when the +empirical variogram never reaches a sill, because an unidentified range must +not be used to size blocks. ```{r sac-range, eval=has_ggplot && has_gstat} sac <- estimate_sac_range(points_sf, response_var = "y", @@ -429,7 +435,7 @@ c(random = folds_random$k, blocked = folds_blocked$k, `plot_folds()` is the fastest way to see whether the blocks actually separate the data or are smaller than the autocorrelation range and therefore leaking: -```{r plot-folds, fig.width=7, fig.height=6, eval=has_ggplot && requireNamespace("patchwork", quietly = TRUE), fig.alt="Two maps of the same points, random folds above and blocked folds below, sharing one fold legend. In the random map the five colours are interleaved everywhere; in the blocked map each fold occupies a contiguous part of the state, with the block grid drawn behind."} +```{r plot-folds, fig.width=7, fig.height=6, eval=has_ggplot && requireNamespace("patchwork", quietly = TRUE), fig.alt="Two maps of the same points, random folds above and blocked folds below, sharing one fold legend. In the random map the five colours are interleaved everywhere; in the blocked map, with the block grid drawn behind, every block holds a single fold and each fold is two to four whole blocks: four of the five folds fall in two separate parts of the state, and the fifth's two blocks meet only at a corner."} library(patchwork) (plot_folds(folds_random, points_sf, boundary = nc_boundary) / plot_folds(folds_blocked, points_sf, boundary = nc_boundary)) + @@ -534,6 +540,19 @@ cat(sprintf("Bandwidth: %.0f neighbours | in-sample R2: %.3f | RMSE: %.3f\n", gwr_fit$info$bandwidth, gwr_met$R2, gwr_met$RMSE)) ``` +The fit raises no collinearity warning, but its survey of the local designs +(`gwr_fit$info$local_collinearity`, see "Collinearity diagnostics" in +`?fit_gwr_model`) is worth a look: in 25 of the 300 windows the condition +index that includes the intercept (`cn`) is above 30. The cause is +`elevation`: it averages about 3,000 but has a standard deviation of only about +400 inside a 42-neighbour window, so locally it is nearly collinear with the +intercept. What that leaves poorly determined is the local intercepts, not the +slopes: the slope index (`cn_slopes`), which centres the predictors in each +window, stays below 30 everywhere, so no slope is masked and the fit does not +warn. `plot(gwr_fit, type = "coefficients", term = "Intercept")` draws those +25 intercepts hollow. Centring the predictor (`elevation - mean(elevation)`) +gives the same bandwidth and fitted values and determines the intercepts too. + ### Comparing backends on identical folds `compare_models_cv()` cross-validates each requested backend on the `folds` you