fishery_model = function(  p, DS="stan", plotresults=TRUE, ... ) {

  if (0) {

    year.assessment=2016
    p = bio.snowcrab::load.environment( year.assessment=year.assessment)
    p$fishery_model = list()
    p$fishery_model$outdir = file.path(project.datadirectory('bio.snowcrab'), "assessments", p$year.assessment )

  }

  if (DS=="stan_surplus_production") {
    return( "
      data {

        int<lower=0> N; // no. years
        int<lower=0> U; // no. regions
        int<lower=0> M; // no. years to project
        int ty;
        real er ;
        real eps ;
        vector[U] Ksd;
        vector[U] rsd;
        vector[U] qsd;
        vector[U] Kmu ;
        vector[U] rmu ;
        vector[U] qmu ;
        matrix[N,U] CAT;
        matrix[N,U] IOA;
        matrix[N,U] missing;
        int missing_n[U];
        int missing_ntot;
      }

      transformed data {
        int MN;
        int N1;
        MN = M+N ;
        N1 = N+1;
      }

      parameters {
        vector <lower=eps>[U] K;
        vector <lower=eps,upper=3>[U] r;
        vector <lower=eps,upper=2>[U] q;
        vector <lower=eps,upper=2>[U] qs;
        vector <lower=eps,upper=(1-eps)>[U] bosd;  // observation error
        vector <lower=eps,upper=(1-eps)>[U] bpsd;  // process error
        vector <lower=eps,upper=(1-eps)>[U] b0;
        vector <lower=eps>[missing_ntot] IOAmissing;
        matrix <lower=eps>[M+N,U] bm;
      }

      transformed parameters {
        matrix[N,U] Y;  // index of abundance
        matrix[N,U] Ymu;  // collator used to force positive values for lognormal
        matrix[MN,U] bmmu; // collator used to force positive values for lognormal
        matrix[MN,U] rem;  // observed catch

        // copy parameters to a new variable (Y) with imputed missing values
        {
          int ii;
          ii = 0;
          for (j in 1:U) {
            for (i in 1:N) {
              Y[i,j] = IOA[i,j];
              if ( missing[i,j] == 1 ) {
                ii = ii+1;
                Y[i,j] = IOAmissing[ii];
              }
            }
          }
        }

        // -------------------
        // removals (catch) observation model, standardized to K (assuming no errors in observation of catch!)
        for (j in 1:U) {
          rem[1:N,j] =  CAT[1:N,j]/K[j] ;
          rem[(N+1):MN,j] =  er*bm[ N:(MN-1),j] ;  // forecasts
        }

        // -------------------
        // observation model calcs and contraints:
        // Ymu = 'surveyed/observed' residual biomass at time of survey (Bsurveyed)
        // cfanorth(1) and cfasouth(2)
        //   This is slightly complicated because a fall / spring survey correction is required:
        //   B represents the total fishable biomass available in fishing year y
        //     in fall surveys:    Btot(t) = Bsurveyed(t) + removals(t)
        //     in spring surveys:  Btot(t) = Bsurveyed(t) + removals(t-1)
        // spring surveys from 1998 to 2003
        //   this is conceptualized in the following time line:
        //     '|' == start/end of each new fishing year
        //     Sf = Survey in fall
        //     Ss = Survey in spring
        //     |...(t-2)...|.Ss..(t-1)...|...(t=2004)..Sf.|...(t+1).Sf..|...(t+2)..Sf.|...
        // Cfa 4X -- fall/winter fishery
        // assume similar to a spring fishery but no need for separate q's
        //    NOTE: year designation in 4X is for the terminal year: ie. 2001-2002 => 2002
        //    Btot(t) = Bsurveyed(t)+ removals(t-1)

        for (j in 1:2) {
          Ymu[1,j]        = qs[j] * bm[1,j] - rem[1,j] ; // starting year approximation
          Ymu[2:(ty-1),j] = qs[j] * bm[2:(ty-1),j] - rem[1:(ty-2),j] ; //spring surveys
          Ymu[ty,j]       = q[j]  * bm[ty,j] - (rem[(ty-1),j] + rem[ty,j] )/2.0  ; // transition year .. approximation
          Ymu[(ty+1):N,j] = q[j]  * bm[(ty+1):N,j] - rem[(ty+1):N,j] ;   // fall surveys
        }
        {
          int k;
          k=3;
          Ymu[1,k]        = q[k] * bm[1,k]   - rem[1,k] ; // starting year approximation
          Ymu[2:(ty-1),k] = q[k] * bm[2:(ty-1),k] - rem[2:(ty-1),k];
          Ymu[ty:N,k]     = q[k] * bm[ty:N,k] - rem[ty:N,k];
        }

        for (j in 1:U) {
          for (i in 1:N) {
            Ymu[i,j] = K[j] * fmax( Ymu[i,j], eps); // force positive value
          }
        }

        // -------------------
        // process model calcs and constraints
        for (j in 1:U) {
          bmmu[1,j] = b0[j] ; // biomass at first year
          for (i in 2:MN) {
            bmmu[i,j] = bm[i-1,j] * ( 1.0 + r[j]*(1-bm[i-1,j]) ) - rem[i-1,j] ;
          }
        }
        for (j in 1:U) {
          for (i in 1:MN) {
            bmmu[i,j] = fmax(bmmu[i,j], eps);  // force positive value
          }
        }

      }

      model {

        // -------------------
        // priors for parameters
        K ~ normal( Kmu, Ksd )  ;
        r ~ normal( rmu, rsd )  ;
        q ~ normal( qmu, qsd )  ;
        qs ~ normal( qmu, qsd )  ;
        b0 ~ beta( 8, 2 ) ; // starting b prior to first catch event
        bosd ~ cauchy( 0, 0.5 ) ;  // slightly informative .. center of mass between (0,1)
        bpsd ~ cauchy( 0, 0.5 ) ;

        // -------------------
        // biomass observation model
        for (j in 1:U) {
          log(Y[1:N,j]) ~ normal( log(Ymu[1:N,j]), bosd[j] ) ;  // stan thinks Y is being transformed due to attempt to impute missing values .. ignore
        }

        // -------------------
        // biomass process model
        for (j in 1:U) {
          log(bm[1:MN,j]) ~ normal( log(bmmu[1:MN,j]), bpsd[j] ) ;
        }

        // could have used lognormal but this parameterization is 10X faster and more stable
        target += - log(fabs(Y));  // required due to log transf above
        target += - log(fabs(bm));

      }

      generated quantities {
        matrix[MN,U] pd;
        vector[U] MSY;
        vector[U] BMSY;
        vector[U] FMSY;
        matrix[MN,U] B;
        matrix[MN,U] P;
        matrix[MN,U] C;

        matrix[MN,U] F;
        matrix[M,U] TAC;

        // -------------------
        // annual production
         for(j in 1:U) {
           pd[1,j] = bm[2,j]- bm[1,j] + rem[1,j] ; // approximation
           for (i in 2:N ){
             pd[i,j] = (bm[i+1,j]- bm[i-1,j])/2 + rem[i,j] ; // linear interpolation cancels out the bm[i,j] term
           }
           for(i in N1:(MN-1)) {
             pd[i,j] = (bm[i+1,j]- bm[i-1,j])/2 + er * bm[i-1,j] ;  // linear interpolation cancels out the bm[i,j] term
           }
           pd[MN,j] = (bm[MN,j]- bm[(MN-1),j]) + er * bm[(MN-1),j]  ; // approximation
         }

        // -------------------
        // fishing mortality
        // fall fisheries

         for (j in 1:3) {
           for (i in 1:N) {
             F[i,j] =  1.0 - rem[i,j] / bm[i,j]  ;
           }
         }
         // spring fishery
//         {
//           int j;
//           j=3;
//           F[1,j] =  1.0 - rem[1,j] / bm[1,j] ; // approximation
//           for (i in 2:N) {
//             F[i,j] =  1.0 - rem[i-1,j] / bm[i,j]  ;
 //          }
 //        }

         for (j in 1:U) {
           for (i in N1:MN) {
             F[i,j] =  1.0 - er * bm[i-1,j] / bm[i,j]  ;
           }
           for (i in 1:MN) {
             F[i,j] =  -log( fmax( F[i,j], eps) )  ;
           }
         }

        // -------------------
        // parameter estimates for output

        for(j in 1:U) {
           MSY[j]    = r[j]* exp(K[j]) / 4 ; // maximum height of of the latent productivity (yield)
           BMSY[j]   = exp(K[j])/2 ; // biomass at MSY
           FMSY[j]   = 2.0 * MSY[j] / exp(K[j]) ; // fishing mortality at MSY
      //    BX2MSY[j] = 1.0 - step( bm[N1,j]-0.25 ) ; // test if bm >= 1/2 bmY
      //    Bdrop[j]  = 1.0 - step( bm[N1,j]-bm[N,j] ) ; // test if bm(t) >= bm(t-1)
      //    Fcrash[j] = 4.0 * MSY[j] / exp(K[j]) ; // fishing mortality at which the stock will crash
        }

        // recaled estimates
         for(j in 1:U) {
           for(i in 1:MN) {
             B[i,j] = (bm[i,j] - rem[i,j]) * K[j] ;
             P[i,j] = pd[i,j]*K[j] ;
             C[i,j] = rem[i,j]*K[j] ;
           }
           for(i in 1:M) {
             TAC[i,j] = rem[N+i,j]*K[j] ;
           }
         }

      }
    "
    )
  }

  if (DS=="stan_surplus_production_stmv_survey_expanded") {
    return( "
            data {

            int<lower=0> N; // no. years
            int<lower=0> U; // no. regions
            int<lower=0> M; // no. years to project
            int ty;
            real er ;
            real eps ;
            vector[U] Ksd;
            vector[U] rsd;
            vector[U] qsd;
            vector[U] Kmu ;
            vector[U] rmu ;
            vector[U] qmu ;
            matrix[N,U] CAT;
            matrix[N,U] IOA;
            matrix[N,U] IOAG;
            matrix[N,U] missing;
            int missing_n[U];
            int missing_ntot;
            }

            transformed data {
            int MN;
            int N1;
            MN = M+N ;
            N1 = N+1;
            }

            parameters {
            vector <lower=eps>[U] K;
            vector <lower=eps,upper=3>[U] r;
            vector <lower=eps,upper=2>[U] q;
            vector <lower=eps,upper=2>[U] qs;
            vector <lower=eps,upper=2>[U] q1;
            vector <lower=eps,upper=2>[U] qs1;

            vector <lower=eps,upper=(1-eps)>[U] bosd;  // observation error of biomass estimate
            vector <lower=eps,upper=(1-eps)>[U] bossd;  // observation error of catch rate
            vector <lower=eps,upper=(1-eps)>[U] bpsd;  // process error
            vector <lower=eps,upper=(1-eps)>[U] b0;
            vector <lower=eps>[missing_ntot] IOAmissing;
            vector <lower=eps>[missing_ntot] IOAGmissing;
            matrix <lower=eps>[M+N,U] bm;
            }

            transformed parameters {
            matrix[N,U] Y;  // index of abundance stmv
            matrix[N,U] Y2;  // index of abundance geomean
            matrix[N,U] Ymu;  // collator used to force positive values for lognormal
            matrix[MN,U] bmmu; // collator used to force positive values for lognormal
            matrix[MN,U] rem;  // observed catch

            // copy parameters to a new variable (Y) with imputed missing values
            {
            int ii;
            ii = 0;
            for (j in 1:U) {
            for (i in 1:N) {
            Y[i,j] = IOA[i,j];
            if ( missing[i,j] == 1 ) {
            ii = ii+1;
            Y[i,j] = IOAmissing[ii];
            }
            }
            }
            }
            {
            int ii;
            ii = 0;
            for (j in 1:U) {
            for (i in 1:N) {
            Y2[i,j] = IOAG[i,j];
            if ( missing[i,j] == 1 ) {
            ii = ii+1;
            Y2[i,j] = IOAGmissing[ii];
            }
            }
            }
            }

            // -------------------
            // removals (catch) observation model, standardized to K (assuming no errors in observation of catch!)
            for (j in 1:U) {
            rem[1:N,j] =  CAT[1:N,j]/K[j] ;
            rem[(N+1):MN,j] =  er*bm[ N:(MN-1),j] ;  // forecasts
            }

            // -------------------
            // observation model calcs and contraints:
            // Ymu = 'surveyed/observed' residual biomass at time of survey (Bsurveyed)
            // cfanorth(1) and cfasouth(2)
            //   This is slightly complicated because a fall / spring survey correction is required:
            //   B represents the total fishable biomass available in fishing year y
            //     in fall surveys:    Btot(t) = Bsurveyed(t) + removals(t)
            //     in spring surveys:  Btot(t) = Bsurveyed(t) + removals(t-1)
            // spring surveys from 1998 to 2003
            //   this is conceptualized in the following time line:
            //     '|' == start/end of each new fishing year
            //     Sf = Survey in fall
            //     Ss = Survey in spring
            //     |...(t-2)...|.Ss..(t-1)...|...(t=2004)..Sf.|...(t+1).Sf..|...(t+2)..Sf.|...
            // Cfa 4X -- fall/winter fishery
            // assume similar to a spring fishery but no need for separate q's
            //    Btot(t) = Bsurveyed(t)+ removals(t-1)
            //    NOTE: year designation in 4X is for the terminal year: ie. 2001-2002 => 2002

            for (j in 1:2) {
              Ymu[1,j]        = qs[j] * bm[1,j] - rem[1,j] ; // starting year approximation
              Ymu[2:(ty-1),j] = qs[j] * bm[2:(ty-1),j] - rem[1:(ty-2),j] ; //spring surveys
              Ymu[ty,j]       = q[j]  * bm[ty,j] - (rem[(ty-1),j] + rem[ty,j] )/2.0  ; // transition year .. approximation
              Ymu[(ty+1):N,j] = q[j]  * bm[(ty+1):N,j] - rem[(ty+1):N,j] ;   // fall surveys
            }
            {
              int k;
              k=3;
              Ymu[1,k]        = qs[k] * bm[1,k]   - rem[1,k] ; // starting year approximation
              Ymu[2:(ty-1),k] = qs[k] * bm[2:(ty-1),k] - rem[1:(ty-2),k];
              Ymu[ty:N,k]     = q[k]  * bm[ty:N,k] - rem[(ty-1):(N-1),k];
            }

            for (j in 1:2) {
              Ymu[1,j]        = qs1[j] * bm[1,j] - rem[1,j] ; // starting year approximation
              Ymu[2:(ty-1),j] = qs1[j] * bm[2:(ty-1),j] - rem[1:(ty-2),j] ; //spring surveys
              Ymu[ty,j]       = q1[j]  * bm[ty,j] - (rem[(ty-1),j] + rem[ty,j] )/2.0  ; // transition year .. approximation
              Ymu[(ty+1):N,j] = q1[j]  * bm[(ty+1):N,j] - rem[(ty+1):N,j] ;   // fall surveys
            }
            {
              int k;
              k=3;
              Ymu[1,k]        = qs1[k] * bm[1,k]   - rem[1,k] ; // starting year approximation
              Ymu[2:(ty-1),k] = qs1[k] * bm[2:(ty-1),k] - rem[1:(ty-2),k];
              Ymu[ty:N,k]     = q1[k]  * bm[ty:N,k] - rem[(ty-1):(N-1),k];
            }

            for (j in 1:U) {
            for (i in 1:N) {
            Ymu[i,j] = K[j] * fmax( Ymu[i,j], eps); // force positive value
            }
            }

            // -------------------
            // process model calcs and constraints
            for (j in 1:U) {
            bmmu[1,j] = b0[j] ; // biomass at first year
            for (i in 2:MN) {
            bmmu[i,j] = bm[i-1,j] * ( 1.0 + r[j]*(1-bm[i-1,j]) ) - rem[i-1,j] ;
            }
            }
            for (j in 1:U) {
            for (i in 1:MN) {
            bmmu[i,j] = fmax(bmmu[i,j], eps);  // force positive value
            }
            }

            }

            model {

            // -------------------
            // priors for parameters
            K ~ normal( Kmu, Ksd )  ;
            r ~ normal( rmu, rsd )  ;
            q ~ normal( qmu, qsd )  ;
            q1 ~ normal( qmu, qsd )  ;
            qs ~ normal( qmu, qsd )  ;
            qs1 ~ normal( qmu, qsd )  ;
            b0 ~ beta( 8, 2 ) ; // starting b prior to first catch event
            bosd ~ cauchy( 0, 0.5 ) ;  // slightly informative .. center of mass between (0,1)
            bpsd ~ cauchy( 0, 0.5 ) ;
            bossd ~ cauchy( 0, 0.5 );

            // -------------------
            // biomass observation model
            for (j in 1:U) {
            log(Y[1:N,j]) ~ normal( log(Ymu[1:N,j]), bosd[j] ) ;  // stan thinks Y is being transformed due to attempt to impute missing values .. ignore
            log(Y2[1:N,j]) ~ normal( log(Ymu[1:N,j]), bossd[j] ) ;  // stan thinks Y is being transformed due to attempt to impute missing values .. ignore
            }

            // -------------------
            // biomass process model
            for (j in 1:U) {
            log(bm[1:MN,j]) ~ normal( log(bmmu[1:MN,j]), bpsd[j] ) ;
            }

            // could have used lognormal but this parameterization is 10X faster and more stable
            target += - log(fabs(Y));  // required due to log transf above
            target += - log(fabs(bm));
            target += - log(fabs(Y2));  // required due to log transf above
            }

            generated quantities {
            matrix[MN,U] pd;
            vector[U] MSY;
            vector[U] BMSY;
            vector[U] FMSY;
            matrix[MN,U] B;
            matrix[MN,U] P;
            matrix[MN,U] C;

            matrix[MN,U] F;
            matrix[M,U] TAC;

            // -------------------
            // annual production
            for(j in 1:U) {
            pd[1,j] = bm[2,j]- bm[1,j] + rem[1,j] ; // approximation
            for (i in 2:N ){
            pd[i,j] = (bm[i+1,j]- bm[i-1,j])/2 + rem[i,j] ; // linear interpolation cancels out the bm[i,j] term
            }
            for(i in N1:(MN-1)) {
            pd[i,j] = (bm[i+1,j]- bm[i-1,j])/2 + er * bm[i-1,j] ;  // linear interpolation cancels out the bm[i,j] term
            }
            pd[MN,j] = (bm[MN,j]- bm[(MN-1),j]) + er * bm[(MN-1),j]  ; // approximation
            }

            // -------------------
            // fishing mortality
            // force first year estimate assuming catches in year 0 to be similar to year 1

            for (j in 1:U) {
            F[1,j] =  1.0 - rem[1,j] / bm[1,j] ;
            for (i in 2:MN) {
            F[i,j] =  1.0 - er * bm[i-1,j] / bm[i,j]  ;
            }
            }
            for (j in 1:U) {
            for (i in 1:MN) {
            F[i,j] =  -log( fmax( F[i,j], eps) )  ;
            }
            }

            // -------------------
            // parameter estimates for output

            for(j in 1:U) {
            MSY[j]    = r[j]* exp(K[j]) / 4 ; // maximum height of of the latent productivity (yield)
            BMSY[j]   = exp(K[j])/2 ; // biomass at MSY
            FMSY[j]   = 2.0 * MSY[j] / exp(K[j]) ; // fishing mortality at MSY
            //    BX2MSY[j] = 1.0 - step( bm[N1,j]-0.25 ) ; // test if bm >= 1/2 bmY
            //    Bdrop[j]  = 1.0 - step( bm[N1,j]-bm[N,j] ) ; // test if bm(t) >= bm(t-1)
            //    Fcrash[j] = 4.0 * MSY[j] / exp(K[j]) ; // fishing mortality at which the stock will crash
            }

            // recaled estimates
            for(j in 1:U) {
            for(i in 1:MN) {
            B[i,j] = (bm[i,j] - rem[i,j]) * K[j] ;
            P[i,j] = pd[i,j]*K[j] ;
            C[i,j] = rem[i,j]*K[j] ;
            }
            for(i in 1:M) {
            TAC[i,j] = rem[N+i,j]*K[j] ;
            }
            }

            }
            "
  )
}

  if (DS=="stan_data" ) {
    sb = snowcrab_tsdata(p=p, assessment_years=2000:p$year.assessment)
    return(sb)
  }

  if (DS=="stan" ) {

    library(rstan)
    rstan_options(auto_write = TRUE)
    options(mc.cores = parallel::detectCores())

    message( "Output location is: ", p$fishery_model$outdir )

    dir.create( p$fishery_model$outdir, recursive=T, showWarnings=F )

    f = sampling( p$fishery_model$stancode_compiled, data=p$fishery_model$standata, ... )
          # warmup = 200,          # number of warmup iterations per chain
          # control = list(adapt_delta = 0.9),
          # # refresh = 500,          # show progress every 'refresh' iterations
          # iter = 1000,            # total number of iterations per chain
          # chains = 5,             # number of Markov chains
          # cores = 5              # number of cores (using 2 just for the vignette)

    res = list( mcmc=extract(f), p=p)
    save(res, file=p$fishery_model$fnres, compress=T)
    return(res)

      if (0) {

          plot(f)
          print(f)
          traceplot(f)

          # extract samples
          e = rstan::extract(f, permuted = TRUE) # return a list of arrays
          m2 = as.array(f)

          traceplot(f, pars=c("K"))
          pred=rstan::extract(f)

          est=colMeans(pred)

          prob=apply(pred,2,function(x) I(length(x[x>0.10])/length(x) > 0.8)*1)
      }

  }

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

  if (DS=="jags") {

    warning( "Jags method is deprecated. Use stan.")

    require(rjags)
    rjags::load.module("dic")
    rjags::load.module("glm")

    if (!exists("fishery_model", p)) p$fishery_model = list()
    if (!exists("n.adapt", p$fishery_model)) p$fishery_model$n.adapt  = 5000  # burn-in  .. 4000 is enough for the full model
    if (!exists("n.iter ", p$fishery_model)) p$fishery_model$n.iter   = 10000  #  n.iter = 30000,
    if (!exists("n.chains", p$fishery_model)) p$fishery_model$n.chains  = 8  #  n.chains = 8 ,
    if (!exists("n.thin", p$fishery_model)) p$fishery_model$n.thin  = 100  # high autocorrelations

    n.iter.total = p$fishery_model$n.iter * p$fishery_model$n.thin

    sb = snowcrab_tsdata( p=p, assessment_years=p$assessment_years )

    sb$tomonitor = c( "r", "K", "q", "qs", "rmu", "rsd", "b","bpsd", "bosd","b0", "b0sd", "rem", "remsd", "remmu","REM", "MSY", "BMSY", "FMSY", "Fcrash", "Bdrop", "BX2MSY", "F", "TAC",
      "C", "P", "B" )

    sb$jagsmodelname = "biomassdynamic_nonhyper_2016.bugs"
    sb$jagsmodel =
    "
model {

  # -------------------
  # define some marginally informative variance priors using CV's (coefficients of variation) as a simple approach
  # uniform distribution seems most stable .. too uninformative?
  # NOTE: eps = a small number non-zero number (essentially equivalent to zero but used to prevent infinity values)
  # uninformative CV's associated with process (bp.) and observation (bo.) errors

  # NOTE for lognormals: CV = sqrt(exp( SD ^2) - 1)  and CV ~ SD where SD ~ < 0.5
  # of SD = sqrt(log(1+CV^2)) and therefore, in terms of precision:
  # TAU = 1/SD^2 = 1/log(1+CV^2)

  for (j in 1:U) {
    r[j] ~ dnorm( rmu[j], pow( rsd[j], -2 ) )
  }

  for (j in 1:U) {
    #qmu[j]  ~ dunif( qmin, qmax )
    #qsd[j]  ~ dunif( qmu[j] * cvnormalmin, qmu[j] *cvnormalmax )  # catchability coefficient (normal scale)
    q[j] ~ dnorm( qmu[j], pow( qsd[j], -2 ) )  T(qmin, qmax)
    #q[j] ~ dunif( qmin[j] , qmax[j] )
  }

  for (j in 1:U) {
    K[j] ~ dlnorm( Kmu[j], pow( Ksd[j], -1 )) # T(Kmin[j], Kmax[j] )
  }

  # -------------------
  # removals (catch) observation model, standardized to K (assuming no errors in observation of catch!)
    for (j in 1:U) {
      for (i in 1:N){
        rem[i,j] <- CAT[i,j]/K[j]
      }
    }

  # -------------------
  # biomass observation model
  #   This is slightly complicated because a fall / spring survey correction is required:
  #   B represents the total fishable biomass available in fishing year y
  #     in fall surveys:    Btot(t) = Bsurveyed(t) + removals(t)
  #     in spring surveys:  Btot(t) = Bsurveyed(t) + removals(t-1)
  #   this is conceptualized in the following time line:
  #     '|' == start/end of each new fishing year
  #     Sf = Survey in fall
  #     Ss = Survey in spring
  #     |...(t-2)...|.Ss..(t-1)...|...(t=2004)..Sf.|...(t+1).Sf..|...(t+2)..Sf.|...

    for (j in 1:(U)) {
      #botau[j] ~ dunif( pow( log( 1 + pow( cvlognormalmax, 2) ), -1 ), pow( log( 1 + pow( cvlognormalmin, 2) ), -1 ) )  # min/max inverted because it is an inverse scale
      #bosd[j] ~ dunif( bomin[j], bomax[j] )
      bosd[j] ~ dlnorm(bomup[j],pow(bosdp[j],-1))
      botau[j]  <- pow( bosd[j], -2 )
    }

    for (j in 1:(U-1)) {
      # spring surveys from 1998 to 2003
      IOA[1,j] ~ dlnorm( log( max( q[j] * K[j] * (bm[1,j] - rem[1,j]) , eps)), botau[j] )  # approximation
      for (i in 2:(ty-1)) {
        IOA[i,j] ~ dlnorm( log( max( q[j] * K[j] * (bm[i,j]- rem[(i-1),j]), eps)), botau[j] )  ;
      }
      # transition year
      IOA[ty,j] ~ dlnorm( log( max( q[j] * K[j] * (bm[ty,j] - (rem[(ty-1),j] + rem[ty,j] )/2 ), eps)), botau[j] ) ;  # approximation
      # fall surveys
      for (i in (ty+1):N) {
        IOA[i,j] ~ dlnorm( log( max( q[j] * K[j] * (bm[i,j] - rem[i,j]), eps)), botau[j] ) ;
      }
    }

    # Cfa 4X -- fall/winter fishery
    # assume similar to a spring fishery but no need for separate q's
    #    Btot(t) = Bsurveyed(t)+ removals(t-1)
    #    NOTE: year designation in 4X is for the terminal year: ie. 2001-2002 => 2002

    IOA[1,cfa4x] ~ dlnorm( log( max( q[cfa4x] * K[cfa4x] * (bm[1,cfa4x] - rem[1,cfa4x]), eps)), botau[cfa4x] ) ;  # approximation
    for (i in 2:N) {
      IOA[i,cfa4x] ~ dlnorm( log( max( q[cfa4x] * K[cfa4x] * (bm[i,cfa4x]- rem[(i-1),cfa4x]), eps)), botau[cfa4x] ) ;
    }

  # -------------------
  # biomass process model

    for (j in 1:U) {
      #bptau[j] ~ dunif( pow( log( 1 + pow( cvlognormalmax, 2) ), -1 ), pow( log( 1 + pow( cvlognormalmin, 2) ), -1 ) )
      bpsd[j] ~ dunif( bpmin[j], bpmax[j] )
      bptau[j]  <- pow( bpsd[j], -2 )
    }

    for(j in 1:U) {
      b0[j] ~ dunif( b0min[j], b0max[j] ) # starting b prior to first catch event
      bm[1,j] ~ dlnorm( log( max( b0[j], eps)), bptau[j] ) T(bmin, bmax ) ;  # biomass at first year
      for(i in 2:(N+M)) {
        bm[i,j] ~ dlnorm( log( max(bm[i-1,j]*( 1 + r[j]*(1-bm[i-1,j])) - rem[i-1,j] , eps)), bptau[j] ) T(bmin, bmax) ;
      }

      # forecasts
      for(i in 1:M) {
        rem[N+i,j] <- er*bm[N+i-1,j]
      }
    }

  # -------------------
  # monitoring nodes and parameter estimates for output
    for(j in 1:U) {
      Bdrop[j]  <- 1 - step( bm[N+1,j]-bm[N,j] ) ; # test if bm(t) >= bm(t-1)
      BX2MSY[j] <- 1 - step( bm[N+1,j]-0.25 ) ; # test if bm >= 1/2 bmY
      MSY[j]    <- r[j]* exp(K[j]) / 4  # maximum height of of the latent productivity (yield)
      BMSY[j]   <- exp(K[j])/2  # biomass at MSY
      FMSY[j]   <- 2 * MSY[j] / exp(K[j]) # fishing mortality at MSY
      Fcrash[j] <- 4 * MSY[j] / exp(K[j]) # fishing mortality at which the stock will crash
    }

    # -------------------
    # fishing mortality
    # force first year estimate assuming catches in year 0 to be similar to year 1
    for(j in 1:U) {
      for(i in 1:N) {
        F[i,j] <- -log( max(1 - rem[i,j] / bm[i,j], eps))
      }
      for(i in (N+1):(N+M)) {
        F[i,j] <- -log( max(1 - er * bm[i-1,j] / bm[i,j], eps))
      }
    }

    # -------------------
    # annual production
    for(j in 1:U) {
      pd[1,j] <- bm[2,j]- bm[1,j] + rem[1,j] # approximation
      for (i in 2:(N) ){
        pd[i,j] <- (bm[i+1,j]- bm[i-1,j])/2 + rem[i,j]  # linear interpolation cancels out the bm[i,j] term
      }
      for(i in (N+1):(N+M-1)) {
        pd[i,j] <- (bm[i+1,j]- bm[i-1,j])/2 + er * bm[i-1,j]   # linear interpolation cancels out the bm[i,j] term
      }
      pd[(N+M),j] <- (bm[(N+M),j]- bm[(N+M-1),j]) + er * bm[(N+M-1),j]   # approximation
    }

    # -------------------
    # recaled estimates

    for(j in 1:U) {
      for(i in 1:(N+M)) {
        B[i,j] <- (bm[i,j] - rem[i,j]) * K[j]
        P[i,j] <- pd[i,j]*K[j]
        C[i,j] <- rem[i,j]*K[j]
      }
      for(i in 1:M) {
        TAC[i,j] <- rem[N+i,j]*K[j]
      }
    }

}

    "

    fn = tempfile()
    cat( sb$jagsmodel, file=fn )

    m = jags.model( file=fn, data=sb, n.chains=p$fishery_model$n.chains, n.adapt=p$fishery_model$n.adapt ) # recruitment + spring/summer q's + all observed CVs

    tomonitor = intersect( variable.names (m), sb$tomonitor )

    y = jags.samples(m, variable.names=tomonitor, n.iter=n.iter.total, thin=p$fishery_model$n.thin) # sample from posterior

    jags2stan = function(x){
      # merge chains together
      print(attr(x, "varname"))
      xdim = dim(x)
      chain = length(xdim)
      iter = chain-1
      oorder = c(iter, chain, 1:(iter-1))
      o = aperm( x,  oorder)
      odim = dim(o)
      dim(o) =c(odim[1]*odim[2], odim[3:length(odim)])
      return( o)
    }
    out = lapply( y, jags2stan )

    res = list( mcmc=out, sb=sb, p=p)
    save(res, file=p$fishery_model$fnres, compress=T)

    return(res)

      if (0) {

        dic.samples(m, n.iter=p$fishery_model$n.iter ) # pDIC

        graphics.off() ; plot.new(); layout( matrix(c(1,2,3), 3, 1 )); par(mar = c(5, 4, 0, 2))
        for( i in 1:3) hist(y$cvr[i,,], "fd")

        # convergence testing -- by 1000 to 1500 convergence observed by Gelman shrink factor diagnostic
        y = jags.samples(m, variable.names=tomonitor, n.iter=6000, thin=1 )

        gelman.plot(y[["r"]])
        gelman.plot(y[["K"]])
        gelman.plot(y[["q"]])  # about 6-8000 runs required to converge
        gelman.plot(y[["rsd"]])
        gelman.plot(y[["Ksd"]])
        gelman.plot(y[["bosd"]])
        gelman.plot(y[["bp.p"]])
        geweke.plot(y[["r"]])

        # update if not yet converged
        #  update(m, n.iter=p$fishery_model$n.iter ) # above seems enough for convergence but a few more to be sure

        # determine autocorrelation thinning
        # y = coda.samples(m, variable.names=c("K", "r", "q"), n.iter=20000, thin=10) # sample from posterior
        # autocorr.plot(y)   # about 10 to 20 required
        # plot(y, ask=T)
        # autocorr(y, lags = c(0, 1, 5, 10, 50), relative=TRUE)

        # final sampling from the posteriors
        #  y = jags.samples(m, variable.names=tomonitor, n.iter=10000, thin=20) # sample from posterior
        y = jags.samples(m, variable.names=tomonitor, n.iter=n.iter.total, thin=p$fishery_model$n.thin) # sample from posterior

        ##
        b1=apply( y$B[,1,,], 1,quantile , probs=c(0.025,0.5,0.975), na.rm=T  )
        f1=apply( y$F[,1,,], 1,quantile , probs=c(0.5), na.rm=T  )
        NENS=data.frame(t(b1),F=f1,row.names=1999:2019)
        NENS$U=1-exp(-NENS$F)
        b2=apply( y$B[,2,,], 1,quantile , probs=c(0.025,0.5,0.975), na.rm=T  )
        f2=apply( y$F[,2,,], 1,quantile , probs=c(0.5), na.rm=T  )
        SENS=data.frame(t(b2),F=f2,row.names=1999:2019)
        SENS$U=1-exp(-SENS$F)

        b3=apply( y$B[,3,,], 1,quantile , probs=c(0.025,0.5,0.975), na.rm=T  )
        f3=apply( y$F[,3,,], 1,quantile , probs=c(0.5), na.rm=T  )
        CFA4X=data.frame(t(b3),F=f3,row.names=1999:2019)
        CFA4X$U=1-exp(-CFA4X$F)

        NENS
        SENS
        CFA4X

        plot.new()
        layout( matrix(c(1,2,3), 3, 1 ))
        par(mar = c(5, 4, 0, 2))

        for( i in 1:3) hist(y$r[i,,], "fd")
        for( i in 1:3) hist(y$qsd[i,,], "fd")
        for( i in 1:3) hist(y$Ksd[i,,], "fd")
        for( i in 1:3) hist(y$b0sd[i,,], "fd")
        for( i in 1:3) hist(y$rsd[i,,], "fd")
        for( i in 1:3) hist(y$b0[i,,], "fd")

      }

  }

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

  if (DS=="LaplacesDemon") {

    warning( "LaplacesDemon method is not yet complete")

    require(LaplacesDemonCpp)

    sb = snowcrab_tsdata( p=p, assessment_years=p$assessment_years )

    debug.region="cfa4x"
    debug.region="cfasouth"
    debug.region="cfanorth"

    # single region test
    K0est =list()
    K0est[["cfanorth"]] = 5
    K0est[["cfasouth"]] = 65
    K0est[["cfa4x"]] = 5

    yrs = as.numeric(rownames( res$B))
    nforecasts = 5

    Data = list(
      Ndata = length(yrs),
      Nforecasts = nforecasts, # no years for projections
      O = res$B[[debug.region]], # observed index of abundance
      log_O0 = mean( log(res$B[[debug.region]]), na.rm=TRUE ),
      Omax = max( res$B[[debug.region]] *1.5 , na.rm=TRUE),
      removals = res$L[[debug.region]] , # removalsches  , assume 20% handling mortality and illegal landings
      log_R0 = log(mean(res$L[[debug.region]], na.rm=TRUE )/K0est[[debug.region]]),
      er = 0.2,  # target exploitation rate
      ty = which(yrs==2004) ,  # index of the transition year (2004) between spring and fall surveys
      log_r0= log(1),
      log_K0= log(K0est[[debug.region]]),
      log_q0= log(mean(res$B[[debug.region]], na.rm=TRUE)/K0est[[debug.region]]),
      S0= 0.6, # normalised
      cv = 0.4,
      smax =1.25,
      eps = 1e-6,
      eps_1 = 1 - 1e-6
    )

    # set up the model
  # set up model for a simple surplus production model
  # to be solved by the Rlibrary: LaplacesDemon (or alternately via penalized Maximum Likelihood)

      # ----------------------------------
      # Identify location and number of missing values -- prediction locations are treated the same way

      # compute a few things here that are constant in the model
      Data$N = Data$Ndata + Data$Nforecasts # no years with data + projections
      Data$q0 = exp( Data$log_q0)
      Data$r0 = exp( Data$log_r0)
      Data$K0 = exp( Data$log_K0)
      Data$R0 = exp(Data$log_R0)
      Data$O0 = exp(Data$log_O0)
      Data$O_range = range( Data$O, na.rm=TRUE)

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

      if (is.null( Data$Missing )) {
        mO = which( !is.finite(Data$O))
        mr = which( !is.finite(Data$removals) )
        Data$Missing = list(
          O = mO,
          nO = length(mO) ,
          removals = mr ,
          nremovals = length( mr ),
          n = length( mO) + length(mr)
        )
      }

      if (is.null( Data$PGF )) {
        # Parameter Generating Function
        Data$PGF = function(Data) {
          r=rnorm(Data$nregions, Data$r0, sd=Data$cv )
          K=rnorm(1, log(Data$K0), sd=Data$cv ) # log scale
          q=rnorm(1, Data$q0, sd=Data$cv )
          S_sd=runif( 1 )
          O_sd=runif( 1 )
          S=rnorm( Data$N, log(Data$S0), sd=Data$cv ) # log scale
          S0=rnorm(1, log(Data$S0), sd=Data$cv ) # log scale
          out = c(r, K, q, S_sd, O_sd, S, S0)
          if (Data$Missing$nO > 0) {
            Omissing = rnorm( Data$Missing$nO, log(Data$Omissing0), sd=Data$cv )
            out = c( out, Omissing )
          }
          if (Data$Missing$nremovals > 0) {
            removalsmissing = rnorm( Data$Missing$nremovals, log(Data$removalsmissing0), sd=Data$cv )
            out = c( out, removalsmissing )
          }
          return( out  )
        }
        Data$PGF = compiler::cmpfun(Data$PGF)
      }

      if (is.null( Data$parm.names )) {
        # paramater names and initial values
        pnames = list(
          r = Data$r0,
          K = Data$K0,
          q = Data$q0,
          S_sd = Data$cv,
          O_sd = Data$cv,
          S = rep( Data$S0, Data$N),
          S0 = Data$S0
        )
        if (Data$Missing$nO > 0) pnames$Omissing = rep( Data$Omissing0, Data$Missing$nO )
        if (Data$Missing$nremovals > 0)  pnames$removalsmissing = rep( Data$removalsmissing0, Data$Missing$nremovals )
        Data$parm.names = as.parm.names( pnames )
      }

      if (is.null( Data$idx )) {
        # index position of parameters
        Data$idx = list(
          r=grep("\\<r\\>", Data$parm.names),
          K=grep("\\<K\\>", Data$parm.names),
          q=grep("\\<q\\>", Data$parm.names),
          S_sd=grep("\\<S_sd\\>", Data$parm.names),
          O_sd=grep("\\<O_sd\\>", Data$parm.names),
          S=grep("\\<S\\>", Data$parm.names),
          S0=grep("\\<S0\\>", Data$parm.names)
        )
        if (Data$Missing$nO > 0) Data$idx$Omissing = grep("\\<Omissing\\>", Data$parm.names)
        if (Data$Missing$nremovals > 0)  Data$idx$removalsmissing = grep("\\<removalsmissing\\>", Data$parm.names)
      }

      if (is.null( Data$mon.names )) {
        Data$mon.names = c("LP", "r", "K", "q" )
        # Data$mon.names = c("LP", "r", "K", "q", paste0("S",1:Data$N), paste0("AR",1:(Data$N-1) ) )
      }

      if (is.null( Data$Model )) {
        Data$Model = function(parm, Data) {

          Spred = Opred = rep(0, Data$N )   # initialize a few storage vectors

          # constraints:
          parm[Data$idx$q] = LaplacesDemonCpp::interval( parm[Data$idx$q], Data$eps, 2 );
          parm[Data$idx$r] = LaplacesDemonCpp::interval( parm[Data$idx$r], Data$eps, 2 );
          parm[Data$idx$K] = LaplacesDemonCpp::interval( parm[Data$idx$K], log(Data$eps), log(Data$K0*2) );
          parm[Data$idx$S0] = LaplacesDemonCpp::interval( parm[Data$idx$S0], log(Data$eps), log(Data$smax) );
          parm[Data$idx$S] = LaplacesDemonCpp::interval( parm[Data$idx$S], log(Data$eps), log(Data$smax) );

          parm[Data$idx$O_sd] = LaplacesDemonCpp::interval( parm[Data$idx$O_sd], Data$eps, 1)
          parm[Data$idx$S_sd] = LaplacesDemonCpp::interval( parm[Data$idx$S_sd], Data$eps, 1)

          # these are SD's on log scale (0,1) is sufficient
          # continue with SD priors as these are now on correct scale

          loglik = c()
          loglik[Data$parm.names] = 0
          loglik[Data$idx$q] = LaplacesDemonCpp::dhalfcauchy( parm[Data$idx$q], Data$cv,  TRUE ) ;
          loglik[Data$idx$r] = dnorm( parm[Data$idx$r], Data$r0, Data$cv, TRUE ) ;
          loglik[Data$idx$K] = dnorm( parm[Data$idx$K], log(Data$K0), Data$cv, TRUE ) ;
          loglik[Data$idx$S0] = dnorm( parm[Data$idx$S0], log(Data$S0), Data$cv, TRUE ) ;
          loglik[Data$idx$O_sd] = LaplacesDemonCpp::dhalfcauchy( parm[Data$idx$O_sd], Data$cv, TRUE );
          loglik[Data$idx$S_sd] = LaplacesDemonCpp::dhalfcauchy( parm[Data$idx$S_sd], Data$cv, TRUE );

          q = parm[Data$idx$q]
          r = parm[Data$idx$r]
          K = exp( parm[Data$idx$K] )
          Spred[1] = exp( parm[Data$idx$S0] );
          S = exp( parm[Data$idx$S] ) ;
          O_sd = parm[Data$idx$O_sd]
          S_sd = parm[Data$idx$S_sd]

          R = Data$removals/K ;
          if (exists( "Missing", Data ) ) {
            if (Data$Missing$nremovals > 0) {
              R[Data$Missing$removals ] = rlnorm( Data$Missing$nremovals,
                parm[Data$idx$removalsmissing], sd=Data$cv )
              R = .Internal(pmax(na.rm=TRUE, R, Data$eps )) ;
              loglik[Data$idx$removalsmissing] = dnorm( parm[Data$idx$removalsmissing],
                log(R[Data$Missing$removals ]), Data$cv )
            }
          }

          AR = 1.0 + r*(1-S[Data$jj]) ;  # autocorelation component
          Spred[ Data$ii ] = S[Data$jj] * AR - R[Data$jj] ;  # simple logistic
          Spred = .Internal(pmax(na.rm=TRUE, Spred, Data$eps )) ;
          loglik[Data$idx$S] = dnorm( parm[Data$idx$S], log(Spred), S_sd, TRUE );

          # Likelihoods for observation model
          i = 1 ;                   Opred[i] = S[i] - R[i] ;
          i = 2:(Data$ty-1);        Opred[i] = S[i] - R[i-1] ;
          i = Data$ty;              Opred[i] = S[i] - (R[i-1] + R[i])/2 ;
          i = (Data$ty+1):Data$N ;  Opred[i] = S[i] - R[i] ;
          Opred = .Internal(pmax( na.rm=TRUE, K*q*Opred, Data$eps ) ) ;
          if (exists( "Missing", Data ) ) {
            if (Data$Missing$nO > 0) {
              Data$O[Data$Missing$O ] = rlnorm( Data$Missing$nO, parm[Data$idx$Omissing], sd=Data$cv )
              Data$O[Data$Missing$O ] = .Internal(pmax(na.rm=TRUE, Data$O[Data$Missing$O ], Data$eps )) ;
              loglik[Data$idx$Omissing] = dnorm( parm[Data$idx$Omissing], log(Data$O[Data$Missing$O ]), Data$cv )
            }
          }
          ll_obs = dnorm( log(Data$O), log(Opred), O_sd, TRUE )

          Smon = Rmon = ER = F = B = C = rep(0, Data$MN )

          Smon[1:Data$N] = S
          Rmon[1:Data$N] = R
          for( i in (Data$N+1):Data$MN ){
            Smon[i] = Smon[i-1] * (1.0 + r*(1.0-Smon[i-1]) ) - Rmon[i-1]
            Rmon[i] = Smon[i-1] * Data$er
          }
          Smon = .Internal(pmax( na.rm=TRUE, Smon, Data$eps ) )
          Rmon = .Internal(pmax( na.rm=TRUE, Rmon, Data$eps ) )

          # monitoring
          ER = Rmon / Smon ;
          B = Smon*K
          C = Rmon*K
          F = -log( 1 - ER) ; # fishing mortality

          LL = sum( ll_obs )  # log likelihood (of the data)
          LP = LL + sum( loglik )  # log posterior
          out = list( LP=LP, Dev=-2*LL, Monitor=c(LP, r, K, q), yhat=S*K, parm=parm )
          return( out  )
        }
        Data$Model.ML  = compiler::cmpfun( function(...) (Data$Model(...)$Dev / 2) )  # i.e. - log likelihood
        Data$Model.PML = compiler::cmpfun( function(...) (- Data$Model(...)$LP) ) #i.e., - log posterior
        Data$Model = compiler::cmpfun(Data$Model) #  byte-compiling for more speed .. use RCPP if you want more speed
      }

      print (Data$Model( parm=Data$PGF(Data), Data=Data ) ) # test to see if return values are sensible

    # 2. maximum likelihood solution
    f.ml = optim( par=sb$PGF(sb), fn=sb$Model.ML, Data=sb, method="BFGS", control=list(maxit=5000, trace=0), hessian=TRUE  )
    names(f.ml$par ) = sb$parm.names
    #print(sqrt( diag( solve(f.ml$hessian) )) ) # assymptotic standard errors
    (f.ml$par)

    # 3. penalized maximum likelihood .. better but still a little unstable depending on algorithm
    f.pml = optim( par=sb$PGF(sb), fn=sb$Model.PML, Data=sb, method="BFGS", control=list(maxit=5000, trace=0), hessian=TRUE )
    names(f.pml$par ) = sb$parm.names
    (f.pml$par)

    #print(sqrt( diag( solve(f.pml$hessian) )) ) # assymptotic standard errors

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=1000, Status=100, Thinning=10) #

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=as.initial.values(f), Iterations=1000, Status=100, Thinning=10) #

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=as.initial.values(f), Iterations=5000, Status=10, Thinning=20, Method="NUTS") #

    Initial.Values <- as.initial.values(f)
    f <- LaplacesDemon(sb$Model, Data=sb, Initial.Values,
         Covar=f$Covar, Iterations=20000, Status=1000, Thinning=1000,
         Algorithm="CHARM", Specs=NULL)

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=as.initial.values(f), Iterations=5000, Status=100, Thinning=25, Covar=f$Covar)

    f = LaplaceApproximation(sb$Model, Data=sb, parm=sb$PGF(sb), Method="Roptim", method="BFGS", Stop.Tolerance=1e-9, Iterations = 10000  )
    f

    Consort(f)
    plot(f, Data=sb)

    PosteriorChecks(f)

    f0 = LaplacesDemon(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=1000, Status=100, Thinning=1)

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="HAR", Iterations=1000  )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="SR1", Iterations=1000  )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="TR", Iterations=10000  )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="BFGS", Iterations=1000  )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="PSO", Iterations=10000  )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f0), Method="SPG", Iterations=10000  )

    # 4. quick solution: acts as "burn-in" .. do a few times in case solution is unstable
    f = LaplaceApproximation(sb$Model, Data=sb, parm=sb$PGF(sb), Iterations=100 )
    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Iterations=1000 )
    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Method="BFGS", Stop.Tolerance=1e-8, Iterations=1000  )

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=5000, Status=10, Thinning=10, Algorithm="NUTS", Covar=f$Covar, Specs=list(A=100, delta=0.6, epsilon=NULL, Lmax=Inf))  # A=burnin, delta=target acceptance rate

    f = LaplacesDemon.hpc(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=10, Status=1, Thinning=1, Algorithm="NUTS", Covar=f$Covar, Specs=list(A=100, delta=0.6, epsilon=NULL, Lmax=Inf))  # A=burnin, delta=target acceptance rate

    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=1000, Status=100, Thinning=1)

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Method="Roptim", Stop.Tolerance=1e-8, Iterations = 5000, method="Nelder-Mead", control=list(maxit=5, reltol=1e-9 ) )
    f

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Method="Roptim", Stop.Tolerance=1e-8, Iterations = 1000, method="L-BFGS-B", control=list(maxit=10, reltol=1e-10 ) )

    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f)  ) # fast spin up of paramters
    f = LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Method="BFGS", Stop.Tolerance=1e-8  )

    # NOTES: NM is slow
    # algorithms = c( "TR", "LM", "CG", "NR", "NM", "SPG", "LBFGS", "BFGS", "PSO", "SR1", "HAR", "DFP", "BHHH", "HJ", "Rprop" ) # available
    # algorithms = c( "CG", "NM", "SPG", "LBFGS", "BFGS", "PSO", "SR1", "HAR", "DFP", "Rprop" ) # reliably working
    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=sb$PGF(sb), Iterations=500, Status=100, Thinning=1)

    algorithms = c( "CG", "LBFGS", "BFGS", "PSO", "SR1", "HAR", "DFP", "Rprop" ) # reliably working
    for (a in algorithms) {
      print(a)
      ft = try( LaplaceApproximation(sb$Model, Data=sb, parm=as.initial.values(f), Method=a, Stop.Tolerance=1e-9, Iterations=5000 ) )
      if (! class(ft) %in% "try-error" ) if (ft$Converged) if( ft$LP.Final > f$LP.Final )  {
        f = ft
        f$Method = a
      }
    }
    str(f)
    plot(f, Data=sb)

    # MCMC ... look at ACF
    f = LaplacesDemon(sb$Model, Data=sb, Initial.Values=as.initial.values(f), Covar=f$Covar,
      Iterations=1000, Status=100, Thinning=1, Algorithm="CHARM" )
    Consort(f)
    plot(f, Data=sb)

     PosteriorChecks(f)
         #caterpillar.plot(f, Parms="beta")
         #plot(f, Data, PDF=FALSE)
         #Pred <- predict(f, Model, Data, CPUs=1)

      #summary(Pred, Discrep="Chi-Square")
         #plot(Pred, Style="Covariates", Data=Data)
         #plot(Pred, Style="Density", Rows=1:9)
         #plot(Pred, Style="Fitted")
         #plot(Pred, Style="Jarque-Bera")
         #plot(Pred, Style="Predictive Quantiles")
         #plot(Pred, Style="Residual Density")
         #plot(Pred, Style="Residuals")
         #Levene.Test(Pred)
         #Importance(f, Model, Data, Discrep="Chi-Square")

    # MCMC: run with appropriate thinning and other options:
    f = LaplacesDemon(sb$Model, Data=sb, as.initial.values(f),
      Covar=NULL, Iterations=10000, Status=1000, Thinning=1000, Algorithm="CHARM", Specs=NULL)

    f = LaplacesDemon(sb$Model, Data=sb, as.initial.values(f),
      Covar=f$Covar , Iterations=50000, Status=10204, Thinning=1000, Algorithm="CHARM", Specs=list(alpha.star=0.44))

    f = LaplacesDemon(sb$Model, Data=sb,
      Initial.Values=as.initial.values(f), Covar=f$Covar, Iterations=10000, Status=1000, Thinning=100)

    f = LaplacesDemon(sb$Model, Data=sb,
      Initial.Values=as.initial.values(f), Covar=f$Covar, Iterations=30000, Status=1000, Thinning=35,
      Algorithm="AMWG", Specs=list(B=NULL, n=1000, Periodicity=35 ) )

    f <- LaplacesDemon(sb$Model, Data=sb,
      Initial.Values=as.initial.values(f), Covar=f$Covar, Iterations=10000, Status=1000, Thinning=105,
      Algorithm="AFSS", Specs=list(A=Inf, B=NULL, m=100, n=0, w=1))

    # medium speed .. increase Iterations til convergence
    f = VariationalBayes(sb$Model, Data=sb,  parm=as.initial.values(f), Iterations=100,  Samples=10, CPUs=5 )
    f = VariationalBayes(sb$Model, Data=sb,  parm=as.initial.values(f), Iterations=5000,  Samples=100, CPUs=5 ,Stop.Tolerance=1e-9)

    # slow
    f = IterativeQuadrature(sb$Model, Data=sb, parm=as.initial.values(f), Iterations=10, Algorithm="AGH",
     Specs=list(N=5, Nmax=7, Packages=NULL, Dyn.libs=NULL) )

  }

  if (DS=="tmb") {

    warning( "TMB method is not yet complete")

    require(aegis)

    sb = snowcrab_tsdata( p=p, assessment_years=p$assessment_years )

    debug.region="cfa4x"
    debug.region="cfanorth"
    debug.region="cfasouth"

    # Data
    data=list(N=sb$Ndata, IOA=sb$O, CAT=sb$removals);
    # Parameters: initial values
    parameters=list(log_sigmap=log(0.2),
                    log_sigmao=log(0.2),
                    log_Q=log(0.1),
                    log_r=log(0.8),
                    log_K=log(70),
                    log_P=rep(log(0.6),sb$Ndata))

    #parameters=list(log_tau=rep(log(0.1),sb$U),
    #                log_sigma=rep(log(0.1),sb$U),
    #                log_Q=rep(log(0.1),sb$U),
    #                log_r=rep(log(0.8),sb$U),
    #                log_K=log(c(6,70,2)),
    #                log_P=matrix(rep(log(0.6),sb$N*sb$U),sb$N,sb$U))
    #

    ############################################################################
    # Compile model cpp file in TMB
    ############################################################################

    tmb.dir = file.path(project.codedirectory('bio.snowcrab'),"inst","tmb")
    setwd(tmb.dir)

    library(TMB);
    compile("biomassdynamic.cpp")
    dyn.load(dynlib("biomassdynamic"))

    ###########################################################################
    # Estimation
    ###########################################################################

    # The objective function
    obj <- MakeADFun(data, parameters,  random="log_P", DLL="biomassdynamic")

    # Optimize the objective function
    opt <- nlminb(obj$par,obj$fn,obj$gr)

    # Report estimates and standard errors
    rep <- sdreport(obj)

    MLE <- list(year=1:data$N,B=rep$value[1:data$N], Bsd=rep$sd[1:data$N],predI=rep$value[1:data$N+data$N], predIsd=rep$sd[1:data$N+data$N], K=rep$value[data$N*2+1], Ksd=rep$sd[data$N*2+1], r=rep$value[data$N*2+2],rsd=rep$sd[data$N*2+2],Q=rep$value[data$N*2+3],Qsd=rep$sd[data$N*2+3],sigma=rep$value[data$N*2+4],sigmasd=rep$sd[data$N*2+4],tau=rep$value[data$N*2+5],tausd=rep$sd[data$N*2+5],nll=rep$value[data$N*2+6],nllsd=rep$sd[data$N*2+6])

    ###########################################################################
    # Results plots
    ###########################################################################
    plot(data$IOA,ylim=c(0,max(MLE$predI+MLE$predIsd)),pch=16,col='red')
    with(MLE,lines(year,predI))
    with(MLE,lines(year,predI+predIsd,lty=2))
    with(MLE,lines(year,predI-predIsd,lty=2))

  }

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

  if (DS=="delay.difference_jags") {

    warning( "This is not yet complete .. will eventually convert to Stan for speed and stability ..")

    require(rjags)
    rjags::load.module("dic")
    rjags::load.module("glm")

    project.library( "bio.models")

    ###  all data follow this sequence: c("cfanorth", "cfasouth", "cfa4x")

    res = snowcrab_tsdata( p=p, assessment_years=p$assessment_years )

    sb = list(
      FB0x = c(0.8, 0.6, 0.1),  # priors of the starting fishable biomass : N,S,4X
      q0x = c(1, 1, 1),  # priors of "catchability"
      K0x = c(4, 50, 1 ),  # mean carrying capacity estimate
      IOA = as.matrix(res$B), # observed index of fishable biomass
      CAT = as.matrix(res$L) , # observed landings
      REC = as.matrix(res$R) , # observed recruitment
      qREC0 = 1, # q correction for recruitment
      sigma = 0.3, # default upper limit in error (CV) of data
      sigmaB = 0.3, # default upper limit in error (CV) of FB data
      cv = 0.5, # ...
      er = 0.2,  # target exploitation rate
      MFB = 0.8, # prior estimate of natural mortality for FB
      MFBsd = 0.8, # prior estimate of SD in natural mortality for FB
      MREC = 0.8, # prior estimate of natural mortality for FB
      MRECsd = 0.8, # prior estimate of SD in natural mortality for FB
      brodycoef = 2,  # proportional increase in weight with each age
      brodysd0 = 0.2,  # proportional increase in weight with each age
      N = nrow( res$B) , # no years with data
      M = 5, # no years for projections
      R = ncol( res$B),  # number of regions
      ty=7,  # index of the transition year (2004) between spring and fall surveys
      cfa4x=3, # index of cfa4x
      eps = 1e-4  # small non-zero number
    )

    # MCMC/Gibbs parameters
    n.adapt = 5000 # burn-in
    n.chains = 3
    n.thin = 100
    n.iter = 10000

    if (modelrun == "simple" ) {
      ## model 1 --- simple delay difference with observation and process error
      m = jags.model( file=fishery.model.jags ( DS="delay.difference" ), data=sb, n.chains=n.chains, n.adapt=n.adapt )
      coef(m)
      tomonitor = c("FB","K", "REC", "Znat", "Ztot", "qbiomass", "qREC", "Catch", "Cr" )
      dic.samples(m, n.iter=n.iter ) # pDIC
      fnres = file.path( project.datadirectory("bio.snowcrab"), "output", "delaydifference.mcmc.simple.rdata" )

    }

    if (modelrun == "simple.illegal" ) {
      ## model 2 --- simple delay difference with observation and process error and illegal landings
      m = jags.model( file=fishery.model.jags ( DS="delay.difference.illegal" ), data=sb, n.chains=n.chains, n.adapt=n.adapt )
      coef(m)
      tomonitor =  c("FB","K", "REC", "Znat", "Ztot", "qbiomass", "qREC", "Catch", "Cr" )
      dic.samples(m, n.iter=n.iter ) # pDIC
      fnres = file.path( project.datadirectory("bio.snowcrab"), "output", "delaydifference.mcmc.simple.illegal.rdata" )

    }

    tomonitor = intersect( variable.names (m), tomonitor )

    # convergence testing -- by 1000 to 1500 convergence observed by Gelman shrink factor diagnostic
    convergence.test = F
    if (convergence.test) {
      y = jags.samples(m, variable.names=tomonitor, n.iter=10000, thin=10)
      gelman.plot(y[["Ztot"]])
      gelman.plot(y[["K"]])
      gelman.plot(y[["qbiomass"]])
      gelman.plot(y[["qREC"]])
      gelman.plot(y[["sdK"]])
      gelman.plot(y[["sdo"]])
      gelman.plot(y[["sdp"]])
      geweke.plot(y[["r"]])
    }

    # autocorrelation thinning
      y = coda.samples(m, variable.names=c("K", "r", "q"), n.iter=10000, thin=10) # sample from posterior
      autocorr.plot(y)
      # plot(y, ask=T)
      # autocorr(y, lags = c(0, 1, 5, 10, 50), relative=TRUE)

    # update if not yet converged
      update(m, n.iter=n.iter ) # above seems enough for convergence but a few more to be sure

    # final sampling from the posteriors
      n.iter.final = n.iter * n.thin
      # n.iter.final = n.iter
      y = jags.samples(m, variable.names=tomonitor, n.iter=n.iter.final, thin=n.thin) # sample from posterior

    # save(y, file=fnres, compress=T)
    # load( fnres )

    # Figures
      dir.output = file.path( dirname(p$ofname), "figures", "bugs")
      dir.create( dir.output, recursive=T, showWarnings=F )

      # frequency density of key parameters
      figure.bugs( "K", y=y, fn=file.path(dir.output, "K.density.png" ) )
      figure.bugs( "r", y=y, fn=file.path(dir.output, "r.density.png" ) )
      figure.bugs( "q", y=y, fn=file.path(dir.output, "qdensity.png" ) )
      figure.bugs( "BMSY", y=y, fn=file.path(dir.output, "BMSY.density.png" ) )

      # timeseries
      figure.bugs( type="timeseries", var="biomass", y=y, fn=file.path(dir.output, "biomass.timeseries.png" ) )
      figure.bugs( type="timeseries", var="fishingmortality", y=y, fn=file.path(dir.output, "fishingmortality.timeseries.png" ) )

      # Harvest control rules
      figure.bugs( type="hcr", var="default", y=y, fn=file.path(dir.output, "hcr.default.png" ) )
      figure.bugs( type="hcr", var="simple", y=y, fn=file.path(dir.output, "hcr.simple.png" ) )

      # diagnostics
      figure.bugs( type="diagnostics.production", y=y, fn=file.path(dir.output, "diagnostic.production.png" ) )
      figure.bugs( type="diagnostics....", y=y, fn=file.path(dir.output, "diagnostic. ... .png" ) )

      # densities of biomass estimates for the year.assessment
        for (i in 1:3) plot(density(y$B[ndata,i,,] ), main="")
        qs = apply( y$B[ndata,,,], 1, quantile, probs=c(0.025, 0.5, 0.975) )
        qs

        # densities of biomass estimates for the previous year
        for (i in 1:3) plot(density(y$B[ndata-1,i,,] ), main="")
        qs = apply( y$B[ndata-1,,,], 1, quantile, probs=c(0.025, 0.5, 0.975) )
        qs

        # densities of F in assessment year
        for (i in 1:3) plot(density( y$F[ndata,i,,] ), xlim=c(0.05, 0.5), main="")
        qs = apply( y$F[ndata,,,], 1, quantile, probs=c(0.025, 0.5, 0.975) )
        qs

        # densities of F in previous year
        for (i in 1:3) plot(density( y$F[ndata-1,i,,] ), main="")
        qs = apply( y$F[ndata-1,,,], 1, quantile, probs=c(0.025, 0.5, 0.975) )
        qs

        # F for table ---
        summary(y$F, median)

    # B timeseries with error
    graphics.off()
    layout( matrix(c(1,2,3), 3, 1 ))
    par(mar = c(5, 4, 0, 2))

    vv = "B"
    Xm = jags.extract( y, vv, mean )
    X = y[[vv]]
    nR = dim(X)[2]
    for (r in 1:nR) {
      nn = create.histograms.yearly( X[,r,,] )
      nn = nn[ 1:(nrow(nn)-1) ,]  # truncate larges and smallest data points as they are not linear increments
      nnr = as.numeric(rownames(nn) )
      if (r==2) nn = nn[ which( nnr < 100 ) ,]
      if (r==3) nn = nn[ which( nnr < 2 ) ,]
      colnames(nn) = yrs
      plot.histograms.temporal( nn, overlaydata=Xm[,r], xlab="Year", ylab="Biomass; kt", barscale=.9, barcol="gray" )
    }

    # F timeseries with error
    graphics.off()
    layout( matrix(c(1,2,3), 3, 1 ))
    par(mar = c(5, 4, 0, 2))

    vv = "F"
    Xm = jags.extract( y, vv, mean )
    X = y[[vv]]
    X[ X>1] = 1
    X = X[ 1:length(yrs0), ,, ]

    nR = dim(X)[2]
    for (r in 1:nR) {
      nn = create.histograms.yearly( X[,r,,] )
      nn = nn[ 2:(nrow(nn)-1) ,]  # truncate larges and smallest data points as they are not linear increments
      uu = scale( nn, center=FALSE, scale=colSums(nn) )
      colnames(nn) = yrs0
      plot.histograms.temporal( nn, overlaydata=Xm[1:length(yrs0),r], xlab="Year", ylab="Fishing mortality", barscale=0.9, barcol="gray" )
    }

  }

}


source("./ETL/CountrySources/util.r")

##########
# Reads and normalizes data from the Spanish government's official data.
# Provides diff columns that are grouped by community
# Input File format:
# Columns [CCA Codigo ISO, Fecha, Casos, Hospitalizados, UCI, Fallecidos]
# Final line is text explaining the use of the data
# Dates are converted from strings to dates
# Parameters
#   csv_file_name - Full path of the file to read using read.csv
# Output
#   cv read and normalized to translated names
#   [region_code, date, total_cases, daily_cases, total_hospitalized, daily_hospitalized, total_icu, daily_icu, total_deaths, daily_deaths, total_recovered, daily_recovered]
##########
ReadSpainCommunityDataFromCSV <- function(csv_file_name) {
    cv <- read.csv(csv_file_name, check.names=FALSE)
    cv <- head(cv, -3) # Remove last row with explanation text
    cv[is.na(cv)] <- 0
    translated_colnames <- c('region_code', 'date', 'total_cases', 'total_hospitalized', 'total_icu', 'total_deaths', 'total_recovered')
    colnames(cv) <- translated_colnames
    cv$date <- as.Date(cv[["date"]], format = "%d/%m/%Y")
    #cv$country_code <- 'ES'
    #cv$country_name <- "Spain"
    cv$total_active <- (cv$total_cases - cv$total_recovered - cv$total_deaths)
    str(cv$total_active)

    return(cv)
}

GenerateDailyDiffs <- function(infection_data, dimension_name) {
    infection_data$daily_cases <- ave(infection_data$total_cases, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))
    infection_data$daily_hospitalized <- ave(infection_data$total_hospitalized, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))
    infection_data$daily_icu <- ave(infection_data$total_icu, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))
    infection_data$daily_deaths <- ave(infection_data$total_deaths, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))
    infection_data$daily_recovered <- ave(infection_data$total_recovered, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))
    infection_data$daily_active <- ave(infection_data$total_active, infection_data[[dimension_name]], FUN = function(x) c(NA, diff(x)))

    return(infection_data)
}


### Jinliang Yang
### Sep 13th, 2015

QPCR <- function(doplot=FALSE){
    qpcr <- read.csv("data/qPCR_results_validation.csv")
    qpcr <- subset(qpcr, sample != "cbf")
    #qpcr$SampleName <- toupper(qpcr$SampleName)

    control <- subset(qpcr, Assay == "GAPDH")
    assay <- subset(qpcr, Assay != "GAPDH")

    ex <- merge(assay, control[, 2:3], by="SampleName")
    ex$exp <- 2^( ex$CqMean.y - ex$CqMean.x)

    ex$Assay <- as.character(ex$Assay)
    genes <-unique(ex$Assay)

    ####
    ob <- load("~/Documents/Github/BDproj/cache/count.RData")

    #countDF <- read.table("./results/countDF")
    targets <- read.csv("~/Documents/Github/BDproj/data/target.csv")
    tem <- as.data.frame(rpkm[genes, ])
    names(tem) <- targets$SampleName

    out <- data.frame()
    for(i in 1:10){
        sub1 <- subset(ex, Assay == genes[i])
        sub1$method <- "qpcr"

        sub2 <- tem[genes[i], ]
        sub2 <- as.data.frame(t(sub2))
        sub2$sampleid <- row.names(sub2)
        sub2$sampleid <- gsub("CBF3_sample1", "CBF_A", sub2$sampleid)
        sub2$sampleid <- gsub("CBF3_sample2", "CBF_B", sub2$sampleid)
        sub2$sampleid <- gsub("CBF3_sample3", "CBF_C", sub2$sampleid)
        sub2$sampleid <- gsub("CBF3_4C_sample1", "CBF_A_4", sub2$sampleid)
        sub2$sampleid <- gsub("CBF3_4C_sample2", "CBF_B_4", sub2$sampleid)
        sub2$sampleid <- gsub("CBF3_4C_sample3", "CBF_C_4", sub2$sampleid)
        sub2$sampleid <- gsub("WT_sample1", "BD21_A", sub2$sampleid)
        sub2$sampleid <- gsub("WT_sample2", "BD21_B", sub2$sampleid)
        sub2$sampleid <- gsub("WT_sample3", "BD21_C", sub2$sampleid)
        sub2$sampleid <- gsub("WT_4C_sample1", "BD21_A_4", sub2$sampleid)
        sub2$sampleid <- gsub("WT_4C_sample2", "BD21_B_4", sub2$sampleid)
        sub2$sampleid <- gsub("WT_4C_sample3", "BD21_C_4", sub2$sampleid)
        sub2 <- subset(sub2, sampleid %in% sub1$SampleName)

        c1 <- cbind(subset(sub1, temp==4)$exp, subset(sub1, temp==23)$exp)

        sub2$temp <- 23
        sub2$temp <- gsub(".*A_|.*B_|.*C_", "",  sub2$sampleid)
        sub2$temp <- gsub(".*A|.*B|.*C", "23",  sub2$temp)
        names(sub2)[1] <- "exp"
        sub2$method <- "rnaseq"

        temp <- merge(sub2, sub1[, c("SampleName", "Assay", "Category", "exp")], by.x="sampleid", by.y="SampleName")
        c2 <- cbind(subset(sub2, temp==4)$exp, subset(sub2, temp==23)$exp)

        out <- rbind(out, temp)
        if(doplot){
            par(mfrow=c(2, 5))
            barplot(c1, beside=TRUE, main=genes[i])
            barplot(c2, beside=TRUE, main=genes[i])
        }

    }
    return(out)

}

######
res <- QPCR(doplot=FALSE)
write.table(res, "data/qpcr_rnaseq_cv.csv", sep=",", row.names=FALSE, quote=FALSE)

cor.test(subset(res, temp==4)$exp.x, subset(res, temp==4)$exp.y)
cor.test(subset(res, temp==23)$exp.x, subset(res, temp==23)$exp.y)

cor.test(res$exp.x, res$exp.y)


install.packages("VennDiagram",
lib = "./libraries",
repos = 'http://cran.us.r-project.org')

# Load library
library(VennDiagram, lib.loc =  "./libraries")

# Generate  sets
setwd("./DEA")
setB_NR <- read.table(file = "filter_3NR_270_B_vs_NR_10_B.csv", sep = ",", header = T)
setB0_NR <- read.table(file = "filter_3NR_270_B0_vs_NR_10_B0.csv", sep = ",", header = T)
setB_R <- read.table(file = "filter_3R_270_B_vs_R_10_B.csv", sep = ",", header = T)
setB0_R <- read.table(file = "filter_3R_270_B0_vs_R_10_B0.csv", sep = ",", header = T)
setM_R <- read.table(file = "filter_3R_270_M_vs_R_10_M.csv", sep = ",", header = T)
setM_NR <- read.table(file = "filter_3NR_270_M_vs_NR_10_M.csv", sep = ",", header = T)
setP_NR <- read.table(file = "filter_3NR_270_P_vs_NR_10_P.csv", sep = ",", header = T)
setP_R <- read.table(file = "filter_3R_270_P_vs_R_10_P.csv", sep = ",", header = T)
# get column of with names of genes deferentially expressed
set_NR_B <- setB_NR$names
set_NR_B0 <- setB0_NR$names
set_R_B <- setB_R$names
set_R_B0 <- setB0_R$names
set_R_M <- setM_R$names
set_NR_M <- setM_NR$names
set_NR_P <- setP_NR$names
set_R_P <- setP_R$names
# make venn diagrams for interesting comparations , max 4 groups
# venn 1
venn.diagram(filename = "test.venn1", x = list(set_R_B, set_R_B0, set_R_M, set_R_P),
             category.names = c("set_R_P", "set_NR_P", "set_NR_M", "set_R_M"), height = 6000, width = 6000)
# venn 2
venn.diagram(filename = "test.venn2", x = list(set_NR_B, set_NR_B0, set_NR_M, set_R_P),
             category.names = c("set_R_P", "set_NR_P", "set_NR_M", "set_R_M"), height = 6000, width = 6000)
# venn 3
venn.diagram(filename = "test.venn3", x = list(set_NR_B, set_R_B0, set_NR_P, set_R_M),
             category.names = c("set_R_P", "set_NR_P", "set_NR_M", "set_R_M"), height = 6000, width = 6000)


#' Construct (but do not fit) an mbm model
#'
#' @param x Matrix giving a series of covariates (in columns) for all sites (in rows).
#' 			Row names are required. All variables will be included in the model.
#' @param y Square dissimilarity or distance matrix, can be complete or lower triangular
#' 			only. Row and column names are required and must match the site names in the
#' 			rows of \code{x}.
#' @param y_name A name to give to the y variable
#' @param link Link function to use
#' @param likelihood Likelihood function to use
#' @param lengthscale Either missing (in which case all lengthscales will be optimized) or
#' 			a numeric vector of length \code{ncol(x)+1}. If a vector, the first entry
#' 			corresponds to environmental distance, and entries \code{i = 1 + (1:n)}
#' 			correspond to the variable in x[,i]. Values must be \code{NA} or positive
#' 			numbers; if NA, the corresponding lengthscale will be set via optimization,
#' 			otherwise it will be fixed to the value given.
#' @param sparse Should we use the stochastic variational GP.
#' @param force_increasing Boolean; if true, beta diversity will be constrained to
#' 			increase with environmental distance
#' @param sparse_inducing Number of inducing inputs to use for the svgp
#' @param sparse_batch Batchsize to use for the svgp
#' @param sparse_iter Maximum number of optimizer iterations for svgp
#' @return An mbm object
#' @keywords internal
make_mbm <- function(y, x, y_name, link, likelihood, lengthscale, sparse, force_increasing,
	sparse_inducing = 10, sparse_batch = 10, sparse_iter = 10000) {
	if(any(rownames(x) != rownames(y)))
		stop("rownames(x) must equal rownames(y)")

	GPy <- reticulate::import("GPy")

	model <- list()
	class(model) <- c('mbm', class(model))
	attr(model, 'y_name') <- y_name

	## process covariates
	model$x <- x
	x <- scale(x)
	model$x_scaling = function(xx) scale(xx, center = attr(x, "scaled:center"),
		scale = attr(x, "scaled:scale"))
	model$x_unscaling = function(xx) xx*attr(x, "scaled:scale") +
 		attr(x, "scaled:center")
	xDF <- env_dissim(x)

	## process response transformation & mean function
	## if a link function is desired with anything but a vanilla GP, we have to cheat
	## by pre-transforming the y-variable
	model$y <- y
	yDF <- reshape2::melt(y,varnames=c('site1', 'site2'), value.name = y_name)
	dat <- merge(xDF, yDF, all.x = TRUE, by=c('site1', 'site2'))
	if((sparse | force_increasing) & link != 'identity') {
		model <- setup_y_transform(model, link)
		link <- "identity"
	} else {
		model$y_transform <- model$y_rev_transform <- function(y) y
	}

	## add data to obj
	x_cols <- which(!colnames(dat) %in% c(y_name))
	model$response <- model$y_transform(as.matrix(dat[,y_name]))
	covars <- dat[,x_cols]
	names <- grep('site', colnames(covars))
	model$covariates <- as.matrix(covars[,-names])
	model$covar_sites <- covars[,names]

	##
	## SET UP SVGP
	##
	if(sparse) {
		attr(model, "batchsize") <- sparse_batch
		attr(model, "inducing_inputs") <- sparse_inducing
		attr(model, "svgp_maxiter") <- sparse_iter
		likelihood <- "gaussian"
		model$inducing_inputs <- apply(model$covariates, 2,
			function(xx) runif(attr(model, "inducing_inputs"), min(xx), max(xx)))
	}

	##
	## SET UP PYTHON OBJECTS
	##
	model$pyobj <- list()
	model <- set_mbm_link(model, link)
	model$likelihood <- likelihood
	model$lengthscale <- lengthscale

	if(model$likelihood == 'gaussian') {
		model$pyobj$likelihood <- GPy$likelihoods$Gaussian(gp_link = model$pyobj$linkFun)
	} else {
		stop("Non-gaussian likelihoods are not supported")
	}

	if(model$likelihood == 'gaussian' & model$link == 'identity') {
		model$pyobj$inference <- GPy$inference$latent_function_inference$ExactGaussianInference()
		if(sparse) {
			attr(model, 'inference') <- 'svgp'
		} else
			attr(model, 'inference') <- 'exact'
	} else {
		model$pyobj$inference <- GPy$inference$latent_function_inference$Laplace()
		attr(model, 'inference') <- 'laplace'
	}

	model$pyobj$kernel <- setup_mbm_kernel(dim = ncol(model$covariates),
		lengthscale = model$lengthscale, sparse = sparse)

 	model$pyobj$mf <- set_mean_function(ncol(model$covariates), force_increasing)
 	attr(model, "mean_function") <- if(force_increasing) "increasing" else "0"

	return(model)
}

#' Set up link functions for mbm objects
#'
#' This is the only supported way for changing link functions in mbm objects; do not try
#' to do it by hand
#' @param x mbm model object
#' @param link Link function to use
#' @return A copy of the mbm object with the link function set
#' @keywords internal
set_mbm_link <- function(x, link) {
	GPy <- reticulate::import("GPy")
	x$link <- link
	if(link == 'identity') {
		x$pyobj$linkFun <- GPy$likelihoods$link_functions$Identity()
		x$inv_link <- function(y) y
	} else if(link == 'probit') {
		x$pyobj$linkFun <- GPy$likelihoods$link_functions$Probit()
		x$inv_link <- function(y) pnorm(y)
	} else {
		stop(link, 'is an unsupported link function')
	}
	return(x)
}

#' Set up MBM kernel
#' @param dim Kernel dimension (number of variables)
#' @param lengthscale Lengthscale parameter as from [mbm()].
#' 		Either NULL (in which case all lengthscales will be optimized) or
#'		a numeric vector of length \code{ncol(x)+1}. If a vector, the first entry
#' 		corresponds to environmental distance, and entries \code{i = 1 + (1:n)}
#' 		correspond to the variable in x[,i]. Values must be \code{NULL} or positive
#' 		numbers; if NULL, the corresponding lengthscale will be set via optimization,
#' 		otherwise it will be fixed to the value given.
#' @param prior Prior distribution to use; currently ignored
#' @param sparse Logical, should a sparse GP be used?
#' @param which Which parameters to set up, either all, variance params, or lengthscale
#' @keywords internal
setup_mbm_kernel <- function(dim, lengthscale = NULL, prior, sparse,
		which = c('all', 'lengthscale', 'variance')) {

	reticulate::source_python(system.file("python/kernel.py", package="mbm"))
	k <- make_kernel(dim, sparse)
	k <- set_kernel_constraints_py(k, lengthscale, which)
	return(k)
}

#' Set up MBM mean function
#' @param dim Kernel dimension (number of variables)
#' @param useMeanFunction Logical, should the mean function be used?
#' @keywords internal
set_mean_function <- function(dim, useMeanFunction) {
	reticulate::source_python(system.file("python/mf.py", package="mbm"))
	mf <- set_mean_function_py(dim, useMeanFunction)
	return(mf)
}

#' Set y transformations for an MBM object
#' @details Sets up y transformations to use instead of a link function for probit links. When
#' 		the y-data include zeros and ones, an additional step is necessary to squeeze the data
#' 		from [0,1], (0,1], or [0,1) to the open interval (0,1). In the [0,1] case, the smithson
#' 		lemon-squeezer is used: y􏰂' = [y􏰀(N – 1) + 1/2]/N. Otherwise, eps is first added or
#' 		subtracted from all values.
#' @param x an MBM object
#' @param link character, link function to use
#' @param eps Constant to add to avoid infinite values for probit
#' @references Smithson, M. and Verkuilen, J. 2006. A Better Lemon Squeezer? Maximum-Likelihood
#'		Regression With Beta-Distributed Dependent Variables. Psychological Methods 11(1): 54-71.
#' @keywords internal
setup_y_transform <- function(x, link, eps = 0.001) {
	if(link != 'probit')
		stop("Currently only identity or probit links are supported with these options")

	if(min(x$y) == 0 & max(x$y) == 1) {
		# use the smithson transform when we have both 0s and 1s
		n <- length(model$y)
		x$y_transform <- function(p) qnorm((p * (n - 1) + 0.5) / n)
		x$y_rev_transform <- function(q) (pnorm(q) * n - 0.5) / (n-1)
	} else {
		eps <- if(min(x$y) == 0) eps else if(max(x$y == 1)) -eps else 0
		x$y_transform <- function(p) qnorm(p + eps)
		x$y_rev_transform <- function(q) pnorm(q) - eps
	}
	return(x)
}


subroutine baklo(x,y,w,npetc,wddnfl,spatol,match,
		etal,s,eta,beta,var,dof,
		qr,qraux,qpivot,effect,iv,v,iwork,work)
implicit double precision(a-h,o-z)
integer n,p,q,nit,maxit,qrank
integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*)
##integer which(q),dwhich(q),degree(q),nef(q),liv(q),lv(q),nvmax(q)
double precision x(*),y(*),w(*),spatol(*),
	etal(*),s(*),eta(*),beta(*),var(*),dof(*),
	qr(*),qraux(*),v(*),effect(*),work(*)
#work size: 4*n + sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
#          = 9*n + sum( nef(k)*(pj+dj+4)+5+3*pj )

n=npetc(1)
p=npetc(2)
q=npetc(3)
maxit=npetc(5)
qrank=npetc(6)
call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1),
            spatol(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1),
            etal,s,eta,beta,var,spatol(q+1),
            nit,maxit,qr,qraux,qrank,qpivot,effect,
            work(1),work(n+1),work(2*n+1),work(3*n+1),
            iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnfl(7*q+1),
            iwork(1),work(4*n+1))
npetc(4)=nit
npetc(6)=qrank
return
end

subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof,match,nef,
			etal,s,eta,beta,var,tol,nit,maxit,
			qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti,
			iv,liv,lv,v,nvmax,iwork,work)
implicit double precision(a-h,o-z)
integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),nef(q),nit,
		maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork(q)
double precision x(n,p),y(n),w(n),span(q),dof(q),
			etal(n),s(n,q),eta(n),beta(p),var(n,q),tol,
			qr(n,p),qraux(p),v(*),effect(n),work(*)
#work should be sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
double precision z(*),old(*),dwrss,ratio
double precision sqwt(n),sqwti(n)
logical anyzwt
double precision deltaf, normf,onedm7
integer job,info,slv,sliv,iw,j,dj,pj
onedm7=1d-7
job=1101;info=1
if(q==0)maxit=1
ratio=1d0
# fix up sqy's for weighted problems.
anyzwt=.false.
do i=1,n{
	if(w(i)>0d0){
		sqwt(i)=dsqrt(w(i))
		sqwti(i)=1d0/sqwt(i)
	}
	else{
		sqwt(i)=0d0
		sqwti(i)=0d0
		anyzwt=.true.
		}
	}
# if qrank > 0 then qr etc contain the qr decomposition
# else baklo computes it.
if(qrank==0){
	do i=1,n{
		do j=1,p{
			qr(i,j)=x(i,j)*sqwt(i)
			}
		}
	do j=1,p{qpivot(j)=j}
	call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7)
	}
do i=1,n{
	eta(i)=0d0
	for(j=1;j<=q;j=j+1){
		eta(i)=eta(i)+s(i,j)
		}
	}
nit=0
while ((ratio > tol )&(nit < maxit)){
	# first the linear fit
	deltaf=0d0
	nit=nit+1
	do i=1,n{
		z(i)=(y(i)-eta(i))*sqwt(i)
		old(i)=etal(i)
	}
#	call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three)
#job=1101 -- computes fits, effects and beta
	call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta,
		work(1),etal,job,info)

# now unsqrt the fits
#Note: we dont have to fix up the zero weights till the end, since their fits
#are always immaterial to the computation
	do i=1,n{
		etal(i)=etal(i)*sqwti(i)
		}
	# now a single non-linear backfitting loop
	sliv=1
	slv=1
	iw=5*n+1
	for(k=1;k<=q;k=k+1){

		j=which(k)
		dj=dwhich(k)
		pj=pwhich(k)
		do i=1,n{
			old(i)=s(i,k)
			z(i)=y(i)-etal(i)-eta(i)+old(i)
		}
call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k),
		nef(k),nit,dof(k),s(1,k),var(1,k),work(iw),
#	xin,win
	work(iw+pj+1),work(iw+nef(k)*dj+pj+1),
#	sqwin,sqwini,
	work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj+2)+pj+2),
#	xqr,qrank,
	work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj+2),
#	qpivot,qraux,
#	work(iw+nef(k)*(pj+dj+4)+pj+3),work(iw+nef(k)*(pj+dj+4)+4+2*pj),
	iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj),
	iv(sliv),liv(k),lv(k),v(slv),
	work(1) )
#work should be sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
# In the call above I give lo1 pieces of work to use for storing
# the  qr decomposition, and it gets the same undisturbed portion
# each time. The fact that it is given a double work word for qrank
# is irrelevant but convenient; it still stores the integer qrank there.
# I do this because there is a partition like this for each lo() term
# in the model, and the number of them is variable
		sliv=sliv+liv(k)
		slv=slv+lv(k)
		iw=iw+nef(k)*(pj+dj+4)+5+3*pj
		do i=1,n{
			eta(i)=eta(i)+s(i,k)-old(i)
			}
		deltaf=deltaf+dwrss(n,old,s(1,k),w)
		}
	normf=0d0
	do i=1,n{
		normf=normf+w(i)*eta(i)*eta(i)
		}
	if(normf>0d0){
		ratio=dsqrt(deltaf/normf)
		}
	 else {ratio = 0d0}
	}
#now package up the results
do j=1,p {work(j)=beta(j)}
do j=1,p {beta(qpivot(j))=work(j)}
if(anyzwt){
	do i=1,n {
		if(w(i) <= 0d0){
			etal(i)=0d0
			do j=1,p{
				etal(i)=etal(i)+beta(j)*x(i,j)
				}
			}
		}
	}

do i=1,n
	eta(i)=eta(i)+etal(i)

return
end


forme_history <- function(data, probs = c(0.025, 0.5, 0.975)) {
  fh <- data |> dplyr::transmute(
    year = year,
    og = og, dettep,
    txppib, tpo,
    tdep=tdeppp*pibpot/qpib,
    spp,
    ci = r_app*dettep,
    ib_po = - tpo + lag(tpo),
    ib_dep = tdeppp - dplyr::lag(tdeppp),
    ib = ib_po + ib_dep,
    qpib, pibpot, tcho, tvnairu, gpib, r_app) |>
    tidyr::pivot_longer(cols = - year, names_to = "variable", values_to = "q0.5")
  se <- stringr::str_c("q", setdiff(probs, 0.5))
  dplyr::bind_cols(fh, dplyr::bind_cols(purrr::map(se, ~tibble::tibble(!!.x := fh$q0.5)))) |>
    dplyr::arrange(year)
}

dataandparams <- function(country, start_year, periods = 2050-start_year, draws=100, globals, ameco=NULL) {
  if(is.null(ameco))
    ameco <- globals$ameco
  country_list <- ameco |> dplyr::distinct(country)

  countries <- set_names(globals$pays |> dplyr::pull(id))
  countries_ln_fr <- globals$pays |> dplyr::pull(nom_fr, name = id)

  data <- ameco |>
    dplyr::filter(country==!!country, unit==0) |>
    dplyr::rename(var = ccode) |>
    dplyr::select(-code, -TITLE, -COUNTRY, -`SUB-CHAPTER`, -UNIT, -csplit2, -csplit3, -unit, -is.prev, -country) |>
    tidyr::drop_na(value) |>
    tidyr::pivot_wider(names_from = var, values_from = value)
  if(!"tvnairu" %in% names(data))
    data <- data |>
    mutate(tvnairu = slider::slide_dbl(tcho, ~mean(.x), .before = 3 ))
  if(!"pibpot" %in% names(data))
    data <- data |>
    mutate(pibpot = slider::slide_dbl(qpib, ~mean(.x), .before = 10),
           og = qpib/pibpot-1)
  data <- data |>
    dplyr::mutate(dplyr::across(.cols=c(irl, irs, tvnairu), .fns = ~ dplyr::if_else(is.na(.x), .x[year==max(year[!is.na(.x)])], .x))) |>
    dplyr::mutate(
      ppib = vpib/qpib,
      gpot = pibpot/dplyr::lag(pibpot) - 1,
      txppib = ppib/dplyr::lag(ppib) - 1,
      gpib = qpib/dplyr::lag(qpib) - 1,
      og = qpib/pibpot-1,
      r_app = ci/dplyr::lag(dette),
      r_inst = irl/100,
      vpibpot = ppib*pibpot,
      tpo = rec_po/vpib,
      tpopp = rec_po/vpibpot,
      tdep = dep_prim/vpib,
      tdeppp = dep_prim/vpibpot,
      cip = ci/vpib,
      soldep=solde/vpib,
      spp=sprim/vpib,
      taut = spp - tpo + tdep,
      tcho = tcho/100,
      tvnairu = tvnairu/100,
      ec = irl/100 - ((ppib/dplyr::lag(ppib,3))^0.33 - 1)- ((pibpot/dplyr::lag(pibpot,3))^0.33 - 1) ) |>
    tibble::as_tibble()

  full_historical_data <- data |>
    dplyr::transmute(year,
                     dettep = dette/vpib, r_app,
                     spp, og, txppib, tpo, tdep, tdeppp, pibpot, qpib, tcho, tvnairu, gpib, ec) |>
    tidyr::drop_na(dettep)

  historical_data <- full_historical_data |>
    dplyr::filter(year<=start_year)

  years <- c(min(historical_data$year), max(data$year))

  init <- data |>
    dplyr::arrange(year) |>
    dplyr::mutate(lagog=dplyr::lag(og),
                  lag2og=dplyr::lag(og),
                  lagtcho=dplyr::lag(tcho),
                  lag2tcho=dplyr::lag(lagtcho),
                  lagtvnairu=dplyr::lag(tvnairu),
                  lagppib=dplyr::lag(ppib),
                  lagpibpot=dplyr::lag(pibpot),
                  lag2pibpot=dplyr::lag(lagpibpot),
                  lag2ppib=dplyr::lag(lagppib),
                  lagqpib = dplyr::lag(qpib),
                  lag2qpib = dplyr::lag(lagqpib),
                  lagtdeppp = dplyr::lag(tdeppp),
                  lag2tdeppp = dplyr::lag(lagtdeppp),
                  lagtpo =dplyr::lag(tpo),
                  lagci = dplyr::lag(ci),
                  lagr_inst = dplyr::lag(r_inst),
                  lagdette = dplyr::lag(dette),
                  lag2dette = dplyr::lag(lagdette),
                  lagdettep = dplyr::lag(dette/vpib),
                  lagspp = dplyr::lag(spp),
                  lag2spp = dplyr::lag(lagspp),
                  lagcip = dplyr::lag(cip),
                  lag2cip = dplyr::lag(lagcip)) |>
    dplyr::filter(year==start_year)
  params <- list(
    periods = periods,
    draws = as.numeric(draws),
    infstar = 0.0175,
    nairu = 0.07,
    dstar = init$dette/init$vpib
  )

  p_def <- globals$defaults |>
    dplyr::filter(type=="p") |>
    dplyr::select(!!country, id) |>
    dplyr::mutate(!!country:=as.numeric(.data[[country]])) |>
    dplyr::pull(!!country, name=id) |>
    as.list()

  dstar <- historical_data |>
    dplyr::filter(year==min(start_year, max(year)-3)) |>
    dplyr::pull(dettep)

  if(is.null(p_def[["dstar"]]))
    p_def$dstar <- dstar

  nairu <- historical_data |>
    dplyr::filter(year==min(start_year, max(year))) |>
    dplyr::pull(tcho)

  if(is.null(p_def[["nairu"]]))
    p_def$nairu <- nairu

  dci <- globals$defaults |>
    dplyr::filter(type==start_year) |>
    dplyr::select(id, !!country) |>
    dplyr::mutate(!!country:=as.numeric(.data[[country]])) |>
    dplyr::pull(name = id) |>
    as.list()

  zn <- function(x) ifelse(is.null(x), 0, x)

  p_init <- list(
    i_ogm = init$og,
    i_lagog = init$og,
    i_lag2og = init$lagog,
    i_lagtcho = init$tcho,
    i_lagtvnairu = init$tvnairu,
    i_lagppib = init$ppib,
    i_lag2ppib = init$lagppib,
    i_lag3ppib = init$lag2ppib,
    i_lagqpib = init$qpib,
    i_lag2qpib = init$lagqpib,
    i_lag3qpib = init$lag2qpib,
    i_lagpibpot = init$pibpot,
    i_lag2pibpot = init$lagpibpot,
    i_lag2dette = init$lagdette,
    i_lagtpo = init$tpo + zn(dci$i_tpo),
    i_lagtdeppp = init$tdeppp + zn(dci$i_tdeppp),
    i_lag2tdeppp = init$lagtdeppp,
    i_lagr_app = init$r_app,
    i_lagr_inst = init$r_inst,
    i_lagdette = init$dette,
    i_lagspp = init$spp + zn(dci$i_tpo) - zn(dci$i_tdeppp)/(1+init$og),
    i_lag2spp = init$lagspp,
    i_lagcip = init$cip,
    i_lag2cip = init$lagcip,
    i_lagecart_c = init$ec,
    dette_oneoff = rep(0, periods),
    tx_deriv_dep = rep(0, periods),
    tx_deriv_po = rep(0, periods),
    gpot = rep(init$gpot, periods),
    taut = rep(init$taut, periods)
  )

  return(list(countries = countries,
              countries_ln_fr = countries_ln_fr,
              params = params,
              p_init = p_init,
              p_def = p_def,
              historical_data = historical_data,
              full_historical_data = full_historical_data,
              init = init,
              years = years,
              country=country,
              start_year=start_year,
              periods=periods))
}

# dust_check_params
dust_fix_params <- function(params, long = c( "dette_oneoff", "phi", "gpot", "taut", "tx_deriv_dep", "tx_deriv_po")) {
  long_exo <- params |> purrr::keep(~length(.x)>1) |> names()
  # pas moyen de récupérer cette liste de l'objet dust model
  long_exo <- unique(c(long_exo, long))
  ss <- purrr::map(
    rlang::set_names(long_exo),
    ~{
      if(!is.null(params[[.x]]))
        trimortrick(params[[.x]], params$periods)
      else
        rep(0,params$periods)
    })
  purrr::list_modify(params, !!!ss)
}

# simulations ---------------

calc_sim_dust <- function(params, model, probs=c(0.025, 0.5, 0.975), history = NULL,
                          long= c("dette_oneoff", "phi", "gpot", "taut", "tx_deriv_dep", "tx_deriv_po")) {
  p <- params
  p <- dust_fix_params(p, long=long)
  if(is.null(params$seed))
    seed <- NULL
  else
    seed <- as.integer(params$seed)
  m <- model$new(pars=p, step=1, n_particles = p$draws, n_threads = 2L, seed = seed)

  state_names <- names(m$info()$index)
  # les variables de sortie sont indicees par _o
  out_i <- which(stringr::str_detect(state_names, "_o$"))
  m$set_index(out_i)
  out_names <- state_names[out_i]
  # on simule une annee de plus
  res <- m$simulate(1:(params$periods+1))
  dimnames(res)[[1]] <- out_names
  # on drop le premier step qui ne contient pas d'info
  res <- res[,,-1, drop=FALSE]
  se <- stringr::str_c("q", setdiff(probs, 0.5))
  if(params$draws>1)
    sim <- purrr::map_dfr(out_names, ~{
      m <- matrixStats::colQuantiles(abind::adrop(res[.x,,,drop=FALSE], drop=1), probs=probs, drop=FALSE)
      colnames(m) <- stringr::str_c("q", probs)
      tibble::as_tibble(m)  |>
        dplyr::mutate(variable = stringr::str_remove(.x, "_o$") , step = 1:nrow(m))
    })
  else
  {
    rr <- tibble::as_tibble(t(abind::adrop(res, drop=2))) |>
      dplyr::mutate(step = dplyr::row_number()) |>
      tidyr::pivot_longer(cols = -step, names_to = "variable", values_to = "q0.5") |>
      dplyr::mutate(variable = stringr::str_remove(variable,"_o$"))
    sim <- dplyr::bind_cols(rr, dplyr::bind_cols(purrr::map(se, ~tibble::tibble(!!.x := rr$q0.5))))
  }

  if(!is.null(history))
  {
    start_year <- max(history$year)
    sim <- sim |>
      dplyr::mutate(year = start_year+step) |>
      dplyr::bind_rows(history) |>
      dplyr::arrange(year) |>
      dplyr::select(-step)
  }
  else
    sim <- sim |>
    dplyr::rename(year=step)
  sim
}

medianloss1 <- function(params, model, controls, n_threads = 2) {
  p <- params
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = p$seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names=="loss_o")
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$run(params$periods+1)
  res <- matrixStats::rowMedians(res)
  lasso_loss <- sum(purrr::as_vector(params[controls])^2) * params$loss_lasso
  return(log(res+lasso_loss))
}

medianloss2 <- function(params, model, controls=c("tpo_og", "tpo_dstar", "tpo_sstar"), n_threads = 2L) {
  p <- params
  p$seed <- NULL
  periods <- params$periods
  seed  <- if(is.null(params$seed)) NULL else as.integer(params$seed)
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names%in%c("loss_nd_o", "dettep_o"))
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$simulate(1:(periods+1))
  res <- res[,,-1, drop=FALSE]
  dimnames(res)[[1]] <- state_names[out_i]
  if(params$draws>1)
    sim <- purrr::map(rlang::set_names(state_names[out_i]), ~{
      matrixStats::colMedians(abind::adrop(res[.x,,,drop=FALSE], drop=1), drop=FALSE)
    })
  else
    sim <-t(abind::adrop(res, drop=2)) |> as_tibble()

  loss_part1 <- sim$loss_nd_o[length(sim$loss_nd_o)]
  loss_part2 <- sum((sim$dettep_o[(params$loss_t+1):periods]-params$dstar)^2) * params$loss_d
  lasso_loss <- sum(purrr::as_vector(params[controls])^2) * params$loss_lasso
  return(loss_part1 + loss_part2 + lasso_loss)
}

constrainedMedianLoss2 <- function(params, model, controls, ccont, n_threads = 2) {
  if(is.null(ccont))
    return(medianloss2(params, model, controls, n_threads))
  ccc <- purrr::map(
    rlang::set_names(names(ccont)),
    ~min(max(params[[.x]],ccont[[.x]][[1]]), ccont[[.x]][[2]])
  )
  params <- list_modify(params,!!!ccc)
  medianloss2(params, model, names(ccont), n_threads =2 )
}

meanloss2 <- function(params, model, controls=c("tpo_og", "tpo_dstar", "tpo_sstar"), n_threads = 2) {
  p <- params
  periods <- params$periods
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = p$seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names%in%c("loss_nd_o", "dettep_o"))
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$simulate(1:(periods+1))
  res <- res[,,-1, drop=FALSE]
  dimnames(res)[[1]] <- state_names[out_i]
  if(params$draws>1)
    sim <- purrr::map(rlang::set_names(state_names[out_i]), ~{
      matrixStats::colMeans2(abind::adrop(res[.x,,,drop=FALSE], drop=1), drop=FALSE)
    })
  else
    sim <-t(abind::adrop(res, drop=2)) |> as_tibble()

  loss_part1 <- sim$loss_nd_o[length(sim$loss_nd_o)]
  loss_part2 <- sum((sim$dettep_o[(params$loss_t+1):periods]-params$dstar)^2) * params$loss_d
  lasso_loss <- sum(purrr::as_vector(params[controls])^2) * params$loss_lasso
  return(log(loss_part1 + loss_part2 + lasso_loss))
}

medianloss3 <- function(params, model, controls=c("tpo_og", "tpo_dstar", "tpo_sstar"), n_threads = 2) {
  p <- params
  p$draws <- NULL
  periods <- params$periods
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = p$seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names%in%c("og_o", "dettep_o"))
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$simulate(1:(periods+1))
  res <- res[,,-1, drop=FALSE]
  dimnames(res)[[1]] <- state_names[out_i]
  if(params$draws>1)
    sim <- purrr::map(rlang::set_names(state_names[out_i]), ~{
      matrixStats::colMedians(abind::adrop(res[.x,,,drop=FALSE], drop=1), drop=FALSE)
    })
  else
    res

  loss_part1 <- sum(sim$og_o^2/ (1+params$df)^(0:(periods-1)))
  loss_part2 <- sum((sim$dettep_o[(params$loss_t+1):periods]-params$dstar)^2)
  log(loss_part1 + params$loss_d * loss_part2)
}

lassomedianloss4 <- function(params, model, controls=c("tpo_og", "tpo_dstar", "tpo_sstar"), n_threads = 2) {
  p <- params
  p$draws <- NULL
  periods <- params$periods
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = p$seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names%in%c("og_o", "dettep_o"))
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$simulate(1:(periods+1))
  res <- res[,,-1, drop=FALSE]
  dimnames(res)[[1]] <- state_names[out_i]
  if(params$draws>1)
    sim <- purrr::map(rlang::set_names(state_names[out_i]), ~{
      matrixStats::colMedians(abind::adrop(res[.x,,,drop=FALSE], drop=1), drop=FALSE)
    })
  else
    res
  og4l <- sim$og_o^2/ (1+params$loss_df)^(0:(periods-1))
  d4l <- sim$dettep_o[(params$loss_t+1):periods]
  loss_part1 <- sum(og4l[sim$og<0])
  loss_part2 <- sum((d4l[d4l>params$dstar]-params$dstar)^2) * params$loss_d
  lasso_loss <- sum(purrr::as_vector(params[controls])^2)
  log(loss_part1 + loss_part2) + log(1+lasso_loss) * params$loss_lasso
}

lassomedianloss5 <- function(params, model, controls=c("tpo_og", "tpo_dstar", "tpo_sstar"), n_threads = 2) {
  p <- params
  p$draws <- NULL
  periods <- params$periods
  m <- model$new(pars=p, step=1, n_particles = params$draws, n_threads = n_threads, seed = p$seed)
  state_names <- names(m$info()$index)
  out_i <- which(state_names%in%c("og_o", "dettep_o"))
  m$set_index(out_i)
  # on simule une annee de plus
  res <- m$simulate(1:(periods+1))
  res <- res[,,-1, drop=FALSE]
  dimnames(res)[[1]] <- state_names[out_i]
  if(params$draws>1)
    sim <- purrr::map(rlang::set_names(state_names[out_i]), ~{
      matrixStats::colMedians(abind::adrop(res[.x,,,drop=FALSE], drop=1), drop=FALSE)
    })
  else
    res
  og4l <- sim$og_o^2/ (1+params$loss_df)^(0:(periods-1))
  d4l <- sim$dettep_o[(params$loss_t+1):periods]
  loss_part1 <- sum(og4l)
  loss_part2 <- sum((d4l-params$dstar)^2) * params$loss_d
  lasso_loss <- sum(purrr::as_vector(params[controls])^2)
  log(loss_part1 + loss_part2) + log(1+lasso_loss) * params$loss_lasso
}

add_previous <- function(ns, ps) {
  if(!purrr::is_empty(ps))
  {
    dplyr::left_join(ns, ps |> dplyr::select(year, variable, pq0.5 = q0.5), by=c("year", "variable"))
  }
  else
    dplyr::mutate(ns, pq0.5 = NA_real_)
}

# applique le facteur pour l'affichage par exemple des %
# à renseigner dans le fichier sliders.xlsx
transform_params <- function(input, globals)
{
  from_input <- map(set_names(names(globals$sliders)), ~{
    type <- globals$sliders[[.x]][["type"]]
    if(type=="slider")
      return(input[[.x]]/globals$sliders[[.x]][["facteur"]])
    if(type=="pick")
      return(as.numeric(input[[.x]]))
    if(type=="pick_str")
      return(as.character(input[[.x]]))
    if(type=="date")
      return(lubridate::year(input[[.x]]))
    if(type=="check")
      return(as.logical(input[[.x]]))
  })
  return(from_input)
}

# inverse la transformation précédente
undo_transform <- function(p, globals) {
  to_undone <- purrr::map_dbl(
    rlang::set_names(names(globals$sliders)),
    ~globals$sliders[[.x]][["facteur"]])
  to_undone <- to_undone[!is.na(to_undone) & to_undone!=1]
  undone <- map(rlang::set_names(names(to_undone)), ~{
    p[[.x]]*to_undone[[.x]]
  })
  purrr::list_modify(p, !!!undone)
}

# généralise l'opérateur %||%
`%|||%` <- function (x, y)
{
  if (purrr::is_empty(x))
    y
  else x
}

set_params <- function(inputs, globals, datas)
{
  s_y <- inputs$start_year
  periods <- inputs$end_year - s_y
  history <- NULL
  # les parametres
  p <- datas$p_def
  p <- purrr::list_modify(p, periods=periods)
  p <- purrr::list_modify(p, !!!datas$p_init)
  p <- purrr::list_modify(p, !!!inputs)

  dtpo <- inputs$i_tpo%|||%0
  dtdeppp <- inputs$i_tdeppp%|||%0
  p$i_tpo <- NULL
  p$i_tdeppp <- NULL
  p$i_lagtdeppp <- p$i_lagtdeppp%|||%0 + dtdeppp
  p$i_lagtpo <- p$i_lagtpo%|||%0 + dtpo

  # du coup on modifie l'historique
  history <- forme_history(
    datas$historical_data |>
      dplyr::filter(year>=inputs$start_hist))
  full_history <- forme_history(datas$full_historical_data) |>
    select(-q0.025, -q0.975) |>
    rename(full_h = q0.5)
  ses <- names(history |> dplyr::select(dplyr::starts_with("q0.", ignore.case = FALSE)) |> dplyr::select(-q0.5))
  names(ses) <- ses

  identities <- purrr::map(ses, ~ function(x) x)

  new <- history |>
    dplyr::filter(year==s_y) |>
    dplyr::select(year, q0.5, variable) |>
    tidyr::pivot_wider(names_from = variable, values_from = q0.5) |>
    dplyr::mutate(
      spp = spp + dtpo - dtdeppp/(1+og),
      tpo = tpo + dtpo,
      tdep = tdep + dtdeppp/(1+og),
      ib_dep = ib_dep + dtdeppp,
      ib_po = ib_po + dtpo) |>
    tidyr::pivot_longer(cols=-year, values_to = "q0.5", names_to = "variable") |>
    dplyr::mutate(dplyr::across(q0.5, .fns = identities, .names="{.fn}"))

  history <- history |>
    dplyr::rows_update(new, by=c("year","variable"))

  # le potentiel
  p$gpot <- rep(inputs$gpot_sj,periods)
  # les depenses publiques et les po
  p$tx_deriv_dep <- c(rep(inputs$ddep/10, min(10, periods)), rep(0, max(periods-10, 0)))
  p$tx_deriv_po <- c(rep(inputs$dtpo/10, min(10, periods)), rep(0, max(periods-10, 0)))

  # checke pas de montecarlo
  if(inputs$go_mc) {
    p$draws  <- inputs$draws
    p$ogn  <-  inputs$og_n
    p$ogn_sigma <- inputs$ogn_sigma
  } else {
    p$draws  <- 1
    p$ogn  <-  0
    p$ogn_sigma <- 0
  }

  # on change les vecteurs à la bonne longueur en les coupant ou étendant si nécessaire
  long_exo <- p |> purrr::keep(~length(.x)>1) |> names()
  ss <- purrr::map(rlang::set_names(long_exo), ~trimortrick(p[[.x]], periods))
  p <- purrr::list_modify(p, !!!ss)

  return(list(p=p, h=history, fh=full_history, start_year=s_y, periods=periods, end_year = s_y + periods, start_hist = inputs$start_hist))
}

calc_rule_params <- function(globals, params, draws=5000) {
  # on calcule la regle optimale (lineaire) si le switch est frappe
  # pour les lag ajouter "tpo_1dstar", "tpo_1sstar", "tpo_1og"
  # pour les termes quadratiques ajouter "tpo_dstar2", "tpo_sstar2", "tpo_og2"
  # on sort une expression avec la regle budgetaire prete a etre affichee
  controls_c <- list(tpo_sstar = c(0.005 , 0.9), tpo_dstar = c(-0.4, -0.005), tpo_og = c(-1.5, 0))
  controls <- purrr::map_dbl(controls_c, mean)
  par_fr <- best_FR_par(
    params, globals$model,
    controls = controls,
    constraints = controls_c,
    loss = medianloss2,
    draws = draws ,
    dt = 20)
  if(!is.null(par_fr$error))
    return(list(error = TRUE))
  p <- purrr::list_modify(params, !!!par_fr, error=FALSE)
  return(p)
}

do_rule_text <- function(tpo_og, tpo_sstar, tpo_dstar) {
  if(is.null(tpo_og)||is.null(tpo_dstar)||is.null(tpo_sstar))
    return("")
  c1 <- signif(tpo_og,2)
  c2 <- signif(tpo_sstar,2)
  c3 <- ifelse(tpo_dstar>0, stringr::str_c("+", signif(tpo_dstar,2)), signif(tpo_dstar,2))
  glue::glue(
    "ib = {{c1}} \\times og + {{c2}} \\times (s_p - s^*) \\\\ {{c3}} \\times (d-d^*)",
    .open="{{", .close="}}")
}

trimortrick <- function(s,t)
{
  if(length(s)>=t)
    return(s[1:t])
  return(c(s, rep(dplyr::last(s), t-length(s))))
}

best_FR_par <- function(p, model, controls, constraints = NULL, method="Nelder-Mead", loss = medianloss2, draws = 1000, dt = 20) {
  lp <- p
  periods <- lp$loss_t+dt
  if(!is.null(p$seed))
    seed <- p$seed + 1
  else
    seed <- as.integer(floor(runif(1,1,2*10^9)))
  lp <- purrr::list_modify(lp, periods=periods, draws=draws, seed = seed)
  lp <- dust_fix_params(lp)
  ffo <- function(cont) {
    if(is.null(constraints))
      ccc <- cont
    else {
      ccc <- purrr::map(
        rlang::set_names(names(constraints)),
        ~{
          min(max(cont[.x], constraints[[.x]][[1]]), constraints[[.x]][[2]])
        }
      )
    }
    err <- sum((as_vector(ccc)-cont)^2)
    loss(
      params = purrr::list_modify(lp, !!!ccc),
      model = model,
      controls = names(controls),
      n_threads = 2
    ) + err
  }

  opt <- try(
    optimx::optimx(
      par=as_vector(controls),
      fn=\(x) ffo(x),
      method=method,
      control = list(kkt=FALSE, maxit = 2000)
    )
  )

  if("try-error"%in%class(opt))
    return(list(error = TRUE))

  if(opt$convcode!=0)
  {
    mess <- case_when(
      opt$convcode == 1 ~ "maxit reached",
      opt$convcode == 10 ~ "Nelder-Mead simplex degerenate")
    message("optimisation code {opt$convcode} [{mess}]" |> glue::glue())
  }
  set_names(c(opt[names(controls)]), names(controls))
}

best_FR_par_with_phi <- function(p, model, controls, method="Nelder-Mead", loss=medianloss2, draws = 1000, dt = 40) {
  null_controls <- unique(purrr:::keep(names(p), ~stringr::str_starts(.x, "tpo")), names(controls))
  null_controls <- rlang::set_names(rep(0, length(null_controls)), null_controls)
  # on cherche les phi déteministes
  lp_det <- purrr::list_modify(p, periods = p$loss_t+dt, ogn_sigma = 0, ogn_ar = 0, loss_lasso = 0, loss_ib = 0, draws = 1, !!!null_controls)
  lp_det <- dust_fix_params(lp_det)

  det_with_phi <- function(cont) {
    medianloss1(purrr::list_modify(lp_det, phi = cont), model, "phi", 2)
  }
  phic <- lp_det$phi
  det_opt <- optimx::optimx(
    par=phic,
    fn=\(x) det_with_phi(x),
    method="nlm")
  phi <- unlist(det_opt[1:lp_det$periods])
  names(phi) <- NULL
  lp <- list_modify(p, phi = phi, periods = p$loss_t+dt, draws = draws)
  lp <- dust_fix_params(lp)
  ffo <- function(cont) {
    loss(
      params = purrr::list_modify(lp, !!!cont),
      model = model,
      controls = names(controls),
      n_threads = 4)
  }
  opt <- optimx::optimx(par=controls, fn=\(x) ffo(x), method=method)
  opt <- set_names(c(opt[names(controls)]), names(controls))
  opt <- list_modify(as.list(null_controls), !!!as.list(opt))
  return(list_modify(list(phi = phi), !!!opt))
}

best_FR_par_with_phi_only <- function(p, model, method="nlm", loss=medianloss2, draws = 1000, dt = 40) {
  null_controls <- unique(purrr:::keep(names(p), ~stringr::str_starts(.x, "tpo")))
  null_controls <- rlang::set_names(rep(0, length(null_controls)), null_controls)
  lp_sto <- purrr::list_modify(p, periods = p$loss_t+dt, draws = draws, !!!null_controls)
  lp_sto <- dust_fix_params(lp_sto)
  phic <- lp_sto$phi
  with_phi <- function(cont) {
    medianloss1(
      params = purrr::list_modify(lp_sto, phi = cont),
      model = model,
      controls = "phi",
      n_threads = 2)
  }
  det_opt <- optimx::optimx(par = phic,
                            fn = \(x) with_phi(x),
                            method= method)
  if(det_opt$convcode!=0)
    message("Convergence not achieved")
  phi <- unlist(det_opt[1:lp_sto$periods])
  names(phi) <- NULL
  list_modify(list(phi = phi), !!!null_controls)
}