covZ <- function(t_seq, Y, C, sigma2)
{
  #########################################################################
  #     covZ: calculate the covariance matrix of paired-y product
  #
  #     Input
  #     t_seq: defined grid point m-by-1
  #     Y: response vector m-by-1
  #     C: covariance matrix of X m-by-m
  #     sigma2: variance of random error
  #
  #     Output
  #     CovZZ: covariance matrix of paired-y product m^2-by-m^2
  #     Z.info: vectorized Z.tri and  the corresponding grid points
  #     Z.tri: upper triangle matrix of paired-y product m-by-m
  #
  #########################################################################
  temp <- expand.grid(Y,Y)
  t.pair <- expand.grid(t_seq,t_seq)
  d <- length(Y)
  id <- expand.grid(1:d,1:d)
  m <- d

  Z <- apply(temp, 1, function(z) prod(z))
  Z.info <- as.matrix(cbind(Z,t.pair,id))
  Z.info <- Z.info[Z.info[,5] <= Z.info[,4],]

#   Z.mat <- matrix(Z,nrow=length(Y),ncol=length(Y),byrow=T)
#   Z.tri <- Z.mat
#   Z.tri[lower.tri(Z.tri)] <- NA

  Z.tri <- matrix(NA,nrow=length(Y),ncol=length(Y))
  Z.tri[lower.tri(Z.tri, diag=T)] <- Z.info[,1]
  Z.tri <- t(Z.tri)

  # Quick-n-dirty implementation (for testing only)
#   CovZZ <- matrix(NA,nrow=length(Z),ncol=length(Z))
#   time.start <- proc.time()
#   for (i in 1:m)
#   {
#     for (j in 1:m)
#     {
#       row.id <- d * (i - 1) + j
#       for (k in 1:m)
#       {
#         for (l in 1:m)
#         {
#           col.id <- d * (k - 1) + l
#           if (row.id <= col.id)
#           {
#             CovZZ[row.id,col.id] = C[i,k] * C[j,l] + C[i,l] * C[j,k] +
#               (i==k) * (j==l) *sigma2^2 + (i==l) * (j==k) *sigma2^2 +
#               (C[i,k] * (j==l) + C[i,l] * (j==k) + C[j,k] * (i==l)
#                + C[j,l] * (i==k)) * sigma2
#           }
#
#         }
#       }
#     }
#   }
#   print((proc.time()-time.start)[3])
#
#   # Avoid loops (even slower, for testing only)
#   time.start <- proc.time()
#   id1 <- as.matrix(expand.grid(1:d,1:d,1:d,1:d))
#   id2 <- as.matrix(expand.grid(1:d^2,1:d^2))
#   id.tab <- as.matrix(cbind(id1,id2))
#   id.tab <- id.tab[id.tab[,5] <= id.tab[,6],]
#   CovZZ2.vec = apply(id.tab,1,function(x)
#     C[x[2],x[4]] * C[x[1],x[3]] + C[x[2],x[3]] * C[x[1],x[4]] +
#     (x[2]==x[4]) * (x[1]==x[3]) *sigma2^2 +
#     (x[2]==x[3]) * (x[1]==x[4]) *sigma2^2 +
#     (C[x[2],x[4]] * (x[1]==x[3]) + C[x[2],x[3]] * (x[1]==x[4]) +
#        C[x[1],x[4]] * (x[2]==x[3]) + C[x[1],x[3]] * (x[2]==x[4])) * sigma2)
#
#   CovZZ2 <- matrix(NA,nrow=length(Z),ncol=length(Z))
#   CovZZ2[upper.tri(CovZZ2, diag=T)] <- CovZZ2.vec
#   print((proc.time()-time.start)[3])

  # Alternative vectorizing
  #time.start <- proc.time()
  id1 <- as.matrix(expand.grid(1:d,1:d,1:d,1:d))
  id2 <- as.matrix(expand.grid(1:d^2,1:d^2))
  id.tab <- as.matrix(cbind(id1,id2))
  id.tab <- id.tab[id.tab[,5] <= id.tab[,6],] # symmetric
  # kronecker delta terms
  # \delta_{jk},\delta_{j'k'},\delta_{jk'},\delta_{j'k}
  k.del <- cbind(id.tab[,1]==id.tab[,3],id.tab[,2]==id.tab[,4],
                 id.tab[,1]==id.tab[,4],id.tab[,2]==id.tab[,3])
  # Cov operator terms
  # C_{jk},C_{j'k'},C_{jk'},C_{j'k}
  c.term <- cbind(C[cbind(id.tab[,1],id.tab[,3])],
                  C[cbind(id.tab[,2],id.tab[,4])],
                  C[cbind(id.tab[,1],id.tab[,4])],
                  C[cbind(id.tab[,2],id.tab[,3])])
  # Form a matrix with pre-calculated terms
  id.tab <- cbind(id.tab,k.del,c.term)
  # CovZZ = C_{jk}C_{j'k'} + C_{jk'}C_{j'k}
  # + (\delta_{jk}\delta_{j'k'} + \delta_{jk'}\delta_{j'k})\sigma_2^2 +
  # (C_{jk}\delta_{j'k'} + C_{jk'}\delta_{j'k} + C_{j'k}\delta_{jk'} +
  # C_{j'k'}\delta_{jk})\sigma_2
  CovZZ3.vec = id.tab[,12] * id.tab[,11] + id.tab[,14] * id.tab[,13] +
      (id.tab[,8] * id.tab[,7] + id.tab[,10] * id.tab[,9]) *sigma2^2 +
      (id.tab[,12] * id.tab[,7] + id.tab[,14] * id.tab[,9] +
         id.tab[,13] * id.tab[,10] + id.tab[,11] * id.tab[,8]) * sigma2
  # CovZZ.vec = vech(CovZZ)
  CovZZ3 <- matrix(NA,nrow=length(Z),ncol=length(Z))
  CovZZ3[upper.tri(CovZZ3, diag=T)] <- CovZZ3.vec
  #print((proc.time()-time.start)[3])

  return (list(CovZZ = CovZZ3,CovZZ.vech = CovZZ3.vec,
               Z.info = Z.info,Z.tri = Z.tri))

}


# set working directory
dir = paste(getwd(),'/datafiles/',sep="")
setwd(dir)

# load packages
library(reshape2)
library(ggplot2)
library(lme4)
library(rstan)
library(loo)
library(plyr)
library(ggsignif)

# EXPERIMENT 1

# load data (no NANs)
memory <- read.csv("exp1_old") # just old items

# prepare data
nSubj<-length(unique(memory$subj_idx))

subs = unique(memory$subj_idx)
nTrials = as.data.frame(table(memory$subj_idx))
nTrials = nTrials$Freq
maxTrials = max(nTrials)

cue<-array(0,c(nSubj,maxTrials)) # binary (1,0: cue event or not)
out<-array(0,c(nSubj,maxTrials)) # binary (1,0: outcome event or not)
reward<-array(0,c(nSubj,maxTrials))
estimate<-array(0,c(nSubj,maxTrials))
out_absPE<-array(0,c(nSubj,maxTrials))
out_PE<-array(0,c(nSubj,maxTrials))
confHit<-array(0,c(nSubj,maxTrials))
trialNumLearn<-array(0,c(nSubj,maxTrials))

for (i in 1:nSubj) {
    cue[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$cueD;
    out[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$outD;
    reward[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$reward;
    estimate[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$estimate;
    out_absPE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$out_absPE;
    out_PE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$out_PE;
    confHit[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$confHit;
    trialNumLearn[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$trialNumLearn;
}

# data structure
standata = list(nSubj=nSubj, nTrials=nTrials, maxTrials=maxTrials, out=out, cue=cue, reward=reward, estimate=estimate, out_absPE=out_absPE, out_PE=out_PE, confHit=confHit, trialNumLearn=trialNumLearn)

# run model
options(mc.cores = parallel::detectCores())
fit<- stan(file = 'memory_exp1.stan', data = standata, iter = 1500, warmup=500, chains = 4)

# EXPERIMENT 2

# load data (no NANs)
memory <- read.csv("exp2_old") # just old items (explicit and implicit memory version run separately)

# prepare data
nSubj<-length(unique(memory$subj_idx))

subs = unique(memory$subj_idx)
nTrials = as.data.frame(table(memory$subj_idx))
nTrials = nTrials$Freq
maxTrials = max(nTrials)

cue<-array(0,c(nSubj,maxTrials)) # binary (1,0: cue event or not)
out<-array(0,c(nSubj,maxTrials)) # binary (1,0: outcome event or not)
reward<-array(0,c(nSubj,maxTrials))
estimate<-array(0,c(nSubj,maxTrials))
out_absPE<-array(0,c(nSubj,maxTrials))
out_PE<-array(0,c(nSubj,maxTrials))
confHit<-array(0,c(nSubj,maxTrials))
cue_absPE<-array(0,c(nSubj,maxTrials))
cue_PE<-array(0,c(nSubj,maxTrials))
trialNumLearn<-array(0,c(nSubj,maxTrials))

for (i in 1:nSubj) {
  cue[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$cueD;
  out[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$outD;
  reward[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$reward;
  estimate[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$estimate;
  out_absPE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$out_absPE;
  out_PE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$out_PE;
  confHit[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$confHit;
  cue_absPE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$cue_absPE;
  cue_PE[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$cue_PE;
  trialNumLearn[i,1:nTrials[i]] = subset(memory,subj_idx==subs[i])$trialNumLearn;
}

# data structure
standata = list(nSubj=nSubj, nTrials=nTrials, maxTrials=maxTrials, out=out, cue=cue, reward=reward, estimate=estimate, out_absPE=out_absPE, out_PE=out_PE, confHit=confHit, cue_absPE=cue_absPE, cue_PE=cue_PE, trialNumLearn=trialNumLearn)

# run model
options(mc.cores = parallel::detectCores())
fit<- stan(file = 'memory_exp2.stan', data = standata, iter = 1500, warmup=500, chains = 4)


source("ac_powerflow_lib.r")

ac_powerflow("ac_powerflow_transmission.pdf")
ac_powerloss("ac_powerloss_transmission.pdf")
ac_dc_comparison("ac_dc_active_powerflow_transmission.pdf")

ac_powerflow("ac_powerflow_distribution.pdf", y_a = -0.785398)
ac_powerloss("ac_powerloss_distribution.pdf", y_a = -0.785398)


library(car)
library(phia)
library(ez)
library(lsr)
library(ggplot2)
library(grid)
library(lsmeans)
library(gridExtra)
library(coin)

source("src/data.r")

ldData <- read.csv(file = "data/lightdark.csv", na.strings = c("NA", "-999"), stringsAsFactors=FALSE)
ldData <- ldClean(ldData)

ldDataPre <- subset(ldData, Time == "PRE")
ldDataPost <- subset(ldData, Time == "POST")

########################
# Analysis - Pre-Puberty
########################

ldMalePre <- subset(ldDataPre, ldDataPre$Sex == "M")
ldFemalePre <- subset(ldDataPre, ldDataPre$Sex == "F")

ldTestPre <- subset(ldDataPre, ldDataPre$Treatment == "D")
ldControlPre <- subset(ldDataPre, ldDataPre$Treatment == "C")

nrow(subset(ldMalePre, ldMalePre$Treatment == "D"))
nrow(subset(ldMalePre, ldMalePre$Treatment == "C"))

nrow(subset(ldFemalePre, ldFemalePre$Treatment == "D"))
nrow(subset(ldFemalePre, ldFemalePre$Treatment == "C"))

qqnorm(ldDataPre$Light_ENTRIES_W)
qqnorm(ldDataPre$Light_DURATION_W)
qqnorm(ldDataPre$Light_LATENCY_W)
qqnorm(ldDataPre$Light_HACTV_W)
qqnorm(ldDataPre$Light_ENTRIES_W_1MIN)
qqnorm(ldDataPre$Light_DURATION_W_1MIN)

# horizontal activity
preHActModel <- lm(HACTV ~ Treatment * Sex, data = ldDataPre)
Anova(preHActModel)

t.test(HACTV ~ Treatment, data = ldMalePre)
cohensD(HACTV ~ Treatment, data = ldMalePre)
t.test(HACTV ~ Treatment, data = ldFemalePre)
cohensD(HACTV ~ Treatment, data = ldFemalePre)

t.test(HACTV ~ Sex, data = ldTestPre)
cohensD(HACTV ~ Sex, data = ldTestPre)
t.test(HACTV ~ Sex, data = ldControlPre)
cohensD(HACTV ~ Sex, data = ldControlPre)

# latency
preLatencyModel <- lm(Light_LATENCY_W ~ Treatment * Sex, data = ldDataPre)
Anova(preLatencyModel)

wilcox.test(Light_LATENCY_W ~ Treatment, data = ldMalePre)
wTest <- wilcox_test(Light_LATENCY_W ~ Treatment, data = ldMalePre, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(ldMalePre))
wilcox.test(Light_LATENCY_W ~ Treatment, data = ldFemalePre)
wTest <- wilcox_test(Light_LATENCY_W ~ Treatment, data = ldFemalePre, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(ldFemalePre))

wilcox.test(Light_LATENCY_W ~ Sex, data = ldTestPre)
wTest <- wilcox_test(Light_LATENCY_W ~ Sex, data = ldTestPre, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(ldTestPre))
wilcox.test(Light_LATENCY_W ~ Sex, data = ldControlPre)
wTest <- wilcox_test(Light_LATENCY_W ~ Sex, data = ldControlPre, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(ldControlPre))

# total entries

preEntriesModel <- lm(Light_ENTRIES_W ~ Treatment * Sex, data = ldDataPre)
Anova(preEntriesModel)

t.test(Light_ENTRIES_W ~ Treatment, data = ldMalePre)
cohensD(Light_ENTRIES_W ~ Treatment, data = ldMalePre)
t.test(Light_ENTRIES_W ~ Treatment, data = ldFemalePre)
cohensD(Light_ENTRIES_W ~ Treatment, data = ldFemalePre)

t.test(Light_ENTRIES_W ~ Sex, data = ldTestPre)
cohensD(Light_ENTRIES_W ~ Sex, data = ldTestPre)
t.test(Light_ENTRIES_W ~ Sex, data = ldControlPre)
cohensD(Light_ENTRIES_W ~ Sex, data = ldControlPre)

# 1 min entries
preEntries1MinModel <- lm(Light_ENTRIES_W_1MIN ~ Treatment * Sex, data = ldDataPre)
Anova(preEntries1MinModel)

t.test(Light_ENTRIES_W_1MIN ~ Treatment, data = ldMalePre)
cohensD(Light_ENTRIES_W_1MIN ~ Treatment, data = ldMalePre)
t.test(Light_ENTRIES_W_1MIN ~ Treatment, data = ldFemalePre)
cohensD(Light_ENTRIES_W_1MIN ~ Treatment, data = ldFemalePre)

t.test(Light_ENTRIES_W_1MIN ~ Sex, data = ldTestPre)
cohensD(Light_ENTRIES_W_1MIN ~ Sex, data = ldTestPre)
t.test(Light_ENTRIES_W_1MIN ~ Sex, data = ldControlPre)
cohensD(Light_ENTRIES_W_1MIN ~ Sex, data = ldControlPre)

# total duration
preDurationModel <- lm(Light_DURATION_W ~ Treatment * Sex, data = ldDataPre)
Anova(preDurationModel)

t.test(Light_DURATION_W ~ Treatment, data = ldMalePre)
cohensD(Light_DURATION_W ~ Treatment, data = ldMalePre)
t.test(Light_DURATION_W ~ Treatment, data = ldFemalePre)
cohensD(Light_DURATION_W ~ Treatment, data = ldFemalePre)

t.test(Light_DURATION_W ~ Sex, data = ldTestPre)
cohensD(Light_DURATION_W ~ Sex, data = ldTestPre)
t.test(Light_DURATION_W ~ Sex, data = ldControlPre)
cohensD(Light_DURATION_W ~ Sex, data = ldControlPre)

# 1 min duration
preDuration1MinModel <- lm(Light_DURATION_W_1MIN ~ Treatment * Sex, data = ldDataPre)
Anova(preDuration1MinModel)

t.test(Light_DURATION_W_1MIN ~ Treatment, data = ldMalePre)
cohensD(Light_DURATION_W_1MIN ~ Treatment, data = ldMalePre)
t.test(Light_DURATION_W_1MIN ~ Treatment, data = ldFemalePre)
cohensD(Light_DURATION_W_1MIN ~ Treatment, data = ldFemalePre)

t.test(Light_DURATION_W_1MIN ~ Sex, data = ldTestPre)
cohensD(Light_DURATION_W_1MIN ~ Sex, data = ldTestPre)
t.test(Light_DURATION_W_1MIN ~ Sex, data = ldControlPre)
cohensD(Light_DURATION_W_1MIN ~ Sex, data = ldControlPre)

#########################
# Analysis - Post-Puberty
#########################

femaleControlSham <- subset(subset(subset(ldDataPost, Gonad == "SHAM"), Sex == "F"), Treatment == "C")
femaleControlRep <- subset(subset(subset(ldDataPost, Gonad == "REP"), Sex == "F"), Treatment == "C")
femaleControlGdx <- subset(subset(subset(ldDataPost, Gonad == "GDX"), Sex == "F"), Treatment == "C")

maleControlSham <- subset(subset(subset(ldDataPost, Gonad == "SHAM"), Sex == "M"), Treatment == "C")
maleControlRep <- subset(subset(subset(ldDataPost, Gonad == "REP"), Sex == "M"), Treatment == "C")
maleControlGdx <- subset(subset(subset(ldDataPost, Gonad == "GDX"), Sex == "M"), Treatment == "C")

femaleTestSham <- subset(subset(subset(ldDataPost, Gonad == "SHAM"), Sex == "F"), Treatment == "D")
femaleTestRep <- subset(subset(subset(ldDataPost, Gonad == "REP"), Sex == "F"), Treatment == "D")
femaleTestGdx <- subset(subset(subset(ldDataPost, Gonad == "GDX"), Sex == "F"), Treatment == "D")

maleTestSham <- subset(subset(subset(ldDataPost, Gonad == "SHAM"), Sex == "M"), Treatment == "D")
maleTestRep <- subset(subset(subset(ldDataPost, Gonad == "REP"), Sex == "M"), Treatment == "D")
maleTestGdx <- subset(subset(subset(ldDataPost, Gonad == "GDX"), Sex == "M"), Treatment == "D")

# sample size
nrow(femaleControlSham)
nrow(femaleControlRep)
nrow(femaleControlGdx)

nrow(maleControlSham)
nrow(maleControlRep)
nrow(maleControlGdx)

nrow(femaleTestSham)
nrow(femaleTestRep)
nrow(femaleTestGdx)

nrow(maleTestSham)
nrow(maleTestRep)
nrow(maleTestGdx)

# assumptions

qqnorm(ldDataPost$Light_ENTRIES_W)
qqnorm(ldDataPost$Light_DURATION_W)
qqnorm(ldDataPost$Light_LATENCY_W)
qqnorm(ldDataPost$Light_HACTV_W)
qqnorm(ldDataPost$Light_ENTRIES_W_1MIN)
qqnorm(ldDataPost$Light_DURATION_W_1MIN)

### horizontal activity

# main model
postHActModel <- lm(HACTV ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postHActModel)

# planned comparisons - hormone condition
t.test(femaleControlSham$HACTV, femaleControlGdx$HACTV) # sham - gdx
cohensD(femaleControlSham$HACTV, femaleControlGdx$HACTV)
t.test(femaleControlGdx$HACTV, femaleControlRep$HACTV) # rep - gdx
cohensD(femaleControlGdx$HACTV, femaleControlRep$HACTV)

t.test(femaleTestSham$HACTV, femaleTestGdx$HACTV)
cohensD(femaleTestSham$HACTV, femaleTestGdx$HACTV)
t.test(femaleTestGdx$HACTV, femaleTestRep$HACTV)
cohensD(femaleTestGdx$HACTV, femaleTestRep$HACTV)

t.test(maleControlSham$HACTV, maleControlGdx$HACTV)
cohensD(maleControlSham$HACTV, maleControlGdx$HACTV)
t.test(maleControlGdx$HACTV, maleControlRep$HACTV)
cohensD(maleControlGdx$HACTV, maleControlRep$HACTV)

t.test(maleTestSham$HACTV, maleTestGdx$HACTV)
cohensD(maleTestSham$HACTV, maleTestGdx$HACTV)
t.test(maleTestGdx$HACTV, maleTestRep$HACTV)
cohensD(maleTestGdx$HACTV, maleTestRep$HACTV)

# planned comparisons - male to female
t.test(femaleControlSham$HACTV, maleControlSham$HACTV)
cohensD(femaleControlSham$HACTV, maleControlSham$HACTV)
t.test(femaleControlRep$HACTV, maleControlRep$HACTV)
cohensD(femaleControlRep$HACTV, maleControlRep$HACTV)
t.test(femaleControlGdx$HACTV, maleControlGdx$HACTV)
cohensD(femaleControlGdx$HACTV, maleControlGdx$HACTV)

t.test(femaleTestSham$HACTV, maleTestSham$HACTV)
cohensD(femaleTestSham$HACTV, maleTestSham$HACTV)
t.test(femaleTestRep$HACTV, maleTestRep$HACTV)
cohensD(femaleTestRep$HACTV, maleTestRep$HACTV)
t.test(femaleTestGdx$HACTV, maleTestGdx$HACTV)
cohensD(femaleTestGdx$HACTV, maleTestGdx$HACTV)

# planned comparisons - test to control
t.test(femaleControlSham$HACTV, femaleTestSham$HACTV)
cohensD(femaleControlSham$HACTV, femaleTestSham$HACTV)
t.test(femaleControlRep$HACTV, femaleTestRep$HACTV)
cohensD(femaleControlRep$HACTV, femaleTestRep$HACTV)
t.test(femaleControlGdx$HACTV, femaleTestGdx$HACTV)
cohensD(femaleControlGdx$HACTV, femaleTestGdx$HACTV)

t.test(maleControlSham$HACTV, maleTestSham$HACTV)
cohensD(maleControlSham$HACTV, maleTestSham$HACTV)
t.test(maleControlRep$HACTV, maleTestRep$HACTV)
cohensD(maleControlRep$HACTV, maleTestRep$HACTV)
t.test(maleControlGdx$HACTV, maleTestGdx$HACTV)
cohensD(maleControlGdx$HACTV, maleTestGdx$HACTV)

### latency - must use non parametric tests

# main model
postLatencyModel <- lm(Light_LATENCY_W ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postLatencyModel)

# planned comparisons - gonad
wilcox.test(femaleControlSham$Light_LATENCY_W, femaleControlGdx$Light_LATENCY_W)
wilcox.test(femaleControlGdx$Light_LATENCY_W, femaleControlRep$Light_LATENCY_W)

wilcox.test(femaleTestSham$Light_LATENCY_W, femaleTestGdx$Light_LATENCY_W)
wilcox.test(femaleTestGdx$Light_LATENCY_W, femaleTestRep$Light_LATENCY_W)

wilcox.test(maleControlSham$Light_LATENCY_W, maleControlGdx$Light_LATENCY_W)
testData <- rbind(maleControlSham, maleControlGdx)
wTest <- wilcox_test(Light_LATENCY_W ~ Gonad, data = testData, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(testData))
wilcox.test(maleControlGdx$Light_LATENCY_W, maleControlRep$Light_LATENCY_W)

wilcox.test(maleTestSham$Light_LATENCY_W, maleTestGdx$Light_LATENCY_W)
wilcox.test(maleTestGdx$Light_LATENCY_W, maleTestRep$Light_LATENCY_W)

# planned comparisons - male to female
wilcox.test(femaleControlSham$Light_LATENCY_W, maleControlSham$Light_LATENCY_W)
testData <- rbind(femaleControlSham, maleControlSham)
wTest <- wilcox_test(Light_LATENCY_W ~ Sex, data = testData, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(testData))
wilcox.test(femaleControlRep$Light_LATENCY_W, maleControlRep$Light_LATENCY_W)
wilcox.test(femaleControlGdx$Light_LATENCY_W, maleControlGdx$Light_LATENCY_W)

wilcox.test(femaleTestSham$Light_LATENCY_W, maleTestSham$Light_LATENCY_W)
testData <- rbind(femaleTestSham, maleTestSham)
wTest <- wilcox_test(Light_LATENCY_W ~ Sex, data = testData, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(testData))
wilcox.test(femaleTestRep$Light_LATENCY_W, maleTestRep$Light_LATENCY_W)
testData <- rbind(femaleTestRep, maleTestRep)
wTest <- wilcox_test(Light_LATENCY_W ~ Sex, data = testData, exact = T)
wTest
wTest@statistic@teststatistic / sqrt(nrow(testData))
wilcox.test(femaleTestGdx$Light_LATENCY_W, maleTestGdx$Light_LATENCY_W)

# planned comparisons - test to control
wilcox.test(femaleControlSham$Light_LATENCY_W, femaleTestSham$Light_LATENCY_W)
wilcox.test(femaleControlRep$Light_LATENCY_W, femaleTestRep$Light_LATENCY_W)
wilcox.test(femaleControlGdx$Light_LATENCY_W, femaleTestGdx$Light_LATENCY_W)

wilcox.test(maleControlSham$Light_LATENCY_W, maleTestSham$Light_LATENCY_W)
wilcox.test(maleControlRep$Light_LATENCY_W, maleTestRep$Light_LATENCY_W)
wilcox.test(maleControlGdx$Light_LATENCY_W, maleTestGdx$Light_LATENCY_W)

### light entries

# main model
postEntriesModel <- lm(Light_ENTRIES_W ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postEntriesModel)

# planned comparisons - gonad
t.test(femaleControlSham$Light_ENTRIES_W, femaleControlGdx$Light_ENTRIES_W)
cohensD(femaleControlSham$Light_ENTRIES_W, femaleControlGdx$Light_ENTRIES_W)
t.test(femaleControlGdx$Light_ENTRIES_W, femaleControlRep$Light_ENTRIES_W)
cohensD(femaleControlGdx$Light_ENTRIES_W, femaleControlRep$Light_ENTRIES_W)

t.test(femaleTestSham$Light_ENTRIES_W, femaleTestGdx$Light_ENTRIES_W)
cohensD(femaleTestSham$Light_ENTRIES_W, femaleTestGdx$Light_ENTRIES_W)
t.test(femaleTestGdx$Light_ENTRIES_W, femaleTestRep$Light_ENTRIES_W)
cohensD(femaleTestGdx$Light_ENTRIES_W, femaleTestRep$Light_ENTRIES_W)

t.test(maleControlSham$Light_ENTRIES_W, maleControlGdx$Light_ENTRIES_W)
cohensD(maleControlSham$Light_ENTRIES_W, maleControlGdx$Light_ENTRIES_W)
t.test(maleControlGdx$Light_ENTRIES_W, maleControlRep$Light_ENTRIES_W)
cohensD(maleControlGdx$Light_ENTRIES_W, maleControlRep$Light_ENTRIES_W)

t.test(maleTestSham$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)
cohensD(maleTestSham$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)
t.test(maleTestGdx$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)
cohensD(maleTestGdx$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)

# planned comparisons - male to female
t.test(femaleControlSham$Light_ENTRIES_W, maleControlSham$Light_ENTRIES_W)
cohensD(femaleControlSham$Light_ENTRIES_W, maleControlSham$Light_ENTRIES_W)
t.test(femaleControlRep$Light_ENTRIES_W, maleControlRep$Light_ENTRIES_W)
cohensD(femaleControlRep$Light_ENTRIES_W, maleControlRep$Light_ENTRIES_W)
t.test(femaleControlGdx$Light_ENTRIES_W, maleControlGdx$Light_ENTRIES_W)
cohensD(femaleControlGdx$Light_ENTRIES_W, maleControlGdx$Light_ENTRIES_W)

t.test(femaleTestSham$Light_ENTRIES_W, maleTestSham$Light_ENTRIES_W)
cohensD(femaleTestSham$Light_ENTRIES_W, maleTestSham$Light_ENTRIES_W)
t.test(femaleTestRep$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)
cohensD(femaleTestRep$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)
t.test(femaleTestGdx$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)
cohensD(femaleTestGdx$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)

# planned comparisons - test to control
t.test(femaleControlSham$Light_ENTRIES_W, femaleTestSham$Light_ENTRIES_W)
cohensD(femaleControlSham$Light_ENTRIES_W, femaleTestSham$Light_ENTRIES_W)
t.test(femaleControlRep$Light_ENTRIES_W, femaleTestRep$Light_ENTRIES_W)
cohensD(femaleControlRep$Light_ENTRIES_W, femaleTestRep$Light_ENTRIES_W)
t.test(femaleControlGdx$Light_ENTRIES_W, femaleTestGdx$Light_ENTRIES_W)
cohensD(femaleControlGdx$Light_ENTRIES_W, femaleTestGdx$Light_ENTRIES_W)

t.test(maleControlSham$Light_ENTRIES_W, maleTestSham$Light_ENTRIES_W)
cohensD(maleControlSham$Light_ENTRIES_W, maleTestSham$Light_ENTRIES_W)
t.test(maleControlRep$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)
cohensD(maleControlRep$Light_ENTRIES_W, maleTestRep$Light_ENTRIES_W)
t.test(maleControlGdx$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)
cohensD(maleControlGdx$Light_ENTRIES_W, maleTestGdx$Light_ENTRIES_W)

### light duration

# main model
postDurationModel <- lm(Light_DURATION_W ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postDurationModel)

# planned comparisons - gonad
t.test(femaleControlSham$Light_DURATION_W, femaleControlGdx$Light_DURATION_W)
cohensD(femaleControlSham$Light_DURATION_W, femaleControlGdx$Light_DURATION_W)
t.test(femaleControlGdx$Light_DURATION_W, femaleControlRep$Light_DURATION_W)
cohensD(femaleControlGdx$Light_DURATION_W, femaleControlRep$Light_DURATION_W)

t.test(femaleTestSham$Light_DURATION_W, femaleTestGdx$Light_DURATION_W)
cohensD(femaleTestSham$Light_DURATION_W, femaleTestGdx$Light_DURATION_W)
t.test(femaleTestGdx$Light_DURATION_W, femaleTestRep$Light_DURATION_W)
cohensD(femaleTestGdx$Light_DURATION_W, femaleTestRep$Light_DURATION_W)

t.test(maleControlSham$Light_DURATION_W, maleControlGdx$Light_DURATION_W)
cohensD(maleControlSham$Light_DURATION_W, maleControlGdx$Light_DURATION_W)
t.test(maleControlGdx$Light_DURATION_W, maleControlRep$Light_DURATION_W)
cohensD(maleControlGdx$Light_DURATION_W, maleControlRep$Light_DURATION_W)

t.test(maleTestSham$Light_DURATION_W, maleTestGdx$Light_DURATION_W)
cohensD(maleTestSham$Light_DURATION_W, maleTestGdx$Light_DURATION_W)
t.test(maleTestGdx$Light_DURATION_W, maleTestRep$Light_DURATION_W)
cohensD(maleTestGdx$Light_DURATION_W, maleTestRep$Light_DURATION_W)

# planned comparisons - male to female
t.test(femaleControlSham$Light_DURATION_W, maleControlSham$Light_DURATION_W)
cohensD(femaleControlSham$Light_DURATION_W, maleControlSham$Light_DURATION_W)
t.test(femaleControlRep$Light_DURATION_W, maleControlRep$Light_DURATION_W)
cohensD(femaleControlRep$Light_DURATION_W, maleControlRep$Light_DURATION_W)
t.test(femaleControlGdx$Light_DURATION_W, maleControlGdx$Light_DURATION_W)
cohensD(femaleControlGdx$Light_DURATION_W, maleControlGdx$Light_DURATION_W)

t.test(femaleTestSham$Light_DURATION_W, maleTestSham$Light_DURATION_W)
cohensD(femaleTestSham$Light_DURATION_W, maleTestSham$Light_DURATION_W)
t.test(femaleTestRep$Light_DURATION_W, maleTestRep$Light_DURATION_W)
cohensD(femaleTestRep$Light_DURATION_W, maleTestRep$Light_DURATION_W)
t.test(femaleTestGdx$Light_DURATION_W, maleTestGdx$Light_DURATION_W)
cohensD(femaleTestGdx$Light_DURATION_W, maleTestGdx$Light_DURATION_W)

# planned comparisons - test to control
t.test(femaleControlSham$Light_DURATION_W, femaleTestSham$Light_DURATION_W)
cohensD(femaleControlSham$Light_DURATION_W, femaleTestSham$Light_DURATION_W)
t.test(femaleControlRep$Light_DURATION_W, femaleTestRep$Light_DURATION_W)
cohensD(femaleControlRep$Light_DURATION_W, femaleTestRep$Light_DURATION_W)
t.test(femaleControlGdx$Light_DURATION_W, femaleTestGdx$Light_DURATION_W)
cohensD(femaleControlGdx$Light_DURATION_W, femaleTestGdx$Light_DURATION_W)

t.test(maleControlSham$Light_DURATION_W, maleTestSham$Light_DURATION_W)
cohensD(maleControlSham$Light_DURATION_W, maleTestSham$Light_DURATION_W)
t.test(maleControlRep$Light_DURATION_W, maleTestRep$Light_DURATION_W)
cohensD(maleControlRep$Light_DURATION_W, maleTestRep$Light_DURATION_W)
t.test(maleControlGdx$Light_DURATION_W, maleTestGdx$Light_DURATION_W)
cohensD(maleControlGdx$Light_DURATION_W, maleTestGdx$Light_DURATION_W)

### 1 min entries

# main model
postEntries1MinModel <- lm(Light_ENTRIES_W_1MIN ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postEntries1MinModel)

# planned comparisons - gonad
t.test(femaleControlSham$Light_ENTRIES_W_1MIN, femaleControlGdx$Light_ENTRIES_W_1MIN)
cohensD(femaleControlSham$Light_ENTRIES_W_1MIN, femaleControlGdx$Light_ENTRIES_W_1MIN)
t.test(femaleControlGdx$Light_ENTRIES_W_1MIN, femaleControlRep$Light_ENTRIES_W_1MIN)
cohensD(femaleControlGdx$Light_ENTRIES_W_1MIN, femaleControlRep$Light_ENTRIES_W_1MIN)

t.test(femaleTestSham$Light_ENTRIES_W_1MIN, femaleTestGdx$Light_ENTRIES_W_1MIN)
cohensD(femaleTestSham$Light_ENTRIES_W_1MIN, femaleTestGdx$Light_ENTRIES_W_1MIN)
t.test(femaleTestGdx$Light_ENTRIES_W_1MIN, femaleTestRep$Light_ENTRIES_W_1MIN)
cohensD(femaleTestGdx$Light_ENTRIES_W_1MIN, femaleTestRep$Light_ENTRIES_W_1MIN)

t.test(maleControlSham$Light_ENTRIES_W_1MIN, maleControlGdx$Light_ENTRIES_W_1MIN)
cohensD(maleControlSham$Light_ENTRIES_W_1MIN, maleControlGdx$Light_ENTRIES_W_1MIN)
t.test(maleControlGdx$Light_ENTRIES_W_1MIN, maleControlRep$Light_ENTRIES_W_1MIN)
cohensD(maleControlGdx$Light_ENTRIES_W_1MIN, maleControlRep$Light_ENTRIES_W_1MIN)

t.test(maleTestSham$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)
cohensD(maleTestSham$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)
t.test(maleTestGdx$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)
cohensD(maleTestGdx$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)

# planned comparisons - male to female
t.test(femaleControlSham$Light_ENTRIES_W_1MIN, maleControlSham$Light_ENTRIES_W_1MIN)
cohensD(femaleControlSham$Light_ENTRIES_W_1MIN, maleControlSham$Light_ENTRIES_W_1MIN)
t.test(femaleControlRep$Light_ENTRIES_W_1MIN, maleControlRep$Light_ENTRIES_W_1MIN)
cohensD(femaleControlRep$Light_ENTRIES_W_1MIN, maleControlRep$Light_ENTRIES_W_1MIN)
t.test(femaleControlGdx$Light_ENTRIES_W_1MIN, maleControlGdx$Light_ENTRIES_W_1MIN)
cohensD(femaleControlGdx$Light_ENTRIES_W_1MIN, maleControlGdx$Light_ENTRIES_W_1MIN)

t.test(femaleTestSham$Light_ENTRIES_W_1MIN, maleTestSham$Light_ENTRIES_W_1MIN)
cohensD(femaleTestSham$Light_ENTRIES_W_1MIN, maleTestSham$Light_ENTRIES_W_1MIN)
t.test(femaleTestRep$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)
cohensD(femaleTestRep$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)
t.test(femaleTestGdx$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)
cohensD(femaleTestGdx$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)

# planned comparisons - test to control
t.test(femaleControlSham$Light_ENTRIES_W_1MIN, femaleTestSham$Light_ENTRIES_W_1MIN)
cohensD(femaleControlSham$Light_ENTRIES_W_1MIN, femaleTestSham$Light_ENTRIES_W_1MIN)
t.test(femaleControlRep$Light_ENTRIES_W_1MIN, femaleTestRep$Light_ENTRIES_W_1MIN)
cohensD(femaleControlRep$Light_ENTRIES_W_1MIN, femaleTestRep$Light_ENTRIES_W_1MIN)
t.test(femaleControlGdx$Light_ENTRIES_W_1MIN, femaleTestGdx$Light_ENTRIES_W_1MIN)
cohensD(femaleControlGdx$Light_ENTRIES_W_1MIN, femaleTestGdx$Light_ENTRIES_W_1MIN)

t.test(maleControlSham$Light_ENTRIES_W_1MIN, maleTestSham$Light_ENTRIES_W_1MIN)
cohensD(maleControlSham$Light_ENTRIES_W_1MIN, maleTestSham$Light_ENTRIES_W_1MIN)
t.test(maleControlRep$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)
cohensD(maleControlRep$Light_ENTRIES_W_1MIN, maleTestRep$Light_ENTRIES_W_1MIN)
t.test(maleControlGdx$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)
cohensD(maleControlGdx$Light_ENTRIES_W_1MIN, maleTestGdx$Light_ENTRIES_W_1MIN)

### 1 min duration

# main model
postDuration1MinModel <- lm(Light_DURATION_W_1MIN ~ Treatment * Sex * Gonad, data = ldDataPost)
Anova(postDuration1MinModel)

# planned comparisons - gonad
t.test(femaleControlSham$Light_DURATION_W_1MIN, femaleControlGdx$Light_DURATION_W_1MIN)
cohensD(femaleControlSham$Light_DURATION_W_1MIN, femaleControlGdx$Light_DURATION_W_1MIN)
t.test(femaleControlGdx$Light_DURATION_W_1MIN, femaleControlRep$Light_DURATION_W_1MIN)
cohensD(femaleControlGdx$Light_DURATION_W_1MIN, femaleControlRep$Light_DURATION_W_1MIN)

t.test(femaleTestSham$Light_DURATION_W_1MIN, femaleTestGdx$Light_DURATION_W_1MIN)
cohensD(femaleTestSham$Light_DURATION_W_1MIN, femaleTestGdx$Light_DURATION_W_1MIN)
t.test(femaleTestGdx$Light_DURATION_W_1MIN, femaleTestRep$Light_DURATION_W_1MIN)
cohensD(femaleTestGdx$Light_DURATION_W_1MIN, femaleTestRep$Light_DURATION_W_1MIN)

t.test(maleControlSham$Light_DURATION_W_1MIN, maleControlGdx$Light_DURATION_W_1MIN)
cohensD(maleControlSham$Light_DURATION_W_1MIN, maleControlGdx$Light_DURATION_W_1MIN)
t.test(maleControlGdx$Light_DURATION_W_1MIN, maleControlRep$Light_DURATION_W_1MIN)
cohensD(maleControlGdx$Light_DURATION_W_1MIN, maleControlRep$Light_DURATION_W_1MIN)

t.test(maleTestSham$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)
cohensD(maleTestSham$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)
t.test(maleTestGdx$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)
cohensD(maleTestGdx$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)

# planned comparisons - male to female
t.test(femaleControlSham$Light_DURATION_W_1MIN, maleControlSham$Light_DURATION_W_1MIN)
cohensD(femaleControlSham$Light_DURATION_W_1MIN, maleControlSham$Light_DURATION_W_1MIN)
t.test(femaleControlRep$Light_DURATION_W_1MIN, maleControlRep$Light_DURATION_W_1MIN)
cohensD(femaleControlRep$Light_DURATION_W_1MIN, maleControlRep$Light_DURATION_W_1MIN)
t.test(femaleControlGdx$Light_DURATION_W_1MIN, maleControlGdx$Light_DURATION_W_1MIN)
cohensD(femaleControlGdx$Light_DURATION_W_1MIN, maleControlGdx$Light_DURATION_W_1MIN)

t.test(femaleTestSham$Light_DURATION_W_1MIN, maleTestSham$Light_DURATION_W_1MIN)
cohensD(femaleTestSham$Light_DURATION_W_1MIN, maleTestSham$Light_DURATION_W_1MIN)
t.test(femaleTestRep$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)
cohensD(femaleTestRep$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)
t.test(femaleTestGdx$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)
cohensD(femaleTestGdx$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)

# planned comparisons - test to control
t.test(femaleControlSham$Light_DURATION_W_1MIN, femaleTestSham$Light_DURATION_W_1MIN)
cohensD(femaleControlSham$Light_DURATION_W_1MIN, femaleTestSham$Light_DURATION_W_1MIN)
t.test(femaleControlRep$Light_DURATION_W_1MIN, femaleTestRep$Light_DURATION_W_1MIN)
cohensD(femaleControlRep$Light_DURATION_W_1MIN, femaleTestRep$Light_DURATION_W_1MIN)
t.test(femaleControlGdx$Light_DURATION_W_1MIN, femaleTestGdx$Light_DURATION_W_1MIN)
cohensD(femaleControlGdx$Light_DURATION_W_1MIN, femaleTestGdx$Light_DURATION_W_1MIN)

t.test(maleControlSham$Light_DURATION_W_1MIN, maleTestSham$Light_DURATION_W_1MIN)
cohensD(maleControlSham$Light_DURATION_W_1MIN, maleTestSham$Light_DURATION_W_1MIN)
t.test(maleControlRep$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)
cohensD(maleControlRep$Light_DURATION_W_1MIN, maleTestRep$Light_DURATION_W_1MIN)
t.test(maleControlGdx$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)
cohensD(maleControlGdx$Light_DURATION_W_1MIN, maleTestGdx$Light_DURATION_W_1MIN)

#############
# Graphing
#############

# pre-puberty

preEntriesGraph <- lightDarkGraphPre(ldDataPre, "Light_ENTRIES_W", "Light-Side Entries", "Light-Side Entries (Total)", 30, F, "PrePubLightEntries.pdf")
preDurationGraph <- lightDarkGraphPre(ldDataPre, "Light_DURATION_W", "Duration (seconds)", "Time in Light-Side (Total)", 150, F, "PrePubLightDuration.pdf")
pre1MinEntriesGraph <- lightDarkGraphPre(ldDataPre, "Light_ENTRIES_W_1MIN", "Light-Side Entries", "Light-Side Entries (1st Minute)", 5, F, "PrePubLightEntries1Min.pdf")
pre1MinDurationGraph <- lightDarkGraphPre(ldDataPre, "Light_DURATION_W_1MIN", "Duration (seconds)", "Time in Light-Side (1st Minute)", 30, F, "PrePubLightEntries1Min.pdf")
preLatencyGraph <- lightDarkGraphPre(ldDataPre, "Light_LATENCY_W", "Latency (seconds)", "Latency to Enter Light-Side", 50, F, "PrePubLatency.pdf")
preHActGraph <- lightDarkGraphPre(ldDataPre, "HACTV", "Number of Beam Breaks", "Total Horizontal Activity", 3000, F, "PrePubHorAct.pdf")

preGraphLegend <- getLegend(preEntriesGraph);
preEntriesGraph <- preEntriesGraph + theme(legend.position = "none")
preDurationGraph <- preDurationGraph + theme(legend.position = "none")
pre1MinEntriesGraph <- pre1MinEntriesGraph + theme(legend.position = "none")
pre1MinDurationGraph <- pre1MinDurationGraph + theme(legend.position = "none")
preLatencyGraph <- preLatencyGraph + theme(legend.position = "none")
preHActGraph <- preHActGraph + theme(legend.position = "none")

pdf(paste("output/", "ld-prepub"), 8, 11)
grid.arrange(preEntriesGraph, pre1MinEntriesGraph, preDurationGraph, pre1MinDurationGraph, preLatencyGraph, preHActGraph, ncol = 2, nrow = 3, widths = c(7, 7))
dev.off()

pdf(paste("output/", "fileName"), 8, 11)
grid.arrange(preGraphLegend, ncol = 1, nrow = 1, widths = c(1.5))
dev.off()

# Post-Puberty

lightDarkGraph(subset(ldDataPost, ldDataPost$Sex == "F"), "Light_ENTRIES_W", "Light Side Entries", "Light Side Entries (Total)", 20, "LightSideEntries.pdf")

lightDarkPanel(ldDataPost, "Light_ENTRIES_W", "Light Side Entries", "Light Side Entries (Total)", 20, "LightSideEntries.pdf")
lightDarkPanel(ldDataPost, "Light_DURATION_W", "Duration (seconds)", "Time in Light Side (Total)", 150, "LightSideDuration.pdf")
lightDarkPanel(ldDataPost, "Light_ENTRIES_W_1MIN", "Light Side Entries", "Light Side Entries (1st Minute)", 5, "LightSideEntriesFirstMin.pdf")
lightDarkPanel(ldDataPost, "Light_DURATION_W_1MIN", "Duration (seconds)", "Time in Light Side (1st Minute)", 25, "LightSideDurationFirstMin.pdf")
lightDarkPanel(ldDataPost, "Light_LATENCY_W", "Latency (seconds)", "Latency to Enter Light Side", 100, "LightSideLatency.pdf")
lightDarkPanel(ldDataPost, "HACTV", "Number of Beam Breaks", "Total Horizontal Activity", 3000, "HorizontalActivity.pdf")


library(cellrangerRkit)
context('PCA')

test_matrix = Matrix(matrix(rbinom(200*100, 10, 0.01), 200, 100))

grp1 <- 1:40
grp2 <- 41:100
test_matrix[1:5,grp1] <- 5
test_matrix[6:10,grp2] <- 6

row.names(test_matrix) = sprintf("gene%d", 1:200)
colnames(test_matrix) = sprintf("sample%d", 1:100)

test_genes = data.frame(id=sprintf("gene%d", 1:200))
row.names(test_genes) = test_genes$id

test_samples = data.frame(barcode=sprintf("sample%d", 1:100))
row.names(test_samples) = test_samples$barcode

gbm <- newGeneBCMatrix(test_matrix, test_genes, test_samples)

pca <- run_pca(gbm, 2)

test_that("pca results make sense", {
  expect_true(nrow(pca$x) == ncol(gbm))
  expect_equal(ncol(pca$x), 2)
  expect_true(nrow(pca$rotation) == length(pca$use_genes))
  expect_equal(ncol(pca$rotation), 2)
  expect_true(all(pca$x[grp1,1] < 0) && all(pca$x[grp2,1] > 0) ||
              all(pca$x[grp1,1] > 0) && all(pca$x[grp2,1] < 0))
} )


# This script apply Dynamic Time Warping to the HPMA115S0 and SDS018 models to
# correct the time delay observed for these sensors.

source("utilities.R")
source("variables.R")
require(dplyr)
require(lubridate)
require(dtw)
require(splitstackshape)

df <-prepare_sensor_data(sensor_raw_file, cdt) %>%
  select(date, sensor, site, PM25, exp, source, variation)

df2<-cSplit(indt=df,splitCols = c("sensor"),sep="-",direction="wide",drop=FALSE) %>%
  select(-sensor_2,-sensor_3)->df

dt <- prepare_dusttrak_data(dusttrak_file, cdt)

df_sensor <- df %>%
  filter(exp != "") %>%
  filter(sensor_1 == "HPMA115S0")

# Initialise the result data frame
res <- df_sensor %>%
  filter(exp == "empty")

for(expe in unique(df_sensor$exp)){

  df_sensor_exp <- df_sensor %>%
    filter(exp == expe)

  dt_exp <- dt %>%
    filter(exp == expe)

  for(sens in unique(df_sensor$sensor)){

    query<- df_sensor_exp %>%
      filter(sensor == sens) %>%
      arrange(date)
    if(nrow(query)==0){next}
    query_diff<-finite.differences(as.numeric(query$date),query$PM25 )

    template<- dt_exp %>%
      arrange(date)
    template_diff<-finite.differences(as.numeric(template$date), template$pm2.5)

    alignment<-dtw(query_diff,template_diff, keep=TRUE, step.pattern = mori2006)
    wq<-warp(alignment,index.reference=FALSE);

    #     p<-ggplot(data=template, aes(x=template$date, y = template$pm2.5)) +geom_line() +
    #     geom_line(aes(x = template$date, y = query$PM25[wq],color="Corrected data"))+
    #     geom_line(data=query, aes(x = date, y=PM25, color = "Original data"))+
    #     ggtitle(paste0("mori2006", " - ", expe))
    # print(p)
    query_1 <-query[wq,]
    query_1$date <- template$date

    res <- rbind(res, query_1)
    # ggplot(data=template, aes(x=template$date, y = template$pm2.5)) +geom_line() + geom_line(aes(x = query_1$date, y = query_1$PM25,color="Corrected data"))
  }

}

df_sensor <- df %>%
  filter(exp != "") %>%
  filter(sensor_1 == "SDS018")

for(expe in unique(df_sensor$exp)){

  df_sensor_exp <- df_sensor %>%
    filter(exp == expe)

  dt_exp <- dt %>%
    filter(exp == expe)

  for(sens in unique(df_sensor$sensor)){

    query<- df_sensor_exp %>%
      filter(sensor == sens) %>%
      arrange(date)
    if(nrow(query)==0){next}
    query_diff<-finite.differences(as.numeric(query$date),query$PM25 )

    template<- dt_exp %>%
      arrange(date)
    template_diff<-finite.differences(as.numeric(template$date), template$pm2.5)

    alignment<-dtw(query_diff,template_diff, keep=TRUE, step.pattern = mori2006)
    wq<-warp(alignment,index.reference=FALSE);

    p<-ggplot(data=template, aes(x=template$date, y = template$pm2.5)) +geom_line() + geom_line(aes(x = template$date, y = query$PM25[wq],color="Corrected data"))+ geom_line(data=query, aes(x = date, y=PM25, color = "Original data"))+ ggtitle("mori2006")
    p
    query_1 <-query[wq,]
    query_1$date <- template$date

    res <- rbind(res, query_1)
    # ggplot(data=template, aes(x=template$date, y = template$pm2.5)) +geom_line() + geom_line(aes(x = query_1$date, y = query_1$PM25,color="Corrected data"))
  }

}

df_sensor <- df %>%
  filter(exp != "") %>%
  filter(sensor_1 == "OPCR1")

res <- rbind(res, df_sensor)

df_sensor <- df %>%
  filter(exp != "") %>%
  filter(sensor_1 == "PMS5003")

res <- rbind(res, df_sensor)

df_sensor <- df %>%
  filter(exp != "") %>%
  filter(sensor_1 == "SPS030")

res <- rbind(res, df_sensor)

res %>%
  saveRDS(file = "datasets/sensor_delay_corrected.rds")


#' @title do_binary_random_forest_roc
#' @description
#' Calculates a random forest analysis of the specified data frame, with the specified class
#' label field.  The analysis must be a binary classification, because we also return a ROC curve for
#' classification accuracy.
#'
#' @param data frame input data
#' @param column to use as class labels
#' @param vector fields to exclude from the random forest classifier.  should NOT include the class label field.
#' @param number fraction of the data frame to sample for out-of-sample test data
#' @param number number of trees to have the random forest classifier fit
#' @param number minimum node size for the decision trees
#' @param number number of variables to sample for each random tree
#' @return list List with fitted model, test classification rate, ROC analysis object, and test error rate for the test data
#' @export

do_binary_random_forest_roc <- function(df, class_field, fields_to_exclude, test_fraction = 0.1, numtrees = 1000,
                             node_size = 1, variables_to_sample = 3) {
  require(randomForest)
  require(ROCR)
  # remove unwanted columns for this analysis
  df_dropped <- df[,!(names(df) %in% fields_to_exclude)]

  # split into random train and test data sets
  data <- random_split_dataset(df_dropped, test_fraction)

  form <- as.formula(paste(class_field, "~", ".", sep = " "))

  fit <- randomForest(form, data=data$train, ntree=numtrees, nodesize = node_size, mtry=variables_to_sample, test=data$test)

  rf.pr = predict(fit,type="prob",newdata=data$test)[,2]
  rf.pred = prediction(rf.pr, data$test[,class_field])
  rf.perf = performance(rf.pred, "tpr", "fpr")
  rf.auc = performance(rf.pred, "auc")

  test_table <- table(data$test[,class_field], predict(fit, data$test[names(df_dropped)]))
  prediction <- sum(data$test[,class_field]==predict(fit, data$test[names(df_dropped)])) / nrow(data$test)
  error <- 1 - prediction

  ret <- list("fit"=fit, "prediction_rate" = prediction, "test_confusion" = test_table,
              "test_error" = error, "roc" = rf.perf, "roc_pred" = rf.pred, "roc_auc" = rf.auc@y.values[[1]])
  ret
}

#' @title do_multiclass_random_forest
#' @description
#' Calculates a random forest analysis of the specified data frame, with the specified class
#' label field.  This function does not calculate a ROC curve, and thus can be used with
#' multiclass labels.
#'
#' @param data frame input data
#' @param column to use as class labels
#' @param vector fields to exclude from the random forest classifier.  should NOT include the class label field.
#' @param number fraction of the data frame to sample for out-of-sample test data
#' @param number number of trees to have the random forest classifier fit
#' @param number minimum node size for the decision trees
#' @param number number of variables to sample for each random tree
#' @return list List with fitted model, test classification rate, and test error rate for the test data
#' @export
#'
do_multiclass_random_forest <- function(df, class_field, fields_to_exclude, test_fraction = 0.1, numtrees = 1000,
                                        node_size = 1, variables_to_sample = 3) {
  require(randomForest)
  # remove unwanted columns for this analysis
  df_dropped <- df[,!(names(df) %in% fields_to_exclude)]

  # split into random train and test data sets
  data <- random_split_dataset(df_dropped, test_fraction)

  form <- as.formula(paste(class_field, "~", ".", sep = " "))

  fit <- randomForest(form, data=data$train, ntree=numtrees, nodesize = node_size, mtry=variables_to_sample, test=data$test)

  test_table <- table(data$test[,class_field], predict(fit, data$test[names(df_dropped)]))
  prediction <- sum(data$test[,class_field]==predict(fit, data$test[names(df_dropped)])) / nrow(data$test)
  error <- 1 - prediction

  ret <- list("fit"=fit, "prediction_rate" = prediction, "test_confusion" = test_table,
              "test_error" = error)
  ret
}


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("TH.data")
# install.packages("ROCR")
# install.packages("caret")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(TH.data) # This package is specifically loaded for breast cancer dataset shipped within it.
library(ROCR)
library(caret)

# Here we directly load the breast cancer dataset installed with the "TH.data" package.
data(GBSG2)

# rename column names in GBSG2 dataset from TH.data package
breastCancerOriginal <- setNames(GBSG2, c("Hormonal_Therapy", "Age", "Menopausal_Status", "Tumor_Size", "Tumor_Grade", "Positive_Nodes", "Progesterone", "Estrogen_Receptor",
"Survival_Time", "Indicator"))

# Omit rows with missing values
breastCancerOriginal <- na.omit(breastCancerOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# breastCancer<- read.csv("BreastCancer.csv")

# Considering integer variable as factor
breastCancerOriginal$Indicator <- factor(breastCancerOriginal$Indicator, ordered = FALSE)

# Randomizing data
breastCancer<-breastCancerOriginal[sample(nrow(breastCancerOriginal)),]

# Divide dataset for training and test
trainData <- breastCancer[1:548, ]
testData  <- breastCancer[549:686, ]

# Set predicted field in formula
formula = formula(Indicator ~ .)

# Create model for training set using naiveBayes
breastCancerTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "cens" column for test data set
breastCancerTestPrediction <- predict(breastCancerTrainingModel, testData)
# Display predicted values
breastCancerTestPrediction

# Create cross table to check on accuracy.
CrossTable(breastCancerTestPrediction, testData$Indicator,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# Predict the Probabilities for test dataset
breastCancerTestProbabilities = predict(breastCancerTrainingModel, newdata = testData, threshold = 0, type = "raw")

# Generate ROC curve and calculate AUC value to predict the accuracy from BreastCancer test dataset

# To create visualizations - ROC curve with "ROCR" package two vectors of data are needed,
# The first vector must contain the class values - cens column and
# The second vector must contain the estimated probability of the positive class(NonCensoredProbability)
pred <- prediction(labels = testData$Indicator, predictions = breastCancerTestProbabilities[,2])

# Using the perf performance object, we can visualize the ROC curve with R's plot() function
perf <- performance(pred, measure = "tpr", x.measure = "fpr")

# Plot the ROC curve for the visualization
plot(perf, main = "ROC curve for BreastCancer Test Dataset", col = "blue", lwd = 3)

# To indicate reference line in the ROC plot
abline(a = 0, b = 1, lwd = 2, lty = 2)

# We can use the ROCR package to calculate the AUC(Area under the ROC Curve)
# To do so, we first need to create another performance object and specify measure = "auc", as shown in the following code:
perf.auc <- performance(pred, measure = "auc")

# perf.auc is an object (specifically known as an S4 object) we need to use a special type of notation to access the values stored within.
# S4 objects hold information in positions known as slots
# The str() function can be used to see all slots for an object
str(perf.auc)

# To access the AUC value, which is stored as a list in the y.values slot, we can use the @ notation along with the unlist() function, which simplifies lists to a vector of numeric values
# Below AUC value is under the "acceptable/fair" category
unlist(perf.auc@y.values)

# View Specificity, Sensitivity and Accuracy information using confusionMatrix function from "caret" package
confusionMatrix(breastCancerTestPrediction,testData$Indicator, positive = "1")

# PMML generation
saveXML(pmml(breastCancerTrainingModel, predictedField = "Indicator"), "BreastCancer.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original breastCancer data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(breastCancerTrainingModel, newdata = breastCancerOriginal, threshold = 0, type = "class")
probabilities = predict(breastCancerTrainingModel, newdata = breastCancerOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file)
{
	result = NULL
	if(is.null(probabilities))
	{
		result = data.frame(classes)
		names(result) = c("Indicator")
	}
	else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("Predicted_censored", "CensoredProbability", "NonCensoredProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")


library(RUVcorr)

seed     = {{i.seed | R}}
outfile  = {{o.outfile | quote}}
nsamples = {{args.nsamples | R}}
ngenes   = {{args.ngenes | R}}
slabel   = {{args.slabel | quote}}
glabel   = {{args.glabel | quote}}
params   = {{args.params | R}}

set.seed(seed)
update.list = function (list1, list2, recursive = F) {
	names2 = names(list2)
	for (name in names2) {
		if (is.list(list1[[name]]) && is.list(list2[[name]]) && recursive) {
			list1[[name]] = update.list(list1[[name]], list2[[name]], recursive = recursive)
		} else {
			list1[[name]] = list2[[name]]
		}
	}
	return (list1)
}
params   = update.list(params, list(
	k             = 10,
	size.alpha    = 2,
	corr.strength = 3,
	g             = NULL,
	Sigma.eps     = 1,
	# An integer setting the number of negative controls.
	nc            = ngenes/2,
	# An integer setting the number of strongly expressed genes.
	ne            = ngenes/2,
	intercept     = TRUE,
	check         = TRUE
))
params$n = ngenes
params$m = nsamples
exprs    = do.call(simulateGEdata, params)$Y
colnames(exprs) = paste0(glabel, 1:ngenes)
rownames(exprs) = paste0(slabel, 1:nsamples)

write.table(t(exprs), outfile, sep = "\t", quote = FALSE, row.names = TRUE, col.names = TRUE)


# R code
# PMML generation for audit, Naive Bayes model
install.packages('e1071')
install.packages('pmml')
library(e1071)
library('pmml')

audit.train <- read.table("~/work/sumatosoft/rubyconf2018ML/audit.csv", header = TRUE, sep = ",")
audit.train$TARGET_Adjusted <- as.factor(audit.train$TARGET_Adjusted)

# Train Naive Bayes model

audit.bn <- naiveBayes(TARGET_Adjusted ~ . - ID - Age - Employment - Education - Marital - Occupation - Income - Gender - Deductions - Hours - IGNORE_Accounts - RISK_Adjustment,
                      data = audit.train)

# Generate pmml from model
pmml <- pmml(audit.bn, dataset=audit.train, predictedField="TARGET_Adjusted")
saveXML(pmml, '~/work/sumatosoft/rubyconf2018ML/r_bayes.pmml')


data <- unlist(read.csv("hand_values.csv", header=FALSE))
paste("mean:",mean(data))
paste("std err:",sqrt(var(data)))
table(data)
hist(data, breaks = rep(0:29), xlab="Score",
     main=paste("Cribbage Hand Values, N =", length(data)))


"
This document provide functions for spatial heterogenetiy analysis
@author: Haoyang Mi
"

library(spatstat)
library(dplyr)
library(flexclust)
library(plyr)
library(rjson)
library(spatstat)
library(pracma)

fac2num <- function(x){

  x <- as.numeric(as.character(x))
  return(x)
}

ShannonE <- function(types, coreData){

    #types <- ctype_tensor
    type.count <- length(types)

    Total <- nrow(coreDat) # total number of cells

    # all int/ext data
    ctype_stat_all <- data.frame(matrix(nrow =  0, ncol = 0))

    for (cseq in seq_len(type.count)) {   # outer loop, calcualte interior stats
        #cseq <- 1
        ctype_int <- 0
        ctype_ext <- 0
        p <- 0 # ratio

        # current cell type
        ctype <- types[cseq]

        # coordinates data for the current core, current cell type

        ctype.Dat <- coreDat[coreDat$ctype_no == ctype, c('Xcoord', 'Ycoord')]

        p <- nrow(ctype.Dat)/Total

        # interior score
        ctype_int <- mean(as.matrix(dist(ctype.Dat[c('Xcoord', 'Ycoord')])))

        # other cell types
        ctype_other <- types[-cseq]

        ctype_stat <- cbind(p, ctype_int)

        for (cseq_other in ctype_other) {

            ctype_other.Dat <- coreDat[coreDat$ctype_no == cseq_other, c('Xcoord', 'Ycoord')]

            # exterior score

            ctype_ext <- ctype_ext +  mean(dist2(ctype.Dat, ctype_other.Dat))

        }
        # number of computations = No. cell types - 1
        ctype_stat <- cbind(ctype_stat, ctype_ext / (type.count - 1))

        colnames(ctype_stat) <- c('p', 'int', 'ext')

        ctype_stat_all <- rbind(ctype_stat_all ,cbind(ctype_stat, ctype))

    }

    ShannonH <- 0
    # combine row data

    for (dat in seq_len(type.count)) {
      p <- as.numeric(as.character(ctype_stat_all[dat, 1]))
      d_int <- as.numeric(as.character(ctype_stat_all[dat, 2]))

      d_ext <- as.numeric(as.character(ctype_stat_all[dat, 3]))
      d_final <- d_int / d_ext

      if(isTRUE(d_int*d_ext == 0)){
        d_final <- 0
      }
      if(isTRUE(p != 0)){
        ShannonH <- -d_final*p*log2(p) + ShannonH
      }
    }

    return(ShannonH)
}

# convet graph to covariance matrix
#@ input: g -> graph
#         null_matrix -> an empty matrix

graph2covMatrix <- function(Community_edges, node_type){

  from_types <- node_type[match(Community_edges$from, node_type$X1),]
  to_types <- node_type[match(Community_edges$to, node_type$X1),]

  nt_types <- data.frame(cbind(as.character(from_types$X2), as.character(to_types$X2)))

  # create covariance matrix
  covar_Matrix <- matrix(nrow = 17, ncol = 17)

  colnames(covar_Matrix) <- ctype_names
  rownames(covar_Matrix) <- ctype_names

  for(row in seq_len(17)){

    # from
    row_name <- ctype_names[row]
    for (col in seq_len(17)) {

      col_name <- ctype_names[col]
      covar_Matrix[row, col] <- nrow(nt_types[nt_types$X1 == row_name & nt_types$X2 == col_name,])+
        nrow(nt_types[nt_types$X1 == col_name & nt_types$X2 == row_name,])

    }
  }
  return(covar_Matrix)
}

GNN <- function(Community_edges, NodeFeature){

  # re-index
  NodeFeature$reindex <- seq_len(nrow(NodeFeature)) - 1
  edges <- list()
  features <- list()

  ## merge
  from_oldNode <- data.frame(Community_edges$from)
  colnames(from_oldNode) <- 'id'
  to_oldNode <- data.frame(Community_edges$to)
  colnames(to_oldNode) <- 'id'

  newNode <- data.frame(cbind(NodeFeature$members, NodeFeature$reindex))
  colnames(newNode) <- c('id', 'new_id')

  from_new <- vector()
  for(row in seq_len(nrow(from_oldNode))){

    old <- from_oldNode$id[row]
    new <- newNode[newNode$id == old, 2]

    from_new <- c(from_new, new)
  }

  to_new <- vector()
  for(row in seq_len(nrow(to_oldNode))){

    old <- to_oldNode$id[row]
    new <- newNode[newNode$id == old, 2]

    to_new <- c(to_new, new)
  }

  newEdge <- data.frame(cbind(from_new, to_new))
  # edges to list

  for(lid in seq_len(nrow(newEdge))) {
    edges[[lid]] <- as.numeric(newEdge[lid,])
  }

  F <- NodeFeature[,c(1,68, 69)]
  F$ctype_int <- as.character(F$ctype_int)

  # features to list

  for(fid in seq_len(nrow(NodeFeature))) {
    features[[fid]] <- F[fid,]$ctype_int
    names(features)[fid] <- F[fid, 3]
  }

  # combine features and edges to one list
  list_final <- list(edges = edges, features = features)
  return(list_final)
}

cor.network <- function(gct_file, allCore){

  #allCore <- NR_core
  R_intercor <- data.frame(matrix(nrow = 0, ncol = 0))

  for (core in allCore) {

    #core <- 2
    # core - dendrogram
    Core_dendro <- gct_file[gct_file$id == core,]
    Core_dendro <- Core_dendro[order(Core_dendro$Community_id, decreasing = FALSE),]

    GNN_vec <- read.csv(paste('./Data/Features/', core, '/nci.csv', sep = ''), row.names = 1)
    intercor <- outer(1:nrow(GNN_vec),1:nrow(GNN_vec), FUN = Vectorize( function(i,j) cor.test(t(GNN_vec[i,]), t(GNN_vec[j,]), method = 'spearman')$p.value) )

    colnames(intercor) <- Core_dendro$dendrogram_cut
    rownames(intercor) <- Core_dendro$dendrogram_cut
    diag(intercor) <- -10

    # melt matrix
    melt_intercor <- melt(intercor)
    melt_intercor <- melt_intercor[!(melt_intercor$value == -10),]
    R_intercor <- rbind(R_intercor, melt_intercor)

  }

  Cor_network <- data.frame(matrix(nrow = 0, ncol = 0))
  for(row in seq_len(8)){
    #row <- 1
    #col <- 1
    for(col in row:8){

      dat <- R_intercor[R_intercor$Var1 == row & R_intercor$Var2 == col,]

      if(nrow(dat) >= 5){
        strength <- nrow(dat[dat$value < 0.05,])/nrow(dat)

      } else {
        strength <- 0
      }
      #hist(dat$value)

      #value <- p.adjust(dat$value, method = 'fdr')

      # normalized communication strength
      #strength <- length(value[value < 0.05])/length(value)
      Cor_network <- rbind(Cor_network, cbind(row, col, strength))

    }
  }
  Cor_network <- Cor_network[complete.cases(Cor_network$strength),]

  Cor_network <- Cor_network[Cor_network$strength > 0,]

  #test <- graph_from_data_frame(Cor_network[,1:2])
  #plot(test)

  return(Cor_network)
}

#######################
# Kcross function #####
#######################

bivarAnalysis.Kcross <- function(type1, type2){

  #type1 <- typeA
  #type2 <- typeB

  colnames(type1) <- c('x', 'y')

  colnames(type2) <- c('x', 'y')

  if(nrow(type1)*nrow(type2) != 0){

    # read pts dat

    type1$attr <- 'ctypeA'

    type2$attr <- 'ctypeB'

    # create multitype df
    pts_OI <- rbind(type1, type2)

    # define the type
    species <- factor(pts_OI$attr)

    # create multitype ppp

    # check if empty
    ppp1 <- ppp(type1$x, type1$y, owin(c(0,800), c(0, 800)))
    ppp2 <- ppp(type2$x, type2$y, owin(c(0,800), c(0, 800)))

    # prevent NA

    if(is.empty(ppp1) == 'FALSE' & is.empty(ppp2) == 'FALSE'){

      multitype_ppp <- ppp(pts_OI$x, pts_OI$y, marks = species, owin(c(0, 800), c(0, 800)))
      K.cross <- data.frame(Kcross(multitype_ppp, i = 'ctypeA', j = 'ctypeB', r = seq(0,20,0.1), correction = 'Ripley'))

      #plot(Gihc)
      # relocat DF

      K.cross <- K.cross[complete.cases(K.cross),]

      # calculate the area (positive - negative )
      K.cross$rs <- K.cross$iso - K.cross$theo

      A.to.B.diff.area <- trapz(K.cross$r, K.cross$iso)

      # j to i

      K.cross <- data.frame(Kcross(multitype_ppp, i = 'ctypeB', j = 'ctypeA', r = seq(0,20,0.1), correction = 'Ripley'))

      K.cross <- K.cross[complete.cases(K.cross),]

      K.cross$iso <- K.cross$iso - K.cross$theo
      K.cross <- K.cross[complete.cases(K.cross),]
      B.to.A.diff.area <- trapz(K.cross$r, K.cross$iso)

    } else {

      A.to.B.diff.area <- NA
      B.to.A.diff.area <- NA

    }
  } else {
    A.to.B.diff.area <- NA
    B.to.A.diff.area <- NA
  }
  return(list(A.to.B.diff.area, B.to.A.diff.area))
}

#----------------------------------------------------#
# generate poisson distribution ppp from a given ppp #
#----------------------------------------------------#

poisp <- function(pos_Target, nsim){

  #pos_Target <- tPos

  n <- nrow(pos_Target)

  simpp <- runifpoint(n = n, win = owin(c(0, 800), c(0, 800)), nsim = nsim)

  # return the result
  return(simpp)
}

#-----------------------------#
# Find number of interactions #
#-----------------------------#

nnIntrxn <- function(sDF, simDF){ # sDF: the coordiantes for the source point pattern

  #sDF <- sPos
  if(nrow(sDF) == 0 | nrow(simDF) == 0){
    simInt <- 0
  } else{
    dist <- nn2(simDF, query = sDF, k = nrow(simDF), treetype = 'kd', searchtype = 'radius', radius = 20)

    nn.idx <- data.frame(dist$nn.idx)

    nn.idx$source <- seq_len(nrow(sDF))

    nn.merge <- melt(nn.idx, id.vars = 'source')

    # clear non-valid rows
    nn.merge <- nn.merge[nn.merge$value != 0, -2]

    # remove itself

    nn.merge$diff <- nn.merge$source - nn.merge$value
    nn.merge <- nn.merge[nn.merge$diff != 0, -3]

    simInt <- nrow(nn.merge)
  }

  # replace by real cell type
  return(simInt)
}

#-----------------------------#
#           cor.mtest         #
#-----------------------------#

cor.mtest <- function(mat, ...) {
  mat <- as.matrix(mat)
  n <- ncol(mat)
  p.mat<- matrix(NA, n, n)
  diag(p.mat) <- 0
  for (i in 1:(n - 1)) {
    for (j in (i + 1):n) {
      tmp <- cor.test(mat[, i], mat[, j], ...)
      p.mat[i, j] <- p.mat[j, i] <- tmp$p.value
    }
  }
  colnames(p.mat) <- rownames(p.mat) <- colnames(mat)
}


 ZPSTRF Example Program Results

 Computed rank:   3

 Factor
                1             2             3             4             5
 1  ( 3.52, 0.00)
 2  ( 0.68, 0.00) ( 1.08, 0.00)
 3  ( 1.27, 0.00) ( 0.26, 0.00) ( 0.18, 0.00)
 4  ( 1.56, 0.01) (-0.02, 0.08) ( 0.01,-0.05) ( 0.00, 0.00)
 5  ( 3.38, 0.00) (-0.45, 0.00) (-0.17, 0.00) ( 0.00, 0.00) ( 0.00, 0.00)

 PIV
                1             2             4             3             5


#' Linear Model Fitter
#'
#' @description
#' Basic linear model fitters.
#'
#' @details
#' \code{lm_fit()} corresponds to R's \code{lm.fit()}.  The returned object is
#' mostly identical between the two functions.  There are a few key differences
#' worth noting.  First, the QR algorithm employed is different, and so the
#' \code{qr} matrix and \code{qraux} vector are unlikely to agree.
#' Additionally, when the data matrix \code{x} is assumed to be full rank and
#' it has more columns (predictors) than rows (observations), the returned
#' coefficients vector will not have \code{NA}'s after the first "rank" values,
#' as R's \code{lm.fit()} does.  Finally, we always return a matrix of
#' coefficients, effects, fitted values, and residuals, regardless of the number
#' of "right hand sides" (number of columns of the response \code{y}).  +R's
#' \code{lm.fit()} will return a vector when there is one right hand side, and
#' a matrix otherwise.
#'
#' \code{.lm_fit()} corresponds to R's \code{.lm.fit()}.  The above caveats
#' also hold.
#'
#' \code{.lm_fit_minimal()} does not correspond to an existing R function.  It
#' exists for personal reasons.  Note that it does not do less work than
#' \code{.lm_fit()}. It is "minimal" in the return, in that it does not return
#' unnecessary QR or miscellaneous, easily inferred information about the model
#' fit.  The return is subject to change at this time.
#'
#' @param x
#' The input data matrix.
#' @param y
#' The vector/matrix of independent variable(s).
#' @param intercept
#' Should an intercept term be included?
#'
#' @examples
#' \dontrun{
#' library(linmod2)
#'
#' n <- 10
#' p <- 3
#' x <- matrix(rnorm(n*p), n, p)
#' y <- rnorm(n)
#'
#' .lm_fit(x, y)
#' }
#'
#' @return
#' It's complicated. The returns are mostly identical to their corresponding R
#' function counterparts.  However, there are a few notable differences.  See
#' the details section for more information..
#'
#' @rdname lm_fit
#' @name lm_fit
NULL

#' @rdname lm_fit
#' @export
.lm_fit_minimal <- function(x, y, intercept=FALSE)
{
  .Call(R_dot_lm_fit_minimal, x, y, intercept)
}

#' @rdname lm_fit
#' @export
.lm_fit <- function(x, y, intercept=FALSE)
{
  .Call(R_dot_lm_fit, x, y, intercept)
}

#' @rdname lm_fit
#' @export
lm_fit <- function(x, y, intercept=FALSE)
{
  .Call(R_lm_fit, x, y, intercept)
}


# For experiment in the dataset folder:
# - Compute the ARI using the true clusters (in the data folder) and the z samples
# - Compute the negative loglikelihood of the true lengths given some prediction samples.
# store the results in a csv file.
# author: Alberto Lumbreras

source('R/metrics.r')

pairwise_posterior <- function(traces_z){
  n_samples <- dim(traces_z)[1]
  n_dim <- dim(traces_z)[2]
  pairwise <- matrix(0, n_dim, n_dim)
  for(i in 1:n_samples){
    pairwise <- pairwise + apply(traces_z[i,,drop=FALSE], 2, function(x) as.numeric(x==traces_z[i,,drop=FALSE]))
  }
  return(pairwise/n_samples)
}

least_squares_clustering <- function(traces_z, pairwise){
  best_sample <- traces_z[1,]
  lse_min <- 1000000000
  for(i in 1:nrow(traces_z)){
    lse <- sum((apply(traces_z[i,,drop=FALSE], 2, function(x) x==traces_z[i,,drop=FALSE]) - pairwise)^2)
    if (lse < lse_min){
      LSE_min <-  lse
      best_sample <- traces_z[i,]
    }
  }
  return(best_sample)
}

evaluate <- function(experiment.path, burnin){
  # Get prediction samples for P_test and compute negative loglikelihood by comparing the predictions
  # with the y_tes

  P_test <- read.csv(file.path("./data/", dataset, "/test_participations_50.csv"), sep='\t')
  y_test <- read.csv(file.path("./data/", dataset, "/test_lengths_50.csv"), sep='\t')$y
  z_true <- read.csv(file.path("./data/", dataset, "/data_users_50.csv"), sep='\t')$z

  traces.path <- file.path(experiment.path, 'traces')
  traces_coefficients <- read.csv(file.path(traces.path, 'traces.coefficients.trc'), sep='')[-c(1:burnin),]
  traces_intercept <- read.csv(file.path(traces.path, 'traces.intercept.trc'), sep='')[-c(1:burnin),]
  traces_noise_inv <- read.csv(file.path(traces.path, 'traces.noise_inv.trc'), sep='')[-c(1:burnin),]
  traces_coefficients <- as.matrix(traces_coefficients)
  traces_noise_inv <- as.matrix(traces_noise_inv)

  # Negative loglikelihood
  negloglike <- -loglike(y_test, P_test, traces_coefficients, traces_intercept, traces_noise_inv)
  cat("\n\n", experiments[i], "negloglike:", negloglike)

  # Mean squared error
  meanse <- mse(y_test, P_test, traces_coefficients, traces_intercept, traces_noise_inv)
  cat("\n", experiments[i], "mse:", meanse)

  # Adjusted Rand Index
  traces_z <- read.csv(file.path(traces.path, 'traces.z.trc'), sep='')[-c(1:burnin),]
  traces_z <- as.matrix(traces_z)
  pairwise <- pairwise_posterior(traces_z[5000:5200,])
  ls_z <- least_squares_clustering(traces_z[5000:5200,], pairwise)
  ari = adjustedRandIndex(z_true, ls_z)
  cat("\n", experiments[i], "ARI:", ari)

  # Plot pairwise clustering and predictions
  image(1:dim(pairwise)[1], 1:dim(pairwise)[1], pairwise, col= gray((0:128)/128),
        xlab="", ylab= "", asp=1, axes=FALSE)
  axis(1,seq(0,50, by=10),seq(0,50, by=10), pos=0.5)
  axis(2,seq(0,50, by=10),seq(0,50, by=10), pos=0.5)
  title(experiments[i])

  # Save to file
  model <- strsplit(strsplit(experiment.path, "/")[[1]][3], '_')[[1]][1]
  nthreads <- strsplit(strsplit(strsplit(experiment.path, "/")[[1]][3], '_')[[1]][3], "-")[[1]][1]
  write.table(t(c(experiment.path, model, nthreads, negloglike, ari)),
              file=file.path("out", dataset, "results.csv"), sep='\t', col.names=FALSE, row.names=FALSE, append=TRUE)

}

###################################
library(doParallel)
library(foreach)
library(parallel)

par(mfrow=c(3,3))
burnin <- 10000

# Load test set
dataset <- 'iris'
dataset <- 'overlapped'
dataset <- 'clear'
dataset <- 'confused_features' #mediamining
dataset <- "disagreement"
dataset <- "agreement"

# Experiments that have not been yet evaluated
experiments <- list.dirs(path = file.path("out", dataset), recursive=F, full.names = T)
experiments.evaluated <- read.csv(file.path('out', dataset, 'results.csv'), sep='\t', head=FALSE)[,1]
experiments <- experiments[! experiments %in% experiments.evaluated]

if(length(experiments)>0){
  ncores <- detectCores() - 2
  cl<-makeCluster(ncores, outfile="", port=11439)
  registerDoParallel(cl)
  pck = c('mclust')
  foreach(i=1:length(experiments), .packages = pck)%dopar%evaluate(experiments[i], burnin)
  stopCluster(cl)
}else{
  cat("\nThere aren't new experiments to evaluate")
}


upper.tri(1:12 %o% 1:12, diag = TRUE) * 1:12 %o% 1:12


#' Handle outliers
#'
#' @param methylation DNA methylation matrix, one row per CpG site,
#' one column per sample.
#' @param method The method for handling outliers.  Options are 'iqr' (default) and 'winsorize'.
#' The 'iqr' option sets observations beyond a user-defined mutliple of the inter-quartile
#' (\code{iqr.limit}) to \code{NA}.  The 'winsorize' option sets observations beyond
#' the \code{winsorize.pct} or \code{1-winsorize.pct} percentiles to the corresponding
#' percentile.
#' @param iqr.limit The multiple of IQR beyond which observations
#' should be set to NA. Default is 3.
#' @param winsorize.pct The percentile used for winsorizing observations. Default is 0.05.
#' @return List containing the methylation matrix with outliers modified
#' depending on the method selected, and a log of how many observations were
#' identified for each probe.
#'
#' @export
ewaff.handle.outliers <- function(methylation, method=c("iqr","winsorize"), iqr.limit=3, winsorize.pct=0.05) {

    method <- match.arg(method)

    stopifnot(is.matrix(methylation))
    if(nrow(methylation) < ncol(methylation))
        warning("expecting CpG methylation as rows (long dataset)")

    if (method == "iqr") {
        iqr.trim(methylation, iqr.limit)
    }
    else {
        winsorize(methylation, winsorize.pct)
    }

}

iqr.trim<-function(methylation, iqr.limit=3) {
    ## find outlying observations more extreme that the iqr.limit
    quantiles <- matrixStats::rowQuantiles(methylation, probs = c(0.25, 0.75), na.rm = T)
    iqr <- quantiles[,2] - quantiles[,1]
    low <- quantiles[,1]
    upper <- quantiles[,2]

    initial.missing <- rowSums(is.na(methylation))

    methylation[methylation < low - iqr.limit * iqr] <- NA
    outliers.lower <- rowSums(is.na(methylation)) - initial.missing

    methylation[methylation > upper + iqr.limit * iqr] <- NA
    outliers.upper <- rowSums(is.na(methylation)) - initial.missing - outliers.lower

    n <- ncol(methylation) - initial.missing - outliers.upper - outliers.lower
    log <- data.frame(outliers.lower, outliers.upper, n)

    return(list(methylation=methylation, log=log))
}

winsorize <- function(methylation,pct=0.05) {
    quantiles <- matrixStats::rowQuantiles(methylation, probs=c(pct,1-pct), na.rm=T)
    low <- quantiles[,1]
    upper <- quantiles[,2]

    outliers.lower <- rowSums(methylation < low, na.rm=T)
    outliers.upper <- rowSums(methylation > upper, na.rm=T)

    idx <- which(methylation < low, arr.ind=T)
    methylation[idx] <- low[idx[,1]]

    idx <- which(methylation > upper, arr.ind=T)
    methylation[idx] <- upper[idx[,1]]

    n <- rowSums(!is.na(methylation))
    log <- data.frame(outliers.lower, outliers.upper, n)

    return(list(methylation=methylation, log=log))
}


 ZGEBRD Example Program Results

 Diagonal
   -3.0870   2.0660   1.8731   2.0022
 Superdiagonal
    2.1126   1.2628  -1.6126


 DSYTRF Example Program Results

 Details of factorization
             1          2          3          4
 1      2.0700
 2      4.2000     1.1500
 3      0.2230     0.8115    -2.5907
 4      0.6537    -0.5960     0.3031     0.4074

 IPIV
            -3         -3          3          4


# First drift model

source('./../../gwloggeR/R/fourier.R')

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name) {
  compare(read.baro(logger.name), read.baro('KNMI_20200312_hourly'))
}

plt.comp <- function(TIMESTAMP_UTC, Y, lm = NULL, front_layer = NULL,
                     xlim = range(TIMESTAMP_UTC), ylim = quantile(Y, c(0.005, 0.995))) {

  force(TIMESTAMP_UTC); force(Y); force(lm)
  force(ylim); force(xlim)

  p <- ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = 'red', alpha = 0.9)

  if (!is.null(lm))
    p <- p + ggplot2::geom_line(mapping = ggplot2::aes(y = lm$fitted.values), col = 'black', size = 1.5)

  if (!is.null(lm[['btrend']]) && summary(lm)$coefficients['btrend',4] < 0.0001)
    p <- p + ggplot2::geom_vline(xintercept = TIMESTAMP_UTC[which.max(lm$btrend > 0)],
                                 col = 'blue', linetype = 'dotted', size = 1.2)

  p <- p +
    ggplot2::coord_cartesian(ylim = ylim, xlim = xlim) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                   axis.title.x = ggplot2::element_blank(),
                   axis.title.y = ggplot2::element_blank())

  p
}

report <- function(logger.name) {

  print(logger.name)

  df.diff <- ref.compare(logger.name)

  if (nrow(df.diff) < 10L) return(invisible(FALSE))

  lm0 <- lm(PRESSURE_DIFF ~ 1, data = df.diff)

  trend <- c(0, cumsum(diff(as.numeric(df.diff$TIMESTAMP_UTC))/3600/24))
  breakpoints <- seq(from = 1, to = nrow(df.diff), by = 10)

  sbasis <- fbasis(timestamps = df.diff$TIMESTAMP_UTC, frequencies = 1/(365.25*3600*24))
  df.seasonal <- data.frame(PRESSURE_DIFF = df.diff$PRESSURE_DIFF,
                            sin = sbasis$`sin(31557600)`,
                            cos = sbasis$`cos(31557600)`)

  lms <- lm(formula = PRESSURE_DIFF ~ . + 1, data = df.seasonal)

  lmt <- lm0
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .lm <- lm(PRESSURE_DIFF ~ btrend + 1, data = df.diff)
    .lm[['btrend']] <- btrend
    if (logLik(.lm) > logLik(lmt)) lmt <- .lm
  }

  lmts <- lm0
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .lm <- lm(PRESSURE_DIFF ~ btrend + . + 1, data = df.seasonal)
    .lm[['btrend']] <- btrend
    if (logLik(.lm) > logLik(lmts)) lmts <- .lm
  }

  p.comp <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF)

  p.lm0 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, lm0)

  p.lms <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, lms)

  p.lmt <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, lmt)

  p.lmts <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, lmts)

  # File export ----------------------------------------------------------------

  filename <- sprintf('./drifts/analysis_23/%s.png', tools::file_path_sans_ext(basename(logger.name)))
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)

  layout_matrix <- rbind(c(1, 2),
                         c(3, 4),
                         c(5, 6))

  grob.title <- grid::textGrob(sprintf('%s (#%s differences with KNMI data from %s to %s)',
                                       basename(logger.name), nrow(df.diff),
                                       min(df.diff$TIMESTAMP_UTC), max(df.diff$TIMESTAMP_UTC)),
                               x = 0.05, hjust = 0)

  p.empty <- ggplot2::ggplot() + ggplot2::theme_void()

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    gridExtra::grid.arrange(p.comp, p.empty,
                            p.lm0, p.lms,
                            p.lmt, p.lmts,
                            layout_matrix = layout_matrix,
                            top = grob.title)
  })

  invisible(TRUE)

}

# report('BAOL009X_78680')
invisible(lapply(logger.names, report))


# Demo 4, 9.10.2014
# Example solutions
# Heini Saarimäki

# -

# 1.2 Import data

setwd('Z:/Desktop/Demo4')

students <- read.table('http://becs.aalto.fi/~heikkih3/students', header=T, sep="")

# -

# Question 1

head(students)
summary(students)

# notice that Educ is not yet coded as a factor,
# and that Extra has a lot of missing values (NA's)
# and that Stress has funny values (999's): probably tried to code as missing values

# recode factor Educ as factor:

students$Educ <- factor(students$Educ)
dim(students)

# locate the outliers:

which(students$Stress == 999)
# rows 37, 40, 43, 46, 50

# -

# Question 2

# values 999 in variable Stress look like an attempt to code NAs

# recode these to NAs and save to a new data frame 'students2':

students2 <- students
students2$Stress[which(students2$Stress == 999)] <- NA

summary(students2)

# -

# Question 3

# The benefit is that you can compare different analysis strategies.

# For instance, you might argue that anyone with an "Hours" score of over 10
# has missed too much of the course to engage with it and properly apply
# themselves to the exam/rate the teacher (difficult if they have missed nearly
# all the classes!), and exclude them from analysis.

# However, another researcher might disagree. You could save one version with
# the cases deleted to data2, and another version with them included to data3.

# Then you could run your analyses on data2 and data3 to see whether the removal
# has any effect. And the original dataset is never overwritten in this process.

# -

# attach the data frame at this point:

attach(students2)

# -

# Question 4

# plotting:

names(students2)

# histograms:

layout(matrix(c(1,2,3,4,5,6),3,2))
hist(Performance)
hist(Hours)
hist(Rating)
hist(Entry)
hist(Stress)
hist(Extra)

# boxplots:

layout(matrix(c(1,2,3,4,5,6),3,2))
boxplot(Performance, main="Performance")
boxplot(Hours, main="Hours")
boxplot(Rating, main="Rating")
boxplot(Entry, main="Entry")
boxplot(Stress, main="Stress")
boxplot(Extra, main="Extra")

# Scatterplots:

plot(students2)

# -

# Question 5

# There appear to be some trends:
# A weak negative association between "Performance" and "Hours" and
# a positive association between "Performance" and "Rating", and an
# even weaker positive association between "Performance" and "Stress".

# Note only the few observations in "Extra".

# ---

# 2. Correlations

# 2.1 Pearson product-moment correlation coefficient:

# take the correlation between two variables:

cor.test(Performance, Hours)

# plot the relationship:

plot(Performance, Hours)

# take the whole correlation matrix for the data frame:

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

corr.test(students2[c(1:2,4:7)])	# include only the numeric variables

# -

# Question 6

# There are no correlations between:
# Extra and any other variable (!)
# Performance and Entry
# Entry and Rating
# Stress and Rating
# Entry and Stress

# -

# Question 7

# maximum sample size 228
# minimum sample size 37

# This matters because if we used the variable with just 37 cases ("Extra")
# we will be greatly limiting out power. If you look at the size of the
# correlations, "Extra" correlates at r=.31 with "Entry" yet is non-significant.
# The sample size for this variable isn't large enough to have confidence in
# the results.

# -

# Question 8

plot(students2)

# "Extra" is non-significant for the reasons given above: inspection of the
# plots shows "Extra" has far fewer data points (only 37) than the other plots.

# -

# Question 9

# No. Note that "Hours" correlates negatively with ALL the other variables.

# ---

# 2.2 Spearman rank correlation coefficient:

# take correlation using rank correlation coefficient:

cor.test(Performance, Hours, method="spearman")

# -

# Question 10

# correlation matrix using rank correlation coefficient:

corr.test(students2[c(1:2, 4:7)], method="spearman")

# -

# Question 11

# save results of correlation using both product-moment and rank coefficients:

pearson <- corr.test(students2[c(1:2, 4:7)])
spearman <- corr.test(students2[c(1:2, 4:7)], method="spearman")

# observe the structure of the correlation matrix object:

str(pearson)

# take out just p value matrix:

pearson$p

# if you want to round things:

round(pearson$p, 2)
round(spearman$p, 2)

# Now you can compare the matrices above.
# Note that Pearson and Spearman give almost similar results.
# The biggest difference is that with Spearman, the correlation
# between "Performance" and "Stress" is not significant.
# if you want to look up the correlation coefficients:

round(pearson$r, 2)
round(spearman$r, 2)

# coefficients vary only slightly between the two methods

# ---

# 2.3 Partial correlations

install.packages('ppcor')
library(ppcor)
?pcor.test

pcor.test(Performance, Entry, Hours)

# -----

# 3. Regression

# ---

# 3.1 Running a basic model

# does attendance (Hours) predict performance in exam (Performance)?

model1 <- lm(Performance ~ Hours)

summary(model1)

# --> attendance predicts exam performance (b=-3.3, t(226)=-5.18, p<.001)
# --> attendance explain 10% of the variance in performance (F(1,226)=26.83, p<.001, adjusted R^2 = 0.10)

# ---

# 3.2 Evaluating assumptions

# Multicollinearity

# i.e. whether predictors correlate strongly with each other

corr.test(students2[c(1:2, 4:7)])

# --> no very strong correlations in this data set
# (all correlations < 0.4)

# -

# Normality

# look at the qq-plot, histogram or explicit tests for normality (see Demo 3)

# see Question 4 for histograms:
# all variables except for "Extra" seem to be normally distributed

# -

# Homoscedasticity

# i.e. are the residuals random?

# you can either look at the "Residuals vs Fitted" plot in regression plots
# (residuals should be equally distributed, i.e. no trends)

plot(model1)

# or test for homoscedasticity explicitly (test result should be non-significant):

install.packages('car')
library(car)
ncvTest(model1)

# -

# Influential cases

# i.e. look whether any cases unduly influence the model

# you can look at "Residuals vs Leverage" plot in regression plot:
# shows Cook's distances, should be below 0.5 or 1
# the 0.5 and 1 levels are shown with dashed red line
# in this model, no highly influential cases (you cannot even see the dashed red line!)

# you can also test for influential cases separately:
# the column labeled "cook.d" shows values for Cook's distances,
# and these should be below 0.5

influence.measures(model1)

# ---

# 3.3 Multiple regression

# do attendance (Hours) and performance at the beginning of the course (Entry)
# predict performance in exam (Performance)?

model2 <- lm(Performance ~ Hours + Entry)

summary(model2)

# --> attendance predicts performance (b=-3.4, t(225)=-5.2, p<.001)
# --> but entry performance does not
# --> model fits data and explains 10% of variance in Performance (F(2,225)=13.7, p<.001), adjusted R^2=0.10)
# --> but is the fit better than in model1 (see Question 13)?

# -

# Question 12

# the new predictor Entry is not significant

# -

# Question 13

# compare models:

anova(model1,model2)

# adding Entry as a predictor does not improve the model fit significantly

# -

# Question 14

# we should not keep Entry, because adding it in model makes the model more
# parsimonious (complex) with no meaningful increase in fit

# -

# Question 15

# Extra has very few cases. As a result it will make any model that uses it
# as a predictor very low-powered and it is best ignored.

# see what happens:

model.x <- lm(Performance ~ Extra)
summary(model.x)

# the model is not significant (F(1,35)=1.13, p=0.296)

# -

# Question 16

# do attendance (Hours) and opinion about the course (Rating) predict
# performance in exam (Performance)?

model3 <- lm(Performance ~ Hours + Rating)

# -

# Question 17

summary(model3)

# --> Rating is a significant predictor (b=1.7, t(225)=2.4, p<.05)

# -

# Question 18

# model fit in model 1 is 0.10, in model 3 0.12
# i.e. model 3 explains a bit more variance, but is it significantly more?

anova(model1, model3)

# --> model 3 fits data better than model 1 (p<.05)

# -

# Question 19

# you should examine Adjusted R-squared value in summary() output

# -

# Question 20

# a little over 12%

# ---

# 3.4 Interactions

# do attendance (Hours) and opinion (Rating) and their interaction
# predict performance in exam (Performance)?

model4 <- lm(Performance ~ Hours * Rating)

# -

# Question 21

# main effects

# -

# Question 22

summary(model4)

# --> interaction is not significant

# -

# Question 23

anova(model3,model4)

# --> adding interaction does not improve model fit

# ---

# 3.5 Nonlinear effects

# create a new variable in the data frame:

students2$Rating2 <- students2$Rating^2
attach(students2)
summary(students2)

# -

# Question 24

# quadratic function takes the shape of either u-shape or inverted u-shape

# -

# Question 25

# does Rating2 predict Performance?

model5 <- lm(Performance ~ Rating + Rating2)
summary(model5)

# --> Rating2 does not predict Performance
# therefore, the trend is not quadratic. a linear trend is the best explanation of the association.

# -

# Question 26

# let's try a full model!
# include all other variables except for Extra (it has a lot of missing values)

names(students2)

model6 <- lm(Performance ~ Hours * Educ * Rating * Entry * Stress)

summary(model6)

# --> none of the predictors is significant
# --> model is very complicated, but not significant

# multiple R^2 increases by a large margin (from 0.13 in model 3 to 0.27 in model 6)
# adjusted R^2 actually decreases (0.12 in model 3 to 0.08 in model 6)

# -

# Question 27

# adjusted R^2 penalizes for complexity. inclusion of "junk" predictors
# does not improve the quality of the model.
# multiple R^2 will not account for the need for parsimony, and will increase
# as further predictors are added.
# adjusted R^2 is the more useful value.

# -----

# 4. Contrasts

summary(students2)

# -

# Building up contrasts

levels(Educ)
contrasts(Educ) <- cbind(c(-0.5, -0.5, 1), c(1, -1, 0))

# -

# Running the comparison

attach(students2)

A1 <- aov(Performance ~ Educ)

summary(A1)

M1 <- lm(Performance ~ Educ)

summary(M1)

# -----

# 5. Exercises

naming <- read.csv("http://becs.aalto.fi/~heikkih3/naming_wide.csv", header=T)

# are factors coded as factors? are there extreme outliers?

summary(naming)

layout(matrix(c(1,2,3,4),2,2))
boxplot(naming$iq, main="iq")
boxplot(naming$hrs, main="hrs")
boxplot(naming$ms.regular, main="ms.regular")
boxplot(naming$ms.exception, main="ms.exception")

# --> factors are already coded as factors, no extreme outliers or missing values

attach(naming)

# -

# Question 28

plot(naming)
corr.test(naming[c(1:2,4:5)])

# -

# Question 29

# yes, sample size in all variables is 998

# -

# Question 30

# Significant correlations:
# strong negative correlation between iq and time spent reading regular words (r=-0.6, p<.001)
# negative correlation between iq and time spent reading exceptional words (r=-0.4, p<.001)
# weak negative correlation between reading hours and time spent reading regular words (r=-0.1, p<.001)
# negative correlation between reading hours and time spent reading exceptional words (r=-0.3, p<.001)
# also a positive correlation between time spent reading regular and exceptional words (r=0.3, p<.001)

# Verbal interpretation:
# higher IQ is related to faster reading times of both regular and exceptional words
# more reading hours is related to faster reading times especially in exceptional words
# reading times of both regular and exceptional words are related

# -

# Question 31

# does IQ predict reading times of regular words?

model.1 <- lm(ms.regular ~ iq)

# H0: IQ does not predict reading times of regular words
# H1: IQ predicts reading times of regular words

# -

# Question 32

summary(model.1)

# --> IQ predicts reading time of regular words (b=-3.0, t(996)=-23.7, p<.001)
# --> IQ explains 36% of the variance in reading times (F(1,996)=560.3, p<.001, adjusted R^2 = 0.36)

# -

# Question 33

# do IQ and reading hours predict reading times of regular words?

model.2 <- lm(ms.regular ~ iq + hrs)
summary(model.2)

# --> also reading hours predict reading times of regular words (b=-15, t(995)=-3.97, p<.001)
# --> model explains 37% of the variance in reading times (F(2,995)=292.2, p<.001, adjusted R^2 = 0.36)

# -

# Question 34

# which model fits the data better?

anova(model.1, model.2)

# --> model 2 fits the data better

# i.e., adding reading hours in the model significantly improves the fit
# we should keep both IQ and reading hours in the future models

# -

# Question 35

# does adding interaction in the model improve it?

model.3 <- lm(ms.regular ~ iq * hrs)
summary(model.3)

# --> interaction effect is not significant

# compare model 2 and 3:

anova(model.2,model.3)

# --> adding interaction effect does not improve the model

# -

# Question 36

# notice that in the exercise sheet the instruction told you to use effects coding;
# in fact, we did not go through this but instead used contrasts in the examples
# I added both solutions below:

# 1) you could solve this by using contrasts this way:

# check the order of the categories
levels(reading_time)
# then add the contrast comparing high and low reading groups
contrasts(reading_time) <- c(1,-1,0)

# 2) or, you can create a new variable (here, ec_1) which codes effect (=comparison) between low and high reading groups

naming$ec_1 <- 0
naming$ec_1[which(reading_time=="low")] <- -1
naming$ec_1[which(reading_time=="high")] <- 1

head(naming)
attach(naming)

# -

# Question 37

# 1) using contrasts:

anova.1a <- aov(ms.regular ~ reading_time)
summary(anova.1a)
summary.lm(anova.1a)

# 2) or using effects coding:

anova.1b <- aov(ms.regular ~ ec_1)
summary(anova.1b)

boxplot(ms.regular ~ ec_1)

# --> low and high reading groups differ significantly

# -

# Question 38

# 1) using contrasts:

# check the order of the categories
levels(reading_time)
# then add a contrast comparing high and low reading groups, and another contrast comparing high and medium groups
contrasts(reading_time) <- cbind(c(1,-1,0), c(1,0,-1))

# 2) or using effects coding:

naming$ec_2 <- 0
naming$ec_2[which(reading_time=="medium")] <- -1
naming$ec_2[which(reading_time=="high")] <- 1

attach(naming)

# -

# Question 39

# 1) using contrasts:

anova.2a <- aov(ms.regular ~ reading_time)
summary.lm(anova.2a)

# 2) or using effects coding:

anova.2b <- aov(ms.regular ~ ec_2)
summary(anova.2b)

# --> medium and high reading groups do not differ significantly


x=read.table('output.score',header=F)
cor(x[,2],x[,3])^2


# fit_robust_linear_model.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Returns a matrix by rows, with the intercept and p-value, and coefficient and
# p-value, of a robust linear model fitted to the input data.
#
# Reverts to a standard linear model in case of no convergence.

fit.robust.linear.model <- function( x.data, y.data, x.name, y.name, asp )
{
    xy.data <- data.frame( x = x.data, y = y.data )

    xy.model <- rlm( y ~ x, xy.data, maxit = asp$rlm.iter.max )

    if ( xy.model$converged )
    {
        xy.coef <- xy.model$coefficients
        xy.t <- summary( xy.model )$coefficients[ , 3 ]
        xy.df <- summary( xy.model )$df[ 2 ]
        xy.pval <- 2*( pt( abs( xy.t ), xy.df, lower.tail = FALSE ) )
    }
    else
    {
        cat( sprintf( "WARNING: rlm of %s ~ %s did not converge - then using ols\n",
            y.name, x.name ), file = stderr() )

        xy.model <- lm( y ~ x, xy.data )

        xy.coef <- xy.model$coefficients
        xy.pval <- summary( xy.model )$coefficients[ , 4 ]
    }

    res <- cbind( xy.coef, xy.pval )
    dimnames( res ) <- NULL
    res
}


# ST3068/ST2054 -- tutorial -- 21 October 2016
# Summer Exam 2009 in the course ST2054
# Question 2

sample_dist_1 = function() {
  n = sample(x = c(0,1), 1, replace = FALSE, prob = c(0.2, 0.8));
  return(n)
}

sample_dist_2 = function() {
  n = sample(x = c(0,1), 1, replace = FALSE, prob = c(0.3, 0.7));
  return(n)
}

sample_dist_3 = function() {
  n = sample(x = c(0,1), 1, replace = FALSE, prob = c(0.4, 0.6));
  return(n)
}

x_count = 0;
run_count = 10000;

for (i in 1:run_count) {

  player_1 = sample_dist_1();
  player_2 = sample_dist_2();
  player_3 = sample_dist_3();

  if ((player_1 == 1) || (player_2 == 1) || (player_3 == 1)) {
    if (player_3 == 1){x_count = x_count + 1}
  }
}
print (x_count/run_count)


library('OpenMx')

setwd('~/git/sem_python/tests')
data <- read.csv('Demo_twolevel_missing.csv')
#data <- read.csv('Demo_twolevel.csv')

y <- c('y1', 'y2', 'y3')
x <- c('x1', 'x2', 'x3')
w <- c('w1', 'w2')
manifest_l1 <- c(y)
latent_l1 <- c('fw', x)
manifest_l2 <- c()
latent_l2 <- c('fb', y, w)
level2 <- data[!duplicated(data$cluster),]

between <- mxModel(
  "between",
  type="RAM",
  manifestVars=manifest_l2,
  latentVars=latent_l2,
  mxData(observed=level2, type="raw", primaryKey="cluster"),
  mxPath(from=y, arrows=2, free=TRUE, values=diag(var(data[y], na.rm=TRUE)), labels=paste0("y",1:3,"_var")),
  mxPath(from='fb', arrows=2, free=FALSE, values=1, labels="fb_var"),
  mxPath(from=y, arrows=2, free=TRUE, values=1, labels=paste0("y",1:3,"_var_b")),

  mxPath(from='fb', to=y, arrows=1, free=TRUE, values=1, labels=c('fb_y1', 'fb_y2', 'fb_y3')),

  mxPath(from=w, to='fb', free=TRUE, labels=paste0('w',1:2,"_fb")),
  mxPath(from='one', to=w, free=FALSE, labels=paste0("data.w",1:2)),
  mxPath(from='one', to=y, free=TRUE))

within <- mxModel(
  "Demo_twolevel",
  type="RAM",
  between,
  manifestVars=manifest_l1,
  latentVars=latent_l1,
  mxData(observed=data, type="raw"),
  mxPath(from=y, arrows=2, free=TRUE, values=diag(var(data[y], na.rm=TRUE)) / 2, labels=paste0("y",1:3,"_var_w")),
  mxPath(from='fw', arrows=2, free=FALSE, values=1, labels="fw_var"),

  mxPath(from='fw', to=y, arrows=1, free=TRUE, values=1, labels=c('fw_y1', 'fw_y2', 'fw_y3')),
  mxPath(from=x, to='fw', arrows=1, free=TRUE, values=1, labels=c('x1_fw', 'x2_fw', 'x3_fw')),

  mxPath(paste0('between.y',1:3), paste0('y',1:3), values=1, free=FALSE, joinKey="cluster"),

  mxPath(from='one', to=manifest_l1, values=0, free=FALSE),
  mxPath(from='one', to=x, free=FALSE, values=0, labels=paste0("data.x",1:3)))

fit <- mxRun(within)

summary(fit)


rmse <- function(data)
{
  return(sqrt(mean(data^2)))
}


# Data Preprocessing

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

# Taking care of 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)

# Encoding categorical data
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 the Training set and Test set
# install.packages('caTools')
library(caTools)
set.seed(123)

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

# Feature Scaling
training_set[, 2:3] = scale(training_set[, 2:3])
test_set[, 2:3] = scale(test_set[, 2:3])


library(lwgeom)
library(sf)

filepath_shp <- 'data/geo/0_manual/Ecoregions2017/fixing/invalid_geom_fix3.shp'

to_fix <-  read_sf(filepath_shp)
fixed <- st_make_valid(to_fix)
st_is_valid(fixed)

filename_out <- paste0(gsub(".shp", "", filepath_shp), "_fixed.shp")
st_write(fixed, filename_out, driver="ESRI Shapefile")


library(dplyr)

bnames <- read.csv("../data/bnames.csv", stringsAsFactors = FALSE)
head(bnames)

# Whole dataset transformations ---------------------------------------------
letter <- function(x, n = 1) {
  if (n < 0) {
    nc <- nchar(x)
    n <- nc + n + 1
  }
  tolower(substr(x, n, n))
}
vowels <- function(x) {
  nchar(gsub("[^aeiou]", "", x))
}

bnames <- mutate(bnames,
  first = letter(name, 1),
  last = letter(name, -1),
  length = nchar(name),
  vowels = vowels(name)
)

# Whole dataset summaries ----------------------------------------------------

summarise(bnames,
  max_perc = max(percent),
  min_perc = min(percent))

# Group-wise transformations  ------------------------------------------------

# Want to calculate rank of each name in each year (per sex).  This is easy if
# we have a single sex for a single year:
one <- filter(bnames, sex == "boy", year == 2008)
one$rank <- rank(-one$percent, ties.method = "first")
# or
one <- mutate(one, rank = rank(-percent, ties.method = "first"))
head(one)

# Conceptually if we want to perform this same task for every sex in every
# year, we need to split up the data, apply the transformation to every piece
# and then join the pieces back together

# This is what group_by and mutate do
bnames <- bnames %>% group_by(sex, year) %>% mutate(rank = rank(-percent, ties.method = "first"))

# Group-wise summaries -------------------------------------------------------

# Group-wise summaries are much more interesting!

bnames %>% group_by(name) %>% summarise(tot = sum(percent))
bnames %>% group_by(length) %>% summarise(tot = sum(percent))
bnames %>% group_by(year, sex) %>% summarise(tot = sum(percent))

fl <- bnames %>% group_by(year, sex, first) %>% summarise(tot = sum(percent))
library(ggplot2)
qplot(year, tot, data = fl, geom = "line", colour = sex, facets = ~ first)


# Solution to sorting data frames
# By http://www.markvanderloo.eu/yaRb/2014/08/15/sort-data-frame/

sort.data.frame <- function(x, decreasing=FALSE, by=1, ... ){
  f <- function(...) order(...,decreasing=decreasing)
  i <- do.call(f,x[by])
  x[i,,drop=FALSE]
}

# #examples
#sort(iris) # default is by 1st column
#sort(iris, by="Sepal.Length")
#sort(iris, by=c("Species","Sepal.Length"))
#sort(iris, by=1:2)
#sort(iris, by="Sepal.Length",decreasing=TRUE)


 ZPOCON Example Program Results

 Estimate of condition number =  1.51E+02


 DPORFS Example Program Results

 Solution(s)
             1          2
 1      1.0000     4.0000
 2     -1.0000     3.0000
 3      2.0000     2.0000
 4     -3.0000     1.0000

 Backward errors (machine-dependent)
       1.0E-16    5.0E-17
 Estimated forward error bounds (machine-dependent)
       2.3E-14    2.3E-14