# Calculate RMSEs and other error metrics (m etc) for each visibility-estimation method

merged$kosch = vis2aot_k(merged$meto)
merged$sixs <- vis2aot_sixs(merged$meto)
merged$modtran <- vis2aot_modtran(merged$meto)

merged$err_kosch <- merged$kosch - merged$aeronet
merged$err_sixs <- merged$sixs - merged$aeronet
merged$err_modtran <- merged$modtran - merged$aeronet

ranges = seq(0, 40, 10)

ranges <- c(ranges, 100)

rmses <- data.frame(kosch_rmse=rep(NA, length(ranges)-1),
                    kosch_avg=rep(NA, length(ranges)-1),
                    kosch_m=rep(NA, length(ranges)-1),
                    kosch_prop_over=rep(NA, length(ranges)-1),
                    sixs_rmse=rep(NA, length(ranges)-1),
                    sixs_avg=rep(NA, length(ranges)-1),
                    sixs_m=rep(NA, length(ranges)-1),
                    sixs_prop_over=rep(NA, length(ranges)-1),
                    modtran_rmse=rep(NA, length(ranges)-1),
                    modtran_avg=rep(NA, length(ranges)-1),
                    modtran_m=rep(NA, length(ranges)-1),
                    modtran_prop_over=rep(NA, length(ranges)-1),
                    avg_vis=rep(NA, length(ranges)-1),
                    sd_aot=rep(NA, length(ranges)-1),
                    avg_aot=rep(NA, length(ranges)-1))

for (i in 2:length(ranges)-1)
{
  if (ranges[i] == 999)
  {
    low = 0
    high = 9999
  }
  else
  {
    low <- ranges[i]
    high <- ranges[i+1]
  }

  sub_df <- subset(merged, merged$meto >= low & merged$meto < high)

  rmses[i,]$kosch_rmse <- rmse(sub_df$err_kosch)
  rmses[i,]$kosch_avg <- mean(sub_df$err_kosch)
  rmses[i,]$kosch_m <- as.numeric(coef(lm(sub_df$kosch ~ sub_df$aeronet + 0))[1])
  rmses[i,]$kosch_prop_over <- sum(sub_df$err_kosch > 0)/nrow(sub_df)

  rmses[i,]$sixs_rmse <- rmse(sub_df$err_sixs)
  rmses[i,]$sixs_avg <- mean(sub_df$err_sixs)
  rmses[i,]$sixs_m <- as.numeric(coef(lm(sub_df$sixs ~ sub_df$aeronet + 0))[1])
  rmses[i,]$sixs_prop_over <- sum(sub_df$err_sixs > 0)/nrow(sub_df)

  rmses[i,]$modtran_rmse <- rmse(sub_df$err_modtran)
  rmses[i,]$modtran_avg <- mean(sub_df$err_modtran)
  rmses[i,]$modtran_m <- as.numeric(coef(lm(sub_df$modtran ~ sub_df$aeronet + 0))[1])
  rmses[i,]$modtran_prop_over <- sum(sub_df$err_modtran > 0)/nrow(sub_df)

  rmses[i,]$avg_vis <- mean(sub_df$meto)
  rmses[i,]$avg_aot <- mean(sub_df$aeronet)
  rmses[i,]$sd_aot <- sd(sub_df$aeronet)
}

cache('rmses')


# Parameters
## SAD
S_POOL   <- seq(from = 10L, to = 90L, by = 10L)
N_SIM    <- c(100L, 200L, 300L, 500L, 1000L, 2000L, 3000L, 5000L) * 100L
SAD_COEF <- c(list(cv_abund = 0.5))

## initial dispersion
SIGMA    <- 10

## movement dispersion
MOVEMENT_SD <- 0
DRIFT    <- seq(from = 0.001, to = 0.01, length = 5) # at max speed, the map comes back to where it was at the beginning in 100 timesteps

## sampling
QUADRAT_AREA <- 0.01 # in a grid of 100
N_QUADRATS <- 100L

## subsampling
# SUBSAMPLING_RATIO <- c(.1, .5, 1)

parameter_table <- expand.grid(
   S_POOL = S_POOL, N_SIM = N_SIM, SAD_COEF = SAD_COEF,
   SIGMA = SIGMA,
   MOVEMENT_SD = MOVEMENT_SD, DRIFT = DRIFT,
   QUADRAT_AREA = QUADRAT_AREA, N_QUADRATS = N_QUADRATS
)


library(a5udes)
library(dplyr)
library(sf)
library(tidygraph)
library(ggraph)
library(igraph)

res_geom_df=reservoir_geometry %>%
  st_set_geometry(NULL) %>%
  dplyr::select(id_jrc,area_max,`distance to river`,`nearest river`) %>%
  rename(name=id_jrc)

river_geometry %>% names

# calculate area contribution of each river reach to the catchment

riv_graph_tbl=river_graph %>% activate(nodes) %>% as_tibble

parent_sum=river_graph %>%
  graph_reverse_direction %>%
  mutate(parent=bfs_parent(mode='out')) %>%
  as_tibble %>%
  group_by(parent) %>%
  summarise(parent_area=sum(UPLAND_SKM)) %>%
  filter(!is.na(parent)) %>%
  mutate(name = riv_graph_tbl$name[.$parent]) %>%
  select(-parent)

riv_g2=river_graph %>%
  left_join(parent_sum) %>%
  mutate(riv_contr_area=ifelse(is.na(parent_area),UPLAND_SKM,UPLAND_SKM-parent_area))
riv_g2 %>% as_tibble %>% head

riv_df=riv_g2 %>% activate(nodes) %>% as_tibble %>%
  dplyr::select(HYRIV_ID,riv_contr_area)

g=reservoir_graph %>%
  graph_reverse_direction %>%
  activate(nodes) %>%
  left_join(res_geom_df) %>%
  left_join(riv_df,by=c('nearest river'='HYRIV_ID')) %>%
  mutate(own_contr_area=ifelse(`distance to river`==0,riv_contr_area/xxxxx,area_max*0.3664))

g_tbl = g %>% as_tibble

parent_sum=g %>%
  mutate(parent=bfs_parent(mode='out')) %>%
  as_tibble %>%
  group_by(parent) %>%
  summarise(parent_area=sum(total_contr_area)) %>%
  filter(!is.na(parent)) %>%
  mutate(name = g_tbl$name[.$parent]) %>%
  select(-parent)

g2=g %>%
  left_join(parent_sum) %>%
  mutate(contr_area=ifelse(is.na(parent_area),own_contr_area,UPLAND_SKM-riv_contr_area+own_contr_area))  # solve all reservoirs without parent

g2 %>% as_tibble %>% filter(contr_area<0)

# plot example

sub_g=g %>% convert(to_local_neighborhood,node=which(.N()$name == "34560"), order = 2, mode = "out")
sub_g %>%  ggraph(.) +
geom_node_point() +
geom_edge_link0() +
geom_node_label(aes(label = name)) # repel=TRUE

# define neighborhood upstream of each reservoir

neigh = g %>% activate(nodes) %>%
  arrange(desc(rank)) %>%
  mutate(neighborhood =   local_members(order = 1,mode='out',mindist=1)) %>%
  as_tibble

contrib=vector(mode='list',length=nrow(neigh))

# for(i in seq(1,nrow(neigh))) {

  if(neigh$`distance to river`[i]>0){
    contrib[[i]]=neigh$area_max[i]*0.3664
  } else {
    riv_l=filter(river_geometry,ARCID==neigh$`nearest river`[i])

  }

  # }
riv_l=res_geom[1,] %>% pull()
res_geom[1,]


# Calculate time series metrics from all current data
#
# Input: Semi-cleaned blue and NDVI files. The process cleans them all over again.
# Output: a multiband file with harmonic parameters

#library(robustbase)
library(probaV)
library(tools)
source("utils/set-temp-path.r")

# create output name on the metrics
if (!exists("OutputDir"))
    OutputDir = "../../userdata/harmonics/"
OutputFile = paste0(OutputDir, "harmonic-coefficients.tif")
LogFile = paste0(OutputDir, "get-harmonics.log")
TileOfInterest = "X20Y01"
if (!exists("CleanNDVIDir"))
    CleanNDVIDir = "../../userdata/cleaned/ndvi/"
CleanDir = "../../userdata/cleaned/"
if (!exists("TempDir"))
    TempDir = "../../userdata/temp/"

# Subset for testing
#xmin <- 27
#xmax <- 28
#ymin <- 58
#ymax <- 59
if (exists("xmin") && exists("xmax") && exists("ymin") && exists("ymax"))
    SubsetExtent = c(xmin, ymin, xmax, ymax)

#BandPattern = "(BLUE|NDVI)_sm.tif$"
#VrtFilename = paste0(OutputDir, "harmonics2.vrt")

BandPattern = "NDVI_sm.tif$"
VrtFilename = paste0(TempDir, "harmonics.vrt")

# Create virtual stack
if (exists("SubsetExtent"))
{
    Vrt = timeVrtProbaV(CleanNDVIDir, pattern = BandPattern, vrt_name = VrtFilename, tile = TileOfInterest,
        return_raster = TRUE, te = SubsetExtent)
} else {
    Vrt = timeVrtProbaV(CleanNDVIDir, pattern = BandPattern, vrt_name = VrtFilename, tile = TileOfInterest,
        return_raster = TRUE)
}

if (exists("SubsetExtent"))
{
    TS = timeVrtProbaV(CleanNDVIDir, pattern = BandPattern, vrt_name = VrtFilename, tile = TileOfInterest,
        return_raster = FALSE, te = SubsetExtent)
} else {
    TS = timeVrtProbaV(CleanNDVIDir, pattern = BandPattern, vrt_name = VrtFilename, tile = TileOfInterest,
        return_raster = FALSE, te = SubsetExtent)
}

if (!exists("RowsPerThread"))
    RowsPerThread = 14
if (!exists("Cores"))
    Cores = 16

print(paste("layers:", nlayers(Vrt), "dates:", "blocks:", blockSize(Vrt, minrows = RowsPerThread)$n, "cores:", Cores))

if (!file.exists(OutputFile))
{
    psnice(value = min(Cores - 1, 19))
    print(system.time(Coeffs <- getHarmMetricsSpatial(Vrt, TS, minrows = RowsPerThread, mc.cores = Cores,
        logfile=LogFile, overwrite=TRUE, filename = OutputFile, order = 2, datatype="FLT4S", progress="text")))
} else
    Coeffs = brick(OutputFile)

phaser = function(co, si)
{
    tau = 2*pi
    return(atan2(si, co) %% tau)
}
amplituder = function(co, si)
{
    return(sqrt(co^2 + si^2))
}

# Calculate phase and amplitude from our data
# Parameters, in order:
# min max intercept co si co2 si2 co3 si3 trend (blue, NDVI)
# min max intercept co si co2 si2 trend (blue, NDVI)
p1 = overlay(Coeffs[[4]], Coeffs[[5]], fun=phaser)
a1 = overlay(Coeffs[[4]], Coeffs[[5]], fun=amplituder)
p2 = overlay(Coeffs[[6]], Coeffs[[7]], fun=phaser)
a2 = overlay(Coeffs[[6]], Coeffs[[7]], fun=amplituder)

# Get mean NDVI value
# Could probably try to get it from trend and intercept, but rounding errors might be severe
MeanNDVI = mean(Vrt, na.rm=TRUE)

# Create final output
FinalStack = stack(MeanNDVI, p1, a1, p2, a2)
brick(FinalStack, filename=paste0(OutputDir, "phase-amplitude.tif"), datatype="FLT4S", overwrite=TRUE,
    progress="text", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Singhal"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Merge datasets, then select and rename columns of interest

x <- merge(mLBF, mLGL, by = c("Locus"))
mL <- x %>% select("Locus")

mL$BF <- (x$TvS.x)/2
mL$dGLS <- x$TvS.y
hypoth <- "TvS"
t <- "ToxPoly vs. Sclero"

#mL$BF <- (x$AIvSA.x)/2
#mL$dGLS <- x$AIvSA.y
#hypoth <- "AIvSA"
#t <- "ToxAI vs. ToxSA"
#

# Get max min for graph

max(abs(min(mL$BF)),abs(max(mL$BF)),abs(min(mL$dGLS)),abs(max(mL$dGLS)))
limit <- 90
tic <- seq(-limit,limit,10)

# Names "TvS", "AIvSA", "AIvSI", "SAvAI", "SAvSI", "SIvAI", "SIvSA", "TvS_support"

color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

quartz()
# Set colors
color_h0 <- color_AI
color_h0 <- color_TP

graph_general <- ggplot(mL, aes(x=BF,y=dGLS)) +
  geom_point(alpha=0.5, color=color_h0, size=1) + theme_bw() + theme(panel.border = element_blank()) +
  theme_classic() +
  theme(
    axis.text = element_text(size=16, color="black"),
    text = element_text(size=20),
    legend.position = "none",
    panel.border = element_blank(),
    panel.background = element_rect(fill = "transparent"), # bg of the panel
    plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
    panel.grid = element_blank(), # get rid of major grid
    plot.title = element_text(hjust = 0.5)
  ) +
  coord_cartesian(ylim=tic,xlim = tic) +
  scale_y_continuous(breaks = tic) +
  scale_x_continuous(breaks = tic) +
  labs(x='ln(BF)',y='dGLS')

graph_general

graph_custom <- graph_general +
  geom_vline(xintercept=c(10,-10),color=c("gray"), linetype="dotted", size=0.5) +
  geom_hline(yintercept=c(0.5,-0.5),color=c("gray"), linetype="dotted", size=0.5) +
  ggtitle(paste(dataset,"\n",t,sep=""))
  #geom_abline(color=c("gray"), size=0.2, linetype="solid") +

graph_custom

ggsave(paste(dataset,"_scatter_",hypoth,".pdf",sep=""), plot=graph_custom,width = 9.5, height = 6, units = "in", device = 'pdf',bg = "transparent")


#' knots2ms
#'
#' Conversion speed from knots in meter per second.
#'
#' @param numeric  knots Speed in knots.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  knots2mph
#'
#' @export
#'
#'
#'
#'
knots2ms<-function(knots)
{
  return(knots * 0.514444);
}


# SEE: https://github.com/jonclayden/RNiftyReg
# CMD>> Rscript scripts/Rscript/regist_niftyReg-linear.r \
#                   data-images/rat-kidney_/scale-5pc/Rat_Kidney_HE.jpg \
#                   data-images/rat-kidney_/scale-5pc/Rat_Kidney_PanCytokeratin.jpg \
#                   data-images/rat-kidney_/scale-5pc/Rat_Kidney_HE.csv \
#                   output/

## Install packages if needed, then load them
# See: https://github.com/jonclayden/RNiftyReg
# install.packages(c("png", "jpeg", "OpenImageR" ,"devtools"))
# devtools::install_github("jonclayden/RNiftyReg")
library(OpenImageR)
library(methods)
library(RNiftyReg)
# require("png", "jpeg", "RNiftyReg")

args <- commandArgs(TRUE)
args

## Reference Image
pathImgA <- args[1]
## Moving Image
pathImgB <- args[2]
## Moving Landmarks
pathLnd <- args[3]
## output folder
outPath <- args[4]
outTime <- paste(outPath, 'time.txt', sep='')
outLnd <- paste(outPath, 'points.pts', sep='')
outImg <- paste(outPath, 'warped.jpg', sep='')

time.start <- Sys.time()

## Read images, and convert (naively) to greyscale by averaging the RGB channels
target <- rgb_2gray(readImage(pathImgA))
source <- rgb_2gray(readImage(pathImgB))

## NiftyReg supports max image size 2048, so any larger image has to be scaled
maxSize <- max(max(dim(target)), max(dim(source)))
scale <- maxSize / 2048.
if (scale > 1) {
    target <- resizeImage(target, floor(dim(target)[1] / scale), floor(dim(target)[2] / scale))
    source <- resizeImage(source, floor(dim(source)[1] / scale), floor(dim(source)[2] / scale))
}

## Register the images and retrieve the affine matrix
result <- niftyreg.linear(source, target,
                          scope=c("affine", "rigid"),
                          nLevels=3,
                          maxIterations=5,
                          useBlockPercentage=50,
                          estimateOnly=FALSE,
                          verbose=TRUE)
result

## Export registration time
time.taken <- Sys.time() - time.start
cat(time.taken, file=outTime)
outTime

## Save image as bitmap
# png::writePNG(result$image, outImg)

clip_values <- function(x, a, b) {
    ifelse(x <= a,  a, ifelse(x >= b, b, x))
}

## Transform image
# output <- applyAffine( invertAffine( result$affine[[1]] ) , source, target, finalInterpolation=3)
imgWarp <- applyTransform( forward(result) , source)
imgWarp <- clip_values(imgWarp, 0, 1)
if (scale > 1) {
    imgWarp <- resizeImage(imgWarp, round(dim(imgWarp)[1] * scale), round(dim(imgWarp)[2] * scale))
}
## Save image as bitmap
writeImage(imgWarp, outImg)
outImg

## Load landmarks from CSV
points <- as.matrix(read.table(pathLnd, skip=1, sep = ','))
points <- points[, c(3, 2)]
if (scale > 1) {
    points <- points / scale
}
## Transform points
#pointsWarp <- transformWithAffine(points, invertAffine( result$affine[[1]] ), source, target)
pointsWarp <- applyTransform( forward(result) , points)
pointsWarp <- pointsWarp[, c(2,1)]
if (scale > 1) {
    pointsWarp <- pointsWarp * scale
}
## Save transformed points
cat('point\n',nrow(pointsWarp),'\n', file=outLnd)
write.table(pointsWarp, file=outLnd, sep = ' ', append=TRUE, row.names=FALSE, col.names=FALSE)
outLnd

## Exit
quit('yes')


#! /usr/bin/env Rscript
# Auth: Michael Zeller 5/28/2019

#Load needed libraries
library(ape)
library(ggplot2)
library(lubridate)
library(gap)
library(cowplot)
library(gridExtra)

#Substring functions
#https://stackoverflow.com/questions/7963898/extracting-the-last-n-characters-from-a-string-in-r
substrRight <- function(x, n){
  substr(x, nchar(x)-n+1, nchar(x))
}

getDistFromOldest <- function(t){
  #Grab R from commandline arguments, or print usage
  treeFile1 <- t

  #Load user specified tree file
  tree1<-read.tree(treeFile1)

  #Get patristic distance matrix
  dist1 <-cophenetic(tree1)

  #Get names
  dates1 <- substrRight(colnames(dist1),10)
  dates1 <- as.Date(dates1, format = "%m/%d/%Y")
  if(is.na(dates1[1])) {
    dates1 <- substrRight(colnames(dist1),10)
    dates1 <- as.Date(dates1, tryFormats = c("%m/%d/%Y","%Y-%m-%d"))
  }
  oldestId <- which(dates1 == sort(dates1)[1])[[1]]

  #Calculate decimal date
  decdate <- decimal_date(dates1)

  #Get clades
  clades <- sapply(strsplit(colnames(dist1), "|", fixed = TRUE), "[", 3)

  #Return
  resultFrame <- data.frame("dates" = dates1, "decimalDate" = decdate, "dist" = dist1[oldestId,], "clade" = clades)
  return(resultFrame)
}

getBranchFrames <- function(t){
  #Grab R from commandline arguments, or print usage
  treeFile1 <- t

  #Load user specified tree file
  tree1<-read.tree(treeFile1)

  #Set up dataframe
  tipLen<-length(tree1$tip.label)
  treeInfo<-setNames(tree1$edge.length[sapply(1:tipLen,function(x,y) which(y==x),y=tree1$edge[,2])],tree1$tip.label)
  resultFrame <- data.frame("branchLengths" = treeInfo)
  clades <- sapply(strsplit(rownames(resultFrame), "|", fixed = TRUE), "[", 3)
  dates <- sapply(strsplit(rownames(resultFrame), "|", fixed = TRUE), "[", 4)
  dates <- as.Date(dates, tryFormats = c("%m/%d/%Y","%Y-%m-%d"))
  resultFrame <- cbind("names" = rownames(resultFrame), resultFrame, "clade" = clades, "date" = dates)

  return(resultFrame)
}

plotCophenDist<- function(df){
  (ggplot(df, aes(dates, dist, color = clade)) +
     geom_point() +
     geom_smooth(method = "lm", se = FALSE) +
     theme(legend.position="bottom")
  )
}

plotBranchHisto <- function(df){
  (ggplot(df, aes(x = branchLengths, color = clade, fill = clade)) +
     geom_histogram(aes(y=..density..), binwidth = 0.001, alpha=0.6, position="identity", lwd=0.2) +
     theme(legend.position="bottom")
  )
}

plotTimeDist <- function(df){
  (ggplot(df, aes(date, branchLengths, color = clade)) +
     geom_point(aes(size = 2))
     #theme(axis.text.x = element_text(angle = 90, hjust = 1))
  )
}

manualChow <- function(lmPooled, lmA, lmB){
  #Get residual sum of squares
  rssA <- sum(residuals(lmA)^2)
  rssB <- sum(residuals(lmB)^2)
  rssPooled <- sum(residuals(lmPooled)^2)

  #Assume intercepts = 2
  k = 2

  #Calculate f critical chow statistic at the 95% confidence level
  fcrit = qf(0.95, df1 = lmA$df, df2 = lmB$df)
  chowStat = ((rssPooled - (rssA + rssB))/k)/((rssA+rssB)/(lmA$df + lmB$df - (2*k)))
  p <- pf(chowStat, lmA$df, lmB$df, lower.tail=FALSE)

  #Return
  result <- c(fcrit, chowStat, p)
  names(result) = c("F-critical", "Chow Statistic", "P-value")
  return(result)
}

#Draw
#reassort234 <- getDistFromOldest("2-3-4/reassortment234.tre")
#reassort56 <- getDistFromOldest("5-6/reassortment56.tre")
#reassort789 <- getDistFromOldest("7-8-9/reassortment789.tre")
reassort1 <- getDistFromOldest("1/short.tre")
reassort4 <- getDistFromOldest("4/redo_reassort4.tre")
reassort5 <- getDistFromOldest("5/redo_reassort5.tre")
reassort6 <- getDistFromOldest("6/redo_reassort6.tre")
reassort7 <- getDistFromOldest("7/redo_reassort7.tre")
reassort9 <- getDistFromOldest("9/redo_reassort9.tre")

#Change the order of factors so the donor HA is on the right, and recpient HA is on right for all legends (red then cyan)
reassort4$clade <- factor(reassort4$clade, levels = rev(levels(reassort4$clade)))
reassort5$clade <- factor(reassort5$clade, levels = rev(levels(reassort5$clade)))
reassort6$clade <- factor(reassort6$clade, levels = rev(levels(reassort6$clade)))
reassort7$clade <- factor(reassort7$clade, levels = rev(levels(reassort7$clade)))
reassort8$clade <- factor(reassort8$clade, levels = rev(levels(reassort8$clade)))
reassort9$clade <- factor(reassort9$clade, levels = rev(levels(reassort9$clade)))

#ggplot
#install.packages("gap") #https://rdrr.io/cran/gap/man/chow.test.html
(plot1 <- plotCophenDist(reassort1))
set1 = reassort1[which(reassort1$clade == "cluster_ivf"),]
set2 = reassort1[which(reassort1$clade == "delta1b"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

(plot4 <- plotCophenDist(reassort4))
set1 = reassort4[which(reassort4$clade == "delta1b"),]
set2 = reassort4[which(reassort4$clade == "2010.1"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plot5 <- plotCophenDist(reassort5)
set1 = reassort5[which(reassort5$clade == "alpha"),]
set2 = reassort5[which(reassort5$clade == "cluster_ivb"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

(plot6 <- plotCophenDist(reassort6))
set1 = reassort6[which(reassort6$clade == "alpha"),]
set2 = reassort6[which(reassort6$clade == "2010.1"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plot7 <- plotCophenDist(reassort7)
set1 = reassort7[which(reassort7$clade == "cluster_iva"),]
set2 = reassort7[which(reassort7$clade == "cluster_ivb"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plot8 <- plotCophenDist(reassort8)
set1 = reassort8[which(reassort8$clade == "cluster_iva"),]
set2 = reassort8[which(reassort8$clade == "delta1a"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plot9 <- plotCophenDist(reassort9)
set1 = reassort9[which(reassort9$clade == "2010.1"),]
set2 = reassort9[which(reassort9$clade == "delta1a"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

######################
#Plotting by N2 clade#
######################
#grid.arrange(plot1, plot4, plot5, plot6, plot7, plot8, plot9, ncol = 3, nrow = 3)
plot_grid(plot1, plot4, plot5, plot6, plot7, plot8, plot9,
          labels = c("A", "B", "C", "D", "E", "F", "G"),
          ncol = 3, nrow = 3)

##########################
#Naihui Zhou's suggestion#
##########################
fitTest = lm(dist ~ decimalDate * clade, reassort1)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort4)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort5)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort6)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort7)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort8)
summary(fitTest)
anova(fitTest)

fitTest = lm(dist ~ decimalDate * clade, reassort9)
summary(fitTest)
anova(fitTest)

#########
#TESTING#
#########
#https://www.youtube.com/watch?v=uUxJk4UGXOg
#http://aoki2.si.gunma-u.ac.jp/R/Chow.html
fita = lm(dist ~ decimalDate, reassort1, subset = clade == "cluster_ivf")
fitb = lm(dist ~ decimalDate, reassort1, subset = clade == "delta1b")
fitp = lm(dist ~ decimalDate, reassort1)
(chow <- manualChow(fitp,fita,fitb))

fita = lm(dist ~ decimalDate, reassort8, subset = clade == "cluster_iva")
fitb = lm(dist ~ decimalDate, reassort8, subset = clade == "delta1a")
fitp = lm(dist ~ decimalDate, reassort8)
(chow <- manualChow(fitp, fita, fitb))

########################
#TERMINAL LEAF PLOTTING#
########################

#http://blog.phytools.org/2013/10/finding-edge-lengths-of-all-terminal.html
#Get tip lengths
#Load user specified tree file
treeInfo1 <- getBranchFrames("1/redo_reassort1.tre")
treeInfo4 <- getBranchFrames("4/redo_reassort4.tre")
treeInfo5 <- getBranchFrames("5/redo_reassort5.tre")
treeInfo6 <- getBranchFrames("6/redo_reassort6.tre")
treeInfo7 <- getBranchFrames("7/redo_reassort7.tre")
treeInfo8 <- getBranchFrames("8/redo_reassort8.tre")
treeInfo9 <- getBranchFrames("9/redo_reassort9.tre")

plotBranchHisto(treeInfo1)
plotBranchHisto(treeInfo4)
plotBranchHisto(treeInfo5)
plotBranchHisto(treeInfo6)
plotBranchHisto(treeInfo7)
plotBranchHisto(treeInfo8)
plotBranchHisto(treeInfo9)

plotTimeDist(treeInfo1)
plotTimeDist(treeInfo4)
plotTimeDist(treeInfo5)
plotTimeDist(treeInfo6)
plotTimeDist(treeInfo7)
plotTimeDist(treeInfo8)
plotTimeDist(treeInfo9)


#  mpiexec -np 2 ./Rscript mantelMPI_22_09_2015.r "SPE_Lagoon16S_C10.csv" TRUE "SPE_Lagoon16S_C05.csv" TRUE "/home/varsos/R-3.1.1/Datasets/Christina_dataset/" "pearson" 999

rm(list = ls())

# Initial Parameters given by the user
args <- commandArgs(trailingOnly = TRUE)
dist1 <- args[1] # The name of the first (community) csv file. Not transposed
transposition1 <- as.logical(args[2]) # Choose to transpose the matrix (TRUE) or not (FALSE).
dist2 <- args[3] # The name of the second (community) csv file. Not transposed
transposition2 <- as.logical(args[4]) # Choose to transpose the matrix (TRUE) or not (FALSE).
datasetPath <- args[5] # The directory (path) where the datasets are stored
method <- args[6] # by default is "pearson"
permutations <- as.numeric(args[7])
#na.rm <- as.logical(args[6])
# outputPath <- args[7] # The directory (path) where the results 'll be stored

setwd(datasetPath)

xdis <- read.csv(dist1, header = TRUE, row.names = 1, sep = ",")
ydis <- read.csv(dist2, header = TRUE, row.names = 1, sep = ",")

if (transposition1) {
  xdis <- t(xdis)
} else if(transposition1 != TRUE) {
  xdis <- xdis
} else {
  stop("Wrong choice. For matrix's transposition choose 1 else 0.")
}

if (transposition2) {
  ydis <- t(ydis)
} else if (transposition2 != TRUE) {
  ydis <- ydis
} else {
  stop("Wrong choice. For matrix's transposition choose 1 else 0.")
}

if((permutations < 0) || is.numeric(permutations) != TRUE) {
  stop("Wrong permutations . Use non-negative values.")
}
# Transpose community matrix

library(vegan)
library(pbdMPI, quiet = TRUE)

init()

# Start the clock
fullProgramTimer = proc.time()

processors <- comm.size()
myrank <- comm.rank()

xdis <- vegdist(xdis)
ydis <- vegdist(ydis)

xdis <- as.dist(xdis)
ydis <- as.vector(as.dist(ydis))
na.rm <- FALSE

mainCalcTimer = proc.time()

if (na.rm) {
  use <- "complete.obs"
} else use <- "all.obs"
statistic <- cor(as.vector(xdis), ydis, method = method,
                 use = use)
variant <- match.arg(method, eval(formals(cor)$method))
variant <- switch(variant, pearson = "Pearson's product-moment correlation",
                  kendall = "Kendall's rank correlation tau", spearman = "Spearman's rank correlation rho",
                  variant)
N <- attr(xdis, "Size")

step1 <- floor(permutations/processors)
step2 <- permutations - step1*(processors - 1)

ptest <- function(take, ...) {
  permvec <- (xmat[take, take])[asdist]
  drop(cor(permvec, ydis, method = method, use = use))
}

# comm.print("--------------------------------------------------------------------")
if (myrank != (processors = 1)) {
  if (length(permutations) == 1) {
    if (permutations > 0) {
      arg <- NULL
      permat <- t(replicate(step1, permute::shuffle(N)))
    }
  } else {
    permat <- as.matrix(permutations)
    if (ncol(permat) != N)
      stop(gettextf("'permutations' have %d columns, but data have %d observations",
                    ncol(permat), N))
    permutations <- nrow(permutations)
  }

  if(permutations) {
    start <- myrank*step1 + 1
    end <- (myrank+1)*step1

    perm <- numeric(step1)
    xmat <- as.matrix(xdis)
    asdist <- row(xmat) > col(xmat)
    perm <- sapply(1:step1, function(i, ...) ptest(permat[i, ], ...))
    sgnf <- (sum(perm >= statistic))
  } else {
    signif <- NA
    perm <- NULL
  }
} else {
  arg <- NULL
  permat <- t(replicate(step2, permute::shuffle(N)))
  permat2 <- permat

  if(permutations) {
    start <- (myrank + 1)*step1 + 1
    end <- (myrank + 1)*step1 + step2

    perm <- numeric(step2)
    xmat <- as.matrix(xdis)
    asdist <- row(xmat) > col(xmat)

    perm <- sapply(1:step2, function(i, ...) ptest(permat2[i, ], ...))
    sgnf <- (sum(perm >= statistic))
  } else {
    signif <- NA
    perm <- NULL
  }
}

all.perm <- gather(perm)
all.sgnf <- reduce(sgnf, op = 'sum')

if(myrank == 0) {

  dmc <- NULL
  for(i in 1:length(all.perm)) {
    dmc <- c(dmc, all.perm[[i]])
  }
  all.perm <- dmc; rm(dmc)
  signif <- (all.sgnf + 1)/(permutations + 1)
}

comm.print("method", rank.print = 0)
comm.print(method, rank.print = 0)
comm.print("permutations", rank.print = 0)
comm.print(permutations, rank.print = 0)

res <- list(call = match.call(definition = function(xdis, ydis, method, permutations)NULL,
            quote(mantel(xdis, ydis, method, permutations))), method = variant,
            statistic = statistic, signif = signif, perm = all.perm, permutations = permutations)

class(res) <- "mantel"

## comm.print(res[[1]])
## comm.print(res[[2]])
## comm.print(res[[3]])
## comm.print(res[[4]])
## comm.print(length(res[[5]]))
## comm.print(res[[6]])

comm.print(res, rank.print = 0)

# Stop the clock
comm.print("Full program execution time for each processor", rank.source = 0)
comm.print(proc.time() - fullProgramTimer, all.rank = T)

comm.print("Main calculations time", rank.source = 0)
comm.print(proc.time() - mainCalcTimer, all.rank = T)

comm.print("Mantel class object size (Mb)", rank.source = 0)
comm.print(object.size(res)/(1024^2), all.rank = T)

comm.print("Object size of the main calculation", rank.source = 0)
comm.print(object.size(res[[5]])/(1024^2), rank.source = T)

#
finalize()


##
## Function to calculate variance-covariance matrix from geeglm models averaged using MuMIn
## which MuMIn can't seem to do by default because the vcov() function doesn't work on geeglm models
## instead, we need to extract their vcov matrices via model$geese$vbeta in each case
##
## See original code in MuMIn:::vcov.averaging
## the only change is on lines 19-20 below
##
## Author: Matthew Gwynfryn Thomas
##
##      {------- email --------}
##         {-- twitter --}
##      mgt@matthewgthomas.co.uk
##          {------ web -------}
##
##
## Copyright (c) 2016 Matthew Gwynfryn Thomas
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License along
## with this program; if not, write to the Free Software Foundation, Inc.,
## 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
##
vcov.averaging.geeglm = function(object, full=T)
{
  object <- MuMIn:::upgrade_averaging_object(object)
  full <- MuMIn:::.checkFull(object, full)
  full <- as.logical(full)[1L]
  models <- attr(object, "modelList")
  if (is.null(models))
    stop("cannot calculate covariance matrix from ", "'averaging' object without component models")

  # get variance-covar matrices
  #vcovs <- lapply(lapply(models, vcov), as.matrix)
  vcovs <- lapply(lapply(models, function(m) m$geese$vbeta), as.matrix)

  names.all <- dimnames(object$coefArray)[[3L]]
  nvars <- length(names.all)
  nvarseq <- seq(nvars)
  wts <- MuMIn::Weights(object)
  wts <- wts/sum(wts)
  vcov0 <- matrix(if (full)
    0
    else NA_real_, nrow = nvars, ncol = nvars, dimnames = list(names.all,
                                                               names.all))
  vcovs2 <- lapply(vcovs, function(v) {
    i <- match(MuMIn:::fixCoefNames(dimnames(v)[[1L]]), names.all)
    vcov0[i, i] <- v
    return(vcov0)
  })
  b1 <- object$coefArray[, 1L, ]
  if (full)
    b1[is.na(b1)] <- 0
  avgb <- object$coefficients[2L - full, ]
  res <- sapply(nvarseq, function(c1) sapply(nvarseq, function(c2) {
    weighted.mean(sapply(vcovs2, "[", c1, c2) + (b1[, c1] -
                                                   avgb[c1]) * (b1[, c2] - avgb[c2]), wts, na.rm = TRUE)
  }))
  dimnames(res) <- list(names.all, names.all)
  return(res)
}


#' Assign spatial polygons to sites
#'
#' This function assigns spatial polygon data to water quality portal type site objects (or data with site information attached).
#' @param data Input dataset. Must include latitude & longitude columns.
#' @param polygon Polygon to assign information to sites. Must be an sf type polygon shapefile, WGS84 projection recommended.
#' @param lat Name of latitude column. Default matches WQP objects.
#' @param long Name of longitude column. Default matches WQP objects.
#' @param columns Vector of columns to retain from polygon object. If columns not specified, function will retain all columns.
#' @importFrom sf st_as_sf
#' @importFrom sf st_set_crs
#' @importFrom sf st_join
#' @examples
#' # Read a couple of sites (Mantua Reservoir and a tributary)
#' sites=readWQP(type="sites", siteid=c("UTAHDWQ_WQX-4900440","UTAHDWQ_WQX-4900470"))
#' sites_AUs=assignPolys(sites, wqTools::au_poly)
#' sites_BUs=assignPolys(sites, wqTools::bu_poly)
#' @return Returns the input data frame with assessment unit information appended.
#' @export
assignPolys=function(data, polygon, lat="LatitudeMeasure", long="LongitudeMeasure", columns){
	if(exists("columns")){polygon=polygon[,columns]} # Subset columns
	x=sf::st_as_sf(data, coords=c(long,lat), crs=4326, remove=F) # Convert data to sf object, WGS84 projection
	isect=suppressMessages({suppressWarnings({sf::st_join(x, polygon, left=TRUE)})}) # Run spatial join
	sf::st_geometry(isect)=NULL # Drop geometry column (this could be optional)
	return(isect)
}


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dffeatures <- read.csv("features.csv", header=TRUE)
dfstores <- read.csv("stores.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#add Weekly_Sales column to the test dataset
dftest[,"Weekly_Sales"] <- NA

#create one dataset
dftmp1 <- rbind(dftrain, dftest)
dftmp2 <- merge(dftmp1, dfstores, by = "Store")
dfrm <- merge(dftmp2, dffeatures, by = c("Store","Date", "IsHoliday"))

#replace NAs by mean value
dfrm$MarkDown1[is.na(dfrm$MarkDown1)] <- mean(dfrm$MarkDown1,na.rm=TRUE)
dfrm$MarkDown2[is.na(dfrm$MarkDown2)] <- mean(dfrm$MarkDown2,na.rm=TRUE)
dfrm$MarkDown3[is.na(dfrm$MarkDown3)] <- mean(dfrm$MarkDown3,na.rm=TRUE)
dfrm$MarkDown4[is.na(dfrm$MarkDown4)] <- mean(dfrm$MarkDown4,na.rm=TRUE)
dfrm$MarkDown5[is.na(dfrm$MarkDown5)] <- mean(dfrm$MarkDown5,na.rm=TRUE)
dfrm$CPI[is.na(dfrm$CPI)] <- mean(dfrm$CPI,na.rm=TRUE)
dfrm$Unemployment[is.na(dfrm$Unemployment)] <- mean(dfrm$Unemployment,na.rm=TRUE)

#replace Type A/B/C by 1/2/3
dfrm$Type <- as.numeric(dfrm$Type)

#replace IsHoliday T/F by 1/2
dfrm$IsHoliday <- as.numeric(dfrm$IsHoliday) + 1

#Add Week Column based on Date
dfrm[,"Week"] <- as.numeric(dfrm$Date)

#add Seasonality 1-52
dfrm <- transform(dfrm, Seasonality = (Week %% 52) + 1 )

#scale parameters
dfrm$Size <- scale(dfrm$Size)
dfrm$Temperature <- scale(dfrm$Temperature)
dfrm$Fuel_Price <- scale(dfrm$Fuel_Price)
dfrm$MarkDown1 <- scale(dfrm$MarkDown1)
dfrm$MarkDown2 <- scale(dfrm$MarkDown2)
dfrm$MarkDown3 <- scale(dfrm$MarkDown3)
dfrm$MarkDown4 <- scale(dfrm$MarkDown4)
dfrm$MarkDown5 <- scale(dfrm$MarkDown5)
dfrm$CPI <- scale(dfrm$CPI)
dfrm$Unemployment <- scale(dfrm$Unemployment)

# fit a linear model
#MarkDown4, Week and Fuel_Price are not relevant
res <- lm( Weekly_Sales ~ Store
		+ Dept
#		+ Week
		+ IsHoliday
		+ Type
		+ Temperature
#		+ Fuel_Price
		+ MarkDown1
		+ MarkDown2
		+ MarkDown3
#		+ MarkDown4
		+ MarkDown5
		+ CPI
		+ Unemployment
		+ Seasonality
		, data = dfrm
		,subset = (Week < 144))
#		,subset = (is.na(Weekly_Sales)))

#predict weekly sales
#res <- predict (res, subset(dfrm, is.na(dfrm$Weekly_Sales)), interval='prediction', level=0.99)
dfrm$Weekly_Sales[is.na(dfrm$Weekly_Sales)] <- predict (res, subset(dfrm, is.na(dfrm$Weekly_Sales)))

#preparing the submission file
#Adding a column with store_department_date
dfrm[,"Id"] <- paste(dfrm$Store, dfrm$Dept, format(as.Date(dfrm$Date), "%Y-%m-%d" ), sep = "_")

#save results in a csv file
write.csv(file = "Solution.csv", x = subset(dfrm, Week > 143,  select = c(Id, Weekly_Sales)), row.names=FALSE)


library(h5)
library(ggplot2)
library(reshape2)
library(dplyr)

graphics.off()

rowMax <- function(x) {
    apply(x, 1, function(e) {
          max(e, na.rm=TRUE)
    })
}

rowMin <- function(x) {
    apply(x, 1, function(e) {
          min(e, na.rm=TRUE)
    })
}

rowMedian <- function(x) {
    apply(x, 1, function(e) {
          median(e, na.rm=TRUE)
    })
}

rowCountNA  <- function(x) {
    apply(x, 1, function(e) {
          sum(is.na(e))/length(e)
    })
}

shaveoff  <- function(vec, max_ratio) {
    vec[-tail(order(vec),5)]
}

getResults <- function(f, test_name) {
    packages <- c("julia","octave","matlab","python","scilab")
    max_input_size <- length(list.datasets(f[test_name]["octave"]))
    max_ratio  <- 2.5
    results <- list()
    for (package in packages) {
        number_of_tests  <- length(f[test_name][package]["1"][])
        results[[package]] <- matrix(NA,max_input_size,number_of_tests)
        for (input_size in 1:max_input_size) {
            res <- shaveoff(as.vector(f[test_name][package][toString(input_size)][]),max_ratio)
            results[[package]][input_size,1:length(res)] <- res
        }
    }
    results
}

preparePlot <- function(results) {
    means <- lapply(results, rowMedian)
    mins <- lapply(results, rowMin)
    maxs <- lapply(results, rowMax)

    means.molten <- as.data.frame(melt(means) %>% group_by(L1) %>% mutate(id = row_number()))
    mins.molten <- as.data.frame(melt(mins) %>% group_by(L1) %>% mutate(id = row_number()))
    maxs.molten <- as.data.frame(melt(maxs) %>% group_by(L1) %>% mutate(id = row_number()))

    means.molten["VectorSize"] <- 10^means.molten["id"]

    plot <- ggplot(means.molten, aes(x=VectorSize, y=value, colour=L1))
    plot <- plot + geom_errorbar(aes(ymin=mins.molten["value"], ymax=maxs.molten["value"]), width=.1)
    plot <- plot + scale_y_log10() + scale_x_log10() + geom_point() + geom_line()
    plot <- plot + xlab("Wielkość wektora wejściowego") + ylab("Czas wykonywania procedury [\\si{\\seconds}]")
    plot <- plot + labs(colour="Pakiet obliczeniowy")
    plot
}

test_name <- "conv"

file <- h5file("../tests/results.h5")

results <- getResults(file, test_name)

preparePlot(results)


evaluate <- function(dataset) {
  library(caret) # include library

  dt <- read.table(dataset, header = TRUE, sep="\t")  # load table

  # extract file name, for naming output and rowname
  f_name <- paste0(tools::file_path_sans_ext(dataset))

  # define variable for confusion matrix
  lvs = c("secreted","other")
  actual = factor(dt$y_true, levels = lvs)
  pred = factor(dt$y_pred, levels = lvs)

  # calculate confusion matrix
  eval_indices <- confusionMatrix(pred, actual)

  # convert to tables
  conf_matrix <- as.data.frame(eval_indices$table)
  eval_table <- t(as.data.frame(eval_indices$byClass, row.names = NULL))
  rownames(eval_table) <- f_name

  # ---------- calculate FDR -------------------
  False.Discovery.Rate <- 1 - eval_table[3]
  eval_table <- data.frame(eval_table,False.Discovery.Rate)

  # --------- calculate MCC ----------
  library(mccr)
  mcc_calc <- mccr(dt$mcc_y_true,dt$mcc_y_pred)
  mcc_to_table <- as.data.frame(mcc_calc)
  colnames(mcc_to_table) <- "MCC"

  # merge eval table with MCC
  eval_table <- data.frame(eval_table,mcc_to_table)

  # export tables
  f1 <- write.table(eval_table,file = sprintf("%s_evaluation_table.tsv",f_name),
                    sep="\t",eol = "\n")
  f2 <- write.table(conf_matrix,file = sprintf("%s_confusion_matrix.tsv",f_name),
                    sep ="\t",eol = "\n")

  # return the value
  return(paste(f_name,"evaluation is completed!"))
}


#install.packages(c("MASS"))
library(MASS)

args = commandArgs(trailingOnly=TRUE)
if (length(args)!=8 & length(args)!=10 & length(args)!=12) {
  stop("Usage: Rscript --vanilla Rprogram Project_dir system dev_id func Dmin [Mmax] Nmax [Kmax] [Mstep] Nstep [Kstep] bench_lim", call.=FALSE)
}
project_dir = args[1]
machine = args[2]
dev_id = as.integer(args[3])
func = args[4]
Dmin = as.integer(args[5])

if (length(args)==12){
	Mmax = as.integer(args[6])
	Nmax = as.integer(args[7])
	Kmax = as.integer(args[8])
	Mstep = as.integer(args[9])
	Nstep = as.integer(args[10])
	Kstep = as.integer(args[11])
	bench_lim = as.integer(args[12])

	infile = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_minDim-%d_max-%d-%d-%d_step-%d-%d-%d_lim-%d.log", project_dir, machine, func, dev_id, Dmin, Mmax, Nmax, Kmax, Mstep, Nstep, Kstep, bench_lim)
	gemm_gpu_df <- read.table(infile,  header = FALSE, sep = ",")
	#summary(gemm_gpu_df)

	# Remove very small values from model fitting
	gemm_gpu_df_clean <- subset(gemm_gpu_df, gemm_gpu_df$V1 > 255 & gemm_gpu_df$V2 > 255 & gemm_gpu_df$V3 > 255)

	# V4 = t_Avg ITER, V5 = t_Min ITER, V6 = t_Max ITER
	gemm_gpu_train_set <- (subset(gemm_gpu_df_clean, select=c("V1", "V2", "V3", "V4", "V5", "V6")))
	gemm_gpu_train_set$SqT <- c(I(gemm_gpu_train_set$V1*gemm_gpu_train_set$V2))
	gemm_gpu_train_set$Exec_T <- c(I(gemm_gpu_train_set$V4))

	# The analytic representation model
	analytic_model <-  lm(Exec_T ~SqT:V3 - 1, data = gemm_gpu_train_set)

	# Stepwise regression model. Use the AIC criterion with k = 10 ( normally is 2, but we want a larger 'punishment' for variable addition.
	step_model <- stepAIC(analytic_model, scope = list(upper = ~SqT:V3 + SqT + V1:V3 + V1 + V3 - 1, lower = ~1), direction = "both", k = 10, trace = TRUE) # FALSE

	step_model$anova
	print(summary(step_model))
	pdf_stats = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_minDim-%d_max-%d-%d-%d_step-%d-%d-%d_lim-%d_aic.pdf", project_dir, machine, func, dev_id, Dmin, Mmax, Nmax, Kmax, Mstep, Nstep, Kstep, bench_lim)
	pdf(pdf_stats)
	par(mfrow = c(2, 2))
	plot(step_model)
	dev.off()
	#step_model$coefficients

	outlist <- c(0,0,0,0,0,0,0,0)

	if ('(Intercept)' %in% names(step_model$coefficients)) { if (step_model$coefficients['(Intercept)'] >=0) {outlist[1] = step_model$coefficients['(Intercept)'] }}

	if ('V1' %in% names(step_model$coefficients)) { if (step_model$coefficients['V1'] >=0) {outlist[2] = step_model$coefficients['V1'] }}
	if ('V3' %in% names(step_model$coefficients)) { if (step_model$coefficients['V3'] >=0) {outlist[4] = step_model$coefficients['V3'] }}

	if ('SqT' %in% names(step_model$coefficients)) { if (step_model$coefficients['SqT'] >=0) {outlist[5] = step_model$coefficients['SqT'] }}

	if ('V1:V3' %in% names(step_model$coefficients)) { if (step_model$coefficients['V1:V3'] >=0) {outlist[6] = step_model$coefficients['V1:V3'] }}
	if ('V3:V1' %in% names(step_model$coefficients)) { if (step_model$coefficients['V3:V1'] >=0) {outlist[6] = step_model$coefficients['V3:V1'] }}

	if ("SqT:V3" %in% names(step_model$coefficients)) { if (step_model$coefficients['SqT:V3'] >=0) {outlist[8] = step_model$coefficients["SqT:V3"] }}
	if ("V3:SqT" %in% names(step_model$coefficients)) { if (step_model$coefficients['V3:SqT'] >=0) {outlist[8] = step_model$coefficients["V3:SqT"] }}

} else if (length(args)==10) {
	Mmax = as.integer(args[6])
	Nmax = as.integer(args[7])
	Mstep = as.integer(args[8])
	Nstep = as.integer(args[9])
	bench_lim = as.integer(args[10])

	infile = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_minDim-%d_max-%d-%d_step-%d-%d_lim-%d.log", project_dir, machine, func, dev_id, Dmin, Mmax, Nmax, Mstep, Nstep, bench_lim)
	gemv_gpu_df <- read.table(infile,  header = FALSE, sep = ",")
	#summary(gemv_gpu_df)

	# Remove very small values from model fitting
	gemv_gpu_df_clean <- subset(gemv_gpu_df, gemv_gpu_df$V1 > 255 & gemv_gpu_df$V2 > 255)

	# V3 = t_Avg ITER, V4 = t_Min ITER, V5 = t_Max ITER
	gemv_gpu_train_set <- (subset(gemv_gpu_df_clean, select=c("V1", "V2", "V3", "V4", "V5")))
	gemv_gpu_train_set$Exec_T <- c(I(gemv_gpu_train_set$V3))

	# The analytic representation model
	analytic_model <-  lm(Exec_T ~V1:V2 - 1, data = gemv_gpu_train_set)

	# Stepwise regression model. Use the AIC criterion with k = 10 ( normally is 2, but we want a larger 'punishment' for variable addition.
	step_model <- stepAIC(analytic_model, scope = list(upper = ~V1:V2 + V1 + V2 - 1, lower = ~1), direction = "both", k = 10, trace = TRUE) # FALSE

	step_model$anova
	print(summary(step_model))
	pdf_stats = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_minDim-%d_max-%d-%d_step-%d-%d_lim-%d_aic.pdf", project_dir, machine, func, dev_id, Dmin, Mmax, Nmax, Mstep, Nstep, bench_lim)
	pdf(pdf_stats)
	par(mfrow = c(2, 2))
	plot(step_model)
	dev.off()
	#step_model$coefficients

	outlist <- c(0,0,0,0)

	if ('(Intercept)' %in% names(step_model$coefficients)) { if (step_model$coefficients['(Intercept)'] >=0) {outlist[1] = step_model$coefficients['(Intercept)'] }}

	if ('V1' %in% names(step_model$coefficients)) { if (step_model$coefficients['V1'] >=0) {outlist[2] = step_model$coefficients['V1'] }}
	if ('V2' %in% names(step_model$coefficients)) { if (step_model$coefficients['V2'] >=0) {outlist[3] = step_model$coefficients['V2'] }}

	if ('V1:V2' %in% names(step_model$coefficients)) { if (step_model$coefficients['V1:V2'] >=0) {outlist[4] = step_model$coefficients['V1:V2'] }}
	if ('V2:V1' %in% names(step_model$coefficients)) { if (step_model$coefficients['V2:V1'] >=0) {outlist[4] = step_model$coefficients['V2:V1'] }}

} else if (length(args)==8) {
	Nmax = as.integer(args[6])
	Nstep = as.integer(args[7])
	bench_lim = as.integer(args[8])

	infile = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_min-%d_max-%d_step-%d_lim-%d.log", project_dir, machine, func, dev_id, Dmin, Nmax, Nstep, bench_lim)
	axpy_gpu_df <- read.table(infile,  header = FALSE, sep = ",")
	#summary(gemv_gpu_df)

	# Remove very small values from model fitting
	axpy_gpu_df_clean <- subset(axpy_gpu_df, axpy_gpu_df$V1 > 255 )

	# V2 = t_Avg ITER, V3 = t_Min ITER, V4 = t_Max ITER
	axpy_gpu_train_set <- (subset(axpy_gpu_df_clean, select=c("V1", "V2", "V3", "V4")))
	axpy_gpu_train_set$Exec_T <- c(I(axpy_gpu_train_set$V3))

	# The analytic representation model
	step_model <-  lm(Exec_T ~V1, data = axpy_gpu_train_set)

	step_model$anova
	print(summary(step_model))
	pdf_stats = sprintf("%s/BenchOutputs/%s/cublas%s/EMLR_dev-%d_min-%d_max-%d_step-%d_lim-%d_aic.pdf", project_dir, machine, func, dev_id, Dmin, Nmax, Nstep, bench_lim)
	pdf(pdf_stats)
	par(mfrow = c(2, 2))
	plot(step_model)
	dev.off()
	#step_model$coefficients

	outlist <- c(0,0)

	if ('(Intercept)' %in% names(step_model$coefficients)) { if (step_model$coefficients['(Intercept)'] >=0) {outlist[1] = step_model$coefficients['(Intercept)'] }}

	if ('V1' %in% names(step_model$coefficients)) { if (step_model$coefficients['V1'] >=0) {outlist[2] = step_model$coefficients['V1'] }}

} else {
  stop("Invalid combination of arguments and functions", call.=FALSE)
}

# Store for C use.
outfile_name = sprintf("%s/BenchOutputs/%s/cublas%s/model_dev-%d.out", project_dir, machine, func, dev_id)
outfile<-file(outfile_name)
writeLines(sapply(outlist,toString), outfile)
close(outfile)

quit()


#===============================================================================
#	Test suite for running GBM.
#===============================================================================
library(testthat)
library(cv.models)
library(gbm)

set.seed(12345)

#-------------------------------------------------------------------------------
#	Tests for regression by GBM.
#-------------------------------------------------------------------------------

# GBM regression.
run.gbm.regression <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		n.trees = 10, n.cores = 2
	)
}

# GBM regression without cluster.
run.gbm.regression.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		n.trees = 10, n.cores = 1
	)
}

# GBM regression with grid search.
run.gbm.regression.with.grid <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		grid = list(interaction.depth = c(1, 5), n.minobsinnode = c(1, 10)),
		n.trees = 10, n.cores = 2
	)
}

# GBM regression with grid search without cluster.
run.gbm.regression.with.grid.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		grid = list(interaction.depth = c(1, 5), n.minobsinnode = c(1, 10)),
		n.trees = 10, n.cores = 1
	)
}

# GBM regression with grid search for predct args.
run.gbm.regression.with.grid.predict <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 100, n.cores = 1
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)), n.cores = 2
	)
}

# GBM regression with grid search for predct args without cluster.
run.gbm.regression.with.grid.predict.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 100, n.cores = 1
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)), n.cores = 1
	)
}

# GBM regression with "join".
run.gbm.regression.join <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		n.trees = 10, aggregate.method = "join", n.cores = 2
	)
}

# GBM regression with "join" without cluster.
run.gbm.regression.join.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Petal.Length ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "gaussian", n.trees = 10, n.cores = 1
		),
		n.trees = 10, aggregate.method = "join", n.cores = 1
	)
}
# GBM regression with external formula.
run.gbm.regression.external.formula <- function() {
	f <- Petal.Length ~ .
	cv <- cv.models(
		gbm(
			f, data = iris, weights = Sepal.Width,
			distribution = "gaussian", n.trees = 100
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)), n.cores = 2
	)
}

# GBM regression with external formula without cluster.
run.gbm.regression.external.formula.no.cluster <- function() {
	f <- Petal.Length ~ .
	cv <- cv.models(
		gbm(
			f, data = iris, weights = Sepal.Width,
			distribution = "gaussian", n.trees = 100
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)), n.cores = 1
	)
}

#-------------------------------------------------------------------------------
#	Tests for classification by GBM.
#-------------------------------------------------------------------------------

# GBM classification.
run.gbm.classification <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", n.cores = 2
	)
}

# GBM classification without cluster.
run.gbm.classification.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", n.cores = 1
	)
}

# GBM classification with grid.
run.gbm.classification.with.grid <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		grid = list(interaction.depth = c(1, 5), n.minobsinnode = c(1, 10)),
		n.trees = 10, positive.class = "virginica", n.cores = 2
	)
}

# GBM classification with grid without cluster.
run.gbm.classification.with.grid.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		grid = list(interaction.depth = c(1, 5), n.minobsinnode = c(1, 10)),
		n.trees = 10, positive.class = "virginica", n.cores = 1
	)
}

# GBM classification with grid for prediction.
run.gbm.classification.with.grid.predict <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 100, n.cores = 1
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)),
		n.trees = 10, positive.class = "virginica", n.cores = 2
	)

}

# GBM classification with grid for prediction without cluster.
run.gbm.classification.with.grid.predict.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 100, n.cores = 1
		),
		grid.predict = list(n.trees = c(5, 10, 50, 80)),
		n.trees = 10, positive.class = "virginica", n.cores = 1
	)
}

# GBM classification with "join".
run.gbm.classification.join <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", aggregate.method = "join",
		n.cores = 2
	)
}

# GBM classification with "join" without cluster.
run.gbm.classification.join.no.cluster <- function() {
	cv <- cv.models(
		gbm(
			Species ~ ., data = iris, weights = iris$Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", aggregate.method = "join",
		n.cores = 1
	)
}

# GBM classification with external formula.
run.gbm.classification.external.formula <- function() {
	f <- Species ~ .
	cv <- cv.models(
		gbm(
			f, data = iris, weights = Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", n.cores = 2
	)
}

# GBM classification with external formula without cluster.
run.gbm.classification.external.formula.no.cluster <- function() {
	f <- Species ~ .
	cv <- cv.models(
		gbm(
			f, data = iris, weights = Sepal.Width,
			distribution = "multinomial", n.trees = 10, n.cores = 1
		),
		n.trees = 10, positive.class = "virginica", n.cores = 1
	)
}

#-------------------------------------------------------------------------------
#	Run all tests for GBM.
#-------------------------------------------------------------------------------
context("Test compatibility with gbm")

do.test.that <- function(fun) {
	msg <- deparse(substitute(fun))
	test_that(msg, expect_silent(fun()))
}

do.test.that(run.gbm.regression)
do.test.that(run.gbm.regression.no.cluster)
do.test.that(run.gbm.regression.with.grid)
do.test.that(run.gbm.regression.with.grid.no.cluster)
do.test.that(run.gbm.regression.with.grid.predict)
do.test.that(run.gbm.regression.with.grid.predict.no.cluster)
do.test.that(run.gbm.regression.join)
do.test.that(run.gbm.regression.join.no.cluster)
do.test.that(run.gbm.regression.external.formula)
do.test.that(run.gbm.regression.external.formula.no.cluster)

do.test.that(run.gbm.classification)
do.test.that(run.gbm.classification.no.cluster)
do.test.that(run.gbm.classification.with.grid)
do.test.that(run.gbm.classification.with.grid.no.cluster)
do.test.that(run.gbm.classification.with.grid.predict)
do.test.that(run.gbm.classification.with.grid.predict.no.cluster)
do.test.that(run.gbm.classification.join)
do.test.that(run.gbm.classification.join.no.cluster)
do.test.that(run.gbm.classification.external.formula)
do.test.that(run.gbm.classification.external.formula.no.cluster)


#' rucrdtw: Fast time series subsequence search in R
#'
#' @description Dynamic Time Warping (DTW) methods provide algorithms to optimally map a given time series onto all or part of another time series. The remaining cumulative distance between the series after the alignment is a useful distance metric in time series data mining applications for tasks such as classification, clustering, and anomaly detection. A broad suite of DTW algorithms is implemented in R in the \strong{dtw} package (Giorgino 2009).
#'
#' Calculating a DTW alignment is computationally relatively expensive, and as a consequence DTW is often a bottleneck in time series data mining applications. The UCR Suite (Rakthanmanon et al. 2012) provides a highly optimized algorithm for best-match subsequence searches that avoids unnecessary distance computations and thereby enables fast DTW and Euclidean Distance queries even in data sets containing trillions of observations.
#'
#' The \strong{rucrdtw} package provides R bindings for the UCR Suite. In addition to queries and data stored in text files, rucrdtw also implements methods for queries and/or data that are held in memory as R objects, as well as a method to do fast similarity searches against reference libraries of time series. The following table gives a quick overview over the different methods provided by \code{rucrdtw}:
#'
#' \tabular{lllll}{
#'   \strong{DTW method} \tab \strong{ED method} \tab \strong{data format} \tab \strong{query format} \tab \strong{Use case}\cr
#'   \code{\link{ucrdtw_ff}} \tab \code{\link{ucred_ff}} \tab text file \tab text file \tab data sets that are too large to keep in memory \cr
#'   \code{\link{ucrdtw_fv}} \tab \code{\link{ucred_fv}} \tab text file \tab  numeric vector \tab data sets that are too large to keep in memory\cr
#'   \code{\link{ucrdtw_vv}} \tab \code{\link{ucred_vv}} \tab numeric vector \tab numeric vector \tab data sets that fit into memory\cr
#'   \code{\link{ucrdtw_mv}} \tab \code{\link{ucred_mv}} \tab numeric matrix \tab numeric vector \tab compare query to a set of reference sequences of equal length
#' }
#'
#' Examples of the functionality in this package are provided in the rucrdtw vignette:
#'
#' \code{vignette("using_rucrdtw", package = "rucrdtw")}
#'
#' @name rucrdtw
#' @docType package
#' @references Rakthanmanon, Thanawin, Bilson Campana, Abdullah Mueen, Gustavo Batista, Brandon Westover, Qiang Zhu, Jesin Zakaria, and Eamonn Keogh. 2012. Searching and Mining Trillions of Time Series Subsequences Under Dynamic Time Warping. In Proceedings of the 18th ACM SIGKDD International Conference on Knowledge Discovery and Data Mining, 262-70. ACM. doi:\href{http://dx.doi.org/10.1145/2339530.2339576}{10.1145/2339530.2339576}.
#' @references Giorgino, Toni (2009). Computing and Visualizing Dynamic Time Warping Alignments in R: The dtw Package. Journal of Statistical Software, 31(7), 1-24, doi:\href{http://dx.doi.org/10.18637/jss.v031.i07}{10.18637/jss.v031.i07}.
#' @references UCR Suite Website: \url{http://www.cs.ucr.edu/~eamonn/UCRsuite.html}
#' @seealso \link[dtw]{dtw-package}
NULL


library(tidyverse)

fbnums <- 1:50

fbmap <- function(input, mod1, mod2, exp1, exp2) {
  output <- ""

  if (input %% mod1 == 0) {output <- paste0(output, exp1)}
  if (input %% mod2 == 0) {output <- paste0(output, exp2)}
  if (output == "") {output <- as.character(input)}

  return(output)
}

output <- map_chr(fbnums, ~ fbmap(.x, 3, 5, "Fizz", "Buzz"))
print(output)

R/fizzbuzz(Functional Solution Using map).r