library(tidyverse)
library(zipcodeR)
library(tigris)

# # ACS codes and names
acs_codes_names_demo <- read_csv("data/acs/demographic-characteristics-acs-metadata.csv")
colnames(acs_codes_names_demo) =  c("Measure_Id", "Measure")
acs_codes_names_econ <- read_csv("data/acs/economic-characteristics-acs-metadata.csv")
colnames(acs_codes_names_econ) =  c("Measure_Id", "Measure")
acs_codes_names_hous <- read_csv("data/acs/housing-characteristics-acs-metadata.csv")
colnames(acs_codes_names_hous) =  c("Measure_Id", "Measure")
acs_codes_names_social <- read_csv("data/acs/social-characteristics-acs-metadata.csv")
colnames(acs_codes_names_social) =  c("Measure_Id", "Measure")
acs_codes_names <- bind_rows(acs_codes_names_demo, acs_codes_names_econ, acs_codes_names_hous, acs_codes_names_social)
acs_codes_names = acs_codes_names %>% mutate(Measure = Measure %>% str_remove_all("\\(")) %>% mutate(Measure = Measure %>% str_remove_all("\\)")) %>% mutate(Measure = Measure %>% str_replace_all("-", " "))
acs_codes_names = acs_codes_names %>% select(contains("Measure")) %>% mutate(MeasureType = Measure %>% str_extract("[a-zA-Z0-9 ]+!!")) %>%  mutate(Measure = Measure %>% str_remove("[a-zA-Z0-9 ]+!!"))
acs_codes_names = acs_codes_names %>% mutate(Variable_Family = Measure %>% str_extract("[a-zA-Z0-9 ]+!!") %>% str_remove_all("!!"))
acs_codes_names = acs_codes_names %>% mutate(Measure = Measure %>% str_remove("[a-zA-Z0-9 ]+!!") %>% str_replace_all("!!", ", "))
acs_codes_names = acs_codes_names %>% drop_na()
acs_codes_names = acs_codes_names %>% mutate(MeasureType = MeasureType %>% str_remove_all("!!"))

tidy_acs_vars = function(acs_df)
{
  geo_cols = c("GEO_ID", "NAME")
  to_return = acs_df %>% mutate_at(vars(-geo_cols), as.double)
  to_return = to_return %>% pivot_longer(cols = !geo_cols, names_to = "Measure_Id", values_to = "Data_Value")
  to_return = to_return %>% left_join(acs_codes_names, by=c("Measure_Id")) %>% filter(MeasureType == "Estimate")
  to_return = to_return %>% rename(CensusTract = GEO_ID, CensusTractName = NAME) %>%
    select(c("CensusTract", "Measure_Id", "Variable_Family", "Measure", "Data_Value")) %>%
    mutate(CensusTract = CensusTract %>% str_remove_all("1400000US"))
  return(to_return)
}

replacement_function <- function (lat, lon, benchmark, vintage)
{
  if (missing(benchmark)) {
    benchmark <- "Public_AR_Census2020"
  }
  else {
    benchmark <- benchmark
  }
  if (missing(vintage)) {
    vintage <- "Census2020_Census2020"
  }
  else {
    vintage <- vintage
  }
  call_start <- "https://geocoding.geo.census.gov/geocoder/geographies/coordinates?"
  url <- paste0("x=", lon, "&y=", lat)
  benchmark0 <- paste0("&benchmark=", benchmark)
  vintage0 <- paste0("&vintage=", vintage, "&format=json")
  url_full <- paste0(call_start, url, benchmark0, vintage0)
  r <- httr::GET(url_full)
  httr::stop_for_status(r)
  response <- httr::content(r)
  return(response$result$geographies$`Census Blocks`[[1]]$GEOID)
  if (length(response$result$geographies$`2020 Census Blocks`[[1]]$GEOID) ==
      0) {
    message(paste0("Lat/lon (", lat, ", ", lon, ") returned no geocodes. An NA was returned."))
    return(NA_character_)
  }
  else {
    if (length(response$result$geographies$`2020 Census Blocks`[[1]]$GEOID) >
        1) {
      message(paste0("Lat/lon (", lat, ", ", lon, ") returned more than geocode. The first match was returned."))
    }
    return(response$result$geographies$`2020 Census Blocks`[[1]]$GEOID)
  }
}

fill_in_missing_cts = function(data_df, ct_tbl, filter_var)
{
  to_return = data_df %>% filter(Measure_Id == filter_var)
  to_return = ct_tbl %>% left_join(to_return, by="CensusTract")
  to_return = to_return %>% fill(Measure, .direction = "downup") %>%
    fill(Measure_Id, .direction = "downup") %>% fill(Variable_Family, .direction = "downup")
  return(to_return)
}

cleanup_tbl_and_add_year_col = function(df, year_value, dataset_value)
{
  df_to_return = df
  df_to_return = df_to_return %>% mutate(DataSet = dataset_value)
  df_to_return = df_to_return %>% mutate(Year=year_value)
  df_to_return = df_to_return %>% mutate(Variable_Family = Variable_Family %>% toupper())
  df_to_return = df_to_return %>% mutate(CensusTractName=CensusTractName %>% str_remove_all(","),
                                         Measure=Measure %>% str_remove_all(","))

  df_to_return = df_to_return %>% filter(CensusTractName != "Virginia")
  return(df_to_return)

}

# # medicare opiate data
#
# va_medicare_opiate_data = read_csv("data/cms/medicare-part-d-opioid-prescriber-summary-file-2016.csv")
# colnames(va_medicare_opiate_data) = c("NPI", "Provider_Last_Name", "Provider_First_Name", "Provider_ZIP_Code", "Provider_State", "Specialty_Description",
#                "Total_Claim_Count", "Opioid_Claim_Count", "Opioid_Prescribing_Rate", "Long_Acting_Opioid_Claims", "Long_Acting_Opioid_Prescribing_Rate")
#
# va_zip_codes = search_state("VA") %>% select(c("zipcode", "lat", "lng"))
# colnames(va_zip_codes) = c("Provider_ZIP_Code", "Lat", "Lng")
# va_medicare_opiate_data = va_medicare_opiate_data %>% inner_join(va_zip_codes, by=c("Provider_ZIP_Code"))
# va_medicare_opiate_data = va_medicare_opiate_data %>% drop_na(c("Lat", "Lng"))
#
# unique_va_medicare_opiate_data_lat_lng = va_medicare_opiate_data %>% distinct(Lat, Lng)
# unique_va_medicare_opiate_data_lat_lng$census_code <- apply(unique_va_medicare_opiate_data_lat_lng, 1, function(row) replacement_function(row['Lat'], row['Lng']))
# unique_va_medicare_opiate_data_lat_lng$census_tract <- substr(unique_va_medicare_opiate_data_lat_lng$census_code, 1, 11)
#
# va_medicare_opiate_data = va_medicare_opiate_data %>% inner_join(unique_va_medicare_opiate_data_lat_lng, by=c("Lat", "Lng"))

# va_vulnerability_index %>% select(c("CensusTract", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))

# va_medicare_opiate_data = va_medicare_opiate_data %>% group_by(census_tract) %>% summarise(CT_Total_Claim_Count = sum(Total_Claim_Count, na.rm = T), CT_Opioid_Claim_Count = sum(Opioid_Claim_Count, na.rm = T), CT_Long_Acting_Opioid_Claims = sum(Long_Acting_Opioid_Claims, na.rm = T))
# va_medicare_opiate_data = va_medicare_opiate_data %>% rename(CensusTract = census_tract)
#
#
#
# va_medicare_opiate_data_long = va_medicare_opiate_data %>% pivot_longer(!CensusTract, names_to = "Measure_Id", values_to = "Data_Value")
# va_medicare_opiate_data_long = va_medicare_opiate_data_long %>% mutate(Variable_Family = "Medicaid Data")
# va_medicare_opiate_data_long = va_medicare_opiate_data_long %>% mutate(Measure = str_replace_all(Measure_Id, "_", " "))
# va_medicare_opiate_data_long = va_medicare_opiate_data_long %>% select(c("CensusTract", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))

# ACS Data
#################################################

# All ACS Data
va_demo_data_long = read_csv("data/acs/demographic-characteristics-acs.csv", na = c("-", "*****", "**"))
va_econ_data_long = read_csv("data/acs/economic-characteristics-acs.csv", na = c("-", "*****", "**"))
va_hous_data_long = read_csv("data/acs/housing-characteristics-acs.csv", na = c("-", "*****", "**"))
va_social_data_long = read_csv("data/acs/social-characteristics-acs.csv", na = c("-", "*****", "**"))
va_acs = va_demo_data_long %>% inner_join(va_econ_data_long, by=c("GEO_ID", "NAME")) %>%
  inner_join(va_hous_data_long, by=c("GEO_ID", "NAME")) %>% inner_join(va_social_data_long, by=c("GEO_ID", "NAME"))

va_acs = va_acs %>% tidy_acs_vars()

# 500 cities data
five_hundred_cities_data = readRDS("data/500-cities/va-specific-500-cities.RDS")
five_hundred_cities_data = five_hundred_cities_data %>% mutate(Esimate_Value = PopulationCount*(Data_Value/100))
five_hundred_cities_data = five_hundred_cities_data %>% mutate(Data_Value = Esimate_Value)
census_tract_populations = five_hundred_cities_data %>% select(c(CensusTract, PopulationCount)) %>% distinct()
census_tract_names = va_demo_data_long %>% select(c(GEO_ID, NAME)) %>% rename(CensusTract = GEO_ID, CensusTractName = NAME) %>% mutate(CensusTract = CensusTract %>% str_remove_all("1400000US"))

va_500_census_tract = five_hundred_cities_data %>% select(-c(PopulationCount, CategoryID, Short_Question_Text)) %>%
  select(CensusTract, MeasureId, Category, Measure, Data_Value) %>% rename(Variable_Family = Category, Measure_Id = MeasureId)
va_500_census_tract = va_500_census_tract %>% mutate(Data_Value = Data_Value %>% round())

# CCVI Vulnerability Data
va_vulnerability_index = read_csv("data/ccvi/ccvi-va-tract.csv", na="NULL")
va_vulnerability_index = va_vulnerability_index %>% select(FIPS, ccvi) %>% rename(CensusTract = FIPS, Data_Value = ccvi)
va_vulnerability_index = va_vulnerability_index %>% mutate(CensusTract = CensusTract %>% as.character())
va_vulnerability_index = va_vulnerability_index %>% mutate(Measure_Id = "CCVI",
                                                           Variable_Family = "Vulnerability",
                                                           Measure = "COVID-19 Community Vulnerability Index")
va_vulnerability_index = va_vulnerability_index %>% select(c("CensusTract", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))

#Norfolk Bike Pedestrian Path Data
va_bike_ped_path_miles = readRDS("data/bike-ped/norfolk-bike-ped-path-miles-by-census-tract.RDS")
va_bike_ped_path_miles = va_bike_ped_path_miles %>% mutate(CensusTract = CensusTract %>% as.character())
va_bike_ped_path_miles = va_bike_ped_path_miles %>% rename(Measure_Id = MeasureId, Variable_Family = Category)
census_tracts = five_hundred_cities_data %>% select(CensusTract)
va_bike_ped_path_miles = census_tracts %>% left_join(va_bike_ped_path_miles, by="CensusTract")
va_bike_ped_path_miles = va_bike_ped_path_miles %>%  select(c("CensusTract", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))
va_bike_ped_path_miles = va_bike_ped_path_miles %>% mutate(Measure_Id = "BIKE PED MILES", Variable_Family = "Environmental Infrastructure", Measure = "Bike Pedestrian Path Mileage")
va_bike_ped_path_miles = va_bike_ped_path_miles %>% mutate(Data_Value = round(Data_Value, 2))

va_acs = census_tract_names %>% inner_join(va_acs) %>% mutate(DataSet = "ACS-5YR-2015-2019")

va_vulnerability_index = census_tract_names %>% left_join(va_vulnerability_index)  %>% mutate(DataSet = "COVID-19CommunityVulnerabilityIndex-2021") %>% fill(Measure, .direction = "downup") %>%
  fill(Measure_Id, .direction = "downup") %>% fill(Variable_Family, .direction = "downup")
va_bike_ped_path_miles = census_tract_names %>% left_join(va_bike_ped_path_miles)  %>% mutate(DataSet = "NorfolkBikeAndPedestrianPaths-2017") %>% fill(Measure, .direction = "downup") %>%
  fill(Measure_Id, .direction = "downup") %>% fill(Variable_Family, .direction = "downup")

unique_va_500_measure_ids = va_500_census_tract$Measure_Id %>% unique()

full_va_500_census_tract = va_500_census_tract %>% fill_in_missing_cts(census_tract_names, unique_va_500_measure_ids[1])
for (i in 2:length(unique_va_500_measure_ids))
{
  temp_df = va_500_census_tract %>% fill_in_missing_cts(census_tract_names, unique_va_500_measure_ids[i])
  full_va_500_census_tract = full_va_500_census_tract %>% bind_rows(temp_df)
}
full_va_500_census_tract = full_va_500_census_tract %>% mutate(DataSet = "CDC500CitiesProject-2017")

# bric stuff
va_bric = readRDS("data/bric/bric-indicies.RDS")
va_bric = va_bric %>% mutate(Hazard_Index = Hazard_Index %>% str_remove_all("%") %>% as.double(),
                             Pop_Vulnerability_Index = Pop_Vulnerability_Index %>% str_remove_all("%") %>% as.double(),
                             MatchingFIPS = FIPS %>% substr(1, 5))

va_bric_ct = census_tract_names %>% mutate(MatchingFIPS = CensusTract %>% substr(1, 5))
va_bric_ct_hazard = va_bric_ct %>% left_join(va_bric, by="MatchingFIPS") %>% select(CensusTract, CensusTractName, Hazard_Index)
va_bric_ct_hazard = va_bric_ct_hazard %>% rename(Data_Value = Hazard_Index) %>% mutate(Measure_Id = "BRIC_HAZARD_INDX",
                                                                                Variable_Family = "ENVIRONMENTAL HAZARDS",
                                                                                Measure = "Baseline Resilience Indicators for Communities, Hazard Index")
va_bric_ct_hazard = va_bric_ct_hazard %>%  select(c("CensusTract", "CensusTractName", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))
va_bric_ct_hazard = va_bric_ct_hazard %>% mutate(DataSet = "BaselineResilienceIndicatorsforCommunities2020")

# "Measure_Id", "Variable_Family", "Measure", "Data_Value"
va_bric_ct_pop = va_bric_ct %>% left_join(va_bric, by="MatchingFIPS") %>% select(CensusTract, CensusTractName, Pop_Vulnerability_Index)
va_bric_ct_pop = va_bric_ct_pop %>% rename(Data_Value = Pop_Vulnerability_Index) %>% mutate(Measure_Id = "BRIC_POP_INDX",
                                                                                Variable_Family = "VULNERABILITY",
                                                                                Measure = "Baseline Resilience Indicators for Communities,  Population Vulnverability Index")
va_bric_ct_pop = va_bric_ct_pop %>%  select(c("CensusTract", "CensusTractName", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))
va_bric_ct_pop = va_bric_ct_pop %>% mutate(DataSet = "BaselineResilienceIndicatorsforCommunities2020")

census_tract_info = va_bric_ct_pop %>% select(CensusTract, CensusTractName)
# va_medicare_opiate_data_long = va_medicare_opiate_data_long %>% inner_join(census_tract_info, by="CensusTract")

# va_medicare_opiate_data_long = va_medicare_opiate_data_long %>% select(c("CensusTract", "CensusTractName", "Measure_Id", "Variable_Family", "Measure", "Data_Value"))

va_digital_twin = bind_rows(va_acs, full_va_500_census_tract, va_vulnerability_index, va_bike_ped_path_miles, va_bric_ct_pop, va_bric_ct_hazard) %>% # va_medicare_opiate_data_long
  mutate(Variable_Family = Variable_Family %>% toupper() %>%
           trimws()) %>% filter(CensusTractName != "Virginia")

va_acs = va_acs %>% cleanup_tbl_and_add_year_col(year = "2017", dataset_value = "ACS 5 Year Estimate")
full_va_500_census_tract = full_va_500_census_tract %>% cleanup_tbl_and_add_year_col(year = "2017", dataset_value = "CDC 500 Cities")
va_vulnerability_index = va_vulnerability_index %>% cleanup_tbl_and_add_year_col(year = "2021", dataset_value = "Covid Community Vulnerability Index")
va_bike_ped_path_miles = va_bike_ped_path_miles %>% cleanup_tbl_and_add_year_col(year = "2017", dataset_value = "BikePed Path Miles")
va_bric_ct_pop = va_bric_ct_pop %>% cleanup_tbl_and_add_year_col(year = "2020", dataset_value = "Human Population - Baseline Resilience Indicators for Communities")
va_bric_ct_hazard = va_bric_ct_hazard %>% cleanup_tbl_and_add_year_col(year = "2020", dataset_value = "Environmental Hazards - Baseline Resilience Indicators for Communities")

big_tbl = bind_rows(va_acs, full_va_500_census_tract, va_vulnerability_index, va_bike_ped_path_miles, va_bric_ct_pop, va_bric_ct_hazard)

measure_tbl = big_tbl %>% select(Measure_Id, Measure) %>% unique()
census_tract_tbl = big_tbl %>% select(CensusTract, CensusTractName) %>% unique()
dataset_tbl = big_tbl %>% select(Measure_Id, DataSet) %>% unique()
var_family_tbl = big_tbl %>% select(Measure_Id, Variable_Family) %>% unique()
value_tbl = big_tbl %>% select(CensusTract, Measure_Id, Data_Value, Year)

# write out individual tables long and wide
write_csv(measure_tbl, file="output/db_tables/measure_tbl.csv")
write_csv(census_tract_tbl, file="output/db_tables/census_tract_tbl.csv")
write_csv(dataset_tbl, file="output/db_tables/dataset_tbl.csv")
write_csv(var_family_tbl, file="output/db_tables/var_family_tbl.csv")
write_csv(value_tbl, file="output/db_tables/value_tbl.csv")

# data_for_emily_query = va_digital_twin %>% filter(Variable_Family == "PREVENTION" | Variable_Family == "HEALTH INSURANCE COVERAGE") %>% filter(CensusTractName %>% str_detect("Norfolk"))

va_digital_twin_categories = read_csv("data/category-mapping/mapping-from-variable-family-to-category-and-subcategory.csv")
va_digital_twin = va_digital_twin %>% inner_join(va_digital_twin_categories, by="Variable_Family") %>% mutate(Measure = paste0(Variable_Family, ": ", Measure)) %>% select(-Variable_Family) %>% arrange(Category, Subcategory)
va_digital_twin = va_digital_twin %>%  distinct(CensusTract, Measure_Id, .keep_all = TRUE)
write_csv(va_digital_twin, "output/long/va-digital-neighborhoods-data-long.csv")

data_for_chris_query = va_digital_twin %>%  filter(CensusTractName %>% str_detect("Norfolk"))
write_csv(data_for_chris_query, "output/long/norfolk-only-digital-neighborhoods-data-long.csv")

va_digital_twin_wide_measure_id_lookup = va_digital_twin %>% select(Measure, Measure_Id) %>% distinct()
va_digital_twin_wide = va_digital_twin %>% select(CensusTract, CensusTractName, Measure_Id, Data_Value) %>% pivot_wider(names_from = Measure_Id, values_from = Data_Value)

write_csv(va_digital_twin_wide, "output/wide/va-digital-neighborhoods-data-wide.csv")
write_csv(va_digital_twin_wide_measure_id_lookup, "output/wide/va_digital_twin_wide_measure_id_lookup.csv")

data_for_chris_query_wide = va_digital_twin_wide %>%  filter(CensusTractName %>% str_detect("Norfolk"))
write_csv(data_for_chris_query_wide, "output/wide/norfolk-only-digital-neighborhoods-data-wide.csv")


#Jenny Smith

#Purpose: Concatenate the expression data-sets downloaded from TCGA/TARGET from GDC or any patient level data
#eg. each individual patient has a single expression-file

catExpnData <- function(filenames,regex, cols, header=FALSE,removeFirstLine=FALSE, sep="\t"){
  library(magrittr)
  options(stringsAsFactors = FALSE)
  #filenames is a character vector of all filenames.
  #regex is a string with the pattern to extract the patient ID , eg "^.+(Kasumi|MV4)", from filenames
  #cols is the character vector or numeric vector of the columns to select and concatenate.

  extract_cols <-function(filename,cols,rmFirstLine=FALSE){

    if(all(rmFirstLine & header)){
      aFile <- readLines(filename)[-1] #remove first line with extra info.
      aFile <- str_split_fixed(aFile, pattern = "\t",n = length(cols)) %>% #split into a matrix
        set_colnames(.[1,] ) %>%  #set colnames from the first line
        .[-1, ] #remove the header row from matrix
    }else{
      aFile <- read.delim(filename, sep=sep, header=header, as.is=TRUE)
    }

    output <- list()
    for ( k in 1:length(cols)){
      colname <- cols[k]
      col <- aFile[,colname]
      output[[colname]] <- col
    }
    return(output)
  }

  combineColumns <- function(extract_cols.res,colname){
    sapply(extract_cols.res, '[[', colname)
  }

  IDs <- gsub(regex, "\\1", filenames)

  columns <- lapply(filenames,extract_cols,cols=cols, rmFirstLine=removeFirstLine) %>%
    set_names(IDs)

  catedMatrices <- lapply(cols, combineColumns, extract_cols.res=columns)  %>%
    set_names(cols)

  return(catedMatrices)
}


#' Get Pathway Map: Generate pathway map with patient data superimposed.
#'
#' @param input - List of parameters passed from R shiny from UI. Important parameters will be input$ptIDs, input$pathwayMapId, and
#'                input$scalingFactor.
#' @param zscore.data - A named vector of metabolites with corresponding z-scores.
#'
#' @return An SVG image of the selected pathway map in input$pathwayMapId, with the mean profile of input$ptIDs
#'         superimposed.
#' @import igraph
#' @import grid
#' @export getPathwayMap
#' @examples
#' data(Miller2015_Heparin)
#' # Input is supplied by R shiny app, but you can hard code parameters as a list object, too, to test functionality.
#' input = list()
#' input$ptIDs = colnames(Miller2015_Heparin)[4]
#' input$diagClass = "paa"
#' input$pathwayMapId = "allPathways"
#' input$scalingFactor = 1
#' svg_img = getPathwayMap(input, Miller2015_Heparin)
#' # SVG file will be saved at following path
#' svg_img$src
#' # Colorbar can be visualized this way
#' plot(svg_img$colorbar)
getPathwayMap = function(input, zscore.data) {
  Pathway.Name = input$pathwayMapId
  if (length(input$ptIDs)==0) {
    return(list(pmap = list(src="", contentType = 'image/svg+xml'), colorbar = NULL))
  } else {
    PatientID = input$ptIDs
    scalingFactor = input$scalingFactor
    tmp = rownames(zscore.data)
    if (length(input$ptIDs)>1) {
      patient.zscore = zscore.data[,which(colnames(zscore.data) %in% input$ptIDs)]
      patient.zscore = apply(patient.zscore, 1, function(i) mean(na.omit(i)))
    } else {
      patient.zscore = zscore.data[,which(colnames(zscore.data)==input$ptIDs)]
    }
    names(patient.zscore) = tmp
    template.ig = getPathwayIgraph(input, Pathway.Name)

    node.labels = V(template.ig)$label
    node.types = V(template.ig)$shape
    pmap.path = "./extdata"
    load(sprintf("%s/complexNodes.RData", pmap.path))
    nms = node.labels[which(node.labels %in% names(patient.zscore))]
    patient.zscore = patient.zscore[which(names(patient.zscore) %in% nms)]
    granularity = 2
    blues = colorRampPalette(c("blue", "white"))(granularity*ceiling(abs(min(na.omit(patient.zscore))))+1)
    reds = colorRampPalette(c("white", "red"))(granularity*ceiling(max(abs(na.omit(patient.zscore)))))
    redblue = c(blues, reds[2:length(reds)])
    for (i in 1:length(node.labels)) {
      if ((node.labels[i] %in% nms) && (!is.na(patient.zscore[node.labels[i]]))) {
        if (!is.na(1 + abs(patient.zscore[node.labels[i]]))) {
          V(template.ig)$size[i] = scalingFactor*ceiling(abs(patient.zscore[node.labels[i]]))
          V(template.ig)$color[i] = redblue[1+granularity*(ceiling(patient.zscore[node.labels[i]])-ceiling(min(na.omit(patient.zscore))))]
        } else {
          V(template.ig)$size[i] = 1
          V(template.ig)$color[i] = "#D3D3D3"
        }
      } else {
        V(template.ig)$size[i] = 1
        V(template.ig)$color[i] = "#D3D3D3"
      }
    }

    mapped=0
    complexNodes = complexNodes[which(names(complexNodes) %in% node.labels)]
    # Next do the complex nodes
    if (length(which(names(complexNodes) %in% node.labels))>0) {
      for (n in 1:length(complexNodes)) {
        metsInComplex = complexNodes[[n]]
        mapped.mets = metsInComplex[which(metsInComplex %in% names(patient.zscore))]
        if (length(na.omit(patient.zscore[mapped.mets]))>0) {
          print(sprintf("%s: %f", names(complexNodes)[n], length(mapped.mets)/length(metsInComplex)))
          mapped = mapped + length(mapped.mets)
          nodeSize = ceiling(max(abs(na.omit(patient.zscore[mapped.mets]))))
          if (is.na(nodeSize)) {
            V(template.ig)$size[which(node.labels==names(complexNodes[n]))] = 1
            V(template.ig)$size2[which(node.labels==names(complexNodes[n]))] = 1
            V(template.ig)$color[which(node.labels==names(complexNodes[n]))] = "#FFFFFF"
          } else {
            V(template.ig)$size[which(node.labels==names(complexNodes[n]))] = scalingFactor*nodeSize
            V(template.ig)$size2[which(node.labels==names(complexNodes[n]))] = scalingFactor*nodeSize
            V(template.ig)$color[which(node.labels==names(complexNodes[n]))] = redblue[1+granularity*(nodeSize-ceiling(min(na.omit(patient.zscore))))]
          }
        } else {
          V(template.ig)$size[which(node.labels==names(complexNodes[n]))] = 1
          V(template.ig)$size2[which(node.labels==names(complexNodes[n]))] = 1
          V(template.ig)$color[which(node.labels==names(complexNodes[n]))] = "#FFFFFF"
        }
      }
    }
    V(template.ig)$label = tolower(V(template.ig)$label)
    wrap_strings = function(vector_of_strings,width){
      as.character(sapply(vector_of_strings, FUN=function(x){
        paste(strwrap(x, width=width), collapse="\n")
      }))
    }
    V(template.ig)$label = wrap_strings(V(template.ig)$label, 15)
    V(template.ig)$label.cex = 0.75
    template.ig = delete.vertices(template.ig, v=grep(unlist(strsplit(Pathway.Name, split="-"))[1], V(template.ig)$label))

    svg_filename = sprintf("%s/pmap-%s_%s.svg", getwd(), Pathway.Name, input$diagClass)
    svg(filename = svg_filename, width=10, height=10)
    par(mar=c(1,0.2,1,1))
    plot.igraph(template.ig, layout=cbind(V(template.ig)$x, V(template.ig)$y), edge.arrow.size = 0.01, edge.width = 1,
                vertex.frame.color=V(template.ig)$color) #main = gsub("-", " ", Pathway.Name)
    legend('bottom',legend=1:max(ceiling(V(template.ig)$size/scalingFactor)),
           pt.cex=seq(1, ceiling(max(V(template.ig)$size)), scalingFactor),
           col='black',pch=21, pt.bg='white', cex=1, horiz=TRUE)
    dev.off()

    # Get colorbar
    z = seq(floor(min(na.omit(patient.zscore))), ceiling(max(na.omit(patient.zscore))), 1/granularity)
    df = data.frame(Zscores = z[1:length(redblue)],
                    Colors = redblue)
    if (length(which(apply(df, 1, function(i) any(is.na(i)))))>0) {
      df = df[-which(apply(df, 1, function(i) any(is.na(i)))),]
    }
    cb = ggplot(df, aes(x=1:nrow(df), y=Zscores, colour=Zscores)) + geom_point() + #ggtitle(input$diagClass) +
      scale_colour_gradient2(guide = "colourbar", low = "blue", mid="white", high="red") +
      guides(colour = guide_colourbar(draw.llim = min(df$Zscores), draw.ulim = max(df$Zscores),
                                      direction="horizontal", title.position = "top", barwidth = 10, barheight = 2, reverse = FALSE))
    g_legend=function(a.gplot){
      tmp = ggplot_gtable(ggplot_build(a.gplot))
      leg = which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
      legend = tmp$grobs[[leg]]
      return(legend)}
    leg = g_legend(cb);
    return(list(pmap = list(src=svg_filename, contentType = 'image/svg+xml'), colorbar = leg))
  }
}


# GetAuditAnnuallyData.r

source("../common/DataUtil.r")

# G E T   D A T A
rm(results)
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.auditannually <- fndfGetAuditData(results)

# T A B U L A T E   D A T A
# Tabulate columns by copies and sector lifetime.
tbl.auditannually <- data.frame(with(dat.auditannually,
            tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
# Re-form the data into a table for printing.
foo<-(with(dat.auditannually,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sOutputFilename <- "./Data_AuditAnnually.txt"
sTitle <- "Document losses with multiple copies and annual total auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

# Micah succeeded in bending dcast to his will, thanks; see email.
library(reshape2)
bar.small <- dat.auditannually[,c("copies", "lifem", "mdmlosspct")]
bar.melted <- melt(bar.small, id=c("copies", "lifem"))
bar.recast <- dcast(bar.melted, copies~lifem)

# P L O T   D A T A
library(ggplot2)
source("../common/PlotUtil.r")

gp <- ggplot(data=trows,aes(x=lifem,y=safe(mdmlosspct)))
gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000)
                ,ybreaks=c(0.01,0.10,1.00)
                )

# Show lines for 3, 4, 5 copies, with annual total auditing, over wiiiide range.
nCopies <- 3; trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- fnPlotAddLine(gp, dat=trows,
                    dotcolor="black", dotsize=5, dotshape=(48+nCopies),
                    linecolor="red", linesize=1, lineshape="dashed")

nCopies <- 4; trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- fnPlotAddLine(gp, dat=trows,
                    dotcolor="black", dotsize=5, dotshape=(48+nCopies),
                    linecolor="blue", linesize=1, lineshape="dashed")

nCopies <- 5; trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- fnPlotAddLine(gp, dat=trows,
                    dotcolor="black", dotsize=5, dotshape=(48+nCopies),
                    linecolor="green", linesize=2, lineshape="dashed")

gp <- fnPlotTitles(gp
            , titleline="With annual auditing (in an uneventful world), "
                %+% "we need only a few copies"
                %+% "\nto minimize permanent losses over a wide range"
                %+% "\n(shown for copies=3,4,5)"
            , titlesize=16
            , xlabel="1MB sector half-life (megahours)"
                %+% "                     (lower error rate ===>)"
            , ylabel="permanent document losses (%)"
            , labelsize=14
        )
gp <- fnPlotPercentLine(gp)

plot(gp)
fnPlotMakeFile(gp, "baseline-auditannually.png")

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#AdjustedFrame The datatoPredict
#Predictors the predictors
#The months for training
#numberOfRandomSamples the number of samples from the adjustedFrame
#MLMethod the Machine Learning method
#asFactor is the class should be treated as a factor
#... parameters to be passed to the ML method

#It will return models that predict if a subject will convert to MCI to AD
#it will return models that predict the time to conversion

TrainTadpoleClassModels <- function(AdjustedFrame,
                                    predictors,
                                    months=NULL,
                                    numberOfRandomSamples=5,
                                    delta=FALSE,
                                    MLMethod=BSWiMS.model,
                                    asFactor=FALSE,
                                    ...){
  #args
 #AdjustedFrame= AdjustedTrainFrame
 #predictors = predictors=c("AGE","PTGENDER",colnames(AdjustedTrainFrame)[-c(1:22)])
 #months=NULL
 #numberOfRandomSamples=numberOfRandomSamples=25
 #delta=TRUE
 #MLMethod=HLCM_EM
 #asFactor=FALSE
 #hysteresis = 0.1
#
  AdjustedFrame$RID <- as.character(AdjustedFrame$RID)
  library("FRESA.CAD")
  if (is.null(months)){
    months <- as.numeric(names(table(AdjustedFrame$M)))
    print(months)
  }
  cpredictors <- predictors

  AdjustedFrame <- AdjustedFrame[order(AdjustedFrame$Years_bl),]
  AdjustedFrame <- AdjustedFrame[order(as.numeric(AdjustedFrame$RID)),]

  pdis <- AdjustedFrame$RID
  lastTimepointSet <- AdjustedFrame[c(pdis[1:(length(pdis)-1)] != pdis[-1],TRUE),]
  rownames(lastTimepointSet) <- lastTimepointSet$RID

  BaseTimepointSet <- AdjustedFrame[c(TRUE,pdis[-1] != pdis[1:(length(pdis)-1)]),]
  rownames(BaseTimepointSet) <- BaseTimepointSet$RID
  deltaFeaturepredictors <- predictors[regexpr('_bl', predictors) < 0][-(c(1:2))]

  TimePointsSubset <- list();
  Orderbytimepoint <- NULL
  m <- 0
  i <- 1;
  for (m in months) {
    TimePointsSubset[[i]] <- subset(AdjustedFrame,M == m)
    rownames(TimePointsSubset[[i]]) <- TimePointsSubset[[i]]$RID
    TimePointsSubset[[i]]$Year_bl_LastVisit <- lastTimepointSet[TimePointsSubset[[i]]$RID,"Years_bl"]
    TimePointsSubset[[i]]$Last_DX <- lastTimepointSet[TimePointsSubset[[i]]$RID,"DX"]
    TimePointsSubset[[i]]$TimeToLastVisit <- TimePointsSubset[[i]]$Year_bl_LastVisit - TimePointsSubset[[i]]$Years_bl
    if (delta)
    {
      deltaObservations <- TimePointsSubset[[i]][,deltaFeaturepredictors] - BaseTimepointSet[rownames(TimePointsSubset[[i]]),deltaFeaturepredictors]
      colnames(deltaObservations) <- paste("Delta",colnames(deltaObservations),sep="_")
      TimePointsSubset[[i]] <- cbind(TimePointsSubset[[i]],deltaObservations)
    }
    TimePointsSubset[[i]] <- TimePointsSubset[[i]][complete.cases(TimePointsSubset[[i]][,predictors]),]
    Orderbytimepoint <- rbind(Orderbytimepoint,TimePointsSubset[[i]])
    i <- i + 1
  }

  AdjustedFrame <- Orderbytimepoint
  AdjustedFrame <- AdjustedFrame[order(AdjustedFrame$Years_bl),]
  AdjustedFrame <- AdjustedFrame[order(as.numeric(AdjustedFrame$RID)),]

  Orderbytimepoint <- NULL
  if (delta){
    predictors <- c(predictors,colnames(deltaObservations))
  }

  ## Get All the MCI subjects that progressed to AD

  print(table(AdjustedFrame$DX))
  MCISubset <- subset(AdjustedFrame,DX == "NL to MCI" | DX == "MCI" | DX == "Dementia to MCI")
  MCIIDS <- unique(MCISubset$RID)
  print(length(MCIIDS))

  subsetMCIADConversion <-  subset(AdjustedFrame,DX == "MCI to Dementia" | DX == "Dementia")
  print(nrow(subsetMCIADConversion))
  MCIConverters <- subsetMCIADConversion$RID %in% MCIIDS
  subsetMCIADConversion <- subsetMCIADConversion[MCIConverters,]
  print(nrow(subsetMCIADConversion))
  pdis <- subsetMCIADConversion$RID
  subsetMCIADConversion <- subsetMCIADConversion[c(TRUE,pdis[-1] != pdis[1:(length(pdis)-1)]),]
  print(nrow(subsetMCIADConversion))

  rownames(subsetMCIADConversion) <- subsetMCIADConversion$RID

  ### MCI Subset by time points

  MCItoADorderbytimepoint <- NULL
  for (m in months){
    TimePointsMCISubset <- subset(MCISubset,M == m)
    rownames(TimePointsMCISubset) <-  TimePointsMCISubset$RID
    TimePointsMCISubset$TimeToEvent <- subsetMCIADConversion[TimePointsMCISubset$RID,"Years_bl"] - TimePointsMCISubset$Years_bl
    MCItoADorderbytimepoint <- rbind(MCItoADorderbytimepoint,TimePointsMCISubset)
  }

  controlMCIToADset <- MCItoADorderbytimepoint[is.na(MCItoADorderbytimepoint$TimeToEvent),]
  controlMCIToADset <- subset(controlMCIToADset,TimeToLastVisit > 3)
  hist(controlMCIToADset$TimeToLastVisit)
  controlMCIToADset$TimeToEvent <- controlMCIToADset$TimeToLastVisit

  caseMCIToADset <- MCItoADorderbytimepoint[!is.na(MCItoADorderbytimepoint$TimeToEvent),]
  caseMCIToADset <- subset(caseMCIToADset,TimeToEvent > 0 & TimeToEvent < 5.0 )
  hist(caseMCIToADset$TimeToEvent)

  ## MCI Modeling Set

  controlMCIToADset$class <- 0
  caseMCIToADset$class <- 1
  MCI_to_AD_set <- rbind(controlMCIToADset,caseMCIToADset)
  MCI_to_AD_set$TimeToLastVisit <- NULL

  MCI_to_AD_TrainSet <- MCI_to_AD_set[MCI_to_AD_set$D1==1,]

  print(table(MCI_to_AD_TrainSet$class))

  ## Modeling MCI conversion

  print(table(MCI_to_AD_TrainSet$VISCODE))

  MCI_to_ADSets <- list();
  MCI_TO_AD_Model <- list();
  MCI_TO_AD_TimeModel <- list();
  n=1
  pMCItoADEvent <- 0;

  for (n in 1:numberOfRandomSamples){
    randomnumber <- sample(1:nrow(MCI_to_AD_TrainSet),nrow(MCI_to_AD_TrainSet))
    MCI_to_AD_RandomSet <- MCI_to_AD_TrainSet[randomnumber,]
    MCI_to_AD_RandomSet <- MCI_to_AD_RandomSet[order(as.numeric(MCI_to_AD_RandomSet$RID)),]
    RID <- MCI_to_AD_RandomSet$RID
    set1 <- MCI_to_AD_RandomSet[c(RID[1:length(RID)-1] != RID[-1],TRUE),]
    rownames(set1) <- set1$RID
    set1 <- set1[complete.cases(set1),]
    print(nrow(set1))
    print(table(set1$class))
    pMCItoADEvent <- pMCItoADEvent + sum(set1$class)/nrow(set1)
    MCI_to_ADSets[[n]] <- set1[,c("class",predictors)]
    if (asFactor){
      MCI_to_ADSets[[n]]$class <- as.factor(MCI_to_ADSets[[n]]$class)
    }

    MCI_TO_AD_Model[[n]] <- MLMethod(class ~ .,MCI_to_ADSets[[n]],hysteresis=hysteresis)

    sm <- summary(MCI_TO_AD_Model[[n]])
    #print(sm$tAUC)
    MCI_TO_AD_Model[[n]]$BSWiMS.model$bootCV$data <- NULL
    MCI_TO_AD_Model[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    MCI_TO_AD_Model[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL

    set1 <- subset(set1,class==1)
    print(nrow(set1))

    MCI_to_ADSets[[n]] <- set1[,c("TimeToEvent",predictors)]
    MCI_to_ADSets[[n]]$TimeToEvent <- set1$TimeToEvent
    MCI_TO_AD_TimeModel[[n]] <- MLMethod(TimeToEvent ~ .,MCI_to_ADSets[[n]],hysteresis=hysteresis)
    MCI_TO_AD_TimeModel[[n]]$univariate <- NULL
    MCI_TO_AD_TimeModel[[n]]$BSWiMS.model$bootCV$data <- NULL
    MCI_TO_AD_TimeModel[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    MCI_TO_AD_TimeModel[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL
  }
  pMCItoADEvent <- pMCItoADEvent/numberOfRandomSamples

  ## Get All the MCI subjects that progressed to NC

  subsetMCINCConversion <-  subset(AdjustedFrame,DX == "MCI to NL" | DX == "NL")
  print(nrow(subsetMCIADConversion))
  MCIConverters <- subsetMCINCConversion$RID %in% MCIIDS
  subsetMCINCConversion <- subsetMCINCConversion[MCIConverters,]
  print(nrow(subsetMCINCConversion))
  pdis <- subsetMCINCConversion$RID
  subsetMCINCConversion <- subsetMCINCConversion[c(TRUE,pdis[-1] != pdis[1:(length(pdis)-1)]),]
  print(nrow(subsetMCINCConversion))

  rownames(subsetMCINCConversion) <- subsetMCINCConversion$RID

  ### MCI Subset by time points

  MCIToNCorderbytimepoint <- NULL
  for (m in months)
  {
    TimePointsMCISubset <- subset(MCISubset,M == m)
    rownames(TimePointsMCISubset) <-  TimePointsMCISubset$RID
    TimePointsMCISubset$TimeToEvent <- subsetMCINCConversion[TimePointsMCISubset$RID,"Years_bl"] - TimePointsMCISubset$Years_bl
    MCIToNCorderbytimepoint <- rbind(MCIToNCorderbytimepoint,TimePointsMCISubset)
  }

  controlMCIToNCset <- MCIToNCorderbytimepoint[is.na(MCIToNCorderbytimepoint$TimeToEvent),]
  controlMCIToNCset <- subset(controlMCIToNCset,TimeToLastVisit > 3)
  hist(controlMCIToNCset$TimeToLastVisit)
  controlMCIToNCset$TimeToEvent <- controlMCIToNCset$TimeToLastVisit

  caseMCIToNCset <- MCIToNCorderbytimepoint[!is.na(MCIToNCorderbytimepoint$TimeToEvent),]
  caseMCIToNCset <- subset(caseMCIToNCset,TimeToEvent > 0 & TimeToEvent < 5.0 )
  hist(caseMCIToNCset$TimeToEvent)

  ## MCI Modeling Set

  controlMCIToNCset$class <- 0
  caseMCIToNCset$class <- 1
  MCI_to_NC_set <- rbind(controlMCIToNCset,caseMCIToNCset)
  MCI_to_NC_set$TimeToLastVisit <- NULL

  MCI_to_NC_TrainSet <- MCI_to_NC_set[MCI_to_NC_set$D1==1,]

  print(table(MCI_to_NC_TrainSet$class))

  ## Modeling MCI conversion

  print(table(MCI_to_NC_TrainSet$VISCODE))

  MCI_to_NCSets <- list();
  MCI_TO_NC_Model <- list();
  MCI_TO_NC_TimeModel <- list();
  n=1
  pMCItoNCEvent <- 0;

  for (n in 1:numberOfRandomSamples)
  {
    randomnumber <- sample(1:nrow(MCI_to_NC_TrainSet),nrow(MCI_to_NC_TrainSet))
    MCI_to_NC_RandomSet <- MCI_to_NC_TrainSet[randomnumber,]
    MCI_to_NC_RandomSet <- MCI_to_NC_RandomSet[order(as.numeric(MCI_to_NC_RandomSet$RID)),]
    RID <- MCI_to_NC_RandomSet$RID
    set1 <- MCI_to_NC_RandomSet[c(RID[1:length(RID)-1] != RID[-1],TRUE),]
    rownames(set1) <- set1$RID
    set1 <- set1[complete.cases(set1),]
    print(nrow(set1))
    print(table(set1$class))
    pMCItoNCEvent <- pMCItoNCEvent + sum(set1$class)/nrow(set1)
    MCI_to_NCSets[[n]] <- set1[,c("class",predictors)]
    if (asFactor)
    {
      MCI_to_NCSets[[n]]$class <- as.factor(MCI_to_NCSets[[n]]$class)
    }

    MCI_TO_NC_Model[[n]] <- MLMethod(class ~ .,MCI_to_NCSets[[n]],...)
    MCI_TO_NC_Model[[n]]$BSWiMS.model$bootCV$data <- NULL
    MCI_TO_NC_Model[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    MCI_TO_NC_Model[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL

    sm <- summary(MCI_TO_NC_Model[[n]])
    print(sm$tAUC)

    set1 <- subset(set1,class==1)
    print(nrow(set1))

    MCI_to_NCSets[[n]] <- set1[,c("TimeToEvent",predictors)]
    MCI_to_NCSets[[n]]$TimeToEvent <- set1$TimeToEvent
    MCI_TO_NC_TimeModel[[n]] <- MLMethod(TimeToEvent ~ .,MCI_to_NCSets[[n]],...)
    MCI_TO_NC_TimeModel[[n]]$BSWiMS.model$bootCV$data <- NULL
    MCI_TO_NC_TimeModel[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    MCI_TO_NC_TimeModel[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL

  }
  pMCItoNCEvent <- pMCItoNCEvent/numberOfRandomSamples

  ## Get All the NC subjects that progressed
  print(table(AdjustedFrame$DX))
  NCSubset <- subset(AdjustedFrame,DX == "NL" | DX == "MCI to NL")
  NCIDS <- unique(NCSubset$RID)
  print(length(NCIDS))

  subsetNCConvConversion <-  subset(AdjustedFrame,DX == "NL to Dementia" | DX == "NL to MCI" | DX == "MCI")
  print(nrow(subsetNCConvConversion))
  MCIConverters <- subsetNCConvConversion$RID %in% NCIDS
  subsetNCConvConversion <- subsetNCConvConversion[MCIConverters,]
  print(nrow(subsetNCConvConversion))
  pdis <- subsetNCConvConversion$RID
  subsetNCConvConversion <- subsetNCConvConversion[c(TRUE,pdis[-1] != pdis[1:(length(pdis)-1)]),]
  print(nrow(subsetNCConvConversion))

  rownames(subsetNCConvConversion) <- subsetNCConvConversion$RID

  ### NC Subset by time points

  NCConvorderbytimepoint <- NULL
  for (m in months)
  {
    TimePointsNCSubset <- subset(NCSubset,M == m)
    rownames(TimePointsNCSubset) <-  TimePointsNCSubset$RID
    TimePointsNCSubset$TimeToEvent <- subsetNCConvConversion[TimePointsNCSubset$RID,"Years_bl"] - TimePointsNCSubset$Years_bl
    NCConvorderbytimepoint <- rbind(NCConvorderbytimepoint,TimePointsNCSubset)
  }

  controlNCConvset <- NCConvorderbytimepoint[is.na(NCConvorderbytimepoint$TimeToEvent),]
  controlNCConvset <- subset(controlNCConvset, TimeToLastVisit > 3)
  hist(controlNCConvset$TimeToLastVisit)
  controlNCConvset$TimeToEvent <- controlNCConvset$TimeToLastVisit
  caseNCConvset <- NCConvorderbytimepoint[!is.na(NCConvorderbytimepoint$TimeToEvent),]
  caseNCConvset <- subset(caseNCConvset,TimeToEvent > 0 & TimeToEvent < 5.0)
  hist(caseNCConvset$TimeToEvent)

  ## Modeling Nomal congitive Set
  controlNCConvset$class <- 0
  caseNCConvset$class <- 1
  NCConv_set <- rbind(controlNCConvset,caseNCConvset)

  NCConv_TrainSet <- NCConv_set[NCConv_set$D1==1,]

  table(NCConv_TrainSet$class)

  table(NCConv_TrainSet$VISCODE)

  NCConvSets <- list();
  NCConv_Model <- list();
  NL_TO_OTHER_TimeModel <- list();
  n=1

  pNCtoMCIEvent <- 0;
  for (n in 1:numberOfRandomSamples)
  {
    randomnumber <- sample(1:nrow(NCConv_TrainSet),nrow(NCConv_TrainSet))
    NCConv_RandomSet <- NCConv_TrainSet[randomnumber,]
    NCConv_RandomSet <- NCConv_RandomSet[order(as.numeric(NCConv_RandomSet$RID)),]
    RID <- NCConv_RandomSet$RID
    set1 <- NCConv_RandomSet[c(RID[1:length(RID)-1] != RID[-1],TRUE),]
    rownames(set1) <- set1$RID
    set1 <- set1[complete.cases(set1),]
    print(nrow(set1))
    print(table(set1$class))
    pNCtoMCIEvent <- pNCtoMCIEvent + sum(set1$class)/nrow(set1)

    NCConvSets[[n]] <- set1[,c("class",predictors)]
    if (asFactor)
    {
      NCConvSets[[n]]$class <- as.factor(NCConvSets[[n]]$class)
    }
    NCConv_Model[[n]] <- MLMethod(class ~ .,NCConvSets[[n]],...)
    NCConv_Model[[n]]$BSWiMS.model$bootCV$data <- NULL
    NCConv_Model[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    NCConv_Model[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL

    sm <- summary(NCConv_Model[[n]])
    print(sm$tAUC)

    set1 <- subset(set1,class==1)
    print(nrow(set1))
    NCConvSets[[n]] <- set1[,c("TimeToEvent",predictors)]
    NCConvSets[[n]]$TimeToEvent <- set1$TimeToEvent
    NL_TO_OTHER_TimeModel[[n]] <- MLMethod(TimeToEvent ~ .,NCConvSets[[n]],...)
    NL_TO_OTHER_TimeModel[[n]]$BSWiMS.model$bootCV$data <- NULL
    NL_TO_OTHER_TimeModel[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    NL_TO_OTHER_TimeModel[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL
  }
  pNCtoMCIEvent <- pNCtoMCIEvent/numberOfRandomSamples

  ## Cross Sectional Modeling

  ### Baseline Modeling Set

  class <-
    2*(AdjustedFrame$DX == "Dementia" | AdjustedFrame$DX == "MCI to Dementia" | AdjustedFrame$DX == "NL to Dementia") +
    1*(AdjustedFrame$DX == "Dementia to MCI" | AdjustedFrame$DX == "MCI" | AdjustedFrame$DX == "NL to MCI")

  AdjustedFrame$class <- class

  AllADNISets <- list();
  AllADNI_Model <- list();
  n=1

  for (n in 1:numberOfRandomSamples)
  {
    randomnumber <- sample(1:nrow(AdjustedFrame),nrow(AdjustedFrame))
    AllADNI_RandomSet <- AdjustedFrame[randomnumber,]
    AllADNI_RandomSet <- AllADNI_RandomSet[order(as.numeric(AllADNI_RandomSet$RID)),]
    RID <- AllADNI_RandomSet$RID
    set1 <- AllADNI_RandomSet[c(RID[1:length(RID)-1] != RID[-1],TRUE),]
    rownames(set1) <- set1$RID
    AllADNISets[[n]] <- set1[,c("class",cpredictors)]
    AllADNISets[[n]] <- AllADNISets[[n]][complete.cases(AllADNISets[[n]]),]
    print(nrow(AllADNISets[[n]]))
    print(table(set1$DX_bl,set1$class))
    if (asFactor)
    {
      AllADNISets[[n]]$class <- as.factor(AllADNISets[[n]]$class)
    }
    AllADNI_Model[[n]] <- MLMethod(class ~ .,AllADNISets[[n]],...)
    AllADNI_Model[[n]]$BSWiMS.model$bootCV$data <- NULL
    AllADNI_Model[[n]]$BSWiMS.model$bootCV$testOutcome <- NULL
    AllADNI_Model[[n]]$BSWiMS.model$bootCV$testPrediction <- NULL
    AllADNI_Model[[n]]$oridinalModels$data <- NULL
    AllADNI_Model[[n]]$oridinalModels$theClassBaggs[[1]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$theClassBaggs[[2]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$theClassBaggs[[3]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$theBaggedModels[[1]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$theBaggedModels[[2]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$redBaggedModels[[1]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$redBaggedModels[[2]]$bagged.model$model <- NULL
    AllADNI_Model[[n]]$oridinalModels$polr <- NULL
  }

  predicitionModels <- list(CrossModels = AllADNI_Model,
                            MCIToADModels=MCI_TO_AD_Model,
                            MCIToADTimeModel = MCI_TO_AD_TimeModel,
                            MCIToNCModels=MCI_TO_NC_Model,
                            MCIToNCTimeModel = MCI_TO_NC_TimeModel,
                            NCToMCIModel=NCConv_Model,
                            NCToMCITimeModel=NL_TO_OTHER_TimeModel,
                            predictors = cpredictors,
                            pMCItoADEvent = pMCItoADEvent,
                            pNCtoMCIEvent = pNCtoMCIEvent,
                            pMCItoNCEvent = pMCItoNCEvent
  )

  return (predicitionModels)
}


## read-praat-files.r: some functions for reading praat files!
source("proctiers.r")
source("proc-prosody.r")
##-----------------------------------------------------------------
## wrappers
get.f0.tiers.conv <- function(currconv, pdir) {
	y <- currconv
	xtier.list <- get.tiers(pdir=pdir,suffix=".PitchTier", yname="F0", short=F, skip=3)
	return(xtier.list)
}

get.i0.tiers.conv <- function(currconv, pdir) {
	y <- currconv
	xtier.list <- get.tiers(pdir,suffix="IntensityTier",yname="I0",skip=6,short=T)
	return(xtier.list)
}

#add.times.all <- function(x.all, x.spurts.channel) {
#        lapply(x.all, add.times, x.spurts.channel=x.spurts.channel)
#}

## Add offset times based on spurt listing, return a data.table that includes
## spurt info.
add.times <- function(x.list, x.spurts.channel) {
        xdf <- data.table(unlist.df(x.list))
	#print("xdf")
	#print(xdf)
        setkey(xdf, fstem)
	#write.table(xdf, file="xdf.txt")
        setkey(x.spurts.channel, wid)
	#print("x.spurts.channel")
	#print(x.spurts.channel)
	#write.table(x.spurts.channel, file="x.spurts.channel.txt")
        y <- x.spurts.channel[xdf]
	#print(y)
	#write.table(y, file="y.txt")
        y$Time <- y$Time + y$starttime
        return(y)
}

##-----------------------------------------------------------------

normalize.conv <- function(x, x.aggs, var.name="F0", st=c("mean.val", "q5.val", "none"), zscore=F, center=c("mean","min","none"),
			remove.outliers=c("q1.val","q5.val","none"), remove.spurt.slope=F) {
        u <- copy(x)
        setnames(u, c(var.name), c("val"))
        participants <- unique(u$participant)
        currconv <- unique(u$conv)
        print(currconv)

        norm.conv <- NULL
        for (currpart in participants) {
		print("-----------------------------------")
		print(currpart)
		if (nrow(u[participant==currpart]) > 3) {
			curr.norm <- normalize.vals.spk(u[participant==currpart], x.aggs, var.name=var.name,
				st=st, zscore=zscore, center=center, remove.outliers=remove.outliers,
				remove.spurt.slope=remove.spurt.slope)

			norm.conv <- rbindlist(list(norm.conv, curr.norm))
		} else {
			print("Less than 3 data points for speakers")
		}

        }

        return(norm.conv)

}

normalize.vals.spk <- function(u, x.aggs, var.name="F0", st=c("mean.val", "q5.val", "none"), zscore=F, center=c("mean","min","none"),
				remove.outliers=c("q1.val","q5.val","none"), remove.spurt.slope=F) {
        currpart <- unique(u$participant)
        currconv <- unique(u$conv)
        curraggs <- x.aggs[conv==currconv][participant==currpart]

	if (remove.outliers != "none") {
		if (remove.outliers=="q1.val") {
			u <- u[val < curraggs$q99.val][val > curraggs$q1.val]
		} else if (remove.outliers=="q5.val") {
			u <- u[val < curraggs$q95.val][val > curraggs$q5.val]
		} else {
			print("Outlier threshold default to (1,99)")
			print(remove.outliers)
			u <- u[val < curraggs$q99.val][val > curraggs$q1.val]
		}
	}

        normvals <- u$val

        if (st != "none") {
		f0ref <- curraggs[[st]]		## Reference value
		if (st != "mean.val") {
			## Use the minimum as the reference
			f0ref <- max(f0ref, min(normvals, na.rm=T))
		}
		cat("st norm val:", f0ref, "\n", sep=" ")
                normvals <- to.semitone(normvals, F0.ref=f0ref)
        }

        if (zscore) {
                normvals <- to.zscore(normvals)
        }

	if ((center != "none") & !zscore & (st == "none")) {
		print("center")
		if (center == "min") {
			normvals <- normvals - min(normvals, na.rm=T)
		} else {
			normvals <- normvals - mean(normvals, na.rm=T)
		}
	}

        norm.u <- data.table(u, normval=normvals)
	if (remove.spurt.slope==T) {
		print("removing spurt slope")
		xslope <- data.table(ddply(norm.u, .(wid), get.slope.correction, xname="Time", yname="normval"))
		setkey(xslope, wid, Time)
		setkey(norm.u, wid, Time)
		norm.u <- norm.u[xslope]
	}

        setnames(norm.u, names(norm.u), gsub("val",var.name, names(norm.u)))

	print(norm.u)
	print("***HERE")
        return(norm.u)

}

##-----------------------------------------------------------------
get.slope.correction <- function(x, xname="Time", yname="val") {
#	print("get.slope.correction")
	zy <- x[[yname]]
        zx <- x[[xname]]

	val.sloperm <- zy
        if(nrow(x) > 2) {
		curr.mod <- lm(zy ~ zx)
		if (curr.mod$coefficients[2] < 0) {
			val.sloperm <- zy-predict(curr.mod)
		}
	}

	return(data.table(x[,c("wid", xname)], slopeval=val.sloperm))
}

znorm.by.window <- function(u, var.name="F0", wpercent=0.5) {

        setnames(u, names(u), gsub(var.name, "val", names(norm.u)))

        currconv <- unique(u$conv)
	totaltime <- max(u$Time, na.rm=T) - min(u$Time, na.rm=T)
	wsize <- totaltime * wpercent

	## z-score normalize by
	norm.u <- data.table(ddply(u, c("wid"),
	function(x, xdata, wsize) {
		curr <- xdata[Time > (min(x$Time)-wsize)][Time < (max(x$Time)+wsize), list(mean.val=mean(val, na.rm=T), sd.val(val, na.rm=T))]
		z <- (x$val - curr$mean.val) / (curr$sd.val)
		return(data.frame(Time=x$Time, wnorm.val=z))
	}, xdata=u, wsize=wsize))

	#write.table(norm.u, file="norm.u.txt")

	setkey(norm.u, wid, Time)
	setkey(u, wid, Time)
	norm.u <- u[norm.u]

        setnames(norm.u, names(norm.u), gsub("val",var.name, names(norm.u)))
	#write.table(norm.u, file="norm.u.joined.txt")

	return(norm.u)
}

##-----------------------------------------------------------------
## This might need to be put in its own file
#calc.spk.aggs <- function(x, var.name="F0", xconv="Xconv", xparticipant="Xpart", xspk="Xspk") {
#	#print("calc.spk.aggs")
#        if (nrow(x) > 0) {
#                u <- copy(x)
#                setnames(u, c(var.name), c("val"))
#		if (("spk" %in% names(u)) & !("nxt_agent" %in% names(u))) {
#			setnames(u, c("spk"), c("nxt_agent"))
#		}
#                y <- u[,{
#			q <- quantile(val, probs=c(0.01, 0.025, 0.05, 0.25,0.5,0.75,0.95, 0.975,0.99))
#		        curr.slope <- slope.value(data.table(Time=Time, val=val), xname="Time", yname="val")
#		        curr.intercept <- intercept.value(data.table(Time=Time, val=val), xname="Time", yname="val")
#                        list(mean.val=mean(val, na.rm=T), sd.val=sd(val, na.rm=T), max.val=max(val,na.rm=T), min.val=min(val,na.rm=T),
#                        median.val=q[5],
#                        q1.val=q[1], q2.5.val=q[2], q5.val=q[3], q25.val=q[4],
#                        q75.val=q[6], q95.val=q[7], q97.5.val=q[8],q99.val=q[9],
#			slope.val=curr.slope, intercept.val=curr.intercept
#			)
#                },by=list(conv, participant, nxt_agent)]
#
#
#        } else {
#                y <- data.table(conv=xconv, participant=xparticipant, nxt_agent=xspk,
#                        mean.val=NA, sd.val=NA, max.val=NA, min.val=NA,
#                        median.val=NA,
#			q1.val=NA, q2.5.val=NA,  q5.val=NA, q25.val=NA,
#                        q75.val=NA, q95.val=NA, q97.5.val=NA, q99.val=NA,
#			slope.val=NA, intercept.val=NA
#		)
#        }
#        setnames(y, names(y), gsub("val", var.name, names(y)))
#        return(y)
#}

##-----------------------------------------------------------------

add.maxtime <- function(x, conv.maxtime) {
        currconv <- unique(x$conv)
        data.table(x, maxtime=conv.maxtime[conv==currconv]$maxtime)
}

add.df.conv <- function(x, var.name="F0") {
	print("add.df.conv")
	setnames(x, names(x), gsub(var.name, "val", names(x)))

        u <- x[,{
		if (length(normval) >= 4) {
			dy <- get.spline.deriv(Time, normval)
			dys <- get.spline.deriv(Time, slopeval)

			xcurr <- data.table(
				nxt_agent=nxt_agent, conv=conv, participant=participant, channel=channel, conv_id=conv,
				starttime=starttime, endtime=endtime,
				Time=Time, val=val, normval=normval, normval.slope=slopeval, maxtime=maxtime,
				dval=dy$y, dval.slope=dys$y)
		} else {
			xcurr <- data.table(
				nxt_agent=nxt_agent, conv=conv, participant=participant, channel=channel, conv_id=conv,
				starttime=starttime, endtime=endtime,
				Time=Time, val=val, normval=normval, normval.slope=slopeval, maxtime=maxtime,
				dval=0, dval.slope=0)
		}
		xcurr
        },by=list(wid)]

	setnames(u, names(u), gsub("val", var.name, names(u)))
	print(names(u))
	return(u)
}

get.spline.deriv <- function(x, y) {
        v <- smooth.spline(x,y)
        dy <- predict(v, deriv=1)
        return(dy)

}

#add.deriv.all.I0 <- function(xlist) {
#        return(lapply(xlist, add.dI0.conv))
#}

#add.deriv.all.F0 <- function(xlist) {
#        return(lapply(xlist, add.dF0.conv))
#}

#==========================================================
normalize.convs.all <- function(x, spk.aggs, var.name="F0", st=c("mean.val", "q5.val", "none"), center=c("mean","min","none"), zscore=F,
				remove.outliers=c("q1.val","q5.val","none")) {
        x.aggs <- copy(spk.aggs)
        setnames(x.aggs, names(x.aggs), gsub(var.name, "val", names(x.aggs)))
        lapply(x, normalize.conv, x.aggs=x.aggs, var.name=var.name, st=st, zscore=zscore, center=center, remove.outliers= remove.outliers)
}

get.spk.aggs <- function(x, var.name="F0") {
        unlist.df(lapply(x, calc.spk.aggs, var.name=var.name))
}

add.maxtime.all <- function(xlist, conv.maxtime) {
        lapply(xlist, add.maxtime, conv.maxtime=conv.maxtime)
}


# PROBA-V images are often cloudy, to the point that no one 5-day composite is ever cloud-free for a single tile.
# Thus we need to composite images manually, starting with the 5-day composites.
# First, bad quality pixels need to be discarded. There should be no ice in summer (even in the middle of Finland), so any such "ice" is actually a cloud.
# Water is a class, keep it. It may be useful as an additional variable.
# Thus discard anything cloudy/shadowed/ice (assert b0-2 == 000), and bad quality (assert b4-7 == 1)
# In dec the good pixels are 240 (water) and 248 (land)
# Some pixels may be covered by not all bands. If there is land cover change between dates, that might result in weird results, so also discard partial pixels like that.
# And the cloud detection algorithm used by PROBA-V is not optimal.
# Thus either get the highest NDVI, or also remove outliers from a LOESS function, or calculate distance from nearest cloud.
# Dealing with bit flags is not something humans should do. So instead have a function that converts a data frame with readable names to bit flags internally.

library(probaV)
library(stringr)
library(foreach)
library(doParallel)
source("utils/set-temp-path.r")
source("utils/GetProbaVQCMask.r")

OutputDir = "../../userdata/indices/"
SemiCleanRadDir = "../../userdata/semicleaned/radiometry/"
CleanNDVIDir = "../../userdata/cleaned/ndvi/"
TempDir = "../../userdata/temp/"

# Load all cleaned images and produce a maximum NDVI composite using overlay
# Needs clean-timeseries.r and apply-timeseries-mask.r to have been run!
CleanNDVI = stack(list.files(CleanNDVIDir, pattern=glob2rx("*NDVI*.tif"), full.names = TRUE))
CleanSummerNDVI = subset(CleanNDVI,
    which(names(CleanNDVI) == "PROBAV_S5_TOC_X20Y01_20160601_100M_V101_NDVI_sm"):
        which(names(CleanNDVI) == "PROBAV_S5_TOC_X20Y01_20160826_100M_V101_NDVI_sm"))

# First, get which of the dates has the highest NDVI
# This doesn't work probably due to which.max confustion, so store things in memory instead
# MaxNDVI = calc(CleanSummerNDVI, fun=which.max, datatype="INT2U", filename=paste0(OutputDir, "/maxndvi.tif"),
#    overwrite=TRUE, progress="text")
#temp = which.max(CleanSummerNDVI)
#MaxNDVI = writeRaster(temp, filename=paste0(TempDir, "maxndvi.tif"), datatype="INT2S",
#    overwrite=TRUE, progress="text")
#rm(temp)
MaxNDVI = brick(paste0(TempDir, "maxndvi.tif"))

Bands = c("BLUE", "RED0", "NIR0", "SWIR")
registerDoParallel(cores = length(Bands))
foreach(i=1:length(Bands), .packages="raster", .inorder=FALSE) %dopar%
{
    Radiometry = stack(list.files(SemiCleanRadDir, pattern=glob2rx(paste0("*", Bands[i], "*.tif")),
        full.names = TRUE))
    SummerRadiometry = subset(Radiometry,
        which(names(Radiometry) == paste0("PROBAV_S5_TOC_X20Y01_20160601_100M_V101_",Bands[i],"_sm")):
        which(names(Radiometry) == paste0("PROBAV_S5_TOC_X20Y01_20160826_100M_V101_",Bands[i],"_sm")))
    stackSelect(SummerRadiometry, MaxNDVI, datatype="INT2S", overwrite=TRUE, progress="text",
        filename=paste0(OutputDir, Bands[i], "_composite.tif"))
}
# Also write a multilayer file (for visualisation etc.)
Composite = writeRaster(stack(paste0(OutputDir, "RED0_composite.tif"), paste0(OutputDir, "NIR0_composite.tif"),
    paste0(OutputDir, "BLUE_composite.tif"), paste0(OutputDir, "SWIR_composite.tif")), datatype="INT2S",
    filename=paste0(OutputDir, "composite.tif"), progress="text", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))
plotRGB(Composite)


##########################preparation of intensity DP##########################
#get the fit1 from normalized data (sc and fe) from Limma at probe level
#load fit from limma, contrast of 2 conditions, intensity is replaced

fit2_df <- get(load("fit2_sc_fe_notAveraged.rda"))

#' Title
#'
#' @param data
#' @param input.1
#' @param input.2
#'
#' @return list containing outputs
#' @export
#'
#' @examples
#'
intensity_normalization_position <- function(data, input.1, input.2){

    data <- data[, c(8, 9, 10, 58, 61)]
    colnames(data)[c(3,4)] <- c("strand", "logFC_int")

#replace orientation (+ with - and vice versa as in limma orientation is opposite)
plus <- which(data$strand == "+")
minus <- which(data$strand == "-")
data$strand[plus] <- "-"
data$strand[minus] <- "+"
positive <- data[ ,c(2:5)] %>%
    filter(strand == "+") %>%
    arrange(end)
colnames(positive)[1] <- "position"
negative <- data[ ,c(1,3:5)] %>%
    filter(strand == "-") %>%
    arrange(start)
colnames(negative)[1] <- "position"
data <- rbind(positive, negative)

#save(data, file="Data_SC_iron_fit1_positionSE.rdata")
dc <- get(load("Data_SC_iron_fit1_positionSE.rdata"))
#join the data together
input.2[,"ID"] <- as.numeric(input.2[,"ID"])

input.2 <- left_join(input.2[,-c(1:4)], dc, by = c("position", "strand"))

input.1[,"ID"] <- as.numeric(input.1[,"ID"])
input.1 <- left_join(input.1[,-c(1:4)], dc, by = c("position","strand"))

 return(list(input.1, input.2))
}


#------------------------------------------------------------
# Julio Ayala
# Created on: May 2021
# Description: Script to create plots of Tajima's D distributions
# for Italian sparrow population based on thetas Analysis from ANGSD
# Note: Before running, set the working directory to the root of the project
#------------------------------------------------------------
rm(list = ls())
library(tidyverse)
library(data.table)
library(cowplot)
library(grid)

setwd("Results/04_Theta/")
## Read from file
read_csv_filename <- function(filename){
  ret <- read.csv(filename, sep = "\t")
  ret$site <- gsub("\\..*","",filename)
  ret
}

## open all files and group
files = list.files(pattern = "*.pestPG")
temp <- lapply(files, read_csv_filename)
df <- rbindlist(temp)

#Separate autosomes and chr z
autosomesdf <- df[df$Chr!="chrZ",]
chrzdf <- df[df$Chr=="chrZ",]
df$type <- ifelse(df$Chr=="chrZ", "Z Chromosome", "Autosomes")

## Tajima's D boxplot
t <- ggplot(df, aes(x = site, y = Tajima, color = type)) +
  geom_boxplot( outlier.size = 0.5) +
  ggtitle("Tajima's D distribution of 100-kb windows") +
  theme_bw() +
  theme(plot.title = element_text(size = 12),
        legend.title = element_blank(),
        legend.direction = "horizontal",
        legend.position = "bottom",
        axis.text.x = element_text(size = 12)) +
  scale_x_discrete(limits=c("house","spanish",
                            "corsica", "crete", "malta", "sicily",
                            "crotone", "guglionesi", "rimini"),
                   labels=c("House","Spanish",
                            "Corsica", "Crete", "Malta", "Sicily",
                            "Crotone", "Guglionesi", "Rimini")) +
  xlab(element_blank())
print(t)

## Density distributions
density_plots <- list()
colors <- c("#fb9a99", "#cab2d6", "#a6cee3", "#1f78b4", "#e31a1c", "#ff7f00", "#b2df8a", "#33a02c", "#fdbf6f")
populations <- c("house","spanish", "corsica", "crete", "malta", "sicily", "crotone", "guglionesi", "rimini")
populations2 <- c(
  "house \nA:0.05243; Z:0.07870",
  "spanish \nA:-0.30463; Z:0.29069",
  "corsica \nA:-0.00663; Z:0.56125",
  "crete \nA:0.17773 ±; Z:0.31415",
  "malta \nA:-0.02135; Z:0.20169",
  "sicily \nA:-0.26238; Z:0.19086",
  "crotone \nA:-0.17396; Z:0.24187",
  "guglionesi \nA:-0.15184; Z:0.32074",
  "rimini \nA:-0.10783; Z:0.29392")
for (i in 1:9) {
  tmp <- autosomesdf[autosomesdf$site == populations[i],]
  tmp$type <- "Autosomes"
  tmp2 <- chrzdf[chrzdf$site == populations[i],]
  tmp2$type <- "Z Chromosome"
  tmp <- rbind(tmp, tmp2)
  tmpplot <- ggplot(tmp, aes(Tajima, color = type, fill = type)) +
    geom_density(alpha = 0.5) +
    ggtitle(str_to_title(populations2[i])) +
    xlab("Tajima's D") +
    theme_bw() +
    theme(plot.title = element_text(size = 10),
          legend.title = element_blank(),
          legend.direction = "horizontal")

  density_plots[[i]] <- tmpplot
}

# Get the legend and remove it from individual plots
tmpplot <- get_legend(density_plots[[1]])
for (i in 1:9){
  density_plots[[i]] <- density_plots[[i]] + theme(legend.position="none",
                                                   axis.title.x = element_blank())
}

pg <- plot_grid(plotlist = density_plots, ncol = 3)
pg <- plot_grid(pg, bottom = textGrob("Tajima's D"), tmpplot, ncol = 1, rel_heights = c(1, 0.05, 0.05))
print(pg)

setwd("../../")


# Function 'InputIntroductoryTask'
# Killian Martin--Horgassan
# 19-02-2015

# Manages the input for the sample size and distribution chosen
# USED IN script IntroductoryTask.r

InputIntroductoryTask <- function() {
cat("Enter the sample size")
Nb <- as.numeric(readline("Sample size :\n"))
cat("Choose a distribution :\n","- [1] for a gaussian distribution\n",
	"- [2] for an exponential distribution\n",
	"- [3] for a Cauchy distribution\n")
choice_dist <- as.character(readline("Your choice ? :\n"))
if (choice_dist == "1") {
	m  <- as.numeric(readline("\nExpectation ? :\n"))
	s  <- as.numeric(readline("\nStandard deviation ? :\n"))
	DIST_1 <-rnorm(Nb,m,s)
	DIST_2 <- "gaussian"
} else if (choice_dist == "2") {
	lambda  <- as.numeric(readline("\nRate ? :\n"))
	DIST_1 <- rexp(Nb,lambda)
	DIST_2 <- "exponential"
} else if (choice_dist == "3") {
	l  <- as.numeric(readline("\nLocation ? :\n"))
	s  <- as.numeric(readline("\nScale ? :\n"))
	DIST_1 <- rcauchy(Nb,l,s)
	DIST_2 <- "cauchy"
} else {
	stop("\n!! Invalid choice, try again !!\n")
}

output <- list(DIST_1,DIST_2)
}


require(graphics)
require(Matrix)

pdf(file="plots/Experiment1a.pdf",
  width=5, height=4.0, family="serif", pointsize=14)

data1 = as.matrix(read.table("results/Experiment1_p1.dat", sep=","))[,2]
data2 = as.matrix(read.table("results/Experiment1_p2.dat", sep=","))[,2]
data3 = as.matrix(read.table("results/Experiment1_p3.dat", sep=","))[,2]
data4 = as.matrix(read.table("results/Experiment1_p4.dat", sep=","))[,2]
data5 = as.matrix(read.table("results/Experiment1_p5.dat", sep=","))[,2]

points = as.vector(seq(1:10));
plot_colors <- c("cornflowerblue","gray40","black","orange","orangered")

plot(   points, data3,
        type="o",
        pch=19,
        cex=1.1,
        col=plot_colors[3],
        ylim = c(0.5,3500000),
        xlab="",
        ylab="",
        axes=FALSE,
        bg=plot_colors[3],
        log="y",
        lwd=1.1,
        lty=1
  )

axis(2, las=2, at=c(1,10,100,1000,1e4,1e5,1e6), labels=c("1","10","100","1000","1e4","1e5","1e6")) # horizontal y axis
axis(1, las=1)      # horizontal x axis
mtext(2, text="# Enumerated Slices",line=2.7)
mtext(1, text="Lattice Level L",line=2)

lines(points[1:4], data5, type="o", pch=15, lty=1, lwd=1.1, col=plot_colors[5], bg=plot_colors[5], cex=1.0)
lines(points[1:4], data4, type="o", pch=15, lty=1, lwd=1.1, col=plot_colors[4], bg=plot_colors[4], cex=1.0)
lines(points[1:8], data2, type="o", pch=25, lty=1, lwd=1.1, col=plot_colors[2], bg=plot_colors[2], cex=1.0)
lines(points[1:8], data1[1:8], type="o", pch=17, lty=1, lwd=1.1, col=plot_colors[1], bg=plot_colors[1], cex=1.0)

box()

legend( "topright",
       c("No dedup","No parents, sc, ss"), col=plot_colors[5:4],
       pch=c(15,15), lty=c(1), lwd=c(1.1), bty="n");

legend( 1.5, 600,
       c("No parents, sc","No parents", "All"), col=plot_colors[3:1], pt.bg=plot_colors[3:1],
       pch=c(19,25,17), lty=c(1), lwd=c(1.1), bty="n");

dev.off()


#' alarm
#'
#' A count down until the clock matches the given time(s).
#'
#' @param timestr Time(s) that the alarm will go off.
#'
#' @examples
#' \dontrun{
#' alarm("01:32")
#' alarm("14:59:15")
#' alarm(c("01:32","14:59:15"))
#' }
#'
#' @export
alarm = function(timestr)
{
  strtosec=function(ts){
    curtime=as.POSIXct(format(Sys.time(), "%Y-%m-%d %H:%M:%S"))
    dt=difftime(as.POSIXct(paste0(format(Sys.time(),"%Y-%m-%d "),ts)),curtime,units="secs")
    if(dt<0){
      # tomorrow's time (12am?)
      dt=difftime(as.POSIXct(paste0(format(Sys.time()+24*60*60,"%Y-%m-%d "),ts)),curtime,units="secs")
    }
    as.numeric(dt)
  }
  for(si in 1:length(timestr)){
    timer(seconds=strtosec(timestr[si]), hours=0, minutes=0, over_time = si==length(timestr))
  }
}


library(dplyr)
library(snpar)
library(lubridate)

#  get_dual_diff
#
# calculate the difficulty of a given dual stim. because i forgot to add it in the experiment
# luckily we have the complete dual stims in the data as a string.
# @param vec: - a vector with the dual stims (i.e. TZRF_TZRF for phonological or {0,1},... for visual)
#
# @ret the difficulty of the stims
#
get_dual_diff <- function(vec){

    char_vec <- as.character(vec)
    difficulty <- c()

    if (length(char_vec)== 0){
        return(difficulty)
    }
    for (i in 1:length(char_vec)) {
        #char_vec[i] <- char_vec[i]+i
        if(is.na(char_vec[i])){
            difficulty <- append(difficulty,c(NA))
        }
        else{
            str_as_char_vec <- strsplit(char_vec[i],"")[[1]]

            if("{" %in% str_as_char_vec){
                # visual task
                diff <- floor(length(which(str_as_char_vec == "{"))/2)
                difficulty <- append(difficulty,c(diff))
            }
            else{
                # phonological task
                diff <- floor(length(str_as_char_vec)/2)
                difficulty <- append(difficulty,c(diff))
            }
        }
    }

    return(difficulty)
}

#  get_data
#
# gets all available data for a prob_code from the data folder.
# @param prob_code: - the participants code to get data for. (filenames with this prob code in the data should start with it)
# @param get_dual_diff: - function to calculate the difficulty of a dual stim
#
# @ret a data frame with all data for the participant
#
get_data <- function(prob_code,get_dual_diff){

    filenames <- list.files("data/",pattern="*.csv$",full.names=TRUE)

    # get a vec for every col in the dataframe
    rt_num <- c()
    correct_num <- c()

    ordered <- c()
    ascending <- c()
    descending <- c()
    distance <- c()
    datetime <- c()
    rt_dual <- c()
    correct_dual <- c()
    dual_stim <- c()
    mode <- c()
    framerate <- c()
    practice <- c()
    numbers <- c()
    rig_randomness_p <- NA
    rig_randomness_runs <- NA
    rig_randomness_1s <- NA
    rig_randomness_0s <- NA

    client_info <- c()

    # we go trough all the files in the folder
    for (filename in filenames){

        # and if it starts with our prob_code we know we have found an interesting one
        if(startsWith(basename(filename),prob_code))
        {

            #message(paste("filename: ",filename))

            file <- read.csv(filename,sep=",",as.is=TRUE)
            fields <- names(file)

            # here we check what kind of file it is.
            # depending on wich file it is we add some data and set the rest NA
            if (grepl("single",basename(filename),fixed=TRUE))
            {

                if ( "rt" %in% names(file)){
                    rt_num <- append(rt_num,file$rt)
                    correct_num <- append(correct_num,file$correct)
                }
                else{
                    # if the vector does not exist add it.
                    rt_num <- append(rt_num,rep(NA,nrow(file)))
                    correct_num <- append(correct_num,rep(NA,nrow(file)))
                }

                rt_dual <- append(rt_dual,rep(NA,nrow(file)))
                correct_dual <- append(correct_dual,rep(NA,nrow(file)))
                ordered <- append(ordered ,file$ordered)
                numbers<- append(numbers,file$numbers)
                ascending <- append(ascending ,file$ascending)
                descending <- append(descending ,file$descending)
                distance <- append(distance ,file$distance)
                datetime <- append(datetime ,file$datetime)
                framerate <- append(framerate ,file$framerate)
                dual_stim <- append(dual_stim,rep(NA,nrow(file)))
                mode <- append(mode,rep("single",nrow(file)))
                if (nrow(file) == 4) { practice <- append(practice,rep(TRUE,nrow(file))) } else{ practice <- append(practice,rep(FALSE,nrow(file))) }

            }
            else if (grepl("dual_phon",basename(filename),fixed=TRUE))
            {

                if ( "rt_ord" %in% names(file)){
                    rt_num <- append(rt_num,file$rt_ord)
                    correct_num <- append(correct_num,file$correct_ord)
                }
                else{
                    # if the vector does not exist add it.
                    rt_num <- append(rt_num,rep(NA,nrow(file)))
                    correct_num <- append(correct_num,rep(NA,nrow(file)))
                }
                if ( "rt_dual" %in% names(file)){
                    rt_dual <- append(rt_dual,file$rt_dual)
                    correct_dual <- append(correct_dual,file$correct_dual)
                }
                else{
                    # if the vector does not exist add it.
                    rt_dual <- append(rt_dual,rep(NA,nrow(file)))
                    correct_dual <- append(correct_dual,rep(NA,nrow(file)))
                }

                ordered <- append(ordered ,file$ordered)
                numbers<- append(numbers,file$numbers)
                ascending <- append(ascending ,file$ascending)
                descending <- append(descending ,file$descending)
                distance <- append(distance ,file$distance)
                datetime <- append(datetime ,file$datetime)
                framerate <- append(framerate ,file$framerate)
                dual_stim <- append(dual_stim,file$dual_stim)
                mode <- append(mode,rep("dual_phon",nrow(file)))
                if (nrow(file) == 4) { practice <- append(practice,rep(TRUE,nrow(file))) } else{ practice <- append(practice,rep(FALSE,nrow(file))) }

            }
            else if (grepl("dual_vis",basename(filename),fixed=TRUE))
            {
                if ( "rt_ord" %in% names(file)){
                    rt_num <- append(rt_num,file$rt_ord)
                    correct_num <- append(correct_num,file$correct_ord)
                }
                else{
                    # if the vector does not exist add it.
                    rt_num <- append(rt_num,rep(NA,nrow(file)))
                    correct_num <- append(correct_num,rep(NA,nrow(file)))
                }

                if ( "rt_dual" %in% names(file)){
                    rt_dual <- append(rt_dual,file$rt_dual)
                    correct_dual <- append(correct_dual,file$correct_dual)
                }
                else{
                    # if the vector does not exist add it.
                    rt_dual <- append(rt_dual,rep(NA,nrow(file)))
                    correct_dual <- append(correct_dual,rep(NA,nrow(file)))
                }

                ordered <- append(ordered ,file$ordered)
                numbers<- append(numbers,file$numbers)
                ascending <- append(ascending ,file$ascending)
                descending <- append(descending ,file$descending)
                distance <- append(distance ,file$distance)
                datetime <- append(datetime ,file$datetime)
                framerate <- append(framerate ,file$framerate)
                dual_stim <- append(dual_stim,file$dual_stim)
                mode <- append(mode,rep("dual_vis",nrow(file)))
                if (nrow(file) == 4) { practice <- append(practice,rep(TRUE,nrow(file))) } else{ practice <- append(practice,rep(FALSE,nrow(file))) }
            }
            else if (grepl("dual_rig",basename(filename),fixed=TRUE))
            {
                if ( "rt" %in% names(file)){
                    rt_num <- append(rt_num,file$rt)
                    correct_num <- append(correct_num,file$correct)
                }
                else{
                    # if the vector does not exist add it.
                    rt_num <- append(rt_num,rep(NA,nrow(file)))
                    correct_num <- append(correct_num,rep(NA,nrow(file)))
                }

                rt_dual <- append(rt_dual,rep(NA,nrow(file)))
                correct_dual <- append(correct_dual,rep(NA,nrow(file)))
                ordered <- append(ordered ,file$ordered)
                ascending <- append(ascending ,file$ascending)
                numbers<- append(numbers,file$numbers)
                descending <- append(descending ,file$descending)
                distance <- append(distance ,file$distance)
                datetime <- append(datetime ,file$datetime)
                framerate <- append(framerate ,file$framerate)
                dual_stim <- append(dual_stim,rep(NA,nrow(file)))
                mode <- append(mode,rep("dual_rig",nrow(file)))
                if (nrow(file) == 4) { practice <- append(practice,rep(TRUE,nrow(file))) } else{ practice <- append(practice,rep(FALSE,nrow(file))) }

            }
            else if (grepl("client_info",basename(filename),fixed=TRUE))
            {
                client_info <- file
            }
            else if (grepl("stair_phon",basename(filename),fixed=TRUE))
            {
            }
            else if (grepl("stair_vis",basename(filename),fixed=TRUE))
            {
            }
            else if (grepl("rig_practice",basename(filename),fixed=TRUE))
            {
            }
            else if (grepl("rig",basename(filename),fixed=TRUE))
            {

                #message(paste("filename: in rig ",filename))
                #  get median distance. and use as by
                distances <- c()
                for (i in 1:(length(file$rt)-1)){
                    distances <- append(distances,(file$rt[i+1] - file$rt[i]))
                }

                is_in_interval_vec <- c()

                #  check how many distances are above or below the median.
                # depending on the value (above or below median) we give it a 0 or a 1
                for( i in distances){
                    if(i < median(distances)){
                        is_in_interval_vec <- append(is_in_interval_vec,1)
                    }else{
                        is_in_interval_vec <- append(is_in_interval_vec,0)
                    }

                }

                # now we can calculate the runs test for our vector of 0s and 1s
                is_in_interval_vec <- unlist(is_in_interval_vec)
                runs_test <- runs.test(is_in_interval_vec, exact = FALSE, alternative = c("two.sided"))
                # and add it to our data
                rig_randomness_p <- runs_test$p.value
                rig_randomness_runs <- runs_test$statistic
                rig_randomness_1s <- length(is_in_interval_vec[is_in_interval_vec == 1])
                rig_randomness_0s <- length(is_in_interval_vec[is_in_interval_vec == 0])

            }

        }

    }

    # get demo cols
    dat_demo <- read.csv("data/demo_data.csv")
    dat_demo <-  dat_demo %>% filter(probanden_code == prob_code)

    if(nrow(dat_demo) == 0){
        demo_sex <- NA
        demo_age <- NA
        demo_rl <- NA
        demo_drogen <- NA
        demo_alkohol <- NA
        demo_dyslex <- NA
        demo_adhs <- NA
    }
    else{
        demo_sex <- dat_demo$sex
        demo_age <- dat_demo$age
        demo_rl <- dat_demo$rechts_links
        demo_drogen <- dat_demo$drogen
        demo_alkohol <- dat_demo$alkohol
        demo_dyslex <- dat_demo$Dyslexie
        demo_adhs <- dat_demo$ADHS
    }

    demo_sex <- rep(demo_sex,length(rt_num))
    demo_age <- rep(demo_age,length(rt_num))
    demo_rl <- rep(demo_rl,length(rt_num))
    demo_drogen <- rep(demo_drogen,length(rt_num))
    demo_alkohol <- rep(demo_alkohol,length(rt_num))
    demo_dyslex <- rep(demo_dyslex,length(rt_num))
    demo_adhs <- rep(demo_adhs,length(rt_num))

    prob_code <- rep(prob_code,length(rt_num))
    rig_randomness_p <- rep(rig_randomness_p,length(rt_num))
    rig_randomness_runs <- rep(rig_randomness_runs,length(rt_num))
    rig_randomness_1s <- rep(rig_randomness_1s,length(rt_num))
    rig_randomness_0s <- rep(rig_randomness_0s,length(rt_num))

    # now we merge all the cols into a dataframe.
    data <- data.frame(prob_code, rt_num, correct_num,numbers, ordered, ascending, descending, distance, datetime, rt_dual, correct_dual, mode,dual_stim,practice,rig_randomness_p,rig_randomness_runs,rig_randomness_1s,rig_randomness_0s,demo_sex,demo_age,demo_rl,demo_drogen,demo_alkohol,demo_dyslex,demo_adhs)
    data["dual_diff"] <- get_dual_diff(data$dual_stim)

    if (length(client_info) != 0){
        data["os"] <- rep(client_info$os[1],nrow(data))
        data["screen_height"] <-rep( client_info$screen_height_t_ratio[1],nrow(data))
        data["screen_width"] <-rep( client_info$screen_width_t_ratio[1],nrow(data))
    }

    if(nrow(data) != 0){
        data$datetime <- parse_date_time(data$datetime,'d.m.Y, H:M:S')
        data <- data %>% arrange(datetime)
        trial_number <- c(1:nrow(data))
        data <- cbind(data,data.frame(trial_number))
    }

    return(data)
}

#  get_unique_prob_codes
#
# goes through all the files in the data folder and gets the prob code column
# then returns only unique prob codes.
# @ret a vector of all the unique prob codes we have in the data folder.
#

get_unique_prob_codes <- function(){
    filenames <- list.files("data/",pattern="*.csv$",full.names=TRUE)
    all_prob_codes <- c()
    for (filename in filenames){

        ##print(filename)
        file <- read.csv(filename,stringsAsFactors=FALSE,colClasses=c('character'))
        # we dont have a prob code for client info but it does not really matter because its in the filename
        if ("prob_code" %in% colnames(file)){
            prob_code <- toString(file$prob_code[1])
            if (prob_code != ""){
                all_prob_codes <- append(all_prob_codes,prob_code)
            }
        }

    }
    return(unique(all_prob_codes))
}

# main:

prob_codes <- get_unique_prob_codes()
all_data_frames <- list()
# get all the data for all prob_codes
for (i in seq_along(prob_codes)){
    data <- get_data(prob_codes[i],get_dual_diff)
    all_data_frames[[i]] <- data

}

# merge them into one big datafile.
first_df <- all_data_frames[[1]]

if (length(all_data_frames) > 1){
for (i in 2:length(all_data_frames)){
    first_df <- rbind(first_df,all_data_frames[[i]])
}
}

write.csv(first_df,file="all_data.csv",row.names=FALSE,na="")


mindistkeep2 <- function(x, thresholdmin)
{
    if (!inherits(x,"ltraj"))
        stop("x should be of class 'ltraj'")
    foo <- function(y) {
        ul <- 1

        if (nrow(y) > 1){
		for (i in 2:nrow(y)) {
			if(y$dist[i-1]<thresholdmin){
				ul[i]= ul[i-1]
				y$dist[i] = sqrt( (y$x[i+1] -y$x [ul[i]])*(y$x[i+1] -y$x [ul[i]])+(y$y[i+1] -y$y [ul[i]])*(y$y[i+1] -y$y [ul[i]]) )
			} else ul[i]={i}

		}
	} else print(nrow (y))

        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
        }
        z <- y[ul,c("x","y")]
        da <- y$date
        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"), infolocs=infol)
        } else {
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"))
        }
        return(lt)
    }
    res <- do.call("c.ltraj", lapply(x, foo))
    class(res) <- c("ltraj","list")
    return(res)
}

mindistkeep3 <- function(x, thresholdmin,thresholdmax)
{
    if (!inherits(x,"ltraj"))
        stop("x should be of class 'ltraj'")
    foo <- function(y) {
        ul <- 1

        if (nrow(y) > 1){
		for (i in 2:nrow(y)) {
			if(y$dist[i-1]<thresholdmin || y$dist[i-1]>thresholdmax){
				ul[i]= ul[i-1]
				if(y$dist[i-1]<thresholdmin) {
					y$dist[i] = sqrt( (y$x[i+1] -y$x [ul[i]])*(y$x[i+1] -y$x [ul[i]])+(y$y[i+1] -y$y [ul[i]])*(y$y[i+1] -y$y [ul[i]]) )
					}
			} else ul[i]={i}

		}
	} else print(nrow (y))

        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
        }
        z <- y[ul,c("x","y")]
        da <- y$date
        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"), infolocs=infol)
        } else {
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"))
        }
        return(lt)
    }
    res <- do.call("c.ltraj", lapply(x, foo))
    class(res) <- c("ltraj","list")
    return(res)
}

maxdistkeep2 <- function(x, threshold =25)
{
    if (!inherits(x,"ltraj"))
        stop("x should be of class 'ltraj'")
    foo <- function(y) {
        ul <- 1

        if (nrow(y) > 1){
		for (i in 2:nrow(y)) {
			if(y$dist[i-1]>threshold){
				ul[i]= ul[i-1]

			} else ul[i]={i}

		}
	} else print(nrow (y))

        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
        }
        z <- y[ul,c("x","y")]
        da <- y$date
        if (!is.null(attr(y, "infolocs"))) {
            infol <- attr(y, "infolocs")
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"), infolocs=infol)
        } else {
            lt <- as.ltraj(z, da, id=attr(y,"id"), burst=attr(y,"burst"),
                           typeII=attr(x,"typeII"))
        }
        return(lt)
    }
    res <- do.call("c.ltraj", lapply(x, foo))
    class(res) <- c("ltraj","list")
    return(res)
}

# creates a circle center x,y and radius r with n points
circle <- function(x, y, r = 1, n = 100) {
    	ang <- seq(0, 2*pi, length.out=n)
    	xx <- x + r * cos(ang)
    	yy <- y + r * sin(ang)
	return(data.frame(xx,yy))
}

#creates a number string with 0 prefix of length
add.zero.prefix <- function(value,length=5) {
	length <- length-nchar(as.character(value))
	zeros <- paste(rep("0",length),collapse="")
	return( paste(zeros,value,sep="") )
}

#ceates a number string with group and id in the prefix
add.group_id.prefix <- function(value,id,group="",length=3) {
	if (group!="") prefix <- paste(as.character(group),as.character(id),sep="-") else		prefix <- as.character(id)

	length <- max (0,length-nchar(as.character(value)))
	zeros <- paste(rep("0",length),collapse="")
	return( paste(prefix,"_",zeros,value,sep="") )
}

# returns the timestamp in ms precision
as.seconds <- function(date) {
	if (!inherits(date, "POSIXct"))
        	stop("date should be of class \"POSIXct\"")
	sec = as.numeric(date)%/%1
	r =  as.numeric(format(date, "%OS3"))%%1
	return(data.frame(sec,r))
}

#returns time differenc in seconds
time.difference <- function(date1,date2) {
	if (!inherits(date1, "POSIXct")||!inherits(date2, "POSIXct"))
        	stop("date1 and date2 should be of class \"POSIXct\"")
	t1 <- as.seconds(date1)
	t2 <- as.seconds(date2)
	t2$sec <- t2$sec - t1$sec
	t2$r <- t2$r - t1$r
	return(t2sec+t2$r)
}

# returns the duration of a date vector to the first element in seconds
get.durations <- function(dates) {
	if (!inherits(dates, "POSIXct"))
		stop("dates should be of class \"POSIXct\"")
	durations = as.seconds(dates)
	durations$s = durations$s - durations$s[1]
	durations$r = durations$r - durations$r[1]
	return(durations$s+durations$r)
}

#returns the angular difference of two angles
angular.diff <- function(a,b) {
	diff <- a-b

	erg <- sapply(diff,function(d) {

		if (is.na(d))
            return(d)

			d <- d%%(2*pi)
			if (d > pi)
				return(-(2*pi)+d)
			else if (d < -pi)
				return((2*pi)-d)
			else
				return (d)

	})

	return(erg)
}

#gets all the burst for the specified group
get.traj.group <- function(traj,id_table,group) {

	if (!inherits(traj, "ltraj"))
        stop("traj should be of class \"ltraj\"")

	ids = id_table[id_table$group==group,]$id
	return(traj[id(traj)%in%ids])
}


f <- function(x) {
	return(58.8273 + 20.7595*x - 18.1163*x*x - 2.36343*x*x*x + x*x*x*x)
}

f1 <- function(x) {
	return(4*x*x*x - 3*2.36343*x*x - 2*18.1163*x + 20.7595)
}

bissecao <- function(a, b) {
	x <- 0
	for(i in 1:a) {
		x <- x + 1
		print(x)
	}
	return(x)
}

newton <- function(x) {
	return(0)
}

secante <- function(x0, x1) {
	return(0)
}

regulaFalsi <- function(x0, x1) {
	return(0)
}

print("Bissecao:")
print(bissecao(0, 2))
print("Newton:")
print(newton(1))
print("Secante:")
print(secante(1, 2))
print("Regula Falsi:")
print(secante(1, 2))