library(ggplot2)
library(tidyverse)
library(dplyr)

read_in_prepped_sam <- function(csv_file) {
    df <- read_csv(csv_file)

    df <- select(df, -QNAME, -RNAME, -MAPQ, -CIGAR, -RNEXT, -PNEXT, -TLEN, -QUAL, -FLAG, -SEQ) #drop unnecessary columns
    return(df)
}

plot_lengths <- function(df, samples, xmin=0, xmax=1000) {
    df <- pivot_longer(df, cols=c("LENGTH"))
    df <- filter(df, id %in% samples)
    plt <- ggplot(df,aes(x=value, color=id, linetype=condition, fill=substrate)) +
                geom_density()
    return(plt)
}

plot_right_location <- function(df, samples) {
    df <- select(df, SAMPLE %in% samples, ATTRIBUTE=="RIGHT")

    plt <- ggplot(df, aes(x=VALUE, color=SAMPLE)) +
        geom_density()

    return (plt)
}


{{rimport}}('__init__.r', 'plot.r', 'sampleinfo.r')
library(methods)
options(stringsAsFactors = FALSE)

infile  = {{i.infile | quote}}
gfile   = {{i.gfile | quote}}
prefix  = {{i.infile | fn2 | quote}}
outdir  = {{o.outdir | quote}}
inopts  = {{args.inopts | R}}
tsform  = {{args.tsform or 'NULL'}}
filter  = {{args.filter or 'NULL'}}
plots   = {{args.plot | R}}
ggs     = {{args.ggs | R}}
params  = {{args.params | R}}
devpars = {{args.devpars | R}}

expr = read.table.inopts(infile, inopts)
if (is.function(filter)) {
	expr = filter(expr)
	outfile = file.path(outdir, basename(infile))
	write.table(expr, outfile, row.names = TRUE, col.names = TRUE, sep = "\t", quote = FALSE)
}
if (is.function(tsform)) {
	expr = tsform(expr)
}
saminfo = NULL
if (gfile != "") {
	saminfo = SampleInfo2$new(gfile)
	groups  = saminfo$all.groups()
}

if (plots$boxplot) {
	bpfile = file.path(outdir, paste0(prefix, '.boxplot.png'))
	plot.boxplot(expr, bpfile, stacked = F, devpars = devpars, params = params$boxplot, ggs = ggs$boxplot)
	if (!is.null(saminfo)) {
		for (group in groups) {
			bpfile = file.path(outdir, paste0(prefix, '.', group, '.boxplot.png'))
			plot.boxplot(
				expr[, saminfo$get.samples('Group', group), drop = FALSE],
				bpfile, stacked = F, devpars = devpars, params = params$boxplot, ggs = ggs$boxplot)
		}
	}
}

if (plots$histogram) {
	histfile = file.path(outdir, paste0(prefix, ".histo.png"))
	plot.histo(stack(as.data.frame(expr)), histfile, devpars = devpars, params = params$histogram, ggs = ggs$histogram)
	if (!is.null(saminfo)) {
		for (group in groups) {
			histfile = file.path(outdir, paste0(prefix, '.', group, '.histo.png'))
			plot.histo(
				stack(expr[, saminfo$get.samples('Group', group), drop = FALSE]),
				histfile, devpars = devpars, params = params$histogram, ggs = ggs$histogram)
		}
	}
}

if (plots$qqplot) {
	qqfile = file.path(outdir, paste0(prefix, ".qq.png"))
	plot.qq(expr, qqfile, stacked = FALSE, devpars = devpars, params = params$qqplot, ggs = ggs$qqplot)
	if (!is.null(saminfo)) {
		for (group in groups) {
			qqfile = file.path(outdir, paste0(prefix, '.', group, '.qq.png'))
			plot.qq(
				stack(expr[, saminfo$get.samples('Group', group), drop = FALSE]),
				qqfile, stacked = FALSE, devpars = devpars, params = params$qqplot, ggs = ggs$qqplot)
		}
	}
}


require(compiler)
enableJIT(3)
library(RDS)
# run with command:
# &"C:\\Program Files\\R\\R-3.3.3\\bin\\Rscript.exe" "R:\\RDS\\code\\est_r\\net_est_ss.r" "fileName = 'mt_temp.txt'"

comments =
"
# first
# second
"
options('warn'=1)
print(R.Version()$version.string)
print("R: Loading Helpers")

##############################################
##  Some helper functions
##############################################
expand_sampleComp = function( attVals ) {
  header2 = c()
  eg = expand.grid( attVals, stringsAsFactors=FALSE )
  #cnum:
  for (i in 1:nrow(eg)) {
    header2 = c(header2,paste("cnum_",paste(eg[i,], collapse=''),sep=""))
  }
  #ctie:
  for (i in 1:nrow(eg)) {
    for (j in 1:nrow(eg)) {
      header2 = c( header2,
                   paste("ctie",
                         paste(eg[i,], collapse=''),
                         paste(eg[j,], collapse=''),
                         sep="_") )
    }
  }

  #seedCount
  header2 = c(header2,"seedCount")

  for (i in 1:nrow(eg)) {
    header2 = c(header2,paste("seed_",paste(names(eg), eg[i,],sep='', collapse='_'),sep=""))
  }

  return(header2)
}

expand_RDS_heads = function( estVals, estVH=FALSE) {
  header2 = c()

  #ehat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"ehat", sep="_"))
    }
  }

  #phat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"phat", sep="_"))
    }
  }

  #VH phat
  if (estVH) {
    for (i in 1:length(estVals)) {
      for (j in 1:length(estVals[[i]])) {
        header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"vh_phat", sep="_"))
      }
    }
  }

  #adj_phat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"adj_phat", sep="_"))
    }
  }

  #deg_comp
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"deg_comp", sep="_"))
    }
  }

  #rec_comp
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"rec_comp", sep="_"))
    }
  }

  #mean recruitment activity
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"rec_act", sep="_"))
    }
  }

  #adj.degree
  #for (i in 1:length(estVals)) {
  #  for (j in 1:length(estVals[[i]])) {
  #    header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"adj_deg", sep="_"))
  #  }
  #}

  #SS phat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"ss_phat", sep="_"))
    }
  }

  #RDSI phat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"rdsI_phat", sep="_"))
    }
  }

  #RDSISM phat
  for (i in 1:length(estVals)) {
    for (j in 1:length(estVals[[i]])) {
      header2 = c(header2,paste(names(estVals)[i],estVals[[i]][j],"rdsIsm_phat", sep="_"))
    }
  }

  #waves data
  for (i in 1:length(estVals)) {
    wavesHeader = c( paste(names(estVals)[i],"waves_req", sep="_"),
                     paste(names(estVals)[i],"waves_max", sep="_") )
    header2 = c(header2, wavesHeader)
  }

  #degree data
  #Replacing: header2 = c(header2,"deg.imp_min","deg.imp_med","deg.adj_min","deg.adj_med")

  for (i in 1:length(estVals)) {
    degreeHeader = c( paste(names(estVals)[i],"deg.imp_min", sep="_"),
                      paste(names(estVals)[i],"deg.imp_med", sep="_"),
                      paste(names(estVals)[i],"deg.adj_min", sep="_"),
                      paste(names(estVals)[i],"deg.adj_med", sep="_") )
    header2 = c(header2, degreeHeader)
  }
  return(header2)
}

print("R: Processing")

##############################################
##  Processing code
##############################################

args=(commandArgs(TRUE))
if(length(args)==0){
  print("No arguments supplied.")
  ##supply default values
  fileName = "foo"
}else{
  for(i in 1:length(args)){
    eval(parse(text=args[[i]]))
  }
}

print(fileName)

source('R:\\RDS\\code\\est_r\\rds4.r')
now = date()
# open files
inFile = paste("R:\\RDS\\samples\\", fileName, sep="")
scanner = file(inFile, open="r")
reader = file(inFile , open="r")
results = file(paste("R:\\RDS\\estimates\\", fileName, sep=""), open="w")

# -----------------------------------
# read settings header
#   get scanner and reader pointed to first non-comment line
#   they read it, so the next line is the first header...
currentLine = "#"
while( substring(currentLine,1,1) == "#" ) {
  write( currentLine, results, append=TRUE )
  currentLine = readLines(scanner,1)
  foo = readLines(reader,1)
}

# skip blank lines
while( trimws(currentLine)=="" ) {
  currentLine = readLines(scanner,1)
  foo = readLines(reader,1)
}

# -----------------------------------
# execute embedded commands
# embedded command includes the attribute names and levels in a pairlist:
# names(attVals) = attributes
# attVals$___ = c(levels of attribute)
while( substring(currentLine,1,1) == "-" ) {
  print( currentLine )
  eval(parse(text=substring(currentLine, 2)))
  currentLine = readLines(scanner,1)
  foo = readLines(reader,1)
}

if(!exists("estVals")) {
  estVals = attVals
}

#cats = expand.grid(attVals, stringsAsFactors=FALSE)

# set vars
nlines = 2
go = TRUE
skip = 0
finish = 0
numlines = 0
counter = 1
estVH = TRUE

#get column header
#this will order columns in header2 similarly to
#how they're ordered in header 1 - a constraint
headerread = readLines(scanner,1)

#print(paste("headerread: ",headerread))

header1 = unlist(strsplit(headerread,'\t'))

header2 = expand_sampleComp( attVals )
header2 = c(header2, expand_RDS_heads(estVals, estVH) ) #estVals can be defined in the header commands passed in, otherwise estVals==attVals
header2 = c(header2, "rec_count_sum")
#everything else

while (go) {
  lines = readLines(scanner,nlines)
  if (length(lines) <= 0) { go=FALSE }

  if ("----\t" %in% lines) {
    numlines = finish - skip + which(lines == "----\t")

    if (counter > 1) {
      mynrows=numlines-2
    }
    else {
      mynrows=numlines-1
    }
    rds = read.table(reader, header = TRUE, sep="\t", skip=0, nrows=mynrows)
    #print(paste("Trial Number: ", counter))

    variables = cbind()
    for (attribute in names(attVals) ) {
      i = match(attribute, names(rds))
      if (!(is.na(i))) {
      	variables = cbind(variables, as.matrix(rds)[,i])
      }
    }
    comp = multi.recruitment( variables, rds$id, rds$RID, attVals)

    ## Looping code that generates estimates for each variable in estvals
    resultList = list()
    rec_act_list = list()
    for (varNum in 1:length(estVals) ) {
      resultList[[varNum]] = rds.set_groups_estimate(
      	rds[,which(names(rds)==names(estVals)[varNum])],
      	rds$id,
      	rds$RID,
      	rds$degree,
      	groups=estVals[[varNum]],
      	estVH=estVH
      )
      rec_act_list[[varNum]] = rds.set_groups_diff_rec(
        rds[,which(names(rds)==names(estVals)[varNum])],
        rds$id, rds$RID, groups=estVals[[varNum]]
      )
    }

    reportItems = c( 'bar$E.hat', 'bar$P.hat', 'bar$adj.P.hat',
                     'bar$group.degree.component', 'bar$group.recruitment.component')
    if (estVH) {
      reportItems = c( 'bar$E.hat', 'bar$P.hat', 'bar$VH.P.hat', 'bar$adj.P.hat',
                       'bar$group.degree.component', 'bar$group.recruitment.component')
    }

    resultsReport = c()
    for (item in reportItems) {
      for (varNum in 1:length(estVals)) {
        bar = resultList[[varNum]]
        resultsReport = c(resultsReport, eval(parse(text=item) ))
      }
    }

    item='bar$mean_rec'
    for (varNum in 1:length(estVals)) {
        bar = rec_act_list[[varNum]]
        resultsReport = c(resultsReport, eval(parse(text=item)))
    }

    ## Add Gile's estimate
    net_size = sum(rds[1,grep("^num*", names(rds))])
    # recruiter for seeds cannot be NA, assign instead value 0
    rds$RID = rds$RID + 1
    rds$id = rds$id + 1
    NAs = is.na(rds$RID)
    rds$RID[NAs] = 0
    ssrds = as.rds.data.frame(rds, id="id", recruiter.id="RID", network.size="degree", population.size = net_size)

    for (varNum in 1:length(estVals)) {
        ssrds$charoutcome = sapply(rds[names(estVals)[varNum]], as.character)
        #as.character(eval(parse(text=paste('rds$',names(estVals)[1], sep = ""))))
        var_cat_count = length(estVals[[varNum]]) # Count of levels of variable

        ssest_est = tryCatch({
                ssest = RDS.SS.estimates(rds.data=ssrds, outcome.variable="charoutcome", N=net_size,  empir.lik=FALSE)
                ssest@estimate
            },
            error=function(err) {
                #print("Bailing on SS");
                #rm(ssest);
                return(rep(NA_character_, var_cat_count))
            })
        if (length(ssest_est) != var_cat_count) {
            ssest_est = rep(NA_character_, var_cat_count)
        }

        rdsi_est = tryCatch({
                rdsi_est = RDS.I.estimates(rds.data=ssrds, outcome.variable="charoutcome", empir.lik=FALSE)
                rdsi_est@estimate
            },
            error=function(err) {
                #print("Bailing on RDSI");
                #rm(rdsi_est);
                return(rep(NA_character_, var_cat_count))
            })
        if (length(rdsi_est) != var_cat_count) {
            rdsi_est = rep(NA_character_, var_cat_count)
        }

        rdsis_est = tryCatch({
                rdsis_est = RDS.I.estimates(rds.data=ssrds, outcome.variable="charoutcome", smoothed=TRUE, empir.lik=FALSE)
                rdsis_est@estimate
            },
            error=function(err) {
                #print("Bailing on RDSI_sm");
                #rm(rdsis_est);
                return(rep(NA_character_, var_cat_count))
            })
        if (length(rdsis_est) != var_cat_count) {
            rdsis_est = rep(NA_character_, var_cat_count)
        }
    	resultsReport = c(resultsReport, ssest_est, rdsi_est, rdsis_est)         #, 1 - ssest@estimate, ssest@estimate)
    }
    rm(ssrds);
    gc();

    for (varNum in 1:length(estVals)) {
      bar = resultList[[varNum]]
      resultsReport = c(resultsReport,
                        bar$waves.req, bar$waves.max,
                        min(bar$imputed.degree, na.rm=TRUE),
                        median(bar$imputed.degree, na.rm=TRUE),
                        min(bar$adj.degree, na.rm=TRUE),
                        median(bar$adj.degree, na.rm=TRUE)
      )
    }

    if (counter == 1) {
      header1 = c( names(rds)[ 1:(length(names(rds))-(length(attVals)+5)) ] ) #trim off id, RID, degree, wave, rec_count and attVals
      header = c(header1,header2)
      write(header, file=results, ncolumns=length(header), sep="\t", append=TRUE)
      #print(comp$categories)
    }

    if ("var_name" %in% names(rds)) {
    	rds$var_name = as.character(rds$var_name)
    }
    write( c(
      unlist(rds[1,1:length(header1)]),
      comp$composition,
      t(comp$multi.rec),
      sum(comp$seed.composition),
      comp$seed.composition,
      resultsReport,
      sum(rds$rec_count)),
           file=results, ncolumns=length(header), sep="\t", append=TRUE )

    skip = skip + numlines
    readLines(reader,1)
    if (counter %% 500 == 0) {
        print(paste(fileName, ", Trial Number: ", counter))
        #print(paste("Memory Use: ", memory.size()))
    }
    counter = counter + 1

    # cjc73 - try to work around 32-bit R
    #rm(ssrds)
    #rm(ssest)
    #rm(resultsReport)
    #rm(variables)
    #rm(comp)
    #rm(rds)
    #rm(bar)
    #gc()

  }
  finish = finish + nlines

}
close(results)
#warnings()
q()


library(tidyverse)
library(lubridate)

#### dataset ####
# use dataset resulting from cleanup.R

colnames(geo_clean)
colnames(acs_data)

geo_acs <- geo_clean %>%
  left_join(acs_data, by = "GEOID")

# dim(geo_clean)
# geo_clean[,1]
# dim(acs_data)
# acs_data[,1]
#colnames(geo_acs[,1:150])

# what's the time span of this dataset?
min(year(geo_clean$Assessment_Start_Date), na.rm = TRUE)
max(year(geo_clean$Assessment_Start_Date), na.rm = TRUE)

#### by states ####

# how do the number of properties look like across states (1970 - 2020)?
geo_clean %>%
  select(ACRES_Property_ID, Property_State) %>%
  distinct(ACRES_Property_ID, .keep_all = TRUE) %>%
  count(Property_State) %>%
  ggplot(aes(x = reorder(Property_State, n), y = n)) +
  geom_bar(stat = "identity", fill = "blue4") +
  labs(title = "Number of ACRES properties (1970 - 2020)",
       x = "Number of ACRES properties",
       y = "States"
      ) +
  coord_flip()

# how do the number of properties (that needs cleaning) look like across states (1970 - 2020)?
# properties that need cleaning by state

geo_clean %>%
  count(Cleanup_Required)

    # count
geo_clean %>%
  select(ACRES_Property_ID, Property_State, Cleanup_Required) %>%
  filter(!is.na(Cleanup_Required)) %>%
  distinct(ACRES_Property_ID, .keep_all = TRUE) %>%
  group_by(Property_State) %>%
  count(Cleanup_Required) %>%
  ggplot(aes(x = reorder(Property_State, n), y = n, fill = Cleanup_Required)) +
  geom_bar(stat = "identity") +
  labs(title = "ACRES properties cleanup requirement (1970 - 2020)",
       x = "Number of ACRES properties",
       y = "States",
       fill = "Cleanup required"
  ) +
  coord_flip()

  # proportion

geo_clean %>%
  select(ACRES_Property_ID, Property_State, Cleanup_Required) %>%
  filter(!is.na(Cleanup_Required)) %>%
  distinct(ACRES_Property_ID, .keep_all = TRUE) %>%
  group_by(Property_State) %>%
  count(Cleanup_Required)%>%
  ggplot(aes(x = reorder(Property_State, n), y = n, fill = Cleanup_Required)) +
  geom_bar(stat = "identity", position = "fill") +
  labs(title = "ACRES properties cleanup requirement (1970 - 2020)",
       x = "Number of ACRES properties",
       y = "States",
       fill = "Cleanup required"
  ) +
  coord_flip()

#### by epa regions ####

# how many epa regions are there?
geo_clean %>%
  count(EPA_Region)

# what's the average number of properties per year in an epa region?
geo_epa <- geo_clean %>%
  select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date) %>%
  filter(!is.na(Assessment_Start_Date)) %>%
  distinct(ACRES_Property_ID, .keep_all = TRUE) %>%
  mutate(year = year(Assessment_Start_Date))

geo_epa %>%
  group_by(EPA_Region) %>%
  group_by(EPA_Region, year) %>%
  summarize(n_properties = n()) %>%
  group_by(EPA_Region) %>%
  summarize(avg_properties = mean(n_properties)) %>%
  ungroup() %>%
  ggplot(aes(x = reorder(EPA_Region, -avg_properties), y = avg_properties)) +
  geom_bar(stat = "identity", fill = "coral2") +
  labs(title = "Average number of ACRES properties per year",
       x = "EPA Region",
       y = "Avg number of ACRES properties"
  )

# how does the number of acres properties changes over the years by regions?

geo_epa %>%
  group_by(EPA_Region, year) %>%
  summarize(n_properties = n()) %>%
  ungroup() %>%
  ggplot(aes(x = year, y = n_properties, colour = EPA_Region)) +
  geom_line() +
  labs(title = "ACRES properties by EPA region (1970 - 2020)",
       x = "Number of ACRES properties",
       y = "Year",
       colour = "EPA Region"
  )

# how does the type of assessments varies between 1995 - 2020 across epa regions?

# recreate geo_epa with required vars, this time an acres_property_id may appear multiple times
# if the property undergoes multiple assessment phases, and/or
# if a property experience several assessment-start-date for a type of assessment

geo_epa <- geo_clean %>%
  select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date, Assessment_Phase) %>%
  filter(!is.na(Assessment_Start_Date)) %>%
  mutate(year = year(Assessment_Start_Date)) %>%
  distinct(ACRES_Property_ID, Assessment_Start_Date, .keep_all = TRUE)

geo_epa%>%
  filter(year > 1994)%>%
  group_by(EPA_Region, Assessment_Phase) %>%
  summarise(n_phase = n()) %>%
  ungroup() %>%
  ggplot(aes(x = EPA_Region, y = n_phase)) +
  geom_bar(aes(fill = Assessment_Phase), position = "dodge", stat = "identity") +
  labs(title = "Assessment Phases on ACRES properties (1995 - 2020)",
       x = "EPA Region",
       y = "Number of ACRES properties",
       fill = "Assessment Phase"
  )

geo_epa %>%
  filter(year > 1994) %>%
  select(-Assessment_Start_Date) %>%
  distinct(ACRES_Property_ID, Assessment_Phase, .keep_all = TRUE) %>%
  ggplot(aes(x = EPA_Region, y = Assessment_Phase)) +
  geom_count(color = "darkblue") +
  theme(legend.position = "bottom")

# what's the average number of phases that a property experience? (out of the four)
geo_epa %>%
  filter(year > 1994) %>%
  select(-Assessment_Start_Date) %>%
  distinct(ACRES_Property_ID, Assessment_Phase, .keep_all = TRUE) %>%
  group_by(EPA_Region, ACRES_Property_ID) %>%
  summarise(n_phase = n()) %>%
  group_by(EPA_Region) %>%
  summarise(avg_phases = mean(n_phase)) %>%
  ungroup() %>%
  ggplot(aes(x = reorder(EPA_Region, avg_phases), y = avg_phases)) +
  geom_bar(stat = "identity", fill = "chartreuse4") +
  labs(title = "Average number of phases per ACRES property (1995 - 2020)",
             x = "EPA Region",
             y = "Number of phases") +
  coord_flip()

# what's the distribution of number of phases per property across region?
geo_epa %>%
  filter(year > 1994) %>%
  select(-Assessment_Start_Date) %>%
  distinct(ACRES_Property_ID, Assessment_Phase, .keep_all = TRUE) %>%
  group_by(EPA_Region, ACRES_Property_ID) %>%
  summarise(n_phase = n()) %>%
  ungroup() %>%
  ggplot(aes(x = EPA_Region, fill = as.factor(n_phase))) +
  geom_bar(position = "dodge") +
  labs(title = "Phases per ACRES property (1995 - 2020)",
       x = "EPA Region",
       y = "Number of properties",
       fill = "Number of phases per ACRES property"
  ) +
  theme(legend.position = "bottom")

# ** investigate duplicates **
# geo_clean %>%
#   filter(ACRES_Property_ID == 58901 & Assessment_Phase == "Supplemental Assessment" &
#            Assessment_Start_Date == "2008-08-14") %>%
#   view()
#
# geo_clean %>%
#   select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date, Assessment_Phase,
#          Source_of_Assessment_Funding, Entity_Providing_Assmnt_Funds, Amt_of_Assessment_Funding,
#          Source_of_Cleanup_Funding, Amount_of_Cleanup_Funding) %>%
#   filter(!is.na(Assessment_Start_Date)) %>%
#   distinct(ACRES_Property_ID, Assessment_Start_Date, Assessment_Phase,
#            Source_of_Assessment_Funding, Entity_Providing_Assmnt_Funds,
#            Amt_of_Assessment_Funding, Source_of_Cleanup_Funding,
#            Amount_of_Cleanup_Funding,
#            .keep_all = TRUE) %>%
#   filter(ACRES_Property_ID == 58901 & Assessment_Phase == "Supplemental Assessment") %>%
#   .[2:3,] %>%
#   view()
#
# geo_clean %>%
#   select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date, Assessment_Phase,
#          Source_of_Assessment_Funding, Entity_Providing_Assmnt_Funds, Amt_of_Assessment_Funding,
#          Source_of_Cleanup_Funding, Amount_of_Cleanup_Funding) %>%
#   filter(!is.na(Assessment_Start_Date)) %>%
#   distinct(ACRES_Property_ID, Assessment_Start_Date, Assessment_Phase,
#            .keep_all = TRUE) %>%
#   filter(ACRES_Property_ID == 16087 & Assessment_Phase == "Supplemental Assessment") %>%
#   view()
#
# geo_clean %>%
#   select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date, Assessment_Phase) %>%
#   filter(!is.na(Assessment_Start_Date)) %>%
#   mutate(year = year(Assessment_Start_Date)) %>%
#   filter(year > 1994) %>%
#   distinct(ACRES_Property_ID, Assessment_Start_Date, .keep_all = TRUE) %>%
#   filter(ACRES_Property_ID == 16087 & Assessment_Phase == "Phase II Environmental Assessment") %>%
#   view()

# ACRES_Property_ID == 58901
# ACRES_Property_ID == 16087
  # Supplemental Assessment : 11 times (at different start-assessment-date)
  # Cleanup Planning: 1 time
  # Phase I Environmental Assessment: 2 times
  # Phase II Environmental Assessment: 11 times -- one phase that stretch from 2004 - 2020, (receive funding diff amount per entry)

# ** end investigate duplicates **

# how long does each phase generally take? any pattern across epa region?

geo_epa <- geo_clean %>%
  select(ACRES_Property_ID, EPA_Region, Assessment_Start_Date, Assessment_Completion_Date, Assessment_Phase) %>%
  filter(!is.na(Assessment_Start_Date)) %>%
  mutate(year = year(Assessment_Start_Date)) %>%
  distinct(ACRES_Property_ID, Assessment_Start_Date, .keep_all = TRUE)

ph_duration <- geo_epa %>%
  filter(year > 1994) %>%
  mutate(phase_duration = Assessment_Completion_Date - Assessment_Start_Date + 1) %>%
  group_by(ACRES_Property_ID, Assessment_Phase) %>%
  mutate(total_duration = sum(phase_duration)) %>% # check for negative numbers
  ungroup() %>%
  distinct(ACRES_Property_ID, EPA_Region, Assessment_Phase, total_duration, .keep_all = TRUE)

# ph_duration %>%
#   filter(total_duration < 0)
#
# ph_duration %>%
#   filter(ACRES_Property_ID == 90742)
#
#
#   filter(ACRES_Property_ID == 16087 & Assessment_Phase == "Phase II Environmental Assessment") %>%
#   view()

# what's the number of funding per phase? do they differ across phase?

# what are the average costs look like across region?

# what does the average cost look like by region and assessment type?

# what's the length of assessment look like across epa regions?

# contaminant types (metal etc) by epa regions

# cost!!


#!/usr/bin/env Rscript
#
# This script does simple forward model selection on variants and
# phenotypes. A simple imputation method (just taking the mean) is used
# to deal with missing genotype data.
#

library(magrittr)
library(data.table)
library(dplyr)
library(dtplyr)
library(MuMIn)

## Function to impute missing data by replacing missing genotypes with
## the mean. Expects alleles to be coded as 0 and 1.
impute = function(x) {
    apply(x, 2, function(x) {
          m = mean(x, na.rm=TRUE)
          x[is.na(x)] = m
          x
})
}

#==============================================================================#

cargs = commandArgs(trailingOnly=TRUE)
if(length(cargs) < 3) {
    cat('mult_regr_model_selections.r <genotypes> <variants> <phenotypes>\n\n',
        file=stderr())
}
geno_data_file = cargs[1] # .tsv file created from VCF with 0 and 1 for genotypes
                          # can have or not have an "rs" column
top_vars_file = cargs[2]  # File with rs; rows are replicates, columns are ordered
pheno_file = cargs[3]     # File with two columns: strain and phenotype value, no
                          # header

## Get the genotype data
## It seems easiest to grab this from the tsv file that was used as
## input for the LD script rather than trying to use the VCF or plink
## files. If there isn't an "rs" column (variant identification), it
## joins the chromosome and position with "-" to get an ID.
geno_data = fread(geno_data_file, header=TRUE,
                  verbose=FALSE, showProgress=FALSE)
if(!('rs' %in% colnames(geno_data))) {
    geno_data = geno_data %>% mutate(rs=paste0(contig, '-', pos))
}
geno_data %<>% setkey(cols='rs')

## Get the phenotype data and put it in the same order as the
## genotype data
pheno = read.table(pheno_file, as.is=TRUE)
pheno = pheno[match(colnames(geno_data), pheno[, 1]), ]
pheno = pheno[!is.na(pheno[, 1]), ]

## Make a matrix with just the genotypes
geno_data = geno_data[, c('contig', 'pos', 'rs', pheno[, 1]), with=FALSE]
geno_mat = geno_data %>% select(-contig, -pos, -rs) %>%
    as.matrix()

## Read in list of top variants
top_vars = read.table(top_vars_file, as.is=TRUE)

## Loop over replicates
cat('replicate\tnvars\tR2\tAIC\tbest\tadded\tvars\n')
for(i in 1:nrow(top_vars)) {

    ## List of variants for this replicate
    focal_vars = as.character(top_vars[i, ])

    ## Get the genotypes for this replicate and impute missing data by
    ## making missing data equal the mean genotype; this is the
    ## strategy used by GEMMA, and it avoids issues with losing lots of
    ## individuals when there is missing data without biasing the results
    ## much.
    top_vars_geno = geno_data[focal_vars, on='rs'] %>%
        select(-contig, -pos, -rs) %>%
        as.matrix %>%
        t() %>%
        impute()
    all_missing = logical(length(focal_vars))
    for(j in 1:length(focal_vars)) {
        if(all(is.na(top_vars_geno[, j]))) {
            all_missing[j] = TRUE
        }
    }
    top_vars_geno = top_vars_geno[, !all_missing]
    focal_vars = focal_vars[!all_missing]
    focal_interacts = t(combn(focal_vars, 2))
    n_vars = length(focal_vars)
    n_interacts = length(focal_interacts)
    n_terms = n_vars + n_interacts

    ## Each variant by itself
    indiv_vars = data.frame('var'=focal_vars,
                            'r2'=numeric(n_vars),
                            'aic'=numeric(n_vars),
                            stringsAsFactors=FALSE)
    for(j in 1:n_vars) {
        m = lm(pheno[, 2] ~ top_vars_geno[, j])
        indiv_vars[j, 'r2'] = summary(m)$r.squared
        indiv_vars[j, 'aic'] = AICc(m)
        indiv_vars[j, 'var'] = focal_vars[j]
    }
    write.table(data.frame('replicate'=rep(i, n_vars),
                           'nvars'=rep(1, n_vars),
                           'R2'=indiv_vars['r2'],
                           'AIC'=indiv_vars['aic'],
                           'best'=rep(NA, n_vars),
                           'added'=indiv_vars['var'],
                           'vars'=indiv_vars['var']),
                file=stdout(), col.names=FALSE, sep='\t',
                row.names=FALSE, quote=FALSE)

    ## Model selection
    sel_methods = c('R2', 'AIC')
    n_meth = length(sel_methods)
    model_selection = data.frame(replicate=rep(i, n_terms*n_meth),
                                 'nvars'=rep(1:n_terms, each=n_meth),
                                 'r2'=numeric(n_terms*n_meth),
                                 'aic'=numeric(n_terms*n_meth),
                                 'best'=rep(1, n_terms*n_meth),
                                 'added'=character(n_terms*n_meth),
                                 'vars'=character(n_terms*n_meth),
                                 stringsAsFactors=FALSE)
    for(sm in seq_along(sel_methods)) {
        method = sel_methods[sm]
        model_vars = logical(n_vars)
        model_i_vars = logical(n_interacts)
        for(j in 1:n_vars) {
            tested_vars = which(!model_vars)
            if(sum(model_vars) > 1) {
                ## TODO: interaction terms to test need to be variables
                ## currently in the model as main effects
                tested_interactions = which(!model_i_vars & ...)
            }
            ## TODO - needs to include interactions
            models = vector('list', length=sum(!model_vars))
            for(k in seq_along(tested_vars)) {
                cols = model_vars
                cols[tested_vars[k]] = TRUE
                models[[k]] = lm(pheno[, 2] ~ top_vars_geno[, cols])
            }
            ## This part is mostly okay
            r2s = sapply(models, function(m) summary(m)$r.squared)
            aics = sapply(models, function(m) AICc(m))
            if(method == 'R2') {
                best = which(r2s == max(r2s))
                best = which(r2s == max(r2s))[1]
            } else if(method == 'AIC') {
                best = which(aics == min(aics))
                best = which(aics == min(aics))[1]
            }
            if(length(best) > 1) {
                ## This shouldn't happen if the data has been thinned
                ## by LD group properly
                cat('Warning: more than one best choice\n', file=stderr())
                best = best[1]
            }
            model_vars[tested_vars[best]] = TRUE
            ## TODO adjust index n_vars*... for interactions
            model_selection[(n_vars*(sm-1))+j, 'nvars'] = j
            model_selection[(n_vars*(sm-1))+j, 'r2'] = r2s[best]
            model_selection[(n_vars*(sm-1))+j, 'aic'] = aics[best]
            model_selection[(n_vars*(sm-1))+j, 'aic'] = method
            model_selection[(n_vars*(sm-1))+j, 'added'] = focal_vars[tested_vars[best]]
            ## TODO - this line needs to handle interactions
            model_selection[(n_vars*(sm-1))+j, 'vars'] = paste(focal_vars[model_vars],
                                                               collapse=',')
        }
    }
    write.table(model_selection, file=stdout(), sep='\t',
                col.names=FALSE, row.names=FALSE, quote=FALSE)
}


######## Construct the Context

args <- commandArgs()
print(args)
currentview=as.character(args[6])
csv_file=as.character(args[7])
rcf_context_file=as.character(args[8])
output_scoring_file=as.character(args[9])
MinSup=as.numeric(args[10])
MinConf=as.numeric(args[11])

myWorkingDirectory=getwd()
options(max.print=10000000)

cat('\n ############### Association Rule Mining ######################## \n')

################ Load objects, attributes and binary matrix from CSV TO suitable variables.

cat('\n Init System LOAD FROM  CSV... \n ')
cat('\n Parameters are: \n ')
cat('\n CSV \n ',csv_file)
source("load_csv.r")
returns_args=load_csv(csv_file)
List_Objects=returns_args$List_Objects
List_Attributes=returns_args$List_Attributes
AttributesofObject=returns_args$AttributesofObject
ObjectOfAttributes=returns_args$ObjectOfAttributes

ContextFileRCF=rcf_context_file
cat('\n ################## sup \n',MinSup)
cat('\n ############### conf \n',MinConf)
##-----------------------------------------LESS DETAILS OF RULES
cat('\n ----> Calculating Rules \n')
SoftAssRulescmd=paste0("./coron-0.8/core02_assrulex.sh  ",ContextFileRCF, " ", MinSup,"% ", MinConf,"% -names -alg:zart -rule:all -full ",sep="") #>thisresults2.txt
cat(SoftAssRulescmd)
SoftAssRulesresult=try(system(SoftAssRulescmd, intern = TRUE,  wait = TRUE))
CoronOutPut=as.list(SoftAssRulesresult)
CoronOutPut=lapply(CoronOutPut,function(x)x[!is.na(x)])
CoronOutPut=lapply(CoronOutPut,function(x)x[!x==""])
CoronOutPut=Filter(length,CoronOutPut)
CoronOutPut=CoronOutPut[14:length(CoronOutPut)-2]
CondRules=lapply(strsplit(as.character(CoronOutPut),">"),"[",1)
CondRules=lapply(CondRules, function(x)gsub("{", '', x, fixed = T))
CondRules=lapply(CondRules, function(x)gsub("}", '', x, fixed = T))
CondRules=lapply(CondRules, function(x)gsub("=", '', x, fixed = T))
CondRules=lapply(CondRules, function(x)gsub(" ", '', x, fixed = T))
NbRules=as.integer(length(CondRules))

cat('nb Association Rules',NbRules)

ResRules=lapply(strsplit(as.character(CoronOutPut),">"),"[",2)
values=lapply(strsplit(as.character(ResRules),"}"),"[",2)
Support=lapply(strsplit(as.character(values),";"),"[",1)
Support=lapply(strsplit(as.character(Support),"\\["),"[",2)
Support=lapply(Support, function(x)gsub("%", '', x, fixed = T))
Support=lapply(Support, function(x)gsub("]", '', x, fixed = T))
Support=as.numeric(Support)
Confidence=lapply(strsplit(as.character(values),";"),"[",2)
Confidence=lapply(strsplit(as.character(Confidence),"\\["),"[",2)
Confidence=lapply(strsplit(as.character(Confidence),"%"),"[",1)
Confidence=as.numeric(Confidence)
#Confidence=lapply(Confidence, function(x)gsub("%", '', x, fixed = T))
#Confidence=lapply(Confidence, function(x)gsub("\\]", '', x, fixed = T))
ResRules=lapply(strsplit(as.character(ResRules),"}"),"[",1)
ResRules=lapply(ResRules, function(x)gsub("{", '', x, fixed = T))
ResRules=lapply(ResRules, function(x)gsub(" ", '', x, fixed = T))

Lift=lapply(strsplit(as.character(CoronOutPut),">"),"[",2)
Lift=lapply(strsplit(as.character(Lift),";"),"[",5)
Lift=lapply(strsplit(as.character(Lift),"="),"[",2)
Lift=as.numeric(Lift)

df.AssocRulesOutPut=data.frame()
df.AssocRulesOutPut=do.call(rbind, Map(data.frame, "CondRules"=CondRules, "ResRules"=ResRules,"Support"=Support,"Confidence"=Confidence,"Lift"=Lift))
write.csv(file=paste0("./contexts/AssociationRules_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".csv",sep=""), df.AssocRulesOutPut)
cat('\n Saving Rules \n')
cat('\n Rules file in =======> \n',paste0("./contexts/AssociationRules_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".csv",sep=""))

cat('\n Calculating Scores of the Rules \n')
TopViolatedRulesForEachObjectConfidence=""
TopViolatedRulesForEachObjectLift=""
ViolatedRulesForEachObjectConfidence=""
ViolatedRulesForEachObjectLift=""
TopScoreConfidence=""
TopScoreLift=""
AVGScoresOfObjectsConfidence =""
AVGScoresOfObjectsLift =""
ViolatorObjectList=""
CondRules=lapply(CondRules, function(x)unlist(strsplit(as.character(x),split=',')))
ResRules=lapply(ResRules, function(x)unlist(strsplit(as.character(x),split=',')))

for(Obj in 1:length(List_Objects)){
  GlobalscoreConf=0.0
  GlobalscoreLift=0.0
  Max_ScoreConf=0.0
  Max_ScoreLift=0.0
  Max_RuleConf=""
  Max_RuleLift=""
  RuleListConf=""
  RuleListLift=""
  nbViolatedRules=0
  cat('Obj \n',Obj)
  for(Rule in 1:length(CoronOutPut)){
    RulescoreConf=0.0
    RulescoreLift=0.0
    if(length(intersect(AttributesofObject[[Obj]], as.list(unlist(CondRules[Rule]))))>0 & length(intersect(AttributesofObject[[Obj]],as.list(unlist( ResRules[Rule]))) )==0        )
    {##Violation =============================================
      ##violation with score based on confidence
      nbViolatedRules=nbViolatedRules+1
      RulescoreConf=log2(1-as.double(Confidence[Rule])/100)
      GlobalscoreConf=GlobalscoreConf+RulescoreConf

    }###================================================endif violation

  }##for rules
  if(nbViolatedRules>0)
  {
    GlobalscoreConf=(0-GlobalscoreConf)/nbViolatedRules
    AVGScoresOfObjectsConfidence=c(AVGScoresOfObjectsConfidence,GlobalscoreConf)

    ViolatorObjectList=c(ViolatorObjectList,List_Objects[[Obj]])
  }

}#for obj

AVGScoresOfObjectsConfidence=AVGScoresOfObjectsConfidence[-1]
ViolatorObjectList=ViolatorObjectList[-1]

# save(AVGScoresOfObjectsLift,file=paste0("./contexts/AVGScoresOfObjectsLift_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(TopViolatedRulesForEachObjectLift,file=paste0("./contexts/TopViolatedRulesForEachObjectLift_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(TopScoreLift,file=paste0("./contexts/TopScoreLift_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(ViolatedRulesForEachObjectLift,file=paste0("./contexts/ViolatedRulesForEachObjectLift_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(AVGScoresOfObjectsConfidence,file=paste0("./contexts/AVGScoresOfObjectsConfidence_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(TopViolatedRulesForEachObjectConfidence,file=paste0("./contexts/TopViolatedRulesForEachObjectConfidence_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(TopScoreConfidence,file=paste0("./contexts/TopScoreConfidence_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))
#  save(ViolatedRulesForEachObjectConfidence,file=paste0("./contexts/ViolatedRulesForEachObjectConfidence_Only_Conf_",currentview,"_",MinConf,"_Sup_",MinSup,".RData",sep=""))

df.ObjectsWithScores=data.frame(matrix(ncol = 2, nrow = 0))
colnames (df.ObjectsWithScores)=c("Objects", "AVGScoresOfObjectsConfidence"
                                    )

df.ObjectsWithScores=do.call(rbind, Map(data.frame,
                                        "Objects"=as.list(ViolatorObjectList),

                                        "AVGScoresOfObjectsConfidence"=as.list(AVGScoresOfObjectsConfidence)
                                          )
)

cat('\n Saving Scores of the Rules \n')

write.csv(file=output_scoring_file, df.ObjectsWithScores)
cat('\n Check ===> :  ',output_scoring_file)


# Performs ordered logistic regression test and saves results in ordered logistic results file
testCategoricalOrdered <- function(varName, varType, thisdata,
    varlogfile, orderStr="")
{
    pheno <- thisdata[,phenoStartIdx:ncol(thisdata)]
    geno <- thisdata[,"geno"]

    cat("CAT-ORD || ", file=varlogfile, append=TRUE)
    incrementCounter("ordCat")

    doCatOrdAssertions(pheno)
    uniqVar <- unique(na.omit(pheno))

    # Log the ordering of categories used
    orderStr <- setOrderString(orderStr, uniqVar)
    cat("order: ", orderStr, " || ", sep="", file=varlogfile, append=TRUE)

    # Check sample size
    numNotNA <- length(which(!is.na(pheno)))
    if (numNotNA < opt$catordnacutoff) {
        cat("CATORD-SKIP-", opt$catordnacutoff, " (", numNotNA, ") || ", sep="",
            file=varlogfile, append=TRUE)
        incrementCounter(paste("ordCat.", opt$catordnacutoff, sep=""))
        return(NULL)
    } else {
        # Test this cat ordered variable with ordered logistic regression
        phenoFactor <- factor(pheno)
        cat("num categories:", length(unique(na.omit(phenoFactor))), "||",
            file=varlogfile, append=TRUE)

        # BEGIN TRYCATCH
        tryCatch(
        {
            incrementCounter("success.ordCat")
            return(list(phenoFactor, varName))
        # END TRYCATCH
        }, error = function(e) {
            cat("ERROR:", varName, gsub("[\r\n]", "", e))
            incrementCounter("ordCat.error")
        })
    }
}

# Check that the phenotype is valid - that there are more than two categories
# and that these all have at least 10 cases.
# Something has gone wrong if this is the case
doCatOrdAssertions <- function(pheno)
{
    # Assert variable has only one column
    if (!is.null(dim(pheno))) stop("More than one column for categorical ordered")

    uniqVar <- unique(na.omit(pheno))

    # Assert more than 2 categories
    if (length(uniqVar) <= 1) stop("1 or zero values")
    if (length(uniqVar) == 2) stop("this variable is binary")

    # Assert each value has >= 10 examples
    for (u in uniqVar) {
        withValIdx <- which(pheno == u)
        numWithVal <- length(withValIdx)
        if (numWithVal < 10) stop("value with <10 examples")
    }
}

# If data coding file does not specify an order then we use the default order as in coding defined by Biobank
# and this function just generates a string with this order for logging purposes
setOrderString <- function(orderStr, uniqVar) {

    if (is.na(orderStr) || nchar(orderStr) == 0) {
    	orderStr <- ""
    	# Create order str by appending each value
        uniqVarSorted <- sort(uniqVar)
        first <- 1

        for (i in uniqVarSorted) {
            if (first == 0) orderStr <- paste(orderStr, "|", sep="")
    		if (i >= 0) orderStr <- paste(orderStr, i, sep="")
            first <- 0
        }
    }
    return(orderStr)
}


sig = read.table("/recurrency-modelling2/dat/dataA.out")$V1
chps = read.table("/recurrency-modelling2/dat/dataAchps.out")$V1

plot(sig)
abline(v = chps, col = "red")

sig = read.table("D:/_tmp/ttt.delay.10.txt")$V1
plot(sig, type = 'l')


# modular_regressions ----
modular_regressions <- function(type = "glm", fam = "gaussian", dv, cv = NULL, iv, mv, fe = NULL, robust_type = 0, var_cluster = NULL, data, full_model = TRUE, show = TRUE, show_cv = FALSE) {

  if (type == "glm") {
    model_parameters <- list(dv = dv, cv = cv, iv = iv, mv = mv, data = data, full_model = full_model)
    class(model_parameters) <- c("param_glm", class(model_parameters))
    attr(model_parameters, "family") <- fam
  } else if (type == "glmer") {
    model_parameters <- list(dv = dv, cv = cv, iv = iv, mv = mv, fe = fe, data = data, full_model = full_model)
    class(model_parameters) <- c("param_glmer", class(model_parameters))
    attr(model_parameters, "family") <- fam
  }

  out <- .hlpr_modular_models(parameters = model_parameters)

  if (robust_type != 0) {
    var_cluster <- as.data.frame(data)[,var_cluster]
  }

  out <- .hlpr_modular_report(model_list = out, cv = cv, show_cv = show_cv, robust_type = robust_type, var_cluster = var_cluster)

  if (show) {
    if (requireNamespace("stargazer", quietly = TRUE)) {
      if (show_cv) {
        std_errors <- vector(mode = "list", length = ncol(out$std.errors) - 1)
        for (i in seq(ncol(out$std.errors) - 1)) {
          std_errors[[i]] <- na.omit(as.data.frame(out$std.errors)[,i + 1])
        }
        stargazer::stargazer(out$models, se = std_errors, type = "text", report = "vc*p", model.numbers = FALSE, intercept.bottom = FALSE, single.row = TRUE)
      } else {
        warning("Stargazer output requires 'show_cv' == TRUE!")
        if (requireNamespace("knitr", quietly = TRUE)) {
          lapply(out[-4], function(x) knitr::kable(x, digits = 3))
        } else {
          lapply(out[-4], print)
        }
      }
    } else if (requireNamespace("knitr", quietly = TRUE)) {
      lapply(out[-4], function(x) knitr::kable(x, digits = 3))
    } else {
      lapply(out[-4], print)
    }
  } else {
    return(out)
  }
}


######################### MASTER SCRIPT #########################
# This R project consists of 4 R scripts:

# 1)	master.r
# Prior to running the following scripts,
# please ensure that you have the necessary dependencies: JAGS, R packages (coda, rjags).

# 2)	supporting_functions.r : contains additional functions, and models.
source('codes/supporting_functions.r')

# 3)	1_knownpop_validation.r : first validation when selecting the 10 known population (computationally intensive)
source('codes/1_knownpop_validation.r')

# 4)	2_nsum_model.r : 3 models---basic model, tranmission error model, barrier effect model (computationally intensive)
source('codes/2_nsum_model.r')


REBOL [
    System: "REBOL [R3] Language Interpreter and Run-time Environment"
    Title: "Generic function interface definitions"
    Rights: {
        Copyright 2012 REBOL Technologies
        Copyright 2012-2018 Rebol Open Source Contributors
        REBOL is a trademark of REBOL Technologies
    }
    License: {
        Licensed under the Apache License, Version 2.0.
        See: http://www.apache.org/licenses/LICENSE-2.0
    }
    Description: {
        The sense of the term "generic" used here is that of a function which
        has no default implementation--rather each data type supplies its own
        implementation.  The code that runs is based on the argument types:

        https://en.wikipedia.org/wiki/Generic_function
        http://factor-language.blogspot.com/2007/08/mixins.html

        At the moment, only the first argument's type is looked at to choose
        the the dispatch.  This is how common verbs like APPEND or ADD are
        currently implemented.

        !!! The dispatch model in Rebol, and how it might be extended beyond
        the list here (to either more generics, or to user-defined datatypes)
        was not fleshed out, and needs to get attention at some point.
    }
    Notes: {
        Historical Rebol called generics "ACTION!"--a term that has been
        retaken for the "one function datatype":

        https://forum.rebol.info/t/596

        This file is executed during the boot process, after collecting its
        top-level SET-WORD! and binding them into the LIB context.  GENERIC
        is an action which quotes its left-hand side--it does this so that
        it knows the symbol that it is being assigned to.  That symbol is
        what is passed in to the "type dispatcher", so each datatype can
        have its own implementation of the generic function.

        The build process scans this file for the SET-WORD!s also, in order
        to add SYM_XXX constants to the word list--so that switch() statements
        in C can be used during dispatch.
    }
]

;-- Binary Math & Logic

add: generic [
    {Returns the addition of two values.}
    value1 [any-scalar! date! binary!]
    value2
]

subtract: generic [
    {Returns the second value subtracted from the first.}
    value1 [any-scalar! date! binary!]
    value2 [any-scalar! date!]
]

multiply: generic [
    {Returns the first value multiplied by the second.}
    value1 [any-scalar!]
    value2 [any-scalar!]
]

divide: generic [
    {Returns the first value divided by the second.}
    value1 [any-scalar!]
    value2 [any-scalar!]
]

remainder: generic [
    {Returns the remainder of first value divided by second.}
    value1 [any-scalar!]
    value2 [any-scalar!]
]

power: generic [
    {Returns the first number raised to the second number.}
    number [any-number!]
    exponent [any-number!]
]

intersect: generic [
    {Returns the intersection (AND) of two values.}
    value1 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
    ]
    value2 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
    ]
    /case
        "Uses case-sensitive comparison"
    /skip
        "Treat the series as records of fixed size"
    size [integer!]
]

union: generic [
    {Returns the union (OR) of two values.}
    value1 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
    ]
    value2 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
    ]
    /case
        "Use case-sensitive comparison"
    /skip
        "Treat the series as records of fixed size"
    size [integer!]
]

difference: generic [
    {Returns the special difference (XOR) of two values.}
    value1 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
        date! ;-- !!! Under review, this really doesn't fit
    ]
    value2 [
        logic! integer! char! tuple! ;-- math
        any-array! any-string! bitset! typeset! ;-- sets
        binary! ;-- ???
        date! ;-- !!! Under review, this really doesn't fit
    ]
    /case
        "Uses case-sensitive comparison"
    /skip
        "Treat the series as records of fixed size"
    size [integer!]
]

;-- Unary

negate: generic [
    {Changes the sign of a number.}
    number [any-number! pair! money! time! bitset!]
]

complement: generic [
    {Returns the one's complement value.}
    value [logic! integer! tuple! binary! bitset! typeset! image!]
]

absolute: generic [
    {Returns the absolute value.}
    value [any-number! pair! money! time!]
]

round: generic [
    {Rounds a numeric value; halves round up (away from zero) by default.}
    value [any-number! pair! money! time!] "The value to round"
    /to "Return the nearest multiple of the scale parameter"
    scale [any-number! money! time!] "Must be a non-zero value"
    /even      "Halves round toward even results"
    /down      "Round toward zero, ignoring discarded digits. (truncate)"
    /half-down "Halves round toward zero"
    /floor     "Round in negative direction"
    /ceiling   "Round in positive direction"
    /half-ceiling "Halves round in positive direction"
]

random: generic [
    {Returns a random value of the same datatype; or shuffles series.}
    return: [<opt> any-value!]
    value   {Maximum value of result (modified when series)}
    /seed   {Restart or randomize}
    /secure {Returns a cryptographically secure random number}
    /only   {Pick a random value from a series}
]

odd?: generic [
    {Returns TRUE if the number is odd.}
    number [any-number! char! date! money! time! pair!]
]

even?: generic [
    {Returns TRUE if the number is even.}
    number [any-number! char! date! money! time! pair!]
]

;-- Series Navigation

skip: generic [
    {Returns the series forward or backward from the current position.}
    return: [<opt> any-series! gob! port!]
        {Input skipped by the given offset, clipped to head/tail if not /ONLY}
    series [<blank> any-series! gob! port!]
    offset [any-number! logic! pair!]
    /only
        {Don't clip to the boundaries of the series (return blank if beyond)}
]

at: generic [
    {Returns the series at the specified index.}
    return: [<opt> any-series! gob! port!]
        {Input at the given index, clipped to head/tail if not /ONLY}
    series [<blank> any-series! gob! port!]
    index [any-number! logic! pair!]
    /only
        {Don't clip to the boundaries of the series (return blank if beyond)}

]

;-- Series Search

find: generic [
    {Searches for the position where a matching value is found}
    return: {position found, else blank (void if series is itself blank)}
        [<opt> any-series! bar!]
    series [<blank> any-series! any-context! map! gob! bitset! typeset!]
    value [any-value!]
    /part {Limits the search to a given length or position}
    limit [any-number! any-series! pair!]
    /only {Treats a series value as only a single value}
    /case {Characters are case-sensitive}
    /skip {Treat the series as records of fixed size}
    size [integer!]
    /last {Backwards from end of series}
    /reverse {Backwards from the current position}
    /tail {Returns the end of the series}
    /match {Performs comparison and returns the tail of the match}
]

select: generic [
    {Searches for a value; returns the value that follows, else void.}
    return: [<opt> any-value!]
    series [<blank> any-series! any-context! map!]
    value [any-value!]
    /part {Limits the search to a given length or position}
    limit [any-number! any-series! pair!]
    /only {Treats a series value as only a single value}
    /case {Characters are case-sensitive}
    /skip {Treat the series as records of fixed size}
    size [integer!]
    /last {Backwards from end of series}
    /reverse {Backwards from the current position}
    /tail ;-- for frame compatibility with FIND
    /match ;-- for frame compatibility with FIND

]

; !!! PUT was added by Red as the complement to SELECT, which offers a /CASE
; refinement for adding keys to MAP!s case-sensitively.  The name may not
; be ideal, but it's something you can't do with path access, so adopting it
; for the time-being.  Only implemented for MAP!s at the moment
;
put: generic [
    {Replaces the value following a key, and returns the new value.}
    return: [<opt> any-value!]
    series [map!]
    key [any-value!]
    value [<opt> any-value!]
    /case {Perform a case-sensitive search}
]

;-- Making, copying, modifying

copy: generic [
    {Copies a series, object, or other value.}

    return: {Return type will match the input type, or void if blank}
        [<opt> any-value!]
    value {If an ANY-SERIES!, it is only copied from its current position}
        [any-value!]
    /part {Limits to a given length or position}
    limit [any-number! any-series! pair!]
    /deep {Also copies series values within the block}
    /types {What datatypes to copy}
    kinds [typeset! datatype!]
]

take*: generic [
    {Removes and returns one or more elements.}
    return: [<opt> any-value!]
    series [any-series! port! gob! varargs!] {At position (modified)}
    /part {Specifies a length or end position}
    limit [any-number! any-series! pair! bar!]
    /deep {Also copies series values within the block}
    /last {Take it from the tail end}
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
insert: generic [
    {Inserts element(s); for series, returns just past the insert.}
    return: {Just past the insert (<opt> needed for COLLECT/KEEP, see notes)}
        [<opt> any-value!]
    series [any-series! port! map! gob! object! bitset! port!] {At position (modified)}
    value [<opt> any-value!] {The value to insert}
    /part {Limits to a given length or position}
    limit [any-number! any-series! pair!]
    /only {Only insert a block as a single value (not the contents of the block)}
    /dup {Duplicates the insert a specified number of times}
    count [any-number! pair!]
    /line {Data should be its own line (use as formatting cue if ANY-ARRAY!)}
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
append: generic [
    {Inserts element(s) at tail; for series, returns head.}
    series [any-series! port! map! gob! object! module! bitset!]
        {Any position (modified)}
    value [<opt> any-value!] {The value to insert}
    /part {Limits to a given length or position}
    limit [any-number! any-series! pair!]
    /only {Only insert a block as a single value (not the contents of the block)}
    /dup {Duplicates the insert a specified number of times}
    count [any-number! pair!]
    /line {Data should be its own line (use as formatting cue if ANY-ARRAY!)}
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
change: generic [
    {Replaces element(s); returns just past the change.}
    series [any-series! gob! port! struct!]{At position (modified)}
    value [<opt> any-value!] {The new value}
    /part {Limits the amount to change to a given length or position}
    limit [any-number! any-series! pair!]
    /only {Only change a block as a single value (not the contents of the block)}
    /dup {Duplicates the change a specified number of times}
    count [any-number! pair!]
    /line {Data should be its own line (use as formatting cue if ANY-ARRAY!)}
]

remove: generic [
    {Removes element(s); returns same position.}
    series [any-series! map! gob! port! bitset!] {At position (modified)}
    /part {Removes multiple elements or to a given position}
    limit [any-number! any-series! pair! char!]
    /map {Remove key from map}
    key
]

clear: generic [
    {Removes elements from current position to tail; returns at new tail.}
    series [any-series! port! map! gob! bitset!] {At position (modified)}
]

swap: generic [
    {Swaps elements between two series or the same series.}
    series1 [any-series! gob!] {At position (modified)}
    series2 [any-series! gob!] {At position (modified)}
]

reverse: generic [
    {Reverses the order of elements; returns at same position.}
    series [any-series! gob! tuple! pair!] {At position (modified)}
    /part {Limits to a given length or position}
    limit [any-number! any-series!]
]

sort: generic [
    {Sorts a series; default sort order is ascending.}
    series [any-series!] {At position (modified)}
    /case {Case sensitive sort}
    /skip {Treat the series as records of fixed size}
    size [integer!] {Size of each record}
    /compare  {Comparator offset, block or action}
    comparator [integer! block! action!]
    /part {Sort only part of a series}
    limit [any-number! any-series!] {Length of series to sort}
    /all {Compare all fields}
    /reverse {Reverse sort order}
]

;-- Port actions:

create: generic [
    {Send port a create request.}
    port [port! file! url! block!]
]

delete: generic [
    {Send port a delete request.}
    port [port! file! url! block!]
]

open: generic [
    {Opens a port; makes a new port from a specification if necessary.}
    spec [port! file! url! block!]
    /new   {Create new file - if it exists, reset it (truncate)}
    /read  {Open for read access}
    /write {Open for write access}
    /seek  {Optimize for random access}
    /allow {Specifies protection attributes}
        access [block!]
]

close: generic [
    {Closes a port/library.}
    return: [<opt> any-value!]
    port [port! library!]
]

read: generic [
    {Read from a file, URL, or other port.}
    return: [<opt> binary! text! block! port!]
        "null on (some) failures !!! REVIEW as part of port model review"
    source [port! file! url! block!]
    /part {Partial read a given number of units (source relative)}
        limit [any-number!]
    /seek {Read from a specific position (source relative)}
        index [any-number!]
    /string {Convert UTF and line terminators to standard text string}
    /lines {Convert to block of strings (implies /string)}
]

write: generic [
    {Writes to a file, URL, or port - auto-converts text strings.}
    destination [port! file! url! block!]
    data [binary! text! block! object!] ; !!! CHAR! support?
        {Data to write (non-binary converts to UTF-8)}
    /part {Partial write a given number of units}
        limit [any-number!]
    /seek {Write at a specific position}
        index [any-number!]
    /append {Write data at end of file}
    /allow {Specifies protection attributes}
        access [block!]
    /lines {Write each value in a block as a separate line}
;   /as {Convert string to a specified encoding}
;       encoding [blank! any-number!] {UTF number (0 8 16 -16)}
]

query: generic [
    {Returns information about a port, file, or URL.}
    return: [<opt> object!]
    target [port! file! url! block!]
    /mode "Get mode information"
    field [word! blank!] "blank will return valid modes for port type"
]

modify: generic [
    {Change mode or control for port or file.}
    return: [logic!]
        "TRUE if successful, FALSE if unsuccessful (!!! REVIEW)"
    target [port! file!]
    field [word! blank!]
    value
]

; This action seems to only be dispatched to *native* ports, and only as part
; of the WAKE-UP function.  It used to have the name UPDATE, but for Ren-C it
; was felt this term would be better applied as a complement to DEFAULT.
; There were no apparent user-facing references in the repo, but it turns out
; to be important it can be called something else.  For now, it's given a
; name most relevant to what it does internally.
;
on-wake-up: generic [
    {Updates external and internal states (normally after read/write).}
    return: [<opt>]
    port [port!]
]

rename: generic [
    {Rename a file.}
    from [port! file! url! block!]
    to [port! file! url! block!]
]


#!/usr/bin/env Rscript

args=commandArgs(trailingOnly=TRUE)
outfile = args[1]
type = args[2]
remainder = args[seq(3,length(args))]
names = remainder[seq(1,length(remainder),2)]
errcol = remainder[seq(2,length(remainder),2)]

filex = substr(outfile,nchar(outfile)-2,nchar(outfile))
if(filex=="pdf") {
  pdf(outfile)
} else if(filex=="png") {
  png(outfile)
} else {
    stop("unsupported type of output file.")
}

#type = "gene"
#names = c('/Shared/Au/jason/Code/NEWFUZZ/tempall/data/gene_rarefraction.txt','/Shared/Au/jason/Code/NEWFUZZ/tempall/data/gene_full_rarefraction.txt')
#errcol=c("#FF000088","#0000FF88")
errwid=4
datawid=3
limitwid=4
limitcol="#00000044"

read_count = 0
gene_any_count_max = 0
for(name in names) {
  d1<-read.csv(name,sep="\t",header=FALSE)
  if(max(d1[,1])>read_count) { read_count = max(d1[,1]) }
  if(max(d1[,4])>gene_any_count_max) { gene_any_count_max = max(d1[,4]) }
}
par(mar=c(5,5,4,2))
plot(1,type="n",ylim=c(0,gene_any_count_max*1.1),xlim=c(0,read_count*1.1),ylab=paste("Median ",type," count",sep=""),xlab="Reads sampled",bty="n",cex.lab=1.5,cex.axis=1.5)
z= 0
for(name in names) {
  z = z+1
  d1<-read.csv(name,header=FALSE,sep="\t")
  gene_any_count_median = max(d1[,3])
  abline(h=gene_any_count_median,lwd=limitwid,lty=2,col=limitcol)
  lines(d1[,1],d1[,3],lwd=datawid,col=errcol[z])
  for(i in seq(1,length(d1[,1]))){
    segments(d1[i,1],d1[i,3],x1=d1[i,1],y1=d1[i,4],col=errcol[z],lwd=errwid)
    segments(d1[i,1],d1[i,3],x1=d1[i,1],y1=d1[i,2],col=errcol[z],lwd=errwid)
  }
  #points(cbind(d1[,1],d1[,4]),pch="-",cex=4,col=errcol[z])
  #points(cbind(d1[,1],d1[,2]),pch="-",cex=4,col=errcol[z])
}
dev.off()


  adjust.inflation = function( x, yr, reference.year, reverse=F) {
    cpi = aegis_ts_db( db="cpi", ref.year=reference.year )
    out = x * NA
    yrs = sort(unique(yr))
    for (YY in yrs) {
      adjustment = cpi$cpi[ which( cpi$yr == YY ) ]
      JJ = which( yr == YY )
      if (reverse) {
        out[JJ] = x[JJ] * adjustment
      } else {
        out[JJ] = x[JJ] / adjustment
      }
    }
    return (out)
  }


options(max.print=1000)
rm(list =ls())
today <- format(Sys.Date(), "%Y%m%d")

get_upstream_comids <- function(comid) {
    fnode <- stream_net$FromNode[which(stream_net$ComID == comid)]
    stream_net$ComID[which(stream_net$ToNode == fnode)]
}

build_network <- function(comid, network = NULL) {
    up_comids <- get_upstream_comids(comid)
    network <- c(comid, up_comids)
    while (length(up_comids) > 0) {
        up_comids <- unique(unlist(lapply(up_comids, get_upstream_comids)))
        up_comids <- up_comids[!(up_comids %in% network)]
        network <- c(network, up_comids)
    }
    return(network)
}

get_impact <- function(comid) {
    network <- networks[[match(comid, names(networks))]]
    network_lu <- lu_table[match(network, lu_table$comid), ]
    sum(network_lu$human, na.rm = T) / sum(network_lu$total_area, na.rm = T)
}

data_dir <- "H:\\gabilan-turbidity-tmdl\\data\\"
cowardin_xwalk <- read.csv(paste0(data_dir, "cowardin-xwalk.csv"))
stream_net <- read.csv(paste0(data_dir, "stream-network.csv"))

lu_table <- read.csv(paste0(data_dir, "lu-table.csv"))
lu_table <- lu_table[-match("OBJECTID", names(lu_table))]
names(lu_table) <- c("comid", "11 Open Water", "21 Developed Open Space",
    "22 Developed, Low Intensity", "23 Developed, Medium Intensity",
    "24 Developed, High Intensity", "31 Barren (Rock/Sand/Clay)",
    "41 Deciduous Forest", "42 Evergreen Forest", "43 Mixed Forest",
    "52 Shrub/Scrub", "71 Grassland/Herbaceous", "81 Pasture/Hay",
    "82 Cultivated Crops", "90 Woody Wetlands",
    "95 Emergent Herbaceous Wetlands")
human <- c("21 Developed Open Space", "22 Developed, Low Intensity",
           "23 Developed, Medium Intensity", "24 Developed, High Intensity",
           "81 Pasture/Hay", "82 Cultivated Crops")
lu_table$total_area <- apply(lu_table[-1], 1, sum)
lu_table$human_area <- apply(lu_table[human], 1, sum)

mon_stats <- read.csv(paste0(data_dir, "mon-stations-edits.csv"))
mon_stats <- mon_stats[!is.na(mon_stats$COMID), ]

comids <- unique(mon_stats$COMID)
networks <- lapply(comids, build_network)
names(networks) <- comids
mon_stats$impact <- sapply(mon_stats$COMID, get_impact)
mon_stats$stream_order <- stream_net$StreamOrde[match(mon_stats$COMID, stream_net$ComID)]
mon_stations <- merge(mon_stats, cowardin_xwalk, by = "ATTRIBUTE")
# write.csv(mon_stations, paste0(data_dir, "mon-stations-classified-", today, ".csv"))
head(mon_stations)

# create networks only for monitored streams (for map)
mon_stations <- mon_stations[!is.na(mon_stations$stream_order), ]
mon_stations$order <- NA
mon_stations$order[mon_stations$stream_order <= 3] <- "head"
mon_stations$order[mon_stations$stream_order > 3] <- "medium"
mon_stations$class <- paste(mon_stations$order, mon_stations$slope,
                            mon_stations$substrate, sep = "-")

mon_comids <- mon_stations$COMID[mon_stations$class == "head-low-unconsolidated"
                        | mon_stations$class == "head-low-vegetated"
                        | mon_stations$class == "medium-low-unconsolidated"]
mon_networks <- lapply(mon_comids, build_network)
mon_networks <- unique(unlist(mon_networks))
mon_networks <- data.frame(comid = mon_networks, monitored = 1)
# write.csv(mon_networks, paste0(data_dir, "mon-networks-", today, ".csv"))


#' Plot the age distribution
#'
#'
#' @param dat dataframe of counts provided as output from the COVID model
#' functions
#'
#' @return a plot the age distribution at the end point. Note that the final
#' age category includes all individuals of that age or more
#'
#' @import ggplot2
#' @import dplyr
#' @importFrom magrittr %>%
#' @examples
#' params <- list(ini.prev = 0.001, n.age.cats = 10,  n.e.cats = 6, n.i.cats = 5,
#'               e.move = 0.99, i.move = 0.99, beta = .35, theta = 1,
#'               n0 = 10000, n.days = 360, d.no = 0.05, d.yes = 0.01, beds = 20,
#'               contacts = matrix(1, nrow = 10, ncol = 10),
#'               severity = c(0, 0, 0.001, 0.002, 0.004, 0.010, 0.020, 0.044,
#'               0.093, 0.200))
#'
#' out <- det_model(params)
#' plot_age_dist(out$counts)
#'
#' @export

plot_age_dist <- function(dat){
  if(missing(dat)==TRUE) warning("missing data to plot")

  S.end <- dat$St %>% filter(day == max(day)) %>% select(age, n) %>% mutate(category = "S")
  E.end <- dat$Et %>% filter(day == max(day)) %>% group_by(age) %>%
    summarize(n = sum(n))  %>% mutate(category = "E")
  I.end <- dat$It %>% filter(day == max(day)) %>% group_by(age) %>%
    summarize(n = sum(n))  %>% mutate(category = "I")
  R.end <- dat$Rt %>% filter(day == max(day)) %>% select(age, n)%>% mutate(category = "R")

  N.end <- rbind(S.end, E.end, I.end, R.end)
  #create the plot
  p <- ggplot(N.end, aes(x = age, y = n, color = category)) +
    geom_line(size = 1.5) +
    ylab("Population") + xlab("Age category") +
    theme_light()  + theme(text = element_text(size = 18),
                           panel.grid.minor = element_blank(),
                           panel.grid.major = element_blank(), legend.position = c(.15,.8))

  p
}


#' tidyLPA: Functionality to carry out Latent Profile Analysis in R
#'
#' Latent Profile Analysis (LPA) is a statistical modeling approach for
#' estimating distinct profiles, or groups, of variables. In the social
#' sciences and in educational research, these profiles could represent, for
#' example, how different youth experience dimensions of being engaged (i.e.,
#' cognitively, behaviorally, and affectively) at the same time.
#'
#' tidyLPA provides the functionality to carry out LPA in R. In particular,
#' tidyLPA provides functionality to specify different models that determine
#' whether and how different parameters (i.e., means, variances, and
#' covariances) are estimated and to specify (and compare solutions for) the
#' number of profiles to estimate.
#'
#' @docType package
#' @name tidyLPA
#' @importFrom dplyr sample_n everything bind_rows bind_cols arrange
#' mutate mutate_at filter case_when rename tbl_df select count semi_join
#' contains vars group_by summarize_all funs left_join mutate_all row_number
#' @importFrom forcats fct_relevel
#' @importFrom ggplot2 ggplot aes aes_string geom_line geom_point xlab ylab
#' theme_bw geom_col geom_errorbar theme element_text scale_x_discrete
#' position_dodge scale_fill_brewer position_jitterdodge scale_alpha_continuous
#' geom_vline
#' @importFrom magrittr "%>%"
#' @importFrom mclust Mclust MclustBootstrap mclustBootstrapLRT mclustBIC
#' mclustICL priorControl icl
#' @importFrom purrr map map_chr map_lgl map_df
#' @importFrom readr write_rds write_lines read_lines
#' @importFrom rlang .data
#' @importFrom stats complete.cases sd reshape quantile qnorm
#' @importFrom stringr str_c str_extract str_detect str_trim str_replace
#' str_sub str_split
#' @importFrom tibble tibble rownames_to_column as_tibble
#' @importFrom tidyr gather spread
#' @importFrom utils capture.output globalVariables write.table
NULL


#' manifold graph structure over a metacell object
#'
#' Splitting metacells over a discrete time axis, defining manifold connections and estimated flows over them
#'
#' @slot mc_id id of the metacell object we represent as a network
#' @slot times_nms names of the time points (Default 1:T)
#' @slot mc_t distribution of metacells (rows) over time points (cols)
#' @slot mc_manifold a data frame defining triplets mc1, mc2, distance.
#'
#' @export tgMCManifGraph
#' @exportClass tgMCManifGraph
tgMCManifGraph <- setClass(
   "tgMCManifGraph",
	slots = c(
	  mc_id = "character",
	  mgraph = "data.frame"
	)
)

#' Construct a meta cell manifold graph
#'
#'
#' @param mc_id metacell object id
#' @param mgraph data fra,e defining mc1, mc2, distance
#' @export

setMethod(
  "initialize",
  signature = "tgMCManifGraph",
  definition =
    function(.Object, mc_id, mgraph) {
		.Object@mc_id = mc_id
		.Object@mgraph = mgraph
		mc = scdb_mc(mc_id)
		if(is.null(mc)) {
			stop("MC-ERR unkown mc_id ", mc_id, " when building mc mgraph")
		}
      return(.Object)
    }
)

#' Generate a new metacell manifold graph object
#'
#' This constructs a meta cell manifold graph object - only encapsulating an edge list data frame
#'
#' @param mc_id id of scdb meta cell object ot be added
#' @param mgraph the mgraph data frame containing fields mc1, mc2, distance
#' @export
mcell_new_mc_mgraph = function(mgraph_id, mc_id, mgraph)
{
	scdb_add_mc(mgraph_id, tgMCManifGraph(mc_id, mgraph))
}


##############################################################################
# Function for plotting K-mer heatmaps
#' @export
##############################################################################
rrheat2 <- function(dat, adj){

  plotdat <- dat %>%
  # plotdat <- gpdat[gpdat$Category==categ,] %>%
    mutate(v2=substr(Motif,1,adj),
      v2a=factor(as.character(lapply(as.vector(v2), reverse_chars))),
      v3=substr(Motif, adj+2, adj*2+1),
      v4=ERV_rel_rate,
      Category=Type,
      v5=factor(gsub("_", ">", Type)))

  nbox <- length(unique(plotdat$v2a))
  nint <- nbox/(4^(adj-1))
  xhi <- rep(1:(4^(adj-1)), 4^(adj-1))*nint+0.5
  xlo <- xhi-nint
  yhi <- rep(1:(4^(adj-1)),each=4^(adj-1))*nint+0.5
  ylo <- yhi-nint
  f <- data.frame(xlo,xhi,ylo,yhi)

  levs_a <- as.character(lapply(as.vector(levels(plotdat$v2a)),
		reverse_chars))

	p <- ggplot()+
	# log(v4*10000+1,2)
	# limits=c(min(dat$v4), max(dat$v4))
	geom_tile(data=plotdat, aes(x=v3, y=v2a, fill=v4))+
	# geom_text(data=dat, aes(x=v2a, y=v3, label=v4a, family="Courier", size=0.1))+
	geom_rect(data=f, size=0.6, colour="grey70",
		aes(xmin=xlo, xmax=xhi, ymin=ylo, ymax=yhi), fill=NA)+
	scale_fill_gradientn("Relative Rate",
		# colours=myPalette((nbp-1)^4),
    colours=myPaletteO(11),
		trans="log10",
		# breaks=10^(seq(-3.65,-.84,0.281)),
    breaks=0.0003*2^(0:9),
		# labels=signif(10^(seq(-3.65,-.84,0.281)), 2),
    labels=0.0003*2^(0:9),
		limits=c(0.0002, 0.2))+
	xlab("3' flank")+
	ylab("5' flank")+
  theme_classic()+
	theme(
		# legend.position="none",
		legend.title = element_text(size=18),
		legend.text = element_text(size=16),
		legend.key.height = unit(1.5, "cm"),
		axis.ticks.x = element_blank(),
		axis.ticks.y = element_blank(),
		axis.text.y = element_blank(),
		axis.text.x = element_blank(),
    axis.title.y = element_blank(),
		axis.title.x = element_blank())

	return(p)
}

##############################################################################
# Plot relative differences between ERVs and AV rates
#' @export
##############################################################################
rrheat3 <- function(dat){
	p<-ggplot()+
	geom_tile(data=dat, aes(x=v3, y=v2a, fill=prop_diff4))+
	geom_rect(data=f, size=0.6, colour="grey70",
		aes(xmin=xlo, xmax=xhi, ymin=ylo, ymax=yhi), fill=NA)+
	scale_fill_gradientn("Rp/Rs\n",
		colours=myPaletteBrBG(nbp),
		trans="log",
		breaks=c(0.5, 1, 2),
		labels=c("<0.5", "1", ">2"),
		limits=c(0.5, 2.2))+
		xlab("3' flank")+
		ylab("5' flank")+
	theme(
		legend.position="none",
		axis.ticks.x = element_blank(),
		axis.ticks.y = element_blank(),
		axis.text.y = element_blank(),
		axis.text.x = element_blank(),
    axis.title.y = element_blank(),
		axis.title.x = element_blank())

	return(p)
}

##############################################################################
# Display plot with inset
#' @export
##############################################################################
insetPlot <- function(main, inset, loc) {
	 print(main)
	 theme_set(theme_bw(base_size = 4))
	 print(inset, vp = loc)
	 theme_set(theme_bw())
 }

 ##############################################################################
 # Multiple plot function
 #
 # ggplot objects passed in ..., or to plotlist (as list of ggplot objects)
 # - cols:   Number of columns in layout
 # - layout: A matrix specifying the layout. If present, 'cols' is ignored.
 #
 # If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
 # then plot 1 will go in the upper left, 2 will go in the upper right, and
 # 3 will go all the way across the bottom.
 #' @export
 ##############################################################################
multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
   library(grid)

   # Make a list from the ... arguments and plotlist
   plots <- c(list(...), plotlist)

   numPlots = length(plots)

   # If layout is NULL, then use 'cols' to determine layout
   if (is.null(layout)) {
     # Make the panel
     # ncol: Number of columns of plots
     # nrow: Number of rows needed, calculated from # of cols
     layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                     ncol = cols, nrow = ceiling(numPlots/cols))
   }

  if (numPlots==1) {
     print(plots[[1]])

   } else {
     # Set up the page
     grid.newpage()
     pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

     # Make each plot, in the correct location
     for (i in 1:numPlots) {
       # Get the i,j matrix positions of the regions that contain this subplot
       matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

       print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                       layout.pos.col = matchidx$col))
     }
   }
 }


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

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

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

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

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

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

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

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

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

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


library(rigma.sheet)

test_that("this is working nice", {

  df1 <- as.data.frame(cbind(
    col_a=c(1,2,3),
    col_b=c(3,7,4),
    col_c=c(9,1,3)
  ))
  df2 <- as.data.frame(cbind(
    col_a=c(3,7,4),
    col_b=c(4,5,6),
    col_c=c(NA,NA,NA)
  ))

  stat <- rigma.sheet::Stat$new()
  sheet <- rigma.sheet::Sheet$new(
    name="sheet_name",
    title="Quite nice sheet"
  )
  report <- rigma.sheet::Report$new(
    name="test_report",
    path="~/Desktop",
    gdrive="",
    title="Test Report",
    description="A bery neat report",
    author="Tiago Taveira-Gomes",
    config.filename.ts=FALSE
  )

  sheet$pop.char(
    config=list(
      section.spacer.rows=1
    ),
    styles=list(
      s.any.g.any.a.any.v.std=list(rigma.sheet::styles.color.gray)
    ),
    rules=list(

    ),
    header=list(
      title="Nice",
      labels=list(
        list(
          name="avg"
        ),
        list(
          name="std"
        )
      ),
      attrs=list(
        list(
          name="col_b",
          title="Column B",
          stats=list(
            list(fun=stat$avg),
            list(fun=stat$std)
          )
        ),
        list(
          name="col_c",
          title="Column C",
          stats=list(
            list(fun=stat$avg),
            list(fun=stat$std)
          )
        )
      )
    ),
    sections=list(
      list(
        name="lab_results",
        title="Lab results",
        labels=list(
          list(
            name="avg",
            title="Avg"
          ),
          list(
            name="std",
            title="Std"
          )
        ),
        attrs=list(
          list(
            name="col_b",
            title="Column B",
            stats=list(
              list(fun=stat$avg),
              list(fun=stat$std)
            )
          ),
          list(
            name="col_c",
            title="Column C",
            stats=list(
              list(fun=stat$avg),
              list(fun=stat$std)
            )
          )
        )
      ),
      list(
        name="measurements",
        title="Measurements",
        labels=list(
          list(
            name="avg",
            title="Avg"
          ),
          list(
            name="std",
            title="Std"
          )
        ),
        attrs=list(
          list(
            name="col_b",
            title="Column B",
            stats=list(
              list(fun=stat$avg),
              list(fun=stat$std)
            )
          ),
          list(
            name="col_c",
            title="Column C",
            stats=list(
              list(fun=stat$avg),
              list(fun=stat$std)
            )
          )
        )
      )
    ),
    groups=list(
      list(
        name="group_a",
        title="Group A",
        data=df1
      ),
      list(
        name="group_b",
        title="Group B",
        data=df2
      )
    )
  )
  print("\n")
  print(sheet$data)
  print(digest::digest(sheet$data))
  report$sheet.add(sheet)
  report$save()
})


x <- rnorm(100)
meanX <- mean(x)
print(meanX)

home <- Sys.getenv("HOME")
jobnum <-  Sys.getenv("PBS_ARRAY_INDEX")

save.image(file=paste(home, "/Demo/output_", jobnum, ".Rdata",sep=""))


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

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

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

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

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

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

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

d <- descript(df)
d

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

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

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

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

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


f<-list.files("tmp")
for (i in 1:length(f)) {
  n<-unlist(strsplit(f[i], "[.]"))[1]
  pdf(paste("img/", n, ".pdf", sep=""))
  data<-read.table(paste("tmp/", f[i], sep=""), header=TRUE)
  mex<-max(data$plus,data$minus)
  plot(data$position, data$plus, type="h", col="green", xlab="Offset", ylab="Counts", ylim=range(-mex:mex))
  abline(h=0)
  points(data$position, -data$minus, type="h", col="black")
  dev.off()
}
rm(list=ls())


### limma for GenePix microarray data
## read https://www.bioconductor.org/packages/3.3/bioc/vignettes/limma/inst/doc/usersguide.pdf
## http://biocourse.wp.sanbi.ac.za/wp-content/uploads/sites/7/2013/01/day3.pdf

## read here on how to install bioconductor packages https://www.bioconductor.org/install/
source("https://bioconductor.org/biocLite.R")
biocLite("limma")

## load the library
library(limma)

## set the folder containing the gpr files as working directory
setwd("/Users/mtang1/Downloads/1H315112001/Gpr")

## according to the service report, it is a single channel experiment with 5ug Cy5-labeled aRNA
targets <- readTargets("targets.txt")

# Set up a filter so that any spot with a flag of −99 or less gets zero weight.

f <- function(x) as.numeric(x$Flags > -99)

# read in the data

## this is single channel data using only Cy5 channel according to the service report , one has to fool limma by:
## read Gorden Smith's reply here https://support.bioconductor.org/p/22328/
## http://permalink.gmane.org/gmane.science.biology.informatics.conductor/51460

## it is a bit complicated for limma to read in single channel

## Cy3 green channel
## Cy5 red channel

Cy3 <- "F532 Median"
Cy5<- "F635 Median"
RG <- read.maimages(targets$FileName, source="genepix", columns = list(R=Cy5, G=Cy5), wt.fun=f)

RG.b<- backgroundCorrect(RG=RG, method='normexp')

## get rid of the fake channel
rownames(RG.b$R) <- RG.b$genes$Name
RG.b$G <- NULL

## design matrix
design <- model.matrix(~ 0+factor(c(1,1,1,2,2,2)))
colnames(design) <- c("group1", "group2")
contrast.matrix <- makeContrasts(group2-group1, levels=design)

library(vsn)
norm.vsn <- normalizeVSN(RG.b$R)
fit.vsn <- lmFit(norm.vsn, design)
fit2.vsn <- contrasts.fit(fit.vsn, contrast.matrix)
fit3.vsn <- eBayes(fit2.vsn)

limma::volcanoplot(fit3.vsn)

toptable<- topTable(fit3.vsn, number= Inf, sort.by = 'P')

hist(toptable$P.Value , breaks=100, col="skyblue", border="slateblue", main="")
hist(toptable$adj.P.Val, breaks=100, col="skyblue", border="slateblue", main="")

toptable %>% arrange(adj.P.Val) %>% head
# Make a basic volcano plot
with(toptable, plot(logFC, -log10(P.Value), pch=20, main="Volcano plot", xlim=c(-6,6)))

# Add colored points: red if padj<0.05, orange of log2FC>1, green if both)
with(subset(toptable, P.Value<.05 ), points(logFC, -log10(P.Value), pch=20, col="red"))
with(subset(toptable, abs(logFC)>1.5), points(logFC, -log10(P.Value), pch=20, col="orange"))
with(subset(toptable, P.Value <.01 & abs(logFC)>1.5), points(logFC, -log10(P.Value), pch=20, col="green"))
abline(h=2)
abline(v=1.5)
abline(v=-1.5)
# Label points with the textxy function from the calibrate plot

library(calibrate)
with(subset(toptable, adj.P.Val<.5 & abs(logFC)> 2), textxy(logFC, -log10(P.Value), labs=ID, cex=.8))

write.table(toptable, "differential_genes.txt", sep="\t", row.names= F, quote = F)

###### PCA analysis and heatmap

colnames(norm.vsn)<- c("C1", "C2", "C3", "PO1", "PO2", "PO3")
plotPCA_SVD(norm.vsn)

subset_by_PC_loadings<- function(x, n){
        X<- t(scale(t(x),center=TRUE,scale=FALSE))
        sv<- svd(t(X))
        U<- sv$u
        V<- sv$v
        D<- sv$d
        k=1
        ord1<- order(abs(V[,k]),decreasing=TRUE)
        x1<- as.matrix(X[ord1[1:n],])
        x1
}

x1<- subset_by_PC_loadings(norm.vsn, 1000)

library(pheatmap)
pheatmap(x1, show_rownames = F, clustering_method = "ward.D")

library(RColorBrewer)
library(gplots)
hmcols<- colorRampPalette(brewer.pal(9,"GnBu"))(100)

colnames(x1)<- c("C1", "C2", "C3", "PO1", "PO2", "PO3")
heatmap.2(x1, distfun=function(x) as.dist(1-cor(t(x))),
          hclustfun=function(x)hclust(x,method="ward.D"),trace="none",
          scale = "row", col=hmcols, labCol=colnames(x1), labRow = F, margins = c(10,6),
          density.info="none", main = "top 1000 regions")


# 3. faza: Vizualizacija podatkov

# Uvozimo zemljevid.
zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB", pot.zemljevida="OB", encoding="Windows-1250")
levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>% { gsub("-", " - ", .) }
zemljevid$OB_UIME <- factor(zemljevid$OB_UIME, levels=levels(obcine$obcina))
zemljevid <- fortify(zemljevid)

#ločimo podatke za Slovenijo in Hrvaško
slo_nocitve <- nocitve %>% filter(drzava == "Slovenia")
slo_nocitve$drzava <- NULL
hrv_nocitve <- nocitve %>% filter(drzava == "Croatia")
hrv_nocitve$drzava <- NULL
slo_potovanja <- potovanja %>% filter(drzava == "Slovenia")
slo_potovanja$drzava <- NULL
hrv_potovanja <- potovanja %>% filter(drzava == "Croatia")
hrv_potovanja$drzava <- NULL
slo_nocitve_brez <- slo_nocitve %>% filter(izvor_turistov != "Evropa", izvor_turistov != "vse drzave sveta")
hrv_nocitve_brez <- hrv_nocitve %>% filter(izvor_turistov != "Evropa", izvor_turistov != "vse drzave sveta")

#vsa potovanja
vsa_slo_potovanja <- slo_potovanja %>% group_by(leto) %>% summarise(stevilo = sum(vrednost, na.rm = TRUE))
vsa_slo_potovanja$namen <- NULL
vsa_hrv_potovanja <- hrv_potovanja %>% group_by(leto) %>% summarise(stevilo = sum(vrednost, na.rm = TRUE))
vsa_hrv_potovanja$namen <- NULL
vsa_potovanja <- vsa_slo_potovanja
names(vsa_potovanja)[2] <- 'stevilo_slo'
vsa_potovanja['stevilo_hrv'] <- NA
vsa_potovanja$stevilo_hrv <- vsa_hrv_potovanja$stevilo

#vsa potovanja na prebivalce
prebivalci_slo <- 2089310
prebivalci_hrv <- 4105493
vsa_potovanja_na_prebivalce <- vsa_potovanja
vsa_potovanja_na_prebivalce$stevilo_slo <- (vsa_potovanja$stevilo_slo) / prebivalci_slo
vsa_potovanja_na_prebivalce$stevilo_hrv <- (vsa_potovanja$stevilo_hrv) / prebivalci_hrv

#vse nočitve
vse_slo_nocitve <- slo_nocitve %>% group_by(leto) %>% summarise(stevilo = sum(vrednost, na.rm = TRUE))
vse_slo_nocitve$prebivalisce <- NULL
vse_hrv_nocitve <- hrv_nocitve %>% group_by(leto) %>% summarise(stevilo = sum(vrednost, na.rm = TRUE))
vse_hrv_nocitve$prebivalisce <- NULL
vse_nocitve <- vse_slo_nocitve
names(vse_nocitve)[2] <- 'stevilo_slo'
vse_nocitve['stevilo_hrv'] <- NA
vse_nocitve$stevilo_hrv <- vse_hrv_nocitve$stevilo

#vse nočitve na površino
povrsina_slo <- 20273
povrsina_hrv <- 56542
vse_nocitve_na_povrsino <- vse_nocitve
vse_nocitve_na_povrsino$stevilo_slo <- (vse_nocitve$stevilo_slo) / povrsina_slo
vse_nocitve_na_povrsino$stevilo_hrv <- (vse_nocitve$stevilo_hrv) / povrsina_hrv

#potovanja v vse države skupaj
slo_potovanja_vse_drzave <- slo_potovanja %>% filter(destinacija == 'All countries of the world')
slo_potovanja_vse_drzave$destinacija <- NULL
hrv_potovanja_vse_drzave <- hrv_potovanja %>% filter(destinacija == 'All countries of the world')
hrv_potovanja_vse_drzave$destinacija <- NULL


# rm(list = ls())
library(ggplot2)
library(stringr)
setwd("~/_workspace/_wangspring2020project/GSE111672/ST/pancreatic-scripts/plotting")

files = c('GSM3036911_PDAC-A-ST1.tsv',
          'GSM4100721_PDAC-A-st2.tsv',
          'GSM4100722_PDAC-A-st3.tsv',
          'GSM3405534_PDAC-B-ST1.tsv',
          'GSM4100723_PDAC-B-st2.tsv',
          'GSM4100724_PDAC-B-st3.tsv')

files = c('GSM3036911_PDAC-A-ST1.tsv')
files = c('GSM3405534_PDAC-B-ST1.tsv')

for (file in files) {

  print(file)
  data <- read.table(file = str_c('data/', file),
                     sep = '\t',
                     header = TRUE,
                     check.names = FALSE)

  # 1st datasets both have flipped axes, for some reason
  if (file == 'GSM3036911_PDAC-A-ST1.tsv') {
    coords <- data[1]
    coords <- unlist(coords, use.names = FALSE)
  } else {
    coords <- colnames(data)
    coords <- coords[2:length(coords)]
  }

  xlist <- vector()
  ylist <- vector()

  for (coord in coords) {
    splitlist <- strsplit(coord, "x")
    xcoord <- splitlist[[1]][1]
    ycoord <- splitlist[[1]][2]

    xlist <- c(xlist, xcoord)
    ylist <- c(ylist, ycoord)
  }

  plotdata <- data.frame(xlist, ylist)
  plotdata$xlist = as.numeric(plotdata$xlist)
  plotdata$ylist = as.numeric(plotdata$ylist)
  # print(plotdata)

  print(ggplot(plotdata, aes(x = xlist, y = ylist)) +
    # xlim(0, 50) +
    # ylim(0, 50) +
    geom_point(shape=15) +
    scale_x_continuous(breaks = round(seq(min(plotdata$x), max(plotdata$x), by = 1),1)) +
    scale_y_continuous(breaks = round(seq(min(plotdata$y), max(plotdata$y), by = 1),1)) +
    theme( axis.title.x=element_blank(),
           axis.title.y=element_blank())
    # + coord_fixed()
  )

  ggsave(paste("figures/",
               str_replace(file, "tsv", "pdf")),
         plot = last_plot())

}