From 516ff0000cab63347554cfd981173935dd311e77 Mon Sep 17 00:00:00 2001 From: Jim Ianelli Date: Tue, 6 Aug 2024 08:10:30 -0700 Subject: [PATCH] Added spm_summary.csv for ready-made dataframe tablemaker --- R/readData.R | 179 ++++++++------------------- examples/goa_flathead/Input_Log.rep | 10 +- examples/goa_flathead/spm.dat | 29 ++--- examples/goa_flathead/spm_detail.csv | 2 +- src/spm.tpl | 53 ++++---- vignettes/00-spm-example.Rmd | 60 +++++++-- 6 files changed, 151 insertions(+), 182 deletions(-) diff --git a/R/readData.R b/R/readData.R index 114bc07..7330162 100644 --- a/R/readData.R +++ b/R/readData.R @@ -30,143 +30,66 @@ list2dat <- function(D, fn, hdr="a new file") { # } } -#' Read Data File into List Object -#' -#' Reads a data file formatted for a projection model and converts it into a list object. -#' The function handles numeric and NA values appropriately. -#' -#' @param fn Filename of the data file to be read. -#' @return A list object containing the data from the file. -#' @export +#' @title Convert Data to List +#' @description This function reads data from a file and converts it into a list. +#' If the data are numeric, it maintains the numeric list. If the data are strings, it returns a character string. +#' @param fn A character string representing the file name to be read. +#' @return A list with numeric data or character strings based on the content of the file. #' @examples #' # Example usage: -#' # myDataList <- dat2list("datafile.dat") +#' # result <- dat2list("datafile.txt") +#' @export dat2list <- function(fn) { - options(warn = -1) # Suppress warnings temporarily - on.exit(options(warn = 0)) # Reset warning options on exit - - file_content <- scan(fn, what = "character", flush = TRUE, blank.lines.skip = FALSE, quiet = TRUE) - - # Identify lines starting with '#' - header_indices <- which(substr(file_content, 1, 1) == "#") - header_names <- substr(file_content[header_indices], 2, nchar(file_content[header_indices])) - - # Initialize the list to store data - list_data <- list() - - # Iterate over header names to extract and store data - for (i in seq_along(header_names)) { - # Get start and end line indices for the current section - start_line <- header_indices[i] - end_line <- if (i < length(header_names)) header_indices[i + 1] - 1 else length(file_content) - - # Extract the data chunk between the header lines - data_chunk <- file_content[(start_line + 1):end_line] + options(warn = -1) # Suppress the NA message in the coercion to double + datfile <- scan(fn, what = "character", flush = TRUE, blank.lines.skip = FALSE, quiet = TRUE) + + datfile + # Identify potential list names by checking if they are not entirely numeric + #idx <- sapply(datfile, function(x) all(is.na(as.numeric(x)))) + idx2 <- (grepl(datfile,pattern="#")) + #idx + #idx2 + #length(idx) + vnam <- datfile[idx2] # list names + #vnam + + nv <- length(vnam) # number of objects + A <- list() + ir <- 0 + + for (i in 1:nv) { + ir <- match(vnam[i], datfile) + if (i != nv) irr <- match(vnam[i + 1], datfile) else irr <- length(datfile) + 1 # next row + #dum <- NA + + if (irr - ir == 2) { + content <- scan(fn, skip = ir, nlines = 1, quiet = TRUE, what = "") + if (all(is.na(as.numeric(content)))) { + dum <- as.character(content) + } else { + dum <- as.numeric(content) + } + } else if (irr - ir > 2) { + content <- read.table(fn, skip = ir, nrow = irr - ir - 1, fill = TRUE, row.names = NULL) + if (all(is.na(as.numeric(as.matrix(content))))) { + dum <- as.character(as.matrix(content)) + } else { + dum <- as.matrix(content) + } + } - # Check if the data chunk is a single line - if (length(data_chunk) == 1 && grepl("^[0-9]", data_chunk)) { - # Convert single line data to numeric - list_data[[header_names[i]]] <- as.numeric(data_chunk) + # Ensure proper naming and storing in the list + if (is.numeric(dum) && !any(is.na(dum))) { + A[[vnam[i]]] <- dum } else { - # Read the table from the data chunk - list_data[[header_names[i]]] <- read.table(text = data_chunk, fill = TRUE, header = FALSE) + A[[vnam[i]]] <- as.character(dum) } } + names(A) <- substr(names(A), 2, nchar(names(A))) + options(warn = 0) - # Print the resulting list to check the output - return(list_data) + return(A) } -#' Print Tier 3 Tables -#' -#' Generates and prints HTML tables for Tier 3 projections including catch, ABC, fishing mortality, and spawning biomass for various scenarios. -#' -#' @param df Data frame containing Tier 3 data. -#' @param modname Name of the model used, defaults to "base". -#' @param stock Name of the stock, defaults to "BSAI Atka mackerel". -#' @return HTML tables for the specified Tier 3 data. -#' @export -#' @importFrom dplyr select, group_by, summarise, spread -#' @examples -#' # Example usage: -#' # print_Tier3_tables(myDataFrame, "model1", "Some Fish Stock") -print_Tier3_tables <- function(df, modname="base", stock="BSAI Atka mackerel") { - tabcap<-tablab <- c("tier3_C","tier3_ABC","tier3_F","tier3_SSB") - tabcap[1]=paste0("Tier 3 projections of ",stock," catch for the 7 scenarios.") - tabcap[2]=paste0("Tier 3 projections of ",stock," ABC for the 7 scenarios.") - tabcap[3]=paste0("Tier 3 projections of ",stock," fishing mortality for the 7 scenarios.") - tabcap[4]=paste0("Tier 3 projections of ",stock," spawning biomass for the 7 scenarios.") - - # Stock Alt Sim Yr SSB Rec Tot_biom SPR_Implied F Ntot Catch ABC OFL AvgAge AvgAgeTot SexRatio FABC FOFL - bfsum <- df %>% select(Alternative,Yr,SSB,F,ABC ,Catch) %>% group_by(Alternative,Yr) %>% summarise(Catch=mean(Catch),SSB=mean(SSB),F=mean(F),ABC=mean(ABC)) - - tC <- bfsum %>% select(Alternative,Yr,Catch) %>% spread(Alternative,Catch) - names(tC) <- c("Catch","Scenario 1","Scenario 2","Scenario 3","Scenario 4","Scenario 5","Scenario 6","Scenario 7") - - tB <- bfsum %>% select(Alternative,Yr,SSB) %>% spread(Alternative,SSB) - names(tB) <- c("SSB","Scenario 1","Scenario 2","Scenario 3","Scenario 4","Scenario 5","Scenario 6","Scenario 7") - tF <- bfsum %>% select(Alternative,Yr,F) %>% spread(Alternative,F) - names(tF) <- c("F","Scenario 1","Scenario 2","Scenario 3","Scenario 4","Scenario 5","Scenario 6","Scenario 7") - - tA <- bfsum %>% select(Alternative,Yr,ABC) %>% spread(Alternative,ABC) - names(tA) <- c("ABC","Scenario 1","Scenario 2","Scenario 3","Scenario 4","Scenario 5","Scenario 6","Scenario 7") - - tab <- (data.frame(tC)) - rownames(tab)<-c() - cap <- tabcap[1] - for (i in 2:length(tab[1,]) ) - tab[,i] <- formatC((tab[,i]), format="d", big.mark=",") - tab <- xtable::xtable(tab, caption = cap, label=paste0("tab:",tablab[1]), - digits=0, auto=TRUE, align=rep("r",(length(tab[1,])+1)) ) - print(tab, "html", caption.placement = "top",include.rownames = FALSE, sanitize.text.function = function(x){x}, scalebox=.85) - - tab <- (data.frame(tB)) - cap <- tabcap[2] - for (i in 2:length(tab[1,]) ) - tab[,i] <- formatC(as.numeric(tab[,i]), format="d", big.mark=",") - tab <- xtable::xtable(tab, caption = cap, label=paste0("tab:",tablab[2]),digits=0, auto=TRUE, align=rep("r",(length(tab[1,])+1)) ) - print(tab, "html", caption.placement = "top",include.rownames = FALSE, sanitize.text.function = function(x){x}, scalebox=.85) - - tab <- (data.frame(tF)) - cap <- tabcap[3] - for (i in 2:length(tab[1,]) ) - tab[,i] <- formatC(as.numeric(tab[,i]), format="f",digits=3) - tab <- xtable::xtable(tab, caption = cap, label=paste0("tab:",tablab[3]), digits=3, align=rep("r",(length(tab[1,])+1)) ) - print(tab, "html", caption.placement = "top",include.rownames = FALSE, sanitize.text.function = function(x){x}, scalebox=.85) - - tab <- (data.frame(tA)) - cap <- tabcap[4] - for (i in 2:length(tab[1,]) ) - tab[,i] <- formatC(as.numeric(tab[,i]), format="d", big.mark=",") - tab <- xtable::xtable(tab, caption = cap, label=paste0("tab:",tablab[4]),digits=0, auto=TRUE, align=rep("r",(length(tab[1,])+1)) ) - print(tab, "html", caption.placement = "top",include.rownames = FALSE, sanitize.text.function = function(x){x}, scalebox=.85) - return(tab) -# -# -# if (!requireNamespace("dplyr", quietly = TRUE)) stop("dplyr package is required but not installed") -# if (!requireNamespace("xtable", quietly = TRUE)) stop("xtable package is required but not installed") -# -# # Compute summaries -# summary_df <- df %>% -# dplyr::select(Alt, Yr, SSB, F, ABC, Catch) %>% -# dplyr::group_by(Alt, Yr) %>% -# dplyr::summarise(Catch = mean(Catch), SSB = mean(SSB), F = mean(F), ABC = mean(ABC)) -# -# # Prepare and print tables -# table_types <- c("Catch", "SSB", "F", "ABC") -# for (type in table_types) { -# formatted_table <- create_formatted_table(summary_df, type, stock) -# print_table(formatted_table, type, stock) -# } -# } -# -# create_formatted_table <- function(df, type, stock) { -# # Table creation logic -# } -# -# print_table <- function(table, type, stock) { -# # Table printing logic -#} -} diff --git a/examples/goa_flathead/Input_Log.rep b/examples/goa_flathead/Input_Log.rep index b0491bb..f743403 100644 --- a/examples/goa_flathead/Input_Log.rep +++ b/examples/goa_flathead/Input_Log.rep @@ -25,15 +25,15 @@ nsims styr 2022 bzero_in -2.14493e-314 +2.141e-314 phizero_in -2.14493e-314 +2.141e-314 alpha_in -3.02973e-314 +2.14175e-314 sigmar_in -8.21168e-148 -rho_in 0 +rho_in +3.03032e-314 nyrs_catch_in 3 nspp diff --git a/examples/goa_flathead/spm.dat b/examples/goa_flathead/spm.dat index 6f1d5fc..ffb7e25 100644 --- a/examples/goa_flathead/spm.dat +++ b/examples/goa_flathead/spm.dat @@ -1,35 +1,36 @@ +# a new file #rn flathead_sole_goa #Tier 3 #nalts -7 +7 #alts 1 -2 +2 3 4 5 6 7 #tac_flag -1 +1 #srr_type -1 +1 #srr_form -1 +1 #srr_conditioning -0 +0 #srr_reserved -0 +0 #spm_detail_flag -1 +1 #nprj_yrs -15 +15 #nsims -1000 +1000 #beg_yr -2022 +2022 #nyrs_fixed_catch 3 #nspp @@ -37,12 +38,12 @@ flathead_sole_goa #OY_min 0 #OY_max -2.00E+06 +2e+06 #datafile projection_data.dat -#ABC_mults +#ABC_mults 1 -#scalars +#scalars 1000 #alt4_spr 0.75 diff --git a/examples/goa_flathead/spm_detail.csv b/examples/goa_flathead/spm_detail.csv index 12fbe31..908ee4b 100644 --- a/examples/goa_flathead/spm_detail.csv +++ b/examples/goa_flathead/spm_detail.csv @@ -1,4 +1,4 @@ -Stock,Alternative,Sim,Yr,SSB,Rec,Tot_biom,SPR_Implied,F,Ntot,Catch,ABC,OFL,AvgAge,AvgAgeTot,SexRatio,B100,B40,B35 +Stock,Alt,Sim,Year,SSB,Rec,Tot_biom,SPR_Implied,F,Ntot,Catch,ABC,OFL,AvgAge,AvgAgeTot,SexRatio,B100,B40,B35 projection_data.dat,1,1,2022,91.8344,454.766,292.385,0.975936,0.00458035,341.333,0.687,38.6377,47.1212,8.14789,4.45396,0.502242,185.165,74.0658,64.8076 projection_data.dat,1,1,2023,94.114,306.918,306.603,0.936965,0.0124968,351.56,1.90797,39.498,48.1833,8.08538,4.49828,0.501956,185.165,74.0658,64.8076 projection_data.dat,1,1,2024,96.1829,162.434,319.647,0.938133,0.01225,360.697,1.90797,40.3217,49.1974,8.09657,4.94049,0.501836,185.165,74.0658,64.8076 diff --git a/src/spm.tpl b/src/spm.tpl index 5dbcd74..2a6c394 100755 --- a/src/spm.tpl +++ b/src/spm.tpl @@ -17,8 +17,8 @@ DATA_SECTION !!CLASS ofstream means_out("means.out") !!CLASS ofstream alts_proj("alt_proj.out") !!CLASS ofstream percent_out("percentiles.out") - !!CLASS ofstream percent_db("percentdb.out") // !!CLASS ofstream Alt3bstuff("alt3b.out") + !!CLASS ofstream spm_summary("spm_summary.csv") !!CLASS ofstream detail_out("spm_detail.csv") !!CLASS ofstream prof_F("F_profile.out"); !!CLASS ofstream elasticity("elasticity.csv"); @@ -710,7 +710,7 @@ PROCEDURE_SECTION if (mceval_phase()) cout< %\VignetteIndexEntry{spmR-examples} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} + +lightbox: true +output: + # rmarkdown::html_vignette + bookdown::html_document2: + code_folding: hide + fig_caption: yes + number_sections: yes + theme: readable + highlight: tango + code-summary: "Show the code" + embed-resources: true + toc: true + toc-title: 'Contents' + toc_float: yes + number-sections: false + code-fold: true +format: + html: + code-summary: "Show the code" + embed-resources: true + toc: true + toc-title: 'Contents' + number-sections: false + code-fold: true editor_options: chunk_output_type: console --- ```{r, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>" -) +knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) +knitr::opts_knit$set(root.dir = here::here()) +knitr::opts_chunk$set(warning = FALSE, message = FALSE, echo = FALSE, results = FALSE, fig.width = 6, fig.height = 5) ``` ```{r setupex} @@ -61,17 +84,32 @@ df <- runSPM(here::here("examples","yfs"),run=FALSE) ``` ## GOA Flathead sole -```{r goa_fhs,eval=FALSE} -df <- runSPM(here::here("examples","goa_flathead/maia"),run=TRUE) -plotSPM(df,thisyr=2024) +First we'll run this model with only 3-years fixed catch assumed + +```{r goa_fhs,eval=TRUE,echo=FALSE} +# df <- runSPM(here::here("examples","goa_flathead/maia"),run=TRUE) +df <- runSPM(here::here("examples","goa_flathead"),run=FALSE) plotSPM(df,thisyr=2025) -p1<- plotSPM(df) -?plotSPM -p1$data +# p1<- plotSPM(df) + +``` +Now let's use the utility to change the input files and re-run the model with 5-years fixed catch assumed. +```{r goa_fhs2,eval=TRUE,echo=FALSE} +inp <- spmR::dat2list(here::here("examples","goa_flathead","spm.dat")) +inp$nyrs_fixed_catch +inp$nyrs_fixed_catch <- 5 +inp$fixed_catch <- rbind(inp$fixed_catch, c(2025, 1100), c(2026, 1100)) +inp$fixed_catch +spmR::list2dat(inp,here::here("examples","goa_flathead","spm.dat")) +df <- runSPM(here::here("examples","goa_flathead"),run=TRUE) + +plotSPM(df,thisyr=2024) ``` + + ## GOA Rougheye blackspotted ```{r rougheye,eval=FALSE}