Blog https://blog.benjaminhlina.com/ quarto-1.6.43 Fri, 04 Apr 2025 00:00:00 GMT Estimating Trophic Position Using the Package {trps} Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/trps/

1 Our Objectives

The purpose of this vignette is to learn how to estimate trophic position of a species using stable isotope data ( and ) using the package {trps}. We can estimate trophic position using several different models but for the purpose of this vignette a one source model is the simplest and easiest to implement. The one source model is based on equations from Post (2002).

If you are wanting to use other trophic position models please walk through this vignette and then check out other vignettes under the article section of the webpage.

2 Trophic Position Model

The equation for a one source model consists of the following:

Where is the trophic position of the baseline (e.g., 2), is the of the consumer, is the mean of the baseline, and is the trophic enrichment factor (e.g., 3.4).

To use this model with a Bayesian framework, we need to rearrange this equation to the following:

The function one_source_model() uses this rearranged equation.

3 Vignette structure

First we need to organize the data prior to running the model. To do this work we will use {dplyr} and {tidyr} but we could also use {data.table}.

When running the model we will use {trps} and {brms}.

Once we have run the model we will use {bayesplot} to assess models and then extract posterior draws using {tidybayes}. Posterior distributions will be plotted using {ggplot2} and {ggdist} with colours provided by {viridis}.

4 Load packages

First we load all the packages needed to carry out the analysis.

{
  library(bayesplot)
  library(brms)
  library(dplyr)
  library(ggplot2)
  library(ggdist)
  library(grid)
  library(tidybayes)
  library(tidyr)
  library(trps)
  library(viridis)
}

5 Assess data

In {trps} we have several data sets, they include stable isotope data ( and ) for a consumer, lake trout (Salvelinus namaycush), a benthic baseline, amphipods, and a pelagic baseline, dreissenids, for an ecoregion in Lake Ontario.

5.1 Consumer data

We check out each data set with the first being the consumer.

consumer_iso
# A tibble: 30 × 4
   common_name ecoregion  d13c  d15n
   <fct>       <fct>     <dbl> <dbl>
 1 Lake Trout  Embayment -22.9  15.9
 2 Lake Trout  Embayment -22.5  16.2
 3 Lake Trout  Embayment -22.8  17.0
 4 Lake Trout  Embayment -22.3  16.6
 5 Lake Trout  Embayment -22.5  16.6
 6 Lake Trout  Embayment -22.3  16.6
 7 Lake Trout  Embayment -22.3  16.6
 8 Lake Trout  Embayment -22.5  16.2
 9 Lake Trout  Embayment -22.9  16.4
10 Lake Trout  Embayment -22.3  16.3
# ℹ 20 more rows

We can see that this data set contains the common_name of the consumer , the ecoregion samples were collected from, and (d13c) and (d15n).

5.2 Baseline data

Next we check out the benthic baseline data set.

baseline_1_iso
# A tibble: 14 × 5
   common_name ecoregion d13c_b1 d15n_b1    id
   <fct>       <fct>       <dbl>   <dbl> <int>
 1 Amphipoda   Embayment   -26.2    8.44     1
 2 Amphipoda   Embayment   -26.6    8.77     2
 3 Amphipoda   Embayment   -26.0    8.05     3
 4 Amphipoda   Embayment   -22.1   13.6      4
 5 Amphipoda   Embayment   -24.3    6.99     5
 6 Amphipoda   Embayment   -22.1    7.95     6
 7 Amphipoda   Embayment   -24.7    7.37     7
 8 Amphipoda   Embayment   -26.6    6.93     8
 9 Amphipoda   Embayment   -24.6    6.97     9
10 Amphipoda   Embayment   -22.1    7.95    10
11 Amphipoda   Embayment   -24.7    7.37    11
12 Amphipoda   Embayment   -22.1    7.95    12
13 Amphipoda   Embayment   -24.7    7.37    13
14 Amphipoda   Embayment   -26.9   10.2     14

We can see that this data set contains the common_name of the baseline, the ecoregion samples were collected from, and (d13c_b1) and (d15n_b1).

6 Organizing data

Now that we understand the data we need to combine both data sets to estimate trophic position for our consumer.

To do this we first need to make an id column in each data set, which will allow us to join them together. We first arrange() the data by ecoregion and common_name. Next we group_by() the same variables, and add id for each grouping using row_number(). Always ungroup() the data.frame after using group_by(). Lastly, we use dplyr::select() to rearrange the order of the columns.

6.1 Consumer data

Let’s first add id to consumer_iso data frame.

con_os <- consumer_iso %>%
  arrange(ecoregion, common_name) %>%
  group_by(ecoregion, common_name) %>%
  mutate(
    id = row_number()
  ) %>%
  ungroup() %>%
  dplyr::select(id, common_name:d15n)

You will notice that I have renamed this object to con_os this is because we are modifying con_os. I have done the same to the baseline and combined objects below.

6.2 Baseline data

Next let’s add id to baseline_1_iso data frame. For joining purposes we are going to drop common_name from this data frame.

b1_os <- baseline_1_iso %>%
  arrange(ecoregion, common_name) %>%
  group_by(ecoregion, common_name) %>%
  mutate(
    id = row_number()
  ) %>%
  ungroup() %>%
  dplyr::select(id, ecoregion:d15n_b1)

6.3 Joining isotope data

Now that we have the consumer and baseline data sets in a consistent format we can join them by "id" and "ecoregion" using left_join() from {dplyr}.

combined_iso_os <- con_os %>%
  left_join(b1_os, by = c("id", "ecoregion"))

We can see that we have successfully combined our consumer and baseline data. We need to do one last thing prior to analyzing the data, and that is calculate the mean (c1) and (n1) for the baseline and add in the constant (l1) to our data frame. We do this by using groub_by() to group the data by our two groups, then using mutate() and mean() to calculate the mean values.

Important note, to run the model successfully, columns need to be named d15n, n1, and l1.

combined_iso_os_1 <- combined_iso_os %>%
  group_by(ecoregion, common_name) %>%
  mutate(
    c1 = mean(d13c_b1, na.rm = TRUE),
    n1 = mean(d15n_b1, na.rm = TRUE),
    l1 = 2
  ) %>%
  ungroup()

Let’s view our combined data.

combined_iso_os_1
# A tibble: 30 × 10
      id common_name ecoregion  d13c  d15n d13c_b1 d15n_b1    c1    n1    l1
   <int> <fct>       <fct>     <dbl> <dbl>   <dbl>   <dbl> <dbl> <dbl> <dbl>
 1     1 Lake Trout  Embayment -22.9  15.9   -26.2    8.44 -24.6  8.28     2
 2     2 Lake Trout  Embayment -22.5  16.2   -26.6    8.77 -24.6  8.28     2
 3     3 Lake Trout  Embayment -22.8  17.0   -26.0    8.05 -24.6  8.28     2
 4     4 Lake Trout  Embayment -22.3  16.6   -22.1   13.6  -24.6  8.28     2
 5     5 Lake Trout  Embayment -22.5  16.6   -24.3    6.99 -24.6  8.28     2
 6     6 Lake Trout  Embayment -22.3  16.6   -22.1    7.95 -24.6  8.28     2
 7     7 Lake Trout  Embayment -22.3  16.6   -24.7    7.37 -24.6  8.28     2
 8     8 Lake Trout  Embayment -22.5  16.2   -26.6    6.93 -24.6  8.28     2
 9     9 Lake Trout  Embayment -22.9  16.4   -24.6    6.97 -24.6  8.28     2
10    10 Lake Trout  Embayment -22.3  16.3   -22.1    7.95 -24.6  8.28     2
# ℹ 20 more rows

It is now ready to be analyzed!

7 Bayesian Analysis

We can now estimate trophic position for lake trout in an ecoregion of Lake Ontario.

There are a few things to know about running a Bayesian analysis, I suggest reading these resources:

  1. Basics of Bayesian Statistics - Book
  2. General Introduction to brms
  3. Estimating non-linear models with brms
  4. Nonlinear modelling using nls nlme and brms
  5. Andrew Proctor’s - Module 6
  6. van de Schoot et al., (2021)

7.1 Priors

Bayesian analyses rely on supplying uninformed or informed prior distributions for each parameter (coefficient; predictor) in the model. The default informed priors for a one source model are the following, assumes a normal distribution (dn; ; ), trophic position assumes a uniform distribution (lower bound = 2 and upper bound = 10), assumes a uniform distribution (lower bound = 0 and upper bound = 10), and if informed priors are desired for (n1; ; ), we can set the argument bp to TRUE in all one_source_ functions.

You can change these default priors using one_source_priors_params(), however, I would suggest becoming familiar with Bayesian analyses, your study species, and system prior to adjusting these values.

7.2 Model convergence

It is important to always run the model with at least 2 chains. If the model does not converge you can try to increase the following:

  1. The amount of samples that are burned-in (discarded; in brm() this can be controlled by the argument warmup)

  2. The number of iterative samples retained (in brm() this can be controlled by the argument iter).

  3. The number of samples drawn (in brm() this is controlled by the argument thin).

  4. The adapt_delta value using control = list(adapt_delta = 0.95).

When assessing the model we want to be 1 or within 0.05 of 1, which indicates that the variance among and within chains are equal (see {rstan} documentation on ), a high value for effective sample size (ESS), trace plots to look “grassy” or “caterpillar like,” and posterior distributions to look relatively normal.

8 Estimating trophic position

We will use functions from {trps} that drop into a {brms} model. These functions are one_source_model() which provides brm() the formula structure needed to run a one source model. Next brm() needs the structure of the priors which is supplied to the prior argument using one_source_priors(). Lastly, values for these priors are supplied through the stanvars argument using one_source_priors_params(). You can adjust the mean (), variance (), or upper and lower bounds (lb and ub) for each prior of the model using one_source_priors_params(), however, only adjust priors if you have a good grasp of Bayesian frameworks and your study system and species.

8.1 Model

Let’s run the model!

model_output_os <- brm(
  formula = one_source_model(),
  prior = one_source_priors(),
  stanvars = one_source_priors_params(),
  data = combined_iso_os_1,
  family = gaussian(),
  chains = 2,
  iter = 4000,
  warmup = 1000,
  cores = 4,
  seed = 4,
  control = list(adapt_delta = 0.95)
)
Compiling Stan program...
Start sampling

8.2 Model output

Let’s view the summary of the model.

model_output_os
 Family: gaussian 
  Links: mu = identity; sigma = identity 
Formula: d15n ~ n1 + dn * (tp - l1) 
         dn ~ 1
         tp ~ 1
   Data: combined_iso_os_1 (Number of observations: 30) 
  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
         total post-warmup draws = 6000

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
dn_Intercept     3.38      0.25     2.90     3.87 1.00     1435     1836
tp_Intercept     4.54      0.19     4.20     4.95 1.00     1430     1885

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     0.61      0.08     0.48     0.80 1.00     2097     1929

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We can see that is 1 meaning that variance among and within chains are equal (see {rstan} documentation on ) and that ESS is quite large. Overall, this means the model is converging and fitting accordingly.

8.3 Trace plots

Let’s view trace plots and posterior distributions for the model.

plot(model_output_os)

We can see that the trace plots look “grassy” meaning the model is converging!

9 Predictive posterior check

We can check how well the model is predicting the of the consumer using pp_check() from {bayesplot}.

pp_check(model_output_os)
Using 10 posterior draws for ppc type 'dens_overlay' by default.

We can see that posteriors draws (; light lines) are effectively modeling of the consumer (; dark line).

10 Posterior draws

Let’s again look at the summary output from the model.

model_output_os
 Family: gaussian 
  Links: mu = identity; sigma = identity 
Formula: d15n ~ n1 + dn * (tp - l1) 
         dn ~ 1
         tp ~ 1
   Data: combined_iso_os_1 (Number of observations: 30) 
  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
         total post-warmup draws = 6000

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
dn_Intercept     3.38      0.25     2.90     3.87 1.00     1435     1836
tp_Intercept     4.54      0.19     4.20     4.95 1.00     1430     1885

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     0.61      0.08     0.48     0.80 1.00     2097     1929

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We can see that is estimated to be 3.37 with l-95% CI of 2.89, and u-95% CI of 3.86. If we move down to trophic position (tp) we see trophic position is estimated to be 4.54 with l-95% CI of 4.21, and u-95% CI of 4.96.

10.1 Extract posterior draws

We use functions from {tidybayes} to do this work. First we look at the the names of the variables we want to extract using get_variables().

get_variables(model_output_os)
 [1] "b_dn_Intercept" "b_tp_Intercept" "sigma"          "lprior"        
 [5] "lp__"           "accept_stat__"  "stepsize__"     "treedepth__"   
 [9] "n_leapfrog__"   "divergent__"    "energy__"

You will notice that "b_tp_Intercept" is the name of the variable that we are wanting to extract. We extract posterior draws using gather_draws(), and rename "b_tp_Intercept" to tp.

post_draws <- model_output_os %>%
  gather_draws(b_tp_Intercept) %>%
  mutate(
    ecoregion = "Embayment",
    common_name = "Lake Trout",
    .variable = "tp"
  ) %>%
  dplyr::select(common_name, ecoregion, .chain:.value)

Let’s view the post_draws

post_draws
# A tibble: 6,000 × 7
# Groups:   .variable [1]
   common_name ecoregion .chain .iteration .draw .variable .value
   <chr>       <chr>      <int>      <int> <int> <chr>      <dbl>
 1 Lake Trout  Embayment      1          1     1 tp          4.23
 2 Lake Trout  Embayment      1          2     2 tp          4.26
 3 Lake Trout  Embayment      1          3     3 tp          4.39
 4 Lake Trout  Embayment      1          4     4 tp          4.44
 5 Lake Trout  Embayment      1          5     5 tp          4.33
 6 Lake Trout  Embayment      1          6     6 tp          4.74
 7 Lake Trout  Embayment      1          7     7 tp          5.06
 8 Lake Trout  Embayment      1          8     8 tp          4.40
 9 Lake Trout  Embayment      1          9     9 tp          4.42
10 Lake Trout  Embayment      1         10    10 tp          4.30
# ℹ 5,990 more rows

We can see that this consists of seven variables:

  1. ecoregion
  2. common_name
  3. .chain
  4. .iteration (number of sample after burn-in)
  5. .draw (number of samples from iter)
  6. .variable (this will have different variables depending on what is supplied to gather_draws())
  7. .value (estimated value)

11 Extracting credible intervals

Considering we are likely using this information for a paper or presentation, it is nice to be able to report the median and credible intervals (e.g., equal-tailed intervals; ETI). We can extract and export these values using spread_draws() and median_qi from {tidybayes}.

We rename b_tp_Intercept to tp, add the grouping columns, round all columns that are numeric to two decimal points using mutate_if(), and rearrange the order of the columns using dplyr::select().

medians_ci <- model_output_os %>%
  spread_draws(b_tp_Intercept) %>%
  median_qi() %>%
  rename(
    tp = b_tp_Intercept
  ) %>%
  mutate(
    ecoregion = "Embayment",
    common_name = "Lake Trout"
  ) %>%
  mutate_if(is.numeric, round, digits = 2) %>%
  dplyr::select(ecoregion, common_name, tp:.interval)

Let’s view the output.

medians_ci
# A tibble: 1 × 8
  ecoregion common_name    tp .lower .upper .width .point .interval
  <chr>     <chr>       <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 Embayment Lake Trout   4.52    4.2   4.95   0.95 median qi

I like to use {openxlsx} to export these values into a table that I can use for presentations and papers. For the vignette I am not going to demonstrate how to do this but please check out {openxlsx}.

12 Plotting posterior distributions – single species or group

Now that we have our posterior draws extracted we can plot them. To analyze a single species or group, I like using density plots.

12.1 Density plot

For this example we first plot the density for posterior draws using geom_density().

ggplot(data = post_draws, aes(x = .value)) +
  geom_density() +
  theme_bw(base_size = 15) +
  theme(
    panel.grid = element_blank()
  ) +
  labs(
    x = "P(Trophic Position | X)",
    y = "Density"
  )

12.2 Point interval

Next we plot it as a point interval plot using stat_pointinterval().

ggplot(data = post_draws, aes(
  y = .value,
  x = common_name
)) +
  stat_pointinterval() +
  theme_bw(base_size = 15) +
  theme(
    panel.grid = element_blank()
  ) +
  labs(
    x = "P(Trophic Position | X)",
    y = "Density"
  )

Congratulations we have estimated the trophic position for Lake Trout!

I’ll demonstrate in another vignette (i.e, one source - multiple groups) how to run the model with an iterative process to produce estimates of trophic position for more than one group (e.g., comparing trophic position among species or in this case different ecoregions).

Now that you have gone through a one source model, you may be looking to model trophic position using a two source model. Please see the following vignette on how to setup and run a two source model Estimate trophic position - two source model. The same iterative processes used in one source - multiple groups can be applied to the two source model.

To view all vignettes, please check out {trps}’s webpage.

]]> Stable Isotopes Trophic Dynamics Food Webs https://blog.benjaminhlina.com/posts/post-with-code/trps/ Fri, 04 Apr 2025 00:00:00 GMT MLB - Market Ranking Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/mlb-market-ranking/

2 Introduction

This will be a different type of post than I normally write. Most of the posts on this blog relate to fish and aquatic sciences and are not sports-related, but I thoroughly enjoy playing and watching sports, especially baseball.

Growing up I played second base or shortstop and have fond memories of my dad, younger brother, and myself sitting around our tiny TV watching the greats of the 1990s and 2000s. Every October, we chat about the postseason baseball and the thrill that it is. I could go on and on about my love for the sport, especially the postseason, but let’s get to the point of this post.

3 MLB 2024 Postseason

The 2024 postseason has been spectacular. There have been so many great stories and games, and it has really been a treat to watch. On top of that, we have the two best teams this year, the Yankees and Dodgers, in the World Series. Both teams hav some of the best players in the league and yet people are mad and upset by this. Why?

Sure it is nice to have an underdog to root for or teams that do not often make it, like my Minnesota Twins, but at the same time how cool is to have two juggernauts who haven’t played each other in over 40 years face off in the World Series! On top of that, the only thing that would make this World Series even more exciting, would be if Ohtani were pitching!

With this being said, there has been a lot of talk about can a team buy a World Series, especially since these two teams often have high payrolls and whether that is a good or bad thing.

With this question in hand, everyone’s favourite baseball guy, Jimmy aka Jomboy, set to the task of answering just that. He put out this great video on Talkin’ Baseball. In the video he showed the two teams that made it to the World Series each year starting in 1989 and ending in 2024, their result (i.e, won or lost), and their market ranking for that year. The market ranking is from 1 to 30, with 1 being the most amount of money spent. He did this in a table which was great, however, as a scientist and someone who loves looking at visualizations, I figured I could visualize this information to complement this video and the story Jimmy is providing. So let’s visualize this data!

4 Market Ranking of World Series Teams

Below are a few interactive visualizations of the raw market ranking for the winning and losing teams across years. The higher we go on the y-axis (i.e, the vertical axis) the better market rank (i.e., the more money a team spent). I have added a dotted line at the market rank of 10 (i.e, ) and a solid line at the market rank of 15 (i.e., 1/2).

4.1 Market Ranking for Winning Teams

For the first visualization, I have emphasized the market ranking for winning teams. Let’s take a look!

We can see there are 5 years that the winning team had a market ranking that was between 15 and 30. This means that they won without spending that much money relative to the rest of the teams.

There is, however, improved success in winning a World Series if a team has a market ranking that is between 1 and 10. This can also be viewed as being a team in the top one-third of payrolls that year.

4.2 Market Ranking for Losing Teams

For the second visualization, I have emphasized the market ranking for loosing teams. Let’s take a look!

We can see there are 8 years that the losing team had a market ranking that was between 15 and 30. This means that although they lost, they made it to the World Series without spending that much money relative to the rest of the teams.

There is, however, improved success in making it to a World series if a team has a market ranking that is between 1 and 10. This can also be viewed as being a team in the top one-third of payrolls that year.

5 Conclusion

Can you buy a World Series? - Somewhat.

Spending more money on players absolutely improves the ability of a team to make it to the World Series and gives them a better chance of winning, but it doesn’t guarantee that they will.

So should we be mad about the Yankees and Dodgers being in the World Series. No, we are going to see some amazing baseball or so I hope!

Enjoy the World Series everyone!

6 Bonus - Statistical Modelling

I often use statistical models to help answer questions about fish and aquatic ecosystems. So I’m going to apply the same approach here.

I have used a type of statistical model called a Generalized Additive Model (GAM) to look at the general trends over the past 30+ years.

Again, the general trend is that a team needs to spend money if they hope to win a World Series.

Do they need to spend the most money? No, not necessarily.

I hope you enjoyed this little analysis!

]]> MLB Generalized Additive Model https://blog.benjaminhlina.com/posts/post-with-code/mlb-market-ranking/ Wed, 23 Oct 2024 00:00:00 GMT How to use {nichetools} with SIBER Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/nichetools-siber/

0.1 Our Objectives

The purpose of this vignette is to use {SIBER} and {nichetools} to extract and then visualize estimates of trophic niche size and similarities and Layman community metrics for multiple freshwater fish using {ggplot2}.

This vignette can be used for additional purposes including estimating niche size and similarities among different groups of aquatic and/or terrestrial species. Furthermore, niche size and similarities for different behaviours exhibited within a population can be made using behavioural data generated from acoustic telemetry (e.g., differences in habitat occupancy).

0.2 Bring in trophic data

First we will load the necessary packages to preform the analysis and visualization. We will use {SIBER} and {nichetools} to preform the analysis. We will use {bayestestR} to calculate and extract medians and Equal-Tailed Interval (ETI) of posterior distributions that we want to plot. We will use {dplyr}, {tidyr}, and {purrr} to manipulate data and iterate processes. Lastly, we will use {ggplot2}, {ggtext}, and {ggdist} to plot and add labels.

I will add that many of the {dplyr} and {tidyr} functions and processes can be replaced using {data.table} which is great when working with large data sets.

We will first load the packages that were just mentioned

{
  library(bayestestR)
  library(dplyr)
  library(ggplot2)
  library(ggdist)
  library(ggtext)
  library(nichetools)
  library(purrr)
  library(SIBER)
  library(tidyr)
  library(viridis)
}
Warning: package 'nichetools' was built under R version 4.4.1

For the purpose of the vignette we will be using the demo.siber.data.2 data frame that is available within {SIBER}. We will first look at the structure of this data frame using the {dplyr} function glimpse(). For your purposes you will need to replace this with your data frame either by loading a csv, rds, or qs file. You can do this multiple ways, I prefer using readr::read_csv() for a csv but base R’s read.csv() works perfectly fine. Note, {SIBER} functions do not take tibbles or data.tables so you will have to convert either to data.frame class prior to running functions in {SIBER}.

glimpse(demo.siber.data.2)
Rows: 150
Columns: 4
$ iso1      <dbl> -11.048902, -8.809360, -9.256212, -8.380952, -10.401561, -7.…
$ iso2      <dbl> 1.02044315, 1.97597511, 3.28707260, -1.95750266, -3.11949113…
$ group     <chr> "city", "city", "city", "city", "city", "city", "city", "cit…
$ community <chr> "dublin", "dublin", "dublin", "dublin", "dublin", "dublin", …

You will notice that the community and group column are character strings that are the actual names of the communities and groups. I advise changing them into factors, thus allow you to know the order for each column prior to converting them into a numeric and then a charcter. The reason why this is important, is that functions in {SIBER} use for loops based on the indexing of the SiberObject. If this order does not match up you can have issues with the names of the communities and groups you are working with.

Let us change these into a factor, then preserve the column and create an id column that is the numerical order that will become the community and group names provided to createSiberObject().

demo.siber.data.2 <- demo.siber.data.2 %>%
  mutate(
    group = factor(group), 
    community = factor(community), 
    group_id = as.numeric(group) %>% 
      as.character(),
    community_id = as.numeric(community) %>%
      as.character()
  ) %>% 
  rename(
    group_name = group,
    community_name = community,
    group = group_id,
    community = community_id
  )

glimpse(demo.siber.data.2)
Rows: 150
Columns: 6
$ iso1           <dbl> -11.048902, -8.809360, -9.256212, -8.380952, -10.401561…
$ iso2           <dbl> 1.02044315, 1.97597511, 3.28707260, -1.95750266, -3.119…
$ group_name     <fct> city, city, city, city, city, city, city, city, city, c…
$ community_name <fct> dublin, dublin, dublin, dublin, dublin, dublin, dublin,…
$ group          <chr> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", …
$ community      <chr> "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", …

After we have done this, we are going to create two data frames that are the names of our communities and groups with their associated id values. We will use these data frames later on to join up the actual names, allowing us to know what estimates belong to which communities and groups. We are doing this because it is unlikely you will have communities and groups named 1, 2, 3 ect. and instead will have actual names.

# ---- create name with group and community data frame ----
cg_names <- demo.siber.data.2 %>%
  distinct(group,
           community, 
           group_name, 
           community_name) %>%
  
  arrange(community, group)

# ---- create community names data frame ---- 
c_names <- demo.siber.data.2 %>% 
  distinct(community, 
           community_name) %>%
  arrange(community)

We will then plot our biplot to confirm we have the correct structure.

ggplot(data = demo.siber.data.2, aes(x = iso1, y = iso2,
                                     colour = group_name)) +
  geom_point() +
  facet_wrap(~ community_name) + 
  scale_colour_viridis_d(option = "A", begin = 0.25, end = 0.85,
                         name = "Groups", alpha = 0.75) + 
  theme_bw(
    base_size = 15
  ) + 
  theme(
    strip.background = element_blank(),
    panel.grid = element_blank(), 
    axis.title = element_markdown(),
    legend.position = "inside",
    legend.position.inside = c(0.65, 0.75)
  ) + 
  labs(
    x = paste0("\U03B4","<sup>", 13, "</sup>", "C", " (‰)"),
    y = paste0("\U03B4","<sup>", 15, "</sup>", "N", " (‰)")
  )

Next we will grab the isotopes we need and the community and group ids that have already been renamed to community and group. This is important as creatSiberObject() will 1) only take the following order with the following names iso1, iso2, group, and community and 2) we will transform this tibble into a data.frame as {SIBER} will only work with a data.frame. In this case we were using tibbles but we could also be working with data.table and will need to do the same thing.

demo_siber_data <- demo.siber.data.2 %>% 
  dplyr::select(iso1, iso2, group, community) %>%
  arrange(community, group) %>% 
  as.data.frame()

0.3 Convert to {SIBER} object

First convert to our isotope data into a {SIBER} object.

siber_example <- createSiberObject(demo_siber_data)

Now that this is a {SIBER} object we can start doing some analysis using a frequentist (e.g., maximum-likelihood) or a Bayesian framework. The data and metrics generated through this analysis by {SIBER} can be extracted using functions in {nichetools}.

0.4 Bayesian Ellipse Analysis

We first need to set the parameters to run the model

# options for running jags
parms <- list()
parms$n.iter <- 2 * 10^4   # number of iterations to run the model for
parms$n.burnin <- 1 * 10^3 # discard the first set of values
parms$n.thin <- 10     # thin the posterior by this many
parms$n.chains <- 2        # run this many chains

Next we need to define the priors for each parameter of the model. This includes fitting the ellipses using an Inverse Wishart prior on the covariance matrix (), and a vague normal prior on the means ().

# fit the ellipses which uses an Inverse Wishart prior on the 
# covariance matrix Sigma, and a vague normal prior on the 
# means.
priors <- list()
priors$R <- 1 * diag(2)
priors$k <- 2
priors$tau.mu <- 1.0E-3

We will now run the model using the function siberMVN().

ellipses_posterior <- siberMVN(siber_example, parms, priors)

0.5 Extract posterior distributions for μ and Σ

We will first extract posterior distribution for using extract_mu() in {nichetools}. We will need to set the argument pkg to "SIBER" and the argument data_format to "wide". This argument takes "long" or "wide" which dictates whether the data object returned is in wide or long format. We will also use the function seperate_wider_delim() from {tidyr} to separate the community and groups names as they are joined by a .. We then will use left_join() and the cg_names data frame we created above to add in the correct community and group names.

df_mu <- extract_mu(ellipses_posterior, pkg = "SIBER", 
                    data_format = "wide") %>%
  separate_wider_delim(sample_name, cols_remove = FALSE,
                       delim = ".", names = c("community",
                                              "group")) %>%
  left_join(cg_names)

We can confirm that the posterior estimates of are correct by plotting them with {ggplot2}.

ggplot() +
  geom_point(data = df_mu, aes(x = d13c, y = d15n,
                               colour = group_name)) +
  geom_point(data = demo.siber.data.2, aes(x = iso1, y = iso2,
                                           colour = group_name)) +
  facet_wrap( ~ community_name) + 
  scale_colour_viridis_d(option = "A", begin = 0.25, end = 0.85,
                         name = "Groups", alpha = 0.75) + 
  theme_bw(
    base_size = 15
  ) + 
  theme(
    strip.background = element_blank(),
    panel.grid = element_blank(), 
    axis.title = element_markdown(),
    legend.position = "inside",
    legend.position.inside = c(0.65, 0.75)
  ) + 
  labs(
    x = paste0("\U03B4","<sup>", 13, "</sup>", "C", " (‰)"),
    y = paste0("\U03B4","<sup>", 15, "</sup>", "N", " (‰)")
  )

Notice the density of points in the center of the raw data for the corresponding colours. This density of points are the posterior estimates from the model for and are an indication that the model is iterating over the groups and communities correctly.

We are also going to extract in long format for creating ellipse, as the function that create ellipse needs the data frame of to be in long format.

df_mu_long <- extract_mu(ellipses_posterior, pkg = "SIBER") %>% 
  separate_wider_delim(sample_name, cols_remove = FALSE,
                       delim = ".", names = c("community",
                                              "group")) %>%
  left_join(cg_names)

Next we are going to extract posterior estimates of using extract_sigma().

df_sigma <- extract_sigma(ellipses_posterior, pkg = "SIBER")

Lastly, we are going to feed each and estimate to niche_ellipse() to estimate each ellipse. There are few things to know about this function and they include the following: 1) it will randomly sample 10 ellipse from the total posterior distribution of and , this seems quite standard, however, you can adjust the number of samples by changing the argument n. 2) to make the function consistently randomly sample the same set you will need to set set_seed to a numerical value. If this is not set then it will randomly sample a different set of 10 ellipses every time. 3) if you would like the function to not randomly sample set the argument random to FALSE. 4) by default it will tell you how long it takes to generate the ellipse and will have progress bars at each step. If you want to turn this off set message to FALSE. 5) if you are wanting to change the confidence level of the ellipse you can do so using the argument p_ell. This value is bound between 0 and 1.

df_el <- niche_ellipse(dat_mu = df_mu_long,
                       dat_sigma = df_sigma, 
                       set_seed = 4, n = 20) %>%
  separate_wider_delim(sample_name, cols_remove = FALSE,
                       delim = ".", names = c("community",
                                              "group")) %>%
  left_join(cg_names)

Now that we have the ellipses created we can plot them.

ggplot(data = df_el, 
       aes(x = d13c, y = d15n, 
           group = interaction(sample_number, 
                               sample_name), 
           colour = group_name)) + 
  geom_polygon(linewidth = 0.5, fill = NA) + 
  facet_wrap( ~ community_name) + 
  scale_colour_viridis_d(option = "A", begin = 0.25, end = 0.85,
                         name = "Groups", alpha = 0.75) + 
  theme_bw(
    base_size = 15
  ) + 
  theme(
    strip.background = element_blank(),
    panel.grid = element_blank(), 
    legend.position = "inside",
    axis.title = element_markdown(),
    legend.background = element_blank(), 
    legend.position.inside = c(0.65, 0.75)
  ) + 
  labs(
    x = paste0("\U03B4","<sup>", 13, "</sup>", "C", " (‰)"),
    y = paste0("\U03B4","<sup>", 15, "</sup>", "N", " (‰)")
  )

0.6 Extract Niche Size

We can use siberEllipses() from {SIBER} to estimate niche size for each posterior sample for each community and group.

sea_b <- siberEllipses(corrected.posteriors = ellipses_posterior)

Next using extract_niche_size() from {nichetools} we can extract niche size which will also add in the correct names for the communities and groups we are working with.

seb_convert <- extract_niche_size(data = sea_b,
                                  pkg = "SIBER",
                                  community_df = cg_names)

We will also extract the parametric estimate for niche size using groupMetricsML() from {SIBER}.

group_ml <- groupMetricsML(siber_example)

We can convert the output of this function using extract_group_metrics().

group_convert <- extract_group_metrics(data = group_ml,
                                       community_df = cg_names)

The object returned will have maximum-likelihood estimates for the standard ellipse area (SEA), the central standard ellipse area (SEAc), and the total area (TA). For plotting niche size we will use SEAc.

sea_c <- group_convert %>% 
  filter(metric == "SEAc")

Lastly, we can visualize the extracted niche sizes using {ggplot2}.

ggplot() +
  geom_violin(data = seb_convert, aes(x = community_name,
                                      y = sea,
                                      fill = group_name)) + 
  scale_fill_viridis_d(option = "A", begin = 0.25, end = 0.85,
                       name = "Groups", alpha = 0.75) + 
  geom_point(data = sea_c, aes(x = community_name, 
                               y = est, 
                               group = group_name,
  ), 
  size = 2.5,
  fill = "white",
  shape = 21,
  position = position_dodge(width = 0.9)) +
  theme_bw(
    base_size = 15
  ) + 
  theme(
    strip.background = element_blank(),
    panel.grid = element_blank(), 
    legend.position = "inside",
    legend.background = element_blank(), 
    legend.position.inside = c(0.85, 0.8)
  ) + 
  labs(
    x = "Communities", 
    y = expression(paste("Niche Size p(", "‰"^2, "| x)"))
  )

0.7 Niche Similarties

Now that we have extracted Bayesian estimates of niche size we are likely wanting to know how much do these niches have in common or are similar.

We can use maximum-likelihood and Bayesian frameworks to estimate the percentage of similarity within communities between groups and/or among communities with groups being consistent. We can use functions in {SIBER} to create maximum-likelihood and Bayesian estimates of niche similarity followed by functions in {nichetools} to extract these similarities.

First we need to create our comparisons that we are wanting to evaluate. We can use the function create_comparisons() to generate a list that has two-column data frames of each comparison. You can change the argument comparison to "among" to compare communities for the same group, versus "within" which compares groups within a community.

cg_names_within_com <- cg_names %>%
  create_comparisons(comparison = "within")

Next we can feed this listed data frames to either maxLikOverlap() or bayesianOverlap() using map() from {purrr}. For this exercise I have not changed .progress argument of map() but when working with large data sets I often turn this argument to TRUE to provide a progress update.

ml_within_overlap <- cg_names_within_com %>%
  map(~ maxLikOverlap(.x$cg_1, .x$cg_2, siber_example,
                      p.interval = 0.95, n = 100))

Next we can extract estimates using extract_similarities() with the type argument set to "ml".

ml_95_within_com <- extract_similarities(ml_within_overlap, 
                                         type = "ml", 
                                         community_df = cg_names)

Now we will repeat the process for bayesianOverlap(), first supplying the function with our list of data frames, next having map() iterate over this list.

bayes95_overlap <- cg_names_within_com %>%
  map(~ bayesianOverlap(.x$cg_1, .x$cg_2, ellipses_posterior,
                        draws = 100, p.interval = 0.95,
                        n = 100)
  )

Next we can extract estimates using extract_similarities() with the type argument set to "bay".

bays_95_overlap <- extract_similarities(bayes95_overlap, 
                                        type = "bay",
                                        community_df = cg_names)

Now that we have extracted maximum-likelihood and Bayesian estimates we can visualize them.

Prior to creating a point interval plot, we need to create a colour palette that will be used to identify each community.

viridis_colors_s <- viridis(4, begin = 0.25, end = 0.85,
                          option = "A",
                          alpha = 0.75
)

Now we can use point interval plots to visually represent posterior distributions.

ggplot() + 
  stat_pointinterval(data = bays_95_overlap,
              aes(x = group_1, 
                  y = prop_overlap, 
                  point_fill = group_2), 
    interval_colour = "grey60",
    point_size = 3,
    shape = 21,
    position = position_dodge(0.4)) + 
  
  geom_point(data = ml_95_within_com, aes(x = group_1, 
                                   y = prop_overlap,
                                   group = group_2), 
             shape = 21,
             fill = "white",
             size = 2,
             alpha = 0.5, 
             position = position_dodge(0.4)) + 
  scale_fill_manual(name = "Group", 
                    aesthetics = "point_fill",
                    values = viridis_colors_s) + 
  theme_bw(
    base_size = 15
  ) + 
  theme(
    panel.grid = element_blank(),
    strip.background = element_blank(),
    legend.position = "inside",
    legend.position.inside = c(0.15, 0.80),
  ) +
  labs(
    x = "Group",
    y = expression(paste("p(", "‰", "|X)"))
  )

0.8 Bayesian Estimates of Layman’s Community Metrics

First I highly recommend reading Layman et al. 2007 to understand the six community metrics that will be estimating using a Bayesian framework in this section.

To create maximum-likelihood estimate of Layman’s community metrics we first need to use communityMetricsML() from {SIBER}.

community_ml <- communityMetricsML(siber_example)

Then we can extract these estimates using extract_layman() with the type argument set to "ml". The default for this argument is "bay".

layman_ml <- extract_layman(community_ml, 
                            type = "ml", 
                            community_df = c_names)

To create Bayesian estimates of Layman’s community metrics we first need to use extractPosteriorMeans() from {SIBER} to extract posterior estimates of means for each community and group.

mu_post <- extractPosteriorMeans(siber_example, ellipses_posterior)

Next we need to use bayesianLayman() from {SIBER} and use our extracted posterior means to create Bayesian estimates for each community metric.

layman_b <- bayesianLayman(mu.post = mu_post)

Once we have created our Bayesian estimates for each community metric we can use extract_layman() to extract these estimates. The function will also create the variable labels which will first assign a new name to each community metric and secondly will reorder these names based on how these metrics are often viewed.

layman_be <- extract_layman(layman_b, community_df = c_names)

Prior to creating a point interval plot, we need to create a colour palette that will be used to identify each community.

viridis_colors <- viridis(2, begin = 0.25, end = 0.85,
                          option = "G",
                          alpha = 0.75
)

Lastly, we can visualize the distributions of the posterior estimates using stat_pointinterval() from {ggdist}.

ggplot() + 
  stat_pointinterval(
    data = layman_be, aes(x = labels, 
                          y = post_est, 
                          point_fill = community_name),
    point_size = 2.5,
    interval_colour = "grey60",
    position = position_dodge(0.4),
    shape = 21
  ) + 
  geom_point(data = layman_ml, aes(x = labels, 
                                   y = estimate,
                                   group = community_name), 
             shape = 21,
             fill = "white",
             alpha = 0.5, 
             position = position_dodge(0.4)) + 
  scale_fill_manual(name = "Community", 
                    aesthetics = "point_fill",
                    values = viridis_colors) + 
  theme_bw(
    base_size = 15
  ) + 
  theme(
    panel.grid = element_blank(),
    axis.text = element_markdown(),
    legend.position = "inside",
    legend.position.inside = c(0.88, 0.85),
  ) +
  labs(
    x = "Community Metrics",
    y = expression(paste("p(", "‰", "|X)"))
  )

Congratulations, we have successfully used functions from {SIBER} to extract and visually represent trophic communities and niche size and similarities. If you something doesn’t work/is confusing please reach out.

]]> Stable Isotopes Trophic Dynamics Food Webs https://blog.benjaminhlina.com/posts/post-with-code/nichetools-siber/ Thu, 29 Aug 2024 00:00:00 GMT How to use {nichetools} with nicheROVER Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/nichetools/

0.1 Our Objectives

The purpose of this vignette is to use {nicheROVER} and {nichetools} to extract and then visualize estimates of trophic niche size and similarities for multiple freshwater fish using {ggplot2}.

This vignette can be used for additional purposes including estimating niche size and similarities among different groups of aquatic and/or terrestrial species. Furthermore, niche size and similarities for different behaviours exhibited within a population can be made using behavioural data generated from acoustic telemetry (e.g., differences in habitat occupancy).

0.2 Bring in trophic niche data

First we will load the necessary packages to preform the analysis and visualization. We will use {nicheROVER} and {nichetools} to preform the analysis. We will use {dplyr}, {tidyr}, and {purrr} to manipulate data and iterate processes. Lastly, we will use {ggplot2}, {ggtext}, and {patchwork} to plot, add labels, and arrange plots.

I will add that many of the {dplyr} and {tidyr} functions and processes can be replaced using {data.table} which is great when working with large data sets.

{
  library(dplyr)
  library(ggplot2)
  library(ggtext)
  library(ggh4x)
  library(nicheROVER) 
  library(nichetools)
  library(patchwork)
  library(purrr)
  library(stringr)
  library(tidyr)
}

For the purpose of the vignette we will be using the fish data frame that is available within {nicheROVER}. We will remove 34S for simplicity of the vignette. If more than two isotopes or metrics are being used to compare niche sizes and similarities, please use the functions for each pairing. Right now some functions (i.e., niche_ellipse()) in {nichetools} doesn’t have the ability to work with more than two isotopes. This will become a feature at some point but for now. Please be patient and use the functions for each pairing you have.

We will first use the function janitor::clean_names() to clean up column names. For your purposes you will need to replace fish with your data frame either by loading a csv, rds, or qs, with your data. You can do this multiple ways, I prefer using readr::read_csv() but base R’s read.csv() works perfectly fine.

df <- fish %>% 
  janitor::clean_names()

If there are any isotopic values that did not run and are NA, they will need to be removed because {nicheROVER}’s functions will not accommodate values of NA.

0.3 Estimate posterior distribution with Normal-Inverse-Wishart (NIW) priors.

We will take 1,000 posterior samples for each group. You can change this but suggest nothing less than 1,000.

nsample <- 1000

We will then split the data frame into a list with each species as a data frame object within the list, We will then iterate over the list, using map() from {purrr}, to estimate posterior distribution using Normal-Inverse-Wishart (NIW) priors.

fish_par <- df %>% 
  split(.$species) %>% 
  map(~ select(., d13c, d15n)) %>% 
  map(~ niw.post(nsample = nsample, X = .))

0.4 Extract μ values

We will use extract_mu()to extract posteriors for estimates. The default output of extract_mu() is long format which works for plotting with {ggplot2} and other functions in {nichetools}. If we want wide format we can specify the argument format with "wide", however, it is unlikely you will need this data in wide format.

df_mu <- extract_mu(fish_par)

The default output will be lacking some info for plotting. We will need to add in a column that is the element abbreviation and neutron number to be used in axis labeling.

df_mu <- df_mu %>%
  mutate(
    element = case_when(
      isotope == "d15n" ~ "N",
      isotope == "d13c" ~ "C",
    ), 
    neutron = case_when(
      isotope == "d15n" ~ 15,
      isotope == "d13c" ~ 13,
    ) 
  )

0.5 Extract Σ values

We will use extract_sigma() to extract posterior estimates for . The default output of extract_sigma() is wide format which doesn’t work for plotting with {ggplot2} but does work other functions in {nichetools}. If we want long for plotting we can specify the argument format with "long".

df_sigma <- extract_sigma(fish_par)

For plotting we will need the extracted values to be in long format. We also need to remove values for when the both isotope columns are the same isotope.

df_sigma_cn <- extract_sigma(fish_par, 
                             data_format = "long") %>%
  filter(id != isotope)

0.6 Plot posterior distrubtion of μ and Σ

For most plotting within this vignette, I will split() the data frame by isotope, creating a list that I will then use imap() to iterate over the list to create plots. We will use geom_density() to represent densities for both and . Plot objects will then be stored in a list.

First we will plot for each isotope. We will use {patchwork} to configure plots for multi-panel figures. This package is phenomenal and uses math operators to configure and manipulate the plots to create multi-panel figures.

For labeling we are also going to use element_markdown() from {ggtext} to work with the labels that are needed to correctly display the isotopic signature. If you are working other data please replace.

posterior_plots <- df_mu %>%
  split(.$isotope) %>%
  imap(
    ~ ggplot(data = ., aes(x = mu_est)) +
      geom_density(aes(fill = sample_name), alpha = 0.5) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw() +
      theme(panel.grid = element_blank(),
            axis.title.x =  element_markdown(),
            axis.title.y =  element_markdown(),
            legend.position = "none",
            legend.background = element_blank()
      ) +
      labs(
        x = paste("\u00b5<sub>\U03B4</sub>", "<sub><sup>",
                  unique(.$neutron), "</sup></sub>",
                  "<sub>",unique(.$element), "</sub>", sep = ""),
        y = paste0("p(\u00b5 <sub>\U03B4</sub>","<sub><sup>",
                   unique(.$neutron), "</sub></sup>",
                   "<sub>",unique(.$element),"</sub>",
                   " | X)"), sep = "")
  )

posterior_plots$d15n +
  theme(legend.position = c(0.18, 0.82)) + 
  posterior_plots$d13c

For labeling purposes we need to add columns that are the element abbreviation and neutron number. I do this by using case_when() which are vectorized if else statements.

df_sigma_cn <- df_sigma_cn %>%
  mutate(
    element_id = case_when(
      id == "d15n" ~ "N",
      id == "d13c" ~ "C",
    ),
    neutron_id = case_when(
      id == "d15n" ~ 15,
      id == "d13c" ~ 13,
    ),
    element_iso = case_when(
      isotope == "d15n" ~ "N",
      isotope == "d13c" ~ "C",
    ),
    neutron_iso = case_when(
      isotope == "d15n" ~ 15,
      isotope == "d13c" ~ 13,
    )
  )

Next we will plot the posteriors for .

sigma_plots <- df_sigma_cn %>%
  group_split(id, isotope) %>%
  imap(
    ~ ggplot(data = ., aes(x = post_sample)) +
      geom_density(aes(fill = sample_name), alpha = 0.5) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw() +
      theme(panel.grid = element_blank(),
            axis.title.x =  element_markdown(),
            axis.title.y =  element_markdown(),
            legend.position = "none"
      ) +
      labs(
        x = paste("\U03A3","<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_id), "</sub></sup>",
                  "<sub>",unique(.$element_id),"</sub>"," ",
                  "<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_iso), "</sub></sup>",
                  "<sub>",unique(.$element_iso),"</sub>", sep = ""),
        y = paste("p(", "\U03A3","<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_id), "</sub></sup>",
                  "<sub>",unique(.$element_id),"</sub>"," ",
                  "<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_iso), "</sub></sup>",
                  "<sub>",unique(.$element_iso),"</sub>", " | X)", sep = ""),
      )
  )

sigma_plots[[1]] + 
  theme(legend.position = c(0.1, 0.82))

0.7 Estimate niche ellipse

We then will use niche_ellipse() to easily extract ellipse for each estimate (i.e., 1000). If you are to have additional isotopes or metrics, you will need to create mu and sigma objects for each pairing, as currently this function only handles two isotopes. In the future, there likely will be the ability to specify the number of isotopes you have with the default being two. The reason for the lack of functionality is ellipse::ellipse() can only work within two-dimensions, not three, so you will have to create multiple ellipse() calls for each combination of isotopes or metrics and I haven’t had the time to implement this. The function will also tell you how long it took to process as with large sets of isotope data it is nice to know the time it takes for the function to work.

ellipse_df <- niche_ellipse(dat_mu = df_mu, dat_sigma = df_sigma)
→ Total time processing was 0.03 secs

We will randomly sample 10 ellipses out of 1,000. You can change this but this seems pretty standard.

set.seed(14)

random_ellipse <- ellipse_df %>% 
  group_by(sample_name, sample_number) %>% 
  nest() %>%
  group_by(sample_name) %>% 
  slice_sample(n = 10, replace = TRUE) %>% 
  ungroup() %>% 
  unnest(cols = c(data))

0.8 Plot ellipses, densities of each istope, and isotope biplot

We will first plot the ellipse for each sample_name

ellipse_plots <- ggplot() + 
  geom_polygon(data = random_ellipse,
               mapping = aes(x = d13c, y = d15n,
                             group = interaction(sample_number, sample_name),
                             color = sample_name),
               fill = NA,
               linewidth = 0.5) + 
  
  scale_colour_viridis_d(begin = 0.25, end = 0.75, 
                         option = "D", name = "species",
  ) + 
  scale_x_continuous(breaks = rev(seq(-20, -40, -2))) +
  scale_y_continuous(breaks = seq(6, 16, 2)) +
  theme_bw(base_size = 10) +
  theme(axis.text = element_text(colour = "black"),
        panel.grid = element_blank(), 
        legend.position = "none", 
        legend.title = element_text(hjust = 0.5),
        legend.background = element_blank()) + 
  labs(x = expression(paste(delta ^ 13, "C")), 
       y = expression(paste(delta ^ 15, "N")))

We need to turn df into long format to iterate over using imap() to easily create density plots. You will notice that I again use case_when() to make columns of element abbreviations and neutron numbers that will be used in plot labeling.

iso_long <- df %>%
  pivot_longer(cols = -species,
               names_to = "isotope", 
               values_to = "value") %>% 
  mutate(
    element = case_when(
      isotope == "d15n" ~ "N",
      isotope == "d13c" ~ "C",
    ), 
    neutron = case_when(
      isotope == "d15n" ~ 15,
      isotope == "d13c" ~ 13,
    )
  )

We will then make density plots for each isotope using geom_density()

iso_density <- iso_long %>% 
  group_split(isotope) %>% 
  imap(
    ~ ggplot(data = .) + 
      geom_density(aes(x = value, 
                       fill = species), 
                   alpha = 0.35, 
                   linewidth = 0.8) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw(base_size = 10) +
      theme(axis.text = element_text(colour = "black"),
            panel.grid = element_blank(), 
            legend.position = c(0.15, 0.55), 
            legend.background = element_blank(), 
            axis.title.x = element_markdown(family = "sans")) + 
      labs(x =  paste("\U03B4",
                      "<sup>", unique(.$neutron), "</sup>",unique(.$element), 
                      sep = ""), 
           y = "Density")
  )

d13c_density <- iso_density[[1]] + 
  scale_x_continuous(breaks = rev(seq(-20, -34, -2)),
                     limits = rev(c(-20, -34)))

d15n_density <- iso_density[[2]] +
  scale_x_continuous(breaks = seq(5, 15, 2.5), 
                     limits = c(5, 15)) + 
  theme(
    legend.position = "none"
  )

Lastly we will use geom_point() to make isotopic biplot.

iso_biplot <- ggplot() + 
  geom_point(data = df, aes(x = d13c, y = d15n,
                            fill = species),
             shape = 21, colour = "black", 
             stroke = 0.8,
             size = 3, alpha = 0.70) +
  scale_fill_viridis_d(begin = 0.25, end = 0.75,
                       option = "D", name = "species") +
  scale_x_continuous(breaks = rev(seq(-20, -39, -1))) +
  scale_y_continuous(breaks = seq(5, 17, 1)) +
  theme_bw(base_size = 10) +
  theme(axis.text = element_text(colour = "black"),
        panel.grid = element_blank(), 
        legend.position = "none", 
        legend.background = element_blank()) + 
  labs(x = expression(paste(delta ^ 13, "C")), 
       y = expression(paste(delta ^ 15, "N")))

0.9 Use {patchwork} to make ellipse, density, and biplots into a paneled figure.

We can also use the function plot_annotation() to add lettering to the figure that can be used in the figure description. To maneuver where plot_annotation() places the lettering, we need to add plot.tag.position = c(x, y) to the theme() call in every plot.

d13c_density + ellipse_plots + iso_biplot + d15n_density +
  plot_annotation(tag_levels = "a", 
                  tag_suffix = ")")

0.10 Determine the 95% niche similarties for each species

We will use the overlap() function from {nicheROVER} to estimate the percentage of similarity among species. We will set overlap to assess based on 95% similarities.

over_stat <- overlap(fish_par, nreps = nsample, nprob = 1000, 
                     alpha = 0.95)

We then are going transform this output to a data frame using extract_overlap() plotting so we can assess overall similarities among species.

over_stat_df <- extract_overlap(data = over_stat) %>% 
    mutate(
      niche_overlap_perc = niche_overlap * 100
  )

We then are going to take our newly made data frame and extract out the mean percentage of similarities and the 2.5% and 97.5% quarantines. We plot these as lines and dotted lines on our percent similarity density figure.

over_sum <- over_stat_df %>% 
  group_by(sample_name_a, sample_name_b) %>% 
  summarise(
    mean_niche_overlap = round(mean(niche_overlap_perc), digits = 2),
    qual_2.5 = round(quantile(niche_overlap_perc, probs = 0.025, na.rm = TRUE), digits = 2), 
    qual_97.5 = round(quantile(niche_overlap_perc, probs = 0.975, na.rm = TRUE), digits = 2)
  ) %>% 
  ungroup() %>% 
  pivot_longer(cols = -c(sample_name_a, sample_name_b, mean_niche_overlap), 
               names_to = "percentage", 
               values_to = "niche_overlap_qual") %>% 
  mutate(
    percentage = as.numeric(str_remove(percentage, "qual_"))
  )

We are now going to use ggplot(), geom_density(), and fact_grid2() from {ggh4x}.

ggplot(data = over_stat_df, aes(x = niche_overlap_perc)) + 
  geom_density(aes(fill = sample_name_a)) + 
  geom_vline(data = over_sum, aes(xintercept = mean_niche_overlap), 
             colour = "black", linewidth = 1) +
  geom_vline(data = over_sum, aes(xintercept = niche_overlap_qual), 
             colour = "black", linewidth = 1, linetype = 6) +
  scale_fill_viridis_d(begin = 0.25, end = 0.75,
                       option = "D", name = "Species", 
                       alpha = 0.35) + 
  facet_grid2(sample_name_a ~ sample_name_b, 
                     independent = "y",
                     scales = "free_y") + 
  theme_bw() + 
  theme(
    panel.grid = element_blank(), 
    axis.text = element_text(colour = "black"), 
    legend.background = element_blank(),
    strip.background = element_blank()
  ) +
  labs(x = paste("Overlap Probability (%)", "\u2013", 
                 "Niche Region Size: 95%"), 
       y = "p(Percent Overlap | X)")

0.11 Estimate overall niche size

We are now going to estimate the overall size of the niche for each posterior sample by using the function extract_niche_size() which is a wrapper around niche.size() and some data manipulation functions.

niche_size <- extract_niche_size(fish_par)

We can calculate the mean niche size, standard deviation, and standard error.

niche_size_mean <- niche_size %>% 
  group_by(sample_name) %>% 
  summarise(
    mean_niche = round(mean(niche_size), digits = 2), 
    sd_niche = round(sd(niche_size), digits = 2), 
    sem_niche = round(sd(niche_size) / sqrt(n()), digits = 2)
  )

0.12 Plot niche size

We will now use geom_violin(), geom_point(), and geom_errorbar() to plot the distribution for niche size for each species.

ggplot(data = niche_size) + 
  geom_violin(
    aes(x = sample_name, y = niche_size),
    width = 0.2) + 
  geom_point(data = niche_size_mean, aes(x = sample_name, y = mean_niche)) +
  geom_errorbar(data = niche_size_mean, aes(x = sample_name, 
                                            ymin = mean_niche  - sem_niche, 
                                            ymax = mean_niche  + sem_niche), 
                width = 0.05) +
  theme_bw(base_size = 15) + 
  theme(panel.grid = element_blank(), 
        axis.text = element_text(colour = "black")) + 
  labs(x = "Species", 
       y = "Niche Size")

Now that we have our niche sizes and similarities determined we can make inferences about the species, trophic similarities, and the ecosystem.

]]> Stable Isotopes Trophic Dynamics Food Webs https://blog.benjaminhlina.com/posts/post-with-code/nichetools/ Fri, 15 Mar 2024 00:00:00 GMT Estimate detection efficiency for acoustic telemetry receivers Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/detection-efficiency/

2 Objectives

This vignette describes methods to quickly and easily calculate the distance from a receiver that a given percentage (e.g., 50%) of detections are heard. The preliminary analysis will allow for range transmitters to be deployed for longer duration to estimate detection efficiency over a study period.

The preliminary study design/protocol is the following:

  1. Deploy range transmitter at set distances (e.g., 100, 250, 500, and 750 m) from the receiver you are wanting to range test for 24 hr. The range transmitters used in this vignette had a min delay of 840 s and max delay of 960 s but you could use continuous transmitters or transmitter with different delays.

  2. After 24 hr retrieve transmitters and receivers and download vrl files.

  3. Import vrl files and receiver and transmitter location data into Fathom Central. Unfortunately you will need internet to do this. If you are unable to use the internet (e.g., in the field), download an older version of the detection efficiency software produced by Innovasea and import the vrl and receiver and transmitter location data. The manual for this software is quite good and will walk you through how to get your data into the detection efficiency tool. You can download the older version at the following Innovasea website. We can also determine detection efficiency in R as well. All we need is the detection csv and receiver and transmitter location data. You can also calculate initial detection efficiency using R, there is a section below that will describe how to do this.

  4. Highly suggest doing multiple 24 hr deployments at the same distances and/or drifts. If you have multiple sets of detection efficiency you will be able to create a model that fits the data better, thus ultimately improving the redeployment locations of range transmitters for longer duration (e.g., length of study).

  5. Calculate the detection efficiency for each distance over the 24 hr using detection range calculator linked above or in fathom central and export the csv.

  6. Use the exported csv to estimate the detection efficiency at a given distance using detection_range_model() from {glatos}. The function, detection_range_model(), will return an estimated distance away from the receiver for a given detection efficiency (e.g., 50%).

  7. We can use R, Python, or GIS to create redeployment locations (i.e., latitude and longitude) at the distances the model estimates for the desired detection efficiency (e.g., 50%).

  8. We can redeploy our range transmitters for a given duration (e.g., 6 month, 1 year), to determine changes in detection efficiency over the study period.

The code below will walk through how to use the detection efficiency data produced by Innovasea software to estimate the redeployment distance away from the receiver and create the redeployment location.

3 Initial deploy

We will initially deploy range transmitters at set distances away from the receiver. The below workflow will allow you to determine the latitude and longitude of each transmitter deployment and export as an excel and gpx file to easily upload to a gps or sonar unit.

3.1 Load packages and data

We will first load the desired packages in R. We will load {dplyr} for data manipulation processes, {ggplot2} to plot our models, {glatos} to use multiple functions associated with acoustic telemetry including modelling detection range, {mapview} to visualize the deployment and redeployment data, {purrr} to iterate over processes, and {sf} to work with spatial data.

# ---- Bring in R packages ----
{
  library(dplyr)
  library(ggplot2)
  library(glatos)
  library(mapview)
  library(purrr)
  library(sf)
}

We will work with the example data set in {glatos} but the receiver deployment data either in table format or as sf object and a shapefile of the body of water you’re working on.

# get path to example receiver_locations file
rec_file <- system.file("extdata",
  "sample_receivers.csv",
  package = "glatos"
)

# note that code above is needed to find the example file
# for real glatos data, use something like below
# rec_file <- "c:/path_to_file/GLATOS_receiverLocations_20150321_132242.csv"

rcv <- read_glatos_receivers(rec_file)

glimpse(rcv)

3.2 Convert to sf object

We will convert deployment data to a sf object and filter the data to only use the glatos array "OSC" for the example. You will not have to do the filtering when using your data but you will want to convert your receiver locations to a sf object and display using mapview().

rcv_osc_sf <- rcv %>%
  st_as_sf(
    coords = c("deploy_long", "deploy_lat"),
    crs = 4326
  ) %>%
  filter(glatos_array %in% "OSC")

# view in mapview
mapview(rcv_osc_sf)

We will filter out station number 12 as example to create our intial deployment rings. We will also convert into UTMs so we can estimate distances away from the receiver in meters.

rcv_osc_sf_12 <- rcv_osc_sf %>%
  filter(station_no %in% 12) %>%
  st_transform(crs = 32617)

3.3 Create buffer rings at set distances

Next, we will create buffer rings at our set distances away from the receiver. These distances are 100, 250, 500, and 750 but feel free to add more distances. If you add more distances, the model predictions will likely be more accurate.

# first create a data frame of distances to iterate over

dists <- data.frame(
  distance = c(100, 250, 500, 750)
)
# next we will split the data frame by distance and iterate over it using map
buffer_rings <- dists %>%
  split(.$distance) %>%
  map(~ st_buffer(dist = .x$distance, rcv_osc_sf_12)) %>%
  bind_rows(.id = "distance") %>%
  st_cast("LINESTRING", warn = FALSE) %>%
  dplyr::select(distance, glatos_array, station_no, ins_serial_no, geometry)
# now view buffer rings
mapview(rcv_osc_sf) +
  mapview(buffer_rings)

Now that we have the buffer rings, we are going to pick 3 locations for each distance to potentially deploy range transmitters for 24 hr. We will then create an excel and gpx file of all the locations.

First we transform our buffer rings into spatial points, view them using mapview() and filter out the points we want. Then save as an excel and/or gpx file.

buffer_rings_pts <- buffer_rings %>%
  st_cast("POINT", warn = FALSE) %>%
  mutate(
    id = 1:nrow(.)
  ) %>%
  dplyr::select(id, distance:geometry)

View them in mapview, this part will might take a little bit to select each point/figure out which ones you want.

mapview(rcv_osc_sf) +
  mapview(buffer_rings_pts)

3.4 Select locations for deployment

Then filter out the points we want, this will change depending on your study site and what locations you want. We will transform the projection back to WGS 84 as this is likely what your gps or sonar will want. We will also add in a few columns to conform to GLATOS and OTN data standards and rearrange the column order.

deploy_sites <- buffer_rings_pts %>%
  st_transform(crs = 4326) %>%
  filter(id %in% c(
    4, 49, 155,
    407, 456, 472,
    671, 696, 720,
    835, 876, 920
  )) %>%
  rename(
    receiver_serial_no = ins_serial_no
  ) %>%
  mutate(
    deploy_date_time = NA,
    deploy_lat = NA,
    deploy_long = NA,
    bottom_depth = NA,
    riser_length = NA,
    instrument_depth = NA,
    ins_model_number = NA,
    ins_serial_no = NA,
    transmitter = NA,
    transmitter_model = NA,
    deployed_by = NA,
    recovered = NA,
    recover_date_time = NA,
    recover_lat = NA,
    recover_long = NA,
    data_downloaded = NA,
    download_date_time = NA,
    comments = NA,
    expect_deploy_lat = st_coordinates(.)[, "Y"],
    expect_deploy_long = st_coordinates(.)[, "X"],
    comments = NA
  ) %>%
  dplyr::select(
    id:receiver_serial_no,
    deploy_date_time:expect_deploy_long, geometry
  )

3.5 Export to excel and gpx formats

Then we will save as an excel and gpx file. To save as excel we will use {openxlsx}. You will notice that I don’t have it in the load packages area of this vignette. I have not placed it there for the purpose of how R builds vignettes but please add it to your load packages call. You will also need to replace "YOUR_FILE_PATH" with your file path for both saving as an excel and/or gpx file.

# drop geometry (coerce to data.frame)
deploy_sites_df <- st_drop_geometry(deploy_sites)

# write xlsx file
openxlsx::write.xlsx(deploy_sites_df, "YOUR_FILE_PATH.xlsx")

# save as gpx
st_write(deploy_sites, "YOUR_FILE_PATH.gpx",
  driver = "GPX",
  dataset_options = "GPX_USE_EXTENSIONS=YES"
)

Now that you’ve created the excel and gpx file you can head out in the field to deploy your ranges transmitters for a given amount of time (e.g., 24 hr). After the time period you will retriever your receivers, download the vrl files and bring them into fathom central or the older detection range software. Once you export the csv you can move on to the next part of this vignette which is the analysis side.

3.6 Preliminary data download

Import vrl files and receiver and transmitter location data into Fathom Central. Unfortunately you will need internet to do this. If you are unable to use the internet (e.g., in the field), download an older version of the detection efficiency software produced by Innovasea and import the vrl and receiver and transmitter location data. The manual for this software is quite good and will walk you through how to get your data into the detection efficiency tool. You can download the older version at the following Innovasea website. Alternatively, you can calculate preliminary detection efficiency in R.

To do this in R can either read in each vrl file into R using {glatos} or {rvdat} or create a vue database, bring in all vrl files, and export the detection file as a csv.

Next, add in a column that is the number of detections expected to be heard in 24 hr for the given delays. To do this we can take the number of seconds in a day, 86400 s, divided by average delay which in this case is 900 s. This value, 96, means that we should hear 96 detections in a day if a receiver heard all detections.

We can use the following example code to determine the preliminary percentage of detections that were heard at the set distances.

det_summary <- dets %>%
  group_by(station, dets_expected, tag_serial_name) %>%
  summarise(
    dets_heard = n()
  ) %>%
  ungroup() %>%
  mutate(
    dets_eff = dets_heard / dets_expected,
    dets_eff_perc = (dets_heard / dets_expected) * 100
  )

4 Analysis

For the analysis you will want to start a new R script, hence why I have left load packages below.

4.1 Load packages and data

# ---- Bring in R packages ----
{
  library(dplyr)
  library(ggplot2)
  library(glatos)
  library(mapview)
  library(purrr)
  library(sf)
}

Considering we will be starting a new script and you will need the location of the receiver we will bring this information back in. For this example I will bring in the receiver location data that we used in the first half of the vignette

# get path to example receiver_locations file
rec_file <- system.file("extdata",
  "sample_receivers.csv",
  package = "glatos"
)

# note that code above is needed to find the example file
# for real glatos data, use something like below
# rec_file <- "c:/path_to_file/GLATOS_receiverLocations_20150321_132242.csv"

rcv <- read_glatos_receivers(rec_file)

glimpse(rcv)
Rows: 898
Columns: 23
$ station               <chr> "WHT-009", "FDT-001", "FDT-004", "FDT-003", "FDT…
$ glatos_array          <chr> "WHT", "FDT", "FDT", "FDT", "FDT", "DTR", "DTR",…
$ station_no            <chr> "9", "1", "4", "3", "2", "1", "2", "3", "4", "1"…
$ consecutive_deploy_no <int> 1, 2, 2, 2, 2, 2, 2, 2, 2, 1, 5, 2, 1, 2, 2, 1, …
$ intend_lat            <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, …
$ intend_long           <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, …
$ deploy_lat            <dbl> 43.74216, 45.93014, 45.94764, 45.93794, 45.92377…
$ deploy_long           <dbl> -82.50791, -83.50204, -83.48847, -83.46884, -83.…
$ recover_lat           <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, …
$ recover_long          <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, …
$ deploy_date_time      <dttm> 2010-09-22 18:05:00, 2010-11-12 15:07:00, 2010-…
$ recover_date_time     <dttm> 2012-08-15 16:52:00, 2012-05-15 13:25:00, 2012-…
$ bottom_depth          <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 1.5,…
$ riser_length          <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 0.5,…
$ instrument_depth      <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 1, N…
$ ins_model_no          <chr> "VR2W", "VR3", "VR3", "VR3", "VR3", "VR3", "VR3"…
$ glatos_ins_frequency  <int> 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, …
$ ins_serial_no         <chr> "109450", "442", "441", "444", "447", "439", "44…
$ deployed_by           <chr> "", "", "", "", "", "", "", "", "", "", "", "", …
$ comments              <chr> "", "", "", "", "", "", "", "", "", "", "", "", …
$ glatos_seasonal       <chr> "NO", "No", "No", "No", "No", "No", "No", "No", …
$ glatos_project        <chr> "HECWL", "DRMLT", "DRMLT", "DRMLT", "DRMLT", "DR…
$ glatos_vps            <chr> "NO", "No", "No", "No", "No", "No", "No", "No", …

4.2 Convert to sf object

We will convert deployment data to a sf object and filter the data to only use the glatos array "OSC" for the example. You will not have to do the filtering when using your data but you will want to convert your receiver locations to a sf object and display using mapview().

rcv_osc_sf <- rcv %>%
  st_as_sf(
    coords = c("deploy_long", "deploy_lat"),
    crs = 4326
  ) %>%
  filter(glatos_array %in% "OSC")

# view in mapview
mapview(rcv_osc_sf)

We will filter out station number 12 as example to create our intial deployment rings. We will also convert into UTMs so we can estimate distances away from the receiver in meters.

rcv_osc_sf_12 <- rcv_osc_sf %>%
  filter(station_no %in% 12) %>%
  st_transform(crs = 32617)

Next, we will bring in our example data which is loaded with {glatos} but you will need to replace sample_detection_efficiency with your data frame either by loading the csv produced by Innovasea software. You can do this multiple ways, I prefer using readr::read_csv() but base R works perfectly fine.

# ----- uncomment the lines below to bring in your data ----
#
# and replace with the file path and name of detection efficiency
# file (replace "YOUR_DET_EFF.csv")
#
# det_eff <- readr::read_csv("YOUR_DET_EFF.csv")
#
# glimpse(det_eff)

# view sample detection efficiency data

sample_detection_efficiency

glimpse(sample_detection_efficiency)

4.3 Calculate distances

Next we will use detection_range_model() to produce estimated distances for particular percentage (e.g., 50%). You will want to look through the help page for the function to make sure you’re setting up the model correctly.

Few additional tips:

  1. With fewer data points a third order polynomial often fits the data better, however, this does not mean that either a logit or probit model should not be assessed.

  2. If a third order polynomial model is selected, the formula call can be in two different formats. The preferred and default format is y ~ -1 + x + I(x ^ 2) + I(x ^ 3) + offset(y-intercept), therefore, model_frame argument needs to be set "data_frame", which is the default, to properly extract parameters and determine distances from a receiver for the percentage of interest. If using the base::poly() in the formula such as, y ~ -1 + poly(x, 3, raw = TRUE) + offset(y-intercept), then, model_frame argument needs to be set to "matrix". Both formula formats have offset() which sets the y-intercept. The y-intercept needs to be set to 100, as x needs to equal 0 m from a receiver because you expect to hear a tag 100% of the time.

  3. A third order polynomial will handle preliminary detection efficiency percentages (y variable) as whole numbers as the model is not bound by 0 and 1. While both logit and probit models use percentages as decimals as the models are bound by 0 and 1.

First, we will use a third order polynomial.

# third order polynomial: ave_percent is a whole number
m <- detection_range_model(
  avg_percent ~ -1 + distance_m + I(distance_m^2) +
    I(distance_m^3) + offset(intercept),
  data = sample_detection_efficiency,
  percentage = c(10, 50, 90),
  link = "polynomial",
  model_frame = "data_frame"
)
Warning: Check if your formula is correct for the model_frame argument

Second, we will model the same data using a logit and probit model.

# logit model: aver percent is in decimal form

m1 <- detection_range_model(avg_percent_d ~ distance_m,
  data = sample_detection_efficiency,
  percentage = c(10, 50, 90),
  link = "logit",
  summary_stats = TRUE
)

# probit model: aver percent is in decimal form

m2 <- detection_range_model(avg_percent_d ~ distance_m,
  data = sample_detection_efficiency,
  percentage = c(10, 50, 90),
  link = "probit",
  summary_stats = TRUE
)

We will then view each of the results with the first being the third order polynomial.

m
# A tibble: 3 × 19
      p distance    df chi_square      pgof     a  a_se a_sig        b     b_se
  <dbl>    <dbl> <int>      <dbl>     <dbl> <dbl> <dbl> <dbl>    <dbl>    <dbl>
1    10      634     4      1304. 4.20e-281 0.202 0.183 0.332 -0.00136 0.000753
2    50      371     4      1304. 4.20e-281 0.202 0.183 0.332 -0.00136 0.000753
3    90      217     4      1304. 4.20e-281 0.202 0.183 0.332 -0.00136 0.000753
# ℹ 9 more variables: b_sig <dbl>, d <dbl>, d_se <dbl>, d_sig <dbl>,
#   offset <dbl>, resid_se <dbl>, r2 <dbl>, adj_r2 <dbl>, aic <dbl>

Second being the logit model.

m1
# A tibble: 3 × 14
      p distance    df chi_square  pgof   slope slope_se slope_sig intercept
  <dbl>    <dbl> <int>      <dbl> <dbl>   <dbl>    <dbl>     <dbl>     <dbl>
1    10     503.     5      0.751 0.980 -0.0165   0.0155     0.287      6.08
2    50     369.     5      0.751 0.980 -0.0165   0.0155     0.287      6.08
3    90     236.     5      0.751 0.980 -0.0165   0.0155     0.287      6.08
# ℹ 5 more variables: intercept_se <dbl>, intercept_sig <dbl>, z_value <dbl>,
#   null_deviance <dbl>, aic <dbl>

and third the probit model.

m2
# A tibble: 3 × 14
      p distance    df chi_square  pgof    slope slope_se slope_sig intercept
  <dbl>    <dbl> <int>      <dbl> <dbl>    <dbl>    <dbl>     <dbl>     <dbl>
1    10     521.     5      0.864 0.973 -0.00815  0.00664     0.220      2.97
2    50     364.     5      0.864 0.973 -0.00815  0.00664     0.220      2.97
3    90     207.     5      0.864 0.973 -0.00815  0.00664     0.220      2.97
# ℹ 5 more variables: intercept_se <dbl>, intercept_sig <dbl>, z_value <dbl>,
#   null_deviance <dbl>, aic <dbl>

Considering the example data set is quite limited, you will notice each model performs differently, especially, the third-order polynomial which fits better than the logit and probit models. Each model predicts that at 50% detections will be heard at roughly 365-370 m away from the receiver.

4.4 Plot all three models

We will first plot the third order polynomial model first because there is a scaling issue as the third order polynomial is bound by 0-100 while the probit and logit models are bound by 0-1.

ggplot() +
  geom_point(
    data = sample_detection_efficiency,
    aes(x = distance_m, y = avg_percent),
    size = 3
  ) +
  geom_hline(yintercept = c(10, 50, 90), linetype = 2) +
  geom_smooth(
    data = sample_detection_efficiency,
    aes(x = distance_m, y = avg_percent),
    method = "lm",
    linewidth = 1,
    formula = y ~ -1 + x + I(x^2) +
      I(x^3),
    method.args = list(offset = sample_detection_efficiency$intercept),
    colour = "#8da0cb", se = FALSE
  ) +
  scale_y_continuous(breaks = seq(0, 100, 20)) +
  theme_bw(base_size = 15) +
  theme(
    panel.grid = element_blank()
  ) +
  labs(
    x = "Distance (m)",
    y = "Detection efficency (%)"
  )

I have added in the dotted lines at where the 10, 50, and 90% detection efficiency occurs. We will then plot the logit and probit models next.

ggplot() +
  geom_point(
    data = sample_detection_efficiency,
    aes(x = distance_m, y = avg_percent_d),
    size = 3
  ) +
  geom_hline(yintercept = c(0.10, 0.50, 0.90), linetype = 2) +
  geom_smooth(
    data = sample_detection_efficiency,
    aes(x = distance_m, y = avg_percent_d),
    method = "glm",
    linewidth = 1,
    method.args = list(family = binomial(link = "logit")),
    colour = "#66c2a5", se = FALSE
  ) +
  geom_smooth(
    data = sample_detection_efficiency,
    aes(x = distance_m, y = avg_percent_d),
    method = "glm",
    linewidth = 1,
    method.args = list(family = binomial(link = "probit")),
    colour = "#fc8d62", se = FALSE
  ) +
  scale_y_continuous(breaks = seq(0, 1, 0.20)) +
  theme_bw(base_size = 15) +
  theme(
    panel.grid = element_blank()
  ) +
  labs(
    x = "Distance (m)",
    y = "Detection efficency (%)"
  )

Now that we have our distances, we will need to create locations at the given percentages (e.g., 50%) we want to deploy for the course of the study. Given the above data we will deploy range transmitters at 365-370 m away from the receiver.

5 Redeployment

5.1 Create buffer ring

The first step in redeployment of the range transmitters is to calculate a buffer ring at the given distance estimated from the models (e.g., 370 m). We will use steps very similar to the deployment steps.

redeploy_loc <- st_buffer(dist = 370, rcv_osc_sf_12) %>%
  st_cast("LINESTRING") %>%
  mutate(
    distance = 370
  ) %>%
  dplyr::select(distance, glatos_array, station_no, ins_serial_no, geometry)
# now view redeployment rings
mapview(rcv_osc_sf) +
  mapview(redeploy_loc)

Now that we have the redeployment ring, we are going to pick 3 locations to potentially deploy range transmitters for the study period. We will then create an excel and gpx file of all the locations.

First we transform our buffer rings into spatial points, view them using mapview() and filter out the points we want. Then save as an excel and/or gpx file.

redeploy_loc_pts <- redeploy_loc %>%
  st_cast("POINT") %>%
  mutate(
    id = 1:nrow(.)
  ) %>%
  dplyr::select(id, distance:geometry)

View them in mapview, this part will might take a little bit to select each point/figure out which ones you want.

mapview(rcv_osc_sf) +
  mapview(redeploy_loc_pts)

5.2 Select redeployment location

Then filter out the points we want, this will change depending on your study site and what locations you want. We will transform the projection back to WGS 84 as this is likely what your gps or sonar will want. We will also add in a few columns to conform to GLATOS and OTN data standards and rearrange the column order.

redeploy_sites <- redeploy_loc_pts %>%
  st_transform(crs = 4326) %>%
  filter(id %in% c(116, 161, 201)) %>%
  rename(
    receiver_serial_no = ins_serial_no
  ) %>%
  mutate(
    deploy_date_time = NA,
    deploy_lat = NA,
    deploy_long = NA,
    bottom_depth = NA,
    riser_length = NA,
    instrument_depth = NA,
    ins_model_number = NA,
    ins_serial_no = NA,
    transmitter = NA,
    transmitter_model = NA,
    deployed_by = NA,
    recovered = NA,
    recover_date_time = NA,
    recover_lat = NA,
    recover_long = NA,
    data_downloaded = NA,
    download_date_time = NA,
    comments = NA,
    expect_deploy_lat = st_coordinates(.)[, "Y"],
    expect_deploy_long = st_coordinates(.)[, "X"],
    comments = NA
  ) %>%
  dplyr::select(
    id:receiver_serial_no,
    deploy_date_time:expect_deploy_long, geometry
  )

5.3 Export as an excel and gpx formats

Then we will save as an excel and gpx file. To save as excel we will use {openxlsx}. You will notice that I don’t have it in the load packages area of this vignette. I have not placed it there for the purpose of how R builds vignettes but please add it to your load packages call. You will also need to replace "YOUR_FILE_PATH" with your file path for both saving as an excel and/or gpx file.

# drop geometry (coerce to data.frame)
redeploy_sites_df <- st_drop_geometry(redeploy_sites)

# write xlsx file
openxlsx::write.xlsx(redeploy_sites_df, "YOUR_FILE_PATH2.xlsx")

# save as gpx
st_write(redeploy_sites, "YOUR_FILE_PATH2.gpx",
  driver = "GPX",
  dataset_options = "GPX_USE_EXTENSIONS=YES"
)

Now that you’ve created the excel and gpx file you can head out in the field to deploy your ranges transmitters for your study period. After the time period you will retriever your receivers, download the vrl files and create detection csvs. From there you can filter your range transmitters, calculate the number of heard in a day (e.g., 38) and divide it by the number you’re supposed to hear (e.g., 96), to get your daily detection efficiency. You can then model changes in daily detection efficiency over the course of the study. Congratulations! You have now successfully calculated your receiver detection range over your study time period.

]]> Acoustic Telemetry GLATOS Generalized Linear Model https://blog.benjaminhlina.com/posts/post-with-code/detection-efficiency/ Tue, 05 Mar 2024 00:00:00 GMT Animal movement across a boundary Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/find-ts-bnd/

0.1 Our Objectives

The purpose of this vignette is to determine when (i.e., time stamps), where (i.e., nodes) and how long, an animal takes to cross a boundary (i.e., line or polygon). The rational for wanting to determine time spent crossing a boundary could be multiple situations. For example, wanting to estimate the amount of time it took for a fish to migrate into or out of a marine protected area (MPA) or a commercial fishing zone in Lake Michigan using satellite or acoustic telemetry data. This vignette was inspired the following twitter post with the initial ideas of a solution inspired by the following blog post by Jesse Sadler focused on network analysis. Additional chunks of code came from Shortest Paths Within a Boundary - {pathroutr} and within functions in {soapcheckr}. Another interesting note is that this problem might be solved with functions from {lwgeom}, {sftime}, {move}, {crawl}, {aniMotum, {trackeR}, and {sftracks}. I don’t have as much experience using serveral of these packages but they might provide an easier workflow to answer this problem.

You can download and unzip this vignette using the following code:

install.packages("usethis")
usethis::use_course("https://github.com/benjaminhlina/find-ts-bnd/archive/refs/heads/master.zip")

0.2 load packages, data, and boundary

We will first load all the packages we need, we will use {lwgeom} to extract lat and lon of each change in direction using st_startpoint() and st_endpoint() and {sf} to find tracks that cross our boundary.

{
  library(dplyr)
  library(ggplot2)
  library(here)
  library(lwgeom)
  library(purrr)
  library(readr)
  library(sf)
  make_line <- function(lon, lat, llon, llat) {
    st_linestring(matrix(c(lon, llon, lat, llat), 2, 2,))
  }
}

Next we will bring in our example detection data for a single fish that was tagged with a satellite or acoustic telemetry transmitter.

dat <- read_csv(here("data", 
                     "example_movement_data.csv"))
glimpse(dat)

For initial plotting purposes we will transform our detection data into a sf object that is a compilation of all the movements into a LINESTRING. We will only use dat_sf for visualization and not data manipulation to answer this problem.

dat_sf <- dat %>% 
  st_as_sf(coords = c("lon", "lat"), crs = 4326) %>% 
  group_by(id) %>% 
  summarise(do_union = FALSE) %>% 
  st_cast("LINESTRING")

Next we will bring in our example MPA shapefile as a sf object. For this exercise the boundary needs to be either a LINESTRING or MULTILINESTRING as POLYGON and MULTIPOLYGON will not work because the area inside the polygon is considered filled.

bnd <- st_read(dsn = here("data", 
                          "shapefile", 
                          "."), 
               layer = "example_mpa") %>% 
  st_cast("MULTILINESTRING")

0.3 Intial plot of movement

We will use {ggplot2} and geom_sf() to initially visualize our tracks.

ggplot() + 
  geom_sf(data = bnd, fill = NA, colour = "blue", linewidth = 1) + 
  geom_sf(data = dat_sf) + 
  theme_void()

We can notice that there are few times the fish moves from outside to inside of the MPA or vis versa. We want to know the location of those two nodes and the time between the detections to know how long it took the fish to move from outside to inside and vis versa.

0.4 Create our from and to data frame

We need to take the detection data and split it up so that each subsequent detection time stamp, latitude, and longitude are in a separate column. We can do this by using the lag() function from either {dplyr} or {data.table}. We will also set the argument default for dplyr::lag() to equal first(YOUR_VARIABLE_NAME) so when lagging back to the previous value for the first time, lag() does not create a NA value.

to_from <- dat %>% 
  mutate(
    from_ts = dplyr::lag(time_stamp, default = first(time_stamp)),
    to_ts = time_stamp,
    llat = dplyr::lag(lat, default = first(lat)),
    llon = dplyr::lag(lon, default = first(lon)),
  ) %>% 
  dplyr::select(-time_stamp)

0.5 Create our tracks for each change in direction

Now that we have our to and from dataframe we are going to select the from and to latitudes and longitudes and make each movement a LINESTRING using the supplied function above make_line(). We will then convert that into a complied sf object and extract the longitudes from each movement LINESTRING using st_startpoint() and st_endpoint() from {lwgeom}. We will add this as a column to our sf object and transform it to a character because the next step involves left_join() from {dplyr} which cannot join based on a double precision numeric.

tracks_sf <- to_from %>%
  dplyr::select(lon, lat, llon,llat) %>% 
  pmap(make_line) %>%
  st_as_sfc(crs = 4326) %>%
  st_sf() %>% 
  mutate(
    lon = st_startpoint(.) %>%
      st_coordinates(.) %>%
      as_tibble() %>%
      .$X %>% 
      as.character(),
    llon = st_endpoint(.) %>%
      st_coordinates(.) %>%
      as_tibble() %>%
      .$X %>% 
      as.character()
  )

0.6 Join our tracks to our from and to timestamps

First we need to make sure our from and to latitudes and longitudes are characters otherwise left_join() will not work. We will also select the columns we only need to join. If you want to know the location of each node you can select all from and to latitudes and longitudes.

to_from_select <- to_from %>% 
  mutate(across(.cols = c(lon, lat, llon, llat), as.character)) %>% 
  dplyr::select(id, lon, llon, from_ts, to_ts)

Next we will left_join() our tracks sf object to our timestamps and fish id dataframe lastly we will drop the lon and llon columns as we no longer need them in our sf object unless you want the location of each from and to node.

tracks_sf <- tracks_sf %>% 
  left_join(to_from_select,
            by = c("lon", "llon")) %>% 
  dplyr::select(-c("lon", "llon"))

0.7 Determine the movements that fall outside the boundary

We can use st_intersects() with the sparse argument set to FALSE. This will produce a matrix of TRUE or FALSE depending on whether each LINESTRING intersects the boundary. To return a vector of TRUE/FALSE instead of a matrix we add the [TRUE] at the end of the call of st_intersects().

tracks_sf <- tracks_sf %>% 
  mutate(
    x_bnd = st_intersects(bnd, tracks_sf, sparse = FALSE)[TRUE]
  )

Congratulations! We now have a column of TRUE/FALSE that lets us know whether or not the fish crossed the boundary. We can then filter out any movement that didn’t cross the boundary.

tracks_sf_x <- tracks_sf %>% 
  filter(x_bnd %in% TRUE)

0.8 Plotting tracks that cross the boundary

We can use {ggplot} or {mapview} to view when the fish moved across the boundary. {mapview} is nice to create an interactive plot for exploration but for any type of publication or report you’ll more than likely need a static figure and can produce it using {ggplot}.

ggplot() + 
  geom_sf(data = bnd, colour = "blue", size = 1, fill = NA) + 
  geom_sf(data = tracks_sf_x) +
  theme_void()

0.9 Calculate time it took to cross the boundary

We can use the base function difftime() to get the time difference between our from and to detections. By calculating the time difference we now know the duration it took the fish to migrate across the boundary.

tracks_sf_x <- tracks_sf %>% 
  mutate(
    time_diff = difftime(to_ts, from_ts)
  )

You will notice that the difference in time in this example is consistent because the example dataset uses a manufactured sequence that is equally spaced. In your dataset this column should vary depending on how the fish moved.

Congratulations! You have now determined when, where, and how long it took for a fish to migrate across a boundary!

]]> Spatial Analysis Acoustic Telemetry Movement https://blog.benjaminhlina.com/posts/post-with-code/find-ts-bnd/ Wed, 06 Dec 2023 00:00:00 GMT How to use {soapcheckr} to make soap-flim smoothers Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/soapcheckr/

0.1 Our Objectives

The purpose of this vignette is to demonstrate an effective workflow while using {soapcheckr} to efficiently make a soap-film smoother for a Generalized Additive Model (GAM) using the package {mgcv}. Soap-film smoothers are really useful when trying to model a variable within a 3-dimensional space (e.g., bathymetry of a lake; Gavin Simpson Blog Post). They can be used for all sorts of data but are quite complex and difficult to setup. {soapcheckr} tries to make this process a little easier. This vignette will walk through several different examples using example data sets loaded when loading {soapcheckr} and {mgcv}. We strongly encourage going through both examples, as the first provides a general background on soap-films within a simple boundary and the second a more complex example within a more complex boundary.

0.2 Example 1: Making a soap-film smoother for a Simple boundary - Ramsay’s horseshoe

If we were wanting to make a soap-film smoother for a boundary that does not have any inner boundaries (e.g., a lake without an island) we can use {soapcheckr} to assess our single boundary and the potential knots we want to smooth over.

0.2.1 Install {soapcheckr}

install.packages("devtools")
devtools::install_github("dill/soapcheckr")

0.2.2 Load packages

We will use some data manipulation functions from {dplyr} and some spatial functions from {sf} to first check if we can make a soap-film using {soapcheckr} and second to run a GAM using {mgcv} with a soap-film smoother.

{
  library(broom.mixed)
  library(fitdistrplus)
  library(dplyr)
  library(ggplot2)
  library(gratia)
  library(mgcv)
  library(purrr)
  library(soapcheckr)
  library(sf)
}

0.2.3 Check if we can make a soap-film for Ramsey’s horseshoe

We will load Ramsey’s horseshoe from {mgcv} and make it a list within a list to sufficiently create the boundary a soap-film smoother needs within a GAM.

fsb <- list(fs.boundary())

We can then can check the boundary using soap_check().

soap_check(fsb)

#> [1] TRUE

We can see that soap_check() returns TRUE indicating that we can use this boundary to make a soap-film smoother. soap_check() will assess if the boundary supplied, has any overlapping polygons and is in the correct structure for a soap-film smoother to be run in {mgcv}.

0.2.4 Check if the data and the evenly spaced knots fall within the boundary

Sometimes knots are too close to the boundary, resulting with errors from the model that look like this:

Error in crunch.knots(ret$G, knots, x0, y0, dx, dy) :
knot 1 is on or outside boundary

It can be tedious and annoying to try to figure out which knots and/or data points are causing issues. The below workflow will demonstrate how to effectively remove knots and/or data points that result in the above error within the GAM.

We will use expand.grid() to create an equally spaced grid of knots. Then we remove knots outside of the boundary using inSide() from {mgcv}. There still may be knots that are too close to the boundary that will cause for a soap-film smoother to not work.

# create knots 
knots <- expand.grid(x = seq(min(fsb[[1]]$x), 
                             max(fsb[[1]]$x), len = 15),
                     y = seq(min(fsb[[1]]$y) + 0.05,
                             max(fsb[[1]]$y), len = 10))
x <- knots$x
y <- knots$y

# identify the knots that are outside the boundary 
ind <- inSide(fsb, x = x, y = y)
# remove knots outside the boundary 
knots <- knots[ind, ]

We will also create some fake data to test the model. We will use a uniform distribution to make our test data and a response variable will be created using fs.test(). We will use inSide() to remove data that fall outside our boundary.

set.seed(0)
n <- 600

# Our x and y data 
x <- runif(n) * 5 - 1
y <- runif(n) * 2 - 1

# create our response variable 
z <- fs.test(x, y, b = 1)

## remove outsiders

ind <- inSide(fsb, x = x, y = y) 

z <- z + rnorm(n) * 0.3 ## add noise

# create the data we want to model 
dat <- data.frame(z = z[ind],
                  x = x[ind],
                  y = y[ind])

However, there still may be knots and/or data points that are too close to the boundary. One can go through, one-by-one and remove the offending knots as crunch.knots() finds them, but that’s a bit tedious. Enter soap_check() and autocruncher(), with the former allowing one to visually check what knots and/or data will causes issues and the latter identifying the index location of the offending knots or data points. If the knot dataframe has column names other than x and y, we need to supply soapcheckr() those names using the arguments x_name and y_name, respectfully.

soap_check(fsb, knots = knots)
#> Warning in soap_check(fsb, knots = knots): Knots 1, 13, 66, 93 are outside the
#> boundary.

#> [1] TRUE

We can see that there four offending knots that we can subsequently remove using autocruncher(). This function will return the indices of the knots that would cause issues. If the knot dataframe has column names other than x and y, we need supply those column names to the arguments xname and yname, respectfully. Note that you need to set the k and nmax arguments in autocruncher() to be the same as your planned value in gam().

crunch_index <- autocruncher(fsb, knots, k = 30)
crunch_index
#> [1]  1 13 66 93

# remove knots that are problematic
knots <- knots[-crunch_index, ]

We can use soap_check() again to check if knots all fall within the boundary.

soap_check(fsb, knots = knots)

#> [1] TRUE

And they do! Congratulations!

0.2.5 Check the data

We can also use soap_check() to check if our data falls within the boundary, but soap_check() only cares about the coordinates you want to supply the soap-film. So first we will create a secondary dataframe that has the response variable, z, removed from it.

dat_2 <- dat[, 2:3]
soap_check(fsb, data = dat_2)

#> [1] TRUE

Congrats we can see our data doesn’t fall too closely to boundary and is within the boundary.

0.2.6 Run the model

Between data, knots, and boundary all column names must be the same for the model to work. Prior to running confirm that they are all the same.

m <- gam(z ~ s(x, y, k = 30 , bs = "so",
               xt = list(bnd = fsb)),
         knots = knots, 
         data = dat)

Next, check main effects of the model.

anova(m)

Then visually check the model effects using draw() from {gratia}

draw(m)

Lastly, check the model fit using appraise() from {gratia}

appraise(m)

We can see the model fits well and is appropriate for the example data. Now that you’ve walked through a simple boundary, we will go to a more complex boundary example. More than likely you will be working with a complex boundary. The below walk through can be applied to a simple boundary as well.

0.3 Example 2: Making a soap-film smoother for a more complex boundary.

More than likely you will have your boundary as a sf object. To convert that sf object into the boundary list needed by {mgcv} and {soapcheckr}, we will have to do some conversions. First that boundary might not be in the correct coordinate reference system (CRS). To create a soap-film smoother we need to use a CRS that for one unit change in either dimension (i.e., x and y) are equal. For example using latitude and longitude in decimal degrees with a WGS 84 projection will not work because one unit of change in either direction is not equal. Therefore, we will need to use a CRS that is based on equal units. The most common CRS to do this is UTMs, if the boundary is already in UTMs great, if not see below.

0.3.1 Convert CRS

The more complex boundary that we will load through {soapcheckr} is a lake from northern Wisconsin, Sissabagama Lake. I grew up fishing on this lake which is where initially became interested and passionate about aquatic ecosystems, fish, and fisheries management. This lake falls within UTM zone 15N that can also be refereed to as ESPG: 32615, but your boundary will more than likely fall into a different CRS. You can look up ESPG codes here.

sissabagama_lake_sf <- sissabagama_lake_sf %>% 
  st_transform(crs = 32615)

0.3.2 Convert to boundary list

We need to create the list of lists of the boundaries from the sf object that we will supply to the soap-film smoother.

Our example lake has a geometry column that is a POLYGON. We need to be able to split that into each polygon (i.e., islands) that we will create the boundary list from. We can do this by first casting our geometry into MULTIPOINT and assigning each MULTIPOINT row an ID value.

bnd_pt_sf <- sissabagama_lake_sf %>%
  dplyr::select(geometry) %>%
  st_cast("MULTIPOINT") %>%
  mutate(
    id = 1:nrow(.)
  )

Next we will split our sf object and iterate over each MULTIPOINT geometry to first cast to individual POINT geometry and extract each x and y coordinates. It is important in this step that the names of the coordinates are x and y.

bnd_pt <- bnd_pt_sf %>%
  split(.$id) %>%
  purrr::map(~ st_cast(.x, "POINT") %>%
               mutate(
                 x = st_coordinates(.)[,"X"],
                 y = st_coordinates(.)[,"Y"]
               ) %>%
               st_drop_geometry() %>% 
               dplyr::select(-id)
  )

We now have a list of dataframes split by each polygon’s x and y coordinates that have had the id column removed. We then need to create a vector that is id number of each polygon. In this case it’s 1-5, we can use length() of our list of dataframes to easily create the end of our numerical vector.

We will then iterate over our list and bind them all together to get our lists and lists of our polygon boundaries.

nr <- 1:length(bnd_pt)

sissabagama_bnd_ls <- lapply(nr, function(n) as.list.data.frame(bnd_pt[[n]]))

0.3.3 Check if the boundary list works

We will check the boundary list using soap_check()

soap_check(sissabagama_bnd_ls)

#> [1] TRUE

soap_check returns back TRUE so our more complex boundary will work for our soap-film smoother. One thing that I’ve always loved about this lake is how it looks like person!

0.3.4 Make knots for a more complex boundary using {sf}

We can use st_make_grid() to create a grid of equally spaced points across the boundary box of our example sf object of Sissabagama Lake. Remember a soap-film smoother needs equally spaced knots to smooth over. Our sf object is in UTMs which is great becasue then each grid point in this case is 200 m away from each other. Depending on the size of the boundary and system you can change 200 to whatever value makes sense (e.g., large system, further spaced knots, small system, closer spaced knots/this is suggestion but do whatever makes sense).

lake_grid <- sissabagama_lake_sf %>%
  st_make_grid(cellsize = 200, square = TRUE, what = "centers") %>%
  st_as_sf() 

st_geometry(lake_grid) <- "geometry"

We will then remove all the knots that fall outside the boundary by using st_intersection().

lake_intesects <- st_intersection(sissabagama_lake_sf, lake_grid)

Next we will create our knot dataframe by extracting the lon and lat of each point and then dropping the geometry column and selecting our lon and lat columns.

lake_knots <- lake_intesects %>%
  mutate(
    lon = st_coordinates(.)[,"X"],
    lat = st_coordinates(.)[,"Y"]
  ) %>%
  st_drop_geometry() %>%
  as.data.frame() %>%
  dplyr::select(lon, lat)

Now that we have our knots we can check to see if there are any knots that fall too close to the boundary using soap_check().

soap_check(sissabagama_bnd_ls, knots = lake_knots, 
           x_name = "lon", y_name = "lat")
#> Warning in soap_check(sissabagama_bnd_ls, knots = lake_knots, x_name = "lon", :
#> Knots 42, 63, 68 are outside the boundary.

#> [1] TRUE

We can see that there are a few knots that are too close to the boundary. We can remove them using autocruncher()

crunch_ind <- autocruncher(sissabagama_bnd_ls, lake_knots, 
                           xname = "lon", yname = "lat")
crunch_ind
#> [1] 42 63 68

# remove knots that are problematic
lake_knots <- lake_knots[-crunch_ind, ]

Now that those knots have been removed we can recheck our knots using soap_check().

soap_check(sissabagama_bnd_ls, knots = lake_knots, 
           x_name = "lon", y_name = "lat")

#> [1] TRUE

Congratulations! We have knots and a boundary that we can supply our model.

0.3.5 Sissabagama example dataset

We will bring our sampled depths at given locations for Sissabagama lake. This data was generated by referencing the contour map supplied by the Wisconsin DNR. We will first remove depth to check if the data points all fall within our boundary using soap_check().

sissabagama_bath_pt <- sissabagama_bath %>% 
  dplyr::select(-depth)

soap_check(sissabagama_bnd_ls, data = sissabagama_bath_pt)

#> [1] TRUE

Then we will assess the distribution of the data to determine which distribution the model should use to fit the data to. We will use functions from {fitdistrplus}.

depths <- sissabagama_bath$depth
descdist(depths)

#> summary statistics
#> ------
#> min:  3   max:  48 
#> median:  15 
#> mean:  15.29438 
#> estimated sd:  9.983594 
#> estimated skewness:  0.7078068 
#> estimated kurtosis:  2.964066

Skewness and kurtosis of our example data indicates that a model using a Gamma error distribution will likely fit.

fit_gamma <- fitdist(depths, distr = "gamma", method = "mme")
plot(fit_gamma)

We can see the depth data will likely fit a Gamma error distribution and therefore our GAM will use a Gamma error distribution.

0.3.6 Run the model

Prior to running our GAM with a soap-film smoother we need to add one last thing to our boundary list. We need to add the variable f to every boundary polygon within our boundary list. This variable indicates to the soap-film smoother that our response variable is 0 right at the boundary, otherwise the soap-film smoother does not know what to do when it hits the boundary.

names(lake_knots) <- c("x", "y")

sissabagama_bnd_ls <- lapply(nr,
                             function(n)
                               sissabagama_bnd_ls[[n]] <- c(
                                 sissabagama_bnd_ls[[n]],
                                 list(f = rep(0, length(sissabagama_bnd_ls[[n]]$x))
                                 )
                               )
)

We can now successfully run our GAM with a soap-film smoother.

m1 <- gam(depth ~ s(x, y,
                    bs = "so",
                    xt = list(bnd = sissabagama_bnd_ls)),
          family = Gamma(link = "identity"),
          knots = lake_knots,
          data = sissabagama_bath)

We can evaluate the main of the model using anova()

anova(m1)
#> 
#> Family: Gamma 
#> Link function: identity 
#> 
#> Formula:
#> depth ~ s(x, y, bs = "so", xt = list(bnd = sissabagama_bnd_ls))
#> 
#> Approximate significance of smooth terms:
#>          edf Ref.df     F p-value
#> s(x,y) 57.47  76.00 16.51  <2e-16

Next we can evaluate partial effects of the model using summary()

summary(m1)
#> 
#> Family: Gamma 
#> Link function: identity 
#> 
#> Formula:
#> depth ~ s(x, y, bs = "so", xt = list(bnd = sissabagama_bnd_ls))
#> 
#> Parametric coefficients:
#>             Estimate Std. Error t value Pr(>|t|)    
#> (Intercept)   2.8408     0.2074    13.7   <2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#> 
#> Approximate significance of smooth terms:
#>          edf Ref.df     F p-value    
#> s(x,y) 57.47     76 16.51  <2e-16 ***
#> ---
#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#> 
#> R-sq.(adj) =  0.786   Deviance explained = 76.8%
#> GCV = 0.15835  Scale est. = 0.12696   n = 445

We can evaluate the partial effects of the model using draw() from {gratia}

draw(m1)

We can evaluate how well the model fit is to the data using appraise() also from {gratia}

appraise(m1)

0.3.7 Plot our predicted results

We will first create a 10 m grid from our sf object of our boundary. Depending on the size of the boundary you can change the grid size distance to whatever distance makes sense (i.e., if the system is large you may want to increase the cellsize).

lake_pred <- sissabagama_lake_sf %>%
  st_make_grid(cellsize = 10, square = TRUE, what = "centers") %>% 
  st_as_sf() 
st_geometry(lake_pred) <- "geometry"

After creating the grid that we will predict values from we will need to remove any points that fall outside our polygon boundary.

lake_pred <- st_intersection(lake_pred, sissabagama_lake_sf) %>% 
  dplyr::select(geometry)

Then we extract latitude and longitude and convert the sf object into a dataframe.

lake_pred_df <- lake_pred %>% 
  mutate(
    x = st_coordinates(.)[,"X"], 
    y = st_coordinates(.)[,"Y"], 
  ) %>% 
  st_drop_geometry()

We then can use the function augment() from the package {broom.mixed} to predict depth of the lake at a given latitude and longitude.

pred <- augment(m1, newdata = lake_pred_df)
pred <- pred %>% 
  mutate(
    lower = .fitted - 1.96 * .se.fit,
    higher = .fitted + 1.96 * .se.fit
  )

Lastly, we can visualize our predicted depths to create a bathymetic map of the lake using ggplot().

ggplot() +
  geom_raster(data = pred, aes(x = x, y = y, fill = .fitted)) +
  geom_sf(data = sissabagama_lake_sf, fill = NA, colour = "black") +
  scale_fill_viridis_c(name = "Depth (m)",
                       trans = "reverse",
                       breaks = rev(seq(0, 60, 15))
  ) + 
  theme_void(
    base_size = 15
  ) + 
  theme(
    legend.background = element_blank(),
    legend.position = c(0.98, 0.82),
  ) + 
  guides(fill = guide_colourbar(
    frame.linewidth = 0.3,
    ticks.colour = 'black', 
    frame.colour = 'black')) + 
  labs(x = "Longitude", 
       y = "Latitude")
#> Warning: A numeric `legend.position` argument in `theme()` was deprecated in ggplot2
#> 3.5.0.
#> ℹ Please use the `legend.position.inside` argument of `theme()` instead.

Congratulations! We have made a soap-film GAM that takes in account the boundaries within the lake to estimate the bathymetry of the lake. For this example I used bathymetry, but you can use this workflow to model any type of variable (e.g., fish and/or animal movement/acceleration, wind speed, water quality, ect.)

]]> Generalized Additive Model Spatial Analysis Bathymetry https://blog.benjaminhlina.com/posts/post-with-code/soapcheckr/ Sun, 12 Nov 2023 00:00:00 GMT Estimating Trophic Niches - {nicheROVER} and {ggplot2} Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/nicheROVER-ggplot/nicheROVER_ggplot.html

0.1 Our Objectives

The purpose of this vignette is to use {ggplot2} to visualize estimates of trophic niche size and similarities for multiple freshwater fish.

This vignette can be used for additional purposes including estimating niche size and similarities among different groups of aquatic and/or terrestrial species. Furthermore, niche size and similarities for different behaviours exhibited within a population can be made using behavioural data generated from acoustic telemetry (e.g., differences in habitat occupancy).

You can download and unzip this vignette using the following code:

install.packages("usethis")
usethis::use_course("https://github.com/benjaminhlina/nicheROVER-ggplot-vignette/archive/refs/heads/main.zip")

0.2 Disclaimer

Sections of this vignette have been replaced with the package {nichetools} which improves this workflow. I have written a vignette for the package that is available on the package’s website or on this blog. I highly suggest using that workflow going forward. This vignette will not be taken down but will also not be maintained.

0.3 Bring in trophic niche data

First we will load the necessary packages to preform the analysis and visualization. We will use {nicheROVER} and {ellipse} to preform the analysis. We will use {dplyr}, {purrr}, and {tidyr} to manipulate data and iterate processes. Lastly, we will use {ggplot2}, {ggtext}, and {patchwork} to plot, add labels and arrange plots.

I will add that many of the {dplyr} and {tidyr} functions and processes can be replaced using {data.table} which is great when working with large datasets.

{
  library(dplyr)
  library(ellipse)
  library(ggplot2)
  library(ggtext)
  library(here)
  library(nicheROVER) 
  library(purrr)
  library(patchwork)
  library(readr)
  library(stringr)
  library(tidyr)
}

For the purpose of the vignette we will be using the fish dataframe that is available within {nicheROVER}. We will remove 34S for simplicity of the vignette. If more than two isotopes or metrics are being used to compare niche sizes and similarities, you can modify the code to include the additional isotopes or metrics.

We will first use the function janitor::clean_names() to clean up column names and remove 34S column. For your purposes you will need to replace fish with your dataframe either by loading a csv or rds with your data. You can do this multiple ways, I prefer using readr::read_csv() but base R works perfectly fine.

df <- fish %>% 
  janitor::clean_names() %>% 
  select(-d34s)

If there are any isotopic values that did not run and are NA, they will need to be removed because {nicheROVER}’s functions will not accommodate values of NA.

0.4 Estimate posterior distribution with Normal-Inverse-Wishart (NIW) priors.

We will take 1,000 posterior samples for each group. You can change this but suggest nothing less than 1,000.

nsample <- 1000

We will then split the dataframe into a list with each species as a dataframe object within the list, We will then iterate over the list, using map() from {purrr}, to estimate posterior distribution using Normal-Inverse-Wishart (NIW) priors.

fish_par <- df %>% 
  split(.$species) %>% 
  map(~ select(., d13c, d15n)) %>% 
  map(~niw.post(nsample = nsample, X = .))

0.5 Extract values

We will use a combination of map() and pluck() to first extract the list of posteriors for . We will extract each vector object for of each species using imap() and convert them into a tibble.

We then will merge each dataframe together for each species using bind_rows(). We will add species and sample_number back into the dataframe.

df_mu <- map(fish_par, pluck, 1) %>% 
  imap(~ as_tibble(.x) %>% 
         mutate( 
           metric = "mu", 
           species = .y
         )
  ) %>%
  bind_rows() %>% 
  mutate(
    species = factor(species, 
                     levels = c("ARCS", "BDWF", "LKWF", "LSCS"))
  ) %>% 
  group_by(species) %>% 
  mutate(
    sample_number = 1:1000
  ) %>% 
  ungroup()

We need to manipulate df_mu into long format instead of wide format for the rest of the analysis. We will also add in a column that is the element abbreviation and neutron number to be used in axis labelling.

df_mu_long <- df_mu %>% 
  pivot_longer(cols = -c(metric, species, sample_number), 
               names_to = "isotope", 
               values_to = "mu_est") %>% 
  mutate(
    element = case_when(
      isotope == "d15n" ~ "N",
      isotope == "d13c" ~ "C",
    ), 
    neutron = case_when(
      isotope == "d15n" ~ 15,
      isotope == "d13c" ~ 13,
    ) 
  )

0.6 Extract values

We will use a combination of map() and pluck() to first extract the list of posteriors for . We will extract each vector object from each of the vectors for each species using imap() and convert them into a tibble.

We will manipulate df_sigma from wide to long format. When doing so we create two columns, id and isotope, that identify the two isotopes that is being estimated for.

df_sigma <- map(fish_par, pluck, 2) %>%
  imap(~ as_tibble(.x) %>%
         mutate(
           metric = "sigma",
           id = c("d15n", "d13c"),
           species = .y
         )
  ) %>%
  bind_rows() %>%
  pivot_longer(cols = -c("id", "species", "metric"),
               names_to = "isotope",
               values_to = "post_sample"
  )  %>%
  separate(isotope, into = c("isotopes", "sample_number"), sep = "\\.")

We then need to remove values for when the two columns are the same isotope.

df_sigma_cn <- df_sigma %>%
  filter(id != isotopes)

0.7 Plot posterior distrubtion of and

For most plotting within this vignette, I will split() the dataframe by isotope, creating a list that I will then use imap() to iterate over the list to create plots. We will use geom_density() to represent densities for both and . Plot objects will then be stored in a list.

First we will plot for each isotope. We will use {patchwork} to configure plots for multi-panel figures. This package is phenomenal and uses math operators to configure and manipulate the plots to create multi-panel figures.

For labelling we are also going to use element_markdown() from {ggtext} to work with the labels that are needed to correctly display the isotopic signature. If you are working other data please replace.

posterior_plots <- df_mu_long %>%
  split(.$isotope) %>%
  imap(
    ~ ggplot(data = ., aes(x = mu_est)) +
      geom_density(aes(fill = species), alpha = 0.5) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw() +
      theme(panel.grid = element_blank(),
            axis.title.x =  element_markdown(),
            axis.title.y =  element_markdown(),
            legend.position = "none"
      ) +
      labs(
        x = paste("\u00b5<sub>\U03B4</sub>", "<sub><sup>",
                  unique(.$neutron), "</sup></sub>",
                  "<sub>",unique(.$element), "</sub>", sep = ""),
        y = paste0("p(\u00b5 <sub>\U03B4</sub>","<sub><sup>",
                   unique(.$neutron), "</sub></sup>",
                   "<sub>",unique(.$element),"</sub>",
                   " | X)"), sep = "")
  )

posterior_plots$d15n +
  theme(legend.position = c(0.18, 0.84)) + 
  posterior_plots$d13c
Warning: A numeric `legend.position` argument in `theme()` was deprecated in ggplot2
3.5.0.
ℹ Please use the `legend.position.inside` argument of `theme()` instead.

For labeling purposes we need to add columns that are the element abbreviation and neutron number. I do this by using case_when() which are vectorized if else statements.

df_sigma_cn <- df_sigma_cn %>%
  mutate(
    element_id = case_when(
      id == "d15n" ~ "N",
      id == "d13c" ~ "C",
    ),
    neutron_id = case_when(
      id == "d15n" ~ 15,
      id == "d13c" ~ 13,
    ),
    element_iso = case_when(
      isotopes == "d15n" ~ "N",
      isotopes == "d13c" ~ "C",
    ),
    neutron_iso = case_when(
      isotopes == "d15n" ~ 15,
      isotopes == "d13c" ~ 13,
    )
  )

Next we will plot the posteriors for .

sigma_plots <- df_sigma_cn %>%
  group_split(id, isotopes) %>%
  imap(
    ~ ggplot(data = ., aes(x = post_sample)) +
      geom_density(aes(fill = species), alpha = 0.5) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw() +
      theme(panel.grid = element_blank(),
            axis.title.x =  element_markdown(),
            axis.title.y =  element_markdown(),
            legend.position = "none"
      ) +
      labs(
        x = paste("\U03A3","<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_id), "</sub></sup>",
                  "<sub>",unique(.$element_id),"</sub>"," ",
                  "<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_iso), "</sub></sup>",
                  "<sub>",unique(.$element_iso),"</sub>", sep = ""),
        y = paste("p(", "\U03A3","<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_id), "</sub></sup>",
                  "<sub>",unique(.$element_id),"</sub>"," ",
                  "<sub>\U03B4</sub>",
                  "<sub><sup>", unique(.$neutron_iso), "</sub></sup>",
                  "<sub>",unique(.$element_iso),"</sub>", " | X)", sep = ""),
      )
  )

sigma_plots[[1]] + 
  theme(legend.position = c(0.1, 0.82))

0.8 Estimate niche ellipse

We need to manipulate df_sigma back to wide format for ellipses.

df_sigma_wide <- df_sigma %>%
  pivot_wider(names_from = id,
              values_from = post_sample)

Next we will use a for loop to estimate niche ellipses for all 1,000 samples. The default confidence level is 0.95 but can be adjusted by changing p.ell.

p.ell <- 0.95

We will then create a vector of unique species (i.e., groups), that we loop over.

species_name <- unique(df_sigma_wide$species)

Next create an empty list to dump the results of the for loop.

all_ellipses <- list()

We then will use the following for loop. First it subsets mu and sigma objects by species. Then it extracts and values for each sample number for each isotope and each species. Then and are given to ellipse() from {ellipse} that will generate a unique ellipse with a confidence interval of p.ell for each sample (e.g., 1,000 samples). We need to add in dummy variables (ell and post.id) in the first loop that we will add to within the second loop.

If you are to have additional isotopes or metrics, you will need to modify this loop to include them. Specifically ellipse() can only work within two-dimensions, not three, so you will have to create multiple ellipse() calls for each combination of isotopes or metrics.

for (i in 1:length(species_name)) {
  
  sigma_species <- df_sigma_wide %>% 
    filter(species %in% species_name[i])
  
  mu_species <- df_mu %>% 
    filter(species %in% species_name[i])
  
  ell <- NULL
  post.id <- NULL
  
  for(j in 1:length(unique(sigma_species$sample_number))) {
    
    sigma_ind <- sigma_species %>%
      filter(sample_number %in% sample_number[j]) %>% 
      dplyr::select(d15n, d13c) 
    
    Sigma <- as.matrix(sigma_ind, 2, 2)
    row.names(Sigma) <- c("d15n", "d13c")
    
    mu <- mu_species %>%
      filter(sample_number %in% sample_number[j]) %>% 
      dplyr::select(sample_number, d15n, d13c) %>% 
      pivot_longer(cols = -sample_number, 
                   names_to = "isotope", 
                   values_to = "mu") %>% 
      .$mu
    
    out <- ellipse::ellipse(Sigma, centre = mu, which = c(1, 2), level = p.ell)
    
    ell <- rbind(ell, out)
    post.id <- c(post.id, rep(j, nrow(out)))
  }
  ell <- as.data.frame(ell)
  ell$rep <- post.id
  all_ellipses[[i]] <- ell
}

We then will then take the resulting list and merge together to create a dataframe that can be used in plotting. I use the argument .id to designate an unique number to each object in the list because each dataframe object in the list is an estimated ellipse for each species (e.g., 1-4). we then will use case_when() to add in a column with our species abbreviations.

# combine ellipose list into dataframe and add species names back in 
ellipse_df <- bind_rows(all_ellipses, .id = "id") %>% 
  mutate(
    species = factor(
      case_when(
        id == "1" ~ "ARCS",
        id == "2" ~ "BDWF",
        id == "3" ~ "LKWF",
        id == "4" ~ "LSCS",
      ), level = c("ARCS", "BDWF", "LKWF", "LSCS")
    )
  ) %>% 
  as_tibble()

We will randomly sample 10 ellipses out of 1,000. You can change this but this seems pretty standard.

ellipse_df %>% 
  group_by(species, rep) %>% 
  nest() %>%
  group_by(species) %>% 
  slice_sample(n = 10, replace = TRUE) %>% 
  ungroup() %>% 
  unnest(cols = c(data)) -> random_ellipse

0.9 Plot ellipses, densities of each istope, and isotope biplot

We will first plot the ellipse for each species

ellipse_plots <- ggplot() + 
  geom_polygon(data = random_ellipse,
               mapping = aes(x = d13c, y = d15n,
                             group = interaction(rep, species),
                             color = species),
               fill = NA,
               linewidth = 0.5) + 
  
  scale_colour_viridis_d(begin = 0.25, end = 0.75, 
                         option = "D", name = "species",
  ) + 
  scale_x_continuous(breaks = rev(seq(-20, -40, -2))) +
  scale_y_continuous(breaks = seq(6, 16, 2)) +
  theme_bw(base_size = 10) +
  theme(axis.text = element_text(colour = "black"),
        panel.grid = element_blank(), 
        legend.position = "none", 
        legend.title.align = 0.5,
        legend.background = element_blank()) + 
  labs(x = expression(paste(delta ^ 13, "C")), 
       y = expression(paste(delta ^ 15, "N")))
Warning: The `legend.title.align` argument of `theme()` is deprecated as of ggplot2
3.5.0.
ℹ Please use theme(legend.title = element_text(hjust)) instead.

We need to turn df into long format to iterate over using imap() to easily create density plots. You will notice that I again use case_when() to make columns of element abbreviations and neutron numbers that will be used in plot labelling.

iso_long <- df %>%
  pivot_longer(cols = -species,
               names_to = "isotope", 
               values_to = "value") %>% 
  mutate(
    element = case_when(
      isotope == "d15n" ~ "N",
      isotope == "d13c" ~ "C",
    ), 
    neutron = case_when(
      isotope == "d15n" ~ 15,
      isotope == "d13c" ~ 13,
    )
  )

We will then make density plots for each isotope using geom_density()

iso_density <- iso_long %>% 
  group_split(isotope) %>% 
  imap(
    ~ ggplot(data = .) + 
      geom_density(aes(x = value, 
                       fill = species), 
                   alpha = 0.35, 
                   linewidth = 0.8) +
      scale_fill_viridis_d(begin = 0.25, end = 0.75,
                           option = "D", name = "Species") +
      theme_bw(base_size = 10) +
      theme(axis.text = element_text(colour = "black"),
            panel.grid = element_blank(), 
            legend.position = c(0.15, 0.65), 
            legend.title.align = 0.5,
            legend.background = element_blank(), 
            axis.title.x = element_markdown(family = "sans")) + 
      labs(x =  paste("\U03B4",
                      "<sup>", unique(.$neutron), "</sup>",unique(.$element), 
                      sep = ""), 
           y = "Density")
  )

d13c_density <- iso_density[[1]] + 
  scale_x_continuous(breaks = rev(seq(-20, -34, -2)),
                     limits = rev(c(-20, -34)))

d15n_density <- iso_density[[2]] +
  scale_x_continuous(breaks = seq(5, 15, 2.5), 
                     limits = c(5, 15)) + 
  theme(
    legend.position = "none"
  )

Lastly we will use geom_point() to make isotopic biplot.

iso_biplot <- ggplot() + 
  geom_point(data = df, aes(x = d13c, y = d15n,
                            fill = species),
             shape = 21, colour = "black", 
             stroke = 0.8,
             size = 3, alpha = 0.70) +
  scale_fill_viridis_d(begin = 0.25, end = 0.75,
                       option = "D", name = "species") +
  scale_x_continuous(breaks = rev(seq(-20, -39, -1))) +
  scale_y_continuous(breaks = seq(5, 17, 1)) +
  theme_bw(base_size = 10) +
  theme(axis.text = element_text(colour = "black"),
        panel.grid = element_blank(), 
        legend.position = "none", 
        legend.title.align = 0.5,
        legend.background = element_blank()) + 
  labs(x = expression(paste(delta ^ 13, "C")), 
       y = expression(paste(delta ^ 15, "N")))

0.10 Use {patchwork} to make ellipse, density, and biplots into a paneled figure.

We can also use the function plot_annotation() to add lettering to the figure that can be used in the figure description. To maneuver where plot_annotation() places the lettering, we need to add plot.tag.position = c(x, y) to the theme() call in every plot.

d13c_density + ellipse_plots + iso_biplot + d15n_density +
  plot_annotation(tag_levels = "a", 
                  tag_suffix = ")")

0.11 Determine the 95% niche similarties for each species

We will use the overlap() function from {nicheROVER} to estimate the percentage of similarty among species. We will set overlap to assess based on 95% similarities.

over_stat <- overlap(fish_par, nreps = nsample, nprob = 1000, 
                     alpha = 0.95)

We then are going transform this output to a dataframe and make the dataframe long format for plotting so we can assess overall similarities among species.

over_stat_df <- over_stat %>% 
  as_tibble(rownames = "species_a") %>% 
  mutate(
    id = 1:nrow(.), 
    species_a = factor(species_a, 
                       level = c("ARCS", "BDWF", "LKWF", "LSCS"))
  ) %>% 
  pivot_longer(cols = -c(id, species_a), 
               names_to = "species_b", 
               values_to = "mc_nr")  %>% 
  separate(species_b, into = c("species_c", "sample_number"), 
           sep = "\\.") %>% 
  select(-id) %>% 
  rename(species_b = species_c) %>% 
  mutate(
    species_b =  factor(species_b, 
                        level = c("ARCS", "BDWF", "LKWF", "LSCS")
                        ), 
    mc_nr_perc = mc_nr * 100
  )

We then are going to take our newly made data frame and extract out the mean percentage of similarities and the 2.5% and 97.5% quarantines. We plot these as lines and dotted lines on our percent similarity density figure.

over_sum <- over_stat_df %>% 
  group_by(species_a, species_b) %>% 
  summarise(
    mean_mc_nr = round(mean(mc_nr_perc), digits = 2),
    qual_2.5 = round(quantile(mc_nr_perc, probs = 0.025, na.rm = TRUE), digits = 2), 
    qual_97.5 = round(quantile(mc_nr_perc, probs = 0.975, na.rm = TRUE), digits = 2)
  ) %>% 
  ungroup() %>% 
  pivot_longer(cols = -c(species_a, species_b, mean_mc_nr), 
               names_to = "percentage", 
               values_to = "mc_nr_qual") %>% 
  mutate(
    percentage = as.numeric(str_remove(percentage, "qual_"))
  )

We are now going to use ggplot(), geom_density(), and fact_grid2() from {ggh4x}.

ggplot(data = over_stat_df, aes(x = mc_nr_perc)) + 
  geom_density(aes(fill = species_a)) + 
  geom_vline(data = over_sum, aes(xintercept = mean_mc_nr), 
             colour = "black", linewidth = 1) +
  geom_vline(data = over_sum, aes(xintercept = mc_nr_qual), 
             colour = "black", linewidth = 1, linetype = 6) +
  scale_fill_viridis_d(begin = 0.25, end = 0.75,
                       option = "D", name = "Species", 
                       alpha = 0.35) + 
  ggh4x::facet_grid2(species_a ~ species_b, 
                     independent = "y",
                     scales = "free_y") + 
  theme_bw() + 
  theme(
    panel.grid = element_blank(), 
    axis.text = element_text(colour = "black"), 
    legend.background = element_blank(),
    strip.background = element_blank()
  ) +
  labs(x = paste("Overlap Probability (%)", "\u2013", 
                 "Niche Region Size: 95%"), 
       y = "p(Percent Overlap | X)")

0.12 Estimate overall niche size

We are now going to estimate the overall size of the niche for each posterior sample by using the function niche.size().

niche_size <- sapply(fish_par, function(spec) {
  apply(spec$Sigma, 3, niche.size)
})

We then need to transform niche_size into a datafame for visualization and summary statistics.

niche_size_df <- niche_size %>% 
  as_tibble() %>% 
  mutate(
    id = 1:nrow(.)
  ) %>% 
  pivot_longer(
    cols = -id, 
    names_to = "species", 
    values_to = "niche_size"
  ) %>% 
  mutate(
    id = 1:nrow(.), 
    species = factor(species,
                   level = c("ARCS", "BDWF", 
                             "LKWF", "LSCS"))
  )

We can calculate the mean niche size, standard deviation, and standard error.

niche_size_mean <- niche_size_df %>% 
  group_by(species) %>% 
  summarise(
    mean_niche = round(mean(niche_size), digits = 2), 
    sd_niche = round(sd(niche_size), digits = 2), 
    sem_niche = round(sd(niche_size) / sqrt(n()), digits = 2)
  )

0.13 Plot niche size

We will now use geom_violin(), geom_point(), and geom_errorbar() to plot the distribution for niche size for each species.

ggplot(data = niche_size_df) + 
  geom_violin(
    aes(x = species, y = niche_size),
    width = 0.2) + 
  geom_point(data = niche_size_mean, aes(x = species, y = mean_niche)) +
  geom_errorbar(data = niche_size_mean, aes(x = species, 
                                            ymin = mean_niche  - sem_niche, 
                                            ymax = mean_niche  + sem_niche), 
                width = 0.05) +
  theme_bw(base_size = 15) + 
  theme(panel.grid = element_blank(), 
        axis.text = element_text(colour = "black")) + 
  labs(x = "Species", 
       y = "Niche Size")

Now that we have our niche sizes and similarities determined we can make inferences about the species, trophic similarities, and the ecosystem.

]]> Stable Isotopes Trophic Dynamics Food Webs https://blog.benjaminhlina.com/posts/post-with-code/nicheROVER-ggplot/nicheROVER_ggplot.html Fri, 04 Aug 2023 00:00:00 GMT Shortest Paths Within a Boundary - {pathroutr} Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/shortest-path-pathroutr/shortest_path_example_pathroutr.html

0.1 Our Objectives

The purpose of this vignette is to create the shortest distance among acoustic telemetry receivers within a confined boundary such as a lake, river, delta, or oceanscape. This workflow can be adapted to find the distance between any two points within a confined boundary.

Use this vignette with a bit of caution, as I found some inconsistency with this method when transferring it to other study systems besides this example study system.

Note, this method differs from the {gdistance} method as we are going to create a network graph to move throughout our study system and determine the shortest path. This vignette will start off the same as the {gdistance} method but will differ when creating the shortest paths.

You can download and unzip this vignette using the following code:

install.packages("usethis")
usethis::use_course("https://github.com/benjaminhlina/shortest_path_example/archive/refs/heads/master.zip")

0.2 Load shapefile and receiver locations

We will first load all the packages we need, we will use {pathroutr} to find the shortest paths using {sfnetworks} and {sf} to find the distances of those shortest paths.

# ---- load packages ----
{
  library(dplyr)
  library(ggplot2)
  library(ggspatial)
  library(here)
  library(igraph)
  library(lwgeom)
  library(pathroutr)
  library(purrr)
  library(readr)
  library(sf)
  library(sfnetworks)
  library(sp)
  library(tibble)
  library(tidyr)
  make_line <- function(lon, lat, llon, llat) {
    st_linestring(matrix(c(lon, llon, lat, llat), 2, 2))
  }
}

We will bring bring in our shapefile. This vignette will use Big Sissabagama Lake as it is the lake I grew up fishing on in Wisconsin, USA. Please replace with the shapefile of your desired body of water.

lake <- st_read(dsn = here("Data",
                           "shapefile",
                           "."),
                layer = "sissabagama_lake")

Important that you convert to the correct UTM zone. For the vignette we are using UTM zone 15 N. Adjust your UTM zone accordingly.

lake_utm <- st_transform(lake, crs = 32615)

We will then bring in our receiver locations. Replace rl_sum_sf with your receiver locations as a RDS or csv file type or whatever you use to document receiver locations.

rl_sum_sf <- read_rds(here("Data",
                           "receiver locations",
                           "rl_sum_sf.rds"))

Convert to UTMs for plotting purposes and make sure you use the correct UTM zone.

rl_sum_utm <- st_transform(rl_sum_sf, crs = 32615)

0.3 Invert shapefile for inland lakes and rivers

{pathroutr} was built with the intent of working on oceanscapes where the shapefile is land. For inland bodies of water the shapefile is usually water, therefore to get {pathroutr} to function we need to invert our inland lake or river shapefile

First we are going to get the extent of our shapefile which will be in UTMs

ext <- st_bbox(lake_utm, crs = st_crs(lake_utm)) %>%
  st_as_sfc() %>%
  st_sf()

We then will invert our shapefile by using st_difference() from {sf}.

inverse <- st_difference(ext, lake_utm)

We will check if we have correctly taken the inverse of our lake.

ggplot() +
  geom_sf(data = inverse) + 
  theme_void()

0.4 Create land region to build our network

We need to create a buffered land region to use as a barrier. Within st_buffer() we will need to adjust dist argument to change the buffer distance to be adequate for the study system. For this example we will use 650 m.

land_region <- rl_sum_utm %>% 
  st_buffer(dist = 650) %>%
  st_union() %>%
  st_convex_hull() %>% 
  st_intersection(inverse) %>% 
  st_sf()

We will check if we have correctly buffered our land region

ggplot() +
  geom_sf(data = land_region) + 
  theme_void()

0.5 Create every combination of paths for every receiver

First we will convert receiver location which is a sf object to a tibble with each location combination.

prep_path <- rl_sum_sf %>%
  mutate(
    lon = st_coordinates(.)[,"X"],# grab lon
    lat = st_coordinates(.)[,"Y"],# grab lat
  ) %>%  
  st_drop_geometry() %>% # drop sf 
  # once geometry removed create to and from lat longs 
  mutate(llon = lon,
         llat = lat,
         lonlat = paste0(lon, ",", lat),
         llonllat = paste0(llon, ",", llat)) %>%
  dplyr::select(-lon, -lat, -llon, -llat) %>%
  expand(lonlat, llonllat) %>% # expand for each to and from combo 
  separate(lonlat, c("lon", "lat"), ",") %>%
  separate(llonllat, c("llon", "llat"), ",")

prep_path has all of the path combinations but we lose the names of the receivers and which paths go from one receiver to another. We are going to add that information back in by creating an object called rec_order

rec_order <- prep_path %>%
  left_join(
    rl_sum_sf %>% 
      mutate(
        lon = st_coordinates(.)[,"X"], 
        lat = st_coordinates(.)[,"Y"]
      ) %>% 
      st_drop_geometry() %>% 
      rename(from = rec_name) %>% 
      dplyr::select(from, lon, lat) %>% 
      mutate(across(.cols = c(lon, lat), as.character)), by = c("lon", "lat"), 
    multiple = "all"
  ) %>%  
  left_join(
    rl_sum_sf %>% 
      mutate(
        lon = st_coordinates(.)[,"X"]
      ) %>% 
      st_drop_geometry() %>% 
      rename(to = rec_name,
             llon = lon) %>% 
      dplyr::select(to, llon) %>% 
      mutate(llon = as.character(llon)), by = c("llon"), 
    multiple = "all"
  ) %>% 
  mutate(
    from_to = paste0(from, "-", to)
  ) %>% 
  dplyr::select(from, to, from_to, lon, lat, llon, llat)

Awesome! We have all of our combinations with their names and we now know which paths go from one receiver to another. Now we need to make each combination a linestring that we will sample points from to reroute.

Be sure to choose the correct UTM zone here. This vignette uses UTM zone 15 north but for other uses you will have to change the UTM zone.

path <- prep_path %>%
  mutate(across(lon:llat, as.numeric)) %>% 
  pmap(make_line) %>%
  st_as_sfc(crs = 4326) %>%
  st_sf() %>%  
  mutate(
    lon = st_startpoint(.) %>%
      st_coordinates(.) %>%
      as_tibble() %>%
      .$X %>% 
      as.character(),
    llon = st_endpoint(.) %>%
      st_coordinates(.) %>%
      as_tibble() %>%
      .$X %>% 
      as.character()
  ) %>% 
  left_join(rec_order %>%
               dplyr::select(from:lon, llon),
             by = c("lon", "llon")
  ) %>%
  dplyr::select(from:from_to) %>% 
  st_transform(crs = 32615) %>% 
  arrange(from, to)

0.6 Sample points along path for {pathroutr} to reroute

Now that we have our paths we need to sample along the LINESTRING to get paths to reroute. I choose to have a sample distance of 5 m but you can change this depending on the study site.

We need to cast our sampled points as MULTIPOINT object for {pathroutr} to sample

path_pts <- path %>% 
  st_segmentize(dfMaxLength = units::set_units(5, m)) %>% 
  st_cast("MULTIPOINT")

Important note, sometimes this sampling step results in points that intersect with the boundary of your land region which may cause issues with {pathroutr}. To fix this you will need to use the following code:

path_pts_fix <- prt_trim(trkpts = path_pts, barrier = land_region)

Though for this vignette we will not use path_pts_fix.

We are going to visualize our paths, we could visualize the path_pts but this often takes awhile to process as the sample interval is 5 m and path_pts will be taken from our paths

ggplot() + 
  geom_sf(data = land_region)  +
  geom_sf_label(data = rl_sum_sf, aes(label = rec_name), 
                size = 4) +
  geom_sf(data = path, linewidth = 1) + 
  theme_void()

0.7 Use get_barrier_segments from {pathroutr} to id path points that travel across landmasses in our lake.

lake_bar_seg <- get_barrier_segments(trkpts = path_pts,
                                     barrier =  land_region)

0.8 Create network graph in our study system

Create a network graph that is bound by land_region and made up Delaunay triangles which are created in theory by looking from one point on one shore to directly across the study system until you hit a land object.

vis <- prt_visgraph(barrier = land_region)

We can manipulate our network graph in several ways, the first is supplying the argument aug_points with the receiver location sf object. By doing so we add in triangles that will directly go to our receiver locations. Secondly, we can use the argument centroids to add additional points within our network.

Lastly, we can use the argument buffer to have paths be buffered from our land masses by a given distance in metres. We can visualize our network by first using the function activate from {sfnetworks}.

vis_graph_sf <- activate(vis, "edges") %>% 
  st_as_sf()

ggplot() + 
  geom_sf(data = vis_graph_sf) + 
  theme_void()

0.9 Create rerouted sections

Using prt_shortestpath we will reroute sections that go across land using our created network.

segs_tbl <- prt_shortpath(lake_bar_seg, vis, blend = TRUE)

We can visualize these rerouted paths

ggplot() + 
  geom_sf(data = land_region, size = 0) +
  layer_spatial(data = segs_tbl$geometry, 
                color = "deepskyblue3",
                linewidth = 1) +
  theme_void()

0.10 Update our paths to not travel across land

track_pts_fix <- prt_reroute(path_pts, land_region, vis)

track_pts_fix <- prt_update_points(track_pts_fix, path_pts)

0.11 Convert points to linestrings to determine distance

track_pts_fixed <- track_pts_fix %>% 
  group_by(from_to) %>% 
  summarise(do_union = FALSE) %>% 
  st_cast('LINESTRING') %>%  
  ungroup() %>% 
  separate(from_to, into = c("from", "to"), sep = "-", 
           remove = FALSE) %>% 
  mutate(
    cost_dist_m = as.numeric(st_length(.))
  ) %>% 
  filter(from != to) %>% 
  dplyr::select(from, to, from_to, cost_dist_m, geometry)

0.12 Visualize our paths

First we will check if one route rerouted properly

# view one reroute to confirm pathroutr is rerouting 
track_pts_fixed %>% 
  filter(from_to == "15-11") %>% 
  ggplot() + 
  geom_sf(data = land_region, size = 0) +
  geom_sf(color = "deepskyblue3", 
          linewidth = 1) +
  theme_void()

Next we will visualize the whole network and have colour be our distances

ggplot() + 
  geom_sf(data = lake_utm, colour = "black",
          size = 1) +
  geom_sf(data = rl_sum_utm, 
          size = 4, colour = "black") + 
  geom_sf(data = track_pts_fixed, 
          aes(color = cost_dist_m), 
          linewidth = 1) +
  scale_colour_viridis_c(option = "D", 
                         name = "Cost Distance (m)") + 
  theme_void()

From here the sf object can be kept together or ripped apart to determine the distance or path a fish could swim within the system along with a whole host of other potential implications (e.g. interpolated paths).

]]> Spatial Analysis Acoustic Telemetry Movement https://blog.benjaminhlina.com/posts/post-with-code/shortest-path-pathroutr/shortest_path_example_pathroutr.html Sun, 28 May 2023 00:00:00 GMT Shortest Paths Within a Boundary - {gdistance} Benjamin L. Hlina https://blog.benjaminhlina.com/posts/post-with-code/shortest-path-gidstance/shortest_path_example_gdistance.html

0.1 Our Objectives

The purpose of this vignette is to create the shortest distance among acoustic telemetry receivers within a confined boundary such as a lake, river, delta, or oceanscape. This workflow can be adapted to find the distance between any two points within a confined boundary.

You can download and unzip this vignette using the following code:

install.packages("usethis")
usethis::use_course("https://github.com/benjaminhlina/shortest_path_example/archive/refs/heads/master.zip")

0.2 Disclaimer

This vignette uses {gdistance}, {raster}, and {sp} which as of October 2023 were retired. Please use the vignette using {pathroutr} for the timing being until I can update this vignette with using {terra}.

0.3 Load shapefile and receiver locations

We will first load all the packages we need, we will use {gdistance} to find the shortest paths, {sf} to find the distances of those shortest paths.

# ---- load packages ----
{
  library(dplyr)
  library(gdistance)
  library(ggplot2)
  library(here)
  library(purrr)
  library(raster)
  library(readr)
  library(sf)
  library(sp)
  library(tibble)
  library(tidyr)
  make_line <- function(lon, lat, llon, llat) {
    st_linestring(matrix(c(lon, llon, lat, llat), 2, 2))
  }
}

We will bring bring in our shapefile. This vignette will use Big Sissabagama Lake as it is the lake I grew up fishing on in Wisconsin, USA. Please replace with the shapefile of your desired body of water.

lake <- st_read(dsn = here("Data",
                           "shapefile",
                           "."),
                layer = "sissabagama_lake")

Important that you convert to the correct UTM zone. For the vignette we are using UTM zone 15 N. Adjust your UTM zone accordingly.

lake_utm <- st_transform(lake, crs = 32615)

Create SpatialPloygonDataFrame we will use it to create a raster that will be a transition layer for paths to move across. We will use lake_utm as we need our raster layer in UTMs.

lake_spd <- as_Spatial(lake_utm)

We will then bring in our receiver locations. Replace rl_sum_sf with your receiver locations as a RDS or csv file type or whatever you use to document receiver locations.

rl_sum_sf <- read_rds(here("Data",
                           "receiver locations",
                           "rl_sum_sf.rds"))

Convert to UTMs for plotting purposes and make sure you use the correct UTM zone.

rl_sum_utm <- st_transform(rl_sum_sf, crs = 32615)

0.4 Rasterize shapefile

We will look at lake SpatialPointsDataFrame via plot, then determine the boundary box (bbox) and save it as an object named ext.

plot(lake_spd)

# determine the extent of the SpatialPointsDataFrame
ext <- extent(lake_spd)

Then we will create the raster, it is important here to control the res argument as that will result in varied resolution. For the vignette I used a resolution of 5 which represents 5 m since we are using UTMs. Using a more fine-scale resolution such as 5 m can be computationally intensive so for large systems scale this value up.

s <- raster(lake_spd, res = 5)
# remove and change NA values to fit within the extent
s <- rasterize(x = lake_spd, y = s, field = 1)

# plot raster to make sure it looks appropriate
plot(s)

The last step is to create the transition layer. Directions will be queens move of 16 spaces. If in a larger systems direction could be reduced from queens space to rook or king, 4 or 8 to reduce computational complexity and speed.

trans <- transition(x = s, transitionFunction = mean, directions = 16)

0.5 Create every combination of paths for every receiver

First we will convert receiver location which is a sf object to a tibble with each location combination.

prep_path <- rl_sum_sf %>%
  mutate(
    lon = st_coordinates(.)[,"X"],# grab lon
    lat = st_coordinates(.)[,"Y"],# grab lat
  ) %>%  
  st_drop_geometry() %>% # drop sf 
  # once geometry removed create to and from lat longs 
  mutate(llon = lon,
         llat = lat,
         lonlat = paste0(lon, ",", lat),
         llonllat = paste0(llon, ",", llat)) %>%
  dplyr::select(-lon, -lat, -llon, -llat) %>%
  expand(lonlat, llonllat) %>% # expand for each to and from combo 
  separate(lonlat, c("lon", "lat"), ",") %>%
  separate(llonllat, c("llon", "llat"), ",")

prep_path has all of the path combinations but we lose the names of the receivers and which paths go from one receiver to another. We are going to add that information back in by creating an object called rec_order

rec_order <- prep_path %>%
  left_join( 
    rl_sum_sf %>% 
      mutate(
        lon = st_coordinates(.)[,"X"], # grab lon 
        lat = st_coordinates(.)[,"Y"]  # grab lat 
      ) %>% 
      st_drop_geometry() %>% # remove sf 
      rename(from = rec_name) %>%  # Line up from names 
      dplyr::select(from, lon, lat) %>% 
      mutate(across(.cols = c(lon, lat), as.character)) , by = c("lon", "lat"), 
    multiple = "all"
  ) %>%  
  left_join(
    rl_sum_sf %>% 
      mutate(
        lon = st_coordinates(.)[,"X"]
      ) %>% 
      st_drop_geometry() %>% 
      rename(to = rec_name,
             llon = lon) %>% # join for the tos  
      dplyr::select(to, llon) %>% 
      mutate(llon = as.character(llon)), by = c("llon"), 
    multiple = "all"
  ) %>% 
  mutate(
    from_to = paste0(from, "-", to), 
    id = 1:nrow(.)
  ) %>% 
  dplyr::select(id, from, to, from_to, lon, lat, llon, llat) %>% 
  mutate(across(.col = c(lon, lat, llon, llat), as.numeric))

Awesome! We have all of our combinations with their names and we now know which paths go from one receiver to another. The only issue is all of points are in decimal degrees with a CRS of WGS 84, we need to convert this into to UTMs.

Be sure to choose the correct UTM zone here. This vignette uses UTM zone 15 north but for other uses you will have to change the UTM zone.

rec_order_utm <- st_as_sf(rec_order, 
                          coords = c("lon", "lat"), 
                          crs = st_crs(rl_sum_sf)) %>% 
  st_transform(crs = 32615) %>% 
  mutate(
    lon = st_coordinates(.)[,"X"], # grab lon 
    lat = st_coordinates(.)[,"Y"]  # grab lat 
  ) %>% 
  st_drop_geometry() %>% 
  st_as_sf(., coords = c("llon", "llat"), 
           crs = st_crs(rl_sum_sf)) %>% 
  st_transform(crs = 32615) %>% 
  mutate(
    llon = st_coordinates(.)[,"X"], # grab lon 
    llat = st_coordinates(.)[,"Y"]  # grab lat 
  ) %>% 
  st_drop_geometry()

0.6 Make shortest paths

We will first split our combinations into individual end points, then use purrr::map() to iterate over each combination and use the shortestPath() function to calculate the shortest path for every combination.

We then will transform the output of this which are SpatialLinesDataFrame to sf objects. Important note here is to change the CRS to your specific CRS UTM zone.

rec_dist_sf <- rec_order_utm %>%
  split(.$id) %>%
  map(possibly(~ shortestPath(trans,
                              c(.$llon, .$llat),
                              c(.$lon, .$lat),
                              output = "SpatialLines"), NA)) %>%
  map(possibly(~ st_as_sf(., crs = 32615), NA)) %>% # u will need to replace CRS
  bind_rows(.id = "id") %>%
  mutate(
    cost_dist = as.numeric(st_length(.))
  )

0.7 Add in metadata of paths start and end desitantions

First we will change the id column to a character to be able to line up the data properly.

rec_order_names <- rec_order_utm %>% 
  mutate(
    id = as.character(id)
  )

Next we will use left_join() from {dplyr} to connect each path’s metadata.

rec_dist_sf <- rec_dist_sf %>% 
  left_join(rec_order_names, by = "id") %>% 
  dplyr::select(id, from:llon, cost_dist, geometry)

0.8 Plot

We will use ggplot to look at our paths. Lets first check if paths go to the right locations and then we will plot the whole thing.

ggplot() +
  geom_sf(data = lake_utm) +
  geom_sf(data = rec_dist_sf %>% 
            filter(from_to %in% "3-12")
          , aes(colour = cost_dist), size = 1) +
  geom_sf_label(data = rl_sum_utm , size = 4, aes(label = rec_name)) +
  scale_colour_viridis_c(name = "Cost Distance (m)", option = "B") +
  theme_void()

ggplot() +
  geom_sf(data = lake_utm) +
  geom_sf(data = rec_dist_sf, aes(colour = cost_dist), size = 1) +
  geom_sf(data = rl_sum_utm , size = 4) +
  scale_colour_viridis_c(name = "Cost Distance (m)", option = "B") +
  theme_void()

From here the sf object can be kept together or ripped apart to determine the distance or path a fish could swim within the system along with a whole host of other potential implications (e.g. interpolated paths).

Credit: R. Lennox, PhD, Incoming Science Director - OTN for the original ideas around this script.

]]> Spatial Analysis Acoustic Telemetry Movement https://blog.benjaminhlina.com/posts/post-with-code/shortest-path-gidstance/shortest_path_example_gdistance.html Fri, 26 May 2023 00:00:00 GMT