  # Figures and tables obtained after completion of data assimilation and processing up to the end of "01.snowcrab.r"

year.assessment = 2021

p = bio.snowcrab::load.environment( year.assessment=year.assessment )

  # --- FIGURES ----

  # ------------------------------------------
   # Time-series: Fisheries landings
  #BZ TODO get these to x the anuary meetings script exactly as that lines up with Improptu reports
  #for now, the plots produced are accurate.
   figure.landings.timeseries( yearmax=p$year.assessment, outdir=file.path( p$annual.results,  "timeseries","fishery"), outfile="landings.ts", outfile2="landings.ts.sm" )

  # ------------------------------------------
  # Time-series: Fisheries effort
   figure.effort.timeseries( yearmax=p$year.assessment, outdir=file.path( p$annual.results,"timeseries", "fishery"), outfile="effort.ts", outfile2="effort.ts.sm" )

  # ------------------------------------------
  # Time-series: Fisheries CPUE
   figure.cpue.timeseries( yearmax=p$year.assessment, outdir=file.path( p$annual.results,"timeseries", "fishery"), outfile="cpue.ts", outfile2="cpue.sm.ts" )

  # ------------------------------------------
  # Size frequency distributions, broken down by moult category from at-sea observed data

    figure.observed.size.freq( regions = c("cfanorth", "cfasouth", "cfa4x"), years="all", outdir=file.path( p$annual.results, "figures", "size.freq", "observer")  )

  # ------------------------------------------
  # Size-frequency distributions of snow crab cw from trawl data, broken down by maturity classes
    histograms.size.maturity.update( outdir=file.path( p$annual.results, "figures", "size.freq", "survey"),  redo.data=T )
    histograms.size.maturity.single.area( outdir=file.path( p$annual.results, "figures", "size.freq", "survey"),  area='cfa4x',redo.data=T ) #area = cfanorth, cfasouth of cfa4x

  # ------------------------------------------
  # Timeseries of all survey variables
  figure.timeseries.survey(p=p, outdir=file.path(p$annual.results, "timeseries", "survey"), variables="R0.mass", plotyears=2004:p$year.assessment) # just R0 to see
  figure.timeseries.survey(p=p, outdir=file.path(p$annual.results, "timeseries", "survey"),variables=c("sexratio.all","sexratio.mat","sexratio.imm"))
  figure.timeseries.survey(p=p, outdir=file.path(p$annual.results, "timeseries", "survey"),plotyears=2004:p$year.assessment) # all variables
  figure.timeseries.survey(p=p, outdir=file.path(p$annual.results, "timeseries", "observer"),plotyears=2004:p$year.assessment,type='observer')

   figure.timeseries.survey(p=p, outdir=file.path(p$annual.results, "timeseries", "survey"),plotyears=2004:p$year.assessment,type='groundfish.t') # groundfish survey temperature
  #-----------------------------------------------

  #Timeseries: geometric mean biomass of by-catch from snow crab survey

  # predators and competitors
    #cod, haddock, halibut, plaice, wolfish, thornyskate, smoothskate, winterskate, northernshrimp, jonahcrab, lessertoadcrab
  species = c(10, 11, 30, 40, 201, 50, 2521, 2511, 202, 204, 2211)
  figure.timeseries.bycatch(p=p, species=species, plotyears=2004:p$year.assessment, outdir=file.path(p$annual.results,"timeseries", "survey"))

  # ------------------------------------------
  # Map:  Interpolated mean/geometric mean of various variables in the set data table
#  p$do.parallel=F
  p$corners = data.frame(plon=c(220, 990), plat=c(4750, 5270) )

  outdir = file.path( p$project.outputdir, "maps", "survey", "snowcrab","annual" )

  # just for the roadshow
    map.set.information( p=p, outdir=outdir, variables=c('totmass.male.com', 'totmass.female.mat'),mapyears=p$mapyears)
    map.set.information( p=p, variables='t',mapyears=p$mapyears,outdir=outdir,log.variable=F,add.zeros=F,theta=100)

    # bycatch (geometric means)
    bc.vars = c(paste("ms.mass",species,sep='.'),paste("ms.no",species,sep='.'))
    outdir.bc= file.path( p$project.outputdir, "maps", "survey", "snowcrab","annual", "bycatch" )
    map.set.information( p, variables=bc.vars, mapyears=p$mapyears, outdir=outdir.bc,probs=c(0,0.975)) #

    # all variables (geometric means)
    #map.set.information( p, outdir=outdir) # takes a long time

    # Means
    # variables that shouldn't be logged
    set = snowcrab.db( p=p, DS="set.biologicals")
    variables = bio.snowcrab::snowcrab.variablelist("all.data")
    variables = intersect( variables, names(set) )

    nolog.variables = c("t","z","sexratio.all","sexratio.mat","sexratio.imm","julian","julian.compressed", variables[grep("cw",variables)])
    map.set.information( p=p, variables=nolog.variables,outdir=outdir,log.variable=F,add.zeros=F,theta=35)
    # logit transform for ratios
    map.set.information( p=p, variables=c("sexratio.all","sexratio.mat","sexratio.imm"),outdir=outdir,log.variable=F,add.zeros=F,theta=40)

    # Geometric Means
    # all except variables that shouldn't be logged
    mass.vars = variables[!variables%in%nolog.variables][grep('mass',variables[!variables%in%nolog.variables])]
    no.vars = variables[!variables%in%nolog.variables][grep('no',variables[!variables%in%nolog.variables])]
    map.set.information( p=p, variables= mass.vars,outdir=outdir)
    map.set.information( p=p, variables= no.vars,outdir=outdir,probs=c(0,0.975))

  # ------------------------------------------
  # Map: Survey locations

    map.survey.locations( p=p, basedir=file.path(p$project.outputdir, "maps", "survey.locations"),  newyear=F, map.method="lattice"  )
  #  map.survey.locations( p, basedir=file.path(p$project.outputdir, "maps", "survey.locations"),  newyear=F, map.method="googleearth"  )

  # ------------------------------------------
  # Map: Observer locations
    map.observer.locations( p=p, basedir=file.path(p$project.outputdir, "maps","observer.locations" ), newyear=F , map.method="lattice"  )

  # ------------------------------------------
  # Map: Logbook recorded locations
    map.logbook.locations( p=p, basedir=file.path(p$project.outputdir, "maps","logbook.locations" ), newyear=F , map.method="lattice"  )

  # ------------------------------------------
  # Map: Logbook data
  map.fisheries.data(
    outdir=file.path( p$project.outputdir, "maps", "logbook","snowcrab","annual" ),
    probs=c(0,0.975),
    plot_crs=st_crs( p$aegis_proj4string_planar_km ),
    outformat="png"
  )

  # --- TABLES ----
  # TODO-BZ add functionality for tables to be saved as pdf
  # add tab.4.tex.r function

  require(gridExtra)
  library("xtable")
  library("R2HTML")

  odb0 = observer.db("odb")
  regions = c("cfanorth", "cfasouth", "cfa4x")
  nregions = length(regions)

  #------------------------------------------------
  #Fisheries statistics per region
  tabledir = file.path(project.datadirectory("bio.snowcrab"), "data", "fisheries")
  outtabledir= file.path(project.datadirectory("bio.snowcrab"), "assessments", p$year.assessment, "tables", "logbook")
  if(!dir.exists(tabledir)) dir.create(tabledir, recursive =T)
  if(!dir.exists(outtabledir)) dir.create(outtabledir, recursive =T)

  setwd(tabledir)

  NFS <- xtable(read.csv("NENS_FisherySummary.csv"))
  SFS <- xtable(read.csv("SENS_FisherySummary.csv"))
  Fx <- xtable(read.csv("4x_FisherySummary.csv"))

  setwd(outtabledir)
  print.xtable(NFS, type="latex", file="NENS_FisherySummary.tex")
  print.xtable(NFS, type="html", file="NENS_FisherySummary.html")

  print.xtable(SFS, type="latex", file="SENS_FisherySummary.tex")
  print.xtable(SFS, type="html", file="SENS_FisherySummary.html")

  print.xtable(Fx, type="latex", file="4x_FisherySummary.tex")
  print.xtable(Fx, type="html", file="4x_FisherySummary.html")

  #regions = c("cfaall")
   #regions = c("cfanorth", "cfasouth", "cfa4x")
   regions = c("cfanorth", "cfa23", "cfa24", "cfa4x")
    l = NULL
    for (r in regions) {
      res = get.fishery.stats.by.region( Reg=r) #need to add the TACs per year and number of licences
      #round the landings to ton
      #round CPUE to no decimal places
      #round the effort to per x1000 trap hauls
      print(r)
      print(res)
    }

# ----------------------------------------
#  Carapace condition from observed data  < 95mm CW

    outtabledir= file.path(project.datadirectory("bio.snowcrab"), "assessments", p$year.assessment, "tables", "observer")

    odb = odb0
    odb = odb[ which( odb$cw < 95 & odb$prodcd_id=="0" ) ,]
    regions = c("cfanorth", "cfasouth", "cfa4x")
    nregions = length(regions)
    years = sort( unique( odb$fishyr ) )

    res = NULL
    for (r in p$regions) {
    for (y in years) {
      out = proportion.cc (odb, region=r, year=y)
      res = rbind( res, cbind( r, y, t(out)) )
    }}

    cnames = c("region", "fishyr", c(1:5), "ntot")
    colnames(res) = cnames
    print(res)
    res = as.data.frame(res)
    res[is.na(res)] <- NA
    ct <- c("CC1", "CC2", "CC3", "CC4", "CC5", "Total")

    setwd(outtabledir)

    Rn= res[res$region=="cfanorth", 3:8]
    print(Rn)
    rownames(Rn) = years
    colnames(Rn) = ct
    print.xtable(Rn, type="latex", file="table.CC.small.north.obs.tex")
    HTML(Rn, file="table.CC.Small.north.obs.html")

    Rs= res[res$region=="cfasouth", 3:8]
    rownames(Rs) = years
    colnames(Rs) = ct
    print.xtable(Rs, type="latex", file="table.CC.small.south.obs.tex")
    HTML(Rs, file="table.CC.small.south.obs.html")

    Rx= res[res$region=="cfa4x", 3:8]
    rownames(Rx) = years
    colnames(Rx) = ct
    print.xtable(Rs, type="latex", file="table.CC.small.4x.obs.tex")
    HTML(Rx, file="table.CC.small.4x.obs.html")

# ----------------------------------------
#  Carapace condition from observed data >=95mm CW
    odb = odb0
    odb = odb[ which( odb$cw >= 95 & odb$cw < 170 & odb$prodcd_id=="0" ) ,]  # commerical sized crab only
    years = sort( unique( odb$fishyr ) )

  # get proportion by cc
    regions = c("cfanorth", "cfasouth", "cfa4x")
    years = sort( unique( odb$fishyr ) )

    res = NULL
    for (r in regions) {
    for (y in years) {
      out = proportion.cc (odb, region=r, year=y)
      res = rbind( res, cbind( r, y, t(out)) )
    }}

    cnames = c("region", "fishyr", c(1:5), "ntot")
    colnames(res) = cnames
    print(res)
    res = as.data.frame(res)
    res[is.na(res)] <- NA
  #  for (i in cnames[-1]) res[,i] = as.numeric(as.character((res[,i])))
    setwd(outtabledir)

    ct <- c("CC1", "CC2", "CC3", "CC4", "CC5")
    Rn = res[res$region=="cfanorth", 3:7]
    #Rn = as.matrix( res[ which(res$region=="cfanorth") , as.character(c(1:5)) ] )
    rownames(Rn) = years
    colnames(Rn) = ct
    print.xtable(Rn, type="latex", file="table.CC.large.north.obs.tex")
    HTML(Rn, file="table.CC.large.north.obs.html")

    #Rs = as.matrix( res[ which(res$region=="cfasouth") , as.character(c(1:5)) ] )
    Rs = res[res$region=="cfasouth", 3:7]
    rownames(Rs) = years
    colnames(Rs) = ct
    print.xtable(Rs, type="latex", file="table.CC.large.south.obs.tex")
    HTML(Rs, file="table.CC.large.south.obs.html")

    #Rx = as.matrix( res[ which(res$region=="cfa4x") , as.character(c(1:5)) ] )
    Rx = res[res$region=="cfa4x", 3:7]
    rownames(Rx) = years
    colnames(Rx) = ct
    print.xtable(Rx, type="latex", file="table.CC.large.4x.obs.tex")
    HTML(Rx, file="table.CC.large.4x.obs.html")

# ----------------------------------------
#  Percent soft from observed data

    odb = odb0
    odb = odb[ which( odb$cw > 95 & odb$cw < 170 & odb$prodcd_id=="0" ) ,]  # commercial crab
    years = sort( unique( odb$fishyr ) )

    res = NULL
    for (r in p$regions) {
    for (y in years) {
      out = proportion.soft (odb, region=r, year=y)
      res = rbind( res, cbind( r, y, t(out)) )
    }}

    cnames = c("region", "fishyr", "pr.soft", "nsoft", "ntot")
    colnames(res) = cnames
    print(res)
    res = as.data.frame(res)

    for (i in cnames[-1]) res[,i] = as.numeric(as.character((res[,i])))

    Rn = as.matrix( res[ which(res$region=="cfanorth") , as.character(c(1:3)) ] )
    rownames(Rn) = years
    latex(Rn, file="", title="", label="table.proportion.soft.north.obs", rowlabel="Year", cgroup="", na.blank=T, caption="Percent soft (by number) over time for N-ENS from at-sea-observed data.")

    Rs = as.matrix( res[ which(res$region=="cfasouth" ), as.character(c(1:5)) ] )
    rownames(Rs) = years
    latex(Rs, file="", title="", label="table.proportion.soft.south.obs", rowlabel="Year", cgroup="", na.blank=T, caption="Percent soft (by number) over time for S-ENS from at-sea-observed data.")

    Rx = as.matrix( res[ which(res$region=="cfa4x") , as.character(c(1:5)) ] )
    rownames(Rx) = years
    latex(Rx, file="", title="", label="table.proportion.soft.4x.obs", rowlabel="Year", cgroup="", na.blank=T, caption="Percent soft (by number) over time for CFA 4X from at-sea-observed data.")

# instars of interest: 11 and 12

# growth increment (assumming average weight in the midpoint of each increment)
  growth.11.to.12 =  predict.mass.g.from.CW.mm( mean(CW.interval.male(12)) ) - predict.mass.g.from.CW.mm (mean(CW.interval.male(11)) )

  # = 419 g
#  12to13 = ~450

  # Table of proportion discarded
    odb = observer.db("odb")
    regions = c("cfanorth", "cfasouth", "cfa4x")
    years = sort( unique( odb$fishyr ) )
    out = NULL
    for (r in regions) {
    for (y in years) {
      res = proportion.legal (odb, region=r, year=y)
      out = rbind(out, cbind( r, y, res[1], res[2], res[3] ) )
    } }
    out

# ---------------------------------------- USED
#  Carapace condition from trawl data  >= 95mm CW  ... not kriged .. simple proportions

    det0 = snowcrab.db( p=p, DS="det.georeferenced" )
    det0$fishyr = det0$yr  ## the counting routine expectes this variable

    det = det0[ which( det0$cw >= 95 ) ,]  # commerical sized crab only
    years = sort( unique( det$yr ) )

    res = NULL
    for (r in p$regions) {
    for (y in years) {
      out = proportion.cc (det, region=r, year=y)
      res = rbind( res, cbind( r, y, t(out)) )
    }}

    cnames = c("region", "fishyr", c(1:5), "ntot")
    colnames(res) = cnames
    print(res)
    res = as.data.frame(res)

    for (i in cnames[-1]) res[,i] = as.numeric(as.character((res[,i])))
    (res)

    HTML(res, file="table.CC.large.survey.html")

  # ------------------
  # counts of stations in each area

    # check towquality .. this should always == 1
    set = snowcrab.db(p=p, DS="set.clean")
    if (length( unique( set$towquality) ) != 1 ) print("error -- not good tows")

    out = data.frame(yr=sort( unique(set$yr )) )
    for (reg in c("cfaall", "cfanorth", "cfasouth","cfa4x"  ) ) {
      d = polygon_inside(set[,c("lon","lat")], reg)
      e = as.data.frame( xtabs(~yr, data=set[d,])  )
      names(e) = c("yr", reg)
      e$yr = as.numeric(as.character(e$yr) )
      out = merge(out, e, by="yr", all=T)
    }
    print(out)

    plot.new()
    year = p$year.assessment
    setdata = set[ which(set$yr==year),]
    N = polygon_inside(setdata[,c("lon","lat")], "cfanorth")
    S = polygon_inside(setdata[,c("lon","lat")], "cfasouth")
    X = polygon_inside(setdata[,c("lon","lat")], "cfa4x")
    plot(setdata$lon, setdata$lat)
    points(setdata$lon[N], setdata$lat[N],col="red",pch=20)
    points(setdata$lon[S], setdata$lat[S],col="blue",pch=20)
    points(setdata$lon[X], setdata$lat[X],col="black",pch=20)

# % mat calculations:
#as above but

      loc = file.path(sc.R, "size.data")
      dir.create(path=loc, recursive=T, showWarnings=F)
      outfilename = paste( c("mi", "mm", "fi", "fm"), "rdata", sep=".")
      outfile = file.path(loc, paste(outfilename))
      for (f in  outfile) load(f)

           f.i = f.imm[which( rownames(f.imm)%in% sids ) ,]
           f.i.means = apply(X=f.i, MARGIN=2, FUN=mean)
           f.m = f.mat[which( rownames(f.mat)%in% sids ) ,]
           f.m.means = apply(X=f.m, MARGIN=2, FUN=mean)

           toplot = rbind(f.m.means, f.i.means)

 ii = as.data.frame(t(toplot))
 ii$cw = as.numeric(rownames(ii))
 ii$pmat = ii[,1]/ (ii[,1]+ii[,2]) * 100

plot(ii$cw, ii$pmat)
abline(h=50)

 str(ii)
#`data.frame':   70 obs. of  4 variables:
# $ f.m.means: num  0 0 0 0 0 ...
# $ f.i.means: num   2.80  6.19 20.05 24.29 74.11 ...
# $ cw       : num  12 14 16 18 20 22 24 26 28 30 ...
# $ pmat     : num  0 0 0 0 0 ...

# ----------------------------------------   NOT USED ____________
#  Carapace condition from trawl data  < 95mm CW  ... not kriged .. simple proportions

    det0 = snowcrab.db( p=p, DS="det.georeferenced" )
    det0$fishyr = det0$yr  ## the counting routine expectes this variable

    det = det0[ which( det0$cw < 95 ) ,]  # commerical sized crab only
    years = sort( unique( det$yr ) )

    res = NULL
    for (r in p$regions) {
    for (y in years) {
      out = proportion.cc (det, region=r, year=y)
      res = rbind( res, cbind( r, y, t(out)) )
    }}

    cnames = c("region", "fishyr", c(1:5), "ntot")
    colnames(res) = cnames
    print(res)
    res = as.data.frame(res)

    for (i in cnames[-1]) res[,i] = as.numeric(as.character((res[,i])))
    (res)

  ##########################################################################
  ###############################  Retired figures #########################

    # ------------------------------------------
  # Map: Scotian Shelf with CFA lines and labels  .. using gmt
  # this is the basemap from map.r which is then post-labelled in sodipodi
  #  p$outdir = file.path(p$annual.results,"figures")
  #  p$outfile.basename = file.path(p$outdir, "map.CFAs")
  #  map.basemap.with.cfa.lines( p, conversions=c("ps2png")  )

  # ------------------------------------------
  # Habitat usage comparisons (bivariate) ... requires the full "set.rdata" database and "logbook.dZ.rdata" database
   # habitat.usage( usevar="totno.all", covariate="depth", outdir = file.path(p$annual.results, "habitat.templates") )

  # ------------------------------------------
  # Habitat usage comparisons (bivariate) ... requires the full "set.rdata" database and "logbook.dZ.rdata" database
    #habitat.usage( usevar="totno.all", covariate="temperature", outdir = file.path(p$annual.results, "habitat.templates") )

  # ------------------------------------------
  # Habitat usage comparisons (bivariate) ... requires the full "set.rdata" database and "logbook.dZ.rdata" database
   # habitat.usage( usevar="totno.all", covariate="bottom.slope", outdir = file.path(p$annual.results, "habitat.templates") )

  # ------------------------------------------
  # Habitat usage comparisons (bivariate) ... requires the full "set.rdata" database and "logbook.dZ.rdata" database
    #habitat.usage( usevar="totno.all", covariate="bottom.curvature", outdir = file.path(p$annual.results, "habitat.templates") )

  # ------------------------------------------
  # Habitat usage comparisons (bivariate) ... requires the full "set.rdata" database and "logbook.dZ.rdata" database
    #habitat.usage( usevar="totno.all", covariate="substrate", outdir = file.path(p$annual.results, "habitat.templates") )

  # ------------------------------------------
  # Timeseries: Larval brachyura from the SSIP data
    ##figure.timeseries.larvae( outdir=file.path(p$project.outputdir, "timeseries", "larvae") )

  # ------------------------------------------
  # Growth as a a function of instar for Scotian Shelf snow crab
    figure.growth.instar( outdir=file.path(p$project.outputdir, "growth") )

  # ------------------------------------------
  # Map: Larval distributions from the Scotian Shelf Ichtyoplankton Program data
    map.larvae( p=p, outdir=file.path(p$project.outputdir, "maps", "larvae"), conversions=conversions )

    # ------------------------------------------
    # Map: Spatial representation of maturity patterns of snow crab
    #MG Not sure we use these maps either, check with Adam and Jae
    # map.maturity( p, outdir=file.path(p$project.outputdir, "maps", "maturity"), newyear=T )


library(xlsx)

k1<-read.xlsx("t_for.xls", sheetName = "0.2", header = TRUE)
k2<-read.xlsx("t_for.xls", sheetName = "0.3", header = TRUE)
k3<-read.xlsx("t_for.xls", sheetName = "0.4", header = TRUE)
k4<-read.xlsx("t_for.xls", sheetName = "0.5", header = TRUE)

v<-4.66e-13  #弯月面体积大小

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12)   #流量从1.5到180

k<-c(0.2,0.3,0.4,0.5) #占空比

pchc<-c(19,22,23,24)

cc<-c("1.5nl/min", "27nl/min","54nl/min","180nl/min")

mycolors<-c("red","blue", "darkgreen", "yellow3")

h<-0.3e-3 #弯月面变形大小

duty<-1-k

par(mfrow=c(2,2), mgp = c(1.5, 0.5, 0),tck=0.02,mar=c(2.4,2.6,1,1), oma=c(2,2,2,2))

#######占空比0.2####
plot(k1[,1],  (v+(duty[1]*q[1]))/(k1[,1]*k1[,2]^2),lwd=1.5,cex=0.6,lty=2, log="x",xlab=expression(log(italic(f["v"])) (Hz)), ylab=expression(italic(F)(N)), main="", col=0, pch=pchc[1], ylim=c(0,8e-14))

mtext("k=0.2",3,line=0,font=2,cex=0.8)

lines(lowess(k1[,1],  (v+(duty[1]*q[1]))/(k1[,1]*k1[,2]^2)),type="b",col=mycolors[1], pch=pchc[1],lwd=1.5,cex=0.6,lty=2)

for(i in 1:3){

  points(k1[,1], (v+(duty[1]*q[i+1]))/(k1[,1]*k1[,i+2]^2),pch=pchc[i+1], lwd=1.5,cex=0.6,lty=2,col=0)
  lines(lowess(k1[,1], (v+(duty[1]*q[i+1]))/(k1[,1]*k1[,i+2]^2)), type="b",lwd=1.5, pch=pchc[i+1],cex=0.6,col=mycolors[i+1], lty=2)
}

legend("topleft",cc, col=mycolors, pch=pchc,lty=2, lwd=2, bty="n",cex=0.8)

abline(v=250, col="red", lwd=2, lty=3)

text(200, 2e-14,"250Hz", col="red", font=2, cex=1)

#####占空比0.3####
plot(k2[,1],  (v+(duty[2]*q[1]))/(k2[,1]*k2[,2]^2), log="x",lwd=1.5,cex=0.6,lty=2,xlab=expression(log(italic(f["v"])) (Hz)), ylab=expression(italic(F)(N)), main="", col=0, pch=pchc[1], ylim=c(0,3e-14))

mtext("k=0.3",3,line=0,font=2,cex=0.8)

lines(lowess(k2[,1],  (v+(duty[2]*q[1]))/(k2[,1]*k2[,2]^2)),type="b",col=mycolors[1],pch=pchc[1], lwd=1.5,cex=0.6,lty=2)

for(i in 1:3){

  points(k2[,1], (v+(duty[2]*q[i+1]))/(k2[,1]*k2[,i+2]^2),pch=pchc[i+1],lwd=1.5,cex=0.6,lty=2,col=0)
  lines(lowess(k2[,1], (v+(duty[2]*q[i+1]))/(k2[,1]*k2[,i+2]^2)),type="b",lwd=1.5,pch=pchc[i+1],cex=0.6,lty=2,col=mycolors[i+1])
}

legend("topleft",cc, col=mycolors, pch=pchc, lwd=2, bty="n",cex=0.8)

abline(v=250, col="red", lwd=2,lty=3)
abline(v=300, col="blue", lwd=2,lty=3)

text(100, 1e-14,"250Hz",col="red", font=2, cex=1)
text(200, 1.5e-14,"300Hz",font=2, col="blue", cex=1)

###占空比0.4###
plot(k3[,1],  (v+(duty[3]*q[1]))/(k3[,1]*k3[,2]^2), log="x", lwd=1.5,cex=0.6,lty=2,xlab=expression(log(italic(f["v"])) (Hz)), ylab=expression(italic(F)(N)), main="", col=0, pch=pchc[1], ylim=c(0,3e-14))

mtext("k=0.4",3,line=0,font=2,cex=0.8)

lines(lowess(k3[,1],  (v+(duty[3]*q[1]))/(k3[,1]*k3[,2]^2)),type="b", col=mycolors[1],pch=pchc[1], lwd=1.5,cex=0.6,lty=2)

for(i in 1:3){

  points(k3[,1], (v+(duty[3]*q[i+1]))/(k3[,1]*k3[,i+2]^2),pch=pchc[i+1],lwd=1.5,cex=0.6,lty=2,col=0)
  lines(lowess(k3[,1], (v+(duty[3]*q[i+1]))/(k3[,1]*k3[,i+2]^2)),type="b",lwd=1.5,pch=pchc[i+1],cex=0.6,lty=2, col=mycolors[i+1])
}

legend("topleft",cc,col=mycolors, pch=pchc, lwd=1.5, bty="n",cex=0.8)

abline(v=250, col="red", lwd=2,lty=3)
abline(v=500, col="blue", lwd=2,lty=3)

text(100, 1e-14,"250Hz", col="red", font=2, cex=1)
text(200, 1.5e-14,"500Hz",font=2, col="blue", cex=1)

####占空比0.5####
plot(k4[,1],  (v+(duty[4]*q[1]))/(k4[,1]*k4[,2]^2),log="x",wd=1.5,cex=0.6,lty=2, xlab=expression(log(italic(f["v"])) (Hz)), ylab=expression(italic(F)(N)), main="", col=0, pch=pchc[1], ylim=c(0,3e-14))

mtext("k=0.5",3,line=0,font=2,cex=0.8)

lines(lowess(k3[,1],  (v+(duty[3]*q[1]))/(k3[,1]*k3[,2]^2)),type="b", col=mycolors[1],pch=pchc[1],lwd=1.5,cex=0.6,lty=2)

for(i in 1:3){

  points(k3[,1], (v+(duty[3]*q[i+1]))/(k3[,1]*k3[,i+2]^2),pch=pchc[i+1], lwd=1.5,cex=0.6,lty=2,col=0)
  lines(lowess(k4[,1], (v+(duty[4]*q[i+1]))/(k4[,1]*k4[,i+2]^2)),type="b",pch=pchc[i+1], col=mycolors[i+1],lwd=1.5,cex=0.6,lty=2)
}
legend("topleft",cc,col=mycolors, pch=pchc, lwd=1.5, bty="n",cex=0.8)

abline(v=300, col="red", lwd=2,lty=3)
abline(v=900, col="blue", lwd=2,lty=3)

text(50, 1e-14,"300Hz", col="red", font=2, cex=1)
text(200, 1.5e-14,"900Hz",font=2, col="blue", cex=1)


setwd("car-insurance-tool")
library(data.table)
library(tidyverse)
library(lubridate)

dt <- read.table("results_image_processing.csv", header=T, sep=',')

table(dt_preproc$is_valid_file)
length(unique(dt$video_file)) # 51 unique files

car_found <- group_by(dt, video_file) %>%
  count(exists_in_rdw)
car_found <- mutate(car_found, at_least_one_exists = ifelse(exists_in_rdw == 'Exists' & n>0, 1, 0)) %>%
  group_by(video_file) %>% summarise(at_least_one_exists=sum(at_least_one_exists, na.rm=T))

ggplot(car_found, aes(x=exists_in_rdw, fill=exists_in_rdw, y=n)) + geom_bar(position='dodge', stat='identity') +
  theme_bw() + facet_wrap(~video_file, scales = 'free_y')

cars_not_found <- filter(car_found, at_least_one_exists==0)
cars_found <- filter(car_found, at_least_one_exists==1)

res <- filter(dt, video_file %in% cars_found$video_file & exists_in_rdw == 'Exists') %>%
  group_by(video_file) %>%
  filter(confidence == max(confidence, na.rm=T))

Mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

res$max_is_right <- c(1,0,1,1,1,0,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1,1,1,0)
lower_conf <- filter(dt, video_file %in% filter(res, max_is_right==0)$video_file) %>%
  filter(exists_in_rdw == 'Exists') %>%
  group_by(video_file) %>%
  filter(plate_nr == Mode(plate_nr))
res$mode_is_right <- c(NA,0,NA,NA,NA,0,rep(NA, 4),0,rep(NA, 5),0,rep(NA, 6),0)

as.data.frame(select(lower_conf, video_file, plate_nr))
# 20170806_125958 - none is right, 9SJS69
# 20170806_130214 - one is right  GT233K    80.9242
# Edited video -  7KDN41    80.7277
# VID_20170815_183919   7KDN41    80.5316
# WhatsApp Video 2017-08-04 at 08.32.59   none is right 91SNS8


library("openxlsx")
library("stringr")
library(ComplexHeatmap)
library(circlize)
library(colorspace)
library(GetoptLong)
library(ggplot2)
library(gplots)
# library(reticulate)
# install.packages("svglite")
library(survival)
require("survival")
library(survminer)

#set the project path
project_path = "./project/"

#load patient data (include survival info)
entire_cohort = read.xlsx(paste(project_path, "data/tcga/entire_cohort.xlsx",sep=""), sheet = 1, colNames = TRUE)
entire_cohort = data.frame(entire_cohort)
entire_cohort$OS = round(entire_cohort$OS/365,2)

#stratify the entire cohort into different groups based on lncRNA expression
xl = entire_cohort[,"ENSG00000206567.8"]
entire_cohort$cluster1 <- 1
entire_cohort$cluster1[which(xl <= median(as.numeric(as.vector(xl))))] <- 0

x2 = entire_cohort[,"ENSG00000187185.4"]
entire_cohort$cluster2 <- 1
entire_cohort$cluster2[which(x2 <= median(as.numeric(as.vector(x2))))] <- 0

x3 = entire_cohort[,"ENSG00000259641.4"]
entire_cohort$cluster3 <- 1
entire_cohort$cluster3[which(x3 <= median(as.numeric(as.vector(x3))))] <- 0

x4 = entire_cohort[,'ENSG00000218510.5']
entire_cohort$cluster4 <- 1
entire_cohort$cluster4[which(x4 <= median(as.numeric(as.vector(x4))))] <- 0

x5 = entire_cohort[,"ENSG00000257989.1"]
entire_cohort$cluster5 <- 1
entire_cohort$cluster5[which(x5 <= median(as.numeric(as.vector(x5))))] <- 0

dif = survdiff(Surv(OS, Censor) ~cluster1, data = entire_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ cluster1, data = entire_cohort)
p <- ggsurvplot(fit, data=entire_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B800", "#2E9FDF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Expression", legend.labs = c("Low", "High"), xlab='Time (years)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

#save figure
title = paste(project_path, "results/ENSG00000206567.8-Survival-AllData.tiff", sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()

dif = survdiff(Surv(OS, Censor) ~cluster2, data = entire_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ cluster2, data = entire_cohort)
p <- ggsurvplot(fit, data=entire_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B800", "#2E9FDF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Expression", legend.labs = c("Low", "High"), xlab='Time (years)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

#save figure
title = paste(project_path, "results/ENSG00000187185.4-Survival-AllData.tiff", sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()

dif = survdiff(Surv(OS, Censor) ~cluster3, data = entire_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ cluster3, data = entire_cohort)
# title = paste(selectedLncRNA , " Expression")
p <- ggsurvplot(fit, data=entire_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B800", "#2E9FDF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Expression", legend.labs = c("Low", "High"), xlab='Time (years)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

#save figure
title = paste(project_path, "results/ENSG00000259641.4-Survival-AllData.tiff", sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()

dif = survdiff(Surv(OS, Censor) ~cluster4, data = entire_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ cluster4, data = entire_cohort)
# title = paste(selectedLncRNA , " Expression")
p <- ggsurvplot(fit, data=entire_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B800", "#2E9FDF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Expression", legend.labs = c("Low", "High"), xlab='Time (years)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

#save figure
title = paste(project_path, "results/ENSG00000218510.5-Survival-AllData.tiff", sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()

dif = survdiff(Surv(OS, Censor) ~cluster5, data = entire_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ cluster5, data = entire_cohort)
p <- ggsurvplot(fit, data=entire_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B800", "#2E9FDF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Expression", legend.labs = c("Low", "High"), xlab='Time (years)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

#save figure
title = paste(project_path, "results/ENSG00000257989.1-Survival-AllData.tiff", sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()


##' Hour rose plot. Copied and modified from the openair package.
##' `phour()` plotted a 24-hour clock, indicating the active hours on the basis of a time column in a data frame. It is highly cumstomized on the basis of the `openair::windrose()` function`.
##'
##' @param my_df A data frame containing the fields ws and wd.
##' @param ws A character string of the name of the column representing the radium of the circular sectors in the diagram. It can be SBD payout, votes, comments, etc..
##' @param wd A character sring of the name of the column representing the hour of the day.
##' @param ws2 The user can supply a second set of data with which the first can be compared.
##' @param wd2 see ws2.
##' @param ws.int A numeric vector of the ws interval. Default is 2.
##' @param angle The hour spokes. Other potentially useful angle is 3 (hours).
##' @param type type determines how the data are split i.e. conditioned, and then plotted.  It can be 'season', 'year', 'weekday'...  The default is will produce a single plot using the entire data. It can also be a numeric or factor vector.
##' @param cols Colours for plotting.  'default', 'increment', 'heat', 'jet', 'hue' and user defined, such as c("yellow", "green", "blue", "black").
##' @param grid.line Grid line interval. NULL in default.It can also be a numeric value like 10, or a list like list(value = 10, lty = 5, col = "purple").
##' @param width The adjustment factor for width of payout intervals. For example, width = 1.5 will make the paddle width 1.5 times wider. For paddle = TRUE.
##' @param seg  The width of the segments. 0.5 will produce segments 0.5 * angle.
##' @param auto.text  A logical value of whether formatting the names and units automatically in the titles and axis labels
##' @param breaks A numeric vector of the number of break points for payouts. 4 by default, which generates the break points 2, 4, 6, 8 SBD for ws.int default of 2 SBD. It can also be c(0, 1, 10, 100), which breaks the data into segments <1, 1-10, 10-100, >100.
##' @param offset A numeric value (default 10) of the size of the 'hole' in the middle of the plot, expressed as a percentage of the polar axis scale.
##' @param paddle A logic value. TRUE means the 'paddle' style spokes, and FALSE means the 'wedge' style spokes.
##' @param key.header A character string of additional text above the scale key.
##' @param key.footer A character string of additional text below the scale key.
##' @param key.position A character string of the location of the scale key. 'top', 'right', 'bottom' and 'left'.
##' @param key Fine control of the scale key
##' @param dig.lab A numeric value of the signficant digits at which scientific number formatting is used in break point.
##' @param statistic A character string of the statistic to be applied.
##' - 'prop.count' (default) sizes bins according to the proportion of the frequency of the records,
##' - 'prop.mean' sizes bins according to their relative contribution to the mean,
##' - 'abs.count' provides the absolute count of records in each bin.
##' @param pollutant Alternative data series to be sampled.
##' @param annotate A logic value or a character string.
##' - TRUE: the percentage calm and mean values are printed in each panel together with a description of the statistic below the plot.
##' - " ": only the stastic is below the plot.
##' - Custom annotations may be added by setting value to c("annotation 1", "annotation 2").
##' @param border A character string of the border colour for shaded areas.
##' @param cust_labels A numeric vector displayed as the customed labels
##' @param ... other parameters
##' @param col_time the column name for the time stamp
##' @param quantile_line whether to display the quantile line
##'
#' @return A figure with the active hour rose
#' @export
#' @examples
#' phour()
phour <- function(my_df = NA, col_time = 'created',
                  ws = "ws", wd = "hour360",
                  ws2 = NA, wd2 = NA,
                  ws.int = 30, angle = 1, type = "default", cols = "default",
                  grid.line = NULL, width = 1, seg = 0.9, auto.text = TRUE,
                  breaks = 4, offset = 10, paddle = FALSE,
                  key.header = NULL, key.footer = "(SBD)",
                  key.position = "right", key = FALSE,
                  dig.lab = 5, statistic = "prop.count", pollutant = NULL,
                  cust_labels = c(0, 6, 12, 18), annotate = FALSE,
                  border = NA, quantile_line = TRUE,
                  ...)
{
  if(is.na(my_df)) {
    return(print('Please give a valid data frame.'))
  } else {
    my_df <- as.data.frame(my_df)
    angle <- 15 * angle
    my_df$hour <- round(as.numeric(format(my_df[, col_time], '%H')) + as.numeric(format(my_df[, col_time], '%M'))/60, 1)
    my_df$hour360 <- my_df$hour * 360 / 24
    my_df$ws <- 1

    if (is.null(seg))
      seg <- 0.9
    if (length(cols) == 1 && cols == "greyscale") {
      lattice::trellis.par.set(list(strip.background = list(col = "white")))
      calm.col <- "black"
    }
    else {
      calm.col <- "forestgreen"
    }
    current.strip <- lattice::trellis.par.get("strip.background")
    on.exit(lattice::trellis.par.set("strip.background", current.strip))
    if (360/angle != round(360/angle)) {
      warning("In windRose(...):\n  angle will produce some spoke overlap",
              "\n  suggest one of: 5, 6, 8, 9, 10, 12, 15, 30, 45, etc.",
              call. = FALSE)
    }
    if (angle < 3) {
      warning("In windRose(...):\n  angle too small", "\n  enforcing 'angle = 3'",
              call. = FALSE)
      angle <- 3
    }
    extra.args <- list(...)
    extra.args$xlab <- if ("xlab" %in% names(extra.args))
      openair::quickText(extra.args$xlab, auto.text)
    else openair::quickText("", auto.text)
    extra.args$ylab <- if ("ylab" %in% names(extra.args))
      openair::quickText(extra.args$ylab, auto.text)
    else openair::quickText("", auto.text)
    extra.args$main <- if ("main" %in% names(extra.args))
      openair::quickText(extra.args$main, auto.text)
    else openair::quickText("", auto.text)
    if (is.character(statistic)) {
      ok.stat <- c("prop.count", "prop.mean", "abs.count",
                   "frequency")
      if (!is.character(statistic) || !statistic[1] %in% ok.stat) {
        warning("In windRose(...):\n  statistic unrecognised",
                "\n  enforcing statistic = 'prop.count'", call. = FALSE)
        statistic <- "prop.count"
      }
      if (statistic == "prop.count") {
        stat.fun <- length
        stat.unit <- "%"
        stat.scale <- "all"
        stat.lab <- "Frequency of counts (%)"
        stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE),
                                        3)
        stat.lab2 <- "mean"
        stat.labcalm <- function(x) round(x, 1)
      }
      if (statistic == "prop.mean") {
        stat.fun <- function(x) sum(x, na.rm = TRUE)
        stat.unit <- "%"
        stat.scale <- "panel"
        stat.lab <- "Proportion contribution to the mean (%)"
        stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE),
                                        3)
        stat.lab2 <- "mean"
        stat.labcalm <- function(x) round(x, 1)
      }
      if (statistic == "abs.count" | statistic == "frequency") {
        stat.fun <- length
        stat.unit <- ""
        stat.scale <- "none"
        stat.lab <- "Count"
        stat.fun2 <- function(x) round(length(x), 0)
        stat.lab2 <- "count"
        stat.labcalm <- function(x) round(x, 0)
      }
    }
    if (is.list(statistic)) {
      stat.fun <- statistic$fun
      stat.unit <- statistic$unit
      stat.scale <- statistic$scale
      stat.lab <- statistic$lab
      stat.fun2 <- statistic$fun2
      stat.lab2 <- statistic$lab2
      stat.labcalm <- statistic$labcalm
    }
    vars <- c(wd, ws)
    diff <- FALSE
    rm.neg <- TRUE
    if (!is.na(ws2) & !is.na(wd2)) {
      vars <- c(vars, ws2, wd2)
      diff <- TRUE
      rm.neg <- FALSE
      my_df$ws <- my_df[, ws2] - my_df[, ws]
      my_df$wd <- my_df[, wd2] - my_df[, wd]
      id <- which(my_df$wd < 0)
      if (length(id) > 0)
        my_df$wd[id] <- my_df$wd[id] + 360
      pollutant <- "ws"
      key.footer <- "ws"
      wd <- "wd"
      ws <- "ws"
      vars <- c("ws", "wd")
      if (missing(angle))
        angle <- 10
      if (missing(offset))
        offset <- 20
      if (is.na(breaks[1])) {
        max.br <- max(ceiling(abs(c(min(my_df$ws, na.rm = TRUE),
                                    max(my_df$ws, na.rm = TRUE)))))
        breaks <- c(-1 * max.br, 0, max.br)
      }
      if (missing(cols))
        cols <- c("lightskyblue", "tomato")
      seg <- 1
    }
    if (any(type %in% dateTypes))
      vars <- c(vars, "date")
    if (!is.null(pollutant))
      vars <- c(vars, pollutant)
    my_df <- checkPrep(my_df, vars, type, remove.calm = FALSE,
                                 remove.neg = rm.neg)
    my_df <- na.omit(my_df)
    if (is.null(pollutant))
      pollutant <- ws
    my_df$x <- my_df[, pollutant]
    my_df[, wd] <- angle * ceiling(my_df[, wd]/angle - 0.5)
    my_df[, wd][my_df[, wd] == 0] <- 360
    my_df[, wd][my_df[, ws] == 0] <- -999
    if (length(breaks) == 1)
      breaks <- 0:(breaks - 1) * ws.int
    if (max(breaks) < max(my_df$x, na.rm = TRUE))
      breaks <- c(breaks, max(my_df$x, na.rm = TRUE))
    if (min(breaks) > min(my_df$x, na.rm = TRUE))
      warning("Some values are below minimum break.")
    breaks <- unique(breaks)
    my_df$x <- cut(my_df$x, breaks = breaks, include.lowest = FALSE,
                   dig.lab = dig.lab)
    theLabels <- gsub("[(]|[)]|[[]|[]]", "", levels(my_df$x))
    theLabels <- gsub("[,]", " to ", theLabels)
    prepare.grid <- function(my_df) {
      if (all(is.na(my_df$x)))
        return()
      levels(my_df$x) <- c(paste("x", 1:length(theLabels),
                                 sep = ""))
      all <- stat.fun(my_df[, wd])
      calm <- my_df[my_df[, wd] == -999, ][, pollutant]
      my_df <- my_df[my_df[, wd] != -999, ]
      calm <- stat.fun(calm)
      weights <- tapply(my_df[, pollutant], list(my_df[,
                                                       wd], my_df$x), stat.fun)
      if (stat.scale == "all") {
        calm <- calm/all
        weights <- weights/all
      }
      if (stat.scale == "panel") {
        temp <- stat.fun(stat.fun(weights)) + calm
        calm <- calm/temp
        weights <- weights/temp
      }
      weights[is.na(weights)] <- 0
      weights <- t(apply(weights, 1, cumsum))
      if (stat.scale == "all" | stat.scale == "panel") {
        weights <- weights * 100
        calm <- calm * 100
      }
      panel.fun <- stat.fun2(my_df[, pollutant])
      u <- mean(sin(2 * pi * my_df[, wd]/360))
      v <- mean(cos(2 * pi * my_df[, wd]/360))
      mean.wd <- atan2(u, v) * 360/2/pi
      if (all(is.na(mean.wd))) {
        mean.wd <- NA
      }
      else {
        if (mean.wd < 0)
          mean.wd <- mean.wd + 360
        if (mean.wd > 180)
          mean.wd <- mean.wd - 360
      }
      weights <- cbind(data.frame(weights), wd = as.numeric(row.names(weights)),
                       calm = calm, panel.fun = panel.fun, mean.wd = mean.wd)
      weights
    }
    if (paddle) {
      poly <- function(wd, len1, len2, width, colour, x.off = 0,
                       y.off = 0) {
        theta <- wd * pi/180
        len1 <- len1 + off.set
        len2 <- len2 + off.set
        x1 <- len1 * sin(theta) - width * cos(theta) + x.off
        x2 <- len1 * sin(theta) + width * cos(theta) + x.off
        x3 <- len2 * sin(theta) - width * cos(theta) + x.off
        x4 <- len2 * sin(theta) + width * cos(theta) + x.off
        y1 <- len1 * cos(theta) + width * sin(theta) + y.off
        y2 <- len1 * cos(theta) - width * sin(theta) + y.off
        y3 <- len2 * cos(theta) + width * sin(theta) + y.off
        y4 <- len2 * cos(theta) - width * sin(theta) + y.off
        lattice::lpolygon(c(x1, x2, x4, x3), c(y1, y2, y4, y3), col = colour,
                          border = border)
      }
    }
    else {
      poly <- function(wd, len1, len2, width, colour, x.off = 0,
                       y.off = 0) {
        len1 <- len1 + off.set
        len2 <- len2 + off.set
        theta <- seq((wd - seg * angle/2), (wd + seg * angle/2),
                     length.out = (angle - 2) * 10)
        theta <- ifelse(theta < 1, 360 - theta, theta)
        theta <- theta * pi/180
        x1 <- len1 * sin(theta) + x.off
        x2 <- rev(len2 * sin(theta) + x.off)
        y1 <- len1 * cos(theta) + x.off
        y2 <- rev(len2 * cos(theta) + x.off)
        lattice::lpolygon(c(x1, x2), c(y1, y2), col = colour, border = border)
      }
    }
    my_df <- openair::cutData(my_df, type, ...)
    results.grid <- plyr::ddply(.data = my_df,
                                .variables = type,
                                .fun = prepare.grid)
    results.grid$calm <- stat.labcalm(results.grid$calm)
    results.grid$mean.wd <- stat.labcalm(results.grid$mean.wd)
    strip.dat <- strip.fun(results.grid, type, auto.text)
    strip <- strip.dat[[1]]
    strip.left <- strip.dat[[2]]
    pol.name <- strip.dat[[3]]
    if (length(theLabels) < length(cols)) {
      col <- cols[1:length(theLabels)]
    }
    else {
      col <- openair::openColours(cols, length(theLabels))
    }
    max.freq <- max(results.grid[, (length(type) + 1):(length(theLabels) + length(type))], na.rm = TRUE)
    off.set <- max.freq * (offset/100)
    box.widths <- seq(0.002^0.25, 0.016^0.25, length.out = length(theLabels))^4
    box.widths <- box.widths * max.freq * angle/5
    legend <- list(col = col, space = key.position, auto.text = auto.text,
                   labels = theLabels,
                   footer = key.footer, header = key.header,
                   height = 0.6, width = 1.5, fit = "scale",
                   plot.style = if (paddle) "paddle" else "other")
    legend <- makeOpenKeyLegend(key, legend, "windRose")
    temp <- paste(type, collapse = "+")
    myform <- formula(paste("x1 ~ wd | ", temp, sep = ""))
    mymax <- 2 * max.freq
    myby <- if (is.null(grid.line))
      pretty(c(0, mymax), 10)[2]
    else grid.line
    if (myby/mymax > 0.9)
      myby <- mymax * 0.9
    xyplot.args <- list(x = myform,
                        xlim = 1.03 * c(- max.freq - off.set, max.freq + off.set),
                        ylim = 1.03 * c(- max.freq - off.set, max.freq + off.set),
                        data = results.grid, type = "n",
                        sub = stat.lab, strip = strip, strip.left = strip.left,
                        as.table = TRUE, aspect = 1, par.strip.text = list(cex = 0.8),
                        scales = list(draw = FALSE), panel = function(x, y,
                                                                      subscripts, ...) {
                          lattice::panel.xyplot(x, y, ...)
                          angles <- seq(0, 2 * pi, length = 360)
                          sapply(seq(off.set, mymax, by = myby), function(x) lattice::llines(x *
                                                                                sin(angles), x * cos(angles), col = "grey85",
                                                                                lwd = 1))
                          subdata <- results.grid[subscripts, ]
                          upper <- max.freq + off.set
                          lar <- upper * 0.9
                          for (langle in seq(0, 2 * pi, pi/4)) lattice::larrows(0, 0, lar * cos(langle), lar * (sin(langle)), code = 3,length = 0, col = 'grey')
                          for (langle in seq(0, 2 * pi, pi/2)) lattice::larrows(0, 0, lar * cos(langle), lar * (sin(langle)), code = 3,length = 0)
                          if (quantile_line) {
                            for (langle in quantile(my_df[, wd], seq(0.25, 1, 0.25)) / 180 * pi) lattice::larrows(0, 0, lar * sin(langle), lar * (cos(langle)), code = 1,length = 0, col = 'red')
                          }

                          # larrows(-upper * 0.9, 0, upper * 0.9, 0, code = 3,
                          #         length = 0)
                          # larrows(0, -upper * 0.9, 0, upper * 0.9, code = 3,
                          #         length = 0)

                          lattice::ltext(0 * upper, upper * 0.95, cust_labels[1], cex = 1)
                          lattice::ltext(upper * 0.95, 0 * upper, cust_labels[2], cex = 1)
                          lattice::ltext(0 * upper, upper * -1 * 0.95, cust_labels[3],
                                         cex = 1)
                          lattice::ltext(upper * -1 * 0.95, 0 * upper, cust_labels[4],
                                         cex = 1)
                          if (nrow(subdata) > 0) {
                            for (i in 1:nrow(subdata)) {
                              with(subdata, {
                                for (j in 1:length(theLabels)) {
                                  if (j == 1) {
                                    temp <- "poly(wd[i], 0, x1[i], width * box.widths[1], col[1])"
                                  } else {
                                    temp <- paste("poly(wd[i], x", j - 1,
                                                  "[i], x", j, "[i], width * box.widths[",
                                                  j, "], col[", j, "])", sep = "")
                                  }
                                  eval(parse(text = temp))
                                }
                              })
                            }
                          }
                          lattice::ltext(seq((myby + off.set), mymax, myby) * sin(pi/4),
                                         seq((myby + off.set), mymax, myby) * cos(pi/4),
                                         paste(seq(myby, mymax, by = myby), stat.unit,
                                               sep = ""), cex = 0.7)
                          if (annotate) if (statistic != "prop.mean") {
                            if (!diff) {
                              lattice::ltext(max.freq + off.set, -max.freq - off.set,
                                             label = paste(stat.lab2, " = ", subdata$panel.fun[1],
                                                           "\ncalm = ", subdata$calm[1], stat.unit,
                                                           sep = ""), adj = c(1, 0), cex = 0.7, col = calm.col)
                            }
                            if (diff) {
                              lattice::ltext(max.freq + off.set, -max.freq - off.set,
                                             label = paste("mean ws = ", round(subdata$panel.fun[1],
                                                                               1), "\nmean wd = ", round(subdata$mean.wd[1],
                                                                                1), sep = ""), adj = c(1, 0), cex = 0.7,
                                             col = calm.col)
                            }
                          } else {
                            lattice::ltext(max.freq + off.set, -max.freq - off.set,
                                           label = paste(stat.lab2, " = ", subdata$panel.fun[1],
                                                         stat.unit, sep = ""), adj = c(1, 0), cex = 0.7,
                                           col = calm.col)
                          }
                        }, legend = legend)
    xyplot.args <- listUpdate(xyplot.args, extra.args)
    plt <- do.call(lattice::xyplot, xyplot.args)
    if (length(type) == 1)
      plot(plt)
    else plot(useOuterStrips(plt, strip = strip, strip.left = strip.left))
    newdata <- results.grid
    output <- list(plot = plt, data = newdata, call = match.call())
    class(output) <- "openair"
    invisible(output)
  }
}

# Check input file and prepare data.
#
# Author: DCC

checkPrep <- function(mydata, Names, type, remove.calm = TRUE, remove.neg = TRUE,
                      strip.white = TRUE, wd = "wd") {

  ## deal with conditioning variable if present, if user-defined, must exist in data
  ## pre-defined types
  ## existing conditioning variables that only depend on date (which is checked)
  conds <- c(
    "default", "year", "hour", "month", "season", "weekday",
    "weekend", "monthyear", "gmtbst", "bstgmt", "dst", "daylight",
    "yearseason", "seasonyear"
  )
  all.vars <- unique(c(names(mydata), conds))

  varNames <- c(Names, type) ## names we want to be there
  matching <- varNames %in% all.vars

  if (any(!matching)) {
    ## not all variables are present
    stop(cat("Can't find the variable(s)", varNames[!matching], "\n"))
  }

  ## add type to names if not in pre-defined list
  if (any(type %in% conds == FALSE)) {
    ids <- which(type %in% conds == FALSE)
    Names <- c(Names, type[ids])
  }

  ## if type already present in data frame
  if (any(type %in% names(mydata))) {
    ids <- which(type %in% names(mydata))
    Names <- unique(c(Names, type[ids]))
  }

  ## just select data needed
  mydata <- mydata[, Names]

  ## if site is in the data set, check none are missing
  ## seems to be a problem for some KCL data...
  if ("site" %in% names(mydata)) { ## split by site

    ## remove any NA sites
    if (anyNA(mydata$site)) {
      id <- which(is.na(mydata$site))
      mydata <- mydata[-id, ]
    }
  }

  ## sometimes ratios are considered which can results in infinite values
  ## make sure all infinite values are set to NA
  mydata[] <- lapply(mydata, function(x) {
    replace(x, x == Inf | x == -Inf, NA)
  })

  if ("ws" %in% Names) {
    if ("ws" %in% Names & is.numeric(mydata$ws)) {

      ## check for negative wind speeds
      if (any(sign(mydata$ws[!is.na(mydata$ws)]) == -1)) {
        if (remove.neg) { ## remove negative ws only if TRUE
          warning("Wind speed <0; removing negative data")
          mydata$ws[mydata$ws < 0] <- NA
        }
      }
    }
  }

  ## round wd to make processing obvious
  ## data already rounded to nearest 10 degress will not be affected
  ## data not rounded will be rounded to nearest 10 degrees
  ## assumes 10 is average of 5-15 etc
  if (wd %in% Names) {
    if (wd %in% Names & is.numeric(mydata[, wd])) {

      ## check for wd <0 or > 360
      if (any(sign(mydata[[wd]][!is.na(mydata[[wd]])]) == -1 |
              mydata[[wd]][!is.na(mydata[[wd]])] > 360)) {
        warning("Wind direction < 0 or > 360; removing these data")
        mydata[[wd]][mydata[[wd]] < 0] <- NA
        mydata[[wd]][mydata[[wd]] > 360] <- NA
      }

      if (remove.calm) {
        if ("ws" %in% names(mydata)) {
          mydata[[wd]][mydata$ws == 0] <- NA ## set wd to NA where there are calms
          mydata$ws[mydata$ws == 0] <- NA ## remove calm ws
        }
        mydata[[wd]][mydata[[wd]] == 0] <- 360 ## set any legitimate wd to 360

        ## round wd for use in functions - except windRose/pollutionRose
        mydata[[wd]] <- 10 * ceiling(mydata[[wd]] / 10 - 0.5)
        mydata[[wd]][mydata[[wd]] == 0] <- 360 # angles <5 should be in 360 bin
      }
      mydata[[wd]][mydata[[wd]] == 0] <- 360 ## set any legitimate wd to 360
    }
  }

  ## make sure date is ordered in time if present
  if ("date" %in% Names) {
    if ("POSIXlt" %in% class(mydata$date)) {
      stop("date should be in POSIXct format not POSIXlt")
    }

    ## if date in format dd/mm/yyyy hh:mm (basic check)
    if (length(grep("/", as.character(mydata$date[1]))) > 0) {
      mydata$date <- as.POSIXct(strptime(mydata$date, "%d/%m/%Y %H:%M"), "GMT")
    }

    ## try and work with a factor date - but probably a problem in original data
    if (is.factor(mydata$date)) {
      warning("date field is a factor, check date format")
      mydata$date <- as.POSIXct(mydata$date, "GMT")
    }

    mydata <- arrange(mydata, date)

    ## make sure date is the first field
    if (names(mydata)[1] != "date") {
      mydata <- mydata[c("date", setdiff(names(mydata), "date"))]
    }

    ## check to see if there are any missing dates, stop if there are
    ids <- which(is.na(mydata$date))
    if (length(ids) > 0) {
      mydata <- mydata[-ids, ]
      warning(paste(
        "Missing dates detected, removing",
        length(ids), "lines"
      ), call. = FALSE)
    }

    ## daylight saving time can cause terrible problems - best avoided!!

    if (any(dst(mydata$date))) {
      warning("Detected data with Daylight Saving Time, converting to UTC/GMT")
      mydata$date <- lubridate::force_tz(mydata$date, tzone = "GMT")
    }
  }

  if (strip.white) {
    ## set panel strip to white
    suppressWarnings(trellis.par.set(list(strip.background = list(col = "white"))))
  }

  ## return data frame
  return(mydata)
}

dateTypes <- c(
  "year", "hour", "month", "season", "weekday", "weekend",
  "monthyear", "gmtbst", "bstgmt", "dst", "daylight",
  "seasonyear", "yearseason"
)

## list update function
## for lattice type object structure and ... handling

## (currently used by)
## (all openair plots that include colorkey controlled by drawOpenKey)

## listUpdate function
# [in development]
listUpdate <- function(a, b, drop.dots = TRUE,
                       subset.a = NULL, subset.b = NULL) {
  if (drop.dots) {
    a <- a[names(a) != "..."]
    b <- b[names(b) != "..."]
  }
  if (!is.null(subset.a)) {
    a <- a[names(a) %in% subset.a]
  }
  if (!is.null(subset.b)) {
    b <- b[names(b) %in% subset.b]
  }
  if (length(names(b) > 0)) {
    a <- modifyList(a, b)
  }
  a
}

## makeOpenKeyLegend v0.1

## common code for making legend list
## objects for use with drawOpenkey outputs

## uses listUpdate in utilities

makeOpenKeyLegend <- function(key, default.key, fun.name = "function") {
  # handle logicals and lists
  if (is.logical(key)) {
    legend <- if (key) default.key else NULL
  } else if (is.list(key)) {
    legend <- listUpdate(default.key, key)
  } else {
    if (!is.null(key)) {
      warning(
        paste(
          "In ", fun.name, "(...):\n unrecognised key not exported/applied\n",
          " [see ?drawOpenKey for key structure/options]",
          sep = ""
        ),
        call. = FALSE
      )
    }
    legend <- NULL
  }

  # structure like legend for drawOpenKey
  if (!is.null(legend)) {
    legend <- list(right = list(
      fun = drawOpenKey, args = list(key = legend),
      draw = FALSE
    ))
    if ("space" %in% names(legend$right$args$key)) {
      names(legend)[[1]] <- legend$right$args$key$space
    }
  }
  legend
}

## gives names of lattice strips
strip.fun <- function(results.grid, type, auto.text) {
  ## proper names of labelling ###################################################
  pol.name <- sapply(
    levels(factor(results.grid[[type[1]]])),
    function(x) quickText(x, auto.text)
  )
  strip <- strip.custom(factor.levels = pol.name)

  if (length(type) == 1) {
    strip.left <- FALSE
  } else { ## two conditioning variables

    pol.name <- sapply(
      levels(factor(results.grid[[type[2]]])),
      function(x) quickText(x, auto.text)
    )
    strip.left <- strip.custom(factor.levels = pol.name)
  }
  if (length(type) == 1 & type[1] == "default") strip <- FALSE ## remove strip
  list(strip, strip.left, pol.name)
}


  biomass.summary.db = function( DS="complete", p=NULL ) {
    #browser()
    warning("This function is deprecated")

    sum_outdir = file.path( project.datadirectory("bio.snowcrab"), "output", "timeseries" )

    if (DS=="surplusproduction" ){
      res =  biomass.summary.db(p=p, DS="complete")
      sb = list(
        bmin = 0.001, # scaled to 1 but allow overshooting
        bmax = 1.1, # scaled to 1 but allow overshooting
        qmin = 0.001,
        qmax = 2,
        qmu = rep(1,3),
        qsd = rep(0.3,3),
        bomup=rep(-2.5579,3),
        bosdp=rep(0.47726,3),
        bpmup=rep(-2.5579,3),
        bpsdp=rep(0.47726,3),
        bomin=rep(0,3),
        bomax=rep(5,3),
        bpmin=rep(0,3),
        bpmax=rep(5,3),
        recmax= c( 10^3, 10^4, 10^2 ),
        Kmu = log( c( 4, 40, 1)), #for ln
        Ksd = c(0.06 ,0.06, 0.04), #for ln
        rmu = rep(0.96, 3),
        rsd = rep(0.01041271, 3),
        b0min = c(0.5, 0.5, 0.2),  # prior: mean value possible in  N,S,4X
        b0max = c(0.8, 0.8, 0.6),  # prior: mean value possible in  N,S,4X
        cvnormalmin = 0.05, # upper limit of CV for normally distributed variables ~ 0.5 covers a reasonably large range, try:   curve( dnorm(x, mean=1, sd=0.5), from=0.1, to=4  )
        cvnormalmax = 0.4, # upper limit of CV for normally distributed variables ~ 0.5 covers a reasonably large range, try:   curve( dnorm(x, mean=1, sd=0.5), from=0.1, to=4  )
        cvlognormalmin = 0.05, #  curve( dlnorm(x, meanlog=log(1), sdlog=0.25), from=0.01, to=2 )
        cvlognormalmax = 0.4, #  curve( dlnorm(x, meanlog=log(1), sdlog=0.25), from=0.01, to=2 )
      # for lognormal: cv = sqrt(exp(sigma^2) - 1); or sigma = sqrt(log(cv^2+ 1) ) ==> sigma = sqrt( log(0.25^2 + 1)) = 0.246 ~ cv -- i.e. cv ~ sd
        IOA = as.matrix(res$B), # observed index of abundance
        IOCPUE = as.matrix(res$CPUE), # observed index of catch rate
        IOAG = as.matrix(res$Bg), # observed index of abundance as geometric mean catches
        IOAcv = as.matrix( log(res$Bsd )), # observed index of log abundance SD estimates ~ CV
        #IREC = as.matrix(res$R), # observed index of abundance
        #IRECcv = as.matrix(res$Rsd ), # observed index of log abundance SD estimates ~CV
        CAT = as.matrix(res$L) , # catches  , assume 20% handling mortality and illegal landings
        CATmin = apply( res$L, 2, min, na.rm=T),
        CATmax = apply( res$L, 2, max, na.rm=T),
        er = 0.2,  # target exploitation rate
        U = ncol( res$B),  # number of regions
        N = nrow( res$B) , # no years with data
        M = 3, # no years for projections
        ty = 7,  # index of the transition year (2004) between spring and fall surveys
        cfa4x = 3, # index of cfa4x
        eps = 1e-4  # small non-zero number
      )

    # set poor data to NA's and maximize associated CV's

      cfa.north =  1 # column index
      cfa.north.bad.data = which( as.numeric(rownames(sb$IOA)) <= 1997 )
      sb$IOA[ cfa.north.bad.data, cfa.north ] = NA
      sb$IOAcv[ cfa.north.bad.data, cfa.north ] = mean( sb$IOAcv[,cfa.north ] ,na.rm=T )
      #sb$IRECcv[ cfa.north.bad.data, cfa.north ] = mean( sb$IRECcv[,cfa.north ] ,na.rm=T )
      #sb$IREC[ cfa.north.bad.data, cfa.north ] = mean( sb$IREC[,cfa.north ] ,na.rm=T )

      cfa.south =  2 # column index
      cfa.south.bad.data = which( as.numeric(rownames(sb$IOA)) <= 1998 )
      sb$IOA[ cfa.south.bad.data, cfa.south ] = NA
      sb$IOAcv[ cfa.south.bad.data, cfa.south ] = mean( sb$IOAcv[,cfa.south ] ,na.rm=T )

      cfa.nodata =   which( as.numeric(rownames(sb$IOA)) <= 2003 )
      sb$IOA[ cfa.nodata , sb$cfa4x ] = NA
      sb$IOAcv[ cfa.nodata , sb$cfa4x ] = mean( sb$IOAcv[,sb$cfa4x] ,na.rm=T )

      # recruitment index has no process model right now ... use min value
      #sb$IREC[ cfa.nodata , sb$cfa4x ] = min( sb$IREC[,sb$cfa4x] ,na.rm=T )
      #sb$IRECcv[ cfa.nodata , sb$cfa4x ] = mean( sb$IRECcv[,sb$cfa4x] ,na.rm=T )

      #sb$IREC = log( sb$IREC )
      return(sb)
    }

    if (DS %in% c("complete", "complete.redo") ) {
      fn = file.path( sum_outdir, "complete_ts.rdata" )
      if ( DS == "complete") {
        out = NULL
        if (file.exists(fn)) load(fn)
        return( out )
      }

      L = biomass.summary.db( DS="L.redo", p=p  )  # must go first as part of biomass estimates
      B = biomass.summary.db( DS="B.redo", p=p )  # rename to avoid confusion below as B is also used
      # Bsd = biomass.summary.db( DS="Bsd.redo", p=p )  # rename to avoid confusion below as B is also used
      CPUE=biomass.summary.db(DS="CPUE.redo") #brings in catch rate estimates in kg
     #  R = biomass.summary.db( DS="R.redo", p=p  )  # rename to avoid confusion below as B is also used
     #  Rsd = biomass.summary.db( DS="Rsd.redo", p=p  )  # rename to avoid confusion below as B is also used

      # geometric means -- sd are on log scale
     Bg = biomass.summary.db( DS="B_geomean.redo", p=p  )
     # Bgsd = biomass.summary.db( DS="B_geomeansd.redo", p=p  )
     # Rg = biomass.summary.db( DS="R_geomean.redo", p=p  )
     # Rgsd = biomass.summary.db( DS="R_geomeansd.redo", p=p  )

      # cfa4x have had no estimates prior to 2004
      spring = 1998:2003
      ib = which( as.numeric( rownames( B) ) %in% spring )
      B[ib,3] = NA

      L = L[ which(rownames(L) %in% rownames(B) ),  ]
      CPUE = CPUE[ which(rownames(CPUE) %in% rownames(B) ),  ]
    #  Bsd = Bsd[ which(rownames(Bsd) %in% rownames(B) ),  ]
    #  R = R[ which(rownames(R) %in% rownames(B) ),  ]
    #  Rsd = Rsd[ which(rownames(Rsd) %in% rownames(B) ),  ]
      Bg = Bg[ which(rownames(Bg) %in% rownames(B) ),  ]
    #  Bgsd = Bgsd[ which(rownames(Bgsd) %in% rownames(B) ),  ]
    #  Rg = Rg[ which(rownames(Rg) %in% rownames(B) ),  ]
    #  Rgsd = Rgsd[ which(rownames(Rgsd) %in% rownames(B) ),  ]

     out = list( L=L, B=B, Bsd=Bsd,Bg=Bg, Bgsd=Bgsd, CPUE=CPUE )

    #  out = list( L=L, B=B, R=R, Bsd=Bsd, Rsd=Rsd, Bg=Bg, Bgsd=Bgsd, Rg=Rg, Rgsd=Rgsd )

      save( out, file=fn, compress=T )

      return( fn )
    }

    if (DS %in% c("L", "L.redo" ) ) {
      fn = file.path( sum_outdir, "L_ts.rdata" )
      L=NULL
      if (DS=="L") {
        if (file.exists(fn)) load(fn)
        return(L)
      }
      L = landings.aggregate( format="bugs" )
      L = L[ , c("cfanorth", "cfasouth", "cfa4x") ]
      L = as.data.frame(L)
      save( L, file=fn, compress=T )
      return (L)
    }

    if (DS %in% c("CPUE", "CPUE.redo" ) ) {
      fn = file.path( sum_outdir, "CPUE_ts.rdata" )
      CPUE=NULL
      if (DS=="CPUE") {
        if (file.exists(fn)) load(fn)
        return(CPUE)
      }
      CPUE = cpue.aggregate( format="bugs" )
      CPUE = CPUE[ , c("cfanorth", "cfasouth", "cfa4x") ]
      CPUE = as.data.frame(CPUE)
      save( CPUE, file=fn, compress=T )
      return (CPUE)
    }

    if (DS %in% c("B", "B.redo" )) {
      fn = file.path( sum_outdir, "B_ts.rdata" )
      B=NULL
      if (DS=="B") {
        if (file.exists(fn)) load(fn)
        return(B)
      }

      # biomass data: post-fishery biomass are determined by survey B)
      pSC = bio.snowcrab::snowcrab_carstm( DS="parameters", assessment.years=2000:p$year.assessment )
      B = carstm::carstm_summary(p=pSC, operation="load_timeseries", carstm_model_label=pSC$carstm_model_label  )

     # areas=c("cfanorth", "cfasouth", "cfa4x", "cfa23", "cfa24")
      # B[,areas] = B[,areas] / 1000 # kt
      save( B, file=fn, compress=T )
      return (B)

    }

    if (DS %in% c("Bsd", "Bsd.redo" )) {
      fn = file.path( sum_outdir, "Bsd_ts.rdata" )
      B=NULL
      if (DS=="Bsd") {
        if (file.exists(fn)) load(fn)
        return(B)
      }
      # biomass data: post-fishery biomass are determined by survey B)
        K = interpolation.db( DS="interpolation.simulation", p=p )
        areas=c("cfanorth", "cfasouth", "cfa4x")
        td = K[ which( K$region %in% areas) ,]
        td$totalsd.ln = abs(td$total.ub - td$total.lb)/(2*1.96) # assuming approx normal
        B = tapply( td$totalsd.ln, INDEX=td[,c("yr", "region")], FUN=sum, na.rm=T )  # summation is really returning identity as there is only 1 element
        B = B[ , areas]
        B = as.data.frame(B)
        save( B, file=fn, compress=T )
        return (B)
    }

    if (DS %in% c("R_geomean", "R_geomean.redo" )) {
      fn = file.path( sum_outdir, "R_geomean_ts.rdata" )
      Bx = NULL
      if (DS=="R_geomean") {
        if (file.exists(fn)) load(fn)
        return(Bx)
      }

      lookup.table = snowcrab.db( p=p, DS="data.transforms" )

      v = "R1.no"
      fm = formula( paste(v, "~yr+cfa"))

      set = snowcrab.db( DS ="set.biologicals", p=p, yrs=2000:p$year.assessment )
      B = set[, c( v, "yr", "cfa" )]
      B[,v] = bio.snowcrab::variable.recode( B[,v], v, direction="forward", lookup.table=lookup.table )

      Bg = aggregate( fm , data=B, FUN=mean, na.rm=T )
      Bg[,v] = bio.snowcrab::variable.recode( Bg[,v], v, direction="backward", lookup.table=lookup.table )

      Bx = xtabs( fm, data=Bg )

      Bx[ which( rownames(Bx) %in% c(2000:2001) ),"cfa4x"] = NA
      Bx[ which( rownames(Bx) %in% c(2000) ),"cfanorth"] = NA
      Bx = Bx[,c("cfanorth", "cfasouth", "cfa4x" ) ]

      Bx[ which(Bx < 0.0001 )] = 0

      save( Bx, file=fn, compress=T )
      return (Bx)
    }

    if (DS %in% c("B_geomean", "B_geomean.redo" )) {
      fn = file.path( sum_outdir, "B_geomean_ts.rdata" )
      Bx = NULL
      if (DS=="B_geomean") {
        if (file.exists(fn)) load(fn)
        return(Bx)
      }

      lookup.table = snowcrab.db( p=p, DS="data.transforms" )

      v = "R0.mass"
      fm = formula( paste(v, "~yr+cfa"))

      set = snowcrab.db( DS ="set.biologicals", p=p, yrs=2000:p$year.assessment )
      B = set[, c( v, "yr", "cfa" )]
      B[,v] = bio.snowcrab::variable.recode( B[,v], v, direction="forward", lookup.table=lookup.table )

      Bg = aggregate( fm , data=B, FUN=mean, na.rm=T )
      Bg[,v] = bio.snowcrab::variable.recode( Bg[,v], v, direction="backward", lookup.table=lookup.table )

      Bx = xtabs( fm, data=Bg )

      Bx[ which( rownames(Bx) %in% c(2000:2001) ),"cfa4x"] = NA
      Bx[ which( rownames(Bx) %in% c(2000) ),"cfanorth"] = NA
      Bx = Bx[,c("cfanorth", "cfasouth", "cfa4x" ) ]

      save( Bx, file=fn, compress=T )
      return (Bx)
    }

    if (DS %in% c("B_geomeansd", "B_geomeansd.redo" )) {
      fn = file.path( sum_outdir, "B_geomeansd_ts.rdata" )
      Bx = NULL
      if (DS=="B_geomeansd") {
        if (file.exists(fn)) load(fn)
        return(Bx)
      }

      lookup.table = snowcrab.db( p=p, DS="data.transforms" )

      v = "R0.mass"
      fm = formula( paste(v, "~yr+cfa"))

      set = snowcrab.db( DS ="set.biologicals", p=p, yrs=2000:p$year.assessment )
      B = set[, c( v, "yr", "cfa" )]
      B[,v] = bio.snowcrab::variable.recode( B[,v], v, direction="forward", lookup.table=lookup.table )

      Bg = aggregate( fm , data=B, FUN=sd, na.rm=T )
      # Bg[,v] = bio.snowcrab::variable.recode( Bg[,v], v, direction="backward", lookup.table=lookup.table )

      Bx = xtabs( fm, data=Bg )

      Bx[ which( rownames(Bx) %in% c(2000:2001) ),"cfa4x"] = NA
      Bx[ which( rownames(Bx) %in% c(2000) ),"cfanorth"] = NA
      Bx = Bx[, c("cfanorth", "cfasouth", "cfa4x" ) ]

      save( Bx, file=fn, compress=T )
      return (Bx)
    }

    if (DS %in% c("R_geomeansd", "R_geomeansd.redo" )) {
      fn = file.path( sum_outdir, "R_geomeansd_ts.rdata" )
      Bx = NULL
      if (DS=="R_geomeansd") {
        if (file.exists(fn)) load(fn)
        return(Bx)
      }

      lookup.table = snowcrab.db( p=p, DS="data.transforms" )

      v = "R1.no"
      fm = formula( paste(v, "~yr+cfa"))

      set = snowcrab.db( DS ="set.biologicals", p=p, yrs=2000:p$year.assessment )
      B = set[, c( v, "yr", "cfa" )]
      B[,v] = bio.snowcrab::variable.recode( B[,v], v, direction="forward", lookup.table=lookup.table )

      Bg = aggregate( fm , data=B, FUN=sd, na.rm=T )
      # Bg[,v] = bio.snowcrab::variable.recode( Bg[,v], v, direction="backward", lookup.table=lookup.table )

      Bx = xtabs( fm, data=Bg )

      Bx[ which( rownames(Bx) %in% c(2000:2001) ),"cfa4x"] = NA
      Bx[ which( rownames(Bx) %in% c(2000) ),"cfanorth"] = NA
      Bx = Bx[,c("cfanorth", "cfasouth", "cfa4x" ) ]

      save( Bx, file=fn, compress=T )
      return (Bx)
    }

    if (DS %in% c("R", "R.redo" )) {
      fn = file.path( sum_outdir, "R_ts.rdata" )
      R=NULL
      if (DS=="R") {
        if (file.exists(fn)) load(fn)
        return(R)
      }

      K = interpolation.db( DS="interpolation.simulation", p=p, varnames="R1.no" )
      areas=c("cfanorth", "cfasouth", "cfa4x")
      td = K[ which(K$vars=="R1.no" & K$region %in% areas) ,]
      R = tapply( td$total, INDEX=td[,c("yr", "region")], FUN=sum, na.rm=T )  # summation is really returning identity as there is only 1 element
      R = R /1000 # kt
      R = R[ , areas]

    # assessments conducted in the spring 2001 and earlier ... they are pre-fishery biomasses ..
    # fishery is modelled using a biomass (fishable biomass) estimate == pre-fishery biomass == landings + post-fishery biomass

      R = R[, areas]
      R[ which( rownames(R) %in% c(1998:2001) ),"cfa4x"] = mean( R[ which( rownames(R) %in% c(2002:2005) ),"cfa4x"] )
      save( R, file=fn, compress=T )
      return (R)
    }

    if (DS %in% c("Rsd", "Rsd.redo" )) {
      fn = file.path( sum_outdir, "Rsd_ts.rdata" )
      R=NULL
      if (DS=="Rsd") {
        if (file.exists(fn)) load(fn)
        return(R)
      }
      message ("not available right now")

      stop()

      K = interpolation.db( DS="interpolation.simulation", p=p, varnames="R1.no" )
      areas=c("cfanorth", "cfasouth", "cfa4x")
      td = K[ which(K$vars=="R1.no" & K$region %in% areas) ,]
      td$totalsd.ln = abs(td$total.ub - td$total.lb)/(2*1.96) # assuming approx normal
      R = tapply( td$totalsd.ln, INDEX=td[,c("yr", "region")], FUN=sum, na.rm=T )  # summation is really returning identity as there is only 1 element
      R = R[ , areas]

    # assessments conducted in the spring 2001 and earlier ... they are pre-fishery biomasses ..
    # fishery is modelled using a biomass (fishable biomass) estimate == pre-fishery biomass == landings + post-fishery biomass

      R[ which( rownames(R) %in% c(1998:2001) ),"cfa4x"] = mean( R[ which( rownames(R) %in% c(2002:2005) ),"cfa4x"] )
      R[ which( R < 0.001) ] = mean( R, na.rm=T )

      save( R, file=fn, compress=T )
      return (R)
    }

  }


#' Make phylogeny with Phylopic images
#'
#' @import ggplot2 ggphylo ape adephylo grid
#' @param pngobj Object from get_image function
#' @param phytheme The ggplot2 style layout. You can write your own theme and pass
#'    it in to the function. See example below.
#' @examples \dontrun{
#' toget <- c("27356f15-3cf8-47e8-ab41-71c6260b2724", "bd88f674-6976-4cb2-a46e-e6a12a8ba463", "e547cd01-7dd1-495b-8239-52cf9971a609", "9c6af553-390c-4bdd-baeb-6992cbc540b1", "e547cd01-7dd1-495b-8239-52cf9971a609", "bd88f674-6976-4cb2-a46e-e6a12a8ba463")
#' myobjs <- get_image(uuids = toget, size = "thumb")
#' make_phylo(pngobj=myobjs)
#'
#' # Settingn phytheme to NULL uses ggphylo's default theme
#' make_phylo(pngobj=myobjs, phytheme=NULL)
#'
#' # Make your own theme
#' mytheme <- theme_phylo_blank2() + ggplot2::theme(panel.background=element_rect(fill="lightblue"))
#' make_phylo(pngobj=myobjs, phytheme=mytheme)
#'
#' # The use case starting from a text search
#' searchres <- search_text(text = "Homo sapiens", options = "names")
#' output <- search_images(uuid=searchres, options=c("pngFiles", "credit", "canonicalName"))
#' myobjs <- get_image(uuids = output, size = "128")
#' make_phylo(pngobj=myobjs)
#' }
#' @export
make_phylo <- function(pngobj, phytheme = theme_phylo_blank2())
{
  imgtoplot <- lapply(pngobj, function(y) matrix(rgb(y[,,1], y[,,2], y[,,3], y[,,4] * 0.2), nrow = dim(y)[1]))
  tree <- rcoal(n=length(pngobj))
  roottotip <- distRoot(x=tree, tips=1)[[1]]
  ggannlist <- list()
  for(i in seq_along(imgtoplot)){
    ggannlist[[i]] <- annotation_custom(xmin=roottotip+(roottotip * 0.1), xmax=roottotip+(roottotip * 0.18), ymin=i-0.3, ymax=i+0.3, rasterGrob(imgtoplot[[i]]))
  }

  return(
    ggphylo(tree, label.size = 0, node.size = 0) +
    ggannlist +
    phytheme
  )
}


##### Non-Detect Levels by Permittee ########################################################################

#color_list <- c("#999999", "#56B4E9", "brown", "#009E73", "#F0E442", "#D55E00", "#CC79A7", "#000000", "#0072B2","red", "dark green", )
color_list<-c("#000000","#00FF7F", "#7FFFD4","#458B00","#CD661D","#6495ED","#00FFFF","#00008B","#FFB90F","#CAFF70","#8A2BE2","#BF3EFF","#BEBEBE","#1E90FF","#FF0000")
#color_list<-rainbow(15)
#color_list<-c(24,7,8,16,20,26,30,31,33,81,54,204,244,47,56)

Param_nonDetects <- ParamData[which(ParamData$nonDetect_Flag == TRUE), ]

if(nrow(Param_nonDetects) > 0) {
  plot(x=c(1:10), y=c(1:10), xlim=c(0,5), ylim=ylimits, ylab=ParamList[i], type="n", xaxt="n", xlab="", log="y", xaxs="i",
      yaxs="i", main="\nNon-Detect Levels", las=2, cex.axis=0.8)
  ### abline(v=c(1:4))
  ### axis(side=1, at=c(0.5, 1.5, 2.5, 3.5, 4.5), labels=c("CLK", "CoS", "PoS", "SNO", "TAC"))

  if (nrow(Param_nonDetects) > 2 ) {
    xValues <- seq(from=0.2, to=4.8, length.out=nrow(Param_nonDetects))
  } else if (nrow(Param_nonDetects) == 2) {
    xValues <- c(2, 4)
  } else {
    xValues <- c(2.5)
  }

  plot_order <- order(Param_nonDetects$new_Result_Value)
  segments(x0=xValues, x1=xValues, y0=rep(min(ylimits), nrow(Param_nonDetects)),
           y1=Param_nonDetects$new_Result_Value[plot_order],
       col=color_list[Param_nonDetects$LabColor[plot_order]])

  ### split_nonDetects <- split(Param_nonDetects, f=Param_nonDetects$Permittee)
  ### for (iPermittee in c(1:length(split_nonDetects))) {
  ###   if (nrow(split_nonDetects[[iPermittee]]) > 0) {
  ###     Permittee_Data <- split_nonDetects[[iPermittee]]
  ###     if (nrow(Permittee_Data) > 2) {
  ###       xValues <- (iPermittee-1) + seq(from=0.05, to=0.95, length.out=nrow(Permittee_Data))
  ###     } else {
  ###      if (nrow(Permittee_Data) == 2) {
  ###        xValues <- (iPermittee-1) + c(0.3, 0.7)
  ###      } else {
  ###        xValues <- (iPermittee-1) + c(0.5)
  ###      }
  ###     }
  ###     plot_order <- order(Permittee_Data$new_Result_Reported_Value)
  ###     segments(x0=xValues, x1=xValues, y0=rep(min(ylimits),nrow(Permittee_Data)),
  ### y1=Permittee_Dat$new_Result_Reported_Value[plot_order],
  ###         col=color_list[Permittee_Data$LabColor[plot_order]])

  ###   } #endif

  ### } #end for

  box()
  par(new=TRUE)

  plot(1:10, type="n", xaxt="n", yaxt="n", xlab="", ylab="", bty="n")

  ### Add legend to identify lab colors:
  xLeft_val <- seq(1.5,9,by=0.5)
  xRight_val <- xLeft_val + 0.5
  ybot <- rep(-1.7,length(xLeft_val))
  ytop <- ybot + 0.5

  rect(xleft=xLeft_val, xright=xRight_val, ybottom=ybot, ytop=ytop, col=color_list, border=NA, xpd=NA)
  text(x=xLeft_val, y=ytop+0.2, labels=Lab.Abbv, xpd=NA, srt=45, cex=0.6, pos=4)

} else {
    plot(1:10, type="n", xaxt="n", yaxt="n", xlab="", ylab="", bty="n")
    text(x=5,y=5,"Not Plotted\n(No Non-Detects)")
} #endif


.reorder.factor<-function(x,neworder=c("Sample","Center","Residual")){
  x<-x[order(factor(x$variable,levels=neworder),decreasing=FALSE),]
  x$variable<-factor(x$variable,levels=neworder)
  x
}
.extractVcomp<-function(mer,sd=FALSE){
  vc<-melt(ldply(mer,function(x){
    if(!sd){
      foo<-as.data.frame(VarCorr(x))[,5]^2
    }else{
      foo<-as.data.frame(VarCorr(x))[,5]
    }
    names(foo)<-as.data.frame(VarCorr(x))[,1]
    #names(foo)<-print(VarCorr(x))[,1]
    foo
  }),id=c("Method","Population"))
  vc
}
.fitMer<-function(TBL){
  mer<-dlply(TBL,.(Method,Population),function(x){
    fit<-lmer(lp~1+(1|Center)+(1|Sample),x,REML=FALSE,verbose=FALSE) #Model biological and center to center variability
    #x$Residual<-1:nrow(x);
    #fit<-glmer(Proportion~1+(1|Center)+(1|Sample)+(1|Residual),x,weights = x$Count_Parent,family=binomial,verbose=FALSE) #Model biological and center to center variability
    fit
  })
  mer
}

.getCI<-function(mer){
  cb<-ldply(mer,function(x){
    # ci<-arm::invlogit(lme4::confint.merMod(x,method="Wald",oldNames=FALSE))
    ci<-lme4::confint.merMod(x,method="Wald",oldNames=FALSE)
    rn<-rownames(ci)
    data.frame(ci,rn)
  })
  setnames(cb,c("Method","Population","lower","upper","Sample"))
  # mns<-(ldply(mer,function(x)arm::invlogit(fixef(x))))
  mns<-(ldply(mer,function(x)(fixef(x))))
  cb<-data.table(cb)
  mns<-data.table(mns)
  mns<-data.table(melt(mns))
  setnames(mns,c("variable","value"),c("Sample","mean"))
  setkey(cb,Method, Population,Sample)
  setkey(mns,Method,Population,Sample)
  merge(cb,mns)
}

.fitMerBias<-function(TBL){
  mer<-dlply(TBL,.(Method,Population),function(x){
   # x$Residual<-1:nrow(x);
    fit<-lmer(lp~Sample+(1|Center),x,REML=FALSE,verbose=FALSE) #Model biological and center to center variability
    #fit<-glmer(Proportion~Sample+(1|Center)+(1|Residual),x,weights=x$Count_Parent,family=binomial,verbose=FALSE) #Model biological and center to center variability
    fit
  })
  mer
}
.transCI<-function(bar){
  foo<-ddply(cast(melt(bar),Method+Population+variable~Sample),.(Method,Population,variable),function(x)with(x,data.frame(Sample12828 = `(Intercept)`,Sample1349=`(Intercept)`+Sample1349,Sample1369=`(Intercept)`+Sample1369)))
  setnames(foo,"variable","ci")
  foo<-melt(foo)
  foo$value<-arm::invlogit(foo$value)
  foo<-setnames(foo,"variable","Sample")
  foo<-(cast(foo,Method+Population+Sample~ci))
  foo
}

.prepDF<-function(VV,CC,ratio){
  vars<-cast(VV)
  foo<-ddply(CC,.(Method,Population),function(x)with(x,data.frame(mean=mean(mean))))
  foo<-merge(vars,foo,by=c("Method","Population"))

  V1<-vars[,3:5]^2
  V2<-vars[,c(4:5)]^2

  S1<-sqrt(rowSums(2*V1))
  S2<-sqrt(rowSums(2*V2))
  popsz<-foo$mean

  vars$mean<-popsz
  vars$S1<-S1
  vars$S2<-S2
  foo<-melt(data.frame(vars[,c(1,2,6:8)]),id=c("Method","Population","mean"))

  samplesize<-c(5,10,20,25,50,75,100)
  setnames(foo,c("variable","value"),c("S.cat","S.value"))
  foo<-melt(cbind(foo,5,10,20,25,50,75,100),id.vars=c("Method","Population","mean","S.value","S.cat"))
  setnames(foo,c("variable","value"),c("SampleSize.cat","SampleSize.value"))

  #average automated gating central analysis
  #fix this for the new data
#   foo$Central<-factor(!foo$Method%in%"flowDensity","OpenCyto",levels=c("FALSE","TRUE"),labels=c("Central","Other"))
  foo<-subset(data.frame(foo),Method%in%"Manual")
  foo<-unique((ddply(foo,.(Population,S.cat,S.value,SampleSize.cat,SampleSize.value),function(x)with(x,data.frame(mean=mean(mean),S.value=mean(S.value))))))

  foo<-subset(foo,Population%in%ratio$Population)
  foo<-(ddply(foo,.(Population,SampleSize.cat,SampleSize.value,mean),function(x){
    with(x,{
      s1<-S.value[S.cat=="S1"]
      s2<-S.value[S.cat=="S2"]
      m<-as.character(ratio$Population)%in%unique(as.character(Population))
      if(sum(m)==0){
        r<-NA
      }else{
        r<-ratio[m,"var.ratio",with=FALSE]
      }
      s3<-sqrt(r*(s1^2-s2^2)+s2^2)
      names(s3)<-"S3"
      data.frame(S1=s1,S2=s2,S3=s3)
    })
  }))
  foo<-melt(foo,id=c("Population","SampleSize.cat","SampleSize.value","mean"))
  setnames(foo,c("variable","value"),c("S.cat","S.value"))
  require(parallel)
  cl<-makeCluster(4)
  clusterSetRNGStream(cl, 123)
  assign("foo",foo,.GlobalEnv)
  clusterExport(cl,list("foo",".power"))
  clusterEvalQ(cl,library(arm))
  clusterEvalQ(cl,library(boot))
  effects<-parSapply(cl,1:nrow(foo),function(x)with(foo,.power(SampleSize.value[x],S.value[x],mean[x])))
  stopCluster(cl)
  foo$effects<-effects
  foo
}

.power<-function(N=NA,S=NA,popsz=NA){
  f1<-function(x){set.seed(1);(mean(replicate(1000,mean(rnorm(N,mean=0,sd=S)))>x)-0.05)^2}
  thresh<-optim(0,f1)$par
  f2<-function(delta,thresh){set.seed(1);(mean(replicate(1000,mean(rnorm(N,mean=delta,sd=S)))>thresh)-0.8)^2}
  leffect<-optim(0,f2,thresh=thresh)$par
  invlogit(logit(popsz)+leffect)-popsz
}

.matchPops<-function(p1,p2){
  d<-adist(p1,p2)
  trans<-FALSE
  if(ncol(d)<=nrow(d))
    trans<-TRUE
  if(trans){
    d<-t(d)
  }
  mapping<-solve_LSAP(d)
  if(trans){
    l<-as.list(p2)
    names(l)<-p1[mapping]
  }else{
    l<-as.list(p2[mapping])
    names(l)<-p1
  }
  l
}


# user options

targetFs<-seq(0.0,1.0,0.05)
#targetFs<-seq(0.51,0.56,0.005)
#targetFs<-0.7

# area 1 and 2
recruit.noise.low<- -2
recruit.noise.high<-2

no.MCMC.iterations<-1

refYear<-seq(1999,2010,1) # years for calc of mean wsea and weca
refYearPropmat<-seq(1983,1984,1) # years for calc of mean proportion mature

legendPlace<-c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right" , "center")[6]

nox<-1; noy<-2;
paper<-F   # if paper==T output on file, else screen
cleanup()

# initialise the function that does all the work
source(file.path(prog.path.func,"MSY_batch.r"))

# Change option in SMS.dat
control<-read.FLSMS.control()
control@read.HCR<-1
write.FLSMS.control(control,write.multi=F)

# stochastich  run stochastic (TRUE) or determenistic analysis (FALSE)
# YieldPerRecruit do YPR (TRUE) or use SSB recruitment relations (FALSE)

do.HCR.batch(NewPlot=T,stochastich=F,YieldPerRecruit=T)
do.HCR.batch(NewPlot=F,stochastich=T,YieldPerRecruit=F)

if (paper) cleanup()  # to release graphics on file
control<-read.FLSMS.control()
control@read.HCR<-0
write.FLSMS.control(control,write.multi=F)