#Simple manhattan plot of the Ods Ratio (OR) of assoc files
#Will output a png plot
#argv[1] Title
#argv[2] Assoc file location

#'qqman' package needs to be installed
#(install.packages("qqman")
library(qqman)

#Able to read given arguments
#args[1]:Title name for the plot
args <- commandArgs(trailing = TRUE)

title <- args[1]
location <- args[2]

#Tell R that output should be .png
png(paste(location, ".OR.png", sep=""), width = 900 , height = 900,  res = 90)

#Load in the table to
theTable <- read.table(location, header = TRUE)
#Plot the table into (X=Chromosone possition, Y=log P value)
manhattan(theTable, p = "OR", logp =FALSE,  ylab="Ods Ratio", genomewideline = FALSE, suggestiveline = FALSE, main = title )


tryNA <- function(x){
    x <- try(x)
    if(inherits(x,'try-error')) return(NA)
    x
}

poLCA <-
    function (formula, data, nclass = 2, maxiter = 1000, graphs = FALSE,
    tol = 0.0000000001, na.rm = TRUE, probs.start = NULL, nrep = 1,
    verbose = TRUE, calc.se = TRUE,impVal=0)
{
    nanProbs <- integer(0)
    starttime <- Sys.time()
    mframe <- model.frame(formula, data, na.action = NULL)
    mf <- model.response(mframe)
    if (any(mf < 1, na.rm = TRUE) | any(round(mf) != mf, na.rm = TRUE)) {
        cat("\n ALERT: some manifest variables contain values that are not\n    positive integers. For poLCA to run, please recode categorical\n    outcome variables to increment from 1 to the maximum number of\n    outcome categories for each variable. \n\n")
        ret <- NULL
    }
    else {
        data <- data[rowSums(is.na(model.matrix(formula, mframe))) ==
            0, ]
        if (na.rm) {
            mframe <- model.frame(formula, data)
            y <- model.response(mframe)
        }
        else {
            mframe <- model.frame(formula, data, na.action = NULL)
            y <- model.response(mframe)
        }
        if (any(sapply(lapply(as.data.frame(y), table), length) ==
            1)) {
            y <- y[, !(sapply(apply(y, 2, table), length) ==
                1)]
            cat("\n ALERT: at least one manifest variable contained only one\n    outcome category, and has been removed from the analysis. \n\n")
        }
        y[is.na(y)] <- 0

        x <- model.matrix(formula, mframe)
        N <- nrow(y)
        J <- ncol(y)
        K.j <- t(matrix(apply(y, 2, max)))
        R <- nclass
        S <- ncol(x)
        if (S > 1) {
            calc.se <- TRUE
        }
        eflag <- FALSE
        probs.start.ok <- TRUE
        ret <- list()
        if (R == 1) {
            ret$probs <- list()
            for (j in 1:J) {
                ret$probs[[j]] <- matrix(NA, nrow = 1, ncol = K.j[j])
                for (k in 1:K.j[j]) {
                  ret$probs[[j]][k] <- sum(y[, j] == k)/sum(y[,
                    j] > 0)
                }
            }
            ret$probs.start <- ret$probs
            ret$P <- 1
            ret$posterior <- ret$predclass <- prior <- matrix(1,
                nrow = N, ncol = 1)
            ret$llik <- sum(log(poLCA:::poLCA.ylik.C(poLCA:::poLCA.vectorize(ret$probs),
                y)))
            if (calc.se) {
                se <- poLCA:::poLCA.se(y, x, ret$probs, prior, ret$posterior)
                ret$probs.se <- se$probs
                ret$P.se <- se$P
            }
            else {
                ret$probs.se <- NA
                ret$P.se <- NA
            }
            ret$numiter <- 1
            ret$probs.start.ok <- TRUE
            ret$coeff <- NA
            ret$coeff.se <- NA
            ret$coeff.V <- NA
            ret$eflag <- FALSE
            if (S > 1) {
                cat("\n ALERT: covariates not allowed when nclass=1; will be ignored. \n \n")
                S <- 1
            }
        }
        else {
            if (!is.null(probs.start)) {
                if ((length(probs.start) != J) | (!is.list(probs.start))) {
                  probs.start.ok <- FALSE
                }
                else {
                  if (sum(sapply(probs.start, dim)[1, ] == R) !=
                    J)
                    probs.start.ok <- FALSE
                  if (sum(sapply(probs.start, dim)[2, ] == K.j) !=
                    J)
                    probs.start.ok <- FALSE
                  if (sum(round(sapply(probs.start, rowSums),
                    4) == 1) != (R * J))
                    probs.start.ok <- FALSE
                }
            }
            ret$llik <- -Inf
            ret$attempts <- NULL
            for (repl in 1:nrep) {
                error <- TRUE
                firstrun <- TRUE
                probs <- probs.init <- probs.start
                while (error) {
                  error <- FALSE
                  b <- rep(0, S * (R - 1))
                  prior <- poLCA:::poLCA.updatePrior(b, x, R)
                  if ((!probs.start.ok) | (is.null(probs.start)) |
                    (!firstrun) | (repl > 1)) {
                    probs <- list()
                    for (j in 1:J) {
                      probs[[j]] <- matrix(runif(R * K.j[j]),
                        nrow = R, ncol = K.j[j])
                      probs[[j]] <- probs[[j]]/rowSums(probs[[j]])
                    }
                    probs.init <- probs
                  }
                  vp <- poLCA:::poLCA.vectorize(probs)
                  iter <- 1
                  llik <- matrix(NA, nrow = maxiter, ncol = 1)
                  llik[iter] <- -Inf
                  dll <- Inf
                  while ((iter <= maxiter) & (dll > tol) & (!error)) {
                    iter <- iter + 1
                    rgivy <- poLCA:::poLCA.postClass.C(prior, vp, y)
                    vp$vecprobs <- poLCA:::poLCA.probHat.C(rgivy, y,
                      vp)
                    if (S > 1) {
                      dd <- poLCA:::poLCA.dLL2dBeta.C(rgivy, prior, x)
                      b <- b + ginv(-dd$hess) %*% dd$grad
                      prior <- poLCA:::poLCA.updatePrior(b, x, R)
                    }
                    else {
                      prior <- matrix(colMeans(rgivy), nrow = N,
                        ncol = R, byrow = TRUE)
                    }
                    nanProbs <- which(is.nan(vp$vecprobs))
                    if(length(nanProbs)){
                        vp$vecprobs[nanProbs] <- impVal
                        if(verbose) message(paste('Replacing NaN probs with',impVal))
                    }
                    llik[iter] <- tryNA(sum(log(rowSums(prior * poLCA:::poLCA.ylik.C(vp,
                      y)))))
                    dll <- llik[iter] - llik[iter - 1]
                    if (is.na(dll)) {
                      error <- TRUE
                    }
                    else if ((S > 1) & (dll < -0.0000001)) {
                      error <- TRUE
                    }
                  }
                  if (!error) {
                    if (calc.se) {
                      se <- poLCA:::poLCA.se(y, x, poLCA:::poLCA.unvectorize(vp),
                        prior, rgivy)
                    }
                    else {
                      se <- list(probs = NA, P = NA, b = NA,
                        var.b = NA)
                    }
                  }
                  else {
                    eflag <- TRUE
                  }
                  firstrun <- FALSE
                }
                ret$attempts <- c(ret$attempts, llik[iter])
                #ret$fullllik <- llik
                if (llik[iter] > ret$llik) {
                  ret$llik <- llik[iter]
                  ret$probs.start <- probs.init
                  ret$probs <- poLCA:::poLCA.unvectorize(vp)
                  ret$probs.se <- se$probs
                  ret$P.se <- se$P
                  ret$posterior <- rgivy
                  ret$predclass <- apply(ret$posterior, 1, which.max)
                  ret$P <- colMeans(ret$posterior)
                  ret$numiter <- iter - 1
                  ret$probs.start.ok <- probs.start.ok
                  if (S > 1) {
                    b <- matrix(b, nrow = S)
                    rownames(b) <- colnames(x)
                    rownames(se$b) <- colnames(x)
                    ret$coeff <- b
                    ret$coeff.se <- se$b
                    ret$coeff.V <- se$var.b
                  }
                  else {
                    ret$coeff <- NA
                    ret$coeff.se <- NA
                    ret$coeff.V <- NA
                  }
                  ret$eflag <- eflag
                }
                if (nrep > 1 & verbose) {
                  cat("Model ", repl, ": llik = ", llik[iter],
                    " ... best llik = ", ret$llik, "\n", sep = "")
                  flush.console()
                }
            }
        }
        names(ret$probs) <- colnames(y)
        if (calc.se) {
            names(ret$probs.se) <- colnames(y)
        }
        ret$npar <- (R * sum(K.j - 1)) + (R - 1)
        if (S > 1) {
            ret$npar <- ret$npar + (S * (R - 1)) - (R - 1)
        }
        ret$aic <- (-2 * ret$llik) + (2 * ret$npar)
        ret$bic <- (-2 * ret$llik) + (log(N) * ret$npar)
        ret$Nobs <- sum(rowSums(y == 0) == 0)
        if (all(rowSums(y == 0) > 0)) {
            ret$Chisq <- NA
            ret$Gsq <- NA
            ret$predcell <- NA
        }
        else {
            compy <- poLCA:::poLCA.compress(y[(rowSums(y == 0) == 0),
                ])
            datacell <- compy$datamat
            rownames(datacell) <- NULL
            freq <- compy$freq
            if (!na.rm) {
                fit <- matrix(ret$Nobs * (poLCA:::poLCA.ylik.C(poLCA:::poLCA.vectorize(ret$probs),
                  datacell) %*% ret$P))
                ret$Chisq <- sum((freq - fit)^2/fit) + (ret$Nobs -
                  sum(fit))
            }
            else {
                fit <- matrix(N * (poLCA:::poLCA.ylik.C(poLCA:::poLCA.vectorize(ret$probs),
                  datacell) %*% ret$P))
                ret$Chisq <- sum((freq - fit)^2/fit) + (N - sum(fit))
            }
            ret$predcell <- data.frame(datacell, observed = freq,
                expected = fit)
            ret$Gsq <- 2 * sum(freq * log(freq/fit))
        }
        y[y == 0] <- NA
        ret$y <- data.frame(y)
        ret$x <- data.frame(x)

        if(length(nanProbs)){
            vp$vecprobs[nanProbs] <- NaN
            ret$probs <- poLCA:::poLCA.unvectorize(vp)
            names(ret$probs) <- colnames(y)
        }

        for (j in 1:J) {
            rownames(ret$probs[[j]]) <- paste("class ", 1:R,
                ": ", sep = "")
            if (is.factor(data[, match(colnames(y), colnames(data))[j]])) {
                lev <- levels(data[, match(colnames(y), colnames(data))[j]])
                colnames(ret$probs[[j]]) <- lev
                ret$y[, j] <- factor(ret$y[, j], labels = lev)
            }
            else {
                colnames(ret$probs[[j]]) <- paste("Pr(", 1:ncol(ret$probs[[j]]),
                  ")", sep = "")
            }
        }
        ret$N <- N
        ret$maxiter <- maxiter
        ret$resid.df <- min(ret$N, (prod(K.j) - 1)) - ret$npar
        class(ret) <- "poLCA"
        if (graphs)
            plot.poLCA(ret)
        if (verbose)
            poLCA:::print.poLCA(ret)
        ret$time <- Sys.time() - starttime

    }
    ret$call <- match.call()
    return(ret)
}

### automatically orders the classes by prevalence
poLCAord <-
    function (formula, data, nclass = 2, maxiter = 1000, graphs = FALSE,
    tol = 0.0000000001, na.rm = TRUE, probs.start = NULL, nrep = 1,
    verbose = TRUE, calc.se = TRUE,ordVar=NULL){

        mm <- match.call()
        mm <- as.list(mm)
        mm[[1]] <- NULL
        mm$ordVar <- NULL
        mod <- do.call("poLCA",mm)

        pp <- if(!is.null(ordVar)) mod$probs[[ordVar]][,1] else mod$P
        if(length(pp)>length(unique(pp))){
            warning(paste0("Ties in ", ordVar," ordering by prevalence"))
            pp <- mod$P
        }
        ord <- order(pp,decreasing=TRUE)

        probs.start.new <- poLCA::poLCA.reorder(mod$probs.start,ord)

        mm$probs.start <- probs.start.new
        mm$nrep <- 1

        do.call("poLCA",mm)
    }


# fix problem of raw length changing analysis

books <- books %>%
  mutate(bookLength = nchar(text))

words <- books %>%
  unnest_tokens(word, text)

words %>%
  filter(word %in% sentiments$word) %>%
  count(title, author, bookLength) %>%
  mutate(EmoRatio = n / bookLength) %>%
  arrange(desc(EmoRatio)) %>%
  View()

# analyze happiest books

happy_books <- words %>%
  filter(word %in% sentiments$word) %>%
  count(title, author, bookLength) %>%
  mutate(EmoRatio = n / bookLength) %>%
  arrange(EmoRatio) %>%
  slice(1:9)

ggplot(books_sentiment %>% filter(title %in% happy_books$title),
       aes(index, sentiment, fill = title)) +
  geom_bar(stat = "identity", show.legend = FALSE) +
  facet_wrap(~title, ncol = 3, scales = "free_x")


checkPangram <- function(sentence){
  my.letters <- tolower(unlist(strsplit(sentence, "")))
  is.pangram <- all(letters %in% my.letters)

  if (is.pangram){
    cat("\"", sentence, "\" is a pangram! \n", sep="")
  } else {
    cat("\"", sentence, "\" is not a pangram! \n", sep="")
  }
}


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Thu Feb 04 13:35:41 2010
########################################################
#Shared functions

#Group dates into intervals
cutDates <- function(df, dates, hack = 0) {
  DateMid <- as.Date(format(df$Date, "%Y%m15"),
                              "%Y%m%d") + hack
  vec <- c(DateMid[1], dates, DateMid[length(DateMid)] + 1000)
  as.numeric(as.factor(cut(DateMid, vec)))
}

#Get rid of the full name of the states (eg: Veracruz de
#Ignacio de la Llave changes to Veracruz
cleanNames <- function(df, varname = "County"){
  df[[varname]] <- gsub("* de .*","", df[[varname]])
  df[[varname]]
}

monthSeq <- function(st, len){
  #start <- as.Date(st)
  #next.mon <- seq(start, length = len, by='1 month')
  #next.mon - 1
  seq(as.Date(st), length = len, by='1 month')
}

monthlyPop <- function() {
  pop <- read.csv("conapo-pop-estimates/conapo-states.csv")
  pop2 <- data.frame(year = rep(1990:2008, each = 12),
                   month = rep(1:12))
  pop2$Monthly.Pop[pop2$month == 6] <- unlist(pop[33,2:ncol(pop)])
  pop2$Monthly <- na.spline(pop2$Monthly.Pop, na.rm=FALSE)
  pop2
}

addHom <- function(df, pop) {
  hom.st <- ddply(df, .(Month.of.Murder, Year.of.Murder),
                 function(df) sum(df$Total.Murders))
  hom.st <- hom.st[order(hom.st$Year.of.Murder,
                         hom.st$Month.of.Murder),]
  pop$murders <- hom.st$V1
  pop$rate <- (pop$murders / pop$Monthly) * 100000 * 12
  start <- as.Date("1990/01/15")
  next.mon <- seq(start, length = 12*19, by='1 month')
  period <- next.mon - 1
  pop$date <- period
  pop
}

addTrend <- function(df){
  hom.ts <- ts(df$rate, start=1990, freq = 12)
  hom.stl <- stl(hom.ts, "per")
  cbind(df, data.frame(hom.stl$time.series))
}

cleanHom <-  function(df) {
  df <- subset(df, Code  == "#NAME?" &
              Year.of.Murder != "Total" &
              Year.of.Murder != "No especificado" &
              Month.of.Murder != "Total" &
              Month.of.Murder != "No especificado" &
              County != "Extranjero"
               )
  df$Year.of.Murder <- as.numeric(gsub('[[:alpha:]]', '',
                                        df$Year.of.Murder))
  df <- subset(df, Year.of.Murder >= 1990)
  df$County <- iconv(df$County, "windows-1252", "utf-8")
  col2cvt <- 5:ncol(df)
  df[is.na(df)] <- 0
  df$Total.Murders <- apply(df[ , col2cvt], 1, sum)
  df$Month.of.Murder <- factor(df$Month.of.Murder)
  #The months are in a weird order, so 04=Abril, etc.
  levels(df$Month.of.Murder) <- c("04","08","12","01","02","07","06","03","05","11","10","09")
  df
}

addMonths <- function(df){
  states <- unique(factor(df$County))
  start <- as.Date("1990/1/15")
  next.mon <- seq(start, length=12*19, by='1 month')
  period <- next.mon
  dates.df <- data.frame(Date = factor(rep(period,
                                    each = 32)),
                         County = states)
  dates <- strptime(as.character(dates.df$Date), "%Y-%m-%d")
  dates.df$Month.of.Murder <- dates$mon + 1
  dates.df$Year.of.Murder <- dates$year + 1900
  df$Month.of.Murder <- as.numeric(as.character(df$Month.of.Murder))
  df <- merge(dates.df, df,
                   by = c("Month.of.Murder",
                          "Year.of.Murder", "County"),
                   all.x = TRUE)
  df[is.na(df)] <- 0
  df
}


steadman_outdoor_index <- function(t, rh, wind, rshort, sunelev) {
    .Call('biometeoR_steadman_outdoor_sun', PACKAGE = 'biometeoR', t, rh, wind, rshort, sunelev)
}


#' Simulate a dyad
#' @param rates Numeric vector. Vector of rates
#' @param mimicy Numeric vector. proportion of mimicry (likelihood).
#' @param last.bite Numeric scalar. Time of last bite.
#' @export
simulate_dyad <- function(
  rates     = c(10, 15),
  mimicy    = c(.1, .5),
  last.bite = stats::runif(1, 1, 2)
) {

  structure(
    .simulate_dyad(rates, mimicy, last.bite),
    class = "bite_dyad"
  )
}

#' Plotting method
#' @param x An object of class `bite_dyad`
#' @param y Ignored.
#' @param ... Ignored.
#' @export
plot.bite_dyad <- function(x, y = NULL, ...) {

  # Computing time range
  op <- graphics::par(mar = rep(0, 4))
  on.exit(graphics::par(op))
  ran <- range(x[[1]], x[[2]])

  graphics::plot.new()
  graphics::plot.window(xlim = ran, ylim = c(.5, 2.5))

  xstart <- diff(ran)*.1+ran[1]

  cols <- c("steelblue", "tomato")
  for (i in 1:2) {
    graphics::text(x=xstart, y = i + .1, labels = paste("Subject", i))

    for (k in 1:length(x[[i]]))
      graphics::text(
        x = x[[i]][k],
        y = i,
        labels = substitute(t[i]^j, list(i=i, j=k)),
        pos = 1, offset = (k %% 2)*.75 + 1
        )

    lines(
      y = rep.int(i, length(x[[i]])), x = x[[i]], col=cols[i],
      type = "b",
      lwd=2
      )
  }

#
#
#   text(x=xstart, y = 2.1, labels = "Subject 2")
#   lines(y = rep.int(2, length(x[[2]])), x = x[[2]], col="tomato", type = "b",
#         lwd=2)

}


# context("Checking data-management methods")

data(fakeexperiment)
data(faketree)

# As phylo methods -------------------------------------------------------------
# test_that("As phylo conversion and methods", {

  tree <- as.phylo(faketree)
  ans <- new_aphylo(tip.annotation = fakeexperiment[,-1], tree = tree)

  expect_silent(print(ans))
  expect_equal(class(as.phylo(ans)), "phylo")
  expect_true(is.null(plot(ans)))
  expect_silent(summary(as.phylo(ans)))
  expect_silent(summary(raphylo(10, P=4)))
# })

# Conversion -------------------------------------------------------------------
# test_that("Can return to the original labeling", {
  ans0  <- faketree
  phylo <- as.phylo(ans0)
  ans1  <- phylo$edge

  ans1[] <- with(phylo, c(tip.label, node.label))[ans1[]]

  expect_equivalent(ans0, ans1)
# })


##############################################################################
# Negbin model processing functions
##############################################################################

#' Run negbin model for each formula specified in formlist
#' @param formlist List of formula objects
#' @param data Data on which you wish to run the model(s)
#' @return List of model objects returned by glm.nb
#' @importFrom MASS glm.nb
#' @export
runMod <- function(formlist, data){
	out <- lapply(formlist, function(x) glm.nb(x, data))
	names(out) <- names(formlist)
	return(out)
}

#' Build list of fitted values (with CHR/BIN names) for each model
#' @param modlist list containing model objects
#' @param data Data to be fitted
#' @importFrom stats fitted.values
#' @return list of fitted values
#' @export
getFits <- function(modlist, data){
	out <- lapply(modlist,
		function(x){
			y <- fitted.values(x)
			names(y) <- paste0(data$CHR, ".", data$BIN)
			y
		})
	names(out) <- names(modlist)
	return(out)
}

#' Build list of dataframes for each model
#' @param fitlist list containing fitted values
#' @param data Data to be fitted
#' @return list of fitted values
#' @export
buildDF <- function(fitlist, data){
	out <- lapply(fitlist,
		function(x){
			data.frame(CHR, Category2=cat1, BIN,
				exp=x,
				obs=data$obs,
				# res=names(fitlist),
				stringsAsFactors=F)
		}
	)
	names(out) <- names(fitlist)
	return(out)
}

#' Compute standard error for correlations
#' @param corval correlation
#' @param ct count?
#' @return list of fitted values
#' @export
corSE <- function(corval, ct){
	sqrt((1-corval^2)/(ct-2))
}


library(ggplot2)

load_results <- function(path= "./synthetic/"){

  if(!dir.exists("./synthetic")){
    stop("The results folder was not found! The raw paper results are available at https://www.dropbox.com/sh/xurs5z6z3uzj6vs/AAC8fzABOvkFaWF9sZFuS57Ua?dl=0")
  }

  vf <- list.files(path)
  all<- NULL
  for(i in vf){
    print(i)
    x <- readRDS(paste0(path,i))
    all <- rbind(all, x)

  }
  return(all)
}

#+++++++++++++++++++++++++++++++ Plot the error when MTe vary for a given MTr ++++++++++++++++++++++++++++++++++
# Used to get the plots of Figure 3
plot_synthetic <- function(MTr){

  all <- readRDS("./all_syn_results_icdm21.rds")
  #all <- load_results("./synthetic/")

  vcol <- c("dodgerblue2",
            "lightsalmon2",
            "lightsteelblue",
            "plum3",
            "pink3",
            "olivedrab3",
            "navajowhite2",
            "lightyellow4",
            "indianred",
            "green3","#597DBE", "#76BF72", "#AF85BE", "#C76E6E"
  )
  aux2 <- all[all$Qnt%in%c("MS", "DyS-TS", "PACC", "HDy-LP", "X", "MAX", "T50", "SORD", "ACC", "CC", "PCC", "MS2", "SMM"),]
  aux2 <- aux2[aux2$MFtr==MTr,]
  aux2 <- aggregate(as.numeric(as.vector(aux2$MAE)), by=list(aux2$Qnt, aux2$MFte), FUN=mean)

  names(aux2) <- c("Quantifier", "MFte", "MAE")
  a1 <- aux2[,-2]
  qn <- unique(a1$Quantifier)
  at <- NULL
  for(qi in qn){
    at <- cbind(at, a1[a1$Quantifier==qi,2])
  }
  at <- apply(at, 2, as.numeric)
  at <- as.matrix(at)
  colnames(at) <- qn

  p1 <- ggplot(data = aux2, aes(x=MFte,y=MAE, group= Quantifier, linetype=Quantifier))+
    geom_vline(xintercept = MTr*20, linetype="dashed",
               color = "black", size=3.5) +
    geom_line(size=5, aes(color=Quantifier), alpha=0.7)+
    geom_point(size=7, aes(shape=Quantifier, color=Quantifier), stroke=2)+
    scale_shape_manual(values=c(0:14))+
    scale_color_manual(values=vcol)+
    scale_x_discrete(breaks = seq(0.05,0.95, length.out = 10))+
    ylab("MAE") +
    xlab("MTe") +
    guides(col = guide_legend(nrow = 5, byrow = TRUE))+
    theme_bw()+
    theme(
      plot.background = element_blank()
      ,text = element_text(size=50)
      ,legend.position = "top"
      ,legend.title = element_blank()
      ,panel.border = element_rect(size = 1.5)
      ,axis.line.x = element_line(size=1)
      ,axis.ticks = element_line(size = 1),
      plot.margin = unit(c(.5,0.1,0.1,0.1), "cm")
    )
    #draws x and y axis line
    theme(axis.line = element_line(color = 'black'))
  print(p1)
  return(p1)
}

setwd(dirname(parent.frame(2)$ofile))
#uncomment the next lines to get the plots presented in Figure 3
#plot_synthetic(0.05)
#plot_synthetic(0.25)
#plot_synthetic(0.5)
#plot_synthetic(0.75)


plotdfall <- function(df, xx, size=0.01, type='b', legendloc='topleft') {
    ## plots every parameter in df as a function of x on single plot
    ## df      = dataframe
    ## xx      = x-axis variable to be specified in quotes
    ## size    = datapoint size (0.01 default to not see points but still get line color)
    ## type    = 'p' for points
    ##         = 'l' for lines     <-- creates a single line so only black
    ##         = 'b' for both      <-- same as above

    ## determine location of xx in the dataframe
    xxcol <- which(grepl(xx, names(df)))  ## xx column
    xx1   <- df[, xxcol]                  ## xx values

    ## first sort the data by xx in case want lines
    df <- df[order(df[xxcol]),]

    ## use melt to create new df with columns: index, series, and value
    ## where every column of old df is now in column value with the
    ## name of the column in series
    df <- reshape2::melt(df, id.vars=xx, variable.name='series')

    ## need to plot points and not just line to get color using df$series
    ## do not actually want points, so plotting them small with cex=0.01
    plot(df[1], df$value, col=df$series,
         cex=size, lty=1, type=type,
         xlab=xx, ylab='value')
    grid(col='grey70')
    legend(legendloc,
           legend = unique(df$series),
           col    = 1:length(df$series),
           lty    = 1)
}

#plotdfall(mtcars, 'mpg', legendloc='topright', type='b')
# a <- seq(10,1,-1)
# b <- seq(21,30)
# c <- seq(41,50)
# df <- data.frame(a,b,c)
# plotdfall(df, 'a')

#d <- rep('type1', 5)
#d2 <- rep('type2', 5)
#d <- c(d, d2)
#df <- data.frame(a,b,c,d)

#plotspace(1,2)
#plotdfall(mtcars, 'mpg', legendloc='topright', type='b')
#df <- select(mtcars, mpg, hp)
#plotdfall(df, 'mpg', legendloc='topright', type='b')

## out <- equityget(c('SPY', 'IWM', 'EFA', 'AGG', 'SHV'), from='1995-01-01', period='years')
## twr <- out$twr
## twrdf <- as.data.frame(twr)
## twrdf$date <- as.Date( rownames(twrdf) )
## plotdfall(twrdf, 'date', size=1)


##############################
# CREATION OF PIE CHARTS FOR INVERSION FREQUENCIES
##############################

###########################
#df <- data.frame(status = c("N/N", "N/I", "I/I"), freq = c(34, 47.9, 17.1))
#bp <- ggplot(df, aes(x="", y=freq, fill=status)) + geom_bar(width = 1, stat = "identity")
#pie <- bp + coord_polar("y", start=0)

#pie + geom_text(aes(y = freq/3 + c(0, cumsum(freq)[-length(freq)]),label = paste(status,percent(freq/100), sep = ": ")), size=6) +
#  ggtitle("inv8_001 - EUR") +
#  theme_minimal() +
#  theme(legend.position="none", axis.title.x=element_blank(), axis.title.y=element_blank()) +
#  theme(plot.title = element_text(size = 20, face="bold"))

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

library(plotrix)
library(maps)
library(stringr)
library(lattice)

setwd("/scratch/itolosana/Rdata/")
load(file = "Allpop_invstatus.Rdata")

# Select data for an inversion (one plot per inversion)
inv8 <- invstatus_allpop[,c(1:2, 3)] # need to change this, to better select columns
inv8$N <- str_count(inv8$inv8_001, "N")
inv8$I <- str_count(inv8$inv8_001, "I")

#groups <- unique(inv8$pop)
############################################ CAMBIAR SUPERPOP DE VIETNAM PQ SON EAS NO SAS
groups <- c("GBR", "FIN", "CHS", "PUR", "CDX", "CLM", "IBS", "PEL", "PJL", "KHV", "ACB",
            "GWD", "ESN", "BEB", "MSL", "STU", "ITU", "CEU", "YRI", "CHB", "JPT", "LWK",
            "ASW", "MXL", "TSI", "GIH")

lat <- c(55, 60, 33.5, 20, 23, 4, 40, -13, 38, 10, 13,
         19, 4, 27, 7, 5, 18, 48, 18, 44, 35.6, -4,
         36, 19.4, 40, 26.5)
lon <- c(-7, 24.5, 113, -71, 104, -73, -6, -76, 75, 106.8, -57.6,
         -15.3, 10, 90.4, -7, 82, 79, 4.5, 15, 121, 139.7, 39.7,
         -97, -99, 15.5, 69)

leglat <- c(60, 60, 28, 29.5, 19, 4, 40, -13, 45, -1, 6,
            19, -7, 36, -1, -5, 14, 57, 18, 53, 35.6, -15,
            46, 19.4, 40, 28)
leglon <- c(-19, 38, 125, -76, 117.5, -87, -19, -88, 65, 112, -46,
            -30, 15, 93, -17, 86, 67, 10, 30, 130, 153, 39.7,
            -103, -114, 29, 57)

Nfreq <- lapply(groups, function(x){
  Ntot <- sum(inv8[inv8$pop==x,]$N)
  Itot <- sum(inv8[inv8$pop==x,]$I)
  freq <- Ntot/(Ntot+Itot)
  freq
})

Nfreq <- as.numeric(Nfreq)
df <- data.frame(groups, lat, lon, leglat, leglon, Nfreq)

layout(matrix(1:2, nrow=2, ncol=2), widths = c(1,0.5),
       heights = c(3, 1), respect = FALSE)
par(mar=c(3,4.5,2,4.5))

map("world", col="grey90", border=0, fill=TRUE)

lapply(unique(inv8[inv8$superpop=="AFR",]$pop), function(x) {floating.pie(df[groups==x,3],df[groups==x, 2],c((100*(df[groups==x, 6])+0.0001),100-(100*df[groups==x, 6])),r=6,
                                                                          col=c("goldenrod3","yellow1"))
                                                              text(df[groups==x,5],df[groups==x,4], labels = x, font = 2, cex=0.7,lwd=1)})
lapply(unique(inv8[inv8$superpop=="AMR",]$pop), function(x) {floating.pie(df[groups==x,3],df[groups==x, 2],c((100*(df[groups==x, 6])+0.0001),100-(100*df[groups==x, 6])),r=6,
                                                                          col=c("darkred","brown1"))
                                                              text(df[groups==x,5],df[groups==x,4], labels = x, font = 2, cex=0.7,lwd=1)})
lapply(unique(inv8[inv8$superpop=="EAS",]$pop), function(x) {floating.pie(df[groups==x,3],df[groups==x, 2],c((100*(df[groups==x, 6])+0.0001),100-(100*df[groups==x, 6])),r=6,
                                                                          col=c("darkgreen","chartreuse2"))
                                                              text(df[groups==x,5],df[groups==x,4], labels = x, font = 2, cex=0.7,lwd=1)})
lapply(unique(inv8[inv8$superpop=="EUR",]$pop), function(x) {floating.pie(df[groups==x,3],df[groups==x, 2],c((100*(df[groups==x, 6])+0.0001),100-(100*df[groups==x, 6])),r=6,
                                                                          col=c("dodgerblue4","darkslategray2"))
                                                              text(df[groups==x,5],df[groups==x,4], labels = x, font = 2, cex=0.7,lwd=1)})
lapply(unique(inv8[inv8$superpop=="SAS",]$pop), function(x) {floating.pie(df[groups==x,3],df[groups==x, 2],c((100*(df[groups==x, 6])+0.0001),100-(100*df[groups==x, 6])),r=6,
                                                                          col=c("purple4","plum"))
                                                              text(df[groups==x,5],df[groups==x,4], labels = x, font = 2, cex=0.7,lwd=1)})

par(xpd=TRUE)

pos <- legend(-46, -80, legend=c("Frequency of NI","Frequency of I"), bty = "n", cex = 1.3)

points(x=rep(pos$text$x, times=2) - c(7,7),
       y=rep(pos$text$y, times=2),
       pch=rep(21, times=2), bg = rep(c("goldenrod3","yellow1"), times=2), col=rep("black", times=2), cex = 1.5)
points(x=rep(pos$text$x, times=2) - c(17,17),
       y=rep(pos$text$y, times=2),
       pch=rep(21, times=2), bg=rep(c("darkred","brown1"), times=2), col=rep("black", times=2), cex = 1.5)
points(x=rep(pos$text$x, times=2) - c(27,27),
       y=rep(pos$text$y, times=2),
       pch=rep(21, times=2), bg=rep(c("darkgreen","chartreuse2"), times=2), col=rep("black", times=2), cex = 1.5)
points(x=rep(pos$text$x, times=2) - c(37,37),
       y=rep(pos$text$y, times=2),
       pch=rep(21, times=2), bg=rep(c("dodgerblue4","darkslategray2"), times=2), col=rep("black", times=2), cex = 1.5)
points(x=rep(pos$text$x, times=2) - c(47,47),
       y=rep(pos$text$y, times=2),
       pch=rep(21, times=2), bg=rep(c("purple4","plum"), times=2), col=rep("black", times=2), cex = 1.5)

title(main="Inversion frequencies: inv8_001", cex.main = 2, font.main= 2)

dev.copy(pdf,'inv8_freq.pdf')
dev.off()

floating.pie(108.9,19.2,c(Nfreq*100,100-(Nfreq*100)),r=5,col=c("blue","lightsteelblue2"))
text(-24,56,expression(bold("FIN")),cex=0.8,lwd=1)

par(xpd=TRUE)

text(-180,120, "a)", cex=2, font=2)
text(-180,-120, "b)", cex=2, font=2)

legend(120, 120, c("Frequency of NI", "Frequency of I"), col=c("blue","lightsteelblue2"), pch=16)

dat <- as.data.frame.matrix(tt)
res$li["MKK", "Axis1"] <- 0.45
res$li["LWK", "Axis2"] <- -0.1
res$li["CHD", "Axis2"] <- 0.1
res$li["CHD", "Axis1"] <- 0.125

s.label(res$li, clab = 1.4, lab = rownames(dat), xlim=c(-1,0.5), ylim=c(-0.4, 0.4))
par(xpd=TRUE)
res$co["X2","Comp1"] <- 0.18 # asthetical purposes
res$co["X2","Comp2"] <- 0.05 # asthetical purposes
for (i in 1:nrow(res$li))
{
  text(res$co[i,1], res$co[i,2], ll[i], cex=2, col="red")
}


#' dewpoint
#'
#' Computes the dewpoint temperature in degC   following different computational schemes defined by formula of saturation pressure estimation
#' ("NOAA","Sonntag","Paroscientific").
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Air Relative humidity in percentage.
#' @param formula character  Default is "NOAA".
#' @return dewpoint
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

dewpoint=function(t,rh,formula="NOAA") {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         if ( length(formula)==1) {formula=rep(formula,length(t))}
                         ct$assign("formula", as.array(formula))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=dewpoint(t[i],rh[i],formula[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(Seurat)
library(SeuratDisk)
library(dplyr)
library(cowplot)
library(argparse)
library(aricode)
library(reticulate)
reticulate::use_python("python")

print_memory_usage <- function() {
    library(reticulate)
    py_run_string('import psutil; pmem = psutil.Process().memory_info(); print(pmem); rss_mb = pmem.rss/1024')
    return(py$rss_mb)
}

parser <- ArgumentParser()
parser$add_argument("--h5seurat-path", type = "character", help = "path to the h5seurat file to be processed")
parser$add_argument("--resolutions", type = "double", nargs = "+", default = c(0.02, 0.03, 0.04, 0.05, 0.08, 0.1, 0.2, 0.25, 0.3, 0.4), help = "resolution of leiden/louvain clustering")
parser$add_argument("--subset-genes", type = "integer", default = 3000, help = "number of features (genes) to select, 0 for don't select")
parser$add_argument("--n-pcs", type = "integer", default = 30, help = "number of pcs to use during integration")
parser$add_argument("--no-eval", action = "store_true", help = "do not eval")
parser$add_argument("--reference", action = "store_true", help = "use the largest batch as reference")
parser$add_argument('--ckpt-dir', type = "character", help='path to checkpoint directory', default = file.path('..', 'results'))
parser$add_argument("--seed", type = "integer", default = -1, help = "random seed.")

args <- parser$parse_args()

if (args$seed >= 0) {
    set.seed(args$seed)
}

library(reticulate)
reticulate::use_python("python")
matplotlib <- import("matplotlib")
matplotlib$use("Agg")
sc <- import("scanpy")
sc$settings$set_figure_params(
    dpi=120,
    dpi_save=250,
    facecolor="white",
    fontsize=10,
    figsize=c(10, 10)
)

dataset_str <- basename(args$h5seurat_path)
dataset_str <- substring(dataset_str, 1, nchar(dataset_str) - 9)
dataset <- LoadH5Seurat(args$h5seurat_path)

ckpt_dir <- file.path(args$ckpt_dir, sprintf("%s_Seuratv3_%d_seed%d_%s", dataset_str, args$subset_genes, args$seed, strftime(Sys.time(),"%m_%d-%H_%M_%S")))
if (!dir.exists((ckpt_dir))) {
    dir.create(ckpt_dir)
}
scETM <- import("scETM")
scETM$initialize_logger(ckpt_dir = ckpt_dir)
anndata <- import("anndata")

start_time <- proc.time()[3]
start_mem <- print_memory_usage()

dataset_list <- SplitObject(dataset, split.by = "batch_indices")
batches <- names(dataset_list)
print(batches)

largest_batch <- NA
largest_batch_sample_size <- 0

for (i in seq_along(batches)) {
    dataset_list[[i]] <- NormalizeData(
        object = dataset_list[[i]],
        verbose = FALSE
    )
    ncells <- dim(dataset_list[[i]])[2]
    if (ncells > largest_batch_sample_size) {
        largest_batch <- i
        largest_batch_sample_size <- ncells
    }
}

if (args$subset_genes) {
    anchor_features <- args$subset_genes
} else {
    anchor_features <- rownames(dataset@assays$RNA@data)
}

if (args$reference){
    anchors <- FindIntegrationAnchors(
        object.list = dataset_list,
        dims = 1:args$n_pcs,
        anchor.features = anchor_features,
        reference = largest_batch
    )
} else {
    anchors <- FindIntegrationAnchors(
        object.list = dataset_list,
        dims = 1:args$n_pcs,
        anchor.features = anchor_features
    )
}

integrated <- IntegrateData(
    anchorset = anchors,
    dims = 1:args$n_pcs
)

DefaultAssay(object = integrated) <- "integrated"

integrated <- ScaleData(
    object = integrated,
    verbose = FALSE
)

time_cost <- proc.time()[3] - start_time
mem_cost <- print_memory_usage() - start_mem
writeLines(sprintf("Duration: %.1f s (%.1f min)", time_cost, time_cost / 60))

integrated <- RunPCA(integrated, npcs = args$n_pcs)
fpath <- file.path(ckpt_dir, sprintf("%s_Seuratv3_seed%d.h5ad", dataset_str, args$seed))
X <- integrated@reductions$pca@cell.embeddings
processed_data <- anndata$AnnData(
    X = X,
    obs = integrated@meta.data
)
processed_data$write_h5ad(fpath)

if (!args$no_eval) {
    result <- scETM$evaluate(
        processed_data,
        embedding_key = "X",
        resolutions = args$resolutions,
        plot_dir = ckpt_dir,
        plot_fname = sprintf("%s_Seuratv3_seed%d_eval", dataset_str, args$seed),
        n_jobs = 1L
    )
    line <- sprintf("%s\tSeuratv3\t%s\t%.4f\t%.4f\t%.4f\t%.5f\t%.5f\t%.2f\t%.0f",
        dataset_str, args$seed,
        result$ari, result$nmi, result$asw, result$ebm, result$k_bet,
        time_cost, mem_cost)
    write(line, file = file.path(args$ckpt_dir, "table1.tsv"), append = T)
}


## Some helper functions for evaluating lme models

## Get group level effects in prediction
get.glevel.effect <- function(u, glevel, gname) {
#	u <- ranef(m)

	xf <- 0
	if ((glevel %in% rownames(u[[gname]]))) {
		xf <- u[[gname]][glevel,]
	} else {
		xf <- 0
	#	print("???")
	}

	return(xf)
}

## linear prediction
get.qs.linear.pred <- function(m, newdata, corpus=F) {

        mm <- model.matrix(terms(m),data=newdata)
        u <- mm %*% fixef(m)

	m.ranef <- ranef(m)
        role.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,role,"role")),by=list(pid)]$fx
        group.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,group,"group")),by=list(pid)]$fx
        meeting.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,meeting,"meeting")),by=list(pid)]$fx
	if (corpus==T) {
        	corpus.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,corpus,"corpus")),by=list(pid)]$fx
        	pred.fx  <- u + role.fx + group.fx + meeting.fx + corpus.fx
	} else {
        	pred.fx  <- u + role.fx
	}
        return(pred.fx)
}

## Out of date with respect to group level indicators?
get.eda.linear.pred <- function(m, newdata, corpus=F) {

        mm <- model.matrix(terms(m),data=newdata)
        u <- mm %*% fixef(m)

	m.ranef <- ranef(m)
        annot.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,annot,"annot")),by=list(wid,annot)]$fx
        mtype.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,mtype,"mtype")),by=list(wid,annot)]$fx
	if (corpus==T) {
        	corpus.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,corpus,"corpus")),by=list(wid,annot)]$fx
        	pred.fx  <- u + annot.fx + mtype.fx + corpus.fx
	} else {
        	pred.fx  <- u + annot.fx + mtype.fx
	}
        return(pred.fx)
}

## This needs to be generalized
get.eda.true.pred <- function(m, newdata, corpus=F, spk=F) {

	print(nrow(newdata))
	#print(terms(m))
        mm <- model.matrix(terms(m),data=newdata)
	#print(nrow(mm))
        u <- mm %*% fixef(m)

	m.ranef <- ranef(m)

	if (spk) {
		print("HERE spk")
		mtype.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,mtype,"mtype")),by=list(wid.spk,annot)]$fx

        	sum.fx  <- u + mtype.fx
		if ("annot" %in% m.ranef) {
			annot.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,annot,"annot")),by=list(wid.spk,annot)]$fx
			sum.fx <- sum.fx + annot.fx
		}
		if ("eda.annot" %in% m.ranef) {
			eda.annot.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,eda.annot,"eda.annot")),by=list(wid.spk,annot)]$fx
			sum.fx <- sum.fx + eda.annot.fx
		}
		if ("mgroup" %in% m.ranef) {
			mgroup.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,mgroup,"mgroup")),by=list(wid.spk,annot)]$fx
			sum.fx <- sum.fx + mgroup.fx
		}
		if ("corpus" %in% m.ranef) {
        		corpus.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,corpus,"corpus")),by=list(wid.spk,annot)]$fx
			sum.fx <- sum.fx + corpus.fx

		}
	} else {
		print("HERE")
		mtype.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,mtype,"mtype")),by=list(wid,annot)]$fx
        	sum.fx  <- u + mtype.fx
		print(m.ranef)
		print(names(m.ranef))
		if ("annot" %in% m.ranef) {
			print("annot")
			annot.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,annot,"annot")),by=list(wid,annot)]$fx
			sum.fx <- sum.fx + annot.fx
		}
		if ("eda.annot" %in% m.ranef) {
			print("eda.annot")
			eda.annot.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,eda.annot,"eda.annot")),by=list(wid,annot)]$fx
			sum.fx <- sum.fx + eda.annot.fx
		}
		if ("mgroup" %in% m.ranef) {
			print("mgroup")
			mgroup.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,mgroup,"mgroup")),by=list(wid,annot)]$fx
			sum.fx <- sum.fx + mgroup.fx
		}
		if ("corpus" %in% m.ranef) {
			print("corpus")
        		corpus.fx <- newdata[,list(fx=get.glevel.effect(m.ranef,corpus,"corpus")),by=list(wid,annot)]$fx
			sum.fx <- sum.fx + corpus.fx

		}
	}

       	pred.fx  <- invlogit(sum.fx)

        return(pred.fx)
}

train.logit.model <- function(m, xdata, x.formula) {
	glmer(x.formula, data=xdata,family=binomial(link="logit"))
}

train.linear.model <- function(m, xdata, x.formula) {
	glmer(x.formula, data=xdata)
}

## Leave one out cross-validation
get.loocv.qs <- function(m, xdata, filename="curr.loocv.qs", corpus=F, linear=T) {
	print(filename)
	x <- xdata
	gnames <- unique(xdata$group)
	xpred <- NULL
	mlist <- list()

	for (gname  in gnames) {
		print(gname)
		curr <- x[group==gname]
		if (linear) {
			curr.m <- train.linear.model(m, x[group != gname])
			curr.pred <- get.qs.linear.pred(curr.m, curr, corpus=corpus)
			xpred <- rbind(xpred, data.table(curr[,list(pid, role, meeting, group, A.centre)],
						pred.val=curr.pred[,1]))

		} else {
			print("Oh no, not yet!")
			xpred <- curr
		}
		mlist[[gname]] <- curr.m
	}

	currcv <- list(xpred=xpred, mlist=mlist)
	if (!is.null(filename)) {
		print(filename)
		save(currcv, file=filename)
	}
	return(xpred)
}

get.cv.qs <- function(m, xdata, nfolds=5, filename="curr.cv.qs", corpus=F, linear=T) {
	print(filename)
	ord <- sample.int(nrow(xdata))
	nx <- ceiling(nrow(xdata)/nfolds)
	fold.starts <- seq(1,nrow(xdata),by=nx)
	fold.ends <- c(fold.starts[2:length(fold.starts)]-1, nrow(xdata))
	folds <- data.table(fstart=fold.starts, fend=fold.ends)

	#x <- xdata
	x <- xdata[ord]
	xpred <- NULL
	mlist <- list()

	for (i in c(1:nrow(folds))) {
		print(folds[i])
		curr <- x[folds$fstart[i]:folds$fend[i]]
		if (linear) {
			curr.m <- train.linear.model(m, x[!(folds$fstart[i]:folds$fend[i])])
			curr.pred <- get.qs.linear.pred(curr.m, curr, corpus=corpus)
			xpred <- rbind(xpred, data.table(curr[,list(pid, role, meeting, group, A.centre)],
						pred.val=curr.pred[,1]))

		} else {
			print("Oh no, not yet!")
			xpred <- curr
		}
		mlist[[folds$fstart[i]]] <- curr.m
	}

	currcv <- list(xpred=xpred, mlist=mlist, folds=folds, ord=ord)
	if (!is.null(filename)) {
		print(filename)
		#save(currcv, file=filename)
	}
	return(xpred)
}

get.cv <- function(m, xdata, x.formula, nfolds=5, filename=NULL, corpus=F, linear=F, spk=F) {
	print(filename)
	ord <- sample.int(nrow(xdata))
	nx <- ceiling(nrow(xdata)/nfolds)
	fold.starts <- seq(1,nrow(xdata),by=nx)
	fold.ends <- c(fold.starts[2:length(fold.starts)]-1, nrow(xdata))
	folds <- data.table(fstart=fold.starts, fend=fold.ends)

	#x <- xdata
	x <- xdata[ord]
	xpred <- NULL
	mlist <- list()

	for (i in c(1:nrow(folds))) {
		print(folds[i])
		curr <- x[folds$fstart[i]:folds$fend[i]]
		print(nrow(curr))
		if (linear) {
			curr.m <- train.linear.model(m=m, xdata=x[!(folds$fstart[i]:folds$fend[i])], x.formula=x.formula)
			curr.pred <- get.eda.linear.pred(curr.m, curr, corpus=corpus)
			xpred <- rbind(xpred, data.table(curr[,list(wid,annot,corpus,eda.true,eda.time,link.eda)],
						pred.val=curr.pred[,1]))

		} else {
			curr.m <- train.logit.model(m=m, xdata=x[!(folds$fstart[i]:folds$fend[i])], x.formula=x.formula)
			print("Here")
			curr.pred <- get.eda.true.pred(curr.m, curr, corpus=corpus, spk=spk)
			xpred <- rbind(xpred, data.table(curr[,list(wid,annot,corpus,eda.true,eda.time,link.eda)],
						logit.val=curr.pred[,1]))
		}
		mlist[[folds$fstart[i]]] <- curr.m
	}

	currcv <- list(xpred=xpred, mlist=mlist, folds=folds, ord=ord)
	if (!is.null(filename)) {
		print(filename)
		#save(currcv, file=filename)
	}
	return(xpred)
}

get.cv.wrapper <- function(m, N, xdata, x.formula=formula(m), nfolds=10, corpus=F, linear=F, spk=F) {
	#get.cv(m, xdata, nfolds, filename=paste("/home/clai/kdata/ami/derived/R.outputs/cv.",N,sep=""), corpus=corpus)
	get.cv(m, xdata, x.formula, nfolds, filename=paste("cv.",N,sep=""), corpus=corpus, linear=linear, spk=spk)
}

get.cv.reps <- function(m, xdata, nfolds=5, nreps=10) {
	mclapply(c(1:nreps), get.cv.wrapper, m=m, xdata=xdata, nfolds=nfolds,
	 	mc.cores=5)

}

get.f1 <- function(x, dep.var="eda.true") {
	if (!is.data.table(x)) {
		x <- data.table(x)
	}
	setnames(x, c(dep.var), c("eda.true"))
	if ("wid" %in% names(x) & !("niteid" %in% names(x))) {
		setnames(x, c("wid"), c("niteid"))
	}
	ctab <- x[,length(niteid),by=list(eda.true, logit.val > 0.5)]
	baseline <- x[,length(niteid)/nrow(x),by=list(eda.true)]
	accuracy <- ctab[,sum(V1[eda.true == logit.val])/(sum(V1))]
	precision <- ctab[,V1[eda.true & logit.val]/(sum(V1[logit.val]))]
	if (length(precision)==0) {precision <- 0}
	recall <- ctab[,V1[eda.true & logit.val]/(sum(V1[eda.true]))]
	if (length(recall)==0) {recall <- 0}
	F1 <- 2* ((precision*recall)/(precision+recall))

	setnames(x, c("eda.true"), c(dep.var))

	return(list(f1=data.table(baseline, accuracy, precision=precision, recall=recall, F1=F1), ctab=ctab))
}

#---------------------------------------------------------------------
# Examine model parameters

## Get fixed effects of model m
get.fixef <- function(m, roundval=3) {
	u <- display(m)
	v0 <- round(data.table(estimate=u$coef, se=u$se, ymin=u$coef-2*u$se, ymax=u$coef+2*u$se), roundval)
	v <- data.table(varx=names(u$coef), v0)
	return(v)
}

get.ranef.var <- function(m, varname) {

	u0 <- se.ranef(m)[[varname]]
	x0 <- ranef(m)[[varname]]

	x1 <- data.frame(varx=rownames(x0), x0)
	names(x1)[2] <- varname #"Intercept"
	x2 <- melt(x1)
	names(x2)  <- c("varx","varb", "estimate")

	u1 <- data.frame(varx=rownames(x0), u0)
	names(u1) <- names(x1)
	u2 <- melt(u1)
	names(u2)  <- c("varx","varb", "se")

	v <- data.frame(x2, u2$se, ymin=x2$estimate-2*u2$se, ymax=x2$estimate+2*u2$se)
	return(v)
}

plot.fixef.est <- function(v, varname="Features") {
	p <- ggplot(v, aes(x=varx, y=estimate, ymin=ymin, ymax=ymax)) + geom_pointrange() + geom_hline(y=0, col="grey")
	p <- p + scale_x_discrete(varname) + theme(axis.text.x=element_text(angle=90, hjust=1))
	p

}
plot.ranef.var <- function(m, varname) {

        u0 <- se.ranef(m)[[varname]]
        x0 <- ranef(m)[[varname]]

        x1 <- data.frame(varx=rownames(x0), x0)
        names(x1)[2] <- varname #"Intercept"
        x2 <- melt(x1)
        names(x2)  <- c("varx","varb", "estimate")

        u1 <- data.frame(varx=rownames(x0), u0)
        names(u1) <- names(x1)
        u2 <- melt(u1)
        names(u2)  <- c("varx","varb", "se")

        v <- data.frame(x2, u2$se, ymin=x2$estimate-2*u2$se, ymax=x2$estimate+2*u2$se)

        p <- ggplot(v, aes(x=varx, y=estimate, ymin=ymin, ymax=ymax)) + geom_pointrange()
        p <- p + geom_hline(y=0, col="grey")
        p <- p + facet_wrap(~ varb)
        p <- p + scale_x_discrete(varname)
        p

}


deseq = modules::import_package('DESeq2')
piano = modules::import_package('piano')
modules::import_package('dplyr', attach = TRUE)

#' @export
prepare_gene_set = function (gene_set)
    piano$loadGSC(gene_set, 'data.frame')

#' @export
gsa_de = function (data, col_data, contrast, go_genes) {
    stopifnot(inherits(go_genes, 'GSC'))
    data = untidy(select(data, Gene, starts_with('do')))
    col_data = untidy(col_data)

    # Annoyingly, we need to recalculate the DE genes here because we previously
    # only stored genes with evidence of DE, not all genes.
    de = deseq_test(data, col_data, contrast) %>%
        deseq$results() %>%
        as.data.frame() %>%
        {.[! is.na(.$padj), ]}
    stats = de[, 'padj', drop = FALSE]
    directions = de[, 'log2FoldChange', drop = FALSE]
    piano$runGSA(stats, directions, gsc = go_genes, verbose = FALSE)
}

#' @export
enriched_terms = function (data, direction = c('up', 'down'), alpha = 0.01) {
    direction = switch(direction, up = 'up', 'down' = 'dn',
                       stop('Invalid ', sQuote('direction')))
    modules::import_package('lazyeval', attach = TRUE)
    dir_col = as.name(sprintf('p adj (dist.dir.%s)', direction))

    piano$GSAsummaryTable(data) %>%
        filter_(interp(~ p < alpha, p = dir_col)) %>%
        select_('Name', padj = dir_col) %>%
        arrange(padj)
}

untidy = function (tidy_data, rownames = 1)
    `rownames<-`(as.data.frame(tidy_data[-rownames]), tidy_data[[rownames]])

deseq_test = function (data, col_data, contrast) {
    cols = rownames(col_data)[col_data[[1]] %in% contrast]
    col_data = col_data[cols, , drop = FALSE]
    # Ensure that the conditions are in the same order as `contrast`; that is,
    # the reference level corresponds to `contrast[1]`.
    # FIXME: DESeq2 bug causes this not to work, need to use relevel instead.
    #col_data[[1]] = factor(col_data[[1]], unique(col_data[[1]]), ordered = TRUE)
    data = data[, cols]
    design = eval(bquote(~ .(as.name(colnames(col_data)[1]))))
    dds = deseq$DESeqDataSetFromMatrix(data, col_data, design)
    GenomicRanges::colData(dds)[[1]] = relevel(GenomicRanges::colData(dds)[[1]],
                                               contrast[1])
    deseq$DESeq(dds, quiet = TRUE)
}


#Title: Estimate fitting decay curve
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-24

###Estimate_normalization_factor_function###
BridgeRHalfLifeCalcR2Select <- function(InputFile = "BridgeR_4_Normalized_expression_dataset.txt",
                                        group,
                                        hour,
                                        InforColumn = 4,
                                        CutoffDataPointNumber = 4,
                                        CutoffDataPoint1 = c(1,2),
                                        CutoffDataPoint2 = c(8,12),
                                        ThresholdHalfLife = c(8,12),
                                        OutputFile = "BridgeR_5C_HalfLife_calculation_R2_selection.txt"){
    ###Prepare_file_infor###
    time_points <- length(hour)
    group_number <- length(group)
    input_file <- fread(InputFile, header=T)
    output_file <- paste(OutputFile,".log",sep="")
    log_file <- OutputFile

    ###print_header###
    cat("",file=output_file)
    cat("",file=log_file)
    hour_label <- NULL
    CutoffDataPoint1 <- sort(CutoffDataPoint1, decreasing = T)
    CutoffDataPoint2 <- sort(CutoffDataPoint2, decreasing = F)
    CutoffDataPoint1_length <- length(CutoffDataPoint1)
    CutoffDataPoint2_length <- length(CutoffDataPoint2)

    for_iteration_number <- CutoffDataPoint1_length + CutoffDataPoint2_length
    for(a in 1:group_number){
        if(!is.null(hour_label)){
            cat("\t", file=output_file, append=T)
            cat("\t", file=log_file, append=T)
        }
        hour_label <- NULL
        for(x in hour){
            hour_label <- append(hour_label, paste("T", x, "_", a, sep=""))
        }
        infor_st <- 1 + (a - 1)*(time_points + InforColumn)
        infor_ed <- (InforColumn)*a + (a - 1)*time_points
        infor <- colnames(input_file)[infor_st:infor_ed]
        cat(infor,hour_label, sep="\t", file=output_file, append=T)
        cat("\t", sep="", file=output_file, append=T)
        cat(infor,hour_label, sep="\t", file=log_file, append=T)
        cat("\t", sep="", file=log_file, append=T)

        for_iteration_number2 <- for_iteration_number + 1
        for(number in 1:for_iteration_number2){
            cat("Model","Decay_rate_coef","coef_error","coef_p-value",
                "R2","Adjusted_R2","Residual_standard_error","half_life",
                sep="\t", file=output_file, append=T)
            cat("\t", sep="", file=output_file, append=T)
        }
        cat("Model","R2","half_life", sep="\t", file=output_file, append=T)
        cat("Model","R2","half_life", sep="\t", file=log_file, append=T)
    }
    cat("\n", sep="", file=output_file, append=T)
    cat("\n", sep="", file=log_file, append=T)

    ###calc_RNA_half_lives###
    ###Function1#################################
    half_calc <- function(time_exp_table,label){
        data_point <- length(time_exp_table$exp)
        if(!is.null(time_exp_table)){
            if(data_point >= CutoffDataPointNumber){
                if(as.numeric(as.vector(as.matrix(time_exp_table$exp[1]))) > 0){
                    model <- lm(log(time_exp_table$exp) ~ time_exp_table$hour - 1)
                    model_summary <- summary(model)
                    coef <- -model_summary$coefficients[1]
                    coef_error <- model_summary$coefficients[2]
                    coef_p <- model_summary$coefficients[4]
                    r_squared <- model_summary$r.squared
                    adj_r_squared <- model_summary$adj.r.squared
                    residual_standard_err <- model_summary$sigma
                    half_life <- log(2)/coef
                    if(coef < 0 || half_life >= 24){
                        half_life <- 24
                    }
                    cat(label,coef,coef_error,coef_p,r_squared,adj_r_squared,residual_standard_err,half_life, sep="\t", file=output_file, append=T)
                    return(c(half_life,r_squared))
                }else{
                    cat("low_expresion","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    return(c("NA","NA"))
                }
            }else{
                cat("few_data","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                return(c("NA","NA"))
            }
        }else{
            cat("low_expresion","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
            return(c("NA","NA"))
        }
    }
    #############################################

    ###Function2#################################
    test_R2 <- function(time_point_exp_raw, cutoff_data_point, halflife_Raw, R2_Raw){
        test_times <- cutoff_data_point
        times_length <- length(test_times)
        times_index <- c(times_length)
        add_index <- times_length

        R2_list <- c(R2_Raw)
        half_list <- c(halflife_Raw)
        label_list <- c("Raw")
        for(counter in times_length:1){
            #excepted_time_points
            check_times <- test_times[times_index] #c(24), c(24,12), c(24,12,8)
            time_point_exp_del <- NULL
            time_point_exp_del_label <- paste("Delete_",paste(check_times,collapse="hr_"),"hr",sep="")
            label_list <- append(label_list, time_point_exp_del_label) #
            time_point_exp_del <- time_point_exp_raw
            for(times_list in check_times){
                time_point_exp_del <- time_point_exp_del[time_point_exp_del$hour != as.numeric(times_list),]
            }
            time_point_exp_del <- time_point_exp_del[time_point_exp_del$exp > 0,]
            halflife_R2_result <- half_calc(time_point_exp_del, time_point_exp_del_label)
            cat("\t", sep="", file=output_file, append=T)

            R2_list <- append(R2_list, halflife_R2_result[2]) #
            half_list <- append(half_list, halflife_R2_result[1]) #

            #Counter
            add_index <- add_index - 1
            times_index <- append(times_index, add_index)
        }

        R2_table <- data.frame(label=label_list, R2=R2_list, half=half_list)
        #R2_table <- R2_table[R2_table$R2 != "NA",]
        #sortlist <- order(R2_table$R2, decreasing = T)
        #R2_table <- R2_table[sortlist,]
        #result <- as.vector(as.matrix(R2_table[1,]))
        #cat(result, sep="\t", file=output_file, append=T)
        return(R2_table)
    }
    #############################################

    gene_number <- length(input_file[[1]])
    for(x in 1:gene_number){
        data <- as.vector(as.matrix(input_file[x,]))
        for(a in 1:group_number){
            if(a != 1){
                cat("\t", sep="", file=output_file, append=T)
                cat("\t", sep="", file=log_file, append=T)
            }
            infor_st <- 1 + (a - 1)*(time_points + InforColumn)
            infor_ed <- (InforColumn)*a + (a - 1)*time_points
            exp_st <- infor_ed + 1
            exp_ed <- infor_ed + time_points

            gene_infor <- data[infor_st:infor_ed]
            cat(gene_infor, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            cat(gene_infor, sep="\t", file=log_file, append=T)
            cat("\t", file=log_file, append=T)

            exp <- as.numeric(data[exp_st:exp_ed])
            cat(exp, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            cat(exp, sep="\t", file=log_file, append=T)
            cat("\t", file=log_file, append=T)

            ###Raw_data
            time_point_exp_raw <- data.frame(hour,exp)
            time_point_exp_base <- time_point_exp_raw[time_point_exp_raw$exp > 0, ]
            test <- half_calc(time_point_exp_base,"Exponential_Decay_Model") #T1/2 - R2
            cat("\t", sep="", file=output_file, append=T)

            ###Re-calculation of RNA half-life(Default: ThresholdHalfLife - 12hr)
            R2_list <- NULL
            half_list <- NULL
            label_list <- NULL
            if(test[1] == "NA"){
                for(number in 1:for_iteration_number){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                cat("Notest","NA","NA", sep="\t", file=output_file, append=T)
                cat("Notest","NA","NA", sep="\t", file=log_file, append=T)
            }else if(test[1] < ThresholdHalfLife[1]){ #Default: <12hr => Delete 8,12hr
                for(number in 1:CutoffDataPoint1_length){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                R2_table <- test_R2(time_point_exp_raw, CutoffDataPoint2, test[1], test[2]) #test[1], test[2] => T1/2, R2

            }else if(test[1] >= ThresholdHalfLife[1] && test[1] < ThresholdHalfLife[2]){
                R2_table1 <- test_R2(time_point_exp_raw, CutoffDataPoint1, test[1], test[2]) #test[1], test[2] => T1/2, R2
                R2_table2 <- test_R2(time_point_exp_raw, CutoffDataPoint2, test[1], test[2]) #test[1], test[2] => T1/2, R2
                R2_table <- rbind(R2_table1, R2_table2)

            }else if(test[1] >= ThresholdHalfLife[2]){ #Default: >=12hr => Delete 1,2hr
                for(number in 1:CutoffDataPoint2_length){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                R2_table <- test_R2(time_point_exp_raw, CutoffDataPoint1, test[1], test[2]) #test[1], test[2] => T1/2, R2

            }
            ###R2_Selection###
            if(test[1] != "NA"){
                R2_table <- R2_table[R2_table$R2 != "NA",]
                sortlist <- order(R2_table$R2, decreasing = T)
                R2_table <- R2_table[sortlist,]
                result <- as.vector(as.matrix(R2_table[1,]))
                cat(result, sep="\t", file=output_file, append=T)
                cat(result, sep="\t", file=log_file, append=T)
            }
        }
        cat("\n", file=output_file, append=T)
        cat("\n", file=log_file, append=T)
    }
}

###TEST###
#output_file <- "test.txt"
#CutoffDataPointNumber <- 4
#x <- c(0,1,2,4,8,12)
#y <- c(1,0.9,0.8,0.5,0.3,0.1)
#table <- data.frame(hour=x,exp=y)
#test_data_point <- c(8,12)
#test_R2(table, test_data_point, 4.5, 0.992)

#    R2_list half_list      label_list
#1 0.9919170  4.547501     Delete_12hr
#2 0.9720505  4.378777 Delete_12hr_8hr

#########################
#test <- c(8,12,24,2,12,21,1)
#test_length <- length(test)
#test_index <- c(test_length)
#add_index <- test_length

#for(x in test_length:1){
#    print(test[test_index])
#    add_index <- add_index - 1
#    test_index <- append(test_index,add_index)
#}


require(graphics)
library(ggplot2)
library(ggthemes)
library(MASS)
library(gridExtra)

mm1 <- function(...) {
  mean_cl_normal(...,mult=1)
}
mm2 <- function(...) {
  mean_cl_normal(...,mult=2)
}

g1 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease, fill = treatment))+
  theme_gray(base_size = 12)+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mean_cl_normal,geom="errorbar",width=0.5) +
  stat_summary(fun.data=mean_cl_normal,geom="bar") + ggFill(color.value = "Hue")+
  theme(legend.position="none",
        panel.grid.minor=element_line(color = "black"),
        panel.grid.major  = element_line(color = "black"),
        panel.border=element_blank(),
        axis.title.y=element_blank(),
        axis.title.x=element_blank()
  )

g2 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease)) + theme_minimal(base_size = 14)+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mean_cl_normal,geom="errorbar",width=0.5) +
  stat_summary(fun.data=mean_cl_normal,geom="bar") +
  theme(legend.position="none",
        panel.grid.minor=element_blank(),
        panel.background=element_blank(),
        axis.title.y=element_blank(),
        axis.title.x=element_blank()
  )

g3 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease)) + theme_minimal(base_size = 14)+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mean_cl_normal,geom="errorbar",width=0.5) +
  stat_summary(fun.data=mean_cl_normal,geom="bar",width=0.7) +
  theme(legend.position="none",
        panel.grid.minor=element_blank(),
        panel.grid.major=element_line(size = 0.5, color = "gray96"),
        panel.background=element_blank(),
        axis.title.y=element_blank(),
        axis.title.x=element_blank()
  )

g4 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease)) + theme_minimal(base_size = 14)+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mean_cl_normal,geom="errorbar",width=0.5, size = 1) +
  stat_summary(fun.data=mean_cl_normal,geom="point",size=3) +
  xlab("Treatment") + ylab("Effect") +
  theme(legend.position="none",
        panel.grid.minor=element_blank(),
        panel.grid.major=element_line(size = 0.5, color = "gray96"),
        panel.background=element_blank()
  )

g5 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease))+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mm2,geom="linerange", size = 0.7)+
  stat_summary(fun.data=mean_cl_normal,geom="point") +
  xlab("Treatment") + ylab("Effect") +
  theme(legend.position="none",
        panel.grid.minor=element_blank(),
        panel.grid.major=element_line(size = 0.5, color = "gray96"),
        panel.background=element_blank()
  )

g6 <- ggplot(OrchardSprays,aes(x=treatment,y=decrease))+
  scale_y_continuous(limits = c(0,100), breaks = c(0,25,50,75,100)) +
  stat_summary(fun.data=mm2,geom="linerange", size = 0.7)+
  stat_summary(fun.data=mm1,geom="linerange",size=1.1, color = "red", position=position_dodge(width=0))+
  stat_summary(fun.data=mean_cl_normal,geom="point") +
  xlab("Treatment") + ylab("Effect") +
  theme(legend.position="none",
        panel.grid.minor=element_blank(),
        panel.grid.major=element_line(size = 0.5, color = "gray96"),
        panel.background=element_blank()
  )

g1
ggsave(file="Plot42a.png", width = 80, height = 80, units = "mm", dpi = 300)

g2
ggsave(file="Plot42b.png", width = 80, height = 80, units = "mm", dpi = 300)

g3
ggsave(file="Plot42c.png", width = 80, height = 80, units = "mm", dpi = 300)

g4
ggsave(file="Plot42d.png", width = 80, height = 80, units = "mm", dpi = 300)

g5
ggsave(file="Plot42e.png", width = 80, height = 80, units = "mm", dpi = 300)

g6
ggsave(file="Plot42f.png", width = 80, height = 80, units = "mm", dpi = 300)


# SVM
library(dplyr)

# 3 Models

# read data - remove #
# data <- read.csv('../input/twitter-sentiment-analysis/Sentiment_Data.csv')
head(data)

data_1 <- data %>%
  select(text, sentiment)
head(data_1)

round(prop.table(table(data_1$sentiment)),2)

library(tm)
# Loading required package: NLP
library(SnowballC)
corpus = VCorpus(VectorSource(data_1$text))
# a snap shot of the first text stored in the corpus
as.character(corpus[[1]])

corpus = tm_map(corpus, content_transformer(tolower))
corpus = tm_map(corpus, removeNumbers)
corpus = tm_map(corpus, removePunctuation)
corpus = tm_map(corpus, removeWords, stopwords("english"))
corpus = tm_map(corpus, stemDocument)
corpus = tm_map(corpus, stripWhitespace)
as.character(corpus[[1]])

dtm = DocumentTermMatrix(corpus)
dtm
dim(dtm)

dtm = removeSparseTerms(dtm, 0.999)
dim(dtm)

#Inspecting the the first 10 tweets and the first 15 words in the dataset
inspect(dtm[0:10, 1:15])

freq<- sort(colSums(as.matrix(dtm)), decreasing=TRUE)
findFreqTerms(dtm, lowfreq=60) #identifying terms that appears more than 60times

library(wordcloud)
positive <- subset(data_1,sentiment=="Positive")
head(positive)
wordcloud(positive$text, max.words = 100, scale = c(3,0.5))

negative <- subset(data_1,sentiment=="Negative")
head(negative)
wordcloud(negative$text, max.words = 100, scale = c(3,0.5))

neutral <- subset(data_1,sentiment=="Neutral")
head(neutral)
wordcloud(neutral$text, max.words = 100, scale = c(3,0.5))

library("wordcloud")

# Loading required package: RColorBrewer
library(RColorBrewer)
set.seed(1234)
wordcloud(words = wf$word, freq = wf$freq, min.freq = 1,
          max.words=200, random.order=FALSE, rot.per=0.35,
          colors=brewer.pal(8, "Dark2"))

convert_count <- function(x) {
  y <- ifelse(x > 0, 1,0)
  y <- factor(y, levels=c(0,1), labels=c("No", "Yes"))
  y
}

# Apply the convert_count function to get final training and testing DTMs
datasetNB <- apply(dtm, 2, convert_count)

dataset = as.data.frame(as.matrix(datasetNB))

dataset$Class = data_1$sentiment
str(dataset$Class)

head(dataset)
dim(dataset)

# Splitting data
set.seed(222)
split = sample(2,nrow(dataset),prob = c(0.75,0.25),replace = TRUE)
train_set = dataset[split == 1,]
test_set = dataset[split == 2,]

prop.table(table(train_set$Class))
prop.table(table(test_set$Class))

# SVM: Support vector machine
svm_classifier <- svm(Class~., data=train_set)
svm_classifier

# Model evaluation: SVM
svm_pred = predict(svm_classifier,test_set)

confusionMatrix(svm_pred,test_set$Class)


# Unit tests for the Bioconductor layer
#
# Author: Renaud Gaujoux
# Created: Mar 6, 2013
###############################################################################

# check extension of Bioc access methods
# => this also serves to check that they are correctly exported
test.access <- function(){

	x <- nmfModel(3, 20, 10)
	.check <- function(fun, val, newval){
		msg <- function(...) paste(fun, ': ', ..., sep='')
		f <- match.fun(fun)
		checkIdentical(f(x), val, msg('on fresh object returns NULL'))

		if( isNumber(newval) ) newval <- paste('aaa', 1:newval)
		res <- try(eval(parse(text=paste(fun, '(x) <- newval', sep=''))))
		checkTrue(!is(res, 'try-error'), msg('setting value works'))
		checkIdentical(f(x), newval, msg('new value is correct'))
		res <- try(eval(parse(text=paste(fun, '(x) <- val', sep=''))))
		checkTrue(!is(res, 'try-error'), msg('resetting value works'))
		checkIdentical(f(x), val, msg('reset value is correct'))
	}

	checkIdentical(nbasis(x), nmeta(x), 'nmeta is defined')
	.check('featureNames', NULL, 20)
	.check('sampleNames', NULL, 10)
	.check('basisnames', NULL, 3)
	.check('metaprofiles', coef(x), rmatrix(coef(x)))
	.check('metagenes', basis(x), rmatrix(basis(x)))

}


context("Network bootstrap")

# rn(list=ls())
# library(microbenchmark)
# library(netdiffuseR)
#
# set.seed(1231)
# g <- rgraph_ba(t=1e2, m=2)
# index <- sample(1:nnodes(g), nnodes(g), TRUE)
# E <- g@x
# g <- g[index,index]
#
# microbenchmark(
#   R   = netdiffuseR:::bootnet_fillselfR(g, index, E),
#   Cpp = netdiffuseR:::bootnet_fillself(g, index, E), times=1e3,
#   unit= "relative"
# )

# ------------------------------------------------------------------------------
test_that("Filling zeros", {

  set.seed(123)
  n <- 5
  g <- rgraph_ba(t = n-1, self=FALSE, m = 1)

  set.seed(1)
  ans0 <- bootnet(g, function(w, i, ...) length(w@x), R=100,
                  resample.args = list(self=FALSE, useR=FALSE))

  set.seed(1)
  ans1 <- bootnet(g, function(w, i, ...) length(w@x), R=100,
                  resample.args = list(self=FALSE, useR=TRUE))

  expect_equal(ans1[-length(ans0)], ans1[-length(ans1)])
})

# ------------------------------------------------------------------------------
test_that("Methods", {
  # Generating the data
  set.seed(1291)

  # Static graphs
  graphdg <- rgraph_ba(t=9)
  graphmt <- as.matrix(graphdg)

  set.seed(123); ans0 <- resample_graph(graphdg)
  set.seed(123); ans1 <- resample_graph(graphmt)

  expect_equal(ans0, ans1)

  # Dynamic graphs
  graphls <- lapply(1:3, function(x) rgraph_ba(t=9))
  names(graphls) <- 2001:2003
  toa <- sample(c(2001:2003, NA), 10, TRUE)

  graphdn <- as_diffnet(graphls, toa, t0=2001, t1=2003)$graph
  graphar <- lapply(graphls, as.matrix)
  graphar <- array(unlist(graphar), dim=c(10,10,3),
                   dimnames = list(1:10, 1:10, 2001:2003))

  set.seed(123); ans0 <- resample_graph(graphls)
  set.seed(123); ans1 <- resample_graph(graphdn)
  set.seed(123); ans2 <- resample_graph(graphar)

  expect_equivalent(ans0, ans1)
  expect_equivalent(ans0, ans2)
})

# ------------------------------------------------------------------------------
test_that("diffnet_bootnet methods", {
  set.seed(1222)
  x <- rgraph_ba(t=19, m=1)
  ans <- bootnet(x, function(g,...) mean(dgr(g)), R=50)

  expect_output(print(ans), "Network Bootstrap")
  expect_silent(hist(ans, ask=FALSE))
  expect_s3_class(c(ans, ans), "diffnet_bootnet")
  expect_output(print(c(ans, ans)), ": 100")

})
# rn(list=ls())
# library(microbenchmark)
# library(netdiffuseR)
#
# set.seed(1231)
# g <- rgraph_ba(t=1e2, m=2)
# index <- sample(1:nnodes(g), nnodes(g), TRUE)
# E <- g@x
# g <- g[index,index]
#
# microbenchmark(
#   R   = netdiffuseR:::bootnet_fillselfR(g, index, E),
#   Cpp = netdiffuseR:::bootnet_fillself(g, index, E), times=1e3,
#   unit= "relative"
# )

# rm(list=ls())
# library(netdiffuseR)
# set.seed(123)
# n <- 5
# g <- rgraph_ba(t = n-1, self=FALSE, m = 1)
#
# set.seed(1); ans0 <- bootnet(g, function(w, ...) ifelse(inherits(w, "list"), length(w$graph@x), length(w@x)), R=100)
# set.seed(1); ans1 <- bootnet(g, function(w, ...) ifelse(inherits(w, "list"), length(w$graph@x), length(w@x)), R=100,
#                              resample.args = list(self=FALSE, useR=FALSE))
#

# library(netdiffuseR)
# n <- 100
# G <- rgraph_ws(n=n, p = .5, undirected = FALSE, self=FALSE, k=4)
# G <- list(G,G)
# Y1 <- sample(c(0,1), n, TRUE)
# Y2 <- Y1
# Y2[Y2==0] <- sample(c(0,1), sum(Y2==0), TRUE)
# X <- runif(n*2)
# dat <- data.frame(Y=c(Y1, Y2), X, year=c(rep(1,n), rep(2,n)))
# dat1 <- subset(dat, year==1)
# dat2 <- subset(dat, year==2)
#
# ans1 <- bootnet(G, function(g, idx) {
#   d <- rbind(dat1[idx,], dat2[idx,])
#   suppressMessages(netmatch(d, g, "year", "Y", "X", treat_thr = 3, method="cem")$fATT)
# }, R=1e3)
#
# ans2 <- struct_test(G, function(g, idx) {
#   suppressMessages(netmatch(dat, g, "year", "Y", "X", treat_thr = 3, method="cem")$fATT)
# }, R=1e3)
#


MGRAST_plot_pca <<- function(file_in,
                             file_out = "my_pca",

                             num_PCs = 2,

                             produce_fig = FALSE,
                             PC1="PC1",
                             PC2="PC2",

                             image_out = "my_pca",
                             image_title = image_out,
                             figure_width = 950,
                             figure_height = 950,
                             points_color = "red",  #c ("color1","color2", ... ,"color_n")  e.g. c("red","red","red")
                             figure_res = NA,
                             lab_cex= 1,
                             axis_cex = 1,
                             points_text_cex = .8)

{

  suppressPackageStartupMessages(library(pcaMethods))                                               # load the neccessary packages (suppress messages)

  {                                                                                # sub to import the input_file
    input_object = data.matrix(read.table(file_in, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))
  }

  number_entries = (dim(input_object)[1])                                                           # get dimensions of input object
  number_samples = (dim(input_object)[2])

  my_pcaRes <<- pca(input_object, nPcs = num_PCs)                                                   # Run pca and create pcaRes object

  # if (produce_fig == TRUE){                                                                         # option to produce figure
  #
  #   suppressPackageStartupMessages(library(Cairo))
  #
  #   CairoPNG(image_out, width = figure_width, height = figure_height, pointsize = 12, res = figure_res , units = "px")
  #
  #   plot(my_pcaRes@loadings[,PC1],
  #        my_pcaRes@loadings[,PC2],
  #        cex.axis = axis_cex,
  #        cex.lab = lab_cex,
  #        main = image_title,
  #        type = "p",
  #        col = points_color,
  #        xlab = paste(PC1, "R^2 =", round(my_pcaRes@R2[PC1], 4)),
  #        ylab = paste(PC2, "R^2 =", round(my_pcaRes@R2[PC2], 4))
  #        )
  #
  #   if (points_color != 0){
  #     points(my_pcaRes@loadings[,PC1], my_pcaRes@loadings[,PC2], col = points_color, pch=19, cex=2 )
  #     # color in the points if the points_color option has a value other than NA
  #     # pch, integer values that indicate different point types (19 is a filled circle)
  #   }
  #
  #   text(my_pcaRes@loadings[,PC1], my_pcaRes@loadings[,PC2], labels=rownames(my_pcaRes@loadings), cex = points_text_cex)
  # }

  write.table(my_pcaRes@R2,        file=file_out, sep="\t", col.names=FALSE, row.names=TRUE, append = FALSE)
  write.table(loadings(my_pcaRes), file=file_out, sep="\t", col.names=FALSE, row.names=TRUE, append = TRUE)

}

#write.table(loadings(my_pcaRes), file=gsub(" ", "_", paste(files_out_prefix, "LOADINGS_matrix.txt")),
#            sep="\t", col.names = NA, row.names = TRUE)
#write.table(scores(my_pcaRes), file=gsub(" ", "_", paste(files_out_prefix, "SCORES_matrix.txt")),
#            sep="\t", col.names = NA, row.names = TRUE)


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of uniform prior wonky world model predictions"
#' author: "Judith Degen"
#' date: "January 12, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/writing/_2015/_journal_cognition/models/graphs/")
source("../rscripts/helpers.r")

#' get model predictions
d = read.table("../modelresults/parsed_uniform_untruthful_results.tsv", quote="", sep="\t", header=T)
d$Type = "untruthful"
untruthful = d
d = read.table("../modelresults/parsed_uniform_uninformative_results.tsv", quote="", sep="\t", header=T)
d$Type = "uninformative"
uninformative = d

d = rbind(untruthful,uninformative)
d$Type = as.factor(d$Type)

table(d$Item)
nrow(d)
head(d)
summary(d)

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = paste(priorexpectations$effect,priorexpectations$object)
d$PriorExpectation = priorexpectations[as.character(d$Item),]$expectation

# get smoothed prior probabilities
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
row.names(priorprobs) = priorprobs$Item
mpriorprobs = melt(priorprobs, id.vars=c("Item"))
head(mpriorprobs)
row.names(mpriorprobs) = paste(mpriorprobs$Item,mpriorprobs$variable)
d$PriorProbability = mpriorprobs[paste(as.character(d$Item)," X",d$State,sep=""),]$value
d$AllPriorProbability = priorprobs[paste(as.character(d$Item)),]$X15
head(d)
d$QUD = NULL
d$Alternatives = NULL

load("../mp-uniform.RData")
head(mp)
mp$Type = "cooperative"
mp = mp[,names(d)]
d = rbind(d,mp)

allprobs = droplevels(subset(d, State == 15 & Quantifier == "some"))
ggplot(allprobs, aes(x=PriorProbability, y=PosteriorProbability, shape=as.factor(SpeakerOptimality),color=Type)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SpeakerOptimality~WonkyWorldPrior)
ggsave("model-predictions-unreliablespeaker.pdf")

best = droplevels(subset(allprobs, SpeakerOptimality == 2 & WonkyWorldPrior == .5))
ggplot(best, aes(x=PriorProbability, y=PosteriorProbability,color=Type)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous("Prior probability of all-state") +
  scale_y_continuous("Predicted posterior probability of all-state")
ggsave("model-predictions-unreliablespeaker-spopt2-wwprior.5.pdf",width=6,height=4)
ggsave("../../pics/modelpredictions-unreliablespeaker.pdf",width=6,height=4)


effects.data.export = function( Y ) {

  Z = Y$x
  Z$predictedPr = inverse.logit( Y$fit )
  Z$se = Y$se # keep on logit scale as it is meaningless of the Pr. scale.
  Z$upper = inverse.logit( Y$upper )
  Z$lower = inverse.logit( Y$lower )

  return (Z)

}


##
##  Java Information Dynamics Toolkit (JIDT)
##  Copyright (C) 2012, Joseph T. Lizier
##
##  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 3 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, see <http://www.gnu.org/licenses/>.
##

# = Example 2 - Transfer entropy on multidimensional binary data =

# Simple transfer entropy (TE) calculation on multidimensional binary data using the discrete TE calculator.

# Load the rJava library and start the JVM
library("rJava")
.jinit()

# Change location of jar to match yours:
#  IMPORTANT -- If using the default below, make sure you have set the working directory
#   in R (e.g. with setwd()) to the location of this file (i.e. demos/r) !!
.jaddClassPath("../../infodynamics.jar")

# Create many columns in a multidimensional array (2 rows by 100 columns),
#  where the next time step (row 2) copies the value of the column on the left
#  from the previous time step (row 1):
twoDTimeSeriesRtime1 <- sample(0:1, 100, replace="TRUE")
twoDTimeSeriesRtime2 <- c(twoDTimeSeriesRtime1[100], twoDTimeSeriesRtime1[1:99])
twoDTimeSeriesR <- rbind(twoDTimeSeriesRtime1, twoDTimeSeriesRtime2)

# Create a TE calculator and run it:
teCalc<-.jnew("infodynamics/measures/discrete/TransferEntropyCalculatorDiscrete", 2L, 1L)
.jcall(teCalc,"V","initialise") # V for void return value
# Add observations of transfer across one cell to the right per time step:
twoDTimeSeriesJava <- .jarray(twoDTimeSeriesR, "[I", dispatch=TRUE)
.jcall(teCalc,"V","addObservations", twoDTimeSeriesJava, 1L)
result2D <- .jcall(teCalc,"D","computeAverageLocalOfObservations")
cat("The result should be close to 1 bit here, since we are executing copy operations of what is effectively a random bit to each cell here: ", result2D, "\n")


#
library(fields)
library(gplots)
library(lme4)
library(abind)
library(stringr)

source("~esswein/lib/R/pt.color.r")
source("~esswein/lib/R/rle_ext.r")
source("~esswein/lib/R/halt.r")
source('~esswein/lib/R/day_of_year.R')
source('~esswein/lib/R/runinfo.R')
source('~esswein/lib/R/strssep.R')
source('~esswein/lib/R/julday.R')
source('~esswein/lib/R/midpoint.R')
source('~esswein/lib/R/earthdist.R')
source('~esswein/lib/R/formula.2.character.R')
source('~esswein/lib/R/position.labels.R')
add.alpha <- function (hex.color.list, alpha) sprintf("%s%02X", hex.color.list, floor(alpha * 256))

if (!exists('do.pdf'))  do.pdf = F

ri = runinfo()
hdr = paste('written_by',ri$prog)

file.pdf = sub('Regress.rds','PlotRegress.pdf',file.regress)

timefrac.color = tim.colors(9)
timefrac.color = timefrac.color[-6]
timefrac.color = add.alpha(timefrac.color,.5)
n.timefrac.color = length(timefrac.color)

if (file.access(file.regress) == 0) {
  dat.regress = readRDS(file.regress)
}
if (!exists('dat.regress')) stop('dat.regress not available')
site.df = dat.regress$site.df
site.data = dat.regress$site.data
doylist = unique(sort(site.df$DOY))
model.s = as.character(deparse(formula(dat.regress$fit)))
model.title = dat.regress$model.title

# Sites that have some PM2.5 for this region and time period:
sitelist = c()
lonlist = c()
latlist = c()
for (i in 1:dim(site.data)[3]) {
  if (length(which(!is.na(site.data[,'PM2.5',i]))) > 0) {
    sitelist = c(sitelist,dimnames(site.data)[[3]][i])
    lonlist = c(lonlist,site.data[1,'lon',i])
    latlist = c(latlist,site.data[1,'lat',i])
  }
}
lon.ctr = mean(lonlist)
lat.ctr = mean(latlist)
dist.ctr = earthdist(lat.ctr,lon.ctr,latlist,lonlist)
hdist.ctr = earthdist(lat.ctr,lon.ctr,lat.ctr,lonlist)
hdist.ctr[lonlist < lon.ctr] = -hdist.ctr[lonlist < lon.ctr]
vdist.ctr = earthdist(lat.ctr,lon.ctr,latlist,lon.ctr)
vdist.ctr[latlist < lat.ctr] = -vdist.ctr[latlist < lat.ctr]
angle.ctr = atan2(vdist.ctr,hdist.ctr)*180/pi

sitechroma = 90
sitehue = angle.ctr
sitelum = 90 - 70*(dist.ctr-min(dist.ctr))/(max(dist.ctr)-min(dist.ctr))
sitecolor = hcl(sitehue,sitechroma,sitelum)
ptcolor = sitecolor[match(site.df$name,sitelist)]

if (do.pdf) pdf(file=file.pdf,title=hdr)

# Coverage plots:
var = 'PM2.5'
# Same range as for predicted maps:
# There are a few values outside this range.
lim.PM2.5 = c(0,75)
n.time = dim(site.data)[1]
n.site = dim(site.data)[3]

daterange.dt = strptime(dat.regress$daterange,format='%Y%m%d',tz='GMT')
date.tick = pretty(daterange.dt)
date.tick = gsub('[A-Z]','',date.tick)

image.plot(site.data[,var,n.site:1],axes=F,main=str_c(dat.regress$region,' ',var),zlim=lim.PM2.5)

lim = par('usr')
xtick = midpoint(seq(lim[1],lim[2],len=n.time+1))
ytick = midpoint(seq(lim[3],lim[4],len=n.site+1))
####
## Note: for this set of runs only
## TBD: programmaticaly choose dates
####
doylab = c(324,345,1,25,48)
wdoytick = rle_ext(site.data[,'DOY',1])$start
wdoylab = rep.int(NA,length(doylab))
for (i in 1:length(doylab)) wdoylab[i] = min(which(site.data[,'DOY',1] == doylab[i]))
doylab = paste(month.abb[site.data[wdoylab,'month',1]],site.data[wdoylab,'day',1])

sitelab = dimnames(site.data)[[3]][n.site:1]
sitebase = sub('.*_','',sitelab)
siterle = rle_ext(sitebase)
# Delete prefix from sites with unduplicated base names;
wsingle = siterle$start[siterle$lengths == 1]
sitelab[wsingle] = sub('^..._','',sitelab[wsingle])
sitelab[grepl('EPA',sitelab)] = paste(sitebase[grepl('EPA',sitelab)],'E')
sitelab[grepl('DAQ',sitelab)] = paste(sitebase[grepl('DAQ',sitelab)],'D')

# Draw a point off the plot:
# This is necessary to get "text" to work.
points(-10,-10)

toffset = -.02
nday = dim(site.data)[1]
xtitle = paste('Day of Year',site.data[1,'day',1],month.name[site.data[1,'month',1]],site.data[1,'year',1],'to',site.data[nday,'day',1],month.name[site.data[nday,'month',1]],site.data[nday,'year',1])
text(xtick[wdoylab],lim[3]+toffset,lab=doylab,srt=90,xpd=NA,adj=1,cex=1)
# text(mean(xtick),lim[3]+6*toffset,lab=xtitle,xpd=NA)
text(lim[1]+toffset,ytick,lab=sitelab,xpd=NA,adj=1,cex=.8)
axis(1,at=xtick[wdoytick],label=F,tcl=-.25)
# halt()

var = 'Residuals'
resid.by.site = matrix(NA,n.time,n.site)
sites = unique(site.df$name)
dates = unique(sort(site.df$yyyymmddhhmm))
colnames(resid.by.site) = sites
isite.used = match(site.df$name,sites)
itime.used = match(site.df$yyyymmddhhmm,dates)
resid.by.site[cbind(itime.used,isite.used)] = site.df$residuals
image.plot(resid.by.site[,n.site:1],axes=F,main=str_c(dat.regress$region,' ',var))

lim = par('usr')
xtick = midpoint(seq(lim[1],lim[2],len=n.time+1))
ytick = midpoint(seq(lim[3],lim[4],len=n.site+1))
points(-10,-10)
toffset = -.02
text(xtick,lim[3]+toffset,lab=site.data[,'DOY',1],srt=90,xpd=NA,adj=1,cex=.6)
text(lim[1]+toffset,ytick,lab=dimnames(site.data)[[3]][n.site:1],xpd=NA,adj=1,cex=.6)

plot(lonlist,latlist,col=sitecolor,pch=19,cex=2,xlim=range(pretty(site.df$lon)),ylim=range(pretty(site.df$lat)),main='Site Colors',xlab='',ylab='',bty='n')
  position.labels(lonlist,latlist,sitelist,xlab='',ylab='',map=F,cex=2,cex.lab=.8)

# Scatterplot fitted vs. obs:
title = c(dat.regress$region,model.title,str_c('Rval',signif(dat.regress$Rval,3),'RMSerr',signif(dat.regress$RMSerr,3),sep=' '))
plot(fitted(dat.regress$fit),fitted(dat.regress$fit)+residuals(dat.regress$fit),xlim=lim.PM2.5,ylim=lim.PM2.5,xlab='Fitted',ylab='Obs',main=title,col=ptcolor,pch=19)

# Time series fitted/obs vs day
plot(site.df$jd,fitted(dat.regress$fit)/(fitted(dat.regress$fit)+residuals(dat.regress$fit)),xlab='DOY',ylab='Fitted/Obs',main=title,col=ptcolor,pch=19)

# Obs vs AOT
if ('AOT' %in% names(dat.regress$model.vars)) {
  rval =  cor(site.df$AOT,fitted(dat.regress$fit)+residuals(dat.regress$fit),use='complete.obs')
  RMSerr = sigma(lm(PM2.5~AOT,data=site.df))
  title = c(dat.regress$region,str_c('Rval',signif(rval,3),'RMSerr',signif(RMSerr,3),sep=' '))
  plot(site.df$AOT,site.df$PM2.5,xlab='AOT',ylab='Obs',main=title,col=ptcolor,pch=19,ylim=c(0,70))
}

# Obs vs AOT/CWV
if ('AOT' %in% names(dat.regress$model.vars) & 'CWV' %in% names(dat.regress$model.vars)) {
  rval =  cor(site.df$AOT/site.df$CWV,fitted(dat.regress$fit)+residuals(dat.regress$fit),use='complete.obs')
  RMSerr = sigma(lm(PM2.5~I(AOT/CWV),data=site.df))
  title = c(dat.regress$region,str_c('Rval',signif(rval,3),'RMSerr',signif(RMSerr,3),sep=' '))
  plot(site.df$AOT/site.df$CWV,fitted(dat.regress$fit)+residuals(dat.regress$fit),xlab='AOT/CWV',ylab='Obs',main=title,col=ptcolor,pch=19)
}

# Random effects
randeffects = ranef(dat.regress$fit)
plot(randeffects[[1]][,1],type='h',xlab='DOY',ylab=paste(randeffects$name,'Random Effect'),main=title)
points(randeffects[[1]][,1],pch=21,bg="cadetblue",cex=0.6)

### When rest of the script is fixed, move this to end
if (do.pdf) {
  dev.off()
  cat(file.pdf,'\n')
}

## May want to randomize point plot order, so that points later in time
## do not obscure earlier points so much.