Bug #496 fix summary output for imposex data

R/assessment_functions.R

@@ -1023,12 +1023,12 @@ assess_lmm <- function(
 
   # construct summary output -
 
-  output$summary <- data.frame(
-    nyall = nYearFull, nyfit = nYear, nypos = nYearPos, 
-    firstYearAll = firstYearFull, firstYearFit = min(data$year), lastyear = max(data$year), 
-    p_nonlinear = NA, p_linear = NA, p_overall = NA, pltrend = NA, ltrend = NA, prtrend = NA, 
-    rtrend = NA, dtrend = NA, meanLY = NA, clLY = NA)
-
+  output$summary <- initialise_assessment_summary(
+    data, 
+    nyall = nYearFull,
+    firstYearAll = firstYearFull, 
+    nypos = nYearPos
+  )
 
   output$summary <- within(output$summary, {
 
@@ -1675,6 +1675,49 @@ ctsm_dyear <- function(
 }
 
 
+# Utility functions ----
+
+initialise_assessment_summary <- function(
+    data, nyall, firstYearAll, nypos = NULL, .extra = NULL) {
+
+  year <- data$year
+
+  nyfit <- dplyr::n_distinct(year)
+
+  if (is.null(nypos)) {
+    nypos <- nyfit
+  }
+
+  out <- data.frame(
+    nyall = nyall, 
+    nyfit = nyfit, 
+    nypos = nypos, 
+    firstYearAll = firstYearAll, 
+    firstYearFit = min(year), 
+    lastyear = max(year),
+    p_nonlinear = NA_real_, 
+    p_linear = NA_real_, 
+    p_overall = NA_real_, 
+    pltrend = NA_real_, 
+    ltrend = NA_real_, 
+    prtrend = NA_real_, 
+    rtrend = NA_real_, 
+    dtrend = NA_real_, 
+    meanLY = NA_real_, 
+    clLY = NA_real_ 
+  )  
+
+  if (!is.null(.extra)) {
+    .extra <- as.data.frame(.extra)
+    if (any(names(.extra) %in% names(out)) || nrow(.extra) != 1) {
+      stop("error in specifying extra output variables")
+    }
+    out <- cbind(out, .extra)
+  }
+
+  out
+}
+
 
 
 
@@ -2014,11 +2057,11 @@ assess_survival <- function(
 
   # construct summary output -
 
-  output$summary <- data.frame(
-    nyall = nYearFull, nyfit = nYear, nypos = nYearPos, 
-    firstYearAll = firstYearFull, firstYearFit = min(data$year), lastyear = max(data$year), 
-    p_nonlinear = NA, p_linear = NA, p_overall = NA, pltrend = NA, ltrend = NA, prtrend = NA, 
-    rtrend = NA, dtrend = NA, meanLY = NA, clLY = NA)
+  output$summary <- initialise_assessment_summary(
+    data, 
+    nyall = nYearFull,
+    firstYearAll = firstYearFull, 
+  )
 
 
   output$summary <- within(output$summary, {
@@ -2477,12 +2520,12 @@ assess_beta <- function(
 
   # construct summary output -
 
-  output$summary <- data.frame(
-    nyall = nYearFull, nyfit = nYear, nypos = nYearPos, 
-    firstYearAll = firstYearFull, firstYearFit = min(data$year), lastyear = max(data$year), 
-    p_nonlinear = NA, p_linear = NA, p_overall = NA, pltrend = NA, ltrend = NA, prtrend = NA, 
-    rtrend = NA, dtrend = NA, meanLY = NA, clLY = NA)
-  
+  output$summary <- initialise_assessment_summary(
+    data, 
+    nyall = nYearFull,
+    firstYearAll = firstYearFull, 
+  )
+
 
   output$summary <- within(output$summary, {
 
@@ -2878,11 +2921,11 @@ assess_negativebinomial <- function(
 
   # construct summary output -
 
-  output$summary <- data.frame(
-    nyall = nYearFull, nyfit = nYear, nypos = nYearPos, 
-    firstYearAll = firstYearFull, firstYearFit = min(data$year), lastyear = max(data$year), 
-    p_nonlinear = NA, p_linear = NA, p_overall = NA, pltrend = NA, ltrend = NA, prtrend = NA, 
-    rtrend = NA, dtrend = NA, meanLY = NA, clLY = NA)
+  output$summary <- initialise_assessment_summary(
+    data, 
+    nyall = nYearFull,
+    firstYearAll = firstYearFull, 
+  )
 
 
   output$summary <- within(output$summary, {

R/imposex_clm.R

@@ -228,7 +228,7 @@ imposex_assess_clm <- function(
   if (nYear <= 2) {
     summary$meanLY <- tail(annualIndex$index, 1)
     summary$clLY <- tail(annualIndex$upper, 1)
-    summary$class = imposex_class(species, summary$clLY)
+    summary$imposex_class = imposex_class(species, summary$clLY)
     return(list(summary = data.frame(summary)))
   }
 

R/imposex_functions.R

@@ -159,7 +159,7 @@ assess_imposex <- function(
 
   nYearFull <- length(unique(data$year))  
 
-  nYearFirst <- min(data$year)
+  firstYearFull <- min(data$year)
 
 
   # deal with data sets that have crept in by mistake and have no recent data
@@ -204,19 +204,18 @@ assess_imposex <- function(
   annualIndex <- annualIndex[annualIndex$year %in% unique(data$year), ]
 
 
-  # initialise output
-
-  output <- list(data = data)
-
-  nYear <- length(unique(data$year))
+  # initialise output:
+  # - add class at end (but may deprecate this)
 
-  summary <- data.frame(
-    nyall = nYearFull, nyfit = nYear, nypos = nYear, 
-    firstYearAll = nYearFirst, firstYearFit = min(data$year), lastyear = max(data$year), 
-    p_nonlinear = NA, p_linear = NA, p_overall = NA, 
-    pltrend = NA, ltrend = NA, prtrend = NA, rtrend = NA, 
-    meanLY = NA, clLY = NA, class = NA)
+  output <- list(data = data)
 
+  summary <- initialise_assessment_summary(
+    data, 
+    nyall = nYearFull,
+    firstYearAll = firstYearFull,
+    .extra = list(imposex_class = NA_character_)
+  )
+
 
   # all individual data, a mixture, or just indices
 
@@ -263,11 +262,9 @@ assess_imposex <- function(
       infoLY <- c(tail(annualIndex, 1))
       if (!("clLY" %in% names(assessment$summary)) || 
           infoLY$upper < assessment$summary$clLY) {
-        assessment$summary <- within(assessment$summary, {
-          meanLY <- infoLY$index
-          clLY <- infoLY$upper
-          class <- imposex_class(species, clLY)
-        })
+        assessment$summary$meanLY <- infoLY$index
+        assessment$summary$clLY <- infoLY$upper
+        assessment$summary$imposex_class <- imposex_class(species, infoLY$upper)
       }
     }
   }  
@@ -368,7 +365,7 @@ imposex.assess.index <- function(annualIndex, species, determinand, info.imposex
     }
     summary$meanLY <- value[1]
     summary$clLY <- value[1]
-    summary$class <- imposex_class(species, value[1])
+    summary$imposex_class <- imposex_class(species, value[1])
 
     output$summary <- data.frame(summary)
 

R/reporting_functions.R

@@ -672,10 +672,6 @@ write_summary_table <- function(
     climit_last_year = "clLY"
   )
 
-  if ("class" %in% names(summary)) {
-    summary <- dplyr::rename(summary, imposex_class = "class")
-  }
-
   if ("dtrend_obs" %in% names(summary)) {
     summary <- dplyr::rename(
       summary,