# Covariance structure: Compound symmetry
#
# This function generates a covariance matrix with compound symmetry structure.
#
# @param p Dimension.
# @param rho Correlation strength.
# @return A covariance matrix (p by p).
# @export
# @examples
# library(NRRR)
# CorrCS(10, 0.5)
CorrCS <- function(p,rho){
  Sigma <- matrix(nrow=p,ncol=p,rho)
  diag(Sigma) <- 1
  Sigma
}

# Covariance structure: Autoregressive
#
# This function generates a covariance matrix with autoregressive structure.
#
# @param p Dimension.
# @param rho Correlation strength.
# @return A covariance matrix (p by p).
# @export
# @examples
# library(NRRR)
# CorrAR(10, 0.5)
CorrAR <- function(p,rho){
  Sigma <- matrix(nrow=p,ncol=p,NA)
  for(i in 1:p){
    for(j in 1:p){
      Sigma[i,j] <- rho^(abs(i-j))
    }
  }
  Sigma
}

# Compute || Y - XC ||_F^2
#
# This function computes the sum of squared errors
# with given (A,B,U,V) and (X,Y).
#
# @param Y Response matrix with n rows and jy*d columns.
# @param X Design matrix with n rows and jx*p columns.
# @param Ag Matrix U.
# @param Bg Matrix V.
# @param Al Matrix A.
# @param Bl Matrix B.
# @param jx Number of basis functions to expand x(s).
# @param jy Number of basis functions to expand y(t).
# @export
# @return The returned items
#   \item{C}{the NRRR estimator of the coefficient matrix C.}
#   \item{XC}{a matrix, prediction of Y.}
#   \item{E}{a matrix, estimated error matrix.}
#   \item{sse,obj}{ a scaler, the sum of squared errors.}
Obj <- function(Y,X,Ag,Bg,Al,Bl,jx,jy){

  if(nrow(Bg)!=ncol(Bg)){
    Bl <- kronecker(diag(jx),Bg)%*%Bl
  }
  if(nrow(Ag)!=ncol(Ag)){
    Al <- kronecker(diag(jy),Ag)%*%Al
  }
  C <- Bl%*%t(Al)
  XC <- X%*%C
  E <- Y - XC
  sse <- sum(E^2)

  return(list(C=C,XC=XC,E=E,sse=sse,obj=sse))
}

cv.rrr <- function (Y,
                    X,
                    nfold = 10,
                    maxrank = min(dim(Y), dim(X)),
                    norder = NULL,
                    coefSVD = FALSE)
{
  ## record function call
  Call <- match.call()

  p <- ncol(X)
  q <- ncol(Y)
  n <- nrow(Y)

  ndel <- round(n / nfold)
  if (is.null(norder))
    norder <- sample(seq_len(n), n)

  cr_path <- matrix(ncol = nfold, nrow = maxrank + 1, NA)
  for (f in seq_len(nfold)) {
    if (f != nfold) {
      iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
    }
    else {
      iddel <- norder[(1 + ndel * (f - 1)):n]
    }
    ndel <- length(iddel)
    nf <- n - ndel
    idkeep <- (seq_len(n))[-iddel]
    Xf <- X[-iddel,]
    Xfdel <- X[iddel,]
    Yf <- Y[-iddel,]
    Yfdel <- Y[iddel,]
    ini <- rrr.fit(Yf, Xf, nrank = maxrank, coefSVD =  coefSVD)
    C_ls <- ini$coef.ls
    A <- ini$A
    tempFit <- Xfdel %*% C_ls
    tempC <- matrix(nrow = q, ncol = q, 0)
    for (i in seq_len(maxrank)) {
      tempC <- tempC + tcrossprod(A[, i])
      cr_path[i + 1, f] <-
        sum((Yfdel - tempFit %*% tempC) ^ 2)
    }
    cr_path[1, f] <- sum(Yfdel ^ 2)
  }
  index <- order(colSums(cr_path))
  crerr <- rowSums(cr_path[, index]) / length(index) * nfold
  minid <- which.min(crerr)
  rankest <- minid - 1
  ini <- rrr.fit(Y, X, nrank = maxrank)
  C_ls <- ini$coef.ls
  A <- ini$A

  out <- if (identical(rankest, 0)) {
    list(
      call = Call,
      cr.path = cr_path,
      cr.error = crerr,
      norder = norder,
      coef = matrix(0, nrow = p, ncol = q),
      rank = 0,
      coef.ls = C_ls
    )
  }
  else {
    list(
      call = Call,
      cr.path = cr_path,
      cr.error = crerr,
      norder = norder,
      coef.ls = C_ls,
      coef = C_ls %*% tcrossprod(A[, seq_len(rankest)]),
      rank = rankest
    )
  }
  #class(out) <- "cv.rrr"
  out
}

rrr.fit <- function(Y,
                    X,
                    nrank = 1,
                    weight = NULL,
                    coefSVD = FALSE)
{
  Call <- match.call()

  q <- ncol(Y)
  n <- nrow(Y)
  p <- ncol(X)
  stopifnot(n == nrow(X))

  S_yx <- crossprod(Y, X)
  S_xx <- crossprod(X)

  ## FIXME: 0.1 is too arbitrary
  S_xx_inv <- tryCatch(
    MASS::ginv(S_xx),
    error = function(e)
      solve(S_xx + 0.1 * diag(p))
  )

  ## FIXME: if weighted, this needs to be weighted too
  C_ls <- tcrossprod(S_xx_inv, S_yx)

  if (!is.null(weight)) {
    stopifnot(nrow(weight) == q && ncol(weight) == q)
    eigenGm <- eigen(weight)
    ## FIXME: ensure eigen success?
    ## sqrtGm <- tcrossprod(eigenGm$vectors * sqrt(eigenGm$values),
    ##                      eigenGm$vectors)
    ## sqrtinvGm <- tcrossprod(eigenGm$vectors / sqrt(eigenGm$values),
    ##                         eigenGm$vectors)
    sqrtGm <- eigenGm$vectors %*% (sqrt(eigenGm$values) *
                                     t(eigenGm$vectors))
    sqrtinvGm <- eigenGm$vectors %*% (1 / sqrt(eigenGm$values) *
                                        t(eigenGm$vectors))

    XC <- X %*% C_ls %*% sqrtGm
    ## FIXME: SVD may not converge
    ## svdXC <- tryCatch(svd(XC,nu=nrank,nv=nrank),error=function(e)2)
    svdXC <- svd(XC, nrank, nrank)
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
    AA <- tcrossprod(A)
    C_rr <- C_ls %*% sqrtGm %*% AA %*% sqrtinvGm
  } else {
    ## unweighted
    XC <- X %*% C_ls
    svdXC <- svd(XC, nrank, nrank)
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
    AA <- tcrossprod(A)
    C_rr <- C_ls %*% AA
  }

  ret <- list(
    call = Call,
    coef = C_rr,
    coef.ls = C_ls,
    fitted = X %*% C_rr,
    fitted.ls = XC,
    A = A,
    Ad = Ad,
    rank = nrank
  )

  if (coefSVD) {
    coefSVD <- svd(C_rr, nrank, nrank)
    coefSVD$d <- coefSVD$d[1:nrank]
    coefSVD$u <- coefSVD$u[, 1:nrank, drop = FALSE]
    coefSVD$v <- coefSVD$v[, 1:nrank, drop = FALSE]
    ret <- c(ret, list(coefSVD = coefSVD))
  }

  #class(ret) <- "rrr.fit"
  ret
}

rrs.fit <- function(Y,
                    X,
                    nrank = min(ncol(Y), ncol(X)),
                    lambda = 1,
                    coefSVD = FALSE)
{
  Call <- match.call()

  q <- ncol(Y)
  n <- nrow(Y)
  p <- ncol(X)

  S_yx <- t(Y) %*% X
  ## This is a key difference
  S_xx <- t(X) %*% X + lambda * diag(p)

  ## S_xx_inv <- tryCatch(solve(S_xx+0.1*diag(p)),error=function(e)ginv(S_xx))
  ## S_xx_inv <- ginv(S_xx)
  ## Use the Woodbury matrix identity
  if (lambda != 0) {
    S_xx_inv <- 1 / lambda * diag(p) -
      lambda ^ (-2) * t(X) %*% MASS::ginv(diag(n) + lambda ^ (-1) * X %*%
                                            t(X)) %*% X
  } else{
    S_xx_inv <- MASS::ginv(S_xx)
    if (sum(is.na(S_xx_inv)) > 0) {
      S_xx_inv <- solve(S_xx + 0.1 * diag(p))
    }
  }

  C_ls <- S_xx_inv %*% t(S_yx)

  ypy.svd <- TRUE
  ##if(ypy.svd){
  ##This is another key difference
  XC <- rbind(X, sqrt(lambda) * diag(p)) %*% C_ls
  svdXC <- tryCatch(
    svd(XC, nu = nrank, nv = nrank),
    error = function(e)
      2)
  if (tryCatch(
    svdXC == 2,
    error = function(e)
      3) == 3) {
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
  } else{
    ypy.svd <- FALSE
  }
  #}
  if (!ypy.svd) {
    SS <- S_yx %*% C_ls
    SS <- (SS + t(SS)) / 2
    eigenSS <- eigen(SS, symmetric = TRUE)
    A <- as.matrix(eigenSS$vectors[, 1:nrank])
    Ad <- eigenSS$values[1:nrank]
  }

  AA <- A %*% t(A)
  C_rr <- C_ls %*% AA

  ##    if(c.svd){
  ##      svd_C <- svd(C_rr,nv=nrank,nu=nrank)
  ##      U <- as.matrix(svd_C$u[,1:nrank])
  ##      V <- as.matrix(svd_C$v[,1:nrank])
  ##      D <- diag(svd_C$d[1:nrank],nrow=nrank)
  ##
  ##      ####return ls estimator C_ls, reduced-rank estimator C_rr
  ##      ####return SVD of C_rr
  ##      list(A=A,Ad=Ad,C_ls=C_ls,C_rr=C_rr,U=U,V=V,D=D,C=C_rr,rank=nrank)
  ##    }else{
  ##      list(A=A,Ad=Ad,C_ls=C_ls,C_rr=C_rr,C=C_rr,rank=nrank)
  ##    }

  ret <- list(
    call = Call,
    coef = C_rr,
    coef.ls = C_ls,
    fitted = X %*% C_rr,
    fitted.ls = XC,
    A = A,
    Ad = Ad,
    nrank = nrank
  )

  if (coefSVD) {
    coefSVD <- svd(C_rr, nrank, nrank)
    coefSVD$d <- coefSVD$d[1:nrank]
    ret <- c(ret, list(coefSVD = coefSVD))
  }

  #class(ret) <- "rrs.fit"
  ret
}


compositeScore = function(in_list,  score_var = 'Z', se_var = 'z_se'){

n_scores = length(in_list)

n_vars = paste('n',1:n_scores, sep = '')
score_vars = paste(score_var, 1:n_scores, sep='')
se_vars = paste(se_var, 1:n_scores, sep = '')

i=0
for (df in in_list){
  i = i + 1
  df['z_se'] = 1
  names(df)[-1] = paste(names(df)[-1], i, sep='')
  if (i==1){
    out_df=df
  } else {
    out_df = merge(out_df, df, all=TRUE, on='inst')
  }
}
#Number of scores for each institution
#(e.g. some hospitals may be not have data for all quality measures)
n_components = rowSums(!is.na(out_df[n_vars]), na.rm = TRUE)

#Constructing N(0,1) composite score
score_weight_vec = 1/sqrt(n_components)
score_se_vec = 1/n_components

out_df['score'] = rowSums(out_df[score_vars] * score_weight_vec,
                          na.rm=TRUE)

#Compute W-S estimated DF
# Limitations of the Welch-Satterthwaite
# approximation for measurement uncertainty
# calculations
# https://iopscience.iop.org/article/10.1088/0026-1394/37/1/8/
#Equation [1] in Ballico, 2000
DF_num = 1 #By construction (composite sums scores totalling unit variance)
DF_denom = rowSums(score_se_vec^2 * 1/out_df[n_vars], na.rm=TRUE)
out_df['ws'] = DF_num/DF_denom

out_df['total_n'] = rowSums(out_df[n_vars], na.rm = TRUE)
#Regression DF approximation of W-S
out_df['ws_approx'] = out_df$total_n * 0.98

out_df['score_p'] = 1-pt(abs(out_df$score), out_df$ws_approx)
out_df = out_df[order(out_df$inst),]
return(out_df)
}


#!/usr/bin/env Rscript

# eg.1 (柱形图)
v = read.table("res/Billianaires.TXT", sep=",", header=T, na.strings="-")
# 返回类型
mode(v)
typeof(v)
par(mfrow=c(1,2))
hist(v$Age, main="", xlab="Age")
hist(v$Net.Worth, main="", xlab="Net Worth")

# eg.2 (沙箱图)
par(mfrow=c(1,1))
w = v[v[,6]=="United States"|v[,6]=="China"|v[,6]=="Japan",]
w[,6] = as.character(w[,6])
boxplot(Age~Country.of.Citizenship, w)

# eg.3 (散点图)
v = read.table("res/g100.txt", sep=",", header=T)
plot(v$Assets, v$Sales,
     pch=1, col=1,
     xlab="Assets(Billion $)",
     ylab="Sales(Billion $)",
     ylim=c(0, 600),
     xlim=c(-100, 3000),
     cex=log(v$Profits))
title("Global 100 Companys' Assets, Sales and log Profits(size of points)")
identify(v$Assets, v$Sales, labels=v$Company)

# eg.4 (饼图), 前10行
# table: 计算频数
w = read.table("res/global2000.TXT", sep=",", header=T)
ws = sort(table(w$Country), de=T)
pie(ws[1:10])
title("Number of Companies Among top 10")

# eg.5 (条形图), 前10行
# cex: character extension (设置字体大小等)
barplot(ws[1:10], cex.names=.8, main="Number of Companies Among top 10")


#' Lambda
#'
#' Seasonal model for the intensity function, \eqn{\lambda(t) = a + b + b \sin(c\,2 \pi/365 + x 2 \,\pi / 365)}.
#'
#' @param x \code{numeric} vector of time points.
#' @param params \code{numeric} vector of parameters of length = 4.
#' @param  names A vector. Can be used to label
#' @return a \code{numeric} vector of the same length as \code{x}.
#' @examples
#' lambda(c(1,2,3,4,5,6), c(1,1,1,1) )
lambda<-function(x, params, names=F){
  p1<-params[1]
  p2<-params[2]
  p3<-params[3]
  p4<-params[4]
   # period = 365 # (days)
  period = 52 # (weeks)

  ret = p1 + p2 + (p2 + p4 * x)* sin(2 * pi / period * p3 + x * 2 * pi / period) + p4* x

  if(names){
    ret = c(0, ret)
    names(ret) = c('NA', 0:(length(ret)-2))
    return(ret)
  }else{
    return(ret)
  }
}

#' Negative log-likelihood
#'
#' \eqn{l(\lambda) = \log L(\lambda) = - \int_0^T\lambda(x) dx + \sum_{i=1}^n\log \lambda(x_i)}
#'
#' @param params A \code{numeric} vector of parameters of length = 4.
#' @param data A \code{numeric} vector of event times.
#' @return \code{numeric}.
#' @examples
#' neg.log.like(c(1,1,1,1),c(1,2,3,4,5,6))
neg.log.like<-function(params, data){
  lower<-min(data)
  upper<-max(data)
  integrate(lambda,lower,upper,params,subdivisions = 5000)$value - sum(log(lambda(data,params)))
}

#' Optimize function \code{neg.log.like} conditioned on having the last parameter fixed.
#'
#' @param data A \code{numeric} vector of event times.
#' @param cpar A \code{numeric}.
#' @param iteration This is the maximum number of interations allowed for the function \code{optimx}.
#' @return 2D 4x2 matrix.
#' @importFrom optimx optimx
#' @examples
#' cmle1(data, 1, iterations=20)
cmle1<-function(data, cpar, iterations=10000){
  fn<-function(par){
    if (all(par>c(0,2,0)) & all(par<c(100, 100, 60)) ){
      res = neg.log.like(c(par, cpar), data)
    }
    else{
      res = Inf
    }
    return(res)
  }
  n = 10
  start<-data.frame(p1=runif(n,0, 100), p2=runif(n, 2, 100), p3=runif(n, 1, 60))
  opt<-function(init){
    res<-optimx(as.vector(init),
                fn,
                method='Nelder-Mead',
                control=list(maxit=iterations, dowarn=FALSE)) # all.methods=TRUE
    # if (res$convcode != 0){
    #   cat("optimisation did not converge with code:", res$convergence, "\n")
    # }
    return(c(res$value, res$convcode, unlist(res[,1:3])))
  }
  res = apply(start, 1, opt)
  id = which.min(res[1,])
  return(res[3:5, id])
}

#' Optimize function \code{neg.log.like} conditioned on having the first three parameters fixed.
#'
#' @param data A \code{numeric} vector of event times.
#' @param cpar \code{numeric}.
#' @return \code{numeric}.
#' @examples
#' cmle2(data, c(1,1,1))
cmle2<-function(data, cpar){
  fn<-function(par){
    res = neg.log.like(c(cpar, par), data)
  }
  # else if ((par[4] < -0.1) | (par[4] > 0.1)){
  #   res = 1000000 * par[4] ^ 2
  # }
  res = optimize(fn, interval = c(0,10), tol = 0.00001)
  return(res$minimum)
}

#' Estimate the parameters for the seasonal model given the aggregated vector of event times.
#'
#' Optimize the function \code{neg.log.like} recursively calling \code{clme1} and \code{cmle2}.
#'
#' @param data A \code{numeric} vector of event times.
#' @param n.cycles \code{integer}. Number of times the conditional optimizers are called.#
#' @param start \code{numeric}. Starting parameters (not yet implemented).
#' @param save.on.dir \code{logical}. If TRUE, will save the inferred parameter in `timefactor_parameters.RData`.
#' @return \code{numeric}. A 2D 2x4 matrix with the estimated parameters.
#' @examples
#' cmle(data)
cmle<-function(data, n.cycles=10, start=NULL, save.on.dir=TRUE){
  par = cmle1(data, 0)
  trace = matrix(data=0, nrow = n.cycles, ncol = 4)
  for (i in 1:n.cycles){
    cat("Estimating parameters for temporal trend, step ", i, " of ", n.cycles, ".\r")
    trace[i,1:3] = par
    par1 = cmle2(data, par)
    trace[i,4] = par1
    par = cmle1(data, par1)
  }
  par1 = cmle2(data, par)
  Parameters = c(par, par1)
  trace[i,] = Parameters
  attributes(Parameters) = list(trace=trace)
  if(save.on.dir){
    save.and.tell('Parameters', file=file.path(getwd(), paste0('timefactor_parameters.RData')))
  }
  return(Parameters)
}

#' Lambda
#'
#' Seasonal model for the intensity function, \eqn{\lambda(t) = a + b + b \sin(c\,2 \pi/365 + x 2 \,\pi / 365)}.
#'
#' @inheritParams lambda
#' @return a \code{numeric} vector of the same length as \code{x}.
#' @examples
#' predict.cmle(c(1,2,3,4,5,6), c(1,1,1,1) )
predict.cmle<-lambda

predict.cmle.ci<-function(x, parameters){
  data.frame(upper=qpois(0.975,lambda(x,parameters)),
             lower=qpois(0.025,lambda(x,parameters)))
}

expand.histogram<-function(histo){
  Histo = data.frame(Names = as.integer(names(histo)), freq = unlist(histo))
  return(unlist(do.call(c, apply(Histo, 1, function(x){rep(x[1], x[2]) }) )))
}

Loess<-function(counts, span = 0.2){
  df = data.frame(time = 1:length(counts), counts = counts)
  loess(counts ~ time, df, span=span)
}

predict.Loess<-function(x, fit){
  df = data.frame(time = x)
  predict(fit, df)
}

predict.Loess.ci<-function(x, fit){
  df = data.frame(time = x)
  data.frame(upper= unlist(-predict(fit, df, se = T)[['se.fit']] + predict(fit, df, se = T)[['fit']]),
             lower= unlist(predict(fit, df, se = T)[['se.fit']] + predict(fit, df, se = T)[['fit']]))
}


library(MASS)

a_white <- 11
a_black <- 10
b_white <- 9
b_black <- 18

# a_white <- 19
# a_black <- 18
# b_white <- 17
# b_black <- 17

# a_white <- 12
# a_black <- 8
# b_white <- 10
# b_black <- 14

a <- a_white + a_black
b <- b_white + b_black

primadomanda <- ((b_white+1)/(b+1) * a_white/a) + ((b_white/(b+1)) * (a_black/a))
secondadomanda <- ((b_white+1)/(b+1) * a_white/a) / primadomanda

print(fractions(primadomanda))
print(fractions(secondadomanda))


library('nonpar')
library('DescTools')

#MC-EffNet-2 with best baseline
method_a_ss_baseline <- matrix(c(670, 101, 111, 55, 503, 123, 109, 145, 583), 3,3)
method_b_ss_baseline <- as.table(matrix(c(670, 101, 111, 55, 503, 123, 109, 145, 583), nrow=3))
stuart.maxwell(method_a_ss_baseline)
StuartMaxwellTest(method_b_ss_baseline)


infile   = {{i.infile    | quote}}
outfile  = {{o.outfile  | quote}}
obsvfile = {{o.obsvfile | quote}}
exptfile = {{o.exptfile | quote}}

{% if args.intype == 'cont' %}

#
#         | Disease | Healthy |
# --------+---------+---------+
#   mut   |   40    |   12    |
# non-mut |   23    |   98    |
# --------+---------+---------+
#
cont.table = read.table(infile, sep = "\t", header = T, row.names = 1, check.names = F)

{% else %}

#
# Contingency table rows: Mut, Non
# Contingency table cols: Disease, Healthy
#
#         | S1 | S2 | ... | Sn |
# --------+----+----+-----+----+
# Disease | 1  | 0  | ... | 1  |
# Healthy | 0  | 1  | ... | 0  |
# --------+----+----+-----+----+
# Mut     | 1  | 0  | ... | 1  |
# Non     | 0  | 1  | ... | 0  |
#
ct.cnames = c()
ct.rnames = c()
{% if isinstance(args.ctcols, list) %}
ct.cnames = {{args.ctcols}}
{% elif args.ctcols %}
ct.cnames = {{args.ctcols | lambda x: [y.strip() for y in x.split(',') if y.strip()]}}
{% else %}
trim  = Vectorize(function (x) gsub("^\\s+|\\s+$", "", x))
lines = readLines(infile, n = 2)
for (line in lines) {
	if (!startsWith(line, '# Contingency table ')) next
	if (startsWith(line, '# Contingency table cols:')) {
		ct.cnames = trim(unlist(strsplit(substring(line, 26), ',', fixed = T)))
	}
	else if (startsWith(line, '# Contingency table rows:')) {
		ct.rnames = trim(unlist(strsplit(substring(line, 26), ',', fixed = T)))
	}
}
{% endif %}

raw.data   = read.table(infile, sep = "\t", header = T, row.names = 1, check.names = F)
# generate contingency table
if (length(ct.rnames) == 0 && length(ct.cnames) == 0) {
	stop('No row names and col names specified for contingency table.')
}
if (length(ct.rnames) == 0) {
	ct.rnames = setdiff(rownames(raw.data), ct.cnames)
}
if (length(ct.cnames) == 0) {
	ct.cnames = setdiff(rownames(raw.data), ct.rnames)
}

# transposed cont.table
cont.table = matrix(NA, ncol = length(ct.cnames), nrow = length(ct.rnames))
colnames(cont.table) = ct.cnames
rownames(cont.table) = ct.rnames
# get the number of each contingency cell
for (rname in ct.rnames) {
	for (cname in ct.cnames) {
		tmp1 = raw.data[rname, ] == 1
		tmp2 = raw.data[cname, ] == 1
		tmp  = tmp1 & tmp2
		cont.table[rname, cname] = length(tmp[tmp])
	}
}
{% endif %}

# further parameters may be introduced, but for now just use defaults
ret = chisq.test(cont.table)
out = data.frame(Xsquare = ret$statistic, df = ret$parameter, pval = ret$p.value, method = ret$method)

#
# Xsquare 1.706667
# df  1
# pval    0.1914184
# method  Pearson's Chi-squared test with Yates' continuity correction
#
write.table(t(out), outfile, col.names = F, sep = "\t", quote = F)
write.table(ret$observed, obsvfile, sep = "\t", quote = F)
write.table(ret$expected, exptfile, sep = "\t", quote = F)


setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
df    <- read.table("../data/workshops.csv", h = T, sep = ";")
x <- df$Instructor.s.pacing.within.allotted.time
x_tgt <- x[df$ID == 6]
x_ref <- x[df$ID != 6]

mean(x_tgt)
mean(x_ref)

#### t-test and CI -------------------------------------------------------------
t.test(x_tgt, x_ref)

#### bootstrap -----------------------------------------------------------------
m <- 1000

set.seed(1)
mus <- c()
for (i in 1:m) {
  y1 <- sample(x_tgt, length(x_tgt), rep = T)
  y2 <- sample(x_ref, length(x_ref), rep = T)
  mus <- c(mus, mean(y1) - mean(y2))
}

head(mus)
quantile(mus, p = c(0.025, 0.975))


df <- mtcars

df$vs <-  factor(df$vs, labels = c("V","S"))
df$am <- factor(df$am, labels = c("Auto", "Manual"))

hist(df$mpg)
hist(df$mpg, breaks = 20, xlab = "MPG")

boxplot(mpg ~ am, df, ylab = " MPG")

plot(df$mpg, df$hp)
plot(df$mpg, df$am)

library(ggplot2)

ggplot(df, aes(x = mpg))+
  geom_histogram(fill = "white", col = "black", binwidth = 2)

ggplot(df, aes(x = mpg, fill = am))+
  geom_dotplot(binwidth = 3)

ggplot(df, aes(x = mpg, fill=am))+
  geom_density(alpha(0.1))

ggplot(df, aes(x = am,y=hp, col= vs))+geom_boxplot()

my_plot <- ggplot(df, aes(x=mpg,y=hp,col=vs, size = qsec))+geom_point()

my_plot2 <- ggplot(df, aes(x = am,y=hp, col= vs))
my_plot2 + geom_point()

# trouble №1
boxplot(airquality$Ozone ~ airquality$Month, airquality, breaks = 5)

# trouble №2
plot1 <- ggplot(mtcars, aes(x=mpg,y=disp,col=hp))+geom_point()

# last trouble today
ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) +
  geom_point(aes(size = Petal.Length))

#save any result
df <- mtcars

getwd()
setwd(getwd())


# Example : 1   Chapter : 10.1     Page No: 496
# r of complex numbers
rad2deg <- function(rad) {
  (rad * 180) / (pi)
}
z<-complex(real=1,imaginary=1)
z1<-Conj(z)
print("r of z and its conjugate are")
print(Mod(z))
print(Mod(z1))
print("The argument of z and its conjugate in degrees are")
print(paste(rad2deg(Arg(z)),"degrees")) # in radians which is equal to 45 degree
print(paste(rad2deg(Arg(z1)),"degrees"))


library(readr)

complexity_measures_sarah <- read_csv('data/measures_csv/sarah_measures_child_adult.csv')
complexity_measures_adam <- read_csv('data/measures_csv/adam_measures_child_adult.csv')

# sarah child
mwt_chi <- lm(MWT_CHI ~ ages, data=complexity_measures_sarah)
summary(mwt_chi)
mct_chi <- lm(MCT_CHI ~ ages, data=complexity_measures_sarah)
summary(mct_chi)
mtl_chi <- lm(MTL_CHI ~ ages, data=complexity_measures_sarah)
summary(mtl_chi)
muw_chi <- lm(MUW_CHI ~ ages, data=complexity_measures_sarah)
summary(muw_chi)
mwl_chi <- lm(MWL_CHI ~ ages, data=complexity_measures_sarah)
summary(mwl_chi)
mul_chi <- lm(MUL_CHI ~ ages, data=complexity_measures_sarah)
summary(mul_chi)

# sarah adult
mwt_adt <- lm(MWT_ADT ~ ages, data=complexity_measures_sarah)
summary(mwt_adt)
mct_adt <- lm(MCT_ADT ~ ages, data=complexity_measures_sarah)
summary(mct_adt)
mtl_adt <- lm(MTL_ADT ~ ages, data=complexity_measures_sarah)
summary(mtl_adt)
muw_adt <- lm(MUW_ADT ~ ages, data=complexity_measures_sarah)
summary(muw_adt)
mwl_adt <- lm(MWL_ADT ~ ages, data=complexity_measures_sarah)
summary(mwl_adt)
mul_adt <- lm(MUL_ADT ~ ages, data=complexity_measures_sarah)
summary(mul_adt)

# adam child
mwt_chi <- lm(MWT_CHI ~ ages, data=complexity_measures_adam)
summary(mwt_chi)
mct_chi <- lm(MCT_CHI ~ ages, data=complexity_measures_adam)
summary(mct_chi)
mtl_chi <- lm(MTL_CHI ~ ages, data=complexity_measures_adam)
summary(mtl_chi)
muw_chi <- lm(MUW_CHI ~ ages, data=complexity_measures_adam)
summary(muw_chi)
mwl_chi <- lm(MWL_CHI ~ ages, data=complexity_measures_adam)
summary(mwl_chi)
mul_chi <- lm(MUL_CHI ~ ages, data=complexity_measures_adam)
summary(mul_chi)

# adam adult
mwt_adt <- lm(MWT_ADT ~ ages, data=complexity_measures_adam)
summary(mwt_adt)
mct_adt <- lm(MCT_ADT ~ ages, data=complexity_measures_adam)
summary(mct_adt)
mtl_adt <- lm(MTL_ADT ~ ages, data=complexity_measures_adam)
summary(mtl_adt)
muw_adt <- lm(MUW_ADT ~ ages, data=complexity_measures_adam)
summary(muw_adt)
mwl_adt <- lm(MWL_ADT ~ ages, data=complexity_measures_adam)
summary(mwl_adt)
mul_adt <- lm(MUL_ADT ~ ages, data=complexity_measures_adam)
summary(mul_adt)


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

StocSIRS <- function(y, pars, T, steps) {

	out <- matrix(NA, nrow = (T+1), ncol = 4)

	R0 <- pars[['R0']]
	r <- pars[['r']]
	N <- pars[['N']]
	eta <- pars[['eta']]
	berr <- pars[['berr']]
    re <- pars[['re']]

	S <- y[['S']]
	I <- y[['I']]
	R <- y[['R']]

	B0 <- R0 * r / N
	B <- B0

	out[1,] <- c(S,I,R,B)

	h <- 1 / steps

	for ( i in 1:(T*steps) ) {

        #Bfac <- 1/2 - cos((2*pi/365)*i)/2
        Bfac <- exp(2*cos((2*pi/365)*i) - 2)

		B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

		BSI <- Bfac*B*S*I
		rI <- r*I
        reR <- re*R

		dS <- -BSI + reR
		dI <- BSI - rI
		dR <- rI - reR

		S <- S + h*dS  #newInf
		I <- I + h*dI  #newInf - h*dR
		R <- R + h*dR  #h*dR

		if (i %% steps == 0)
			out[i/steps+1,] <- c(S,I,R,B)

	}

	colnames(out) <- c("S","I","R","B")
	return(out)

}

### suggested parameters
#
# T 		<- 200
# i_infec 	<- 10
# steps 	<- 7
# N 		<- 500
# sigma 	<- 5
#
# pars <- c(R0 = 3.0, 	# new infected people per infected person
#           r = 0.1, 	# recovery rate
#		    N = 500,    # population size
#		    eta = 0.5, 	# geometric random walk
#		    berr = 0.5, # Beta geometric walk noise
#           re = 1)  	# resuceptibility rate


library(graph)
library(Rgraphviz)
library(plyr)

data0 <- data.frame(
	x=c("a","a","a","a","b","b","b","b"),
	y=c("t","t","u","u","t","t","u","u"),
	z=c("c","d","c","d","c","d","c","d"))

edges0 <- list(x=list(edges=2),y=list(edges=3),z=list())
g0 <- graphNEL(nodes=names(data0),edgeL=edges0,edgemod="directed")
plot(g0)

data1 <- read.csv("http://archive.ics.uci.edu/ml/machine-learning-databases/nursery/nursery.data", col.names=c("parents","has_nurs","form","children","housing","finance","social","health","class"))
edges1 <- list( parents=list(), has_nurs=list(), form=list(), children=list(),
	     housing=list(), finance=list(), social=list(), health=list(),
	     class=list(edges=1:8) )
g1 <- graphNEL(nodes=names(data1), edgeL=edges1,edgemod="directed")
plot(g1)

make_cpt<-function(df,pa)
{
	prob <- nrow(df)
	parents <- data.frame(df[1,pa])
	names(parents) <- pa

	data.frame(parents,prob)
}

learn <- function(g,data)
{
	rg <- reverseEdgeDirections(g)
	result <- list()

	for(var in rg@nodes)
	{
		pa <- unlist(adj(rg,var))
		if(length(pa)>0)
		{
			X <- ddply(data, c(var,pa), make_cpt, pa)
			Y <- ddply(data, pa, make_cpt, pa)
			for(i in 1:nrow(Y))
			{
				c <- sapply(1:nrow(X), function(j) all(X[j,pa] == Y[i,pa]))
				c <- which(c)
				X$prob[c] <- X$prob[c]/Y$prob[i]
			}
		}
		else
		{
			X <- ddply(data,var, function(df) c(prob=nrow(df)))
			X$prob <- X$prob/sum(X$prob)
		}

		result[[length(result)+1]] <- X
	}

	return(result)
}


intToLogicalBits <- function(intx) as.logical(intToBits(intx))
logicalBitsToInt <- function(lb) as.integer(sum((2^(0:31))[lb]))
"%AND%" <- function(x, y)
{
   logicalBitsToInt(intToLogicalBits(x) & intToLogicalBits(y))
}
"%OR%" <- function(x, y)
{
   logicalBitsToInt(intToLogicalBits(x) | intToLogicalBits(y))
}

35 %AND% 42    # 34
35 %OR% 42     # 42


# vectorized approach based on scalar code from primeSieve and mersenne in CRAN package `numbers`
require(gmp)
n <- 4423  # note that the sieve below assumes n > 9

# sieve the set of primes up to n
p <- seq(1, n, by = 2)
q <- length(p)
p[1] <- 2
for (k in seq(3, sqrt(n), by = 2))
  if (p[(k + 1)/2] != 0)
    p[seq((k * k + 1)/2, q, by = k)] <- 0
p <- p[p > 0]
cat(p[1]," special case M2 == 3\n")
p <- p[-1]

z2 <- gmp::as.bigz(2)
z4 <- z2 * z2
zp <- gmp::as.bigz(p)
zmp <- z2^zp - 1
S <- rep(z4, length(p))

for (i in 1:(p[length(p)] - 2)){
  S <- gmp::mod.bigz(S * S - z2, zmp)
  if( i+2 == p[1] ){
    if( S[1] == 0 ){
      cat( p[1], "\n")
      flush.console()
    }
    p <-  p[-1]
    zmp <- zmp[-1]
    S <-  S[-1]
  }
}


# Group members (Name, Student ID, E-Mail):
# 1. Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# 2. Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# 3. Shinho Kang, 2890169, wis.shinho.kang@gmail.com

data(iris)

# shuffle the dataset and get training and test dataset
shuffled.iris <- iris[sample(1:nrow(iris)), ]
test.ds <- shuffled.iris[1:30,]
training.ds <- shuffled.iris[31:150,]

png(filename="task3.png")
par(mfrow=c(4, 3))

labels = names(iris)[-5]
indexes = c(1:4)
for (x in indexes) {
    for (y in indexes) {
        if (x != y) {

            a = training.ds[,x]
            b = training.ds[,y]

            plot(a~b,
                 pch = 22,
                 bg = c('red', 'green', 'blue')[unclass(iris$Species)],
                 xlab = labels[x],
                 ylab = labels[y]
                 # xlim = c(0,7),
                 # ylim = c(0,7)
                 )
            model = lm(a~b)
            abline(model, col='brown')
        }
    }
}
dev.off()

# Because each of the plots show a correlation between the columns we can
# conclude that one of the predictors can be expressed as a linear combination
# of the others.


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     02.07.2017
#modificado: 11.02.2019

library("GA")

#Define data
n <- c("pocketknife","beans","potatoes","unions","sleepingbag","rope","compass")                # Items
p <- c(10,20,15,2,30,10,30) # Profits
w <- c(1,5,10,1,7,5,1)      # Weights
W <- 20                     # Knapsack ’s capacity

#Define fitness function
knapsack <- function(x){
    if(sum(x*w) > W)
	    return(0)
    else
		return(sum(x*p))
}

# Run SGA
SGA <- ga(type="binary",
  fitness=knapsack,         #fitness function
  nBits=length(n),          #chromosome length
  popSize=100,              #population size
  pcrossover=0.8,           #crossover rate
  pmutation=0.1,            #mutation rate
  elitism=5,                #number of best individuals sure to be selected
  maxiter=100,              #number of generations
  names=n,                  #name of "genes"
  seed=12345)               #random seed

res <- SGA@solution
print(res)                  #Best solution
sum(res)                    #Total number of selected items
sum(res*p)                  #Total profit of selected items
sum(res*w)                  #Total weight of selected items

#Plot model
plot(SGA@summary[,"mean"],type="l",ylab="mean fitness",xlab="iteration",
  col="blue",lty=1,lwd=2)
barplot(SGA@fitness,ylab="fitness",xlab="",col="blue")


################################################################################
# The contents of this file are Teradata Public Content
# and have been released to the Public Domain.
# Licensed under BSD; see "license.txt" file for more information.
# Copyright (c) 2021 by Teradata
################################################################################
#
# R And Python Analytics with SCRIPT Table Operator
# Orange Book supplementary material
# Alexander Kolovos - October 2021 - v.2.1
#
# Example 2: Clustering - (R version)
# File     : ex2r.r
#
# Use case:
# Based on Pycluster Workshop example in "Data Analysis with Open Source Tools"
# by Philipp K. Janert. Copyright 2011 Philipp K. Janert, 978-0-596-80235-6
# Identify a user-specified number of clusters in given data set of points at
# given locations. Classify each observation of the data set into a cluster,
# on the basis of the observation coordinates.
#
# Script accounts for the general scenario that an AMP might have no data.
#
# Requires cluster package.
#
# Required Input:
# - ex2tbl table data from file "ex2data.csv". Contains the variables:
#   ObsID     : The unique ID of each observation
#   X_Coord   : The x coordinate of the observation
#   Y_Coord   : The y coordinate of the observation
#   ObsGroup  : Integer that identifies which group the obs belongs to
#
# Input Parameter:
# n         : The number of clusters we want to create (default: n=5)
#
# Output:
# - X_Centroid: The cluster centroid x coordinate
# - Y_Centroid: The cluster centroid y coordinate
# - isil      : Silhouette coef for each obs (in [-1,1]). Clustering good if =0
# - silhCoef  : Average silhouette coefficient for data set
#
# Note: In the presence of multiple groups of data in the same data set,
#       meaningful cluster analysis on Teradata with the present script can be
#       performed only by operating on same-group observations.
#       For efficient analysis, ensure that each instance of the present script
#       operates on a single data partition.
#
################################################################################

# Load dependency package
# We use the suppressPackageStartupMessages() function to prevent unwanted
# output that may interfere with the output expected by the database.
suppressPackageStartupMessages(library(cluster))
args = commandArgs(trailingOnly=TRUE)

# The present script expects the number of clusters as an input argument.
# If no argument is specified, then use a default number of 5 clusters.
if (length(args) == 0) {
  n = 5
} else if (length(args) >= 1) {
  n = args[1]
}

DELIMITER <- '\t'
stdin <- file(description="stdin",open="r")

inputDF <- data.frame();

# Need to know the type of input columns. Cite them in following vector to feed
# the colClasses argument of the read.table() function.
cv <- c("numeric","numeric","numeric","numeric")
inputDF <- try(read.table(stdin, sep=DELIMITER, flush=TRUE, header=FALSE,
                          quote="", na.strings="", colClasses=cv), silent=TRUE)

close(stdin)

# For AMPs that receive no data, choose to simply quit the script immediately.
if (class(inputDF) == "try-error") {
  inputDF <- NULL
  quit()
}

nObs <- nrow(inputDF)
obsID <- inputDF[,1]
XY_Coords <- inputDF[,2:3]
obsGroup <- inputDF[,4]

# Perform clustering and find centroids
#     predClus is the predicted cluster each observation is assigned to
#     centers are the centroid coordinates for each of the n clusters
kmeansObj <- kmeans(XY_Coords, n, iter.max = 50)
predClus <- kmeansObj$cluster
centers <- kmeansObj$centers
obsCenterX <- numeric(nObs)
obsCenterY <- numeric(nObs)
for (i in 1:nObs) {
  obsCenterX[i] <- centers[predClus[i], 1]
  obsCenterY[i] <- centers[predClus[i], 2]
}

# Assess the clustering quality
#    silhCoeff is the silhouette coefficient for each observation
#    silhScore is the average score for all observations
silhCoeff <- silhouette(predClus, dist(XY_Coords))
silhScore <- mean(silhCoeff[, 3])

# Print output: Current obsID, cluster it belongs to, coordinates of its cluster
# center, silhouette coefficient. Build export data frame:
output <- data.frame(obsID, obsGroup, predClus, obsCenterX, obsCenterY,
                     list(rep(n, nObs)), silhCoeff[, 3],
                     list(rep(silhScore, nObs)))

# Export results to the SQL Engine database through standard output
write.table(output, file=stdout(), col.names=FALSE, row.names=FALSE,
            quote=FALSE, sep=DELIMITER, na="")


##### Chapter 8: Association Rules -------------------

## Example: Identifying Frequently-Purchased Groceries ----
## Step 2: Exploring and preparing the data ----

# load the grocery data into a sparse matrix
library(arules)
groceries <- read.transactions("groceries.csv", sep = ",")
summary(groceries)

# look at the first five transactions
inspect(groceries[1:5])

# examine the frequency of items
itemFrequency(groceries[, 1:3])

# plot the frequency of items
itemFrequencyPlot(groceries, support = 0.1)
itemFrequencyPlot(groceries, topN = 20)

# a visualization of the sparse matrix for the first five transactions
image(groceries[1:5])

# visualization of a random sample of 100 transactions
image(sample(groceries, 100))

## Step 3: Training a model on the data ----
library(arules)

# default settings result in zero rules learned
apriori(groceries)

# set better support and confidence levels to learn more rules
groceryrules <- apriori(groceries, parameter = list(support =
                          0.006, confidence = 0.25, minlen = 2))
groceryrules

## Step 4: Evaluating model performance ----
# summary of grocery association rules
summary(groceryrules)

# look at the first three rules
inspect(groceryrules[1:3])

## Step 5: Improving model performance ----

# sorting grocery rules by lift
inspect(sort(groceryrules, by = "lift")[1:5])

# finding subsets of rules containing any berry items
berryrules <- subset(groceryrules, items %in% "berries")
inspect(berryrules)

# writing the rules to a CSV file
write(groceryrules, file = "groceryrules.csv",
      sep = ",", quote = TRUE, row.names = FALSE)

# converting the rule set to a data frame
groceryrules_df <- as(groceryrules, "data.frame")
str(groceryrules_df)


# plot(anaughts, numDeriv::grad(c_a0, anaughts), type = "l")
# post.dens <- function(p, n, y, cc, dd, a_0){
#   exp(
#     a_0 * dbinom(x = y, size = n, prob = p, log = TRUE) + dbeta(p, cc, dd, log = TRUE)
#   )
# }
# post.dens <- Vectorize(post.dens)
#
# expec_ll <- function(y, N, cc, dd, a_0){
#   integrate(
#     function(p) post.dens(p, n = N, y = y, cc = cc, dd = dd, a_0 = a_0) * dbinom(x = y, size = N, prob = p, log = TRUE),
#     0, 1
#   )$value
# }
#
# e_c0 <- function(x) exp(c_a0(x))
# expec_ll(y = y, N = N, cc = cc, dd = dd, a_0 = .5)
# numDeriv::grad(e_c0, .5)


#Chapter 3
# Install the yarrr package
install.packages('yarrr')

# Load the package
library(yarrr)

# What is the mean age?
mean(pirates$age)

# What was the tallest pirate?
max(pirates$height)

# How many pirates are there of each sex?
table(pirates$sex)

# Calculate the mean age, separately for each sex
aggregate(formula = age ~ sex,
          data = pirates,
          FUN = mean)

# Create scatterplot Beginner
plot(x = pirates$height,        # X coordinates
     y = pirates$weight)        # y-coordinates

# Create scatterplot Intermediate
plot(x = pirates$height,        # X coordinates
     y = pirates$weight,        # y-coordinates
     main = 'My first scatterplot of pirate data!',
     xlab = 'Height (in cm)',   # x-axis label
     ylab = 'Weight (in kg)',   # y-axis label
     pch = 16,                  # Filled circles
     col = gray(.0, .1))        # Transparent gray

# Create scatterplot Advanced
plot(x = pirates$height,        # X coordinates
     y = pirates$weight,        # y-coordinates
     main = 'My first scatterplot of pirate data!',
     xlab = 'Height (in cm)',   # x-axis label
     ylab = 'Weight (in kg)',   # y-axis label
     pch = 16,                  # Filled circles
     col = gray(.0, .1))        # Transparent gray

grid()        # Add gridlines

# Create a linear regression model
model <- lm(formula = weight ~ height,
            data = pirates)

abline(model, col = 'blue')      # Add regression to plot

#------------------------------------------------------------------Hypothesis tests
# Age by headband t-test
t.test(formula = age ~ headband,
       data = pirates,
       alternative = 'two.sided')
cor.test(formula = ~ height + weight,
         data = pirates)

# Create tattoos model
tat.sword.lm <- lm(formula = tattoos ~ sword.type,
                   data = pirates)

# Get ANOVA table
anova(tat.sword.lm)

# Create a linear regression model: DV = tchests, IV = age, weight, tattoos
tchests.model <- lm(formula = tchests ~ age + weight + tattoos,
                    data = pirates)

# Show summary statistics
summary(tchests.model)


> max.subseq(c(-1, -2, 3, 5, 6, -2, -1, 4, -4, 2, -1))
[1]  3  5  6 -2 -1  4


library(ggplot2)

mpg <- read.csv("mpg.csv", stringsAsFactors = FALSE)

sentra <-
sentra$trans <- factor(sentra$trans)

qplot(year, cty, data=sentra)

qplot(year, cty, data=subset(mpg, manufacturer == "toyota"), colour=displ, group=interaction(model, trans,displ), geom=c("jitter","line"), facets = . ~ class)

mpgm <- melt(mpg, id = c("class","manufacturer", "model", "fl", "displ", "trans", "cyl", "year"), measure = c("cty", "hwy"))

cast(mpgm, class + year ~ variable, mean)

qplot(year, hwy, data=cast(mpgm, class + year ~ variable, mean), group=class, geom="line", colour=reorder(factor(class), hwy))

ggplot(mpg, aes(displ, hwy)) + geom_point()
ggplot(mpg, aes(displ, hwy)) + geom_point(colour = alpha("black", 1/10))
ggplot(mpg, aes(displ, hwy)) + geom_jitter(colour = alpha("black", 1/10))
ggplot(mpg, aes(displ, hwy)) + geom_jitter(colour = alpha("black", 1/50))

ggplot(mpg, aes(1 / displ, hwy)) + geom_point()

ggplot(mpg, aes(displ, hwy)) + geom_point() + xlim()
ggplot(mpg, aes(displ, hwy)) + geom_point(colour = alpha)

mpgt <- cast(mpgm, ... ~ trans, mean)


subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror)

# The Lee-Schacter test for the LOP (all points are real,
# i.e. non-ideal).  If the LOP is ***not*** satisfied (i.e. if
# vertex j is inside the circumcircle of vertices h, i, and k) then the
# diagonals should be swapped, i.e. shdswp ("should-swap") is true.
# Called by qtest.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot)
integer h
logical shdswp

# The vertices of the quadrilateral are labelled
# h, i, j, k in the anticlockwise direction, h
# being the point of central interest.

# Make sure the quadrilateral is convex, so that
# it makes sense to swap the diagonal.
# call acchk(i,j,k,shdswp,x,y,ntot,eps)
# if(!shdswp) return
#
# 23 July 2011:
# The foregoing test is a load of dingos' kidneys.  (1) It is
# unnecessary, and (2) it is wrong!  (1) If the LOP is not satisfied
# (the only circumstance under which there should be a swap) then the
# quadrilateral ***must*** be convex, and so swapping can sensibly
# take place.  (2) The vertices i, j, k in will ***always*** be in
# anticlockwise order, since the vertices h, i, j, k of the quadrilateral
# are in such order and i is connected to k, whence j can't be inside
# the triangle ihk.  So the test does nothing.  But then it didn't need
# to do anything.

# Get the coordinates of vertices h and j.
xh = x(h)
yh = y(h)
xj = x(j)
yj = y(j)

# Find the centre of the circumcircle of vertices h, i, k.
call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror)
if(nerror>0) return
if(shdswp) return # The points h, i, and k are colinear, so
                  # the circumcircle has `infinite radius', so
                  # (xj,yj) is definitely inside.

# Check whether (xj,yj) is inside the circle of centre
# (x0,y0) and radius r = dist[(x0,y0),(xh,yh)]

a  = x0-xh
b  = y0-yh
r2 = a*a+b*b
a  = x0-xj
b  = y0-yj
ch = a*a + b*b
if(ch<r2) shdswp = .true.
else shdswp = .false.

return
end


# Program no. 1
# Laboratory Practice-I
# tushar@tusharkute.com

# read the dataset
df = read.csv("iris.csv")

#see the summary of dataset
print("SUMMARY AND STRUCTURE")
summary(df)
str(df)  #structure with class

print("MINIMUM VALUE")
print(sapply(df, function(x) min(as.numeric(x))))
print("MAXIMUM VALUE")
print(sapply(df, function(x) max(as.numeric(x))))
print("AVERAGE VALUE")
print(sapply(df, function(x) mean(as.numeric(x))))
print("RANGE OF VALUES")
print(sapply(df, function(x) range(as.numeric(x))))
print("STANDARD DEVIATIONS")
print(sapply(df, function(x) sd(as.numeric(x))))
print("VARIANCE")
print(sapply(df, function(x) var(as.numeric(x))))

print("PERCENTILES")
num = c(1,2,3,4)
for (n in num) {
  cat("Column", n , "\n")
  print(quantile(df[,n], probs = c(0, 0.25, 0.5, 0.75, 1)))
}

for (n in num) {
  hist(df[,n], main = "Histogram")
  Sys.sleep(5)
}

boxplot(df[,1:4], main = "Boxplot of Iris")

LP 1/Data Analytics/Assignment 1/01_DA_iris.r


 DSYGVD Example Program Results

 Eigenvalues
       -3.5411    -0.3347     0.2983     2.2544
 Eigenvectors
             1          2          3          4
 1     -0.0356    -0.1039    -0.7459     0.1909
 2      0.3809     0.4322    -0.7845     0.3540
 3     -0.2943     1.5644    -0.7144     0.5665
 4     -0.3186    -1.0647     1.1184     0.3859

 Estimate of reciprocal condition number for B
        5.8E-03

 Error estimates for the eigenvalues
        1.4E-13    1.7E-14    1.6E-14    9.1E-14

 Error estimates for the eigenvectors
        5.6E-14    1.3E-13    1.3E-13    6.8E-14


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6

x = crossprod(matrix(stats::rnorm(30), 10))
xs = fl(x)

test = dbl(chol(xs))
stopifnot(all.equal(test, chol(x), tol=tol))


library(RSQLite)
library(ggplot2)

get.data.from.sqlite <- function(db.name, table.name) {
  con <- dbConnect(SQLite(), dbname=db.name)
  db.query <- paste('select * from', table.name)
  table.data <- dbGetQuery(con, db.query)
  return(table.data)
}

game.data <- get.data.from.sqlite("bgg_data_3.db", "board_games")

collected.ranks <- grep('[[:digit:]]+', game.data$rank, value=TRUE)
collected.ranks <- as.numeric(collected.ranks)

missing.data <- as.matrix(setdiff(1:4999, collected.ranks))

hist(missing.data, breaks = 50)
# currently missing 20% of top games, and 10% of bottom games
# I have all of the middle games

#####
# Clean the data
#####

clean.data <- game.data %>%
  filter(grepl('[[:digit:]]+', rank)) %>% mutate(rank = as.numeric((rank))) %>%
  filter(grepl('[[:digit:]]+', num_votes)) %>% mutate(num_votes = as.numeric((num_votes))) %>%
  filter(grepl('[[:digit:].]+', geek_rating)) %>% mutate(geek_rating = as.numeric((geek_rating))) %>%
  filter(grepl('[[:digit:].]+', avg_rating)) %>% mutate(avg_rating = as.numeric((avg_rating))) %>%
  filter(grepl('[[:digit:].]+', avg_rating_std_deviations)) %>% mutate(avg_rating_std_deviations = as.numeric((avg_rating_std_deviations)))

######

rank.votes <- clean.data %>% select(rank, num_votes)
rank.votes <- rank.votes[complete.cases(rank.votes), ]

ggplot(rank.votes, aes(x=rank, y=num_votes)) + geom_point()

######

year.votes <- clean.data %>% select(year_published, num_votes) %>% filter(year_published > 1950)
year.votes <- year.votes[complete.cases(year.votes), ]

ggplot(year.votes, aes(x=year_published, y=num_votes)) + geom_point()

######

year.comments <- clean.data %>% select(year_published, num_comments) %>% filter(year_published > 1950)
year.comments <- year.comments[complete.cases(year.comments), ]

ggplot(year.comments, aes(x=year_published, y=num_comments)) + geom_point()

######

votes.comments <- clean.data %>% select(num_votes, num_comments, rank)
votes.comments <- votes.comments[complete.cases(votes.comments), ]

ggplot(votes.comments, aes(x=num_votes, y=num_comments, color=rank)) + geom_point() + scale_colour_continuous("Rank", limits= c(1, 5000), low="green", high="blue") + scale_x_log10() + scale_y_log10()

######

weight.rating <- clean.data %>% select(weight, avg_rating, rank)
weight.rating <- weight.rating[complete.cases(weight.rating), ]

ggplot(weight.rating, aes(x=weight, y=avg_rating, color=rank)) + geom_point() + scale_colour_continuous("Rank", limits= c(1, 5000), low="green", high="blue")

######

retention.rank <- clean.data %>% mutate(retention = prev_owned / (owned + prev_owned)) %>% select(retention, geek_rating, rank)
retention.rank <- retention.rank[complete.cases(retention.rank), ]

ggplot(retention.rank, aes(x=geek_rating, y=retention, color=rank)) + geom_point() + scale_colour_continuous("Rank", limits= c(1, 5000), low="green", high="blue") + xlab("Geek Rating") + ylab("Non-Retention")

######

geek.rating.rounded <- clean.data %>% mutate(rating = round(geek_rating, digits = 1)) %>%
  select(rating) %>% group_by(rating) %>% summarise(count = n()) %>% mutate(rating.method = "Geek Rating")

hist(clean.data$geek_rating)

avg.rating.rounded <- clean.data %>% mutate(rating = round(avg_rating, digits = 1)) %>%
  select(rating) %>% group_by(rating) %>% summarise(count = n()) %>% mutate(rating.method = "Avg. Rating")

hist(clean.data$avg_rating)

rating.comparison <- rbind(geek.rating.rounded, avg.rating.rounded)

#ggplot(rating.comparison, aes(x=rating, y=count, color=rating.method)) + geom_line()
#p2 <- ggplot(avg.rating.rounded, aes(x=avg_rating, y=count)) + geom_line(colour='blue')

#######

geek.rating.mu <- mean(clean.data$geek_rating)
geek.rating.sd <- sd(clean.data$geek_rating)

num.votes.mu <- mean(clean.data$geek_rating)
num.votes.sd <- sd(clean.data$geek_rating)

# how far above average geek rating is the game? <- this gives us a score
# how many people thought talking about it was important? <- this gives us weight
score.mechanics <- clean.data %>% select(geek_rating, num_votes, mechanics) %>%
  mutate(score = (geek_rating - geek.rating.mu)) %>%
  mutate(weight = log10(num_votes)) %>%
  mutate(score = score * weight / log10(mean(num_votes))) %>%
  select(score, mechanics)

score.mechanics <- score.mechanics %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  group_by(mechanics) %>% summarise(score = mean(score))

########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", num_fans)) %>% mutate(fans = as.numeric(num_fans))

# how far above average geek rating is the game? <- this gives us a score
# how many people thought talking about it was important? <- this gives us weight
fans.mechanics <- valid.data %>% select(fans, num_votes, mechanics) %>%
  select(fans, mechanics)

fans.mechanics <- fans.mechanics %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  group_by(mechanics) %>% summarise(fans = mean(fans))

#########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", num_fans)) %>% mutate(fans = as.numeric(num_fans))

# how far above average geek rating is the game? <- this gives us a score
# how many people thought talking about it was important? <- this gives us weight
fans.categories <- valid.data %>% select(fans, num_votes, categories) %>%
  select(fans, categories)

fans.categories <- fans.categories %>%
  mutate(categories = strsplit(categories, split = "|", fixed=TRUE)) %>% unnest(categories) %>%
  group_by(categories) %>% summarise(fans = mean(fans))

#########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", weight)) %>% mutate(weight = as.numeric(weight))

# how far above average geek rating is the game? <- this gives us a score
# how many people thought talking about it was important? <- this gives us weight
weight.mechanics <- valid.data %>% select(weight, mechanics) %>%
  select(weight, mechanics)

weight.mechanics <- weight.mechanics %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  group_by(mechanics) %>% summarise(weight = mean(weight))

#########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", min_playtime)) %>% mutate(min_playtime = as.numeric(min_playtime))

playtime.mechanics <- valid.data %>% select(min_playtime, mechanics) %>%
  select(min_playtime, mechanics)

playtime.mechanics <- playtime.mechanics %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  group_by(mechanics) %>% summarise(min_playtime = mean(min_playtime))

########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", min_playtime)) %>% mutate(min_playtime = as.numeric(min_playtime))
valid.data <- valid.data %>% filter(grepl("[[:digit:].]+", weight)) %>% mutate(weight = as.numeric(weight))
valid.data <- valid.data %>% filter(grepl("[[:digit:].]+", num_fans)) %>% mutate(num_fans = as.numeric(num_fans))

ggplot(valid.data, aes(x=min_playtime, y=num_fans, color=weight)) + geom_point() +
  scale_colour_continuous(limits= c(1, 5), low="green", high="blue") + scale_x_log10() + geom_jitter()

#########

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", num_expansions)) %>% mutate(num_expansions = as.numeric(num_expansions))
valid.data <- valid.data %>% filter(grepl("[[:digit:].]+", num_fans)) %>% mutate(num_fans = as.numeric(num_fans))
expansions.rank <- valid.data %>% group_by(num_expansions) %>% summarise(rank.mu = mean(rank), num_fans = mean(num_fans))

ggplot(expansions.rank, aes(x=num_expansions, y=num_fans, color=rank.mu, size=3)) + geom_point() + scale_colour_continuous("Rank", low="green", high="blue")

#########
# game mechanic worth playing once only?

valid.data <- clean.data %>%
  filter(grepl("[[:digit:]]+", owned)) %>% mutate(owned = as.numeric(owned)) %>%
  filter(grepl("[[:digit:]]+", prev_owned)) %>% mutate(prev_owned = as.numeric(prev_owned))

play.once <- valid.data %>% select(categories, prev_owned, owned)
play.once <- play.once[complete.cases(play.once), ]

play.once <- play.once %>%
  mutate(categories = strsplit(categories, split = "|", fixed=TRUE)) %>% unnest(categories) %>%
  group_by(categories) %>% summarise(retention = sum(owned) / (sum(prev_owned) + sum(owned)))

##########

valid.data <- clean.data %>%
  filter(grepl("[[:digit:]]+", min_playtime)) %>% mutate(min_playtime = as.numeric(min_playtime)) %>%
  filter(grepl("[[:digit:]]+", total_plays)) %>% mutate(total_plays = as.numeric(total_plays))

valid.data <- valid.data %>% filter(min_playtime < 1000)

#valid.data <- valid.data %>% mutate(ppf = total_plays / num_fans)

ggplot(valid.data, aes(x=total_plays, y=min_playtime, color=rank)) + geom_point() + geom_jitter() + scale_x_log10()

###########

fans.mechanics <- fans.mechanics %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  group_by(mechanics) %>% summarise(fans = mean(fans)) %>% arrange(desc(fans))

top.mechanics <- fans.mechanics[1:10, ]
top.mechanics[, 1]

test <- clean.data %>%
  mutate(mechanics = strsplit(mechanics, split = "|", fixed=TRUE)) %>% unnest(mechanics) %>%
  filter(mechanics %in% top.mechanics$mechanics)

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

###########

fans.categories <- fans.categories %>%
  mutate(categories, strsplit(categories, split = "|", fixed=TRUE)) %>% unnest(categories) %>%
  group_by(categories) %>% summarise(fans = mean(fans)) %>% arrange(desc(fans))

top.categories <- fans.categories[1:10, ]
top.categories[, 1]

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

valid.data <- clean.data %>%
  filter(grepl("[[:digit:]+]", num_fans)) %>%
  mutate(num_fans = log10(as.numeric(num_fans))) %>% filter(num_fans > 0) %>%
  select(num_fans, geek_rating)

ggplot(valid.data, aes(x=num_fans, y=geek_rating)) + geom_point()

cor(valid.data)

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

valid.data <- clean.data %>% filter(grepl("[[:digit:].]+", num_fans)) %>% mutate(fans = as.numeric(num_fans)) %>% filter(fans > 0)

zombie.games <- valid.data

zombie.games <- zombie.games %>%
  mutate(categories = strsplit(categories, split = "|", fixed=TRUE)) %>% unnest(categories) %>%
  filter(categories == "Zombies")

zombie.games <- zombie.games[1:10, ]
zombie.games[, 1]


#setwd("~/norolling_speed")

get_rates <- function(data_set){
  rates <- NULL
  start <- NULL
  for(i in 1:ncol(data_set)){
    x = seq(0, nrow(data_set) - 1, by = 1)
    y = data_set[,i]
    mod = lm(y ~ x)
    rates[i] <- mod[[1]][2]
    start[i] <- mod[[1]][1]
  }
  return(data.frame(rates,start))
}

nrspeed0 <- data.frame(t(read.csv("norolling_speed2.5.csv", header = FALSE)))
row.names(nrspeed0) <- NULL

nrspeed1 <- data.frame(t(read.csv("norolling_speed5.csv", header = FALSE)))
row.names(nrspeed1) <- NULL

nrspeed2 <- data.frame(t(read.csv("norolling_speed7.5.csv", header = FALSE)))
row.names(nrspeed2) <- NULL

nrspeed3 <- data.frame(t(read.csv("norolling_speed10.csv", header = FALSE)))
row.names(nrspeed3) <- NULL

nrspeed4 <- data.frame(t(read.csv("norolling_speed12.5.csv", header = FALSE)))
row.names(nrspeed4) <- NULL

nrspeed5 <- data.frame(t(read.csv("norolling_speed15.csv", header = FALSE)))
row.names(nrspeed5) <- NULL

nrspeed6 <- data.frame(t(read.csv("norolling_speed17.5.csv", header = FALSE)))
row.names(nrspeed6) <- NULL

nrspeed7 <- data.frame(t(read.csv("norolling_speed20.csv", header = FALSE)))
row.names(nrspeed7) <- NULL

matplot(nrspeed1,type="l",xlab = "iterations",ylab = "environmental quality",main="Depletion: Non-Rolling",ylim=c(1500,3700))

rates_025<- get_rates(nrspeed0)
rates_050<- get_rates(nrspeed1)
rates_075<- get_rates(nrspeed2)
rates_100<- get_rates(nrspeed3)
rates_125<- get_rates(nrspeed4)
rates_150<- get_rates(nrspeed5)
rates_175<- get_rates(nrspeed6)
rates_200<- get_rates(nrspeed7)

boxplot(rates_025$rates,rates_050$rates,rates_075$rates,rates_100$rates,rates_125$rates,rates_150$rates,rates_175$rates,rates_200$rates,xlab="speed",ylab="rate of depletion")

shapiro.test(rates_025$rates)
shapiro.test(rates_050$rates)
shapiro.test(rates_075$rates)
shapiro.test(rates_100$rates)
shapiro.test(rates_125$rates)
shapiro.test(rates_150$rates)
shapiro.test(rates_175$rates)
shapiro.test(rates_200$rates)

nr_rate_list <- c(rates_025$rates,rates_050$rates,rates_075$rates,rates_100$rates,rates_125$rates,rates_150$rates,rates_175$rates,rates_200$rates)
nr_speed_list <- rep(seq(2.5,20,by=2.5),each=30)

boxplot(nr_rate_list ~ nr_speed_list,xlab="speed",ylab="depletion rate",ylim=c(-1,-0),main="Without Rolling Behaviour")
bartlett.test(rate_list~speed_list)
kruskal.test(rate_list~speed_list)


# install.packages("caret")
# install.packages("e1071")

library(caret)
library(kernlab)

data(spam)

# Data splitting with createDataPartition()
inTrain <- createDataPartition(y=spam$type, p=0.75, list=FALSE)

training <- spam[inTrain, ]
testing <- spam[-inTrain, ]
dim(training)

# Fit a model with train() from 'caret'
set.seed(32343)
modelFit <- train(type ~., data=training, method="glm") # generalized linear model
modelFit

# final model
modelFit$finalModel

# prediction
predictions <- predict(modelFit, newdata=testing)
predictions

# confusion Matrix
confusionMatrix(predictions, testing$type)

# Further information
# Caret tutorials:
#   - http://www.edii.uclm.es/~useR-2013/Tutorials/kuhn/user_caret_2up.pdf
#   - http://cran.r-project.org/web/packages/caret/vignettes/caret.pdf
# A paper introducing the caret package
#   - http://www.jstatsoft.org/v28/i05/paper


# Multiple Linear Regression
# Importing the Dataset
dataset = read.csv('50_Startups.csv')
library(caTools)
set.seed(123)

# Enconding Categorial data
dataset$State = factor(dataset$State,
                       levels = c('New York', 'California', 'Florida'),
                       labels = c(1, 2, 3))

split = sample.split(dataset$Profit, SplitRatio = 0.8)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Fitting Multiple Linear Regression
regressor = lm(formula = Profit ~ .,
               data = training_set)

# Predicting the Test set results
y_pred = predict(regressor, newdata = test_set)

# Building the optimal model using Backward Elimination
regressor = lm(formula = Profit ~ R.D.Spend + Administration + Marketing.Spend + State,
                data = dataset)

regressor = lm(formula = Profit ~ R.D.Spend + Administration + Marketing.Spend,
               data = dataset)

regressor = lm(formula = Profit ~ R.D.Spend + Marketing.Spend,
               data = dataset)

regressor = lm(formula = Profit ~ R.D.Spend,
               data = dataset)

summary(regressor)
# Checked the summary(regressor) and R.D.Spend  is the most important dependent variable
# regressor = lm(formula = Profile ~ R.D.Spend, data = training_set)


Nsr = (1 - albedoCoefficient) * solarRadiation
clearSkySolarRadiation = (0.75 + 2 * 10**(-5) * elevation) * extraSolarRadiation
averageT = ((maxTair + 273.16)** 4 + (minTair + 273.16)** 4) / 2
surfaceEmissivity = (0.34 - 0.14 * sqrt(vaporPressure / 10))
cloudCoverFactor = (1.35 * (solarRadiation / clearSkySolarRadiation) - 0.35)
Nolr = stefanBoltzman * averageT * surfaceEmissivity * cloudCoverFactor
netRadiation= Nsr - Nolr
netOutGoingLongWaveRadiation = Nolr


## First use no ordinal high-end category overrides, and compare power
## to t-test when there is no covariate

require(Hmisc)
n <- 100
delta <- .5
sd <- 1
require(pwr)
power.t.test(n = n / 2, delta=delta, sd=sd, type='two.sample')  # 0.70
source('~/R/Hmisc/R/popower.s')
set.seed(1)
w <- simRegOrd(n, delta=delta, sigma=sd, pr=TRUE)     # 0.686

## Now do ANCOVA with a quadratic effect of a covariate
n <- 100
x <- rnorm(n)
w <- simRegOrd(n, nsim=400, delta=delta, sigma=sd, x=x,
               X=cbind(x, x^2),
               Eyx=function(x) x + x^2, pr=TRUE)
w$power  # 0.68

## Fit a cubic spline to some simulated pilot data and use the fitted
## function as the true equation in the power simulation
require(rms)
N <- 1000
set.seed(2)
x <- rnorm(N)
y <- x + x^2 + rnorm(N, 0, sd=sd)
f <- ols(y ~ rcs(x, 4), x=TRUE)

n <- 100
j <- sample(1 : N, n, replace=n > N)
x <-   x[j]
X <- f$x[j,]
w <- simRegOrd(n, nsim=400, delta=delta, sigma=sd, x=x,
               X=X,
               Eyx=Function(f), pr=TRUE)
w$power  ## 0.70

## Finally, add discrete ordinal category overrides and high end of y
## Start with no effect of treatment on these ordinal event levels (OR=1.0)

w <- simRegOrd(n, nsim=400, delta=delta, odds.ratio=1, sigma=sd,
               x=x, X=X, Eyx=Function(f),
               p=c(.98, .01, .01),
               pr=TRUE)
w$power  ## 0.61   (0.3 if p=.8 .1 .1, 0.37 for .9 .05 .05, 0.50 for .95 .025 .025)

## Now assume that odds ratio for treatment is 2.5
## First compute power for clinical endpoint portion of Y alone
or <- 2.5
p <- c(.9, .05, .05)
popower(p, odds.ratio=or, n=100)   # 0.275
## Compute power of t-test on continuous part of Y alone
power.t.test(n = 100 / 2, delta=delta, sd=sd, type='two.sample')  # 0.70
## Note this is the same as the p.o. model power from simulation above
## Solve for OR that gives the same power estimate from popower
popower(rep(.01, 100), odds.ratio=2.4, n=100)   # 0.706
## Compute power for continuous Y with ordinal override
w <- simRegOrd(n, nsim=400, delta=delta, odds.ratio=or, sigma=sd,
               x=x, X=X, Eyx=Function(f),
               p=c(.9, .05, .05),
               pr=TRUE)
w$power  ## 0.72


d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
               author=c('Alice','Bob','Alice','Charlie','Bob','Bob','Alice','Bob','Alice','Bob'),
               order.nr=c(1,2,3,4,5,6,1,2,3,4))
d

g = adjacency(list(author=d$author), d$conversation, as.graph=T) # In how many conversations did author.X and author.Y communicate?
plot(g, edge.label=E(g)$weight, vertex.size=40, vertex.label=as.character(V(g)$author))
g = adjacency(list(author=d$author), d$conversation, measure='overlap_jacard', as.graph=T) # In what percentage of articles in which author.X communicated did author.Y communicate as well?
plot(g, edge.label=E(g)$weight, vertex.size=40, vertex.label=as.character(V(g)$author))
g = adjacency(list(author=d$author), d$conversation, measure='cosine', as.graph=T) # what is the cosine similarity of authors based on their participation in conversations (takes number of times author participates within the conversation into account)
plot(g, edge.label=round(E(g)$weight,2), vertex.size=40, vertex.label=as.character(V(g)$author))

g = windowed.adjacency(list(authors=d$author), d$order.nr, d$conversation, window.size=2, as.graph=T, direction='up') # how many times did author.X communicate directly after author.Y?
plot(g, edge.label=E(g)$weight, vertex.size=35)
g = windowed.adjacency(list(authors=d$author), d$order.nr, d$conversation, window.size=3, as.graph=T, direction='up') # larger window size
plot(g, edge.label=E(g)$weight, vertex.size=35)
g = windowed.adjacency(list(authors=d$author), d$order.nr, d$conversation, window.size=3, as.graph=T) # undirected
plot(g, edge.label=E(g)$weight, vertex.size=35)
plot(g, edge.label=E(g)$average, vertex.size=35) # using average values
g = windowed.adjacency(list(authors=d$author), d$order.nr, d$conversation, window.size=3, as.graph=T, count.once=T) # counting unique authors only once
plot(g, edge.label=E(g)$average, vertex.size=35) # using average values, now representing percentage of times author.X communicating within a distance of 2 messages from author.Y


# a fake dataset with a continuous response and a continuous explanatory

d0 <- list()
d0$explanatory <- rnorm(66, 17.35, 0.4)
a <- 0.2
b <- 0.005
error <- rnorm(66, 0, 0.0013)
d0$response <- a + b*d0$explanatory + error

plot(response ~ explanatory , d0)
abline(lm(response ~ explanatory , d0))

write.csv(as.data.frame(d0), file = "rbasics/d0.csv")

# a fake dataset of one continuous response, two fatorial explanatory variables, and a continuous covariable of little effect
d1 <- list()
d1$exp1 <- as.factor(rep(c("ae","ge","rw"), each = 20))
d1$exp2 <- as.factor(rep(rep(c("A","B","C","D"), each = 5), times = 3))
d1$cov1 <- rnorm(60, 3.35, sd = runif(4, 1.2,1.8)[as.integer(d1$exp1)])

a <- runif(3, 5,8)
b <- runif(4, 0,0.3)
c <- 0.24353
error <- rnorm(60, 0, sd = 1.2)
d1$resp <-  a[as.integer(d1$exp1)] + b[as.integer(d1$exp2)] +  c*d1$cov1 + error
d1$resp <- round(d1$resp, 2)

model <- lm(resp ~ exp1 + exp2 , d1)
anova(model)
summary(model)

plot(resp ~ exp1, d1)
plot(predict(model), d1$resp, asp = 1)
abline(a = 0, b = 1)
TukeyHSD(aov(resp ~ exp1 , d1))

as.data.frame(d1)

write.csv(as.data.frame(d1), file = "d1.csv")

# a fake dataset with one continuous response, two continuous explanatories and a factorial cofactor
d2 <- list()
d2$cof1 <- as.factor(rep(sample(c("a","b","c","d","e"), 40, replace = TRUE), times = 3))
d2$exp1 <- rnorm(120, 0.15, rnorm(5, 2.2131,0.42)[as.integer(d2$cof1)] )
d2$exp2 <- rnorm(120, 43.1, 12.42) + rnorm(5, 0,6)[as.integer(d2$cof1)]

a <- 44.1
b <- 0.212
c <- 0.64
d <- 0.06353
error <- rnorm(120, 0, sd = 18.2)
d2$resp <- a + b * d2$exp1 + c * d2$exp2 +  d*d2$exp1*d2$exp2 + error
d2$resp <- as.integer(d2$resp)

model <- lm(resp ~ exp1 * exp2, d2)
anova(model)
summary(model)
model <- lm(resp ~ exp1 + exp2, d2)
anova(model)

plot(resp ~ exp2, d2)
summary(model)
abline(a = 46.935, b = 0.6152)

plot(model$residuals ~ exp1, d2)
summary(model)
abline(a = 0, b = 2.0999)

write.csv(as.data.frame(d2), file = "rbasics/d2.csv")

# fake bad data structure version of d2

df1 <- as.data.frame(d1)
df_bad <- cbind(subset(df1, exp1 == "ae"),subset(df1, exp1 == "ge")[,3:4],subset(df1, exp1 == "rw")[3:4])

write.csv(as.data.frame(df_bad), file = "rbasics/d_bad.csv")


#R version 3.3.2

# Implementation provided by
# Banks J., Garrabrant S.M., Huber M.L., Perizzolo A.
# in their paper titled "Using TPA to count linear extensi-ons"
# published in Journal of Discrete Algorithms, 2018.

#necessary to install the library for the first time
#install.packages('gtools', repos='http://cran.us.r-project.org')

library(gtools)
library(Matrix)

chain.step <- function(state,beta,i,c1,c2,posetmatrix) {
# Takes one step in the Karzanov-Khatchyan chain using randomness in i, c1, c2
# Assumes that home state is the identity permutation
# Line 2 of Algorithm 5.1
d <- i + 1 - state[i]
# Line 3 of Algorithm 5.1
if ((state[i] <= length(state)) && (state[i+1] <= length(state)))
posetflag <- posetmatrix[state[i],state[i+1]]
else
posetflag <- 0
if ( (c1 == 1) && (posetflag == 0) &&
(d <= ceiling(beta)) && ((d < beta) || (c2 == 1))) {
13
a <- state[i+1]; state[i+1] <- state[i]; state[i] <- a
}
return(state)
}

bounding.chain.step <- function(cstate,beta,i,c1,c2,posetmatrix) {
# Based on Algorithm 5.2
# Here cstate is a matrix with two rows, the first is the underlying state,
# while the second is the bounding state
n <- dim(cstate)[2]
# Line 1
if (cstate[2,i+1] == cstate[1,i]) c3 <- 1 - c1
else c3 <- c1
# Line 2 & 3
cstate[1,] <- chain.step(cstate[1,],beta,i,c3,c2,posetmatrix)
cstate[2,] <- chain.step(cstate[2,],beta,i,c1,c2,posetmatrix)
# Line 4 through 6
if (cstate[2,n] == (n+1))
cstate[2,n] <- 1 + sum(cstate[2,] <= n)
#Line 7
return(cstate)
}
generate <- function(t,beta,posetmatrix) {
n <- dim(posetmatrix)[1]; beta <- min(beta,n-1)
# Line 1
sigma <- 1:n; B <- rep(n+1,n)
# Line 2 thorugh 4
for (item in 1:(n - ceiling(beta)))
B[item+ceiling(beta)] <- item
B0 <- B
cstate <- matrix(c(sigma,B),byrow=TRUE,nrow=2)
# Line 5 through 8
i <- floor(runif(t)*(n-1))+1;c1 <- rbinom(t,1,1/2)
c2 <- rbinom(t,1,1+beta-ceiling(beta))
for (s in 1:t) {
cstate <- bounding.chain.step(cstate,beta,i[s],c1[s],c2[s],posetmatrix)
}
# Line 9
if (sum(cstate[2,] < (n+1)) == n) return(cstate[2,])
# Line 11-15
else {
cstate[1,] <- generate(2*t,beta,posetmatrix)
14
cstate[2,] <- B0
for (s in 1:t)
cstate <- bounding.chain.step(cstate,beta,i[s],c1[s],c2[s],posetmatrix)
}
return(cstate[1,])
}

approximate.sample <- function(n,beta,posetmatrix,tvdist) {
# Generates an approximate sample from the target distribution
x <- 1:n
n <- length(x)
t <- 10*n^3*log(n)*log(1/tvdist)
for (i in 1:t) {
i <- runif(1)*(n-1)+1
c1 <- rbinom(1,1,1/2)
c2 <- rbinom(1,1,1+beta-ceiling(beta))
x <- chain.step(x,beta,i,c1,c2,posetmatrix)
}
return(x)
}
checksum <- function(x) {
checksum <- 0
n <- length(x)
for (i in n:1) {
onespot <- which(x == 1)
checksum <- checksum + factorial(i-1)*(onespot-1)
x <- x[-onespot] - 1
}
return(checksum+1)
}

count.perfect.linear.extensions <- function(n = 4,beta = 4,posetmatrix,trials = 100) {
# Generates a number of linear extensions, then counts the results
results <- rep(0,factorial(n))
# Burnin to an approximate sample
x <- 1:n
n <- length(x)
# Take data
for (i in 1:trials) {
15
x <- generate(1,beta,posetmatrix)
cs <- checksum(x)
results[cs] <- results[cs] + 1
}
return(results/trials)
}

tpa.count.linear.extensions <- function(r,posetmatrix) {
# Algorithm 6.1
# Returns an estimate of the number of linear
# extensions consistant with posetmatrix
require(Matrix)
n <- dim(posetmatrix)[1]
# Line 1
k <- 0
# Line 2 through 12
for (i in 1:r) {
beta <- n - 1; k <- k - 1
while (beta > 0) {
k <- k + 1
x <- generate(1,beta,posetmatrix)
xinv <- invPerm(x)
betastep <- rep(0,n); y <- rep(0,n)
for (j in 1:n) {
y[j] <- runif(1)*((1+beta-ceiling(beta))*(xinv[j]-j == ceiling(beta))+
((xinv[j]-j) < ceiling(beta)))
betastep[j] <- (xinv[j]-j-1+y[j])*(xinv[j]-j > 0)
}
beta <- max(betastep)
# cat(" X: ",x,"\n X^{-1}: ",xinv,"\n Y: ",y,"\n betastep: ",betastep,"\n beta: ",beta,"\n")
}
}
cat(" Estimate: [",exp((k-2*sqrt(k))/r),",",exp((k+2*sqrt(k))/r),"]\n")
return(exp(k/r))
}

tpa.approximation <- function(posetmatrix,epsilon,delta) {
# Gives an $(\epsilon,\delta)$-ras for the number of posets
r1 <- ceiling(2*log(2/delta))
a1 <- tpa.count.linear.extensions(r1,posetmatrix)
16
a1 <- log(a1)
r2 <- ceiling(2*(a1+sqrt(a1)+2)*
(log(1+epsilon)^2-log(1+epsilon)^3)^(-1)*log(4/delta))
a2 <- tpa.count.linear.extensions(r2,posetmatrix)
return(a2)
}

brute.force.count.linear.extensions <- function(posets) {
# Counts the number of linear extensions of a poset by direct
# ennumeration of all n! permutations and checking each to see
# if it is a linear extension
#
# The poset is given as an n by n matrix whose (i,j)th entry
# is the indicator function of $i \preceq j$
require(gtools)
n <- dim(posets)[1]
A <- permutations(n,n)
nfact <- nrow(A)
le.flag <- rep(1,nfact)
count <- 0
for (i in 1:nfact) {
for (a in 1:(n-1))
for (b in (a+1):n) {
le.flag[i] <- le.flag[i]*(1-posets[A[i,b],A[i,a]])
}
count <- count + le.flag[i]
}
return(count)
}


#' Find optimal radia
#'
#' This function compute the optimal cylinder radia, such that the corresponding
#' cylinders contain one event in average
#' for the chosen N heights (\code{heights}) and a given \code{baseline.matrix}.
#' It returns an Nx2 \code{Matrix} whose first column contains the heights and
#' and the second column contains the corresponding radia.
#' @param baseline.matrix A \code{Matrix} enconding the baseline.
#' @param heigths \code{integer}.
#' @return A \code{Matrix}.
#' @examples
#' radia_and_heights = f_radia_and_heights(baseline.matrix, 1:10)
f_radia_and_heights<-function(baseline.matrix, heigths=1:100){
  n.heigths = ncol(baseline.matrix)
  mean.baseline = mean(baseline.matrix[, 1:n.heigths])
  # R = 3959 # earth radius in miles
  # lat1 = min(postcode2coord$latitude)
  # lat2 = max(postcode2coord$latitude)
  # lon1 = min(postcode2coord$longitude)
  # lon2 = max(postcode2coord$longitude)
  # total.area = (pi / 180) * R * R  * abs(sin(lat1)-sin(lat2)) * abs(lon1-lon2)
  total.area = 130279 # total area of England in km2s
  n.points = nrow(baseline.matrix)
  mean.spatial.baseline = mean.baseline * n.points / total.area
  # we want A such that A * mean.spatial.baseline=1,  A * mean.spatial.baseline=1/2,  A * mean.spatial.baseline=1/3, etc
  radia = sapply(heigths, function(x){sqrt(1 / mean.spatial.baseline / pi / x)} )
  ret = cbind(heigths, radia)
  colnames(ret) = c('heights','radia')
  return(ret)
}

#' Find optimal radia
#'
#' This function compute the optimal cylinder radia, such that the corresponding
#' cylinders contain one event in average
#' for the chosen N heights (\code{heights}) and a given tabulated baseline.
#' It returns an Nx2 \code{Matrix} whose first column contains the heights and
#' and the second column contains the corresponding radia.
#' @param baseline.matrix An \code{expand.grid} tab enconding the baseline.
#' @param heigths \code{integer}.
#' @return A \code{Matrix}.
#' @examples
#' radia_and_heights = f_radia_and_heights(baseline.matrix, 1:10)
f_radia_and_heights_<-function(baseline.tab, heights=1:100){
  n.heights = length(unique(baseline.tab$t))
  mean.baseline = mean(baseline.tab$z[baseline.tab$z>0]) # z strictly > 0 to exclude the grid points on unpopulated area.

  total.area = 130279 # total area of England in km2
  idx = baseline.tab$z > 0
  n.points = sum(idx) / n.heights
  delta2 = prod(attributes(baseline.tab)$delta2)
  mean.spatial.baseline = mean.baseline / (n.points * delta2) * total.area
  # we want A such that A * mean.spatial.baseline=1,  A * mean.spatial.baseline=1/2,  A * mean.spatial.baseline=1/3, etc
  radia = sapply(heights, function(x){sqrt(1 / mean.spatial.baseline / pi / x )} )
  ret = cbind(heigths, radia)
  colnames(ret) = c('heights','radia')
  return(ret)
}

#' Draw random cylinder coordinates
#'
#' Find the coordinates (centers and height limits) of cylinders
#' that contain events defined in \code{observation.matrix}, with radia and heights
#' given in \code{radia_and_heights}.
#'
#' @param n.cylinders An \code{integer}; the number of cylinders to draw.
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param time.range An \code{integer} vector.
#' @param radia_and_heights A \code{Matrix}.
#' @param postcode2coord A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @importFrom truncnorm rtruncnorm
#' @import Matrix
#' @return A \code(data.frame).
#' @examples
#' cylinders=rcylinder(10, observation.matrix, time.range, radia_and_heights, postcode2coord)
rcylinder<-function(n.cylinders, observation.matrix, time.range, radia_and_heights, postcode2coord, only.last=F){
  if (any(rownames(observation.matrix)=='NA')){
    cat("WARNING: any(rownames(observation.matrix)=='NA'")
  }
  cols = as.character(time.range[1]:time.range[2])
  cases = which(observation.matrix[, cols] > 0, arr.ind = T)
  # cases is of the form:
  #           row col
  # PL15 9NE 5851 231
  # SY11 3PN 6370 255
  if (sum(observation.matrix[, cols]) > 0){
    idx = sample(1:nrow(cases), n.cylinders, replace = T)
    y = postcode2coord[cases[idx, 1], 'y']
    x = postcode2coord[cases[idx, 1], 'x']

    # t = cases[idx,2] + time.range[1] - 1
    # print(head(t))
    t = as.integer(colnames(observation.matrix[,cols])[cases[idx,2]])
    # radia and heights are given as input in the matrix radia_and_heights

    radia_and_heights = radia_and_heights[sample(1:nrow(radia_and_heights), n.cylinders, replace=T),]
    # randomise wilst keeping same radius and height and avoiding negative t
    rho = radia_and_heights[, 2]
    random_radia = runif(n.cylinders, 0, rho)
    theta = runif(n.cylinders, 0, 2* pi)

    y = y + sin(theta) * random_radia
    x = x + cos(theta) * random_radia
    tt = t + runif(n.cylinders, -radia_and_heights[,1]/2, radia_and_heights[,1]/2)

   if (only.last){
      t.upp = as.integer(time.range[2])
    }else{
      t.upp = ceiling(tt + radia_and_heights[,1] / 2)
    }
    t.max = as.integer(time.range[2])

    if (only.last){
      t.low = floor(t.upp - radia_and_heights[,1])
      t.low = ifelse(t < t.low, t, t.low)
    }else{
      t.low = floor(tt - radia_and_heights[,1] / 2)
    }
    t.min = as.integer(time.range[1])

    t.low = ifelse(t.low >= t.min, t.low, t.min)
    t.upp = ifelse(t.upp <= t.max, t.upp, t.max)

    t.low = as.integer(ifelse(t.low == t.max, t.low - 1, t.low))
    # isx = (t.low == t.upp)
    # if (any(isx)){
    #   print(c(t.low[isx], t.upp[isx]))
    # }

    return(data.frame(x=x, y=y, rho=rho, t.low=t.low, t.upp=t.upp))
  }else{
    return(data.frame(x=double(), y=double(), rho=double(), t.low=integer(), t.upp=integer()))
  }
}

#' Compute exceedance probabality in a cylinder.
#'
#' A cylinder is defined by the circle coordinated (say, x,y, and radius) and lower and upper height limits (aay, t.low and t.upp, respectively).
#' For a given cylinder, this function computes the number of observed events (\code{n_cases}) in the cylinder according to
#' \code{observation.matrix}, the expected number \code{mu} of events according the Poisson point model (with intensity
#' defined in \code{baseline.matrix}), and the probability that .
#' The function returns \code{c(n_cases, mu, p.val)}.
#'
#' @param cylinder
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param baseline.matrix A \code{Matrix} object enconding the baseline.
#' @param postcode.locations A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @import Matrix
#' @return A \code{numeric} vector of dimension 3.
#' @examples
#' exceedance=compute(c(x,y,rho,t.low,t.upp), observation.matrix, baseline.matrix, postcode.locations)
compute<-function(cylinder, observation.matrix, baseline.matrix, postcode.locations){
  t.range = as.character(as.integer(cylinder['t.low']):as.integer(cylinder['t.upp']))
  observations = observation.matrix[,t.range]
  baselines = baseline.matrix[,t.range]

  d = sqrt(
    (as.numeric(postcode.locations$x) - as.numeric(cylinder['x']))^2 +
      (as.numeric(postcode.locations$y) - as.numeric(cylinder['y']))^2
  )
  in_circle = (d<as.numeric(cylinder['rho'])) & (!is.na(d))
  n_cases = sum(observations[in_circle, ], na.rm=T)
  # postcodes<-paste(rownames(observations[in_circle, ]), collapse = ",")
  # the sum of Poisson RVs is Poisson
  mu = sum(baselines[in_circle, ])
  #mu = sum(baselines[in_circle, ]) + 1

  #  ci = qpois(c(0.25, 0.95) , lambda=mu)
  p.val = ppois(n_cases-1, lambda=mu, lower.tail=FALSE)
  return (c(n_cases, mu, p.val))
}

#' Compute exceedance probabality in a cylinder.
#'
#' A cylinder is defined by the circle coordinated (say, x,y, and radius) and lower and upper height limits (aay, t.low and t.upp, respectively).
#' For a given cylinder, this function computes the number of observed events (\code{n_cases}) in the cylinder according to
#' \code{observation.matrix}, the expected number \code{mu} of events according the Poisson point model (with intensity
#' defined in \code{tab.baseline}), and the probability that .
#' The function returns \code{c(n_cases, mu, p.val)}.
#'
#' @param cylinder
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param tab.baseline An \code{expand.grid} tab enconding the baseline.
#' @param postcode.locations A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @import Matrix
#' @return A \code{numeric} vector of dimension 3.
#' @examples
#' exceedance=compute(c(x,y,rho,t.low,t.upp), observation.matrix, tab.baseline, postcode.locations)
compute.from.tab.baseline<-function(cylinder, observation.matrix, tab.baseline, postcode.locations){
  t.low = as.numeric(cylinder['t.low'])
  t.upp = as.numeric(cylinder['t.upp'])
  x0 = as.numeric(cylinder['x'])
  y0 = as.numeric(cylinder['y'])
  rho = as.numeric(cylinder['rho'])
  t.range = as.character(as.integer(cylinder['t.low']):as.integer(cylinder['t.upp']))
#  cat("t.range",t.range,"\n")

  observations = observation.matrix[,t.range]

  d = sqrt(
    (tab.baseline$x - x0)^2 +
    (tab.baseline$y - y0)^2
  )
  in_circle = (d < rho) & !is.na(d)
  in_height = (tab.baseline$t >= t.low) & (tab.baseline$t <= t.upp)

  mu = sum(tab.baseline[in_circle & in_height,]$z) #* attributes(tab.baseline)$delta2 #multiply by delta2 as this is the bin size

#  in_of_square = sum(in_circle & in_height) * delta2
#  out_of_square = pi * rho* rho - in_of_square
#  correct by taking into account that outsise the square there is nothing.
#  mu = mu * pi * rho *rho / in_of_square

  d = sqrt(
      (as.numeric(postcode.locations$longitude) - x0)^2 +
      (as.numeric(postcode.locations$latitude)  - y0)^2
  )
  in_circle = (d < rho) & (!is.na(d))

  n_cases_in_cylinder = sum(observations[in_circle, ], na.rm = T)

#  ci = qpois(c(0.25,0.95) , lambda=mu)
  p.val = ppois(n_cases_in_cylinder-1, lambda=mu, lower.tail=FALSE)
  return (c(n_cases_in_cylinder, mu, p.val))
}

warning_ratio<-function(i, observation.matrix, cylinders, postcode.locations){
  # check if the location i
  x = as.numeric(postcode.locations[i, 'longitude'])
  y = as.numeric(postcode.locations[i, 'latitude'])

  ## da vettorizzare
  # in_circle = apply(cylinders, 1, function(X){
  #   ifelse(sqrt((as.numeric(X['x']) - x)^2 + (as.numeric(X['y']) - y)^2) < as.numeric(X['rho']), TRUE, FALSE)
  # })

  # vettorizzato
  in_circle = sqrt((as.numeric(cylinders['x']) - x)^2 + (as.numeric(cylinders['y']) - y)^2) < as.numeric(cylinders['rho'])

  times = which(observation.matrix[i,] > 0)

  if (length(times) > 0){
    in_cylinder_height = matrix(FALSE, nrow = nrow(cylinders), ncol=length(times))

    for (i in 1:length(times)){

      #da vettorizzare:
      in_cylinder_height[,i] = apply(cylinders, 1,  function(X){
        TT = as.numeric(names(times[i]))
        (as.numeric(X['t.low']) < TT) & (as.numeric(X['t.upp']) > TT)
      })

      # vettorizzato
      #TT = as.numeric(names(times[i]))
      #in_cylinder_height[,i] = (as.numeric(cylinders['t.low']) < TT) & (as.numeric(cylinders['t.upp']) > TT)

    }

    # number of cylinders that include locations `i`
    in_cylinder = sum(in_circle * in_cylinder_height)
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height)

    return(warning / in_cylinder)
  }else{
    return(NA)
  }
}
#
# warning_ratio2<-function(i, observation.matrix, t, cylinders, postcode.locations){
#   times = which(observation.matrix > 0)
#   if (length(times) > 0){
#     # check if the location is in any circle
#     x = as.numeric(postcode.locations[i,'longitude'])
#     y = as.numeric(postcode.locations[i,'latitude'])
#
#
#     in_circle = apply(cylinders, 1, function(X){
#       ifelse(sqrt((as.numeric(X['x']) - x)^2 + (as.numeric(X['y']) - y)^2) < as.numeric(X['rho']), TRUE, FALSE)
#     })
#     in_cylinder_height = (cylinders['t.low'] < t) & (cylinders['t.upp'] > t)
#     # number of cylinders that include locations
#     in_cylinder = sum(in_circle * in_cylinder_height)
#     # number of cylinder with `warning` flag that include location `i`
#     warning = sum(cylinders$warning * in_circle * in_cylinder_height)
#     if (in_cylinder == 0){
#       return(0)
#     }else{
#       return(warning / in_cylinder)
#     }
#   }else{
#     return(0)
#   }
# }

warning.score<-function(case, cylinders, date.time.field = 'week'){
  x = as.numeric(case['x'])
  y = as.numeric(case['y'])
  TT = as.numeric(case[date.time.field])

  d = sqrt((cylinders$x - x)^2 + (cylinders$y - y)^2)
  in_circle = as.integer(d <= cylinders$rho)
  in_cylinder_height = as.integer((cylinders$t.low <= TT) & (cylinders$t.upp >= TT))

  # number of cylinders that include geo-coordinate of `case`
  in_cylinder = sum(in_circle * in_cylinder_height, na.rm=T)
  if (in_cylinder>0){
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height, na.rm=T)
    re = warning / in_cylinder
  }else{
    re = 0
  }
  return(re)
}

warning.score2 <-function(case, TT, cylinders) {

  x = as.numeric(case['x'])
  y = as.numeric(case['y'])

  d = sqrt((cylinders$x - x)^2 + (cylinders$y - y)^2)
  in_circle = as.integer(d <= cylinders$rho)
  in_cylinder_height = as.integer((cylinders$t.low <= TT) & (cylinders$t.upp >= TT))

  # number of cylinders that include geo-coordinate of `case`
  in_cylinder = sum(in_circle * in_cylinder_height, na.rm=T)
  if (in_cylinder>0){
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height, na.rm=T)
    re = warning / in_cylinder
  }else{
    re = 0
  }
  return(re)
}


 # for clinic 1
r1=c(50,50)
c1=c(55,45)

# for clinic 2
r2=c(50,50)
c2=c(55,45)

# for clinic 3
r3=c(50,50)
c3=c(74,26)
nh=100
# The numerator of the CMH statistic
N=((40-((r1[1]*c1[1])/nh))+(35-((r2[1]*c2[1])/nh))+(43-((r3[1]*c3[1])/nh)))^2
print(N)

D=((r1[1]*r1[2]*c1[1]*c1[2])/(nh^2*(nh-1)))+((r2[1]*r2[2]*c2[1]*c2[2])/(nh^2*(nh-1)))+((r3[1]*r3[2]*c3[1]*c3[2])/(nh^2*(nh-1)))
print(D)

X2=N/D
print(X2)
# For df = 1, this result is significant at the p < .001 level. the drug-treated groups have consistently higher improvement rates than the placebo groups.


# https://github.com/ericgoolsby/Rphylopars/wiki

library(Rphylopars)
library(phytools) # for simulating pure-birth phylogenies
set.seed(21) # Set the seed for reproducible results
trait_cov <- matrix(c(4,2,2.2,2,3,1.5,2.2,1.5,2.5),nrow = 3,ncol = 3)
trait_cov # Phylogenetic trait covariance
tree <- pbtree(n = 20)
sim_data <- simtraits(v = trait_cov,tree = tree,nmissing = 10)

p_BM <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree)

sim_data$trait_data[,2:4]

p_BM$anc_recon[1:20,] # Data with imputed species means
p_BM$anc_var[1:20,] # Variances for each estimate
p_BM$anc_recon[1:20,] - sqrt(p_BM$anc_var[1:20,])*1.96 # Lower 95% CI
p_BM$anc_recon[1:20,] + sqrt(p_BM$anc_var[1:20,])*1.96 # Upper 95% CI

plot.phylo(reorder(tree,"postorder"))
nodelabels()

p_BM$anc_recon[21:39,] # Reconstructed ancestral states for each trait
p_BM$anc_var[21:39,] # Variances for each estimate
p_BM$anc_recon[21:39,] - sqrt(p_BM$anc_var[21:39,])*1.96 # Lower 95% CI
p_BM$anc_recon[21:39,] + sqrt(p_BM$anc_var[21:39,])*1.96 # Upper 95% CI

p_lambda <- phylopars(trait_data = sim_data$trait_data,
                      tree = sim_data$tree,model = "lambda")
p_lambda # Estimated trait covariance and Pagel's lambda

p_star <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "star")
p_star # Estimated trait covariance, fixed Pagel's lambda = 0

chi_square <- as.double(2*(logLik(p_lambda) - # 2*(logLik_alt - logLik_null)
                             logLik(p_star)))
degrees_freedom <- p_lambda$npars - p_star$npars # df = difference in # model parameters
pchisq(q = chi_square,df = degrees_freedom,lower.tail = FALSE) # p-value

p_OU <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "OU")
p_OU # Estimated trait covariance, OU alpha, and stationary covariance

p_EB <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "EB")
p_EB # Estimated trait covariance and EB rate parameter

AIC(p_BM)
AIC(p_OU)
AIC(p_EB)

BIC(p_BM)
BIC(p_OU)
BIC(p_EB)


####################################################################
###         use apply, lapply, sapply, tapply and by             ###
####################################################################

# create some data of particular class ==========================================================

### a data frame
my.data.frame <- as.data.frame(matrix(sample(size = 500, x = 1:10, replace = T),
                                      ncol = 5)
)
colnames(my.data.frame) <- letters[1:dim(my.data.frame)[2]]

### a vector
my.vector <- my.data.frame[, 1]

### a list
my.list <- as.list(c(my.data.frame, my.data.frame, my.data.frame))

# use the different function to repeat an action over dimensions ======================================================

# mean per column for dataframe
mean.colums.df <- apply(my.data.frame, MARGIN = 2,
                        FUN = mean)

# print quantiles per columns
apply(my.data.frame, MARGIN = 2,
      FUN = quantile, probs = c(0.20, 0.45, 0.65))

### lapply and sapply for mean over elements of list
lapply(my.list, FUN = mean)
sapply(my.list, FUN = sd)

# by and tapply to repeat accross levels =================================================================

# add variable of class factor to my.data.frame
my.data.frame$fac1 <- sample(size = dim(my.data.frame)[1],
                             c('level1', 'level2'), replace = TRUE)
my.data.frame$fac1 <- as.factor(my.data.frame$fac1)

# add second variable of class factor to my.data.frame
my.data.frame$fac2 <- sample(size = dim(my.data.frame)[1],
                             c('factor1', 'factor2'), replace = TRUE)
my.data.frame$fac2 <- as.factor(my.data.frame$fac2)

# use by to compute some mean
by(data = my.data.frame$a,
   INDICES = list(my.data.frame$fac1, my.data.frame$fac2),
   FUN = mean)

# use tapply
#tapply(X = my.data.frame$a,
#       INDEX = list(my.data.frame$fac1, my.data.frame$fac2),
#       FUN = mean)


#Working directory changed to remove name of file
setwd("C:/Users/-------")

#OLD
a<-Sys.time()
data<-read.csv("PokerRingSlim.csv",header=T)
data<-data[,-c(1)]
list<-which(duplicated(data$Round_ID))
data2<-data[-list,]
write.csv(data2,"pokerRingSlimUnique.csv",row.names=F)
b<-Sys.time()
b-a
rm(b,a,list)

data<-read.csv("PokerRingSlimUnique.csv",header=T)
noblank<-data[-which(data$TableCards==""),]
write.csv(noblank,"noblanks.csv",row.names=F)
table<-as.data.frame(noblank$TableCards)
colnames(table)<-c("TableCards")

write.csv(table,"TableCards.csv",row.names=F)
write.table(table,"Table.txt",row.names=F)
####END OLD####

###START ANALYSIS###
cards<-read.csv("SepTableCards.csv",header=T)
flop<-cards[,-c(1,5,6)]
adjust<-(flop-1)%%13
write.csv(adjust,"AdjustedFlop.csv",row.names=F)

pair<-function(x,y,z){if(x==y||x==z||y==z){return(T)}else{return(F)}}

##Test small sample to make sure working correctly
test<-head(adjust,100)
test1<-data.frame(apply(test, 1,function(x) pair(x[1],x[2],x[3])))
colnames(test1)<-c("IsPair")
comb<-cbind(test,test1)
comb2<-cbind(head(flop,100),comb)
p<-which(test1==T);np<-which(test1==F)
P.pair<-length(p)/(length(p)+length(np))
P.pair ## =0.15
##End, back to full analysis

ispair<-data.frame(apply(adjust,1,function(x) pair(x[1],x[2],x[3])))
colnames(ispair)<-c("IsPair")
p<-which(ispair==T);np<-which(ispair==F)
p.pair<-length(p)/(length(p)+length(np))
p.pair

##Function to partition data and cound pairs/non-pairs
part<-function(x,y){
  temp.p<-length(which(ispair[x:y,1]==T))
  temp.np<-length(which(ispair[x:y,1]==F))
  df<-data.frame(x1<-temp.p,x2<-temp.np)
  colnames(df)<-c("Pair","NoPair")
  return(df)
}

n<-10000
m<-floor(length(ispair$IsPair)/n)
for(i in 1:m){
  min<-(i-1)*n+1
  max<-i*n
  partition<-part(min,max)
  if(i==1){
	samp<-partition}
  else{
	samp<-rbind(samp,partition)}
}

prop<-data.frame(apply(samp,1,function(x) (x[1]/(x[1]+x[2]))))

plot(prop[,1],xlab="Sample",ylab="Prop of Pair",main="Scatter Plot of Proportion of Pairs on the Flop(10,000 per sample)")

###Test using patrons sample size
n<-3000
m<-floor(length(ispair$IsPair)/n)
for(i in 1:m){
  min<-(i-1)*n+1
  max<-i*n
  partition<-part(min,max)
  if(i==1){
	samp<-partition}
  else{
	samp<-rbind(samp,partition)}
}

prop<-data.frame(apply(samp,1,function(x) (x[1]/(x[1]+x[2]))))
test<-t.test(prop[,1],mu=0.1718,conf.level=.95)
test

plot(prop[,1],xlab="Sample",ylab="Prop of Pair",main="Scatter Plot of Proportion of Pairs on the Flop(3,000 per sample)")

##Random samples of 3,000
s<-3000
n<-1000
for(i in 1:n){
  x<-sample(ispair[,1],s)
  a<-length(which(x==T))
  b<-length(which(x==F))
  partition<-data.frame(x1<-a,x2<-b)
  colnames(dt)<-c("Pair","NoPar")
  if(i==1){
	samp<-partition}
  else{
	samp<-rbind(samp,partition)}
}

prop<-data.frame(apply(samp,1,function(x) (x[1]/(x[1]+x[2]))))
test<-t.test(prop[,1],mu=0.1718,conf.level=.95)
test
plot(prop[,1],xlab="Sample",ylab="Prop of Pair",main="Scatter Plot of Proportion of Pairs on the Flop(3,000 per random sample)")

##Random samples of 10,000
s<-10000
n<-1000
for(i in 1:n){
  x<-sample(ispair[,1],s)
  a<-length(which(x==T))
  b<-length(which(x==F))
  partition<-data.frame(x1<-a,x2<-b)
  colnames(dt)<-c("Pair","NoPar")
  if(i==1){
	samp<-partition}
  else{
	samp<-rbind(samp,partition)}
}

prop<-data.frame(apply(samp,1,function(x) (x[1]/(x[1]+x[2]))))
test<-t.test(prop[,1],mu=0.1718,conf.level=.95)
test
plot(prop[,1],xlab="Sample",ylab="Prop of Pair",main="Scatter Plot of Proportion of Pairs on the Flop(10,000 per random sample)")


=begin
[((<index-ja|URL:index-ja.html>))]
= Algebra::ResidueClassRing
((*(剰余環クラス)*))

環からその1つの元を法とした剰余環を構成します。実際のクラスを生成するには環
と法とを指定して、クラスメソッド ((<::create>)) あるいは
関数 ((<Algebra.ResidueClassRing>))() を用います。

== ファイル名:
* ((|residue-class-ring.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

なし

== 関連する関数:

--- Algebra.ResidueClassRing(ring, mod)
    ((<::create>))(ring, mod) と同じです。

== クラスメソッド:

--- ::create(ring, mod)

    クラス ((|ring|)) で表現されるを環とその環の元 ((|mod|)) から、
    その元を法とした剰余環を表現するクラスを返します。

    この戻り値は ((<Algebra::ResidueClassRing>)) クラスのサブクラスです。
    このサブクラスにはクラスメソッドとして ((|::ground|)) と
    ((|::modulus|)) と (({[x]})) が定義され、それぞれ、基礎環 ((|ring|))、
    法 ((|mod|))、x を代表元とする剰余類を返します。

    例: 多項式環を法 (({x**2 + x + 1})) で割る。
      require "rational"
      require "polynomial"
      require "residue-class-ring"
      Px = Algebra.Polynomial(Rational, "x")
      x = Px.var
      F = Algebra.ResidueClassRing(Px, x**2 + x + 1)
      p F[x + 1]**100     #=> -x - 1

    ((|ring|)) が Integer である場合に限り、全ての逆数を予め計算して
    保管します。また (({0, 1, ... , mod-1})) に対応する剰余類の配列を
    ((|to_ary|)) で得ることができます。

    例: modulo 7 の素体
      require "residue-class-ring"
      F7 = Algebra::ResidueClassRing.create(Integer, 7)
      a, b, c, d, e, f, g = F7
      p [e + c, e - c, e * c, e * 2001, 3 + c, 1/c, 1/c * c]
        #=> [6, 2, 1, 3, 5, 4, 1]
      p( (1...7).collect{|i| F7[i]**6} )
        #=> [1, 1, 1, 1, 1, 1]

--- ::[](x)
    ((|x|)) で代表される剰余類を返します。

#--- ::indeterminate(obj)

--- ::zero
    零元を返します。

--- ::unity
    単位元を返します。

== メソッド:

--- lift
    剰余類の代表元を返します。

#--- monomial?

--- zero?
    零元であるとき真を返します。

--- zero
    零元を返します。

--- unity
    単位元を返します。

--- ==(other)
    等しいとき真を返します。

--- +(other)
    和を計算します。

--- -(other)
    差を計算します。

--- *(other)
    積を計算します。

--- **(n)
    ((|n|)) 乗を計算します。

--- /(other)
    ((<inverse>)) を利用して商を計算します。

--- inverse
    基礎環がユークリッド環であることを仮定して、逆数を返します。
    逆数が存在しない場合の値は nil です。

#--- to_s

=end


# Data Preprocessing Template.
#
# This is a file that I use as a template for data pre-processing in Machine
# learning projects. After a while I figured out it might be easier to have it as
# a reference. And to save time.

# Importing the data set
dataset = read.csv('data/Data.csv')

# Dealing with missing data
dataset$Age = ifelse(is.na(dataset$Age), ave(dataset$Age,
                     FUN = function(x) mean(x, na.rm = TRUE)), dataset$Age)
dataset$Salary = ifelse(is.na(dataset$Salary), ave(dataset$Salary,
                        FUN = function(x) mean(x, na.rm = TRUE)), dataset$Salary)

# Encode categorical data and make them into numeric categories.
dataset$Country = factor(dataset$Country, levels = c('France', 'Spain', 'Germany'),
                         labels = c(1,2,3))
dataset$Purchased = factor(dataset$Purchased,
                           levels = c('No', 'Yes'),
                           labels = c(0,1))

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Purchased, SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Feature scaling, normalize scale is important. Especially on algorithms
# involving euclidian distance. Two main feature scaling formulas are:
# Standardisation: x_stand = (x-mean(x))/(standard_deviation(x))
# Normalisation: x_norm = (x-min(x))/(max(x)-min(x))
training_set[, 2:3] = scale(training_set[, 2:3])
test_set[, 2:3] = scale(test_set[, 2:3])


#
dat$fw = dat$tc - dat$hdl - 0.2*dat$tg

tc = dat$tc
hdl = dat$hdl
tg = dat$tg
a = tc/0.948
b = hdl/0.971
c1 = tg/8.56
c2 = tg*(tc - hdl)/2140
c3 = tg*tg/16100
c = c1 + c2 - c3
dat$nih = a - b - c - 9.44