#####################################################################################################
#																									#
#	FUNCTIONS PER LA VERIFICA DELLA CONCORDANZA PESI ESPERTI AHP									#
#	PROGETTO	= 	AHP VETTORI																		#
#	AUTHORS		=	PAOLO MULATTI, MATTEO MAZZUCATO													#
#	VERSIONE	=	1.0																				#
#																									#
#####################################################################################################

# INPUT and VARs
# path = expert elicitation path files
# level = level (1,2,3) to be considered in the analysis
# threshold = threshold below which the combinations of experts are excluded based on the concordance between ahp weights. Default value = 0.75(75%).

# npoints =	number of random points generated
# prjcrs = prject reference system. Defeault value(UTM32) = "+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=1500000 +y_0=0 +ellps=intl +units=m +no_defs"
# imax = maximum number of iterations
# rstclc = raster("data\\rst\\clcl06clip.tif")

require(gtools)
require(irr)
require(Kendall)

#Get data from a specific path
ahp.get.data = function(path, level, view=FALSE){
	path <- paste(path,"data\\ahp\\",sep="")
	csv.list <- list.files(path = path, pattern="*.csv")
	csv.names <- strsplit(csv.list,"_")
	csv.names <- lapply(csv.names,function(x) x[1])
	ncsv <- do.call("c",csv.names)
	data.list <- list()
	d <- length(csv.list)
	for (i in 1:d) {
		data.list[[i]] <- read.csv(paste(path,csv.list[i],sep=""), header=TRUE, sep=";")
	}
	data.list = lapply(data.list,function(x) x[order(x$elemcod),])
	dlist = lapply(data.list,function(x) subset(x,x$level==level))
	dmat = data.frame(CLASS=dlist[[1]]$elemcod, do.call("cbind",lapply(dlist,function(x) x["ahp_res"])))
	names(dmat)[-1]=ncsv
	if(view == TRUE){
		ahp.plot.data(dmat)
	}
	return(dmat)
}

#Plot ahp data with histograms
ahp.plot.data = function(dataframe){
	windows(height=10,width=20)
	par(mfrow=c((length(names(dataframe))-1)/5,5))
	for(i in 2:ncol(dataframe))
	{
		barplot(dataframe[,i], main=names(dataframe)[i], ylim=c(0,round(max(apply(dataframe[2:length(dataframe)], 2, function(x) max(x))),1)+0.1))
	}
}

#Best combination from AHP experts
ahp.combo.best = function(dataframe, threshold=0.75){
	n.df = names(dataframe)[-1]
	combo.w = list()
	w.list = list()

	for(i in 2:length(n.df))
	{
	 w.list[[i]] = list()
	 combo.nm = combinations(length(n.df),i,n.df)
 	 w = integer(length=0)
	 id = vector(length=0)
	 l = integer(length=0)
		for(j in 1:nrow(combo.nm))
		{
		 id[j] = paste(combo.nm[j,],collapse="-")
		 l = length(combo.nm[j,])
		 sub.data = dataframe[,names(dataframe)%in%combo.nm[j,]]
		 w.list[[i]][[j]] = kendall(sub.data,correct=T)
		 w[j] = w.list[[i]][[j]]$value
		}
	 combo.w[[i]] = data.frame(id=id,w=w,l=l)
	}
	df.w = do.call("rbind",combo.w)

	u1=df.w
	u1$ok=u1$w*ifelse(u1$w>=threshold,1,NA)
	u2=split(u1,u1$l)
	u3=lapply(u2,function(x) x[which.max(x$ok),])
	u4=do.call("rbind",u3)
	u5=u4[which.max(u4$l),]
	u.id=unlist(strsplit(as.character(u5$id),"-"))
	df.w.s=dataframe[,u.id]

	return(df.w.s)
}

#Geometric Mean
gm_mean = function(x,na.rm=TRUE){
  exp(sum(log(x[x > 0]), na.rm=na.rm) / length(x))
}

#Export csv file for analysis
ahp.val.gm = function(path, dataframe, threshold=0.75, view=FALSE, type="gm"){
	df.w.s = ahp.combo.best(dataframe, threshold)
	dm <- as.matrix(df.w.s)

	gmean = switch(type,
              mean = apply(dm,1,mean),
              median = apply(dm,1,median),
              gm = apply(dm,1,gm_mean)
			)

	gm.df=data.frame(CLASSLVL3=substr(dataframe$CLASS,4,length(dataframe$CLASS)),PESO=gmean/sum(gmean))
	if(view == TRUE){
		gm.df
	}
	write.table(gm.df,paste(path,"clcweights.csv",sep=""),sep=";",row.names=FALSE,col.names=TRUE)
	return(gm.df)
}

#SAW
require("raster")
require("rgeos")
require("spatstat")
require("rgdal")

ahp.geo.analysis = function(csvWeights, rstClc, csvClass, studyArea, npoints, mindist, radius=2000, prjcrs="+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=1500000 +y_0=0 +ellps=intl +units=m +no_defs", imax, showtime=FALSE, view=FALSE){
	prt=proc.time()

	print("STARTING PROCESS...")

	i = 1
	nodataval = 128
	res.list <- list()
	dfClassLVL3 <- merge(csvClass, csvWeights, by.x = "CLC_CODE", by.y="CLASSLVL3",all.x=T)
	mtxPesiLVL3 <- cbind(csvClass$GRID_CODE, csvClass$GRID_CODE+1, csvClass$CLC_CODE)
	mtxPesiLVL3 <- rbind(mtxPesiLVL3,c(nodataval,nodataval+1,999))
	mtxPesiLVL3 <- cbind(dfClassLVL3$GRID_CODE, dfClassLVL3$GRID_CODE+1, dfClassLVL3$PESO)
	mtxPesiLVL3 <- rbind(mtxPesiLVL3,c(nodataval,nodataval+1,NA))
	rstclclvl3 <- reclassify(rstClc, mtxPesiLVL3, include.lowest=TRUE, right=FALSE)

	polyas=lapply(studyArea@polygons[[1]]@Polygons,function(x) x@coords[nrow(x@coords):2,])
	shpas <- owin(xrange=studyArea@bbox[1,], yrange=studyArea@bbox[2,], poly=polyas)

	rstbuf <- raster(nrows=rstclclvl3@nrows, ncols=rstclclvl3@ncols, xmn=rstclclvl3@extent@xmin, xmx=rstclclvl3@extent@xmax, ymn=rstclclvl3@extent@ymin, ymx=rstclclvl3@extent@ymax, crs=prjcrs)
	while(i<=imax){
		rndpoints <- rSSI(r=mindist, n=npoints, win=shpas)
		if(rndpoints$n == npoints){
			dfrandompoints <- data.frame(zone=1:npoints,x=rndpoints$x,y=rndpoints$y)
			shppunti <- SpatialPoints(dfrandompoints[c("x","y")], proj4string=CRS(prjcrs), bbox = studyArea@bbox)
			buf2k = gBuffer(shppunti,byid=T,width=radius)
			rstbuf2k <- rasterize(buf2k, rstbuf)
			rstzonres <-zonal(rstclclvl3,rstbuf2k, sum)
			dftmp <- merge(dfrandompoints,rstzonres,by="zone")
			res.list[[i]] <- dftmp
			if(showtime==TRUE){
				print(paste("round=",i," - time(s)=", round((proc.time()-prt)[[3]],2)))
			}
			i <- i+1
		}
	}
	ris.fin=lapply(res.list,function(x) data.frame(PESO=sum(x$value),mindist=min(dist(x[c("x","y")]))))
	#ris.df=do.call("rbind",ris.fin)
	#(proc.time()-prt)[[3]]
	output <- do.call("rbind", ris.fin)					#output pesi
	#output.ord <- output[order(-output$PESO),] 		#pesi ordinati desc
	output.val = ris.fin[[which.max(output$PESO)]]		#lancio con MAX valore
	output.elem = res.list[[which.max(output$PESO)]]	#lista punti con MAX valore
	df.points <- data.frame(res.list[[which.max(output$PESO)]])

	print("END OF THE PROCESS!")
	print("")
	print(paste("BEST SIMULATION OF POINTS = ", which.max(output$PESO), ", WITH TOTAL VALUE = ", round(output$PESO[which.max(output$PESO)],2), sep= ""))
	print("")

	#exports
	print("STARTING EXPORT...")

	outSites <- SpatialPoints(df.points[c("x","y")], proj4string=CRS(prjcrs), bbox=studyArea@bbox)
	shpobj = SpatialPointsDataFrame(outSites@coords, data.frame(df.points))
	writeOGR(obj=shpobj, dsn=paste(outpath,"sites.shp",sep=""), layer="sites.shp", driver="ESRI Shapefile")
	print("sites.shp exported")

	outBuffers <- gBuffer(outSites,byid=T,width=radius)
	shpobj = SpatialPolygonsDataFrame(outBuffers, data.frame(dummy = rep(1,npoints)))
	writeOGR(obj=shpobj, dsn=paste(outpath,"buffers.shp",sep=""), layer="buffers.shp", driver="ESRI Shapefile")
	print("buffers.shp exported")
	print("EXPORT COMPLETE!")

	if(view == TRUE){
		windows(height=10,width=20)
		plot(rstclclvl3)
		plot(studyArea,add=TRUE)
		plot(outBuffers,add=TRUE,col="#6bc6ff",pch=1 )
		plot(outSites,add=TRUE,col="black",cex=0.5, pch=21)

	}
	outputs = list(rstclc = rstclclvl3, outSites = outSites, res.list = res.list, bestSimulation = which.max(output$PESO), bestValue = output$PESO[which.max(output$PESO)])
	writeRaster(outputs[[1]], paste(outpath, "clc_class.tif"), "GTiff", overwrite=TRUE)
	return(outputs)
}

#Check results
ahp.geo.check  = function(rstModelTest, list.data, studyArea, prjcrs="+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=1500000 +y_0=0 +ellps=intl +units=m +no_defs"){
	#change NA to 0 in the check raster layer
	rstModelTest <- setValues(rstModelTest, ifelse(is.na(values(rstModelTest)),0,values(rstModelTest)))
	df.check <- data.frame(id = numeric(length=0), val = numeric(length=0), checkval = numeric(length=0), checkperc = numeric(length=0))

	for(i in 1:length(list.data)){
		spdata = SpatialPoints(list.data[[i]][2:3], proj4string=CRS(prjcrs), bbox = studyArea@bbox)
		spdatatmp <- data.frame(id = i, val = sum(list.data[[i]]$value), checkval = sum(extract(rstModelTest, spdata)), checkperc = sum(extract(rstModelTest, spdata))/nrow(list.data[[i]]))
		df.check <- rbind(df.check, spdatatmp)
	}
	return(df.check)
}


# Clase 2022-05-03
# Véase la clase de la semana pasada, a partir de "Otras funciones"

#
# --- 4.1.6 DISPOSITIVOS GRAFICOS ------------------------------------------------------
#

# dev.(...)
# Funciones: pdf() jpeg(), postscript()

# --------------------------------------------------------------------------------
# Bloque 1: Generación de datos para los gráficos
x <- seq(0, 2 * pi, length.out = 20)
set.seed(2)
y1 <- sin(x) + 0.3 * rnorm(20)
y2 <- sin(x) + 0.15 * rnorm(20)
# Bloque 2: Iniciar un dispositivo gráfico (número 2)
# y representar (x,y1)
windows()
plot(x, y1, type = "o", pch = 15, col = 2)
# Bloque 3: Iniciar otro dispositivo gráfico (número 3)
# y representar (x,y2)
windows()
plot(x, y2, type = "o", pch = 16, col = 4)
## Comprueba la lista de dispositivos y el dispositivo actual
dev.list()
dev.cur()

# Bloque 4: Añadir la curva $f(x)=sen(x)$ a ambos gráficos
# primero en rojo en el dispositivo 2
dev.set(2)
curve(sin(x), add = TRUE, col = 2, lty = 3)
# después en azul el dispositivo 3
dev.set(3) # esto no sería necesario (3 es el dispositivo actual)
curve(sin(x), add = TRUE, col = 4, lty = 3)
# Bloque 5: Comparar las dos gráficas en un nuevo dispositivo (4)
# en este caso será un fichero con nombre 'graf.pdf'
pdf("graf.pdf")
plot(x, y1, pch = 15, col = 2, ylab = "")
points(x, y2, pch = 16, col = 4)
# añadimos segmentos entre los puntos
segments(x, y1, x, y2, col = "purple")
# y la curva f(x)=sen(x) de referencia
curve(sin(x), add = TRUE, lty = 3)
# cerramos el dispositivo actual (el pdf)
dev.off()

#
# --- 4.1.7 GRAFICOS DE VARIABLES ALEATORIAS -------------------------------------
#

# Lo vimos previamente

#
# --- 4.1.8 PAQUETES ESPECIFICOS -------------------------------------------------
#

# ggplot2

#
# --- SEGUNDA PARTE DEL TEMA. ANALISIS ESTADISTICO --------------------------------
#

# Definición de modelos estadístico

help("~")
# Ajuste del modelo lineal

# --------------------------------------------------------------------------------
# Eg
library(MASS)
plot(forbes$bp, forbes$pres, xlab = "temperatura", ylab = "presión")

lm(pres ~ bp, data = forbes)

fit <- lm(pres ~ bp, data = forbes)
typeof(fit)
class(fit)

names(fit)

plot(forbes$bp, forbes$pres, xlab = "temperatura", ylab = "presión")
abline(fit)

summary(fit)

anova(fit)

confint(fit)
predict(fit, newdata = data.frame(bp = 200), interval = "confidence", se.fit = TRUE)
predict(fit, newdata = data.frame(bp = 200), interval = "prediction")

x0 <- data.frame(bp = seq(min(forbes$bp), max(forbes$bp), length.out = 20))
pred.m <- predict(fit, newdata = x0, interval = "confidence", se.fit = T)
pred.p <- predict(fit, newdata = x0, interval = "prediction", se.fit = T)
matplot(x0$bp, cbind(pred.m$fit, pred.p$fit[, -1]),
    lty = c(1, 2, 2, 3, 3),
    col = c(1, 2, 2, 4, 4), type = "l", xlab = "temperatura", ylab = "presión", main = ""
)
legend("topleft", c("Media", "Predicción"), lty = c(2, 3), col = c(2, 4), bt = "n")
points(forbes$bp, forbes$pres)

# --------------------------------------------------------------------------------
# Eg 2
library(faraway)
data(coagulation)
boxplot(coag ~ diet, data = coagulation)

lm(coag ~ diet, data = coagulation)
fit <- lm(coag ~ diet, data = coagulation)
anova(fit)
# Alternativa usando aov en vez de lm
fit2 <- aov(coag ~ diet, data = coagulation)
summary(fit2)

pairwise.t.test(coagulation$coag, coagulation$diet)
TukeyHSD(aov(coag ~ diet, coagulation))


# wahpenayo at gmail dot com
# 2017-12-21
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taiga')) {
  setwd('e:/porta/projects/taiga/docs/overview')
} else {
  setwd('c:/porta/projects/taiga/docs/overview')
}
#-----------------------------------------------------------------
source('../../src/scripts/r/functions.r')
#-----------------------------------------------------------------
d <- make.data('reg')

illustrate.rpart(name='1-split',d=d,maxdepth=1)
illustrate.rpart(name='3-split',d=d,maxdepth=2)

illustrate.rpart(name='unpruned',d=d,cp=0.00001)

illustrate.rpart(name='pruned',d=d,cp=0.0005)

illustrate.rf(name='1-tree',d=d,ntree=1)
illustrate.rf(name='4-tree',d=d,ntree=4)
illustrate.rf(name='1024-tree',d=d,ntree=1024)
#-----------------------------------------------------------------


library(testthat)
library(sparsediscrim)

context("LDA with the Moore-Penrose Pseudo-Inverse")

test_that("The lda_pseudo classifier works properly on the iris data set", {
  require('MASS')

  set.seed(42)
  n <- nrow(iris)
  train <- sample(seq_len(n), n / 2)
  lda_pseudo_out <- lda_pseudo(Species ~ ., data = iris[train, ])
  predicted <- predict(lda_pseudo_out, iris[-train, -5], type = "prob")

  lda_pseudo_out2 <- lda_pseudo(x = iris[train, -5], y = iris[train, 5])
  predicted2 <- predict(lda_pseudo_out2, iris[-train, -5], type = "prob")

  # Tests that the same prob results from the matrix and formula versions of
  # the lda_pseudo classifier
  expect_equal(predicted, predicted2)
})

# Related to issue #41
test_that("The lda_pseudo classifier works properly when 1 feature used", {
  require('MASS')

  train <- seq(1, 150, by = 3)

  lda_pseudo_out <- lda_pseudo(x = iris[train, 1, drop = FALSE], y = iris[train, 5])
  predicted_cls   <- predict(lda_pseudo_out, iris[-train, 1, drop = FALSE])
  predicted_prob  <- predict(lda_pseudo_out, iris[-train, 1, drop = FALSE], type = "prob")
  predicted_score <- predict(lda_pseudo_out, iris[-train, 1, drop = FALSE], type = "score")

  expect_equal(length(predicted_cls), 150 - length(train))
  expect_is(predicted_prob,  "data.frame")
  expect_is(predicted_score, "data.frame")
  expect_equal(dim(predicted_prob),  c(150 - length(train), nlevels(iris$Species)))
  expect_equal(dim(predicted_score), c(150 - length(train), nlevels(iris$Species)))
})


is.even <- function(x) !is.odd(x)

is.odd <- function(x) intToBits(x)[1] == 1
#or
is.odd <- function(x) x %% 2 == 1


D = data.frame( t(matrix(c(28,	99,
17,	78),nrow=2)))
require(exact2x2)

rS = rowSums(D)
cS = colSums(D)

res = uncondExact2x2(D[1,1],rS[1],D[2,1],rS[2])
summary(res)

print(help(uncondExact2x2))


myMatrix <- matrix(1:12, ncol = 4)
myMatrix


#' The zero-truncated compund poisson-lognormal distributions and their
#' mixtures
#'
#' Functions for obtaining the density, random deviates and maximum likelihood
#' estimates of the zero-truncated Poisson lognormal distributions and their
#' mixtures.
#'
#' @author Masatoshi Katabuchi <mattocci27@gmail.com>
#'
#' @references Bulmer, M. G. 1974. On Fitting the Poisson Lognormal Distribution to Species-Abundance Data. Biometrics 30:101-110.
#' @references Inouye, D., E. Yang, G. Allen, and P. Ravikumar. 2017. A Review of Multivariate Distributions for Count Data Derived from the Poisson Distribution. Wiley interdisciplinary reviews. Computational statistics 9.
#' @references Raqab, M. Z., D. Kundu, and F. A. Al-Awadhi. 2019. Compound zero-truncated Poisson normal distribution and its applications. Communications in Statistics - Theory and Methods:1–21.
#'
#' @keywords internal
"_PACKAGE"

#' @import Rcpp
#' @import stats
#' @importFrom DistributionUtils is.wholenumber
#' @importFrom mixtools normalmixEM

#' @useDynLib ztpln, .registration=TRUE
NULL


#' Build a cell graph using blanacing of an extrenal distance matrix
#'
#' @param mat_id matrix object id
#' @param d_mat distance matrix, col and row names should be a super set of the non ignored cells for the matrix in mat_id
#' @param graph_id  new graph id to create
#' @param K the guideline Knn parameter. The balanced will be constructed aiming at K edges per cell
#' @param balance should balancing be performed (Default False)
#' @param k_expand determine how much shoudl the K be expanded intially in order to find enough balanced neighbors.
#'
#' @export

mcell_add_cgraph_from_distmat= function(d_mat, graph_id, K, balance=F, k_expand=10)
{
	k_beta = get_param("scm_balance_graph_k_beta")

	d_mat = as.matrix(d_mat)

	if(balance) {
		x_knn = tgs_knn(max(d_mat)-d_mat, K*k_expand)
		message("will build balanced knn graph on ", ncol(d_mat), " cells, this can be a bit heavy for >20,000 cells")
		gr = tgs_graph(x_knn, K, k_expand, k_beta)
	} else {
		x_knn = tgs_knn(max(d_mat)-d_mat, K)
		gr = x_knn[,c("col1", "col2")]
		gr$w = 1-(x_knn$rank-1)/K
	}
	colnames(gr) = c("mc1","mc2","w")

	scdb_add_cgraph(graph_id, tgCellGraph(gr, colnames(d_mat)))
}


> ## inicio da aula R ##
>

> ## UNIDADE 1 ##

> ## OPERACOES MATEMATICAS##
> 3+3
[1] 6
> 3-4
[1] -1
> 3*3
[1] 9
> 4/2
[1] 2
> %% 2
Error: unexpected SPECIAL in "%%"
>
> ## VARIAVEL ##
> var <- 3*4
> var
[1] 12
>
> ## VARIAVEL NAO TEM TIPO PODE SER CHARACTER ##
> VAR <- "jONATHAN sARTORI bRUZARROSCO"
> VAR
[1] "jONATHAN sARTORI bRUZARROSCO"

> ##SALVAR DADOS NO ENVIRONMENT##
> idade <- 34
> nome <- "Jonathan Sartori Bruzarrosco"
> logica <- TRUE
> salario <- 1000.15
> var <- "qualquer coisa"
>
> ## MOSTRAR A KISTA DAS VARIAVEIS SALVAS ##
> ls()
[1] "idade"   "logica"  "nome"    "salario"
[5] "var"
>
> ## REMOVER VARIAVEL SALVA ##
> rm(var)
>
> ## REMOVER A LISTA TODA ##
> rm(list = ls())
>
>

> ## UNIDADE 2 ##

## ADICIONANDO VARIAVEIS ##
> nome <- "Jonathan Sartori Bruzarrosco"
> idade <- 34
> salario <- 1000.15
> logica <- TRUE
>
> ## PARA SABER O TIPO DE DADO ##
> class(idade)
[1] "numeric"
> class(salario)
[1] "numeric"
> class(nome)
[1] "character"
> class(logica)
[1] "logical"
> ## LOGICAL ACEITA VERDADEIRO OU FALSO ##

> ## character vai estar sempre entre""##
>
> ## EXEMPLO ##
> idade <- "5"
> class(idade)
[1] "character"
>
> ## TESTAR O TIPO DO DADO ##
> is.numeric(idade)
[1] FALSE
> is.character(nome)
[1] TRUE
> is.logical(logica)
[1] TRUE
>
> ## CONVERTER TIPO ##
> var <- idade + 5
Error in idade + 5 : non-numeric argument to binary operator
> as.integer(idAde)
Error: object 'idAde' not found
> as.integer(idade)
[1] 5
> var <- as.integer(idade) + 5
> var
[1] 10
> ## ou seja is verifica e as converte ##
> ## nem sempre se consegue exemplo ##
> as.integer(nome)
[1] NA
Warning message:
NAs introduced by coercion

> ## INICIANDO CONDICIONAL ##
> numero <- 10
>
> ##SHIFT + ENTER PARA PASSAR LINHA SEM RODAR CODIGO##
>
> if(class(numero) != "numeric"){
+     print("não é numerico")
+ }else{
+     if(numero %% 2 == 0){
+         print("o numero é par")
+     }else{
+         print("o numero é impar")
+     }
+ }
[1] "o numero é par"
>
> numero <- 11
> if(class(numero) != "numeric"){
+     print("não é numerico")
+ }else{
+     if(numero %% 2 == 0){
+         print("o numero é par")
+     }else{
+         print("o numero é impar")
+     }
+ }
[1] "o numero é impar"
>
> numero <- "jonathan"
> if(class(numero) != "numeric"){
+     print("não é numerico")
+ }else{
+     if(numero %% 2 == 0){
+         print("o numero é par")
+     }else{
+         print("o numero é impar")
+     }
+ }
[1] "não é numerico"

> ## != diferente ##
> ## %% 2 == 0 (resto da divisao é igual a 0 ou nao)##
> ## %% = mod ##
>
>
> ##ESTRUTURA DE REPETIÇÃO##
>
> professores <- c("Gobbato", "Maito", "alcides")
>
> ##saber a quantidade de elementos dentro do conjunto##
>
> length(professores)
[1] 3
> professores[1]
[1] "Gobbato"
> professores[2]
[1] "Maito"
> professores[0]
character(0)
> ##diferente de outras linguagens R comeca no 1##
>
> print(paste("o nome do professor é: ",professores[1] ))
[1] "o nome do professor é:  Gobbato"
>
> for(pos in 1:length(professores)){
+     print(paste("o nome do professor é:", professores[pos]))
+ }
[1] "o nome do professor é: Gobbato"
[1] "o nome do professor é: Maito"
[1] "o nome do professor é: alcides"

> posicao <- 1

> while(posicao <= length(professores)){
+     print(paste("o nome do professor é:", professores[posicao]))
+     posicao <- posicao + 1 #incremento
+ }
[1] "o nome do professor é: Gobbato"
[1] "o nome do professor é: Maito"
[1] "o nome do professor é: alcides"

> ## UNIDADE 3 ##


#R-Code for generating Polar plots using the plotrix library
library(plotrix)
data<-read.csv('15T-epsilon.dat')

setEPS()
png("15T-epsilon.png")
polar.plot(data[1:14999,1],data[1:14999,2],rp.type="p",start=90,clockwise=TRUE,main=expression(paste("Torsion Angles: 1,5T-",epsilon)))
dev.off()


# An introduction to R programming
# NDSU Analysis of Ecosystems
# Devan Allen McGranahan (devan.mcgranahan@ndsu.edu)

# Lesson 3.1: Introduction to graphing in R, continued

# Install and load packages for use in this session

  install.packages(c("tidyverse","plyr","ggthemes","devtools"))
  devtools::install_github("dill/emoGG")

library(ggplot2) # in the tidyverse

##
##  Tour of geoms
##
    # Using an example ggplot dataset
    mpg  # it is a tibble, don't need str()

# Discrete independent variables
    # One variable: bar graphs with geom_bar

    bg <- ggplot(mpg, aes(factor(cyl)))
    bg + geom_bar() # Automatic count per group on y axis

    # Two variables (continuous response variable)

      bp <- ggplot(mpg, aes(x=factor(class), y=hwy))
      bp + geom_boxplot()
      bp + geom_violin() # Insight into data distribution
      bp + geom_violin() + geom_jitter()
      bp +  geom_violin() +
            geom_jitter(width=0.5, alpha=0.3)

      bp +  geom_boxplot() +
            geom_jitter(width=0.5, alpha=0.3)

      bp +  geom_boxplot(outlier.colour=NA) +
            geom_jitter(width=0.5, alpha=0.3)

      bp +  geom_boxplot(outlier.colour=NA) +
            geom_jitter(aes(colour=factor(cyl)), width = 0.25)

    # A bit of customization

      # More intuitive order of x axis with reorder function.
      # arguments go variable, data, function to apply in sorting
      bp <- ggplot(mpg, aes(x=reorder(class, hwy, mean), y=hwy))
      bp + geom_boxplot()

      # Not typically how plots work; usually go large -> small.
      # Reverse the order by changing the sign of the variable:

      bp <- ggplot(mpg, aes(x=reorder(class, -hwy, mean), y=hwy))
      bp <- bp + geom_boxplot()
      bp

      # Default axis labels weren't great before, and they've
      # gotten uglier. Let's specify them:

      bp + labs(x="Vehicle class",
                y="Highway fuel economy (mpg)" )

      # Two variables: continuous vs. continuous

      sp <- ggplot(mpg, aes(x=cty, y=hwy))
      sp + geom_point() # Boring!

      library(emoGG)
      sp + geom_emoji(emoji="1f697")

      emoji_search("cats")

# Can also "pipe" in to ggplot with dplyr:

  library(dplyr) # in the tidyverse

  mpg %>%
    mutate(class = reorder(class, -hwy, mean)) %>%
      ggplot() + geom_violin(aes(x=class, y=hwy))

# Piping makes it easy to calculate summary stats for plotting:

  library(forcats) # in the tidyverse, for fct_reorder()

mpg %>%
    group_by(class) %>%
      summarise(Mean = mean(hwy),
                se   = sd(hwy) / sqrt(length(hwy))) %>%
        mutate(class = fct_reorder(class, -Mean)) %>%
    ggplot(aes(x=class)) + # an aes in the ggplot call is universal (all geoms)
      geom_errorbar(aes(ymin = Mean-se, # an aes in a geom is geom-specific
                        ymax = Mean+se),
                    size=1.25, width=0.2) +
      geom_point(aes(y=Mean),
                 shape=21, size=4, fill="black",
                 color="white", stroke=1.5) +
      labs(x = "Vehicle class",
           y = "Highway mileage (mean +/- s.e.)")

Analysis of Ecosystems/03 - data visualization/3-1_more_ggplotting.r


files <- c('ADCY5_D.txt')
files <- c('ADCY5_D.txt',  'ADCY5_M.txt',  'ADCY5_P.txt',  'TCF7L2_D.txt',  'TCF7L2_M.txt',  'TCF7L2_P.txt')

IDX_TH <- 100;	# All values below this index should be true positives

for( file in files ) {
	pngFile <- paste( file , '.png', sep="");
	png(pngFile, width = 1024/2, height = 1024);

	par( mfrow=c(2,1) );

	d <- read.table(file, header = FALSE, col.names = c('pos' , 'pvalue'));
	cat('\n', file, '\tNumber of pvalues:', length(d$pvalue), '\n');

	#---
	# Convert zero p-values to non-zero values
	#---
	pval <- d$pvalue
	idx <- 1:length(pval)
	nonNull <- pval > 0
	minp <- min( pval[ nonNull ] )
	pval[ ! nonNull ] <- minp;

	# Plot pvalues
	title <- paste( file, 'p-values [db]');
	q <- -10 * log(pval) / log(10);
	plot( idx, q, main=title, xlab='Index', ylab='p-values [db]' )
	abline( v=IDX_TH , col='blue' )

	th <- mean(q) + 3 * sd(q)
	abline( h=th , col='red' )

	# Stats
	tp <- (q >= th) & (idx <= IDX_TH)
	fn <- (q < th) & (idx <= IDX_TH)
	fp <- (q >= th) & (idx > IDX_TH)
	tn <- (q < th) & (idx > IDX_TH)
	cat('True positives  :', sum(tp), '\n')
	cat('False positives :', sum(fp), '\n')
	cat('False negatives :', sum(fn), '\n')
	cat('True negatives  :', sum(tn), '\n')
	points( idx[tp], q[tp], col='green')
	points( idx[fn], q[fn], col='blue')
	points( idx[fp], q[fp], col='red')

	# QQ-plot
	title <- paste( file, ' QQ-plot');
	y <- sort(pval)
	n <- length(y);
	x <- (1:n) / (n+1)
    lx <- -log10( x )
    ly <- -log10( y )
	range <- c(0 , max(lx, ly) );
	plot( lx, ly, xlim=range, ylim=range, main=title, xlab="-Log[ rank / (N+1) ]", ylab="-Log[ p ]" );
	abline( 0 , 1 , col='red');

	dev.off();
}


##
## Zero-inflated Poissons predicting number of gifts and amount of farm help received
##
## Supplementary Table 1
##
source("init.r")

library(pscl)
library(igraph)
library(MuMIn)

##########################################################################################
## Calculate in-degrees on various networks
##
prepend_ego = function(x) paste0("Ego.", x)  # helper function to add "Ego." to start of column names

nodes.hh = hh %>%
  rename_all(prepend_ego)

# remove village 6
nodes.hh = subset(nodes.hh, Ego.VillageID != 6)

##
## Individual gifts
##
dat = subset(hh.dyads, TotalGifts.ind > 0 & Ego.VillageID != 6, select=c(Ego.HH, Alter.HH, TotalGifts.ind))
g.gifts_ind = graph.data.frame(dat, vertices=nodes.hh, directed=T)

# calculate in degree and put into houses dataframe
deg.in  = degree(g.gifts_ind, mode="in")
nodes.hh$gift.deg.in  = deg.in[ as.character(nodes.hh$Ego.HH) ]

##
## Farm help
##
dat = subset(hh.dyads, HelpObserved > 0 & Ego.VillageID != 6, select=c(Ego.HH, Alter.HH))
g.farm = graph.data.frame(dat, vertices=nodes.hh, directed=T)

# calculate in degree and put into houses dataframe
deg.in  = degree(g.farm, mode="in")
nodes.hh$farm.deg.in  = deg.in[ as.character(nodes.hh$Ego.HH) ]

##########################################################################################
## What predicts in-degree for farm work and gifts
##
d.hh = nodes.hh %>%
  dplyr::select(Ego.HH, farm.deg.in, gift.deg.in, Ego.Size, Ego.WealthRank, Ego.VillageID, Ego.Sex, Ego.zhubo1) %>%
  distinct() %>%
  na.omit()

# zero-inflated poissons
# null
m.null = zeroinfl(farm.deg.in ~ 1, data=d.hh)
m.gift.null = zeroinfl(gift.deg.in ~ 1, data=d.hh)

# control
m.control = zeroinfl(farm.deg.in ~ Ego.Size + Ego.WealthRank + Ego.Sex + factor(Ego.VillageID), data=d.hh)
m.gift.control = zeroinfl(gift.deg.in ~ Ego.Size + Ego.WealthRank + Ego.Sex + factor(Ego.VillageID), data=d.hh)

# full
m.zhubo = zeroinfl(farm.deg.in ~ factor(Ego.zhubo1) + Ego.Size + Ego.WealthRank + Ego.Sex + factor(Ego.VillageID), data=d.hh)
m.gift.zhubo = zeroinfl(gift.deg.in ~ factor(Ego.zhubo1) + Ego.Size + Ego.WealthRank + Ego.Sex + factor(Ego.VillageID), data=d.hh)

#################################################################################
## model selection
##
##
## farm work
##
best.models = model.sel(m.null, m.control, m.zhubo)
top.models  = mget(row.names(subset(best.models, delta<2)))
best.avg    = model.avg(top.models, revised.var=T, beta=F)

# summary(best.avg)

# incidence risk ratios with CIs
zip = cbind( data.frame((coef(best.avg, full=T))), (confint(best.avg, full=T, digits=3)) )
names(zip) = c("Farm work B", "Farm work lwr", "Farm work upr")

round(zip, 3)

write.csv(best.models, file="in-degree - candidate models - farm.csv", row.names=T)

##
## gifts
##
best.models = model.sel(m.gift.null, m.gift.control, m.gift.zhubo)
top.models  = mget(row.names(subset(best.models, delta<2)))
best.avg    = model.avg(top.models, revised.var=T, beta=F)

# summary(best.avg)

# incidence risk ratios with CIs
zip = cbind(zip, data.frame((coef(best.avg, full=T))), (confint(best.avg, full=T, digits=3)) )
names(zip)[4:6] = c("Gifts B", "Gifts lwr", "Gifts upr")

write.csv(best.models, file="in-degree - candidate models - gift.csv", row.names=T)

write.csv(zip, file="zip - parameter estimates.csv", row.names=T)


require(rms)
require(ggplot2)
n <- 1000    # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
sex            <- factor(sample(c('female','male'), n, TRUE))
i <- sex == 'female'
cholesterol <- numeric(n)
cholesterol[i]   <- rnorm(sum(i),   170, 15)
cholesterol[! i] <- rnorm(sum(! i), 200, 25)
label(age)            <- 'Age'      # label is in Hmisc
label(cholesterol)    <- 'Total Cholesterol'
label(blood.pressure) <- 'Systolic Blood Pressure'
label(sex)            <- 'Sex'
units(cholesterol)    <- 'mg/dl'   # uses units.default in Hmisc
units(blood.pressure) <- 'mmHg'
# Specify population model for log odds that Y=1
L <- .4*(sex=='male') + .045*(age-50) +
     (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
# Simulate binary y to have Prob(y=1) = 1/[1+exp(-L)]
y <- ifelse(runif(n) < plogis(L), 1, 0)
cholesterol[1:3] <- NA   # 3 missings, at random
d <- data.frame(y, blood.pressure, age, cholesterol, sex)
rm(y, blood.pressure, age, cholesterol, sex)
dd <- datadist(d); options(datadist='dd')

f <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)),
         data=d)
p <- Predict(f, cholesterol)
class(p) <- setdiff(class(p), 'Predict')
a <- attributes(p)$info$Design
g <- ggplot(p, aes(x=cholesterol, y=yhat)) + geom_line()
xl <- labelPlotmath(a$label['blood.pressure'],
                    a$units['blood.pressure'])
xl2 <- labelPlotmath(a$label['cholesterol'],
                     a$units['cholesterol'])
g <- g + xlab(xl)
g <- g + geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2, linetype=0)
g
g + histSpikeg(yhat ~ cholesterol, p, d, ylim=c(-1, 1.25))
g + histSpikeg(yhat ~ cholesterol, data=d, ylim=c(-1, 1.25))
g + histSpikeg(yhat ~ cholesterol, data=d, ylim=c(-1, 1.25), side=3)

p <- Predict(f, cholesterol, sex)
class(p) <- setdiff(class(p), 'Predict')
g <- ggplot(p, aes(x=cholesterol, y=yhat, color=sex)) + geom_line() +
  xlab(xl2) + ylim(-1, 1)
# show.legend=FALSE gets rid of slash in legend boxes
# See http://stackoverflow.com/questions/10660775/ggplot-legend-slashes
g <- g + geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2,
                linetype=0, show.legend=FALSE)
g
g + histSpikeg(yhat ~ cholesterol + sex, p, d, ylim=c(-1, 1.25))

p <- Predict(f, sex)
class(p) <- setdiff(class(p), 'Predict')
ggplot(p, aes(x=sex, y=yhat)) + coord_flip() + geom_point() +
  geom_errorbar(aes(ymin=lower, ymax=upper), width=0)

p     <- Predict(f)
a     <- attributes(p)$info
yl    <- a$ylabPlotmath
xlabs <- a$Design$label
unts  <- a$Design$units
ylim <- range(pretty(
  if(TRUE) c(p$yhat, p$lower, p$upper)
  else p$yhat), na.rm=TRUE)

grid::grid.newpage()
grid::pushViewport(grid::viewport(layout = grid::grid.layout(2, 2)))
nr <- 1; nc <- 0
for(w in unique(p$.predictor.)) {
  nc <- nc + 1
  if(nc > 2) {nr <- nr + 1; nc <- 1}
  i <- p$.predictor. == w
  z <- p[i, w]
  yhat <- p[i, 'yhat']
  l  <- levels(z)
  ll <- length(l)
  xl <- labelPlotmath(xlabs[w], unts[w])
  zz <- data.frame(z, yhat)
  g  <- ggplot(zz, aes(x=z, y=yhat)) + ylim(ylim) +
    theme(plot.margin = unit(rep(.2, 4), 'cm'))

  g <- g + if(ll) geom_point() else geom_line()
  g <- g + xlab(xl) + ylab(yl)
  g <- g + if(ll)
    geom_errorbar(data=p[i,], aes(ymin=lower, ymax=upper), width=0)
    else
      geom_ribbon(data=p[i,], aes(ymin=lower, ymax=upper), alpha=0.2,
                  linetype=0, show.legend=FALSE)
  print(g, vp = grid::viewport(layout.pos.row = nr, layout.pos.col = nc))
}

# Change y scale to be uniform
# try to narrow gaps

p <- Predict(f, age, sex, blood.pressure=c(120,140,160),
             cholesterol=c(180,200,215))
class(p) <- setdiff(class(p), 'Predict')
g <- ggplot(p, aes(x=age, y=yhat, color=sex)) + geom_line()
g <- g + geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2,
                linetype=0, show.legend=FALSE)
g + facet_grid(blood.pressure ~ cholesterol)
g + facet_grid(cholesterol ~ blood.pressure)
eval(parse(text='g + facet_grid(cholesterol ~ blood.pressure)'))

# attr(p, 'info')$varying shows 4 predictors varying in order: age bp ch sex

g <- ggplot(p, aes(x=age, y=yhat)) + geom_line()
g <- g + geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2,
                linetype=0, show.legend=FALSE)
g + facet_grid(blood.pressure ~ cholesterol*sex)
g + facet_grid(cholesterol*sex ~ blood.pressure)

# Add superposition
g <- ggplot(p, aes(x=age, y=yhat, color=blood.pressure)) + geom_line()
g <- g +
  geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2,
                linetype=0, show.legend=FALSE)
g=g + facet_grid(sex ~ blood.pressure)

if(FALSE) {   # doesn't work - where is .predictor.?
p <- as.data.frame(p)
g <- ggplot(p, aes(y=yhat)) + facet_wrap(~ .predictor., scales='free_x') +
  xlab(NULL)
require(plyr)
pa <- subset(p, .predictor. == 'age')
pc <- subset(p, .predictor. == 'cholesterol')

g <- g + geom_line(subset=.(.predictor.=='age'), aes(x=age)) +
  geom_ribbon(subset=.(.predictor.=='age'), aes(x=age, ymin=lower, ymax=upper),
              alpha=0.2, linetype=0, show.legend=FALSE) +
  geom_line(subset=.(.predictor.=='cholesterol'), aes(x=cholesterol)) +
  geom_ribbon(subset=.(.predictor.=='cholesterol'),
              aes(x=cholesterol, ymin=lower, ymax=upper),
              alpha=0.2, linetype=0, show.legend=FALSE)
g
g + geom_point(subset=.(.predictor.=='sex'), aes(x=as.numeric(sex))) +
    geom_errorbar(subset=.(.predictor.=='sex'),
               aes(x=as.numeric(sex), ymin=lower, ymax=upper), width=0)

## Will not work:
##  g + geom_point(subset=.(.predictor.=='sex'), aes(x=sex)) +
##  geom_errorbar(subset=.(.predictor.=='sex'),
##                aes(x=sex, ymin=lower, ymax=upper), width=0)
## Error: Discrete value supplied to continuous scale

xx <- NULL
pred <- p$.predictor.
for(i in unique(pred)) xx <- c(xx, p[pred == i, i])
p$xx <- xx
z <- ggplot(p, aes(x=xx, y=yhat)) +
     facet_wrap(~ .predictor., scales='free_x') + xlab(NULL) +
     geom_line() + geom_ribbon(aes(x=xx, ymin=lower, ymax=upper),
                            alpha=0.2, linetype=0, show.legend=FALSE)
z
}

## From http://stackoverflow.com/questions/11979017/changing-facet-label-to-math-formula-in-ggplot2
facet_wrap_labeller <- function(gg.plot, labels=NULL) {
  require(gridExtra)
  g <- ggplotGrob(gg.plot)
  gg <- g$grobs
  strips <- grep("strip_t", names(gg))
  for(ii in seq_along(labels))  {
    modgrob <- getGrob(gg[[strips[ii]]], "strip.text",
                       grep=TRUE, global=TRUE)
    gg[[strips[ii]]]$children[[modgrob$name]] <-
      editGrob(modgrob,label=labels[ii])
  }
  g$grobs <- gg
  class(g) = c("arrange", "ggplot", class(g))
  g
}
if(FALSE) {
pold <- p
p$.predictor. <- factor(p$.predictor., names(a$label))
pmlabels <- vector('expression', length(a$label))
names(pmlabels) <- levels(p$.predictor.)
for(v in names(a$label)) pmlabels[v] <-
 labelPlotmath(a$label[v], a$units[v])

## Re-order panels by original model specification
z <- ggplot(p, aes(x=xx, y=yhat)) +
     facet_wrap(~ .predictor., scales='free_x', ncol=3) + xlab(NULL) +
     geom_line() + geom_ribbon(aes(x=xx, ymin=lower, ymax=upper),
                            alpha=0.2, linetype=0, show.legend=FALSE)

facet_wrap_labeller(z, pmlabels)
}


#Starter code
link <- 'https://github.com/gumdropsteve/datasets/raw/master/deck.csv'
deck <- read.csv(link)
deck

#Create number of rounds and players

n_rounds = 100
n_players = 4

# make result holders
round_leader_points = rep(0, n_rounds)
round_leader_name = rep(0, n_rounds)

# start rounds
for (r in 1:n_rounds){

  # shuffle the original deck (needs to be reshuffled every round)
  shuffled_deck <- deck[sample(nrow(deck)),]
  # print(shuffled_deck)

  # how many cards do we need for this round? (3 cards per player)
  n_cards_total <- 3 * n_players

  # take the number of cards from the top of the shuffled deck
  cards_in_play = head(shuffled_deck, n_cards_total)

  for (p in 1:n_players){
    # print(p)

    first_value = (p * 3) - 2
    last_value = p * 3

    # deal this player (p) their cards
    this_players_cards = cards_in_play[first_value:last_value, ]
    # print(this_players_cards)

    # add the values of the player's cards together (value column)
    this_players_score = sum(this_players_cards$value)
    # print(this_players_score)

    # did this player score higher than the current leader?
    if (round_leader_points[r] < this_players_score){
      # yes, so make this player (p) the new leader (of this round (r))
      round_leader_points[r] = this_players_score
      round_leader_name[r] = p
    }
    # did the player tie the current high score?
    else if (round_leader_points[r] == this_players_score) {
      # yes, so set the round leader to 0 (no winner)
      round_leader_name[r] = 0
      # if a later player scores more than the tie, they will be made the leader by the 1st if ^^
    }
  }
}

# make table of sums of rounds won by each player
leader_table = table(round_leader_name)
leader_table

# plot the table
plot(leader_table)


dist_gene <- function(start1, end1, start2, end2){
  dist <- 0
  if( sign(start2 - start1) * sign(start2 - end1)>0  & sign(end2 - start1) * sign(end2 - end1)>0 &sign(start2 - start1) * sign(end2 - start1) >0 & sign(start2 - end1) * sign(end2 - end1)> 0 ){
    dist <- min (abs(start2 - start1),  abs(start2 - end1), abs(end2 - start1),  abs(end2 - end1))
  }
  dist
}

dist_pairwise <- function(x, gene_complete){
  gene_sub <- subset(gene_complete, name2==as.character(x))
  dist <- c()
  if(dim(gene_sub)[1] >1 ){
    for(i in seq_along(gene_sub$bin)){
      for (j in seq_along(gene_sub$bin) ){
      if(j<=i){
        next()
      }
      dist <- c(dist, dist_gene(gene_sub$txStart[i], gene_sub$txEnd[i], gene_sub$txStart[j], gene_sub$txEnd[j] ))
    }
  }
  }else{
    dist <- 0
  }

  max(dist)
}

getGene <- function(x, gene_complete){
  gene_sub <- subset(gene_complete, name2==as.character(x))
  len <- with(gene_sub, txEnd-txStart)
  as.character(gene_sub$name)[which.max(len)]
}

gene_complete <- read.table("refGene.txt", header=F, sep="\t")

names(gene_complete) <- c("bin", "name", "chrom", "strand", "txStart", "txEnd", "cdsStart", "cdsEnd", "exonCount", "exonStarts", "exonEnds", "score", "name2", "cdsStartStat", "cdsEndStat", "exonFrames")

with(gene_complete, table(name)) -> temp

gene_complete <- subset(gene_complete, (! name %in% names(temp)[temp>1]) & cdsStartStat=="cmpl" & cdsEndStat=="cmpl" & grepl("NM_", name) & (substr(chrom, 4, 100) %in% c(c(1:22), "X")) )

with(gene_complete, tapply(chrom, as.character(name2), function(x){length(unique(x))})) -> temp
gene_complete <- subset(gene_complete, ! name2 %in% names(temp)[temp>1])

unlist(lapply(unique(gene_complete$name2), dist_pairwise, gene_complete)) -> temp
gene_complete <- subset(gene_complete, ! name2 %in% unique(gene_complete$name2)[temp>50000])

lapply(unique(gene_complete$name2), getGene, gene_complete) -> temp
gene_complete <- gene_complete[match(unlist(as.character(temp)), gene_complete$name), ]

write.table(gene_complete[,c(3:13)], "refGene.cleaned.txt", col.names=T, row.names=F, sep="\t", quote=F)


#trading algorithm #1

#library(pracma)
#training_data <- read.csv("GE.csv")
#ma_LONG <- 26 #days for long
#ma_SHORT <- 12 #days for short
#ma_SIGNAL <- 9
#ma_DAYS <- 26 #days to use for average of absolute maximas

#training
#portfolio <- 1000
#portfolio2 <- 1000
#shares <- 0
#shares2 <- 0

#average_price <- c()
#number_of_buys <- 0
#number_of_sells <- 0
#counter <- 0
#count <- 0

#MACD
#long <- movavg(training_data[,5],ma_LONG, type="e")
#short <- movavg(training_data[,5],ma_SHORT, type="e")
#MACD <- short - long
#SIGNAL <- movavg(MACD,ma_SIGNAL, type="e")
#hist_difference <- MACD - SIGNAL
#p_n_avg <- check_sign(hist_difference)
#p_avg <- p_n_avg[1]
#n_avg <- p_n_avg[2]

#calculates average of historical MACD differences
#check_sign <- function(hist_difference) {
#	pp_avg <- 0
#	nn_avg <- 0
#	for(i in 1:length(hist_difference)) {
#		isS <- sign(hist_difference[i])
#		if(!is.null(isS)) {
#			if(isS) {
#				pp_avg <- c(pp_avg, hist_difference[i])
#			} else if (!isS) {
#				nn_avg <- c(nn_avg, hist_difference[i])
#			}
#		}
#	}
#	if(length(nn_avg) > 1) {
#		#if(length(nn_avg) > 2) {
#		#	nn_avg <- (mean(nn_avg[-1]) - sd(nn_avg[-1]))
#		#} else {
#			nn_avg <- mean(nn_avg[-1])
#		#}
#	} else {
#		nn_avg <- 0
#	}
#	if(length(pp_avg) > 1) {
#	#	if(length(pp_avg) > 2) {
#	#		pp_avg <- (mean(pp_avg[-1]) - sd(pp_avg[-1]))
#	#	} else {
#			pp_avg <- mean(pp_avg[-1])
#	#	}
#	} else {
#		pp_avg <- 0
#	}
#	return(c(pp_avg,nn_avg))
#}

#check if positive, negative, or zero
#sign <- function(difference) {
#	if(difference > 0) {
#		return(TRUE)
#	} else {
#		if(difference == 0) {
#			return(NULL)
#		} else {
#			return(FALSE)
#		}
#	}
#}

#training
#for(i in (ma_DAYS+1):nrow(training_data)) {
#	if(counter >= 30) {
#		portfolio <- portfolio + 1000
#		portfolio2 <- portfolio2 + 1000
#		counter <- 0
#		count <- count + 1
#	}
#	counter <- counter + 1
#	price <- training_data[i,5] #testing on closing price
#	difference <- hist_difference[i]
#	p_n_avg <- check_sign(hist_difference[(i - ma_DAYS):(i - 1)])
#	p_avg <- p_n_avg[1]
#	n_avg <- p_n_avg[2]
#
#	if(i == (ma_DAYS+1)) { #initial investment
#		can_buy <- floor(portfolio / price)
#		portfolio <- portfolio - (can_buy * price)
#		number_of_buys <- number_of_buys + 1
#		shares <- can_buy
#		average_price <- price
#
#
#
#		can_buy <- floor(portfolio2 / price)
#		portfolio2 <- portfolio2 - (can_buy * price)
#		shares2 <- can_buy
#
#	}
#
#	isS <- sign(difference)
#	if(!is.null(isS)) {
#		if(isS) {
#			if(difference > p_avg) {
#				if(shares > 0) {
#					if((mean(average_price) * shares) < (shares * price)) {
#						portfolio <- portfolio + (shares * price)
#						shares = 0
#						number_of_sells <- number_of_sells + 1
#						average_price <- c()
#					}
#				}
#			}
#		} else if (!isS) {
#			if(difference < n_avg) {
#				if(portfolio > price) {
#					can_buy <- floor(portfolio / price)
#					if(can_buy > 0) {
#						portfolio <- portfolio - (can_buy * price)
#						number_of_buys <- number_of_buys + 1
#						shares <- shares + can_buy
#						average_price <- c(average_price, price)
#					}
#				}
#				if(portfolio2 > price) {
#					can_buy <- floor(portfolio2 / price)
#					if(can_buy > 0) {
#						portfolio2 <- portfolio2 - (can_buy * price)
#						shares2 <- shares2 + can_buy
#					}
#				}
#
#			}
#		}
#	}
#	if(i == nrow(training_data)) {
#		if(shares > 0) {
#				portfolio <- (shares * price)
#				shares = 0
#				number_of_sells <- number_of_sells + 1
#				average_price <- 0
#		}
#		investment <- (count * 1000) + 1000
#		print(paste("Investment: ", investment, sep=""))
#		print(paste("Portfolio: ", portfolio, sep=""))
#		print(paste("Return: %", round(((portfolio - investment)/investment)*100, digits=2), sep=""))
#		print(paste("Bought: ", number_of_buys, sep=""))
#		print(paste("Sold: ", number_of_sells, sep=""))
#
#		print(paste("Portfolio2: ", portfolio2 + (shares2 * price), sep=""))
#		print(paste("Return: %", round((((portfolio2 + (shares2 * price)) - investment)/investment)*100, digits=2), sep=""))
#
#	}
#}


library(optimx)
library(tidyverse)
library(lme4)

prior <- read.csv("prior_data.csv")

# compare effect of position
m.position_t <- glmer(CHOICE=='TOP' ~ 1 + (1|SUB) + (1|ITEM), prior, family="binomial")
summary(m.position)
m0.position_t <- glmer(CHOICE=='TOP' ~ 0 + (1|SUB) + (1|ITEM), prior, family="binomial")
anova(m0.position_t,m.position_t)

m.position_c <- glmer(CHOICE=='TOP' ~ 1 + (1|SUB) + (1|ITEM), prior, family="binomial")
summary(m.position)
m0.position_c <- glmer(CHOICE=='TOP' ~ 0 + (1|SUB) + (1|ITEM), prior, family="binomial")
anova(m0.position_c,m.position_c)

# compare effect of size
m.size_smaller <- glmer(CHOICE_SIZE=="SMALLER" ~ 1 + (1|SUB) + (1|ITEM), prior, family="binomial")
summary(m.size_smaller)
m0.size_smaller <- glmer(CHOICE_SIZE=="SMALLER" ~ 0 + (1|SUB) + (1|ITEM), prior, family="binomial")
anova(m0.size_smaller,m.size_smaller)

m.size_larger <- glmer(CHOICE_SIZE=="LARGER" ~ 1 + (1|SUB) + (1|ITEM), prior, family="binomial")
summary(m.size_larger)
m0.size_larger <- glmer(CHOICE_SIZE=="LARGER" ~ 0 + (1|SUB) + (1|ITEM), prior, family="binomial")
anova(m0.size_larger,m.size_larger)


stdin <- file("stdin")
open(stdin)

invisible(readLines(stdin, n = 1, warn = FALSE)) # Consumes line to ignore `n`
x <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])

close(stdin)

quartiles <- function(x) {
  y <- sort(x)
  if (length(y) %% 2 == 0) {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y)])
    ))
  } else {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y) + 1])
    ))
  }
}
cat(paste(quartiles(x), collapse = "\n"), "\n")


# /* !/usr/bin/Rscript */

# /*
writeLines("\n-------------")
writeLines("Exploring combined dataset to view topography & select features")
# */

#' ## Exploration
#' Quickly summarise some key features:
summary(combi[c("Age", "Sex", "SibSp", "Parch", "Fare", "Class", "Fate")])

#' From the above we can list the following facts about the passengers:
#' - Majority boarded at Southampton.
#' - Majority in 3rd class.
#' - Majority perished.
#' - There were ~twice as many men than women.
#' - Mean age ~30.
#'
#' ### Examining Fare
#' It seems some passengers had a fare of zero, which should only apply to
#' infants (<1 year). Let's assert that:
combi[which(combi$Fare == 0), c("Name", "Age")]

#' Although *Age* is missing from some of the records, it seems some adults
#' have managed to pay 0 Fare, or more likely they are part of a group and
#' the fare has been registered to another person. However, before the data
#' can be processed the missing Age data must be imputed.
#'
#' ### Distributions
#' Examine the distribution of *Age*, *Class* and *Sex*:
barplot(table(combi$Pclass),
  names.arg = c("First", "Second", "Third"),
  main="Transport class", col="black"
)

barplot(table(combi$Sex),
  names.arg = c("Female", "Male"),
  main="Gender", col="black"
)

hist(combi$Age,
  main = "Passenger Age",
  col  = "black",
  xLab = NULL
)

#' Nothing above looks too out of the ordinary except for a slight skewing of
#' Age data towards young people (0-30).
#'
#' ### Categorical Features
#' Next examine the relationship between various feature pairs. For this we
#' employ mosaic plots to most effectively show the distributions of
#' categorical variables against one another.
#'
#' Since we're most interested in identifying trends with respect to the
#' outcome variable "Fate", only the training data is used to generate the
#' plots (as it contains the ground truth for the records within).
mosaicplot(Survived ~ Pclass,
  data  = raw,
  main  = "Passenger Fate by Traveling Class",
  shade = FALSE,
  color = TRUE,
  dir   = c("v", "h"),
  xlab  = "Survived",
  ylab  = "Travel Class"
)

mosaicplot(Survived ~ SibSp,
  data  = raw,
  main  = "Passenger Fate by Siblings + Spouse",
  shade = FALSE,
  color = TRUE,
  dir   = c("v", "h"),
  xlab  = "Survived",
  ylab  = "Siblings + Spouse"
)

mosaicplot(Survived ~ Parch,
  data  = raw,
  main  = "Passenger Fate by Parents and Children",
  shade = FALSE,
  color = TRUE,
  dir   = c("v", "h"),
  xlab  = "Survived",
  ylab  = "Parents + Kids"
)

mosaicplot(Survived ~ Embarked,
  data  = raw,
  main  = "Passenger Fate by Embarkation",
  shade = FALSE,
  color = TRUE,
  dir   = c("v", "h"),
  xlab  = "Survived",
  ylab  = "Embarked"
)

mosaicplot(Survived ~ Sex,
  data  = raw,
  main  = "Passenger Fate by Gender",
  shade = FALSE,
  color = TRUE,
  dir   = c("v", "h"),
  xlab  = "Survived",
  ylab  = "Gender"
)

mosaicplot(Survived ~ Sex + Pclass,
  data  = raw,
  main  = "Passenger Fate by Gender and Class",
  shade = FALSE,
  color = TRUE,
  off   = c(1,5,5),
  dir   = c("h", "v", "v"),
  xlab  = "Travelling Class",
  ylab  = "Survived"
)

#' Here we can identify a number of relationships, and therefore possible
#' correlations and/or con-founders:
#' - *Survived* vs *Pclass*; definite relationship
#' - *Survived* vs *Gender*; definite relationship
#' - *Survived* vs *Pclass* vs *Gender*; definite relationship
#'
#' ### Continuous Features
#' Also explore continuous variables such as *Age* through boxplots.
boxplot(Age ~ Survived,
  data = raw,
  xlab = "Survived",
  ylab = "Age"
)

boxplot(Age ~ Class,
  data = combi,
  xlab = "Pclass",
  ylab = "Age"
)

boxplot(Age ~ Class + Survived,
  data = combi,
  xlab = "Pclass",
  ylab = "Age"
)

#' The plots demonstrate a possible relationship between *Age* and *Fate*,
#' worthy of further exploration or feature engineering. Additionally it
#' confirms a suspicion that higher class equates to older age. This maybe
#' potentially important when constructing the model later.

# /*
writeLines("\n-------------")
writeLines("Exploring DONE")
# */


#' @title
#' Predict the response trajectory
#'
#' @description
#' This function generates prediction of the functional response based on the fitting
#' results of the NRRR model and the given predictor trajectory. The functional
#' response is predicted at a given sequence of time points \code{tseq}.
#'
#' @usage
#' NRRR.pred(tseq, X, sseq, Ag, Bg, Al, Bl, phi)
#'
#' @param tseq a sequence of time points at which the prediction of the response
#'             trajectory is generated.
#' @param sseq a sequence of time points at which the predictor trajectory is observed.
#' @param X an array of dimension \code{(n, p, length(sseq))} where n is
#'          the sample size and p is the number of components in the
#'          multivariate predictor. It is the predictor trajectory observed at
#'          discrete time points \code{sseq}.
#' @param phi a matrix of dimension \code{length(sseq)}-by-jx. It is the set of
#'            basis functions to expand the predictor trajectory.
#' @param Ag the estimated matrix U in a NRRR model.
#' @param Bg the estimated matrix V in a NRRR model.
#' @param Al the estimated matrix A in a NRRR model.
#' @param Bl the estimated matrix B in a NRRR model.
#'
#'
#' @return This function returns a list:
#'   \item{Cstar}{the estimated coefficient matrix in equation (7) of the NRRR paper,
#'                i.e., \eqn{(U \otimes I_jy)A* B*^T(V \otimes I_jx)^T}.}
#'   \item{Ypred}{the predicted response trajectory which is an array of
#'           dimension \code{(n, d, length(tseq))}}
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#' @importFrom splines bs
#' @export
#' @examples
#' library(NRRR)
#' set.seed(3)
#' # Simulation setting 2 in NRRR paper
#' simDat <- NRRR.sim(n = 100, ns = 100, nt = 100, r = 3, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 20, d = 20, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' fit_nrrr <- with(simDat, NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
#'                  jx = 8, jy = 8, p = 20, d = 20, n = 100,
#'                  maxiter = 300, conv = 1e-4, method = c("RRR", "RRS")[1],
#'                  lambda = 0, ic = c("BIC", "BICP", "AIC", "GCV")[1],
#'                  dimred = c(TRUE, TRUE, TRUE), rankfix = NULL))
#' Ypred_nrrr <- NRRR.pred(simDat$tseq, simDat$X, simDat$sseq,
#'                         fit_nrrr$Ag, fit_nrrr$Bg, fit_nrrr$Al,
#'                         fit_nrrr$Bl, simDat$phi)
NRRR.pred <- function(tseq,X,sseq,Ag,Bg,Al,Bl,phi){
  n <- nrow(X)

  p <- nrow(Bg)
  d <- nrow(Ag)
  rx <- ncol(Bg)
  ry <- ncol(Ag)

  jx <- nrow(Bl)/rx
  jy <- nrow(Al)/ry

  nt <- length(tseq)
  ns <- length(sseq)

  # Note that you can predict at different time
  psi <- splines::bs(c(0,tseq),df = jy)[-1,]
  Jpsi <- matrix(nrow=jy,ncol=jy,0)
  tdiff <- (tseq - c(0,tseq[-nt]))
  for(t in 1:nt) Jpsi <- Jpsi + psi[t,]%*%t(psi[t,])*tdiff[t]
  eJpsi <- eigen(Jpsi)
  Jpsihalf <- eJpsi$vectors%*%diag(sqrt(eJpsi$values))%*%t(eJpsi$vectors)
  Jpsihalfinv <- eJpsi$vectors%*%diag(1/sqrt(eJpsi$values))%*%t(eJpsi$vectors)

  # Compute Cstar from estimated C
  alindex <- rep(1:ry,jy)
  Alstar <- Al[order(alindex),]
  blindex <- rep(1:rx,jx)
  Blstar <- Bl[order(blindex),]
  # Adjust
  Alstar <- kronecker(diag(ry),Jpsihalfinv)%*%Alstar
  Cstar <- kronecker(Ag,diag(jy))%*%Alstar%*%t(Blstar)%*%kronecker(t(Bg),diag(jx))

  # Integrated X
  # phi <- splines::bs(c(0,sseq),df = jx)[-1,]
  Xint <- matrix(nrow=p*jx,ncol=n,0)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(s in 1:ns){
    Xint <- Xint + kronecker(diag(nrow=p,ncol=p),phi[s,])%*%t(X[,,s])*sdiff[s]
  }

  # Compute predicted values
  Ypred <- array(dim=c(n,d,nt),NA)
  for(t in 1:nt){
    Psit <- kronecker(diag(nrow=d,ncol=d),t(psi[t,]))
    Ypred[,,t] <- t(Psit%*%Cstar%*%Xint)
  }

  list(Jpsihalf=Jpsihalf,Cstar=Cstar,Ypred=Ypred)

}


#!/usr/bin/env Rscript
library("optparse")

computedher<-function(beta, se, af,N){
#https://journals.plos.org/plosone/article/file?type=supplementary&id=info:doi/10.1371/journal.pone.0120758.s001
maf<-af
maf[!is.na(af) & af>0.5]<- 1 - maf[!is.na(af) & af>0.5]
ba<-!is.na(beta) & !is.na(se) & !is.na(maf) & !is.na(N)
a<-rep(NA, length(beta))
b<-rep(NA, length(beta))
a<-2*(beta[ba]**2)*(maf[ba]*(1-maf[ba]))
b<-2*(se[ba]**2)*N[ba]*maf[ba]*(1-maf[ba])
res<-rep(NA, length(beta))
res[ba]<-a[ba]/(a[ba]+b[ba])
res
}

option_list = list(
  make_option(c("-f", "--file"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chro"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chro_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--bp_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--pheno_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--beta_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ci_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--p_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--n_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--freq_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--rs_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--riskall_head"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--format"), type="character", default="USCS",
              help="dataset file name", metavar="character"),
  make_option(c("--typeformat"), type="character", default="csv",
              help="dataset file name", metavar="character"),
  make_option(c("-o", "--out"), type="character", default="out.txt",
              help="output file name [default= %default]", metavar="character")
);

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
#bin 	590	smallint(5) unsigned 	range 	Indexing field to speed chromosome range queries.
#chrom 	chr1	varchar(255) 	values 	Reference sequence chromosome or scaffold
#chromStart 	768252	int(10) unsigned 	range 	Start position in chromosome
#chromEnd 	768253	int(10) unsigned 	range 	End position in chromosome
#name 	rs2977608	varchar(255) 	values 	ID of SNP associated with trait
#pubMedID 	31969693	int(10) unsigned 	range 	PubMed ID of publication of the study
#author 	Coleman JRI	varchar(255) 	values 	First author of publication
#pubDate 	2020-01-23	varchar(255) 	values 	Date of publication
#journal 	Mol Psychiatry	varchar(255) 	values 	Journal of publication
#title 	Genome-wide gene-environmen...	varchar(1024) 	values 	Title of publication
#trait 	Major depressive disorder	varchar(255) 	values 	Disease or trait assessed in study
#initSample 	29,475 European ancestry ca...	longblob 	  	Initial sample size
#replSample 	NA	longblob 	  	Replication sample size
#region 	1p36.33	varchar(255) 	values 	Chromosome band / region of SNP
#genes 	NR	longblob 	  	Reported Gene(s)
#riskAllele 	rs2977608-A	longblob 	  	Strongest SNP-Risk Allele
#riskAlFreq 	0.259029	varchar(255) 	values 	Risk Allele Frequency
#pValue 	8E-6	varchar(255) 	values 	p-Value
#pValueDesc 	 	varchar(255) 	values 	p-Value Description
#orOrBeta 	1.0729614	varchar(255) 	values 	Odds ratio or beta
#ci95 	[1.04-1.1]	varchar(255) 	values 	95% Confidence Interval
#platform 	Affymetrix [7791636] (imputed)	varchar(255) 	values 	Platform and [SNPs passing QC]
#cnv 	N	enum('Y', 'N') 	values 	Y if Copy Number Variant

#lisp="Type 2 diabetes";lisc=c("22","21")
format=opt[['format']]
if(format=="USCS"){
Data<-read.csv(opt[['file']], header=F, sep='\t')
chrohead="chrom";phenhead="trait";poshead="chromEnd";OrBetaHead="orOrBeta";headCi95="ci95";pValueHead="pValue";nvalueHead="initSample";freqHead="riskAlFreq";rsHead="name";riskall="riskAllele"
names(Data)<-c("bin", "chrom", "chromStart", "chromEnd", "name", "pubMedID", "author", "pubDate", "journal", "title", "trait", "initSample","replSample","region", "genes", "riskAllele", "riskAlFreq", "pValue", "pValueDesc", "orOrBeta", "ci95","platform", "cnv")
}else{
chrohead=opt[['chro_head']];phenhead=opt[['pheno_head']];poshead=opt[['bp_head']];OrBetaHead=opt[['beta_head']];headCi95=opt[['ci_head']];pValueHead=opt[['p_head']];nvalueHead=opt[['n_head']];freqHead=opt[['freq_head']];rsHead=opt[['rs_head']];riskall=opt[['riskall_head']]
if(opt[['typeformat']]=='csv')Data<-read.csv(opt[['file']])
else Data<-read.table(opt[['file']], header=T, sep='\t')
}

Data[,chrohead]<-gsub('chr', '',as.character(Data[,chrohead]))

Data2Sub<-Data #[, c(chrohead,poshead, OrBetaHead,headCi95,pValueHead,phenhead,nvalueHead,freqHead)]

IC<-t(sapply(strsplit(gsub("[", "", sapply(strsplit(as.character(Data2Sub[,headCi95]), split=']',fixed=T),function(x)x[1]),fixed=T), split="-"),function(x){
if(length(x)==2){return(c(as.numeric(x[1]),as.numeric(x[2])))
}else{
return(c(-as.numeric(x[2]),as.numeric(x[3])))
}
}))
IC<-data.frame(lower.cat=IC[,1], upper.cat=IC[,2])
Data2Sub<-cbind(Data2Sub,IC)
Data2Sub$nsample.cat<-sapply(strsplit(as.character(Data2Sub[,nvalueHead]),split="[ ]"),function(x)sum(as.integer(gsub(",", "",grep("[0-9]", x,value=T)))))
Data2Sub$beta.cat<-as.numeric(as.character(Data2Sub[,OrBetaHead]))
balisebeta<-!is.na(Data2Sub$beta.cat) & Data2Sub$beta.cat>=1
Data2Sub$lower.cat[balisebeta]<-log2(Data2Sub$lower.cat[balisebeta])
Data2Sub$upper.cat[balisebeta]<-log2(Data2Sub$upper.cat[balisebeta])
#Data2Sub<-Data2Sub[!is.na(Data2Sub$beta.cat) & !is.na(Data2Sub$lower.cat) & !is.na(Data2Sub$upper.cat) & !is.na(Data2Sub$nsample.cat) ,]

Data2Sub$beta.cat[balisebeta]<-log2(Data2Sub$beta.cat[balisebeta])
Data2Sub$risk.allele.af[balisebeta]<-as.numeric(as.character(Data2Sub[balisebeta,freqHead]))
Data2Sub$sd.cat<-(Data2Sub$upper.cat - Data2Sub$beta.cat)/1.96
Data2Sub$sd.cat2<-(Data2Sub$upper.cat - Data2Sub$beta.cat)/1.96*sqrt(Data2Sub$nsample.cat)
Data2Sub$z.cat.v1<-Data2Sub$beta.cat/(Data2Sub$sd.cat)
Data2Sub$z.cat<-qnorm(Data2Sub[,pValueHead],lower.tail=FALSE)
Data2Sub$h2.cat=computedher(Data2Sub$beta.cat, Data2Sub$sd.cat, Data2Sub$risk.allele.af,Data2Sub$nsample.cat)
Data2Sub$pvalue<-as.numeric(as.character(Data2Sub[,pValueHead]))
#Data2Sub<-Data2Sub[!is.na(Data2Sub$h2.cat) & !is.na(Data2Sub[,pValueHead]),]
#Data2Sub<-Data2Sub[order(Data2Sub$h2.cat),]
Data2Sub$order<-1:nrow(Data2Sub)
#Good<-aggregate(as.formula(paste("order~",chrohead,"+",poshead,sep="")), data=Data2Sub, min)$order
#Data2Sub<-Data2Sub[Data2Sub$order %in% Good,]

write.csv(Data2Sub, file=paste(opt[['out']], '_all.csv',sep=''), row.names=F)
writeLines(unique(as.character(Data2Sub[,phenhead])), con=paste(opt[['out']], '_pheno.csv',sep=''))
write.csv(as.data.frame(table(Data2Sub[,phenhead])), file=paste(opt[['out']], '_phenocount.csv',sep=''))


## Get package implementing Weinstein et al., from GitHub
library(devtools)
install_github("selectiveCI", "johnros", subdir='selectiveCI')
library(selectiveCI)

library(raster)

x <- scale(matrix(c(1,1,1.1,.9,.8,1.2),2),center=FALSE)

b1 <- (x[2,1]+x[2,2])/(x[1,1]+x[1,2])
b2 <- (x[2,1]+x[2,3])/(x[1,1]+x[1,3])

ci.len.wrapper <- function(xy) {
    good <- which((xy[,2] > b1*xy[,1]) & (xy[,2] < b2 * xy[,1]))
    z <- rep(NA,nrow(xy))
    z[good] <- ci.len(xy[good,1],xy[good,2])
    z
}

ci.len <- function(x,y) {
    cutoff.x <- ifelse(x>y,(y-x)/(b1-1),(y-x)/(b2-1))
    cutoff.y <- ifelse(x>y,b1*(y-x)/(b1-1),b2*(y-x)/(b2-1))
    cutoff <- (cutoff.x + cutoff.y)/sqrt(2)
    observed <- (x+y)/sqrt(2)
    apply(cbind(observed,cutoff),1,function(x) {
        ci <- try(ShortestCI(x[1],1,x[2],.05),silent=TRUE)
        if(is.list(ci)) {
            return(ci$upper - ci$lower)
        } else {
            return(NA)
        }
    })
}

xy <- expand.grid(c(-1,seq(0,4,.02)),c(-1,seq(0,4,.02)))
z <- ci.len.wrapper(xy)
## This is a hack because of a bug in the package
z[xy[,1] > 0 & abs(xy[,1]-xy[,2])<.023] <- 2*1.96

rast <- rasterFromXYZ(cbind(xy,z))

pdf("CILengthCorr.pdf")
plot(rast,xlim=c(-2.5,4),ylim=c(-2.5,4),xlab=expression(y[1]),ylab=expression(y[2]),col=rev(heat.colors(20)),
     main="CI Length for Univariate Model")
abline(h=0,lty=3,col="gray")
abline(v=0,lty=3,col="gray")
arrows(x0=c(0,0,0),y0=c(0,0,0),x1=c(x[1,]),y1=c(x[2,]),length=.15)
abline(0,b1,lty=2)
abline(0,b2,lty=2)
dev.off()


source('~/project/main.r')
library('highcharter')

######## Zone Analysis
raw_tmp <- select(row_refine,區,死,受傷)
raw_tmp$count <- 1
raw_tmp[is.na(raw_tmp)] <- 0
raw_tmp_summary <- (raw_tmp %>% group_by(區) %>%
  summarise_all(sum)
)

raw_tmp_summary$死比率 <- raw_tmp_summary$死 / sum(raw_tmp_summary$count) * 100
raw_tmp_summary$受傷比率 <- raw_tmp_summary$受傷 / sum(raw_tmp_summary$count) * 100
raw_tmp_summary$意外比率 <- raw_tmp_summary$count / sum(raw_tmp_summary$count) * 100

highchart() %>%
  hc_chart(type ="column") %>%
  hc_xAxis(categories = raw_tmp_summary$區) %>%
  hc_add_series(data = raw_tmp_summary$死比率, name = "死/總意外比率") %>%
  hc_add_series(data = raw_tmp_summary$受傷比率, name = "受傷/總意外比率") %>%
  hc_add_series(data = raw_tmp_summary$意外比率, name = "意外/總意外比率")

# rm(raw_tmp,raw_tmp_summary)

raw_tmp_summary %>% hchart(
  "pie", hcaes(x = 區, y = count),
  name = "意外比率"
)


#' Calculate log likelihood for each observation of an enmSdmBayes model
#'
#' This function calculates the log likelihood of each observation (detections within a county).
#' @param mcmc Object of class \code{mcmc.list}.
#' @param data Data list object (like that supplied to \code{nimbleMCMC} or \code{runMCMC}).
#' @param constants Constants list object (like that supplied to \code{nimbleMCMC} or \code{runMCMC}).
#' @param hasNeighs Logical, if \code{TRUE} then at least two counties are spatial neighbors.
#' @param hasIslands Logical, if \code{TRUE} then at least one county has no spatial neighbors.
#' @expor

likeFromMcmc <- function(
	mcmc,
	data,
	constants,
	hasNeighs = TRUE,
	hasIslands = TRUE
) {

	# combine chains
	nchains <- coda::nchain(mcmc)
	niter <- coda::niter(mcmc) * nchains
	combined <- mcmc[[1]]
	if (nchains > 1) {
		for (chain in 2:nchains) {
			combined <- rbind(combined, mcmc[[chain]])
		}
	}

	# counties with neighborhoods (not islands)
	if (hasNeighs) {

		neigh_ll <- matrix(NA, nrow=niter, ncol=length(data$y_neigh))

		# detection and occupancy
		for (iter in 1:niter) {

			# CAR component
			psi_tau <- combined[iter, 'psi_tau', drop=TRUE]
			psi_tau_ll <- dgamma(psi_tau, 0.001, 0.001, log=TRUE)

			psi_car <- combined[iter, grepl(colnames(combined), pattern='psi_car[[]')]
			psi_car_ll <- dcar_normal(psi_car, adj=data$carAdjCounty[1:constants$lengthAdjCounties], weights=data$carWeightCounty[1:constants$lengthAdjCounties], num=data$carNumCounty[1:constants$numNeighs], tau=psi_tau, c=3, zero_mean=0, log=TRUE)

			# detection
			z_neigh <- combined[iter, grepl(colnames(mcmc), pattern='z_neigh[[]'), drop=TRUE]
			p <- combined[iter, grepl(colnames(mcmc), pattern='p[[]'), drop=TRUE]
			q <- combined[iter, 'q', drop=TRUE]

			p_ll <- dbeta(p, 1, 1)
			q_ll <- dbeta(q, 1, 2)

			p_star_neigh <- z_neigh * p[constants$state_neigh] + (1 - z_neigh[g]) * q

			neigh_ll[iter, ] <-
				dbin(data$y_neigh, p_star_neigh, data$N_neigh, log = TRUE) + 			# detection
				p_ll[constants$state_neigh] +									# state effect
				q_ll +															# false detection
				psi_car															# occupancy ~ CAR

		} # next iteration

	} # has neighbors

	# island counties
	if (hasIslands) {

		island_ll <- matrix(NA, nrow=niter, ncol=length(data$y_island))

		# detection and occupancy
		for (iter in 1:niter) {

			# detection
			z_island <- combined[iter, grepl(colnames(mcmc), pattern='z_island[[]'), drop=TRUE]
			p <- combined[iter, grepl(colnames(mcmc), pattern='p[[]'), drop=TRUE]
			q <- combined[iter, 'q', drop=TRUE]

			p_ll <- dbeta(p, 1, 1)
			q_ll <- dbeta(q, 1, 2)

			p_star_island <- z_island[h] * p[constants$state_island[h]] + (1 - z_island[h]) * q

			psi_islandMean <- combined[iter, 'psi_islandMean', drop=TRUE]
			psi_islandSd <- combined[iter, 'psi_islandSd', drop=TRUE]

			psi_islandMean_ll <- dnorm(psi_islandMean, mean=0, sd=1000)
			psi_islandMean_ll <- dgamma(psi_islandSd, 0.001, 0.001)

			island_ll[iter, ] <-
				dbin(data$y_island, p_star_island, data$N_island, log = TRUE) +	# detection
				p_ll[constants$state_island] +									# state effect
				q_ll +															# false detection
				psi_islandMean_ll +												# psi for islands
				psi_islandSd_ll													# psi for islands

		} # next iteration

	} # if has islands

	# return
	if (hasNeighs & !hasIslands) {
		neigh_ll
	} else if (!hasNeighs & hasIslands) {
		island_ll
	} else {
		cbind(neigh_ll, island_ll)
	}

}


#! /usr/bin/env Rscript

if (!require("pacman"))
	install.packages("pacman", repos = "https://cloud.r-project.org/")
pacman::p_load(tidyverse, cowplot, lubridate, scales, wpp2019, RcppRoll)
pdf(NULL)

data = read_csv("csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv")

data = rename(data, Country = "Country/Region", State = "Province/State")

data = filter(data, is.na(State))

data$Country[ data$Country == "United Kingdom" ] <- "UK"

data = select(data, Country, matches("[0-9]+/[0-9]+/[0-9]+"))

data = filter(data, Country %in% commandArgs(trailingOnly=TRUE))

data = pivot_longer(data, cols=matches("[0-9]+/[0-9]+/[0-9]+"), names_to="Date", values_to="Count")

data = mutate(data, Date=mdy(Date))

data = filter(data, Count > 1)

data(pop)
pop$name[ pop$name == "United States of America" ] <- "US"
pop$name[ pop$name == "United Kingdom" ] <- "UK"

p = filter(pop, name %in% commandArgs(trailingOnly=TRUE))
p = select(p, name, "2020")
p = rename(p, Population = "2020")
p = mutate(p, Population = Population * 1000)
data = inner_join(data, p, by=c("Country"="name"))

data = mutate(data, Diff=Count-lag(Count, default=first(Count)),
              Diff14=roll_sum(Diff, 14, align = "right", fill = NA),
              Diff7=roll_sum(Diff, 7, align = "right", fill = NA),
              DiffFract=Diff/Count,
              Diff100K14=Diff14/Population*100000,
              Diff100K7=Diff7/Population*100000)

data = filter(data, Diff > 1)

print(data, n=1000)

f <- function(start, x) 10^(x-start)

p_cnt = ggplot(data, aes(x=Date, y=Count, group=Country, color=Country)) +
	scale_y_log10(limits=c(1, NA), labels=comma_format(accuracy=1)) +
	geom_point() +
	# geom_smooth() +
	labs(y="Cases") +
	theme_minimal_grid() + theme(legend.position="bottom")

p_diff = ggplot(data, aes(x=Date, y=Diff, group=Country, color=Country)) +
	scale_y_continuous(limits=c(-100, NA), labels=comma_format(accuracy=1)) +
	coord_cartesian(ylim=c(0, NA)) +
	geom_point() +
	geom_smooth() +
	labs(y="New cases") +
	theme_minimal_grid() + theme(legend.position="bottom")

p_difffract = ggplot(data, aes(x=Date, y=DiffFract, group=Country, color=Country)) +
	scale_y_continuous(limits=c(-1, NA), labels=comma_format(accuracy=1)) +
	coord_cartesian(ylim=c(0, NA)) +
	geom_point() +
	# geom_smooth() +
	theme_minimal_grid() + theme(legend.position="bottom")

p_diff100k14 = ggplot(data, aes(x=Date, y=Diff100K14, group=Country, color=Country)) +
	scale_y_continuous(limits=c(-1, NA), labels=comma_format(accuracy=1)) +
	coord_cartesian(ylim=c(0, NA)) +
	geom_point() +
	# geom_smooth() +
	labs(y="New cases per 100K in last 14 days") +
	theme_minimal_grid() + theme(legend.position="bottom")

p_diff100k7 = ggplot(data, aes(x=Date, y=Diff100K7, group=Country, color=Country)) +
	scale_y_continuous(limits=c(-1, NA), labels=comma_format(accuracy=1)) +
	coord_cartesian(ylim=c(0, NA)) +
	geom_point() +
	# geom_smooth() +
	labs(y="New cases per 100K in last 7 days") +
	theme_minimal_grid() + theme(legend.position="bottom")

final = plot_grid(p_cnt, p_diff, p_diff100k14, p_diff100k7, nrow=2)

save_plot("corona.pdf", final, base_width=10, base_height=10)


library(survminer)
library(survival)
library(breastCancerNKI)
library(dplyr)

data(nki)

# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC2656909/

nki <- pData(nki) %>%
  rename(
    os_time = t.os,
    os_event = e.os,
    mets_free_time = t.dmfs,
    mets_free_event = e.dmfs,
    estrogen_receptor = er,
    brca_mutation = brca.mutation,
    lymph_node = node) %>%
  select(size, age, estrogen_receptor, grade, brca_mutation, mets_free_time,
         mets_free_event, os_time, os_event, treatment) %>%
  as_tibble()

ggsurvplot(
  survfit(Surv(mets_free_time, mets_free_event) ~ treatment, data = nki),
  data = nki)

nki$response <- nki$mets_free_time >= 2546 & nki$os_time >= 4000

nki <- na.omit(nki)

responses <- c(
  "Surv(mets_free_time, mets_free_event)",
  "Surv(os_time, os_event)",
  "response")

baseline_demo <- c("age", "estrogen_receptor", "brca_mutate")

baseline_tumor <- c("size", "grade")

roles <- list(
  treatment = "treatment",
  demography = baseline_demo,
  baseline_tumor = baseline_tumor,
  responses = responses,
  bunk = "a")

nkia <- add_roles(nki, roles)
nkia <- add_roles(nki, roles[-5])
nkia <- add_roles(nki, list())

roles(nkia)


v1 <- c(2,5,6,3,7)
v2 <- c(15,16,7,3,2,7,5)
match(v1,v2) #returns the position of the elements of Vector V1 in vector v2 which matches

R Community/R functions Assignments/Assignment5.r