# examine egg colour using a binomial GLM

  require (effects) # for "effect" for adjusted means
  require(car) # for "Anova"

    workdir = file.path( project.datadirectory( "bio.snowcrab"), "output" )  # linux
  	p = bio.snowcrab::load.environment()

# recreate the data files, only if the data needs to be refreshed
#  eggdata( data.loc=workdir, redo.data=T )

# load the data
#  sc = eggdata( data.loc=workdir, data.file="sc" )
  sdt = eggdata( data.loc=workdir, data.file="sdt" )

# choose the time variable resolution
  time.resolution = "weekly"
  sdt$timevalue = recode.time.maturity( sdt$julianday, time.resolution )
  yearoffset =  recode.time.maturity( 365, time.resolution )  # used when adding another year to the time value (see below)
  end.of.year = recode.time.maturity( 365*c(0,1,2,3), time.resolution )

  predictions.time = recode.time.maturity( c(1:730), time.resolution )
  predictions.eggpr =   c(0,1,2,3,4)
  predictions.temperature = round( quantile(sdt$t, probs=c(0.05, 0.5, 0.95), na.rm=T ), 2)

# ID various categories; p = primiparous; m = multiparous
  p12  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell<=2 & sdt$eggcol %in% c(1,2) )   # n= 10,830
  p23  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell<=2 & sdt$eggcol %in% c(2,3) )
  p34  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell<=2 & sdt$eggcol %in% c(3,4) )
  m123 = which( sdt$sex==2 & sdt$mat==1 & sdt$shell>=3 & sdt$cw<100 )   # There were 3 outliers, cw>100 not likely!!
  m12  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell>=3 & sdt$cw<100 & sdt$eggcol %in% c(1,2) )  #  n=32,803
  m23  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell>=3 & sdt$cw<100 & sdt$eggcol %in% c(2,3) )  # n=19,898
  m34  = which( sdt$sex==2 & sdt$mat==1 & sdt$shell>=3 & sdt$cw<100 & sdt$eggcol %in% c(3,4) ) #  were only 2 females with eggcol=4

#################### Analysis finally begins ...

  # compare primi vs multi
  primi = sdt[ c(p12), ]
  primi$egg = 0
  primi$egg[ which(primi$eggcol==1)] = 1
  primi.binned = compute.proportions( primi, var="egg" )

 # compare primi vs multi
  multi = sdt[ c(m12), ]
  multi$egg = 0
  multi$egg[ which(multi$eggcol==1)] = 1
  multi.binned = compute.proportions( multi, var="egg" )

  # prim and mult 1-2:

   primi$stage = "P"
   multi$stage = "M"
   x=rbind( primi,multi)
  #Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==1)] = 1

  model1 =  glm( egg ~   timevalue + stage + timevalue:stage , data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  coef(model1)
  summary(model1)

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

# Primiparous: Egg 1 to 2 transition
  x = sdt[ p12 , ]

  #Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==1)] = 1

  model1 =  glm( egg ~   timevalue + t  + timevalue:t  , data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list(t=predictions.temperature, timevalue=predictions.time), type="response" )
  plot(res, multiline=T, rescale.axis=F)

  coef(model1)
  summary(model1)

 # plot( res,  "timevalue:t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.time))

#  plot( res,  "timevalue:eggPr", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.time))

#  plot( res,  "t:eggPr", type="response", multiline=T, rescale.axis=F, xlab="Egg fullness", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.eggpr) )

  to.plot = effects.data.export( res[["timevalue:t"]] )
  to.plot = effects.data.export( res[["timevalue:eggPr"]] )
  to.plot = effects.data.export( res[["t:eggPr"]] )

  binned.data = compute.proportions(x, var="egg")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data )

  # julian day at 50% transition of egg stage
  covariates = list( temp=predictions.temperature, eggpr=predictions.eggpr )  # associated with values of the other main effects where predictions are to be made
  tr = LDx( model1, p=0.5, error.method="2main.1interaction", covariates=covariates )

# ---------------------------
# Primiparous: Egg 2 to 3 transition
  x = sdt[ p23 , ]

  # ...  the following is not needed as there are no cases ... but kept to remind that it is conducted with multiparous females
  # move #3's btwn day 0-181 to the 'next year'
  # i = which( x$julianday <= 181 & x$julianday >= 0 & x$egg==0 )
  # x$timevalue[i] = x$timevalue[i] + yearoffset

  #Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==3)] = 1

 i = which( x$julianday <= 181 & x$julianday >= 0 & x$eggcol ==3 )
 x$timevalue[i] =  x$timevalue[i] + yearoffset

  model1 =  glm( egg ~   timevalue +  t + timevalue:t, data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list(t=predictions.temperature, timevalue=predictions.time), type="response" )

  plot(res, multiline=T, rescale.axis=F)

#  plot( res,  "timevalue", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.time) )

#  plot( res,  "eggPr:t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.eggpr) )

  coef(model1)
  summary(model1)

  to.plot = effects.data.export( res[["timevalue:t"]] )
  to.plot = effects.data.export( res[["eggPr"]] )

  binned.data = compute.proportions(x, var="egg")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data)

  # julian day at 50% transition of egg stage
  covariates = list( temp=predictions.temperature,  eggpr=predictions.eggpr )  # associated with values of the other main effects where predictions are to be made
  tr = LDx( model1, p=0.5, error.method="3main.1interaction", covariates=covariates )

# ----------------------
# Multiparous: Egg 1 to 2 transition
  x = sdt[ m12 , ]

  #Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==1)] = 1

  model1 =  glm( egg ~   timevalue + t + timevalue:t , data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list(t=predictions.temperature, timevalue=predictions.time, eggPr=predictions.eggpr), type="response" )
  plot(res, multiline=T, rescale.axis=F)

 #  plot( res,  "timevalue:t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.time))

 #  plot( res,  "timevalue:eggPr", type="response", multiline=T, rescale.axis=F, xlab="Egg fullness", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.time))

 #  plot( res,  "t:eggPr", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.temperature) )

  coef(model1)
  summary(model1)

  to.plot = effects.data.export( res[["timevalue"]] )
  to.plot = effects.data.export( res[["t"]] )
  to.plot = effects.data.export( res[["eggPr"]] )

  binned.data = compute.proportions(x, var="egg")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data)

  # julian day at 50% transition of egg stage
  covariates = list( temp=predictions.temperature, eggpr=predictions.eggpr )  # associated with values of the other main effects where predictions are to be made
  tr = LDx( model1, p=0.5,  error.method="2main.1interaction", covariates=covariates )

# ------------------------
# Multiparous: Egg 2 to 3 transition
  x = sdt[ m23 , ]

  # Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==3)] = 1

  # 212 end of July, no BL eggs in Aug.
  i = which( x$julianday <= 181 & x$julianday >= 0 & x$eggcol==3 )
  x$timevalue[i] =  x$timevalue[i] + yearoffset

  model1 =  glm( egg ~   timevalue +  t , data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list(t=predictions.temperature, timevalue=predictions.time), type="response" )

  plot(res, multiline=T, rescale.axis=F)

  # plot( res,  "timevalue", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: dark orange vs black", main="", xlim=range(predictions.time) )

  # plot( res,  "eggPr", type="response", multiline=T, rescale.axis=F, xlab="Egg fullness", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.eggpr))

  # plot( res,  "t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: light orange vs. dark orange", main="", xlim=range(predictions.temperature) )

  coef(model1)
  summary(model1)

  to.plot = effects.data.export( res[["timevalue"]] )
  to.plot = effects.data.export( res[["t"]] )
  to.plot = effects.data.export( res[["eggPr"]] )

  binned.data = compute.proportions(x, var="egg")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data)

  # julian day at 50% transition of egg stage
  covariates = list( temp=predictions.temperature, eggpr=predictions.eggpr )  # associated with values of the other main effects where predictions are to be made
  tr = LDx( model1, p=0.5,  error.method="2main.0interaction", covariates=covariates )

# ---------------------------------------------
# Multiparous: Egg 3 to 4 transition
  x = sdt[ m34 , ]

  #Create a binary variable with shell condition, 0's for all other conditions, the basis for using the logit model
  x$egg = 0
  x$egg[ which(x$eggcol==4)] = 1

 # ? needs more work here ... ?
  # i = which( x$julianday <= 270 & x$julianday >= 0  & x$egg==0 ??? )
  # x$timevalue[i] =  x$timevalue[i] + yearoffset

  model1 =  glm( egg ~    timevalue + t + eggPr + timevalue:t + t:eggPr , data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list(t=predictions.temperature, timevalue=predictions.time, eggPr=predictions.eggpr), type="response" )
  plot(res, multiline=T, rescale.axis=F)

 #  plot( res,  "timevalue:t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: black vs coccoon", main="", xlim=range(predictions.time))

  coef(model1)
  summary(model1)

  to.plot = effects.data.export( res[["timevalue"]] )
  to.plot = effects.data.export( res[["t"]] )
  to.plot = effects.data.export( res[["eggPr"]] )

  binned.data = compute.proportions(x, var="egg")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data)

  # julian day at 50% transition of egg stage
  covariates = list( temp=predictions.temperature, eggpr=predictions.eggpr )  # associated with values of the other main effects where predictions are to be made
  tr = LDx( model1, p=0.5,  error.method="3main.2interaction.12.23", covariates=covariates )

# -------------------------------------
# Analysis of female maturity schedules

  x = sdt
  x$maturity = NA
  x$maturity[ which(x$mat=="2") ]  = 0 # immature
  x$maturity[ which(x$mat=="1") ]  = 1 # mature
  x = x[ is.finite( x$maturity) & x$sex==2, ]
  x$maturity = as.factor(x$maturity)

  newlymoulted.mature = which( x$maturity==1 & x$shell %in% c(1) )
  immature = which( x$maturity == 0 )
  p = sort( unique( c( immature, newlymoulted.mature ) ) )
  x = x[ p,]

  time.res = "daily"
  predictions.time = recode.time.maturity( c(-100:365), time.res )
  x$timevalue = recode.time.maturity( x$julianday, time.res )
  i = which( x$julianday > 180  )
  x$timevalue[i] =  x$timevalue[i] - recode.time.maturity( 365, time.res )

  model1 =  glm( maturity ~ timevalue + t + timevalue:t, data=x, family=binomial()  )
  Anova(model1) # Get chi-sq and significance

  res = all.effects( model1, xlevels=list( t=predictions.temperature, timevalue=predictions.time ), type="response" )
  plot( res,  "timevalue:t", type="response", multiline=T, rescale.axis=F, xlab="Days", ylab="Proportion: immature vs. mature", main="", xlim=range(predictions.time) )
  coef(model1)
  summary(model1)

  to.plot = effects.data.export( res[["timevalue:t"]] )
  to.plot = effects.data.export( res[["t"]] )

  binned.data = compute.proportions(x, var="maturity")

  plot(to.plot$timevalue, to.plot$predictedPr, col="blue", pch=".")
  points(binned.data$timevalue, binned.data$fraction, col="red", pch=20)
  abline( v=end.of.year )

  export.to.clipboard( to.plot)
  export.to.clipboard( binned.data )

  # julian day at 50% transition of egg stage
  tr = NULL
  for (temps in predictions.temperature ) {
    tr = rbind( tr, LDx( model1, p=0.5, error.method="2main.1interaction", covariates=temps ) )  # ######## must choose correct method depending on model specification

  }
  tr


if (!requireNamespace("BiocManager", quietly = TRUE))

  install.packages("BiocManager")

BiocManager::install("metagenomeSeq")

library(metagenomeSeq)

OTU_read_count <- read.delim("feature-table.biom.txt")
rownames(OTU_read_count) <- OTU_read_count$OTU_ID
OTU_read_count <- OTU_read_count[-c(1)]

metaSeqObject = newMRexperiment(OTU_read_count)

metaSeqObject_CSS  = cumNorm( metaSeqObject , p=cumNormStatFast(metaSeqObject) )

OTU_read_count_CSS = data.frame(MRcounts(metaSeqObject_CSS, norm=TRUE, log=TRUE))

cor(OTU_read_count$P1, OTU_read_count_CSS$P1)
cor(OTU_read_count$M1, OTU_read_count_CSS$M1)

write.csv(OTU_read_count_CSS, "feature-table_CSS_norm.biom.txt", row.names = TRUE)


calc_proportion_landed<-function(sp='COD',Species='X') {
  load(file.path(root,"data_NorthSea","2012-data","stocks",paste(sp,".Rdata",sep='')))    # Data from Clara
  a<-stock@landings.n/stock@catch.n
  a<-subset(as.data.frame(a),select=c( age,year,data))
  a$SP<-sp
  a$Species<-Species
  return(a)

}

a<-rbind(
  calc_proportion_landed(sp='COD',Species="17 Cod"),
  calc_proportion_landed(sp='HAD',Species="19 Haddock"),
  calc_proportion_landed(sp='WHG',Species="18 Whiting"),
  calc_proportion_landed(sp='POK',Species="20 Saithe"),
  calc_proportion_landed(sp='PLE',Species="25 Plaice")
)
head(a)

# use mean landingsrate for the year befor 1989
whg<-subset(a,Species=='18 Whiting' & year> 1990 & year<1995)
whg<-aggregate(data~ age +SP+Species,mean,data=whg)
yy<-data.frame(year=1963:1989)
whg<-merge(whg,yy)
a<-rbind(a,whg)

SMS<-read.FLSMS.control(file=file.path(data.path,'SMS.dat'))
prop<-expand.grid(age=SMS@first.age:SMS@max.age.all, quarter=1:SMS@last.season , year=SMS@first.year:SMS@last.year,
                   Species=paste(first.VPA:SMS@no.species,SMS@species.names[first.VPA:SMS@no.species]),prop=1)

aa<-merge(x=prop,y=a, all.x = T)
aa[!is.na(aa$data),'prop']<-aa[!is.na(aa$data),'data']

summary(aa)
bb<-tapply(aa$prop,list(aa$quarter,aa$age,aa$year,aa$Species),sum)

out<-file.path(data.path,"proportion_landed.in")
cat("# Proportion landed\n", file=out,append=F)
for (sp in (paste(first.VPA:SMS@no.species,SMS@species.names[first.VPA:SMS@no.species]) )) for (y in (SMS@first.year:SMS@last.year)) {
   cat("# ",sp,y, "\n",file=out,append=T)
   write.table(round(bb[,,as.character(y),as.character(sp)],digits=4),file=out, col.names=F,row.names=F,append=T)
}


  # I am a fan of the http://covidvax.live site. But, from what I can tell it's just straight line projecting
  # recent growth out in order to build its forecast for when countries reach 70%
  # I'm not convinced this is quite as realistic as we can be given it's a constrained growth (logistic growth) model
  # So here's my attempt at using the same data set for a quick and dirty whip-up of a Prophet based growth model
  #************Provide input parameters here**********
  #Provide as code from here https://en.wikipedia.org/wiki/ISO_3166-1_alpha-3
  #Provide as Integer (no leading 0) from here https://en.wikipedia.org/wiki/ISO_3166-1_numeric

  # load the package
  #library('COVID19') # We don't use this library as the vaccination data is too coarse grained.
  library(jsonlite)
  library(prophet)
  library(data.table)
  library(lubridate)
  library(wpp2019)
  library(dplyr)
  library(dygraphs)

  data(pop)

  growth_cap<-0.90
  threshold_line<-0.90
  first_dose_model <- TRUE #Models jut the first does. Interesting when looking at hesitancy/access as countries progress

  #cty_chr<-'PRT'
  #cty_iso<- 620
  #popn_manual<-0

  #cty_chr<-'SIN'
  #cty_iso<- 702
  #popn_manual<-0

  #cty_chr<-'AUS'
  #cty_iso<- 36
  #popn_manual<-21865095 # 12 & over from ABS data https://www.abs.gov.au/statistics/people/population/national-state-and-territory-population/mar-2021#data-download

  #cty_chr<-'JPN'
  #cty_iso<- 392
  #popn_manual<- 125710000 * 0.89 #Quick estimate based on table here: https://en.wikipedia.org/wiki/Demographics_of_Japan#Population_density
  #popn_manual<- 0

  cty_chr<-'NZL'
  cty_iso<- 554
  popn_manual<- 4208338  # Population over 12 from NZ MoH HSU Population projection in spreadsheet
  #popn_manual<- 4208338 + (791346/2) #As above but add in 50% of the 0-11 age group
  #country_data <- fread("https://raw.githubusercontent.com/cauldnz/nz-covid19-data-auto/main/vaccinations/Date.csv",col.names=c("date","first_dose","second_dose"), colClasses = c("Date","integer","integer"))
  country_data <- fread("https://raw.githubusercontent.com/UoA-eResearch/nz-covid19-data-auto/main/vaccinations/Date.csv",col.names=c("date","first_dose","second_dose"), colClasses = c("Date","integer","integer"))
  country_series_dt <- country_data[,.(ds=date,y=cumsum(first_dose))]

  #cty_chr<-'TWN'
  #cty_iso<- 158

  #cty_chr<-'CRI'
  #cty_iso<- 188

  #cty_chr<-'MEX'
  #cty_iso<- 484

  #*****************************************************

  # install the package
  #install.packages("COVID19")
  #install.packages('jsonlite')
  #install.packages('prophet')
  #install.packages('data.table')
  #install.packages('lubridate')
  #install.packages('wpp2019')
  #install.packages("rmarkdown", repos="https://cran.r-project.org/") #I use MRO... so force install latest from CRAN

  if(popn_manual>0)  {
    proj_popn<-popn_manual
  } else {
    popn <-data.table(pop) #Forecast population
    proj_popn<- as.integer(popn[country_code==cty_iso]$'2020'  * 1000 )
  }

  #Retrieve raw 'Our World in Data' vaccination dataset
  vax_data_json <- fromJSON('https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.json')
  #vax_data_json <- fromJSON('https://raw.githubusercontent.com/cauldnz/covid-19-data/cauld/public/data/vaccinations/vaccinations.json')
  vax_data <- data.table(vax_data_json$data[which(vax_data_json$iso_code==cty_chr)][[1]])

  if (!first_dose_model){
    #Model double dose and assume two-dose regime for all
    proj_popn <- proj_popn * 2 #Moved to using total vaccinations so assume 2 dose reigime and just double popn.
    series_dt <- vax_data[,.(ds=date,y=total_vaccinations)]
  } else {
    series_dt <- country_series_dt
  }
  series_dt[,ds:=as_date(ds)]
  series_dt[,cap:=proj_popn*growth_cap] # Set growth capacity at 90% of total population...

  model <- prophet(series_dt,growth = 'logistic', weekly.seasonality = TRUE, daily.seasonality = FALSE, yearly.seasonality = FALSE)

  ds_future <- data.table(make_future_dataframe(model, periods = 180))
  ds_future[,cap:=proj_popn*growth_cap]
  forecast <- predict(model, ds_future)

  #Static Plot
  plot(model, forecast)

  #Dynamic Plot
  dyplot.prophet(model, forecast, graphTitle=paste("Forecast for: ", cty_chr, " Latest data: ", max(series_dt$ds), ifelse(first_dose_model," First Dose Only", " All Doses")), limitLine=proj_popn*threshold_line, limitLabel=paste(threshold_line*100,"%"))

  #Nicked from https://stackoverflow.com/questions/53947623/how-to-change-type-of-line-in-prophet-plot
  dyplot.prophet <- function(x, fcst, uncertainty=TRUE, graphTitle, limitLine, limitLabel, ...)
  {
    forecast.label='Predicted'
    actual.label='Actual'
    # create data.frame for plotting
    df <- prophet:::df_for_plotting(x, fcst)

    # build variables to include, or not, the uncertainty data
    if(uncertainty && exists("yhat_lower", where = df))
    {
      colsToKeep <- c('y', 'yhat', 'yhat_lower', 'yhat_upper')
      forecastCols <- c('yhat_lower', 'yhat', 'yhat_upper')
    } else
    {
      colsToKeep <- c('y', 'yhat')
      forecastCols <- c('yhat')
    }
    # convert to xts for easier date handling by dygraph
    dfTS <- xts::xts(df %>% dplyr::select_(.dots=colsToKeep), order.by = df$ds)

    # base plot
    dyBase <- dygraphs::dygraph(dfTS, main=graphTitle)

    presAnnotation <- function(dygraph, x, text) {
      dygraph %>%
        dygraphs::dyAnnotation(x, text, text, attachAtBottom = TRUE)
    }

    dyBase <- dyBase %>%
      # plot actual values
      dygraphs::dySeries(
        'y', label=actual.label, color='black',stepPlot = TRUE, strokeWidth=1
      ) %>%
      # plot forecast and ribbon
      dygraphs::dySeries(forecastCols, label=forecast.label, color='blue') %>%
      # allow zooming
      dygraphs::dyRangeSelector() %>%
      # make unzoom button
      dygraphs::dyUnzoom() %>%
      #Add Crosshairs
      dyCrosshair(direction = "both") %>%
      #Add threshold line and label
      dyLimit(as.numeric(limitLine), color = "red", label=limitLabel)
    if (!is.null(x$holidays)) {
      for (i in 1:nrow(x$holidays)) {
        # make a gray line
        dyBase <- dyBase %>% dygraphs::dyEvent(
          x$holidays$ds[i],color = "rgb(200,200,200)", strokePattern = "solid")
        dyBase <- dyBase %>% dygraphs::dyAnnotation(
          x$holidays$ds[i], x$holidays$holiday[i], x$holidays$holiday[i],
          attachAtBottom = TRUE)
      }
    }
    return(dyBase)
  }


library(Hmisc)
clc <- function() cat(rep("\n",100))
clc()

set.seed(42)

read.data <- function(file) {
	# read training data
	data <- read.csv(file, sep=',', na.strings=c(''), stringsAsFactors=FALSE)
	# drop some columns
	data <- subset(data, select = -c(Name, Fare, Ticket))

	# correct some column types
	 #data$Survived <- as.factor(data$Survived)
	data$Sex <- as.factor(data$Sex)
	data$Embarked <- as.factor(data$Embarked)
	data$Pclass <- as.factor(data$Pclass)
	if('Survived' %in% colnames(data)) {
		data$Survived <- as.factor(data$Survived)
	}
	return (data)
}

train <- read.data('data/train.csv')
test <- read.data('data/test.csv')

# massage and impute missing data
cabin_to_deck <- function(data) {
	data = as.character(data)
	for(i in seq(along=data)) {
		if (is.na(data[i]))
			next
		data[i] <- substr(data[i], 1, 1)
	}
	return (as.factor(data))
}

# Cabin
train$Cabin <- impute(cabin_to_deck(train$Cabin), 'random')
test$Cabin <- impute(cabin_to_deck(test$Cabin), 'random')

# Age
train$Age <- impute(train$Age, mean)
test$Age <- impute(test$Age, mean)

# Embarked
train$Embarked <- impute(train$Embarked, mean)
test$Embarked <- impute(test$Embarked, mean)

model <- glm(
	Survived ~ Pclass + Sex + Age + Cabin + SibSp + Parch +
		Pclass : Sex +
		Pclass : Age +
		Pclass : Cabin +
		Sex : SibSp +
		Sex : Parch +
		Sex : Age +
		Sex : Cabin +
		Age : Cabin,
	data=train,
	family="binomial",
	control=list(maxit = 150)
)
summary(model)

anova(model, test="Chisq")
if(T){
head(test)
test$Survived <- predict(model, newdata=test, type="response")
test$Survived <- round(test$Survived)
head(test)
summary(test)

write.csv(test[,c("PassengerId", "Survived")], file="predictions.csv", row.names=FALSE, quote=FALSE)

}


library(data.table)
library(rgrass7)
library(sp)
library(WatershedTools)
library(raster)
library(rgdal)

tifInt <- c("COMPRESS=LZW", "PREDICTOR=2")
tifFloat <- c("COMPRESS=LZW", "PREDICTOR=3")

# setwd("~/work/projects/FLEE_catchments")

# use this if drainAccum fails with an error about stars
tryCatch(rgrass7::use_sp(), error = function(e) warning(e))

metadat <- fread("catchment_list.csv")[catchment == "thur"]

dir <- file.path(metadat$dir, metadat$catchment, metadat$version)
shpdir <- file.path(dir, "shape")
shareDir <- metadat$dir
tmpdir <- file.path(dir, "tmp")
dir.create(dir, recursive=TRUE, showWarnings = FALSE)
dir.create(shpdir, showWarnings = FALSE)
dir.create(tmpdir, showWarnings = FALSE)

#############
# Grass setup
# 	it is essential that the DEM be projected
#	also do a bit of cropping because the original DEM is huge
#############

gisbase <- WatershedTools:::getGISBase()
# used this older DEM of unknown origin, because the copernicus DEM wasn't working for some reason
dem <- raster(file.path(shareDir, "dem", "thur_25m", "thur_dem_3035.tif"))
dem <- crop(dem, extent(4180925, 4313486, 2654576, 2733574))
plot(dem)
outletPoint_approx <- SpatialPoints(matrix(c(4263096, 2708975 ), nrow=1),
	proj4string = CRS(proj4string(dem)))
plot(outletPoint_approx, add=TRUE)
gs <- GrassSession(dem, gisbase, layerName = 'dem')

#############
# Fill the DEM
#############
# gs <- fillDEM("dem", gs = gs, filledDEM = 'filledDEM', probs = 'probs')
# demFilled <- GSGetRaster('filledDEM', gs)
demFilled <- writeRaster(demFilled, file.path(dir, "filled_dem.tif"),
	options = tifFloat)

demFilled <- raster(file.path(dir, "..", "1.1.0", "filled_dem.tif"))
gs <- GSAddRaster(demFilled, "filledDEM", gs)

#############
# Compute drainage direction/flow accumulation
#############
# gs <- drainageAccumulation('filledDEM', gs = gs, accumulation = 'accum', drainage = 'drainage')
# drain <- GSGetRaster('drainage', gs, file = file.path(dir, "drainage.tif"))
# accum <- GSGetRaster('accum', gs, file = file.path(dir, "accumulation.tif"))

drain <- raster(file.path(dir, "..", "1.1.0", "drainage.tif"))
accum <- raster(file.path(dir, "..", "1.1.0", "accumulation.tif"))
gs <- GSAddRaster(drain, "drainage", gs)
gs <- GSAddRaster(accum, "accum", gs)

plot(drain, col=rainbow(12), xaxt='n', yaxt='n')
plot(log(accum), xaxt='n', yaxt='n')

#############
# Find streams; threshold must be determined empirically, so we output, look at it in QGIS
# then adjust
#############

writeOGR(SpatialPointsDataFrame(outletPoint_approx, data=data.frame(name="thur")), file.path(dir, "tmp"), "outlet", "ESRI Shapefile")
thresh <- 0.95
streamChannel <- extractStream(dem = 'filledDEM', gs = gs, accumulation = 'accum',
	qthresh = thresh, type='both')
writeOGR(streamChannel$vector, file.path(dir, "tmp"), paste0("stream", thresh*100),
	"ESRI Shapefile")

#############
# Find an outlet point (by eye) and delineate catchment
#############
outletPointSnap <- snapToStream(outletPoint_approx, streamChannel$raster, buff= 400)
catchment <- catchment(outletPointSnap, drainage = 'drainage', gs = gs, areas=FALSE)
catchment <- writeRaster(catchment, file=file.path(dir, "catchment.tif"), options = tifInt)

#############
# Crop the delineated watershed to the catchment
#############
stream <- cropToCatchment(outletPointSnap, streamChannel$raster, streamChannel$vector, 'drainage', gs = gs)
plot(dem, col=gray.colors(50))
plot(catchment, add=TRUE, col="#aa000055")
plot(stream$vector, add=TRUE, col='blue')

writeOGR(stream$vector, shpdir, "thur_stream", "ESRI Shapefile")
writeRaster(stream$raster, file.path(dir, "thur_stream.tif"), options = tifInt)

# split coordinates for catchment area by reach
pixvals <- values(stream$raster)
coords <- coordinates(stream$raster)
df <- cbind(pixvals, coords)
df <- df[complete.cases(df),]
caPts <- by(df, df[,1], function(x) x[,2:3])
saveRDS(caPts, file.path(dir, "tmp", "caPoints_byReach.rds"))


#This script will take the Tg data (temp and density) and plot it.
#It will find the CTE below the Tg and above the Tg.
#You will need to update the breakpoint guess for your system. I recommend setting the initial guess as the Tg value for your system.
#
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#Read in csv file
tgfile <-"your_file_name_here_CTE_RData.csv"
tgdat <- read.csv(tgfile)
tgfilename <- strsplit(tgfile,"\\.")[[1]]

#create vectors for temp, linear expansion, volume expansion
tgtemp <- tgdat[,1]
tglin <- tgdat[,2]
tgvol <- tgdat[,3]
tgdens <- tgdat[,4]
tgtemp <- rev(tgtemp)
tglin <- rev(tglin)
tgvol <- rev(tgvol)
tgdens <- rev(tgdens)
#fit a regular linear model to data, this is for the segmented command
lin.mod <- lm(tgdens ~ tgtemp)

#use segmented package to calculated breakpoint (Tg)
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~tgtemp, psi=416)
#Define moving average function
#mav <- function(x,n=1000){filter(x,rep(1/n,n),sides=2)}

#tgdens_ma <- mav(tgdens,1500)

# Get point at tg_value
tg_value <- segmented.mod$psi[2]
tg_value_stderror <- segmented.mod$psi[3]
tg_y_value <- segmented.mod$coefficients[2]*tg_value+segmented.mod$coefficients[1]

# Save regular plot to pdf
pdf(paste(tgfilename[1],"pdf",sep="."))
plot(tgtemp,tgdens,col="blue",xlim=c(300,500),ylim=c(1.24,1.34),xlab = 'Temperature (Kelvin)',ylab = 'Density (g/cc)')
#plot(tgtemp,tgdens)
par(new = TRUE)
plot(segmented.mod,col="red",xlim=c(300,500),ylim=c(1.24,1.34),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(tg_value,tg_y_value,pch=24,col="white",bg="white",xlim=c(300,500),ylim=c(1.24,1.34),xlab = '',ylab = '')
dev.off()

#tg_value <- 459.5

# Begin CTE analysis
# These ranges will need to be changed for each individual sample/run.
# tg_above and tg_below are the ranges the CTE equation will be fitted to
tg_above <- c(tg_value,500)
tg_below <- c(300,tg_value)

# Find indices of tgtemp where the above ranges occur
tg_above_lower_index <- which(tgtemp > tg_above[1])[1]
tg_above_upper_index <- tail(which(tgtemp > tg_above[2]),1)
tg_below_lower_index <- which(tgtemp > tg_below[1])[1]
tg_below_upper_index <- which(tgtemp > tg_below[2])[1]

# Get ranges for fitting
cte_linear_above <- tglin[tg_above_lower_index:tg_above_upper_index]
cte_linear_below <- tglin[tg_below_lower_index:tg_below_upper_index]
cte_volume_above <- tgvol[tg_above_lower_index:tg_above_upper_index]
cte_volume_below <- tgvol[tg_below_lower_index:tg_below_upper_index]
temp_below <- tgtemp[tg_below_lower_index:tg_below_upper_index]
temp_above <- tgtemp[tg_above_lower_index:tg_above_upper_index]

# Fit a linear model to the volumetric CTE data below Tg
vcte_below_mod <- lm(formula = cte_volume_below ~ temp_below -1)
vcte_above_mod <- lm(formula = cte_volume_above ~ temp_above -1)
lcte_below_mod <- lm(formula = cte_linear_below ~ temp_below -1)
lcte_above_mod <- lm(formula = cte_linear_above ~ temp_above -1)

# Save volumetric CTE plot to pdf
pdf(paste(tgfilename[1],"vCTE.pdf",sep="_"))
plot(tgtemp,tgvol,col="blue",xlim=c(300,500),ylim=c(min(tgvol),max(tgvol)),xlab="Temperature (K)",ylab="Volumetric expansion (dV/V times 1000)")
text(375,31,sprintf("CVTE = %3.2E/K",vcte_below_mod$coefficients[2]*10^-3),pos=2,col="red")
text(375,29,sprintf("CVTE = %3.2E/K",vcte_above_mod$coefficients[2]*10^-3),pos=2,col="brown")
par(new = TRUE)
abline(v=tg_value)
text(tg_value-20,-10,sprintf("Tg=%3.0f K",tg_value))
par(new = TRUE)
# The clip command can be used to limit some line using lines or abline
clip(tg_below[1],tg_below[2],-100,100)
abline(lm(cte_volume_below ~ temp_below),col="red")
par(new = TRUE)
clip(tg_above[1],tg_above[2],-100,100)
abline(lm(cte_volume_above ~ temp_above),col="brown")
dev.off()

# Save linear CTE plot to pdf
pdf(paste(tgfilename[1],"lCTE.pdf",sep="_"))
plot(tgtemp,tglin,col="blue",xlim=c(300,500),ylim=c(min(tglin),max(tglin)),xlab="Temperature (K)",ylab="Linear expansion (dV/V times 1000)")
text(375,11,sprintf("CLTE = %3.2E/K",lcte_below_mod$coefficients[2]*10^-3),pos=2,col="red")
text(375,9,sprintf("CLTE = %3.2E/K",lcte_above_mod$coefficients[2]*10^-3),pos=2,col="brown")
par(new = TRUE)
abline(v=tg_value)
text(tg_value-20,-3,sprintf("Tg=%3.0f K",tg_value))
par(new = TRUE)
# The clip command can be used to limit some line using lines or abline
clip(tg_below[1],tg_below[2],-100,100)
abline(lm(cte_linear_below ~ temp_below),col='red')
par(new = TRUE)
clip(tg_above[1],tg_above[2],-100,100)
abline(lm(cte_linear_above ~ temp_above),col='brown')

dev.off()

# Save moving average plot to pdf
# ma_name <- paste(tgfilename[1],"ma",sep="_")
# pdf(paste(ma_name,"pdf",sep="."))
# plot(tgtemp,tgdens_ma,col="blue",xlim=c(300,500),ylim=c(1.24,1.34),xlab = 'Temperature (Kelvin)',ylab = 'Density (g/cc)')
# #plot(tgtemp,tgdens)
# par(new = TRUE)
# plot(segmented.mod,col="red",xlim=c(300,500),ylim=c(1.24,1.34),xlab = '',ylab = '',rug=FALSE)
# par(new = TRUE)
# plot(tg_value,tg_y_value,pch=24,col="white",bg="white",xlim=c(300,500),ylim=c(1.24,1.34),xlab = '',ylab = '')
# dev.off()

# Get slope coefficients into variables
clte_above <- lcte_above_mod$coefficients[2]
clte_below <- lcte_below_mod$coefficients[2]
cvte_above <- vcte_above_mod$coefficients[2]
cvte_below <- vcte_below_mod$coefficients[2]

# Write Tg value to file
tg_data <- data.frame(tg_value,tg_value_stderror,clte_above,clte_below,cvte_above,cvte_below)
write.table(tg_data, file=paste(tgfilename[1],"txt",sep="."))


rankall <- function(outcome, num = "best") {
  ## Read outcome data
  data <- read.csv("outcome-of-care-measures.csv", colClasses = "character")
  hosp <- data.frame(data[,2], #name
                         data[,7], #state
                         data[,11], #heart attack
                         data[,17], # heart failure
                         data[,23], stringsAsFactors = FALSE) #pneumonia
  colnames(hosp) <- c("hospital", "state", "heart attack", "heart failure", "pneumonia")

  ## Check that state and outcome are valid

  if (!outcome %in% c("heart attack", "heart failure", "pneumonia")) { stop('invalid outcome')}
  ## For each state, find the hospital of the given rank
  else if (num == "best") {
    sort_hospital <- order(hosp[,outcome], hosp[,"hospital"]) #sort outcome and hospital first
    sort_hospital <- hosp[sort_hospital, ]

    outcome_hospital <- sort_hospital[,c("hospital","state",outcome)]
    outcome_hospital[,3] <- as.numeric(outcome_hospital[,3])
    outcome_hospital <- outcome_hospital[order(outcome_hospital[,outcome], decreasing = FALSE), ]

    hospital_state <- split(outcome_hospital, outcome_hospital[,"state"])
    result <- lapply(hospital_state, function(x) { x[1,1:2]})
    result <- do.call(rbind, result) }
  else if (num == "worst") {
    sort_hospital <- order(hosp[,outcome], hosp[,"hospital"]) #sort outcome and hospital first
    sort_hospital <- hosp[sort_hospital, ]

    outcome_hospital <- sort_hospital[,c("hospital","state",outcome)]
    outcome_hospital[,3] <- as.numeric(outcome_hospital[,3])
    outcome_hospital <- outcome_hospital[order(outcome_hospital[,outcome], decreasing = TRUE), ]

    hospital_state <- split(outcome_hospital, outcome_hospital[,"state"])
    result <- lapply(hospital_state, function(x) { x[1,1:2]})
    result <- do.call(rbind, result)}

  else if (is.numeric(num)) {
    sort_hospital <- order(hosp[,outcome], hosp[,"hospital"])
    sort_hospital <- hosp[sort_hospital, ]

    outcome_hospital <- sort_hospital[,c("hospital","state",outcome)]
    outcome_hospital[,3] <- as.numeric(outcome_hospital[,3])
    outcome_hospital <- outcome_hospital[order(outcome_hospital[,outcome], decreasing = FALSE), ]

    hospital_state <- split(outcome_hospital, outcome_hospital$state)

    result <- lapply(hospital_state, function(x) { x[num,1:2]}) #if sorted
    result <- do.call(rbind, result)
    result[,2]
    result[,2] <- rownames(result) #Insert state name to NA
  } else { stop('NA') }

  ## Return a data frame with the hospital names and the (abbreviated) state name
  result
  }

head(rankall("heart attack", 20), 10)
tail(rankall("pneumonia", "worst"), 3)
tail(rankall("heart failure"), 10)

Data Science /R Programming/ProgrammingAssignment3/rankall.r


###########################################################################
#########This script contains code and examples       #####################
#########for making scientific quality figures.       #####################
###########################################################################

#read in example dataset
	datRH <- read.csv("c:/Users/scardarelli/Documents/research/siberia_lai/R_Intro-master/3_Plots/canopyRH.csv")
	datRH$Time <- datRH$doy + (datRH$hour/24)

#######################################################
######## Make a multipanel figure #####################
#######################################################
#this code makes a multipanel figure in a jpeg
#that will have manuscript quality label sizes.
#it uses the example dataset to generate the figure
#but it can be changed to any type of data.

#1. specify the directory where you will save your plots
	plotDir <- "c:/Users/scardarelli/Documents/research/siberia_lai/R_Intro-master/3_Plots/plots/"

#2. specify the number of panels you will need in your plot
	pN <- 4

#3. specify how many columns of panes you want
	pC <- 2

#4. specify width and height of the panels
	#these numbers will depend on how big you make your jpeg
	#if they are too big of a size for the jpeg, you will get
	#a figure region too big
	wd <- 35
	hd <- 35

#5. Declare the boundries of each plot limits. This way
    #you can readily alter the plot limits without having
	#to change anything by hand

	#I am going to make a panel of relative humidity and
	#temperature across each hourfor each of my sites.
	#Each site has a different time period.
	#I will stack the graphs so that each column in the
	#panel is a site since it shares the same values on
	#the x axis.
	#x axis limits

	#site 1
	xl1	<- 181
	xh1 <- 183
	#site 2
	xl2 <- 183
	xh2 <- 185
	#y axis limits
	#temperature
	ylT <- 0
	yhT <- 25
	#relative humidity
	ylR <- 0
	yhR <- 1

	#axis label sequences
	ysT <- seq(0,20, by=5)
	ysR <- seq(0,.9, by=.1)
	xs1 <- seq(181,182.5,by=.5)
	xs2 <- seq(183,185,by=.5)

	#character expansions
	#cex for plot symbols
	cP <- 8
	#for y axis
	cAy <- 5
	#for axis labesl
	clabel <- 6
	#for x axis
	cAx <- 4

	#colors for plot symbols
	col1 <- "royalblue3"
	col2 <- "tomato3"

	#line thickness
	lw <- 3

	#panel letter size and location
	#cex for letter label
	cl <- 8
	#offset from panels
	l.offs <- .1
	l.offT <- 1
	l.offR <-.05

#6. Start generating the plot
	#this command will start plotting to file, and anything after it will go to your file.
	#It can only be ended with the dev.off() function.
	#the plot will be generated into the directory plotDir indicated above
	jpeg(paste0(plotDir, "\\multipanel.jpg"), width=2500, height=2500, units="px", quality=100)
		####################################################
		############ jpeg            #######################
		####################################################
		#jpeg(file.name and path, width=width of file, height=height of file,
		#     units="px" indicated pixel units, quality=100 (lower numbers will produce lower quality))

# 7. specify the panel layout
	#the layout is based on the number of panels declared above  (pn),
	#the number of columns specified above (pc), and the width and height
	#of each panel (wd, hd respectively) that was specified above
	 layout(matrix(seq(1,pN), byrow=FALSE, ncol=pC), width=rep(lcm(wd),pN), height=rep(lcm(hd),pN))
		####################################################
		############ layout          #######################
		####################################################
		#layout(matrix that is structured to the layout of the panels that contains the plot
		#order for each panel, width=widths for each panel, height=heights for each panel)
# 8. start making the plot for panel 1: high density Temp
	#8.A. Specify that there should be no margins to the plot
	par(mai=c(0,0,0,0))

	#8.B. Make an empty plot with the proper limits above
	# all points, labels, and axes will be added in seperately.

	plot(c(0,1),c(0,1), type="n", xlim=c(xl1,xh1), ylim=c(ylT,yhT), axes=FALSE, xlab=" ",
		ylab=" ", xaxs="i", yaxs="i")

	#8. C. add the points that we want to plot
	points(datRH$Time[datRH$site=="hd"],datRH$TempC.VP4[datRH$site=="hd"], type="b",
			col=col1,  lwd=lw, cex=cP, pch=19)

	#8. D. make axis for y axis
	axis(2, ysT, cex.axis=cAy, las=2, lwd.ticks=3)

	#8. E. add a letter to label the panel
	text(xl1+l.offs,yhT-l.offT, "A", cex=cl)

	#8. F. label the y axis
	mtext("Temperature (C)", side=2, cex=clabel, line=15)

	#8. G. make a box around the plot
	box(which="plot")

	#8. H. label the site
	mtext("High density", side=3, cex=clabel, line=5)

# 9. start making the plot for panel 2: high density RH
	#9.A. Specify that there should be no margins to the plot
	par(mai=c(0,0,0,0))

	#9.B. Make an empty plot with the proper limits above
	# all points, labels, and axes will be added in seperately.

	plot(c(0,1),c(0,1), type="n", xlim=c(xl1,xh1), ylim=c(ylR,yhR), axes=FALSE, xlab=" ",
		ylab=" ", xaxs="i", yaxs="i")

	#9. C. add the points that we want to plot
	points(datRH$Time[datRH$site=="hd"],datRH$RH.VP4[datRH$site=="hd"], type="b",
			col=col1,  lwd=lw, cex=cP, pch=19)

	#9. D. make axis for y axis
	axis(2, ysR, cex.axis=cAy, las=2, lwd.ticks=3)

	#9. E. add a letter to label the panel
	text(xl1+l.offs,yhR-l.offR, "B", cex=cl)

	#9. F. label the y axis
	mtext("Relative humidity (-)", side=2, cex=clabel, line=15)

	#9. G. make a box around the plot
	box(which="plot")

	#9. H. make labels for the xaxis
	#x axis labels don't get offset from the axis as well in jpeg file set up.
	#they will be set up a little differently
	#first add axis ticks
	axis(1, xs1, rep(" ", length(xs1)),  lwd.ticks=3)
	mtext(xs1, at=xs1, side=1, line=4, cex=cAx)

	#9. I. add an outer label for both bottom panels since they have the same measure
	mtext("Day of year", side=1, outer=TRUE, line=-7, cex=clabel)

# 10. start making the plot for panel 3: low density Temp
	#10.A. Specify that there should be no margins to the plot
	par(mai=c(0,0,0,0))

	#10.B. Make an empty plot with the proper limits above
	# all points, labels, and axes will be added in seperately.

	plot(c(0,1),c(0,1), type="n", xlim=c(xl2,xh2), ylim=c(ylT,yhT), axes=FALSE, xlab=" ",
		ylab=" ", xaxs="i", yaxs="i")

	#10. C. add the points that we want to plot
	points(datRH$Time[datRH$site=="ld"],datRH$TempC.VP4[datRH$site=="ld"], type="b",
			col=col2,  lwd=lw, cex=cP, pch=19)

	#10. D. add a letter to label the panel
	text(xl2+l.offs,yhT-l.offT, "C", cex=cl)

	#10. E. make a box around the plot
	box(which="plot")

	#10. F. label the site
	mtext("Low density", side=3, cex=clabel, line=5)

# 11. start making the plot for panel 2: high density RH
	#11.A. Specify that there should be no margins to the plot
	par(mai=c(0,0,0,0))

	#11.B. Make an empty plot with the proper limits above
	# all points, labels, and axes will be added in seperately.

	plot(c(0,1),c(0,1), type="n", xlim=c(xl2,xh2), ylim=c(ylR,yhR), axes=FALSE, xlab=" ",
		ylab=" ", xaxs="i", yaxs="i")

	#11. C. add the points that we want to plot
	points(datRH$Time[datRH$site=="ld"],datRH$RH.VP4[datRH$site=="ld"], type="b",
			col=col2, lwd=lw, cex=cP, pch=19)

	#11. D. add a letter to label the panel
	text(xl2+l.offs,yhR-l.offR, "D", cex=cl)

	#11. E. make a box around the plot
	box(which="plot")

	#11. F. make labels for the xaxis
	#x axis labels don't get offset from the axis as well in jpeg file set up.
	#they will be set up a little differently
	#first add axis ticks
	axis(1, xs2, rep(" ", length(xs2)),  lwd.ticks=3)
	mtext(xs2, at=xs2, side=1, line=4, cex=cAx)

#12. turn off plot
dev.off()

######End multipanel figure############################


#!/usr/bin/env Rscript

args <- commandArgs(trailingOnly=TRUE)
if (length(args)<1) {
	path = "."
} else {
	path = args[1]
}

peakfind <- function(dist) {
	x <- dist
	level <- 0
	for (y in seq(sort(x))) {
		z <- sum(x[which(x>y)])
		if (z/sum(x) > 0.68) { level <- y }
	}
	x[which(x<level)] <- 0
	return (x)
}

flux <- as.matrix(read.table(paste(path, "/gasimage.txt", sep=""), head=FALSE))
vel <- as.matrix(read.table(paste(path, "/gasvel.txt", sep=""), head=FALSE))
params <- read.table(paste(path,"/imagedata.txt", sep=""), head=FALSE)[[1]]

vel[which(is.nan(vel))] <- 0

vlimits <- c(vel[1,1], vel[1,length(vel[1,])])

vbins <- vel[1,]

nbins <- 25

size <- params[1]
windowSize <- 1.0/params[2]
baser <- 0.02/params[2]

inclination <- params[3]
if (inclination>(pi/2)) { inclination <- pi-inclination }

vc <- function(x,y) {
	return(1+y+(x-1)*size)
}

vplot <- function() {
	dev.new(width=4, height=4)
	vimage <- matrix(0,size,size)
	for (y in seq(size)) {
		for (x in seq(size)) {
			n <- 1+x+(y-1)*size
			dist <- vel[n,]
			medv <- vbins[which.max(dist)]
			if (sum(dist)<100) { medv = 0 }
			vimage[x,y] = medv
		}
	}
	#par(mfrow=c(1,1))
	image(vimage)
}

vplot2 <- function() {
	vimage <- matrix(0,size,size)
	vlimit <- 0

	fluxmin <- 0.10*max(flux)
	print(fluxmin)

	for (y in seq(size)) {
		for (x in seq(size)) {
			n <- 1+x+(y-1)*size
			dist <- peakfind(vel[n,])
			red <- sum(dist[which(vbins>vlimit)])
			blue <- sum(dist[which(vbins<(-vlimit))])
			if (sum(dist)>fluxmin) {
				vimage[y,x]=blue-red
				#if (blue-red==0) {
				#	vimage[y,x]=10
				#}
			} else {
				vimage[y,x]=-999999
			}
		}
	}
	#vimage[which(abs(vimage)>1e10)] <- 0
	#par(mfrow=c(1,1))
	colseq <- rgb(seq(1,0, by=-0.05), 0, seq(0,1,by=0.05))
	colseq <- c(rgb(seq(0,0.5,by=0.05), 0, seq(1,0.5,by=-0.05)), rgb(0,0,0), rgb(seq(0.5,1, by=0.05), 0, seq(0.5,0,by=-0.05)))

	rangesize <- 40
	rangeclip <- 50

	colseq <- c(rgb(0,0,0), rgb(seq(0,0.5,length.out=rangesize), 0, seq(1,0.5,length.out=rangesize)), rgb(seq(0.5,1, length.out=rangesize), 0, seq(0.5,0,length.out=rangesize)))

	vsize <- max(abs(vimage[which(vimage>-999999)]))+1
	breakseq <- c(-1000000, seq(-vsize,vsize,length.out=1+rangesize*2))

	image(vimage, col=colseq, breaks=breakseq, xaxt= "n", yaxt= "n", xlab="x(kpc)", ylab="y(kpc)")
	w <- round(1e3*windowSize/2)
	axis(1, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
	axis(2, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
}

residplot <- function() {
	velmodel <- as.matrix(read.table(paste(path, "/model/gasvel.txt", sep=""), head=FALSE))
	vimage <- matrix(0,size,size)
	for (y in seq(size)) {
		for (x in seq(size)) {
			n <- 1+x+(y-1)*size
			dist1 <- cumsum(vel[n,])
			dist2 <- cumsum(velmodel[n,])
			med1 <- which(dist1>=0.5*max(dist1))[1]
			med2 <- which(dist2>=0.5*max(dist2))[1]
			if (sum(dist1)>0 && sum(dist2)>0) {
				vimage[y,x] <- med2-med1
			} else {
				vimage[y,x] <- -999999
			}
		}
	}
	#vimage[which(abs(vimage)>1e10)] <- 0
	#par(mfrow=c(1,1))
	rangesize <- 40
	rangeclip <- 50

	#colseq <- c(rgb(seq(0,0.5,length.out=rangesize), 0, seq(1,0.5,length.out=rangesize)), rgb(0,0,0), rgb(seq(0.5,1, length.out=rangesize), 0, seq(0.5,0,length.out=rangesize)))

	#breakseq <- seq(-size/rangeclip,size/rangeclip,length.out=2+rangesize*2)

	colseq <- c(rgb(0,0,0), rgb(seq(0,0.5,length.out=rangesize), 0, seq(1,0.5,length.out=rangesize)), rgb(seq(0.5,1, length.out=rangesize), 0, seq(0.5,0,length.out=rangesize)))

	breakseq <- c(-1000000, seq(-size/rangeclip,size/rangeclip,length.out=1+rangesize*2))

	image(vimage, col=colseq, breaks=breakseq, xaxt= "n", yaxt= "n", xlab="x(kpc)", ylab="y(kpc)")
	w <- round(1e3*windowSize/2)
	axis(1, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
	axis(2, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
}

centreplot <- function() {
	n <- 1+(size/2)+((size/2)-1)*size
	plot(vbins, vel[n,]/sum(vel[n,]), type="l", xlab=expression(v[los]~(km/s)), ylab=expression(n/n[tot]))
	segments(0,0,0,1e10, lty=2)
}

plainfluxplot <- function() {
	image(flux, xaxt= "n", yaxt= "n", xlab="x(kpc)", ylab="y(kpc)")
	w <- round(1e3*windowSize/2)
	axis(1, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
	axis(2, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
}

fluxplot <- function(x,y, angle) {
	image(flux, xaxt= "n", yaxt= "n", xlab="x(kpc)", ylab="y(kpc)")
	w <- round(1e3*windowSize/2)
	axis(1, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
	axis(2, at=seq(0,1, length.out=5), labels=c(-w, -w/2, 0, w/2, w))
	xend <- (0.05*cos(angle))/windowSize
	yend <- (0.05*sin(angle))/windowSize
	x <- x/windowSize + 0.5
	y <- y/windowSize + 0.5
	points(x,y)
	segments(x-1000*cos(angle), y-1000*sin(angle), x+1000*cos(angle), y+1000*sin(angle), lty=3)
	points(c(x+xend, x-xend), c(y+yend, y-yend), pch=4)
}

dplot <- function(x,y, angle, dptype) {
	par(mfrow=c(2,2))
	fluxplot(x,y,angle)
	rotgrid <- matrix(0, nbins, length(vel[1,]))
	rotcur <- rep(0,nbins)
	radius <- seq(baser, baser*nbins/2,by=baser)
	radius <- c(sort(-radius), 0, radius)

 	sink(paste(path,"/curve.txt", sep=""))
	cat("r v\n")
	for(i in seq(length(radius))) {
		px <- radius[i]*cos(angle)
		py <- radius[i]*sin(angle)
		gx <- px * size/windowSize + size*0.5
		gy <- py * size/windowSize + size*0.5
		n <- c(vc(floor(gx), floor(gy)), vc(floor(gx), ceiling(gy)), vc(ceiling(gx), floor(gy)), vc(ceiling(gx), ceiling(gy)))
		xdist <- gx-floor(gx)
		ydist <- gy-floor(gy)
		v1 <- vel[n[1],]*xdist + vel[n[3],]*(1-xdist)
		v2 <- vel[n[2],]*xdist + vel[n[4],]*(1-xdist)
		vhist <- v1*(1-ydist) + v2*(ydist)
		peak1 <- vel[1,which.max(vel[n[1],])]*xdist + vel[1,which.max(vel[n[3],])]*(1-xdist)
		peak2 <- vel[1,which.max(vel[n[2],])]*xdist + vel[1,which.max(vel[n[4],])]*(1-xdist)
		peak <- peak1*(1-ydist) + peak2*(ydist)
		peak <- seq(vlimits[1], vlimits[2], length.out=length(vhist))[which.max(vhist)]
		rotgrid[i,] = vhist
		rotcur[i] = peak
		cat(c(radius[i]," ",rotcur[i]/sin(inclination),"\n"))
	}
	sink()

	vplot2()
	image(rotgrid, xaxt= "n", yaxt= "n", xlab="dR(kpc)", ylab=expression(v[rot]~(km/s)))
	axis(1, at=seq(0,1, length.out=5), labels=1000*as.numeric(quantile(radius)))
	axis(2, at=seq(0,1, length.out=5), labels=seq(round(vlimits[1]), round(vlimits[2]),length.out=5))
	segments(-1.0, -1.0/(vlimits[2]/vlimits[1] - 1.0), 2.0, -1.0/(vlimits[2]/vlimits[1] - 1.0), lty=2)
	segments(0.5, -1.0, 0.5, 2.0, lty=2)
	#lines(seq(0,1,length.out=nbins), (rotcur-vlimits[1])/(vlimits[2]-vlimits[1]), lty=1)
	if (dptype==0) {
		centreplot()
	} else {
		residplot()
	}
}

rotation <- function() {
	data <- read.table(paste(path,"/curve.txt", sep=""), head=TRUE)
	n <- which(data$v>0)[1]
	r0 <- data$r[n-1]+(data$r[n]-data$r[n-1])*(-data$v[n-1]/(data$v[n-1]+data$v[n]))
	data$r <- abs(data$r-r0)
	data$v <- abs(data$v)
	r1 <- data$r[(n-1):1]*1e3
	v1 <- data$v[(n-1):1]
	r2 <- data$r[n:length(data$r)]*1e3
	v2 <- data$v[n:length(data$r)]
	smooth1 <- splinefun(r1,v1)
	smooth2 <- splinefun(r2,v2)
	par(mfrow=c(1,1))
	rs <- seq(1,12, by=0.5)
	centre <- (smooth1(rs) + smooth2(rs))/2
	err <- abs(smooth1(rs) - smooth2(rs))/2
	err[which(err<1)] = 1
	plot(rs, centre, ylim=c(0,max(data$v)*1.3))
	segments(rs, smooth1(rs), rs, smooth2(rs))
	sink(paste(path,"/obs.csv", sep=""))
	for(i in seq(length(rs))) {
		cat(c(rs[i],", ",centre[i],"\n"))
	}
	sink()
	sink(paste(path,"/err.csv", sep=""))
	for(i in seq(length(rs))) {
		cat(c(rs[i],", ",err[i],"\n"))
	}
	sink()
}

baryons <- function() {
	data <- read.table(paste(path, "/gasphi.txt", sep=""), head=TRUE)
	curve <- splinefun(data$r*1e3, data$phi)
	rs <- seq(1,12, by=0.5)
	vc <- sqrt(curve(rs, deriv=1)*rs)
	sink(paste(path, "/gas.csv", sep=""))
	for(i in seq(length(rs))) {
		cat(c(rs[i], ", ", vc[i], "\n"))
	}
	sink()

	data <- read.table(paste(path,"/starphi.txt", sep=""), head=TRUE)
	curve <- splinefun(data$r*1e3, data$phi)
	rs <- seq(1,12, by=0.5)
	vc <- sqrt(curve(rs, deriv=1)*rs)
	sink(paste(path, "/star.csv", sep=""))
	for(i in seq(length(rs))) {
		cat(c(rs[i], ", ", vc[i], "\n"))
	}
	sink()

	sink(paste(path,"/star2.csv", sep=""))
	for(i in seq(length(rs))) {
		cat(c(rs[i], ", 0\n"))
	}
	sink()
}

curveplot <- function() {
	data <- read.csv(paste(path, "/obs.csv", sep=""), head=FALSE)
	radius <- data[[1]]
	obs <- data[[2]]
	data <- read.csv(paste(path, "/err.csv", sep=""), head=FALSE)
	err <- data[[2]]
	data <- read.csv(paste(path, "/gas.csv", sep=""), head=FALSE)
	gas <- data[[2]]
	data <- read.csv(paste(path, "/star.csv", sep=""), head=FALSE)
	stars <- data[[2]]
	plot(radius, obs, ylim=c(0,max(obs)*1.2), ylab=expression(v[c]), xlab="R(kpc)")
	segments(radius, obs-err, radius, obs+err)
	lines(radius, stars, col="red")
	lines(radius, gas, col="blue")
}

pdf("output.pdf")
dplot(0,0,(pi/2.0)-params[5], 0)
dev.off() -> dumpvar

pdf("flux.pdf")
plainfluxplot()
dev.off() -> dumpvar

pdf("output2.pdf")
dplot(0,0,(pi/2.0)-params[5], 1)
dev.off() -> dumpvar


code 'instr_lastTerm'
name ''
dimensions {
	item null
	bal {}
	icd {
		dummy true
		staticHeads {
			head model:[id:1,name:'本期']
			head model:[id:2,name:'上期'],formula:{lastTerm()}
			head {
                model ([id:3,name:'比上期 %'])
				formula {increaseRate()}
				dataType 'percent'
			}
		}
	}
}
layout {
	rows 'item'
	columns (['bal','icd'])
}
dataRequest {
	table 'gl'
	params {
		date parseDate('2012-5-31')
		bank '110101'
		currency '01'
	}
}
discoverDR true
heads {
	item {
		params {
			code (['like','1%'])
		}
		paginate {
			perPage 10
			page 1
		}
	}
}
derivedHeads {
	item {
		head SUM_HEAD()
	}
}
dataGrids {
	apply sel([-1,[2,5,8]]), {
		formula {(left.left-left)/left}
	}
}

//instrument new Instrument(){
//	List<Head> headsExpanded(dimension,List<Head> heads,Head parentHead=null){
//		if(dimension.name=='bal'){
//			heads.grep{it.model.id!='credit'}
//		}
//	}
//	List<Head> lowerHeads(HeadGrid headGrid, List<Head> lowerHeads){
//		if(headGrid.head.model.id=='debit'){
//			def last=lowerHeads.last()
//			lowerHeads[-1]=new Head(name:'比上期',aggregate:true,formula:{left.left-left})
//			lowerHeads << last
//			lowerHeads
//		}
//	}
//}


#!/usr/bin/env Rscript
#
# File Name  : asequan.r
# Author     : Zhenhua Zhang
# E-mail     : zhenhua.zhang217@gmail.com
# Created on : Fri 25 Jan 2019 10:51:30 AM CET
# Version    : v0.1.0
# License    : MIT
#

# Example
# Rscript asequan.r input.tsv output.tsv

rm(list = ls())

library(dplyr)

# Customized paste function
ppaste <- function(...){ paste(..., sep = "/") }

# Log-likelihood function under Binomial distribution
bn_llik <- function(p, alts, refs) {
  totals <- alts + refs
  r <- -sum(lchoose(totals, alts) + alts * log(p) + refs * log(1 - p))

  if (r == -Inf){
    return(-.Machine$integer.max)
  } else if (r == Inf){
    return(.Machine$integer.max)
  } else {
    return(r)
  }
}

# Likelihood ratio test under binomial likelihood
bn_lrt <- function(alt_counts, ref_counts) {

  nul_p <- 0.5
  nul_llik <- bn_llik(nul_p, alt_counts, ref_counts)  # Filter out alt == ref

  alt_p <- exp(mean(log(alt_counts / ref_counts)))
  alt_llik_opt <- optim(
    par = alt_p, fn = bn_llik, NULL,
      method = "L-BFGS-B", lower = c(1e-12), upper = c(1),
      control = list(maxit = 10000),
      alts = alt_counts, refs = ref_counts
  )

  alt_p <- alt_llik_opt$par
  alt_llik <- alt_llik_opt$value

  dof <- length(alt_counts) - 1

  if (dof == 0) {
    chisq <- NA
    chisq_p <- NA
  } else {
    chisq <- - 2 * (alt_llik - nul_llik)
    chisq_p <- 1 - pchisq(chisq, dof)
  }

  r <- list(nul_bn_llik=nul_llik, alt_bn_llik=alt_llik, p_value = chisq_p)
  return(r)
}

# Log-likelihood function under Beta-Binomial distribution
bb_llik <- function(p_od, alts, refs){
  alts_len <- length(alts)
  refs_len <- length(refs)
  if(alts_len != refs_len) {
    stop("alts and refs should have identical length...")
  }

  if (length(p_od) == 1){
    p <- 0.5
    od <- p_od[[1]]
  } else if (length(p_od) == 2){
    p <- p_od[[1]]
    od <- p_od[[2]]
  } else {
    stop("p_od should be no more than 2 elements")
  }

  if (p > 1 || p < 0){
    stop("The first element of p_od should be a decimal between 0 to 1")
  }

  if (od <= 0) {
	stop("The second element of p_od should be positive, but get ", od)
  }

  a <- od * p
  b <- od * (1 - p)
  r <- -sum(lbeta(alts + a, refs + b) - lbeta(a, b) + lchoose(alts + refs, alts))

  if (r == -Inf){
    return(-.Machine$integer.max)
  } else if (r == Inf){
    return(.Machine$integer.max)
  } else {
    return(r)
  }
}

# Likelihood ratio test under Beta-Binomial distribution
bb_lrt <- function(alt_counts, ref_counts){
  alts_len <- length(alt_counts)
  refs_len <- length(ref_counts)

  if(alts_len != refs_len) {
    stop("alt_counts and ref_counts should have identical length...")
  }

  alt_od_init <- sum(alt_counts + ref_counts)  # Using total reads counts
  alt_p_init <- exp(mean(log(alt_counts / ref_counts)))
  alt_opt <- optim(
    par = c(alt_p_init, alt_od_init), fn = bb_llik, NULL,
    method = "L-BFGS-B", lower = c(1e-12, 1e-10), upper = c(1, 1e10),
    control = list(maxit = 10000),
    alts = alt_counts, refs = ref_counts
  )

  alt_par <- alt_opt$par
  alt_llik <- alt_opt$val

  # Using optim to find the over-dispersion parameter under null model
  # nul_opt <- optim(
  #   par = c(10), fn = bb_llik, NULL,
  #     method = "L-BFGS-B", lower = c(1e-12), upper = c(1e12),
  #     control = list(maxit = 10000),
  #     alts = alt_counts, refs = ref_counts
  # )
  # nul_par <- nul_opt$par
  # nul_llik <- nul_opt$val

  # nul_par <- alt_par[[2]]  # Using the over-dispersion parameter derived from samples
  nul_par <- sum(alt_counts + ref_counts)  # Using average total reads counts
  nul_llik <- bb_llik(c(0.5, nul_par), alt_counts, ref_counts)
  nul_llik <- nul_llik

  dof <- alts_len - 1
  if (dof == 0) {
    chisq <- NA
    chisq_p <- NA
  } else {
    chisq <- - 2 * (alt_llik - nul_llik)
    chisq_p <- 1 - pchisq(chisq, dof)
  }

  r <- list(
    nul_p=0.5, nul_od=nul_par, nul_llik_bb=nul_llik,
    alt_p=alt_par[[1]], alt_od=alt_par[[2]], alt_llik_bb=alt_llik,
    p_value = chisq_p
  )

  return(r)
}

trans_into_bin <- function(rtb, cr, pv = 0.05, min_dep = 10, min_dep_per = 3){
  cat("FILTER: BY refCountsBios and altCountsBios ...\n")
  gp <- rtb %>%
    filter(
    (refCountsBios >= min_dep_per)
    & (altCountsBios >= min_dep_per)
    & (refCountsBios != altCountsBios)
    & (refCountsBios + altCountsBios >= min_dep)
    & (!is.na(GeneID))
    & (!is.na(FeatureID))
    & (!is.na(GeneName))
  )

  cat("MUTATE: ADD bn_p, bb_p, group_size, and log2FC ...\n")
  gp <- gp %>%
    group_by(Chrom, Pos, Ref, Alt, GeneID) %>%
    mutate(
      log2FC = log2(sum(altCountsBios) / sum(refCountsBios)),
    bn_p = bn_lrt(altCountsBios, refCountsBios)$p_value,
    bb_p = bb_lrt(altCountsBios, refCountsBios)$p_value,
    group_size = n_distinct(sampleBios)
    )

  cat("MUTATE: ADD bn_p_adj, bn_ASE, bb_p_adj, bb_ASE ...\n")
  gp <- gp %>%
    ungroup() %>%
    mutate(
      bn_p_adj = p.adjust(bn_p, method = "fdr"),
      bb_p_adj = p.adjust(bb_p, method = "fdr"),
      bn_ASE = ifelse(bn_p_adj < pv, ifelse(log2FC < 0, -1, 1), 0),
      bb_ASE = ifelse(bb_p_adj < pv, ifelse(log2FC < 0, -1, 1), 0)
    ) %>%
    select(rn)

  cat("ARRANGE: Filter ...\n")
  gp <- gp %>%
    arrange(Chrom, Pos, Ref, Alt) %>%
    distinct() %>%
    as.data.frame()

  return(gp)
}

# Deal with input and output
args <- commandArgs(trailingOnly = TRUE)
if(length(args) == 2){
  ipf <- args[1]
  opf <- args[2]
} else {
  stop("Wrong number of arguments. Require 2...\n")
}

# Deal with `tar` compressed files
if (endsWith(ipf, '.tar.gz') || endsWith(ipf, '.tgz')){ ipf <- untar(ipf) }
rtb <- read.csv(ipf, header = TRUE, sep = "\t")
rn <- c(
  colnames(rtb)[1:107], "log2FC", "bn_p", "bn_p_adj", "bb_p", "bb_p_adj",
  "group_size", "bn_ASE", "bb_ASE"
)

# Calculate
odf <- trans_into_bin(rtb, rn)
# cat(dim(odf[which(abs(odf$bn_ASE)==1), ]), " in bn_ASE(1, -1)\n")
# cat(dim(odf[which(abs(odf$bb_ASE)==1), ]), " in bb_ASE(1, -1)\n")

# Dump out results
write.table(odf, file = opf, quote = FALSE, sep = "\t", row.names = FALSE)


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of uniform prior wonky world model predictions"
#' author: "Judith Degen"
#' date: "May 17, 2015"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/")
source("rscripts/helpers.r")

#' get model predictions
load("data/mp-uniform-prits.RData")
d = read.table("data/parsed_uniform_prits_results.tsv", quote="", sep="\t", header=T)
table(d$Item)
nrow(d)
head(d)
summary(d)
d[d$Item == "ate the seeds birds" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 1,]
d[d$Item == "stuck to the wall baseballs" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 2 & d$Wonky == "true",]
mp = ddply(d, .(Item, State, Quantifier, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))
head(mp)
wr = ddply(d, .(Item, Wonky, Quantifier, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))

# get prior expectations
priorexpectations = read.table(file="/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_data_analysis/ordered_expectations.txt",sep="\t", header=T, quote="")
priorexpectations$Item = as.factor(gsub("cd players","cd-players",as.character(priorexpectations$Item)))
row.names(priorexpectations) = priorexpectations$Item
mp$PriorExpectation = priorexpectations[as.character(mp$Item),]$expectation
wr$PriorExpectation = priorexpectations[as.character(wr$Item),]$expectation
head(mp)
head(wr)

# get smoothed prior probabilities
priorprobs = read.table(file="/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_data_analysis/prits_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
priorprobs$Item = as.factor(gsub("cd players","cd-players",as.character(priorprobs$Item)))
row.names(priorprobs) = priorprobs$Item
mpriorprobs = melt(priorprobs, id.vars=c("Item"))
head(mpriorprobs)
row.names(mpriorprobs) = paste(mpriorprobs$Item,mpriorprobs$variable)
mp$PriorProbability = mpriorprobs[paste(as.character(mp$Item)," X",mp$State,sep=""),]$value
mp$AllPriorProbability = priorprobs[paste(as.character(mp$Item)),]$X15
head(mp)
tail(mp)

# get empirical state posteriors:
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/16_sinking-marbles-sliders-certain/results/data/r.RData")
head(r)
# because posteriors come in 4 bins, make Bin variable for model prediction dataset:
mp$Proportion = as.factor(ifelse(mp$State == 0, "0", ifelse(mp$State == 15, "100", ifelse(mp$State < 8, "1-50", "51-99"))))

agr = aggregate(normresponse ~ Item + quantifier + Proportion,data=r,FUN=mean)
#agr$CILow = aggregate(normresponse ~ Item + quantifier + Proportion,data=r, FUN=ci.low)$normresponse
#agr$CIHigh = aggregate(normresponse ~ Item + quantifier + Proportion,data=r,FUN=ci.high)$normresponse
#agr$YMin = agr$normresponse - agr$CILow
#agr$YMax = agr$normresponse + agr$CIHigh
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Proportion, agr$Quantifier)
mp$PosteriorProbability_empirical = agr[paste(mp$Item,mp$Proportion,mp$Quantifier),]$normresponse

#plot empirical against predicted distributions for "some"
some = ddply(mp, .(Item, Quantifier, SpeakerOptimality, PriorExpectation, Proportion, WonkyWorldPrior, PosteriorProbability_empirical), summarise, PosteriorProbability_predicted=sum(PosteriorProbability), PriorProbability_smoothed=sum(PriorProbability))
some= subset(some, Quantifier == "some")
nrow(some)
head(some)
msome = melt(some, measure.vars=c("PosteriorProbability_empirical","PosteriorProbability_predicted","PriorProbability_smoothed"))
msome$ptype = as.factor(ifelse(msome$variable == "PosteriorProbability_empirical", "posterior (empirical)",ifelse(msome$variable == "PosteriorProbability_predicted","posterior (model)", "prior")))
head(msome)
nrow(msome)
summary(msome)

toplot = droplevels(subset(msome,  SpeakerOptimality == 2))#"0_basic1_lownum2_extra4_twowords5_threewords"))
nrow(toplot)
toplot$Probability = as.factor(ifelse(toplot$ptype == "prior","prior","posterior"))
toplot$Prop = factor(toplot$Proportion, levels=c("1-50","51-99","100"))
ggplot(toplot, aes(x=Prop, y=value,color=ptype, group=ptype, size=Probability)) +
  geom_point() +
  geom_line() +
  scale_size_discrete(range=c(1,2)) +
  scale_color_manual(values=c("red","blue","black")) +
  facet_wrap(WonkyWorldPrior~Item)
ggsave("graphs/4_prits/model-empirical-uniform-howmany-2-basic-prits.pdf",width=35,height=30)

#plot empirical against predicted expectations for "some"
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")
summary(r)
r$Item = as.factor(paste(r$effect, r$object))
agr = aggregate(ProportionResponse ~ Item + quantifier, data=r, FUN=mean)
#agr$CILow = aggregate(ProportionResponse ~ Item + quantifier,data=r, FUN=ci.low)$ProportionResponse
#agr$CIHigh = aggregate(ProportionResponse ~ Item + quantifier,data=r,FUN=ci.high)$ProportionResponse
#agr$YMin = agr$ProportionResponse - agr$CILow
#agr$YMax = agr$ProportionResponse + agr$CIHigh
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Quantifier)
mp$PosteriorExpectation_empirical = agr[paste(mp$Item,mp$Quantifier),]$ProportionResponse
mp$PriorExpectation_smoothed = mp$PriorExpectation

pexpectations = ddply(mp, .(Item, Quantifier, SpeakerOptimality,PriorExpectation_smoothed, WonkyWorldPrior, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability))
head(pexpectations)
some = droplevels(subset(pexpectations, Quantifier == "some"))
some$PosteriorExpectation_empirical = some$PosteriorExpectation_empirical*15

# cors = ddply(some, .(SpeakerOptimality, WonkyWorldPrior), summarise, r=cor(PosteriorExpectation_predicted, PosteriorExpectation_empirical))
# cors = cors[order(cors[,c("r")],decreasing=T),]
# head(cors)

# plot by-item diff in predicted and empirical expectation by confidence rating
confidence = read.table("../../../experiments/24_sinking-marbles-prior-fourstep/results/data/confidence.txt",sep="\t",quote="",header=T)
nrow(confidence)
head(confidence)
row.names(confidence) = confidence$Item

some$Confidence = confidence[as.character(some$Item),]$response
head(some)
some$PredictionDiff = some$PosteriorExpectation_predicted - some$PosteriorExpectation_empirical

ggplot(some, aes(y=PredictionDiff,x=Confidence)) +
  geom_point() +
  geom_smooth() +
  geom_hline(yintercept=0) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality) #+
  #geom_text(aes(label=Item))
#ggsave(file="graphs/4_prits/model-empirical-diff-by-confidence-annotated.pdf",width=20,height=16)
ggsave(file="graphs/4_prits/model-empirical-diff-by-confidence.pdf",width=10,height=8)

ggplot(some, aes(y=abs(PredictionDiff),x=Confidence)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality) +
  geom_text(aes(label=Item),size=3,color="lightblue")
ggsave(file="graphs/4_prits/model-empirical-diff-by-confidence-annotated.pdf",width=20,height=16)
#ggsave(file="graphs/4_prits/model-empirical-absdiff-by-confidence.pdf",width=10,height=8)

library(hydroGOF)
#mses = ddply(some, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=mse(PosteriorExpectation_predicted, PosteriorExpectation_empirical))
#mses = mses[order(mses[,c("mse")]),]
#head(mses)

test = ddply(some, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["MSE",],r=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["r",],R2=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)

some$ScaledPosteriorExpectation_predicted = some$PosteriorExpectation_predicted/15
some$ScaledPosteriorExpectation_empirical = some$PosteriorExpectation_empirical/15
test = ddply(some, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=gof(ScaledPosteriorExpectation_predicted, ScaledPosteriorExpectation_empirical)["MSE",],r=gof(ScaledPosteriorExpectation_predicted, ScaledPosteriorExpectation_empirical)["r",],R2=gof(ScaledPosteriorExpectation_predicted, ScaledPosteriorExpectation_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)
some$Predicted = some$ScaledPosteriorExpectation_predicted
some$Empirical = some$ScaledPosteriorExpectation_empirical
some[,c("Item","WonkyWorldPrior","SpeakerOptimality","Predicted","Empirical")] %>%
  save(file="data/some-expectations-prits.RData")

ggplot(some, aes(x=PosteriorExpectation_predicted, y=PosteriorExpectation_empirical,color=as.factor(SpeakerOptimality), shape=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,15)) +
#  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(SpeakerOptimality~WonkyWorldPrior)
ggsave("graphs/4_prits/model-empirical-uniform-expectations-prits.pdf",width=20,height=10)

ggplot(some, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted,color=as.factor(SpeakerOptimality), shape=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,15)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(SpeakerOptimality~WonkyWorldPrior)
ggsave("graphs/4_prits/model-uniform-expectations-prits.pdf",width=20,height=10)

#plot empirical against predicted allstate-prbabilities for "some"
allstate = droplevels(subset(mp, State == 15 & Quantifier == "some"))
#cors = ddply(allstate, .(SpeakerOptimality, WonkyWorldPrior), summarise, r=cor(PosteriorProbability, PosteriorProbability_empirical))
#cors = cors[order(cors[,c("r")],decreasing=T),]
#head(cors)

#mses = ddply(allstate, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=mse(PosteriorProbability, PosteriorProbability_empirical))
#mses = mses[order(mses[,c("mse")]),]
#head(mses)
# .46 correlation despite being shitty model
test = ddply(allstate, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=round(gof(PosteriorProbability, PosteriorProbability_empirical)["MSE",],3),r=gof(PosteriorProbability, PosteriorProbability_empirical)["r",],R2=gof(PosteriorProbability, PosteriorProbability_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)
allstate$Predicted = allstate$PosteriorProbability
allstate$Empirical = allstate$PosteriorProbability_empirical
allstate[,c("Item","WonkyWorldPrior","SpeakerOptimality","Predicted","Empirical")] %>%
  save(file="data/some-allprobs.RData")

probs_and_exps = rbind(some[,c("Item","WonkyWorldPrior","SpeakerOptimality","Predicted","Empirical")],allstate[,c("Item","WonkyWorldPrior","SpeakerOptimality","Predicted","Empirical")])
nrow(probs_and_exps)
test = ddply(probs_and_exps, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=gof(Predicted, Empirical)["MSE",],r=gof(Predicted, Empirical)["r",],R2=gof(Predicted, Empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)

toplot = probs_and_exps[probs_and_exps$WonkyWorldPrior == .7 &  probs_and_exps$SpeakerOptimality == 0,]
toplot$Type = rep(c("expectation","allprob"),each=90)
nrow(toplot)

ggplot(toplot, aes(x=Predicted,y=Empirical,color=Type)) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1)
ggsave(file="graphs/4_prits/optimal-uniform-prits.pdf")

ggplot(allstate, aes(x=PosteriorProbability, y=PosteriorProbability_empirical,color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(SpeakerOptimality~WonkyWorldPrior)
ggsave("graphs/4_prits/model-empirical-uniform-allstateprobs-prits.pdf",width=30,height=10)

# plot by-item diff in predicted and empirical expectation by confidence rating
confidence = read.table("../../../experiments/24_sinking-marbles-prior-prits/results/data/confidence.txt",sep="\t",quote="",header=T)
nrow(confidence)
head(confidence)
row.names(confidence) = confidence$Item

allstate$Confidence = confidence[as.character(allstate$Item),]$response
head(allstate)
allstate$PredictionDiff = allstate$PosteriorProbability - allstate$PosteriorProbability_empirical

ggplot(allstate, aes(y=PredictionDiff,x=Confidence)) +
  geom_point() +
  geom_smooth() +
  geom_hline(yintercept=0) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality) #+
#geom_text(aes(label=Item))
#ggsave(file="graphs/4_prits/model-empirical-diff-by-confidence-annotated.pdf",width=20,height=16)
ggsave(file="graphs/4_prits/model-empirical-allprobs-diff-by-confidence.pdf",width=10,height=8)

ggplot(allstate, aes(y=abs(PredictionDiff),x=Confidence)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality) #+
#geom_text(aes(label=Item))
#ggsave(file="graphs/4_prits/model-empirical-diff-by-confidence-annotated.pdf",width=20,height=16)
ggsave(file="graphs/4_prits/model-empirical-allprobs-absdiff-by-confidence.pdf",width=10,height=8)

ggplot(allstate, aes(x=PriorProbability, y=PosteriorProbability,color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(SpeakerOptimality~WonkyWorldPrior)
ggsave("graphs/4_prits/model-uniform-allstateprobs-prits.pdf",width=30,height=10)

# get empirical wonkiness posteriors
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/11_sinking-marbles-normal/results/data/r.RData")
head(r)
nrow(r)
r$Item = as.factor(paste(r$effect,r$object))

t = as.data.frame(prop.table(table(r$Item, r$quantifier, r$response), mar=c(1,2)))
head(t)
colnames(t) = c("Item","Quantifier","NormalMarbles","Proportion")
t[t$Var1=="ate the seeds birds",]
t$Quantifier = tolower(t$Quantifier)
tail(t)
t$Wonky = as.factor(ifelse(t$NormalMarbles == "yes","false","true"))
row.names(t) = paste(t$Item, t$Quantifier, t$Wonky)

wr$PosteriorProbability_empirical = t[paste(wr$Item, wr$Quantifier, wr$Wonky),]$Proportion
head(wr)
wonky = droplevels(subset(wr, Wonky == "true"))

head(wonky)
toplot = droplevels(subset(wonky,  WonkyWorldPrior == .5 & SpeakerOptimality == 0))

ggplot(toplot, aes(x=PriorExpectation, y=PosteriorProbability, color=Quantifier)) +
  geom_point() +
  geom_smooth()
ggsave(file="graphs/4_prits/wonkinessplot-prits.pdf",width=6)

test = ddply(wonky, .(SpeakerOptimality, WonkyWorldPrior), summarise, mse=gof(PosteriorProbability, PosteriorProbability_empirical)["MSE",],r=gof(PosteriorProbability, PosteriorProbability_empirical)["r",],R2=gof(PosteriorProbability, PosteriorProbability_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)

# plot by-item diff in predicted and empirical expectation by confidence rating
confidence = read.table("../../../experiments/24_sinking-marbles-prior-fourstep/results/data/confidence.txt",sep="\t",quote="",header=T)
nrow(confidence)
head(confidence)
row.names(confidence) = confidence$Item

wonky$Confidence = confidence[as.character(wonky$Item),]$response
head(wonky)
wonky$PredictionDiff = wonky$PosteriorProbability - wonky$PosteriorProbability_empirical

wonky_all = subset(wonky, Quantifier == "all")
wonky_none = subset(wonky, Quantifier == "none")
wonky_some = subset(wonky, Quantifier == "some")

ggplot(wonky_all, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness_all-prits.pdf", width=30,height=10)

ggplot(wonky_none, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness_none-prits.pdf", width=30,height=10)

ggplot(wonky_some, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) #+
  #facet_grid(QUD~Alternatives)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness_some-prits.pdf", width=30,height=10)

ggplot(wonky, aes(x=Confidence,y=abs(PredictionDiff),color=Quantifier)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-prits-abs-confidence.pdf", width=12,height=10)

ggplot(wonky, aes(x=Confidence,y=PredictionDiff,color=Quantifier)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-prits-confidence.pdf", width=12,height=10)

ggplot(wonky_all, aes(x=Confidence,y=PredictionDiff)) +
  geom_point() +
  geom_smooth() +
  geom_hline(yintercept=0) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-all-prits-confidence.pdf", width=12,height=10)

ggplot(wonky_all, aes(x=Confidence,y=abs(PredictionDiff))) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-all-prits-abs-confidence.pdf", width=12,height=10)

ggplot(wonky_some, aes(x=Confidence,y=PredictionDiff)) +
  geom_point() +
  geom_smooth() +
  geom_hline(yintercept=0) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-some-prits-confidence.pdf", width=12,height=10)

ggplot(wonky_some, aes(x=Confidence,y=abs(PredictionDiff))) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-some-prits-abs-confidence.pdf", width=12,height=10)

ggplot(wonky_none, aes(x=Confidence,y=PredictionDiff)) +
  geom_point() +
  geom_smooth() +
  geom_hline(yintercept=0) +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-none-prits-confidence.pdf", width=12,height=10)

ggplot(wonky_none, aes(x=Confidence,y=abs(PredictionDiff))) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~SpeakerOptimality)
ggsave("graphs/4_prits/model-empirical-uniform-wonkiness-none-prits-abs-confidence.pdf", width=12,height=10)

save(mp, file="data/mp-uniform-prits.RData")
save(wr, file="data/wr-uniform-prits.RData")


library(RcppDE)
library(data.table)
library(dHRUM)

NhrusBP <- nrow(br)

dny=c(30,60,90,120,150,180,210,240,270,300,330,355,364)
p_OBS=dny/365.25

# BP 96.68961 (1.736-2.430446)
RaBP = 96# odhad Martin Hanel
QmBP = c(26, 18, 14, 12, 10, 8.0, 7.0, 6.0, 4.5, 3.5, 2.5, 1.0, 0.5)
A=sum(SoilBP$Area)# plocha BP
RmBP = QmBP * (3600*24) / A #CHMU ZHU 4.42 v datech SoilBP 4.41

nHrus <- NhrusBP
Areas <- br$Plocha
IdsHrus <- br$ID
dhrusBP <- initdHruModel(nHrus,Areas,IdsHrus)
filname2 = "../dHRUM/Calibrations/Amalie/indata/BP_1960_01_01.txt"
setPTInputsToAlldHrusFromFile(dHRUM_ptr = dhrusBP, filname2)
calcPetToAllHrus(dHRUM_ptr = dhrusBP,50.1,"HAMON")
ParDFup1 = data.frame( B_SOIL = 2., C_MAX = 800, B_EVAP = 2,  KS = 0.4, KF = 0.7, ADIV = 0.9, CDIV = 0.1,
                       SDIV = 0.05, CAN_ST = 2., STEM_ST = 2., CSDIV = 0.8, TETR = 4, DDFA = 0.8, TMEL = 0.0,
                       RETCAP = 2 )

parsvec=as.numeric(ParDFup1[1,])
for(i in 1:(nHrus-1)){
  ParDFup1 <- rbind(ParDFup1,parsvec)
}
ParDFlow1 = data.frame( B_SOIL = 0.6, C_MAX = 10, B_EVAP = 0.6,  KS = 0.002, KF = 0.2, ADIV = 0.01, CDIV = 0.05,
                        SDIV = 0.01, CAN_ST = 0.1, STEM_ST = 0.1, CSDIV = 0.01, TETR = 0, DDFA = 0.08, TMEL = -10.0,
                        RETCAP = 1 )

parsvec=as.numeric(ParDFlow1[1,])
for(i in 1:(nHrus-1)){
  ParDFlow1 <- rbind(ParDFlow1,parsvec)
}
ParNams <- names(ParDFlow1)

nParIhru <- ncol(ParDFlow1)

mae = function(myPar){
  newmat <- as.data.frame(matrix(myPar,nrow = nHrus, ncol = nParIhru))
  names(newmat) <- ParNams
  setParsToDistdHRUM(dhrusBP, newmat, FALSE)
  # # for( i in 1:1000){
  calcHBInAlldHrus(dHRUM_ptr = dhrusBP)
  gatherHBdata(dHRUM_ptr = dhrusBP)
  # # }
  dta <- getOutput(dHRUM_ptr = dhrusBP)
  dF <-data.frame(dta$outDta)
  names(dF) <- dta$VarsNams
  simRM=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
  mymae =as.double(sum(abs(simRM - RmBP)))
  # # mymae=NA
  # if(is.na(mymae)) mymae = 9999
  # (return as.double(mymae))
}

itermaxW=2
decntr<-DEoptim.control(VTR = 0, strategy = 2, bs = FALSE, NP = 100,
                        itermax = itermaxW, CR = 0.25, F = 0.7, trace = TRUE,
                        initialpop = NULL, storepopfrom = itermaxW + 1,
                        storepopfreq = 1, p = 0.2, c = 0, reltol = sqrt(.Machine$double.eps),
                        steptol = itermaxW)

u=DEoptim( lower=as.numeric(as.matrix(ParDFlow1)),
           upper=as.numeric(as.matrix(ParDFup1)), fn=mae, control = decntr)

# u$optim$bestmem

ParBestVec <- as.numeric(u$optim$bestmem)
ParBestDF <- as.data.frame(matrix(ParBestVec,nrow = nHrus, ncol = nParIhru))
names(ParBestDF) <- ParNams
setParsToDistdHRUM(dhrusBP, ParBestDF, TRUE)
dta <- dHRUMrun(dHRUM_ptr = dhrusBP)

dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams
plot(dF$TOTR, type='l')
plot(dF$BASF, type='l')
plot(dF$DIRR, type='l')
plot(dF$SOIS, type='l')
plot(dF$GROS, type='l')
plot(dF$SNOW, type='l')
simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
plot(RmBP, simBest)

plot(p_OBS,RmBP, pch=19, ylim=range(c(RmBP,simBest)),
     main = paste0("Brejlský potok  - ",nHrus," HRU jednotek"),xlab="P(Qm)", ylab="Qm [mm/den]")
points(p_OBS,simBest,col="red",pch=19)
grid()
mm=mae(as.numeric(u$optim$bestmem))
mm

NhrusKL <- nrow(kl)

dny=c(30,60,90,120,150,180,210,240,270,300,330,355,364)
p_OBS=dny/365.25

RaKL = 96# odhad Martin Hanel
# ZHU Qa
Qa=10
# mdenni Q
QmKL = c(22, 15, 12, 10, 8.5, 6.5, 6.0, 5.0, 3.5, 3.0, 2.0, 1.0, 0.5)
A=sum(SoilKL$Area)# plocha KL 3.28 chmu plocha
RmKL = QmKL * (3600*24) / A #CHMU ZHU
Ra =Qa*3600*24*365/A

RmKL = QmKL * (3600*24) / A #CHMU ZHU 3.28 v datech SoilKL 3.24

filname2 = "../dHRUM/Calibrations/Amalie/indata/KL_1960_01_01_noDate.txt"
Areas <- kl$Plocha
IdsHrus <- kl$ID
dhrusKL <- initdHruModel(NhrusKL,Areas,IdsHrus)
PTdta = read.table(filname2)
prec=PTdta$V1
temp=PTdta$V2
setPTInputsToAlldHrus(dHRUM_ptr = dhrusKL, Prec = prec, Temp = temp, as.Date("1990/01/30"))
calcPetToAllHrus(dHRUM_ptr = dhrusKL,50.1,"HAMON")

ParDFup1 = data.frame( B_SOIL = 2., C_MAX = 800, B_EVAP = 2,  KS = 0.4, KF = 0.7, ADIV = 0.9, CDIV = 0.1,
                       SDIV = 0.05, CAN_ST = 2., STEM_ST = 2., CSDIV = 0.8, TETR = 4, DDFA = 0.8, TMEL = 0.0,
                       RETCAP = 2 )

parsvec=as.numeric(ParDFup1[1,])
for(i in 1:(nHrus-1)){
  ParDFup1 <- rbind(ParDFup1,parsvec)
}
# ParDFup1$C_MAX <- SoilBP$RVK
# ParDFup1$C_MAX <- SoilBP$VVK

ParDFlow1 = data.frame( B_SOIL = 0.6, C_MAX = 10, B_EVAP = 0.6,  KS = 0.002, KF = 0.2, ADIV = 0.01, CDIV = 0.05,
                        SDIV = 0.01, CAN_ST = 0.1, STEM_ST = 0.1, CSDIV = 0.01, TETR = 0, DDFA = 0.08, TMEL = -10.0,
                        RETCAP = 1 )

parsvec=as.numeric(ParDFlow1[1,])
for(i in 1:(nHrus-1)){
  ParDFlow1 <- rbind(ParDFlow1,parsvec)
}

ParNams <- names(ParDFlow1)

nParIhru <- ncol(ParDFlow1)
mae = function(myPar){
  newmat <- as.data.frame(matrix(myPar,nrow = nHrus, ncol = nParIhru))
  names(newmat) <- ParNams
  setParsToDistdHRUM(dhrusKL, newmat, FALSE)
  # # for( i in 1:1000){
  calcHBInAlldHrus(dHRUM_ptr = dhrusKL)
  gatherHBdata(dHRUM_ptr = dhrusKL)
  # # }
  dta <- getOutput(dHRUM_ptr = dhrusKL)
  dF <-data.frame(dta$outDta)
  names(dF) <- dta$VarsNams
  simRM=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
  mymae =as.double(sum(abs(simRM - RmKL)))
  # # mymae=NA
  # if(is.na(mymae)) mymae = 9999
  # (return as.double(mymae))
}

library(RcppDE)
itermaxW=2
decntr<-DEoptim.control(VTR = 0, strategy = 2, bs = FALSE, NP = 200,
                        itermax = itermaxW, CR = 0.25, F = 0.7, trace = TRUE,
                        initialpop = NULL, storepopfrom = itermaxW + 1,
                        storepopfreq = 1, p = 0.2, c = 0, reltol = sqrt(.Machine$double.eps),
                        steptol = itermaxW)

u=DEoptim( lower=as.numeric(as.matrix(ParDFlow1)),
           upper=as.numeric(as.matrix(ParDFup1)), fn=mae, control = decntr)

# u$optim$bestmem

ParBestVec <- as.numeric(u$optim$bestmem)
ParBestDF <- as.data.frame(matrix(ParBestVec,nrow = nHrus, ncol = nParIhru))
names(ParBestDF) <- ParNams

setParsToDistdHRUM(dhrusKL, ParBestDF, TRUE)
dta <- dHRUMrun(dHRUM_ptr = dhrusKL)

dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams
plot(dF$TOTR, type='l')
plot(dF$BASF, type='l')
plot(dF$DIRR, type='l')
plot(dF$SOIS, type='l')
plot(dF$GROS, type='l')
plot(dF$SNOW, type='l')
simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
plot(RmBP, simBest)
simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
plot(RmKL, simBest)

plot(p_OBS,RmKL, pch=19, ylim=range(c(RmKL,simBest)),
     main = paste0("Karlův Luh - ",NhrusKL," HRU jednotek"),xlab="P(Qm)", ylab="Qm [mm/den]")
points(p_OBS,simBest,col="red",pch=19)
grid()

mmKL=mae(as.numeric(u$optim$bestmem))
mmKL


set.seed(2141)
source("~/quasr/suff_stats_quasr.r")
source("~/trw/startup.r")

source("~/quasr/admm.r")

library(parallel)
library(magrittr)

library(huge)

d=20
n=100
#m1=2
#m2=1
m1=2
m2=2
#source("~/trw/startup.r")
setwd("~/quasr")
rep=10
#h=huge.generaor(n=n,d=d,graph="random",prob=.9)
h=huge.generator(n=2*rep*n,d=d,graph="scale-free")#, prob=2/d)
#h=huge.generator(n=2*rep*n,d=d,graph="hub",g=5)
h$data<-scale(h$data,center=T,scale=T)/8+0.5
h$data<- sign(h$data-.5)*(abs(h$data-.5))^.6
h$data<-scale(h$data,center=T,scale=T)/4+0.5

h$data[h$data>=1] = .95
h$data[h$data<=0] = .05

roc=rochuge=list()

hout=h$theta[row(h$theta)>=col(h$theta)+1]
spar=sum(hout)

lammax=1.5
lammax=max(abs(unlist(Kvec2(h$data,m1,m2))))*1.5
lamseq=exp(seq(from=log(.01*lammax),to=log(lammax),length.out=25))

out=mclapply(1:rep,function(r){
#for(r in 1:rep){

#print(paste("rep number ",r))
ncount=1
#dat=h$data[((r-1)*max(nlist)+1):(r*max(nlist)),]
dat=h$data[((r-1)*n+1):(r*n),]
test=h$data[rep*n + ((r-1)*n+1):(r*n) ,]
#test=h$data[(rep*max(nlist)+(r-1)*max(nlist)+1):(rep*max(nlist)+r*max(nlist)),]
ncount=ncount+n

#dat=matrix(runif(d*n),n,d)

g<-graph.full(d,directed=F)
edgelist<- get.edgelist(g)
#g=graph.adjacency(h$theta,mode="undirected")
#edgelist=get.edgelist(g)
# clust<- clusters(g)$membership
edge_mean <- edge.means(dat, edgelist, m2, cores)
node_mean <- node.means(dat , m1,cores)
edge_mean_test <- edge.means(test, edgelist, m2, cores)
node_mean_test <- node.means(test , m1,cores)
# #weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])
# edge_coef<- array(0,dim=c(m2,m2,dim(edgelist)[1]))
# node_coef<- matrix(0,d,m2)
# #lam=.1
# alpha_start=1
# sub=g
# tree_obj<-edge.Start(sub,burn.in=10)
# wt<-E(tree_obj)$weight
# lambda_seq<- lapply(1:dim(edgelist)[1],
#  	                    function(x){
# 	                    norm(edge_mean[,,x]-tcrossprod(node_mean[edgelist[x,1],],node_mean[edgelist[x,2],]),"F")
#    	                 })
# lambda_seq<-simplify2array(lambda_seq)
# seqlp<-round( seq(from=1,to=min(1e10,length(lambda_seq)),length.out=25) )
# lp<-(lambda_seq%>%sort(decreasing=T))[seqlp]
# #lp=seq(from=1e-1,to= 1.5,length.out=25)
# lp=lamseq
# lpout=lapply(lp,function(i){
# 	eind<- which(lambda_seq > i)
# 	elist_new<-edgelist[eind,,drop=F]
# 	sub<-subgraph.edges(g,eids=eind,delete.vertices=F)
# 	return(sub[])
# })

admm=admmSel(dat,lam=lamseq,m1=m1,m2=m2,rho=1,elist=edgelist)

Q = huge.npn(dat)
lshuge=seq(from=.001,to=1.5,length.out=100)
hugeout=huge(Q,lambda=lshuge,method="glasso")

# roc=lapply(lpout,function(x){
# 	a=1 - sum( ( x[row(x)>=col(x)+1]==0)  & (hout!=0) )/spar
# 	b=1- sum( (x[row(x)>=col(x)+1]!=0 ) & (hout==0 ) )/(d*(d-1)/2-spar)
# 	return(list(a,b))
# })

roc=lapply(admm,function(x){
	a=1 - sum( (apply(x$ze,3,function(i) 1*any(i!=0)) ==0 )  & (hout!=0) )/spar
	b=1- sum( (apply(x$ze,3,function(i) 1*any(i!=0)) !=0 ) & (hout==0 ) )/(d*(d-1)/2-spar)
	return(list(a,b))
})

rochuge=lapply(hugeout$path,function(x){
	a=1 - sum( (x[row(x)>=col(x)+1] ==0)  & (hout!=0) )/spar
	b=1- sum( (x[row(x)>=col(x)+1] !=0) & (hout==0 ) )/(d*(d-1)/2-spar)
	return(list(a,b))
})

roc=matrix(unlist(roc),nrow=2)
rochuge=matrix(unlist(rochuge),nrow=2)
#roc2=matrix(unlist(roc2),nrow=2)

return(list(roc,rochuge))
},mc.cores=rep)

rocplot1= Reduce("+",lapply(out,function(x)x[[1]]))/rep
rocplot2= Reduce("+",lapply(out,function(x)x[[2]]))/rep
#rocplot3= Reduce("+",lapply(out,function(x)x[[3]]))/rep

lapply(out,function(x){
	ind=which.max(apply(x[[1]],2,sum))
	ot= x[[1]][,ind]
	return(ot)
})

pdf("rocquasrtreenongauss2.pdf")

plot(rocplot1[1,],rocplot1[2,],type="l",lty=6,xlim=c(0,1),ylim=c(0,1),col="red",
	xlab="TN%",ylab="TP%")
points(rocplot2[1,],rocplot2[2,],type="l",lty=1,col="blue")
#points(rocplot3[1,],rocplot3[2,],type="l",lty=2)

legend("bottomleft",c("quasr","skeptic"),lty=c(6,1),col=c("red","blue"))
dev.off()