## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, fig.height = 4.6,
                      dpi = 96, out.width = "100%")

## ----packages, message = FALSE------------------------------------------------
library(corridoR)
library(terra)
library(sf)
ex <- corridor_example(acc = TRUE)

## ----genetics-----------------------------------------------------------------
pc <- read_genotypes(ex$files$structure)
fst <- pairwise_fst(pc)
dM <- directional_gst(pc)$dM
gen <- pairwise_table(fst, dM)

## ----paths--------------------------------------------------------------------
xy <- st_coordinates(ex$sites); rownames(xy) <- ex$sites$site
pairs <- as.data.frame(t(combn(ex$sites$site, 2))); names(pairs) <- c("from", "to")
pairs <- pairs[sqrt(rowSums((xy[pairs$from, ] - xy[pairs$to, ])^2)) < 9000, ]
tr <- make_transition(ex$resistance, barrier = 1e6)
paths <- least_cost_paths(tr, ex$sites, pairs = pairs, dem = ex$dem)
nrow(paths)

## ----corridors----------------------------------------------------------------
both <- c(ex$env, ex$env_future)
names(both) <- c(names(ex$env), paste0(names(ex$env), "_f"))
x <- corridor_extract(both, pairs, acc = ex$acc, q = 0.05, progress = FALSE)

## ----model--------------------------------------------------------------------
vars <- names(ex$env)
now <- both_directions(cbind(x[, c("from", "to", vars)], path_length = paths$length))
future <- now
future[vars] <- both_directions(x[, c("from", "to", paste0(vars, "_f"))])[paste0(vars, "_f")]
now <- cbind(now, site_contrast(ex$sites, now, env = ex$env)[, -(1:2)])
future <- cbind(future, site_contrast(ex$sites, now, env = ex$env_future)[, -(1:2)])
lin <- st_drop_geometry(ex$sites)[, c("site", "lineage")]
now$LineageCross <- future$LineageCross <- lineage_cross(now$from, now$to, lin, ex$lineage_tmrca)
y <- gen$dM[match(paste(now$from, now$to), paste(gen$from, gen$to))]
groups <- list(climate = c("snowpack", "runoff", "summer_temp"),
               climate.at = c("snowpack.at", "runoff.at", "summer_temp.at"))
m <- fit_connectivity(now, y, groups, committees = c(1, 20), neighbors = c(0, 5), folds = 5)
m

## ----forecast, fig.height = 5-------------------------------------------------
change <- data.frame(from = now$from, to = now$to, value = predict(m, future) - predict(m, now))
shift <- map_pairwise(change, ex$acc, ex$sites, progress = FALSE)
lc <- c(North = "#ff3939", East = "#0070ff", West = "#000000", South = "#4ce600")
plot_shift(shift, dem = ex$dem, sites = ex$sites, col_sites = lc[ex$sites$lineage],
           main = "Projected shift in net migration", legend_title = "|change in dM|")