inst/doc/additional-features.R

In sfclust: Bayesian Spatial Functional Clustering

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(fig.align = "center")
knitr::opts_chunk$set(fig.height = 7, fig.width = 8, dpi = 90, out.width = '100%')
knitr::opts_chunk$set(comment = "#>")

## ----warning=FALSE, include=TRUE----------------------------------------------
library(sfclust)
library(stars)
library(ggplot2)
library(dplyr)

## -----------------------------------------------------------------------------
data("stgaus")
stgaus

## -----------------------------------------------------------------------------
stweekly <- aggregate(stgaus, by = "week", FUN = mean)
ggplot() +
    geom_stars(aes(fill = y), stweekly) +
    facet_wrap(~ time) +
    scale_fill_distiller(palette = "RdBu") +
    theme_bw()

## ----fig.height = 7, fig.width = 8--------------------------------------------
stgaus |>
    st_set_dimensions("geometry", values = 1:nrow(stgaus)) |>
    as_tibble() |>
    ggplot() +
    geom_line(aes(time, y, group = geometry, color = factor(geometry)), linewidth = 0.3) +
    theme_bw() +
    theme(legend.position = "none")

## -----------------------------------------------------------------------------
set.seed(123)
initial_cluster <- genclust(st_geometry(stgaus), nclust = 20)
names(initial_cluster)

## -----------------------------------------------------------------------------
st_sf(st_geometry(stgaus), cluster = factor(initial_cluster$membership)) |>
  ggplot() +
    geom_sf(aes(fill = cluster)) +
    theme_bw()

## ----eval = FALSE, echo = FALSE-----------------------------------------------
# # result <- sfclust(stgaus, graphdata = initial_cluster, niter = 50,
# #     formula = y ~ f(idt, model = "rw1", hyper = list(prec = list(prior = "normal", param = c(-2, 1)))),
# #   path_save = file.path("inst", "vigdata", "full-gaussian-mcmc1.rds"))
# # system.time(
# #   update(result, niter = 2000, path_save = file.path("inst", "vigdata", "full-gaussian-mcmc2.rds"))
# # )
# # #      user    system   elapsed
# # # 16010.960 11900.949  2794.096

## ----eval = FALSE, echo = FALSE-----------------------------------------------
# # # Reduce size of object
# # result1 <- readRDS(file.path("inst", "vigdata", "full-gaussian-mcmc1.rds"))
# # result2 <- readRDS(file.path("inst", "vigdata", "full-gaussian-mcmc2.rds"))
# # pseudo_inla <- function(x) {
# #   list(
# #     summary.random = list(id = x$summary.random$id["mean"]),
# #     summary.linear.predictor = x$summary.linear.predictor["mean"]
# #   )
# # }
# # result1$clust$models <- NULL
# # result2$clust$models <- lapply(result2$clust$models, pseudo_inla)
# # saveRDS(result1, file.path("inst", "vigdata", "gaussian-mcmc1.rds"))
# # saveRDS(result2, file.path("inst", "vigdata", "gaussian-mcmc2.rds"))

## ----eval = FALSE-------------------------------------------------------------
# result <- sfclust(stgaus, graphdata = initial_cluster, niter = 50,
#     formula = y ~ f(idt, model = "rw1", hyper = list(prec = list(prior = "normal", param = c(-2, 1)))))
# result

## ----echo = FALSE-------------------------------------------------------------
result <- readRDS(system.file("vigdata", "gaussian-mcmc1.rds", package = "sfclust"))
result

## ----fig.dpi = 72-------------------------------------------------------------
plot(result, which = 2)

## ----eval = FALSE-------------------------------------------------------------
# result2 <- update(result, niter = 2000)
# result2

## ----echo = FALSE-------------------------------------------------------------
result2 <- readRDS(system.file("vigdata", "gaussian-mcmc2.rds", package = "sfclust"))
result2

## ----fig.dpi = 72-------------------------------------------------------------
plot(result2, which = 2)

## -----------------------------------------------------------------------------
summary(result2, sort = TRUE)

## -----------------------------------------------------------------------------
stgaus$cluster <- fitted(result2, sort = TRUE)$cluster
st_sf(st_geometry(stgaus), cluster = factor(stgaus$cluster)) |>
  ggplot() +
    geom_sf(aes(fill = cluster)) +
    theme_bw()

## ----fig.height = 9.5---------------------------------------------------------
stgaus$cluster <- fitted(result2, sort = TRUE)$cluster
stgaus |>
  st_set_dimensions("geometry", values = 1:nrow(stgaus)) |>
  as_tibble() |>
  ggplot() +
    geom_line(aes(time, y, group = geometry), linewidth = 0.3) +
    facet_wrap(~ cluster, ncol = 2) +
    theme_bw() +
    labs(title = "Risk per cluster", y = "Risk", x = "Time")