rm(list = ls())

dd <- "/home/eric/Desktop/MXelsCalendGovt/elecReturns/data/"
setwd(dd)

# read raw data file
dat <- read.csv(file = "aymu1977-present.csv", stringsAsFactors = FALSE)
dim(dat)

#########################################################################
#########################################################################
##  script ayClean.r has routines used once to save a cleaner dataset  ##
#########################################################################
#########################################################################

# re-compute effective and total votes
sel <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel] # subset votes columns
v[is.na(v)==TRUE] <- 0 # replace NAs with zeroes
v[v==""|v=="NA"|v=="-"|v=="N/R"] <- 0 # replace with zeroes
for (i in 1:ncol(v)){
    v[,i] <- as.numeric(v[,i])
}
dat[,sel] <- v # return votes without missing to data
v$efec <- round(rowSums(v), 0)
dat$efec <- v$efec
tmp <- dat$nr # remove NAs
tmp[is.na(tmp)] <- 0
dat$nr <- tmp
tmp <- as.numeric(dat$nulos)  # make numeric & remove NAs
tmp[is.na(tmp)] <- 0
dat$nulos <- tmp
v$tot <- dat$efec + dat$nr + dat$nulos
dat$tot <- v$tot
rm(v, tmp)

# verify that coalition member separator is always a -
sel <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel] # subset label columns
for (i in 1:ncol(l)){
    #i <- 18 # debug
    tmp <- l[,i] # duplicate column for manipulation
    #table(gsub(pattern = "([0-9a-zA-Záéíóúñ])", replacement = "", tmp)) # keep only non-letter-number characters
    tmp <- gsub(pattern = "[ ]", replacement = "", tmp)
    tmp <- gsub(pattern = "[.,]", replacement = "-", tmp)
    #sel1 <- grep("[ ]", tmp)
    #tmp[sel1]
    l[,i] <- tmp # return to data
}
dat[,sel] <- l # return to data
rm(l)

## # replace NAs with zeroes (no longer needed)
## sel.v <- grep("^v[0-9]{2}", colnames(dat))
## v <- dat[,sel.v] # subset vote columns
## v[is.na(v)] <- 0
## dat[,sel.v] <- v # return to data
## rm(v)

# any votes with no labels?
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
for (i in 1:ncol(l)){
    #i <- 2 # debug
    sel <- which(v[,i]>0 & l[,i]=="0")
    if (length(sel)>0) print(paste("Warning!!!  i=", i, sep = ""))
    print(paste("column", i , "ok"))
}
rm(l,v)

# drop upper case from labels
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset labels columns
for (i in 1:ncol(l)){
    l[,i] <- tolower(l[,i])
    }
dat[,sel.l] <- l # return to data
rm(l)

# remove useless labels
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
for (i in 1:ncol(l)){
    #i <- 1 # debug
    sel <- which(v[,i]==0 & l[,i]!="0")
    l[sel,i] <- "0"
}
dat[,sel.l] <- l # return to data
rm(l,v)

# change confusing party labels
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset labels columns
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^c$|^cd$|^cdppn$|^pc$|^conver(gencia)?$", replacement = "conve", l[,i])
    l[,i] <- gsub(pattern = "-c-|-cd-|-cdppn-|-pc-|-conver(gencia)?-", replacement = "-conve-", l[,i])
    l[,i] <- gsub(pattern = "-c$|-cd$|-cdppn$|-pc$|-conver(gencia)?$", replacement = "-conve", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^mrn$", replacement = "morena", l[,i])
    l[,i] <- gsub(pattern = "-mrn-", replacement = "-morena-", l[,i])
    l[,i] <- gsub(pattern = "-mrn$", replacement = "-morena", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^cc$", replacement = "cc1", l[,i])
    l[,i] <- gsub(pattern = "-cc-", replacement = "-cc1-", l[,i])
    l[,i] <- gsub(pattern = "-cc$", replacement = "-cc1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pmc$", replacement = "mc", l[,i])
    l[,i] <- gsub(pattern = "-pmc-", replacement = "-mc-", l[,i])
    l[,i] <- gsub(pattern = "-pmc$", replacement = "-mc", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^mp$", replacement = "mexpos", l[,i])
    l[,i] <- gsub(pattern = "-mp-", replacement = "-mexpos-", l[,i])
    l[,i] <- gsub(pattern = "-mp$", replacement = "-mexpos", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pd$", replacement = "pd1", l[,i])
    l[,i] <- gsub(pattern = "-pd-", replacement = "-pd1-", l[,i])
    l[,i] <- gsub(pattern = "-pd$", replacement = "-pd1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pj$", replacement = "pj1", l[,i])
    l[,i] <- gsub(pattern = "-pj-", replacement = "-pj1-", l[,i])
    l[,i] <- gsub(pattern = "-pj$", replacement = "-pj1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^p?fc$|^fzaciud$|^fuerciud$", replacement = "fc1", l[,i])
    l[,i] <- gsub(pattern = "-p?fc-|-fzaciud-|-fuerciud-", replacement = "-fc1-", l[,i])
    l[,i] <- gsub(pattern = "-p?fc$|-fzaciud$|-fuerciud$", replacement = "-fc1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^p?asd?c?$|^alter(nativa)?$", replacement = "pasd", l[,i])
    l[,i] <- gsub(pattern = "-p?asd?c?-|-alter(nativa)?-", replacement = "-pasd-", l[,i])
    l[,i] <- gsub(pattern = "-p?asd?c?$|-alter(nativa)?$", replacement = "-pasd", l[,i])
    l[,i] <- gsub(pattern = "^p?asd?c?-|^alter(nativa)?-", replacement = "pasd-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pl$", replacement = "pl1", l[,i])
    l[,i] <- gsub(pattern = "-pl-", replacement = "-pl1-", l[,i])
    l[,i] <- gsub(pattern = "-pl$", replacement = "-pl1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pp$", replacement = "pp1", l[,i])
    l[,i] <- gsub(pattern = "-pp-", replacement = "-pp1-", l[,i])
    l[,i] <- gsub(pattern = "-pp$", replacement = "-pp1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pr$", replacement = "pr1", l[,i])
    l[,i] <- gsub(pattern = "-pr-", replacement = "-pr1-", l[,i])
    l[,i] <- gsub(pattern = "-pr$", replacement = "-pr1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^ps$", replacement = "ps1", l[,i])
    l[,i] <- gsub(pattern = "-ps-", replacement = "-ps1-", l[,i])
    l[,i] <- gsub(pattern = "-ps$", replacement = "-ps1", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pt$", replacement = "pt1", l[,i])
    l[,i] <- gsub(pattern = "-pt-", replacement = "-pt1-", l[,i])
    l[,i] <- gsub(pattern = "-pt$", replacement = "-pt1", l[,i])
    l[,i] <- gsub(pattern = "^pt-", replacement = "pt1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pac$", replacement = "pac1", l[,i])
    l[,i] <- gsub(pattern = "-pac-", replacement = "-pac1-", l[,i])
    l[,i] <- gsub(pattern = "-pac$", replacement = "-pac1", l[,i])
    l[,i] <- gsub(pattern = "^pac-", replacement = "pac1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^panal$", replacement = "pna", l[,i])
    l[,i] <- gsub(pattern = "-panal-", replacement = "-pna-", l[,i])
    l[,i] <- gsub(pattern = "-panal$", replacement = "-pna", l[,i])
    l[,i] <- gsub(pattern = "^panal-", replacement = "pna-", l[,i])
    }
#
# avoid "na" in csv, recognized as missing...
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^na$", replacement = "pna", l[,i])
    l[,i] <- gsub(pattern = "-na-", replacement = "-pna-", l[,i])
    l[,i] <- gsub(pattern = "-na$", replacement = "-pna", l[,i])
    l[,i] <- gsub(pattern = "^na-", replacement = "pna-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pbc$", replacement = "ppbc", l[,i])
    l[,i] <- gsub(pattern = "-pbc-", replacement = "-ppbc-", l[,i])
    l[,i] <- gsub(pattern = "-pbc$", replacement = "-ppbc", l[,i])
    l[,i] <- gsub(pattern = "^pbc-", replacement = "ppbc-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pcd$", replacement = "pcd1", l[,i])
    l[,i] <- gsub(pattern = "-pcd-", replacement = "-pcd1-", l[,i])
    l[,i] <- gsub(pattern = "-pcd$", replacement = "-pcd1", l[,i])
    l[,i] <- gsub(pattern = "^pcd-", replacement = "pcd1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pcm$", replacement = "pcm1", l[,i])
    l[,i] <- gsub(pattern = "-pcm-", replacement = "-pcm1-", l[,i])
    l[,i] <- gsub(pattern = "-pcm$", replacement = "-pcm1", l[,i])
    l[,i] <- gsub(pattern = "^pcm-", replacement = "pcm1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pds$", replacement = "pds1", l[,i])
    l[,i] <- gsub(pattern = "-pds-", replacement = "-pds1-", l[,i])
    l[,i] <- gsub(pattern = "-pds$", replacement = "-pds1", l[,i])
    l[,i] <- gsub(pattern = "^pds-", replacement = "pds1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pfd$", replacement = "pfd1", l[,i])
    l[,i] <- gsub(pattern = "-pfd-", replacement = "-pfd1-", l[,i])
    l[,i] <- gsub(pattern = "-pfd$", replacement = "-pfd1", l[,i])
    l[,i] <- gsub(pattern = "^pfd-", replacement = "pfd1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^ppn$", replacement = "ppn1", l[,i])
    l[,i] <- gsub(pattern = "-ppn-", replacement = "-ppn1-", l[,i])
    l[,i] <- gsub(pattern = "-ppn$", replacement = "-ppn1", l[,i])
    l[,i] <- gsub(pattern = "^ppn-", replacement = "ppn1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^psd$", replacement = "psd1", l[,i])
    l[,i] <- gsub(pattern = "-psd-", replacement = "-psd1-", l[,i])
    l[,i] <- gsub(pattern = "-psd$", replacement = "-psd1", l[,i])
    l[,i] <- gsub(pattern = "^psd-", replacement = "psd1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^udc$", replacement = "pudc", l[,i])
    l[,i] <- gsub(pattern = "-udc-", replacement = "-pudc-", l[,i])
    l[,i] <- gsub(pattern = "-udc$", replacement = "-pudc", l[,i])
    l[,i] <- gsub(pattern = "^udc-", replacement = "pudc-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^mrps$", replacement = "pmrps", l[,i])
    l[,i] <- gsub(pattern = "-mrps-", replacement = "-pmrps-", l[,i])
    l[,i] <- gsub(pattern = "-mrps$", replacement = "-pmrps", l[,i])
    l[,i] <- gsub(pattern = "^mrps-", replacement = "pmrps-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^otro$", replacement = "otros", l[,i])
    l[,i] <- gsub(pattern = "-otro-", replacement = "-otros-", l[,i])
    l[,i] <- gsub(pattern = "-otro$", replacement = "-otros", l[,i])
    l[,i] <- gsub(pattern = "^otro-", replacement = "otros-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^parme.$", replacement = "parm", l[,i])
    l[,i] <- gsub(pattern = "-parme.-", replacement = "-parm-", l[,i])
    l[,i] <- gsub(pattern = "-parme.$", replacement = "-parm", l[,i])
    l[,i] <- gsub(pattern = "^parme.-", replacement = "parm-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^indep$", replacement = "indep1", l[,i])
    l[,i] <- gsub(pattern = "-indep-", replacement = "-indep1-", l[,i])
    l[,i] <- gsub(pattern = "-indep$", replacement = "-indep1", l[,i])
    l[,i] <- gsub(pattern = "^indep-", replacement = "indep1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^alianza$", replacement = "alianza1", l[,i])
    l[,i] <- gsub(pattern = "-alianza-", replacement = "-alianza1-", l[,i])
    l[,i] <- gsub(pattern = "-alianza$", replacement = "-alianza1", l[,i])
    l[,i] <- gsub(pattern = "^alianza-", replacement = "alianza1-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^es$", replacement = "pes", l[,i])
    l[,i] <- gsub(pattern = "-es-", replacement = "-pes-", l[,i])
    l[,i] <- gsub(pattern = "-es$", replacement = "-pes", l[,i])
    l[,i] <- gsub(pattern = "^es-", replacement = "pes-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pmac$|^moveracps$", replacement = "pmch", l[,i])
    l[,i] <- gsub(pattern = "-pmac-|-moveracps-", replacement = "-pmch-", l[,i])
    l[,i] <- gsub(pattern = "-pmac$|-moveracps$", replacement = "-pmch", l[,i])
    l[,i] <- gsub(pattern = "^pmac-|^moveracps-", replacement = "pmch-", l[,i])
    }
#
for (i in 1:ncol(l)){
    l[,i] <- gsub(pattern = "^pcu$", replacement = "pchu", l[,i])
    l[,i] <- gsub(pattern = "-pcu-", replacement = "-pchu-", l[,i])
    l[,i] <- gsub(pattern = "-pcu$", replacement = "-pchu", l[,i])
    l[,i] <- gsub(pattern = "^pcu-", replacement = "pchu-", l[,i])
    }
#
#
sel.r <- which(dat$yr>2006)
#table(l[sel.r,18]) # easier to verify one column at a time
dat[,sel.l] <- l # return to data
rm(l)

## # shorter pty labels included in longer ones (eg pan panal) give false positives in regexes
## # figure which and change them
## sel.l <- grep("^l[0-9]{2}", colnames(dat))
## l <- dat[,sel.l] # subset label columns
## lab.tmp <- c(t(l)) # vectorize
## lab.tmp <- lab.tmp[lab.tmp!="0"] # drop empty cells
## lab.tmp <- unique(lab.tmp)
## lab.tmp <- strsplit(lab.tmp, split = "-") # break into component character vector
## lab.tmp <- unlist(lab.tmp)
## lab.tmp <- unique(lab.tmp)
## lab.tmp <- lab.tmp[lab.tmp!="0"] # drop empty cells
## lab.tmp <- lab.tmp[order(lab.tmp)]        # sort
## lab.tmp <- lab.tmp[order(nchar(lab.tmp))] # put shorter labels first
## # verify that all labels unique
## i <- 1
## i <- i+1; grep(lab.tmp[i], lab.tmp)
## lab.tmp[grep(lab.tmp[i], lab.tmp)]
## x

save.image(file = "tmp.RData")

## consider running script above to make sure data is up-to-date with latest csv
rm(list = ls())
dd <- "/home/eric/Desktop/MXelsCalendGovt/elecReturns/data/"
setwd(dd)
load(file = "tmp.RData")

######################################################
######################################################
# identify coalitions by searching for "-" in labels #
######################################################
######################################################
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
#
# dummy had at least one coalition
dat$dcoal <- 0
for (i in 1:ncol(l)){
    dat$dcoal[grep("-", l[,i])] <- 1
}

# create objects with vote for coalition(s) added and redudant columns dropped
cv <- v; cv[] <- NA # will receive votes with coalitions aggregated
cl <- l; cl[] <- NA # will keep coalition labels but drop coalition member labels
ci <- data.frame(dcoal=dat$dcoal, ncoal=NA, coal1="none", coal2="none", coal3="none", coal4="none", stringsAsFactors = FALSE) # coalition summary info
ci$ncoal[ci$dcoal==0] <- 0 # 0=no coalition
# ci$coal1 coal2 coal3 coal4 pre-filled
  # n is object reporting how many parties reported in a v/l cell?
  ln1 <- v # duplicate votes
  ln1[] <- 0 # will receive info
  ln2 <- ln1 # duplicate
  # replace each label with its character length
  for (i in 1:ncol(ln1)){
      #i <- 16 # debug
      tmp <- l[,i] # pick ith column as vector
      ln1[,i] <- nchar(tmp) # replace items with num characters
  }
  # drop hyphens to count character difference
  l.tmp <- l # duplicate
  for (i in 1:ncol(l.tmp)){
      #i <- 1 # debug
      l.tmp[,i] <- gsub("-", "", l.tmp[,i]) # remove hyphens to count char dif
      ln2[,i] <- nchar(l.tmp[,i]) # replace items with num characters
  }
  n <- ln1 - ln2 + 1 # 1 means no coalition, single party
  n[l=="0"] <- 0     # empty votes
  rm(i, ln1, ln2, l.tmp, sel, tmp)
#
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
I <- nrow(v)
c1 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # will receive vector of 1st coalition's members
c2 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 2nd coalition's members
c3 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 3rd coalition's members
c4 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 3rd coalition's members
#
# will receive columns corresponding to coalition members in v/l for use when weighting votes contributed by each member
w1 <- as.list(rep("noCoal",I))
w2 <- as.list(rep("noCoal",I))
w3 <- as.list(rep("noCoal",I))
w4 <- as.list(rep("noCoal",I))
#
# fill in easy cases with no coalition
sel <- which(dat$dcoal==0)
cv[sel,] <- v[sel,]
cl[sel,] <- l[sel,]
# c1 c2 c3 c4 are pre-filled
# w1 w2 w3 w4 are pre-filled

# fill in info selecting cases of coalitions with most members
sel7 <- which(max.tmp>1)
tmp.v <- v[sel7,] # subset for manipulation
tmp.l <- l[sel7,]
tmp.n <- n[sel7,]
max.tmp <- max.tmp[sel7]
tmp.c1 <- c1[sel7,]
tmp.w1 <- w1[sel7]
tmp.ci <- ci[sel7,]

# debug
#i <- which(dat$ord[sel7]==847)

for (i in 1:length(sel7)){
    #i <- length(sel7) # debug
    message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 1               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal1[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c1[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 1 # debug
        if (tmp.c1[i,j]=="0") next
        pat <- paste("^", tmp.c1[i,j], "$|", tmp.c1[i,j], "-|-", tmp.c1[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c1[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w1[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c1[sel7,] <- tmp.c1
w1[sel7] <- tmp.w1
ci[sel7,] <- tmp.ci
#tail(w1[sel7])

####################################
# process cases with 2nd coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c2 <- c2[sel7,]
tmp.w2 <- w2[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

# debug
#i <- which(dat$ord[sel7]==847)

for (i in 1:length(sel7)){
    #i <- 3079 # debug
    tmp.l[i,] # debug
    #tmp.n[i,] # debug
    message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 2               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal2[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c2[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c2[i,j]=="0") next
        pat <- paste("^", tmp.c2[i,j], "$|", tmp.c2[i,j], "-|-", tmp.c2[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c2[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w2[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c2[sel7,] <- tmp.c2
w2[sel7] <- tmp.w2
ci[sel7,] <- tmp.ci
# tail(w2[sel7])

####################################
# process cases with 3rd coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c3 <- c3[sel7,]
tmp.w3 <- w3[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

for (i in 1:length(sel7)){
    #i <- 1 # debug
    #tmp.l[i,] # debug
    #tmp.n[i,] # debug
    message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 3               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal3[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c3[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c3[i,j]=="0") next
        pat <- paste("^", tmp.c3[i,j], "$|", tmp.c3[i,j], "-|-", tmp.c3[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c3[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w3[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c3[sel7,] <- tmp.c3
w3[sel7] <- tmp.w3
ci[sel7,] <- tmp.ci
# tail(w3[sel7])

####################################
# process cases with 4th coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c4 <- c4[sel7,]
tmp.w4 <- w4[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

for (i in 1:length(sel7)){
    #i <- 1 # debug
    #tmp.l[i,] # debug
    #tmp.n[i,] # debug
    message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 4               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal4[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c4[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c4[i,j]=="0") next
        pat <- paste("^", tmp.c4[i,j], "$|", tmp.c4[i,j], "-|-", tmp.c4[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c4[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w4[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c4[sel7,] <- tmp.c4
w4[sel7] <- tmp.w4
ci[sel7,] <- tmp.ci

max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7

# prepare object with coalition party weights
w <- as.list(rep("noCoal",I))
sel <- which(ci$ncoal>=1)
for (i in sel){
    w[[i]] <- list(coal1="no", coal2="no", coal3="no", coal4="no")
    #i <- sel[1] # debug
    w[[i]]$coal1 <- v[i,w1[[i]]]
    names(w[[i]]$coal1) <- l[i,w1[[i]]]
}
#
sel <- which(ci$ncoal>=2)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal2 <- v[i,w2[[i]]]
    names(w[[i]]$coal2) <- l[i,w2[[i]]]
}
#
sel <- which(ci$ncoal>=3)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal3 <- v[i,w3[[i]]]
    names(w[[i]]$coal3) <- l[i,w3[[i]]]
}
#
sel <- which(ci$ncoal>=4)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal4 <- v[i,w4[[i]]]
    names(w[[i]]$coal4) <- l[i,w4[[i]]]
}
coal.weights <- w # rename
coal.info <- ci
rm(w, ci)

rm(c1, c2, c3, c4, I, i, j, max.tmp, n, pat, save.col, save.label, save.vote, sel, sel7, target.cols, tmp, tmp.c1, tmp.c2, tmp.c3, tmp.c4, tmp.ci, tmp.l, tmp.n, tmp.target, tmp.v, tmp.w1, tmp.w2, tmp.w3, tmp.w4, w1, w2, w3, w4) # housecleaning

## winner (sorts data to have largest vote-winning party in column 1)
# handy function to sort one data frame's rows by order of another, matching data frame
sortBy <- function(target, By){
    t <- target; b <- By;
    do.call(rbind, lapply(seq_len(nrow(b)),
            function(i) as.character(unlist(t[i,])[order(unlist(-b[i,]))]))) # change to -b for decreasing order
}
# example
## v1 <- data.frame(c1=c(30,15,3), c2=c(10,25,2), c3=c(20,35,4))
## l1 <- data.frame(c1=c("thirty","fifteen","three"), c2=c("ten","twenty-five","two"), c3=c("twenty","thirty-five","four"))
## v1.sorted <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE))) # sort each row of df -- http://stackoverflow.com/questions/6063881/sorting-rows-alphabetically
## l1.sorted <- sortBy(target = l1, By = v1)
## sortBy(target = v1, By = v1)
##
## this sorts matrix rows faster than function above
## vot <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE)))

# sort coalition-aggregated data
tail(cv)
tail(cl)
###########################################
cv.sorted <- sortBy(target = cv, By = cv) # slow! wait for process
#                                         # end before continuing
###########################################
cl.sorted <- sortBy(target = cl, By = cv) # slow! wait for process
#                                         # end before continuing
###########################################
cv.sorted <- as.data.frame(cv.sorted, stringsAsFactors = FALSE) # return matrix to dataframe
cl.sorted <- as.data.frame(cl.sorted, stringsAsFactors = FALSE) # return matrix to dataframe
colnames(cv.sorted) <- colnames(v); colnames(cl.sorted) <- colnames(l)
cv.sorted <- transform(cv.sorted, v01 = as.numeric(v01), v02 = as.numeric(v02), v03 = as.numeric(v03), v04 = as.numeric(v04), v05 = as.numeric(v05), v06 = as.numeric(v06), v07 = as.numeric(v07), v08 = as.numeric(v08), v09 = as.numeric(v09), v10 = as.numeric(v10), v11 = as.numeric(v11), v12 = as.numeric(v12), v13 = as.numeric(v13), v14 = as.numeric(v14), v15 = as.numeric(v15), v16 = as.numeric(v16), v17 = as.numeric(v17), v18 = as.numeric(v18)) # return to numeric format
tail(cv.sorted)
tail(cl.sorted)

# rename objects so that dat now has coalition aggregates
dat.orig <- dat # original data
dat[,sel.l] <- cl.sorted # return manipulated labels to data
dat[,sel.v] <- cv.sorted # return manipulated votes to data
head(dat)
# move dcoal column before v01
tmp <- dat # duplicate if I mess up
tmp1 <- grep("v01", colnames(dat))
tmp2 <- grep("dcoal", colnames(dat))
dat <- dat[, c(1:(tmp1-1), tmp2, tmp1:(tmp2-1))]
colnames(dat)
rm(cv, cl, cv.sorted, cl.sorted, sel.l, sel.v, v, l, tmp)

table(dat$v16) # check that only has zeroes
dat$v16 <- dat$l16 <- dat$v17 <- dat$l17 <- dat$v18 <- dat$l18 <- NULL # redundant columns
dat$win <- dat$l01
# move win column before v01
tmp <- dat # duplicate if I mess up
tmp1 <- grep("v01", colnames(dat))
tmp2 <- grep("win", colnames(dat))
dat <- dat[, c(1:(tmp1-1), tmp2, tmp1:(tmp2-1))]
colnames(dat)

sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
dat$ncand <- apply(v, 1, function(x) length(x[x>0]))
# check that coal aggregation produces same efec as before
check <- rowSums(v) - dat$efec
table(check==0) # all must be true
## sel <- which(check!=0)
## dat[sel[2],]
## dat.orig[sel[2],]
# move ncand column before dcoal
tmp <- dat # duplicate if I mess up
tmp1 <- grep("dcoal", colnames(dat))
tmp2 <- grep("ncand", colnames(dat))
dat <- dat[, c(1:(tmp1-1), tmp2, tmp1:(tmp2-1))]
colnames(dat)

## #################################
## #### DROPS USOS Y COSTUMBRES ####
## #################################
## # any dusos==1?
## table(dat$dusos)
## # caso Cherán
## sel <- which(dat$dusos==1 & dat$edon==16)
## dat$munn[sel]
## sel <- which(dat$edon==16 & dat$munn==24)
## dat[sel, c("yr","efec","status")]
## # drop uyc
## sel <- which(dat$dusos==1)
## table(dat$v01[sel]==0) # all report no votes?
## dat <- dat[-sel,]

################################
### export a coalAgg version ###
################################
sel <- dat$yr>=1997
dat <- dat[sel,] # drop early years
dat$ord <- 1:nrow(dat)
write.csv(dat, file = "aymu1997-present.coalAgg.csv", row.names = FALSE)

dat <- read.csv(file = "aymu1997-present.coalAgg.csv", stringsAsFactors = FALSE)
dat[1,]

sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns

ci <- coal.info
head(ci[ci$ncoal==3,])
compare this to pancoal etc columns

#table(gsub(pattern = "([0-9a-zA-Záéíóúñ])", replacement = "", tmp)) # keep only non-letter-number characters

## # julio: lista de datos faltantes
## ver2013 pdf difícil

###########################
# ESTO ANALIZA INCUMBENTS #
###########################

dd <- "/home/eric/Desktop/MXelsCalendGovt/elecReturns/data/"
setwd(dd)

# read raw data file
inc <- read.csv(file = "aymu1985-present.incumbents.csv", stringsAsFactors = FALSE)
dim(inc)
colnames(inc)

sel <- which(inc$edon==24)
tmp <- inc[sel,]

table(tmp$reelec.post)

i <- 0

i <- i+1
sel <- which(tmp$munn==i)
tmp[sel, c("yr","incumbent","dreran.post","dreelec.post")]


inflection.pt = function (expvar, pred, ste) {
  # to determine the inflection point (day when eggcolour/CC changes) and associated se

  aa = tapply(pred, expvar, mean)
  me= approx( x= aa, y=sort(unique(expvar)), xout= 0.5)   #interpolate
  plot(sort(unique(expvar)), aa)              # use unique since there are multiple days that are the same.

  bb=(tapply(ste,expvar, mean))
  se=approx( y= bb, x=sort(unique(expvar)), me$y)
  plot(sort(unique(expvar)), bb)
  return ( list(me,se))     # combine in a list to return
}


\docType{data}
\name{atmosfera}
\alias{atmosfera}
\title{Datos atmosféricos}
\format{Un data.frame con 41472 filas y 11 columnas
\describe{
\item{latitud}{Ubicación de la medida. Grilla espacial de 24 por 24 desde longitud 113.8O a 56.2O y desde latitud 36.2N a 21.2S.}
\item{longitud}{Ubicación de la medida. Grilla espacial de 24 por 24 desde longitud 113.8O a 56.2O y desde latitud 36.2N a 21.2S.}
\item{anio}{72 puntos en el tiempo. Una vez al mes desde enero de 1995 hasta diciembre de 2000.}
\item{mes}{72 puntos en el tiempo. Una vez al mes desde enero de 1995 hasta diciembre de 2000.}
\item{temp_superficie}{Temperatura media mensual basada en la energía emitida desde la Tierra en condiciones de cielo despejado (en K).}
\item{temperatura}{Temperatura media mensual del aire cerca de la superficie de la Tierra (en K).}
\item{presion}{Presión media mensual en una ubicación determinada de la superficie de la Tierra (en mb).}
\item{ozono}{Cantidad media mensual de ozono en la columna atmosférica (en Dobsons).}
\item{nube_baja}{Porcentaje de la media mensual de cielo cubierto por nubes con una presión superior mayor a 680 mb o aproximadamente menor que 3.24 km.}
\item{nube_media}{Porcentaje de la media mensual de cielo cubierto por nubes con una presión superior entre 440-680 mb o aproximadamente menor que 3.24 a 6.5 km.}
\item{nube_alta}{Porcentaje de la media mensual de cielo cubierto por nubes con una presión superior menor o igual a 440 mb o aproximadamente mayor que 6.5 km.}
}}
\usage{atmosfera}
\description{Datos atmosféricos}
\keyword{datasets}


# historical data

library(quantmod)
symbol <- "AMZN"
getSymbols(symbol) # or getSymbols(symbol, src = "yahoo")
head(AMZN) # returns some data of AMZN vector
colnames(AMZN) # returns column names of AMZN vector
#Op(AMZN) # only column of open of all data
#Hi(AMZN) # only column of high of all data
#Lo(AMZN) # only column of low of all data
#Cl(AMZN) # only column of close of all data
#Vo(AMZN) # only column of volume of all data
#Ad(AMZN) # value adjusted of the close (of all data)
#OHLC(AMZN) # columns open, high, low and close of all data

# Exchange rates (forex) from Yahoo finance
library(quantmod)
cross_from <- c("EUR", "USD", "CAD")
cross_to <- c("USD", "JPY", "USD")
getQuote(paste0(cross_from, cross_to, "=X"))

# Exchange rates (forex) from Oanda
library(quantmod)
currency <- "EUR/GBP"
# the last 6 months
getSymbols(currency, src = "oanda")
head(EURGBP) # returns some data of EURGBP vector
# the last 60 days
getSymbols(currency, from = Sys.Date() - 60, to = Sys.Date(), src = "oanda")
head(EURGBP) # returns some data of EURGBP vector

#  CoinMarketCap API
library(httr)
library(jsonlite)
base_url <- 'https://sandbox-api.coinmarketcap.com/'
get_coinmarketcap_data <- function(base_url, path, query) {
    response <- GET(url = base_url, path = paste('v1/', path, sep = ''), query = query)
    content <- content(response, 'text', encoding = 'utf-8')
    return(fromJSON(content, flatten = TRUE))
}
# returns all active cryptocurrencies
path <- 'cryptocurrency/map'
marketcap_map <- get_coinmarketcap_data(base_url, path, list())
head(marketcap_map$data)
# returns last market data of all active cryptocurrencies
path <- 'cryptocurrency/listings/latest'
query <- list(convert = 'EUR')
last_marketcap <- get_coinmarketcap_data(base_url, path, query)
head(last_marketcap$data)
# returns last market data of Bitcoin
path <- 'cryptocurrency/quotes/latest'
query <- list(id = 1, convert = 'EUR')
last_bitcoin <- get_coinmarketcap_data(base_url, path, query)
last_bitcoin$data$`1`
last_bitcoin$data$`1`$`quote`$EUR
# returns historical data from a time_start to a time_end
path <- 'cryptocurrency/quotes/historical'
query <- list(id = 1, convert = 'EUR', time_start = '2020-05-21T12:14', time_end = '2020-05-21T12:44')
data <- get_coinmarketcap_data(base_url, path, query)
head(data$data)

# Quandl library
library(Quandl)
oil_data <- Quandl(code = "CHRIS/CME_QM1")
head(oil_data) # returns all free columns names
#getPrice(oil_data) # returns all free columns values
#getPrice(oil_data, symbol = "CHRIS/CME_QM1", prefer = "Open$") # returns open values of a specific symbol
getPrice(oil_data, prefer = "Open$") # returns open values


##### Differential analysis of ADRC microarray data
# conda environment 850k
# Writtn by Andy Madrid
#

rm(list=ls())
getwd()
set.seed(1234)
library(limma)
library(minfi)
library(IlluminaHumanMethylationEPICanno.ilm10b2.hg19)
library(missMethyl)
library(stringr)
library(sva)
library(data.table)

load("adrcPreprocessedData.RData")
out_dir_name <- "./LOAD/"

### set variables for making models
# only groupwise model shown below

mValues <- mValues[, targets$patient_id]

bmi <- as.numeric(targets$bmi)
gran <- as.numeric(targets$Gran)
mono <- as.numeric(targets$Mono)
nk <- as.numeric(targets$NK)
bcell <- as.numeric(targets$Bcell)
cd8 <- as.numeric(targets$CD8T)
cd4 <- as.numeric(targets$CD4T)
sex <- as.factor(targets$sex)
age <- as.numeric(as.character(targets$age))
group <- as.factor(targets$cohort)
slide <- as.factor(targets$chip_id)

bmi <- as.numeric(targets$bmi)

### generate model and identify surrogate variables
mod <- model.matrix( ~ bmi + group + sex + age + slide + gran + nk + mono + bcell + cd8 + cd4)
mod0 <- model.matrix(~  group + sex + age + slide + gran + nk + mono + bcell + cd8 + cd4)

n.sv <- num.sv(mValues,mod,method='leek')
svobj <- sva(mValues,mod,mod0,n.sv=n.sv)
modSv <- cbind(mod, svobj$sv)

### basic linear fit using limma

# get suset of informatino of interest from annotation
# Grab the most important columns--chrom, pos, rs id, gene set, CpG island, etc.
annEPICSub <- annEPIC[match(rownames(mValues),annEPIC$Name),c(1:4,22,24,19)]

fit <- lmFit(mValues,modSv)
fit2 <- eBayes(fit)

tmp <- rep(0, ncol(modSv))
tmp[2] <- 1
contrast <- matrix(tmp, length(tmp))
contrasts.fit(fit, contrast)
fit.cont <- lmFit(mValues)

DMPs <- topTable(fit2,coef=2,num=Inf,sort.by='none',genelist=annEPICSub)

saveRDS(fit2, file = paste0(out_dir_name, "fit2.RDS"))
fwrite(DMPs, file = paste0(out_dir_name, "DMPs.csv"))


import::here(R6, R6Class)
import::here(magrittr, "%>%")
import::here(purrr, map, reduce, imap, imap_dfr)
import::here(dplyr, .all = TRUE)
import::here(tibble, .all = TRUE)
import::here(readr, .all = TRUE)
import::here(jsonlite, .all = TRUE)
import::here(stringr, .all = TRUE)

#' @export
computed_matrix <- R6Class("computed_matrix", list(
    metadata = NULL,
    sample_matrix_list = list(),
    sample_mean_coverage = list(),
    region_total_coverage = list(),
    initialize = function(metadata, sample_matrix) {
        self$metadata <- metadata
        self$sample_matrix_list <- sample_matrix
    },
    calculate_mean_coverage_each_sample = function() {
        dflist <- self$sample_matrix_list
        sample_mean_coverage <- dflist %>%
            imap(function(df, name) {
                splited_by_group_label <- df %>%
                    group_by(group_label) %>%
                    group_split() %>%
                    setNames(df$group_label %>% unique())

                mean_coverage_per_group <- splited_by_group_label %>%
                    imap(function(df, group_label) {
                        df <- df %>% select(!group_label)
                        mtx <- df %>% as.matrix()
                        col_means_ <- mtx %>% colMeans()
                        names(col_means_) <- seq_len(length(col_means_)) %>%
                            as.character() %>%
                            paste0("X_", .)
                        return(col_means_)
                    })
                return(mean_coverage_per_group)
            })

        self$sample_mean_coverage <- self$metadata$group_labels %>%
            map(
                function(group_label) {
                    coverage_mtx <- sample_mean_coverage %>%
                        imap_dfr(
                            function(content, name) {
                                content_group<-content[[group_label]]
                                content_group["samplename"] <- name
                                return(content_group)
                            }
                        ) %>%
                        as.data.frame() %>%
                        column_to_rownames("samplename") %>%
                        as.matrix()
                }
            ) %>%
            setNames(self$metadata$group_labels)
    },
    calculate_total_coverage_each_region = function() {
        total_coverage_each_region <- self$sample_matrix_list %>%
            imap(function(df, name) {
                df %>%
                    group_by(group_label) %>%
                    group_split() %>%
                    setNames(df$group_label %>% unique()) %>%
                    imap(function(df, group_label) {
                        df %>%
                            select(!group_label) %>%
                            as.matrix() %>%
                            rowSums()
                    })
            })
        self$region_total_coverage <- total_coverage_each_region
    }
))

#' @export
read_computed_matrix <- function(matrix_path, offset = 6, df_obj = NULL) {
    if (is.null(df_obj)) {
        df <- read_tsv(
            skip = 1,
            file = matrix_path,
            col_names = F,
            col_types = cols(
                X1 = "c",
                X2 = "i",
                X3 = "i",
                X4 = "c",
                X5 = "d",
                X6 = "c",
                .default = "d"
            )
        ) %>%
            mutate_if(
                is.numeric,
                ~ replace(., is.na(.), 0)
            )
    } else {
        df <- df_obj
    }
    metadata <- readLines(gzfile(matrix_path), 1) %>%
        str_remove("^@") %>%
        fromJSON()
    df_splited <- list()
    df_splited <- map(
        seq_len(length(metadata$sample_labels)),
        function(i) {
            sample_left_bond <- offset + 1 + metadata$sample_boundaries[i]
            sample_right_bond <- offset + metadata$sample_boundaries[i + 1]
            df_sample <- df[, sample_left_bond:sample_right_bond]
            if ("group_labels" %in% names(metadata)) {
                group_bonds <- metadata$group_boundaries
                group_labels <- metadata$group_labels
                group_label <- map(seq_len(length(metadata$group_labels)), function(j) {
                    group_ <- rep_len(
                        group_labels[j],
                        group_bonds[j + 1] - group_bonds[j]
                    )
                    return(group_)
                }) %>%
                    reduce(~ c(.x, .y))
                df_sample$group_label <- group_label
            }
            return(df_sample)
        }
    ) %>%
        setNames(metadata$sample_labels)
    res <- computed_matrix$new(
        metadata = metadata,
        sample_matrix = df_splited
    )
    return(res)
}


treatment.rhs <- . ~  user.revert.cv + ttr + n.reverts + p.reverts.admin + p.reverts.bot + p.reverts.patroller + p.reverteds.newcomer + p.reverteds.anonymous + ns0.anon.edits + ns0.newcomer.edits + ns4.edits + p.ns4.edits.newcomer + p.ns4.edits.anon + ns0.edits + p.ns0.edits.anon +  p.ns0.edits.newcomer + n.pages.baseline.ns.0 + n.pages.baseline.ns.4 +  active.editors + view.count + has.patrollers

treatment.lhs <- treated ~ .

treatment.formula<- update(treatment.rhs,treatment.lhs)

m1.rhs  <-  . ~  treated + week.factor + treated.with.ores

m1.rhs.stan  <-  . ~ treated + week.factor + treated.with.ores + (1 | wiki.db)

m1.lhs <- undo.geom.mean.ttr ~ .
m1.formula <- update(m1.lhs,m1.rhs)
m1.formula.stan  <- update(m1.lhs, m1.rhs.stan)
m1.formula.dr <- update(m1.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m1.rhs[3],"- ttr",collapse="+")))

m1.formula.dr.stan <- update(m1.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m1.rhs[3],"- ttr + (1|wiki.db)",collapse="+")))

m2.lhs <- undo.N.reverts ~ .
m2.rhs <- m1.rhs
m2.rhs.stan <- m1.rhs.stan
m2.formula  <- update(m2.lhs, m2.rhs)
m2.formula.stan  <- update(m2.lhs, m2.rhs.stan)

m2.formula.dr <- update(m2.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m2.rhs[3],"- n.reverts",collapse="+")))

m2.formula.dr.stan <- update(m2.rhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m2.lhs[3],"- n.reverts + (1|wiki.db)",collapse="+")))

m3.lhs <- user.week.revert.cv ~ .
m3.rhs <- m1.rhs
m3.rhs.stan <- m1.rhs.stan
m3.formula <- update(m3.lhs,m3.rhs)
m3.formula.stan <- update(m3.lhs, m3.rhs.stan)

m3.formula.dr <- update(m3.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m3.rhs[3],"- user.revert.cv",collapse="+")))
m3.formula.dr.stan <- update(m3.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m3.rhs[3],"- user.revert.cv + (1|wiki.db)",collapse="+")))

m4.lhs <- newcomer.n.reverted ~ .
m4.rhs <- m1.rhs
m4.rhs.stan <- m1.rhs.stan
m4.formula <- update(m4.lhs, m4.rhs)
m4.formula.stan <- update(m4.lhs, m4.rhs.stan)
m4.formula.dr <- update(m4.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m4.rhs[3],"- p.reverteds.anonymous - p.reverteds.newcomer - p.reverteds.established",collapse="+")))
m4.formula.dr.stan <- update(m4.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m4.rhs[3],"- p.reverteds.anonymous - p.reverteds.newcomer - p.reverteds.established + (1|wiki.db)",collapse="+")))

m5.lhs <- anonymous.n.reverted ~ .
m5.rhs <- m1.rhs
m5.rhs.stan <- m1.rhs.stan
m5.formula <- update(m5.lhs, m5.rhs)
m5.formula.stan <- update(m5.lhs, m5.rhs.stan)
m5.formula.dr <- update(m5.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m5.rhs[3],"- p.reverteds.anonymous - p.reverteds.newcomer - p.reverteds.established",collapse="+")))
m5.formula.dr.stan <- update(m5.lhs, paste(". ~ + ", paste0(treatment.rhs[3],"+"),paste0(m5.rhs[3],"- p.reverteds.anonymous - p.reverteds.newcomer - p.reverteds.established + (1|wiki.db)",collapse="+")))


#'@useDynLib waddR
#'@importFrom Rcpp sourceCpp
#'@importFrom parallel nextRNGStream
#'@importFrom methods is
#'@importFrom stats binomial cor ecdf p.adjust pchisq quantile sd na.exclude
#'@importFrom arm bayesglm
#'@importFrom BiocParallel bplapply bpmapply
#'@importFrom BiocFileCache BiocFileCache bfcadd bfcquery bfcdownload
#'@importFrom BiocFileCache bfcpath bfcrpath bfccount bfcneedsupdate
#'@importFrom SingleCellExperiment SingleCellExperiment counts logcounts
NULL

#' Compute value of the asymptotic CDF occuring in the asymptotic theory-based test
#'
#' Computes the values of the cumulative distribution function (CDF) of the integral over the squared standard Brownian bridge in the unit interval, where the computation is based on Monte Carlo simulations.
#' This CDF occurs as an asymptotic distribution in the asymptotic theory-based test using the 2-Wasserstein distance, see Schefzik et al. (2020) for details.
#' It is used to determine the corresponding p-values in the function \code{.wassersteinTestAsy}.
#'
#' @param v a number
#' @return Value at \code{v} of the asymptotic CDF
#' @name .brownianBridgeEmpcdf
#'
#'@references Schefzik, R., Flesch, J., and Goncalves, A. (2020). waddR: Using the 2-Wasserstein distance to identify differences between distributions in two-sample testing, with application to single-cell RNA-sequencing data.
.brownianBridgeEmpcdf <- function(v) NULL # distribution loaded in .onLoad

# TODO: upload as data package
#' URL for downloading the asymptotic CDF occuring in the asymptotic theory-based test
#'
#' URL for downloading the cumulative distribution function (CDF) of the integral over the squared standard Brownian bridge in the unit interval, where the computation is based on Monte Carlo simulations.
#' This CDF occurs as an asymptotic distribution in the asymptotic theory-based test using the 2-Wasserstein distance, see Schefzik et al. (2020) for details.
#' It is used to determine the corresponding p-values in the function \code{.wassersteinTestAsy}.
#'
#' @name brownianBridgeEmpcdf.url
#' @docType data
#'
#'@references Schefzik, R., Flesch, J., and Goncalves, A. (2020). waddR: Using the 2-Wasserstein distance to identify differences between distributions in two-sample testing, with application to single-cell RNA-sequencing data.
brownianBridgeEmpcdf.url <- paste0( "https://github.com/goncalves-lab/",
                                    "waddR-data/blob/master/data/",
                                    "empcdf_ref.RData?raw=true")

# Non-exported definition to check if non-exported functions are available.
# This will cause tests for these functions (causing issues on build systems)
# to be skipped.
NONEXPORTS.AVAILABLE <- TRUE

.onLoad <- function (libname, pkgname) {

    # Load the reference distributions from cache
    if (is.null(.brownianBridgeEmpcdf(0))) {
        brownianBridgeEmpcdf.path <- .cache.getOrDownload(
            url=brownianBridgeEmpcdf.url,
            rname="empcdf.ref")
        empcdf.ref <- NULL # this variable will be loaded from the file
        load(brownianBridgeEmpcdf.path)
        assign(".brownianBridgeEmpcdf",
               empcdf.ref,
               environment(.brownianBridgeEmpcdf))
    }
}

# cleanup after our cpp libraries
.onUnload <- function (libpath) {
    library.dynam.unload("waddR", libpath)
}


#!/usr/bin/Rscript
# version 20130821

arg <- commandArgs(trailingOnly=TRUE)

mcmc_BiSSE <- function(
	infile1, # tree
	infile2, # trait table
	wd="default",
	TDI=0,
	out_file_stem="default",
	rho0=1,
	rho1=1,
	BD_model_0=1,
	BD_model_1=1,
	Trait_model=0,
	link_speciation=0,
	link_extinction=0,
	link_trait=0,
	prior_r=5,
	prior_a=1,
	prior_b=1,
	prior_q=1,
	trees=1,
	IT=20000,
	sampling_freq=100,
	print_freq=100,
	burnin=1000,
	win_1=0.5,
	win_2=0.25,
	win_3=0.05,
	categories=10,
	beta_shape=0.3,
	path_lib="default"
	) {	# end args

	if (wd=="default"){
		wd=dirname(infile1)
		}else{setwd(wd)}

	if (out_file_stem=="default"){
		st=basename(infile2)
		out_file= paste(st,"_BiSSEBMA.log", sep="")
		}else{out_file= paste(out_file_stem,".log", sep="")}

	if (path_lib=="default") {
		library(diversitree)
		}else{library(diversitree, , lib.loc=path_lib)}

	options(warn=-1) # hide warnings

	rhos=c(rho0, rho1)  #sampling fractions for state 0 and 1
	#out_file="boh.log"   #!!change in each analysis
	#TDI=0     # 0 parameter estimation, 1 TD integration (not real estimates)
	#trees=5  # one tree for TDI is advised

	#burnin=0   # run test to check the proportion
	#sampling_freq=25
	#print_freq=10
	#IT=200  # mcmc iterations (per tree)
	#categories=20

	use_exp=1 # 0: uniform priors; 1: exponential priors (extinction fraction has always uniform prior 0-1)
	M=c(5,5,1,1,5,5) # max parameter values (if uniform priors)
	# if exp no limit (max =1000)
	if (prior_r>0){M[1:2]=1000}
	if (prior_q>0){M[5:6]=1000}
	#shape_prior=c(2,2,1,1) # shape parameters of exp prior (net diversification and q rates)
	#constraints=c() # constant sp. [2], ex. [4], q. [6] const sp + ex is 2,4
	#PB=c() # 3: pb clade 1, 4: pb clade 2, 5: q0->1 =0; 6: q1->0 =0  # pure birth / irreversible rate models

	PB=NULL
	if (BD_model_0==0){PB=append(PB,3)}
	if (BD_model_1==0){PB=append(PB,4)}
	if (Trait_model==1){PB=append(PB,6)}
	if (Trait_model==2){PB=append(PB,5)}

	constraints=NULL
	if (link_speciation==1){constraints=append(constraints,2)}
	if (link_extinction==1){constraints=append(constraints,4)}
	if (link_trait==1)     {constraints=append(constraints,6)}

	shape_prior=c(prior_r,prior_a,prior_b,prior_q)
	win_size=c(win_1,win_1,win_2,win_2,win_3,win_3)

	Tree=read.nexus(file=infile1)
	traits=read.csv(file=infile2, header=TRUE, sep="\t")  #one single trait or create a vector
	states<-traits[,2]
	names(states)<-as.character(traits[,1])

	update_parameter <- function(i,d,M) {
		if (length(i)==1) {
			ii=abs(i+(runif(length(i),0,1)-.5)*d)
			if (ii>M) {ii=abs((M-(ii-M)))}
			if (ii>M) {ii=i}
			}
		ii}
	if (TDI>0)	{
		K=categories-1.
		k=0:K # K+1 categories
		beta=k/K
		alpha=beta_shape # categories are beta distributed
		temps=rev(beta^(1./alpha))
	} else{temps=c(1)}

	exp_prior = function(value,l,Mv) {
		if (l>0){
			l=1./l
			log(l)-l*(value)
			}else{log(1/Mv)}
	}

	beta_prior = function(a,b,value){
		dbeta(value, a, b, log = TRUE)
	}

	true_iteration=1
	cat(sprintf("it\tlikelihood\tprior\tacceptance\tl0\tl1\tm0\tm1\tr0\tr1\ta0\ta1\tq0\tq1\ttemp\ttree\n"), append=FALSE, file=out_file)
	cat(sprintf("it\tlikelihood\tprior\tacc\tl0\tl1\tm0\tm1\ttemp\ttree\n"))
	for (J in 1:length(temps)) { # Loop temperatures
		temperature=temps[J]
		d= win_size*(4 - 3*temperature)

		for  (t_index in 1:trees) { # loop trees

			if (class(Tree)=="multiPhylo"){current_tree=Tree[[J]]}
			else{current_tree=Tree}

			BISSE=make.bisse(current_tree, states, strict=F, sampling.f=rhos)
			pars=runif(min=.1,max=.5, 6) # initialize parameters

			if (temperature<1) {burnin=0}
			LIK=0
			acc=0
			for (iteration in 1:(IT+burnin)) { # MCMC loop
				if (iteration==1){
					likA = BISSE(pars)[1]
					parsA=pars}
				pars=parsA
				ind=sample(1:6,1)
				pars[ind]=update_parameter(pars[ind],d[ind],M[ind])
				pars[PB]=0
				if (length(constraints)>0) {
					if (is.element(2, constraints) & is.element(4, constraints)) {pars[constraints] = pars[constraints-1]}
					else if (is.element(2, constraints)) {pars[2]=(pars[1]/(1-pars[3]))*(1-pars[4])}
					else if (is.element(4, constraints)) {pars[4]=pars[3]*pars[1]/(pars[2]-pars[3]*pars[2]+pars[3]*pars[1])}
					if (is.element(6, constraints)) {pars[6] = pars[5]}
					}
				#cat("pars:", pars)
				l=pars[1:2]/(1-pars[3:4])
				m=-pars[3:4]*pars[1:2]/(pars[3:4]-1)
				#lik=BISSE(c(l,m,pars[5:6]))[1]

				# CALC PRIORS # exponential
				if (use_exp==1) {
					prior=sum(exp_prior(pars[1:2],shape_prior[1],M[1:2])) + sum(exp_prior(pars[5:6],shape_prior[4],M[5:6])) + sum(beta_prior(shape_prior[2],shape_prior[3],pars[3:4]))
				} else{
					prior=sum(log(1/M))
					if (min(M-temp)<0) {prior = -Inf}
					}  # uniform

				# CALC LIKELIHOOD
				if (prior> -Inf) {
					lik=try(BISSE(c(l,m,pars[5:6])))
					if (is.na(lik) | (class(lik) == "try-error" )) {lik=-Inf}
					} else{lik= -Inf}

				if (iteration==1){priorA=prior}

				tryCatch(
				{
				if ( (lik-likA)*temperature + (prior-priorA) >= log(runif(1,0,1)) ){
					likA=lik
					priorA=prior
					parsA=pars
					acc =acc + 1.
				}
				}
				,error = function(e) NULL
				)

				if (iteration %% print_freq ==0) {cat(sprintf("%s\t", round(c(true_iteration, likA, priorA, parsA, temperature, t_index),2)), "\n")}

				if (true_iteration %% sampling_freq ==0 & iteration>=burnin) {
					l=parsA[1:2]/(1-parsA[3:4])
					m=-parsA[3:4]*parsA[1:2]/(parsA[3:4]-1)
					LIK= LIK+likA
					cat(sprintf("%s\t", c(true_iteration, likA, priorA, acc/iteration, l, m, parsA, temperature, t_index)), "\n", append=TRUE, file=out_file)
				}

				if (iteration>burnin) {true_iteration = true_iteration+1}
				}
			}
		}

	if (TDI>0)	{

		out_marg= paste(out_file_stem,"_marginal.txt",sep="")

		d<-read.table(out_file, header=T) #, stringsAsFactors=F,sep="\t") #, row.names = NULL)
		trapezia<-aggregate(d$lik, list(d$temp),FUN="mean")
		stds<-aggregate(d$lik, list(d$temp),FUN="sd")

		ml=0
		for (i in 1:(dim(trapezia)[[1]]-1)){
			ml=ml+( (trapezia[i,2] + trapezia[(i+1),2])/2 * (trapezia[(i+1),1] - trapezia[(i),1]))
		}
		cat("\nmean log likelihoods:", trapezia[,2], file=out_marg, append=TRUE)
		cat("\ntemperatures:", unique(d$temp), file=out_marg, append=TRUE)
		cat("\nstd(lnL):", stds[,2], file=out_marg, append=TRUE)
		cat("\n\nLog Marginal Likelihood:", ml, file=out_marg, append=TRUE)

		cat("\n\n Log Marginal Likelihood:", ml)
		cat("
 The marginal likelihood can be used to compare different analyses and to perform model selection
 and hypothesis testing via Bayes factors.

 The marginal likelihood was saved to file:", out_marg,"\n\n")
		}

		cat("\n")
	}

mcmc_BiSSE(
	as.character(arg[1]),       # infile1, # tree
	as.character(arg[2]),       # infile2, # trait table
	as.character(arg[3]),       # wd,
	as.integer(arg[4]),         # TDI,
        as.character(arg[5]),       # out_file,
	as.double(arg[6]),	    # rho0,
	as.double(arg[7]),          # rho1,
        as.integer(arg[8]),         # BD_model_0,
        as.integer(arg[9]),         # BD_model_1,
        as.integer(arg[10]),        # Trait_model,
        as.integer(arg[11]),        # link_speciation,
        as.integer(arg[12]),        # link_extinction,
        as.double(arg[13]),         # link_trait,
        as.double(arg[14]),         # prior_r,
        as.double(arg[15]),         # prior_a,
        as.double(arg[16]),         # prior_b,
        as.double(arg[17]),         # prior_q,
        as.integer(arg[18]),        # trees,
        as.integer(arg[19]),        # iterations,
        as.integer(arg[20]),        # sampling_freq,
        as.integer(arg[21]),        # print_freq,
        as.integer(arg[22]),        # burnin,
        as.double(arg[23]),         # win_1,
        as.double(arg[24]),         # win_2,
        as.double(arg[25]),         # win_3,
        as.integer(arg[26]),        # categories,
        as.double(arg[27]),         # beta_shape
	as.character(arg[28])	    # path to diversitree library
	)


library(hdfmat)
suppressMessages(library(float))

f = tempfile()
n = "mydata"
type = "float"

nr = 10
nc = 5
x = matrix(1:(nr*nc), nr, nc)

h = hdfmat::hdfmat(f, n, nr, nc, type)
h$fill(x)
h$close()

k = hdfmat::hdfmat_open(f, n)

test = k$read()
truth = float::fl(x)

stopifnot(all.equal(test, truth))
unlink(f)


#Rienje Veenhof and Frank Fluit
#Project for the course Geoscripting at Wageningen University
#28-1-2021
#This script contains two functions, the first of which extracts raster data from a
#given polygon extent and converts it to sf.
#The second functions also extracts data, but returns a df instead of an sp. It then merges
#this df to the 'template' of the sp file from the first function, thereby adding new columns with
#data from different rasters, each time the function is run.

#Install needed libraries
if(!"terra" %in% rownames(installed.packages())){install.packages("terra")}
library(terra)
if(!"sf" %in% rownames(installed.packages())){install.packages("sf")}
library(sf)

#First function
extract_spatial <- function(rasterfile, polygonfile){
  spatial_extract <- terra::extract(rasterfile, polygonfile, fun = mean, df = TRUE, na.rm = TRUE,sp=TRUE)
  spatial_extract <- st_as_sf(spatial_extract)
  return(spatial_extract)
}
#Second function
#we used indexing here to determine the place of the new column as we had some
#weird problems that it wouldnt assign the real name to the new column
extract_df <- function(rasterfile, polygonfile, spatialfile){
  df_extract <- terra::extract(rasterfile, polygonfile, fun = mean, df = TRUE, na.rm = TRUE)
  n <- ncol(spatialfile)
  spatialfile[n+1] <- df_extract[2]
  return(spatialfile)
}


#---UNWEIGHTED FREQUENCY---#
unwt_freq <- function(UNWT.VAR){#FUNCTION TO PRINT UNWEIGHTED FREQUENCIES

    unwt.tab <- wtd.table(UNWT.VAR, weights =  NULL, type = 'table')
    unwtd.freq <- data.frame(cbind(
        unwt.tab, round(unwt.tab/sum(unwt.tab)*100,2),
        cumsum(unwt.tab), cumsum(round(unwt.tab/sum(unwt.tab)*100,2))))
    names(unwtd.freq) <- c("Frequency", "Percent", "Cumulative Frequency", "Cumulative Percent")
    unwtd.title <- paste('2016 NIS', 'UNWEIGHTED FREQUENCIES', var_label(UNWT.VAR), sep = "\n")
    var_label(unwtd.freq) <- unwtd.title

    print(unwtd.freq)
}


\name{hc_text-HilbertCurve-method}
\alias{hc_text,HilbertCurve-method}
\title{
Add text to Hilbert curve
}
\description{
Add text to Hilbert curve
}
\usage{
\S4method{hc_text}{HilbertCurve}(object, ir = NULL, labels, x1 = NULL, x2 = x1, gp = gpar(),
    centered_by = c("interval", "polygon"), ...)
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{ir}{an \code{\link[IRanges:IRanges-constructor]{IRanges}} object that contains positions which correspond to text. The middle point of the interval will be the position of the text.}
  \item{labels}{text corresponding to intervals in \code{ir}.}
  \item{x1}{if start positions are not integers, they can be set by \code{x1}.}
  \item{x2}{if end positions are not integers, they can be set by \code{x2}.}
  \item{gp}{graphic parameters for text. It should be specified by \code{\link[grid]{gpar}}.}
  \item{centered_by}{how to define the "center" of the interval represented in Hilbert curve. See Details section.}
  \item{...}{pass to \code{\link[grid]{grid.text}}. E.g. you can set text justification by \code{just} here.}

}
\details{
If \code{centered_by == "interval"}, the text is added correspoding to the middle of each interval in \code{ir},
while if \code{centered_by == "polygon"}, the text is put in the visual center of the polygon of the interval
in the Hilbert curve.
}
\value{
A data frame which contains coordinates (in the 2D space) of text.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(1, 100, level = 4, reference = TRUE)

x = sort(sample(100, 20))
s = x[1:10*2 - 1]
e = x[1:10*2]
require(IRanges)
ir = IRanges(s, e)

labels = sample(letters, length(ir), replace = TRUE)
hc_text(hc, ir, labels = labels)
}


subsampling = function(firmsList, sample_size) {

  graphJobsDT = graph_datatable()

  year_t = 2010

  for (dtFirm in firmsList) {
    # All Simples
    jobSimples =
    #firmSimples = subsample(dtFirm[Ind.Simples == 1, .N])

    # All Non-simples
    jobNSimples = mean(subsample(dtFirm[Ind.Simples == 0, Qtd.Vínculos.CLT], sample_size))
    #firmNSimples = dtFirm[Ind.Simples == 0, .N]

    # All Simples eligible
    jobEligibleSimples = sum(dtFirm[Ind.Simples == 1 &
                                                 eligible == 1, Qtd.Vínculos.CLT], sample_size)
    #firmEligibleSimples = dtFirm[Ind.Simples == 1 & eligible == 1, .N]

    # All Non-simples treated
    jobEligibleNSimples = sum(dtFirm[Ind.Simples == 0 &
                                                  eligible == 1, Qtd.Vínculos.CLT], sample_size)
    #firmEligibleNSimples = dtFirm[Ind.Simples == 0 &
    #                                eligible == 1, .N]

    # All eligible
    jobTotalEligible = sum(dtFirm[eligible == 1, Qtd.Vínculos.CLT], sample_size)
    #firmTotalEligible = dtFirm[eligible == 1, .N]

    graphJobsDT = rbind(
      graphJobsDT,
      list(
        year_t,
        jobSimples,
        jobNSimples,
        jobEligibleSimples,
        jobEligibleNSimples,
        jobTotalEligible
      )
    )

    year_t = year_t + 1
  }
  return(graphJobsDT)
}

subsample = function(datatable, size) {
  data = numeric(0)
  for (i in 1:1000) {
    data[i] = sum(sample(datatable, size, replace = TRUE))
  }
  return(data)
}

graph_datatable = function() {
  j.simples = numeric(0)
  j.nonsimples = numeric(0)
  j.simples.eligible = numeric(0)
  j.nonsimples.treated = numeric(0)
  j.eligible = numeric(0)
  j.year = numeric(0)

  graphJobsDT = data.table(j.year,
                           j.simples,
                           j.nonsimples,
                           j.simples.eligible,
                           j.nonsimples.treated,
                           j.eligible)
  return(graphJobsDT)
}


wtd.chi.sq <- function(var1, var2, var3=NULL, weight=NULL, na.rm=TRUE, drop.missing.levels=TRUE){
  require(gdata)
  if(is.null(weight)){
    weight <- rep(1, length(var1))
  }
  if(na.rm==TRUE){
    filt <- (!is.na(var1) & !is.na(var2))
    if(!is.null(var3))
      filt <- (!is.na(var1) & !is.na(var2) & !is.na(var3))
    var1 <- var1[filt]
    var2 <- var2[filt]
    if(!is.null(var3))
      var3 <- var3[filt]
    weight <- weight[filt]
  }
  if(drop.missing.levels==TRUE){
    var1 <- drop.levels(var1)
    var2 <- drop.levels(var2)
    if(!is.null(var3))
      var3 <- drop.levels(var3)
  }
  var12set <- unlist(summary(xtabs(weight~var1+var2))[c("statistic", "parameter", "p.value")])
  names(var12set) <- c("Chisq", "df", "p.value")
  out <- var12set
  if(!is.null(var3)){
    as.numeric(var3)
    var123set <- unlist(summary(xtabs(weight~var1+var2+var3))[c("statistic", "parameter", "p.value")])
    var13set <- unlist(summary(xtabs(weight~var1+var3))[c("statistic", "parameter", "p.value")])
    var23set <- unlist(summary(xtabs(weight~var2+var3))[c("statistic", "parameter", "p.value")])
    v12sep <- unlist(sapply(unique(var3), function(x) unlist(summary(xtabs(weight[var3==x]~var1[var3==x]+var2[var3==x]))[c("statistic", "parameter")])))
    acvar3 <- c(sum(v12sep[1,])-var12set[1], sum(v12sep[2,])-var12set[2], 1-pchisq(sum(v12sep[1,])-var12set[1], sum(v12sep[2,])-var12set[2]))
    v13sep <- unlist(sapply(unique(var2), function(x) unlist(summary(xtabs(weight[var2==x]~var1[var2==x]+var3[var2==x]))[c("statistic", "parameter")])))
    acvar2 <- c(sum(v13sep[1,])-var13set[1], sum(v13sep[2,])-var13set[2], 1-pchisq(sum(v13sep[1,])-var13set[1], sum(v13sep[2,])-var13set[2]))
    v23sep <- unlist(sapply(unique(var1), function(x) unlist(summary(xtabs(weight[var1==x]~var2[var1==x]+var3[var1==x]))[c("statistic", "parameter")])))
    acvar1 <- c(sum(v23sep[1,])-var23set[1], sum(v23sep[2,])-var23set[2], 1-pchisq(sum(v23sep[1,])-var23set[1], sum(v23sep[2,])-var23set[2]))
    out <- rbind(var123set, var12set, var13set, var23set, acvar1, acvar2, acvar3)
    colnames(out) <- c("Chisq", "df", "p.value")
    rownames(out) <- c("Using All Three Variables", "Using Var1 and Var2", "Using Var1 and Var3", "Using Var2 and Var3", "Difference Across Levels of Var1", "Difference Across Levels of Var2", "Difference Across Levels of Var3")
  }
  out
}


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(cowplot))
suppressPackageStartupMessages(library(svglite))

# Store t test results and identify top features
t_test_results_files <- list.files("results", full.names = TRUE)
t_test_results_files <- t_test_results_files[grepl('t_test', t_test_results_files)]
t_test_results_files

# Store t test results and identify top features
best_result_list <- list()
line_gg_list <- list()
for (t_test_file in t_test_results_files) {
  full_results_df <- readr::read_tsv(t_test_file,
                                     col_types = readr::cols(
                                       t_stat = readr::col_double(),
                                       t_p = readr::col_double(),
                                       algorithm = readr::col_character(),
                                       feature_num = readr::col_double(),
                                       z_dim = readr::col_double(),
                                       signal = readr::col_character(),
                                       seed = readr::col_double(),
                                       neg_log_p = readr::col_double()
                                       )
                                     )

  top_results_df <- full_results_df %>%
    dplyr::group_by(algorithm, z_dim, signal) %>%
    dplyr::filter(neg_log_p == max(neg_log_p),
                  signal == "signal")

  # Create factors for plotting
  top_results_df$z_dim <-
    factor(top_results_df$z_dim,
           levels =
             sort(as.numeric(paste(unique(top_results_df$z_dim))))
    )

  top_results_df$algorithm <-
    factor(top_results_df$algorithm,
           levels = c("pca", "ica", "nmf", "dae", "vae"))

  panel_gg <- ggplot(top_results_df,
                       aes(x = z_dim,
                           y = neg_log_p,
                           color = algorithm,
                           group = algorithm)) +
    geom_smooth(aes(fill = algorithm),
                lwd = 0.3,
                alpha = 0.4,
                method = 'loess',
                formula = 'y ~ x') +
    geom_point(size = 0.5) +
    scale_color_manual(name = "Algorithm",
                       values = c("#e41a1c",
                                  "#377eb8",
                                  "#4daf4a",
                                  "#984ea3",
                                  "#ff7f00"),
                       labels = c("pca" = "PCA",
                                  "ica" = "ICA",
                                  "nmf" = "NMF",
                                  "dae" = "DAE",
                                  "vae" = "VAE")) +
    scale_fill_manual(name = "Algorithm",
                      values = c("#e41a1c",
                                 "#377eb8",
                                 "#4daf4a",
                                 "#984ea3",
                                 "#ff7f00"),
                      labels = c("pca" = "PCA",
                                 "ica" = "ICA",
                                 "nmf" = "NMF",
                                 "dae" = "DAE",
                                 "vae" = "VAE")) +
    theme_bw() +
    ylab("-log10 P Value") +
    xlab("k Dimensions") +
    theme(axis.title.x = element_text(size = 7),
          axis.title.y = element_text(size = 7),
          axis.text.x = element_text(angle = 90,
                                     size = 5),
          axis.text.y = element_text(size = 6),
          plot.title = element_text(size = 8,
                                    hjust = 0.5),
          legend.text = element_text(size = 5),
          legend.title = element_text(size = 6),
          legend.key.size = unit(0.4, "lines"))

  best_result_df <- top_results_df %>%
    dplyr::arrange(desc(neg_log_p)) %>%
    dplyr::ungroup() %>%
    dplyr::top_n(n = 1, wt = neg_log_p)

  best_result_list[[t_test_file]] <- best_result_df
  line_gg_list[[t_test_file]] <- panel_gg
}

file <- file.path("..", "0.expression-download", "download", "GTEx_v7_Annotations_SubjectPhenotypesDS.txt")
gtex_sex_df <- readr::read_tsv(file)
head(gtex_sex_df, 2)

file <- file.path("..", "0.expression-download", "download", "GTEx_v7_Annotations_SampleAttributesDS.txt")
gtex_pheno_df <- readr::read_tsv(file, col_types = readr::cols(.default = readr::col_character(),
                                                               "SMGTC" = readr::col_character()))

full_gtex_ids <- c()
for (gtex_id in strsplit(gtex_pheno_df$SAMPID, "-")) {
  gtex_id_unlist <- unlist(gtex_id)
  sample_id <- paste0(gtex_id_unlist[1], "-", gtex_id_unlist[2])
  full_gtex_ids <- c(full_gtex_ids, sample_id)
}

gtex_pheno_df$SUBJID <- full_gtex_ids
gtex_pheno_df <- gtex_pheno_df %>%
    dplyr::left_join(gtex_sex_df, by = "SUBJID")

head(gtex_pheno_df, 2)

best_gtex_k_dim <- paste(best_result_list[[t_test_results_files[2]]]$z_dim[1])
best_gtex_seed <- paste(best_result_list[[t_test_results_files[2]]]$seed[1])
best_gtex_feature <- paste0(paste(best_result_list[[t_test_results_files[2]]]$algorithm[1]),
                            "_",
                            paste(best_result_list[[t_test_results_files[2]]]$feature_num[1]))

print(best_gtex_k_dim)
print(best_gtex_seed)
print(best_gtex_feature)

feature_file <- file.path("..",
                          "2.sequential-compression",
                          "results",
                          "GTEX_results",
                          "ensemble_z_matrices",
                          paste0("gtex_components_", best_gtex_k_dim),
                          paste0("model_", best_gtex_seed, "_z_test_matrix.tsv.gz"))

top_gtex_feature_df <- readr::read_tsv(feature_file,
                                       col_types = readr::cols(
                                           .default = readr::col_double(),
                                           sample_id = readr::col_character()
                                       )
                                      ) %>%
    dplyr::select(sample_id, !!best_gtex_feature)

head(top_gtex_feature_df)

balance_file <- file.path("results", "balanced_gtex_tissues.tsv")
balanced_gtex_tissues <- readr::read_tsv(balance_file, col_types = readr::cols()) %>%
    dplyr::pull(SMTS)

balanced_gtex_tissues

top_gtex_feature_df <- top_gtex_feature_df %>%
    dplyr::left_join(gtex_pheno_df, by = c("sample_id" = "SAMPID")) %>%
    dplyr::filter(SMTS %in% balanced_gtex_tissues)

top_gtex_feature_df$SEX <- dplyr::recode_factor(top_gtex_feature_df$SEX, `1` = "Male", `2` = "Female")
top_gtex_feature_df$SEX <- factor(top_gtex_feature_df$SEX, levels = c("Female", "Male"))

male_scores <- top_gtex_feature_df %>%
    dplyr::filter(SEX == "Male") %>%
    dplyr::pull(!!best_gtex_feature)
female_scores <- top_gtex_feature_df %>%
    dplyr::filter(SEX == "Female") %>%
    dplyr::pull(!!best_gtex_feature)

gtex_ttest_result <- t.test(male_scores, female_scores, var.equal = FALSE, paired = FALSE)
gtex_ttest_result

gtex_sex_gg <- ggplot(top_gtex_feature_df,
                      aes_string(y = best_gtex_feature,
                                 x = "SEX",
                                 fill = "SEX")) +
  geom_boxplot(alpha = 0.5,
               outlier.alpha = 0) +
  geom_jitter(aes(color = SEX),
              size = 0.2,
              alpha = 0.6,
              width = 0.3) +
  scale_fill_manual(labels = c("Male" = "Male",
                               "Female" = "Female"),
                    values = c("Male" = "#42c8f4",
                               "Female" = "#f489c9")) +
  scale_color_manual(labels = c("Male" = "Male",
                                "Female" = "Female"),
                     values = c("Male" = "#42c8f4",
                                "Female" = "#f489c9")) +
  theme_bw() +
  ylab("NMF Feature 111 (k = 200)") +
  xlab("") +
  ylim(c(-0.5, 1.7)) +
  ggtitle("GTEx Sex") +
  theme(axis.title.x = element_text(size = 7),
        axis.title.y = element_text(size = 7),
        axis.text.x = element_text(size = 6),
        axis.text.y = element_text(size = 6),
        plot.title = element_text(size = 8,
                                  hjust = 0.5),
        legend.position = "none") +
    geom_segment(aes(x=1,
                     y=max(top_gtex_feature_df[, best_gtex_feature]) + 0.15,
                     xend=2,
                     yend=max(top_gtex_feature_df[, best_gtex_feature]) + 0.15),
                 size=0.4) +
    geom_segment(aes(x=1,
                     y=max(top_gtex_feature_df[, best_gtex_feature]) + 0.15,
                     xend=1,
                     yend=max(top_gtex_feature_df[, best_gtex_feature])),
                 size=0.4) +
    geom_segment(aes(x=2,
                     y=max(top_gtex_feature_df[, best_gtex_feature]) + 0.15,
                     xend=2,
                     yend=max(top_gtex_feature_df[, best_gtex_feature])),
                 size=0.4) +
    geom_text(x=1.5,
              y = (max(top_gtex_feature_df[, best_gtex_feature]) + 0.25),
              size = 3.0,
              label = paste0("t = ",
                            round(gtex_ttest_result$statistic, 1),
                            "; p",
                            format.pval(gtex_ttest_result$p.value, digits = 2)))

gtex_sex_gg

# Load TCGA phenotype data
file <- file.path("..", "0.expression-download", "download", "TCGA-CDR-SupplementalTableS1.xlsx")
tcga_pheno_df <- readxl::read_xlsx(file, sheet=1, col_types = "text")

print(dim(tcga_pheno_df))
head(tcga_pheno_df)

best_tcga_k_dim <- paste(best_result_list[[t_test_results_files[3]]]$z_dim)
best_tcga_seed <- paste(best_result_list[[t_test_results_files[3]]]$seed)
best_tcga_feature <- paste0(paste(best_result_list[[t_test_results_files[3]]]$algorithm),
                            "_",
                            paste(best_result_list[[t_test_results_files[3]]]$feature_num))

print(best_tcga_k_dim)
print(best_tcga_seed)
print(best_tcga_feature)

feature_file <- file.path("..",
                          "2.sequential-compression",
                          "results",
                          "TCGA_results",
                          "ensemble_z_matrices",
                          paste0("tcga_components_", best_tcga_k_dim),
                          paste0("model_", best_tcga_seed, "_z_test_matrix.tsv.gz"))

top_tcga_feature_df <- readr::read_tsv(feature_file,
                                       col_types = readr::cols(
                                           .default = readr::col_double(),
                                           sample_id = readr::col_character()
                                       )
) %>%
  dplyr::select(sample_id, !!best_tcga_feature)

head(top_tcga_feature_df)

balance_file <- file.path("results", "balanced_tcga_tissues.tsv")
balanced_tcga_tissues <- readr::read_tsv(balance_file, col_types = readr::cols()) %>%
    dplyr::pull(type)

balanced_tcga_tissues

full_tcga_ids <- c()
for (tcga_id in strsplit(top_tcga_feature_df$sample_id, "-")) {
  tcga_id_unlist <- unlist(tcga_id)
  sample_id <- paste0(tcga_id_unlist[1], "-", tcga_id_unlist[2], "-", tcga_id_unlist[3])
  full_tcga_ids <- c(full_tcga_ids, sample_id)
}

top_tcga_feature_df$tcga_id <- full_tcga_ids
top_tcga_feature_df <- top_tcga_feature_df %>%
  dplyr::left_join(tcga_pheno_df, by = c("tcga_id" = "bcr_patient_barcode"))

top_tcga_feature_df$gender[is.na(top_tcga_feature_df$gender)] <- "Unlabeled"
top_tcga_feature_df$gender <- dplyr::recode_factor(top_tcga_feature_df$gender,
                                                   "MALE" = "Male",
                                                   "FEMALE" = "Female")
top_tcga_feature_df$gender <- factor(top_tcga_feature_df$gender,
                                     levels = c("Female", "Male", "Unlabeled"))

top_tcga_feature_df <- top_tcga_feature_df %>%
    dplyr::filter(type %in% balanced_tcga_tissues)

head(top_tcga_feature_df, 3)

male_scores <- top_tcga_feature_df %>%
    dplyr::filter(gender == "Male") %>%
    dplyr::pull(!!best_tcga_feature)
female_scores <- top_tcga_feature_df %>%
    dplyr::filter(gender == "Female") %>%
    dplyr::pull(!!best_tcga_feature)

tcga_ttest_result <- t.test(male_scores, female_scores, var.equal = FALSE, paired = FALSE)
tcga_ttest_result

tcga_sex_gg <- ggplot(top_tcga_feature_df,
                      aes_string(y = best_tcga_feature,
                                 x = "gender",
                                 fill = "gender")) +
  geom_boxplot(alpha = 0.5,
               outlier.alpha = 0) +
  geom_jitter(aes(color = gender),
              size = 0.2,
              alpha = 0.6,
              width = 0.3) +
  scale_fill_manual(labels = c("Male" = "Male",
                               "Female" = "Female",
                               "Unlabeled" = "Unlabeled"),
                    values = c("Male" = "#42c8f4",
                               "Female" = "#f489c9",
                               "Unlabeled" = "grey25")) +
  scale_color_manual(labels = c("Male" = "Male",
                                "Female" = "Female",
                                "Unlabeled" = "Unlabeled"),
                     values = c("Male" = "#42c8f4",
                                "Female" = "#f489c9",
                                "Unlabeled" = "grey25")) +
  theme_bw() +
  ylim(c(-0.075, 0.075)) +
  ylab("ICA Feature 53 (k = 90)") +
  xlab("") +
  ggtitle("TCGA Sex") +
  theme(axis.title.x = element_text(size = 7),
        axis.title.y = element_text(size = 7),
        axis.text.x = element_text(size = 6),
        axis.text.y = element_text(size = 6),
        plot.title = element_text(size = 8,
                                  hjust = 0.5),
        legend.position = "none") +
    geom_segment(aes(x=1,
                     y=max(top_tcga_feature_df[, best_tcga_feature]) + 0.005,
                     xend=2,
                     yend=max(top_tcga_feature_df[, best_tcga_feature]) + 0.005),
                 size=0.4) +
    geom_segment(aes(x=1,
                     y=max(top_tcga_feature_df[, best_tcga_feature]) + 0.005,
                     xend=1,
                     yend=max(top_tcga_feature_df[, best_tcga_feature])),
                 size=0.4) +
    geom_segment(aes(x=2,
                     y=max(top_tcga_feature_df[, best_tcga_feature]) + 0.005,
                     xend=2,
                     yend=max(top_tcga_feature_df[, best_tcga_feature])),
                 size=0.4) +
    geom_text(x=1.5,
              y = (max(top_tcga_feature_df[, best_tcga_feature]) + 0.012),
              size = 3.0,
              label = paste0("t = ",
                            round(tcga_ttest_result$statistic, 1),
                            "; p = ",
                            format.pval(tcga_ttest_result$p.value, digits = 2)))

tcga_sex_gg

best_target_k_dim <- paste(best_result_list[[t_test_results_files[1]]]$z_dim)
best_target_seed <- paste(best_result_list[[t_test_results_files[1]]]$seed)
best_target_feature <- paste0(paste(best_result_list[[t_test_results_files[1]]]$algorithm),
                              "_",
                              paste(best_result_list[[t_test_results_files[1]]]$feature_num))

print(best_target_k_dim)
print(best_target_seed)
print(best_target_feature)

feature_file <- file.path("..",
                          "2.sequential-compression",
                          "results",
                          "TARGET_results",
                          "ensemble_z_matrices",
                          paste0("target_components_", best_target_k_dim),
                          paste0("model_", best_target_seed, "_z_matrix.tsv.gz"))

top_mycn_feature_df <- readr::read_tsv(feature_file,
                                       col_types = readr::cols(
                                           .default = readr::col_double(),
                                           sample_id = readr::col_character()
                                       )
                                      ) %>%
  dplyr::select(sample_id, !!best_target_feature)

# Load TARGET phenotype data
file <- file.path("..", "0.expression-download", "data", "2017-09-30-TARGET update harmonized.txt")
nbl_pheno_df <- readr::read_tsv(file)

full_target_ids <- c()
for (target_id in strsplit(top_mycn_feature_df$sample_id, "-")) {
  target_id_unlist <- unlist(target_id)
  full_target_ids <- c(full_target_ids, target_id_unlist[3])
}

top_mycn_feature_df$target_id <- full_target_ids
top_mycn_feature_df <- top_mycn_feature_df %>%
  dplyr::inner_join(nbl_pheno_df, by = c("target_id" = "usi")) %>%
    dplyr::rename("mycn_status" = "MYCN status")

head(top_mycn_feature_df, 2)

amp_scores <- top_mycn_feature_df %>%
    dplyr::filter(mycn_status == "Amplified") %>%
    dplyr::pull(!!best_target_feature)
noamp_scores <- top_mycn_feature_df %>%
    dplyr::filter(mycn_status == "Not Amplified") %>%
    dplyr::pull(!!best_target_feature)

mycn_ttest_result <- t.test(amp_scores, noamp_scores, var.equal = FALSE, paired = FALSE)
mycn_ttest_result

mycn_amp_gg <- ggplot(top_mycn_feature_df,
                      aes_string(y = best_target_feature,
                                 x = "mycn_status",
                                 fill = "mycn_status")) +
    geom_boxplot(alpha = 0.5,
               outlier.alpha = 0) +
    geom_jitter(aes(color = mycn_status),
              alpha = 0.7,
              size = 0.9,
              width = 0.2) +
    scale_fill_manual(labels = c("Amplified" = "Amplified",
                                 "Not Amplified" = "Not Amplified",
                                 "Unknown" = "Unknown"),
                    values = c("Amplified" = "#d95f02",
                               "Not Amplified" = "#1b9e77",
                               "Unknown" = "grey25")) +
    scale_color_manual(labels = c("Amplified" = "Amplified",
                                "Not Amplified" = "Not Amplified",
                                "Unknown" = "Unknown"),
                     values = c("Amplified" = "#d95f02",
                                "Not Amplified" = "#1b9e77",
                                "Unknown" = "grey25")) +
    theme_bw() +
    ylab("VAE Feature 12 (k = 50)") +
    xlab("") +
    ggtitle("TARGET NBL MYCN Status") +
    ylim(c(-0.5, 8.0)) +
    theme(axis.title.x = element_text(size = 7),
       axis.title.y = element_text(size = 7),
       axis.text.x = element_text(size = 6),
       axis.text.y = element_text(size = 6),
       plot.title = element_text(size = 8,
                                 hjust = 0.5),
       legend.position = "none") +
    geom_segment(aes(x=1,
                     y=max(top_mycn_feature_df[, best_target_feature]) + 0.8,
                     xend=2,
                     yend=max(top_mycn_feature_df[, best_target_feature]) + 0.8),
                 size=0.4) +
    geom_segment(aes(x=1,
                     y=max(top_mycn_feature_df[, best_target_feature]) + 0.8,
                     xend=1,
                     yend=max(top_mycn_feature_df[, best_target_feature]) + 0.3),
                 size=0.4) +
    geom_segment(aes(x=2,
                     y=max(top_mycn_feature_df[, best_target_feature]) + 0.8,
                     xend=2,
                     yend=max(top_mycn_feature_df[, best_target_feature]) + 0.3),
                 size=0.4) +
    geom_text(x=1.5,
              y = (max(top_mycn_feature_df[, best_target_feature]) + 1.25),
              size = 3.0,
              label = paste0("t = ",
                            round(mycn_ttest_result$statistic, 1),
                            "; p = ",
                            format.pval(mycn_ttest_result$p.value, digits = 2)))

mycn_amp_gg

file <- file.path("results", "mycn_nbl_scores.tsv")
mycn_validation_df <- readr::read_tsv(file) %>%
    dplyr::rename("mycn_status" = "MYCN status")

mycn_validation_df$mycn_status <- dplyr::recode_factor(mycn_validation_df$mycn_status,
                                                       "Non-amplified" = "Not Amplified")
mycn_validation_df$mycn_status <- factor(mycn_validation_df$mycn_status,
                                         levels = c("Amplified", "Not Amplified"))
head(mycn_validation_df)

amp_scores <- mycn_validation_df %>%
    dplyr::filter(mycn_status == "Amplified") %>%
    dplyr::pull(!!best_target_feature)
noamp_scores <- mycn_validation_df %>%
    dplyr::filter(mycn_status == "Not Amplified") %>%
    dplyr::pull(!!best_target_feature)

mycn_val_ttest_result <- t.test(amp_scores, noamp_scores, var.equal = FALSE, paired = FALSE)
mycn_val_ttest_result

mycn_validation_gg <-
    ggplot(mycn_validation_df,
           aes_string(y = best_target_feature,
                      x = "mycn_status",
                      fill = "mycn_status")) +
    geom_boxplot(alpha = 0.5,
               outlier.alpha = 0) +
    geom_jitter(aes(color = mycn_status),
              alpha = 0.7,
              size = 0.9,
              width = 0.2) +
    theme_bw() +
    scale_fill_manual(labels = c("Amplified" = "Amplified",
                               "Not Amplified" = "Not Amplified"),
                    values = c("Amplified" = "#d95f02",
                               "Not Amplified" = "#1b9e77")) +
    scale_color_manual(labels = c("Amplified" = "Amplified",
                                "Not Amplified" = "Not Amplified"),
                     values = c("Amplified" = "#d95f02",
                                "Not Amplified" = "#1b9e77")) +
    ylab("VAE Feature 12 (k = 50)") +
    xlab("") +
    ggtitle("NBL Cell Lines MYCN Status") +
    ylim(c(8, 36.5)) +
    theme(axis.title.x = element_text(size = 7),
       axis.title.y = element_text(size = 7),
       axis.text.x = element_text(size = 6),
       axis.text.y = element_text(size = 6),
       plot.title = element_text(size = 8,
                                 hjust = 0.5),
       legend.position = "none") +
    geom_segment(aes(x=1,
                     y=max(mycn_validation_df[, best_target_feature]) + 1.2,
                     xend=2,
                     yend=max(mycn_validation_df[, best_target_feature]) + 1.2),
                 size=0.4) +
    geom_segment(aes(x=1,
                     y=max(mycn_validation_df[, best_target_feature]) + 1.2,
                     xend=1,
                     yend=max(mycn_validation_df[, best_target_feature]) + 0.4),
                 size=0.4) +
    geom_segment(aes(x=2,
                     y=max(mycn_validation_df[, best_target_feature]) + 1.2,
                     xend=2,
                     yend=max(mycn_validation_df[, best_target_feature]) + 0.4),
                 size=0.4) +
    geom_text(x=1.5,
              y = (max(mycn_validation_df[, best_target_feature]) + 2.75),
              size = 3.0,
              label = paste0("t = ",
                            round(mycn_val_ttest_result$statistic, 1),
                            "; p = ",
                            format.pval(mycn_val_ttest_result$p.value, digits = 2)))

mycn_validation_gg

# Plot multi panel figure
line_gg_legend <- cowplot::get_legend(line_gg_list[[1]])

full_line_gg <- cowplot::plot_grid(
    line_gg_list[[2]] +
        theme(legend.position = "none") +
    ggtitle("GTEx Sex"),
        line_gg_list[[3]] +
    theme(legend.position = "none") +
        ggtitle("TCGA Sex"),
    labels = c("a", "c")
)

full_line_gg <- cowplot::plot_grid(full_line_gg,
                                   line_gg_legend,
                                   rel_widths = c(1, 0.08),
                                   ncol = 2)

box_gg <- cowplot::plot_grid(
    gtex_sex_gg,
    tcga_sex_gg,
    labels = c("b", "d"),
    ncol = 2
)

full_nbl_gg <- cowplot::plot_grid(
    line_gg_list[[1]] +
        ggtitle("TARGET NBL MYCN Status") +
        theme(legend.position = "bottom"),
    mycn_amp_gg +
        ggtitle("TARGET NBL MYCN Status"),
    mycn_validation_gg +
        ggtitle("NBL Cell Lines MYCN Status"),
    labels = c("e", "f", "g"),
    ncol = 3
)

main_plot <- cowplot::plot_grid(
    full_line_gg,
    box_gg,
    full_nbl_gg,
    nrow = 3
)

main_plot

for(extension in c('.png', '.pdf', '.svg')) {
  fig_file <- paste0("full_separation_plot", extension)
  fig_file <- file.path("figures", fig_file)
  cowplot::save_plot(filename = fig_file,
                     plot = main_plot,
                     base_height = 180,
                     base_width = 170,
                     units = "mm",
                     dpi = 500)
}


#' Interpret lox statements
#'
#' @param statements list from \code{parse_tokens}
#' @param locals hashmap from \code{resolver}
#' @param env global environment
interpret <- function(statements, locals, env = NULL) {
  # create environment if it doesn't exist
  #env <- rlang::new_environment()
  if (is.null(env)) env <- env_new()

  # define built-in global functions
  # this should go somewhere else probably
  if (!env_has(env, "clock")) {
    env_define(
      env,
      "clock",
      callable(0, function() as.double(Sys.time()), function() "<native fn>")
    )
  }

  # create interpreter object
  interpreter <- list(env_global = env, env_cur = env, locals = locals)
  class(interpreter) <- c("lox_interpreter", class(interpreter))

  # evaluate statements in environment
  for (statement in statements) {
    execute(statement, interpreter)
  }

  # debug show env
  #rlang::env_print(env)

  # return env? not necessary because env is modified in place
  invisible(env)
}

is_truthy <- function(x) {
  if (x == "nil") return(FALSE)
  if (is.logical(x)) return(x)
  TRUE
}

is_equal <- function(x, y) {
  if (x == "nil" && y == "nil") return(TRUE)
  if (x == "nil" || y == "nil") return(FALSE)
  x == y
}

check_number_operand <- function(operator, operand) {
  if (is.double(operand)) return()
  lox_runtime_error(sprintf("Operand %s must be number", operand), operator)

}

check_number_operands <- function(operator, left, right) {
  if (is.double(left) && is.double(right)) return()
  lox_runtime_error(sprintf("Operands must be numbers"), operator)
}