inch2Millimeter <- function(val, ...) {

  val_new <- val * 25.4
  val_new <- round(val_new, ...)

  return(val_new)
}

knots2mps <- function(val, ...) {

  val_new <- val * 0.514444
  val_new <- round(val_new, ...)

  return(val_new)
}

knots2ms <- function(val, ...) {

  kmperhour = val*1.8535
  val_new = kmperhour*(1000/3600)
  val_new <- round(val_new, ...)

  return(val_new)
}

retrieve_GSOD=function(usaf,WBAN="99999",start_year = NA, end_year = NA, dsn = ".")
{

  fls_gz <- sapply(start_year:end_year, function(year) {
    dlbase <- paste0(as.character(usaf), "-", WBAN, "-", year, ".op.gz")
    dlurl <- paste0("ftp://ftp.ncdc.noaa.gov/pub/data/gsod/",year, "/", dlbase)
    dlfile <- paste0(dsn, "/", dlbase)

    if (file.exists(dlfile)) {
      cat("File", dlfile, "already exists. Proceeding to next file... \n")
    }
    else {
      try(download.file(dlurl, dlfile), silent = FALSE)
    }
    return(dlfile)  })

}

is.leapyear=function(year){
  return(((year %% 4 == 0) & (year %% 100 != 0)) | (year %% 400 == 0))
}

findindexes = function(x,window=15) {
  j = window+x
  indexdayj = c(c(365-window):365,c(1:365),c(1:window))
  indexdayj[(j-window+1):(j+window-1)]
}

####################################################
#' firenze_peretola_gsod_1979_2015
#'
#' @description  Firenze Peretola 1979-2015 16700 GSOD daily weather data.
#'
#' @references   Data are obtained from GSOD NOAA site.  \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @format data.frame
#'
#' @source \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso crisci \email{a.crisci@@ibimet.cnr.it}
#'

####################################################
#' selected_italian_weather
#'
#' @description  Main features of a selected GSOD italian weather station.
#'
#' @references   Data are obtained from GSOD NOAA site.  \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @format data.frame
#'
#' @source \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso crisci \email{a.crisci@@ibimet.cnr.it}
#'

####################################################
#' geo_selected_italian_weather
#'
#' @description  Geographical information of a selected GSOD italian weather station.
#'
#' @references   Data are obtained from GSOD NOAA site. \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @format SpatialPointDataframe
#'
#' @source \url{https://data.noaa.gov/dataset/global-surface-summary-of-the-day-gsod}
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  meteo spatial
#'

####################################################
#' calculate_HWdays
#'
#' Calculate HWdays days and Critical ones adding some columns at data.frame.
#' Mean air temperature, mean relative humidity and extreme thermal values are required.
#'
#'
#' @param data data.frame Daily time series with colums' names: date(YYYY-MM-DD),tmed,tmax,tmin,rhum,vmed.
#' @param clim_array data.frame Name of location or the time series analized.
#' @param method character Method to assess critical and heatwave days. Default is "EuroHeat" and other are "TMAX","TMED","TMIN".
#' @param index character Biometerological index to calculate apparent temperature with ATI or UTCI. Default is "ATI" corresponding to the shaded version of ATI Steadman (2004).
#' @param wind logical  If TRUE the wind in biometeorological index are considered.
#' @param months numeric The month her HW days are calculated. Default are c(5:9) corresponding to May-Dec.
#' @param P_intesity numeric If one of the "TMAX","TMED","TMIN" methods was selected is the level of intensity in term of percentiles.Default are c(95),
#' @param  duration numeric Minimum spell of critical days to be considered for heatave definition. Default is 2.
#' @param time_reference numeric Temporal format of the referenced climatology: DAY (daily) or MON (monthly).Default is "DAY".
#' @return Return a list of data.frame respectively with monthly and daily values.
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords heat wave
#'
#' @export
#'
#'
#'
#'
#'
#'

calculate_HWdays=function(data,
                          clim_array,
                          method="EuroHeat",
                          index="ATI",
                          wind=T,
                          P_intesity=c(95),
                          duration=2,
                          time_reference="DAY"
) {

  if (class(data) != "data.frame") {stop(paste("data argument must be a daily data.frame object with column's names equal to:",
                                               "date( %Y-%m-%d ),tmed,tmax,tmin,rhum,vmed"))
  }

  if (time_reference=="DAY") {if  (nrow(clim_array)!=365) {stop(paste("Valid climatology is needed!")) } }
  if (time_reference=="MONTH") {if  (nrow(clim_array)!=12) {stop(paste("Valid climatology is needed!")) } }
  if (wind==T ) { if (length(grep("vmed",names(data)))==0)  {stop(paste("Wind data are needed!")) } }
  if (length(grep(P_intesity,names(clim_array)))<1) {stop(paste("Valid P_intesity Percentile intensity value is needed!"))}

  temp_mat=data;
  temp_mat$yday=strptime(as.Date(data$date), format = "%Y-%m-%d")$yday+1
  temp_mat$yday365=temp_mat$yday
  temp_mat$yday365[grep("-02-29",temp_mat$date)]=28
  temp_mat$yday365[which(temp_mat$yday==366)]=365
  temp_mat$CritDay=0
  temp_mat$HWDay=0
  temp_matTappmax=NA
  temp_mat$Tappmed=NA
  temp_mat$mese=as.numeric(format(as.Date(temp_mat$date),"%m"))

  if ( index=="ATI")
  {
    temp_mat$Tappmax=round(steadman_indoor(temp_mat$tmax,temp_mat$rhum),1)
    temp_mat$Tappmed=round(steadman_indoor(temp_mat$tmed,temp_mat$rhum),1)

    if ( wind == T)
    {  temp_mat$Tappmax=round(steadman_outdoor_shade(temp_mat$tmax,temp_mat$rhum,temp_mat$vmed),1)
        temp_mat$Tappmed=round(steadman_outdoor_shade(temp_mat$tmed,temp_mat$rhum,temp_mat$vmed),1)
    }
  }

  if ( index=="UTCI")

  {
    temp_mat$Tappmax=round(UTCI(temp_mat$tmax,temp_mat$rhum,rep(0.1,nrow(temp_mat)),temp_mat$tmax),1)
    temp_mat$Tappmed=round(UTCI(temp_mat$tmed,temp_mat$rhum,rep(0.1,nrow(temp_mat)),temp_mat$tmed),1)

    if ( wind == T)
    { temp_mat$Tappmax=round(UTCI(temp_mat$tmax,temp_mat$rhum,temp_mat$vmed,temp_mat$tmax),1)
    temp_mat$Tappmed=round(UTCI(temp_mat$tmed,temp_mat$rhum,temp_mat$vmed,temp_mat$tmed),1)
    }
  }

  #####################################################################################################################
  if ( time_reference == "DAY") {

    if (method == "EuroHeat"  & wind==T)

    {
      for (i in 1:nrow(temp_mat))
      { iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
      if (is.na(temp_mat$Tappmax[i])) {temp_mat$CritDay[i]=0;next}
      if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
      a=ifelse(temp_mat$Tappmax[i] >= clim_array$TmaxApp_V_P90_DAY[temp_mat$yday365[i]],1,0)
      b=ifelse(temp_mat$tmin[i] >= clim_array$Tmin_P90_DAY[temp_mat$yday365[i]] && temp_mat$Tappmax[i] >= clim_array$TmaxApp_V_P50_DAY[temp_mat$yday365[i]],1,0)
      if(a==1 || b==1) {temp_mat$CritDay[i]=1}
      if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "EuroHeat"  & wind==F)

    {
      for (i in 1:nrow(temp_mat))
      { iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
      if (is.na(temp_mat$Tappmax[i])) {temp_mat$CritDay[i]=0;next}
      if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
      a=ifelse(temp_mat$Tappmax[i] >= clim_array$TmaxApp_P90_DAY[temp_mat$yday365[i]],1,0)
      b=ifelse(temp_mat$tmin[i] >= clim_array$Tmin_P90_DAY[temp_mat$yday365[i]] && temp_mat$Tappmax[i] >= clim_array$TmaxApp_P50_DAY[temp_mat$yday365[i]],1,0)
      if(a==1 || b==1) {temp_mat$CritDay[i]=1}
      if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "TMED" )

    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmed[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmed[i] >= clim_array[temp_mat$yday365[i],paste0("Tmax_P",P_intesity,"_DAY")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "TMAX" )

    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmax[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmax[i] >= clim_array[temp_mat$yday365[i],paste0("Tmax_P",P_intesity,"_DAY")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }
    if (method == "TMIN" )

    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmin[i] >= clim_array[temp_mat$yday365[i],paste0("Tmin_P",P_intesity,"_DAY")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    ########################################################################################################################

  } # day loop
  ########################################################################################################################

  if ( time_reference == "MON") {

    if (method == "EuroHeat"  & wind==T)

    {
      for (i in 1:nrow(temp_mat))
      { iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
      if (is.na(temp_mat$Tappmax[i])) {temp_mat$CritDay[i]=0;next}
      if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
      a=ifelse(temp_mat$Tappmax[i] >= clim_array$TmaxApp_V_P90_MON[temp_mat$mese[i]],1,0)
      b=ifelse(temp_mat$tmin[i] >= clim_array$Tmin_P90_MON[temp_mat$mese[i]] && temp_mat$Tappmax[i] >= clim_array$TmaxApp_V_P50_MON[temp_mat$mese[i]],1,0)
      if(a==1 || b==1) {temp_mat$CritDay[i]=1}
      if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "EuroHeat"  & wind==F)

    {
      for (i in 1:nrow(temp_mat))
      { iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
      if (is.na(temp_mat$Tappmax[i])) {temp_mat$CritDay[i]=0;next}
      if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
      a=ifelse(temp_mat$Tappmax[i] >= clim_array$TmaxApp_P90_MON[temp_mat$mese[i]],1,0)
      b=ifelse(temp_mat$tmin[i] >= clim_array$Tmin_P90_MON[temp_mat$mese[i]] && temp_mat$Tappmax[i] >= clim_array$TmaxApp_P50_MON[temp_mat$mese[i]],1,0)
      if(a==1 || b==1) {temp_mat$CritDay[i]=1}
      if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "TMED" )

    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmed[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmed[i] >= clim_array[temp_mat$mese[i],paste0("Tmax_P",P_intesity,"_MON")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "TMAX" )

    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmax[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmax[i] >= clim_array[temp_mat$mese[i],paste0("Tmax_P",P_intesity,"_MON")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }

    if (method == "TMIN" )
    {
      for (i in 1:nrow(temp_mat))
      {
        iHW=ifelse(i-(duration-1)>0,i-(duration-1),1)
        if (is.na(temp_mat$tmin[i])) {temp_mat$CritDay[i]=0;next}
        a=ifelse(temp_mat$tmin[i] >= clim_array[temp_mat$mese[i],paste0("Tmin_P",P_intesity,"_MON")],1,0)
        if( a==1)  {temp_mat$CritDay[i]=1}
        if (sum(temp_mat$CritDay[iHW:i]) == duration) {temp_mat$HWDay[i]=1}
      }
    }
  }
  # MON Loop

  #######################################################################################################################
  res_HW=temp_mat[c("date","mese","yday365","CritDay","HWDay")]

  if ( method == "EuroHeat") {res_HW=temp_mat[c("date","mese","yday365","CritDay","HWDay","Tappmax","Tappmed")]}

  return(res_HW)

}

#' create_clim_param_HW
#'
#' Calculate the parameters to assess heat-wave daily status from a climatic time series monthly.
#' Mean air temperature , mean relative humidity and extreme thermal values are required.
#' Parameters
#'
#'
#' @param data data.frame Daily time series with colums' names: date(YYYY-MM-DD),tmed,tmax,tmin,rhum,vmed.
#' @param name character Name of location or ID of time series.
#' @param index character Biometerological index to calculate apparent temperature.
#' @param iniclim character Initial year of climatological reference time period, Default is "1981".
#' @param yfinclim character Final year of climatological reference time period, Default is "2010".
#' @param PT numeric  Three levels of percentile used as thresholds for intensity. Default are c(90, 95, 98).
#' @param window_days numeric Half Day span to calculate daily climatology. Default is 15.
#' @param save_clim logical If True save file daily and montly in RDS and CSV format. Default is F.
#' @return Return a list of data.frame respectively with monthly and daily values.
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords heat wave
#'
#' @export
#'
#'
#'
#'

create_clim_param_HW=function(data,
                              name,
                              index="ATI",
                              yiniclim="1981",
                              yfinclim="2010",
                              PT=c(90,95,98),
                              window_days=15,
                              save_clim=F) {

  if (class(data) != "data.frame") {stop(paste("data argument must be a daily data.frame object with column's names equal to:",
                                               "date( %Y-%m-%d ),tmed,tmax,tmin,rhum,vmed"))
  }
  if (length(PT) != 3 ) {stop(paste("Please  three values of PT parameter are required!"))}

  dates=seq(as.Date(paste0(yiniclim,"-01-01")),as.Date(paste0(yfinclim,"-12-31")),1)
  indexday=which(as.character(data$date) %in% as.character(dates) ==T)
  anni=unique(as.numeric(format(as.Date(data$date),"%Y")))
  if (length(which(anni %in% yiniclim:yfinclim==T)) < length(yiniclim:yfinclim) ) {stop(paste("Please refine year climate range!"))}

  ##########################################################################################################################################################################

  PTD=PT/100
  temp_mat=data;
  temp_mat$yday=strptime(as.Date(data$date), format = "%Y-%m-%d")$yday+1
  temp_mat$yday365=temp_mat$yday
  temp_mat$yday365[grep("-02-29",temp_mat$date)]=28
  temp_mat$yday365[which(temp_mat$yday==366)]=365

  ##########################################################################################################################################################################

  temp_mat$Tappmax=NA
  temp_mat$Tappmed=NA
  temp_mat$Tappmax_v=NA
  temp_mat$Tappmed_v=NA

  if ( index=="ATI")
  {
    temp_mat$Tappmax=round(steadman_indoor(temp_mat$tmax,temp_mat$rhum),1)
    temp_mat$Tappmed=round(steadman_indoor(temp_mat$tmed,temp_mat$rhum),1)

    if ( length(grep("vmed",names(temp_mat)))>0)
    {  temp_mat$Tappmax_v=round(steadman_outdoor_shade(temp_mat$tmax,temp_mat$rhum,temp_mat$vmed),1)
    temp_mat$Tappmed_v=round(steadman_outdoor_shade(temp_mat$tmed,temp_mat$rhum,temp_mat$vmed),1)
    }
  }

  if ( index=="UTCI")
  {
    temp_mat$Tappmax=round(UTCI(temp_mat$tmax,temp_mat$rhum,rep(0.1,nrow(temp_mat)),temp_mat$tmax),1)
    temp_mat$Tappmed=round(UTCI(temp_mat$tmed,temp_mat$rhum,rep(0.1,nrow(temp_mat)),temp_mat$tmed),1)

    if ( length(grep("vmed",names(temp_mat)))>0)
    { temp_mat$Tappmax_v=round(UTCI(temp_mat$tmax,temp_mat$rhum,temp_mat$vmed,temp_mat$tmax),1)
      temp_mat$Tappmed_v=round(UTCI(temp_mat$tmed,temp_mat$rhum,temp_mat$vmed,temp_mat$tmed),1)
    }
  }

  ##########################################################################################################################################################################

  temp_mat_climdata=temp_mat[indexday,]
  temp_mat_climdata$mese=as.numeric(format(as.Date(temp_mat_climdata$date),"%m"))

  ##########################################################################################################################################################################

  temp_clim=data.frame(Tmax_P50=NA,Tmax_PT1=NA,Tmax_PT2=NA,Tmax_PT3=NA,
                       TmaxApp_P50=NA,TmaxApp_PT1=NA,TmaxApp_PT2=NA,TmaxApp_PT3=NA,
                       TmaxApp_V_P50=NA, TmaxApp_V_PT1=NA,TmaxApp_V_PT2=NA,TmaxApp_V_PT3=NA,
                       Tmin_P50=NA,Tmin_PT1=NA,Tmin_PT2=NA,Tmin_PT3=NA,
                       Tmed_P50=NA,Tmed_PT1=NA,Tmed_PT2=NA,Tmed_PT3=NA)

  temp_clim_daily=cbind(id=1:365,temp_clim)
  temp_clim_monthly=cbind(id=1:12,temp_clim)

  #######################################################################################################################################################à

  for ( i in 1:365) {

    temp_clim_daily$Tmax_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmax,na.rm=T))
    temp_clim_daily$Tmax_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmax,PTD[1],na.rm=T)[1])
    temp_clim_daily$Tmax_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmax,PTD[2],na.rm=T)[1])
    temp_clim_daily$Tmax_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmax,PTD[3],na.rm=T)[1])

    temp_clim_daily$TmaxApp_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax,na.rm=T))
    temp_clim_daily$TmaxApp_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax,PTD[1],na.rm=T)[1])
    temp_clim_daily$TmaxApp_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax,PTD[2],na.rm=T)[1])
    temp_clim_daily$TmaxApp_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax,PTD[3],na.rm=T)[1])

    temp_clim_daily$TmaxApp_V_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax_v,na.rm=T))
    temp_clim_daily$TmaxApp_V_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax_v,PTD[1],na.rm=T)[1])
    temp_clim_daily$TmaxApp_V_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax_v,PTD[2],na.rm=T)[1])
    temp_clim_daily$TmaxApp_V_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$Tappmax_v,PTD[3],na.rm=T)[1])

    temp_clim_daily$Tmed_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmed,na.rm=T))
    temp_clim_daily$Tmed_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmed,PTD[1],na.rm=T)[1])
    temp_clim_daily$Tmed_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmed,PTD[2],na.rm=T)[1])
    temp_clim_daily$Tmed_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmed,PTD[3],na.rm=T)[1])

    temp_clim_daily$Tmin_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmin,na.rm=T))
    temp_clim_daily$Tmin_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmin,PTD[1],na.rm=T)[1])
    temp_clim_daily$Tmin_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmin,PTD[2],na.rm=T)[1])
    temp_clim_daily$Tmin_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$yday365 %in% findindexes(i,window_days))==TRUE),]$tmin,PTD[3],na.rm=T)[1])

  }

  for ( i in 1:12) {

    temp_clim_monthly$Tmax_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,na.rm=T))
    temp_clim_monthly$Tmax_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,PTD[1],na.rm=T)[1])
    temp_clim_monthly$Tmax_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,PTD[2],na.rm=T)[1])
    temp_clim_monthly$Tmax_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,PTD[3],na.rm=T)[1])

    temp_clim_monthly$TmaxApp_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax,na.rm=T))
    temp_clim_monthly$TmaxApp_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax,PTD[1],na.rm=T)[1])
    temp_clim_monthly$TmaxApp_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,PTD[2],na.rm=T)[1])
    temp_clim_monthly$TmaxApp_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmax,PTD[3],na.rm=T)[1])

    temp_clim_monthly$TmaxApp_V_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax_v,na.rm=T))
    temp_clim_monthly$TmaxApp_V_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax_v,PTD[1],na.rm=T)[1])
    temp_clim_monthly$TmaxApp_V_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax_v,PTD[2],na.rm=T)[1])
    temp_clim_monthly$TmaxApp_V_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$Tappmax_v,PTD[3],na.rm=T)[1])

    temp_clim_monthly$Tmed_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmed,na.rm=T))
    temp_clim_monthly$Tmed_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmed,PTD[1],na.rm=T)[1])
    temp_clim_monthly$Tmed_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmed,PTD[2],na.rm=T)[1])
    temp_clim_monthly$Tmed_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmed,PTD[3],na.rm=T)[1])

    temp_clim_monthly$Tmin_P50[i]=as.numeric(median(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmin,na.rm=T))
    temp_clim_monthly$Tmin_PT1[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmin,PTD[1],na.rm=T)[1])
    temp_clim_monthly$Tmin_PT2[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmin,PTD[2],na.rm=T)[1])
    temp_clim_monthly$Tmin_PT3[i]=as.numeric(quantile(temp_mat_climdata[which((temp_mat_climdata$mese == i)),]$tmin,PTD[3],na.rm=T)[1])

  }

  #######################################################################################################################################################################

  names(temp_clim_daily)=gsub("T1",PT[1],names(temp_clim_daily))
  names(temp_clim_daily)=gsub("T2",PT[2],names(temp_clim_daily))
  names(temp_clim_daily)=gsub("T3",PT[3],names(temp_clim_daily))
  names(temp_clim_monthly)=gsub("T1",PT[1],names(temp_clim_monthly))
  names(temp_clim_monthly)=gsub("T2",PT[2],names(temp_clim_monthly))
  names(temp_clim_monthly)=gsub("T3",PT[3],names(temp_clim_monthly))

  names(temp_clim_daily)=paste0(names(temp_clim_daily),"_DAY")
  names(temp_clim_monthly)=paste0(names(temp_clim_monthly),"_MON")

  if ( save_clim == T) {
    saveRDS(temp_clim_daily,paste0(name,"_DAYCLIM.rds"))
    write.csv(temp_clim_daily,paste0(name,"_DAYCLIM.csv"))
    saveRDS(temp_clim_monthly,paste0(name,"_MONCLIM.rds"))
    write.csv(temp_clim_monthly,paste0(name,"_MONCLIM.csv"))

  }

  return(list(MONCLIM=temp_clim_monthly,
              DAYCLIM=temp_clim_daily))
}

#############################################################################################################################################
#' manage_GSOD
#'
#' Download and build a specific data.frame for heatwave analisys from a GSOD NOAA repository station based on its unique USAF code.
#'
#'
#' @param id character USAF code of weather station.
#' @param name character Name of location or ID of time series.
#' @param ini_year character Initial year of data time period, Default is "1979".
#' @param last_year character Final year of climatological reference time period, Default is "2016".
#' @param save_files logical If True save GSOD data file in RDS and CSV format. Default is F.
#' @return  Return  data.frame ready to use for heat-wave analitics.
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords GSOD
#' @importFrom GSODTools gzGsodStations
#' @importFrom lubridate ymd
#' @export
#'
#'
#'

manage_GSOD=function(id,name,ini_year = 1979, last_year = 2015, missing=NA,save_files=T) {
  retrieveGSOD(usaf=id,start_year = ini_year, end_year = last_year)
  temp_daily<- gzGsodStations(x,start_year = ini_year, end_year = last_year)
  temp_daily$Date=as.Date(ymd(temp_daily$YEARMODA))
  temp_daily$YEARMODA=NULL
  temp_daily$tmed <- toCelsius(temp_daily$TEMP, digits = 1)
  temp_daily$tmax <- toCelsius(temp_daily$MAX, digits = 1)
  temp_daily$tmin <- toCelsius(temp_daily$MIN, digits = 1)
  temp_daily$prec <-inch2Millimeter(temp_daily$PRCP, digits = 1)
  temp_daily$DEWP <- toCelsius(temp_daily$DEWP, digits = 1)
  temp_daily$rhum <- 100*(exp((17.625*temp_daily$DEWP)/(243.04+temp_daily$DEWP))/exp((17.625*temp_daily$tmed)/(243.04+temp_daily$tmed)))
  temp_daily$slp=temp_daily$SLP
  temp_daily$prec[which(temp_daily$PRCPFLAG=="I")]=missing
  temp_daily$vmed=knots2ms(temp_daily$WDSP,1)
  temp_daily$vmax=knots2ms(temp_daily$MXSPD,1)
  temp_daily=temp_daily[c("date","tmed","tmax","tmin","rhum","DEWP","vmed","vmax","prec","slp")]
  if ( save_files == T) {
                         saveRDS(temp_daily,paste0(name,"_DAYCLIM.rds"))
                         write.csv(temp_daily,paste0(name,"_DAYCLIM.csv"))

                        }
  return(temp_daily)
}


subroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var,
		beta,iv,liv,lv,v,iwork,work)
integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*)
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work(*)
double precision beta(p+1)
#work should be nef*(p+d+8) + 2*p + n +8
integer qrank
	call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta,
#	xin,win,sqwin,sqwini,
	work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2),
#	xqr,qrank,qpivot,qraux,
	work(nef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p),
	iv,liv,lv,v,
	work(nef*(p+d+4)+4+2*p) )
return
end

subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	work)
integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1)
integer iv(liv),liv,lv
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
	xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1),
	qraux(p+1),v(lv),
	work(*)
#work should have size n +4*(nef+1)
call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	work(1),work(nef+2),work(2*nef+3),work(3*nef+4))
return
end

subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	levout,sout,yin,work)
integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1)
integer iv(liv),liv,lv
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
	xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1),
	qraux(p+1),v(lv),
	levout(nef+1), sout(nef+1),yin(nef+1),work(*)
#work should be length n
double precision junk, onedm7
integer job, info
logical setLf, ifvar
job=110;info=1
ifvar=.true.
onedm7=1d-7
if(nit<=1){
	call pck(n,nef,match,w,win)
	do i=1,nef{
		if(win(i)>0d0){
			sqwin(i)=dsqrt(win(i))
			sqwini(i)=1d0/sqwin(i)
		}
		else{
			sqwin(i)=1d-5
			sqwini(i)=1d5
			}
		}
	do i=1,n{
		k=match(i)
		if(k<=nef){
			do j=1,d
				xin(k,j)=x(i,j)
			for(j=d+1;j<=p;j=j+1)
				xqr(k,j+1)=x(i,j)

			}
		}
	do i=1,nef{
		xqr(i,1)=sqwin(i)
		do j=1,d
			xqr(i,j+1)=xin(i,j)*sqwin(i)
		for(j=d+2;j<=p+1;j=j+1)
				xqr(i,j)=xqr(i,j)*sqwin(i)
		}
	for(j=1;j<=p+1;j=j+1)
		qpivot(j)=j
	call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7)
	setLf = (nit==1)
	call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setLf)
	v(2)=span/5d0
	}
do i=1,n
	work(i)=y(i)*w(i)
call pck(n,nef,match,work,yin)
	do i=1,nef
		yin(i)=yin(i)*sqwini(i)*sqwini(i)

if(nit<=1)call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v)
	else call lowesr(yin,iv,liv,lv,v)
call lowese(iv,liv,lv,v,nef,xin,sout)

#now remove the parametric piece
do i=1,nef
	sout(i)=sout(i)*sqwin(i)
call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta,
		sout,work(1),job,info)
#####dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
do i=1,nef
	sout(i)=sout(i)*sqwini(i)

#now clean up

if(nit<=1){
#get rid of the parametric component of the leverage
	job=10000
	for(j=1;j<=p+1;j=j+1){
		do i=1,nef
			work(i)=0d0
		work(j)=1d0
		call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk,
			junk,junk,job,info)
		do i=1,nef
			levout(i)=levout(i) - var(i)**2
		}
	dof=0d0
	do i=1,nef {
		if(win(i)>0d0) {
			levout(i)=levout(i)/win(i)
			}
		else {levout(i)=0d0}
		}
	do i=1,nef {dof=dof+levout(i)*win(i)}
	call unpck(n,nef,match,levout,var)
	for(j=1;j<=p+1;j=j+1){work(j)=beta(j)}
	for(j=1;j<=p+1;j=j+1){beta(qpivot(j))=work(j)}
	}
call unpck(n,nef,match,sout,s)
return
end
subroutine pck(n,p,match,x,xbar)
integer match(n),p,n
double precision x(n),xbar(n)
	do i=1,p
		xbar(i)=0d0
	do i=1,n
		xbar(match(i))=xbar(match(i))+x(i)
return
end

subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work)
integer match(n),p,n
double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n)
call pck(n,p,match,w,wbar)
do i=1,n
	xbar(match(i))=x(i)
do i=1,n
	work(i)=y(i)*w(i)
call pck(n,p,match,work,ybar)
	do i=1,p{
		if(wbar(i)>0d0)
			ybar(i)=ybar(i)/wbar(i)
		else ybar(i)=0d0

	}
return
end
subroutine unpck(n,p,match,xbar,x)
integer match(n),p,n
double precision x(n),xbar(p+1)
if(p<n)xbar(p+1)=0d0
do i = 1,n
	x(i)=xbar(match(i))
return
end
double precision function dwrss(n,y,eta,w)
integer n
double precision y(n),w(n),wtot,wsum,work,eta(n)
wsum=0d0
wtot=0d0
do i = 1,n{
	work=y(i)-eta(i)
	wsum=wsum+w(i)*work*work
	wtot=wtot+w(i)
}
if (wtot > 0d0) {dwrss=wsum/wtot} else {dwrss=0d0}
return
end


score <- function(input) {
    return((subroutine0(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.0351) - (input[1])) ^ (2.0)) + (((95.0) - (input[2])) ^ (2.0))) + (((2.68) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.4161) - (input[5])) ^ (2.0))) + (((7.853) - (input[6])) ^ (2.0))) + (((33.2) - (input[7])) ^ (2.0))) + (((5.118) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((224.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((392.78) - (input[12])) ^ (2.0))) + (((3.81) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine0 <- function(input) {
    return((subroutine1(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((18.0846) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.679) - (input[5])) ^ (2.0))) + (((6.434) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.8347) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((27.25) - (input[12])) ^ (2.0))) + (((29.05) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine1 <- function(input) {
    return((subroutine2(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.98843) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.813) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((4.0952) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((394.54) - (input[12])) ^ (2.0))) + (((19.88) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine2 <- function(input) {
    return((subroutine3(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((10.8342) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.679) - (input[5])) ^ (2.0))) + (((6.782) - (input[6])) ^ (2.0))) + (((90.8) - (input[7])) ^ (2.0))) + (((1.8195) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((21.57) - (input[12])) ^ (2.0))) + (((25.79) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine3 <- function(input) {
    return((subroutine4(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.22358) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.605) - (input[5])) ^ (2.0))) + (((6.943) - (input[6])) ^ (2.0))) + (((97.4) - (input[7])) ^ (2.0))) + (((1.8773) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((363.43) - (input[12])) ^ (2.0))) + (((4.59) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine4 <- function(input) {
    return((subroutine5(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((6.53876) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.631) - (input[5])) ^ (2.0))) + (((7.016) - (input[6])) ^ (2.0))) + (((97.5) - (input[7])) ^ (2.0))) + (((1.2024) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((392.05) - (input[12])) ^ (2.0))) + (((2.96) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine5 <- function(input) {
    return((subroutine6(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.18337) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((27.74) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.609) - (input[5])) ^ (2.0))) + (((5.414) - (input[6])) ^ (2.0))) + (((98.3) - (input[7])) ^ (2.0))) + (((1.7554) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((711.0) - (input[10])) ^ (2.0))) + (((20.1) - (input[11])) ^ (2.0))) + (((344.05) - (input[12])) ^ (2.0))) + (((23.97) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine6 <- function(input) {
    return((subroutine7(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.03578) - (input[1])) ^ (2.0)) + (((20.0) - (input[2])) ^ (2.0))) + (((3.33) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.4429) - (input[5])) ^ (2.0))) + (((7.82) - (input[6])) ^ (2.0))) + (((64.5) - (input[7])) ^ (2.0))) + (((4.6947) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((216.0) - (input[10])) ^ (2.0))) + (((14.9) - (input[11])) ^ (2.0))) + (((387.31) - (input[12])) ^ (2.0))) + (((3.76) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine7 <- function(input) {
    return((subroutine8(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((45.7461) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((4.519) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.6582) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((88.27) - (input[12])) ^ (2.0))) + (((36.98) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine8 <- function(input) {
    return((subroutine9(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((2.01019) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.605) - (input[5])) ^ (2.0))) + (((7.929) - (input[6])) ^ (2.0))) + (((96.2) - (input[7])) ^ (2.0))) + (((2.0459) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((369.3) - (input[12])) ^ (2.0))) + (((3.7) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine9 <- function(input) {
    return((subroutine10(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((7.67202) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.747) - (input[6])) ^ (2.0))) + (((98.9) - (input[7])) ^ (2.0))) + (((1.6334) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((393.1) - (input[12])) ^ (2.0))) + (((19.92) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine10 <- function(input) {
    return((subroutine11(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.46336) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.605) - (input[5])) ^ (2.0))) + (((7.489) - (input[6])) ^ (2.0))) + (((90.8) - (input[7])) ^ (2.0))) + (((1.9709) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((374.43) - (input[12])) ^ (2.0))) + (((1.73) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine11 <- function(input) {
    return((subroutine12(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.61282) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((6.096) - (input[6])) ^ (2.0))) + (((96.9) - (input[7])) ^ (2.0))) + (((3.7598) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((248.31) - (input[12])) ^ (2.0))) + (((20.34) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine12 <- function(input) {
    return((subroutine13(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((67.9208) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.683) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.4254) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((384.97) - (input[12])) ^ (2.0))) + (((22.98) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine13 <- function(input) {
    return((subroutine14(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((22.5971) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.7) - (input[5])) ^ (2.0))) + (((5.0) - (input[6])) ^ (2.0))) + (((89.5) - (input[7])) ^ (2.0))) + (((1.5184) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((31.99) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine14 <- function(input) {
    return((subroutine15(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((14.2362) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((6.343) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.5741) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((20.32) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine15 <- function(input) {
    return((subroutine16(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.25387) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((6.91) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.448) - (input[5])) ^ (2.0))) + (((5.399) - (input[6])) ^ (2.0))) + (((95.3) - (input[7])) ^ (2.0))) + (((5.87) - (input[8])) ^ (2.0))) + (((3.0) - (input[9])) ^ (2.0))) + (((233.0) - (input[10])) ^ (2.0))) + (((17.9) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((30.81) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine16 <- function(input) {
    return((subroutine17(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.01501) - (input[1])) ^ (2.0)) + (((90.0) - (input[2])) ^ (2.0))) + (((1.21) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.401) - (input[5])) ^ (2.0))) + (((7.923) - (input[6])) ^ (2.0))) + (((24.8) - (input[7])) ^ (2.0))) + (((5.885) - (input[8])) ^ (2.0))) + (((1.0) - (input[9])) ^ (2.0))) + (((198.0) - (input[10])) ^ (2.0))) + (((13.6) - (input[11])) ^ (2.0))) + (((395.52) - (input[12])) ^ (2.0))) + (((3.16) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine17 <- function(input) {
    return((subroutine18(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((9.91655) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.852) - (input[6])) ^ (2.0))) + (((77.8) - (input[7])) ^ (2.0))) + (((1.5004) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((338.16) - (input[12])) ^ (2.0))) + (((29.97) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine18 <- function(input) {
    return((subroutine19(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.31533) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((6.2) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.504) - (input[5])) ^ (2.0))) + (((8.266) - (input[6])) ^ (2.0))) + (((78.3) - (input[7])) ^ (2.0))) + (((2.8944) - (input[8])) ^ (2.0))) + (((8.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((17.4) - (input[11])) ^ (2.0))) + (((385.05) - (input[12])) ^ (2.0))) + (((4.14) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine19 <- function(input) {
    return((subroutine20(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.83377) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.605) - (input[5])) ^ (2.0))) + (((7.802) - (input[6])) ^ (2.0))) + (((98.2) - (input[7])) ^ (2.0))) + (((2.0407) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((389.61) - (input[12])) ^ (2.0))) + (((1.92) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine20 <- function(input) {
    return((subroutine21(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.38799) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.95) - (input[6])) ^ (2.0))) + (((82.0) - (input[7])) ^ (2.0))) + (((3.99) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((232.6) - (input[12])) ^ (2.0))) + (((27.71) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine21 <- function(input) {
    return((subroutine22(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.01538) - (input[1])) ^ (2.0)) + (((90.0) - (input[2])) ^ (2.0))) + (((3.75) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.394) - (input[5])) ^ (2.0))) + (((7.454) - (input[6])) ^ (2.0))) + (((34.2) - (input[7])) ^ (2.0))) + (((6.3361) - (input[8])) ^ (2.0))) + (((3.0) - (input[9])) ^ (2.0))) + (((244.0) - (input[10])) ^ (2.0))) + (((15.9) - (input[11])) ^ (2.0))) + (((386.34) - (input[12])) ^ (2.0))) + (((3.11) - (input[13])) ^ (2.0))))) * (0.7500000000002167)))
}
subroutine22 <- function(input) {
    return((subroutine23(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.01381) - (input[1])) ^ (2.0)) + (((80.0) - (input[2])) ^ (2.0))) + (((0.46) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.422) - (input[5])) ^ (2.0))) + (((7.875) - (input[6])) ^ (2.0))) + (((32.0) - (input[7])) ^ (2.0))) + (((5.6484) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((255.0) - (input[10])) ^ (2.0))) + (((14.4) - (input[11])) ^ (2.0))) + (((394.23) - (input[12])) ^ (2.0))) + (((2.97) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine23 <- function(input) {
    return((subroutine24(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((2.77974) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.871) - (input[5])) ^ (2.0))) + (((4.903) - (input[6])) ^ (2.0))) + (((97.8) - (input[7])) ^ (2.0))) + (((1.3459) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((29.29) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine24 <- function(input) {
    return((subroutine25(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((9.2323) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.631) - (input[5])) ^ (2.0))) + (((6.216) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.1691) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((366.15) - (input[12])) ^ (2.0))) + (((9.53) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine25 <- function(input) {
    return((subroutine26(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.06129) - (input[1])) ^ (2.0)) + (((20.0) - (input[2])) ^ (2.0))) + (((3.33) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.4429) - (input[5])) ^ (2.0))) + (((7.645) - (input[6])) ^ (2.0))) + (((49.7) - (input[7])) ^ (2.0))) + (((5.2119) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((216.0) - (input[10])) ^ (2.0))) + (((14.9) - (input[11])) ^ (2.0))) + (((377.07) - (input[12])) ^ (2.0))) + (((3.01) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine26 <- function(input) {
    return((subroutine27(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.25179) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.57) - (input[6])) ^ (2.0))) + (((98.1) - (input[7])) ^ (2.0))) + (((3.7979) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((376.57) - (input[12])) ^ (2.0))) + (((21.02) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine27 <- function(input) {
    return((subroutine28(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((4.89822) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.631) - (input[5])) ^ (2.0))) + (((4.97) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.3325) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((375.52) - (input[12])) ^ (2.0))) + (((3.26) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine28 <- function(input) {
    return((subroutine29(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.13081) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.713) - (input[6])) ^ (2.0))) + (((94.1) - (input[7])) ^ (2.0))) + (((4.233) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((360.17) - (input[12])) ^ (2.0))) + (((22.6) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine29 <- function(input) {
    return((subroutine30(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.33147) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((6.2) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.507) - (input[5])) ^ (2.0))) + (((8.247) - (input[6])) ^ (2.0))) + (((70.4) - (input[7])) ^ (2.0))) + (((3.6519) - (input[8])) ^ (2.0))) + (((8.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((17.4) - (input[11])) ^ (2.0))) + (((378.95) - (input[12])) ^ (2.0))) + (((3.95) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine30 <- function(input) {
    return((subroutine31(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.52693) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((6.2) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.504) - (input[5])) ^ (2.0))) + (((8.725) - (input[6])) ^ (2.0))) + (((83.0) - (input[7])) ^ (2.0))) + (((2.8944) - (input[8])) ^ (2.0))) + (((8.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((17.4) - (input[11])) ^ (2.0))) + (((382.0) - (input[12])) ^ (2.0))) + (((4.63) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine31 <- function(input) {
    return((subroutine32(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.35472) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((6.072) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((4.175) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((376.73) - (input[12])) ^ (2.0))) + (((13.04) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine32 <- function(input) {
    return((subroutine33(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.57834) - (input[1])) ^ (2.0)) + (((20.0) - (input[2])) ^ (2.0))) + (((3.97) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.575) - (input[5])) ^ (2.0))) + (((8.297) - (input[6])) ^ (2.0))) + (((67.0) - (input[7])) ^ (2.0))) + (((2.4216) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((264.0) - (input[10])) ^ (2.0))) + (((13.0) - (input[11])) ^ (2.0))) + (((384.54) - (input[12])) ^ (2.0))) + (((7.44) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine33 <- function(input) {
    return((subroutine34(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.08187) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((2.89) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.445) - (input[5])) ^ (2.0))) + (((7.82) - (input[6])) ^ (2.0))) + (((36.9) - (input[7])) ^ (2.0))) + (((3.4952) - (input[8])) ^ (2.0))) + (((2.0) - (input[9])) ^ (2.0))) + (((276.0) - (input[10])) ^ (2.0))) + (((18.0) - (input[11])) ^ (2.0))) + (((393.53) - (input[12])) ^ (2.0))) + (((3.57) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine34 <- function(input) {
    return((subroutine35(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.02009) - (input[1])) ^ (2.0)) + (((95.0) - (input[2])) ^ (2.0))) + (((2.68) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.4161) - (input[5])) ^ (2.0))) + (((8.034) - (input[6])) ^ (2.0))) + (((31.9) - (input[7])) ^ (2.0))) + (((5.118) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((224.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((390.55) - (input[12])) ^ (2.0))) + (((2.88) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine35 <- function(input) {
    return((subroutine36(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.61154) - (input[1])) ^ (2.0)) + (((20.0) - (input[2])) ^ (2.0))) + (((3.97) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.647) - (input[5])) ^ (2.0))) + (((8.704) - (input[6])) ^ (2.0))) + (((86.9) - (input[7])) ^ (2.0))) + (((1.801) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((264.0) - (input[10])) ^ (2.0))) + (((13.0) - (input[11])) ^ (2.0))) + (((389.7) - (input[12])) ^ (2.0))) + (((5.12) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine36 <- function(input) {
    return((subroutine37(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((3.32105) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.871) - (input[5])) ^ (2.0))) + (((5.403) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.3216) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((26.82) - (input[13])) ^ (2.0))))) * (-0.400989603367655)))
}
subroutine37 <- function(input) {
    return((subroutine38(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.29819) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((6.2) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.504) - (input[5])) ^ (2.0))) + (((7.686) - (input[6])) ^ (2.0))) + (((17.0) - (input[7])) ^ (2.0))) + (((3.3751) - (input[8])) ^ (2.0))) + (((8.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((17.4) - (input[11])) ^ (2.0))) + (((377.51) - (input[12])) ^ (2.0))) + (((3.92) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine38 <- function(input) {
    return((subroutine39(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.51902) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((19.58) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.605) - (input[5])) ^ (2.0))) + (((8.375) - (input[6])) ^ (2.0))) + (((93.9) - (input[7])) ^ (2.0))) + (((2.162) - (input[8])) ^ (2.0))) + (((5.0) - (input[9])) ^ (2.0))) + (((403.0) - (input[10])) ^ (2.0))) + (((14.7) - (input[11])) ^ (2.0))) + (((388.45) - (input[12])) ^ (2.0))) + (((3.32) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine39 <- function(input) {
    return((subroutine40(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((5.66998) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.631) - (input[5])) ^ (2.0))) + (((6.683) - (input[6])) ^ (2.0))) + (((96.8) - (input[7])) ^ (2.0))) + (((1.3567) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((375.33) - (input[12])) ^ (2.0))) + (((3.73) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine40 <- function(input) {
    return((subroutine41(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((8.26725) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))) + (((0.668) - (input[5])) ^ (2.0))) + (((5.875) - (input[6])) ^ (2.0))) + (((89.6) - (input[7])) ^ (2.0))) + (((1.1296) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((347.88) - (input[12])) ^ (2.0))) + (((8.88) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine41 <- function(input) {
    return((subroutine42(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((25.0461) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.987) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.5888) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((26.77) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine42 <- function(input) {
    return((subroutine43(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.05602) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((2.46) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.488) - (input[5])) ^ (2.0))) + (((7.831) - (input[6])) ^ (2.0))) + (((53.6) - (input[7])) ^ (2.0))) + (((3.1992) - (input[8])) ^ (2.0))) + (((3.0) - (input[9])) ^ (2.0))) + (((193.0) - (input[10])) ^ (2.0))) + (((17.8) - (input[11])) ^ (2.0))) + (((392.63) - (input[12])) ^ (2.0))) + (((4.45) - (input[13])) ^ (2.0))))) * (1.0)))
}
subroutine43 <- function(input) {
    return((subroutine44(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.38735) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((25.65) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.581) - (input[5])) ^ (2.0))) + (((5.613) - (input[6])) ^ (2.0))) + (((95.6) - (input[7])) ^ (2.0))) + (((1.7572) - (input[8])) ^ (2.0))) + (((2.0) - (input[9])) ^ (2.0))) + (((188.0) - (input[10])) ^ (2.0))) + (((19.1) - (input[11])) ^ (2.0))) + (((359.29) - (input[12])) ^ (2.0))) + (((27.26) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine44 <- function(input) {
    return((subroutine45(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((41.5292) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.531) - (input[6])) ^ (2.0))) + (((85.4) - (input[7])) ^ (2.0))) + (((1.6074) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((329.46) - (input[12])) ^ (2.0))) + (((27.38) - (input[13])) ^ (2.0))))) * (-0.3490103966325617)))
}
subroutine45 <- function(input) {
    return((subroutine46(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((24.8017) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.349) - (input[6])) ^ (2.0))) + (((96.0) - (input[7])) ^ (2.0))) + (((1.7028) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((19.77) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine46 <- function(input) {
    return((subroutine47(input)) + ((exp((-0.0000036459736698188483) * (((((((((((((((1.15172) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.701) - (input[6])) ^ (2.0))) + (((95.0) - (input[7])) ^ (2.0))) + (((3.7872) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((358.77) - (input[12])) ^ (2.0))) + (((18.35) - (input[13])) ^ (2.0))))) * (-1.0)))
}
subroutine47 <- function(input) {
    return((((25.346480984077544) + ((exp((-0.0000036459736698188483) * (((((((((((((((16.8118) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.7) - (input[5])) ^ (2.0))) + (((5.277) - (input[6])) ^ (2.0))) + (((98.1) - (input[7])) ^ (2.0))) + (((1.4261) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((30.81) - (input[13])) ^ (2.0))))) * (-1.0))) + ((exp((-0.0000036459736698188483) * (((((((((((((((38.3518) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((18.1) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.693) - (input[5])) ^ (2.0))) + (((5.453) - (input[6])) ^ (2.0))) + (((100.0) - (input[7])) ^ (2.0))) + (((1.4896) - (input[8])) ^ (2.0))) + (((24.0) - (input[9])) ^ (2.0))) + (((666.0) - (input[10])) ^ (2.0))) + (((20.2) - (input[11])) ^ (2.0))) + (((396.9) - (input[12])) ^ (2.0))) + (((30.59) - (input[13])) ^ (2.0))))) * (-1.0))) + ((exp((-0.0000036459736698188483) * (((((((((((((((0.84054) - (input[1])) ^ (2.0)) + (((0.0) - (input[2])) ^ (2.0))) + (((8.14) - (input[3])) ^ (2.0))) + (((0.0) - (input[4])) ^ (2.0))) + (((0.538) - (input[5])) ^ (2.0))) + (((5.599) - (input[6])) ^ (2.0))) + (((85.7) - (input[7])) ^ (2.0))) + (((4.4546) - (input[8])) ^ (2.0))) + (((4.0) - (input[9])) ^ (2.0))) + (((307.0) - (input[10])) ^ (2.0))) + (((21.0) - (input[11])) ^ (2.0))) + (((303.42) - (input[12])) ^ (2.0))) + (((16.51) - (input[13])) ^ (2.0))))) * (-1.0)))
}


## Plot simulations for Mincerian Wage equation
## Load libraries
library(tidyverse)
library(texreg)
library(cowplot)
library(ggsci)
library(ggpubr)
library(vtable)

## Make descriptipve table
df <- read.csv("data/edit/analysis_df.csv") %>%
  dplyr::select(-X.1)

labs <- data.frame(
  age = "Age",
  S = "Schooling (years)",
  X = "Work experience (years)",
  ln_y_I = "Log wages (linear-I)",
  ln_y_II = "Log wages (linear-II)",
  ln_y_III = "Log wages (linear-III)",
  ln_y_IV = "Log wages (linear-IV)",
  gender = "Sex (1 = female, 0 = male)"
)

df %>%
  select(age, S, X, gender, ln_y_I, ln_y_II, ln_y_III, ln_y_IV) %>%
  mutate(gender = ifelse(gender == 1, "Female", "Male")) %>%
  vtable::sumtable(
    labels = labs, out = "latex",
    file = "tex/tables/desc_mincerian.tex"
  )

## Plot OOS performance
source("mincerian/functions.R")
data <- readRDS("data/final/simul_4models_100.rds")

df <- data %>%
  mutate(
    lm_1_1 = 1 - (lm_1_1 / lm_1_bench),
    lm_1_2 = 1 - (lm_1_2 / lm_1_bench),
    lm_1_3 = 1 - (lm_1_3 / lm_1_bench),
    lm_1_4 = 1 - (lm_1_4 / lm_1_bench),
    lm_2_1 = 1 - (lm_2_1 / lm_2_bench),
    lm_2_2 = 1 - (lm_2_2 / lm_2_bench),
    lm_2_3 = 1 - (lm_2_3 / lm_2_bench),
    lm_2_4 = 1 - (lm_2_4 / lm_2_bench),
    lm_3_1 = 1 - (lm_3_1 / lm_3_bench),
    lm_3_2 = 1 - (lm_3_2 / lm_3_bench),
    lm_3_3 = 1 - (lm_3_3 / lm_3_bench),
    lm_3_4 = 1 - (lm_3_4 / lm_3_bench),
    lm_4_1 = 1 - (lm_4_1 / lm_4_bench),
    lm_4_2 = 1 - (lm_4_2 / lm_4_bench),
    lm_4_3 = 1 - (lm_4_3 / lm_4_bench),
    lm_4_4 = 1 - (lm_4_4 / lm_4_bench),
    gb_1 = 1 - (gb_1 / lm_1_bench),
    gb_2 = 1 - (gb_2 / lm_2_bench),
    gb_3 = 1 - (gb_3 / lm_3_bench),
    gb_4 = 1 - (gb_4 / lm_4_bench)
  ) %>%
  dplyr::select(-lm_1_bench, -lm_2_bench, -lm_3_bench, -lm_4_bench)

df_melt <- df %>%
  reshape2::melt() %>%
  mutate(
    dataset = ifelse(grepl("lm_1|gb_1", variable), "Dataset I",
      ifelse(grepl("lm_2|gb_2", variable), "Dataset II",
        ifelse(grepl("lm_3|gb_3", variable), "Dataset III",
          ifelse(grepl("lm_4|gb_4", variable), "Dataset IV",
            "Else"
          )
        )
      )
    ),
    model = ifelse(grepl("\\d{1}_1", variable), "Linear I",
      ifelse(grepl("\\d{1}_2", variable), "Linear II",
        ifelse(grepl("\\d{1}_3", variable), "Linear III",
          ifelse(grepl("\\d{1}_4", variable), "Linear IV",
            ifelse(grepl("gb", variable), "XGBoost",
              "Other"
            )
          )
        )
      )
    )
  )

df_summ <- df_melt %>%
  group_by(variable) %>%
  summarise(
    mean = mean(value),
    sd = sd(value),
    model = unique(model),
    dataset = unique(dataset)
  )

df_plot <- df_summ %>%
  filter(!grepl("rf", variable))

custom_pal <- c(
  ggsci::pal_aaas()(6)[6],
  RColorBrewer::brewer.pal(4, "Blues")
)

df_plot$model <- factor(df_plot$model, levels = c(
  "XGBoost", "Linear I", "Linear II",
  "Linear III", "Linear IV"
))
text_size <- 20

ggplot(df_plot, aes(y = mean, x = model, group = dataset, fill = model)) +
  geom_bar(stat = "identity", color = "black") +
  geom_text(aes(label = paste0(as.character(round(mean, 2) * 100), "%")),
    vjust = -0.5
  ) +
  geom_hline(yintercept = 0.9, linetype = "dashed") +
  scale_fill_manual(values = custom_pal, name = "") +
  ylim(0, 1) +
  scale_y_continuous(
    limits = c(0.5, 1.05), oob = scales::rescale_none,
    labels = scales::percent
  ) +
  geom_errorbar(aes(ymin = mean - sd, ymax = mean + sd), width = 0.5) +
  facet_wrap(~dataset, nrow = 1) +
  cowplot::theme_cowplot() +
  xlab("Model") +
  ylab("Out-of-sample R-squared") +
  theme(
    panel.grid.minor.x = element_line(size = 0.25), # linetype = 'dotted'),
    strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
    strip.background = element_rect(fill = NA, color = "black", size = 1.5),
    legend.position = "top",
    panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
    text = element_text(size = 20)
  ) +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1, size = (text_size - 1)),
    axis.text.y = element_text(size = (text_size - 1)),
    axis.title.y = element_text(size = 16.3)
  ) +
  scale_y_continuous(labels = scales::percent, limits = c(0, 1))

ggsave("tex/figs/fig1_mincerian.pdf", last_plot(), width = 12, height = 6)

## Plot in-sample regression results

analysis_df <- read.csv("data/edit/analysis_df.csv")

form_0 <- as.formula("ln_y ~ 1")
form_1 <- as.formula("ln_y ~ 1 + S + X")
form_2 <- as.formula("ln_y ~ 1 + S + X + X_sq")
form_3 <- as.formula(
  "ln_y ~ 1 + S_0_8 + S_9_10 + S_11_12 + S_13_14 + S_15p + X + X_sq"
)
form_4 <- as.formula(
  "ln_y ~ 1 + S_0_8 + S_9_10 + S_11_12 + S_13_14 + S_15p + X + X_sq + gender"
)

formulas <- list(form_0, form_1, form_2, form_3, form_4)

vars <- list("ln_y_I", "ln_y_II", "ln_y_III", "ln_y_IV")

coef_dfs <- lapply(vars, FUN = function(x) {
  make_coef_df(formulas, analysis_df, var = x)
})

total_df <- data.frame()

for (i in coef_dfs) {
  total_df <- rbind(total_df, i)
}

total_df <- total_df[total_df$model_no != "Null", ]
plot_df <- total_df[total_df$coefficient != "(Intercept)", ]
plot_df$dataset <- as.factor(plot_df$dataset)

plot_df <- plot_df %>%
  mutate(var_type = ifelse(grepl("X", coefficient), "Years Work Experience",
    ifelse(grepl("S", coefficient), "Years Schooling", "Sex")
  )) %>%
  mutate(coefficient = gsub("gender", "Female", coefficient)) %>%
  mutate(
    coefficient = gsub("S_|S", "School years: ", coefficient),
    coefficient = gsub("_", " to ", coefficient),
    coefficient = gsub("p$", "+", coefficient),
    coefficient = gsub("X to sq", "Work years (squared)", coefficient),
    coefficient = gsub("X", "Work years", coefficient),
    dataset = gsub("ln_y_", "Dataset ", dataset)
  ) %>%
  mutate(
    sig = ifelse(`p-value` < 0.01, "*", ""),
    sig_pos = estimate + 0.05
  )

ggplot(
  plot_df,
  aes(x = estimate, y = coefficient, fill = model_no)
) +
  geom_point(
    size = 2.5, position = position_dodge(width = 0.5),
    color = "black", pch = 21
  ) +
  facet_wrap(~dataset, nrow = 1) +
  geom_vline(xintercept = 0, linetype = "dashed") +
  theme_cowplot() +
  scale_fill_manual(
    values = custom_pal[2:5],
    name = "Model type"
  ) +
  theme(legend.position = "top") +
  xlab("Coefficient Estimate") +
  ylab("Coefficient") +
  geom_text(
    data = plot_df, aes(x = sig_pos, y = coefficient, label = sig),
    color = "black",
    position = position_dodge(width = 0.5),
    vjust = 0.7
  ) +
  theme(
    panel.grid.major.x = element_line(
      size = 0.5, linetype = "dotted",
      colour = "lightgrey"
    ),
    panel.grid.minor.x = element_line(
      size = 0.25, linetype = "dotted",
      colour = "lightgrey"
    ),
    strip.placement = "outside",
    strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
    strip.background = element_rect(fill = NA, color = "black", size = 1.2),
    legend.position = "top",
    panel.spacing.x = unit(1, "lines"),
    panel.spacing.y = unit(0.1, "lines"),
    panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
    plot.margin = grid::unit(c(0.5, 0.5, 0.1, 0.1), "mm")
  )

ggsave("tex/figs/fig2_mincerian.pdf", last_plot(), width = 12, height = 8)

## -- Shapley plots

df <- read.csv("data/edit/mincerian_shap.csv") %>%
  rowwise() %>%
  mutate(
    S1 = as.numeric(S1),
    S_0_8 = min(S1, 8),
    S_9_10 = min(max(S1 - 8, 0), 2),
    S_11_12 = min(max(S1 - 10, 0), 2),
    S_13_14 = min(max(S1 - 12, 0), 2),
    S_15p = max(S1 - 14, 0),
  ) %>%
  ungroup()

df$X1_1_predict <- predict_XSQ(df, total_df, "Linear I", "ln_y_I")
df$X1_2_predict <- predict_XSQ(df, total_df, "Linear II", "ln_y_I")
df$X1_3_predict <- predict_XSQ(df, total_df, "Linear III", "ln_y_I")
df$X1_4_predict <- predict_XSQ(df, total_df, "Linear IV", "ln_y_I")

df$X2_1_predict <- predict_XSQ(df, total_df, "Linear I", "ln_y_II")
df$X2_2_predict <- predict_XSQ(df, total_df, "Linear II", "ln_y_II")
df$X2_3_predict <- predict_XSQ(df, total_df, "Linear III", "ln_y_II")
df$X2_4_predict <- predict_XSQ(df, total_df, "Linear IV", "ln_y_II")

df$X3_1_predict <- predict_XSQ(df, total_df, "Linear I", "ln_y_III")
df$X3_2_predict <- predict_XSQ(df, total_df, "Linear II", "ln_y_III")
df$X3_3_predict <- predict_XSQ(df, total_df, "Linear III", "ln_y_III")
df$X3_4_predict <- predict_XSQ(df, total_df, "Linear IV", "ln_y_III")

df$X4_1_predict <- predict_XSQ(df, total_df, "Linear I", "ln_y_IV")
df$X4_2_predict <- predict_XSQ(df, total_df, "Linear II", "ln_y_IV")
df$X4_3_predict <- predict_XSQ(df, total_df, "Linear III", "ln_y_IV")
df$X4_4_predict <- predict_XSQ(df, total_df, "Linear IV", "ln_y_IV")

df$S1_1_predict <- predict_S(df, total_df, "Linear I", "ln_y_I")
df$S1_2_predict <- predict_S(df, total_df, "Linear II", "ln_y_I")
df$S1_3_predict <- predict_S(df, total_df, "Linear III", "ln_y_I")
df$S1_4_predict <- predict_S(df, total_df, "Linear IV", "ln_y_I")

df$S2_1_predict <- predict_S(df, total_df, "Linear I", "ln_y_II")
df$S2_2_predict <- predict_S(df, total_df, "Linear II", "ln_y_II")
df$S2_3_predict <- predict_S(df, total_df, "Linear III", "ln_y_II")
df$S2_4_predict <- predict_S(df, total_df, "Linear IV", "ln_y_II")

df$S3_1_predict <- predict_S(df, total_df, "Linear I", "ln_y_III")
df$S3_2_predict <- predict_S(df, total_df, "Linear II", "ln_y_III")
df$S3_3_predict <- predict_S(df, total_df, "Linear III", "ln_y_III")
df$S3_4_predict <- predict_S(df, total_df, "Linear IV", "ln_y_III")

df$S4_1_predict <- predict_S(df, total_df, "Linear I", "ln_y_IV")
df$S4_2_predict <- predict_S(df, total_df, "Linear II", "ln_y_IV")
df$S4_3_predict <- predict_S(df, total_df, "Linear III", "ln_y_IV")
df$S4_4_predict <- predict_S(df, total_df, "Linear IV", "ln_y_IV")

df_melt_X <- df %>%
  sample_n(250) %>%
  dplyr::select(
    X1, X1_shap, X2_shap, X3_shap, X4_shap,
    contains("_predict"),
    -starts_with("S"), sex
  ) %>%
  reshape2::melt(id.vars = c("X1", "sex")) %>%
  mutate(
    model = ifelse(grepl("shap", variable), "Shapley Value",
      ifelse(grepl("_1", variable), "Linear I",
        ifelse(grepl("_2", variable), "Linear II",
          ifelse(grepl("_3", variable), "Linear III",
            ifelse(grepl("_4", variable), "Linear IV", "None")
          )
        )
      )
    ),
    dataset = gsub("_.*", "", variable),
    dataset = gsub("X", "Dataset ", dataset),
    sex = as.factor(ifelse(sex == 1, "Female", "Male"))
  ) %>%
  rename(Sex = sex) %>%
  group_by(variable) %>%
  mutate(value = scale(value)) %>%
  ungroup()

df_melt_S <- df %>%
  sample_n(250) %>%
  dplyr::select(
    S1, S1_shap, S2_shap, S3_shap, S4_shap,
    contains("_predict"), sex
  ) %>%
  dplyr::select(-contains("X"), sex) %>%
  reshape2::melt(id.vars = c("S1", "sex")) %>%
  mutate(
    model = ifelse(grepl("shap", variable), "Shapley Value",
      ifelse(grepl("_1", variable), "Linear I",
        ifelse(grepl("_2", variable), "Linear II",
          ifelse(grepl("_3", variable), "Linear III",
            ifelse(grepl("_4", variable), "Linear IV", "None")
          )
        )
      )
    ),
    dataset = gsub("_.*", "", variable),
    dataset = gsub("S", "Dataset ", dataset),
    S1 = as.numeric(S1),
    sex = as.factor(ifelse(sex == 1, "Female", "Male"))
  ) %>%
  rename(Sex = sex) %>%
  group_by(variable) %>%
  mutate(value = scale(value)) %>%
  ungroup()

X_shap_plot <- ggplot(
  df_melt_X %>% filter(!grepl("shap", variable)),
  aes(y = value, x = X1, color = Sex)
) +
  geom_point(
    data = df_melt_X %>% filter(grepl("shap", variable)),
    alpha = 0.5, size = 3.5
  ) +
  geom_line(aes(linetype = model), color = "black", size = 0.8) +
  ggsci::scale_color_aaas() +
  xlab("Work experience (years)") +
  ylab("Implied effect on log wages") +
  scale_linetype_manual(values = c("solid", "dashed", "twodash", "dotted")) +
  theme_cowplot() +
  guides(color = guide_legend(override.aes = list(fill = NA))) +
  facet_wrap(~dataset, nrow = 1) +
  theme(
    panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
    panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
    strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
    strip.background = element_rect(fill = NA, color = "black", size = 1.5),
    legend.position = "top",
    panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
    text = element_text(size = 20),
    legend.title = element_blank()
  )

S_shap_plot <- ggplot(
  df_melt_S %>% filter(!grepl("shap", variable)),
  aes(y = value, x = S1, color = Sex)
) +
  geom_point(
    data = df_melt_S %>% filter(grepl("shap", variable)),
    size = 3.5, alpha = 0.5
    #  color = ggsci::pal_aaas("default")(4)[1], size = 3.5
  ) +
  ggsci::scale_color_aaas() +
  geom_line(aes(linetype = model), color = "black", size = 0.8) +
  xlab("Schooling (years)") +
  ylab("Implied effect on log wages") +
  scale_linetype_manual(values = c("solid", "dashed", "twodash", "dotted")) +
  theme_cowplot() +
  theme(
    panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
    panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
    strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
    strip.background = element_rect(fill = NA, color = "black", size = 1.5),
    legend.position = "top",
    panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
    text = element_text(size = 20),
    legend.title = element_blank()
  ) +
  guides(color = guide_legend(override.aes = list(fill = NA))) +
  facet_wrap(~dataset, nrow = 1)

ggarrange(X_shap_plot + theme(legend.position = "none"),
  S_shap_plot + theme(legend.position = "none"),
  nrow = 2, common.legend = TRUE, legend = "top"
)

ggsave("tex/figs/fig3_mincerian.pdf", last_plot(), width = 12, height = 8)


    XIFUpixelFracs <- function(ctrate, deltat, t0, t1, t2, tolsep){
        #
        # Calculate (Quality) Fractions of photons for XIFU pixels, using photon simulation AND
        # Poisson statistics
        #
        # Poissonian Distribution of Photons
        #   tp = Tprevious
        #   tn = Tnext
        #   L : event with "Low" Quality
        #   M : event with "Medium" Quality
        #   H : event with "High" Quality
        #   I : event "Invalid"
        #   P2 : secondary events piled-up (same arrival time) (preceeded by close pulses)
        #   P1: first pulse in pile-up (followed by close pulses but no pulse close before)
        #   P : Pile-up = P1+P2
        #===================================================
        #            | tolsep>tp  tolsep<tp<t0   tp>t0     =
        # -------------------------------------------------=
        #   tn<t1    |      P2           I        L        =
        # t1<tn<t2   |      P2           I        M        =
        #   tn>t2    |      P2           I        H        =
        #  tn<tolsep |      P2           P1       P1       =
        #===================================================
        #
        # ctrate (in) : count rate (phs/s)
        # deltat (in) : time interval for simulations
        # t0, t1, t2, tolsep as in table above
        # fractions (out): list with H(igh)Q, M(edium)Q, L(ow)Q, I(nvalid)Q, P(i)L(eup) quality

        N.mean.photons <- deltat*ctrate
        stopifnot(N.mean.photons>0)
        N.real.photons <- rpois(1,N.mean.photons)
        #cat("psfrac=",psf, "N.mean.photons=", N.mean.photons,"\n")
        points <- runif(N.real.photons,0.,deltat)
        points <- sort(points)

        # Calculate fractions by photon counting (points in plots)
        # ----------------------------------------------------------
        Frac.HQ <- 0.
        Frac.MQ <- 0.
        Frac.LQ <- 0.
        Frac.IQ <- 0.
        Frac.PL <- 0.
        Frac.P1L <- 0.
        Frac.P2L <- 0.

        N.HQ.photons <- 0.
        N.MQ.photons <- 0.
        N.LQ.photons <- 0.
        N.IQ.photons <- 0.
        N.PL.photons <- 0.
        N.P1L.photons <- 0.
        N.P2L.photons <- 0.

        if(N.real.photons < 2){  # if less than 2 photons in total
            Frac.HQ <- 1.
            Frac.MQ <- 0.
            Frac.LQ <- 0.
            Frac.IQ <- 0.
            Frac.PL <- 0.
            Frac.P1L <- 0.
            Frac.P2L <- 0.
        }else{
            for (i in 1:N.real.photons){
                if(i==1){            # first photon case
                    if((points[i+1]-points[i])>t2){  # HQ
                        N.HQ.photons <- N.HQ.photons +1
                    }else if((points[i+1]-points[i])>t1 && (points[i+1]-points[i])<t2){  # MQ
                        N.MQ.photons <- N.MQ.photons +1
                    }else if((points[i+1]-points[i])<tolsep){
                        #N.PL.photons <- N.PL.photons +1
                        N.P1L.photons <- N.P1L.photons +1
                    }else{                           # LQ
                        N.LQ.photons <- N.LQ.photons +1
                    }
                }else if(i==N.real.photons){ # last photon case
                    if((points[i]-points[i-1])>t0){   # HQ
                        N.HQ.photons <- N.HQ.photons +1
                    }else if((points[i]-points[i-1])<tolsep){
                        #N.PL.photons <- N.PL.photons +1
                        N.P2L.photons <- N.P2L.photons +1
                    }else{                           # LQ
                        N.I.photons <- N.IQ.photons +1
                    }
                }else{
                    if((points[i]-points[i-1])>t0 && (points[i+1]-points[i])>t2){  # HQ
                        N.HQ.photons <- N.HQ.photons +1
                    }else if((points[i]-points[i-1])>t0 && (points[i+1]-points[i])>t1 &&
                             (points[i+1]-points[i])<t2){  # MQ
                        N.MQ.photons <- N.MQ.photons +1
                    }else if((points[i]-points[i-1])>t0 && ((points[i+1]-points[i])<t1) &&
                             (points[i+1]-points[i])>tolsep){ # LQ
                        N.LQ.photons <- N.LQ.photons +1
                    }else if((points[i+1]-points[i])<tolsep && (points[i]-points[i-1])>tolsep){
                        N.P1L.photons <- N.P1L.photons +1     # P1L
                    }else if((points[i]-points[i-1])<tolsep){
                        N.P2L.photons <- N.P2L.photons +1     # P2L
                    #}else if((points[i+1]-points[i])<tolsep || (points[i]-points[i-1])<tolsep){
                    #    N.PL.photons <- N.PL.photons +1
                    }else{                          # IQ
                        N.IQ.photons <- N.IQ.photons +1
                    }
                } # if for first/last/interm. photons
            }# foreach photon
            N.PL.photons <- N.P1L.photons + N.P2L.photons
            Frac.HQ <- N.HQ.photons/N.real.photons
            Frac.MQ <- N.MQ.photons/N.real.photons
            Frac.LQ <- N.LQ.photons/N.real.photons
            Frac.IQ <- N.IQ.photons/N.real.photons
            Frac.PL <- N.PL.photons/N.real.photons
            Frac.P1L <- N.P1L.photons/N.real.photons
            Frac.P2L <- N.P2L.photons/N.real.photons
        }# if >2 photons

        # Calculate fractions from Expression by Poissonian theory: given a photon...
        #----------------------------------------------------------------------------
        # HQ => pH: exp(-ctrate*t0) * exp(-ctrate*t2)
        # Prob of having 0 prev. photons in t0  and     0 next photons in t2
        pH <- dpois(0,lambda*t0)*dpois(0,lambda*t2)

        # MQ => pM: exp(-ctrate*t1) *  exp(-ctrate*t1)- pH
        # Prob of having 0 prev. photons in t1  and     0 next photons in t1    - pH
        pM <- dpois(0,lambda*t0)*dpois(0,lambda*t1)-pH

        # LQ => pL: exp(-ctrate*t0) -pH - pM
        pL <- dpois(0,lambda*t0)-pH-pM

        # PL => pP: two pulses arriving at t<ti
        # 2*exp(-ctrate*ti)  * (1- exp(-ctrate*ti))  : one pulse < ti, the other >ti
        # + (1- exp(-ctrate*ti))*(1- exp(-ctrate*ti)) : tp and tn closer than ti
        pP <- 1-dpois(0,2*lambda*tolsep)
        # also = ppois(0,2*lambda*tolsep, lower.tail=FALSE) -> given 1 photon, which is the prob of finding >0 ph in the double interval?
        pP2 <- 1-dpois(0,lambda*tolsep)
        pP1 <- pP - pP2
        # IQ => pI
        pI <- 1-pH-pM-pL-pP

        return(list("HQ_ph"=Frac.HQ, "MQ_ph"=Frac.MQ,   "LQ_ph"=Frac.LQ, "IQ_ph"=Frac.IQ,
                    "PL_ph"=Frac.PL, "P1L_ph"=Frac.P1L, "P2L_ph"=Frac.P2L,
                    "HQ_Ps"=pH,      "MQ_Ps"=pM,        "LQ_Ps"=pL,      "IQ_Ps"=pI,
                    "PL_Ps"=pP,      "P1L_Ps"=pP1,      "P2L_Ps"=pP2))
    }


## Descriptive statistics for questionnaire data
# Copyright 2021 Enrico Glerean
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

# Data description
#   filetype: CSV, first row list of column names with format C[1-4]_Q[1-40]
#   40 items (Q*) arranged in columns, divided in 4 subscales (C*)
# The four subscales:
# C1_Q1, C1_Q5, C1_Q9, C1_Q11, C1_Q13, C1_Q16, C1_Q19, C1_Q25, C1_Q27, C1_Q29, C1_Q31, C1_Q35,
# C2_Q4, C2_Q6, C2_Q8, C2_Q10, C2_Q14, C2_Q21, C2_Q22, C2_Q23, C2_Q30, C2_Q34,
# C3_Q3, C3_Q12, C3_Q17, C3_Q20, C3_Q24, C3_Q26, C3_Q28, C3_Q32, C3_Q33, C3_Q37, C3_Q38, C3_Q39,
# C4_Q2, C4_Q7, C4_Q15, C4_Q18, C4_Q36, C4_Q40
#
#   each row contains the scored answer of a participant:
#     -1: the participant answered wrongly
#     0: the participant answered "I am unsure"
#     1: the participant answered correctly
# Missing values were replaced with median (see python code for preprocessing)

# In this script we report classical descriptive summaries for the dataset
# The script should be run from the terminal prompt as an R-script
#   - without input argument: descriptive statistics for the whole scale
#   - with input argument 1,2,3,4: descriptive statistics for one of the 4 subscales

# We use the descriptive function from the ltm package
library("ltm")

dfA <- read.table("../results/scores/scores_sorted.csv",header=TRUE, sep=',', colClasses = "integer")
dfA <- dfA + 1 # We have values from 0 to 2 as required in other R packages with polytomous data

#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

if (length(args)==0) {
  print("Running for all items")
  plotlabel="allItems.pdf"
  df <- dfA
} else if (length(args)==1) {
  if (args==1){
    itemssub <- c(1,2,3,4,5,6,7,8,9,10,11,12);
    df <- subset(dfA, select = c("C1_Q1", "C1_Q5", "C1_Q9", "C1_Q11", "C1_Q13", "C1_Q16", "C1_Q19", "C1_Q25", "C1_Q27", "C1_Q29", "C1_Q31", "C1_Q35"));
    plotlabel="Subscale1.pdf";
    print("Running for Subscale 1")
  }
  if (args==2){
    itemssub <- c(13,14,15,16,17,18,19,20,21,22);
    df <- subset(dfA, select = c(C2_Q4, C2_Q6, C2_Q8, C2_Q10, C2_Q14, C2_Q21, C2_Q22, C2_Q23, C2_Q30, C2_Q34));
    plotlabel="Subscale2.pdf";
    print("Running for Subscale 2")
  }
  if (args==3){
    itemssub <- c(23,24,25,26,27,28,29,30,31,32,33,34)
    df <- subset(dfA, select = c(C3_Q3, C3_Q12, C3_Q17, C3_Q20, C3_Q24, C3_Q26, C3_Q28, C3_Q32, C3_Q33, C3_Q37, C3_Q38, C3_Q39));
    plotlabel="Subscale3.pdf"
  }
  if (args==4){
    itemssub <- c(35,36,37,38,39,40)
    df <- subset(dfA, select = c(C4_Q2, C4_Q7, C4_Q15, C4_Q18, C4_Q36, C4_Q40))
    plotlabel="Subscale4.pdf"
  }
}

d <- descript(df)
d

## Item Response Theory equivalent of reliability
#   - Item Separation Reliability (ISR)
#   - Person Separation Reliability (PSR)
# IMPORTANT NOTE:
#  ISR and PSR can also be computed from the standard error of the model fit
#  See for example implementation in package eRm.
#  Here we follow the formulas from Chapter 18 of:
#   Wright, B. D., & Stone, M. (1999). Measurement Essentials, Wide Range. INC. Wilmington, Delaware.
#  https://www.rasch.org/measess/met-18.pdf

# item separation reliability code from https://bookdown.org/chua/new_rasch_demo2/PC-model.html
# Based on formulas from https://www.rasch.org/measess/met-18.pdf
# Get Item scores
ItemScores <- colSums(df)
# Get Item SD
ItemSD <- apply(df,2,sd)
# Calculate the se of the Item
ItemSE <- ItemSD/sqrt(length(ItemSD))
# compute the Observed Variance (also known as Total Person Variability or Squared Standard Deviation)
SSD.ItemScores <- var(ItemScores)
# compute the Mean Square Measurement error (also known as Model Error variance)
Item.MSE <- sum((ItemSE)^2) / length(ItemSE)
# compute the Item Separation Reliability
item.separation.reliability <- (SSD.ItemScores-Item.MSE) / SSD.ItemScores

print("Item separation reliability: ")
item.separation.reliability

# person separation reliability code from https://bookdown.org/chua/new_rasch_demo2/PC-model.html
# Based on formulas from https://www.rasch.org/measess/met-18.pdf
# Get Person scores
PersonScores <- rowSums(df)
# Get Person SD
PersonSD <- apply(df,1,sd)
# Calculate the se of the Person
PersonSE <- PersonSD/sqrt(length(PersonSD))
# compute the Observed Variance (also known as Total Person Variability or Squared Standard Deviation)
SSD.PersonScores <- var(PersonScores)
# compute the Mean Square Measurement error (also known as Model Error variance)
Person.MSE <- sum((PersonSE)^2) / length(PersonSE)
# compute the Person Separation Reliability
person.separation.reliability <- (SSD.PersonScores-Person.MSE) / SSD.PersonScores

print("Person separation reliability: ")
person.separation.reliability