file.name<-'ICES stock summary sum'             # graphical output file if paper<-TRUE

first.year<-2004              #first year on plot, negative value means value defined by data
last.year<- 2013                 #last year on plot

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

ref<-Read.reference.points.OP()
Init.function()
Blim<-as.vector(ref[,'Blim'])
Bpa<-as.vector(ref[,'Bpa'])
Fpa<-as.vector(ref[,'Fpa'])

a<-subset(Read.summary.data(), select=c(Species.n,Species,Year,Age,Yield))
price<-Read.price()
a<-merge(a,price)
a$Value<-a$Price*a$Yield
a<-aggregate(Value~Species.n+Species+Year,data=a,sum)

b<-Read.summary.table()
b<-merge(a,b)

b<-droplevels(subset(b,Species !='Plaice' & Species !='Sole' & Year>=first.year & Year<=last.year))
b$belowBlim<-ifelse(b$SSB<Blim[b$Species.n-first.VPA+1],1,0)
b$belowBpa<-ifelse(b$SSB<Bpa[b$Species.n-first.VPA+1],1,0)
b$aboveFpa<-ifelse(b$mean.F>Fpa[b$Species.n-first.VPA+1],1,0)

minY<-min(b$Year)
maxY<-max(b$Year)
ny<-maxY-minY+1

  a<-aggregate(cbind(Yield,SOP,Value,SSB,mean.F)~Species.n+Species,mean,data=b)

  aa<-aggregate(cbind(belowBlim,belowBpa,aboveFpa)~Species.n+Species,sum,data=b)

  aa$belowBlim<- aa$belowBlim/ny*100
  aa$belowBpa<- aa$belowBpa/ny*100
  aa$aboveFpa<- aa$aboveFpa/ny*100

  aa<-merge(a,aa)
  aa$labels<-paste(aa$Species.n-first.VPA+1,aa$Species)

  a<-cbind(
    t(t(tapply(aa$Yield,aa$labels,sum)/1000)),
    t(t(tapply(aa$SOP,aa$labels,sum)/1000)),
    t(t(tapply(aa$Value,aa$labels,sum)/1000)),
    t(t(tapply(aa$SSB,aa$labels,sum)/1000)) ,
     t(t(tapply(aa$mean.F,aa$labels,sum))),
    t(t(tapply(aa$belowBlim,aa$labels,sum))),
    t(t(tapply(aa$belowBpa,aa$labels,sum))),
    t(t(tapply(aa$aboveFpa,aa$labels,sum))))

  all<-colSums(a)
  all[5:8]<-NA

  a<-rbind(a,all)

  my.dimnames<-c('Yield','Catch','Value','SSB','Fbar','SSB below Blim','SSB below Bpa','F above Fpa')

  dimnames(a)[[2]]<-my.dimnames

  print(a)
  my.units<-c('(kt)','(kt)','(m Euro)','(kt)',' ','(%)','(%)','(%)')
  my.dec<-c(0,0,0,0,2,0,0,0)

  xtab(a, caption='', cornername='  ',
             file=file.path(paste('hist_performance_',first.year,'-',last.year,'.html',sep='')),
             dec=my.dec, width='"100%"',units=my.units)


#Code that uses Cox PH models to associate observed-to-expected neoantigen ratio in initial or recurent tumors with overall survival and surgical interval
#Cox PH models that associate overall survival with observed-to-expected neoantigen ratio are reported in the manuscript
#Query at the top adapted from Kevin, joins neoantigen depletion with other tables to perform survival analyses
#Other analyses (not reported in manuscript):
#	Correlates surgical interval with observed-to-expected neoantigen ratio (no association)
#	Query and then Cox model to examine association between neoantigen load with overall survival (no association, reviewer request)
#	Query to look at observed-to-expected neoantigen ratio in samples treated with immunotherapy (nothing of note)
#------------------------------------------------------------------------------

library(odbc)
library(DBI)
library(ggplot2)
library(survival)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "WITH roman_to_int (grade, grade_int)
AS
(
     VALUES ('I', 1),
            ('II', 2),
            ('III', 3),
            ('IV', 4)
)
SELECT
    tp.tumor_pair_barcode,
    tp.case_barcode,
    tp.tumor_barcode_a,
    tp.tumor_barcode_b,
	clin.idh_codel_subtype AS subtype,
	cas1.case_age_diagnosis_years AS age,
    (CASE
     WHEN s1.surgery_location = s2.surgery_location AND (s1.surgery_laterality = s2.surgery_laterality OR (s1.surgery_laterality IS NULL AND s2.surgery_laterality IS NULL)) THEN 'Local'
     WHEN s1.surgery_location <> s2.surgery_location OR s1.surgery_laterality <> s2.surgery_laterality THEN 'Distal'
     END) AS recurrence_location,
    (SELECT bool_or(treatment_tmz) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_tmz,
    (SELECT sum(treatment_tmz_cycles) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number)::integer AS received_tmz_sum_cycles,
    (SELECT bool_or(treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt,
    (SELECT sum(treatment_radiation_dose_gy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt_sum_gy,
    (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_alk,
    (SELECT bool_or(treatment_alkylating_agent or treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_treatment,
    (CASE
     WHEN r2.grade_int > r1.grade_int THEN 'Grade up'
     WHEN r2.grade_int = r1.grade_int THEN 'Grade stable'
     WHEN r2.grade_int < r1.grade_int THEN 'Grade down'
     END) AS grade_change,
    s2.surgical_interval_mo - s1.surgical_interval_mo AS surgical_interval,
    1 AS surgery,
    cas1.case_overall_survival_mo AS OS,
    CASE WHEN cas1.case_vital_status='alive' THEN 0 WHEN cas1.case_vital_status='dead' THEN 1 END AS case_vital_status,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 THEN false
     ELSE NULL
     END) hypermutator_status,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN false
     ELSE NULL
     END) alk_assoc_hypermutator_status,
     CASE WHEN nd1.rneo < 1 THEN 1 WHEN nd1.rneo >=1 THEN 0 END AS depletion_initial,
     CASE WHEN nd2.rneo < 1 THEN 1 WHEN nd2.rneo >=1 THEN 0 END AS depletion_recurrent
FROM analysis.tumor_pairs tp
LEFT JOIN biospecimen.aliquots a1 ON a1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN biospecimen.aliquots a2 ON a2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.surgeries s1 ON s1.sample_barcode = a1.sample_barcode
LEFT JOIN clinical.surgeries s2 ON s2.sample_barcode = a2.sample_barcode
LEFT JOIN roman_to_int r1 ON r1.grade = s1.grade
LEFT JOIN roman_to_int r2 ON r2.grade = s2.grade
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN analysis.neoantigen_depletion nd1 ON nd1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.neoantigen_depletion nd2 ON nd2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = s1.case_barcode
LEFT JOIN clinical.cases cas1 ON cas1.case_barcode = s1.case_barcode
INNER JOIN analysis.gold_set gs ON gs.case_barcode = tp.case_barcode
WHERE nd1.rneo IS NOT NULL AND nd2.rneo IS NOT NULL AND (nd1.nobs >= 3 AND nd2.nobs >= 3)
"

res <- dbGetQuery(con, q)

#surg_cox_a <- coxph(Surv(surgical_interval,surgery) ~ nd_a + subtype, data = res)
#surg_cox_b <- coxph(Surv(surgical_interval,surgery) ~ nd_b + subtype, data = res)

os_cox_a <- summary(coxph(Surv(os,case_vital_status) ~ depletion_initial + age + subtype, data = res))
os_cox_b <- summary(coxph(Surv(os,case_vital_status) ~ depletion_recurrent + age + subtype, data = res))

surg_cox_a <- coxph(Surv(surgical_interval,surgery) ~ nd_a + subtype + received_treatment, data = res)
surg_cox_b <- coxph(Surv(surgical_interval,surgery) ~ nd_b + subtype + received_treatment, data = res)

cor(res[,"surgical_interval"],res[,"nd_b"],method="s",use="complete")

#Neoantigen load
#----------------
library(odbc)
library(DBI)
library(ggplot2)
library(survival)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "WITH roman_to_int (grade, grade_int)
AS
(
     VALUES ('I', 1),
            ('II', 2),
            ('III', 3),
            ('IV', 4)
)
SELECT
    tp.tumor_pair_barcode,
    tp.case_barcode,
    tp.tumor_barcode_a,
    tp.tumor_barcode_b,
	clin.idh_codel_subtype AS subtype,
	cas1.case_age_diagnosis_years AS age,
    (CASE
     WHEN s1.surgery_location = s2.surgery_location AND (s1.surgery_laterality = s2.surgery_laterality OR (s1.surgery_laterality IS NULL AND s2.surgery_laterality IS NULL)) THEN 'Local'
     WHEN s1.surgery_location <> s2.surgery_location OR s1.surgery_laterality <> s2.surgery_laterality THEN 'Distal'
     END) AS recurrence_location,
    (SELECT bool_or(treatment_tmz) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_tmz,
    (SELECT sum(treatment_tmz_cycles) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number)::integer AS received_tmz_sum_cycles,
    (SELECT bool_or(treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt,
    (SELECT sum(treatment_radiation_dose_gy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt_sum_gy,
    (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_alk,
    (SELECT bool_or(treatment_alkylating_agent or treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_treatment,
    (CASE
     WHEN r2.grade_int > r1.grade_int THEN 'Grade up'
     WHEN r2.grade_int = r1.grade_int THEN 'Grade stable'
     WHEN r2.grade_int < r1.grade_int THEN 'Grade down'
     END) AS grade_change,
    s2.surgical_interval_mo - s1.surgical_interval_mo AS surgical_interval,
    1 AS surgery,
    cas1.case_overall_survival_mo AS OS,
    CASE WHEN cas1.case_vital_status='alive' THEN 0 WHEN cas1.case_vital_status='dead' THEN 1 END AS case_vital_status,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 THEN false
     ELSE NULL
     END) hypermutator_status,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN false
     ELSE NULL
     END) alk_assoc_hypermutator_status,
     CAST(COALESCE(nd1.neoag_count,0) AS numeric) AS neoag_load_a,
     CAST(COALESCE(nd2.neoag_count,0) AS numeric) AS neoag_load_b
FROM analysis.tumor_pairs tp
LEFT JOIN biospecimen.aliquots a1 ON a1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN biospecimen.aliquots a2 ON a2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.surgeries s1 ON s1.sample_barcode = a1.sample_barcode
LEFT JOIN clinical.surgeries s2 ON s2.sample_barcode = a2.sample_barcode
LEFT JOIN roman_to_int r1 ON r1.grade = s1.grade
LEFT JOIN roman_to_int r2 ON r2.grade = s2.grade
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN analysis.neoag_freq nd1 ON nd1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.neoag_freq nd2 ON nd2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = s1.case_barcode
LEFT JOIN clinical.cases cas1 ON cas1.case_barcode = s1.case_barcode
INNER JOIN analysis.gold_set gs ON gs.case_barcode = tp.case_barcode
"

res <- dbGetQuery(con, q)

os_cox_a <- summary(coxph(Surv(os,case_vital_status) ~ neoag_load_a + age + subtype, data = res))
os_cox_b <- summary(coxph(Surv(os,case_vital_status) ~ neoag_load_b + age+  subtype, data = res))

#Immunotherapy
#----------------

library(odbc)
library(DBI)
library(ggplot2)
library(survival)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "
WITH roman_to_int (grade, grade_int)
AS
(
     VALUES ('I', 1),
            ('II', 2),
            ('III', 3),
            ('IV', 4)
)
SELECT
    tumor_pair_barcode,
    tp.case_barcode,
    tumor_barcode_a,
    tumor_barcode_b,
	clin.idh_codel_subtype AS subtype,
    (CASE
     WHEN s1.surgery_location = s2.surgery_location AND (s1.surgery_laterality = s2.surgery_laterality OR (s1.surgery_laterality IS NULL AND s2.surgery_laterality IS NULL)) THEN 'Local'
     WHEN s1.surgery_location <> s2.surgery_location OR s1.surgery_laterality <> s2.surgery_laterality THEN 'Distal'
     END) AS recurrence_location,
    (SELECT bool_or(treatment_tmz) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_tmz,
    (SELECT sum(treatment_tmz_cycles) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number)::integer AS received_tmz_sum_cycles,
    (SELECT bool_or(treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt,
    (SELECT sum(treatment_radiation_dose_gy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_rt_sum_gy,
    (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_alk,
    (SELECT bool_or(treatment_alkylating_agent or treatment_radiotherapy) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) AS received_treatment,
    (CASE
     WHEN r2.grade_int > r1.grade_int THEN 'Grade up'
     WHEN r2.grade_int = r1.grade_int THEN 'Grade stable'
     WHEN r2.grade_int < r1.grade_int THEN 'Grade down'
     END) AS grade_change,
    s2.surgical_interval_mo - s1.surgical_interval_mo AS surgical_interval,
    1 AS surgery,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 THEN false
     ELSE NULL
     END) hypermutator_status,
    (CASE
     WHEN mf2.coverage_adj_mut_freq > mf1.coverage_adj_mut_freq AND mf2.coverage_adj_mut_freq > 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN true
     WHEN mf2.coverage_adj_mut_freq < 10 AND (SELECT bool_or(treatment_alkylating_agent) FROM clinical.surgeries ss WHERE ss.case_barcode = tp.case_barcode AND ss.surgery_number >= s1.surgery_number AND ss.surgery_number < s2.surgery_number) IS TRUE THEN false
     ELSE NULL
     END) alk_assoc_hypermutator_status,
	 s1.treatment_chemotherapy_other AS immunotherapy_a,
	 s2.treatment_chemotherapy_other AS immunotherapy_b,
     nd1.rneo AS nd_a,
     nd2.rneo AS nd_b
FROM analysis.tumor_pairs tp
LEFT JOIN biospecimen.aliquots a1 ON a1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN biospecimen.aliquots a2 ON a2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.surgeries s1 ON s1.sample_barcode = a1.sample_barcode
LEFT JOIN clinical.surgeries s2 ON s2.sample_barcode = a2.sample_barcode
LEFT JOIN roman_to_int r1 ON r1.grade = s1.grade
LEFT JOIN roman_to_int r2 ON r2.grade = s2.grade
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN analysis.neoantigen_depletion nd1 ON nd1.aliquot_barcode = tp.tumor_barcode_a
LEFT JOIN analysis.neoantigen_depletion nd2 ON nd2.aliquot_barcode = tp.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = s1.case_barcode
WHERE (nd1.rneo IS NOT NULL AND nd2.rneo IS NOT NULL AND (nd1.nobs >= 3 AND nd2.nobs >= 3)) AND
	s1.treatment_chemotherapy_other LIKE '%embrolizumab%' OR s2.treatment_chemotherapy_other LIKE '%embrolizumab%' OR
	s1.treatment_chemotherapy_other LIKE 'DC%' OR s2.treatment_chemotherapy_other LIKE 'DC%' OR
	s1.treatment_chemotherapy_other LIKE '%endritic%' OR s2.treatment_chemotherapy_other LIKE '%endritic%' OR
	s1.treatment_chemotherapy_other LIKE '%accine%' OR s2.treatment_chemotherapy_other LIKE '%accine%' OR
	s1.treatment_chemotherapy_other LIKE '%dc%ax%' OR s2.treatment_chemotherapy_other LIKE '%dc%ax%'
"

res <- dbGetQuery(con, q)


# Data Wrangling in R
# Austin Water Quality Case Study

# Load in the libraries that we'll need
library(tidyverse)
library(stringr)
library(lubridate)

# Read in the dataset
water <- read_csv('http://594442.youcanlearnit.net/austinwater.csv')

# Let's take a look at what we have
glimpse(water)

# First, let's get rid of a lot of columns that we don't need
# I'm going to do that by building a new tibble with just
# siteName, siteType, parameter, result and unit

water <- tibble('siteName'=water$SITE_NAME,
                'siteType'=water$SITE_TYPE,
                'sampleTime'=water$SAMPLE_DATE,
                'parameterType'=water$PARAM_TYPE,
                'parameter'=water$PARAMETER,
                'result'=water$RESULT,
                'unit'=water$UNIT)

glimpse(water)

# Now let's start finding the rows that we need.
# First, we need pH.  I might start by trying to look at all unique parameter names

unique(water$parameter)

# but that's way too long... what if we try searching for names that contain PH?

unique(water[which(str_detect(water$parameter,'PH')),]$parameter)

# still a mess... let's backtrack and look at parameter types

unique(water$parameterType)

# OK, what if I filter this down to look only at parameter types of Alkalinity/Hardness/pH
# and Conventionals

filtered_water <- subset(water,(parameterType=='Alkalinity/Hardness/pH') |
                                  parameterType=='Conventionals')

# Notice that this is much smaller in size.  let's check what parameters we have now

unique(filtered_water$parameter)

# I want only two of these, (discuss PH and temp choices), so let's filter those

filtered_water <- subset(filtered_water, ((parameter=='PH') |
                                            (parameter=='WATER TEMPERATURE')))

glimpse(filtered_water)

# Let's take a look at the data a different way
summary(filtered_water)

# It would be helpful to convert some of these to factors
filtered_water$siteType <- as.factor(filtered_water$siteType)
filtered_water$parameterType <- as.factor(filtered_water$parameterType)
filtered_water$parameter <- as.factor(filtered_water$parameter)
filtered_water$unit <- as.factor(filtered_water$unit)

summary(filtered_water)

# And sampleTime should be a date/time object
filtered_water$sampleTime <- mdy_hms(filtered_water$sampleTime)

summary(filtered_water)

# Why are some of these measurements in feet?
subset(filtered_water,unit=='Feet')

# Looks like that is supposed to be Farenheit
convert <- which(filtered_water$unit=='Feet')
filtered_water$unit[convert] <- 'Deg. Fahrenheit'

summary(filtered_water)

# What about the MG/L?
subset(filtered_water,unit=='MG/L')
subset(filtered_water,unit=='MG/L' & parameter=='PH')

convert <- which(filtered_water$unit=='MG/L' & filtered_water$parameter=='PH')
filtered_water$unit[convert] <- 'Standard units'

subset(filtered_water,unit=='MG/L')
subset(filtered_water,unit=='MG/L' & filtered_water$result>70)
convert <- which(filtered_water$unit=='MG/L' & filtered_water$result>70)
filtered_water$unit[convert] <- 'Deg. Fahrenheit'

subset(filtered_water,unit=='MG/L')
convert <- which(filtered_water$unit=='MG/L')
filtered_water$unit[convert] <- 'Deg. Celsius'

summary(filtered_water)

# Let's just take a quick and dirty look at all of our results
ggplot(filtered_water,mapping=aes(x=sampleTime, y=result)) +
  geom_point()

# There's clearly one large outlier
subset(filtered_water,result>1000000)

# I don't know how to correct that, so I'm going to remove it.  I also want to remove the NA result
remove <- which(filtered_water$result>1000000 | is.na(filtered_water$result))
filtered_water <- filtered_water[-remove,]

summary(filtered_water)

# Still some very high values, so let's repeat
subset(filtered_water,result>1000)

remove <- which(filtered_water$result>1000 | is.na(filtered_water$result))
filtered_water <- filtered_water[-remove,]

summary(filtered_water)

# That looks better.  Let's drill into some boxplots now

ggplot(data=filtered_water, mapping = aes(x=unit,y=result)) + geom_boxplot()

# Those Celsius values over 60 should probably  be Fahrenheit
# Because 60 degrees Celsius is 140 degrees Fahrenheit!

convert <- which(filtered_water$result>60 & filtered_water$unit=='Deg. Celsius')
filtered_water$unit[convert] <- 'Deg. Fahrenheit'

# Let's look at the boxplots again

ggplot(data=filtered_water, mapping = aes(x=unit,y=result)) + geom_boxplot()

# Let's find our Fahrenheit values in the dataset
fahrenheit <- which(filtered_water$unit=='Deg. Fahrenheit')

# And convert them to Celsius
filtered_water$result[fahrenheit] <- (filtered_water$result[fahrenheit] - 32) * (5/9)

# Now how do our boxplots look?
ggplot(data=filtered_water, mapping = aes(x=unit,y=result)) + geom_boxplot()

# We just need to fix up the unit values
filtered_water$unit[fahrenheit] <- 'Deg. Celsius'

# And check the plots again
ggplot(data=filtered_water, mapping = aes(x=unit,y=result)) + geom_boxplot()

# Let's look at a final summary of the data
summary(filtered_water)

# There are some empty factor levels in there, let's get rid of them
filtered_water$unit <- droplevels(filtered_water$unit)
summary(filtered_water)


#!/usr/bin/env Rscript

##======================
## filters input interactions according to the distance range
## allows circukler genome
##======================

args <- commandArgs(TRUE)
InpFile <- as.character(args[1])
OutFile <- as.character(args[2])
LowDistThres <- as.integer(args[3])
UppDistThres <- as.integer(args[4])
CircularGenome <- as.integer(args[5])
ChrSizeFile <- as.character(args[6])

if (CircularGenome == 0) {
	## default interaction filtering based on the absolute genomic distance
	system(paste0("awk -v l=", LowDistThres, " -v u=", UppDistThres, " -F[\'\t\'] \'function abs(v) {return v < 0 ? -v : v} {if ((NR==1) || (($1==$4) && ($7>0) && (abs($2-$5)>=l) && (abs($2-$5)<=u))) {print $0}}\' ", InpFile, " > ", OutFile))
} else {
	## use circular genome and chromosome size information
	system(paste0("awk \'(NR==1)\' ", InpFile, " > ", OutFile))

	ChrSizeData <- read.table(ChrSizeFile, header=F, sep="\t", stringsAsFactors=F)
	ChrList <- unique(ChrSizeData[,1])
	for (j in 1:length(ChrList)) {

		currchr <- ChrList[j]
		cat(sprintf("\n ==>> circular genome - genomic distance based filtering - processing chromosome : %s ", currchr))
		## chromosome size for this chromosome
		max_coord <- ChrSizeData[which(ChrSizeData[,1] == currchr), 2]
		cat(sprintf(" -->> max_coord (from ChrSizeFile) for this chromosome : %s ", max_coord))

		## analyze the circular genomic distance
		## include cis-pairs, with distance within the specified distance thresholds
		system(paste0("awk -F\'[\t]\' -v R=", max_coord, " -v c=\"", currchr, "\" -v l=", LowDistThres, " -v u=", UppDistThres, " \'function abs(v) {return v < 0 ? -v : v}; function min(x,y) {return x < y ? x : y} {if ((NR>1) && ($1==c) && ($1==$4) && ($7>0)) {d=min(min(abs($5-$2),abs((R-$5)+$2)),abs((R-$2)+$5)); if ((d>=l) && (d<=u)) {print $0}}}\' ", InpFile, " >> ", OutFile))

	}	# end chromosome loop
}


library(Seurat)
library(Seurat)
llibrary(data.table)
library(dplyr)
library('org.Hs.eg.db')
library(limma)

write_csv = function(vec, fn){write.table(vec, file = fn, append = FALSE, quote = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")}

seurat_recipet = function(expr){
expr_obj = CreateSeuratObject(expr)
expr_obj = NormalizeData(expr_obj, normalization.method = "LogNormalize", scale.factor = 10000)
expr_obj = ScaleData(expr_obj)
expr_obj = FindVariableFeatures(expr_obj, selection.method = "vst", nfeatures = 2000)
expr_obj = RunPCA(expr_obj, features = VariableFeatures(object = expr_obj), npcs = 100)
expr_obj
}

folder_to_save = './seurat/'
exprs=read.csv('expr_v10k.csv', row.names=1, header=T , check.names = F)
exprs=t(exprs)

meta=read.csv('meta_v10k', row.names=1, header=T, check.names = F)
abrain = seurat_recipet(exprs)
write_csv(Embeddings(object = abrain, reduction = "pca"), paste0(folder_to_save, 'seurat_pca.csv'))

for (npc in c(20, 50, 100))
{
    abrain1=FindNeighbors(object = abrain, dims = 1:npc, k.param = 100)
    abrain1=FindClusters(object = abrain1, resolution = 1., graph.name = 'RNA_snn')
    abrain1=RunUMAP(object = abrain1, min.dist = 1.5, graph = 'RNA_snn')

    write_csv(abrain1@meta.data$seurat_clusters, paste0(folder_to_save, "seurat_clusters_pc", npc, '.csv') )
    write_csv(Embeddings(object = abrain1, reduction = "umap"), paste0(folder_to_save, 'seurat_umap_pc', npc, '.csv') )
}

npc = 50

fn_cluster = fn_hpca = paste0('./seurat/harmony_cluster', npc, '.csv')
fn_topgene = 'seurat/topgene_r1.csv'
fn_marker = 'seurat/markers_r1.csv'

fn_hpca = paste0('./seurat/harmony', npc, '.csv')

fn_umap = paste0('./seurat/umap_harmony', npc, '.csv')

df_harmony = read.csv(fn_hpca, row.names = 1)

abrain[["harmony"]] <- CreateDimReducObject(embeddings = as.matrix(df_harmony),
                                 key = "harmony_", assay = DefaultAssay(abrain))

abrain1=FindNeighbors(object = abrain, dims = 1:npc, k.param = 15, reduction = "harmony")
abrain1=FindClusters(object = abrain1, resolution = .1, graph.name = 'RNA_snn')
write_csv(abrain1@meta.data$seurat_clusters, fn_cluster)

abrain1=RunUMAP(object = abrain1, min.dist = .3, graph = 'RNA_snn',  n.epochs = 200)
write_csv(Embeddings(object = abrain1, reduction = "umap"), fn_umap)

abrain.markers=FindAllMarkers(object = abrain1, min.pct= 0.3, return.thresh = 1.)
topgene=abrain.markers %>% group_by(cluster) %>% top_n(n = 10, wt = avg_logFC)
write_csv(topgene,fn_topgene)
write_csv(as.data.frame(abrain.markers), fn_marker)

abrain.markers=FindAllMarkers(object = abrain1, min.pct= 0.3, return.thresh = 1.)
topgene=abrain.markers %>% group_by(cluster) %>% top_n(n = 10, wt = avg_logFC)
write_csv(topgene,fn_topgene)
write_csv(as.data.frame(abrain.markers), fn_marker)


# Example for
# http://stackoverflow.com/questions/25085537/permute-groups-in-a-data-frame-r#
#
#DqStr <- "Group   q        Dq       SD.Dq
#    1 -3.0 0.7351 0.0067
#    1 -2.5 0.6995 0.0078
#    1 -2.0 0.6538 0.0093
#    2 -3.0 0.7203 0.0081
#    2 -2.5 0.6829 0.0094
#    2 -2.0 0.6350 0.0112"
#
#    Dq1 <- read.table(textConnection(DqStr), header=TRUE)
#
#    g <-unique(Dq1$q)
#    Dq2<- data.frame()
#    for(n in g)
#    {
#      Dqq <- Dq1[Dq1$q==n,]
#      Dqq$Group <-sample(Dqq$Group)
#      Dq2 <- rbind(Dq2,Dqq)
#    }
#
#    n <- -3
#    print(n)
#    Dqq <- Dq1[Dq1$q==g,]
#    Dqq$Group <-sample(Dqq$Group)
#    Dq2 <- rbind(Dq2,Dqq)
#    print(Dq2[,1:2])
#    library(plyr)
#    ddply(Dq1,.(q), function(x) { x$Group <- sample(x$Group)
#                                  data.frame(x)})
#
#Dq1$Group <- with(Dq1, ave(Group, q, FUN = sample))
#Dq1

# Test for comparing two curves with sd
#

source("R/Test_Dq_fun.r")

# Test with other data
#
setwd("Simul")
Dq1 <- readNeutral_calcDq(paste0(bName,"T100mfSAD.txt"))
Dq1$Time <- rep( 1:(nrow(Dq1)/35),each=35)
Dq1$n <- 6

plotDq_ReplaceR(Dq1,0.2,0.04,0.0001)

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,1)
names(Dqq)

Dqq<- Dqq[1:70,c(5:8,10)]
plotDq(Dqq,"as.factor(Time)")

#undebug(compareTwoGCurves)

# Compare using permutations
#
compareTwoGCurves(Dqq$Time,Dqq[,3:5],Dqq$q,1000)

Dq2 <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.01)
Dq2<- Dq2[1:70,c(5:8,10)]
plotDq(Dq2,"as.factor(Time)")

Dq2 <- rbind(Dq2[1:35,],Dqq[1:35,])
plotDq(Dq2,"as.factor(Time)")
names(Dq2)

compareTwoGCurves(Dq2$Time,Dq2[,3:5],Dq2$q,1000)

# Compare using differences an Bartlett test
#

g <- unique(Dq2$Time)
Diq1 <- with(Dq2, Dq2[Time==g[1],])
Diq2 <- with(Dq2, Dq2[Time==g[2],])
diffNormT(Diq1[,3:5],Diq2[,3:5])

g <- unique(Dqq$Time)
Diq1 <- with(Dqq, Dqq[Time==g[1],])[,3:5]
Diq2 <- with(Dqq, Dqq[Time==g[2],])[,3:5]
diffNormT(Diq1,Diq2)

# Compare using monte carlo
#
undebug(compareTwoCurvesMC)
compareTwoCurvesMC(Dqq$Time,Dqq$Dq,Dqq$SD.Dq)
compareTwoCurvesMC(Dq2$Time,Dq2$Dq,Dq2$SD.Dq,10000)
Diq2 <- with(Dq2, Dq2[q<0,])
compareTwoCurvesMC(Diq2$Time,Diq2$Dq,Diq2$SD.Dq,10000)

# Another dataset

Dq1 <- readNeutral_calcDq(paste0(bName,"T100mfOrd.txt"))
Dq1$Time <- rep( 1:(nrow(Dq1)/35),each=35)
Dq1$n <- 6

plotDq_ReplaceR(Dq1,0.2,0.04,0.0001)

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,1)
names(Dqq)

Dqq<- Dqq[1:70,c(5:8,10)]
plotDq(Dqq,"as.factor(Time)")

#undebug(compareTwoGCurves)

compareTwoGCurves(Dqq$Time,Dqq[,3:5],Dqq$q,1000)

Dq2 <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.01)
Dq2<- Dq2[1:70,c(5:8,10)]
plotDq(Dq2,"as.factor(Time)")

Dq2 <- rbind(Dq2[1:35,],Dqq[1:35,])
plotDq(Dq2,"as.factor(Time)")

compareTwoGCurves(Dq2$Time,Dq2[,3:5],Dq2$q,1000)

Dq2$SD.Dq <- Dq2$SD.Dq/10
plotDq(Dq2,"as.factor(Time)")
compareTwoGCurves(Dq2$Time,Dq2[,3:5],Dq2$q,1000)

g <- unique(Dqq$Time)

Diq1 <- with(Dqq, Dqq[Time==g[1],])
Diq2 <- with(Dqq, Dqq[Time==g[2],])
diffNormT(Diq1[,3:5],Diq2[,3:5])

g <- unique(Dq2$Time)

Diq1 <- with(Dq2, Dq2[Time==g[1],])
Diq2 <- with(Dq2, Dq2[Time==g[2],])

names(Dq2)
diffNormT(Diq1[,3:5],Diq2[,3:5])

Dq2$SD.Dq[is.nan(Dq2$SD.Dq)] <- 0
c <- compareTwoCurvesMC(Dq2$Time,Dq2$Dq,Dq2$SD.Dq,1000)
hist(c$dist)
c$stat
c
debug(compareTwoCurvesMC)

## COMPARE USING MULTIPLE T TEST

debug(compareTwoCurvesT)
c <- compareTwoCurvesT(Dq2$Time,Dq2$Dq,Dq2$SD.Dq,6)
Dq2$p.value <- c
Dq2[Dq2$p.value<0.05,]

Fisher.test(na.omit(c))  # p-value = 0.017

c <- compareTwoCurvesT(Dqq$Time,Dqq$Dq,Dqq$SD.Dq,6)
c[c<0.05]

Fisher.test(na.omit(c))  # p-value = 0.017

c[c<0.05]

### TEST KS for Dq comparison
#
# THIS Discard the SD but works the way it should!
#
Dq1 <- readNeutral_calcDq(paste0(bName,"T100mfSAD.txt"))

names(Dq1)
plotDq_ReplaceR(Dq1,0.2,0.04,0.0001)

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,1)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)

mk1 <- pairKS_DqByRep(Dqq$Dq,Dqq$rep)
propNotDiffSAD(mk1) # =.36

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.1)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
mk1 <- pairKS_DqByRep(Dqq$Dq,Dqq$rep)
propNotDiffSAD(mk1) # =1

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.01)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
mk1 <- pairKS_DqByRep(Dqq$Dq,Dqq$rep)
propNotDiffSAD(mk1) # =1

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.001)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
mk1 <- pairKS_DqByRep(Dqq$Dq,Dqq$rep)
propNotDiffSAD(mk1) # =1

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
mk1 <- pairKS_DqByRep(Dqq$Dq,Dqq$rep)
propNotDiffSAD(mk1) # =1

# Para DqSAD solamente replacementRate=1 da que los que provienen de simulaciones iguales
# son distintos

# Dq1 <- readNeutral_calcDq(paste0(bName,"T100mfOrd.txt"))

# RELACIONAR VARAIBILIDADES TEMPORALES - ESPACIALES con PARAMETROS
# Como varia SAD DqSAD DqSRS en tiempo en relacion de con parametros/procesos
# (nicho vs no nicho)
#

require(plyr)
Dq2 <- ddply(Dq1,.(MortalityRate,DispersalDistance,ColonizationRate,ReplacementRate,q),summarise,Dq=mean(Dq))

plotDq_ReplaceR(Dq2,0.2,0.04,0.0001)

# Test pairwise diferences in SAD
#
mk1 <- pairKS_Dq(Dq2)
propNotDiffSAD(mk1) # 0.84 is not so good

# Select 1 from each combination
#
Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
Diq1 <- Dqq[Dqq$rep==sample(10,1),]

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.1)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
Diq1 <- rbind(Diq1,Dqq[Dqq$rep==sample(10,1),])

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.01)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
Diq1 <- rbind(Diq1,Dqq[Dqq$rep==sample(10,1),])

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.001)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
Diq1 <- rbind(Diq1,Dqq[Dqq$rep==sample(10,1),])

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,1)
Dqq$rep <- rep( 1:(nrow(Dqq)/35),each=35)
Diq1 <- rbind(Diq1,Dqq[Dqq$rep==sample(10,1),])

mk1 <- pairKS_Dq(Diq1)
propNotDiffSAD(mk1) # 0.3 is very good

# TO DO a function to compare one of each parameter combination.

hh <- function(x) {
n <- nrow(x)/35
rp <- rep( 1:n,each=35)
return(x[rp==sample(n,1),])
}
debug(hh)
Dq2 <- ddply(Dq1,.(MortalityRate,DispersalDistance,ColonizationRate,ReplacementRate),hh)

debug(pairKS_Dq)
mk1 <- pairKS_Dq(Dq2,35)
mk1 <- pairKS_Dq(Dq1,35)
propNotDiffSAD(mk1) # 0.3 is very good
debug(compMethod_DqKS_Time)
m <- compMethod_DqKS_Time(bName,100,spMeta)


# General operators (from R documentation `?Syntax`)

:: :::
$ @
[ [[
^
- +
:
%any%
* /
+ -
< > <= >= == !=
!
&  &&
| ||
~
-> ->>
<- <<-
=
?

# Subset extraction

x[3]
x[["a"]]
x$y
x$`a a`
x$"a b"

# Operators

2-2, 2+2, 2~2, 2*2, 2/2, 2^2, 2<2, 2>2, 2==2, 2>=2, 2<=2, 2!=2, a<-2, a=2, a<<-2, a:=2, 2->a, 2->>a, 1:2
~a+b
!TRUE
?help, ?`?`, methods?show, ??topic
TRUE&FALSE, T|F
TRUE&&FALSE, T||F
base::sum, base:::sum

# Custom operators

2%*%3
a%<>%b
2%in%y
a %`tick`% b
a %'quot'% b
a %"quot"% b
a %for% b
a %\% b
a %`% b

`% %` = paste
"foo"`% %`"bar"


library(tidyverse)

# simple custom data
# https://r4ds.had.co.nz/relational-data.html#understanding-joins

x <- tribble(
  ~key, ~val_x,
  1, "x1",
  2, "x2",
  3, "x3"
)
y <- tribble(
  ~key, ~val_y,
  1, "y1",
  2, "y2",
  4, "y3"
)

x %>%
  inner_join(y, by = "key")

x %>%
  left_join(y, by = "key")

x %>%
  right_join(y, by = "key")

x %>%
  full_join(y, by = "key")


createSurvivalFrame <- function(f.survfit){ # initialise frame variable
f.frame <- NULL
# check if more then one strata
if(length(names(f.survfit$strata)) == 0){
# create data.frame with data from survfit
f.frame <- data.frame(time=f.survfit$time, n.risk=f.survfit$n.risk, n.event=f.survfit$n.event, n.censor = f.survfit $n.censor, surv=f.survfit$surv, upper=f.survfit$upper, lower=f.survfit$lower)
# create first two rows (start at 1)
f.start <- data.frame(time=c(0, f.frame$time[1]), n.risk=c(f.survfit$n, f.survfit$n), n.event=c(0,0), n.censor=c(0,0), surv=c(1,1), upper=c(1,1), lower=c(1,1))
# add first row to dataset
f.frame <- rbind(f.start, f.frame)
# remove temporary data
rm(f.start) }
else {
# create vector for strata identification
f.strata <- NULL
for(f.i in 1:length(f.survfit$strata)){
# add vector for one strata according to number of rows of strata
f.strata <- c(f.strata, rep(names(f.survfit$strata)[f.i], f.survfit$strata[f.i])) }
# create data.frame with data from survfit (create column for strata)
f.frame <- data.frame(time=f.survfit$time, n.risk=f.survfit$n.risk, n.event=f.survfit$n.event, n.censor = f.survfit $n.censor, surv=f.survfit$surv, upper=f.survfit$upper, lower=f.survfit$lower, strata=factor(f.strata))
# remove temporary data
rm(f.strata)
# create first two rows (start at 1) for each strata
for(f.i in 1:length(f.survfit$strata)){
# take only subset for this strata from data
f.subset <- subset(f.frame, strata==names(f.survfit$strata)[f.i])
# create first two rows (time: 0, time of first event)
f.start <- data.frame(time=c(0, f.subset$time[1]), n.risk=rep(f.survfit[f.i]$n, 2), n.event=c(0,0), n.censor=c(0,0), surv=c(1,1), upper=c(1,1), lower=c(1,1), strata=rep(names(f.survfit$strata)[f.i], 2))
# add first two rows to dataset
f.frame <- rbind(f.start, f.frame)
# remove temporary data
rm(f.start, f.subset) }
# reorder data
f.frame <- f.frame[order(f.frame$strata, f.frame$time), ]
# rename row.names
rownames(f.frame) <- NULL }
# return frame
return(f.frame) }


data = read.csv(file="edmonton.csv", header=FALSE, sep=",")
colnames(data)=NULL
plot(data[,1])
for (count in c(1:dim(data)[1]))
{
    lines(predict(smooth.spline(data[,count],spar=0.01),seq(1,length(data[,count]),len=1000)))
}


#' Dispatch the fitting of local models to parallel cores, if registered
#'
#' Loops through estimation locations with foreach, sending each local model to a core for fitting. If zero or one cores are registered, then foreach computes the local models sequentially.
#'
#' @param x matrix of observed covariates
#' @param y vector of observed responses
#' @param family exponential family distribution of the response
#' @param coords matrix of locations, with each row giving the location at which the corresponding row of data was observed
#' @param fit.loc matrix of locations where the local models should be fitted
#' @param kernel kernel function for generating the local observation weights
#' @param bw bandwidth parameter
#' @param bw.type type of bandwidth - options are \code{dist} for distance (the default), \code{knn} for nearest neighbors (bandwidth a proportion of \code{n}), and \code{nen} for nearest effective neighbors (bandwidth a proportion of the sum of squared residuals from a global model)
#' @param tol.loc tolerance for the tuning of an adaptive bandwidth (e.g. \code{knn} or \code{nen})
#' @param varselect.method criterion to minimize in the regularization step of fitting local models - options are \code{AIC}, \code{AICc}, \code{BIC}, \code{GCV}
#' @param tuning logical indicating whether this model will be used to tune the bandwidth, in which case only the tuning criteria are returned
#' @param D pre-specified matrix of distances between locations
#' @param verbose print detailed information about our progress?
#'
lagr.dispatch = function(x, y, family, coords, fit.loc, oracle, D, bw, bw.type, verbose, varselect.method, prior.weights, tuning, predict, simulation, kernel, min.bw, max.bw, min.dist, max.dist, tol.loc, lambda.min.ratio, n.lambda, lagr.convergence.tol, lagr.max.iter, jacknife=FALSE, bootstrap.index=NULL) {
    if (!is.null(fit.loc)) { coords.fit = fit.loc }
    else { coords.fit = coords }
    n = nrow(coords.fit)

    vcr.model = list()

    #For the adaptive bandwith methods, use a default tolerance if none is specified:
    if (is.null(tol.loc)) {tol.loc = bw / 1000}

    #The knn bandwidth is a proportion of the total prior weight, so compute the total prior weight:
    if (bw.type == 'knn') {
        prior.weights = drop(prior.weights)
        total.weight = sum(prior.weights)
    }

    group.id = attr(x, 'assign')

#models = list()
    models = foreach(i=1:n, .errorhandling='stop') %dopar% {
#for (i in 1:n) {
        if (!is.null(fit.loc)) {
            dist = drop(D[nrow(coords)+i,1:nrow(coords)])
        } else { dist = drop(D[i,]) }
        loc = coords.fit[i,]

        #If we are seeking the bandwidth via the jacknife, then remove any observations with zero distance.
        if (jacknife==TRUE || jacknife=='anti') {
            indx = which(dist!=0)
        } else {
            indx = 1:nrow(x)
        }

        if (!is.null(bootstrap.index)) {
            indx = indx[bootstrap.index]
        }

        if (jacknife=='anti') {
            indx = c(indx, which(indx==0))
        }

        #Use a prespecified distance as the bandwidth?
        if (bw.type == 'dist') {
            bandwidth = bw
            kernel.weights = drop(kernel(dist, bandwidth))

        #Compute the bandwidth that sets the sum of weights around location i equal to bw?
        } else if (bw.type == 'knn') {
            opt = optimize(
                lagr.knn,
                lower=min.dist,
                upper=max.dist,
                maximum=FALSE,
                tol=tol.loc,
                loc=loc,
                coords=coords[indx,],
                kernel=kernel,
                verbose=verbose,
                dist=dist[indx],
                total.weight=total.weight,
                prior.weights=prior.weights[indx],
                target=bw
            )
            bandwidth = opt$minimum
            kernel.weights = drop(kernel(dist, bandwidth))

        #Compute the bandwidth so that the sum of the local weighted squared error equals the bw?
        } else if (bw.type == 'nen') {
            opt = optimize(
                lagr.ssr,
                lower=min.dist,
                upper=max.dist,
                maximum=FALSE,
                tol=tol.loc,
                x=x[indx,],
                y=y[indx],
                group.id=group.id,
                family=family,
                loc=loc,
                coords=coords[indx,],
                dist=dist[indx],
                kernel=kernel,
                target=bw,
                varselect.method=varselect.method,
                oracle=oracle,
                prior.weights=prior.weights[indx],
                verbose=verbose,
                lambda.min.ratio=lambda.min.ratio,
                n.lambda=n.lambda,
                lagr.convergence.tol=lagr.convergence.tol,
                lagr.max.iter=lagr.max.iter
            )
            bandwidth = opt$minimum
            kernel.weights = drop(kernel(dist, bandwidth))
        }

        #If we have specified covariates via an oracle, then use those
        if (!is.null(oracle)) {oracle.loc = oracle[[i]]}
        else {oracle.loc = NULL}

        #Fit the local model
        m = list(tunelist=list('ssr-loc'=list('pearson'=Inf, 'deviance'=Inf), 'df-local'=1), 'sigma2'=0, 'nonzero'=vector(), 'weightsum'=sum(kernel.weights))
        try(m <- lagr.fit.inner(
            x=x[indx,, drop=FALSE],
            y=y[indx],
            group.id=group.id,
            family=family,
            coords=coords[indx,, drop=FALSE],
            loc=loc,
            varselect.method=varselect.method,
            tuning=tuning,
            predict=predict,
            simulation=simulation,
            lambda.min.ratio=lambda.min.ratio,
            n.lambda=n.lambda,
            lagr.convergence.tol=lagr.convergence.tol,
            lagr.max.iter=lagr.max.iter,
            verbose=verbose,
            kernel.weights=kernel.weights[indx],
            prior.weights=prior.weights[indx],
            oracle=oracle.loc)
        )
        if (verbose) {
            cat(paste("For i=", i, "; location=(", paste(round(loc,3), collapse=","), "); bw=", round(bandwidth,3), "; s=", m$s, "; dispersion=", round(tail(m$dispersion, 1), 3), "; nonzero=", paste(m$nonzero, collapse=","), "; weightsum=", round(m$weightsum, 3), ".\n", sep=''))
        }
        m$bw = bandwidth
        return(m)
#models[[i]] = m
    }

    vcr.model$fits = models

    #Calculate information criteria:
    fitted = vector()
    df = 0
    n = nrow(x)

    #Compute model-average fitted values and degrees of freedom:
    for (x in models) {
        #Compute the model-averaging weights:
        crit = x$tunelist$criterion
        if (varselect.method %in% c("AIC", "AICc", "BIC")) {
            crit.weights = as.numeric(crit==min(crit))
        } else if (varselect.method %in% c("wAIC", "wAICc")) {
            crit.weights = -crit
        }

        fitted = c(fitted, sum(x$tunelist$localfit * crit.weights) / sum(crit.weights))
        df = df + sum((1 + x$model$results$df) * crit.weights / x$weightsum ) / sum(crit.weights)
    }

    dev.resids = family$dev.resids(y, fitted, prior.weights)
    ll = family$aic(y, n, fitted, prior.weights, sum(dev.resids))

    #Compute the information criteria:
    vcr.model$AICc = ll + 2*df + 2*df*(df+1)/(n-df-1)
    vcr.model$AIC = ll + 2*df
    vcr.model$GCV = ll
    vcr.model$BIC = ll + log(n)*df

    vcr.model$df = df

    return(vcr.model)
}


#! /usr/bin/env Rscript
d<-scan("stdin", quiet=TRUE)
cat("Min:", min(d), "Max:", max(d), "Median:", median(d), "Mean:", mean(d), sep="\n")


churn <- read.csv(file.choose(), na.strings = "")
View(churn)
library(dplyr)
library(tidyverse)

#________________________________Cleaning___________________________________#

#Checking for NA's
summary(churn)
churn <- na.omit(churn)
churn = churn[,c(-1)]
#Changing Data Type
churn$MonthlyCharges <- as.double(churn$MonthlyCharges)
churn$TotalCharges <- as.double(churn$TotalCharges)
View(churn)
#0utliers

outliers <- function(dataframe){
  dataframe %>%
    select_if(is.numeric) %>%
    map(~ boxplot.stats(.x)$out)

}
z <- outliers(churn)
z <- t(as.matrix(z))
z

#Cleaning data
churn$Contract <- gsub("-", "", churn$Contract)
churn$Contract <- gsub(" ", "", churn$Contract)
churn$Contract <- tolower(churn$Contract)

churn$PaymentMethod <- tolower(churn$PaymentMethod)
churn$PaymentMethod <- gsub(" ", "", churn$PaymentMethod)
churn$PaymentMethod <- gsub("automatic|[[:punct:]]", "", churn$PaymentMethod)

new.function <- function(a, b="No internet service")
{
  c <- gsub(b, "no", a)
  tolower(c)
}

churn$MultipleLines <- new.function(churn$MultipleLines,"No phone service")
churn$OnlineSecurity <- new.function(churn$OnlineSecurity)
churn$OnlineBackup <- new.function(churn$OnlineBackup)
churn$DeviceProtection <- new.function(churn$DeviceProtection)
churn$TechSupport <- new.function(churn$TechSupport)
churn$StreamingTV <- new.function(churn$StreamingTV)
churn$StreamingMovies <- new.function(churn$StreamingMovies)
churn$Partner <- new.function(churn$Partner)
churn$Dependents <- new.function(churn$Dependents)
churn$PhoneService <- new.function(churn$PhoneService)
churn$PaperlessBilling <- new.function(churn$PaperlessBilling)
churn$Churn <- new.function(churn$Churn)

churn$SeniorCitizen <- ifelse(churn$SeniorCitizen == 0, "n", "y")

#Subset
male_cust <- churn[which(churn$gender=='Male'),]
female_cust <- churn[which(churn$gender=='Female'),]
elder_male <- male_cust[which(male_cust$SeniorCitizen=='y'),]
elder_Female <- female_cust[which(female_cust$SeniorCitizen=='y'),]

#_____________________________________Modelling_______________________________________#

#_________________________________Logistic Model_____________________________________#
#Creating Dummy Variables
install.packages("fastDummies")
library(fastDummies)
results <- fastDummies::dummy_cols(churn)
knitr::kable(results)
View(results)
churn_dummy <- results[,c(5,18:56)]
names(churn_dummy)[18] <- "InternetService_Fiber"

#.1 logistic Regression
table(churn_dummy$Churn)
str(churn_dummy)
churn_dummy$Churn <- ifelse(churn$Churn == 'no', 1, 0)
a <- colnames(churn_dummy)
a <- a[c(1,5:40)]
churn_dummy[a] <- sapply(churn_dummy[a], as.numeric)
View(churn_dummy)
#.1.2 Subsetting
churn_yes <- churn_dummy[which(churn_dummy$Churn==0),]
churn_no <- churn_dummy[which(churn_dummy$Churn==1),]

#.1.3 Training sets
set.seed(100)
train_rows_churn_yes <- sample(1:nrow(churn_yes), 0.7*nrow(churn_yes))
train_rows_churn_no <- sample(1:nrow(churn_no), 0.7*nrow(churn_no))
training_churn_yes <- churn_yes[train_rows_churn_yes, ]
training_churn_no <- churn_no[train_rows_churn_no, ]
trainingData <- rbind(training_churn_yes, training_churn_no)
View(trainingData)
#.1.4 Test data
test_churn_yes <- churn_yes[-train_rows_churn_yes, ]
test_churn_no <- churn_no[-train_rows_churn_no, ]
testData <- rbind(test_churn_yes, test_churn_no)

#.1.5 Build model
library(MASS)
model <- glm(Churn ~ ., data = trainingData, family = binomial(link="logit"))
stepAIC(model, direction = 'backward')
model <- glm(Churn ~ tenure + MonthlyCharges + TotalCharges +
               SeniorCitizen_n + PhoneService_no + MultipleLines_no + InternetService_DSL +
               InternetService_Fiber + OnlineBackup_no + DeviceProtection_no +
               StreamingTV_no + StreamingMovies_no + Contract_monthtomonth +
               Contract_oneyear + PaperlessBilling_no + PaymentMethod_electroniccheck,
             family = binomial(link = "logit"), data = trainingData)
predicted <- predict(model, testData, type="response")
stepAIC(model, direction = 'backward')

#.1.6 Optimal cut off
install.packages("InformationValue")
library(InformationValue)
optCutOff <- optimalCutoff(testData$Churn, predicted)[1]
summary(model)

#.1.7 Comparison between actual vs predicted
misClassError(testData$Churn, predicted, threshold = optCutOff)

#.1.8 true positive detection using ROC
plotROC(testData$Churn, predicted)

#1.9 Confusion matrix
Concordance(testData$Churn, predicted)
p <- InformationValue::confusionMatrix(testData$Churn, predicted, threshold = optCutOff)

# Accuracy of the Model
accuracy = ((p[1,1] + p[2,2])/sum(p))*100
accuracy

#VIF
library(car)
vif(model) #Used to check multicollinearity

#k-cross validation
# Define training control
install.packages("e1071")
library(e1071)
library(caret)
set.seed(123)
train.control <- trainControl(method = "cv", number = 10)
# Train the model
model <- train(Churn ~ tenure + MonthlyCharges + TotalCharges +
                 SeniorCitizen_n + PhoneService_no + MultipleLines_no + InternetService_DSL +
                 InternetService_Fiber + OnlineBackup_no + DeviceProtection_no +
                 StreamingTV_no + StreamingMovies_no + Contract_monthtomonth +
                 Contract_oneyear + PaperlessBilling_no + PaymentMethod_electroniccheck, data = trainingData, method = "glm",
               trControl = train.control)
# Summarize the results
print(model)

#________________Forward Selection______________________#
#.1.5 Build model
library(MASS)
model <- glm(Churn ~ ., data = trainingData, family = binomial(link="logit"))
stepAIC(model, direction = 'forward')
model <- glm(Churn ~ tenure + MonthlyCharges + TotalCharges + gender_Female +
               SeniorCitizen_n + Partner_no + Dependents_no + PhoneService_no +
               MultipleLines_no + InternetService_DSL + InternetService_Fiber +
               OnlineSecurity_no + OnlineBackup_no + DeviceProtection_no +
               TechSupport_no + StreamingMovies_no + Contract_monthtomonth +
               Contract_oneyear + PaperlessBilling_no + PaymentMethod_banktransfer +
               PaymentMethod_creditcard + PaymentMethod_electroniccheck, family = binomial(link = "logit"), data = trainingData)
predicted <- plogis(predict(model, testData))
stepAIC(model, direction = 'forward')

#.1.6 Optimal cut off
install.packages("InformationValue")
library(InformationValue)
optCutOff <- optimalCutoff(testData$Churn, predicted)[1]
summary(model)

#.1.7 Comparison between actual vs predicted
misClassError(testData$Churn, predicted, threshold = optCutOff)

#.1.8 true positive detection using ROC
plotROC(testData$Churn, predicted)

#1.9 Confusion matrix
Concordance(testData$Churn, predicted)
p <- InformationValue::confusionMatrix(testData$Churn, predicted, threshold = optCutOff)
# Accuracy of the Model
accuracy = ((p[1,1] + p[2,2])/sum(p))*100
accuracy

#VIF validation
vif(model)

#k-cross validation
# Define training control
install.packages("e1071")
library(e1071)
library(caret)
set.seed(123)
train.control <- trainControl(method = "cv", number = 10)
# Train the model
model <- train(Churn ~ tenure + MonthlyCharges + TotalCharges + gender_Female +
                 SeniorCitizen_n + Partner_no + Dependents_no + PhoneService_no +
                 MultipleLines_no + InternetService_DSL + InternetService_Fiber +
                 OnlineSecurity_no + OnlineBackup_no + DeviceProtection_no +
                 TechSupport_no + StreamingMovies_no + Contract_monthtomonth +
                 Contract_oneyear + PaperlessBilling_no + PaymentMethod_banktransfer +
                 PaymentMethod_creditcard + PaymentMethod_electroniccheck, data = trainingData, method = "glm",
               trControl = train.control)
# Summarize the results
print(model)

#_________________________random Forest___________________________#

library(randomForest)

random_forest <- churn
s <- random_forest[,c(5,8,18,19)]
random_forest <- random_forest[,-c(5,8,18,19)]
View(random_forest)
c <- colnames(random_forest)
random_forest[c] <- lapply(random_forest[c], as.factor)
str(random_forest)
random_forest <- as.data.frame(random_forest)
random_forest <- cbind(s, random_forest)

set.seed(123)
index = sample(1:nrow(random_forest), size=0.7*nrow(random_forest))
train_data = random_forest[index,]
test_data = random_forest[-index,]

#Without tuning
model_r <- randomForest(Churn ~ ., data = train_data,importance = TRUE)

#optimal mtry
tune_r <- tuneRF(train_data[,-20], train_data[,20], stepFactor = 0.5, plot = TRUE, ntreeTry = 500, trace = TRUE, improve = 0.001)

#With Tuning
model_r <- randomForest(Churn ~ ., data = train_data, mtry = 2, importance = TRUE)

#Prediction for trainig set
predTrain <- predict(model_r, train_data, type = "class")
table(predTrain, train_data$Churn)

#Prediction for testin set
predtest <- predict(model_r, test_data, type = "class")
p_r <- table(predtest, test_data$Churn)
accuracy = ((p_r[1,1] + p_r[2,2])/sum(p_r))*100
accuracy

#Importance
importance(model_r)
varImpPlot(model_r)

#Plot
plot(model_r, main = "Forest Model with Tuning" )
legend("topright", colnames(model_r$err.rate), col = 1:3, fill=1:3)

# We will compare model 1 of Random Forest with Decision Tree model

model_dt <- train(Churn ~ ., data = train_data, method = "rpart")
model_dt_1 <- predict(model_dt, data = train_data)
table(model_dt_1, train_data$Churn)
mean(model_dt_1 == train_data$Churn)

model_dt_vs <- predict(model_dt, newdata = test_data)
table(model_dt_vs, test_data$Churn)

mean(model_dt_vs == test_data$Churn)
acc_r <- table(model_dt_vs, test_data$Churn)
accuracy = ((acc_r[1,1] + acc_r[2,2])/sum(acc_r))*100
accuracy


library(ggplot2)
library(odbc)
library(DBI)
library(rjson)

rm(list=ls())

con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

q <- "SELECT kq.*
FROM analysis.kallisto_qc kq"
ka <- dbGetQuery(con,q)

unique_thr <- mean(ka[,"p_unique"]) - 2*sd(ka[,"p_unique"])

complexity_exclusion <- ifelse(ka[,"p_unique"] < mean(ka[,"p_unique"])-2*sd(ka[,"p_unique"]),"block","allow")
complexity_exclusion_reason <- ifelse(ka[,"p_unique"] < mean(ka[,"p_unique"])-2*sd(ka[,"p_unique"]),"low_complexity",NA)

res <- data.frame(ka[,"aliquot_barcode"],complexity_exclusion,complexity_exclusion_reason)
colnames(res) <- c("aliquot_barcode","complexity_exclusion","complexity_exclusion_reason")

dbWriteTable(con, Id(schema="analysis", table="rna_blocklist"), res, overwrite=TRUE)


pdf_file<-"pdf/maps_tunisia_symbols.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=10)

par(bg="lightskyblue1",mai=c(0,0,0,0),oma=c(0,0,0,0),family="Lato Light",las=1)
library(maptools)
library(rgdal)
library(gdata)

# Import data and prepare chart

myTun<-readShapeSpatial("myData/TUN_adm/TUN_adm0.shp",proj4string=CRS("+proj=longlat"))
plot(myTun,col="mintcream",border="white",lwd=3, xlim=c(8,14), ylim=c(32,38))
myDza<-readShapeSpatial("myData/DZA_adm/DZA_adm0.shp",proj4string=CRS("+proj=longlat"))
plot(myDza,col="burlywood1",border="white",lwd=3, add=T)
myLby<-readShapeSpatial("myData/LBY_adm/LBY_adm0.shp",proj4string=CRS("+proj=longlat"))

# Create chart and other elements

plot(myLby,col="burlywood1",border="white",lwd=3, add=T)

myLocations<-read.xls("myData/tunisia.xlsx", encoding="latin1")
attach(myLocations)
n<-nrow(myLocations)
for (i in 1:n)
{
text(long[i]+hoffset[i], lat[i]+voffset[i], place[i], cex=1.75,col="black", adj=adjust[i])
}
text(10.12, 36.43, "Tunis", cex=3, family="Lato Black")
text(12.5, 33.5, "Mediterranean", adj=0, cex=2, family="Lato Regular", col="darkblue")
text(7.25, 32, "ALGERIA", adj=0, cex=2, family="Lato Black")
text(9,33, "TUNISIA", adj=0, cex=2, family="Lato Black")
text(12, 32, "LIBYA", adj=0, cex=2, family="Lato Black")

par(family="Datendesign")
text(long, lat, "a", cex=size, col="red")

# Titling

mtext("Unrest in Tunisia",side=3,line=-4,adj=0.05,cex=2.7,family="Lato Black",col="black")

# Separate figure

par(mai=c(6,6,0,0), bg="white",new=T)
data(wrld_simpl)
w <- wrld_simpl[wrld_simpl@data[, "NAME"] != "Antarctica",]
m <- spTransform(w, CRS=CRS("+proj=merc"))
plot(m,xlim=c(-900000,2800000),ylim=c(3300000,7000000),col=rgb(160,160,160,100,maxColorValue=255),border=F)
w <- wrld_simpl[wrld_simpl@data[, "NAME"] == "Tunisia",]
m <- spTransform(w, CRS=CRS("+proj=merc"))
plot(m, add=T,col="red",border=F)
dev.off()


theme_set(theme_bw(18))

setwd("/home/caroline/cocolab/overinformativeness/models/basic_level_reference/modelExploration/rscripts")
#setwd("~/cogsci/projects/stanford/projects/overinformativeness/models/basic_level_reference/modelExploration/rscripts")

source("helpers.R")

#load("data/r.RData")
unlogged = read.table(file="../litLisOutput_unloggedTyps.csv",sep=",", header=T, quote="")
head(unlogged)
logged = read.table(file="../litLisOutput_loggedTyps.csv",sep=",", header=T, quote="")
head(logged)
nrow(logged)

agr = unlogged %>%
  select(p_l_t,p_l_d1,p_l_d2, t_d1, t_t) %>%
  gather(Utterance,Mentioned,-t_t, -t_d1) %>%
  group_by(Utterance,t_t, t_d1) %>%
  summarise(Probability=mean(Mentioned),ci.low=ci.low(Mentioned),ci.high=ci.high(Mentioned))
agr = as.data.frame(agr)
agr$YMin = agr$Probability - agr$ci.low
agr$YMax = agr$Probability + agr$ci.high
head(agr)

#ggplot(agr, aes(x=Utterance,y=Probability)) +
#  geom_bar(stat="identity") +
#  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
#  facet_grid(t_d1~t_t) +
#  #facet_wrap(~condition) +
#  theme(axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))
#ggsave("../graphs/litLisProb_unlogged_by_t_t_by_t_d.pdf",width=10,height=10)

ggplot(agr, aes(x=t_t,y=Probability,color=t_d1,group=t_d1)) +
#   geom_bar(stat="identity") +
  geom_point() +
  geom_line() +
#   geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_wrap(~Utterance) +
  #facet_wrap(~condition) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))
ggsave("../graphs/litLisProb2_unlogged_by_t_t_by_t_d.pdf",width=10,height=10)

# do same thing for logged typicalities
agr = logged %>%
  select(p_l_t,p_l_d1,p_l_d2, t_d1, t_t) %>%
  gather(Utterance,Mentioned,-t_t, -t_d1) %>%
  group_by(Utterance,t_t, t_d1) %>%
  summarise(Probability=mean(Mentioned),ci.low=ci.low(Mentioned),ci.high=ci.high(Mentioned))
agr = as.data.frame(agr)
agr$YMin = agr$Probability - agr$ci.low
agr$YMax = agr$Probability + agr$ci.high

#ggplot(agr, aes(x=Utterance,y=Probability)) +
#  geom_bar(stat="identity") +
#  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
#  facet_grid(t_d1~t_t) +
#  #facet_wrap(~condition) +
#  theme(axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))
#ggsave("litLisProb_logged_by_t_t_by_t_d.pdf",width=10,height=10)

ggplot(agr, aes(x=t_t,y=Probability,color=t_d1,group=t_d1)) +
  #   geom_bar(stat="identity") +
  geom_point() +
  geom_line() +
  #   geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_wrap(~Utterance) +
  #facet_wrap(~condition) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))
ggsave("../graphs/litLisProb2_logged_by_targetTyp_by_t_sub_d1.pdf",width=10,height=10)

# t_t = targetTypicality
# t_d1 = distr1Typicality (=distr2Typicality)
# p_l_t = literal listener probability to pick target
# p_l_d1 = literal listener probability to pick distractor1
# p_l_d2 = literal listener probability to pick distractor2


#' @title
#' Plot the predicted response trajectory
#'
#' @description
#' This function plots the predicted response trajectory based on the output of \code{\link{NRRR.pred}}.
#'
#'
#' @usage
#' NRRR.plot.pred(Ypred, Y = NULL, i_ind = 1, yi_ind = 1,
#'                tseq, t_index = NULL, x_lab = NULL,
#'                y_lab = NULL)
#'
#'
#' @param Ypred an array of dimension \code{(n, d, length(tseq))} where n is
#'              the sample size and d is the number of components in the
#'              multivariate response. The response trajectory is predicted at
#'              a set of time points \code{tseq}.
#' @param Y an array of dimension \code{(n, d, length(tseq))}. It is the truly
#'          observed response trajectory in the form of discrete observations at
#'          time points \code{tseq}. This term is only available
#'          when the function is applied to a testing set.
#' @param i_ind a user-specified sample ID for which the plot is to be drawn.
#'              If the prediction is only conducted on one sample,
#'              then set \code{i_ind = 1}; otherwise it should be an integer
#'              less than or equal to n. Default is 1.
#' @param yi_ind a user-specified response component index for which the plot
#'               is to be drawn. It should satisfy \eqn{0 < yi_ind \le d}.
#'               Default is 1.
#' @param tseq a sequence of time points at which the predicted response values
#'             are obtained.
#' @param x_lab,y_lab the user-specified x-axis and y-axis label,
#'                    and it should be given as a character string, e.g., x_lab = "Time".
#'                    Default is NULL.
#' @param t_index the user-specified x-axis tick marks, and it should be
#'                given as a vector of character strings of the same length as tseq.
#'                Default is NULL.
#'
#' @return A ggplot2 object. If the truly observed response trajectory is available, then
#'         it is plotted as a black line while the predicted trajectory is in red.
#'
#'
#' @details
#' An example of its usage can be found in the vignette of electricity demand analysis.
#'
#' @references
#' Liu, X., Ma, S., & Chen, K. (2020). Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#' @import ggplot2
#' @export

NRRR.plot.pred <- function(Ypred, Y = NULL, i_ind = 1, yi_ind = 1,
                           tseq, t_index = NULL, x_lab = NULL,
                           y_lab = NULL){

  if (i_ind > dim(Ypred)[1]) stop("i_ind cannot be greater than n")
  if (yi_ind > dim(Ypred)[2]) stop("yi_ind cannot be greater than d")

  iy <- i_ind
  l <- yi_ind

  tseq <- factor(tseq)
  if (!is.null(t_index)) {
    levels(tseq) <- t_index
  } else {
    t_index <- tseq
  }

  if (is.null(x_lab)) x_lab <- "t"
  if (is.null(y_lab)) y_lab <- "Predicted Value"

  if (is.null(Y)) {
    b <- Ypred[iy,l,]
    y.range <- range(b)
    cur <- data.frame(b,tseq)
    ggplot(data = cur, aes(x = tseq)) +
      geom_line(aes(y = b,group = 1), colour = "red", linetype = 2,size=1.5) +
      scale_x_discrete(breaks = t_index[seq(1,length(t_index),2)]) +
      xlab(x_lab) +
      ylab(y_lab) +
      ylim(y.range) +
      theme_bw() +
      theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
      theme(axis.text=element_text(size=12),axis.title=element_text(size=20),
            plot.title = element_text(hjust = 0.5, size = 20))
  } else {
    a <- Y[iy,l,]
    b <- Ypred[iy,l,]
    y.range <- range(a,b)
    cur <- data.frame(a,b,tseq)
    ggplot(data = cur, aes(x = tseq)) +
      geom_line(aes(y = a,group = 1), colour = "black",size=1.5) +
      geom_line(aes(y = b,group = 1), colour = "red", linetype = 2,size=1.5) +
      scale_x_discrete(breaks = t_index[seq(1,length(t_index),2)]) +
      xlab(x_lab) +
      ylab(y_lab) +
      ylim(y.range) +
      theme_bw() +
      theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
      theme(axis.text=element_text(size=12),axis.title=element_text(size=20),
            plot.title = element_text(hjust = 0.5, size = 20))
  }
}


# generate gene list from genes highly correlated with CD38-high B cells

source("R/functions/load_sig.r")

dir.create(file.path(PROJECT_DIR, "generated_data", "signatures"), showWarnings = F)

fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_genes.txt")
gene.sig = load_sig(fn.cd38.cor, "cor.mean.sd.ratio", ntop=10)
fn.cd38.sig = file.path(PROJECT_DIR, "generated_data", "signatures", "CD38_ge_sig.txt")
gene.sig %>% as.data.frame() %>%
  fwrite(fn.cd38.sig, col.names = F)

# generate gene lists from BTMs related to plasma cells

library(tmod)
data(tmod)
mod.id.li = tmod$MODULES %>% dplyr::filter(grepl("plasma",Title, ignore.case = F), Category=="immune") %>%
  dplyr::select(ID) %>%
  unlist(use.names=F)
mod.id.dc = c("DC.M4.11","DC.M7.7","DC.M7.32")
mod.id = c(mod.id.dc, mod.id.li)
mod.gene = tmod$MODULES2GENES[mod.id]

for(k in mod.id) {
  fn.pb.sig = file.path(PROJECT_DIR, "generated_data", "signatures",
                        sprintf("PB_%s_ge_sig.txt", k))
  mod.gene[[k]] %>% as.data.frame() %>%
    fwrite(fn.pb.sig, col.names = F)
}


library(zoo)
library(ggplot2)
library(plotly)
library(htmlwidgets)
library(readr)

library(grid)

Sys.setlocale("LC_TIME", "hr_HR.UTF-8")

# num days to plot
n <- 100

# read latest data
diff_df <- read_csv('data/latest/diff_df.csv')

load('data/latest/percentage_change.Rda')
load('data/latest/cumulative_cases.Rda')
load('data/latest/avg7_df.Rda')

load('data/latest/last_date.Rda')
load('data/latest/last_date_.Rda')

plot_df <- merge(diff_df, percentage_change, by=c("Datum"))

data_to_plot <- tail(plot_df, n=n)

f <- list(size = 18, color = "black")
f2 <- list(size = 16, color = "black")

for(use_log_scale in c(FALSE, TRUE)) {
  p <- list()
  a <- list()

  for(i in 1:22) {
    title <- colnames(data_to_plot)[1 + i]

    if (i == 21) {
      title <- gsub("[.]", "", title)
    }
    else
    {
      title <- gsub("[.]", "-", title)
    }

    if ((i - 1) %% 5 == 0) {
      ylab <- ylab("Broj slučajeva")
    }
    else {
      ylab <- ylab('')
    }

    p[[i]] <- ggplot(data=data_to_plot, aes_string(x='Datum', y=colnames(data_to_plot)[1 + i])) +
      ylab +
      geom_bar(stat="identity") +
      geom_col(aes_string(fill=colnames(data_to_plot)[1 + i + 22])) +
      scale_fill_distiller(palette = "RdYlGn", limits = c(-50, 50), oob = scales::oob_squish_any, name='') +
      geom_line(data=tail(avg7_df, n=n), aes_string(x='Datum', y=colnames(data_to_plot)[1 + i]), size=1, colour='blue') +  #
      theme_minimal() +
      theme(axis.text.x = element_text(size = 10)) +
      theme(plot.margin = unit(c(1,1,1,1), "cm"))

    if (use_log_scale) {
      p[[i]] <- p[[i]] + scale_y_continuous(trans=scales::pseudo_log_trans(base = 10))
    }

    p[[i]] <- ggplotly(p[[i]])

    a[[i]] <- list(
      text = paste('\n', title, ' (', diff_df[nrow(diff_df), i], ')\nTjedna razlika ', sprintf("%+d", round(data_to_plot[nrow(data_to_plot), 1 + i + 22], 0)), '%', sep=''),
      font = f,
      xref = "paper",
      yref = "paper",
      yanchor = "bottom",
      yshift = 10,
      xanchor = "center",
      align = "center",
      cliponaxis = FALSE,
      x = 0.5,
      y = 0.92, # 0.92
      showarrow = FALSE
    )

    p[[i]] <- p[[i]] %>%
      layout(annotations = a[i])
  }

  s <- subplot(p, nrows = 5, margin=c(0.01,0.0,0.04,0.05), titleY = TRUE, heights=c(0.17, 0.22, 0.22, 0.22, 0.17)) %>% # 2 0 5 4
    add_annotations(x = 0.65,
                    y = 0.07,
                    text = paste('COVID 19 u Hrvatskoj: Pregled broja zaraženih po županijama (', last_date ,')\n\nBoje prikazuju promjenu broja slučajeva zadnjih tjedan dana u usporedbi s brojem slučajeva prethodnog tjedna.\nBroj novih slučajeva u prošlih 24 sata prikazan je u zagradi kraj imena županije.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), '\nIzvor podataka: koronavirus.hr\n\nAutor: Petar Palašek, ppalasek.github.io', sep=''),
                    font = f2,
                    xref = "paper",
                    yref = "paper",
                    align='left',
                    ax = 0,
                    ay = 0)

  if (use_log_scale) {
    saveWidget(s, file = "html/index_log.html", title = "COVID 19 u Hrvatskoj: Pregled broja zaraženih po županijama")
  }
  else {
    saveWidget(s, file = "html/index.html", title = paste("COVID 19 u Hrvatskoj: Pregled broja zaraženih po županijama (", last_date, ")", sep=""))

    orca(s, file = paste('img/', last_date_, '_line_plots.png', sep = ''), width = 27 * 72, height = 13 * 72)
  }
}


pdf_file<-"pdf/networks_directed_network.pdf"
cairo_pdf(bg="grey98", pdf_file,width=6,height=6)

par(mai=c(0.25,0.25,0.25,0.5),omi=c(0.25,0.25,0.25,0.25),
	family="Lato Light",las=1)
library(igraph)
library(RColorBrewer)

# Import data and prepare chart

nodes <- read.csv("myData/reg_plot.csv", header=T, as.is=T)
links <- read.csv("myData/reg_flow.csv", header=T, as.is=T)

links <- links[order(links$orig_reg, links$dest_reg),]
colnames(links)[3] <- "weight"
rownames(links) <- NULL

binnen<-links[links$orig_reg==links$dest_reg, ]
nodes$inside<-binnen$weight[match(nodes$region, binnen$orig_reg)]

net <- graph_from_data_frame(d=links, vertices=nodes, directed=T)
net <- simplify(net, remove.multiple = F, remove.loops = T)

E(net)$width <- E(net)$weight*5
V(net)$size <- sqrt(V(net)$inside*100)

colrs <- brewer.pal(9, "Paired")
V(net)$color <- colrs[V(net)$order1]

edge.start <- ends(net, es=E(net), names=F)[,1]
edge.col <- V(net)$color[edge.start]

# Create chart

plot(net, edge.arrow.size=0, edge.color=edge.col,layout=layout_in_circle(net),
     vertex.color=colrs, vertex.frame.color="#ffffff", edge.curved=.1,
     vertex.label=V(net)$media, vertex.label.color="black", vertex.label.family="Lato Light")

legend(x=0.8, y=1.25, c("", "   2 M","", "   1 M"), pch=19,xpd=T,title="Internal Migration:",
       col="#777777", pt.cex=c(0, sqrt(4),0,sqrt(2)), cex=.8, bty="n", ncol=1)

legend(x=-1.25, y=-1.15, c(" 3 M"," 2 M", " 1 M"), pch=15,xpd=T,horiz=T,
       col="#777777", pt.cex=c(sqrt(3),sqrt(2),sqrt(1)), cex=.8, bty="n", ncol=1)

# Titling

mtext("Migration 2010-2015", line=-1.5, adj=0, cex=2, family="Lato Black", col="grey40", outer=T)
mtext("Data Source: https://github.com/cran/migest/tree/master/inst/vidwp", side=1, line=-1, adj=1, cex=0.9, font=3, outer=T)
dev.off()


subroutine testeq(a,b,eps,value)

# Test for the equality of a and b in a fairly
# robust way.
# Called by trifnd, circen, stoke.

implicit double precision(a-h,o-z)
logical value

# Define constants.
one = 1.d0
ten = 1.d10

# If b is essentially 0, check whether a is essentially zero also.
# The following is very sloppy!  Must fix it!
if(abs(b)<=eps) {
        if(abs(a)<=eps) value = .true.
        else value = .false.
        return
}

# Test if a is a `lot different' from b.  (If it is
# they're obviously not equal.)  This avoids under/overflow
# problems in dividing a by b.
if(abs(a)>ten*abs(b)|abs(a)<one*abs(b)) {
        value = .false.
        return
}

# They're non-zero and fairly close; compare their ratio with 1.
c = a/b
if(abs(c-1.d0)<=eps) value = .true.
else value = .false.

return
end


# Master Thesis Project - Extreme Value Theory
# Introductory Task
# Killian Martin--Horgassan
# 19-02-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Elementary test
#x <- 5
#print(x)

# sourcing works

# Loading function 'NormMax'
source("./NormMax.r")
source("./InputIntroductoryTask.r")

# Input from keyboard
DIST <- InputIntroductoryTask()
DIST_1 <- DIST[[1]]
DIST_2 <- DIST[[2]]

# Calling function NormMax
listMax <- NormMax(length(DIST_1),DIST_1,DIST_2)


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

# 01	01181000	     WEST BRANCH WESTFIELD RIVER AT HUNTINGTON, MA	  42.23731	 -72.89565	    243.50

pathToCamel <- "/home/eleni/hubert/prg/data/basin_timeseries_v1p2_metForcing_obsFlow/basin_dataset_public_v1p2"
# pathToForcing <- "/basin_mean_forcing/maurer/"
# pathToForcing <-"/basin_mean_forcing/daymet/"
pathToForcing <- "/basin_mean_forcing/nldas/"
pathToObsQ <- "/usgs_streamflow/"

basinChrs <- fread(paste0(paste0(pathToCamel,"/basin_metadata/basin_physical_characteristics.txt")))
gaugeChars <- fread(paste0(paste0(pathToCamel,"/basin_metadata/gauge_informationPM.txt")))

gaugeChars[523:524,]

i <- 1
nt <- 2000
nseVec <- c()
kgeVec <- c()
for(i in 1:nrow(gaugeChars)){
  ifelse((gaugeChars$GAGE_ID[i]<10000000), gChrs <-paste0(0,gaugeChars$GAGE_ID[i]), gChrs <- paste0(gaugeChars$GAGE_ID[i]))
  ifelse((gaugeChars$HUC_02[i]<10), HUc <-paste0(0,gaugeChars$HUC_02[i],"/"), HUc <- paste0(gaugeChars$HUC_02[i],"/"))
  # dtaFC <- read.table(paste0(pathToCamel,pathToForcing,HUc,gChrs,"_lump_cida_forcing_leap.txt"), skip = 4)
  # dtaFC <- read.table(paste0(pathToCamel,pathToForcing,HUc,gChrs,"_lump_maurer_forcing_leap.txt"), skip = 4)
  dtaFC <- read.table(paste0(pathToCamel,pathToForcing,HUc,gChrs,"_lump_nldas_forcing_leap.txt"), skip = 4)
  dtaQ <- read.table(paste0(pathToCamel,pathToObsQ,HUc,gChrs,"_streamflow_qc.txt"))

  pr<-dtaFC$V6
  temp<-(dtaFC$V9+dtaFC$V10)/2

  area <- gaugeChars$`DRAINAGE_AREA_(KM^2)`[i] * 1000 * 1000
  lat <- gaugeChars$LAT[i]

  Qm <-dtaQ$V5 * 0.0283168466 * 3600 * 24/area*1000

  print(paste("The basin number: ",i))
  print(sum(pr[1:nt]))
  print(sum(Qm[1:nt]))

  nHrus <- 1
  IdsHrus <- paste0("ID_",0,gaugeChars$GAGE_ID[i])
  dhrus <- initdHruModel(nHrus,area,IdsHrus)
  gwStorType <- c("LIN_RES");
  swStorType <- c("COLLIE_V2");

  setPTInputsToAlldHrus(dhrus, Prec = pr[1:nt], Temp = temp[1:nt], inDate = as.Date("1980/01/01"))
  calcPetToAllHrus(dHRUM_ptr = dhrus,Latitude = lat,"Hamon")

  ParDF = data.frame( B_SOIL = 1.6, C_MAX = 100, B_EVAP = 1,  KS = 0.01, KF = 0.03, ADIV = 0.8, CDIV = 0.3,
                      SDIV = 0.3, CAN_ST = 1., STEM_ST = 1., CSDIV = 0.8, TETR = 0, DDFA = 0.75, TMEL = 0.0,
                      RETCAP = 10, D_BYPASS = 0.8, THR = 10, KS2 = 0.1, ALPHA = 0.5, FOREST_FRACT = 0.3, FC = 10,
                      KF_NONLIN = 10, KF2 = 0.01, C = 10, INFR_MAX = 10, RF = 0.5, WP = 0.3)
  ParDFup = data.frame( B_SOIL = 2, C_MAX = 800, B_EVAP = 2,  KS = 0.4, KF = 0.7, ADIV = 0.9, CDIV = 0.3,
                        SDIV = 0.3, CAN_ST = 4., STEM_ST = 4., CSDIV = 0.8, TETR = 0.5, DDFA = 10, TMEL = 0.0,
                        RETCAP = 25, D_BYPASS = 1, THR = 100, KS2 = 0.4, ALPHA = 1, FOREST_FRACT = 0.3, FC = 100,
                        KF_NONLIN = 100, KF2 = 0.1, C = 100, INFR_MAX = 100, RF = 1, WP = 1)
  ParDFlow = data.frame( B_SOIL = 1.3, C_MAX = 5, B_EVAP = 0.5,  KS = 0.002, KF = 0.2, ADIV = 0.01, CDIV = 0.05,
                         SDIV = 0.01, CAN_ST = 1., STEM_ST = 1., CSDIV = 0.01, TETR = -1, DDFA = 0.08, TMEL = -8.0,
                         RETCAP = 2, D_BYPASS = 0.1, THR = 1, KS2 = 0.002, ALPHA = 0.1, FOREST_FRACT = 0.01, FC = 1,
                         KF_NONLIN = 1, KF2 = 0.001, C = 1.0, INFR_MAX = 1.0, RF = 0.01, WP = 0.3)

  ParBest = ParDF

  fitness = function(myPar){
    # myPar =ParDF[1,]
    setGWtypeToAlldHrus(dHRUM_ptr = dhrus, gwStorType, IdsHrus)
    setSoilStorTypeToAlldHrus(dHRUM_ptr = dhrus, swStorType, IdsHrus)
    setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(myPar),names(ParDF))
    # # for( i in 1:1000){
    outDta <- dHRUMrun(dHRUM_ptr = dhrus)
    outDF <- data.frame(outDta$outDta)
    names(outDF) <- outDta$VarsNams
    # # }
    dF <- outDF
    # print((-1)*as.double(KGE(sim=dF$TOTR[365:nt],obs=Qm[365:nt])))
    sim=dF$TOTR[365:nt]
    obs=Qm[365:nt]

    mae = mae(sim = sim, obs = obs)

    if (is.na(mae)) {
      mae = 99999999
    }

    mae
    #myfitnes = sum((sim-obs)^2) / sum((obs- mean(obs))^2)
    # # mymae=NA
    # if(is.na(mymae)) mymae = 9999
    # (return as.double(mymae))
  }

  itermaxW=20
  decntr<-DEoptim.control(VTR = 0, strategy = 2, bs = FALSE, NP = 300,
                          itermax = itermaxW, CR = 0.75, F = 0.9, trace = FALSE,
                          initialpop = NULL, storepopfrom = itermaxW + 1,
                          storepopfreq = 1, p = 0.2, c = 0, reltol = sqrt(.Machine$double.eps),
                          steptol = itermaxW)
  u=DEoptim( lower=as.numeric(ParDFlow[1,]), upper=as.numeric(ParDFup[1,]), fn=fitness, control = decntr)
  ParBest[1,] = as.numeric(u$optim$bestmem)

  setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(ParBest[1,]),names(ParDF))
  #run in a for loop and update state variables odnosno reset za sekoja presmetka
  #preserve mass balance
  outDta <- dHRUMrun(dHRUM_ptr = dhrus)
  outDF <- data.frame(outDta$outDta)
  names(outDF) <- outDta$VarsNams
  plot(outDF$SOIS)
  plot(outDF$PERC)
  # # }
  dF <- outDF

  kgeVec[i] <- KGE(sim=dF$TOTR[365:nt],obs=Qm[365:nt])
  nseVec[i] <- NSE(sim=dF$TOTR[365:nt],obs=Qm[365:nt])
  plot(Qm[1:nt],dF$TOTR, main=paste(gaugeChars$GAGE_ID[i]," KGE=", format(kgeVec[i], digits = 2)," NSE=", format(nseVec[i], digits = 2)))
  plot(Qm[1:nt],type="l", main=paste(gaugeChars$GAGE_ID[i]," KGE=", format(kgeVec[i], digits = 2)," NSE=", format(nseVec[i], digits = 2))
       ,ylab ="Q [mm]", xlab="Time [day]")
  lines(dF$TOTR,col="red")
  grid()
}


#!/usr/bin/env Rscript
#
# Use a weighted linear regression to test for differences in read depth
# among treatments. The weights come from the total number of aligned
# reads.
#
#   read_depth_test.r <file with group 1 input files>
#       <file with group 2 input files>
#
# In this version, the square root of the aligned reads is used.
#
#==============================================================================#

cargs = commandArgs(trailingOnly=TRUE)
group_1 = scan(cargs[1], what='character')
group_2 = scan(cargs[2], what='character')

trtmnt = c(rep('a', length(group_1)),
           rep('b', length(group_2)))

data_sets = lapply(c(group_1, group_2),
                   function(x) read.csv(x, sep='\t',
                                        stringsAsFactors=FALSE,
                                        check.names=FALSE,
                                        comment.char='#',
                                        header=TRUE))
n_genes = nrow(data_sets[[1]])

same_gene = sapply(1:n_genes,
                   function(i) {
                       genes = sapply(data_sets,
                                       function(x) x[i, 'name'])
                       all(genes == genes[1])
                    })
if(!all(same_gene))
    stop('Gene names do not match')

# Get the weights - based on the number of aligned reads. Divide the
# count of aligned reads by the count of aligned reads million to get
# the number of aligned reads in millions. This only has to be done
# once per pool.
wts = sapply(data_sets, function(x) {
             r = which(x$count > 10)[1]
             sqrt(x[r, 'count'] / x[r, 'count (CPM)'])
                    })
cat(wts, '\n', file=stderr())

cat('contig\tstart\tend\tgene\tp\teffect\trpkm1\trpkm2\n', file=stdout())
for(i in 1:n_genes) {
    contig = data_sets[[1]][i, 'chrom']
    start_pos = data_sets[[1]][i, 'start']
    end_pos = data_sets[[1]][i, 'end']
    gene = data_sets[[1]][i, 'name']

    raw_counts = sapply(data_sets, function(x) x[i, 'count'])
    cpm = sapply(data_sets, function(x) x[i, 'count (CPM)'])
    rpkm = sapply(data_sets, function(x) x[i, 'RPKM'])

    # A previous version of this script had an "and" instead of an
    # "or", but I think it's okay to do a test if one treatment has
    # no reads, as long as the other one has reads.
    if(sum(raw_counts[trtmnt == 'a'] != 0) > 0 ||
       sum(raw_counts[trtmnt == 'b'] != 0) > 0) {
        # In a previous version of this script, I eliminated replicates
        # with zero reads. I have no idea why I did that - it seems
        # silly.
        test_results = lm(rpkm ~ trtmnt, weights=wts)
        effect = coefficients(test_results)['trtmntb']
        p = coefficients(summary(test_results))['trtmntb', 'Pr(>|t|)']
    } else {
        p = NaN
        effect = NaN
    }
    cat(paste(contig, start_pos, end_pos, gene, p, effect, sep='\t'),
        '\t', paste(round(rpkm[trtmnt == 'a'], 3), collapse=','),
        '\t', paste(round(rpkm[trtmnt == 'b'], 3), collapse=','),
        '\n', sep='', file=stdout())
}


comp208 <- read.table("Comp_Data.txt", header = T, sep = "\t")

#Compute the largest y and x in the data
max_y <- max(comp208$Comparações_AVL, comp208$Comparações_ABB)
max_x <- max(comp208$Tamanho_AVL, comp208$Tamanho_ABB)

#Define colors to be used for AVL and BST
plot_colors <- c("black", 'red')

#Start PNG device to save output to Fig_Plot.png
png("Fig_Plot.png", height = 720, width = 1280, bg = "white")

#Plotting
plot(comp208$Tamanho_ABB, comp208$Comparações_ABB, type = "p", pch = 20, col = plot_colors[1],
     ylim = c(0, max_y), xlim = c(0, max_x), axes = FALSE, ann = FALSE)

#Change interval scale
axis(1, las = 1, at = ((max_x %% 1000000)/10)*0:max_x)

axis(2, las = 1, at = ((max_y %% 1000000)/10)*0:max_y)

box()

#Graph BST
lines(comp208$Tamanho_AVL, comp208$Comparações_AVL, type = "p", pch = 20, lty = 2, col = plot_colors[2])

#Create a title with red, bold/italic font
title(main = "Search Algorithm: AVL x BST", col.main = "black", font.main = 4)

#Label the x and y axes with dark green text
title(xlab = "Size", col.lab = rgb(0, 0, 0), cex.lab = 1.75, line = 2.5)
title(ylab = "Number of Comparisons", col.lab = rgb(0, 0, 0), cex.lab = 1.75, line = -2)

nameStruct <- c("ABB", "AVL")

legend(1, max_y, nameStruct, cex = 0.8, col = plot_colors, pch = 20:20, lty = 1:2);

#turn off device driver (to flush output to png)
dev.off()


library(shiny)
library(shinydashboard)

shinyServer(

  function(input, output) {
    output$histogram <- renderPlot(
      {
        hist(faithful$eruptions, breaks = input$bins)
      }
    )

  }
)


student<-c(0:849)
# we can sample number of students according to our wish using sample function
sample(student , 20)
# We would repeat the process in subsequent weeks  .


#FAN PLOT
library(plotrix)
slices<-c(10,12,4,16,8)
lbls<-c("US", "UK", "Australia", "Germany", "France")
fan.plot(slices,labels=lbls,main="Fan Plot")


#load libraries
library(tidyverse)
library(datasets)
#make a tibble
TestDataFrame <- as_tibble(diamonds)
#plot in ggplot2
ggplot(data=TestDataFrame) +
  aes(x = cut, y = color) +
  geom_count()


#' mbtommHG
#'
#' Conversion from Millibar [hPa] to mmHG.
#'
#' @param mb numeric   Air pressure in Millibar [hPa].
#' @return mmHG
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  mbtommHG
#'
#' @export
#'
#'
#'
#'

mbtommHG=function(mb) {
                         ct$assign("mb", as.array(mb))
                         ct$eval("var res=[]; for(var i=0, len=mb.length; i < len; i++){ res[i]=mbtommHG(mb[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#' ms2mph
#'
#' Conversion speed in meters per second to miles per hour.
#'
#' @param ms numeric Speed in meters per second.
#' @return  miles per hour
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  ms2mph
#'
#' @export
#'
#'
#'
#'

ms2mph=function(ms) {
                         ct$assign("ms", as.array(ms))
                         ct$eval("var res=[]; for(var i=0, len=ms.length; i < len; i++){ res[i]=ms2mph(ms[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# Unit tets for RNGseq
#
# Author: Renaud Gaujoux
###############################################################################

library(parallel)

test.RNGseq_seed <- function(){

	# actual testing function
	.test_loc <- function(.msg, ..., .change=FALSE){
		msg <- function(...) paste(.msg, ':', ...)
		os <- RNGseed()
		on.exit(RNGseed(os))
		s <- RNGseq_seed(...)
		checkTrue(length(s) == 7L && s[1] %% 100 == 7L, msg("RNGseq_seed returns a value of .Random.seed for L'Ecuyer-CMRG"))
		checkIdentical(RNGseed()[1], os[1], msg("RNGseq_seed does not change the type of RNG"))

		if( !.change ) checkIdentical(RNGseed(), os, msg("RNGseq_seed does not change the value of .Random.seed"))
		else checkTrue( !identical(RNGseed(), os), msg("RNGseq_seed changes the value of .Random.seed"))
		s
	}

	# test in two RNG settings: default and L'Ecuyer
	.test <- function(.msg, ..., ss=NULL, .change=FALSE, Dchange=.change, Lchange=.change){
		os <- RNGseed()
		on.exit(RNGseed(os))

		# default RNG
		RNGkind('default')
		if( !is.null(ss) ) set.seed(ss)
		s1 <- .test_loc(paste(.msg, '- default'), ..., .change=Dchange)

		RNGkind("L'Ecuyer")
		if( !is.null(ss) ) set.seed(ss)
		s2 <- .test_loc(paste(.msg, "- CMRG"), ..., .change=Lchange)

		list(s1, s2)
	}

	os <- RNGseed()
	on.exit(RNGseed(os))

	RNGkind('default', 'default')

	# test different arguments
	s1 <- .test("seed=missing", ss=1, Dchange=TRUE, Lchange=FALSE)
	runif(10)
	s2 <- .test("seed=NULL", NULL, ss=1, Dchange=TRUE, Lchange=FALSE)
	checkIdentical(s1, s2, "set.seed(1) + seed=missing and seed=NULL return identical results")

	# doRNG seed with single numeric
	runif(10)
	s3 <- .test("seed=single numeric", 1)
	checkIdentical(s1[[1]], s3[[1]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG")
	checkIdentical(s1[[2]], s3[[2]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is CMRG")
	checkTrue( !identical(s1[[1]], s1[[2]]), "v1.4 - set.seed(1) + seed=missing return NON identical results in different RNG settings")
	checkTrue( !identical(s3[[1]], s3[[2]]), "v1.4 - seed=num return NON identical results in different RNG settings")

	# version < 1.4
#	doRNGversion("1.3.9999")
	s1 <- .test("v1.3 - seed=missing", ss=1, Dchange=TRUE, Lchange=TRUE, version=1)
	s3 <- .test("v1.3 - seed=single numeric", 1, version=1)
	checkIdentical(s1[[1]], s3[[1]], "v1.3 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG")
	checkTrue( !identical(s1[[2]], s3[[2]]), "v1.3 - set.seed(1) + seed=missing and seed=1 return NON identical results when current RNG is CMRG")
	checkTrue( !identical(s1[[1]], s1[[2]]), "v1.3 - set.seed(1) + seed=missing return NON identical results in different RNG settings")
	checkTrue( !identical(s3[[1]], s3[[2]]), "v1.4 - seed=num return NON identical results in different RNG settings")
#	doRNGversion(NULL)
	##

	.test("seed=single integer", 10L)
	# directly set doRNG seed with a 6-length
	.test("seed=6-length integer", 1:6)
	.test("seed=6-length numeric", as.numeric(1:6))
	s <- 1:6
	checkIdentical(RNGseq_seed(s)[2:7], s, "RNGseq_seed(6-length) returns stream to the given value")
	# directly set doRNG seed with a full 7-length .Random.seed
	.test("seed=7-length integer", c(407L,1:6))
	.test("seed=7-length numeric", as.numeric(c(107L,1:6)))
	s <- c(407L,1:6)
	checkIdentical(RNGseq_seed(s), s, "RNGseq_seed(7-length) returns complete seed with the given value")

	# errors
	os <- RNGseed()
	checkException(RNGseq_seed(NA), "seed=NA throws an exception")
	checkIdentical(os, RNGseed(), "RNGseq_seed(NA) does not change the value of .Random.seed [error]")

	# Current CMRG is L'Ecuyer
	RNGkind("L'Ecuyer")
	set.seed(456)
	s <- RNGseed()
	r <- RNGseq_seed(NULL)
	checkIdentical(s, r, "Current is CMRG: seed=NULL return current stream")
	runif(10)
	checkIdentical(s, RNGseq_seed(456), "Current is CMRG: seed=numeric return stream seeded with value")

}

test.RNGseq <- function(){

	os <- RNGseed()
	on.exit(RNGseed(os))

	# actual testing function
	.test_loc <- function(.msg, n, ..., .list=TRUE, .change=FALSE){
		msg <- function(...) paste(.msg, ':', ...)
		os <- RNGseed()
		on.exit(RNGseed(os))

		s <- RNGseq(n, ...)

		if( !.change ) checkIdentical(RNGseed(), os, msg("the value of .Random.seed is not changed"))
		else checkTrue( !identical(RNGseed(), os), msg("the value of .Random.seed does change"))

		if( .list )	checkTrue(is.list(s), msg("result is a list"))
		else{
			checkTrue(is.integer(s), msg("result is an integer vector"))
			s <- list(s)
		}

		checkTrue(length(s) == n, msg("result has correct length"))
		checkTrue(all(sapply(s, length) == 7L), msg("each element has length 7"))
		checkTrue(all(sapply(s, function(x) x[1] %% 100) == 7L), msg("each element has correct RNG kind"))
		s
	}

	.test <- function(msg, n, ...){
		set.seed(1)
		s1 <- .test_loc(paste(msg, '- no seed'), n, ..., .change=TRUE)
		runif(1)
		s2 <- .test_loc(paste(msg, '- seed=1'), n, 1, ..., .change=FALSE)
		#checkIdentical(s1, s2, paste(msg, " - set.seed(1) + no seed is identical to seed=1"))
		.test_loc(paste(msg, '- seed=1:6'), n, 1:6, ...)
	}
	.test("n=1", 1, .list=FALSE)
	.test("n=2", 2)
	.test("n=5", 5)

	# with full list
	s <- RNGseq(3)
	checkIdentical(RNGseq(length(s), s), s, "If passing a complete list: returns the list itself")
	s3 <- RNGseq(5)
	s <- structure(s, rng=s3)
	checkIdentical(RNGseq(length(s3), s), s3, "If passing a complete list in rng S3 slot: returns the complete slot")
	#

	# Current RNG is CMRG
	set.seed(456, "L'Ec")
	s <- .Random.seed
	ref <- list(s, nextRNGStream(s), nextRNGStream(nextRNGStream(s)))
	rs <- RNGseq(3, 456)
	checkIdentical(rs, ref, "Current RNG is CMRG: RNGseq(n, num) returns RNG streams that start with stream as set.seed")
	checkIdentical(s, .Random.seed, "Current RNG is CMRG: RNGseq(n, num) did not change random seed")

	runif(10)
	s <- .Random.seed
	ref <- list(s, nextRNGStream(s), nextRNGStream(nextRNGStream(s)))
	rs2 <- RNGseq(3)
	checkIdentical(rs2, ref, "Current RNG is CMRG: RNGseq(n) returns RNG streams that start with current stream")
	checkIdentical(.Random.seed, nextRNGStream(tail(rs2,1)[[1]]), "Current RNG is CMRG: RNGseq(n) changes current random seed to next stream of last stream in sequence")

}


# cerner_2^5_2018
numerals <- readline(prompt="Enter roman numerals: ")

print(as.integer(as.roman(numerals)))