# Snow crab size structured model

  require(bio.snowcrab)   # loadfunctions("bio.snowcrab")

  year.assessment = 2021
  yrs = 1999:year.assessment
  spec_bio = bio.taxonomy::taxonomy.recode( from="spec", to="parsimonious", tolookup=2526 )

  loadfunctions("bio.snowcrab")

  pS = snowcrab_parameters( project_class="size_structured", yrs=yrs,
    selection = list( type = "number", biologicals=list( spec_bio=spec_bio ) )
  )

  M = snowcrab.db( p=pS, DS="set.complete" )
  setDT(M)

  # must check why we have dups here
  i = which(duplicated(M[,1:10]))
  M = M[-i,]

  s_male = c("mi123.no", "mi4.no", "mi5.no", "mi6.no", "mi7.no", "mi8.no", "mi9.no", "mi10.no", "mi11.no", "mi12.no", "ma9.no", "ma10.no", "ma11.no", "ma12.no", "ma13.no" )
  i_male = c( 3:12, 9:13 )  # instar
  m_male = c( rep(0, 10), rep(1, 5) ) # maturity

  # convert to numbers
  males = M[ , c("uid",  s_male ) ]
  males[, s_male] = males[, s_male]  * M$sa
  m = data.table::melt( setDT(males), id.vars="uid", measure.vars=s_male, variable.factor=FALSE  )
  setnames(m, "value", "n")
  setnames(m, "variable", "stage")
  # plot(xtabs(n~stage, m)[s_male])

  m$instar = i_male[ match( m$stage, s_male ) ]
  m$maturity = m_male[ match( m$stage, s_male ) ]

  tot = m[, .(ntot=sum(n)), by=.(uid, instar) ]
  mat = m[ maturity==1, .(nmat=sum(n)),  by=.(uid, instar)]
  cnts = mat[ tot, on=.(uid, instar) ]
  cnts$fraction_mature = cnts$nmat / cnts$ntot

  cnts = cnts[ M[,c("uid", "yr")], on=.(uid) ]

  mx = dcast( cnts[,.(ntot=sum(ntot, na.rm=TRUE)), by=.( instar, yr) ], instar ~ yr, value.var="ntot" )

  mtm = dcast( cnts[,.(tm=sum(fraction_mature*ntot, na.rm=TRUE)), by=.( instar, yr) ], instar ~ yr, value.var="tm" )

  mm = as.matrix(mtm / mx)[ , 2:26]

  image( as.matrix( round( mm, 3) ) )

  plot(rowMeans(mm))

  s_female = c("fi1234.no", "fi5.no", "fi6.no", "fi7.no", "fi8.no", "fi9.no", "fi10.no", "fa7.no", "fa8.no", "fa9.no", "fa10.no" )

  females = M[ , c("uid",  s_female ) ]
  females[, s_female] = females[, s_female]  * M$sa
  f = data.table::melt( setDT(females), id.vars="uid", measure.vars=s_female, variable.factor=FALSE  )
  setnames(f, "value", "n")
  setnames(f, "variable", "stage")
  plot(xtabs(n~stage, f)[s_female])

  # some survey timestamps extend into January (e.g., 2020) force them to be part of the correct "survey year", i.e., "yr"
  i = which(lubridate::month(M$timestamp)==1)
  if (length(i) > 0) M$timestamp[i] = M$timestamp[i] - lubridate::duration(month=1)

  M$tiyr = lubridate::decimal_date(M$timestamp)
  M$dyear[ M$dyear > 1] = 0.99  # a survey year can run into the next year, cap the seasonal compenent at the calendar year for modellng

  # reduce size
  M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
  # levelplot(z.mean~plon+plat, data=M, aspect="iso")

    if (areal_units) {
      # polygon structure:: create if not yet made
      # for (au in c("cfanorth", "cfasouth", "cfa4x", "cfaall" )) plot(polygon_managementareas( species="snowcrab", au))
      xydata = snowcrab.db( p=pN, DS="areal_units_input", redo=TRUE )
      xydata = snowcrab.db( p=pN, DS="areal_units_input" )
      sppoly = areal_units( p=pN, xydata=xydata[ which(xydata$yr %in% pN$yrs), ], redo=TRUE, verbose=TRUE )  # create constrained polygons with neighbourhood as an attribute

      sppoly=areal_units( p=pN )

      plot(sppoly["npts"])

      additional_features = snowcrab_features_tmap(pN)  # for mapping below

      figure_area_based_extraction_from_carstm(DS="temperature" )  # can only do done once we have an sppoly for snow crab

      M = snowcrab.db( p=pN, DS="carstm_inputs", sppoly=sppoly, redo=TRUE )  # will redo if not found

    }

    sppoly=areal_units( p=pN )

  # ------------------------------------------------
  # Part 2 -- spatiotemporal statistical model

    if ( spatiotemporal_model ) {

      # total numbers
      sppoly = areal_units( p=pN )
      M = snowcrab.db( p=pN, DS="carstm_inputs", sppoly=sppoly  )  # will redo if not found

      io = which(M$tag=="observations")
      ip = which(M$tag=="predictions")

      # subset to positive definite data (for number and size)
      isubset =1:nrow(M)
      ipositive = unique( c( which( M$totno > 0), ip ) )
      if (grepl("hurdle", pN$carstm_model_label)) {
        isubset = ipositive
        hist(M$data_offset[ipositive])
      }

      # number
      fit = NULL; gc()
      fit = carstm_model( p=pN, data=M[ isubset, ], sppoly=sppoly,
        posterior_simulations_to_retain="predictions", improve.hyperparam.estimates=TRUE
      )

      # mean size
      fit = NULL; gc()
      fit = carstm_model( p=pW, data=M[ isubset, ], sppoly = sppoly,
        posterior_simulations_to_retain="predictions", improve.hyperparam.estimates=TRUE,
        control.inla = list( strategy="laplace", int.strategy="eb" )
      )

      # model pa using all data
      fit = NULL; gc()
      fit = carstm_model( p=pH, data=M, sppoly=sppoly,
        posterior_simulations_to_retain="predictions", improve.hyperparam.estimates=TRUE,
        # control.family=list(control.link=list(model="logit")),  # default
        control.inla = list( strategy="laplace", int.strategy="eb" )
      )

      # choose:
      p = pN
      p = pW
      p = pH

      if (0) {
        # extract results
        fit = carstm_model( p=p, DS="carstm_modelled_fit",  sppoly = sppoly )  # extract currently saved model fit
        fit$summary$dic$dic
        fit$summary$dic$p.eff
        plot(fit)
        plot(fit, plot.prior=TRUE, plot.hyperparameters=TRUE, plot.fixed.effects=FALSE )
        plot( fit, plot.prior=TRUE, plot.hyperparameters=TRUE, plot.fixed.effects=FALSE )
        plot( fit$marginals.hyperpar$"Phi for space_time", type="l")  # posterior distribution of phi nonspatial dominates
        plot( fit$marginals.hyperpar$"Precision for space_time", type="l")
        plot( fit$marginals.hyperpar$"Precision for setno", type="l")
        fit = NULL
      }

      res = carstm_model( p=p, DS="carstm_modelled_summary",  sppoly = sppoly ) # to load currently saved results

      if (0) {

        vn=c( "random", "space", "combined" )
        vn=c( "random", "spacetime", "combined" )
        vn="predictions"  # numerical density (km^-2)

        tmatch= as.character(year.assessment)

        carstm_map(  res=res, vn=vn, tmatch=tmatch,
            sppoly = sppoly,
            palette="-RdYlBu",
            plot_elements=c(  "compass", "scale_bar", "legend" ),
            additional_features=additional_features,
            title =paste( vn, paste0(tmatch, collapse="-"), "no/m^2"  )
        )

        # map all :
        if ( number ) {
          outputdir = file.path( p$modeldir, p$carstm_model_label, "predicted.numerical.densitites" )
          if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )
          fn_root_prefix = "Predicted_numerical_abundance"
          fn_root =  "Predicted_numerical_abundance_persistent_spatial_effect"
          outfilename = file.path( outputdir, paste(fn_root, "png", sep=".") )
          title= paste( snowcrab_filter_class, "Predicted numerical density (no./m^2) - persistent spatial effect"  )
        }
        if ( meansize) {
          outputdir = file.path( p$modeldir, p$carstm_model_label, "predicted.meansize" )
          if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )
          fn_root_prefix = "Predicted_meansize"
          fn_root =  "Predicted_meansize_persistent_spatial_effect"
          outfilename = file.path( outputdir, paste(fn_root, "png", sep=".") )
          title= paste( snowcrab_filter_class, "Predicted meansize (kg) - persistent spatial effect" )
        }
        if ( presence_absence ) {
          outputdir = file.path( p$modeldir, p$carstm_model_label, "predicted.presence_absence" )
          if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )
          fn_root_prefix = "Predicted_presence_absence"
          fn_root =  "Predicted_presence_absence_persistent_spatial_effect"
          outfilename = file.path( outputdir, paste(fn_root, "png", sep=".") )
          title= paste( snowcrab_filter_class, "Predicted habitat probability - persistent spatial effect")
        }

        vn = c( "random", "space", "combined" )
        toplot = carstm_results_unpack( res, vn )
        brks = pretty(  quantile(toplot[,"mean"], probs=c(0,0.975), na.rm=TRUE )  )

        tmout = carstm_map(  res=res, vn=vn,
          sppoly = sppoly,
          breaks = brks,
          palette="-RdYlBu",
          plot_elements=c(  "compass", "scale_bar", "legend" ),
          additional_features=additional_features,
          outfilename=outfilename,
          title= title
        )
        tmout

        vn="predictions"
        toplot = carstm_results_unpack( res, vn )
        brks = pretty(  quantile(toplot[,,"mean"], probs=c(0,0.975), na.rm=TRUE )  )

        for (y in res$time ){
          tmatch = as.character(y)
          fn_root = paste(fn_root_prefix, paste0(tmatch, collapse="-"), sep="_")
          outfilename = file.path( outputdir, paste(fn_root, "png", sep=".") )

          tmout = carstm_map(  res=res, vn=vn, tmatch=tmatch,
            sppoly = sppoly,
            breaks =brks,
            palette="-RdYlBu",
            plot_elements=c(   "compass", "scale_bar", "legend" ),
            additional_features=additional_features,
            outfilename=outfilename,
            title=paste(fn_root_prefix, snowcrab_filter_class,  paste0(tmatch, collapse="-") )
          )
          tmout
          print(outfilename)

        }

        # plots with 95% PI
        outputdir = file.path( p$modeldir, p$carstm_model_label, "effects" )
        if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

        (fn = file.path( outputdir, "time.png"))
        png( filename=fn, width=1024, height=1024, pointsize=12, res=196 )
          carstm_plotxy( res, vn=c( "res", "random", "time" ),
            type="b", ylim=c(0, 1), xlab="Year", ylab="Probabilty", h=0, cex=1.25, cex.axis=1.25, cex.lab=1.25   )
        dev.off()

        (fn = file.path( outputdir, "cyclic.png"))
        png( filename=fn, width=1024, height=1024, pointsize=12, res=196 )
          carstm_plotxy( res, vn=c( "res", "random", "cyclic" ),
            type="b", col="slategray", pch=19, lty=1, lwd=2.5, ylim=c(0.35, 0.65),
            xlab="Season", ylab="Probabilty", cex=1.25, cex.axis=1.25, cex.lab=1.25   )
        dev.off()

        (fn = file.path( outputdir, "temperature.png"))
        png( filename=fn, width=1024, height=1024, pointsize=12, res=196 )
          carstm_plotxy( res, vn=c( "res", "random", "inla.group(t, method = \"quantile\", n = 11)" ),
            type="b", col="slategray", pch=19, lty=1, lwd=2.5, ylim=c(0, 0.8) ,
            xlab="Bottom temperature (degrees Celsius)", ylab="Probabilty", cex=1.25, cex.axis=1.25, cex.lab=1.25 )
        dev.off()

        (fn = file.path( outputdir, "depth.png"))
        png( filename=fn, width=1024, height=1024, pointsize=12, res=196 )
          carstm_plotxy( res, vn=c( "res", "random", "inla.group(z, method = \"quantile\", n = 11)" ),
            type="b", col="slategray", pch=19, lty=1, lwd=2.5, ylim=c(0, 0.9) ,
            xlab="Depth (m)", ylab="Probabilty", cex=1.25, cex.axis=1.25, cex.lab=1.25 )
        dev.off()

        fit = carstm_model( p=pW, DS="carstm_modelled_fit",  sppoly = sppoly ) # to load currently saved results

        plot( fit, plot.prior=TRUE, plot.hyperparameters=TRUE, plot.fixed.effects=FALSE )
        plot( fit$marginals.hyperpar$"Phi for space_time", type="l")  # posterior distribution of phi nonspatial dominates
        plot( fit$marginals.hyperpar$"Precision for space_time", type="l")
        plot( fit$marginals.hyperpar$"Precision for setno", type="l")

      }

    }  # end spatiotemporal model

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

    assimilate_numbers_and_size = TRUE

    if (assimilate_numbers_and_size ) {

      # wgts_max = 1.1 # kg, hard upper limit
      # N_max = NULL
      # #  quantile( M$totno[ipositive]/M$data_offset[ipositive], probs=0.95, na.rm=TRUE )

      # posterior sims
      sims = carstm_posterior_simulations( pN=pN, pW=pW, pH=pH, sppoly=sppoly, pa_threshold=0.05, qmax=0.99 )
      sims = sims / 10^6 # 10^6 kg -> kt;; kt/km^2

      SM = aggregate_biomass_from_simulations(
        sims=sims,
        sppoly=sppoly,
        fn=carstm_filenames( pN, returnvalue="filename", fn="aggregated_timeseries" ),
        yrs=pN$yrs,
        method="sum",
        redo=TRUE
      )

      RES= SM$RES
      # RES = aggregate_biomass_from_simulations( fn=carstm_filenames( pN, returnvalue="filename", fn="aggregated_timeseries" ) )$RES

      outputdir = file.path( carstm_filenames( pN, returnvalue="output_directory"), "aggregated_biomass_timeseries" )

      if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

      ( fn = file.path( outputdir, "cfa_all.png") )
      png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
        plot( cfaall ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Biomass index (kt)", xlab="")
        lines( cfaall_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
        lines( cfaall_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
      dev.off()

      ( fn = file.path( outputdir, "cfa_south.png") )
      png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
        plot( cfasouth ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Biomass index (kt)", xlab="")
        lines( cfasouth_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
        lines( cfasouth_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
      dev.off()

      ( fn = file.path( outputdir, "cfa_north.png") )
      png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
        plot( cfanorth ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Biomass index (kt)", xlab="")
        lines( cfanorth_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
        lines( cfanorth_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
      dev.off()

      ( fn = file.path( outputdir, "cfa_4x.png") )
      png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
        plot( cfa4x ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Biomass index (kt)", xlab="")
        lines( cfa4x_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
        lines( cfa4x_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
      dev.off()

      # map it ..mean density
      sppoly = areal_units( p=pN )  # to reload

      vn = paste("biomass", "predicted", sep=".")

      outputdir = file.path( carstm_filenames( pN, returnvalue="output_directory"), "predicted_biomass_densitites" )

      if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

      B = apply( sims, c(1,2), mean )

      brks = pretty( log10( quantile( B[], probs=c(0.05, 0.95) )* 10^6)  )

      additional_features = snowcrab_features_tmap(pN)  # for mapping below

      for (i in 1:length(pN$yrs) ){
        y = as.character( pN$yrs[i] )
        sppoly[,vn] = log10( B[,y]* 10^6 )
        outfilename = file.path( outputdir , paste( "biomass", y, "png", sep=".") )
        tmout =  carstm_map(  sppoly=sppoly, vn=vn,
            breaks=brks,
            additional_features=additional_features,
            title=paste( "log_10( Predicted biomass density; kg/km^2 )", y ),
            palette="-RdYlBu",
            plot_elements=c( "compass", "scale_bar", "legend" ),
            outfilename=outfilename
        )
        tmout

      }

    }  # end assimilate size and numbers

##########

# this part is only relevent for R0

fishery_model = FALSE

if (fishery_model) {

  # you need a stan installation on your system as well (outside of R), and the R-interface "cmdstanr":
  # install.packages("cmdstanr", repos = c("https://mc-stan.org/r-packages/", getOption("repos")))

  require(cmdstanr)

  loadfunctions("bio.snowcrab")

  # choose:
  pN$fishery_model_label = "stan_surplus_production_2022_model_qc_uniform"
  # pN$fishery_model_label = "stan_surplus_production_2022_model_variation1_wider_qc_uniform"
  # pN$fishery_model_label = "stan_surplus_production_2022_model_variation1_wider_qc_normal"
  # pN$fishery_model_label = "stan_surplus_production_2022_model_qc_cauchy_wider"

  # pN$fishery_model_label = "stan_surplus_production_2022_model_qc_beta"  # qc_beta postive definite
  # pN$fishery_model_label = "stan_surplus_production_2022_model_qc_cauchy"
  # pN$fishery_model_label = "stan_surplus_production_2019_model"

  pN$fishery_model = fishery_model( DS = "logistic_parameters", p=pN, tag=pN$fishery_model_label )
  to_look = c("K", "r", "q", "qc", "log_lik" )

      if ( model_version=="framework_2019" ) {
        # this is to create results for reviewers in 2022 that wanted a comparison with previous methods .. can be deleted in future
        # bring in unscaled abundance index
        a = fishery_model( DS="data_aggregated_timeseries", p=pN  )
        a$IOA[ !is.finite(a$IOA) ] = 0
        pN$fishery_model$standata$IOA = a$IOA
        to_look = c("K", "r", "q", "log_lik" )

      }

  #  str( pN$fishery_model)

  pN$fishery_model$stancode = stan_initialize( stan_code=fishery_model( p=pN, DS=pN$fishery_model_label ) )
  pN$fishery_model$stancode$compile()

  fit = pN$fishery_model$stancode$sample(
    data=pN$fishery_model$standata,
    iter_warmup = 4000,
    iter_sampling = 4000,
    seed = 45678,
    chains = 3,
    parallel_chains = 3,  # The maximum number of MCMC chains to run in parallel.
    max_treedepth = 18,
    adapt_delta = 0.99,
    refresh = 1000
  )

  fit$summary(to_look)

  require(loo)
  waic(fit$draws("log_lik"))
  loo(fit$draws("log_lik"))

  # save fit and get draws
  res = fishery_model( p=pN, DS="logistic_model", tag=pN$fishery_model_label, fit=fit )       # from here down are params for cmdstanr::sample()

  if (0) {
    # reload saved fit and results
    load(pN$fishery_model$fnres)
    fit = readRDS(pN$fishery_model$fnfit)

  }

  # frequency density of key parameters
  fishery_model( DS="plot", vname="K", res=res )
  fishery_model( DS="plot", vname="r", res=res )
  fishery_model( DS="plot", vname="q", res=res, xrange=c(0.5, 2.5))
  fishery_model( DS="plot", vname="qc", res=res, xrange=c(-1, 1))
  fishery_model( DS="plot", vname="FMSY", res=res  )

  # timeseries
  fishery_model( DS="plot", type="timeseries", vname="biomass", res=res  )
  fishery_model( DS="plot", type="timeseries", vname="fishingmortality", res=res)

  # Harvest control rules
  fishery_model( DS="plot", type="hcr", vname="default", res=res  )

  # Summary table of mean values for inclusion in document

  ( qs = apply(  res$mcmc$K[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )  # carrying capactiy

  ( qs = apply(  res$mcmc$FMSY[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) ) # FMSY

  biomass = as.data.table( fit$summary("B") )
  np = year.assessment+c(1:pN$fishery_model$standata$M)
  biomass$yr = rep( c(pN$yrs, np ), 3)
  nt = pN$fishery_model$standata$N +pN$fishery_model$standata$M
  biomass$region = c( rep("cfanorth", nt), rep("cfasouth", nt), rep("cfa4x", nt) )
  (biomass)

  NN = res$pN$fishery_model$standata$N

  # densities of biomass estimates for the year.assessment
  ( qs = apply(  res$mcmc$B[,NN,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

  # densities of biomass estimates for the previous year
  ( qs = apply(  res$mcmc$B[,NN-1,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

  # densities of F in assessment year
  ( qs = apply(  res$mcmc$F[,NN,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )
  ( qs = apply(  res$mcmc$F[,NN,], 2, mean ) )

  # densities of F in previous year
  ( qs = apply(  res$mcmc$F[,NN-1,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )
  ( qs = apply(  res$mcmc$F[,NN-1,], 2, mean ) )

  if (0) {
      # obsolete:

      fishery_model( DS="plot", vname="bosd", res=res  )
      fishery_model( DS="plot", vname="bpsd", res=res  )
      fishery_model( DS="plot", type="hcr", vname="simple", res=res  )

      # biomass.summary.table()

      fit = fishery_model( p=pN,   DS="fit", tag=pN$fishery_model_label )  # to load samples (results)
      fit$summary(c("K", "r", "q", "qc"))
      print( fit, max_rows=30 )
      fit$cmdstan_diagnose()
      fit$cmdstan_summary()

      # testing other samplers and optimizsers ... faster , good for debugging

      # (penalized) maximum likelihood estimate (MLE)
      fit_mle =  pN$fishery_model$stancode$optimize(data =pN$fishery_model$standata, seed = 123)
      fit_mle$summary( to_look )
      u = stan_extract( as_draws_df(fit_mle$draws() ) )

      # mcmc_hist(fit$draws("K")) + vline_at(fit_mle$mle(), size = 1.5)

      # # Variational Bayes
      fit_vb = pN$fishery_model$stancode$variational( data =pN$fishery_model$standata, seed = 123, output_samples = 4000)
      fit_vb$summary(to_look)
      fit_vb$cmdstan_diagnose()
      fit_vb$cmdstan_summary()

      u = stan_extract( as_draws_df(fit_vb$draws() ) )

      # bayesplot_grid(
      #   mcmc_hist(fit$draws("K"), binwidth = 0.025),
      #   mcmc_hist(fit_vb$draws("K"), binwidth = 0.025),
      #   titles = c("Posterior distribution from MCMC", "Approximate posterior from VB")
      # )

      # color_scheme_set("gray")
      # mcmc_dens(fit$draws("K"), facet_args = list(nrow = 3, labeller = ggplot2::label_parsed ) ) + facet_text(size = 14 )
      # mcmc_hist( fit$draws("K"))

      # obtain mcmc samples from vb solution
      res_vb = fishery_model(
        DS="logistic_model",
        p=pN,
        tag=pN$fishery_model_label,
        fit = fit_vb
      )

      names(res_vb$mcmc)

      # other diagnostics
      # fishery_model( DS="plot", type="diagnostic.errors", res=res )
      # fishery_model( DS="plot", type="diagnostic.phase", res=res  )

      NN = res$pN$fishery_model$standata$N

      # bosd
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$bosd[,i] ), main="")
      ( qs = apply(  res$mcmc$bosd[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # bpsd
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$bpsd[,i] ), main="")
      ( qs = apply(  res$mcmc$bpsd[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # rem_sd
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$rem_sd[,i] ), main="")
      ( qs = apply(  res$mcmc$rem_sd[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

    # qc
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$qc[,i] ), main="")
      ( qs = apply(  res$mcmc$qc[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # b0
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$b0[,i] ), main="")
      ( qs = apply(  res$mcmc$b0[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # K
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$K[,i] ), main="")
      ( qs = apply(  res$mcmc$K[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # R
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$r[,i] ), main="")
      ( qs = apply(  res$mcmc$r[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # q
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$q[,i] ), main="")
      ( qs = apply(  res$mcmc$q[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # FMSY
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$FMSY[,i] ), main="")
      ( qs = apply(  res$mcmc$FMSY[,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # densities of biomass estimates for the year.assessment
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(res$mcmc$B[,NN,i] ), main="")
      ( qs = apply(  res$mcmc$B[,NN,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # densities of biomass estimates for the previous year
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density( res$mcmc$B[,NN-1,i] ), main="")
      ( qs = apply(  res$mcmc$B[,NN-1,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )

      # densities of F in assessment year
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(  res$mcmc$F[,NN,i] ), xlim=c(0.01, 0.6), main="")
      ( qs = apply(  res$mcmc$F[,NN,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )
      ( qs = apply(  res$mcmc$F[,NN,], 2, mean ) )

      # densities of F in previous year
      plot.new()
      layout( matrix(c(1,2,3), 3, 1 ))
      par(mar = c(4.4, 4.4, 0.65, 0.75))
      for (i in 1:3) plot(density(  res$mcmc$F[,NN-1,i] ), xlim=c(0.01, 0.6), main="")
      ( qs = apply(  res$mcmc$F[,NN-1,], 2, quantile, probs=c(0.025, 0.5, 0.975) ) )
      ( qs = apply(  res$mcmc$F[,NN-1,], 2, mean ) )

      # F for table ---
      summary( res$mcmc$F, median)

    }  # end skip

}  # end fishery model

# end


# WICHTIG: Bei Erstinstallation zuerst install_everything.r _ausführen

source('libs.r')
source('import.r')

#features <- c('Age', 'Sex', 'Fare', 'Pclass', 'SibSp', 'Parch', 'Embarked', 'Cabin', 'CabinClass', 'peopleInCabin')
features <- c('Age', 'Sex', 'Fare', 'Pclass', 'SibSp', 'Parch', 'Embarked')
labels <- 'Survived'

#Traningsdaten
trainCsv <- titanicCsvImport('../data/train.csv')
train <- trainCsv[, c(features, labels)]

#Ein Blick in die Datenstrukturen
str(trainCsv)

# Manuell in Traningsdaten und Validierungsdaten zerlegen
splits <- sample(nrow(trainCsv)*0.85)
train <- trainCsv[splits, c(features, labels)]
test <- trainCsv[-splits, c(features, labels)]

# Start H2O
#h2o.shutdown(prompt = F)
h2o.init()

h2o_train <- as.h2o(train)
h2o_test <- as.h2o(test)

# Trainiere ein oder mehrere Modelle (RF, GBM, XGBOOST)
# Random Forest
titanic_rf <- h2o.randomForest(x=features,
                       y=labels,
                       training_frame = h2o_train,
                       model_id = 'ipv-titanic_rf',
                       nfolds = 10)

# Analyse des tranierten random Forest
h2o.confusionMatrix(titanic_rf)
h2o.auc(titanic_rf)

# Vergleiche den Einfluss der Variablen der Blackbox?
h2o.varimp_plot(titanic_rf)

# Automatisiertes Machinelles Lernen: Modell selbst lernen lassen
titanic_automl <- h2o.automl(x=features,
                       y=labels,
                       seed = 12345,
                       training_frame = h2o_train,
                       max_models=10,
                       nfolds = 5)

# Alle gelernten Modelle betrachten
titanic_leaderboard <- h2o.get_leaderboard(titanic_automl, extra_columns = 'ALL')
print(titanic_leaderboard, n = nrow(titanic_leaderboard))

# Das "beste" Modell
titanic_leader <- titanic_automl@leader
titanic_leader@model_id

h2o_test.prediction = h2o.predict(titanic_leader, h2o_test)
test.prediction = as.data.frame(h2o_test.prediction)

#test.results = merge(test, test.prediction, by.x=row.names(test), by.y=row.names(test.prediction))
test.results = cbind(test, test.prediction)

# Analyse des besten Modells
h2o.confusionMatrix(titanic_leader, h2o_test)

# Anomalieerkennung
# einen Autoencoder tranieren
titanic_anomalie <- h2o.deeplearning(x=features,
                                     seed=12345,
                                     model_id = "aie-titanic_autoencoder",
                                     training_frame = h2o_train,
                                     autoencoder = T,
                                     hidden = c(20,2,20)
                                     )
# Anomaliebewertung
h2o_test.anomalie <- h2o.anomaly(titanic_anomalie, h2o_test)
test.anomalie = as.data.frame(h2o_test.anomalie)
h2o_test.anomalie_predict <- h2o.predict(titanic_anomalie, h2o_test)
test.anomalie_predict = as.data.frame(h2o_test.anomalie_predict)

# Was ist in dem Datensatz
head(test.anomalie_predict)

test = test %>% mutate(index = row.names(test))
result = cbind(test, test.prediction, test.anomalie, test.anomalie_predict)
result <- result %>% mutate(correct = Survived==predict)

# einen belibigen Wert als Linie darstellen
anomalie_schwellwert = 0.09

ggplot( result, aes(x=reorder(index, Reconstruction.MSE), y=result$Reconstruction.MSE, color=result$correct  ) ) +
  geom_point() +
  geom_hline(yintercept = anomalie_schwellwert)

# Anomalien ausgeben
head(result %>% filter(Reconstruction.MSE > anomalie_schwellwert))

# keine Anomalien ausgeben
head(result %>% filter(Reconstruction.MSE < anomalie_schwellwert))

# Die Modelle finden sich unter http://localhost:54321


#######################################################################
# A benchmark script for S-RASTER with different window sizes and
# increasing data files
source('sraster.r')
printf <- function(...) cat(sprintf(...))

nr_repeats = 5
n_clusters = list(100, 1000, 10000, 100000)
ws = list(10, 100, 1000, 10000, 100000)

write("#clusters,window size,user time[s],elapsed time[s],#clustered in the end", file="timed_benchmark_results.csv")
write("#clusters,window size,mean elapsed time[s],#runs", file="timed_mean_benchmark_results.csv")

for (n in n_clusters) {
  filename <- sprintf("timed_data_%d.csv", n)
  for (w in ws) {
    if(w > n) break
    times <- c()
    for (repeatme in 1:nr_repeats) {
      raster <- DSC_SRaster(p=3.5, window_size = w)

      stream <- DSD_ReadCSV(filename)
      t <- system.time({ update(raster, stream, 500*n) })
      close_stream(stream)
      times <- c(times, t[3])

      end_clusters <- NROW(get_centers(raster, type='macro'))
      line <- sprintf("%d,%d,%.3f,%.3f,%d", n, w, t[1], t[3], end_clusters)
      cat(paste(line, "\n"))
      write(line, file="timed_benchmark_results.csv", append=TRUE)
    }
    mean_t <- sum(times) / length(times)
    line <- sprintf("%d,%d,%.3f,%d", n, w, mean_t, length(times))
    write(line, file="timed_mean_benchmark_results.csv", append=TRUE)
  }
}


treemap_brewer <-function (id,
                           area,
                           group,
                           color,
                           scale = NULL,
                           lab = c(TRUE, FALSE),
                           main = "Tree Map",
                           print = TRUE,
                           pal="Blues",
                           textcol="white",
                           linecol="grey")
{
    if (any(length(id) != length(area), length(id) != length(group),
        length(id) != length(color))) {
        stop("id, area, group, and color must be the same length.")
    }
    if (length(lab) == 1) {
        lab[2] <- lab[1]
    }
    stopifnot(all(!is.na(id)))
    data <- data.frame(label = id, group, area, color)
    data <- data[order(data$area, decreasing = TRUE), ]
    if (any(is.na(data$area) | is.na(data$group) | is.na(data$color))) {
        warning("Stocks with NAs for area, group, or color will not be shown")
        data <- subset(data, !is.na(area) & !is.na(group) & !is.na(color))
    }
    if (nrow(data) == 0) {
        stop("No records to display")
    }
    data$color.orig <- data$color
    if (is.null(scale)) {
        data$color <- data$color * 1/max(abs(data$color))
    }
    else {
        data$color <- sapply(data$color, function(x) {
            if (x/scale > 1)
                1
            else if (-1 > x/scale)
                -1
            else x/scale
        })
    }
    data.by.group <- split(data, data$group, drop = TRUE)
    group.data <- lapply(data.by.group, function(x) {
        sum(x[, 3])
    })
    group.data <- data.frame(area = as.numeric(group.data), label = names(group.data))
    group.data <- group.data[order(group.data$area, decreasing = TRUE),
        ]
    group.data$color <- rep(NULL, nrow(group.data))
    bpal <- c(brewer.pal(7, pal))
    color.ramp.pos <- colorRamp(bpal, space="Lab")
    color.ramp.neg <- colorRamp(bpal, space="Lab")
    color.ramp.rgb <- function(x) {
        col.mat <- mapply(function(x) {
            if (x < 0) {
                color.ramp.neg(abs(x))
            }
            else {
                color.ramp.pos(abs(x))
            }
        }, x)
        mapply(rgb, col.mat[1, ], col.mat[2, ], col.mat[3, ],
            max = 255)
    }
    add.viewport <- function(z, label, color, x.0, y.0, x.1,
        y.1) {
        for (i in 1:length(label)) {
            if (is.null(color[i])) {
                filler <- gpar(col = "blue", fill = "transparent",
                  cex = 1)
            }
            else {
                filler.col <- color.ramp.rgb(color[i])
                filler <- gpar(col = filler.col, fill = filler.col,
                  cex = 0.6)
            }
            new.viewport <- viewport(x = x.0[i], y = y.0[i],
                width = (x.1[i] - x.0[i]), height = (y.1[i] -
                  y.0[i]), default.units = "npc", just = c("left",
                  "bottom"), name = as.character(label[i]), clip = "on",
                gp = filler)
            z <- append(z, list(new.viewport))
        }
        z
    }
    squarified.treemap <- function(z, x = 0, y = 0, w = 1, h = 1,
        func = add.viewport, viewport.list) {
        cz <- cumsum(z$area)/sum(z$area)
        n <- which.min(abs(log(max(w/h, h/w) * sum(z$area) *
            ((cz^2)/z$area))))
        more <- n < length(z$area)
        a <- c(0, cz[1:n])/cz[n]
        if (h > w) {
            viewport.list <- func(viewport.list, z$label[1:n],
                z$color[1:n], x + w * a[1:(length(a) - 1)], rep(y,
                  n), x + w * a[-1], rep(y + h * cz[n], n))
            if (more) {
                viewport.list <- Recall(z[-(1:n), ], x, y + h *
                  cz[n], w, h * (1 - cz[n]), func, viewport.list)
            }
        }
        else {
            viewport.list <- func(viewport.list, z$label[1:n],
                z$color[1:n], rep(x, n), y + h * a[1:(length(a) -
                  1)], rep(x + w * cz[n], n), y + h * a[-1])
            if (more) {
                viewport.list <- Recall(z[-(1:n), ], x + w *
                  cz[n], y, w * (1 - cz[n]), h, func, viewport.list)
            }
        }
        viewport.list
    }
    map.viewport <- viewport(x = 0.05, y = 0.05, width = 0.9,
        height = 0.75, default.units = "npc", name = "MAP", just = c("left",
            "bottom"))
    map.tree <- gTree(vp = map.viewport, name = "MAP", children = gList(rectGrob(gp = gpar(col = "white"),
        name = "background")))
    group.viewports <- squarified.treemap(z = group.data, viewport.list = list())
    for (i in 1:length(group.viewports)) {
        this.group <- data.by.group[[group.data$label[i]]]
        this.data <- data.frame(this.group$area, this.group$label,
            this.group$color)
        names(this.data) <- c("area", "label", "color")
        stock.viewports <- squarified.treemap(z = this.data,
            viewport.list = list())
        group.tree <- gTree(vp = group.viewports[[i]], name = group.data$label[i])
        for (s in 1:length(stock.viewports)) {
            stock.tree <- gTree(vp = stock.viewports[[s]], name = this.data$label[s],
                children = gList(rectGrob(name = "color")))
            if (lab[2]) {
                stock.tree <- addGrob(stock.tree, textGrob(x = unit(1,
                  "lines"), y = unit(1, "npc") - unit(1, "lines"),
                  label = this.data$label[s], gp = gpar(col = textcol),
                  name = "label", just = c("left", "top")))
            }
            group.tree <- addGrob(group.tree, stock.tree)
        }
        group.tree <- addGrob(group.tree, rectGrob(gp = gpar(col = linecol),
            name = "border"))
        if (lab[1]) {
            group.tree <- addGrob(group.tree, textGrob(label = group.data$label[i],
                name = "label", gp = gpar(col = textcol)))
        }
        map.tree <- addGrob(map.tree, group.tree)
    }
    op <- options(digits = 1)
    top.viewport <- viewport(x = 0.05, y = 1, width = 0.9, height = 0.2,
        default.units = "npc", name = "TOP", , just = c("left",
            "top"))
    legend.ncols <- 51
    l.x <- (0:(legend.ncols - 1))/(legend.ncols)
    l.y <- unit(0.25, "npc")

    # If only positive values then legend should only be positive.
    if(all(data$color >= 0)){
      l.cols <- color.ramp.rgb(seq(0, 1, by = 1/(legend.ncols -
                                                    1)))
      if (is.null(scale)) {
        l.end <- max(abs(data$color.orig))
      }
      else {
        l.end <- scale
      }
      top.list <- gList(textGrob(label = main, y = unit(0.7, "npc"),
                                 just = c("center", "center"), gp = gpar(cex = 2)), segmentsGrob(x0 = seq(0,
                                 1, by = 0.25), y0 = unit(0.25, "npc"), x1 = seq(0, 1,
                                 by = 0.25), y1 = unit(0.2, "npc")), rectGrob(x = l.x,
                                 y = l.y, width = 1/legend.ncols, height = unit(1, "lines"),
                                 just = c("left", "bottom"), gp = gpar(col = NA, fill = l.cols),
                                 default.units = "npc"), textGrob(label = format(l.end *
                                 seq(0, 1, by = 0.25), trim = TRUE), x = seq(0, 1, by = 0.25),
                                 y = 0.1, default.units = "npc", just = c("center", "center"),
                                 gp = gpar(col = "black", cex = 0.8, fontface = "bold")))
    } else {
      l.cols <- color.ramp.rgb(seq(-1, 1, by = 2/(legend.ncols -
          1)))
      if (is.null(scale)) {
          l.end <- max(abs(data$color.orig))
      }
      else {
          l.end <- scale
      }
      top.list <- gList(textGrob(label = main, y = unit(0.7, "npc"),
          just = c("center", "center"), gp = gpar(cex = 2)), segmentsGrob(x0 = seq(0,
          1, by = 0.25), y0 = unit(0.25, "npc"), x1 = seq(0, 1,
          by = 0.25), y1 = unit(0.2, "npc")), rectGrob(x = l.x,
          y = l.y, width = 1/legend.ncols, height = unit(1, "lines"),
          just = c("left", "bottom"), gp = gpar(col = NA, fill = l.cols),
          default.units = "npc"), textGrob(label = format(l.end *
          seq(-1, 1, by = 0.5), trim = TRUE), x = seq(0, 1, by = 0.25),
          y = 0.1, default.units = "npc", just = c("center", "center"),
          gp = gpar(col = "black", cex = 0.8, fontface = "bold")))
    }

    options(op)
    top.tree <- gTree(vp = top.viewport, name = "TOP", children = top.list)
    mapmarket <- gTree(name = "MAPMARKET", children = gList(rectGrob(gp = gpar(col = "white",
        fill = "white"), name = "background"), top.tree,
        map.tree))
    if (print) {
        grid.newpage()
        grid.draw(mapmarket)
    }
    invisible(mapmarket)
}


# Loading the required libraries
if(!require("caret")) install.packages("caret")
if(!require("e1071")) install.packages("e1071")
if(!require("randomForest")) install.packages("randomForest")
if(!require("caTools")) install.packages("caTools")
if(!require("rpart")) install.packages("rpart")
if(!require("rpart.plot")) install.packages("rpart.plot")
if(!require("ggplot2")) install.packages("ggplot2")
if(!require("gridExtra")) install.packages("gridExtra")
if(!require("mice")) install.packages("mice")
if(!require("quantreg")) install.packages("quantreg")
if(!require("pbkrtest")) install.packages("pbkrtest")
if(!require("VIM")) install.packages("VIM")
if(!require("corrplot")) install.packages("corrplot")
if(!require("RColorBrewer")) install.packages("RColorBrewer")
if(!require("ROCR")) install.packages("ROCR")

set.seed(108)
work_path = "D:/vaibhav/trend nxt/topgear/R Community/Predictive Model Based Logistic Regression-LoanData"
setwd(work_path)
###Loading the csv,data preprocessing###

# Some NAs are coded as empty strings , hence converting them to NA
data <- read.csv("Loan_data.csv", header=T, na.strings=c(""," ","NA"))
original_data=data
head(data)
summary(data)
str(data)
nrow(data)
ncol(data)
any(is.na(data))
sum(is.na(data))
### HAving a look at missing data
md.pattern(data)
aggr_plot <- aggr(data, col=c('Blue','Yellow'), numbers=TRUE, sortVars=TRUE, labels=names(data), cex.axis=.5,cex.numbers=.9, gap=1, ylab=c("Histogram of missing data","Pattern"))

# dropping the ID column
Loan_ID = data$Loan_ID
data$Loan_ID = NULL
data$Credit_History=factor(data$Credit_History)

# Exploratory Analysis (Univariate)
p1= qplot(Gender,data = data,geom="auto")
p2 = qplot(Married, data=data,geom="auto")
p3 = qplot(Dependents,data = data,geom="auto")
p4 = qplot(Education,data = data,geom="auto")
p5 = qplot(Self_Employed,data = data,geom="auto")
p6 = qplot(Credit_History,data = data,geom="auto")
p7 = qplot(Property_Area,data = data,geom="auto")
p8 = qplot(Loan_Status,data = data,geom="auto")
grid.arrange(p1,p2,p3,p4,p5,p6,p7,p8,nrow=3,ncol=3)

# Imputation
NAsubset = data[c("Gender","Married","Dependents","Self_Employed","LoanAmount","Loan_Amount_Term","Credit_History")]
summary(NAsubset)
set.seed(108)
imputed=complete(mice(NAsubset))
data$Gender=imputed$Gender
data$Married=imputed$Married
data$Dependents=imputed$Dependents
data$Self_Employed=imputed$Self_Employed
data$LoanAmount=imputed$LoanAmount
data$Loan_Amount_Term=imputed$Loan_Amount_Term
data$Credit_History=imputed$Credit_History
summary(data)

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

plottable1=table(data$Loan_Status,data$Property_Area)
barplot(plottable1, main="Loan Approval vs Property Area", xlab="Property Area",col=c("LightBlue","LightYellow"),legend=rownames(plottable1),beside = TRUE)
plottable2=table(data$Loan_Status,data$Credit_History)
barplot(plottable2, main="Loan Approval vs Credit History", xlab="Credit History",col=c("LightBlue","LightYellow"),legend=rownames(plottable2),beside = TRUE)
plottable3=table(data$Loan_Status,data$Loan_Amount_Term)
barplot(plottable3, main="Loan Approval v sLoan Amount term", xlab="Loan amount term",col=c("LightBlue","LightYellow"),legend=rownames(plottable3),beside = TRUE)
plottable4=table(data$Loan_Status,data$Self_Employed)
barplot(plottable4, main="Loan Approval vs Self Employed", xlab="Self_Employed",col=c("LightBlue","LightYellow"),legend=rownames(plottable4),beside = TRUE)
plottable5=table(data$Loan_Status,data$Education)
barplot(plottable5, main="Loan Approval vs Education", xlab="Education",col=c("LightBlue","LightYellow"),legend=rownames(plottable5),beside = TRUE)
plottable6=table(data$Loan_Status,data$Dependents)
barplot(plottable6, main="Loan Approval vs Dependents", xlab="Dependents",col=c("LightBlue","LightYellow"),legend=rownames(plottable6),beside = TRUE)
plottable7=table(data$Loan_Status,data$Married)
barplot(plottable7, main="Loan Approval vs Marital Status", xlab="Marriage",col=c("LightBlue","LightYellow"),legend=rownames(plottable7),beside = TRUE)
plottable8=table(data$Loan_Status,data$Gender)
barplot(plottable8, main="Loan Approval vs Gender", xlab="Gender",col=c("LightBlue","LightYellow"),legend=rownames(plottable8),beside = TRUE)

# Correlation Analysis
numeric_features= data[c("ApplicantIncome","CoapplicantIncome","LoanAmount","Loan_Amount_Term")]
corTable=cor(numeric_features)
corTable
corrplot( cor(as.matrix(numeric_features), method = "pearson", use = "complete.obs") ,is.corr = FALSE, type = "lower", order = "hclust", tl.col = "black", tl.srt = 360)

# applicant income and loan amount correlated
# Feature Engineering
# Add a new feature has a coapplicant
coAppIn=data$CoapplicantIncome
for(i in data$CoapplicantIncome){
	data$CoapplicantIncome[data$CoapplicantIncome!=0.00] = 1.00
	}
data$Coapplicant= as.factor(data$CoapplicantIncome)
# data$CoapplicantIncome= coAppIn
## Training & Testing Set
set.seed(108)
split=sample.split(data$Loan_Status,SplitRatio = .7)
train=subset(data,split==T)
test=subset(data,split==F)

## Model Building & CV Using GLM
Status=glm(Loan_Status~Married+LoanAmount+Credit_History+Property_Area,data=train,family="binomial")
predGlm=predict(Status,type="response",newdata=test)
summary(Status)
# Computing accuracy
table(test$Loan_Status,predGlm>.5)
(27+123)/(27+123+31+4)
set.seed(108)
# Decision Tree Model
numFolds = trainControl( method = "cv", number = 10 )
cpGrid = expand.grid( .cp = seq(0.01,0.5,0.01))
train(Loan_Status~Married+LoanAmount+Credit_History+Property_Area,data=train,method="rpart",trControl=numFolds,tuneGrid=cpGrid)
decisionTreeModel=rpart(Loan_Status~Married+LoanAmount+Credit_History+Property_Area,data=train,method="class",cp=.37)
rpart.plot(decisionTreeModel,extra=104, box.palette="GnBu",branch.lty=3, shadow.col="gray", nn=TRUE)
## CV with rpart
predDT=predict(decisionTreeModel,newdata = test,type = "class")
table(test$Loan_Status,predDT)
# Accuracy
(27+123)/(27+123+31+4)

# RF Model
set.seed(108)
randomForestModel=randomForest(Loan_Status~Married+LoanAmount+Credit_History+Property_Area,data=train,ntree=50,nodesize=10)
predictRF=predict(randomForestModel,newdata=test)
table(test$Loan_Status,predictRF)
# Accuracy
(29+122)/(29+122+29+5)

# AUC Calculation
glm_ROC=predict(Status,test,type="response")
pred_glm=prediction(glm_ROC,test$Loan_Status)
perf_glm=performance(pred_glm,"tpr","fpr")

dt_ROC=predict(decisionTreeModel,test)
pred_dt=prediction(dt_ROC[,2],test$Loan_Status)
perf_dt=performance(pred_dt,"tpr","fpr")

RF_ROC=predict(randomForestModel,test,type="prob")
pred_RF=prediction(RF_ROC[,2],test$Loan_Status)
perf_RF=performance(pred_RF,"tpr","fpr")

auc_glm <- performance(pred_glm,"auc")
auc_glm <- round(as.numeric(auc_glm@y.values),3)
auc_dt <- performance(pred_dt,"auc")
auc_dt <- round(as.numeric(auc_dt@y.values),3)
auc_RF <- performance(pred_RF,"auc")
auc_RF <- round(as.numeric(auc_RF@y.values),3)
print(paste('AUC of Logistic Regression:',auc_glm))
print(paste('AUC of Decision Tree:',auc_dt))
print(paste('AUC of Random Forest:',auc_RF))

# ROC Curves
plot(perf_glm, main = "ROC curves for the models", col='blue')
plot(perf_dt,add=TRUE, col='red')
plot(perf_RF, add=TRUE, col='green3')
legend('bottom', c("Logistic Regression", "Decision Tree", "Random Forest"), fill = c('blue','red','green3'), bty='n')

R Community/Predictive Model Based Logistic Regression-LoanData/code.r


C05AWJ Example Program Results

With eps = 1.00e-03   root = 0.56715
With eps = 1.00e-04   root = 0.56715


#Calculates auto.arima() for Non-stationary models

rm(list=ls())
library(forecast) #for loading auto.arima() function

dukh<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_dhak_dhak_non_stat.txt",skip=1)

melinda<-as.character(dukh$V1)     #taking all non-stationary ids

rakshak<-NULL
for(humdum in melinda){

ek_tuhi<-read.table(paste("C:\\kindle_patrika\\PDB\\pdb_jugnu_bholu\\",humdum,".txt",sep=""))

chumma<-ts(ek_tuhi$V1) #complete time series

afsana<-auto.arima(chumma)

#taking parameter
arima_p<-length(afsana$model$phi)
arima_q<-length(afsana$model$theta)
arima_aic<-afsana$aic
arima_aicc<-afsana$aicc

bhutan<-cbind(humdum,arima_p,arima_q,arima_aic,arima_aicc,deparse.level=0)
rakshak<-rbind(rakshak,bhutan,deparse.level=0)

}        #for-file iterating

write.table(rakshak,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Non_stationary\\Autofit_arma_non_stationary_TS\\Auto_arima_non_stat_TS.txt",col.names=c("PDB_id","arima_p","arima_q","arima_aic","arima_aicc"),row.names=F)


#clearing the workspace
rm(list=ls())
# Uncomment to set the script directory as the working directory
# setwd(dirname(sys.frame(tail(grep('source',sys.calls()),n=1))$ofile))
graphics.off()

require(deSolve)
require(ggplot2)
require(gdata)
require(foreach)
require(doParallel)

<user_def>

# For documentation explaining how to modify the commands below see
# the simulation vignette:
# vignette(package="ubiquity", topic="Simulation")
# Or the simulation tutorial at the bottom of this page:
# http://r.ubiquity.tools/

# --------------------------------------------------------------
# By default the system uses the stand-alone libraries generated
# by the ShinyApp during export:
source("<libfile>");
# Loading the system information
cfg = system_fetch_cfg()
# --------------------------------------------------------------
# # Comment out the block above above then uncomment this block
# # to rebuild the system and incorporate modifications to the
# # system file into the simulation results
# if("ubiquity" %in% rownames(installed.packages())){require(ubiquity)} else
# {source(file.path('library', 'r_general', 'ubiquity.R')) }
# # Rebuilding the system (R scripts and compiling C code)
# cfg = build_system(system_file="<system_file>",
#                    output_directory     = file.path(".", "output"),
#                    temporary_directory  = file.path(".", "transient"))
# --------------------------------------------------------------

cfg = system_select_set(cfg, "<pset>")

<parameters>
# The previous statement sets 'parameters' to the values
# in the currently selected parameter set. To overwrite
# a specific parameter uncomment the following statement
# and replace PNAME with the name of the parameter
# and VALUE with the desired value:
#
# parameters$PNAME = VALUE;

# Setting simulation options:
<options>

# Forcing the r-script to be used
cfg=system_set_option(cfg, group  = "simulation",
                           option = "integrate_with",
                           value  = "r-file")

<bheader><bolus><rheader><infusion_rates><cheader><covariates><iheader><iiv>

# To view the system state before the simulations are run
# uncomment the following line:
# cat(system_view(cfg))

# --------------------------------------------------------------
# Running simulation(s)
<sim>

<save_csv>
# --------------------------------------------------------------

# --------------------------------------------------------------
# plotting timecourse
<plot_timecourse><plot_paramdist>
# --------------------------------------------------------------


# Function for calculate phytosociological table
# Version: 1.2.0
# https://github.com/MarioJose/r-functions/tree/master/phyto

phyto <- function(x, filter = NULL, area = NULL, criteria = NULL, measure = NULL, incDead = TRUE, nmDead = "Dead", diversity = TRUE, evenness = TRUE){
  # x must be data frame with: plot, family, specie, diameter, (height).
  #   It must be in this order, but not necessarily with this names. Height is
  #   optional

  # Checking input
  # ++++++++++++++

  if(!is.data.frame(x)){
    stop("'x' must be a data frame")
  } else {
    if(dim(x)[2] < 4 | dim(x)[2] > 5){
      stop("Your data frame must have at least 4 columns with the follow data at the same order: 'plot', 'family', 'specie', 'diameter'. The column 'height' is optional")
    }
  }

  if(is.null(filter)){
    stop("You must inform the filter to summarization: 'plot', 'family', 'genus', 'specie'")
  } else {
    if(!(filter %in% c("plot", "family", "genus", "specie"))){
      stop("You must inform one of the follow option to filter: 'plot', 'family', 'genus', 'specie'")
    }
  }

  if(is.null(area)){
    stop("You must inform the area sampled")
  }

  if(is.null(criteria)){
    stop("You must inform the diameter criteria for individual inclusion")
  }

  if(is.null(measure)){
    stop("You must inform the measure: \"d\" = diameter; \"c\" = circumference")
  } else {
    if(!(measure %in% c("d","c"))){
      stop("You must inform one of the follow option to measure: \"d\" = diameter; \"c\"c = circumference")
    }
  }

  # Convert family and species column to character
  x[ ,2] <- as.character(x[ ,2])
  x[ ,3] <- as.character(x[ ,3])

  # Remove dead individuals (column 'specie')
  if(!incDead){
    didx <- grep(nmDead , x[ ,3])
    x <- x[-didx, ]
    print(paste("Removed", length(didx), "individual named as", nmDead))
  }

  # Functions
  # +++++++++

  # Split multiple diameter or height and return diameter of total basal area of
  # each individual or mean height of each individual
  splitMultiple <- function(x, m){

    if(!is.numeric(x)) tmp <- as.numeric(unlist(strsplit(x , "+", TRUE)))
    else tmp <- x

    # Expression used in conversion
    # area = (pi*diameter^2)/4
    # area = (circumference^2)/(4*pi)
    # diameter = sqrt((4*area)/pi)

    # Return diameter of total basal area
    if(m == "d") out <- sqrt(4 * sum((pi * (tmp ^ 2)) / 4) / pi)

    # Convert circumference and return diameter of total basal area
    if(m == "c") out <- sqrt(4 * sum((tmp ^ 2) / (4 * pi)) / pi)

    # Return mean of height
    if(m == "h") out <- mean(tmp)

    return(out)
  }

  # Shannon and Simpson diversity index
  shannon_fn <- function(x){
    p <- x / sum(x)
    H <- -sum(p * log(p))
    # Variance as Hutcheson (1970)
    varH <- ((sum(p * (log(p)^2)) - sum(p * log(p))^2) / sum(x)) + ((length(x) - 1) / (2 * (length(x)^2)))

    return(c(H = H, varH = varH))
  }

  simpson_fn <- function(x, var = FALSE){
    # As Simpson (1949)
    N <- sum(x)
    p <- x / N
    D <- sum(x * (x - 1)) / (N * (N - 1))
    varD <- ( 4*N*(N - 1)*(N - 2)*sum(p^3) + 2*N*(N - 1)*sum(p^2) - 2*N*(N - 1)*(2*N - 3)*(sum(p^2)^2) ) / (N*(N - 1))^2
    # if N be very large, approximately
    #varD <- (4/N) * ( (sum(p^3)) - (sum(p^2))^2 );

    return(c(D = D, varD = varD))
  }

  # Evar and E1/D evenness index
  evenness_fn <- function(x){
    # As Smith & Wilson (1996)

    mulog <- sum(log(x)) / length(x)
    # 0 = minimum eveness
    Evar <- 1 - (2 / pi) * atan( sum((log(x) - mulog)^2) / length(x) )
    E1D <- (1 / simpson_fn(x)[["D"]]) / length(x)

    return(c(Evar = Evar, E1D = E1D))
  }

  # Checking data
  # +++++++++++++

  # Columns names
  colnames(x) <- c("plot", "family", "specie", "diameter", "height")[1:dim(x)[2]]

  # Create column with genus
  x$genus <- sapply(x$specie, function(x) strsplit(x, " ")[[1]][1])

  # Order data frame
  x <- x[, c(1:2, dim(x)[2], 3:(dim(x)[2] - 1))]

  # Standardize measure to diameter. Split multiples measures and return
  # diameter of total basal area to individual
  if(is.character(x$diameter) | is.factor(x$diameter))
    x$diameter <- sapply(as.character(x$diameter), splitMultiple, m = measure)
  else if(measure == "c") x$diameter <- x$diameter / pi

  # Standardize height. Split multiples measures and return mean of height to
  #   individual
  if(dim(x)[2] == 6)
    if(is.character(x$height) | is.factor(x$height))
      x$height <- sapply(as.character(x$height), splitMultiple, m = "h")

  # Filter by inclusion criteria
  cidx <- x$diameter >= criteria
  x <- x[cidx, ]

  if(dim(x)[1] < 1) stop("Your criteria removed all individuals")
  else print(paste("Removed", length(cidx) - sum(cidx), "individual(s) by criteria", criteria))

  # Calculate parameters
  # ++++++++++++++++++++

  # Create output data frame
  out <- aggregate(list(nInd = x$specie), by = list(c1 = x[ ,filter]), FUN = length)
  colnames(out) <- c(filter, "nInd")

  # Add families
  if(filter %in% c("genus", "specie")){
    tf <- aggregate(list(nInd = x[ ,filter]), by = list(family = x$family, filter = x[ ,filter]), FUN = length)
    out$family <- tf$family[match(out[ ,filter], tf$filter)]
    out <- out[ ,c("family", filter, "nInd")]
  }

  if(filter == "plot"){
    # Number of families per plot
    out[ ,"nFamilies"] <- aggregate(x$family, by = list(x$plot), FUN = function(x){length(unique(x))})$x

    # Number of genera per plot
    out[ ,"nGenera"] <- aggregate(x$genus, by = list(x$plot), FUN = function(x){length(unique(x))})$x

    # Number of species per plot
    out[ ,"nSpecies"] <- aggregate(x$specie, by = list(x$plot), FUN = function(x){length(unique(x))})$x

    if(diversity){
      out[ ,c("H", "varH")] <- aggregate(x$specie, by = list(x$plot), FUN = function(x){shannon_fn(table(as.character(x)))})[[2]]
      out[ ,c("D", "varD")] <- aggregate(x$specie, by = list(x$plot), FUN = function(x){simpson_fn(table(as.character(x)))})[[2]]
    }

    if(evenness)
      out[ ,c("Evar","E1D")] <- aggregate(x$specie, by = list(x$plot), FUN = function(x){evenness_fn(table(as.character(x)))})[[2]]

  }

  if(filter == "family"){
    # Number of genera per family
    out[ ,"nGenera"] <- aggregate(x$genus, by = list(x$family), FUN = function(x){length(unique(x))})$x

    # Number of species per family
    out[ ,"nSpecies"] <- aggregate(x$specie, by = list(x$family), FUN = function(x){length(unique(x))})$x
  }

  if(filter == "genus"){
    # Number of species per genus
    out[ ,"nSpecies"] <- aggregate(x$specie, by = list(x$genus), FUN = function(x){length(unique(x))})$x
  }

  # Convert diameter measure from centimetres to meters
  x$diameter <- x$diameter / 100
  out[ ,"tBasalArea"] <- aggregate(x$diameter, by = list(x[ ,filter]), FUN = function(x){sum((pi * (x^2)) / 4)})$x

  if(filter != "plot"){
    out[ ,"AbsDens"] <- out$nInd / area
    out[ ,"RelDens"] <- (out$nInd / sum(out$nInd)) * 100

    # Species or genera by plot
    tmp <- aggregate(list(nInd = x[ ,filter]), by = list(filter = x[ ,filter], plot=x$plot), FUN = length)
    out[ ,"nPlot"] <- aggregate(tmp$filter, by = list(tmp$filter), FUN = length)$x
    out[ ,"AbsFreq"] <- (out[ ,"nPlot"] / length(unique(x$plot))) * 100
    out[ ,"RelFreq"] <- (out$AbsFreq / sum(out$AbsFreq)) * 100

    out[ ,"AbsDom"] <-  out[ ,"tBasalArea"] / area
    out[ ,"RelDom"] <- (out[ ,"tBasalArea"] / sum(out[ ,"tBasalArea"])) * 100

    out[ ,"IVI"] <- out$RelDens + out$RelFreq + out$RelDom
    out[ ,"CVI"] <- out$RelDens + out$RelDom
  }

  if(length(x[1, ]) == 6){
    out[ ,"meanHeight"] <- aggregate(x[ ,6], by = list(x[ ,filter]), FUN = mean)$x
    out[ ,"sdHeight"] <- aggregate(x[ ,6], by = list(x[ ,filter]), FUN = sd)$x
  }

  return(out)
}


#!/usr/bin/env Rscript
# R-script to extract the interesting activity data from a simulation run
arguments <- commandArgs(trailingOnly=TRUE)
fbase  <- arguments[1]

outputDir <- paste0(fbase, "output")
outputFile <- paste0(fbase, "SignalStrategy.csv")

generations <- list.dirs(outputDir, recursive = FALSE, full.names = FALSE)

calcGA <- function(generation) {
    genDir <- paste0(outputDir, "/", generation)
    groups <- list.dirs(genDir, recursive = FALSE, full.names = FALSE)
    data <- lapply(groups, calcGroupActivity, generation = generation)
    data <- do.call(rbind, data)
    return(data)
}

calcGroupActivity <- function(generation, group) {
    groupDir <- paste0(outputDir, "/", generation, "/", group)
    evals <- list.dirs(groupDir, recursive = FALSE)
    data <- lapply(evals, calcActivity)
    mean <- Reduce("+", data) / length(data)
    result <- c(generation, group, mean)
    return(result)
}

calcActivity <- function(evalDir) {
    agentFiles <- list.files(evalDir, pattern = "\\d+_agent.csv", full.names = TRUE)
    data <- lapply(agentFiles, extractValues)
    data <- do.call(rbind, data) # Join Agents

    nearPoison <- data[data$currentReward < 0, ]
    timeNearPoison <- nrow(nearPoison)
    lightNearPoison <- nrow(nearPoison[nearPoison$light == 'true', ])

    nearFood <- data[data$currentReward > 0, ]
    timeNearFood <- nrow(nearFood)
    lightNearFood <- nrow(nearFood[nearFood$light == 'true', ])

    agentCount <- length(agentFiles)

    f <- lightNearFood / timeNearFood
    p <- lightNearPoison / timeNearPoison

    if(is.nan(f)) {
        f <- 0
    }

    if(is.nan(p)) {
        p <- 0
    }

    signalStrategy <- (f - p) / agentCount
    return(signalStrategy)
}

# Get AgentID, CurrentReward, Light where currentReward != 0
extractValues <- function(file) {
    tmp <- read.csv(file, stringsAsFactors = FALSE, sep=",", strip.white=TRUE)
    tmp <- tmp[c("currentReward", "light")]
    tmp$AgentID <- extractID(file)
    tmp <- tmp[tmp$currentReward != 0, ]
    return(tmp)
}

extractID <- function(path) {
    split_name <- strsplit(path, "/")[[1]]
    filename <- (tail(split_name, 1))[1]
    id <- head(strsplit(filename, "_"))[[1]][1]
    return(id)
}

result <- lapply(generations, calcGA)
result <- do.call(rbind, result)
colnames(result) <- c("Generation", "Group", "SignalStrategy")
result <- as.data.frame(result)
write.table(result, file=outputFile, sep=", ", row.names=FALSE, quote = FALSE)


options( scipen = 20 )
x = read.csv("../../sampledata/linux/maps4274.txt.csv", header = TRUE, sep = ",", colClasses = c("character", "numeric"))
x[,2] = sapply(x[,2], function(a) { a/1048576 })
x[order(x[,2], decreasing=TRUE), ]


# generate sample data files for development

library(detourr)

set.seed(1)

p <- detour(tourr::flea, tour_aes(projection = where(is.numeric), color = species, label = species)) |>
  display_scatter()

writeLines(
  jsonlite::toJSON(unclass(p$x), auto_unbox = TRUE, null = "null"),
  "../dev/display_scatter_2d/static/sample_data.json"
)

set.seed(1)

p <- detour(tourr::flea, tour_aes(projection = where(is.numeric), color = species, label = species)) |>
  tour_path(grand_tour(3)) |>
  display_scatter()

writeLines(
  jsonlite::toJSON(unclass(p$x), auto_unbox = TRUE, null = "null"),
  "../dev/display_scatter_3d/static/sample_data.json"
)


## Set of useful R functions for general use in plotting, analyzing and
## converting.
##
## Author: Thomas Bryce Kelly (tbk14 at fsu.edu)
## https://urldefense.proofpoint.com/v2/url?u=http-3A__about.tkelly.org_&d=DwIGAg&c=MNHwOqQ8N1u91SoMLfIblwuGXKgp50OPUXjl8uRAbak&r=OqmwiruNRrBVjwRDz_rOIW4lt52uD5YZ94BCkXBkcSU&m=A8ifeaSsB7OUd2OIZ_RVFtX7Y6rtEsOOC77zcbZ0C6s&s=-_9Yx_KpWVvj1uMgQs3TVGvsru9RvaB7BSu7mj9usJQ&e=
##
## Dept of Earth, Ocean & Atmospherical Sciences
## Florida State University
##
## Center for Ocean & Atmospheric Prediction Studies
## Florida State University
##
## National High Magnetic Field Laboratory
## Florida State University

##############################
## Date Times ################
##############################

## Helper function for converting the date time stamps.
conv.time.excel = function (x, tz = "GMT") {
    as.POSIXct(x*86400, origin = "1899-12-30 00:00:00", tz = tz)
}

conv.time.unix = function(x, tz='GMT') {
    as.POSIXct(x, origin="1970-01-01", tz=tz)
}

conv.time.matlab = function (x, tz = "GMT") {
    as.POSIXct((x - 1)*86400, origin = "0000-01-01", tz = tz)
}

## Find the indicies of the closest times for each entry of x
which.closest.time = function(x, y) {
    if (length(y) > 1) {
        l = c()
        for (i in 1:length(x)) {
            l.new = which.min(as.numeric(difftime(x[i], y, units='mins'))^2)
            l = c(l, l.new)
        }
    } else {
        l = which.min(as.numeric(difftime(x, y, units='mins'))^2)
    }
    l
}

which.unique = function(x) {
    which(!duplicated(x))
}

##############################
## Plotting ################
##############################

get.pal = function(n=10, pal='ocean.haline', rev = FALSE) {
    pal = do.call(pal, list(n = n))

    if (rev) {
        pal = rev(pal)
    }
    pal
}

make.pal = function(x, n = 10, min = NA, max = NA, pal='ocean.haline', rev = FALSE) {
    cols = get.pal(n+1, pal = pal, rev = rev)

    if (is.na(min)) {  ## set a minimum
        min = base::min(x, na.rm=TRUE)
    }
    if (is.na(max)) { ## Set a maximum
        max = base::max(x, na.rm=TRUE)
    }

    ## Force min and max
    x[x < min] = min
    x[x > max] = max

    x = (x-min) * n / (max-min) ## Scale so x falls between [0 -> n]
    cols[floor(x)+1] # return the colors
}

make.pal.custom = function(x, n = 10, pal = c('white', 'blue'),  min = NA, max = NA, rev = FALSE) {
    cols = colorRampPalette(pal)(n)

    if (is.na(min)) {  ## set a minimum
        min = base::min(x, na.rm=TRUE)
    }
    if (is.na(max)) { ## Set a maximum
        max = base::max(x, na.rm=TRUE)
    }

    ## Force min and max
    x[x < min] = min
    x[x > max] = max

    x = (x-min) * n / (max-min) ## Scale so x falls between [0 -> n]
    cols[floor(x)+1] # return the colors

}

## make div and seq for numeric values
make.div.pal = function(x, n = 10, min = NA, max = NA, pal = 'coolwarm', rev = FALSE) {
    make.pal(x, n, min, max, pal, rev)
}

make.seq.pal = function(x, n = 10, min = NA, max = NA, pal = 'ocean.haline', rev = FALSE) {
    make.pal(x, n, min, max, pal, rev)
}

## Make pal for categorical data
make.qual.pal = function(x=100, pal='tol', rev = FALSE) {

    ## Determine numeric values
    a = sapply(x, function(xx) {which(xx == unique(x))})

    cols = get.pal(n = length(unique(x)), pal = pal, rev = rev)
    cols[a]
}

add.colorbar = function(min, max, X1, Y1, X2, Y2, pch=15, cex=1, cex.text=1, col.bg=NA,  n=10,
                        pal='ocean.algae', text.dist = 0.15, rev = FALSE, log = FALSE, base = 10,
                        n.tick = 5, cex.tick = 1, col.tick = 'black') {

    x = seq(X1, X2, length.out = 200)
    y = seq(Y1, Y2, length.out = 200)

    if (!is.na(col.bg)) {
        points(x, y, col = col.bg, cex = cex + 0.2, pch=pch)
    }

    col = make.pal(x = c(1:200), n = n, pal = pal, rev = rev)

    if (log) {
        k = c(1:9)
        k = c(k/1000, k/100, k/10, k, 10*k, 100 *k , 1000 * k, 1e4*k)
        k = k[which( k >= min & k <= max)]
        k = log(k, base)
        print(k)

        k.min = log(min, base)
        k.max = log(max, base)

        k.x = approx(c(1:length(x)), x, xout = length(x) * (k - k.min) / (k.max - k.min))$y
        k.y = approx(c(1:length(x)), y, xout = length(x) * (k - k.min) / (k.max - k.min))$y

        points(k.x, k.y, pch = 3, cex = cex.tick, col = col.tick)

    } else if (!is.na(n.tick)) {
        k = c(0:n.tick)

        k.x = approx(c(1:length(x)), x, xout = length(x) * k / n.tick, rule = 2)$y
        k.y = approx(c(1:length(x)), y, xout = length(x) * k / n.tick, rule = 2)$y

        points(k.x, k.y, pch = 3, cex = cex.tick, col = col.tick)
    }

    ## Color bar points
    points(x, y, cex = cex, pch=pch, col = col)

    text(X1 - (X2 - X1) * text.dist, Y1 - (Y2 - Y1) * text.dist, min, cex = cex.text)
    text(X2 + (X2 - X1) * text.dist, Y2 + (Y2 - Y1) * text.dist, max, cex = cex.text)
}

add.colorbar.log = function(min, max, X1, Y1, X2, Y2, base, pch=15, cex=1, cex.text=1, col.bg=NA,  n=10,
                        pal='ocean.algae', text.dist = 0.15, rev = FALSE, n.tick = 5, cex.tick = 1, col.tick = 'black') {

  x = seq(X1, X2, length.out = 200)
  y = seq(Y1, Y2, length.out = 200)

  if (!is.na(col.bg)) {
    points(x, y, col = col.bg, cex = cex + 0.2, pch=pch)
  }

  col = make.pal(x = base^seq(log(min, base), log(max, base), length.out = 200),
                 n = n, pal = pal, rev = rev)

    if (!is.na(n.tick)) {
        k = c(0:n.tick)

        k.x = approx(c(1:length(x)), x, xout = length(x) * k / n.tick, rule = 2)$y
        k.y = approx(c(1:length(x)), y, xout = length(x) * k / n.tick, rule = 2)$y

        points(k.x, k.y, pch = 3, cex = cex.tick, col = col.tick)
    }

  points(x, y, col = col, cex = cex, pch=pch)

  text(X1 - (X2 - X1) * text.dist, Y1 - (Y2 - Y1) * text.dist, min, cex = cex.text)
  text(X2 + (X2 - X1) * text.dist, Y2 + (Y2 - Y1) * text.dist, max, cex = cex.text)
}

##############################
## Mapping (cartesian) #######
##############################

plot.map = function(lon, lat, main = '', xlab='Longitude', ylab='Latitude', col='black', pch=20,
                    cex=1, zoom = 0, lat.offset = 0, lon.offset = 0, bounds = NULL) {

    if (is.null(bounds)) {
        lat.max = max(lat, na.rm = TRUE) + zoom + lat.offset
        lat.min = min(lat, na.rm = TRUE) - zoom + lat.offset
        lon.max = max(lon, na.rm = TRUE) + zoom + lon.offset
        lon.min = min(lon, na.rm = TRUE) - zoom + lon.offset
    } else{
        lat.min = bounds[3]
        lat.max = bounds[4]
        lon.min = bounds[1]
        lon.max = bounds[2]
    }
    newmap <- getMap(resolution = "high")

    plot(newmap, xlim = c(lon.min, lon.max), ylim = c(lat.min, lat.max), asp = 1)
    points(lon, lat, main = main, col = col, xlab = xlab, ylab = ylab, pch = pch, cex = cex)
}

add.map.grid = function(by = 1, axis.by = 2, col='#00000020') {

    for (i in seq(-180, 180, by=by)) {
        lines(rep(i,2), c(0,60), lty=2, col=col)
    }

    for (i in seq(-90, 90, by=by)) {
        lines(c(-200,-100), rep(i,2), lty=2, col=col)
    }

    axis(side = 2, at = seq(10, 60, by = axis.by))
    axis(side = 1, at = seq(-200, -100, by = axis.by))
    axis(side = 4, at = seq(10, 60, by = axis.by))
    axis(side = 3, at = seq(-200, -100, by = axis.by))
}

##############################
## Statistics ################
##############################

jackknife = function(x, y, n=1000) {

    k = c(which(is.na(x)), which(is.na(y)))
    if (length(k) > 0) {
        k = unique(k)
        x = x[-k]
        y = y[-k]
    }

    res = data.frame(m=0, b=0)

    for (i in 1:n) {
        l = sample(1:length(x), replace = TRUE)
        temp.model = lm(y[l] ~ x[l])
        res = rbind(res, c(coef(temp.model)[2], coef(temp.model)[1]))
    }
    res= res[-1,]
    res
}

bootstrap = function(x, s.x, y, s.y, n = 1000) {

    k = c(which(is.na(x)), which(is.na(s.x)), which(is.na(y)), which(is.na(s.y)))
    if (length(k) > 0) {
        k = unique(k)
        x = x[-k]
        s.x = s.x[-k]
        y = y[-k]
        s.y = s.y[-k]
    }

    result = data.frame(m = 0, b = 0)
    num.x = length(x)

    for (i in 1:n) {
        l = sample(x = c(1:num.x), replace = TRUE)

        ## Generate random sampling
        temp.x = rnorm(num.x, x[l], s.x[l])
        temp.y = rnorm(num.x, y[l], s.y[l])

        model = lm(temp.y ~ temp.x)

        result = rbind(result, rev(coefficients(model)))
    }
    result = result[-1,]
    result
}

bootstrap.2 = function(x, s.x, y, s.y, n = 1000) {

    k = c(which(is.na(x)), which(is.na(s.x)), which(is.na(y)), which(is.na(s.y)))
    if (length(k) > 0) {
        k = unique(k)
        x = x[-k]
        s.x = s.x[-k]
        y = y[-k]
        s.y = s.y[-k]
    }

    result = data.frame(m = 0, b = 0)
    num.x = length(x)

    for (i in 1:n) {
        l = sample(x = c(1:num.x), size = num.x, replace = TRUE)

        ## Generate random sampling
        temp.x = rnorm(num.x, x[l], s.x[l])
        temp.y = rnorm(num.x, y[l], s.y[l])

        model = lmodel2(temp.y ~ temp.x, nperm = 0)

        result = rbind(result, as.numeric(model$regression.results[3,c(3,2)]))
    }
    result = result[-1,]
    result
}

bootstrap.lmodel2.both = function(x, s.x, y, s.y, n=100) {
    mod = lmodel2(y ~ x)$regression.results
    results.OLS = mod[1,c(2:3)]
    results.MA = mod[2,c(2:3)]

    for (i in 1:n) {
        new.x = rnorm(length(x), x, s.x)
        new.y = rnorm(length(y), y, s.y)

        mod = lmodel2(new.y ~ new.x)$regression.results

        results.OLS = rbind(results.OLS, mod[1,c(2:3)])
        results.MA = rbind(results.MA, mod[2,c(2:3)])
    }
    list(OLS = results.OLS, MA = results.MA)
}

#### CONFIDENCE AND TRENDLINES

add.boot.trendline.median = function(model, new.x, col = 'black', lty = 2) {
    m = median(model$m, rm.na = TRUE)
    b = median(model$b, na.rm = TRUE)
    lines(new.x, new.x * m + b, col = col, lty = lty)
}

add.boot.trendline = function(model, new.x, col = 'black', lty = 2, lwd=1) {
    res = c()
    for (i in 1:length(new.x)) {
        res = c(res, median(model$m * new.x[i] + model$b, na.rm=TRUE))
    }
    lines(new.x, res, col = col, lty = lty, lwd = lwd)
}

add.boot.trendline2 = function(res, new.x, col = 'black', lty = 2) {
    m = mean(res[,2], rm.na = TRUE)
    b = mean(res[,1], na.rm = TRUE)
    lines(new.x, new.x * m + b, col = col, lty = lty)
}

add.lm.conf = function(x, name, model, col = '#50505030', level = 0.95, log = FALSE) {
    if(!log) {
        dat = data.frame(a = c(1:length(x)))
        dat[[name]] = x
        pred = predict(model, interval='confidence', newdata = dat, level = level)
        polygon(c(x,rev(x)), c(pred[,"lwr"], rev(pred[,"upr"])), border = NA, col = col)
    } else {
        dat = data.frame(a = c(1:length(x)))
        dat[[name]] = x
        pred = predict(model, interval='confidence', newdata = dat, level = level)
        polygon(c(exp(x),rev(exp(x))), c(pred[,"lwr"], rev(pred[,"upr"])), border = NA, col = col)
    }
}

add.boot.conf = function(model, new.x = c(-1e3:1e3), col = '#55555540', conf = c(0.025, 0.975),
                         border = FALSE, trendline = FALSE) {
    x.upper = new.x
    y.upper = c()
    y.lower = c()
    y.mid = c()

    for (x in x.upper) {
        y = x * model$m + model$b
        y.mid = c(y.mid, median(y))

        ## Quantiles
        y = quantile(y, conf)
        y.lower = c(y.lower, y[1])
        y.upper = c(y.upper, y[2])
    }

    polygon(x = c(x.upper, rev(x.upper)), y = c(y.upper, rev(y.lower)), col = col, border = border)

    if (trendline) {
        lines(x.upper, y.mid, lty=2)
    }
}

get.boot.vals = function(model, x, conf = 0.5) {
    y = rep(0, length(x))

    for (i in 1:length(y)) {
        yy = x[i] * model$m + model$b
        y[i] = quantile(yy, probs = conf, na.rm = TRUE)[[1]]
    }

    y
}

add.boot.trendline.sig = function(model, new.x, p = 0.01, sig = 0, lty = 2, lwd = 1, col = 'black') {
    if(ecdf(model$m)(sig) < p | ecdf(model$m)(sig) > 1 - p) {
        add.boot.trendline(model, new.x, col = col, lty = lty, lwd = lwd)
    }
}

####################
#### Statistics ####
####################

#### Calc R Squared
calc.boot.r.squared = function(model, x, y) {
    ## rm NAs
    l = which(is.na(x) | is.na(y))
    if (length(l) > 0) {
        x = x[-l]
        y = y[-l]
    }

    ## R2 = 1 - SSR / SS
    1 - boot.ssr(model = model, x = x, y = y) / calc.boot.ss(y = y)
}

#### Sum of Squared Residuals
calc.boot.ssr = function(model, x, y) {
    ## rm NAs
    l = which(is.na(x) | is.na(y))
    if (length(l) > 0) {
        x = x[-l]
        y = y[-l]
    }

    ## SSR
    y.pred = rep(0, length(x))

    for (i in 1:length(x)) {
        y.pred[i] = median(model$m) * x[i] + median(model$b)
    }

    sum((y.pred - y)^2)
}

#### Sum of Squares
calc.boot.ss = function(y) {
    y = y[!is.na(y)] ## Remove NAs

    ## Calc Total Sum of Squares
    sum((mean(y) - y)^2)
}

calc.r.squared = function(x, y){
    1 - sum((x - y)^2) / sum((x - mean(x))^2)
}

########################
#### Misc Plot Stuff ###
########################

add.error.bars = function(x, s.x, y, s.y, col = 'black') {

    if (length(s.x) == 1) {
        s.x = rep(s.x, length(x))
    }
    if (length(s.y) == 1) {
        s.y = rep(s.y, length(y))
    }

    for (i in 1:length(x)) {
        lines(x = c(x[i], x[i]),
              y = c(y[i] + s.y[i], y[i] - s.y[i]),
              col = col)

        lines(x = c(x[i] + s.x[i], x[i] - s.x[i]),
              y = c(y[i], y[i]),
              col = col)
    }
}

add.error.bars.logx = function(x, s.x, y, s.y, base, col = 'black') {

  if (length(s.x) == 1) {
    s.x = rep(s.x, length(x))
  }
  if (length(s.y) == 1) {
    s.y = rep(s.y, length(y))
  }

  ## Remove NAs
  l = !is.na(x) & !is.na(y)
  x = x[l]
  s.x = s.x[l]
  y = y[l]
  s.y = s.y[l]

  for (i in 1:length(x)) {
    if(!is.na(s.y[i])) {
      lines(x = rep(log(x[i], base), 2),
            y = c(y[i] + s.y[i], y[i] - s.y[i]),
            col = col)
    }

    if(!is.na(s.x[i])) {
      lines(x = log(c(x[i] + s.x[i], x[i] - s.x[i]), base),
            y = rep(y[i], 2),
            col = col)
    }
  }
}

add.error.bars.logy = function(x, s.x, y, s.y, base, col = 'black') {

  if (length(s.x) == 1) {
    s.x = rep(s.x, length(x))
  }
  if (length(s.y) == 1) {
    s.y = rep(s.y, length(y))
  }

  ## Remove NAs
  l = !is.na(x) & !is.na(y)
  x = x[l]
  s.x = s.x[l]
  y = y[l]
  s.y = s.y[l]

  for (i in 1:length(x)) {
    if(!is.na(s.y[i])) {
      lines(x = rep(x[i], 2),
            y = log(c(y[i] + s.y[i], y[i] - s.y[i]), base),
            col = col)
    }

    if(!is.na(s.x[i])) {
      lines(x = c(x[i] + s.x[i], x[i] - s.x[i]),
            y = rep(log(y[i], base), 2),
            col = col)
    }
  }
}

add.one.to.one = function(scale = 1e7, lty=2, col='#00000080', slope = 1) {
    lines(c(-scale, scale), c(-scale*slope, scale*slope), lty=lty, col=col)
}

## Install the package if needed:
#install.packages('cmocean', repos='https://urldefense.proofpoint.com/v2/url?u=http-3A__cran.us.r-2Dproject.org&d=DwIGAg&c=MNHwOqQ8N1u91SoMLfIblwuGXKgp50OPUXjl8uRAbak&r=OqmwiruNRrBVjwRDz_rOIW4lt52uD5YZ94BCkXBkcSU&m=A8ifeaSsB7OUd2OIZ_RVFtX7Y6rtEsOOC77zcbZ0C6s&s=HV6H_jB_gohewcGJehHluAOL9hXKAyWQt63wTOeePk0&e=')

## Load the relevent packages
library(ncdf4)  # For reading in the NCEP wind fields
#library(R.matlab)  # If you need to read in matlab .mat files
library(openxlsx)  # If you need to read in .xlsx files
library(RColorBrewer)
library(compiler)  # required for JIT (below)
library(rworldmap)
library(rworldxtra)
library(rgdal)
library(lmodel2)
library(pals)

## Enable compilation (speed gain?)
enableJIT(3)


# Authors: Mark Emmerson and Maja Ilic
# Last update: November 2019

# This is a script to explore and plot soil moisture data from the Grassland Resilience
# Year 1 All Ireland Drought Experiment.

#===========================================
# Clear objects from the workspace

rm(list = ls())

#===========================================
# Set working directory

# Maja's desktop PC

setwd("C:/Users/3054311/Documents/My Documents/Grassland project/01_Probes_soil_moisture_and_temp")

data.dir <- paste0(getwd(),"/Data/")
figures.dir <- paste0(getwd(),"/Figures/")
script.dir <- paste0(getwd(),"/Script/")

#===========================================
# Packages

library(ggplot2)
library(lubridate)
library(dplyr)
library(tidyr)
library(stringr)
library(patchwork)
library(cowplot)

#===========================================
# Load data and add column treatment

load(paste0(data.dir,"Cleaned_Soil_Moisture_Data_from_Loggers.RData"))
df <- df.moisture   ## shorter
rm(df.moisture)
names(df)

dir.create(paste0(figures.dir,"Soil moisture per site"))
mydir <- paste0(figures.dir,"Soil moisture per site/")

#================================================
# Theme for ggplots

min.date <- min(df$date.time)
max.date <- max(df$date.time)

mytheme <- theme_bw() +
  theme(panel.grid = element_blank(),
        axis.text = element_text(size = 12),
        axis.title.x = element_text(size = 14, face = "bold", margin = margin(15,0,0,0)),
        axis.title.y = element_text(size = 14, face = "bold", margin = margin(0,15,0,0)),
        plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
        panel.spacing = unit(1, "lines"),
        legend.position = "none")

#================================================
# Add events (start drought, end drought, days 8. 16. 32 and 64)

load(file = paste0(data.dir,"All events.RData"))

##------------------##
##                  ##
##     for-loop     ##
##                  ##
##------------------##

regions <- unique(df$Region)
sites <- unique(df$Site)

for (site in sites){

  mysite <- df %>%
    filter(Site == site) %>%
    droplevels()

  title <- paste(mysite$Region[1],mysite$Farm[1])

  ## Get all important dates (only day, month and year) and add 11 hours ( = 12:00:00)

  start.drought <- as.POSIXct(mdy(events$StartDrought[events$Site == site]), tz = "GMT") + 11*60*60
  end.drought <- as.POSIXct(mdy(events$EndDrought[events$Site == site]), tz = "GMT") + 11*60*60
  day8 <- as.POSIXct(mdy(events$Day8[events$Site == site]), tz = "GMT") + 11*60*60
  day16 <- as.POSIXct(mdy(events$Day16[events$Site == site]), tz = "GMT") + 11*60*60
  day32 <- as.POSIXct(mdy(events$Day32[events$Site == site]), tz = "GMT") + 11*60*60
  day64 <- as.POSIXct(mdy(events$Day64[events$Site == site]), tz = "GMT") + 11*60*60

  g <- ggplot(mysite,
              aes(x = date.time, y = Moisture)) +
    geom_rect(aes(xmin = start.drought,
                  xmax = end.drought,
                  ymin = -Inf,
                  ymax = +Inf),
              fill = "gray80") +
    geom_line(aes(color = treatment)) +
    facet_wrap(~ Plot) +
    labs(x = "Date", y = "Soil Moisture (%)", title = title) +
    mytheme +
    scale_color_manual(values = c("red","blue")) +
    scale_y_continuous(limits = c(-2,102), breaks = c(0,25,50,75,100)) +
    scale_x_datetime(limits = c(min.date,max.date),
                     breaks = c(start.drought,
                                end.drought,
                                day64),
                     date_labels = "%b %d") +
    geom_vline(aes(xintercept = day8),
               linetype = "dashed", color = "gray50") +
    geom_vline(aes(xintercept = day16),
               linetype = "dashed", color = "gray50") +
    geom_vline(aes(xintercept = day32),
               linetype = "dashed", color = "gray50") +
    geom_vline(aes(xintercept = day64),
               linetype = "dashed", color = "gray50")

  ggsave(paste0(mydir,site," - Soil moisture.png"), g,
         width = 8, height = 6)

}


# Internal function that uses the implementation of Telfer written by Gary Powney

telfer_func <- function (taxa_data, iterations = 10, useIterations = TRUE, minSite = 5){

  # Check we have two time periods
  TPs <- sort(unique(taxa_data$time_period))
  if(length(unique(taxa_data$time_period)) != 2) stop('There are not two time periods in the data')

  # subset data to one object for each time perod
  T1 <- unique(taxa_data[taxa_data$time_period == TPs[1], c('taxa', 'site')])
  T2 <- unique(taxa_data[taxa_data$time_period == TPs[2], c('taxa', 'site')])

  # remove gridcells that are only found in one time period
  T1cells <- unique(T1$site)
  T2cells <- unique(T2$site)
  allGood <- T1cells[T1cells %in% T2cells]
  T1 <- T1[T1$site %in% allGood,]
  T2 <- T2[T2$site %in% allGood,]

  ### Identify the number of sites each taxa occupies in each time period. ###
  T1_range <- data.frame(taxa = names(table(T1$taxa)), T1Nsites = as.numeric(table(T1$taxa)))
  T2_range <- data.frame(taxa = names(table(T2$taxa)), T2Nsites = as.numeric(table(T2$taxa)))

  ### Remove taxa which have less than minSite grid cells in first period ###
  T1_range_good <- T1_range[T1_range$T1Nsites >= minSite,]
  if(nrow(T1_range_good) == 0) stop(paste('No taxa satisfy the minSite criteria when comparing time',
                                          'period', TPs[1], 'and', TPs[2]))

  ### Link the two tables by taxa ###
  spp_table <- merge(T1_range_good, T2_range, by = 'taxa')

  ### Identify the simple difference between the two time periods ###
  spp_table$range_change <- spp_table$T2Nsites - spp_table$T1Nsites

  ### convert the grid cell number to proportion of total number of cells surveyed ###
  total.cells <- length(allGood)

  # To avoid the problems associated with 0 proportions they were calculated as (x + 0.5) / (n + 1).
  spp_table$T1_range_prop <- (spp_table$T1Nsites + 0.5) / (total.cells + 1)
  spp_table$T2_range_prop <- (spp_table$T2Nsites + 0.5) / (total.cells + 1)

  spp_table$T1_logit_range <- log(spp_table$T1_range_prop / (1 - spp_table$T1_range_prop))  # logit transform the proportions
  spp_table$T2_logit_range <- log(spp_table$T2_range_prop / (1 - spp_table$T2_range_prop))	# logit transform the proportions

  ### To account for non constant variance we must do the following steps to create a variable to weight the final regression ###
  row.names(spp_table) <- spp_table$taxa # name rows helps make sense of the model output
  m1 <- lm(T2_logit_range ~ T1_logit_range, data = spp_table)  	# linear regression of two time periods

  if(!useIterations){

    spp_table$change_index <- rstandard(m1)
    final_output_table <- spp_table[,c(1:3,9)]
    return(list(final_output_table, spp_table))

  } else if(useIterations){

    spp_table$sq_residual_m1 <- resid(m1)^2 # square the residuals
    spp_table$fitted_proportions <- ilt(m1$fitted) # exponential function, overwrite fitted values to fitted proportions

    total.cell.1 <- total.cells + 1								# total grid cells surveyed + 1

    spp_table$NP_test <- 1 / (total.cell.1 * spp_table$fitted_proportions *
                                (1 - spp_table$fitted_proportions))	# 1 / [NP (1 - P)] in telfer paper

    # second model which is the squared residuals of m1 on 1/[NP (1-P)]
    m2 <- lm(sq_residual_m1 ~ NP_test, data = spp_table)

    # second model which is the squared residuals of m1 on 1/[NP (1-P)]
    c_ <- coef(m2)[1] # take the intercept of m2
    d_ <- coef(m2)[2] # take the slope of m2

    V_ <- NULL												# prepare variance vector
    rep_loop <- 1:(iterations-1)		# repeat the process
    C_all <- c_												# prepare c vector
    D_all <- d_												# prepare d vector
    V_all <- V_												# prepare variance vector

    for (i in rep_loop){

      # c_ + d_ should not be in brackets as they were in a previous version
      V_ <- c_ + d_ / (total.cell.1 * spp_table$fitted_proportions * (1 - spp_table$fitted_proportions))	# work out the variance (modification of the binomial proportion variance structure)

      # take the inverse of variance squared.
      inv_sq_V <- 1 / (V_^2)

      # run the new model weighting by the inverse variance identifeid above.
      error <- try(m4 <- lm(sq_residual_m1 ~ NP_test, weights = inv_sq_V, data = spp_table), silent = TRUE)
      if(class(error) == 'try-error') stop('Model failed in iteration, too little data?')

      c_ <- coef(m4)[1] # take the intercept of the new model
      d_ <- coef(m4)[2] # take the slope of the new model

      C_all <- c(C_all,c_) # build a vector with all of the new intercepts
      D_all <- c(D_all,d_) # build a vector with all of the new slopes
      V_all <- c(V_all,V_) # build a vector with all of the new inverse variances squared

    }

    ## final model to take the residuals from
    # take the reciprocal of the "settled" variance (Telfer et al 2002)
    spp_table$recip_V <- 1 / V_
    # use the reciprocal of the "settled" variance as weight for the final model.
    m1 <- lm(T2_logit_range ~ T1_logit_range, weights = spp_table$recip_V, data = spp_table)
    # take the standardised residuals from the model.
    # For each taxa, the standardised residual from the fitted regression line provides
    # the index of relative change in range size. A taxa with a negative change index has
    # been recorded in relatively fewer grid cells in the later period, whereas a taxa with
    # a positive change index has been recorded in relatively more.
    spp_table$change_index <- rstandard(m1)
    final_output_table <- spp_table[,c(1:3,13)]

    return(list(final_output_table, spp_table))

  }

}


#' Fire data set.
#'
#' A data set showing the distance of fires from nearest fire station and the cost of their damage.
#'
#' @format A data frame with 15 rows and 2 variables
#' \describe {
#'   \item{DISTANCE}{distance in miles from nearest fire station}
#'   \item{Damage}{damage caused by fire in thousands of dollars}
#'   ...
#' }
#' @source \url{https://bookshelf.vitalsource.com/#/books/9781498728881}
"fire"


#This function takes a vector of fixed effects
#writes a linear beta regression model for JAGS, and priors.
#saves as a file.

write_jags_beta <- function(fixed.effects,file.path){
  #text conenction for file
  fileConn <- file(file.path)

  #setup priors block
  prior.lines <- list()
  for(i in 1:length(fixed.effects)){
    parm <- paste0('m',i)
    prior.line <- paste0(parm,'~ dnorm(0, .001)')
    prior.lines[[i]] <- prior.line
  }
  prior.lines <- do.call('rbind',prior.lines)
  #add intercept and ucnertainty prior
  prior.lines <- rbind('m0~ dnorm(0, .001)',prior.lines)
  prior.lines <- rbind(prior.lines,'tau ~ dgamma(.1,.1)')

  #setup model block
  #write model lines
  pre.mod <-
    rbind('for(i in 1:N){',
          'y[i] ~ dbeta(p[i], q[i])',
          'p[i] <- mu[i] * tau',
          'q[i] <- (1 - mu[i]) * tau'
    )

  #linear statement
  linear.out <- list()
  for(i in 1:length(fixed.effects)){
    linear.out[[i]] <- paste0('m',i,' * x',i,'[i]')
  }
  linear <- do.call('rbind',linear.out)
  linear <- paste0(paste0(linear, sep = ' + '), collapse = '')
  linear <- paste(linear, 'm0')
  linear <- paste('logit(mu[i]) <-',linear)

  #wrap up model lines
  model.lines <- rbind(pre.mod,
                       linear,
                       '}')

  #put it all together
  all.lines <- rbind('model{',
                     prior.lines,
                     model.lines,
                     '}')

  #write to file connection.
  writeLines(all.lines,fileConn)
}


# Read previous scripts
# source("R/dm02_pkg.r")

# If simulated data
# source("R/dm03_sim_data.R")

# Time-to-event data
#
# Number of subjects at start of follow-up stratified by covariates
# Number of person-years
# Number of events
# Age at event (mean, SD, median, range)

# fbc <- df_all # If with other colnames
fbc <- df_tot

# Table 1 -----------------------------------------------------------------

# Scaled grades
fbc_tab <-
  fbc %>%
  mutate_at(c(vars_avera, vars_grade), compose(c, scale)) %>%
  mutate_at(
    vars(starts_with("time")),
    ~ ((d_start - 1) %--% .) / years(1)
  ) %>%
  mutate(
    all = "all",

    # For simulation data
    Average_c = cut(Average, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),

    subject_1_c = cut(subject_1, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F) ,
    subject_2_c = cut(subject_2, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    subject_3_c = cut(subject_3, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F) ,
    subject_4_c = cut(subject_4, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    subject_5_c = cut(subject_5, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    subject_6_c = cut(subject_6, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),

    Average_c2 = cut(Average, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),

    subject_1_c2 = cut(subject_1, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F) ,
    subject_2_c2 = cut(subject_2, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    subject_3_c2 = cut(subject_3, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F) ,
    subject_4_c2 = cut(subject_4, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    subject_5_c2 = cut(subject_5, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    subject_6_c2 = cut(subject_6, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F)

    # For real data
    # Literature_c = cut(Literature, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F) ,
    # Mathematics_c = cut(Mathematics, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    # Phys_Edu_c = cut(Phys_Edu, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F) ,
    # Handicrafts_c = cut(Handicrafts, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    # Arts_c = cut(Arts, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    # Music_c = cut(Music, breaks = c(-Inf, -1.5, -1, -0.5, 0.5, 1, 1.5, Inf), right = F),
    #
    # Average_c2 = cut(Average, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    # Literature_c2 = cut(Literature, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F) ,
    # Mathematics_c2 = cut(Mathematics, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    # Phys_Edu_c2 = cut(Phys_Edu, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F) ,
    # Handicrafts_c2 = cut(Handicrafts, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    # Arts_c2 = cut(Arts, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F),
    # Music_c2 = cut(Music, breaks = c(-Inf, -1.5, -0.5, 0.5, 1.5, Inf), right = F)
  )

strata <- c("all", vars_covar,
            "Average_c",
            paste0(vars_grade, "_c"),
            "Average_c2",
            paste0(vars_grade, "_c2"))

# With original grades (non-scaled)

# fbc_tab_orig <-
#   fbc %>%
#   mutate_at(
#     vars(starts_with("time")),
#     ~ ((d_start - 1) %--% .) / years(1)
#   ) %>%
#   mutate(
#     all = "all" ,
#     Average_int = as.integer(Average),
#     Average_round = round(Average, 0),
#     Average_c = cut(Average, breaks = c(-Inf, 6, 7, 8, 9, Inf)) ,
#     Average_c2 = cut(Average, breaks = c(-Inf, 4:10, Inf)) ,
#     Literature_c = cut(Literature, breaks = c(-Inf, 6, 7, 8, 9, Inf)) ,
#     Mathematics_c = cut(Mathematics, breaks = c(-Inf, 6, 7, 8, 9, Inf)),
#     Phys_Edu_c = cut(Phys_Edu, breaks = c(-Inf, 6, 7, 8, 9, Inf)) ,
#     Handicrafts_c = cut(Handicrafts, breaks = c(-Inf, 6, 7, 8, 9, Inf)),
#     Arts_c = cut(Arts, breaks = c(-Inf, 6, 7, 8, 9, Inf)),
#     Music_c = cut(Music, breaks = c(-Inf, 6, 7, 8, 9, Inf))
#   )
#
# strata <- c("all",
#             vars_covar,
#             "Average_c",
#             "Average_c2",
#             "Average_int",
#             "Average_round",
#             vars_grade,
#             paste0(vars_grade, "_c"))

# Same for scaled and non-scaled
fbc_long <-
  fbc_tab %>% # or fbc_tab_orig if non-scaled
  pivot_longer(
    cols = matches("^(event|time)_"),
    names_sep = "_",
    names_to = c(".value", "outcome")
  )

#' @param x a survfit object
cumulative_incidence <- function(x, at = Inf) {
  broom::tidy(x) %>%
    filter(time <= !!at) %>%
    slice(n()) %>%
    select(estimate, conf.high, conf.low) %>%
    mutate_all(~ (1 - .) * 100)
}

table_1_data <-
  map_df(strata, ~ {
  fbc_long %>%
    group_by(outcome, chracteristic = .x, value = !!sym(.x)) %>%
    summarize(
      n = n(),
      n_risk = sum(time > 0, na.rm = T),
      pyears = sum(time, na.rm = T),
      events = sum(event, na.rm = T),
      km_fit = list(survfit(Surv(time, event) ~ 1))
    ) %>%
    mutate(ci = map(km_fit, cumulative_incidence)) %>%
    unnest_wider(ci, names_sep = "_") %>%
    mutate(value = as.character(value))
})

# openxlsx::write.xlsx(
#   table_1_data %>% select(-km_fit),
#   paste0(
#     "figures/table_1_data_",
#     Sys.Date(),
#     ".xlsx"
#   )
# )

# Mean age ----------------------------------------------------------------

fbc_age <-
  fbc %>%
  filter(fas == 1, fas_dg != "none") %>%
  mutate_at(
    vars(starts_with("time")),
    ~ ((dob) %--% .) / years(1)
  ) %>%
  select(
    contains("time"))

summary_age <-
  bind_rows(
  fbc_age %>%
    summarise_all( ~ (mean(., na.rm = T))),
  fbc_age %>%
    summarise_all( ~ (sd(., na.rm = T))),
  fbc_age %>%
    summarise_all( ~ (min(., na.rm = T))),
  fbc_age %>%
    summarise_all( ~ (median(., na.rm = T))),
  fbc_age %>%
    summarise_all( ~ (max(., na.rm = T)))
) %>%
  mutate(
    measure = c(
      "mean",
      "sd",
      "min",
      "median",
      "max"
    )
  )

# openxlsx::write.xlsx(
#   summary_age,
#   paste0(
#     "figures/tab_summary_age_",
#     Sys.Date(),
#     ".xlsx"
#   )
# )
# openxlsx::write.xlsx(
#   summary(fbc_age),
#   paste0(
#     "figures/tab_summary_age2_",
#     Sys.Date(),
#     ".xlsx"
#   )
# )


## EWAS of schizophrenia
## uses a multi level model with random effect for individual & brain bank
## runs in parallel

runEWAS<-function(row,pheno){
	pheno<-cbind(row,pheno)
	model<-lmer(row ~ Phenotype + CCDNAmAge + Sex + Cell.type + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)
	ctNull<-lmer(row ~ Phenotype + CCDNAmAge + Sex  + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)
	modelInt<-lmer(row ~ Phenotype + CCDNAmAge + Sex + Cell.type + Phenotype * Cell.type + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)
	outtab<-c(summary(model)$coefficients["PhenotypeControl",c(1,2,5)],
	anova(model, ctNull)[2,8],
	summary(model)$coefficients["Cell.typeNeuN +ve",c(1,2,5)],
	summary(model)$coefficients["Cell.typeSox10 +ve",c(1,2,5)],
	unlist(summary(model)$varcor),
	anova(modelInt,model)[2,8],
	summary(modelInt)$coefficients["PhenotypeControl",c(1,2,5)],
	summary(modelInt)$coefficients["Cell.typeNeuN +ve",c(1,2,5)],
	summary(modelInt)$coefficients["Cell.typeSox10 +ve",c(1,2,5)],
	summary(modelInt)$coefficients["PhenotypeControl:Cell.typeNeuN +ve",c(1,2,5)],
	summary(modelInt)$coefficients["PhenotypeControl:Cell.typeSox10 +ve",c(1,2,5)])
	return(outtab)
}

library(lme4)
library(lmerTest)
library(doParallel)

args<-commandArgs(trailingOnly = TRUE)
source(args[1])

setwd(dataDir)

load(normData)

## remove total samples and cell types with less than 10 samples
pheno<-pheno[which(pheno$Cell.type != "Total"),]
nSample<-table(pheno$Cell.type)
pheno<-pheno[pheno$Cell.type %in% names(nSample[which(nSample > 9)]),]

celltypenormbeta<-celltypenormbeta[,pheno$Basename]

## create parallel environment

nCores<-detectCores()
cl <- makeCluster(nCores-1)
registerDoParallel(cl)
clusterExport(cl, list("runEWAS", "lmer"))

#parRapply(cl, celltypenormbeta[1:10,], runEWAS, pheno)

outtab<-foreach(i=1:nrow(celltypenormbeta), .combine = "cbind") %dopar% runEWAS(celltypenormbeta[i,], pheno)
outtab<-t(outtab)
rownames(outtab)<-rownames(celltypenormbeta)
colnames(outtab)<-c("SCZ_coeff", "SCZ_SE", "SCZ_P", "CellType_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "RE_ID_SD", "RE_BrainBank_SD", "CellType_SCZ_P", "SCZ_coeff", "SCZ_SE", "SCZ_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "NeuN_SCZ_coeff", "NeuN_SCZ_SE","NeuN_SCZ_P", "SOX10_SCZ_coeff", "SOX10_SCZ_SE","SOX10_SCZ_P")

save(outtab, file = "Analysis/Schizophrenia/MLM.rdata")

stopCluster(cl)