# Set up the environment

# Makes sure package is not already installed and loaded before it loads it
prepare.package <- function(package) {
    if(package %in% rownames(installed.packages()) == FALSE) {
        install.packages(package)
    }
    require(package, character.only = TRUE)
}

setwd(dirname(parent.frame(2)$ofile))
prepare.package("doBy")
prepare.package("ggplot2")
prepare.package("gdata")
prepare.package("plyr")

################################################################################
# First challenge: load in and clean up the data
################################################################################

cat(c("Initializing data...\n"), sep="")

if(file.exists("./data_set/rollingsales_manhattan.xls")) {
    mh <- read.xls("./data_set/rollingsales_manhattan.xls",pattern="BOROUGH")
} else {
    cat(c("Can't find data file!\n"), sep="")
}

# Get some information about what we have to work with
head(mh)
summary(mh)

# Set column names to lower case
names(mh) <-tolower(names(mh))

# Creates a numerical version of columns containing commas and/or dollar signs
mh$sale.price.n <- as.numeric(gsub("[^[:digit:]]", "", mh$sale.price))
mh$gross.sqft <- as.numeric(gsub("[^[:digit:]]", "", mh$gross.square.feet))
mh$land.sqft <- as.numeric(gsub("[^[:digit:]]", "", mh$land.square.feet))

# See if we have any invalid values within the newly created columns
count(is.na(mh$sale.price.n))
count(is.na(mh$gross.sqft))
count(is.na(mh$land.sqft))

################################################################################
# Next, conduct exploratory data analysis in order to find out where there are
# outlier or missing values, decide how you will treat them, make sure the
# dates are formatted correctly, make sure values you think are numerical are
# being treated as such, etc.
################################################################################

# Making sure dates are formatted correctly
mh$sale.date <- as.Date(mh$sale.date)
# Making sure values I think are numerical are being treated as such
mh$year.built <- as.numeric(as.character(mh$year.built))

# Some exploration to make sure there's nothing weird going on with sale prices

# Total sales on record
ggplot(mh, aes(x=sale.price.n)) +
    geom_histogram(binwidth = diff(range(mh$sale.price.n)))
# Total sales on record with a price more than 0
ggplot(subset(mh, sale.price.n>0), aes(x=sale.price.n)) +
    geom_histogram(binwidth = diff(range(mh$sale.price.n)))
# Total sales on record with a price of 0
ggplot(subset(mh, sale.price.n==0), aes(x=gross.sqft)) +
    geom_histogram(binwidth = diff(range(mh$gross.sqft)))

# We shall treat sales with price of 0 as missing values and omit them

# Keep only the actual sales
mh.sale <- mh[mh$sale.price.n!=0,]

# Let us look for some outliers
ggplot(mh.sale, aes(gross.sqft, sale.price.n)) + geom_point()
ggplot(mh.sale, aes(log(gross.sqft), log(sale.price.n))) + geom_point()

# Seems like we found some let's investigate further and see what we can do

# Factorize building.class.category
mh.sale$building.class.category <- factor(mh.sale$building.class.category)

# Let us look at building types and see what is most reasonable to work with
levels(mh.sale$building.class.category)

# We do want to work with building types that give us gross.sqft and lad.sqft
summaryBy(gross.sqft+land.sqft~building.class.category,
          data=mh.sale, FUN=c(min, max))

# It seems most reasonable to work with 1, 2, and 3 family homes
mh.homes <- mh.sale[which(grepl("FAMILY",mh.sale$building.class.category)),]

# Let us look and see if we still have outliers
ggplot(mh.homes, aes(gross.sqft, sale.price.n)) + geom_point()
ggplot(mh.homes, aes(log(gross.sqft), log(sale.price.n))) + geom_point()

# We seem to have some, let's take a closer look
summaryBy(sale.price.n~address, data=subset(mh.homes, sale.price.n<10000),
          FUN=c(length, min, max))

# The summarized values above are definitely outliers and so we shall omit them
mh.homes$outliers <- (log(mh.homes$sale.price.n) <=5) + 0
mh.homes <- mh.homes[which(mh.homes$outliers==0),]

# Let us look and see if we still have outliers
ggplot(mh.homes, aes(gross.sqft, sale.price.n)) + geom_point()
ggplot(mh.homes, aes(log(gross.sqft), log(sale.price.n))) + geom_point()

################################################################################
# Once the data is in good shape, conduct exploratory data analysis to visualize
# and make compariosons (i) across neighborhoods,
################################################################################

# Factorize neighborhood
mh.homes$neighborhood <- factor(mh.homes$neighborhood)

# Let's first see which neighborhoods are included in our data
levels(mh.homes$neighborhood)

# Let's explore the data quantitatively first:

metrics <- function(x) {
    c(length(x),                 # count
      round(mean(x)),            # mean
      round(median(x)),          # median
      names(sort(-table(x)))[1], # mode
      round(sd(x)),              # standard deviation
      min(x),                    # minimum
      max(x),                    # maximum
      max(x)-min(x))             # range
}

# Sale price across neighborhoods
summaryBy(sale.price.n~neighborhood, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Gross square feet across neighborhoods
summaryBy(gross.sqft~neighborhood, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Land square feet across neighborhoods
summaryBy(land.sqft~neighborhood, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Year built  across neighborhoods
summaryBy(year.built~neighborhood, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))

# Let's now explore the data by visualizing it:

# Number of sales of homes across neighborhoods
ggplot(mh.homes, aes(x=neighborhood, fill=neighborhood, ymax=max(..count..))) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/28)) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1))

# Sale price across neighborhoods
# Histogram
ggplot(mh.homes, aes(x=sale.price.n, fill=neighborhood)) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/60))
# Box and whisker plot
ggplot(mh.homes, aes(x=neighborhood, y=sale.price.n, fill=neighborhood)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=sale.price.n, color=neighborhood)) + geom_density()
# Jitter Plot
ggplot(mh.homes, aes(x=neighborhood, y=sale.price.n, color=neighborhood)) +
    geom_jitter()
# Scatter Plot
ggplot(mh.homes, aes(x=neighborhood, sale.price.n, color=neighborhood)) +
    geom_point()
# Kernel density estimate
ggplot(mh.homes, aes(x=sale.price.n, fill=neighborhood)) + stat_density()

# Gross square feet across neighborhoods
# Histogram
ggplot(mh.homes, aes(x=gross.sqft, fill=neighborhood)) +
    geom_histogram(binwidth = diff(range(mh.homes$gross.sqft)/60))
# Box and whisker plot
ggplot(mh.homes, aes(x=neighborhood, y=gross.sqft, fill=neighborhood)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=gross.sqft, color=neighborhood)) + geom_density()
# Jitter Plot
ggplot(mh.homes, aes(x=neighborhood, y=gross.sqft, color=neighborhood)) +
    geom_jitter()
# Scatter Plot
ggplot(mh.homes, aes(x=neighborhood, gross.sqft, color=neighborhood)) +
    geom_point()
# Kernel density estimate
ggplot(mh.homes, aes(x=gross.sqft, fill=neighborhood)) + stat_density()

# Land square feet across neighborhoods
# Histogram
ggplot(mh.homes, aes(x=land.sqft, fill=neighborhood)) +
    geom_histogram(binwidth = diff(range(mh.homes$land.sqft)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=neighborhood, y=land.sqft, fill=neighborhood)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=land.sqft, color=neighborhood)) + geom_density()
# Jitter Plot
ggplot(mh.homes, aes(x=neighborhood, y=land.sqft, color=neighborhood)) +
    geom_jitter()
# Scatter Plot
ggplot(mh.homes, aes(x=neighborhood, land.sqft, color=neighborhood)) +
    geom_point()
# Kernel density estimate
ggplot(mh.homes, aes(x=land.sqft, fill=neighborhood)) + stat_density()

# Year built across neighborhoods
# Histogram
ggplot(mh.homes, aes(x=year.built, fill=neighborhood)) +
    geom_histogram(binwidth = diff(range(mh.homes$year.built)/60))
# Box and whisker plot
ggplot(mh.homes, aes(x=neighborhood, y=year.built, fill=neighborhood)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=year.built, color=neighborhood)) + geom_density()
# Jitter Plot
ggplot(mh.homes, aes(x=neighborhood, y=year.built, color=neighborhood)) +
    geom_jitter()
# Scatter Plot
ggplot(mh.homes, aes(x=neighborhood, year.built, color=neighborhood)) +
    geom_point()
# Kernel density estimate
ggplot(mh.homes, aes(x=year.built, fill=neighborhood)) + stat_density()

################################################################################
# and (ii) across time.
################################################################################

# We only have data for August, 2012 - August 2013
# Seeing as we don't have full years or comparable months of those years
# it would be wiser to conduct EDA across months and weekdays only.

# Categorize sale dates by month and weekday
mh.homes$sale.month <- format(mh.homes$sale.date, "%B")
mh.homes$sale.day <- format(mh.homes$sale.date, "%A")

# Factorize sale dates by month and weekday
mh.homes$sale.month <-
    factor(mh.homes$sale.month,
           levels= c("January", "February", "March", "April", "May", "June",
                     "July", "August", "September", "October", "November",
                     "December"))
mh.homes$sale.day <-
    factor(mh.homes$sale.day,
           levels= c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday"))

# Let's explore the data quantitatively first:

# Sale price across months
summaryBy(sale.price.n~sale.month, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Gross square feet across months
summaryBy(gross.sqft~sale.month, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Land square feet across months
summaryBy(land.sqft~sale.month, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Year built across months
summaryBy(year.built~sale.month, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))

# Sale price across days of the week
summaryBy(sale.price.n~sale.day, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Gross square feet across days of the week
summaryBy(gross.sqft~sale.day, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Land square feet across days of the week
summaryBy(land.sqft~sale.day, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))
# Year built across days of the week
summaryBy(year.built~sale.day, data=mh.homes, FUN=metrics,
          fun.names=c("Count","Mean","Median","Mode","SD","Min","Max","Range"))

# Let's now explore the data by visualizing it:

# Number of sales of homes
# By month
ggplot(mh.homes, aes(x=sale.month, fill=sale.month, ymax=max(..count..))) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/12)) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1))
# By day of the week
ggplot(mh.homes, aes(x=sale.day, fill=sale.day, ymax=max(..count..))) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/7)) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1))

# Sale price across months
# Histogram
ggplot(mh.homes, aes(x=sale.price.n, fill=sale.month)) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/60))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.month, y=sale.price.n, fill=sale.month)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=sale.price.n, color=sale.month)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.month, sale.price.n, color=sale.month)) +
    geom_point()
# Sale price across days of the week
# Histogram
ggplot(mh.homes, aes(x=sale.price.n, fill=sale.day)) +
    geom_histogram(binwidth = diff(range(mh.homes$sale.price.n)/60))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.day, y=sale.price.n, fill=sale.day)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=sale.price.n, color=sale.day)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.day, sale.price.n, color=sale.day)) + geom_point()

# Gross square feet (for sold homes) across months
# Histogram
ggplot(mh.homes, aes(x=gross.sqft, fill=sale.month)) +
    geom_histogram(binwidth = diff(range(mh.homes$gross.sqft)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.month, y=gross.sqft, fill=sale.month)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=gross.sqft, color=sale.month)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.month, gross.sqft, color=sale.month)) + geom_point()
# Gross square feet (for sold homes) across days of the week
# Histogram
ggplot(mh.homes, aes(x=gross.sqft, fill=sale.day)) +
    geom_histogram(binwidth = diff(range(mh.homes$gross.sqft)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.day, y=gross.sqft, fill=sale.day)) + geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=gross.sqft, color=sale.day)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.day, gross.sqft, color=sale.day)) + geom_point()

# Land square feet (for sold homes) across months
# Histogram
ggplot(mh.homes, aes(x=land.sqft, fill=sale.month)) +
    geom_histogram(binwidth = diff(range(mh.homes$land.sqft)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.month, y=land.sqft, fill=sale.month)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=land.sqft, color=sale.month)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.month, land.sqft, color=sale.month)) + geom_point()
# Land square feet (for sold homes) across days of the week
# Histogram
ggplot(mh.homes, aes(x=land.sqft, fill=sale.day)) +
    geom_histogram(binwidth = diff(range(mh.homes$land.sqft)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.day, y=land.sqft, fill=sale.day)) + geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=land.sqft, color=sale.day)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.day, land.sqft, color=sale.day)) + geom_point()

# Year built (for sold homes) across months
# Histogram
ggplot(mh.homes, aes(x=year.built, fill=sale.month)) +
    geom_histogram(binwidth = diff(range(mh.homes$year.built)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.month, y=year.built, fill=sale.month)) +
    geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=year.built, color=sale.month)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.month, year.built, color=sale.month)) + geom_point()
# Year built (for sold homes) across days of the week
# Histogram
ggplot(mh.homes, aes(x=year.built, fill=sale.day)) +
    geom_histogram(binwidth = diff(range(mh.homes$year.built)/30))
# Box and whisker plot
ggplot(mh.homes, aes(x=sale.day, y=year.built, fill=sale.day)) + geom_boxplot()
# Density plot
ggplot(mh.homes, aes(x=year.built, color=sale.day)) + geom_density()
# Scatter Plot
ggplot(mh.homes, aes(x=sale.day, year.built, color=sale.day)) + geom_point()

################################################################################
# If you have time, start looking for meaningful patters in this dataset.
################################################################################

# - Most sales happen in Harlem and the Upper East Side.
# - Housing is most expensive in the Upper East Side.
# - Housing is least expensive in Harlem.
# - Houses have the most gross square feet in Gremich and the Upper East Side.
# - Houses seem about equal in terms of gross square feet elsewhere.
# - Houses seem about equal in terms of land square feet throughout.
# - The Upper West side has the newest housing.
# - Housing was built mostly around the early 1900s.
# - Harlem has the newest housing.
# - The amount of sales seem equally distributed around Wednesday.
# - December has a lot more sales than any other month.
# - The least amount of sales happen in September and October.
# - Home sales according to other metrics across time seem equally distributed.


require(Hmisc)
set.seed(2)
d <- expand.grid(major=c('Alabama', 'Alaska', 'Arkansas',
                         'Arizona', 'Nevada'),
                 minor=c('East', 'West'),
                 group=c('Female', 'Male'),
                 city=0:2)
n <- nrow(d)
# d$x <- (1 : nrow(d)) + runif(n)
d$num <- round(100*runif(n))
d$denom <- d$num + round(100*runif(n))
d$x <- d$num / d$denom
d

with(d,
     dotchartpl(x, major, minor, group, city, big=city==0, num=num, denom=denom)
     )

## Same without city, compute Famale - Male differences and conf. intervals
## Within major groups sort in descending order of differences, show
## differences with color of Female if positive, Male if negative,
## add layer with horizontal bar centered at the difference and with
## width equal to half-width of confidence interval
d <- subset(d, city==0)
i <- with(d, order(major, minor, group))
# xless(d[i, ])
with(d,
     dotchartpl(x, major, minor, group, refgroup='Male', num=num, denom=denom,
                  xlim=c(0,1))
     )

# Original source of aeanonym: HH package
# aeanonym <- read.table(hh("datasets/aedotplot.dat"), header=TRUE, sep=",")
# Modified to remove denominators from data and to generate raw data
# (one record per event per subject)

ae <-
    structure(list(RAND = structure(c(1L, 2L, 1L, 2L, 1L, 2L, 1L,
                                      2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
                                      2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
                                      2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
                                      2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L), .Label = c("a",
                                                                                "b"), class = "factor"), PREF = structure(c(12L, 12L,
                                                                                18L, 18L, 26L, 26L, 33L, 33L, 5L, 5L, 27L, 27L, 6L, 6L, 15L,
                                                                                15L, 22L, 22L, 23L, 23L, 31L, 31L, 17L, 17L, 2L, 2L, 3L, 3L,
                                                                                13L, 13L, 25L, 25L, 28L, 28L, 14L, 14L, 4L, 4L, 8L, 8L, 19L,
                                                                                19L, 21L, 21L, 29L, 29L, 10L, 10L, 20L, 20L, 16L, 16L, 32L, 32L,
                                                                                11L, 11L, 1L, 1L, 30L, 30L, 24L, 24L, 9L, 9L, 7L, 7L),
                                                                                .Label = tolower(c("ABDOMINAL PAIN",
                                                                                "ANOREXIA", "ARTHRALGIA", "BACK PAIN", "BRONCHITIS", "CHEST PAIN",
                                                                                "CHRONIC OBSTRUCTIVE AIRWAY", "COUGHING", "DIARRHEA", "DIZZINESS",
                                                                                "DYSPEPSIA", "DYSPNEA", "FATIGUE", "FLATULENCE", "GASTROESOPHAGEAL REFLUX",
                                                                                "HEADACHE", "HEMATURIA", "HYPERKALEMIA", "INFECTION VIRAL", "INJURY",
                                                                                "INSOMNIA", "MELENA", "MYALGIA", "NAUSEA", "PAIN", "RASH", "RESPIRATORY DISORDER",
                                                                                "RHINITIS", "SINUSITIS", "UPPER RESP TRACT INFECTION", "URINARY TRACT INFECTION",
                                                                                "VOMITING", "WEIGHT DECREASE")), class = "factor"), SAE = c(15L,
                                                                                9L, 4L, 9L, 4L, 9L, 2L, 9L, 8L, 11L, 4L, 11L, 9L, 12L, 5L, 12L,
                                                                                7L, 12L, 6L, 12L, 6L, 12L, 2L, 14L, 2L, 15L, 1L, 15L, 4L, 16L,
                                                                                4L, 17L, 11L, 17L, 6L, 20L, 10L, 23L, 13L, 26L, 12L, 26L, 4L,
                                                                                26L, 13L, 28L, 9L, 29L, 12L, 30L, 14L, 36L, 6L, 37L, 8L, 42L,
                                                                                20L, 61L, 33L, 68L, 10L, 82L, 23L, 90L, 76L, 95L)), .Names = c("RAND",
                                                                                "PREF", "SAE"), class = "data.frame", row.names = c(NA,
                                                                                -66L))

ae$n <- ifelse(ae$RAND == 'a', 212, 188)
ae$p <- ae$SAE / ae$n
# ae <- subset(ae, p >= 0.05)
with(ae, dotchartpl(p, num=SAE, denom=n, minor=PREF, group=RAND, refgroup='a'))

n <- 500
set.seed(1)
d <- data.frame(
  race         = sample(c('Asian', 'Black/AA', 'White'), n, TRUE),
  sex          = sample(c('Female', 'Male'), n, TRUE),
  treat        = sample(c('A', 'B'), n, TRUE),
  smoking      = sample(c('Smoker', 'Non-smoker'), n, TRUE),
  hypertension = sample(c('Hypertensive', 'Non-Hypertensive'), n, TRUE),
  region       = sample(c('North America','Europe','South America',
                          'Europe', 'Asia', 'Central America'), n, TRUE))

d <- upData(d, labels=c(race='Race', sex='Sex'))

dm <- addMarginal(d, region)
s <- summaryP(race + sex + smoking + hypertension ~
                region + treat,  data=dm)

## add exclude1=FALSE to include female category
ggplot(s, groups='treat', exclude1=TRUE, abblen=12)
ggplot(s, groups='region')

s$region <- ifelse(s$region == 'All', 'All Regions', as.character(s$region))

with(s,
 dotchartpl(freq / denom, major=var, minor=val, group=treat, mult=region,
            big=region == 'All Regions', num=freq, denom=denom)
)

s2 <- s[- attr(s, 'rows.to.exclude1'), ]
with(s2,
     dotchartpl(freq / denom, major=var, minor=val, group=treat, mult=region,
                big=region == 'All Regions', num=freq, denom=denom)
)


# TECOA166
#Sheetal Singh

#install.packages('ggplot2')
library(ggplot2)

# Funcions for perticular action

scatter_plot_1 <- function(d) {
  print(ggplot(data = d) +
    geom_point(mapping = aes(x = displ, y = hwy, color = class)))
}

scatter_plot_2 <- function(d) {
  print(ggplot(data = d) +
    geom_point(mapping = aes(x = displ, y = hwy)) +
    facet_wrap(~ class, nrow = 2))
}

line_graph <- function(d) {
  print(ggplot(data = d) +
    geom_line(
      mapping = aes(x = displ, y = hwy, color = drv)))
}

curve_plot <- function(d) {
  print(ggplot(data = d) +
    geom_smooth(
      mapping = aes(x = displ, y = hwy, color = drv)))
}

bar_plot <- function(d) {
  print(ggplot(d, aes(class, fill = drv)) +
    geom_bar(position = "dodge"))
}

pie_chart <- function(d) {
  print(ggplot(d, aes(x = factor(1), fill = drv)) +
    geom_bar(width = 1) +
    coord_polar(theta = "y"))
}

box_plot <- function(d) {
  print(ggplot(data = d, mapping = aes(x = class, y = hwy)) +
    geom_boxplot(aes(fill=class)))
}

# Main Program Starts form here
data<-ggplot2::mpg  # Dataset for visualization
#?mpg    # to know about mpg dataset
while (TRUE)
{
  # Display Menu
  cat("\n\nMenu:-
1. Scatter Plot 1
2. Scatter Plot 2
3. Line Graph
4. Curve Plot
5. Bar Plot
6. Pie Chart
7. Box Plot
8. Exit\n\n")

  # Take input form user
  ch = as.integer(readline(prompt="Enter Your Choice: "))

  # Perform action specified by user
  switch(ch,
         scatter_plot_1(data),
         scatter_plot_2(data),
         line_graph(data),
         curve_plot(data),
         bar_plot(data),
         pie_chart(data),
         box_plot(data))

  if(ch==8){break}
}


# .hlpr_modular_models generic function [helper] ----
.hlpr_modular_models <- function(parameters, ...)  UseMethod(".hlpr_modular_models", parameters)

# .hlpr_modular_models param_glm method ----
.hlpr_modular_models.param_glm <- function(parameters, ...) {
  dv <- parameters$dv
  cv <- parameters$cv
  iv <- parameters$iv
  mv <- parameters$mv
  data <- parameters$data

  if (is.null(cv)) {
    cv <- 1
  }

  out <- vector(mode = "list", length = 3 + length(mv) * 2)
  form_cv <- formula(paste0(dv, "~", paste0(cv, collapse = "+")))
  out[[1]] <- glm(formula = form_cv, data = data, family = attr(parameters, "family"))

  form_iv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv))
  out[[2]] <- update(out[[1]], formula. = form_iv)

  for (i in seq(length(mv))) {
    j <- i * 2 + 1
    form_mv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", mv[i]))
    out[[j]] <- update(out[[1]], formula. = form_mv)
    j <- j + 1
    form_mv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", mv[i], "+", paste0(c(iv, mv[i]), collapse = ":")))
    out[[j]] <- update(out[[1]], formula. = form_mv)
  }

  if (parameters$full_model) {
    form_full <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", paste0(mv, collapse = "+"), "+", .hlpr_paste(element1 = iv, element2 = mv, sep = ":", collapse = "+")))
    out[[length(out)]] <- update(out[[1]], formula. = form_full)
  } else {
    out <- out[-length(out)]
  }

  return(out)
}

# .hlpr_modular_models param_glmer method ----
.hlpr_modular_models.param_glmer <- function(parameters, ...) {
  dv <- parameters$dv
  cv <- parameters$cv
  iv <- parameters$iv
  mv <- parameters$mv
  fe <- paste0("(1|", parameters$fe, ")")
  data <- parameters$data

  if (!is.null(cv)) {
    cv <- c(cv, fe)
  } else {
    cv <- fe
  }

  out <- vector(mode = "list", length = 3 + length(mv) * 2)
  form_cv <- formula(paste0(dv, "~", paste0(cv, collapse = "+")))
  if (attr(parameters, "family") == "gaussian") {
    out[[1]] <- lme4::lmer(formula = form_cv, data = data)
  } else {
    out[[1]] <- lme4::glmer(formula = form_cv, data = data, fam = attr(parameters, "family"))
  }

  form_iv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv))
  out[[2]] <- update(out[[1]], formula. = form_iv)

  for (i in seq(length(mv))) {
    j <- i * 2 + 1
    form_mv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", mv[i]))
    out[[j]] <- update(out[[1]], formula. = form_mv)
    j <- j + 1
    form_mv <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", mv[i], "+", paste0(c(iv, mv[i]), collapse = ":")))
    out[[j]] <- update(out[[1]], formula. = form_mv)
  }

  if (parameters$full_model) {
    form_full <- formula(paste0(dv, "~", paste0(cv, collapse = "+"), "+", iv, "+", paste0(mv, collapse = "+"), "+", .hlpr_paste(element1 = iv, element2 = mv, sep = ":", collapse = "+")))
    out[[length(out)]] <- update(out[[1]], formula. = form_full)
  } else {
    out <- out[-length(out)]
  }

  return(out)
}


library(ggplot2)
library(gridExtra)
library(gtable)
library(grid)

# Given a set of regions plot as lines related to an ID parameter
# world_data
PlotDimensionForRegionSet <- function(data, x_col_name, region_ids, region_id_col_name, dimension_name, color_codes) {
    g <- ggplot(data, aes_string(x=x_col_name, y=dimension_name, col=region_id_col_name)) +
        geom_line() +
        scale_color_manual(values = color_codes) +
        geom_smooth()
    return(g)
}

# Plots lines for all regions in a given data set
PlotDimensionForRegions <- function(data, x_col_name, region_id_col_name, dimension_name, line_colors) {

}

# Draws 4 graphs to one plot and adds a legend at the bottom
# spain_communities
GraphDimensionForCountry <- function(regional_data, country_data, dimension_name, country_name, color_codes) {

    total_dimension_name = paste("total_", dimension_name, sep = "")
    daily_dimension_name = paste("daily_", dimension_name, sep = "")

    str(color_codes)

    p1 <- ggplot(country_data, aes_string(x="date", y=total_dimension_name)) + geom_line()
    p2 <- ggplot(country_data, aes_string(x="date", y=daily_dimension_name)) + geom_line() + geom_smooth()
    p3 <- ggplot(regional_data, aes_string(x="date", y=total_dimension_name, col="region_code")) + geom_line()
    p4 <- ggplot(regional_data, aes_string(x="date", y=daily_dimension_name, col="region_code")) + geom_line()

    if (!is.na(color_codes)) {
        p3 <- p3 + scale_color_manual(values = color_codes)
        p4 <- p4 + scale_color_manual(values = color_codes)
    }

    g <- arrangeGrob(
        p1 + theme(legend.position="none"),
        p2 + theme(legend.position="none"),
        p3 + theme(legend.position="none"),
        p4 + theme(legend.position="none"),
        ncol=2,
        nrow=2
    )

    legend <- gtable_filter(ggplot_gtable(ggplot_build(p3)), "guide-box")
    title <- paste(country_name, dimension_name, sep=" - ")
    footer <- paste(max(country_data$date))
    final <- grid.arrange(g, legend, ncol = 2, widths=c(1.15, 0.25), bottom = footer, top = textGrob(title, gp=gpar(fontsize=20, font=3)))
    return(final)

}

# Draws a graph for all of a country
DrawGraphForCountry <- function(country_data, dimension_name, country_name) {

}

# Output all available graphable dimensions as png
# italy_data, daily_graphs
OutputAllDimensionsAsPng <- function(regional_data, country_data, country_name, color_codes) {
    empty_columns <- apply(regional_data, 2, function(x) any(is.na(x)))

    # Generate output path
    output_path <- paste("Output/", country_name, sep="")
    dir.create(output_path, showWarnings = FALSE)

    for(i in GRAPHABLE_COLUMN_ROOT_NAMES) {
        total_name <- paste("total_", i, sep="")
        if(!empty_columns[total_name]) {
            file_name <- paste(output_path, "/", i, ".png", sep="")
            g <- GraphDimensionForCountry(regional_data, country_data, i, country_name, color_codes)
            ggsave(file_name, plot = g, width = 16, height = 10, dpi = 300)
        }
    }
}


# inc_forecast_interval_05_index.r
myLand<-subset(UNPop,UNPop$Country==mySelection[i] & UNPop$Variant=="Medium variant")
myPrognoses<-subset(UNPop,UNPop$Country == mySelection[i] & Year >= 2010)
myPrognosis_L<-subset(myPrognoses,myPrognoses$Variant=="Low variant")$Value/1000
myPrognosis_M<-subset(myPrognoses,myPrognoses$Variant=="Medium variant")$Value/1000
myPrognosis_H<-subset(myPrognoses,myPrognoses$Variant=="High variant")$Value/1000
myYears<-seq(2010,2100,by=5)
attach(myLand)
myBase<-(Value[13]/1000)

plot(axes=F,type="n",xlab="",ylab="",Year,Value/1000,ylim=c(ymin[i],ymax[i]))
py<-c(0,100,200,300,400,500)
abline(h=py[2:6], col="lightgray",lty="dotted")
axis(1,tck=-0.01,col="grey",at=c(1950,2010,2100),cex.axis=1.2)
py<-c(0,100,200,300,400,500)
if (mySelection[i]=="World")
{
axis(2,tck=-0.01,col="grey",at=py,labels=format(py,big.mark="."),cex.axis=1.2)
}
xx<-c(myYears,rev(myYears))
yy<-c(100*myPrognosis_H/basis,rev(100*myPrognosis_L/basis))

polygon(xx,yy,col=rgb(192,192,192,maxColorValue=255),border=F)

lines(Year,100*(Value/1000)/basis,col="grey",lwd=2)
lines(myYears,100*myPrognosis_H/basis,col="black",lwd=2)
lines(myYears,100*myPrognosis_L/basis,col="orange",lwd=2)
lines(myYears,100*myPrognosis_M/basis,col="white",lwd=2)


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of uniform prior wonky world model predictions with prior slider DV"
#' author: "Judith Degen"
#' date: "March 12, 2015"
#' ---

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

#' get model predictions
load("data/mp-uniform-priorsliders.RData")
load("data/wr-uniform-priorsliders.RData")

d = read.table("data/parsed_uniform_priorslider_results.tsv", quote="", sep="\t", header=T)
names(d)
table(d$Item)
nrow(d)
head(d)
summary(d)

agrmp = aggregate(PosteriorProbability ~ Item + State + SpeakerOptimality + WonkyWorldPrior + Wonky, FUN="mean", data=d)
nrow(agrmp)
summary(agrmp)
agrmp$CILow = aggregate(PosteriorProbability ~ Item + State + SpeakerOptimality + WonkyWorldPrior + Wonky, FUN="ci.low", data=d)$PosteriorProbability
agrmp$CIHigh = aggregate(PosteriorProbability ~ Item + State + SpeakerOptimality + WonkyWorldPrior + Wonky, FUN="ci.high", data=d)$PosteriorProbability

mp = ddply(agrmp, .(Item, State, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))
summary(mp)
head(mp)
#mp[mp$Item == "ate the seeds birds" & mp$QUD=="how-many" & mp$Alternatives=="0_basic" & mp$SpeakerOptimality == 1,]
wr = ddply(agrmp, .(Item, Wonky, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))
summary(wr)
wr[wr$Item == "ate the seeds birds" & wr$QUD=="how-many" & wr$Alternatives=="0_basic" & wr$SpeakerOptimality == 1,]

mp$Item = gsub("_"," ",mp$Item)
wr$Item = gsub("_"," ",wr$Item)

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

agr = aggregate(normresponse ~ Item + quantifier + Proportion,data=r,FUN=mean)
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Proportion, agr$Quantifier)
mp$PosteriorProbability_empirical = agr[paste(mp$Item,mp$Proportion,"some"),]$normresponse

head(mp)

# get slider prior probabilities
load(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/23_sinking-marbles-prior-sliders-exactly/results/data/agr-normresponses.RData")

sliderprobs = agr
head(sliderprobs)
nrow(sliderprobs)
row.names(sliderprobs) = paste(sliderprobs$Item,sliderprobs$slider_id)
mp$PriorProbability_slider = sliderprobs[paste(as.character(mp$Item),mp$State),]$normresponse
#mp$AllPriorProbability_slider = priorprobs[paste(as.character(mp$Item)),]$X15
head(mp)
mp[mp$Item == "sank marbles" & mp$WonkyWorldPrior == .5 & mp$SpeakerOptimality == 2,]

# get slider expectations
slexp = ddply(sliderprobs, .(Item), summarise, expectation=sum(slider_id*normresponse))
summary(slexp)
head(slexp)
row.names(slexp) = as.character(slexp$Item)

mp$PriorExpectation_slider = slexp[as.character(mp$Item),]$expectation
wr$PriorExpectation_slider = slexp[as.character(wr$Item),]$expectation

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

###### HERE WE START WITH ALL THE INTERESTING PLOTTING
#plot empirical against predicted distributions for "some"
some = ddply(mp, .(Item, SpeakerOptimality, PriorExpectation_slider, Proportion, WonkyWorldPrior, PosteriorProbability_empirical), summarise, PosteriorProbability_predicted=sum(PosteriorProbability), PriorProbability_smoothed=sum(PriorProbability_slider))
nrow(some)
head(some)
msome = melt(some, measure.vars=c("PosteriorProbability_empirical","PosteriorProbability_predicted","PriorProbability_smoothed"))
msome$ptype = as.factor(ifelse(msome$variable == "PosteriorProbability_empirical", "posterior (empirical)",ifelse(msome$variable == "PosteriorProbability_predicted","posterior (model)", "prior")))
head(msome)
nrow(msome)
summary(msome)

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

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

pexpectations = ddply(mp, .(Item,SpeakerOptimality,PriorExpectation_slider, WonkyWorldPrior, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability))
head(pexpectations)
some=pexpectations

library(hydroGOF)

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

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

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

# plot only empirical
un = unique(some[,c("Item","PriorExpectation_slider","PosteriorExpectation_empirical")])
nrow(un)
ggplot(un, aes(x=PriorExpectation_slider,y=PosteriorExpectation_empirical)) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1)
#  scale_x_continuous(limits=c(0,15)) +
#  scale_y_continuous(limits=c(0,15))
ggsave("graphs/2_slider_priors/some_empirical_expectation_priorslider.pdf",width=7)

#plot empirical against predicted allstate-prbabilities for "some"
allstate = droplevels(subset(mp, State == 15))

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

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

#maybe COGSCI plot basis? plot  predicted allstate-prbabilities for "some" as a function of prior allstate-probabilities

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

un = unique(allstate[,c("PriorProbability_slider","PosteriorProbability_empirical")])
nrow(un)
ggplot(un, aes(x=PriorProbability_slider, y=PosteriorProbability_empirical)) +
  geom_point() +
  geom_smooth(method="lm") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1))
ggsave("graphs/2_slider_priors/some_empirical_allprobs_priorslider.pdf",width=7)

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

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

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

head(wonky)
#toplot = droplevels(subset(wonky,  WonkyWorldPrior == .6 & SpeakerOptimality == 2))
#head(toplot)

ggplot(wonky, aes(x=PriorExpectation_slider, y=PosteriorProbability)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior ~ SpeakerOptimality)
ggsave(file="graphs/2_slider_priors/wonkinessplot_priorslider.pdf")

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


# Evaluating the dual taxonomic resolution of observed interactions
inter_taxo_resolution <- function(tx.list, inter.list, taxo.resolution.accepted){
  # tx.list <- taxon list with taxonomic resolution, taxon should be rownames
  # inter.list <- list of binary interactions with three columns: 1 == predator, 2 == interaction type, 3 == prey
  # taxo.resolution.accepted <- list of taxonomic resolutions accepted for further analyses
  nb.inter <- nrow(inter.list)
  inter.resolution <- character(nb.inter)
  taxo.resol <- unique(tx.list[, 2])

  matrix.dims <- dim(inter.list)
  if(is.matrix(inter.list) == FALSE) {inter.list <- as.matrix(inter.list)}
  if(identical(matrix.dims,dim(inter.list)) == FALSE) {stop("Verify table structure")}

  # Evaluating taxonomic resolutions of predators and preys forming observed binary interactions
  for(i in 1:nb.inter) {
    pred.tx.resolution <- tx.list[inter.list[i, 1], 2]
    prey.tx.resolution <- tx.list[inter.list[i, 3], 2]
    inter.resolution[i] <- paste(pred.tx.resolution, prey.tx.resolution, sep = " - ")
  }

  inter.list <- cbind(inter.list, inter.resolution)

  taxo.combination <- as.vector(outer(taxo.resolution.accepted, taxo.resolution.accepted, paste, sep = " - "))  # Computes all combinations that could be of interest

  # Evaluating which interactions in the list meets our criteria for minimal dual taxonomic resolution
  row.inter.accepted <- numeric()
  for(i in 1:length(taxo.combination)) {
    row.inter.accepted <- c(row.inter.accepted,which(inter.resolution == taxo.combination[i]))
  }

  inter.list.tot <- inter.list[row.inter.accepted, ]

  return(inter.list.tot)
}


#' @docType package
#' @name MethylDeconBloodSubtypes
#' @title Deconvolute array-based methylation data.

#' Fit models.
#'
#' @family Model fitting
#' @param testVector
#' @param basis
#' @return A numeric matrix
fitNonneg.nosum1 <- function (testVector, basis){
	basisIndex <- c(seq(1,dim(basis)[2]))
	basisSplice <- basis
	while (1)
	{
		afit <- lsfit (basisSplice, testVector,intercept=F)
		coef <- afit$coefficients[1:(dim(basisSplice)[2])]
		coeff <- c(rep(0,dim(basis)[2]))
		coeff[basisIndex] <- coef

		if (length(which(coeff < 0)) == 0)
		{
			coeff2 <- coeff
			if (sum(coeff)>1)
			{
				coeff2 <- coeff/sum(coeff)
			}
			return(coeff2)
		}

		else
		{
			low <- which.min(coeff)
			basisIndex[low] <- 0
			basisSplice <- basis[,which(basisIndex > 0)]

			if ((length(which(coeff > 0)) == 1) && (length(which(coeff != 0)) == 2))
			{
				coeff[which(coeff > 0)] <- 1
				coeff[which(coeff <= 0)] <- 0
				return(coeff)

			}
		}
	}
}

## (may want to also hard code in this list using the default options to make code faster)
#' Get the CpG list for the model for main cell types.
#'
#' @family Generate list
#' @param length.anova An integer numeric
#' @param length.pairs An integer numeric
#' @return A character
#' @export
get.cpg.list.main <- function(length.anova = 1000, length.pairs = 300){
	## get keep list of CpGs for overall ANOVA test for all types
	ord.anova <- tests.main[,"anova.p"]
	names(ord.anova) <- row.names(tests.main)
	ord.anova <- ord.anova[order(ord.anova)]
	names.ord.anova <- names(ord.anova)

	## get keep list of CpGs for all pairwise comparisons

	## CD4-CD8
	ord.cd4.cd8 <- tests.main[,"cd4.cd8.p"]
	names(ord.cd4.cd8) <- row.names(tests.main)
	ord.cd4.cd8 <- ord.cd4.cd8[order(ord.cd4.cd8)]
	names.ord.cd4.cd8 <- names(ord.cd4.cd8)

	## CD4-CD14
	ord.cd4.cd14 <- tests.main[,"cd4.cd14.p"]
	names(ord.cd4.cd14) <- row.names(tests.main)
	ord.cd4.cd14 <- ord.cd4.cd14[order(ord.cd4.cd14)]
	names.ord.cd4.cd14 <- names(ord.cd4.cd14)

	## CD4-CD19
	ord.cd4.cd19 <- tests.main[,"cd4.cd19.p"]
	names(ord.cd4.cd19) <- row.names(tests.main)
	ord.cd4.cd19 <- ord.cd4.cd19[order(ord.cd4.cd19)]
	names.ord.cd4.cd19 <- names(ord.cd4.cd19)

	## CD4-gran
	ord.cd4.gran <- tests.main[,"cd4.gran.p"]
	names(ord.cd4.gran) <- row.names(tests.main)
	ord.cd4.gran <- ord.cd4.gran[order(ord.cd4.gran)]
	names.ord.cd4.gran <- names(ord.cd4.gran)

	## CD4-nk
	ord.cd4.nk <- tests.main[,"cd4.nk.p"]
	names(ord.cd4.nk) <- row.names(tests.main)
	ord.cd4.nk <- ord.cd4.nk[order(ord.cd4.nk)]
	names.ord.cd4.nk <- names(ord.cd4.nk)

	## CD8-CD14
	ord.cd8.cd14 <- tests.main[,"cd8.cd14.p"]
	names(ord.cd8.cd14) <- row.names(tests.main)
	ord.cd8.cd14 <- ord.cd8.cd14[order(ord.cd8.cd14)]
	names.ord.cd8.cd14 <- names(ord.cd8.cd14)

	## CD8-CD19
	ord.cd8.cd19 <- tests.main[,"cd8.cd19.p"]
	names(ord.cd8.cd19) <- row.names(tests.main)
	ord.cd8.cd19 <- ord.cd8.cd19[order(ord.cd8.cd19)]
	names.ord.cd8.cd19 <- names(ord.cd8.cd19)

	## CD8-gran
	ord.cd8.gran <- tests.main[,"cd8.gran.p"]
	names(ord.cd8.gran) <- row.names(tests.main)
	ord.cd8.gran <- ord.cd8.gran[order(ord.cd8.gran)]
	names.ord.cd8.gran <- names(ord.cd8.gran)

	## CD8-nk
	ord.cd8.nk <- tests.main[,"cd8.nk.p"]
	names(ord.cd8.nk) <- row.names(tests.main)
	ord.cd8.nk <- ord.cd8.nk[order(ord.cd8.nk)]
	names.ord.cd8.nk <- names(ord.cd8.nk)

	## CD14-CD19
	ord.cd14.cd19 <- tests.main[,"cd14.cd19.p"]
	names(ord.cd14.cd19) <- row.names(tests.main)
	ord.cd14.cd19 <- ord.cd14.cd19[order(ord.cd14.cd19)]
	names.ord.cd14.cd19 <- names(ord.cd14.cd19)

	## CD14-gran
	ord.cd14.gran <- tests.main[,"cd14.gran.p"]
	names(ord.cd14.gran) <- row.names(tests.main)
	ord.cd14.gran <- ord.cd14.gran[order(ord.cd14.gran)]
	names.ord.cd14.gran <- names(ord.cd14.gran)

	## CD14-nk
	ord.cd14.nk <- tests.main[,"cd14.nk.p"]
	names(ord.cd14.nk) <- row.names(tests.main)
	ord.cd14.nk <- ord.cd14.nk[order(ord.cd14.nk)]
	names.ord.cd14.nk <- names(ord.cd14.nk)

	## CD19-gran
	ord.cd19.gran <- tests.main[,"cd19.gran.p"]
	names(ord.cd19.gran) <- row.names(tests.main)
	ord.cd19.gran <- ord.cd19.gran[order(ord.cd19.gran)]
	names.ord.cd19.gran <- names(ord.cd19.gran)

	## CD19-nk
	ord.cd19.nk <- tests.main[,"cd19.nk.p"]
	names(ord.cd19.nk) <- row.names(tests.main)
	ord.cd19.nk <- ord.cd19.nk[order(ord.cd19.nk)]
	names.ord.cd19.nk <- names(ord.cd19.nk)

	## gran-nk
	ord.gran.nk <- tests.main[,"gran.nk.p"]
	names(ord.gran.nk) <- row.names(tests.main)
	ord.gran.nk <- ord.gran.nk[order(ord.gran.nk)]
	names.ord.gran.nk <- names(ord.gran.nk)

	init <- cbind(names.ord.anova,names.ord.cd4.cd8,names.ord.cd4.cd14,names.ord.cd4.cd19,names.ord.cd4.gran,names.ord.cd4.nk,names.ord.cd8.cd14,names.ord.cd8.cd19,names.ord.cd8.gran,names.ord.cd8.nk,names.ord.cd14.cd19,names.ord.cd14.gran,names.ord.cd14.nk,names.ord.cd19.gran,names.ord.cd19.nk,names.ord.gran.nk)

	keep.anova <- init[1:length.anova,"names.ord.anova"]

	list.rm.cd4.cd8 <- c(init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.cd8 <- unique(list.rm.cd4.cd8)
	ord.list.rm.cd4.cd8 <- setdiff(init[,"names.ord.cd4.cd8"],list.rm.cd4.cd8)

	list.rm.cd4.cd14 <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.cd14 <- unique(list.rm.cd4.cd14)
	ord.list.rm.cd4.cd14 <- setdiff(init[,"names.ord.cd4.cd14"],list.rm.cd4.cd14)

	list.rm.cd4.cd19 <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.cd19 <- unique(list.rm.cd4.cd19)
	ord.list.rm.cd4.cd19 <- setdiff(init[,"names.ord.cd4.cd19"],list.rm.cd4.cd19)

	list.rm.cd4.gran <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.gran <- unique(list.rm.cd4.gran)
	ord.list.rm.cd4.gran <- setdiff(init[,"names.ord.cd4.gran"],list.rm.cd4.gran)

	list.rm.cd4.nk <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.nk <- unique(list.rm.cd4.nk)
	ord.list.rm.cd4.nk <- setdiff(init[,"names.ord.cd4.nk"],list.rm.cd4.nk)

	list.rm.cd8.cd14 <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd8.cd14 <- unique(list.rm.cd8.cd14)
	ord.list.rm.cd8.cd14 <- setdiff(init[,"names.ord.cd8.cd14"],list.rm.cd8.cd14)

	list.rm.cd8.cd19 <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd8.cd19 <- unique(list.rm.cd8.cd19)
	ord.list.rm.cd8.cd19 <- setdiff(init[,"names.ord.cd8.cd19"],list.rm.cd8.cd19)

	list.rm.cd8.gran <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd8.gran <- unique(list.rm.cd8.gran)
	ord.list.rm.cd8.gran <- setdiff(init[,"names.ord.cd8.gran"],list.rm.cd8.gran)

	list.rm.cd8.nk <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd8.nk <- unique(list.rm.cd8.nk)
	ord.list.rm.cd8.nk <- setdiff(init[,"names.ord.cd8.nk"],list.rm.cd8.nk)

	list.rm.cd14.cd19 <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd14.cd19 <- unique(list.rm.cd14.cd19)
	ord.list.rm.cd14.cd19 <- setdiff(init[,"names.ord.cd14.cd19"],list.rm.cd14.cd19)

	list.rm.cd14.gran <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd14.gran <- unique(list.rm.cd14.gran)
	ord.list.rm.cd14.gran <- setdiff(init[,"names.ord.cd14.gran"],list.rm.cd14.gran)

	list.rm.cd14.nk <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd14.nk <- unique(list.rm.cd14.nk)
	ord.list.rm.cd14.nk <- setdiff(init[,"names.ord.cd14.nk"],list.rm.cd14.nk)

	list.rm.cd19.gran <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd19.gran <- unique(list.rm.cd19.gran)
	ord.list.rm.cd19.gran <- setdiff(init[,"names.ord.cd19.gran"],list.rm.cd19.gran)

	list.rm.cd19.nk <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd19.nk <- unique(list.rm.cd19.nk)
	ord.list.rm.cd19.nk <- setdiff(init[,"names.ord.cd19.nk"],list.rm.cd19.nk)

	list.rm.gran.nk <- c(init[1:length.pairs,"names.ord.cd4.cd8"],init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"])
	list.rm.gran.nk <- unique(list.rm.gran.nk)
	ord.list.rm.gran.nk <- setdiff(init[,"names.ord.gran.nk"],list.rm.gran.nk)

	keep.cd4.cd8 <- ord.list.rm.cd4.cd8[1:length.pairs]
	keep.cd4.cd14 <- ord.list.rm.cd4.cd14[1:length.pairs]
	keep.cd4.cd19 <- ord.list.rm.cd4.cd19[1:length.pairs]
	keep.cd4.gran <- ord.list.rm.cd4.gran[1:length.pairs]
	keep.cd4.nk <- ord.list.rm.cd4.nk[1:length.pairs]

	keep.cd8.cd14 <- ord.list.rm.cd8.cd14[1:length.pairs]
	keep.cd8.cd19 <- ord.list.rm.cd8.cd19[1:length.pairs]
	keep.cd8.gran <- ord.list.rm.cd8.gran[1:length.pairs]
	keep.cd8.nk <- ord.list.rm.cd8.nk[1:length.pairs]

	keep.cd14.cd19 <- ord.list.rm.cd14.cd19[1:length.pairs]
	keep.cd14.gran <- ord.list.rm.cd14.gran[1:length.pairs]
	keep.cd14.nk <- ord.list.rm.cd14.nk[1:length.pairs]

	keep.cd19.gran <- ord.list.rm.cd19.gran[1:length.pairs]
	keep.cd19.nk <- ord.list.rm.cd19.nk[1:length.pairs]

	keep.gran.nk <- ord.list.rm.gran.nk[1:length.pairs]

	## merge CpG sets to get final cpg list
	cpg.list <- c(keep.anova,keep.cd4.cd8,keep.cd4.cd14,keep.cd4.cd19,keep.cd4.gran,keep.cd4.nk,keep.cd8.cd14,keep.cd8.cd19,keep.cd8.gran,keep.cd8.nk,keep.cd14.cd19,keep.cd14.gran,keep.cd14.nk,keep.cd19.gran,keep.cd19.nk,keep.gran.nk)

	cpg.list <- unique(cpg.list)

	return(cpg.list)
}

#' Fit the model for the 6 main cell types
#'
#' @family Model fitting
#' @param data A data frame
#' @param cpg.list A character
#' @return A character
#' @export
fit.main.nosum1 <- function(data, cpg.list = cpg.list.main.stage1){

	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.main[match(cpg.list,row.names(med.main)),])

	fit.sub3 <- t(fit.sub3)

	colnames(fit.sub3) <- c("CD4","CD8","CD14","CD19","Gran","NK")

	return(fit.sub3)
}

## Functions to partition the whole blood beta in order to fit the two-stage model (refine CD4/CD8 estimates)
## 	and also to fit T and B cell subtype models
#' Partition whole blood beta for two-stage model fit inner
#'
#' @family Data partitioning
#' @param x
#' @param fit
#' @param keep.cols
#' @return A numeric matrix
get.beta.sub.inner <- function(x, fit, keep.cols){
	x <- as.numeric(x)
	keep.len <- length(keep.cols)
	sub.cols <- setdiff(seq(from=1,to=dim(fit)[2]),keep.cols)
	sub.len <- length(sub.cols)
	beta <- x[(sub.len+1):length(x)]
	blood <- x[1:sub.len]

	temp.sum <- 0
	for (i in (1:sub.len))
	{
		temp <- fit[,sub.cols[i]]*as.numeric(blood[i])
		temp.sum <- temp.sum+temp
	}
	temp2 <- beta-temp.sum
	return(temp2)
}

#' Partition whole blood beta for two-stage model fit
#'
#' @family Data partitioning
#' @param data A data frame
#' @param blood
#' @param fit
#' @param keep.cols
#' @return A numeric matrix
#' @export
get.beta.sub <- function(data, blood = med.main, fit, keep.cols){
	per.sum <- apply(fit,1,function(x){sum(x[keep.cols])})
	#blood.sub <- blood[,keep.cols]
	sub.cols <- setdiff(seq(from=1,to=dim(fit)[2]),keep.cols)
	keep.cpgs <- intersect(row.names(data),row.names(blood))
	data.all <- cbind(blood[keep.cpgs,sub.cols],data[keep.cpgs,])
	beta.sub <- t(apply(data.all,1,get.beta.sub.inner,fit=fit,keep.cols=keep.cols))
	beta.sub2 <- beta.sub/per.sum
	return(beta.sub)
}

## Stage 2 models to improve CD4/CD8 main cell type estimates -------------
## Stage 2b (CD4 vs. CD8)

# (should hard code in CpG list also)
#' Get CpG list for stage 2
#'
#' @family Generate list
#' @param length.pairs An integer numeric
#' @return A Character
#' @export
get.cpg.list.stage2b <- function(length.pairs = 100){
	## get keep list of CpGs for all pairwise comparisons

	## CD4-CD8
	ord.cd4.cd8 <- tests.main[,"cd4.cd8.p"]
	names(ord.cd4.cd8) <- row.names(tests.main)
	ord.cd4.cd8 <- ord.cd4.cd8[order(ord.cd4.cd8)]
	names.ord.cd4.cd8 <- names(ord.cd4.cd8)

	## CD4-CD14
	ord.cd4.cd14 <- tests.main[,"cd4.cd14.p"]
	names(ord.cd4.cd14) <- row.names(tests.main)
	ord.cd4.cd14 <- ord.cd4.cd14[order(ord.cd4.cd14)]
	names.ord.cd4.cd14 <- names(ord.cd4.cd14)

	## CD4-CD19
	ord.cd4.cd19 <- tests.main[,"cd4.cd19.p"]
	names(ord.cd4.cd19) <- row.names(tests.main)
	ord.cd4.cd19 <- ord.cd4.cd19[order(ord.cd4.cd19)]
	names.ord.cd4.cd19 <- names(ord.cd4.cd19)

	## CD4-gran
	ord.cd4.gran <- tests.main[,"cd4.gran.p"]
	names(ord.cd4.gran) <- row.names(tests.main)
	ord.cd4.gran <- ord.cd4.gran[order(ord.cd4.gran)]
	names.ord.cd4.gran <- names(ord.cd4.gran)

	## CD4-nk
	ord.cd4.nk <- tests.main[,"cd4.nk.p"]
	names(ord.cd4.nk) <- row.names(tests.main)
	ord.cd4.nk <- ord.cd4.nk[order(ord.cd4.nk)]
	names.ord.cd4.nk <- names(ord.cd4.nk)

	## CD8-CD14
	ord.cd8.cd14 <- tests.main[,"cd8.cd14.p"]
	names(ord.cd8.cd14) <- row.names(tests.main)
	ord.cd8.cd14 <- ord.cd8.cd14[order(ord.cd8.cd14)]
	names.ord.cd8.cd14 <- names(ord.cd8.cd14)

	## CD8-CD19
	ord.cd8.cd19 <- tests.main[,"cd8.cd19.p"]
	names(ord.cd8.cd19) <- row.names(tests.main)
	ord.cd8.cd19 <- ord.cd8.cd19[order(ord.cd8.cd19)]
	names.ord.cd8.cd19 <- names(ord.cd8.cd19)

	## CD8-gran
	ord.cd8.gran <- tests.main[,"cd8.gran.p"]
	names(ord.cd8.gran) <- row.names(tests.main)
	ord.cd8.gran <- ord.cd8.gran[order(ord.cd8.gran)]
	names.ord.cd8.gran <- names(ord.cd8.gran)

	## CD8-nk
	ord.cd8.nk <- tests.main[,"cd8.nk.p"]
	names(ord.cd8.nk) <- row.names(tests.main)
	ord.cd8.nk <- ord.cd8.nk[order(ord.cd8.nk)]
	names.ord.cd8.nk <- names(ord.cd8.nk)

	## CD14-CD19
	ord.cd14.cd19 <- tests.main[,"cd14.cd19.p"]
	names(ord.cd14.cd19) <- row.names(tests.main)
	ord.cd14.cd19 <- ord.cd14.cd19[order(ord.cd14.cd19)]
	names.ord.cd14.cd19 <- names(ord.cd14.cd19)

	## CD14-gran
	ord.cd14.gran <- tests.main[,"cd14.gran.p"]
	names(ord.cd14.gran) <- row.names(tests.main)
	ord.cd14.gran <- ord.cd14.gran[order(ord.cd14.gran)]
	names.ord.cd14.gran <- names(ord.cd14.gran)

	## CD14-nk
	ord.cd14.nk <- tests.main[,"cd14.nk.p"]
	names(ord.cd14.nk) <- row.names(tests.main)
	ord.cd14.nk <- ord.cd14.nk[order(ord.cd14.nk)]
	names.ord.cd14.nk <- names(ord.cd14.nk)

	## CD19-gran
	ord.cd19.gran <- tests.main[,"cd19.gran.p"]
	names(ord.cd19.gran) <- row.names(tests.main)
	ord.cd19.gran <- ord.cd19.gran[order(ord.cd19.gran)]
	names.ord.cd19.gran <- names(ord.cd19.gran)

	## CD19-nk
	ord.cd19.nk <- tests.main[,"cd19.nk.p"]
	names(ord.cd19.nk) <- row.names(tests.main)
	ord.cd19.nk <- ord.cd19.nk[order(ord.cd19.nk)]
	names.ord.cd19.nk <- names(ord.cd19.nk)

	## gran-nk
	ord.gran.nk <- tests.main[,"gran.nk.p"]
	names(ord.gran.nk) <- row.names(tests.main)
	ord.gran.nk <- ord.gran.nk[order(ord.gran.nk)]
	names.ord.gran.nk <- names(ord.gran.nk)

	init <- cbind(names.ord.cd4.cd8,names.ord.cd4.cd14,names.ord.cd4.cd19,names.ord.cd4.gran,names.ord.cd4.nk,names.ord.cd8.cd14,names.ord.cd8.cd19,names.ord.cd8.gran,names.ord.cd8.nk,names.ord.cd14.cd19,names.ord.cd14.gran,names.ord.cd14.nk,names.ord.cd19.gran,names.ord.cd19.nk,names.ord.gran.nk)

	list.rm.cd4.cd8 <- c(init[1:length.pairs,"names.ord.cd4.cd14"],init[1:length.pairs,"names.ord.cd4.cd19"],init[1:length.pairs,"names.ord.cd4.gran"],init[1:length.pairs,"names.ord.cd4.nk"],init[1:length.pairs,"names.ord.cd8.cd14"],init[1:length.pairs,"names.ord.cd8.cd19"],init[1:length.pairs,"names.ord.cd8.gran"],init[1:length.pairs,"names.ord.cd8.nk"],init[1:length.pairs,"names.ord.cd14.cd19"],init[1:length.pairs,"names.ord.cd14.gran"],init[1:length.pairs,"names.ord.cd14.nk"],init[1:length.pairs,"names.ord.cd19.gran"],init[1:length.pairs,"names.ord.cd19.nk"],init[1:length.pairs,"names.ord.gran.nk"])
	list.rm.cd4.cd8 <- unique(list.rm.cd4.cd8)
	ord.list.rm.cd4.cd8 <- setdiff(init[,"names.ord.cd4.cd8"],list.rm.cd4.cd8)

	keep.cd4.cd8 <- ord.list.rm.cd4.cd8[1:length.pairs]

	## merge CpG sets to get final cpg list
	cpg.list <- keep.cd4.cd8

	cpg.list <- unique(cpg.list)

	return(cpg.list)
}

#' Fit models for stage 2
#'
#' @family Model fitting
#' @param data A data frame
#' @param fit.main A numeric matrix
#' @param cpg.list A character
#' @return A numeric matrix
fit.stage2b <- function(data, fit.main, cpg.list = cpg.list.2b){

	t.per <- fit.main[,1]+fit.main[,2]
	cpg.list <- intersect(cpg.list,row.names(data))

	med.t <- med.main[,c(1,2)]

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.t[match(cpg.list,row.names(med.t)),])

	fit.sub3 <- t(fit.sub3)

	sum.fit <- apply(fit.sub3,1,sum)

	ratio <- sum.fit/t.per

	fit.sub3 <- fit.sub3/ratio

	fit.new <- cbind(fit.sub3[,1],fit.sub3[,2],fit.main[,3],fit.main[,4],fit.main[,5],fit.main[,6])
	colnames(fit.new) <- c("CD4","CD8","CD14","CD19","Gran","NK")

	return(fit.new)
}

### functions for CD4 subtypes -----------------------------------------------

## get CpG list for CD4 subtypes (should hard code in CpG list also)
#' Get CpG list for CD4 subtypes
#' @family Generate list
#' @param length.anova An integer numeric
#' @param length.pairs An integer numeric
#' @return A character
get.cpg.list.cd4.sub <- function(length.anova = 2100, length.pairs = 600){
	## get keep list of CpGs for overall ANOVA test for all types
	ord.anova <- tests.cd4.sub[,"cd4.anova.p"]
	names(ord.anova) <- row.names(tests.cd4.sub)
	ord.anova <- ord.anova[order(ord.anova)]
	names.ord.anova <- names(ord.anova)

	## get keep list of CpGs for all pairwise comparisons

	## Mem-Naive
	ord.mem.naive <- tests.cd4.sub[,"cd4.mem.naive.p"]
	names(ord.mem.naive) <- row.names(tests.cd4.sub)
	ord.mem.naive <- ord.mem.naive[order(ord.mem.naive)]
	names.ord.mem.naive <- names(ord.mem.naive)

	## Mem-Reg
	ord.mem.reg <- tests.cd4.sub[,"cd4.mem.reg.p"]
	names(ord.mem.reg) <- row.names(tests.cd4.sub)
	ord.mem.reg <- ord.mem.reg[order(ord.mem.reg)]
	names.ord.mem.reg <- names(ord.mem.reg)

	## Naive-Reg
	ord.naive.reg <- tests.cd4.sub[,"cd4.naive.reg.p"]
	names(ord.naive.reg) <- row.names(tests.cd4.sub)
	ord.naive.reg <- ord.naive.reg[order(ord.naive.reg)]
	names.ord.naive.reg <- names(ord.naive.reg)

	keep.anova <- names.ord.anova[1:length.anova]

	list.rm.mem.naive <- c(names.ord.mem.reg[1:length.pairs],names.ord.naive.reg[1:length.pairs])
	list.rm.mem.naive <- unique(list.rm.mem.naive)
	ord.list.rm.mem.naive <- setdiff(names.ord.mem.naive,list.rm.mem.naive)

	list.rm.mem.reg <- c(names.ord.mem.naive[1:length.pairs],names.ord.naive.reg[1:length.pairs])
	list.rm.mem.reg <- unique(list.rm.mem.reg)
	ord.list.rm.mem.reg <- setdiff(names.ord.mem.reg,list.rm.mem.reg)

	list.rm.naive.reg <- c(names.ord.mem.naive[1:length.pairs],names.ord.mem.reg[1:length.pairs])
	list.rm.naive.reg <- unique(list.rm.naive.reg)
	ord.list.rm.naive.reg <- setdiff(names.ord.naive.reg,list.rm.naive.reg)

	keep.mem.naive <- ord.list.rm.mem.naive[1:length.pairs]
	keep.mem.reg <- ord.list.rm.mem.reg[1:length.pairs]
	keep.naive.reg <- ord.list.rm.naive.reg[1:length.pairs]

	## merge CpG sets to get final cpg list
	cpg.list <- c(keep.anova,keep.mem.naive,keep.mem.reg,keep.naive.reg)

	cpg.list <- unique(cpg.list)

	return(cpg.list)
}

#(need to partition data into CD4 beta value first)
#' Fit model for CD4 subtypes on whole blood data
#'
#' @family Generate list
#' @param data A data frame
#' @param fit.main A numeric matrix
#' @param cpg.list A character
#' @return A numeric matrix
#' @export
fit.cd4.sub <- function(data, fit.main, cpg.list = cpg.list.cd4) {

	cd4.per <- fit.main[,1]
	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd4.sub[match(cpg.list,row.names(med.cd4.sub)),])

	fit.sub3 <- t(fit.sub3)

	sum.fit <- apply(fit.sub3,1,sum)

	ratio <- sum.fit/cd4.per

	fit.sub3 <- fit.sub3/ratio
	colnames(fit.sub3) <- c("CD4-Naive","CD4-Mem","CD4-Reg")

	return(fit.sub3)
}

#' Fit model for CD4 subtypes on M450 data from sorted CD4 T cells
#'
#' @family Model fitting
#' @param data A data frame
#' @param cpg.list A character
#' @return A numeric matrix
fit.cd4.sorted <- function(data, cpg.list = cpg.list.cd4){
	#cd4.per <- fit.main[,1]
	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd4.sub[match(cpg.list,row.names(med.cd4.sub)),])

	fit.sub3 <- t(fit.sub3)

	#sum.fit <- apply(fit.sub3,1,sum)

	#ratio <- sum.fit/cd4.per

	#fit.sub3 <- fit.sub3/ratio
	colnames(fit.sub3) <- c("CD4-Naive","CD4-Mem","CD4-Reg")

	return(fit.sub3)
}

## functions to fit model for CD8 subtypes ------------------------------------

#  (should hard code in this CpG list also)
#' Get CpG list for CD8 subtypes
#'
#' @family Generate list
#' @param length.list An integer numeric
#' @return A character
#' @export
get.cpg.list.cd8.sub <- function(length.list = 300){
	## get keep list of CpGs for overall ANOVA test for all types
	ord.list <- tests.cd8.sub[,"cd8.mem.naive.p"]
	names(ord.list) <- row.names(tests.cd8.sub)
	ord.list <- ord.list[order(ord.list)]
	names.ord.list <- names(ord.list)

		## merge CpG sets to get final cpg list
	cpg.list <- names.ord.list[1:length.list]

	cpg.list <- unique(cpg.list)

	return(cpg.list)
}

# (need to parition data into CD8 beta value first)
#' Fit model for CD8 subtypes for whole blood data
#'
#' @family Model fitting
#' @param data A data frame
#' @param fit.main A numeric matrix
#' @param cpg.list A character
#' @return A numeric matrix
#' @export
fit.cd8.sub <- function(data, fit.main, cpg.list = cpg.list.cd8){

	cd8.per <- fit.main[,2]
	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd8.sub[match(cpg.list,row.names(med.cd8.sub)),])

	fit.sub3 <- t(fit.sub3)

	sum.fit <- apply(fit.sub3,1,sum)

	ratio <- sum.fit/cd8.per

	fit.sub3 <- fit.sub3/ratio
	colnames(fit.sub3) <- c("CD8-Naive","CD8-Mem")

	return(fit.sub3)
}

#' Fit model for CD8 subtypes using M450 data from sorted CD8 T cells
#'
#' @family Model fitting
#' @param data A data frame
#' @param cpg.list A character
#' @return A numeric matrix
fit.cd8.sub.sorted <- function(data, cpg.list = cpg.list.cd8){

	#cd8.per <- fit.main[,2]
	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd8.sub[match(cpg.list,row.names(med.cd8.sub)),])

	fit.sub3 <- t(fit.sub3)

	#sum.fit <- apply(fit.sub3,1,sum)

	#ratio <- sum.fit/cd8.per

	#fit.sub3 <- fit.sub3/ratio
	colnames(fit.sub3) <- c("CD8-Naive","CD8-Mem")

	return(fit.sub3)
}

## models for CD19 B cell subtypes -----------------------------------------------

#(should hard code in CpG list also)
#' Function to get CpG list for CD19 B cell subtypes
#'
#' @family Model fitting
#' @param length.pairs An integer numeric
#' @return A character
#' @export
get.cpg.list.cd19.sub <- function(length.pairs = 300){
	## get keep list of CpGs for overall ANOVA test for all types
	ord.anova <- tests.cd19.sub[,"cd19.naive.mem.p"]
	names(ord.anova) <- row.names(tests.cd19.sub)
	ord.anova <- ord.anova[order(ord.anova)]
	names.ord.anova <- names(ord.anova)

	keep.anova <- names.ord.anova[1:length.pairs]

	cpg.list <- keep.anova

	cpg.list <- unique(cpg.list)

	return(cpg.list)
}

# (need to partition data into B cell beta score first)
#!! med.cd19.sub not available !!
#' Fit model for CD19 B cell subtypes for whole blood
#'
#' @family Model fitting
#' @param data A data frame
#' @param fit.main A numeric matrix
#' @param cpg.list A character
#' @return A numeric matrix
#' @export
fit.cd19.sub <- function(data, fit.main, cpg.list = cpg.list.cd19){

	cd19.per <- fit.main[,4]

	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd19.sub.2class[match(cpg.list,row.names(med.cd19.sub.2class)),])

	fit.sub3 <- t(fit.sub3)

	sum.fit <- apply(fit.sub3,1,sum)

	ratio <- sum.fit/cd19.per

	fit.sub3 <- fit.sub3/ratio

	colnames(fit.sub3) <- c("CD19-Naive","CD19-Mem")

	return(fit.sub3)
}

#' Fit model for CD19 subtypes using M450 data from sorted B cells
#'
#' @family Model fitting
#' @param data A data frame
#' @param cpg.list A character
#' @return A numeric matrix
#' @export
fit.cd19.sorted <- function(data, cpg.list = cpg.list.cd19){

	cpg.list <- intersect(cpg.list,row.names(data))

	fit.sub3 <- apply(data[match(cpg.list,row.names(data)),],2,fitNonneg.nosum1,med.cd19.sub.2class[match(cpg.list,row.names(med.cd19.sub.2class)),])

	fit.sub3 <- t(fit.sub3)

	colnames(fit.sub3) <- c("CD19-Naive","CD19-Mem")

	return(fit.sub3)
}

#' Get stage 1 & 2 estimates and T and B cell subtypes
#'
#' @family Subtype estimation
#' @param data A data frame
#' @return A numeric matrix
#' @export
est.all.wb <- function(data){
	## stage 1
	fit.stage1 <- fit.main.nosum1(data)

	## stage 2
	# t.data <- get.beta.sub(data[cpg.list.2b,],med.main,fit.stage1,c(1,2))
	# fit.stage2 <- fit.stage2b(t.data,fit.stage1,cpg.list.2b)

	## cd4 subtypes
	# data.cd4.partition <- get.beta.sub(data[cpg.list.cd4,],med.main,fit.stage2,1)
	# fit.data.cd4.sub <- fit.cd4.sub(data.cd4.partition,fit.stage2,cpg.list.cd4)

	# ## cd8 subtypes
	# data.cd8.partition <- get.beta.sub(data[cpg.list.cd8,],med.main,fit.stage2,2)
	# fit.data.cd8.sub <- fit.cd8.sub(data.cd8.partition,fit.stage2,cpg.list.cd8)

	# ## cd19 subtypes
	# data.cd19.partition <- get.beta.sub(data[cpg.list.cd19,],med.main,fit.stage2,4)
	# fit.data.cd19.sub <- fit.cd19.sub(data.cd19.partition,fit.stage2,cpg.list.cd19)

	# ## merge results together
	# res <- cbind(fit.stage2,fit.data.cd4.sub,fit.data.cd8.sub,fit.data.cd19.sub)

	# return(res)
}


#######DESCRIPTION###############################
#processes raw stage data from Indian CWC records
#outputs rdata object and csv
#################################################
#load libraries
library(dplyr)
library(data.table)
library(readr)
library(tidyr)
library(ncdf4)
library(tools)
##user inputs
#raw file location
dir_raw = '/Volumes/gonggong/flood forecasting/data/raw/stage/'
#output location
dir_dat = '/Volumes/gonggong/flood forecasting/data/'
#quality control flag - see qc_reference for a description of the flag values and methods
qc_thresh = 90
##process raw files
stage_list = list.files(paste0(dir_raw), pattern = '.nc')
date_ref = as.POSIXct('2000-01-01 00:00:00', "%Y-%m-%d %H:%M:%S", tz = 'GMT')
date_ref = data.table(date = seq(from = as.POSIXct('2000-01-01 00:00:00'), to = as.POSIXct(Sys.Date()), by = 'min'))
date_ref$date_ind = 0:(nrow(date_ref) - 1)
stage_dat = NULL
for(i in 1:length(stage_list)){
	sta_id_temp = file_path_sans_ext(stage_list[i])
	nc_temp = try(nc_open(paste0(dir_raw, stage_list[i])))
	if(length(nc_temp) > 1){
		stage_temp = ncvar_get(nc_temp, 'level')
		qc_temp = ncvar_get(nc_temp, 'QC')
		date_temp = ncvar_get(nc_temp, 'date')

		stage_dat_temp = data.table(sta_id = sta_id_temp, date_ind = date_temp, flag = qc_temp, stage = stage_temp)
		stage_dat = rbind_list(stage_dat, stage_dat_temp)
	}
}
stage_dat = stage_dat %>% left_join(date_ref) %>% dplyr::select(-date_ind) %>% dplyr::filter(flag >= qc_thresh)
#output processed files
write.csv(stage_dat, paste0(dir_dat, 'stage.csv'), row.names = F)
saveRDS(stage_dat, paste0(dir_dat, 'stage.csv'))


#!/usr/bin/env Rscript
library("optparse")
library(splines)
library(limma)
library(edgeR)
library(xlsx)

option_list = list(
                   make_option(c("-p", "--project-path"),
                               type="character",
                               default=NULL,
                               help="Project path",
                               metavar="character"),
                   make_option(c("-c", "--counts"),
                               type="character",
                               default=NULL,
                               help="Collected counts file ready for R.",
                               metavar="character"),
                   make_option(c("-s", "--strains"),
                               type="character",
                               default=NULL,
                               help="File describing strains and/or conditions.",
                               metavar="character"),
                   make_option(c("-o", "--output"),
                               type="character",
                               default=NULL,
                               help="Output path",
                               metavar="character"),
                   make_option(c("-f", "--filter"),
                               type="double",
                               default=0.5,
                               help="Filter threshold for CPM",
                               metavar="double")
                  );

opt <- parse_args(OptionParser(option_list=option_list), convert_hyphens_to_underscores=TRUE);
# set project path
setwd(opt$project_path)
# create results path
if (!(dir.exists(opt$output))) {dir.create(opt$output, recursive=TRUE)}

# write edgeR plots on this file
pdf(paste(opt$output, "edgeR_plots.pdf", sep="/"))

counts <- read.delim(opt$counts, header=T, row.names=1, sep=",")
counts <- counts[ , order(names(counts))]

# Plot mean-difference accross all pairs
# It's probably not worth doing this "per replicate" bases. It might make sense to see it "per averaged replicates" bases - which I haven't figured out how.

# box plot for counts
boxplot(log2(counts+1), las=1)
title('Gene level counts', ylab='log2(count+1)')

# bar plot for total counts
par(mar=c(5,6,4,2)+0.1,mgp=c(5,1,0)) # to avoid overlaping axis label/title
total_counts <- colSums(counts)
barplot(total_counts, las=1)
title('Total mapped read counts', ylab='Read counts')

## Make design matrix
conditions <- read.csv(opt$strains)
group <- factor(paste(conditions$Strain,conditions$Treatment,sep="."))
cbind(conditions,group=group)
design <- model.matrix(~0+group)
colnames(design) <- levels(group)

## Make new DGEList
y <- DGEList(counts=counts, group=group)

## This is a manual filter to keep only Features that have a CPM>0.5 in at least two sample. Features with less are
## considered not expressed and won't be included in comparisons.
## CPM bound depends very much on the read/genome size. A CPM corresponding to 10 counts should be aimed for. Ideally,
## this should not be a static value. Since we usually get generous amount of reads, it will be set to 0.5 for now.
## This may not apply in all conditions, so a switch as an argument might be useful later on.
keep <- rowSums(cpm(y)>opt$filter) >= 2
y <- y[keep, , keep.lib.sizes=FALSE]

## Calculate normalization factor to account for library size
y <- calcNormFactors(y, method='upperquartile')

# Plot for MDS
plotMDS(y)
title('Fold-change based multi-dimensional scaling (MDS) plot')

## normalize by library size, and estimate dispersion allowing possible trend with average count size
y <- estimateDisp(y, design, robust=TRUE)

# Plot for MDS
plotMDS(y, method='BCV')
title('Biological coefficient of variation based multi-dimensional scaling (MDS) plot')

# plot BCV for replicates
plotBCV(y)
title('Biological coefficient of variation')

## Run an Exact Test for Differences between Two Negative Binomial Groups
#et <- exactTest(y)

fit <- glmQLFit(y, design, robust=TRUE)
# generate comparison string based in available groups to make pairwise comparisons for all
constr <- paste(combn(levels(group), 2, simplify=TRUE, FUN=function(x) {sprintf("%s_vs_%s=%s-%s", x[1], x[2], x[1], x[2])}), sep=', ')
con <- makeContrasts(contrasts=constr, levels=design)

# Create the excel file for results and design
wb <- createWorkbook()
saveWorkbook(wb, paste(opt$output, "edgeR_pairwise_comparisons.xlsx", sep='/'))
write.xlsx(con, paste(opt$output, "edgeR_pairwise_comparisons.xlsx", sep='/'), sheetName ="Comparisons", append=TRUE)
write.xlsx(counts, paste(opt$output, "edgeR_pairwise_comparisons.xlsx", sep='/'), sheetName ="Counts", append=TRUE)

for (i in colnames(con)){
	lrt = glmLRT(fit, contrast=con[,i])
	assign(i, topTags(lrt, n=nrow(y))$table)
	write.xlsx(get(i), paste(opt$output, "edgeR_pairwise_comparisons.xlsx", sep='/'), sheetName = i, append = TRUE)
	dt <- decideTestsDGE(lrt)
	isDE <- as.logical(dt)
	DEnames <- rownames(y)[isDE]
	plotSmear(lrt, de.tags=DEnames)
	abline(h=c(-1,1), col="blue")
	title(con[1])
}
dev.off()


readcube <- function(fname, drpcat=NULL) {
    require(FITSio)
    ff <- file(fname, "rb")
    hd0 <- parseHdr(readFITSheader(ff))
    mangaid <- hd0[grep("MANGAID", hd0)+1]
    plateifu <- hd0[grep("PLATEIFU", hd0)+1]
    ra <- as.numeric(hd0[grep("IFURA", hd0)+1])
    dec <- as.numeric(hd0[grep("IFUDEC", hd0)+1])
    l <- as.numeric(hd0[grep("IFUGLON", hd0)+1])
    b <- as.numeric(hd0[grep("IFUGLAT", hd0)+1])
    ebv <- as.numeric(hd0[grep("EBVGAL", hd0)+1])
    hd0 <- parseHdr(readFITSheader(ff))
    cra <- as.numeric(hd0[grep("CRVAL1", hd0)+1])
    cdec <- as.numeric(hd0[grep("CRVAL2", hd0)+1])
    cpix1 <- as.numeric(hd0[grep("CRPIX1", hd0)+1])
    cpix2 <- as.numeric(hd0[grep("CRPIX2", hd0)+1])
    cd1 <- as.numeric(hd0[grep("CD1_1", hd0)+1])
    cd2 <- as.numeric(hd0[grep("CD2_2", hd0)+1])
    close(ff)

    flux <- readFITS(fname, hdu=1)$imDat
    ivar <- readFITS(fname, hdu=2)$imDat
    mask <- readFITS(fname, hdu=3)$imDat
    lambda <- readFITS(fname, hdu=4)$imDat
    ivar[ivar <= 0] <- NA
    ivar[mask >= 1024] <- NA
    flux[is.na(ivar)] <- NA
    extc <- elaw(lambda, ebv)
    nx <- dim(flux)[1]
    ny <- dim(flux)[2]
    for (ix in 1:nx) {
        for (iy in 1:ny) {
            flux[ix,iy,] <- flux[ix,iy,]*extc
            ivar[ix,iy,] <- ivar[ix,iy,]/extc^2
        }
    }
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), c(1,2), median, na.rm=TRUE)
    xpos <- (1:nx-cpix1)*cd1
    ypos <- (1:ny-cpix2)*cd2
    phi <- function(x,y) atan2(-y, x)
    rho <- function(x,y) sqrt(x^2 + y^2)
    long <- outer(xpos, ypos, phi)
    lat <- atan(180/pi/outer(xpos, ypos, rho))
    dec.f <- 180/pi*asin(sin(lat)*sin(cdec*pi/180) - cos(lat)*cos(long)*cos(cdec*pi/180))
    ra.f <- cra + 180/pi*atan2(cos(lat)*sin(long),
                               sin(lat)*cos(cdec*pi/180) + cos(lat)*cos(long)*sin(cdec*pi/180))
    gimg <- readFITS(fname, hdu=8)$imDat*elaw(4640.4,ebv)
    rimg <- readFITS(fname, hdu=9)$imDat*elaw(6122.3,ebv)
    iimg <- readFITS(fname, hdu=10)$imDat*elaw(7439.5,ebv)
    zimg <- readFITS(fname, hdu=11)$imDat*elaw(8897.1,ebv)
    if (!is.null(drpcat)) {
        ind <- which(drpcat$plateifu == plateifu)
        z <- drpcat$nsa_z[ind]
        zdist <- drpcat$nsa_zdist[ind]
    } else {
        z <- zdist <- NA
    }
    list(meta=list(mangaid=mangaid, plateifu=plateifu, ra=ra, dec=dec, l=l, b=b,
                   ebv=ebv, z=z, zdist=zdist, cpix=c(cpix1, cpix2)),
        xpos=xpos, ypos=ypos,
        lambda=lambda, ra.f=ra.f, dec.f=dec.f, flux=flux, ivar=ivar, snr=snr,
         gimg=gimg, rimg=rimg, iimg=iimg, zimg=zimg)
}

readrss <- function(fname, drpcat=NULL, ndither=3) {
    require(FITSio)
    ff <- file(fname, "rb")
    hd0 <- parseHdr(readFITSheader(ff))
    mangaid <- hd0[grep("MANGAID", hd0)+1]
    plateifu <- hd0[grep("PLATEIFU", hd0)+1]
    nexp <- as.numeric(hd0[grep("NEXP", hd0)+1])
    ra <- as.numeric(hd0[grep("IFURA", hd0)+1])
    dec <- as.numeric(hd0[grep("IFUDEC", hd0)+1])
    l <- as.numeric(hd0[grep("IFUGLON", hd0)+1])
    b <- as.numeric(hd0[grep("IFUGLAT", hd0)+1])
    ebv <- as.numeric(hd0[grep("EBVGAL", hd0)+1])
    close(ff)

    flux <- readFITS(fname, hdu=1)$imDat
    ivar <- readFITS(fname, hdu=2)$imDat
    mask <- readFITS(fname, hdu=3)$imDat
    lambda <- as.vector(readFITS(fname, hdu=5)$imDat)
    xpos <- readFITS(fname, hdu=9)$imDat
    ypos <- readFITS(fname, hdu=10)$imDat
    xpos <- apply(xpos, 2, mean)
    ypos <- apply(ypos, 2, mean)
    ivar[ivar <= 0] <- NA
    ivar[mask >= 1024] <- NA
    flux[is.na(ivar)] <- NA
    extc <- elaw(lambda, ebv)
    flux <- flux*extc
    ivar <- ivar/extc^2
    nl <- nrow(flux)
    ns <- nexp/ndither
    npos <- ncol(flux)/ns
    xy <- data.frame(x=xpos, y=ypos)
    txy <- SearchTrees::createTree(xy)
    neighbors <- as.vector(SearchTrees::knnLookup(txy, newdat=xy[1:npos,], k=ns))
    flux <- flux[,neighbors]
    ivar <- ivar[,neighbors]
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), 2, median, na.rm=TRUE)
    flux <- array(t(flux), dim=c(npos, ns, nl))
    ivar <- array(t(ivar), dim=c(npos, ns, nl))
    snr <- matrix(snr, npos, ns)
    xpos <- matrix(xpos[neighbors], npos, ns)
    ypos <- matrix(ypos[neighbors], npos, ns)
    if (!is.null(drpcat)) {
        ind <- which(drpcat$plateifu == plateifu)
        z <- drpcat$nsa_z[ind]
        zdist <- drpcat$nsa_zdist[ind]
    } else {
        z <- zdist <- NA
    }
    list(meta=list(mangaid=mangaid, plateifu=plateifu, nexp=nexp, ra=ra, dec=dec, l=l, b=b,
                   ebv=ebv, z=z, zdist=zdist),
         lambda=lambda, flux=flux, ivar=ivar, snr=snr,
         xpos=xpos, ypos=ypos
        )
}

stackrss <- function(gdat, dz=NULL) {
    meta <- gdat$meta
    ivar <- apply(gdat$ivar, c(1,3), sum, na.rm=TRUE)
    ivar[ivar <= 0] <- NA
    flux <- apply(gdat$flux*gdat$ivar, c(1,3), sum, na.rm=TRUE)/ivar
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), 1, median, na.rm=TRUE)
    nr <- nrow(flux)
    nc <- ncol(flux)
    dim(flux) <- c(nr, 1, nc)
    dim(ivar) <- c(nr, 1, nc)
    snr <- matrix(snr, nr, 1)
    if (!is.null(dz)) {
        dz <- rowMeans(dz, na.rm=TRUE)
    }
    xpos <- rowMeans(gdat$xpos)
    ypos <- rowMeans(gdat$ypos)
    dec.f <- meta$dec + ypos/3600
    ra.f <- meta$ra - xpos/3600/cos(dec.f*pi/180)
    list(meta=meta, lambda=gdat$lambda, flux=flux, ivar=ivar, snr=snr,
         xpos=xpos, ypos=ypos, ra.f=ra.f, dec.f=dec.f, dz=dz)
}

## Galactic extinction correction from Fitzpatrick (1998): http://arxiv.org/abs/astro-ph/9809387v1
## This is spline fit portion valid from near-UV to near-IR and R=3.1

elaw <- function(lambda, ebv) {
  il <- c(0,0.377,0.820,1.667,1.828,2.141,2.433,3.704,3.846)
  al <- c(0,0.265,0.829,2.688,3.055,3.806,4.315,6.265,6.591)
  fai <- splinefun(il,al)
  10^(0.4*fai(10000/lambda)*ebv)
}


library(Matrix)

handler <- function() {
	return(Matrix(1:6, 3, 2)[,2])
}


suppressPackageStartupMessages(library("optparse"))

option_list <- list(
    make_option(c("-s", "--silent"), action="store_true",
        help="Silent mode to reduce logs"),
    make_option(c("-n", "--number"), type="integer", default=5,
        help="Number of number to generate [default %default]",
        metavar="number"),
    make_option(c("-w", "--word"), default="word",
        help = "Word to use [default \"%default\"]")
    )

opt <- parse_args(OptionParser(option_list=option_list))

if ( opt$verbose ) {
    write("writing some verbose output to standard error...\n", stderr())
}

if( opt$generator == "rnorm") {
    cat(paste(rnorm(opt$count, mean=opt$mean, sd=opt$sd), collapse="\n"))
} else {
    cat(paste(do.call(opt$generator, list(opt$count)), collapse="\n"))
}
cat("\n")