# Libraries
library(tidyverse)
library(lubridate)
library(rpart)
library(rpart.plot)

# Data
paywall <- read_csv("paywall_data.csv") %>%
  mutate_at(3:18, mdy_hm) %>%
  inner_join(read_csv("paywall_payment_data.csv"), by = "id") %>%
  mutate(`First Payment Date` = mdy_hm(`First Payment Date`))

# Exploratory -------------------------------------------------------------

# Distribution of Payments
summary(paywall$`Registration Date`)
table(paywall$`Paid?`)
as.data.frame(table(as_date(paywall$`First Payment Date`)))
ggplot(paywall) +
  geom_histogram(aes(`First Payment Value`))

# Conversion rates
foo <- paywall %>%
  group_by(year(`Registration Date`), month(`Registration Date`)) %>%
  summarise(Registrations = n(),
            Converstions = sum(`Paid?`),
            Converstion_rate = Converstions/Registrations)

# Filtering for 2016 only
paywall <- paywall %>%
  filter(`Registration Date` >= as_date("2016-01-01"))

# Removing all paywalls after first payment date
foo <- paywall %>%
  mutate_at(4:18, function(.){!is.na(.)}) %>%
  mutate(paywalls_seen = rowSums(.[4:18]))
sum(foo$paywalls_seen) #22670 paywalls seen before

paywall <- paywall %>%
  mutate(temp_date = ifelse(is.na(`First Payment Date`), ymd_hm("2999-01-01 02:22"), `First Payment Date`)) %>%
  mutate(temp_date = as.POSIXct(temp_date, tz = "UTC", origin = "1970-01-01"))
paywall <- paywall %>%
  mutate_at(4:18, function(.){ifelse(. >= paywall$temp_date, NA, .)}) %>%
  mutate_at(4:18, function(.){as.POSIXct(., tz = "UTC", origin = "1970-01-01")}) %>%
  select(-temp_date)

foo <- paywall %>%
  mutate_at(4:18, function(.){!is.na(.)}) %>%
  mutate(paywalls_seen = rowSums(.[4:18]))
sum(foo$paywalls_seen) #21400 paywalls seen after

# More testing to ensure no paywalls after first payment date
foo <- paywall %>%
  filter(`Paid?` == 1)
foo$colMax <- apply(foo[,4:18], 1, function(x) max(x, na.rm = TRUE))
foo$colMax <- ymd_hms(foo$colMax)
foo$diff <- (foo$`First Payment Date`-foo$colMax)/(24*60)

# Removing all paywalls before registration date
foo <- paywall %>%
  mutate_at(4:18, function(.){!is.na(.)}) %>%
  mutate(paywalls_seen = rowSums(.[4:18]))
sum(foo$paywalls_seen) #21400 paywalls seen before

paywall <- paywall %>%
  mutate(temp_date = ifelse(is.na(`Registration Date`), ymd_hm("1900-01-01 02:22"), `Registration Date`)) %>%
  mutate(temp_date = as.POSIXct(temp_date, tz = "UTC", origin = "1970-01-01"))

paywall <- paywall %>%
  mutate_at(4:18, function(.){ifelse(. <= paywall$temp_date, NA, .)}) %>%
  mutate_at(4:18, function(.){as.POSIXct(., tz = "UTC", origin = "1970-01-01")}) %>%
  select(-temp_date)

foo <- paywall %>%
  mutate_at(4:18, function(.){!is.na(.)}) %>%
  mutate(paywalls_seen = rowSums(.[4:18]))
sum(foo$paywalls_seen) #20898 paywalls seen after

foo <- paywall
foo$colMin <- apply(foo[,4:18], 1, function(x) min(x, na.rm = TRUE))
foo$colMin <- ymd_hms(foo$colMin)
foo$diff <- (foo$colMin - foo$`First Payment Date`)/(24*60)

# Converstion Rate --------------------------------------------------------

# Last Paywall Wins

paywall_vert <- paywall %>%
  select(1:2,4:18) %>%
  gather(paywall,date,3:17) %>%
  arrange(id)

foo <- paywall_vert %>%
  group_by(id) %>%
  filter(date == max(date, na.rm = TRUE))

bar <- foo %>%
  group_by(paywall) %>%
  summarise(cnt = n(),
            converted = sum(`Paid?`),
            converstion_rate = converted/cnt) %>%
  arrange(desc(cnt))

# Every Paywall Seen

# All Customers
paywall_vert %>%
  filter(!is.na(date)) %>%
  group_by(id) %>%
  summarise(cnt_paywalls = n()) %>%
  group_by(cnt_paywalls) %>%
  summarise(dist = n())

# Converted Customers
paywall_vert %>%
  filter(!is.na(date),
         `Paid?` == 1) %>%
  group_by(id) %>%
  summarise(cnt_paywalls = n()) %>%
  group_by(cnt_paywalls) %>%
  summarise(dist = n())

bar <- paywall_vert %>%
  filter(!is.na(date)) %>%
  group_by(paywall) %>%
  summarise(cnt = n(),
            converted = sum(`Paid?`),
            not_converted = cnt - converted,
            converstion_rate = converted/cnt) %>%
  arrange(desc(converted))

# Denominator in both conversion rate methods
sum(paywall_vert$`Paid?`) #29025
sum(paywall$`Paid?`) #1935

# Testing Significance
foo <- bar[c(1,3,15),]
chisq.test(foo$converted, foo$not_converted)

# Predictive Modelling ----------------------------------------------------

paywall_dt <- paywall %>%
  select(2,4:18) %>%
  mutate_at(2:16, function(.){factor(!is.na(.), levels=c("TRUE","FALSE"))}) %>%
  mutate(`Paid?` = ifelse(`Paid?`==1,"Paid","Not"))

# Grow a tree
control <- rpart.control(minbucket = 5, cp = 0.0001, maxsurrogate = 0, usesurrogate = 0, xval = 3) # Tuning parameters
fit1 <- rpart(`Paid?` ~ ., paywall_dt, method="class", control = control) # model fit

# results of tree
printcp(fit1) # display the results
plotcp(fit1) # visualize cross-validation results

# prune the tree
#fit1<- prune(fit1, cp=fit1$cptable[which.min(fit1$cptable[,"xerror"]),"CP"])
fit1<- prune(fit1, cp = 0.00010336)
foo <- as.data.frame(fit1$variable.importance )
summary(fit1)

# plot tree
plot(fit1, uniform=TRUE, main="Pruned Decision Tree")
text(fit1, use.n=TRUE, all=TRUE, cex=.8)
rpart.plot(fit1, cex = .8)

# Revenue Attribution -----------------------------------------------------

# Last Paywall Wins
paid <- paywall %>%
  filter(`Paid?` == 1) %>%
  select(1,4:18,20) %>%
  gather(paywall, date, 2:16) %>%
  filter(!is.na(date)) %>%
  group_by(id) %>%
  arrange(desc(date)) %>%
  top_n(1) %>%
  group_by(paywall) %>%
  summarise(rev = sum(`First Payment Value`))

# Equal Weighting
paid <- paywall %>%
  filter(`Paid?` == 1) %>%
  select(1,4:18,20) %>%
  mutate_at(2:16, function(.){!is.na(.)}) %>%
  mutate(paywalls_seen = rowSums(.[2:16]),
         rev_perc = `First Payment Value`/paywalls_seen) %>%
  gather(paywall,value,2:16) %>%
  filter(value == TRUE) %>%
  arrange(id) %>%
  group_by(paywall) %>%
  summarise(rev = sum(rev_perc))

# Time-Weighted

# Calculating total trial duration

options(scipen=999)
paid <- paywall %>%
  filter(`Paid?` == 1) %>%
  mutate(trial_duration_days = as.numeric(`First Payment Date` - `Registration Date`)/(60*60*24)) %>%
  filter(!is.na(`Registration Date`))
paid$trial_duration_days[1]
paid <- paid %>%
  mutate_at(4:18, function(.){. - paid$`Registration Date`}) %>%
  mutate_at(4:18, function(.){as.numeric(.)/(60*24)})
paid$`(Pw) Page-Limit`[1]

# Weighting by days since registraion
paid <- paid %>%
  mutate_at(4:18, function(.){. / paid$trial_duration_days})
paid$`(Pw) Page-Limit`[1]

# Calculating revenue attribution
paid <- paid %>%
  mutate(denom = rowSums(.[4:18], na.rm = TRUE)) # denominator
paid <- paid %>%
  mutate_at(4:18, function(.){. / paid$denom}) # weighting
paid <- paid %>%
  mutate(total_perc = rowSums(.[4:18], na.rm = TRUE)) # should equal 1
paid <- paid %>%
  mutate_at(4:18, function(.){. * paid$`First Payment Value`}) #value

# testing
paid <- paid %>%
  mutate(test = rowSums(.[4:18], na.rm = TRUE)) #should equal first payment

paid <- paid %>%
  select(1,4:18,20) %>%
  gather(paywall, rev, 2:16) %>%
  filter(!is.na(rev))

paid <- paid %>%
  group_by(paywall) %>%
  summarise(rev_att = sum(rev))

# Association Rules -------------------------------------------------------

paid <- paywall %>%
  filter(`Paid?` == 1) %>%
  select(id, `(Pw) Page-Limit`, `(Pw) Pdf-dpi`, `(Pw) Storage`, `First Payment Value`)

paid$group <- ifelse(!is.na(paid$`(Pw) Page-Limit`) & !is.na(paid$`(Pw) Storage`) & !is.na(paid$`(Pw) Pdf-dpi`), "All Three",
              ifelse(!is.na(paid$`(Pw) Page-Limit`) & !is.na(paid$`(Pw) Storage`) & is.na(paid$`(Pw) Pdf-dpi`), "Page-Limit & Storage",
              ifelse(!is.na(paid$`(Pw) Page-Limit`) & is.na(paid$`(Pw) Storage`) & !is.na(paid$`(Pw) Pdf-dpi`), "Page-Limit & PDF",
              ifelse(is.na(paid$`(Pw) Page-Limit`) & !is.na(paid$`(Pw) Storage`) & !is.na(paid$`(Pw) Pdf-dpi`), "Storage & PDF",
              ifelse(!is.na(paid$`(Pw) Page-Limit`) & is.na(paid$`(Pw) Storage`) & is.na(paid$`(Pw) Pdf-dpi`), "Page-Limit Only",
              ifelse(is.na(paid$`(Pw) Page-Limit`) & !is.na(paid$`(Pw) Storage`) & is.na(paid$`(Pw) Pdf-dpi`), "Storage Only",
              ifelse(is.na(paid$`(Pw) Page-Limit`) & is.na(paid$`(Pw) Storage`) & !is.na(paid$`(Pw) Pdf-dpi`), "PDF Only",
              ifelse(is.na(paid$`(Pw) Page-Limit`) & is.na(paid$`(Pw) Storage`) & is.na(paid$`(Pw) Pdf-dpi`), "None of Them","Error"))))))))

foo <- paid %>%
  group_by(group) %>%
  summarise(rev_ave = mean(`First Payment Value`),
            cnt = n())


library(data.table)

dir.create('generated', showWarnings=F)

sppchar <- fread('../input-data/acap-species-list.csv')

dat <- fread('../input-data/species-demography/demographic-parameters.csv')
dat[species.cname == 'New Zealand white-capped albatross', species.cname := 'white-capped albatross']

dat[, code :=  NA_character_]
dat[, code := sppchar[match(tolower(species.cname), tolower(cname)), code.sra]]

stopifnot(dat[, !any(is.na(code))])

source('../functions.r')

source('pst_parameter_chosen_values.r')

## transform survival parameters and proportion of breeders from % to [0,1]
for (v in c('point.estimate', 'range.min', 'range.max',  'se', 'sd'))
    dat[parameter %in% c('Scurr', 'Sopt', 'PB'), eval(v) := get(v) / 100]

## take standard error if no standard deviation
dat[is.na(sd) & !is.na(se), sd := se]

case_summ <- list()

#####################################################################################
##  Estimate uncertainty for survival and afr if necessary

## *  SURVIVAL
cond <- dat[, parameter=='Scurr' &
             ((is.na(range.min) & !is.na(range.max)) | (!is.na(range.min) & is.na(range.max)))]
if (any(cond))
    stop('ERROR!!! Single bounds for curr survival not treated!')
cond <- dat[, parameter=='Sopt' &
             ((is.na(range.min) & !is.na(range.max)) | (!is.na(range.min) & is.na(range.max)))]
if (any(cond))
    stop('ERROR!!! Single bounds for opt survival not treated!')

## choose sd for point estimate without uncertainty
cond <- dat[, parameter %in% c('Scurr','Sopt') &
             !is.na(point.estimate) & is.na(sd) & is.na(range.min) & is.na(range.max)]
if (any(cond)) {
    case_summ$s_pointest <- cond
    dat[cond, sd := ifelse(data.quality == 'good', ssdgood,
                    ifelse(data.quality == 'medium', ssdmed, ssdpoor))]
}
## estimate + min-max
## get sd from CI...
cond <- dat[, parameter %in% c('Scurr','Sopt') & is.na(sd) & !is.na(range.min) & !is.na(range.max) &
             (range.type=='CI' | grepl('MARK',range.type))]
if (any(cond)) {
    case_summ$s_eminmax <- cond
    dat[cond, c('point.estimate', 'sd') := surv_meansd_from_ci(range.min, range.max)]
}
## ...and from symmetrical CI (assuming they are real CI)
cond2 <- dat[, parameter %in% c('Scurr','Sopt') & !is.na(point.estimate) & is.na(sd) & !is.na(range.min) &
              !is.na(range.max) & abs((range.min+range.max)/2 - point.estimate)<1e-5 & !cond]
if (any(cond2)) {
    case_summ$s_eci <- cond2
    dat[cond2, c('point.estimate', 'sd') := surv_meansd_from_ci(range.min, range.max)]
}

## * AGE AT FIRST REPRODUCTION
## only min
cond <- dat[, parameter=='A' & !is.na(range.min) & is.na(range.max) & is.na(point.estimate)]
if (any(cond))	{
    case_summ$a_minonly <- cond
    dat[cond, range.max := range.min * eval(a_mult_minonly)]
}
## only max
cond <- dat[, parameter=='A' & is.na(range.min) & !is.na(range.max) & is.na(point.estimate)]
if (any(cond))	{
    case_summ$a_maxonly <- cond
    dat[cond, range.min := range.max * eval(a_mult_maxonly)]
}
## min and point estimate
cond <- dat[, parameter=='A' & !is.na(range.min) & is.na(range.max) & !is.na(point.estimate)]
if (any(cond))	{
    case_summ$a_emin <- cond
    dat[cond, range.max := 2*point.estimate - range.min]
}
## max and point estimate
cond <- dat[, parameter=='A' & is.na(range.min) & !is.na(range.max) & !is.na(point.estimate)]
if (any(cond))	{
    case_summ$a_emax <- cond
    dat[cond, range.min := 2*point.estimate - range.max]
}
## only point estimate
cond <- dat[, parameter=='A' & is.na(range.min) & is.na(range.max) & !is.na(point.estimate)]
if (any(cond)) {
    case_summ$a_pointest <- cond
    dat[cond, c("range.min", "range.max") := list(floor(dat$point.estimate[cond] * eval(a_multmin_meanonly)),
                                                  ceiling(dat$point.estimate[cond] * eval(a_multmax_meanonly)))]
}

## * PROPORTION OF BREEDERS
if (any(dat[, parameter=='PB' & (!is.na(range.min) | !is.na(range.max)),]))
    stop('ERROR!!! min-max for PB non treated!')
## only mean
cond <- dat[, parameter=='PB' & !is.na(point.estimate) & is.na(sd)]
if (any(cond))	{
    case_summ$pb_esd <- cond
    dat[cond, sd := pb_sd_meanonly]
}

case_summ <- as.data.frame(case_summ)
case_summ <- cbind(code=dat$code, parameter=dat$parameter, case_summ)

#####################################################################################
## *  choose S and A

l <- list()
sp=dat$code[1]
for (sp in sort(unique(dat$code))) {
    lst <- list()
    for (param in c('Scurr','Sopt','A')) {
        min <- max <- mean <- sd <- 0
        ds <- dat[code %in% sp & parameter==param]
        if (sum(ds$proxy.sp=='') == nrow(ds))
            use.proxy.sp <- FALSE else use.proxy.sp <- TRUE
        onlyminmax <- prod(!is.na(c(ds$range.min, ds$range.max)))==1
        someminmax <- sum(!is.na(ds$range.min) & !is.na(ds$range.max))>0
        onlymeansd <- prod(!is.na(c(ds$point.estimate, ds$sd)))==1
        somemeansd <- sum(!is.na(ds$point.estimate) & !is.na(ds$sd))>0
        severalmeansd <- sum(!is.na(ds$point.estimate) & !is.na(ds$sd))>1
        ## only min-max
        if (someminmax & !somemeansd) {
            lst[[param]]['min'] <- min(c(ds$range.min, ds$range.max))
            lst[[param]]['max'] <- max(c(ds$range.min, ds$range.max))
        }
        ## only 1 mean/sd
        if (somemeansd & !severalmeansd & !someminmax) {
            cond <- !is.na(ds$point.estimate) & !is.na(ds$sd)
            lst[[param]]['mean'] <- ds$point.estimate[cond]
            lst[[param]]['sd'] <- ifelse(is.na(ds$sd[cond]), ds$se[cond], ds$sd[cond])
        }
        ## mix of min/max and 1 mean/sd
        if (someminmax & somemeansd & !severalmeansd) { # last condition just to make it exclusive from next if
            cond <- ds[, !is.na(point.estimate) & !is.na(sd)]
            if (param=='A') {
                ds[cond, range.min := point.estimate - 1.96 * sd]
                ds[cond, range.max := point.estimate + 1.96 * sd]
            }
            if (param %in% c('Scurr','Sopt')) {
                ds[cond, c('range.min', 'range.max') := surv_ci(point.estimate, sd)]
            }
            lst[[param]]['min'] <- min(c(ds$range.min, ds$range.max), na.rm=T)
            lst[[param]]['max'] <- max(c(ds$range.min, ds$range.max), na.rm=T)
        }
        ## several mean/sd (can have min/max too)
        if (severalmeansd) {
            cond <- ds[, !is.na(point.estimate) & !is.na(sd)]
            if (param=='A') {
                ds[cond, c('range.min', 'range.max') :=  list(point.estimate - 1.96 * sd,
                                                              point.estimate + 1.96 * sd)]
            }
            if (param %in% c('Scurr','Sopt')) {
                ds[cond, c('range.min', 'range.max') := surv_ci(point.estimate, sd)]
            }
            lst[[param]]['min'] <- min(c(ds$range.min, ds$range.max), na.rm=T)
            lst[[param]]['max'] <- max(c(ds$range.min, ds$range.max), na.rm=T)
        }
        lst[[param]]['proxysp'] <- use.proxy.sp
    }
    l[[sp]] <- lst
}

#####################################################################################
## * proportion breeding

sp=dat$code[1]
for (sp in sort(unique(dat$code))) {
    spc <- dat$code %in% sp
    biennial <- sppchar[code.sra %in% sp, biennial]
    PB <- list(mean=dat[parameter=='PB' & spc, point.estimate], sd=dat[parameter=='PB' & spc, sd])
    if (length(PB$mean) & length(PB$sd)) {
        l[[sp]]$PB <- PB
    } else if (biennial=='Y') {
        l[[sp]]$PB <- PBbi
    } else if (grepl('^N',biennial)) {
        l[[sp]]$PB <- PBan
    } else l[[sp]]$PB <- PBmix
}

#####################################################################################
## * Convert list to final data frame

i=1
dt <- rbindlist(lapply(1:length(l), function(i) {
    sp <- names(l[i])
    data.table(sp        = sp,
               A.mean    = ifelse(length(l[[i]]$A['mean']), l[[i]]$A['mean'], NA),
               A.sd      = ifelse(length(l[[i]]$A['sd']), l[[i]]$A['sd'], NA),
               A.min     = ifelse(length(l[[i]]$A['min']), l[[i]]$A['min'], NA),
               A.max     = ifelse(length(l[[i]]$A['max']), l[[i]]$A['max'], NA),
               A.proxysp = ifelse(length(l[[i]]$A['proxysp']), l[[i]]$A['proxysp'], NA),
               Scurr.mean    = ifelse(length(l[[i]]$Scurr['mean']), l[[i]]$Scurr['mean'], NA),
               Scurr.sd      = ifelse(length(l[[i]]$Scurr['sd']), l[[i]]$Scurr['sd'], NA),
               Scurr.min     = ifelse(length(l[[i]]$Scurr['min']), l[[i]]$Scurr['min'], NA),
               Scurr.max     = ifelse(length(l[[i]]$Scurr['max']), l[[i]]$Scurr['max'], NA),
               Scurr.proxysp = ifelse(length(l[[i]]$Scurr['proxysp']), l[[i]]$Scurr['proxysp'], NA),
               Sopt.mean    = ifelse(length(l[[i]]$Sopt['mean']), l[[i]]$Sopt['mean'], NA),
               Sopt.sd      = ifelse(length(l[[i]]$Sopt['sd']), l[[i]]$Sopt['sd'], NA),
               Sopt.min     = ifelse(length(l[[i]]$Sopt['min']), l[[i]]$Sopt['min'], NA),
               Sopt.max     = ifelse(length(l[[i]]$Sopt['max']), l[[i]]$Sopt['max'], NA),
               Sopt.proxysp = ifelse(length(l[[i]]$Sopt['proxysp']), l[[i]]$Sopt['proxysp'], NA),
               PB.mean   = ifelse(length(l[[i]]$PB$mean), l[[i]]$PB$mean, NA),
               PB.sd     = ifelse(length(l[[i]]$PB$sd), l[[i]]$PB$sd, NA),
               PB.min    = ifelse(length(l[[i]]$PB$min), l[[i]]$PB$min, NA),
               PB.max    = ifelse(length(l[[i]]$PB$max), l[[i]]$PB$max, NA)
               )
}))

## Check completedness
acols <- grep('^A.',names(dt))
scurrcols <- grep('^Scurr.',names(dt))
soptcols <- grep('^Sopt.',names(dt))
pbcols <- grep('^PB.',names(dt))
a <- apply(dt,1,function(x) {
    A <- sum(!is.na(x[acols]))>1
    Scurr <- sum(!is.na(x[scurrcols]))>1
    Sopt <- sum(!is.na(x[soptcols]))>1
    PB <- sum(!is.na(x[pbcols]))>1
    return(c(a=A,scurr=Scurr,sopt=Sopt,pb=PB))
})
a <- as.data.frame(t(a))

b <- apply(a,2,all)
incompl <- names(b[!b])
if (length(incompl)) {
    inc <- which(a[,incompl]==F)
    l[dt$sp[inc]]
}

#############################
## Add common and group names
dt[, cname   := sppchar[match(dt$sp, code.sra), cname]]
dt[, spgroup := sppchar[match(dt$sp, code.sra), Taxa]]

#############################
## Point estimates
for (param in c('A','Scurr','Sopt','PB')) {
    dt[!is.na(get(paste0(param,'.mean'))) & !is.na(get(paste0(param,'.sd'))),
       eval(paste0(param,'.ptest')) := get(paste0(param,'.mean'))]
    dt[!is.na(get(paste0(param,'.min'))) & !is.na(get(paste0(param,'.max'))),
       eval(paste0(param,'.ptest')) := (get(paste0(param,'.min')) + get(paste0(param,'.max')))/2]
    if (any(dt[, is.na(get(paste0(param,'.ptest')))]))
        stop(paste0('ERROR!!! Some NAs for', param))
}

#####################################################################################
##  EXPORT FINAL TABLE
fwrite(dt, 'generated/@estimates_table_final.csv')


###plot pysim5g lookup tables
# install.packages("tidyverse")
library(tidyverse)
library(plyr)
library(ggpubr)
#####################

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#get path to full tables via the data folder
full_tables <- file.path(folder, '..', 'data', 'raw', 'pysim5g', 'full_tables')

#get a list of all files in the folder ending in .csv
myfiles = list.files(path=full_tables, pattern="*.csv", full.names=TRUE)

#import data for all files in file list
data = ldply(myfiles, read_csv)

#select the ISD of 10000m to plot
data = data[data$inter_site_distance_m == 8800,]

data = data[!(data$environment == 'urban' & data$r_distance > 5000),]

data = data[!(data$sinr_dB > 50),]

#turn env into factor and relabel
data$environment = factor(data$environment, levels=c("urban",
                                                     "suburban",
                                                     "rural"),
                                            labels=c("Urban",
                                                     "Suburban",
                                                     "Rural"))

data$generation = factor(data$generation, levels=c("5G",
                                                     "4G",
                                                     "3G"),
                          labels=c("5G (4x4 MIMO)",
                                   "4G (2x2 MIMO)",
                                   "3G (SISO)"
                                   ))

data$frequency_GHz = factor(data$frequency_GHz,
                            levels=c(0.7, 0.8, 0.9, 1.8, 2.1, 3.5),
                          labels=c("0.7 GHZ",
                                   "0.8 GHZ",
                                   "0.9 GHZ",
                                   "1.8 GHZ",
                                   "2.1 GHZ",
                                   "3.5 GHZ"))

#subset the data for plotting
data = select(data, environment, generation, frequency_GHz, sinr_dB,
              r_distance, spectral_efficiency_bps_hz)

sinr = ggplot(data, aes(x=r_distance/1000,
                        y=sinr_dB,
                        colour=factor(frequency_GHz))) +
  geom_point(size=0.2) +
  geom_smooth(formula=y~x, method='loess', size=.5) +
  scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0)) +
  theme(legend.position="bottom") + guides(colour=guide_legend(ncol=7)) +
  labs(title = '(A) SINR vs User Distance From the Cell Site',
       subtitle = 'Results reported by settlement type and cellular generation',
       x = 'Distance (km)', y='SINR (dB)', colour='Frequency') +
  facet_grid(generation~environment)

spectral_efficiency = ggplot(data, aes(x=r_distance/1000,
                     y=spectral_efficiency_bps_hz,
                     colour=factor(frequency_GHz))) +
  geom_point(size=0.2) +
  geom_smooth(formula=y~x, method='loess', size=.5) +
  scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0)) +
  theme(legend.position="bottom") + guides(colour=guide_legend(ncol=7)) +
  labs(title = '(B) Spectral Efficiency vs User Distance From the Cell Site',
       subtitle = 'Results reported by settlement type and cellular generation',
       x = 'Distance (km)', y='Spectral Efficiency (Bps/Hz)', colour='Frequency') +
  facet_grid(generation~environment)

combined <- ggarrange(sinr, spectral_efficiency,
                      ncol = 1, nrow = 2,
                      common.legend = TRUE,
                      legend='bottom'
                      # heights=c(3.5, 5)
)

path = file.path(folder, 'figures', 'panel.png')
ggsave(path, units="in", width=8, height=10, dpi=300)
print(combined)
dev.off()

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#get path to lut
lut <- read.csv(file.path(folder, 'modulation_and_coding_lut.csv'))

#select variables
lut = select(lut, generation, spectral.efficiency, sinr)

lut$generation = factor(lut$generation, levels=c("5G",
                                                   "4G",
                                                   "3G"),
                         labels=c("5G (4x4 MIMO)",
                                  "4G (2x2 MIMO)",
                                  "3G (SISO)"
                         ))

#plot
spectral_efficiency = ggplot(lut, aes(x=sinr, y=spectral.efficiency,
                 colour=factor(generation))) +
  geom_line() +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0)) +
  theme(legend.position="bottom") + guides(colour=guide_legend(ncol=4)) +
  labs(title = 'Spectral Efficiency vs Signal-to-Interference-plus-Noise Ratio (SINR)',
       subtitle = 'Results reported by for each cellular generation',
       x = 'Signal-to-Interference-plus-Noise Ratio (dB)', y='Bps/Hz', colour='Frequency')

path = file.path(folder, 'figures', 'panel.png')
ggsave(path, units="in", width=7, height=8, dpi=300)
print(spectral_efficiency)
dev.off()


library(filesampler)

system.time({
    x <- sample_csv("big.csv", method="exact", param=15000, verbose=TRUE)
})

system.time({
    x <- sample_csv("big.csv", param=.001, verbose=TRUE)
})


1 -> 4 (0)
0 -> 2 (1)
4 -> 5 (1)
3 -> 5 (2)
2 -> 3 (2)
5 -> 6 (6)
4 -> 7 (8)


#' Observed HIV transmission pairs
#'
#' Counts of directed HIV transmission pairs observed within and between
#' intervention and control communities in the 30-community BCPP/Ya Tsie
#' HIV prevention trial in Botswana (2013-2018). The Botswana -Ya Tsie
#' trial was a pair-matched community randomized trial that evaluated
#' the effect of a universal HIV test and treat intervention in reducing
#' population-level incidence. For further details see references and:
#' \url{https://magosil86.github.io/bumblebee/}.
#'
#' @format A data frame:
#' \describe{
#' 	\item{H1_group}{Name of population group 1}
#' 	\item{H2_group}{Name of population group 1}
#' 	\item{num_linked_pairs_observed}{Number of observed directed transmission pairs between samples from population groups 1 and 2}}
#'
#' @references
#' Magosi LE, et al., Deep-sequence phylogenetics to quantify patterns of
#' HIV transmission in the context of a universal testing and treatment
#' trial – BCPP/ Ya Tsie trial. To submit for publication, 2021.
#'
#'
#' @source \url{https://magosil86.github.io/bumblebee/}
#'
"counts_hiv_transmission_pairs"

#' Sampling fequency
#'
#' Estimated number of individuals with HIV in intervention and control communities
#' of the BCPP/Ya Tsie trial, and the number of individuals sampled from each for
#' HIV viral phylogenetic analysis.
#'
#' @format A data frame:
#' \describe{
#' \item{population_group}{Population group}
#' \item{number_sampled}{Number of individuals sampled per population group}
#' \item{number_population}{Estimated number of individuals in each population group}
#' }
#'
#' @references
#' Magosi LE, et al., Deep-sequence phylogenetics to quantify patterns of
#' HIV transmission in the context of a universal testing and treatment
#' trial – BCPP/ Ya Tsie trial. To submit for publication, 2021.
#'
#' @source \url{https://magosil86.github.io/bumblebee/}
#'
"sampling_frequency"

#' Estimated HIV transmission flows
#'
#' Estimated HIV transmissions within and betweeen intervention and control communities
#' in the BCPP/Ya Tsie trial population adjusted for variability in sampling.
#'
#' @format A data frame:
#' \describe{
#'     \item{H1_group}{Name of population group 1}
#'     \item{H2_group}{Name of population group 2}
#'     \item{number_hosts_sampled_group_1}{Number of individuals sampled from population group 1}
#'     \item{number_hosts_sampled_group_2}{Number of individuals sampled from population group 2}
#'     \item{number_hosts_population_group_1}{Estimated number of individuals in population group 1}
#'     \item{number_hosts_population_group_2}{Estimated number of individuals in population group 2}
#'     \item{max_possible_pairs_in_sample}{Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2}
#'     \item{max_possible_pairs_in_population}{Number of distinct possible transmission pairs between individuals in population groups 1 and 2}
#'     \item{num_linked_pairs_observed}{Number of observed directed transmission pairs between samples from population groups 1 and 2}
#'     \item{p_hat}{Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked}
#'     \item{est_linkedpairs_in_population}{Estimated transmission pairs between population groups 1 and 2}
#'     \item{theta_hat}{Estimated transmission flows or relative probability of transmission within and between population groups 1 and 2 adjusted
#'           for sampling heterogeneity. More precisely, the conditional probability that a pair of pathogen sequences is from a specific population
#'           group pairing given that the pair is linked.}
#'     \item{obs_trm_pairs_est_goodman}{Point estimate, Goodman method Confidence intervals for observed transmission pairs}
#'     \item{obs_trm_pairs_lwr_ci_goodman}{Lower bound of Goodman confidence interval}
#'     \item{obs_trm_pairs_upr_ci_goodman}{Upper bound of Goodman confidence interval}
#'     \item{est_goodman}{Point estimate, Goodman method Confidence intervals for estimated transmission flows}
#'     \item{lwr_ci_goodman}{Lower bound of Goodman confidence interval}
#'     \item{upr_ci_goodman}{Upper bound of Goodman confidence interval}
#'     \item{prob_group_pairing_and_linked}{Probability that a pair of pathogen sequences is from a specific population group pairing and is linked}
#'     \item{c_hat}{Probability that a randomly selected pathogen sequence in one population group links to at least
#'           one pathogen sequence in another population group i.e. probability of clustering}
#'     \item{est_goodman_cc}{Point estimate, Goodman method Confidence intervals with continuity correction}
#'     \item{lwr_ci_goodman_cc}{Lower bound of Goodman confidence interval}
#'     \item{upr_ci_goodman_cc}{Upper bound of Goodman confidence interval}
#'     \item{est_sisonglaz}{Point estimate, Sison-Glaz method Confidence intervals}
#'     \item{lwr_ci_sisonglaz}{Lower bound of Sison-Glaz confidence interval}
#'     \item{upr_ci_sisonglaz}{Upper bound of Sison-Glaz confidence interval}
#'     \item{est_qhurst_acswr}{Point estimate, Queensbury-Hurst method Confidence intervals via ACSWR r package}
#'     \item{lwr_ci_qhurst_acswr}{Lower bound of Queensbury-Hurst confidence interval}
#'     \item{upr_ci_qhurst_acswr}{Upper bound of Queensbury-Hurst confidence interval}
#'     \item{est_qhurst_coinmind}{Point estimate, Queensbury-Hurst method Confidence intervals via CoinMinD r package}
#'     \item{lwr_ci_qhurst_coinmind}{Lower bound of Queensbury-Hurst confidence interval}
#'     \item{upr_ci_qhurst_coinmind}{Upper bound of Queensbury-Hurst confidence interval}
#'     \item{lwr_ci_qhurst_adj_coinmind}{Lower bound of Queensbury-Hurst confidence interval adjusted}
#'     \item{upr_ci_qhurst_adj_coinmind}{Upper bound of Queensbury-Hurst confidence interval adjusted}
#' }
#'
#' @references
#' Magosi LE, et al., Deep-sequence phylogenetics to quantify patterns of
#' HIV transmission in the context of a universal testing and treatment
#' trial – BCPP/ Ya Tsie trial. To submit for publication, 2021.
#'
#' @source \url{https://magosil86.github.io/bumblebee/}
#'
"estimated_hiv_transmission_flows"


setwd("C:\\Users\\Ivan.Liuyanfeng\\Desktop\\Data_Mining_Work_Space\\Afr-Soil-Prediction")
library(e1071); library(caret)

train <- read.csv("Data/training.csv",header=TRUE,stringsAsFactors=FALSE)
test <- read.csv("Data/sorted_test.csv",header=TRUE,stringsAsFactors=FALSE)

submission <- test[,1]

labels <- train[,c("Ca","P","pH","SOC","Sand")]
index <- createDataPartition(y = train$Ca, p=0.8, list=F)

# Exclude CO2
train <- train[,c(2:2655,2671:3579)]
test <- test[,c(2:2655,2671:3579)]

# split
train_train <- train[index,]
train_test <- train[-index,]
labels_train <- labels[index,]
labels_test <- labels[-index,]

svms <- lapply(1:ncol(labels_train),
               function(i)
               {
                 svm(train_train,labels_train[,i],cost=10000,scale=FALSE)
               })
pred_Ca <- predict(svms[[1]], train_train)

predictions <- sapply(svms,predict,newdata=test)

colnames(predictions) <- c("Ca","P","pH","SOC","Sand")
submission <- cbind(PIDN=submission,predictions)

write.csv(submission,"r_first_try.csv",row.names=FALSE,quote=FALSE)


# Auteurs :Philippe Pieri, Benjamin Bois - INRA, Equipe Ecophysiologie et Agronomie Viticole; 71, Rue Edouard Bourlaux B.P. 81, 33 883 VILLENAVE DORNON Cedex- contact : bbois@bordeaux.inra.fr
# Traduction en langage R : Xavier Delpuech, IFV, Domaine de Donadille, 30230 Rodilhan. xavier.delpuech@vignevin.com , février 2012
# Bibliographie
# LEBON, E., DUMAS, V., PIERI, P. and SCHULTZ, H. R., 2003. Modelling the seasonal dynamics of the soil water balance of vineyards. Functional Plant Biology 30 (6).
# RIOU, C., PIERI, P. and CLECH, B. L., 1994. Water use of grapevines well supplied with water. Simplified expression of transpiration. Vitis 33 (3).
# RIOU, C., VALANCOGNE, C. and PIERI, P., 1989. Un modele simple d'interception du rayonnement solaire par la vigne. Verification experimentale. Agronomie 9 (5).
# HARGREAVES, G. H. and SAMANI, Z. A., 1982. Estimating Potential Evapotranspiration. Journal of the Irrigation and Drainage Division 108 p. 223-230.
# HARGREAVES, G. L., HARGREAVES, G. H. and RILEY, J. P., 1985. Agricultural benefits for Senegal River Basin. Journal of Irrigation and Drainage Engineering 111 p. 111-124.
# BRISSON, N., PERRIER, A. (1991) A semi-empirical model of bare soil evaporation for crop simulation models Water Resources Research 27, p.719-727
###
#### sous fonction Radiation_Interception_DI
Radiation_Interception_DI<-function(r_lat=44.5, r_longit=0, i_year=2000, i_doy=183, d_r=1.5, hf_r=1, lf_r=0.4,
az_r=0, poro_r=0.25, alb_f=0.22, alb_s=0.18, Dt=1800, r_rgi=20)
{
#Dt = 1800
#r_lat = latitude    # =44.5
#r_longit = 0
#az_r = azimut # =0   Azimut en degrés (ex: 0=NS ; 90=EW ; -45 = NW-SE )
#d_r = d      # =1.5 Distance inter-rang (en mètres)
#alb_f = 0.22
#alb_s = alb_sol  # =0.18
#i_year = n_an
#i_doy = doy   # par defaut au 1er juillet
#r_rgi = rg    # par defaut = 20
#hf_r = hautf # =1 Hauteur de feuillage (en metres)
#lf_r = largf  # =0.4 Largeur de feuillage (en metres)
#poro_r = poro   # =0.25 Porosite min en ete, de 0 à 1 (0=aucun trou dans le feuillage)

#calculates daily integrals for radiation interception by vine rows and soil in a vineyard
#parameters
rDt = Dt
rLatitude = r_lat
rLongitude = r_longit
iYear = i_year
rOrientRangs = az_r     #à l#entrée :   0 pour rangs NS, 90 pour EW et -45 pour NW-SE
    #ici en entrée, rOrientRangs  en degrés :    ( 0=NS ; 90=EW )  ( -45 = NW-SE )
    #passage direction des rangs à angle de la normale aux rangs avec la direction NS
rOrientRangs = rOrientRangs + 90                            #orientée de N à S
        #If rOrientRangs >= 180 Then rOrientRangs = rOrientRangs - 180     CORRIGE LE 31/03/98 :
if (rOrientRangs >= 90) rOrientRangs = rOrientRangs - 180
#donc angle normale = -90 pour rangs NS, 0 pour EW , 45 pour NW-SE et -45 pour NE-SW
#orientation comme angles d#azimut solaire, à partir du Sud, négatifs le matin et positifs l#après-midi
rEcartRangs = d_r
rHautRang = hf_r
rLargRang = lf_r
rPorosite = poro_r
rAlbedoFeuilles = alb_f
rAlbedoSol = alb_s

 #variables d#entree :
iSimulDay = i_doy
rRgiJour = r_rgi * 1000000               #MJ.m^-2  à  J.m^-2

# *****************************************  DEBUT  JOURNEE  ***************************************

rSJRytGlo = 0           #intialisation des intégrales journalières Rayonnement
rSJRytDif = 0
rSJRytGloVigne = 0
rSJRytGloSol = 0
rSJAlbedoVignoble = 0
rSJRgvRel = 0
rSJRgsRel = 0

iSJtot = 0                              #compteurs
iSJdiurne = 0

# *****************************************  DEBUT CALCULS  ***************************************

#    Call ParSolAnn((iYear))                 #sous programmes astronomiques annuel et journaliers
# ParSolAnn(ian) # ian as integer
#         CALCUL DES PARAMETRES SOLAIRES ANNUELS
#
#           rOmegaRadparJour, vitesse de la Terre (radian)  (par jour)              integer
#           rDoyEqui, date equinoxe (jour)
#           rLongitPerigRad, longitude perigee (radian)
#           rExentr, excentricite
#           rDoyPerig, date perigee (jour)
#           rEpsilonRad, obliquite(radian)
#
## ian=à définir
ian=iYear
rOmegaRadparJour = 2 * pi / 365.25636
rDoyEqui = 80.08 + 0.2422 * (ian - 1900) - trunc((ian - 1901) / 4)
rLongitPerigRad = -1.374953 + 0.000300051 * (ian - 1900)
rExentr = 0.016751 - 0.00000042 * (ian - 1900)
rDoyPerig = rDoyEqui + (rLongitPerigRad - 2 * rExentr * sin(rLongitPerigRad)) / rOmegaRadparJour
rEpsilonRad = 0.40932 - 0.000002271 * (ian - 1900)
ian = 1

#    Call ParSolJour((iYear), (iSimulDay)) # remplacé par le sous-programme lui-même
#ParSolJour(ian As Integer, iNJ As Integer)
#   Calcul de la LONGITUDE CELESTE, de la DECLINAISON du Soleil
#      (radians), de l'EQUATION du TEMPS (minutes) pour le jour iNJ de
#      de l'annee iAn.

#   ATTENTION
#        Ce SOUS-PROGRAMME ne peut etre executé qu'apres le SOUS-PRO-
#        GRAMME  PSOLAN(iAn, ...) qui definit les parametres solaires annuels
#
#      COMMON /PARAN/rOmegaRadparJour,rDoyEqui,rLongitPerigRad,rExentr,rDoyPerig,rEpsilonRad
#      COMMON /PARJOU/rLongitCelesteRad,rDeltaRad,rEquaTemps
ian=iYear
iNJ=iSimulDay
rNJ = iNJ + 0.5
#   LONGITUDE CELESTE du Soleil     (radians)
rLongitCelesteRad = rLongitPerigRad + rOmegaRadparJour * (rNJ - rDoyPerig) + 2 * rExentr * sin(rOmegaRadparJour * (rNJ - rDoyPerig))
#   DECLINAISON du Soleil           (radians)
rDeltaRad = asin(sin(rLongitCelesteRad) * sin(rEpsilonRad))
#   EQUATION DU TEMPS               (minutes)
rEquaTemps = 720 / pi * (atan(tan(rLongitCelesteRad) * cos(rEpsilonRad)) - rOmegaRadparJour * (rNJ - rDoyPerig) - rLongitPerigRad)
while (rEquaTemps <= -100) (rEquaTemps = rEquaTemps + 720)
### fin sous-programme

# Call ParSolJourBis((iYear), (iSimulDay)) # remplacé par le sous-programme lui-même
# ParSolJourBis(ian As Integer, iNJ As Integer)
#   Calcul de l'HEURE de PASSAGE du Soleil au MERIDIEN, de l'HEURE du
#      LEVER et du COUCHER du Soleil (h TU), de la DUREE du JOUR (h)
#
#   Calcul du RAYONNEMENT GLOBAL EXTRATERRESTRE (Joule.m-2). On a admis
#      une valeur de la constante solaire de 1353 watt.m-2
#
#   Pour passer à l'heure legale, ajouter le décalage par rapport a l'heure TU
#   (ex.: en FRANCE, +1h ou +2h selon la periode de l'annee, en GUADELOUPE, -4h, etc...)
#
#   ATTENTION
#        Avant d'utiliser ce SOUS PROGRAMME, il est indispensable
#        d'executer dans l'ordre les SOUS PROGRAMMES:
#            PSOLAN(iAn) pour definir les parametres annuels
#            PSOLJ(NJ) pour definir les parametres journaliers
#        Il faut aussi preciser le lieu en définissant
#
#Dim rNJ, rLatRad, rRefrac, X, a, b, C                               As Double
#Global rHrMidi, rDurJour, rHrLevSol, rHrCouSol, rRytGloExtraAtmJour        As Double
ian=iYear
iNJ=iSimulDay
rNJ = iNJ + 0.5
rLatRad = rLatitude * pi / 180

#HEURE DE PASSAGE du Soleil  au MERIDIEN
rHrMidi = 12 + rLongitude / 15 + rEquaTemps / 60

#Durée du jour, avec rRefrac, Correction de réfraction atmosphérique
rRefrac = -0.0106
if (abs(rLatitude)== 90) X=(rLatRad * (rRefrac - rDeltaRad) * 1000000) else X=(sin(rRefrac) - sin(rLatRad) * sin(rDeltaRad)) / cos(rLatRad) / cos(rDeltaRad)
if (X==0) rDurJour = 12
if (X<=(-1))rDurJour = 24
if (X>(-1)&(X<0)) rDurJour = 24 * (1 + atan((1 - X * X)^0.5 / X) / pi)
if (X>=1) rDurJour = 0
if ((X>0)&(X<1)) rDurJour = 24 * atan((1 - X * X)^0.5 / X) / pi

#HEURES de LEVER et de COUCHER du Soleil
rHrLevSol = rHrMidi - rDurJour / 2
rHrCouSol = rHrMidi + rDurJour / 2

#RAYONNEMENT GLOBAL EXTRATERRESTRE journalier
X = abs(rLatRad + rDeltaRad)
if (rLatRad==0) {a=cos(rDeltaRad)
    }else {if (rDeltaRad==0) {a=cos(rLatRad)
          }else {if (X>pi/2) {b = pi
                             a = b * sin(rLatRad) * sin(rDeltaRad)
                }else {if (abs(rDeltaRad-rLatRad)>pi/2) {a=0
                      }else {
                            C = (1 - (sin(rLatRad) * sin(rLatRad) + sin(rDeltaRad) * sin(rDeltaRad)))^0.5 / sin(rLatRad) / sin(rDeltaRad)
                            b = C + atan(-C)
                            if (rLatRad * rDeltaRad > 0) {b=b+pi}else{}
                            a = b * sin(rLatRad) * sin(rDeltaRad)
                            }
                      }
                }
          }
rRytGloExtraAtmJour = 37210000 * (1 + 0.033 * cos(rOmegaRadparJour * (rNJ - rDoyPerig))) * a
### fin sous-programme

if (rRytGloExtraAtmJour <= 0) print("rRytGloExtraAtmJour <= 0")

if (rHautRang>0) {  #********************  DEBUT BOUCLE rHautRang > 0  ***********************************
                    #MsgBox "rLAI >0  := " & rLAI & snl() & "jour et heure = " & iSimulDay & "  ,  " & rHr

rLatRad = rLatitude * pi / 180               #Latitude en radians
rOrientRangsRad = rOrientRangs * pi / 180    #Où rOrientRangs = ANGLE NORMALE AU RANG AVEC DIRECTION NORD-->SUD (DEGRES)

                             #Début Appel Sous-Programmes Rayonnement
#       Sub AbsDiffus()
#       ex-subroutine KDIFFU(rKdif, rKdifSol, imodel)
#       Calcul des coefficients d'interception du rayonnement diffus :
#       rKdif,  rayonnement venant du ciel et rKdifSol, rayonnement venant du sol
#       1 variante : mur poreux sauf haut et bas, ex. Vigne  (issu de MODELM.FOR)
#  c    porosité du feuillage rPorosite
#      common /ccultu/rEcartRangs,rHautTotMax,rHautRang,rLargRang,rOrientRangs,rAlbedoFeuilles,rAlbedoSol,rPorosite
#Dim rKDIF1, rKDIF2, rKDIF3  As Double          DECLARE en GLOBAL

# ... fraction du rayonnement diffus intercepté par la masse foliaire de la vigne
        #par les parties supérieures des rangs (horizontales et non poreuses)
        rKDIF1 = rLargRang / rEcartRangs
        #facteur de forme entre 2 rangs voisins : auparavant dans sub Calcul_PAR()
        rFF0 = tan(0.5 * atan(rHautRang / (rEcartRangs - rLargRang)))
        #facteur de forme entre les parois horizontales entre les rangs, supérieure et inférieure.
        rFFdif = tan(0.5 * atan((rEcartRangs - rLargRang) / rHautRang))
        #par les parois verticales (d'abord supposées non poreuses)                 'eq 16 de Riou et al., 1989
        rKDIF2 = (1 - rFFdif)
        rKDIF2 = rKDIF2 * (1 - rLargRang / rEcartRangs)
        #par les parties inférieures des rangs (horizontales et non poreuses)       'eq 20 de Riou et al., 1989
        rKDIF3 = (sin(0.5 * atan(2 * rHautRang / rLargRang))) ^ 2
        rKDIF3 = rKDIF3 - (sin(0.5 * atan(rHautRang / (rEcartRangs - rLargRang / 2)))) ^ 2
        rKDIF3 = rKDIF3 * 2 * rLargRang / rEcartRangs
        rKdif = rKDIF1 + (1 - rPorosite) * rKDIF2 + rPorosite * rKDIF3              #eq 21 de Riou et al., 1989
        rKdifSol = rKdif
##### fin

# Sub CoefAbsRytDiff()
#       ex-subroutine ARDIF (rKdif,rKdifSol,cardif,crrdif)
#       calcul des taux d'absorption (cardif) et de réflexion (crrdif) du rayt.diffus
#       common /ccultu/rEcartRangs,rHautTotMax,rHautMax,rLargMax,rOrientRangs,rAlbedoFeuilles,rAlbedoSol,rPorositeMin
rCardif = (1 - rAlbedoFeuilles) * ((1 - rAlbedoSol * rKdifSol) * rKdif + rAlbedoSol * rKdifSol)
rCrrdif = (rAlbedoFeuilles - rAlbedoSol * (1 - rKdifSol) - rAlbedoFeuilles * rAlbedoSol * rKdifSol / 2) * rKdif
rCrrdif = rCrrdif + (rAlbedoSol * (1 - rKdifSol) + rAlbedoFeuilles * rAlbedoSol * rKdifSol / 2)
# fin sub

#            Sub PosGeomLim()
#       Positions Géométriques Limites
#       ex-subroutine cbetal(rBetaLim, nbetal, imodel)
#       interception du Rayonnement Solaire Direct
#       calcul des nbetal valeurs de rBetaLim(),
#       rapports correspondant a des positions caracteristiques limites
#       (composante Horizontale du Rayt DIRECT sur composante Verticale)
      rBetaLim_1 = rLargRang / rHautRang
      rBetaLim_2 = (rEcartRangs - rLargRang) / rHautRang
      rBetaLim_3 = rEcartRangs / rHautRang
      rBetaLim_4 = (rEcartRangs + rLargRang) / rHautRang
      rBetaLim_5 = (2 * rEcartRangs - rLargRang) / rHautRang
      rBetaLim_6 = (2 * rEcartRangs) / rHautRang
      rBetaLim_7 = (3 * rEcartRangs) / rHautRang
# End Sub

   # premier indice pour boucle horaire :
   #(le temps rTempsTUFirst lu dans data_H doit être en heures TU decimales et centrées)
   j = 0                                                        #calculs à partir de 0 h

# *****************************************  DEBUT BOUCLE HORAIRE  ***************************************
   repeat
   {
   if (j >= trunc(24 / (rDt / 3600))) break()

    rHr = rDt / 3600 / 2 + j * rDt / 3600

    #MsgBox "jour et heure = " & iSimulDay & "  ,  " & rHr

# sous-programme        ParSolHor((rHr))                #paramètre rHr = Heure TU (h)
### ParSolHor
#      Calcul des rHautSol et rAzimSol du Soleil (degres) à l#heure rHr (en h TU)
#      du jour iNJ de l#annee iAn pour un lieu de Latitude rLatitude, de
#      Longitude rLongitude (degres), d#équation du temps rEquaTemps (minutes),
#      et de déclinaison du Soleil rDeltaRad (radians)
#
#      ATTENTION
#        Avant l#utilisation de ce SOUS-PROGRAMME, il faut avoir executé
#      les SOUS-PROGRAMMES ParSolAnn(iAn%) et ParSolJour(iNJ%, iAn%)
#        Il faut avoir precisé le lieu par sa rLatitude et sa rLongitude (degres)
#
rLatRad = rLatitude * pi / 180
# ... Calcul Heure en Temps Solaire Vrai, rHrTSV et Angle Horaire (radians), rHrRad
rHrTSV = rHr - 12 - rLongitude / 15 - rEquaTemps / 60
rHrRad = rHrTSV * pi / 12
# ... Calcul de la HAUTEUR du Soleil
X = sin(rLatRad) * sin(rDeltaRad) + cos(rLatRad) * cos(rDeltaRad) * cos(rHrRad)
if (X < 0) rHautSol = 0  #-99.9                    #le Soleil n#est pas levé
rHautSol=ifelse ((X==1), 90, asin(X) * 180 / pi)          # XD : vérifier les radians
# ... Calcul de l'AZIMUT du Soleil
#        codage signe: Nord    -180°
#                      Est      -90°
#                      Sud        0°
#                      Ouest     90°
#                      Nord     180°
#
X = sin(rLatRad) * cos(rHrRad) - cos(rLatRad) * tan(rDeltaRad)
if (X==0) {
b=90
a=0
          } else { if (X<0) {
                            b =180
                            } else { b=0
                            }
                   a = atan(sin(rHrRad) / X) * 180 / pi
          }

if (rHrRad==0) {
rAzimSol = 0
  }else{ if(rHrRad < 0) {
       rAzimSol = a - b
       }else{ rAzimSol = a + b
       }
  }
# fin sous-programme  ParSolHor

rHeureTSV = rHr - rLongitude / 15 - rEquaTemps / 60   #temps solaire vrai (h)
rAHDeg = (rHeureTSV - 12) * 15                        #angle horaire  (degrés)
rAHRad = rAHDeg * pi / 180                          #angle horaire  (radians)
rHautSolRad = rHautSol * pi / 180                   #hauteur soleil (radians)
rAzimSolRad = rAzimSol * pi / 180                   #azimut soleil (radians)

iSJtot = iSJtot + 1                   #compteur jour

            #Microclimat_Feuilles                         #MsgBox "Microclimat_Feuilles  Terminé"

            #rSJTleaf = rSJTleaf + rTleaf                #mise à jour des intégrales journalières microclimat
            #rSJDefSat = rSJDefSat + rDefSat

if (rHautSol>0) {        #DEBUT TEST rHautSol > 0  pour partie Ryt Solaire
#rSJTleafDiurne = rSJTleafDiurne + rTleaf    #mise à jour des intégrales journ. microclimat periode diurne
#rSJDefSatDiurne = rSJDefSatDiurne + rDefSat
iSJdiurne = iSJdiurne + 1                   #compteur periode diurne
r = 1353 * (1 + 2 * rExentr * cos(rOmegaRadparJour * iSimulDay + 0.5 - rDoyPerig))
rRytGloExtraAtm = r * sin(rHautSol * pi / 180)
#If bOption11 = False Then
rRytGlo = rRytGloExtraAtm * rRgiJour / rRytGloExtraAtmJour
#End If

                if (rRytGloExtraAtm>0) {             #Début calcul Rayonnement Diffus
                    GSG0 = rRytGlo / rRytGloExtraAtm
                    }else{GSG0 = 0
                    }

                #DSG = 1.09 - 2.6896 * GSG0 * GSG0 + 1.2843 * GSG0 * GSG0 * GSG0   # relation journalière à Bordeaux (CV)
                DSG = 1.09 - 2.44 * GSG0 * GSG0 + 1.084 * GSG0 * GSG0 * GSG0   # relation horaire à Bordeaux (CV)

                if (DSG>1) DSG = 1
                if (GSG0 >= 0.2) {
                    rRytDif = rRytGlo * DSG
                    rRytDir = rRytGlo - rRytDif
                } else {
                    rRytDif = rRytGlo
                    rRytDir = 0
                }

                if (rRytDif < 0) rRytDif = 0
                if (rRytDir < 0) rRytDir = 0

        # ... rapport composante horizontale (--> paroi verticale)
        # ... / composante verticale (--> paroi horizontale) du Ryt Direct (RDIR)
                rBeta1 = cos(rOrientRangsRad) * tan(rLatRad)
                rBeta2 = sin(rDeltaRad) * cos(rOrientRangsRad) / (sin(rHautSolRad) * cos(rLatRad))
                rBeta3 = sin(rOrientRangsRad) * cos(rDeltaRad) * sin(rAHRad) / sin(rHautSolRad)
                rBeta = abs(rBeta1 - rBeta2 + rBeta3)

# Sub AbsDirect()
#       ex-subroutine kdirec(rBetaLim, nbetal, imodel, rKdir, rBeta)
#       interception du Rayonnement Solaire Direct par le feuillage
#       rBetaLim() rapports correspondant a des valeurs caracteristiques de rBeta
#       rBeta = rapport composante Horizontale du Rayt DIRECT / composante Verticale

    if (rBeta > rBetaLim_1) {
        if (rBeta > rBetaLim_2) {
            if (rBeta > rBetaLim_3) {
                if (rBeta > rBetaLim_4) {
                    if (rBeta > rBetaLim_5) {
                        if (rBeta > rBetaLim_6) {
                            if (rBeta >= rBetaLim_7) {
                                rKdir = (rEcartRangs - rPorosite * rPorosite * rPorosite * (rEcartRangs - rLargRang)) / rEcartRangs
                            }else{
                                rKdir = (rEcartRangs - rPorosite * rPorosite * (rEcartRangs - rLargRang) + rPorosite * rPorosite * (1 - rPorosite) * (rBeta * rHautRang - 2 * rEcartRangs - rLargRang)) / rEcartRangs
                            }
                        }else{
                            rKdir = (rEcartRangs - rPorosite * rPorosite * (rBeta * rHautRang - rEcartRangs - rLargRang)) / rEcartRangs
                        }
                    }else{
                        rKdir = (rEcartRangs - rPorosite * (2 * rEcartRangs - rLargRang - rBeta * rHautRang) - rPorosite * rPorosite * (rBeta * rHautRang - rEcartRangs - rLargRang)) / rEcartRangs
                    }
                }else{
                    rKdir = (rEcartRangs - rPorosite * (2 * rEcartRangs - rLargRang - rBeta * rHautRang)) / rEcartRangs
                }
            }else{
                rKdir = (rEcartRangs - rPorosite * (rBeta * rHautRang - rLargRang)) / rEcartRangs
            }
         }else{
            rKdir = ((rBeta * rHautRang + rLargRang) - rPorosite * (rBeta * rHautRang - rLargRang)) / rEcartRangs
         }
    }else{
        rKdir = ((rBeta * rHautRang + rLargRang) / rEcartRangs)
    }
#End Sub

#Sub CoefAbsRytDir()
#       ex-subroutine ARDIR(rKdifSol, rKdir, cardir, crrdir)
#       calcul des taux d'absorption (cardir) et de de réflexion (crrdir) du rayt. direct
rCardir = (1 - rAlbedoFeuilles) * ((1 - rAlbedoSol * rKdifSol) * rKdir + rAlbedoSol * rKdifSol)
rCrrdir = (rAlbedoFeuilles - rAlbedoSol * (1 - rKdifSol) - rAlbedoFeuilles * rAlbedoSol * rKdifSol / 2) * rKdir
rCrrdir = rCrrdir + (rAlbedoSol * (1 - rKdifSol) + rAlbedoFeuilles * rAlbedoSol * rKdifSol / 2)
#End Sub

        }else{                #SUITE TEST rHautSol > 0 donc ici #If rHautSol <= 0
            rHautSol = 0            #pour partie ryt sol
            rAzimSol = 0
            rRytGloExtraAtm = 0
            rRytGlo = 0
            rRytDir = 0
            rRytDif = 0
            rCardir = 0
            rCrrdir = 0
            rBeta = 0
       }              #FIN TEST rHautSol > 0  pour partie Ryt Solaire

        rRytGloVigne = rCardir * rRytDir + rCardif * rRytDif
        rRytGloSol = (1 - rCardir - rCrrdir) * rRytDir + (1 - rCardif - rCrrdif) * rRytDif

        if (rRytGlo > 0) {
            rAlbedoVignoble = (rCrrdir * rRytDir + rCrrdif * rRytDif) / rRytGlo
            rRgvRel = rRytGloVigne / ((1 - rAlbedoVignoble) * rRytGlo)
            rRgsRel = rRytGloSol / ((1 - rAlbedoVignoble) * rRytGlo)
            }
        if (rRytGlo <= 0) {
            rAlbedoVignoble = 0
            rRgvRel = 0
            rRgsRel = 0
            }

        rSJRytGlo = rSJRytGlo + rRytGlo * rDt                 #Mise à Jour des Intégrales Journalières / Rayonnement
        rSJRytDif = rSJRytDif + rRytDif * rDt
        rSJRytGloVigne = rSJRytGloVigne + rRytGloVigne * rDt
        rSJRytGloSol = rSJRytGloSol + rRytGloSol * rDt

    j = j + 1
    }             #FIN BOUCLE HORAIRE commencee par : Do While (j < CInt(24 / (rDt / 3600)))

    # ------------------------------  mise à jour des intégrales journalières (rSJ...)  ---------------------
    #                                 et sur toute la duree du fichier d#entree (rSom...)

        if (rSJRytGlo>0){
        rSJAlbedoVignoble = 1 - (rSJRytGloVigne + rSJRytGloSol) / rSJRytGlo     #ratios journaliers / Rayonnement
        rSJRgvRel = rSJRytGloVigne / ((1 - rSJAlbedoVignoble) * rSJRytGlo)
        rSJRgsRel = rSJRytGloSol / ((1 - rSJAlbedoVignoble) * rSJRytGlo)
        }

}       #fin boucle if rHautRang > 0  (realisation calculs int ryt dans boucle horaire)

    # ------------------------------  sorties journalières  ------------------------------------
    #                           (intégrales sur la durée de la journée)
sor_ryt=data.frame(c(1:25))
sor_ryt[1,1]= iSimulDay
sor_ryt[2,1]= iYear
sor_ryt[3,1]= rLatitude
sor_ryt[4,1]= rHrLevSol
sor_ryt[5,1]= rHrCouSol
sor_ryt[6,1]= rDurJour
sor_ryt[7,1]= rRytGloExtraAtmJour / 1000000
sor_ryt[8,1]= rRgiJour / 1000000

        if (rHautRang>0){   #donc si realisation calculs int ryt (et event. photos.) dans boucle horaire
            sor_ryt[9,1] = rEcartRangs
            sor_ryt[10,1] = az_r     #comme en entrée :   0 pour rangs NS, 90 pour EW et -45 pour NW-SE
            sor_ryt[11,1] = rHautRang
            sor_ryt[12,1] = rLargRang
            sor_ryt[13,1] = rPorosite
            sor_ryt[14,1] = rPorosite
            sor_ryt[15,1] = tan(0.5 * atan(rHautRang / (rEcartRangs - rLargRang)))     #Fact de Forme entre 2 rangs

            sor_ryt[16,1] = rSJRytGlo / 1000000
            sor_ryt[17,1] = (rSJRytGlo - rSJRytDif) / 1000000
            sor_ryt[18,1] = rSJRytDif / 1000000
            sor_ryt[19,1] = rSJRytGloVigne / 1000000
            sor_ryt[20,1] = rSJRytGloSol / 1000000
            sor_ryt[21,1] = rSJAlbedoVignoble
            sor_ryt[22,1] = rSJRgvRel
            sor_ryt[23,1] = rSJRgsRel
            sor_ryt[24,1] = iSJdiurne #nb d#intervalles utilisés pour calculer les integrales SJ (jour entier)
            sor_ryt[25,1] = iSJtot     #nb d#intervalles utilisés pour calculer les integrales SJ (per. diurne)
        }else{
            for (i in 9:25) {
                sor_ryt[i,1] = 0
                 }
        }      #FIN TEST   If rHautRang > 0 Then
                                #(=test si realisation effective des calculs d#int ryt dans boucle horaire)

#résultats journaliers :
    #Cells(i_ligne, 49).Value = sor_ryt(21)                              #alb
    #Cells(i_ligne, 50).Value = sor_ryt(22)                              #k_rgv
return(sor_ryt[22,1])    # retourne en sortie le kmax de la vigne
} # fin de la fonction  Radiation_Interception_DI


## function for plotting GWAS results, default filter is MAF 5%, to change for MAC filter change maf_or_mac to a different value then 1

plot_gwas<-function(output,h=8,maf_or_mac=1,maf=0.05,mac=NA,black=TRUE,colSet='Dark2',thres=NA,max.y=NA,show=NA,lower.limit=0.01,title=TRUE,name=NA) {
 colnames(output)[h]<-'Plot'
if(maf_or_mac==1) {
mafi=paste('maf',maf)
new_<-subset(output,output$MAF>=maf&output$Plot<lower.limit)
if (is.na(thres)==TRUE) {thres<--log10(0.05/nrow(subset(output,output$MAF>=maf)))}

if (is.na(mac)==FALSE) {cat ('MAF Filter of',maf,' have been used, for MAC set maf_or_mac to 2','\n')}}
 else {
mafi<-paste('mac',mac)
new_<-subset(output,output$MAC>=mac&output$Plot<lower.limit)
if (is.na(thres)==TRUE) {thres<--log10(0.05/nrow(subset(output,output$MAC>=mac)))}}

if(is.na(max.y)==TRUE) {
max.y<-ceiling(-log10(min(new_[,h]))+1)}

output_<-new_[order(new_$Pos),]
output_ok<-output_[order(output_$Chr),]

maxpos<-c(0,cumsum(aggregate(output_ok$Pos,list(output_ok$Chr),max)$x+max(cumsum(aggregate(output_ok$Pos,list(output_ok$Chr),max)$x))/100))
if(black==TRUE) {
plot_col<-rep(c('gray10','gray60'),ceiling(max(unique(output_ok$Chr))/2))
} else {
require(RColorBrewer)
colorCount = length(unique(output_ok$Chr))
getPalette = colorRampPalette(brewer.pal(colorCount,colSet))

plot_col<-getPalette(colorCount)}
size<-aggregate(output_ok$Pos,list(output_ok$Chr),length)$x

a<-rep(maxpos[1],size[1])
b<-rep(plot_col[1],size[1])
for (i in 2:max(unique(output_ok$Chr))){
a<-c(a,rep(maxpos[i],size[i]))
b<-c(b,rep(plot_col[i],size[i]))}

output_ok$xpos<-output_ok$Pos+a
output_ok$col<-b

d<-(aggregate(output_ok$xpos,list(output_ok$Chr),min)$x+aggregate(output_ok$xpos,list(output_ok$Chr),max)$x)/2

plot(output_ok$xpos,-log10(output_ok$Plot),col=output_ok$col,pch=16,ylab='-log10(pval)',xaxt='n',xlab='chromosome',axes=FALSE,cex=1.2,ylim=c(-log10(lower.limit),max.y))
axis(1,tick=FALSE,at=d,labels=c(1:max(unique(output_ok$Chr))))
axis(2,lwd=2)
abline(h=thres,lty=9,col='black',lwd=2)
if(title==TRUE) {
title(main=name)}
if(is.character(show)==TRUE) {
poso<-list()
for (z in 1:length(show)) {
poso[[z]]<-tair9[which(tair9[,3]==show[[z]]),1]+maxpos[tair9[which(tair9[,3]==show[[z]]),4]]}
abline(v=poso,lty=2,col=2)}

}

qq_plot<-function(output,h=8,farbe='red',max.y=NA,maf=0.05,sex=2,main='') {
colnames(output)[h]<-'Plot'
out_<-subset(output,output$MAF>maf)

out<-subset(output,output$MAF>maf&output$Plot<0.05)

e<--log10(ppoints(nrow(out_)))[1:nrow(out)]
o<--log10(sort(out$Plot))
if(is.na(max.y)==T) {
max.y<-ceiling(max(unlist(o)))+1}

plot(e,o,type='l',col=farbe,xlab=expression(Expected~~-log[10](italic(p))), ylab=expression(Observed~~-log[10](italic(p))),xlim=c(0,max(e)+1),ylim=c(0,max.y),lwd=sex,axes=FALSE)
abline(0,1,col="dark grey")
axis(1,lwd=2)
axis(2,lwd=2)
title(main=main)
}

## set parameters
#high=T
local_plot<-
function(output,h=8,chr=0,pos=0,rank=1,high=FALSE,maf=0.05,window_size=50,cex=1,cex.c=2,thres=8){
colnames(output)[h]<-'Plot'
new_<-subset(output,output$MAF>maf)
colnames(new_)[2]<-'chromosomes'
jet.colors = colorRampPalette(c("black", "black", "black", "blue",
"#7FFF7F", "yellow", "#FF7F00", "red"))

### or provide a specific SNP
if (chr!=0) {
z<-which(new_[order(new_[,h]),2]==chr& new_[order(new_[,h]),3]==pos)
} else {z<-rank}

wind<-window_size*1000
a<-new_[order(new_[,h]),][z,2]
b<-new_[order(new_[,h]),][z,3]-wind
c<-b+2*wind
stopifnot(new_[order(new_[,h]),][z,h]<0.01)
localo <- subset(new_,chromosomes==a&Pos>b&Pos<c&Plot<0.01)

vu<--log10(min(localo[,h]))+2

xx<-X_ok[,colnames(X_ok)%in%localo$SNP]
snp_mean<-apply(xx,2,mean)
snp_sd<-apply(xx,2,sd)
snpm<-matrix(nrow=nrow(xx),ncol=ncol(xx),data=snp_mean,byrow=T)
snpd<-matrix(nrow=nrow(xx),ncol=ncol(xx),data=snp_sd,byrow=T)
xx_stand<-(xx-snpm)/snpd
r2<-(crossprod(xx_stand,xx_stand)/nrow(xx))^2

r2<<-r2/r2[1,1]

if(high==TRUE) {
lead_snp<-as.character(localo[which(localo[,h]==min(localo[,h])),1][1])

} else { lead_snp<-new_[order(new_[,h]),][z,1]}

ld<-r2[rownames(r2)%in%lead_snp,]

ld_col<-jet.colors(21)[round(ld*20)+1]

plot(localo[,3],-log10(localo[,h]),type='p',pch=19,xlab='',ylab='-log(p)',col=ld_col,ylim=c(2,vu),xlim=c(b,c),axes=FALSE,cex=cex)
par(new=T)
plot(localo[which(localo[,1]%in%lead_snp),3],-log10(localo[which(localo[,1]%in%lead_snp),h]),type='p',pch=18,xlab='',ylab='-log(p)',ylim=c(2,vu),cex=cex.c,col='red',xlim=c(b,c),axes=FALSE,main=localo[which(localo[,1]%in%lead_snp),1])
abline(h=thres,lty=2,lwd=2)
#abline(h=-log10(0.05/ncol(X_ok)),lty=2,lwd=2)
axis(1,lwd=2)
axis(2,lwd=2)

}

### plot color scale
color.scale<-function(x){
jet.colors = colorRampPalette(c("black", "black", "black", "blue",
"#7FFF7F", "yellow", "#FF7F00", "red"))

#hallo<-c(0,0,0.1,0.1,0.2,0.2,0.3,0.3,0.4,0.4,0.5,0.5,0.6,0.6,0.7,0.7,0.8,0.8,0.9,0.9,1,1)
plot(1,1,col='white',xlim=c(0,2),ylim=c(0,1),xlab='',ylab='',axes=FALSE)
axis(4,lwd=4)

for(z in 1:x) {
 rect(0.9,(0+((z-1)/x)),1.1,(0+((z)/x)),col=jet.colors(x)[z],border='gray')
 par(new=TRUE)}
# if( z %% 2 !=0) {text(c,(+((z-1)/5)),hallo[z])}}
 #text(c,(2+((z)/5)),hallo[21])
}


library(ggplot2)
library(scales)
library(ggthemes)
# fig 1

set.seed(42)
demog_data_camcan <- data.frame(
    age = c(rgamma(300, 90, 2), rgamma(320, 100, 2)),
    gender = c(rep("F", 300), rep("M", 320)),
    dataset = "cam-can"
)
demog_data_tuab <- data.frame(
    age = c(rgamma(700, 100, 2), rgamma(639, 95, 2)),
    gender = c(rep("F", 700), rep("M", 639)),
    dataset = "tuab"
)
demog_data_lemon <- data.frame(
    age = c(rgamma(90, 105, 2), rgamma(100, 100, 2)),
    gender = c(rep("F", 90), rep("M", 100)),
    dataset = "lemon"
)
demog_data_chpb <- data.frame(
    age = c(rgamma(120, 95, 2), rgamma(130, 105, 2)),
    gender = c(rep("F", 120), rep("M", 130)),
    dataset = "chbp"
)

demog_data <- rbind(
  demog_data_camcan, demog_data_tuab, demog_data_lemon, demog_data_chpb)

ggplot(
  aes(x = age, color = gender, fill = gender),
      data = demog_data) +
  geom_density(alpha=0.4, size=1) +
  facet_wrap(.~dataset, ncol=2) +
  theme_minimal(base_size = 16) +
  scale_color_colorblind() +
  scale_fill_colorblind() +
  labs(x="Age [years]", y="Density")

ggsave("demographic_hypothesis.png", dpi=150, height = 6, width = 8)

out_grid <- expand.grid(
    data = c("tuab", "chbp", "lemon", "cam-can"),
    benchmarks = c("dummy", "hand-crafted", "cov-riemann", "cov-mne",
                   "deep")
)
expected_mae <- expand.grid(
    data_delta = c(0.5, -2, -1, 1),
    bench_mu = c(16, 10, 8.3, 7.5, 8.7)
)

expected_mae_cv <- cbind(out_grid, expected_mae)

CV <- 10
expected_mae_cv <- do.call(
  rbind,
  lapply(
    seq(nrow(expected_mae_cv)),
        function(ii){
          this_res <- expected_mae_cv[ii,]
          data.frame(data=this_res$data,
                     benchmark=this_res$benchmarks,
                     fold=seq(CV),
                     MAE=rgamma(
                       CV, (this_res$bench_mu + this_res$data_delta) * 2, 2))
}))

ggplot(
  aes(x = MAE, y = interaction(rev(benchmark), data), color = benchmark,
      fill = benchmark,
      shape = data) ,
  data = expected_mae_cv) +
  geom_jitter() +
  geom_boxplot(alpha=0.1) +
  theme_minimal(base_size = 16) +
  scale_color_colorblind() +
  scale_fill_colorblind() +
  scale_y_discrete(
    labels = rep(rev(c("dummy", "hand-crafted", "cov-riemann", "cov-mne",
                       "deep")), times = 5)) +
  theme(legend.position = c(.9, .5)) +
  labs(y = element_blank(), x = "age prediction MAE [10-fold CV]")

ggsave("benchmark_hypothesis.png", dpi=150, height = 6, width = 8)


#' sum
#'
#' Sums the elements of a shaq.
#'
#' @details
#' Combinations of shaq and numeric matrices/vectors can be used, so long as the
#' first item is always a shaq.
#'
#' @section Communication:
#' Communication consists of a an allreduce on a single value.
#'
#' @param x
#' A shaq.
#' @param ...
#' Additionaly elements (shaqs or numeric vectors/matrices) to sum.  Regular
#' vectors/matrices are assumed to be global, but will only be included to the
#' sum on rank 0.
#' @param na.rm
#' should NA's be removed?
#'
#' @return
#' A single value.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' sum(x)
#' sum(x, 1)
#'
#' finalize()
#' }
#'
#' @name sum
#' @rdname sum
NULL

summer = function(x, na.rm)
{
  if (is.shaq(x))
    sum(DATA(x), na.rm=na.rm)
  else
  {
    if (comm.rank() == 0)
      sum(x, na.rm=na.rm)
    else
      0
  }
}

sum.shaq = function(x, ..., na.rm=FALSE)
{
  additional = list(...)
  if (length(additional) > 0)
  {
    s = sum(sapply(additional, summer, na.rm=na.rm))
  }
  else
    s = 0

  if (is.na(s))
    pbdMPI::allreduce(s)
  else
  {
    local = sum(DATA(x), na.rm=na.rm) + s
    pbdMPI::allreduce(local)
  }
}

#' @rdname sum
#' @export
setMethod("sum", signature(x="shaq"), sum.shaq)


add_raster_4way_legend <- function(labs = letters[1:4], limits = c(0.25, 0.5, 0.75),
                                   nx = ny * 12.5, ny = 200, ...) {

    limits5 = c(0, limits, 1)
    add_3way <- function(i, xpos) {
        out = add_raster_3way_legend_for_4way(legend, xpos = xpos, limits = limits, hash = i, ...)

        #text(x = mean(xpos) * nx, y = -0.45 * ny, paste(limits5[i], '<', labs[4], '<', limits5[i+1]), xpd = TRUE)
        return(rbind(legend.xyz, out))
    }

    plot(c(0, nx), c(0, ny), type = 'n', axes = FALSE, xlab = '', ylab = '')
    legend = raster(nrows=ny, ncols=nx, xmn = 0, xmx = 1, ymn = 0, ymx =1)
    legend.xyz = c()

    legend.xyz = add_3way(1, xpos = c(0.00, 0.20))
    legend.xyz = add_3way(2, xpos = c(0.25, 0.45))
    legend.xyz = add_3way(3, xpos = c(0.50, 0.70))
    legend.xyz = add_3way(4, xpos = c(0.75, 0.95))

    legend.z = rasterFromXYZ(apply(legend.xyz[,  1:3   ],2,as.numeric))
    legend.e = rasterFromXYZ(apply(legend.xyz[,c(1:2,4)],2,as.numeric))
    cols = unique(legend.xyz[,5])
    limits = as.numeric(unique(legend.xyz[,3])[-1]) - 0.5

    plot_raster_from_raster(legend.z, cols = cols, limits = limits, smooth_image = FALSE, coast.lwd = NULL,
                             add_legend = FALSE, e = legend.e, invert_e = FALSE,  limits_error = seq(1.5, 3.5),
                             add = TRUE,  ePatternRes = 100,  ePatternThick = 0.4, e_polygon = FALSE)

    #text(x = 0.10 * nx, y = -0.25 * ny, labs[1], xpd = TRUE           )
    #text(x = 0.00 * nx, y =  0.50 * ny, labs[2], xpd = TRUE, srt =  45)
    #text(x = 0.20 * nx, y =  0.50 * ny, labs[3], xpd = TRUE, srt = -45)

    #text(x = seq(0.0, 0.2*nx, length.out = 5), y = -0.1 *ny, rev(limits5), xpd = TRUE)
}

add_raster_3way_legend_for_4way <- function(legend.z, cols, limits = c(0.25, 0.5, 0.75), xpos = c(0,1),
                                    lighten_factor = 1.4, hash = 1,...) {

    nsq = nrow(legend.z)
    limits = limits * nsq
    xpos = xpos * ncol(legend.z)

    l = 0; u = nsq; xyz = c()
    nz = 0
    for (i in 1:nsq) {
        if (i %% 2 == 1) l = l + 1
            else         u = u - 1

        z = (l:u)

        x = (z / nsq * diff(xpos)) + xpos[1]

        y = rep(i, length(x))

        bl = nsq - z - floor(i/2) + 1
        gr = rep(i, length(z))
        rd = z - floor(i/2)

        cut_results_col <- function(x) {
            x = cut_results(x, limits)
            x = cols[x]
            return(x)
        }

        bl = cut_results_col(bl)
        gr = cut_results_col(gr)
        rd = cut_results_col(rd)

        xcols = paste('#', rd, gr, bl, sep = '')
        xyz = rbind(xyz, cbind(x, y, NaN, hash, xcols))
    }

    ucols = unique(xyz[,5])
    xyz[,3] = sapply(xyz[,5], function(i) which(i == ucols))

    return(xyz)
}


# Convert Unix timestamp into datetime in R

value <- 1465507827

# just the date "2016-06-09"
as.Date(as.POSIXct(value, origin="1970-01-01"))

# the date with hours:mins:secs  "2016-06-09 23:30:27 CEST"
as.POSIXct(value, origin="1970-01-01")

#REF:
#"Handling date-times in R" by Cole Beck, August 30, 2012.


library(readxl)
census1=as.data.frame(read_xlxs("GreekCensus2011Data.xlsx",sheet=1))
census2=as.data.frame(read_xlxs("GreekCensus2011Data.xlsx",sheet=2))
census3=as.data.frame(read_xlxs("GreekCensus2011Data.xlsx",sheet=3))

#answer1 is objective 1
answer1=sum( rowSums ( census1[  2:(dim(census1))[1],2:(dim(census1))[2]  ]) ) #sum is10817485

#answer2 is objective 2
answer2= col ])Sums ( census1[  2:(dim(census1))[1],2:(dim(census1))[2]  ])

#barplot is objective 3
barplot(answer2,main="Age Distribution"),xlab="Age",ylab="Absolute Values")

arrayBarplot = answer2/answer1
arrayBarplot= arrayBarplot*100
barplot(arrayBarplot,main="Age Distribution"),xlab="Age",ylab="Percentage")

#creating arrays with FALSE,TRUE
#arrayTrue είναι στην "Ευρώπη"==TRUE,
#arrayTrue3 είναι στην "Ναι"==TRUE,
arrayTrue = census2[,2]
arrayTrue3 = census3[,2]
arrayTrue = arrayTrue == "Ευρώπη"
arrayTrue3 = arrayTrue3 == "Ναι"

#if(arrayTrue[i] == TRUE){
#επιλέγουμε από την πρώτη καρτέλα τις χώρες που είναι στην Ευρώπη
#if(arrayTrue3[i] == TRUE){
#επιλέγουμε από την πρώτη καρτέλα τις χώρες που είναι στην ΕΕ και παίρνουμε
#παίρνουμε άθροισμα των επιθυμητών γραμμών
#ομοίως στο else για τους εκτός ΕΕ

sumEu = 0
sumNonEu=0;
j=1;
for(i in 1:length(arrayTrue)){
	if(arrayTrue[i] == TRUE){
		if(arrayTrue3[j] == TRUE){
			sumEu = sumEu + rowSums(census1[1,2:dim(census1)[2]])
		}
		else
		sumNonEu = sumNonEu +rowSums(census1[i,2:dim(census1)[2]])
		}
	j=j+1
	}
}

#sumEu 10058669
#sumNonEu 495658

slices = c(sumNonEu,sumEeu)
lbl = c("outside European Union","In European Union")
pie(slices,labels=lbl,main="Europeans in the country")

arrayNoEurope = census2[,2]

sumAfrica =0;
sumAmerica =0;
sumAsia =0;
sumOther =0;

#επιλέγουμε για κάθε ήπειρο και αθροίζουμε στο αντίστοιχο άθροισμα

for(i in 1:length(arrayNoEurope)){

if(census2[i,2] == "Αφρική"){
sumAfrica =sumfrica+ rowSums(census1[1,2:dim(census1)[2]]);
}
else{
if(census2[i,2] == "Αμερική" ){
sumAmerica = sumAmerica + rowSums(census1[1,2:dim(census1)[2]]);
}
else{
if((census2[i,2] == "Ασία"){
sumAsia = sumAsia  + rowSums(census1[1,2:dim(census1)[2]]);
}else{
 sumOther = sumOther + rowSums(census1[1,2:dim(census1)[2]]);
}
}
}
}

lbl2 = c("Africa","America","Asia","Other/Unknown")
slices2 = c(sumAfrica,sumAmerica,sumAsia,sumOther)
pie(slices2,labels=lbl2,main="Non Europeans living in the Country")


# author: Lara Habashy
# date: 2020-11-26

"Creates eda plots for the pre-processed training data from the default of credit card clients data (from http://archive.ics.uci.edu/ml/datasets/default+of+credit+card+clients).
Saves the plots as a png file.

Usage:  src/eda_cred.r --train=<train> --train_scaled=<train_scaled>  --out_dir=<out_dir>

Options:
--train=<train>     Path (including filename) to training data (which needs to be saved as a feather file)
--train_scaled=<train_scaled>
--out_dir=<out_dir> Path to directory where the plots should be saved
" -> doc

library(feather)
library(tidyverse)
#library(caret)
library(docopt)
library(ggthemes)
#library(graphics)
library(ggcorrplot)
library(arrow)

theme_set(theme_minimal())

opt <- docopt(doc)

main <- function(train, train_scaled, out_dir) {

  # make directory for results
  if (!dir.exists("results")){
    dir.create(file.path(getwd(), "results"))
  }
  if (!dir.exists("results/figures")){
    dir.create(file.path(getwd(), "results/figures"))
  }

  # read data
  training_data <- arrow::read_feather(train)
  training_scaled <- arrow::read_feather(train_scaled)

  # density plot
  density_plot <- training_scaled %>%
    ggplot(aes(x = limit_bal,
               fill = default)) +
    geom_density(alpha = 0.6) +
    xlab("Credit Limit") +
    ylab("Density") +
    ggtitle("Density of Credit Limit")

  density_plot <- density_plot + guides(fill=guide_legend(title="Default Flag"))
  density_plot <- density_plot + scale_shape_discrete(labels = c("Non-Defaults", "Defaults")) + scale_fill_discrete(labels = c("Non-Defaults", "Defaults"))

  ggsave(paste0(out_dir, "/density_plot.png"),
         density_plot,
         width = 8,
         height = 10)

  # education count colort by default
  education_histogram <- training_data %>%
    ggplot(aes(x=factor(education), fill=default)) +
    geom_bar(position="dodge") +
    ggtitle("Education levels of Defaulting Clients") +
    xlab("Education") +
    ylab("Count")

  education_histogram <- education_histogram + guides(fill=guide_legend(title="Default Flag"))
  education_histogram <- education_histogram + scale_shape_discrete(labels = c("Non-Defaults", "Defaults")) + scale_fill_discrete(labels = c("Non-Defaults", "Defaults"))
  education_histogram <-  education_histogram + scale_x_discrete(labels=c("0" = "Undefined", "1" = "masters",
                                                                          "2" = "bachelors", "3" = "highschool",
                                                                          "4" = "school", "5" = "other",
                                                                          "6" = "other"))

  ggsave(paste0(out_dir, "/education_histogram.png"),
         education_histogram,
         width = 8,
         height = 10)

  # proportions plot
  prop_plot <- training_data %>%
    ggplot(aes(x=as.numeric(default),  y = ..prop.., fill = factor(..x..), group = 1)) +
    geom_bar(stat='count') +
    geom_text(stat='count', aes(label=..prop..), vjust=3, hjust=0.5, color = 'black') +
    scale_y_continuous(labels = scales::percent_format()) +
    ggtitle("Proportions of Defaulting Clients") +
    xlab("Defaults") +
    ylab("Proportion")

  prop_plot <- prop_plot + guides(fill=guide_legend(title="Default Flag"))
  prop_plot <- prop_plot + scale_shape_discrete(labels = c("Non-Defaults", "Defaults")) + scale_fill_discrete(labels = c("Non-Defaults", "Defaults"))

  ggsave(paste0(out_dir, "/proportions_plot.png"),
         prop_plot,
         width = 8,
         height = 10)

  numeric_df <- training_data %>%
    select(-c(sex, education, marriage))
  numeric_df$default <- as.numeric(numeric_df$default)
  numeric_df$age <- as.numeric(numeric_df$age)

  # target counts bar plot
  count_plot <- training_data %>%
    ggplot(aes(x=as.numeric(default), fill=default)) +
    geom_bar() +
    geom_text(stat='count', aes(label=..count..), vjust=3, hjust=0.9, color = 'black') +
    ggtitle("Count of Defaulting Clients") +
    xlab("Defaults") +
    ylab("Count")

  count_plot <- prop_plot + guides(fill=guide_legend(title="Default Flag"))
  count_plot <- prop_plot + scale_shape_discrete(labels = c("Non-Defaults", "Defaults")) + scale_fill_discrete(labels = c("Non-Defaults", "Defaults"))

  ggsave(paste0(out_dir, "/counts_plot.png"),
         count_plot,
         width = 8,
         height = 10)

  # correlation plot
  corr <- round(cor(numeric_df %>% select_if(is.numeric)), 1)
  correlation_plot <- ggcorrplot(corr, hc.order = TRUE, outline.col = "white")

  ggsave(paste0(out_dir, "/correlation_plot.png"),
         correlation_plot,
         width = 8,
         height = 10)
}

main(opt[["--train"]], opt[["--train_scaled"]], opt[["--out_dir"]])


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Wed Feb 17 19:25:40 2010
########################################################
#Small multiples plot to compare the INEGI and ICESI data

source("library/utilities.r")

icesi <- read.csv("INEGIvsSNSP/data/states-icesi.csv")
inegi <- read.csv("accidents-homicides-suicides/output/states.csv")

icesi$State <- iconv(icesi$State, "windows-1252", "utf-8")
#inegi$State <- iconv(inegi$State, "windows-1252", "utf-8")

icesi <- melt(icesi, id = "State")
icesi$org <- "SNSP"

#Remove the years 1990:1996
inegi <- inegi[,-(2:8)]
inegi <- melt(inegi, id = "State")
inegi$org <- "INEGI"

ii <- rbind(inegi, icesi)
ii$variable <- rep(1997:2008, each=32)
ii$State <- cleanNames(ii, "State")

#Population of Mexico 1997-2008
#source: CONAPO
pop <- read.csv("conapo-pop-estimates/conapo-states.csv")
pop$State <- iconv(pop$State, "windows-1252", "utf-8")
pop <- pop[-(33) ,-(2:8)]
pop <- melt(pop, id = "State")
pop$variable <- rep(1997:2008, each=32)
pop <- pop[order(pop$State),]
pop$State <- cleanNames(pop, "State")
ii.pop <- merge(ii, pop, by = c("State", "variable"), all.x = TRUE)
ii.pop$rate <- ii.pop$value.x / ii.pop$value.y * 100000

variat <- function(df){
  ine <- subset(df, org == "INEGI")
  sns <- subset(df, org == "SNSP")
  var(ine$rate - sns$rate)
}
ii.pop <- merge(ii.pop, ddply(ii.pop, .(State), variat), by = "State")
ii.pop$State <- with(ii.pop, reorder(factor(State), -V1))
print(ggplot(ii.pop, aes(variable, rate, group = org, color = org)) +
    geom_line(size = 2) +
    facet_wrap(~ State, scales = "free_y"))
dev.print(png, file = "INEGIvsSNSP/output/INEGI-SNSP.png", width = 960, height = 600)

dif <- cast(ii.pop[order(ii.pop$org),], State ~ variable,
            value = "rate",
            fun.aggregate = function(x) x[1] - x[2])
difm <- melt(dif, id=c("State"))
difm <- ddply(difm, .(State), transform, var = var(value))
difm$State <- reorder(factor(difm$State), -difm$var)
print(ggplot(difm, aes(as.numeric(as.character(variable)), value)) +
    geom_line(size = 1.2, color = "darkred") +
    facet_wrap(~ State) +
    geom_hline(yintercept = 0, color = "gray40") +
    opts(title = "Differences in homicide rates (INEGI - SNSP)") +
    xlab("Year") + ylab("Difference in Homicide Rate") +
    scale_x_continuous(breaks = c(1998, 2003, 2008),
                         labels = c("98", "03", "08")) +
    #scale_y_continuous(formatter="percent") +
    theme_bw())
dev.print(png, file = "INEGIvsSNSP/output/INEGI-SNSP-dif.png", width = 960, height = 600)


library(knitr)
library(kableExtra)

tryNA <- function(expr,num=1){
    out <- try(expr,silent=TRUE)
    if(inherits(out,'try-error')) return(rep(NA,num))
    out
}

####################################
#### Table 3 simulation (linear)
##############################
#' Create simulated data set
#'
#'  With `curve=3` and `tdist=TRUE` we get the simulation as reported in arxiv v3
#'
#' @param n size (no. obs) in simulation
#' @param curve Amount by which magnitude of slope increases as R passes below -.5
#' @param tdist Generate disturbances from t dist'n on 3 d.f.? (As opposed to std Normal,
#' the default)
#' @param tau Magnitude of simulated treatment effect
#'
#' @return  Data frame w/ running variable R, covariate x, yc, Z, Y
#' @export
#'

makeData <- function(n,tdist=FALSE,frc=0,tauMean=0,tauErr='none',plt=FALSE){
   ## O(n^-.5) contamination fraction OK -> try 1/sqrt(n) contamination
    R <- c(runif(n*(1-frc),-.5,.5),runif(ceiling(n*frc/2),-.75,-.5),runif(ceiling(n*frc/2),.5,.75))
    R <- sample(R,n)
    yc <- .75*R
    yc <- ifelse(abs(R)>0.5,4.5*R-sign(R)*15/8,yc)
    if(plt) yhat <- yc
    err <- if(tdist) rt(n,3) else rnorm(n,0,.75)
    if(tdist) err <- err/sd(err)*0.75
    yc <- yc+err

    Z <- R>0

  tau <- if(tauErr=='t') rt(n,3) else if(tauErr=='norm') rnorm(n,0,.75) else 0

  if(tauErr=='t') tau <- tau/sd(tau)*0.75

  tau <- tau+tauMean

    Y <- yc+Z*tau

    if(plt){
        plot(R,Y)
        lines(sort(R),yhat[order(R)])
    }
    data.frame(R=R,yc=yc,Z=Z,Y=Y)
}

#' Bandwidth, p-value, point estimate from SH method
#'
#' Analyze a simulated data set with the SH method
#'
#' @param dat data frame with variables R, x, Y, Z
#'
#' @return vector with elements
#' \itemize{
#'  \item bandwidth
#'  \item p-value
#'  \item HL point estimate
#' }
#' @export
#'
#'
shbw <- function(ddd,BW=NULL){
    if(missing(BW) | is.null(BW)) BW <- bw(ddd)
    res <- CIsh(dat=ddd,BW=BW)
    p <- testSH(dat=ddd,BW=BW)
    setNames(c(BW,p,res['CI1'],res['CI2'],res['est']),c('BW','p','CIl','CIh','est'))
}

#' Bandwidth p-value, point estimate from IK method
#'
#' Analyze a simulated dataset with the IK method (implemented via rdd package)
#'
#' @import rdd
#'
#' @param dat data frame with variables R, x, Y, Z
#'
#' @return vector with elements
#' \itemize{
#'  \item bandwidth
#'  \item p-value
#'  \item HL point estimate
#' }
#' @export
#'
ikSim <- function(dat,BW=NULL){
    if(missing(BW) | is.null(BW)){
        mod <- RDestimate(Y~R,data=dat,kernel='rectangular')
        return(setNames(with(mod,c(bw[1],p[1],ci[1,1],ci[1,2],est[1])),c('BW','p','CIl','CIh','est')))
    }
    mod <- lm(Y~R*Z,data=dat,subset=abs(R)<=BW)
    est <- coef(mod)['ZTRUE']
    se <- sqrt(vcovHC(mod,'HC1')['ZTRUE','ZTRUE']) ## what RDestimate uses
    setNames(c(BW,2*pnorm(-abs(est/se)),est+c(-1,1)*1.96*se,est),c('BW','p','CIl','CIh','est'))
}

cftSim <- function(dat,BW=NULL){
    if(missing(BW) | is.null(BW)) BW <- bw(dat,method='cft')
    res=cftTest(dat,BW,'Y',justP=FALSE)
    setNames(c(BW=BW,res$p.value,res$conf.int[1],res$conf.int[2],res$estimate),c('BW','p','CIl','CIh','est'))
}

totalOutcomeOne <- function(n,tdist,frc,tauErr,tauMean){
    dat <- makeData(n=n,tdist=tdist,frc=frc,tauErr=tauErr,tauMean=tauMean)
    BW <- max(abs(dat$R))
    c(sh=tryNA(shbw(dat,BW),5),
      ik=tryNA(ikSim(dat,BW),5),
      cft=tryNA(cftSim(dat,BW),5))
}

#' Run the level/power simulation from Table 3
#'
#' @import rdd robustbase
#'
#' @param nreps Number of simulation replications
#'
#' @param cluster For multicore computation with the `parallel` package, an initialized SOCK cluster
#'
#' @return list of output for each simulation run
#' @export
#'
totalOutcomeSim <- function(nreps=5000,cluster=NULL){
    res <- list()
    #B <- 5000

    appFunc <- if(is.null(cluster)) sapply else function(X,FUN) parSapply(cl=cluster,X=X,FUN=FUN)

    for(n in c(50,250,2500)){
      for(tdist in c(TRUE,FALSE)){
        for(tauErr in c('none','some')){
          for(tauMean in c(0,0.2)){
            if(tauErr=='some') tauErr <- ifelse(tdist,'t','norm')
            message(paste(n,tdist,tauErr,tauMean))
            res[[paste0(n,'_','err',ifelse(tdist,'t','norm'),'_','tau',tauMean,'W',tauErr)]] <-
              appFunc(1:nreps,function(i) totalOutcomeOne(n,tdist,frc=0,tauErr=tauErr,tauMean=tauMean))
          }
        }
      }
    }
    res
}

###############
### table 4 simulation (polynomial)
###############
mu3 <- function(x){
    ifelse(x<0,1.27*x-.5*7.18*x^2+0.7*20.21*x^3+1.1*21.54*x^4+1.5*7.33*x^5,
    .84*x-0.1*3.00*x^2-0.3*7.99*x^3-0.1*9.01*x^4+3.56*x^5)
}

### from Wasserman "all of nonparametric stats" p.99 (just the sine function really)
mu4 <- function(x)
  sin(3*x)

makeDataShapes <- function(n,shape,tdist=FALSE,tau=0,plt=FALSE){
    curve <- 3
    R <- runif(n,-1,1)

    yc <- .5*R
    if(shape=='antiSym')
        yc <- ifelse(abs(R)>0.5,3*R+sign(R)*(0.5-3)*0.5,yc)
    if(shape=='oneSide')
        yc <- yc+ ifelse(R> 0.5,3*R+(0.5-3)*0.5,yc)
    if(shape=='sym')
        yc <- ifelse(abs(R)> 0.5,sign(R)*3*R+(sign(R)*0.5-3)*0.5,yc)
    if(shape=='cct')
        yc <- mu3(R)
    if(shape=='poly3')
      yc <- 1.75*R^3
    if(shape=='wass')
      yc <- mu4(R)

    if(plt) plot(R,yc)

    yc <- yc+if(tdist) rt(n,3) else rnorm(n)

    Z <- R>0

    Y <- yc+Z*tau

    data.frame(R=R,Z=Z,Y=Y)
}

ikPoly <- function(dat,deg){
    mod <- lm(Y~poly(R,deg)*Z,data=dat)
    Z.pos <- which(grepl('Z',names(coef(mod))) & !grepl(':',names(coef(mod))))
    setNames(c(p=summary(mod)$coef[Z.pos,4],est=coef(mod)[Z.pos]),
             paste0(c('ik.p.','ik.est.'),deg))
}

shPoly <- function(dat,deg){
    rhs <- paste0('~poly(R,',deg,')+Z')
    setNames(c(p=testSH(dat,1,rhs=rhs),est=HLsh(dat,1,rhs=rhs)),
            paste0(c('sh.p.','sh.est.'),deg))
}

llPoly <- function(dat){
    mod <- RDestimate(Y~R,data=dat)
    setNames(c(mod$p[1],mod$est[1]),c('ll.p','ll.est'))
}

polySim <- function(n,degs=1:5,shape='lin',tdist=TRUE,tau=0){
    dat <- makeDataShapes( n=n,shape=shape,tdist=tdist,tau=tau)

    func <- function(deg){
        c(tryNA(shPoly(dat,deg),2),tryNA(ikPoly(dat,deg),2))
    }

    c(do.call('c',lapply(degs,func)),tryNA(llPoly(dat),2))
}

polyDisp <- function(sim){
    if(nrow(sim)<ncol(sim)) sim <- t(sim)

    simp <- sim[,grep('p',colnames(sim))]
    simEst <- sim[,grep('est',colnames(sim))]
    print('level of test')
    print(apply(simp,2,function(x) mean(x<0.05,na.rm=TRUE)))
    print('mean of est')
    print(apply(simEst,2,mean,na.rm=TRUE))
    print('SD of est')
    print(apply(simEst,2,sd,na.rm=TRUE))
    print('RMSE')
    print(apply(simEst,2,function(x) mean(x^2,na.rm=TRUE)))

}

#' Run the polynomial simulation from Table 4
#'
#' @import robustbase
#'
#' @param nreps Number of simulation replications
#'
#' @return list of output for each simulation run
#' @export
#'
totalPolySim <- function(nreps=5000,cluster=NULL){
  appFunc <- if(is.null(cluster)) sapply else function(X,FUN) parSapply(cl=cluster,X=X,FUN=FUN)
  res <- list()
    #B=5000
    n=500
    tau=0
    degs <- 1:5

    for(shape in c('lin','antiSym','wass')){
        for(tdist in c(TRUE)){#,FALSE)){
            res[[paste0(shape,'_',ifelse(tdist,'t','norm'))]] <-
                appFunc(1:nreps,function(i) polySim(n,degs,shape,tdist,tau))
        }
    }
    res
}


#Set working directory to file directory with data
setwd("E:/Garg Lab/Server output 1")

#Set the desired volume cutoff (cubic microns)
minVolumeCutoff<-1

#This function counts the total number of bundles in each file and returns the count
countObjects<-function(fileName){
	#Load the file into a temporary matrix
	fileMatrix<-read.table(fileName, sep="\t", header=TRUE)

	#Return the number of samples in the file
	count<-nrow(fileMatrix)
	return(count)
}

#This function fills a matrix with the corresponding measurements in an excel file
excelToMatrix<-function(fileName, maxCount){
	#Load the file into a temporary matrix
	fileMatrix<-read.table(fileName, sep="\t", header=TRUE)

	#Retrieve the desired measurements
	volumeVector<-fileMatrix$Volume
	boundingBoxWidthVector<-fileMatrix$B.width #Hyphens are replaced with "."
	boundingBoxHeightVector<-fileMatrix$B.height #Hyphens are replaced with "."

	#Fill the remaining vector with NA so that sapply creates a matrix (all returned vectors are of equal length)
	for (a in length(volumeVector):maxCount){
		volumeVector[a+1]<-NA
		boundingBoxWidthVector[a+1]<-NA
		boundingBoxHeightVector[a+1]<-NA
	}

	dataVector<-c()

	#Return the volume measurements column
	return(volumeVector)
}

#Get all file names that end with a *.xls file extension
fileNameList<-list.files(pattern = "\\.xls$",  ignore.case=TRUE)

#Count the number of results in each file
fileObjectCounts<-sapply(fileNameList, countObjects, simplify = TRUE)

#Find the largest number of object counts (this value will be used to setup a matrix to store all volume measurements)
maxCount<-max(fileObjectCounts)

#Add the volume measurements to  each corresponding column in the a new matrix
allVolumeMatrix<-sapply(fileNameList, excelToMatrix, maxCount, simplify = TRUE, USE.NAMES = FALSE)

#Extract the sample ID for each file by removing the prefix and extension and set as the column names in the new matrix
sampleIDvector<-sapply(fileNameList, gsub, pattern="\\.xls$", replacement="")
sampleIDvector<-sapply(sampleIDvector, gsub, pattern="\\.lif", replacement="")
colnames(allVolumeMatrix)<-sampleIDvector

#Create a vector of all sample IDs so that replicates can be pooled together
#initize variables and vectors
index<-1
sampleNameVector<-vector(,0)
sampleVolumeList<-list()

for(a in 1:length(sampleIDvector)){
	#Remove the numeric sample identifier suffix from the name
	sampleID<-gsub(" - Series [0-9]+", "", sampleIDvector[a])
	#On the first iteration, add the sample and count up the index
	if(a == 1){
		sampleNameVector[index]<-sampleID
		sampleVolumeList<-allVolumeMatrix[,a]
	}

	#On all following iterations, check to see if the same sample is found, and if so, add it to the vector
	else if(sampleID == sampleNameVector[index]){
		sampleVolumeList<-c(sampleVolumeList, allVolumeMatrix[,a])
	}

	#If a new sample is found, create a new list and add it to the list of lists
	else{
		#If index is 1 then create a new list of lists
		if(index == 1){
			listOfLists<-list(sampleVolumeList)
		}
		#Otherwise, add the current list to the list of lists
		else{
			listOfLists[[length(listOfLists)+1]]<-sampleVolumeList
		}

		#Increase the index counter
		index<-index+1
		sampleNameVector[index]<-sampleID
		sampleVolumeList<-allVolumeMatrix[,a]

	}
}
#Add the last list to the list of lists
listOfLists[[length(listOfLists)+1]]<-sampleVolumeList

#convert the list of lists to a matrix
sampleVolumeMatrix<-do.call(cbind, lapply(listOfLists, unlist))
colnames(sampleVolumeMatrix)<-sampleNameVector

#Remove all volume measurements that are below the set cutoff
sampleVolumeMatrix<-replace(sampleVolumeMatrix, sampleVolumeMatrix < minVolumeCutoff, NA)

#Create a notched box plot for each sample
par(mar = c(15,6,3,3))
boxplot(sampleVolumeMatrix, log="y", las = 2, names = sampleNameVector, notch = TRUE, ylim = c(min(sampleVolumeMatrix, na.rm = TRUE), max(sampleVolumeMatrix, na.rm = TRUE)), ps = 1, cex.lab=1, cex.axis=1, cex.main=1, cex.sub=1, bty="n")
mtext(expression(paste( plain("Graphene Particle Volume Distribution (μm") ^ plain("3"), plain(")") )), side=2, line = 3, cex = 1)

Aspect Ratio and volume comparator - draft 2.r