Fixes for generality among machines (and usernames on those machines)

DESCRIPTION

@@ -56,7 +56,7 @@ Remotes:
     pbs-assess/rosettafish,
     pbs-software/pbs-data/PBSdata,
     pbs-software/pbs-mapping/PBSmapping,
-    pacific-hake/hake-assessment
+    pacific-hake/hake
 URL: https://github.com/pbs-assess/arrowtooth
 BugReports: https://github.com/pbs-assess/arrowtooth/issues
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -28,6 +28,8 @@ export(props_comm_data_summary)
 export(props_surv)
 export(props_surv_data_summary)
 export(read_psv_file)
+export(rotate_coords)
+export(rotate_df)
 export(run_models)
 export(system_)
 export(table_prop_female)

R/plot-trawl-footprint.R

@@ -19,7 +19,7 @@
 #' @return A [ggplot2::ggplot()] object
 #' @export
 plot_trawl_footprint <- function(
-    tf_rda_fn = "/home/grandin/github/main/pbs-data/PBSdata/data/trawlfoot.rda",
+    tf_rda_fn = system.file("data/trawlfoot.rda", package = "PBSdata"),
     crs_num = 3156, # Zone 9 NAD83
     utm_zone = 9, # For boundary labels only
     bath = c(100, 200, 500),

R/utils.R

@@ -38,4 +38,47 @@ get_os <- function(){
       os <- "linux"
   }
   tolower(os)
-}
+}
+
+#' Rotate the coordinates in a data frame
+#'
+#' @param df An [sf] data frame
+#' @param rotation_angle The angle to rotate the coordinates
+#' @param rotation_center A vector of 2: X and Y location for the
+#' center to rotate about
+#'
+#' @return The modified [sf] data frame
+#' @export
+rotate_df <- function(df, rotation_angle, rotation_center){
+
+  r <- rotate_coords(df$X,
+                     df$Y,
+                     rotation_angle = rotation_angle,
+                     rotation_center = rotation_center
+  )
+  df$X <- r$x
+  df$Y <- r$y
+
+  df
+}
+
+#' Rotate vectors of coordinates
+#'
+#' @param x The X position vector
+#' @param y The Y position vector
+#' @param rotation_angle The angle to rotate the coordinates
+#' @param rotation_center A vector of 2: X and Y location for the
+#' center to rotate about
+#'
+#' @return A [tibble::tibble()] containing the rotated coordinates
+#' @export
+rotate_coords <- function(x, y, rotation_angle, rotation_center) {
+
+  rot <- -rotation_angle * pi / 180
+  newangles <- atan2(y - rotation_center[2], x - rotation_center[1]) + rot
+  mags <- sqrt((x - rotation_center[1])^2 + (y - rotation_center[2])^2)
+  x <- rotation_center[1] + cos(newangles) * mags
+  y <- rotation_center[2] + sin(newangles) * mags
+
+  tibble(x = x, y = y)
+}

doc/060-figures-main.Rmd

@@ -290,6 +290,7 @@ plot_age_resids_mcmc(base_model,
 (ref:fig-base-age-fits-hss-fr) Ajustements de la composition par âge pour chaque sexe pour le `r hss`. Voir la figure \@ref(fig:fig-base-age-fits-ft) pour plus de détails.
 
 ```{r fig-base-age-fits-hss, fig.cap = ifelse(fr(), "(ref:fig-base-age-fits-hss-fr)", "(ref:fig-base-age-fits-hss-en)")}
+
 plot_age_fits_mcmc(base_model,
                    gear = 4,
                    text_title_size = NULL,
@@ -327,6 +328,7 @@ plot_age_fits_mcmc(base_model,
 (ref:fig-base-age-resids-wcvis-fr) Résidus de Pearson pour les ajustements de la composition par âge pour chaque sexe pour le `r wcvis`. Les bulles représentent la médiane de la postériorité pour les résidus de Pearson. Les bulles rouges correspondent à des résidus négatifs, les noires à des résidus positifs et les points à des résidus nuls.
 
 ```{r fig-base-age-resids-wcvis, fig.cap = ifelse(fr(), "(ref:fig-base-age-resids-wcvis-fr)", "(ref:fig-base-age-resids-wcvis-en)")}
+
 plot_age_resids_mcmc(base_model,
                      gear = 5,
                      text_title_size = NULL,

doc/062-figures-mcmc-diagnostics.Rmd

@@ -10,9 +10,10 @@ cat("## CHIFFRES DU DIAGNOSTIC MCMC POUR LE MODÈLE DE BASE
 
 (ref:fig-base-priors-posts-en) Prior probability distributions used in the base model (blue shaded areas) overlaid with posterior distribution histograms. The solid red line is the mode of the prior distribution, the vertical solid black line is the mean of the prior, and the vertical dashed black lines represent one standard deviation from the mean. Plots that are entirely shaded blue represent uniform priors. Catchability ($q$) parameters for the survey indices have numerical subscripts which are: `r paste(base_index_gears$gear, " = ", base_index_gears$gear_name, collapse = ", ")`.
 
-(ref:fig-base-priors-posts-fr) Distributions de probabilités antérieures utilisées dans le modèle de base (zones ombrées en bleu) superposées aux histogrammes de distribution postérieure. La ligne rouge continue est le mode de la distribution antérieure, la ligne noire continue verticale est la moyenne de la distribution antérieure et les lignes noires verticales en pointillés représentent un écart-type par rapport à la moyenne. Les graphiques entièrement bleus représentent des a priori uniformes. Les paramètres de capturabilité ($q$) pour les indices de l'enquête ont des indices numériques qui sont : `r paste(base_index_gears$gear, " = ", base_index_gears$gear_name, collapse = ", ")`.
+(ref:fig-base-priors-posts-fr) Distributions de probabilités antérieures utilisées dans le modèle de base (zones ombrées en bleu) superposées aux histogrammes de distribution postérieure. La ligne rouge continue est le mode de la distribution antérieure, la ligne noire continue verticale est la moyenne de la distribution antérieure et les lignes noires verticales en pointillés représentent un écart-type par rapport à la moyenne. Les graphiques entièrement bleus représentent des a priori uniformes. Les paramètres de capturabilité ($q$) pour les indices de l'enquête ont des indices numériques qui sont: `r paste(base_index_gears$gear, " = ", base_index_gears$gear_name, collapse = ", ")`.
 
 ```{r fig-base-priors-posts, fig.cap = ifelse(fr(), "(ref:fig-base-priors-posts-fr)", "(ref:fig-base-priors-posts-en)")}
+
 plot_priors_posts_mcmc(base_model,
                        param_rm = c("sel",
                                     "bo",

doc/070-tables.Rmd

@@ -85,7 +85,7 @@ table_param_settings(base_model,
                      caption = cap)
 ```
 
-```{r param-estimates-table, results = "asis", eval=isTRUE(user == "grandin")}
+```{r param-estimates-table, results = "asis", eval = length(grep("grandin", user))}
 cap <- paste0("Posterior median and 95\\% credible interval estimates of key ",
               "parameters for the base model.")
 if(fr()){

doc/index.Rmd

@@ -54,34 +54,40 @@ output:
    # build_rds is a toggle to re-build all the RDS files for the models
    build_rds: false
    keep_md: true
-   french: true
-   # copy_sty is a toggle to copy the style file from the csasdown package every time you compile
-   # the document. If false, any changes you have made to the style file in your project
-   # will remain between compilations. If true, your changes will be lost when you compile
+   french: false
+   # copy_sty is a toggle to copy the style file from the csasdown package
+   # every time you compile the document. If false, any changes you have
+   # made to the style file in your project will remain between
+   # compilations. If true, your changes will be lost when you compile
    copy_sty: true
-   # line_nums is a toggle to show line numbers on the left side of the page. 
+   # line_nums is a toggle to show line numbers on the left side of the page
    line_nums: false
    # line_nums_mod represents showing every Nth line if line_nums is true
    line_nums_mod: 1
-   # lot_lof is a toggle to show/not show the lists of tables and figures at the
-   # beginning of the document
+   # lot_lof is a toggle to show/not show the lists of tables and figures
+   # at the beginning of the document
    lot_lof: false
-   # draft_watermark is a toggle to show/not show a DRAFT watermark across every page
+   # draft_watermark is a toggle to show/not show a DRAFT watermark across
+   # every page
    draft_watermark: false
-   # include_section_nums, if true includes section numbering in the document body,
-   # if false, no numbering in the document body but the TOC will still show numbering
+   # include_section_nums, if true includes section numbering in the
+   # document body, if false, no numbering in the document body but the
+   # TOC will still show numbering
    include_section_nums: true
-   # highlight is the theme to use for code output. Must be one of the list given by:
+   # highlight is the theme to use for code output. Must be one of the
+   # list given by:
    # pandoc --list-highlight-styles
    # which are:
-   # pygments, tango, espresso, zenburn, kate, monochrome, breezedark, haddock
-   # or the name of a custom *.latex file which is most easily made by copying one from 
-   # the csasdown library 'themes' directory, this directory on your machine:
+   # pygments, tango, espresso, zenburn, kate, monochrome, breezedark,
+   # haddock or the name of a custom *.latex file which is most easily
+   # made by copying one from  the csasdown library 'themes' directory,
+   # this directory on your machine:
    # file.path(.libPaths(), "csasdown", "themes")
    # to your working directory (the one containing index.Rmd)
-   # To change the foreground text color, change the RGB value in the line containing
-   # 'DefineVerbatimEnvironment'
-   # To change background color, change the RGB values in the line containing 'shadecolor'
+   # To change the foreground text color, change the RGB value in the
+   # line containing 'DefineVerbatimEnvironment'
+   # To change background color, change the RGB values in the line
+   # containing 'shadecolor'
    highlight: tango
 # ------------
 # End of options to set
@@ -95,7 +101,7 @@ header-includes:
   - \usepackage{amsmath}
 ---
 
-```{r setup, echo=FALSE, cache=FALSE, message=FALSE, results='hide', warning=FALSE}
+```{r setup, echo = FALSE, cache = FALSE, message = FALSE, results = "hide", warning = FALSE}
 
 curr_dir <- basename(getwd())
 curr_dir_up1 <- basename(dirname(getwd()))
@@ -133,7 +139,8 @@ opts_chunk$set(
   # autodep = isTRUE(user %in% "seananderson"),
   # cache = isTRUE(user %in% "seananderson"),
   cache.comments = FALSE,
-  # These two lines needed for the maps with geom_sf() to be rendered correctly
+  # These two lines needed for the maps with geom_sf() to be rendered
+  # correctly
   dev = "ragg_png",
   fig.ext = "png",
   dpi = 180,
@@ -160,7 +167,7 @@ options(knitr.graphics.rel_path = FALSE)
 
 library(devtools)
 library(dplyr)
-if(user == "grandin"){
+if(length(grep("grandin", user))){
   load_all("~/github/pbs-assess/gfiscamutils")
   load_all("~/github/pbs-assess/gfplot")
   load_all("~/github/pbs-assess/csasdown")
@@ -349,32 +356,6 @@ wchgs <- tr("West Coast Haida Gwaii Synoptic Survey")
 dcpue <- tr("Discard CPUE Index")
 
 la <- ifelse(fr(), "Évaluation de 2015", "2015 assessment")
-# tv_block1 <- paste0(unique(filter(base_model$mcmccalcs$selest_quants,
-#                                   gear == "QCS Synoptic", block == 1)$start_year),
-#                     "--", 
-#                     unique(filter(base_model$mcmccalcs$selest_quants,
-#                                   gear == "QCS Synoptic", block == 1)$end_year))
-# tv_block2 <- paste0(unique(filter(base_model$mcmccalcs$selest_quants,
-#                                   gear == "QCS Synoptic", block == 2)$start_year),
-#                     "--", 
-#                     unique(filter(base_model$mcmccalcs$selest_quants,
-#                                   gear == "QCS Synoptic", block == 2)$end_year))
-
-# Text for selectivity block year ranges
-# qcs_tv_yr_start <- base_model$ctl$start.yr.time.block[3, ]
-# qcs_tv_yr_start[1] <- base_model$dat$start.yr
-# qcs_tv_yr_end <- c(qcs_tv_yr_start[2:length(qcs_tv_yr_start)] - 1,
-#                    base_model$dat$end.yr)
-# if(length(qcs_tv_yr_start) == 2){
-#   qcs_sel_ranges <- paste(paste0(qcs_tv_yr_start, "-", qcs_tv_yr_end),
-#                           collapse = " and ")
-# }else{
-#   qcs_sel_ranges <- paste0(qcs_tv_yr_start, "-", qcs_tv_yr_end)
-#   tmp <- qcs_sel_ranges[length(qcs_sel_ranges)]
-#   qcs_sel_ranges <- paste(qcs_sel_ranges[-length(qcs_sel_ranges)],
-#                           collapse = ", ")
-#   qcs_sel_ranges <- paste0(qcs_sel_ranges, ", and ", tmp)
-# }
 
 # Number of parameters estimated (from PAR file)
 num_params <- get_num_params_est(base_model)
@@ -510,26 +491,20 @@ length_samples_ss <- filter(
   !length %in% find_length_outliers(comm_ss$length)
 )
 
-all_length_samples <- bind_rows(length_samples_survey, length_samples_ft, length_samples_ss)
+all_length_samples <- bind_rows(length_samples_survey,
+                                length_samples_ft,
+                                length_samples_ss)
 
 all_age_samples <- bind_rows(dat$survey_samples, comm_ft, comm_ss) |>
   filter(!is.na(age) & age < 40)
-# it seems there's one extreme outlier... 50 y, also size and sex wouldn't make sense so definite error
-
-# TODO: should the reported values (and coastwide plot) be for just from the 4 trawl surveys combined? Doesn't seem to fit as well if commercial samples added. 
-#vb_m <- fit_vb(dat$survey_samples |> filter(survey_series_id %in% c(1, 3, 4, 16)), 
-#               sex = "male", method = "tmb", too_high_quantile = 1)
-
-#vb_f <- fit_vb(dat$survey_samples |> filter(survey_series_id %in% c(1, 3, 4, 16)), 
-#               sex = "female", method = "tmb", too_high_quantile = 1)
 
-#mat_fit <- fit_mat_ogive(dat$survey_samples |> filter(survey_series_id %in% c(1, 3, 4, 16)), 
-#                         type = "age", sample_id_re = TRUE, year_re = FALSE)
-#                     
 # Use function from this package as it is (very) slightly different than what 
 # fit_mat_ogive() returns, and is what is input into the model
 mat_fit <- export_mat_lw_age(dat$survey_samples, write_file = FALSE)
-# TODO: what random effects wanted? If year, than params are saved as mat_fit$mat_perc$mean$f.mean.p0.5 and mat_fit$mat_perc$mean$m.mean.p0.5 instead of mat_fit$mat_perc$f.p0.5 and mat_fit$mat_perc$m.p0.5. I assume fig:fig-mat should also be made to match 
+# TODO: what random effects wanted? If year, than params are saved as
+# mat_fit$mat_perc$mean$f.mean.p0.5 and mat_fit$mat_perc$mean$m.mean.p0.5
+# instead of mat_fit$mat_perc$f.p0.5 and mat_fit$mat_perc$m.p0.5. I assume
+# fig:fig-mat should also be made to match 
 
 # Natural mortality values in the control file
 param_ctl_table <- models$bridge_grps[[3]][[2]]$ctl$params |>
@@ -553,7 +528,10 @@ if(file.exists(prop_female_fn)){
 }else{
   comm_prop <- props_comm(dat$commercial_samples)
   surv_prop <- props_surv(surv_series = c(1, 3, 4, 16),
-                          surv_series_names = c("qcsss", "hsss", "wcviss", "wchgss"),
+                          surv_series_names = c("qcsss",
+                                                "hsss",
+                                                "wcviss",
+                                                "wchgss"),
                           surv_samples = dat$survey_samples,
                           surv_sets = dat$survey_sets)
   prop_female_lst <- list(comm_prop, surv_prop)
@@ -578,17 +556,6 @@ base_h <- get_parvals(base_model, "h", digits = 2)
 
 bvals <- get_group_parvals(models$bridge_grps)
 svals <- get_group_parvals(models$sens_grps)
-# Now, to get the b0 median for the first sensitivity model in the third model group:
-# Note you ave to skip the first one in each group because it is the base model
-# svals[[3]][[2]]$bo[1]
-# b0 CI range:
-# svals[[3]][[2]]$bo[2]
-# sbt median:
-# svals[[3]][[2]]$sbt[1]
-# sbt CI range:
-# svals[[3]][[2]]$sbt[2]
-# sbt end year:
-# svals[[3]][[2]]$sbt[3
 
 # Extract parameter values from the table found in the control file
 #

docs/csas-review/assessment-main.Rmd

@@ -1233,7 +1233,7 @@ grid.arrange(grobs = ma_plot_lst,
 class: center
 ### Growth Parameters fit externally
 
-```{r growth-params-table, results = "asis", eval=isTRUE(user == "grandin")}
+```{r growth-params-table, results = "asis", eval = length(grep("grandin", user))}
 
 # This is a necessary step when compiling a latex table in HTML!
 tex2markdown <- function(texstring) {
@@ -1358,7 +1358,7 @@ cowplot::plot_grid(
 class: center
 ### Bridge models - Index fits for group 2 models
 
-```{r bridge-index-group2, out.width = "85%", eval=isTRUE(user == "grandin")}
+```{r bridge-index-group2, out.width = "85%", eval = length(grep("grandin", user))}
 plot_index_mcmc(models$bridge_grps[[2]],
                 type = "fits",
                 surv_index = survey_index,