Added spm_summary.csv for ready-made dataframe tablemaker

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
-#}
-}

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

examples/goa_flathead/spm.dat

@@ -1,48 +1,49 @@
+# 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
 1
 #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

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

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<<log_Rzero<<" "<<steepness<<" "<<sigr<<" "<<endl;
 
 FUNCTION Run_Sim
-  detail_out<<"Stock,Alternative,Sim,Yr,SSB,Rec,Tot_biom,SPR_Implied,F,Ntot,Catch,ABC,OFL,AvgAge,AvgAgeTot,SexRatio,B100,B40,B35"<<endl;
+  detail_out<<"Stock,Alt,Sim,Year,SSB,Rec,Tot_biom,SPR_Implied,F,Ntot,Catch,ABC,OFL,AvgAge,AvgAgeTot,SexRatio,B100,B40,B35"<<endl;
     for (int ispp=1;ispp<=nspp;ispp++)
     {
       Get_SPR_Catches(ispp);
@@ -1931,6 +1931,13 @@ FUNCTION void write_sim_hdr(const int& ispp)
             endl;
   percent_out <<"CV Recruit" <<endl;
   percent_out << cvrec(ispp)  <<" "<<endl;
+  // spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_ofl," << Cofl(ispp)<<endl;
+  spm_summary << "spp_file,Alt,Year,variable,value"<<endl;
+  spm_summary << spname(ispp) <<",NA,NA,SSB_100, "<< SB100(ispp) <<endl;
+  spm_summary << spname(ispp) <<",NA,NA,SSB_40, "<< SBF40(ispp) <<endl;
+  spm_summary << spname(ispp) <<",NA,NA,SSB_ofl, "<< SBFofl(ispp) <<endl;
+  spm_summary << spname(ispp) <<",NA,NA,SSB_"<<styr<<","<< Bcurrent(ispp) <<endl;
+  spm_summary << spname(ispp) <<",NA,NA,Mean_rec, "<< AMeanRec(ispp) <<endl;
 
 FUNCTION void write_spp(const int& ispp) 
   // Write out afsd objective function
@@ -1945,13 +1952,13 @@ FUNCTION void write_spp(const int& ispp)
   {
     int iyr=i+styr-1;
     double sd_cat_tmp =      sqrt(norm2(mtmp(i)-mean(mtmp(i)))/nsims)          ;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" Cabc " << Cabc(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" Cofl " << Cofl(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" CLCI " << mtmp(i,LCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" CUCI " << mtmp(i,UCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" CMedian " << mtmp(i,int((UCI+LCI)/2))<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" CMean " << mean(mtmp(i))<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" CStdn " << sd_cat_tmp <<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_abc," << Cabc(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_ofl," << Cofl(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_lb," << mtmp(i,LCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_ub," << mtmp(i,UCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_median," << mtmp(i,int((UCI+LCI)/2))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_mean," << mean(mtmp(i))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",C_sd," << sd_cat_tmp <<endl;
 
    percent_out << i+styr-1                  <<" "
           << " 0"                       <<" "
@@ -1971,13 +1978,13 @@ FUNCTION void write_spp(const int& ispp)
   for (int i=1;i<=npro;i++)
    {
     int iyr=i+styr-1;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBF100 " << SB100(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBFabc " << SBFabc(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBFofl " << SBFofl(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBLCI " << mtmp(i,LCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBUCI " << mtmp(i,UCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBMedian " << mtmp(i,int((UCI+LCI)/2))<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" SSBMean " << mean(mtmp(i))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_F100," << SB100(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_Fabc," << SBFabc(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_Fofl," << SBFofl(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_lb," << mtmp(i,LCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_ub," << mtmp(i,UCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_median," << mtmp(i,int((UCI+LCI)/2))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",SSB_mean," << mean(mtmp(i))<<endl;
 
    percent_out << i+styr-1                         <<" ";
      percent_out      << SB100(ispp)               <<" ";
@@ -1997,13 +2004,13 @@ FUNCTION void write_spp(const int& ispp)
   for (int i=1;i<=npro;i++)
    {
     int iyr=i+styr-1;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" F0 0 "<<endl; 
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" Fabc " << Fabc(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<" Fofl " << Fofl(ispp)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<"  F_LCI " << mtmp(i,LCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<"  F_UCI " << mtmp(i,UCI)<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<"  F_Median " << mtmp(i,int((UCI+LCI)/2))<<endl;
-    percent_db << spname(ispp)<<" "<< alt<<" "<< iyr<<"  F_Mean " << mean(mtmp(i))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_0,0 "<<endl; 
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_abc," << Fabc(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_ofl," << Fofl(ispp)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_lb," << mtmp(i,LCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_ub," << mtmp(i,UCI)<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_median," << mtmp(i,int((UCI+LCI)/2))<<endl;
+    spm_summary << spname(ispp)<<","<< alt<<","<< iyr<<",F_mean," << mean(mtmp(i))<<endl;
    percent_out << i+styr-1                  <<" "
           << " 0"                       <<" "
           << Fabc(ispp)                 <<" "