#############################################################################
#
# Mark Cembrowski, Janelia Research Campus, Nov 6 2016
#
# This script plots does PCA for all hippocampal cells.
#
# If gsnList is supplied, then the PCA is performed on this list; otherwise,
# high CV genes are chosen across a range of expression values.
#
#############################################################################

singleCellPca <- function(gsnList=c(),x='PC1',y='PC2',quiet=T,
				xLim=c(),yLim=c(),alpha=0.2){
	subMat <- scHip

	if(length(gsnList)<0.1){

		# Identify genes to use for analysis via overdispersion.
		theAvg <- apply(subMat,1,mean)
		binMin <- 1 # molecules/cell to consider use for analysis.
		subMat <- subMat[theAvg>binMin,]
		theAvg <- apply(subMat,1,mean)
		theSd <- apply(subMat,1,sd)
		theCv <- theSd/theAvg
		binSize <- 118
		totGenesPerBin <- 3

		subMat <- subMat[order(theAvg),]
		theAvg <- theAvg[order(theAvg)]
		theSd <- theSd[order(theAvg)]
		theCv <- theSd[order(theAvg)]

		genesToKeep <- c()
		for (ii in 1:(floor(length(theAvg))/binSize)){
			firstInd <- 1+(ii-1)*binSize
			lastInd <- ii*binSize

			tempMat <- subMat[firstInd:lastInd,]
			tempCv <- apply(tempMat,1,sd)/apply(tempMat,1,mean)
			tempCv <- tempCv[order(-1*tempCv)]

			genesToKeep <- c(genesToKeep,names(tempCv)[1:totGenesPerBin])
		}
	}else{
		genesToKeep <- gsnList
		# Ensure all genes provided are in single cell data.
		genesToKeep <- genesToKeep[genesToKeep%in%rownames(scHip)]
	}
	print(paste('Using',length(genesToKeep),'for PCA'))

	# Do PCA.
	tempDat <- scHip[genesToKeep,]

	# Need to exclude genes if not expressed anywhere.
	isZero <- apply(tempDat,1,sum) < 0.1
	tempDat <- tempDat[!isZero,]
#	tempDat <- log10(tempDat+1)

	colourRule <- c('astrocytes_ependymal'='blue',
			'interneurons'='purple','microglia'='green',
			'oligodendrocytes'='brown','endothelial-mural'='red','pyramidal CA1'='grey')

	PC <- prcomp(t(tempDat),scale=T)
	if(!quiet){print(summary(PC))}
	dat <- data.frame(obsnames=row.names(PC$x),PC$x)
	theClasses <- scMeta$level1class[colnames(scHip)]
	dat[,'grp'] <- theClasses[rownames(dat)]

	# Sort data frame for nice plotting.
	dat <- rbind(
		subset(dat,grp=='pyramidal CA1'),
		subset(dat,grp=='oligodendrocytes'),
		subset(dat,grp=='interneurons'),
		subset(dat,grp=='astrocytes_ependymal'),
		subset(dat,grp=='microglia'),
		subset(dat,grp=='endothelial-mural'))
#	dat <- dat[order(-dat$grp),]

#
#	dat$grp <- factor(dat$grp,levels=c('astrocytes_ependymal',
#		'interneurons','oligodendrocytes','endothelial-mural','microglia','pyramidal CA1'))

	plot <- ggplot(dat,aes_string(x=x,y=y))
	plot <- plot + geom_point(alpha=alpha, size = 2, aes(label = obsnames,colour=grp))
	plot <- plot + theme_bw()
	plot <- plot + scale_colour_manual(values=colourRule)
#	plot <- plot + scale_x_log10() + scale_y_log10()

	if(abs(length(xLim)-2)<0.1){plot <- plot + scale_x_continuous(lim=xLim)}
	if(abs(length(yLim)-2)<0.1){plot <- plot + scale_y_continuous(lim=yLim)}
#	plot <- plot + scale_x_continuous(lim=c(xLo,xHi))
#	plot <- plot + scale_y_continuous(lim=c(yLo,yHi))

#	if(xLabLo<0){
#		plot <- plot + geom_text(data=subset(datLab,xVal<xLabLo),aes(x=xVal,y=yVal,label=obsnames),hjust=0,vjust=0,size=2)
#	}
#	if(xLabHi>0){
#		plot <- plot + geom_text(data=subset(datLab,xVal>xLabHi),aes(x=xVal,y=yVal,label=obsnames),hjust=0,vjust=0,size=2)
#	}
#	if(yLabLo<0){
#		plot <- plot + geom_text(data=subset(datLab,yVal<yLabLo),aes(x=xVal,y=yVal,label=obsnames),hjust=0,vjust=0,size=2)
#	}
#	if(yLabHi>0){
#		plot <- plot + geom_text(data=subset(datLab,yVal>yLabHi),aes(x=xVal,y=yVal,label=obsnames),hjust=0,vjust=0,size=2)
#	}

	print(plot)
}


library(MASS) # for lda
library(caret) # models and classification utils

# custom utils
source('functions.r')

#here you have to change the path to use your own data. Probably you will need to tune the read_tps function inside functions.r
file_path = './data/Muestra_563_UC3M_fixed.TPS'

tps = read_tps(file_path, remove_point_5 = TRUE, n_cases = 563)

# some columns names to use it latter
x_coord_names = tps$x_colnames
y_coord_names = tps$y_colnames
x_procrustes_coord_names = sprintf("x_%s_proc",1:length(x_coord_names))
y_procrustes_coord_names = sprintf("y_%s_proc",1:length(y_coord_names))
x_allom_coord_names = sprintf("x_%s_allom",1:length(x_coord_names))
y_allom_coord_names = sprintf("y_%s_allom",1:length(y_coord_names))

# compute all the diagnosis types combinations
diagnosis_combinations = combn(levels(tps$df$diagnosis), 2, simplify = FALSE)

for(comb in diagnosis_combinations){
  print(comb)
  data_filter = function(x) x %>% filter(diagnosis==comb[1] | diagnosis==comb[2])

  results_cols = c("Accuracy", "Sensitivity","Specificity", "Precision", "Recall", "F1")
  results = data.frame(matrix(ncol = length(results_cols), nrow = 0))
  colnames(results) = results_cols

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

  #### Procrustes  -> SVM
  # test name
  t_name = 'procrustes_svm'
  df = tps$df

  df = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE)

  res = test_LOOCV_svmRadial(df, c(x_procrustes_coord_names, y_procrustes_coord_names), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Procrustes -> allo -> SVM
  t_name = 'procrustes_allo_svm'
  df = tps$df

  gpa = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE, return_object=TRUE)
  df = remove_allometric_shape_effect(df, gpa)

  res = test_LOOCV_svmRadial(df, c(x_allom_coord_names, y_allom_coord_names), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Procrustes -> Remove Colinear -> SVM
  t_name = 'procrustes_colinear_svm'
  df = tps$df

  df = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE)
  (non_colinear_cols = get_noncolinear_columns(df, columns = c(x_procrustes_coord_names, y_procrustes_coord_names), max_percentage=0.96, plot_correlation=FALSE))

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Procrustes -> allo -> Remove Colinear -> SVM
  t_name = 'procrustes_allo_collinear_svm'
  df = tps$df

  gpa = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE, return_object=TRUE)
  df = remove_allometric_shape_effect(df, gpa)
  (non_colinear_cols = get_noncolinear_columns(df, columns = c(x_allom_coord_names, y_allom_coord_names), max_percentage=0.96, plot_correlation=FALSE))

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> PCA95 -> SVM
  t_name = 'distances_pca95_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  distances_pca = perform_pca_and_filter(distances_raw, columns=NULL, max_explained_var=0.95)
  df = cbind(df, distances_pca)

  res = test_LOOCV_svmRadial(df, colnames(distances_pca), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> PCA99 -> SVM
  t_name = 'distances_pca99_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  distances_pca = perform_pca_and_filter(distances_raw, columns=NULL, max_explained_var=0.99)
  df = cbind(df, distances_pca)

  res = test_LOOCV_svmRadial(df, colnames(distances_pca), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> PCA999 -> SVM
  t_name = 'distances_pca999_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  distances_pca = perform_pca_and_filter(distances_raw, columns=NULL, max_explained_var=0.999)
  df = cbind(df, distances_pca)

  res = test_LOOCV_svmRadial(df, colnames(distances_pca), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> Remove Colinear96 -> SVM
  t_name = 'distances_colinear96_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  (non_colinear_cols = get_noncolinear_columns(distances_raw, columns = NULL, max_percentage=0.96, plot_correlation=FALSE))
  df = cbind(df, distances_raw)

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> Remove Colinear99 -> SVM
  t_name = 'distances_colinear99_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  (non_colinear_cols = get_noncolinear_columns(distances_raw, columns = NULL, max_percentage=0.99, plot_correlation=FALSE))
  df = cbind(df, distances_raw)

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  #### Distances -> SVM
  t_name = 'distances_svm'
  df = tps$df
  distances_raw = get_all_distances(df, x_coord_names, y_coord_names)
  df = cbind(df, distances_raw)

  res = test_LOOCV_svmRadial(df, colnames(distances_raw), data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  ######## Procrustes -> Distances -> Remove Colinear -> SVM
  t_name = 'procrustes_distances_colinear_svm'
  df = tps$df

  df = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE)
  distances_procrustes = get_all_distances(df, x_procrustes_coord_names, y_procrustes_coord_names)
  (non_colinear_cols = get_noncolinear_columns(distances_procrustes, columns = NULL, max_percentage=0.96, plot_correlation=FALSE))
  df = cbind(df, distances_procrustes)

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  ######## Procrustes -> allo -> Distances -> Remove Colinear -> SVM
  t_name = 'procrustes_allo_distances_colinear_svm'
  df = tps$df

  gpa = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE, return_object=TRUE)
  df = remove_allometric_shape_effect(df, gpa)
  distances_procrustes = get_all_distances(df, x_allom_coord_names, y_allom_coord_names)
  (non_colinear_cols = get_noncolinear_columns(distances_procrustes, columns = NULL, max_percentage=0.96, plot_correlation=FALSE))
  df = cbind(df, distances_procrustes)

  res = test_LOOCV_svmRadial(df, non_colinear_cols, data_filter = data_filter, test_name=t_name)
  results = results %>% rbind(res)

  ##################################################################################
  ##################################################################################
  #diagnosis_table = df %>% data_filter %>% dplyr::select(diagnosis) %>% table
  #results = results %>% mutate(n_MAM=diagnosis_table['MAM'], n_NOR=diagnosis_table['NOR'], n_RIS=diagnosis_table['RIS'], n_SAM=diagnosis_table['SAM'])
  print(results)
}


#' GEE Beta Equations
#'
#' Creates GEE Equations for beta coefficients.
#'
#' @param betas vector of coefficients
#' @param rho overdispersion parameter
#' @param dat matrix of multinomial clusters
#'
#' @return estimating equations for betas
create_beta_equations <- function (betas, rho, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  betas.exp <- exp(betas)
  rho.sq <- rho ^ 2
  denom <- 1 + sum(betas.exp)
  dispi <- (ni * (1 + (ni - 1) * rho.sq))
  p.vec <- as.vector(betas.exp / denom)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  # create matrices
  d.mat <- (diag( betas.exp * denom, m ) - betas.exp %*% t( betas.exp )) / (denom ^ 2)
  var.mat <- diag( p.vec, m ) - p.vec %*% t( p.vec )
  r.vec <- dat[, 1:m] - ni * p.mat

  # result
  d.mat %*% solve(var.mat) %*% rowSums( t((ni / dispi) * r.vec) )
}

#' GEE Rho Equations
#'
#' Creates GEE Equations for rho (overdispersion parameter).
#'
#' @param rho overdispersion parameter
#' @param betas vector of coefficients
#' @param dat matrix of multinomial clusters
#'
#' @return estimating equations for rho
create_rho_equations <- function (rho, betas, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  betas.exp <- exp(betas)
  rho.sq <- rho ^ 2
  denom <- 1 + sum(betas.exp)
  dispi <- ni * (1 + (ni - 1) * rho.sq)
  p.vec <- as.vector(betas.exp / denom)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  # create matrices
  var.mat <- diag(p.vec, m) - p.vec %*% t(p.vec)
  r.vec <- dat[, 1:m] - ni * p.mat
  res <- tr( r.vec %*% solve(var.mat) %*% t( (1 / dispi) * r.vec) ) - m * num.clus

  res
}


args = commandArgs(trailingOnly=TRUE)
regrex <- read.csv(args[1])
png('r_orig.png')
plot(regrex, pch = 16, col = "blue")
dev.off()

lmRegrex = lm(x~y, data = regrex) #Create the linear regression
png('r_lm.png')
plot(regrex, pch = 16, col = "blue") #Plot the results
abline(lmRegrex) #Add a regression line
dev.off()


#!/usr/bin/Rscript

# M x N Chess Board.
M = 8; N = 8; board = matrix(0, nrow = M, ncol = N)

# Get/Set value on a board position.
getboard = function (position)    { board[position[1], position[2]] }
setboard = function (position, x) { board[position[1], position[2]] <<- x }

# (Relative) Hops of a Knight.
hops = cbind(c(-2, -1), c(-1, -2), c(+1, -2), c(+2, -1),
             c(+2, +1), c(+1, +2), c(-1, +2), c(-2, +1))

# Validate a move.
valid = function (move) {
    all(1 <= move & move <= c(M, N)) && (getboard(move) == 0)
}

# Moves possible from a given position.
explore = function (position) {
    moves = position + hops
    cbind(moves[, apply(moves, 2, valid)])
}

# Possible moves sorted according to their Wornsdorff cost.
candidates = function (position) {
    moves = explore(position)

    # No candidate moves available.
    if (ncol(moves) == 0) { return(moves) }

    wcosts = apply(moves, 2, function (position) { ncol(explore(position)) })
    cbind(moves[, order(wcosts)])
}

# Recursive function for touring the chess board.
knightTour = function (position, moveN) {

    # Tour Complete.
    if (moveN > (M * N)) {
        print(board)
        quit()
    }

    # Available moves.
    moves = candidates(position)

    # None possible. Backtrack.
    if (ncol(moves) == 0) { return() }

    # Make a move, and continue the tour.
    apply(moves, 2, function (position) {
                        setboard(position, moveN)
                        knightTour(position, moveN + 1)
                        setboard(position, 0)
                    })
}

# User Input: Starting position (in algebraic notation).
square = commandArgs(trailingOnly = TRUE)

# Convert into board co-ordinates.
row      = M + 1 - as.integer(substr(square, 2, 2))
ascii    = function (ch) { as.integer(charToRaw(ch)) }
col      = 1 + ascii(substr(square, 1, 1)) - ascii('a')
position = c(row, col)

# Begin tour.
setboard(position, 1); knightTour(position, 2)


library(lmerTest)
library(ggplot2)

rm(list=ls())

dta<-read.csv('..\\..\\..\\empowermentexploration\\data\\regression\\20211011-1425-tinyalchemy-valuedifferences-human-1.csv')
dtp<-read.csv('..\\..\\..\\empowermentexploration\\data\\regression\\20211011-1434-tinypixels-valuedifferences-human-1.csv')

dat<-data.frame(trial=scale(c(dta$trial, dtp$trial)),
                id=paste(c(dta$id, dtp$id+1000)),
                cbu=scale(c(dta$delta_cbu, dtp$delta_cbu)),
                emp=scale(c(dta$delta_emp, dtp$delta_emp)),
                bin=scale(c(dta$delta_bin, dtp$delta_bin)),
                decision=c(dta$decision, dtp$decision),
                game=c(rep('alchemy', nrow(dta)) ,rep('pixel', nrow(dtp))))

mfull1<-glmer(decision~-1+cbu+emp+game+game*emp+game*cbu+trial+trial*emp+trial*cbu+(1|id), family='binomial', data=dat)
ms<-summary(mfull1)
alechmym<-ms$coefficients[1:2,1]
alchemyse<-ms$coefficients[1:2,2]
ms

dat$game<-relevel(dat$game, ref='pixel')

mfull2<-glmer(decision~-1+cbu+emp+game+game*emp+game*cbu+trial+trial*emp+trial*cbu+(1|id), family='binomial', data=dat)
ms<-summary(mfull2)
pixelm<-ms$coefficients[1:2,1]
pixelmse<-ms$coefficients[1:2,2]
dp<-data.frame(mu=c(alechmym, pixelm), ci=1.96*c(alchemyse, pixelmse),
               game=rep(c('Tiny Alchemy', 'Tiny Pixels'), each=2),
               model=rep(c('Uncertainty', 'Empowerment'), 2))

ms

#limits with 95% CIs
limits <- aes(ymax = mu + ci, ymin= mu - ci)

#plot
p <- ggplot(dp, aes(x=model, y=mu)) +
  #bars
  geom_bar(position="dodge", stat="identity", width=0.6)+
  #error bars
  geom_errorbar(limits, position="dodge", width=0.25)+
  #points
  geom_point(size=3)+
  #color
  #scale_fill_manual(values = c(cbPalette))+
  #theme
  theme_minimal() +
  #limits
  #scale_y_continuous(limits = c(0,100), expand = c(0, 0)) +
  #two facets
  facet_wrap(~game, nrow=2)+
  #labs
  xlab("Model")+
  ylab(expression(beta))+
  #title
  ggtitle("")+
  #adjust text size
  theme(text = element_text(size=21,  family="sans"))+
  #no legend
  theme(legend.position = "none")

#png('modelcomparison.png', width=350, height=450)
p
dp

#
#
# ## BOTTOM UP ANALYSIS - uncomment when more detailed analyses needed
# # get model with single models as fixed effect
# me <- glmer(decision ~ -1 + emp + trial + trial*emp +game+game*emp+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(me)
#
# mb <- glmer(decision ~ -1 + bin + trial + trial*bin +game+game*bin+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mb)
#
# mu <- glmer(decision ~ -1 + cbu + trial + trial*cbu +game+game*cbu+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mu)
#
# # get model with empowerment and binary as fixed effect
# meb <- glmer(decision ~ -1 + emp + bin + trial + trial*emp + trial*bin +game+game*emp+game*bin+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meb)
#
# # get model with empowerment and CBU as fixed effect
# meu <- glmer(decision ~ -1 + emp + cbu + trial + trial*emp + trial*cbu +game+game*emp+game*cbu+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meu)
#
# # get model with binary and CBU as fixed effect
# mub <- glmer(decision ~ -1 + bin + cbu + trial + trial*bin + trial*cbu +game+game*bin+game*cbu+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mub)
#
# # get model with empowerment and binary and CBU as fixed effect
# meub <- glmer(decision ~ -1 + emp + bin + cbu + trial + trial*emp + trial*bin + trial*cbu +game+game*emp+game*bin+game*cbu+game*trial+ (1 | id), data=dat, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meub)
#
# # compare models
# anova(me, meb)
# anova(mb, meb)
# anova(me, meu)
# anova(mu, meu)
# anova(mb, mub)
# anova(mu, mub)
# anova(mub, meub)
# anova(meu, meub)
# anova(meb, meub)


libraries <- function() {
  library(quantmod)
  library(remotes)
  library(corrplot)
  library(cowplot)
  library(ggplot2)
  library(outlieR)
  library(magrittr)
  library(NoiseFiltersR)
  library(caret)
  library(TTR)
  library(readr)
  library(arm)
  library(png)
  library(grid)
  library(dplyr)
  library(tidyverse)
  library(Hmisc)
}


## Trabajo final MAPP Otoño. Métodos cuantitativos.
## Integrantes:
## Guadalupe Álvarez
## Ángel Carrillo
## Eduardo Muñiz

Sys.setlocale("LC_ALL", "es_ES.UTF-8") # Cambiar locale para prevenir problemas con caracteres especiales
options(scipen=999) # Prevenir notación científica
rm(list=ls()) #Limpia todas las variables y objetos creados

##### Paquetería ----
library(tidyverse)
library(ggplot2)
library(ggcorrplot)
library(ggthemes)

library(cluster)
library(dplyr)
library(pacman)
library(factoextra)
library(dendextend)
library(purrr)

#PAQUETERÍA PARA ANOVA Y REGRESIÓN LINEAL
library(lme4)
library(lmerTest)

##### Base de datos ----
computoeinegi <- read.csv("2021 computoeinegi.csv")
str(computoeinegi)
head(computoeinegi)
# View(computoeinegi)

###################################
####### Indice de cosas por hacer:
###################################

# FECHA DE ENTREGA: 13 Y 14 DE DICIEMBRE

# Limpiar la base
# Estadistica descriptiva LALO
# ANOVA LUPITA
# Regresión lineal con variables explicativas CARILLO
# Hito 1: DEBE ESTAR LISTO EL  25-NOV EN LA NOCHE
# Ahí cordinarnos por mensajería sobre lo siguiente.

# Usar variables explicativas para analisis de componentes principales
# crear subconjunto de variables
# utilizar estas variables explicativas para:
# Conglomerados
# Nuevo grupos
# con nuevos grupos analisis jerárquico.

##### Estadística descriptiva ----

gr_participacion <- ggplot( computoeinegi,
                   aes(x=distrito , y=participacion) )+
              geom_point() +
              labs(title="Participación electoral",
                  subtitle="Proceso Electoral Federal 2021.",
                  x="Distrito electoral federal",
                  y="Porcentaje de participación",
                  caption="Elaboración propia con datos de INE(2021).") +
              theme_economist()+
              theme(axis.text.x=element_text(angle=50,size=12))

plot(gr_participacion)

########
      ##  ANOVA  ##

#Creamos una base con la variable categórica complejidad que nos indicará el número de grupos
# y la variable de interés será el porcentaje de participación

Anova_part <- computoeinegi [, -c(1,2,3,4,5,6,8,9,11,12,13,14,15,16,17)]

# Gráfica simple
ggplot(data = Anova_part, aes(x = 1:nrow(Anova_part), y = participacion)) +
  geom_point() +
  theme_bw()

# Gráfica por complejidad
ggplot(data = Anova_part, aes(x = 1:nrow(Anova_part),
                              y = participacion, colour = complejidad)) +
                              geom_point() +
                              theme_bw()

# Grafica de la gran media
ggplot(data = Anova_part, aes(x = 1:nrow(Anova_part), y = participacion, colour = complejidad)) +
  geom_point() +
  geom_hline(yintercept = mean(Anova_part$participacion), colour = "purple", size = 1) +
  theme_bw()

# Graficar la gran media y las medias de los grupos
ggplot(data = Anova_part, aes(x = 1:nrow(Anova_part), y = participacion, colour = complejidad)) +
  geom_point() +
  geom_hline(yintercept = mean(Anova_part$participacion), colour = "purple", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="
Altamente Concentrado 1"]),
             colour = "orangered1", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="
Altamente Concentrado 2"]),
             colour = "orange", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Concentración Media"]),
             colour = "olivedrab", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Concentrado 1"]),
             colour = "green", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Concentrado 2"]),
             colour = "turquoise2", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Disperso 1"]),
             colour = "blue", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Disperso 2"]),
             colour = "royalblue", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Muy Disperso 1"]),
             colour = "violet", size = 1) +
  geom_hline(yintercept = mean(Anova_part$participacion[Anova_part$complejidad=="Muy Disperso 2"]),
             colour = "deeppink", size = 1) +
  theme_bw()

###
### ANOVA
### Hipótesis Nula = las medias son iguales
### Hipótesis Alternativa = No todas las medias son iguales

anova(lm(participacion ~ complejidad, data = Anova_part))


model_snowmelt <- function (ps = 0.0,
         M = 0.0){
    #'- Name: SnowMelt -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Snow Melt
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: Snow melt
    #'- inputs:
    #'            * name: ps
    #'                          ** description : density of snow cover
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : kg/m**3
    #'                          ** uri :
    #'            * name: M
    #'                          ** description : snow in the process of melting
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'- outputs:
    #'            * name: Snowmelt
    #'                          ** description : Snow melt
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : m
    #'                          ** uri :
    Snowmelt <- 0.0
    if (ps > 1e-8)
    {
        Snowmelt <- M / ps
    }
    return (list('Snowmelt' = Snowmelt))
}


require(sdcMicro)
tab <- readMicrodata(path="C:/Users/prasser/git/suda2/data/ihsn.csv", type="csv", header=TRUE, sep=";")
su <- suda2(tab)
su$score


#!/usr/bin/env Rscript

# http://www.sthda.com/english/articles/31-principal-component-methods-in-r-practical-guide/118-principal-component-analysis-in-r-prcomp-vs-princomp/

# install.packages('factoextra')
library(factoextra)

htseq_counts_folder <- getwd()

###
# read htseq-counts files
###

read_htseq <- function(main_folder, file_name) {
  read.csv(paste(main_folder, "/", file_name, sep=''),
           header=FALSE,
           row.names=1,
           col.names=c("gene", substring(file_name, 9, 10)),
           sep='\t')
}

htseq_count_list <- list.files(path=htseq_counts_folder, pattern="*.htseq_counts*")
for (i in 1:length(htseq_count_list)) {
  if (!exists("dataset")){
    dataset <- read_htseq(htseq_counts_folder, htseq_count_list[i])
  }
  else {
    temp_dataset <- read_htseq(htseq_counts_folder, htseq_count_list[i])
    dataset <- cbind(dataset, temp_dataset)
    rm(temp_dataset)
  }
}

# remove statistics at the end of each hteq-counts file (last 5 lines)
dataset <- dataset[-seq(nrow(dataset) - 4, nrow(dataset)),]
dataset <- t(dataset)

# change row names
rownames(dataset) <- c("1A", "1B", "1C", "3A", "3B", "3C", "5A", "5B", "5C", "7A", "7B", "7C")

###
# pca
###

png("PCA_htseq_counts.png")
dev.control('enable')
pca <- prcomp(dataset)
pca_graphic <- fviz_pca_ind(pca,
             invisible=c("quali"),
             col.ind=c("#00AFBB","#00AFBB", "#00AFBB", "#00BB22","#00BB22","#00BB22", "#BBBB00","#BBBB00","#BBBB00", "#BB3000","#BB3000","#BB3000"),
             repel=TRUE)
pca_graphic + theme(legend.position="none")
dev.copy(postscript, "PCA_htseq_counts.eps", onefile=TRUE, horizontal=FALSE)
dev.off()
dev.off()


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

input_file = "assunpink.csv"
CSVFile = read.csv(file = input_file, header = T)
data_col = 3
year_col = 1
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
lmfit = lm(Data~Year)
cat("Slope: ",lmfit$coefficients[2],'\n')
fit_summary = summary(lmfit)
cat('p-value of slope:', fit_summary$coefficients[2,4],'\n')
cat('R2 of fit:', fit_summary$r.squared,'\n')
pdf("Results/TimeSeriesAssunpink.pdf")
plot(Year,Data, col = "red", pch = 19,main = "Assunpink Creek", xlab = "Year", ylab = NA,cex.lab = 1.33,cex.axis =1.33,cex.main = 1.33)
abline(lm(Data~Year), col = "blue", lwd = 2)
dev.off()


useLog<-1  # 0= no log N and no log F, 1=log N and (no log) F, 2=log N and log F

# extract covariance or correlation matrix

fit<-read.fit()
#str(fit)

getCorCov<-function(vname,fit){
    idx<-which(fit$names %in% vname)
    COR<-fit$cor[idx,idx]
    COV<-fit$cov[idx,idx]
    labels<-paste(fit$names[idx],paste("sp",fit$species[idx],sep=''),paste("Age",fit$age[idx],sep=''),sep='.')
    dimnames(COR)<-list(labels,labels)
    dimnames(COV)<-list(labels,labels)
    val<-fit$est[idx]
    return(list(cov=COV,cor=COR,val=val,species=fit$species[idx],age=fit$age[idx],vari=fit$names[idx]))
}

 a<-getCorCov(vname=c("term_N_next","term_N_next"),fit=fit)
 a

if (useLog==0) a<-getCorCov(vname=c("term_N_next","term_F"),fit=fit)
if (useLog==1) a<-getCorCov(vname=c("log_term_N_next","term_F"),fit=fit)
if (useLog==2) a<-getCorCov(vname=c("log_term_N_next","log_term_F"),fit=fit)

COV<-a$cov
est<-a$val  # estimate used to for COV

if (T) {   # test input and output
  outFile<-file.path(data.path,"OP_Nnext_F_covariance.in")
  write.matrix(COV,file=outFile,sep=',')
  COV<-read.csv(file=outFile)
  dimnames(COV)[[1]]<-dimnames(COV)[[2]]
  outFile<-file.path(data.path,"OP_Nnext_F_value.in")
  write(est,file=outFile)
  est<-scan(file=outFile)

  outFile<-file.path(data.path,"OP_Nnext_F_labels.in")
  write.table(data.frame(Species=a$species,Age=a$age,vari=ifelse(a$vari=="log_term_N_next",'N','F')),file=outFile,col.names=T,row.names=F)

}

cleanup()
levelplot(a$cor,xlab='',ylab='',main='Before',at=seq(-1,1,0.05))

# get the values of F at age in the terminal year, and N  at age in the Terminal Year+1
n<-10000
x<-mvrnorm(n=n, mu=est, Sigma=COV)

Nlast<-min(grep("term_F",dimnames(COV)[[1]]))-1
fin<-length(est)

if (useLog==0) noiseFactor<-x/rep(est,each=n)
if (useLog==1) {
  noiseFactor<-x
  noiseFactor[,1:Nlast]<- exp(x[,1:Nlast]-rep(est[1:Nlast],each=n))
  noiseFactor[,(Nlast+1):fin]<- exp(x[,(Nlast+1):fin]-rep(est[(Nlast+1):fin],each=n))
}
if (useLog==2) noiseFactor<-x-rep(est,each=n)

X11()
levelplot(cor(noiseFactor),xlab='',ylab='',main='After',at=seq(-1,1,0.05))

apply(noiseFactor[,1:4],2,summary)

X11()
par(mfcol=c(7,7),mar=c(3,1,1,1))     #c(bottom, left, top, right)
for (i in (1:dim(noiseFactor)[[2]])) {
  hist(noiseFactor[,i],main=dimnames(noiseFactor)[[2]][[i]])
}


pvals <- sapply ( 1 : m , function ( i ){
  control <- sample ( population , 6 )
  treatment <- sample ( population , 6 )
  if ( ! nullHypothesis [ i ]) treatment <- treatment + delta
  t.test ( treatment , control ) $ p.value
})
sum(pvals < 0.05/10000)


#       __  ___
#      /  |/  /___ _______________
#     / /|_/ / __ `/ ___/ ___/ __ \
#    / /  / / /_/ / /  / /__/ /_/ /
#   /_/  /_/\__,_/_/   \___/\____/
#  _       ___      __  __    ___
#  | |     / (_)____/ /_/ /_  / (_)___
#  | | /| / / / ___/ __/ __ \/ / / __ \
#  | |/ |/ / / /  / /_/ / / / / / / / /
#  |__/|__/_/_/   \__/_/ /_/_/_/_/ /_/-------------------------------------------------------------------------

#S2876507

# Running instructions: Press Ctrl+A, then Ctrl+Enter. "plyr" package must be installed.
# If you zoom in on the graph, drag the window a bit to the right, until the plots are roughly of quadratic shape (nicer that way).

library("plyr")

# exp_dict according to Taatgen, van Rijn and Anderson (2004)
exp_dict <- list(
    tick_increment = 1.1,
    b = 0.015,
    tick_base = 11,
    decay = -0.75, #decay parameter, default 0.5
    amount_subjects = 5, # subjects per interval
    amount_trials = 500, # amount of trials per subject and per interval
    subject_data = data.frame(matrix(ncol = 4, nrow = 0)),
    parm_t = 20
)

# act-r noise
noise <- function(number)
{
    random <- runif(1, min = 0.0001, max = 0.9999)
    number * log( (1 - random ) / random)
}

# function which converts time in ms to an internal representation in pulses
msecs_to_pulses <- function(msecs)
{
    pulse_counter = 0 # number of accumulated pulses
    time_counter <- 0 # passed time
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (time_counter < msecs)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    pulse_counter
}

# function which produces time in ms based on an internal representation in pulses
pulse_to_msces <- function(pulses_input)
{

    time_counter <- 0 # passed time
    pulse_counter <- 0 # number of pulses
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (pulse_counter < pulses_input)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    time_counter
}

experiment_setup <- function(current_subject) #I want setup the experiment parameters for each subject, once
{
    real_time <- 0 #this is the subjects objective time in ms. this will stay with the subject for the duration of the experiment
    DecMem <- matrix(NA, 35, 900)
    #simuli for the trials get determined:
    short_condition_values <- seq(494, 847, length=11) #values of the short interval get determined
    short_condition_sample <- sample(short_condition_values, exp_dict$amount_trials, replace = TRUE)
    medium_condition_values <- seq(671, 1023, length=11) #values of the short interval get determined
    medium_condition_sample <- sample(medium_condition_values, exp_dict$amount_trials, replace = TRUE)
    long_condition_values <- seq(847, 1200, length=11) #values of the short interval get determined
    long_condition_sample <- sample(long_condition_values, exp_dict$amount_trials, replace = TRUE)

    condition_order <- sample(c(1, 2, 3)) #randomization of experimental condition order (1=short, 2=medium, 3=long)

    list(real_time = real_time, subject_nr = current_subject,
        DecMem = DecMem,
        short_condition_sample = short_condition_sample,
        medium_condition_sample = medium_condition_sample,
        long_condition_sample = long_condition_sample,
        condition_order = condition_order
    )
}

encounter_add <- function(subject_setup, sample_int_pulse)
{
    tmp <- sum(!is.na(subject_setup$DecMem[sample_int_pulse, ])) + 1
    subject_setup$DecMem[sample_int_pulse, tmp] <- subject_setup$real_time
    subject_setup$real_time <- subject_setup$real_time + 50
    subject_setup
}

encounters_get <- function(subject_setup, current_row)
{
    tmp <- subject_setup$DecMem[current_row,]

    if (length(tmp[!is.na(tmp)]) == 0){
        return(NA)
    }else{
        return(tmp[!is.na(tmp)])
    }

}

chunk_activation <- function(encounters, curtime)
{
    if (curtime < min(encounters)) {
        return(NA)
    } else {
        sum((curtime - encounters[encounters<curtime])^exp_dict$decay)
    }
}

prob_calc <- function(current_activation, total_activation)
{
    dividend = sum(current_activation) / exp_dict$parm_t
    divisor = total_activation / exp_dict$parm_t

    retrieval_prob = dividend / divisor
}

blending <- function(subject_setup)
{
    total_activation <- 0
    blended_response <- 0

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {
            encounters <- encounters_get(subject_setup, current_row)

            current_activation <- chunk_activation(encounters, subject_setup$real_time)

            total_activation <- total_activation + current_activation # ACTIVATION OF THE DECLARATIVE MEMORY
        }
    }

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {

        encounters <- encounters_get(subject_setup, current_row)

        current_activation <- chunk_activation(encounters, subject_setup$real_time)

        retrieval_prob <- prob_calc(current_activation, total_activation)
        blended_response <- blended_response + (retrieval_prob * current_row)

        }
    }

    blended_response
}

trial <- function(current_condition, subject_setup)
{
    if(current_condition == 1){
        current_condition_sample <- subject_setup$short_condition_sample} else if(current_condition == 2){
            current_condition_sample <- subject_setup$medium_condition_sample} else if(current_condition == 3){
                current_condition_sample <- subject_setup$long_condition_sample}

    for (.. in seq(1, length(current_condition_sample))) #length = amount_trials (default: 500)
    {
        ts <- current_condition_sample[..] # sample interval (ts) for the current trial
        subject_setup$real_time <- subject_setup$real_time + 1.000 + sample(seq(0.250, 0.850), 1) + 0.100 + ts + 0.50

        # presentation of central fixation point (+1000), + variable delay ranging from 0.25–0.85s
        # + "READY?" flash for 100 ms + actual time of the sample interval
        # + "SET!" flash (lasted 100ms, but tp was recorded alrady after 50ms)

        sample_int_pulse <- msecs_to_pulses(ts) # the sample interval gets converted into pulses

        subject_setup <- encounter_add(subject_setup, sample_int_pulse)

        blended_response <- blending(subject_setup)
        tp <- pulse_to_msces(blended_response)

        subject_setup$subject_data <- rbind(subject_setup$subject_data, c(subject_setup$subject_nr, current_condition, ts, tp))
    }

    subject_setup
}

train <- function(current_condition, subject_setup)
{
    train_amount <- 250
    if(current_condition == 1){
        current_condition_sample <- subject_setup$short_condition_sample} else if(current_condition == 2){
            current_condition_sample <- subject_setup$medium_condition_sample} else if(current_condition == 3){
                current_condition_sample <- subject_setup$long_condition_sample}

    for (.. in seq(1, train_amount))
    {
        ts <- current_condition_sample[..] # sample interval (ts) for the current trial
        subject_setup$real_time <- subject_setup$real_time + 1 + sample(seq(0.250, 0.850), 1) + 0.100 + ts + 0.50
        sample_int_pulse <- msecs_to_pulses(ts) # the sample interval gets converted into pulses
        subject_setup <- encounter_add(subject_setup, sample_int_pulse)
    }
    subject_setup
}

main <- function()
{
    simulated_data <- data.frame(matrix(ncol = 4, nrow = 0))

    for (.. in seq(1, exp_dict$amount_subjects)) #loop for subjects
    {
        current_subject <- ..
        subject_setup <- experiment_setup(current_subject)

        for (.. in subject_setup$condition_order) # loop containing all conditions
        {
            current_condition <- ..
            subject_setup$DecMem <- matrix(NA, 35, 900) #new DM each day(condition)
            subject_setup <- train(current_condition, subject_setup)
            subject_setup$real_time <- subject_setup$real_time + 1
            subject_setup <- trial(current_condition, subject_setup) #here the trials happen (another loop inside)

        }

        simulated_data <- rbind(simulated_data, subject_setup$subject_data)
    }

    colnames(subject_setup$subject_data) <- c("Subject_Nr ", "Cond", "Ts", "Tp")
    subject_data <- data.frame(subject_setup$subject_data)
    subject_data$Response[is.nan(subject_data$Response)] <- subject_data$Prior[is.nan(subject_data$Response)]
    subject_data
}

plotting <- function(dataframe)
{

    brown <- "#8b4513";
    red <- "#ff1100";
    black <- "#000000";
    brownT <- "#8b451322";
    redT <- "#ff110022";
    blackT <- "#00000022";

    ## ---
    datJS <- dataframe
    par(mfrow=c(1,1))

    plotDatJS <- with(datJS,aggregate(list(Tp=Tp),list(Ts=Ts,Cond=Cond),mean))
    agregJS <- ddply(datJS, c("Cond", "Ts"), summarise, Ts_mean = mean(Ts), Tp_mean = mean(Tp))
    yrange <- range(plotDatJS$Ts)*c(.95,1.05)

    with(plotDatJS[plotDatJS$Cond==3,],plot(Ts,Tp,type="b",col=red,lwd=2,ylim=yrange,xlim=yrange,main="J&S All"))
    with(plotDatJS[plotDatJS$Cond==2,],lines(Ts,Tp,type="b",col=brown,lwd=2,ylim=yrange,xlim=yrange))
    with(plotDatJS[plotDatJS$Cond==1,],lines(Ts,Tp,type="b",col=black,lwd=2,ylim=yrange,xlim=yrange))

    lines(c(yrange[1],yrange[2]),c(yrange[1],yrange[2]),col="darkgrey",lty=2)

    with(datJS[datJS$Cond==3,],points(jitter(Ts),Tp,col=redT,pch=".",cex=3))
    with(datJS[datJS$Cond==2,],points(jitter(Ts),Tp,col=brownT,pch=".",cex=3))
    with(datJS[datJS$Cond==1,],points(jitter(Ts),Tp,col=blackT,pch=".",cex=3))
}

plotting(main())


# setup ----------------------------------------------------------------
rm(list = ls())
library(ape)
set.seed(0)

# import dat ----------------------------------------------------------
dat <- read.csv("data-long.csv")
names(dat) <- c("can", "bout", "plot", "tmnt", "tsct", "cat", "occ")
dat$can <- ifelse(dat$can == "barloy", 2, 1)
dat$tmnt <- ifelse(dat$tmnt == "control", 0, 1)
dat$tid <- # give uniqe id to each transect-bout
    with(dat, paste0(can, bout, plot, tmnt, tsct))
dat$pt <- rep(1:40, len = nrow(dat))

# define functions --------------------------------------------------
get_i <- function(tran, mlag) {
    # get Moran's I of a transect at a given lag distance
    Moran.I(tran, mlag)$observed
}
get_is <- function(lag, bdata, mdist) {
    # get Moran's Is at each lag distance of each (resampled) transect-bout
    # assumes data comes in "box" format, which is a stack of tables.
    #   data are occurrences at points along transects (0, 1)
    #   the bottom stack is observed data,
    #       rows are transect-bouts,
    #       columns are points along the transects-bouts
    #   the upper stacks are resampled transect-bout data
    mlag <- # create lag-weighted distance matrix
        ifelse(mdist == lag, 1, 0)
    # returns a table. Has same format as observed data table, except
    #   columns are lag distances instead of transect points
    apply(bdata, c(1, 3), get_i, mlag)
}

# number of iterations -------------------------------------------------
# 1000 takes a long time to run. Load image below to skip computation.
nits <- 1000

# permutate Is ---------------------------------------------------------
cats <- c("bapi", "bu", "ag", "onh", "onn", "inv")
lboxis <- lapply(1:length(cats), function(x) NA)
for (i in 1:length(cats)) {
    # i <- 1
    cat <- cats[i]
    datcat <- dat[dat$cat == cat, ]
    # create matrix or transect-bout data
    #     rows are transect-bouts
    #     columns are points along transects
    trans <- tapply(datcat$occ, list(datcat$tid, datcat$pt), function(x) x)
    trans <- # remove transect-bouts with 0 variance or Moran.I() will choke
        trans[apply(trans, 1, var) != 0, ]
    nrows <- nrow(trans)
    ncols <- ncol(trans)
    nlags <- # weirdness happens when nlags >= half the no. transect points
        ((ncol(trans) / 2) - 1 )
    mdist <- as.matrix(dist(1:ncols))
    # create stack of matrices of resampled transect-bout data
    #     rows are transect-bouts
    #     columns are points along transects
    #     layers are iterations (n = nits)
    reps <- replicate(nits, t(apply(trans, 1, sample, ncols)))
    boxcat <- # create the "box"
        array(NA, dim = c(nrows, ncols, nits + 1))
    boxcat[, , 1] <- # bottom layer is observed data
        trans
    boxcat[, , -1] <- # upper layers are resampled data
        reps
    # compute Moran's I for each (resampled) transect-bout at each lag distance
    # returns a list of tables
    lis <- lapply(0:(nlags + 1), get_is, bdata = boxcat, mdist = mdist)
    # Stack each element of the list into another box
    boxis <- array(unlist(lis), dim = c(nrows, nits + 1, nlags))
    # permutate box to same format where
    #     rows are transect-bouts
    #     columns are lag distances
    #     layers are observed/resampled
    lboxis[[i]] <- aperm(boxis, c(1, 3, 2))
}

# calculate ranks
lranks <- lapply(1:length(cats), function(x) NA)
for (i in 1:length(cats)) {
    boxis <- lboxis[[i]]
    # "collapse" box into table of proportions where
    #   a datum is the proportion of resampled data "above" an observed datum
    #     that is greater than or equal to that observed datum
    #   rows are transect-bouts
    #   columns are lag distances
    lranks[[i]] <- apply(boxis, c(1, 2), function(k) sum(k[1] >= k[-1]) / nits)
}

# calculate median ranks
lmedians <- lapply(1:length(cats), function(x) NA)
for (i in 1:length(cats)) {
    ranks <- lranks[[i]]
    # "collapse" table into vector of medias
    lmedians[[i]] <- apply(ranks, 2, median)
}

# save r data
# save.image("./autocorrelation.rdata")

# load r data #
load("./autocorrelation.rdata")

# plot
catnams <- c("Coyote Brush", "Bunch Grass", "Annual Grass",
             "Other Native Herb", "Other Non-native", "Invasive")
colors <- c("#996600", "#669900", "#ffcc00",
          "#99cc00", "#ff9900", "#ff0000")
x <- 0.2
xsleg <- c(rep(x, 6))
ysleg <- rev(seq(0.03, 0.27, length.out = 6))
x1sleg <- rep(x + 5.1, 6)
x2sleg <- rep(x + 6.7, 6)
lwd <- 2
ltys <- c("solid", "a2", "8212", "621212", "42121212", "12")

# plot 1
data <- lboxis[[1]]
transect <- data[1, , 1]
treps <-  t(data[1, , -1])
png('./figures/correlation-1.png',
    width = 6, height = 4, units = "in", res = 300)
par(las = 1, mar = c(4, 5, 2, 1),
    cex = 0.8, cex.axis = 0.9,
    xaxs = "i", yaxs = "i")
plot(c(1, 20), c(-1, 1),  type="n", axes = F, xlab = "",
     xlim = c(1, nlags + 2), ylim = c(-1, 1),
     ylab = "Moran's I")
title(xlab = "Lag Distance (m)", line =2)
box(bty = "l")
boxplot(treps, add = T, border = "gray", col = "gray", outline = F,
        outwex = 2.5, staplewex = 0, whisklty = "solid", range = 0,
        boxwex = 0.7, axes = F)
lines(1:nlags, transect, lwd = 1, col = colors[1])
axis(1, at = c(1, 5, 9, 13, 17, 21), labels = c(0, 1:5))
axis(2)
lines(c(1.5, 2.3), c(-0.6, -0.6), lwd = 1, col = colors[1])
t1 <- expression(paste(italic(I),
                      " of example transect at lag distance"))
text(2.6, -0.6, t1, adj = c(0, 0.5))
polygon(c(1.5, 1.5, 2.3, 2.3), c(-0.85, -0.75, -0.75, -0.85),
        col = "gray", border = "white")
lines(c(1.9, 1.9), c(-0.7, -0.9), col = "gray")
t2 <- expression(paste("IQR and range of ",
                      italic(I),
                      " of resampled transect (n = 1000) at lag distance"))
text(2.6, -0.8, t2, adj = c(0, 0.5))
dev.off()

# plot 2
ranks <- lranks[[1]]
rank25 <- apply(ranks, 2, quantile, probs = 0.25)
rank75 <- apply(ranks, 2, quantile, probs = 0.75)
png(paste0('./figures/correlation-2.png'),
    width = 6, height = 4, units = "in", res = 300)
par(las = 1, mar = c(4, 5, 2, 1),
    cex = 0.8, cex.axis = 0.9,
    xaxs = "i", yaxs = "i")
plot(lmedians[[1]], type = "n", axes = F, xlab = "",
     xlim = c(0, nlags + 1), ylim = c(0, 1), ylab = "")
title(xlab = "Lag Distance (m)", line = 2)
title(ylab = "Median Rank Relative to Resampled", line = 3)
lines(0:(nlags + 1), rep(0.5, nlags + 2), lwd = 0.5)
ltys <- c("solid", "a2", "8212", "621212", "42121212", "12")
i <- 1
medians <- lmedians[[i]]
lines(0:(nlags - 1), medians, lwd = lwd, col = colors[i], lty = ltys[i])
lines(0:(nlags - 1), rank25, lty = 3, col = colors[i])
lines(0:(nlags - 1), rank75, lty = 3, col = colors[i])
axis(1, at = c(0, 4, 8, 12, 16, nlags + 1), labels = c(0, 1:4, 5))
axis(2, at = c(0, 0.25, 0.5, 0.75, 1 ))
lines(c(0.5, 1.3), c(0.10, 0.10), lwd = 2, col = colors[1])
t1 <- expression(paste("Median Rank of Observed ",
                       italic(I),
                      " Relative to Resampled"))
text(1.6, 0.10, t1, adj = c(0, 0.5))
lines(c(0.5, 1.3), c(0.05, 0.05), lty = 3, col = colors[1])
t2 <- expression(paste("25th/75th Percentile Rank of Observed ",
                       italic(I), "..."))
text(1.6, 0.05, t2, adj = c(0, 0.5))
dev.off()

# plot 3 -----------------------------------------------------------------
png(paste0('./figures/correlation-3.png'),
    width = 6, height = 4, units = "in", res = 300)
par(las = 1, mar = c(4, 5, 2, 1),
    xaxs = "i", yaxs = "i",
    cex = 0.8, cex.axis = 0.9)
plot(lmedians[[1]], type = "n", axes = F, xlab = "",
     xlim = c(0, nlags + 1), ylim = c(0, 1),
     ylab = "Median Rank Relative to Resampled")
title(xlab = "Lag Distance (m)", line = 2)
lines(0:(nlags + 1), rep(0.5, nlags + 2), lwd = 0.5)
for (i in length(cats):1) {
    medians <- lmedians[[i]]
    lines(0:(nlags - 1), medians, lwd = lwd, col = colors[i], lty = ltys[i])
    axis(1, at = c(0, 4, 8, 12, 16, nlags + 1), labels = c(0, 1:4, 5))
    axis(2, at = c(0, 0.25, 0.5, 0.75, 1 ))
    text(x = xsleg[i], y = ysleg[i], labels = catnams[i], adj = c(0, 0.5))
    lines(x = c(x1sleg[i], x2sleg[i]), y = c(ysleg[i], ysleg[i]),
          lwd = lwd, col = colors[i], lty = ltys[i])
}
dev.off()


###########################################################################
#########This script analyzes thaw depth data from    #####################
#########the summer of 2016 in Cherskiy Russia        #####################
#########The data consists of thaw depth measured     #####################
#########below a transect or under sap flux trees     #####################
###########################################################################

#1. read in data

	#A. read in necessary packages for this R session
	#note run the commented out install.packages if you haven't installed them
	#install.packages(c("lubridate"))
		library(lubridate)

	#B. set the working directory
		setwd("c:\\Users\\scardarelli/Documents/research/siberia_lai/R_Intro-master/2_Datasets/")

	#C. read in thaw depth csv
		datTD <- read.csv("thaw_depth.csv")

	#D. check data
		head(datTD)

#2. Convert dates to day of year

	#A. specify date format
		dateTD <- as.Date(datTD$Date, "%m/%d/%Y")

	#B. extract the day of year out of the date and add to datTD
		datTD$doyTD <- yday(dateTD)

	#C. extract the year out of the date and add to datTD
		datTD$yearTD <- year(dateTD)

		####################################################
		############ lubridate       #######################
		####################################################
		#as.Date(Vector of dates or date/time, date format)
			#see here for table of date format symbols:
			# https://www.r-bloggers.com/date-formats-in-r/

		#yday(as.Date output) gives a vector of day of year

		#year(as.Date output) gives a vector of year

#3. Get the average thaw depth by site

	#A. First way to get the average

		ave1 <- tapply(datTD$TD, datTD$Site, FUN="mean")

		####################################################
		############ tapply()        #######################
		####################################################
		#tapply(vector, Index (can be a list of multiple vectors or a single vector of factors), FUN= "function")
		####################################################

		#look at results
		ave1
		#let's get some information about what this output is
		str(ave1)

		#you'll see the name of the factor for each mean is linked as an object called dimnames
		#and the means are actually stored in ave 1 as vector
		dimnames(ave1)

		#pull out the DAV mean
		ave1[1]

		#you'll also note there is an inconsistancy in the name for the Davydov forest

#4. Fix the site name for Davydov

	#A. using the ifelse function we can apply a statement to the entire vector of names
		#Note: it will also be easier if we give the stand names a numerical id rather than
		#treat them as characters.

		datTD$standID <- ifelse(datTD$Site == "DAV" | datTD$Site == "DAVY", 1,
							ifelse(datTD$Site == "LDF2", 2, NA))

		####################################################
		############ ifelse()        #######################
		####################################################
		#ifelse(logical statement, output if true, output if false)
		#Note: we just used logical statements:
		# here the == denotes is equal to
		# | means or
		####################################################

	#B. setup a flag to make sure we don't have any names that don't fit in
	    #our ifelse statement that statement

			if( length( which( is.na(datTD$standID) ) ) > 0){
				print("ERROR unnamed site")
				}else{
						print("No unnamed sites")
					}

		#there's a lot going on here
		#we might be concerned that our ifelse statement might work but it could
		#spit out NAs when it shouldn't, and we might not notice without scrolling
		#through the data.

		#we just used the other version of if. This only evaluates one element at a time
		# we would need a for loop (we'll cover these in the future) to iterate through
		# the if statement above if we wanted to use it to make our standID

		####################################################
		############ IF and IF/ELSE  #######################
		####################################################

		#here is how this if statement works
		#if(logical statement){
			#does whatever is in these brackets if true
		#}

		#you can also add an else statement if you want

		#if(logical statement){
		# does whatever is in these brackets if true
		#}else{
				#does whatever is in these brackets if true
			#}

		####################################################
		############ length          #######################
		####################################################

		#length(vector)

		#this will return a single number, the length of your vector

		####################################################
		############ which           #######################
		####################################################

		#which(logical statement)

		#which will return the row numbers of data that meets a logical statement

		####################################################
		############ is.na           #######################
		####################################################

		#is.na(data element)

		#returns a true or false if there is an NA value
		####################################################

#5. Get the average for the stand and day of year

		#A.  take the average across stand and day of year
			TDave<-aggregate(datTD$TD, by=list(datTD$doyTD, datTD$standID), FUN="mean")
			TDave
		#B. rename the columns to be more informative
			colnames(TDave)<-c("doy","standID", "TD")

		####################################################
		############ aggregate       #######################
		####################################################

		#aggregate(data.vector, by=list(one or more numerical index or factors), FUN="function")

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

#6. Make a plot of the average thaw depth over time	with each stand seperated

		#A. set up the plot

			#start by plotting high density
			plot(TDave$doy[TDave$standID==1],TDave$TD[TDave$standID==1],
				ylim=c(min(TDave$TD)-5,max(TDave$TD)+5),
				xlim=c(min(TDave$doy)-2,max(TDave$doy)+2), type="b",
				xlab="Day of Year", ylab="Thaw depth (cm)", pch=19, col="forestgreen" )

		#B.#add points for low density
			points(TDave$doy[TDave$standID==2],TDave$TD[TDave$standID==2],
			 pch=19, col="deepskyblue3",type="b" )

		#C. add a legend

			legend(min(TDave$doy),max(TDave$TD),
					c("high density", "low density"),
					col=c("forestgreen", "deepskyblue3"), pch= 19, bty="n",
					cex=1.25)

		####################################################
		############ plot            #######################
		####################################################

		#plot(x.coordinates,y.coordinates, xlim=c(lower value, upper value),
		#	ylim=c(lower value, upper value), xlab="label for axis",
		#	ylab="label for axis", pch=point.shape.number,
		#	col=" colorname", type="b" for both "p" for point "l" for line)

		####################################################
		############ points          #######################
		####################################################

		#adds points to existing plot
		#points(x.coordinates,y.coordinates,pch=point.shape.number,
		#	col=" colorname", type="b" for both "p" for point "l" for line)

		####################################################
		############ legend          #######################
		####################################################

		#adds a legend to a plot
		#legend(upper.left.x.coordinate, upper.left.y.coordinate,
		#		c(vector of labels), col=c(vector of colors for point or line)
		#		OR fill=c(vector of colors for box fill), pch or lty arguments,
		#		bty="n" this gets rid of the ugly box, cex=+1 for bigger legend)
		####################################################

#7. Activities to complete on your own:

	#A. calculate the standard deviation sd() for each stand and day of year

	#B. add arrows to the plot using arrows() with the code argument set to zero

	#C. Make a plot that looks at the thaw depth for each tree in the Davydov stand


#' Rank products of a matrix where larger statistics have stronger rank
#'
#' Rank products of a matrix. Larger statistics have stronger rank.
#'
#' @param mat Numeric matrix with columns holding statistics per comparison & rows are analytes.
#' @param nsim Numeric number of simulations.
#' @param seed Random seed.
#' @inheritParams ezlimma::ezcor
#' @return Data frame with statistics from rank products test.
#' @export

rankprod <- function(mat, nsim=1e7-1, reorder.rows=TRUE, prefix=NULL, seed=100){
  stopifnot(!is.null(colnames(mat)))
  rmat <- apply(mat, 2, rank)
  rmat <- rmat/nrow(mat)

  colnames(rmat) <- paste(gsub("\\..$", "", colnames(mat)), "Rank.Prop", sep=".")

  set.seed(seed)
  rmat.sim <- apply(rmat, 2, function(v, nsim) sample(v, size=nsim, replace=TRUE), nsim)

  rankprod <- -1 * apply(rmat, 1, prod)
  rankprod.sim <- -1 * apply(rmat.sim, 1, prod)

  Fn <- stats::ecdf(c(rankprod.sim, Inf))
  pval <- Fn(rankprod)
  fdr <- stats::p.adjust(pval, method="BH")

  res <- data.frame(rmat, Rankprod.p=pval, Rankprod.FDR=fdr, row.names=rownames(mat))
  if(reorder.rows) res <- res[order(res$Rankprod.p), ]
  if(!is.null(prefix)) colnames(res) <- paste(prefix, colnames(res), sep=".")
  return(res)
}


# analyze phenotype changes

# functions
require(data.table)
require(ggplot2)

calc50p <- function(x,y){ # fit logistic regression and return x value for y=50%
  mod <- glm(y ~ x, family = binomial)
  betas <- coef(mod)
  return(-betas[1]/betas[2])
}

# read in data
canmat <- fread('data/phenotypes/Brattey et al_2018_Table18_proportion_mature.csv')
lofmat <- fread('data/phenotypes/AFWG_Table 3.11.csv', skip = 3)
lofmat <- lofmat[!is.na(Year_age), ] # trim off an NA row

# long format
canmatl <- melt(canmat, id.vars = c('Year'), value.name = 'propmat')
canmatl[, age := as.numeric(gsub('Age', '', variable))]

setnames(lofmat, c('Year_age', '+gp'), c('Year', '15')) # set older ages to 15 for simplicity
lofmatl <- melt(lofmat, id.vars = c('Year'), value.name = 'propmat', variable.name = 'age') # gives an error, but I don't understand why. looks fine
lofmatl[, age := as.numeric(age)]

# plot maturity curves by year
ggplot(canmatl, aes(age, propmat, group = Year, color = Year)) +
  geom_line(alpha = 0.5)

ggplot(lofmatl, aes(age, propmat, group = Year, color = Year)) +
  geom_line(alpha = 0.5)

# calc 50% maturity from logistic regression models
canmat50 <- canmatl[, .(age50 = calc50p(age, cbind(propmat*1000, (1-propmat)*1000)), pop = 'can'), by = Year]
lofmat50 <- lofmatl[, .(age50 = calc50p(age, cbind(propmat*1000, (1-propmat)*1000)), pop = 'lof'), by = Year]

# combine
mat50 <- rbind(canmat50, lofmat50)

# plot age of 50% maturity by year
ggplot(mat50, aes(Year, age50, group = pop, color = pop)) +
  geom_line() +
  geom_smooth()

# write out
write.csv(mat50, 'output/age_50percmature.csv', row.names = FALSE)


require(dplyr)
require(keras)
require(progress)
require(readtext)
require(tokenizers)
require(yaml)
rm(list=ls())

# --- script settings start ---
document <- '../data/marktwain.txt'
yml <- './simple_rnn.yml'
save_path <- '../data/simple_rnn.r.model'
# --- script settings end ---

FLAGS <- yaml.load_file(yml)

tokens <- readtext(document) %>% tokenize_words(simplify = T)
unique_tokens <- tokens %>% unique()
rm(document, yml)

samples <- array(dim = c(length(tokens) - FLAGS$sample_length + 1, FLAGS$sample_length))
for(i in 1:(dim(samples)[1])) {
  samples[i, ] <- tokens[i:(i + FLAGS$sample_length - 1)]
}
rm(tokens, i)

# build a simple model
# words -> one-hot -> rnn -> dense -> output
model <-
  keras_model_sequential() %>%
  layer_simple_rnn(
    units = FLAGS$units,
    input_shape = c(FLAGS$sample_length - 1, length(unique_tokens))) %>%
  layer_dense(length(unique_tokens)) %>%
  layer_activation("softmax")
compile(
  model,
  loss = "categorical_crossentropy",
  optimizer = optimizer_nadam())

make_batch <- function(samples, batch_start, batch_size) {
  sz = dim(samples)
  batch <- batch_start:min(sz[1], batch_start + batch_size - 1)
  batch_x <- samples[batch,-sz[2]]
  batch_y <- samples[batch, sz[2]]
  list(x = batch_x, y = batch_y)
}
one_hot_batch <- function(batch, unique_tokens) {
  one_hot_x <- array(0, dim = c(dim(batch$x), length(unique_tokens)))
  one_hot_y <- array(0, dim = c(length(batch$y), length(unique_tokens)))
  sz = dim(batch$x)
  for(i in 1:sz[1]) {
    for(j in 1:sz[2]) {
      one_hot_x[i,j,] <- as.integer(unique_tokens == batch$x[i,j])
    }
    one_hot_y[i,] <- as.integer(unique_tokens == batch$y[i])
  }
  list(x = one_hot_x, y = one_hot_y)
}

# train the model ---
t1 <- Sys.time()
sz = dim(samples)
for(i in 1:FLAGS$epochs) {
  batch_i <- 1
  pb <-
    progress_bar$new(
      format = 'batch :current/:total [:bar] eta: :eta',
      total = ceiling(sz[1]/FLAGS$batch_size))
  pb$tick(0)
  while(batch_i <= sz[1]) {
    batch <- make_batch(samples, batch_i, FLAGS$batch_size)
    one_hot <- one_hot_batch(batch, unique_tokens)
    loss = train_on_batch(model, one_hot$x, one_hot$y)
    rm(batch, one_hot)
    batch_i <- batch_i + FLAGS$batch_size
    pb$tick()
  }
  print(sprintf('Epoch: %i, Loss: %f', i, loss))
  rm(batch_i, pb, loss)
}
t2 <- Sys.time()
print(t2 - t1)

rm(model, save_path, make_batch, one_hot_batch, t1, t2, sz, i)


# Formatting the 2011 Diallel phenotype data
# Jinliang Yang
# Jan 17th, 2012
# server .7

#setwd("/Users/yangjl/Documents/Heterosis_GWAS/pheno2011")

#diallel <- read.csv("pheno_diallel_master_raw_040612.csv", header=TRUE)
sum(!is.na(diallel$KRN))
# 3225

############# H2 ###############################
fit1 <- aov(KRN ~ Farm + Genotype, data=diallel)
#7974.099/(7974.099+6225.719+221.082)=0.55
fit2 <- aov(KC ~ Farm + Genotype, data=diallel)
#91481212/(91481212+38953037+11996774)=0.64
fit3 <- aov(AKW ~ Farm + Genotype, data=diallel)
#9.2250/(9.2250+4.3802+1.0351)=0.63
fit4 <- aov(TKW ~ Farm + Genotype, data=diallel)
#12480224/(12480224+4092526+1789453)=0.67
fit5 <- aov(CD ~ Farm + Genotype, data=diallel)
#28020.7/(28020.7+17740.9+691.4)=0.60
fit6 <- aov(CW ~ Farm + Genotype, data=diallel)
#407395/(407395+116368+44141)=0.72
fit7 <- aov(CL ~ Farm + Genotype, data=diallel)
#3214417/(1363090+3214417+579579)=0.62

#######################################################
### BOX-COX transformation not necessary
### get the LSmean

library(MASS)
library(ggplot2)

#bct computes the Box-Cox family of transforms: y = (y^lambda - 1)/(lambda*gm^(lambda-1)),
#where gm is the geometric mean of the y's. returns log(y)*gm when lambda equals 0.
bct <- function(y,lambda){
  gm <- exp( mean( log(y) ) )
  if(lambda==0) return( log(y)*gm )
  yt <- (y^lambda - 1)/( lambda * gm^(lambda-1) )
  return(yt)
}

boxcox(diallel$KRN ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$KC ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$AKW ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$TKW ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$CD ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$CW ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
boxcox(diallel$CL ~ 1, lambda = seq(-10, 10, 1/10), plotit = TRUE)
#ykrn <- bct(diallel$KRN[!is.na(diallel$KRN)], 0)
##################################################################################
library(nlme)
BLUE <- function(data=krn, model=KRN~Genotype2, random=~1|Farm, trait="KRN"){
  lmeout1 <- lme(model, data=data, random=random);
  ped.hat1 <- lmeout1$coef$fixed;
  ped.hat1[-1] <- ped.hat1[-1]+ped.hat1[1];
  names(ped.hat1)[1]="B73xZ001";
  names(ped.hat1) <- gsub("Genotype2", "", names(ped.hat1));
  tped <- data.frame(Genotype=names(ped.hat1), trait=ped.hat1)
  names(tped)[2] <- trait;
    return(tped)
}

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

# start to calculate BLUE:
krn <- diallel[!is.na(diallel$KRN) & diallel$Type=="Diallel", ]
krn$Note_KRN <- as.character(krn$Note_KRN)
table(krn$Note_KRN)
krn2 <- BLUE(data=krn, model=KRN~Genotype2, trait="KRN")

############### ear trait #####################################
diallel$Note_ear <- as.character(diallel$Note_ear)
table(diallel$Note_ear)
ear <- subset(diallel, KC>50 & Note_ear!=" ")
dim(ear)
# 3057 22
###########-----KC
kc <- ear[!is.na(ear$KC) & ear$Type=="Diallel",]
kc2 <- BLUE(data=kc, model=KC~Genotype2, trait="KC")
hist(kc2$KC)
###########-----AKW
akw <- ear[!is.na(ear$AKW) & ear$Type=="Diallel",]
akw2 <- BLUE(data=akw, model=AKW~Genotype2, trait="AKW")
hist(akw2$AKW)
###########-----TKW
tkw <- ear[!is.na(ear$TKW) & ear$Type=="Diallel",]
tkw2 <- BLUE(data=tkw, model=TKW~Genotype2, trait="TKW")
hist(tkw2$TKW)

############## cob trait #####################################
diallel$Note_cob <- as.character(diallel$Note_cob)
table(diallel$Note_cob)

###########-----CD
cd <- diallel[!is.na(diallel$CD) & diallel$Type=="Diallel",]
cd2 <- BLUE(data=cd, model=CD~Genotype2, trait="CD")
hist(cd2$CD, main="CD")
###########-----CW
cw <- diallel[!is.na(diallel$CW) & diallel$Type=="Diallel",]
cw2 <- BLUE(data=cw, model=CW~Genotype2, trait="CW")
hist(cw2$CW, main="CW")
###########-----CL
cl <- diallel[!is.na(diallel$CL) & diallel$Type=="Diallel",]
cl2 <- BLUE(data=cl, model=CL~Genotype2, trait="CL")
hist(cl2$CL, main="CL")

############################################################################
pheno <- merge(krn2, akw2, by="Genotype", all=TRUE)
pheno <- merge(pheno, kc2, by="Genotype", all=TRUE)
pheno <- merge(pheno, tkw2, by="Genotype", all=TRUE)
pheno <- merge(pheno, cd2, by="Genotype", all=TRUE)
pheno <- merge(pheno, cw2, by="Genotype", all=TRUE)
pheno <- merge(pheno, cl2, by="Genotype", all=TRUE)

write.table(pheno, "cache/pheno_diallel_master_BLUE.csv", sep=",", row.names=FALSE, quote=FALSE)


## From Leena Choi
require(rms)
set.seed(3)
x1 <- factor(sample(c('a','b','c'),1000,TRUE))
x2 <- (x1=='b') + 3*(x1=='c') + rnorm(1000,0,2)
x3 <- rnorm(1000)
y  <- x2 + 1*(x1=='c') + .2*x3 + rnorm(1000,0,2)
orig.x1 <- x1[1:250]
orig.x2 <- x2[251:350]
x1[1:250] <- NA
x2[251:350] <- NA
d <- data.frame(x1,x2,x3,y)
ddist <- datadist(d); options(datadist='ddist')

a <- aregImpute(~y + x1 + x2 + x3, nk=c(0,3:5), data=d)

f <- fit.mult.impute(y ~ x1 + x2 + x3, ols, a, data=d)
g <- fit.mult.impute(y ~ x1 + x2 + x3, lm,  a, data=d)
vcov(f) - vcov(g)
f
summary(g)

f <- ols(y ~ x1 + x2 + x3, data=d)
g <- lm (y ~ x1 + x2 + x3, data=d)
vcov(f) - vcov(g)
f
summary(g)


 ZSPCON Example Program Results

 Estimate of condition number =  2.06E+01


# Copyright © 2013-2015 Université catholique de Louvain, Belgium - UCL
# All rights reserved.
#
# This file is part of the precall package.
#
# The precall package has been developed by Adrien Dessy [Machine Learning
# Group (MLG) - Institute of Information and Communication Technologies,
# Electronics and Applied Mathematics (ICTEAM)] for the Université catholique de
# Louvain (UCL). The precall package enables to plot precision-recall curves and
# to compute the Area Under Precision-Recall curves.
#
# The precall package is distributed under the terms of the MIT License (MIT).
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished
# to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

context("Subroutines to plot PR-curves")

approximate_aupr <- function(labels, scores, nb_interpolation_points) {

  coords = precall_interpolation(labels, scores, nb_interpolation_points)
  precision = coords$precision
  recall = coords$recall

  base =  tail(recall,-1) - head(recall,-1)
  height = (head(precision,-1) + tail(precision,-1))/2
  approx_aupr = sum(base*height)

  return(approx_aupr)
}

test_that("Interpolation can be used to approximate the aupr...", {

  scores1 = c(10, 5, 5, 4, 7, 5, 3, 8, 2, 4)
  scores2 = c(10, 7, 3, 2, 6, 2, 7, 10, 9, 7)
  scores3 = c(2, 6, 8, 6, 1, 3, 5, 3, 6, 8)
  scores4 = c(7, 7, 10, 9, 4, 1, 8, 8, 7, 2)
  scores5 = c(10, 8, 4, 1, 1, 8, 5, 8, 1, 2)

  labels = c(T,T,T,F,F,T,F,T,T,F)

  relative_delta <- function(scores, labels) {
    aupr_approx = approximate_aupr(labels, scores, 1000)
    aupr_analytic = aupr(labels, scores)
    abs(aupr_approx - aupr_analytic) / aupr_analytic
  }

  delta_1 = relative_delta(scores1, labels)
  delta_2 = relative_delta(scores2, labels)
  delta_3 = relative_delta(scores3, labels)
  delta_4 = relative_delta(scores4, labels)
  delta_5 = relative_delta(scores5, labels)

  testthat::expect_less_than(delta_1, 1e-7)
  testthat::expect_less_than(delta_2, 1e-7)
  testthat::expect_less_than(delta_3, 1e-7)
  testthat::expect_less_than(delta_4, 1e-7)
  testthat::expect_less_than(delta_5, 1e-7)
})


#' Supplement the data fitted to a linear model with model fit statistics.
#'
#' If you have missing values in your model data, you may need to refit
#' the model with `na.action = na.exclude`.
#'
#' @return The original data with extra columns:
#'   \item{.hat}{Diagonal of the hat matrix}
#'   \item{.sigma}{Estimate of residual standard deviation when
#'     corresponding observation is dropped from model}
#'   \item{.cooksd}{Cooks distance, [cooks.distance()]}
#'   \item{.fitted}{Fitted values of model}
#'   \item{.resid}{Residuals}
#'   \item{.stdresid}{Standardised residuals}
#' @param model linear model
#' @param data data set, defaults to data used to fit model
#' @param ... not used by this method
#' @keywords internal
#' @export
#' @examples
#' mod <- lm(mpg ~ wt, data = mtcars)
#' head(fortify(mod))
#' head(fortify(mod, mtcars))
#'
#' plot(mod, which = 1)
#'
#' ggplot(mod, aes(.fitted, .resid)) +
#'   geom_point() +
#'   geom_hline(yintercept = 0) +
#'   geom_smooth(se = FALSE)
#'
#' ggplot(mod, aes(.fitted, .stdresid)) +
#'   geom_point() +
#'   geom_hline(yintercept = 0) +
#'   geom_smooth(se = FALSE)
#'
#' ggplot(fortify(mod, mtcars), aes(.fitted, .stdresid)) +
#'   geom_point(aes(colour = factor(cyl)))
#'
#' ggplot(fortify(mod, mtcars), aes(mpg, .stdresid)) +
#'   geom_point(aes(colour = factor(cyl)))
#'
#' plot(mod, which = 2)
#' ggplot(mod) +
#'   stat_qq(aes(sample = .stdresid)) +
#'   geom_abline()
#'
#' plot(mod, which = 3)
#' ggplot(mod, aes(.fitted, sqrt(abs(.stdresid)))) +
#'   geom_point() +
#'   geom_smooth(se = FALSE)
#'
#' plot(mod, which = 4)
#' ggplot(mod, aes(seq_along(.cooksd), .cooksd)) +
#'   geom_col()
#'
#' plot(mod, which = 5)
#' ggplot(mod, aes(.hat, .stdresid)) +
#'   geom_vline(size = 2, colour = "white", xintercept = 0) +
#'   geom_hline(size = 2, colour = "white", yintercept = 0) +
#'   geom_point() + geom_smooth(se = FALSE)
#'
#' ggplot(mod, aes(.hat, .stdresid)) +
#'   geom_point(aes(size = .cooksd)) +
#'   geom_smooth(se = FALSE, size = 0.5)
#'
#' plot(mod, which = 6)
#' ggplot(mod, aes(.hat, .cooksd)) +
#'   geom_vline(xintercept = 0, colour = NA) +
#'   geom_abline(slope = seq(0, 3, by = 0.5), colour = "white") +
#'   geom_smooth(se = FALSE) +
#'   geom_point()
#'
#' ggplot(mod, aes(.hat, .cooksd)) +
#'   geom_point(aes(size = .cooksd / .hat)) +
#'   scale_size_area()
fortify.lm <- function(model, data = model$model, ...) {
  infl <- stats::influence(model, do.coef = FALSE)
  data$.hat <- infl$hat
  data$.sigma <- infl$sigma
  data$.cooksd <- stats::cooks.distance(model, infl)

  data$.fitted <- stats::predict(model)
  data$.resid <- stats::resid(model)
  data$.stdresid <- stats::rstandard(model, infl)

  data
}


siglev <- function(p)
{
  if (p <= 0.1)
    if (p <= 0.05)
      if (p <= 0.01)
        if (p <= 0.001)
          sig <- "***"
  else
    sig <- "**"
  else
    sig <- "*"
  else
    sig <- "."
  else
    sig <- ""
}

siglev <- function(p)
{
  if (p <= 0.1)
    if (p <= 0.05)
      if (p <= 0.01)
        if (p <= 0.001)
          sig <- "***"
  else
    sig <- "**"
  else
    sig <- "*"
  else
    sig <- "."
  else
    sig <- ""
}

# This functions makes a plot of the COEFFICIENTS of significant factors.
plot.coef <- function(glm, alpha = 0.05, pr="Pr(>|z|)", cex.labels = 1, pos.labels = 0.4, ...)
{
  # Extract p values and coefs.
  p <- coef(summary(glm))[,pr]
  c <- coef(glm)

  # Separate intercept from other coefs.
  p.int <- as.numeric(p[1])
  c.int <- as.numeric(c[1])
  p <- p[-1]
  c <- c[-1]

  # Find the order in which to put coefficients.
  c <- c[which(p <= alpha)]
  p <- p[which(p <= alpha)]

  # Find the order according to coef.
  order <- order(c)
  c <- c[order]
  p <- p[order]
  names <- names(c)

  # Put intercept and coefs back together.
  names <- c("(Intercept)", names)
  vals <- c(round(c.int, 3), round(c, 3))

  c <- c(as.numeric(c.int), as.numeric(c))
  p <- c(as.numeric(p.int), as.numeric(p))
  vals <- paste(vals, lapply(p, siglev), sep=" ")
  names <- paste(names, vals, sep="\n")

  range <- max(c)-min(c)
  ylim <- c(min(c)-0.25*range, max(c)+0.25*range)
  bars <- barplot(c, ylim=ylim, col=c("white", rep("lightgray", length(c)-1)), ...)
  pos <- ifelse(c > 0, c+pos.labels*cex.labels, c-pos.labels*cex.labels)
  text(bars, pos, names, cex=cex.labels)
}

# This functions makes a plot of the ODDS RATIOS of significant factors.
plot.or <- function(glm, alpha = 0.05, pr="Pr(>|z|)", cex.labels = 1, pos.labels = 3, ...)
{
  # Extract p values and coefs.
  p <- coef(summary(glm))[,pr]
  c <- exp(coef(glm))

  # Separate intercept from other coefs.
  p.int <- as.numeric(p[1])
  c.int <- as.numeric(c[1])
  p <- p[-1]
  c <- c[-1]

  # Extract the significant coefficients.
  c <- c[which(p <= alpha)]
  p <- p[which(p <= alpha)]

  # Find the order according to coef.
  order <- order(c)
  c <- c[order]
  p <- p[order]
  names <- names(c)

  # Put intercept and coefs back together.
  names <- c("(Intercept)", names)
  vals <- c(round(c.int, 3), round(c, 3))

  c <- c(as.numeric(c.int), as.numeric(c))
  p <- c(as.numeric(p.int), as.numeric(p))
  vals <- paste(vals, lapply(p, siglev), sep=" ")
  names <- paste(names, vals, sep="\n")

  range <- max(c)-min(c)
  ylim <- c(0, max(c)+0.25*range)
  bars <- barplot(c, ylim=ylim, col=c("white", rep("lightgray", length(c)-1)), ...)
  pos <- ifelse(c > 0, c+pos.labels*cex.labels, c-pos.labels*cex.labels)
  text(bars, pos, names, cex=cex.labels)
}

lr.test <- function(glm, glm0)
{
  ll <- -2*logLik(glm)
  ll0 <- -2*logLik(glm0)
  lr <- ll0 - ll
  df <- glm$rank - glm0$rank
  p <- pchisq(lr, df)
  list(lr=as.numeric(lr), df=as.numeric(df), p=as.numeric(p))
}

phi.glm <- function(glm)
{
  sum(resid(glm, type="pearson")^2 / df.residual(glm))
}


#' Title
#'
#' @param x is the dataset vector
#' @param mn is the name of the barplot
#' @param ...
#'
#' @return Returns a pareto barplot
#' @export
#'
#' @examples
pareto<-function(x,mn="Pareto barplot",...){  # x is a vector
x.tab=table(x)
xx.tab=sort(x.tab, decreasing=TRUE,index.return=FALSE)
cumsum(as.vector(xx.tab))->cs
length(x.tab)->lenx
bp<-barplot(xx.tab,ylim=c(0,max(cs)),las=2)
lb<-seq(0,cs[lenx],l=11)
axis(side=4,at=lb,labels=paste(seq(0,100,length=11),"%",sep=""),las=1,line=-1,col="Blue",col.axis="Red")
for(i in 1:(lenx-1)){
segments(bp[i],cs[i],bp[i+1],cs[i+1],col=i,lwd=2)
}
title(main=mn,...)

}

pareto(c(1,2,3,4,4))


load_filepath <- as.character(commandArgs(trailingOnly=TRUE)[1])
write_filepath <- paste(load_filepath,"write.csv",sep=".")
threshold <- as.numeric(commandArgs(trailingOnly=TRUE)[2])

max <- 0
g<-file(load_filepath,"r")
while(1){
  line <- readLines(g, n=1)
  max <- max+1
  if(length(line) == 0){
    break
  }
}

f<-file(load_filepath,"r")
header <- readLines(f, n=1)
header.x = unlist(strsplit(header, ","))
header_write_mes <- paste("p-value", header.x[2], header.x[3], header.x[4], header.x[5], header.x[6], header.x[7],sep=",")
write(header_write_mes, write_filepath , append = F)
x <- 0
while(1){
  x <- x + 1
  if(x %% 100 == 0){
   message(x,"/",max,"\r",appendLF=FALSE)
   flush.console()
  }

  line <- readLines(f, n=1)
  if(length(line) == 0){
    break
  }else{
    line.x = unlist(strsplit(line, ","))
  }
  ABtest_data <- data.frame(
     maximal_substrings = c("Maximal substring", "Maximal substring", "Others", "Others"),
     result = c("(+) items", "(-) items","(+) items", "(-) items"),
     number = c(as.numeric(line.x[3]), as.numeric(line.x[4]), as.numeric(line.x[5]), as.numeric(line.x[6]))
   )
    cross_data <- xtabs(number ~ ., ABtest_data )
    result <- fisher.test(cross_data)
    if(result$p.value <= threshold){

      write_mes <- paste(result$p.value, line.x[2], line.x[3], line.x[4], line.x[5], line.x[6], line.x[7],sep=",")
      #print(line.x[1])
      write(write_mes, write_filepath , append = T)
    }
}


master_col_data<-function(col,margin=0.1,ignoreCase=TRUE,method="jw",p=0.1){
	library(plyr)
	library(stringdist)
	# compute term freq
	paste2 <- function(x, y, sep = " ") paste(x, y, sep = sep)
	mydoc<-Reduce(paste2,col)
	# termFreq replacement
	a<-count(col)
	r<-a$freq
	names(r)<-tolower(as.character(a$x))

	r<-mean(r)/r
	# identify unique values
	c<-unique(col)
	# compute string dist matrix
	if(ignoreCase){
		d<-stringdistmatrix(tolower(c),tolower(c),method=method,p=p)
	} else{
		d<-stringdistmatrix(c,c,method=method,p=p)
	}

	r<-r[order(match(names(r),tolower(c)))]

	d<-diag(r)%*%d
	d<-t(diag(r)%*%t(d))

	d<-round(d,4)
	out<-find_hubs(d,margin)
	if(!is.null(out)){
		hubs<-c[out$medoids]
		r<-hubs[out$clustering]
		f<-function(x) r[which(c == x)]
		r<-unlist(lapply(col,f))
	}else{
		r<-col
	}
	gc()
	return(r)
}

bisection<-function(d, threshold, prec = 1e-4,  n = 50){
	x1<-nrow(d)
	x0<-1
	for (i in 1:n) {
		x2=(x1+x0)/2
		r<-pam(d, x2, diss = TRUE,stand=TRUE)
		max_diss<-max(r$clusinfo[,2])
		if(max_diss < threshold){
			x0<-x0
			x1<-x2
		} else{
			x0<-x2
			x1<-x1
		}
		if(x1 - x0 <= prec){
			return(round(x2,0))
		}
	}
}

find_hubs<-function(d,reach){
	library(cluster)
	n<-bisection(d,reach)
	if(n != nrow(d)){
		r<-pam(d, n, diss = TRUE)
	}else{
		r<-NULL
	}
}


#load data, fit a bunch of hierarchical models
rm(list=ls())
library(nlme)
library(MuMIn)
library(data.table)
library(boot)

#load data
d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/tal_core_data.rds'))

#transform [0,1] to (0,1) a la Cribari-Neto & Zeileis 2010
d$relEM  <- (d$relEM  * (nrow(d) - 1) + 0.5) / nrow(d)
d$relAM  <- (d$relAM  * (nrow(d) - 1) + 0.5) / nrow(d)
d$relWR  <- (d$relWR  * (nrow(d) - 1) + 0.5) / nrow(d)
d$relSAP <- (d$relSAP * (nrow(d) - 1) + 0.5) / nrow(d)

#Fit ecto models
m <-  lm(logit(relEM) ~ doy + mat30 + map30 + pH + cn + horizon + wet.dep + latitude,  data = d)
m <- lme(logit(relEM) ~ doy + mat30 + map30 + pH + cn + horizon + wet.dep + latitude, random = ~1|site/plotID, data = d, na.action = na.omit)
m <- lme(logit(relEM) ~ n.dep + mat30 + moisture + horizon + latitude, random = ~1|site/plotID, data = d, na.action = na.omit)
summary(m)
r.squaredGLMM(m)
#plotting
test <- d[complete.cases(d[,.(relEM,n.dep,mat30,moisture,horizon,latitude)])]
plot(logit(test$relEM) ~ (fitted(m)), cex= 0.5, pch = 16)

#Fit an AM model
m <- lme(logit(relAM) ~ doy + mat30 + map30 + wet.dep + latitude + pH + cn + moisture + horizon, random = ~1|site/plotID, data = d, na.action = na.omit)
m <- lme(logit(relAM) ~ doy + mat30 + map30 + wet.dep + latitude + moisture , random = ~1|site/plotID, data = d, na.action = na.omit)
summary(m)
r.squaredGLMM(m)
<<<<<<< HEAD
test <- d[complete.cases(d[,.(doy,mat30,map30,wet.dep,latitude,moisture)])]
plot(logit(test$relAM) ~ fitted(m), cex=0.5, pch = 16)
=======
>>>>>>> 86f6aad5e093b910fe7cc8ff293b9089204f114c

#Fit a SAP model
m <- lme(logit(relSAP) ~ wet.dep + pH + moisture + horizon, random = ~1|site/plotID, data = d, na.action = na.omit)
summary(m)
r.squaredGLMM(m)
<<<<<<< HEAD
test <- d[complete.cases(d[,.(wet.dep,pH,moisture,horizon)])]
plot(logit(test$relSAP) ~ fitted(m), cex=0.5, pch = 16)

=======
>>>>>>> 86f6aad5e093b910fe7cc8ff293b9089204f114c

#Fit WR model
m <- lme(logit(relWR) ~ doy + mat30 + map30 + pH + cn + horizon + wet.dep, random = ~1|site/plotID, data = d, na.action = na.omit)
summary(m)
r.squaredGLMM(m)
<<<<<<< HEAD
test <- d[complete.cases(d[,.(doy,mat30,map30,pH,cn,horizon,wet.dep)])]
plot(logit(test$relWR) ~ fitted(m), cex=0.5, pch = 16)
=======
>>>>>>> 86f6aad5e093b910fe7cc8ff293b9089204f114c

testing_development/fitting hierarchical models to fungi 111017.r


results <- c()
stdErr <- c()
sumHisto <- c()
approxMeanAmplitude = 0
numberOfSamples = length(data) - 11
for (i in 11:length(data)) {
  historyData <- data[1:i]
  sumHisto <- c(sumHisto, sum(historyData))
  fitDn <- tryCatch({nlsLM(historyData~a*pnorm(1:i, mean = m, sd = sd), start=list(m=10,sd=2,a=100))},
                    error = function(e) {print(e)})
  mCur = as.list(coef(fitDn))$m
  mCurStdErr = summary(fitDn)$coefficients[1,2]
  print(mCur)
  stdErr <- c(stdErr, mCurStdErr)
  results <- c(results, mCur)
}

plot(results, type = 'l')
points(stdErr)
weightedMean <- weighted.mean(results, sumHisto * results / stdErr)
print('weightedMeanMean')
print(weightedMean)
abline(weightedMean, 0)
print(as.Date(startDate) + weightedMean)

invStdErrNorm <- normalize.vector(1/stdErr)

print('Var Std Err. Mean')
varStdErrMean <- var(abs(results - weightedMean)*invStdErrNorm/length(stdErr))
print(varStdErrMean)


# R code
# Luis P. F. Garcia 2018
# Feature Selection based on PCA

pca <- function(data) {
  aux = prcomp(data)
  aux = which(summary(aux)$importance[3,] < 0.95)
  return(aux)
}

entropy <- function(data) {
  cfs(class ~ ., data)
}

selector <- function(data, type="entropy") {
  aux = eval(call(type, data))
  data = data.frame(data[,aux], class=data$class)
  return(data)
}


PATH <- 'D:/mse/BI/02_data-analytics/03_data/GOLF_MIXT.CSV'
GOLF_MIXT <- read.csv(PATH)

library(rpart)

GOLF_FORM <- Play ~ .
GOLF_MODEL <- rpart(GOLF_FORM, data = GOLF_MIXT, method = "class", minsplit = 1)
GOLF_MODEL

plot(GOLF_MODEL, uniform = TRUE, main = "")
text(GOLF_MODEL, use.n = TRUE, all = TRUE, cex = 0.9, fancy = FALSE, minlength = 10)


#!/usr/bin/r

## New and shorter version of Fibonacci example using Rcpp 0.9.16 or later features
## The the sibbling file 'fibonacci.r' for context

require(Rcpp)                           # no longer need inline

## R version
fibR <- function(seq) {
    if (seq < 2) return(seq)
    return (fibR(seq - 1) + fibR(seq - 2))
}

## C++ code
cpptxt <- '
int fibonacci(const int x) {
   if (x < 2) return(x);
   return (fibonacci(x - 1)) + fibonacci(x - 2);
}'

## C++ version
fibCpp <- cppFunction(cpptxt)           # compiles, load, links, ...

## load rbenchmark to compare
library(rbenchmark)

N <- 35     ## same parameter as original post
res <- benchmark(fibR(N), fibCpp(N),
                 columns=c("test", "replications", "elapsed", "relative"),
                 order="relative", replications=1)
print(res)  ## show result


## This function makes a matrix that supports caching
## and then caches the inverse of the matrix

## This function assumes the matrix is invertible.  Error checking needed (later)
##   since that is not always true

makeCacheMatrix <- function(x = matrix()) {
  m <- NULL
  ## Set the matrix given values y
  set <- function(y) {
    x <<- y
    m <<- NULL
  }
  ## Get the matrix
  get <- function() x
  ## Set the inverse given the inverse 'solve'
  setinv <- function(solve) m <<- solve
  ## Get the inverse, which is m
  getinv <- function() m
  list(set = set, get = get,
       setinv = setinv,
       getinv = getinv)
}

## Caches the inverse of x

cacheSolve <- function(x, ...) {
  ## Return a matrix that is the inverse of 'x'

  m<-x$getinv()
  if(!is.null(m)) {
    ## m is not null, inv exists
    message("Getting Cached Data")
    return(m)
  }
  ## Got here because m is null, inv does not exist
  ## Put x into data
  data <- x$get()
  ## invert data and put into m
  m <- solve(data)
  x$setinv(m)
  ## Return m
  m
  }


context("stack")

A = matrix(1:4, nrow=2, ncol=2, dimnames=list(c('a','b'),c('x','y')))
B = matrix(5:6, nrow=2, ncol=1, dimnames=list(c('b','a'),'z'))

C = stack(list(A, B), along=2)
#    x y z
#  a 1 3 6   # B is stacked correctly according to its names
#  b 2 4 5

test_that("match names, not extent", {
    Cref = structure(c(1L, 2L, 3L, 4L, 6L, 5L), .Dim = 2:3,
                     .Dimnames = list(c("a", "b"), c("x", "y", "z")))
    expect_equal(C, Cref)
})

test_that("supply objects instead of list", {
    Cobj = stack(A, B, along=2)
    expect_equal(Cobj, C)

    Cobj2 = stack(b=B, a=A, along=2)
    expect_equal(Cobj2, C[c(2,1),c(3,1,2)])
})

test_that("fill empty elements", {
    D = stack(list(m=A, n=C), along=3)
    D2 = stack(m=A, n=C, along=3)
    # , , m          , , n
    #
    #   x y  z         x y z
    # a 1 3 NA       a 1 3 6
    # b 2 4 NA       b 2 4 5
    Dref = structure(c(1L, 2L, 3L, 4L, NA, NA, 1L, 2L, 3L, 4L, 6L, 5L),
                     .Dim = c(2L,3L, 2L), .Dimnames = list(c("a", "b"),
                     c("x", "y", "z"), c("m", "n")))
    expect_equal(D, Dref)
    expect_equal(D2, Dref)
})

test_that("same as first but without colnames", {
    colnames(A) = NULL
    colnames(B) = NULL
    colnames(C) = NULL
    Cnull = stack(list(A, B), along=2)
    expect_equal(C, Cnull)
})

test_that("vector stacking", {
    a = b = setNames(1:5, LETTERS[1:5])
    expect_equal(stack(list(a=a, b=b), along=1),
                 t(stack(list(a=a, b=b), along=2)))

    amat = as.matrix(a)
    colnames(amat) = "a"
    expect_equal(stack(list(a=a), along=2), amat)
    expect_equal(stack(list(a=a), along=1), t(amat))
})

test_that("keep_empty arg when stacking zero-length vectors", {
    a = setNames(1:3, letters[1:3])
    b = numeric()
    re1 = stack(list(a=a, b=b), keep_empty=TRUE)
    expect_equal(re1,
          structure(c(1, 2, 3, NA, NA, NA), .Dim = c(3L, 2L),
                    .Dimnames = list(c("a", "b", "c"), c("a", "b"))))

    re2 = stack(list(a, b), along=1, keep_empty=TRUE)
    re3 = stack(list(a, b), along=2, keep_empty=TRUE)
    expect_equal(re3, structure(c(1, 2, 3, NA, NA, NA), .Dim = c(3L, 2L),
                    .Dimnames = list(c("a", "b", "c"), NULL)))
    expect_equal(re2, t(re3))
})


#reference :
http://onepager.togaware.com/KnitRO.pdf
page 14

#ggplot2

library(rattle)   # For the weatherAUS dataset.
library(ggplot2)  # To generate a density plot.
png("#21_portfolio_ggplot2_ddensity_plot.png" , width = 800, height = 600)
png("#21_ggplot2_ddensity_plot.png" , width = 480, height = 480)
cities <- c("Canberra", "Darwin", "Melbourne", "Sydney")
ds <- subset(weatherAUS, Location %in% cities & ! is.na(Temp3pm))
p  <- ggplot(ds, aes(Temp3pm, colour=Location, fill=Location))
p  <- p + geom_density(alpha=0.55)
p