tests/testthat/test-benthos-fluxes.R

In StrathE2E2: End-to-End Marine Food Web Model

test_that("check benthos feeding flux calculations", {

#-----------------------------------------------------------------------------------------------------------------
#
# This test uses a 'Testbed' version of the model in which all of the external drivers are set to constant values.
# We expect the model outputs to converge to a steady state under these conditions. Then we take the masses of the
# food web variables from the steady state model output, and manually derive the uptake fluxes between them.
# These manually derived fluxes are then compared with the fluxes generated in the 'flux_matrix' outputs from the model.
# So the test is checking that the flux calculations in the C-code of the package are correctly evaluated.
#
# The Testbed model is stored in /StrathE2E2/tests/testdata/models/
#
# The model has been run for >1000 years to ensure a steady state, and the end-state saved as initial conditions.
# So the model should be at steady state from time 0. In fact, the input csv file containing the initial conditions
# does not hold sufficient precision (number of decimal places) to ensure perfect steady state from the onset of a run.
# This is manifest as some tiny oscillations in the first year or so of a run before everything settles to its steady state.
# Hence we run the Testbed model for 10 years and then base the test on the final year of the run.
# 
# For convenience, the Testbed model uses the fitted parameters from the North Sea implementation of StrathE2E2.
# 
# Two important points to note:
# 1) The temperature driving data for all three spatial compartmets of the Testbed
# model are set to 10C, wich matches the Q10 reference temperature in the fixed parameter inputs. This means that when manually
# calculating the uptake fluxes there is no need to compute any temperature corrections for the maximum uptake rate
# parameters. However, the C-code in the model IS doing the Q10 calculation, so this is an important aspect of the testing.
# As a consequence, it is very important not to chnage the temperature driving values in the Testbed model - they must be
# equal to the Q10 reference temperature value.
# 2) The sediment habitats are all set to the same area (0.125). This affects the calculation of uptake of corpses by benthos.
# By setting the habitats to equal area, we can simply sum the mass of corpses across each zone and use that as input to the
# manual calculation of uptake by benthos. The C code performs this calculation separately for each habitat and then adds the
# results. So this is an additional test of the model code. But it means that the habitat areas should not be edited in the
# input csv files.
#
# This test applies the above approach to uptake by susp/dep feeding and carn/scav feeding benthos classes.
#
#-----------------------------------------------------------------------------------------------------------------
#
# The following non-exported functions in the package are needed for the test:
# source("internal.R")
# source("read_fitted_parameters.R")
# source("read_fixed_parameters.R")
# source("read_physics_drivers.R")
# source("read_physical_parameters.R")
#
#-----------------------------------------------------------------------------------------------------------------

#Some additional functions required for assembling the tests

#######################
#Function to pull the final year annual average mass of a variable out of the results
pull_final_year_mean<-function(results,vtoget){
vgot<-(elt(results$output, vtoget))
vmean<-mean(vgot[(length(vgot)-360):(length(vgot))])
vmean
}
######################
#Function to pull flux data out of the flow matrix generated by the model
extract_model_flux<-function(matrixname,preyname,predname){
predi<-which(colnames(matrixname)==predname)
preyi<-which(colnames(matrixname)==preyname)
model_flux<-(matrixname[preyi,predi]/360)
model_flux
}
#######################
#Heterotrophic uptake function
f1<-function(a,b,k1,k2)
#          prey,pred,umax,hs
{
  return ((b*k1*a)/(a+k2))
}
#######################

#-----------------------------------------------------------------------------------------------------------------

#Run the Testbed model and pull out data from the results object

#Run the testbed model - assuming R home dir is "/GitLab/StrathE2E2/tests"
model<-e2e_read(model.name="Testbed",
                  model.variant="Const",
                  model.ident="base",
                  models.path="../testdata/models")
results <- e2e_run(model,nyears=10,csv.output=FALSE)
#plot_full_length_timeseries(model,results)
#extract_new_initial_cond_from_end_of_run(model, results)

#Pull out the inshore and offshore final year data for phytoplankton and zoopkankton groups

#names(results$output[1:78]) # Lists the names of state varibales in the header

detritus_si<-pull_final_year_mean(results,"detritus_si")
x_detritus_s1<-pull_final_year_mean(results,"x_detritus_s1")
x_detritus_s2<-pull_final_year_mean(results,"x_detritus_s2")
x_detritus_s3<-pull_final_year_mean(results,"x_detritus_s3")
xR_detritus_s1<-pull_final_year_mean(results,"xR_detritus_s1")
xR_detritus_s2<-pull_final_year_mean(results,"xR_detritus_s2")
xR_detritus_s3<-pull_final_year_mean(results,"xR_detritus_s3")
corpse_s0<-pull_final_year_mean(results,"corpse_s0")
corpse_s1<-pull_final_year_mean(results,"corpse_s1")
corpse_s2<-pull_final_year_mean(results,"corpse_s2")
corpse_s3<-pull_final_year_mean(results,"corpse_s3")
phyt_si<-pull_final_year_mean(results,"phyt_si")
benths_i<-pull_final_year_mean(results,"benths_i")
benthc_i<-pull_final_year_mean(results,"benthc_i")
kelp_i<-pull_final_year_mean(results,"kelpN")
kelpdebris_i<-pull_final_year_mean(results,"kelpdebris")

corpse_i <- corpse_s0 + corpse_s1 + corpse_s2 + corpse_s3
x_detritus_i<-x_detritus_s1 + x_detritus_s2 + x_detritus_s3
xR_detritus_i<-xR_detritus_s1 + xR_detritus_s2 + xR_detritus_s3

detritus_d<-pull_final_year_mean(results,"detritus_d")
x_detritus_d1<-pull_final_year_mean(results,"x_detritus_d1")
x_detritus_d2<-pull_final_year_mean(results,"x_detritus_d2")
x_detritus_d3<-pull_final_year_mean(results,"x_detritus_d3")
xR_detritus_d1<-pull_final_year_mean(results,"xR_detritus_d1")
xR_detritus_d2<-pull_final_year_mean(results,"xR_detritus_d2")
xR_detritus_d3<-pull_final_year_mean(results,"xR_detritus_d3")
corpse_d0<-pull_final_year_mean(results,"corpse_d0")
corpse_d1<-pull_final_year_mean(results,"corpse_d1")
corpse_d2<-pull_final_year_mean(results,"corpse_d2")
corpse_d3<-pull_final_year_mean(results,"corpse_d3")
phyt_d<-pull_final_year_mean(results,"phyt_d")
benths_o<-pull_final_year_mean(results,"benths_o")
benthc_o<-pull_final_year_mean(results,"benthc_o")

corpse_o <- corpse_d0 + corpse_d1 + corpse_d2 + corpse_d3
x_detritus_o<-x_detritus_d1 + x_detritus_d2 + x_detritus_d3
xR_detritus_o<-xR_detritus_d1 + xR_detritus_d2 + xR_detritus_d3

#Pull out the flow matrix from the results
flow_matrix<-elt(results$final.year.outputs,"flow_matrix_all_fluxes")

#colnames(flow_matrix)   #Lists the column names in the flow matrix
#rownames(flow_matrix)   #Lists the row names in the flow matrix

#-----------------------------------------------------------------------------------------------------------------

#Pull data out of the model object, ie data that have been assembled from the input csv files

#Pull out the model configuration to get areas and volumes

model.path<-model$setup$model.path
	read.model.setup(model.path)			# Models/Model/Variant/MODEL_SETUP.csv
	physical.parameters	<- read_physical_parameters(model.path)
	bx_depth<-elt(physical.parameters,"bx_depth")
	so_depth<-elt(physical.parameters,"so_depth")
	si_depth<-elt(physical.parameters,"si_depth")
	d_depth<-elt(physical.parameters,"d_depth")
        area_s0<-elt(physical.parameters,"x_area_s0")
        area_s1<-elt(physical.parameters,"x_area_s1")
        area_s2<-elt(physical.parameters,"x_area_s2")
        area_s3<-elt(physical.parameters,"x_area_s3")
        area_d0<-elt(physical.parameters,"x_area_d0")
        area_d1<-elt(physical.parameters,"x_area_d1")
        area_d2<-elt(physical.parameters,"x_area_d2")
        area_d3<-elt(physical.parameters,"x_area_d3")
shallowprop<-(area_s0+area_s1+area_s2+area_s3)
volume_so<-so_depth*(1-shallowprop)
volume_d<-d_depth*(1-shallowprop)
volume_si<-si_depth*(shallowprop)



# Pull out the uptake function parameters needed to manually calculate the fluxes

model.path<-model$setup$model.path
	read.model.setup(model.path)			# Models/Model/Variant/MODEL_SETUP.csv
	fitted.parameters	<- read_fitted_parameters(model.path)
	fixed.parameters	<- read_fixed_parameters(model.path)



u_benths<-elt(fitted.parameters,"u_benths")
h_benths<-elt(fitted.parameters,"h_benths")

PREF_phyt_benths<-elt(fitted.parameters,"PREF_phyt_benths")
PREF_det_benths<-elt(fitted.parameters,"PREF_det_benths")
PREF_sed_benths<-elt(fitted.parameters,"PREF_sed_benths")

qs_p3<-elt(fitted.parameters,"xqs_p3")

#....

u_benthc<-elt(fitted.parameters,"u_benthc")
h_benthc<-elt(fitted.parameters,"h_benthc")

PREF_corpse_benthc<-elt(fitted.parameters,"PREF_corp_benthc")
PREF_benths_benthc<-elt(fitted.parameters,"PREF_benths_benthc")
PREF_kelp_benthc<-elt(fitted.parameters,"PREF_kelp_benthc")
PREF_kelpdebris_benthc<-elt(fitted.parameters,"PREF_kelpdebris_benthc")

#-----------------------------------------------------------------------------------------------------------------

#Now calculate the fluxes


#............................

calc_flux_phyt_benths_o<- f1(phyt_d*bx_depth/d_depth,  (benths_o),u_benths*PREF_phyt_benths,h_benths*(1-shallowprop))
calc_flux_phyt_benths_i<- f1(phyt_si*bx_depth/si_depth,(benths_i),u_benths*PREF_phyt_benths,h_benths*(shallowprop))

calc_flux_phyt_benths_w <- calc_flux_phyt_benths_o + calc_flux_phyt_benths_i

model_flux_phyt_benths<-extract_model_flux(flow_matrix,"phyt","benths")

#calc_flux_phyt_benths_w
#model_flux_phyt_benths

#............................

calc_flux_det_benths_o<- f1(detritus_d*bx_depth/d_depth,  (benths_o),u_benths*PREF_det_benths,h_benths*(1-shallowprop))
calc_flux_det_benths_i<- f1(detritus_si*bx_depth/si_depth,(benths_i),u_benths*PREF_det_benths,h_benths*(shallowprop))

calc_flux_det_benths_w <- calc_flux_det_benths_o + calc_flux_det_benths_i

model_flux_det_benths<-extract_model_flux(flow_matrix,"wcdetritus","benths")

#calc_flux_det_benths_w
#model_flux_det_benths

#............................

#Flux of labile and refractory sediment detritus combined
calc_flux_seddetT_benths_d1<- f1((x_detritus_d1+xR_detritus_d1),  (benths_o*area_d1/(1-shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_d1))
calc_flux_seddetT_benths_d2<- f1((x_detritus_d2+xR_detritus_d2),  (benths_o*area_d2/(1-shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_d2))
calc_flux_seddetT_benths_d3<- f1((x_detritus_d3+xR_detritus_d3),  (benths_o*area_d3/(1-shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_d3))

calc_flux_seddetT_benths_s1<- f1((x_detritus_s1+xR_detritus_s1),  (benths_i*area_s1/(shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_s1))
calc_flux_seddetT_benths_s2<- f1((x_detritus_s1+xR_detritus_s2),  (benths_i*area_s2/(shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_s2))
calc_flux_seddetT_benths_s3<- f1((x_detritus_s1+xR_detritus_s3),  (benths_i*area_s3/(shallowprop)),u_benths*PREF_sed_benths,h_benths*(area_s3))

calc_flux_seddetT_benths_o <- calc_flux_seddetT_benths_d1 + calc_flux_seddetT_benths_d2 + calc_flux_seddetT_benths_d3
calc_flux_seddetT_benths_i <- calc_flux_seddetT_benths_s1 + calc_flux_seddetT_benths_s2 + calc_flux_seddetT_benths_s3

calc_flux_seddetL_benths_o<- calc_flux_seddetT_benths_o * (x_detritus_o/(x_detritus_o+xR_detritus_o))
calc_flux_seddetL_benths_i<- calc_flux_seddetT_benths_i * (x_detritus_i/(x_detritus_i+xR_detritus_i))

calc_flux_seddetR_benths_o<- qs_p3 * calc_flux_seddetT_benths_o * (xR_detritus_o/(x_detritus_o+xR_detritus_o))
calc_flux_seddetR_benths_i<- qs_p3 * calc_flux_seddetT_benths_i * (xR_detritus_i/(x_detritus_i+xR_detritus_i))

calc_flux_seddetL_benths_w <- calc_flux_seddetL_benths_o + calc_flux_seddetL_benths_i
calc_flux_seddetR_benths_w <- calc_flux_seddetR_benths_o + calc_flux_seddetR_benths_i

model_flux_seddetL_benths<-extract_model_flux(flow_matrix,"seddetritus","benths")
model_flux_seddetR_benths<-extract_model_flux(flow_matrix,"seddetritusR","benths")

#calc_flux_seddetL_benths_w
#model_flux_seddetL_benths

#calc_flux_seddetR_benths_w
#model_flux_seddetR_benths

#............................
#............................

calc_flux_kelp_benthc_i<- f1(kelp_i,(benthc_i*area_s0/shallowprop),u_benthc*PREF_kelp_benthc,h_benthc*(shallowprop))

model_flux_kelp_benthc<-extract_model_flux(flow_matrix,"kelp","benthc")

#calc_flux_kelp_benthc_i
#model_flux_kelp_benthc

#............................

calc_flux_kelpdebris_benthc_i<- f1(kelpdebris_i,(benthc_i*area_s0/shallowprop),u_benthc*PREF_kelpdebris_benthc,h_benthc*(shallowprop))

model_flux_kelpdebris_benthc<-extract_model_flux(flow_matrix,"kelpdebris","benthc")

#calc_flux_kelpdebris_benthc_i
#model_flux_kelpdebris_benthc

#............................

calc_flux_benths_benthc_o<- f1(benths_o,(benthc_o),u_benthc*PREF_benths_benthc,h_benthc*(1-shallowprop))
calc_flux_benths_benthc_i<- f1(benths_i,(benthc_i),u_benthc*PREF_benths_benthc,h_benthc*(shallowprop))

calc_flux_benths_benthc_w <- calc_flux_benths_benthc_i + calc_flux_benths_benthc_o

model_flux_benths_benthc<-extract_model_flux(flow_matrix,"benths","benthc")

#calc_flux_benths_benthc_w
#model_flux_benths_benthc

#............................

calc_flux_corpse_benthc_o<- f1(corpse_o,(benthc_o),u_benthc*PREF_corpse_benthc,h_benthc*(1-shallowprop))
calc_flux_corpse_benthc_i<- f1(corpse_i,(benthc_i),u_benthc*PREF_corpse_benthc,h_benthc*(shallowprop))

calc_flux_corpse_benthc_w <- calc_flux_corpse_benthc_i + calc_flux_corpse_benthc_o

model_flux_corpse_benthc<-extract_model_flux(flow_matrix,"corpses","benthc")

#calc_flux_corpse_benthc_w
#model_flux_corpse_benthc

#............................
#............................



#Implement testthat checks...

expect_equal(model_flux_phyt_benths,calc_flux_phyt_benths_w , 1e-7)
expect_equal(model_flux_det_benths,calc_flux_det_benths_w , 1e-7)
expect_equal(model_flux_seddetL_benths,calc_flux_seddetL_benths_w , 1e-7)
expect_equal(model_flux_seddetR_benths,calc_flux_seddetR_benths_w , 1e-7)

expect_equal(model_flux_kelp_benthc,calc_flux_kelp_benthc_i , 1e-6)
expect_equal(model_flux_kelpdebris_benthc,calc_flux_kelpdebris_benthc_i , 1e-7)
expect_equal(model_flux_benths_benthc,calc_flux_benths_benthc_w , 1e-7)
expect_equal(model_flux_corpse_benthc,calc_flux_corpse_benthc_w , 1e-7)


})