#Castigo = 25

fit = function(observed_I, beta0, beta_min, beta_max, tau10, tau1_min, tau1_max,
               tau20, tau2_min, tau2_max,
               N00, N0_min, N0_max, Castigo, ignore_beta_diff, max_eval = 1000 ) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases. (son los incubadores!! o son los infecciosos nuevos)
  beta0 : numeric vector
    Initial value for beta; the expected number of cases (incubadores) stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, tau10, tau20, N00)
  steps = length(beta0)
  lb = c(rep(beta_min, steps), tau1_min, tau2_min, N0_min)
  ub = c(rep(beta_max, steps), tau1_max, tau2_max,  N0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7, "maxeval" = max_eval)
  print(opts)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    tau1 = x[steps + 1]
    tau2 = x[steps + 2]
    N0 = x[steps + 3]
    # calculate loss
    expected = get_expected(beta, N0, tau1, tau2) # Obtiene el número de casos infectados
    beta_diff = diff(beta)
    regularization1 =  (beta_diff/beta[1:length(beta_diff)])
    regularization =  (diff(regularization1)) ^ 2
    regularization = regularization[!1:length(regularization) %in% ignore_beta_diff]
    observed_I=round(observed_I,0)
    factSum=function(x){
      return(sum(log(1:round(x,0))))
    }
    loglikelihood=observed_I*log(expected$NN)-expected$NN-sapply(as.matrix(observed_I), FUN=factSum)
    loglikelihood[observed_I==0]=-expected$NN[observed_I==0]

    loss = -mean(loglikelihood) + Castigo * mean(regularization)
    #loss=sum((observed_I-expected$I)^2)+ sum(regularization)
    loss
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$tau1 = result$solution[steps + 1]
  model$tau2 = result$solution[steps + 2]
  model$N0 = result$solution[steps + 3]
  model$loss = result$objective
  beta=model$beta
  beta_diff = diff(beta)
  regularization1 =  (beta_diff/beta[1:length(beta_diff)])
  regularization =  (diff(regularization1)) ^ 2
  regularization = regularization[!1:length(regularization) %in% ignore_beta_diff]
  model$likelihood=(model$loss-Castigo*mean(regularization))*length(beta)
  return(model)
}


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

NE = 44514
t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
tcut.train = as.numeric(strptime("2010-04-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tcut.lead =  as.numeric(strptime("2010-09-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);

TD = read.csv(paste(RESDIR,'OrigSet_xinp1p2_yinp3.csv',sep=''),header=T)
LD = read.csv(paste(RESDIR,'OrigSet_xinp1p2p3.csv',sep=''),header=T)
RD = read.csv(paste(RESDIR,'reverts_related_features_training_and_LB.csv',sep=''),header=T)

stopifnot(dim(LD)[1] == NE, dim(RD)[1] == NE)
stopifnot(RD$user_id == LD$user_id)

# Add following features
# "intercept"                  "edits_per_in_day"
# "reverts_per_edit"            "edits_per_article"
# "reverts_per_edit_l5"        "edits_p" "edits_pp" "edits_ppp" "edits_pppp" "edits_ppppp"
# "fsdt_inv"                   "lsdt_inv"
# "mean_time_between_edits"    "mean_time_between_edits_l5" "edits_week_minus0"
# "edits_week_minus1"          "edits_week_minus2"          "edits_week_minus3"
# "sessions"
# "sessions_week_minus0"        "sessions_week_minus1"      "sessions_week_minus2"
# "sessions_week_minus3"      "sessions_month_minus0"       "sessions_month_minus1"
# "sessions_month_minus2"     "sessions_month_minus3"
# "sessions_p" "sessions_pp" "sessions_ppp"  "sessions_pppp"  "sessions_ppppp"
# "edits_per_session"  "edits_per_session_l5" "edits_per_session_week_last" "edits_per_session_month_last"
# "days_in_p","days_in_pp","days_in_ppp","days_in_pppp","days_in_ppppp"

# Add intercept, fsdt_inv, lsdt_inv
LD$intercept = rep(1,dim(LD)[1])
TD$intercept = rep(1,dim(TD)[1])

LD$fsdt_inv = tcut.lead - LD$FSDT
LD$lsdt_inv = tcut.lead - LD$LSDT
TD$fsdt_inv = tcut.train - TD$FSDT
TD$lsdt_inv = tcut.train - TD$LSDT

# Add reverts_per_edit, reverts_per_edit_l5, edits_per_article
LD$reverts_per_edit = LD$sum_reverts / LD$sum_edits
LD$reverts_per_edit_l5 = (LD$sum_reverts+1) / (LD$sum_edits+1)
LD$edits_per_article = LD$sum_edits / LD$sum_articles

TD$reverts_per_edit = TD$sum_reverts / TD$sum_edits
TD$reverts_per_edit_l5 = (TD$sum_reverts+1) / (TD$sum_edits+1)
TD$edits_per_article = TD$sum_edits / TD$sum_articles

# Add edits_per_in_day, days_in_p, days_in_pp ... in_ppppp
Mlen = tcut.lead / 116

LD$edits_per_in_day = LD$sum_edits / LD$fsdt_inv
LD$days_in_p = pmin(LD$fsdt_inv, Mlen*5)
LD$days_in_pp = pmin(pmax(LD$fsdt_inv-Mlen*5,0), Mlen*5)
LD$days_in_ppp = pmin(pmax(LD$fsdt_inv-Mlen*10,0), Mlen*5)
LD$days_in_pppp = pmin(pmax(LD$fsdt_inv-Mlen*15,0), Mlen*5)
LD$days_in_ppppp = pmin(pmax(LD$fsdt_inv-Mlen*20,0), Mlen*5)

TD$edits_per_in_day = TD$sum_edits / TD$fsdt_inv
TD$days_in_p = pmin(TD$fsdt_inv, Mlen*5)
TD$days_in_pp = pmin(pmax(TD$fsdt_inv-Mlen*5,0), Mlen*5)
TD$days_in_ppp = pmin(pmax(TD$fsdt_inv-Mlen*10,0), Mlen*5)
TD$days_in_pppp = pmin(pmax(TD$fsdt_inv-Mlen*15,0), Mlen*5)
TD$days_in_ppppp = pmin(pmax(TD$fsdt_inv-Mlen*20,0), Mlen*5)

et = scan(paste(RESDIR,'edit_times_unrounded.csv',sep=''),what="character")
meu = read.csv(paste(RESDIR,"editor_monthly_edits_unique_sessions_unrounded.csv",sep=''),header=T)
mea = read.csv(paste(RESDIR,"editor_monthly_edits_unrounded.csv",sep=''),header=T)
stopifnot(dim(meu) == c(NE,117), dim(mea) == c(NE,117), length(et)==NE)

# Add edits_p, _pp ... _ppppp and sessions_p, sessions_pp, ...._ppppp
LD$edits_p = rowSums(mea[,113:117])
LD$edits_pp = rowSums(mea[,108:112])
LD$edits_ppp = rowSums(mea[,103:107])
LD$edits_pppp = rowSums(mea[,98:102])
LD$edits_ppppp = rowSums(mea[,93:97])

LD$sessions = rowSums(meu[,-1])
LD$sessions_p = rowSums(meu[,113:117])
LD$sessions_pp = rowSums(meu[,108:112])
LD$sessions_ppp = rowSums(meu[,103:107])
LD$sessions_pppp = rowSums(meu[,98:102])
LD$sessions_ppppp = rowSums(meu[,93:97])

itrain = which(mea[,1] %in% TD$user_id)
TD$edits_p = LD$edits_pp[itrain]
TD$edits_pp = LD$edits_ppp[itrain]
TD$edits_ppp = LD$edits_pppp[itrain]
TD$edits_pppp = LD$edits_ppppp[itrain]
TD$edits_ppppp = rowSums(mea[itrain,88:92])

TD$sessions = rowSums(meu[itrain,2:112])
TD$sessions_p = LD$sessions_pp[itrain]
TD$sessions_pp = LD$sessions_ppp[itrain]
TD$sessions_ppp = LD$sessions_pppp[itrain]
TD$sessions_pppp = LD$sessions_ppppp[itrain]
TD$sessions_ppppp = rowSums(meu[itrain,88:92])

# Add "mean_time_between_sessions"    "mean_time_between_sessions_l5"
stopifnot(min(LD$sessions) > 0)
LD$mean_time_between_sessions = (LD$LSDT - LD$FSDT)/LD$sessions
iz = which(LD$sessions_p == 0)
LD$mean_time_between_sessions_l5 = (Mlen*5)/(LD$sessions_p)
LD$mean_time_between_sessions_l5[iz] = LD$lsdt_inv[iz]

stopifnot(min(TD$sessions) > 0)
TD$mean_time_between_sessions = (TD$LSDT - TD$FSDT)/TD$sessions
iz = which(TD$sessions_p == 0)
TD$mean_time_between_sessions_l5 = (Mlen*5)/(TD$sessions_p)
TD$mean_time_between_sessions_l5[iz] = TD$lsdt_inv[iz]

#  Add edits_week_minus<0-3> , sessions_week_minus<0-3>, sessions_month_minus<0-3>
Wlen = 7
ewvar = list(); swvar=list(); smvar = list()
newfeatures = list()
for (j in 0:3){

	ewvar[j+1] = paste("edits_week_minus",j,sep='')
	swvar[j+1] = paste("sessions_week_minus",j,sep='')
	smvar[j+1] = paste("sessions_month_minus",j,sep='')
	newfeatures[j+1] = smvar[j+1]
	newfeatures[12-(j*2)-1] = ewvar[j+1]
	newfeatures[12-j*2] = swvar[j+1]
}
ewvar = unlist(ewvar); swvar = unlist(swvar); smvar = unlist(smvar); newfeatures = unlist(newfeatures)

temp.t = matrix(0,dim(TD)[1],length(newfeatures)); colnames(temp.t) <- newfeatures
temp.l = matrix(0,dim(LD)[1],length(newfeatures)); colnames(temp.l) <- newfeatures
TD = as.matrix(TD); LD = as.matrix(LD) #Matrix indexing is much faster than data.frame indexing
TD = cbind(TD,temp.t); LD = cbind(LD,temp.l)

weekref.lead = tcut.lead - 4*Wlen
weekref.train = tcut.train - 4*Wlen

for (ia in 1:NE){
	itr = which(TD[,'user_id'] == LD[ia,'user_id'])

	if (ia%%2000 == 0) {cat(sprintf("Parsed %i of %i editors",ia,NE),"\n"); flush.console();}

	for (m in 0:3){
		LD[ia,smvar[m+1]] = meu[ia,117-m]

		if (length(itr) == 1){
			TD[itr,smvar[m+1]] = meu[ia,112-m]
		}
	}
	splita <- as.numeric(strsplit(et[ia],",",fixed=T)[[1]])
	for (w in 3:0){
		winst = w*Wlen + weekref.lead
		winen = winst + Wlen
		iwithin = (splita > winst & splita <= winen)
		LD[ia,ewvar[w+1]] = sum(iwithin)
		if (LD[ia,ewvar[w+1]] > 0){
			LD[ia,swvar[w+1]] = sum(diff(sort(splita[iwithin])) > 0.5) + 1
		}else{
			LD[ia,swvar[w+1]] = 0
		}
		rm(list=c("winst","winen","iwithin"))

		# check if this user also exists in the training set, process if it does
		if (length(itr) == 1){
			winst = w*Wlen + weekref.train
			winen = winst + Wlen
			iwithin = (splita > winst & splita <= winen)
			TD[itr,ewvar[w+1]] = sum(iwithin)
			if (TD[itr,ewvar[w+1]] > 0){
				TD[itr,swvar[w+1]] = sum(diff(sort(splita[iwithin])) > 0.5) + 1
			}else{
				TD[itr,swvar[w+1]] = 0
			}
		}
	}
}
TD = data.frame(TD)
LD = data.frame(LD)

# "edits_per_session"  "edits_per_session_l5" "edits_per_session_last_month"  "edits_per_session_last_week"
LD$edits_per_session = LD$sum_edits / LD$sessions
LD$edits_per_session_l5 = LD$edits_p / pmax(LD$sessions_p,1);
LD$edits_per_session_last_month = LD$Edits_mth_cutoff_minus_0 / pmax(LD$sessions_month_minus0,1);
LD$edits_per_session_last_week = LD$edits_week_minus0 / pmax(LD$sessions_week_minus0,1);

TD$edits_per_session = TD$sum_edits / pmax(TD$sessions,1);
TD$edits_per_session_l5 = TD$edits_p / pmax(TD$sessions_p,1);
TD$edits_per_session_last_month = TD$Edits_mth_cutoff_minus_0 / pmax(TD$sessions_month_minus0,1);
TD$edits_per_session_last_week = TD$edits_week_minus0 / pmax(TD$sessions_week_minus0,1);

write.csv(LD, file = paste(RESDIR,"Featureskd_XinP1P2P3.csv",sep=''), row.names = FALSE);
write.csv(TD, file = paste(RESDIR,"Featureskd_XinP1P2_YinP3.csv",sep=''), row.names = FALSE);

### -------------- Now Merge reverts related features ------------------------------------------------

itrain = which(RD$user_id %in% TD$user_id)
stopifnot(RD$user_id[itrain] == TD$user_id)

TD = cbind(TD,RD[itrain,2:10])
LD = cbind(LD,RD[,11:19])

TD$reverts_got_per_edit_l5 = (TD$train_l5m_got - TD$train_l5m_auto)/(TD$edits_p + 1)
TD$reverts_made_per_edit_l5 = (TD$train_l5m_made - TD$train_l5m_auto)/(TD$edits_p + 1)

TD$reverts_got_per_edit_l1 = (TD$train_l1m_got - TD$train_l1m_auto)/(TD$Edits_mth_cutoff_minus_0 + 1)
TD$reverts_made_per_edit_l1 = (TD$train_l1m_made - TD$train_l1m_auto)/(TD$Edits_mth_cutoff_minus_0 + 1)

LD$reverts_got_per_edit_l5 = (LD$lead_l5m_got - LD$lead_l5m_auto)/(LD$edits_p + 1)
LD$reverts_made_per_edit_l5 = (LD$lead_l5m_made - LD$lead_l5m_auto)/(LD$edits_p + 1)

LD$reverts_got_per_edit_l1 = (LD$lead_l1m_got - LD$lead_l1m_auto)/(LD$Edits_mth_cutoff_minus_0 + 1)
LD$reverts_made_per_edit_l1 = (LD$lead_l1m_made - LD$lead_l1m_auto)/(LD$Edits_mth_cutoff_minus_0 + 1)

colnames(TD) = gsub('train_','reverts_',colnames(TD))
colnames(LD) = gsub('lead_','reverts_',colnames(LD))

write.csv(LD, file = paste(RESDIR,"Featureskd_wrevs_XinP1P2P3.csv",sep=''), row.names = FALSE);
write.csv(TD, file = paste(RESDIR,"Featureskd_wrevs_XinP1P2_YinP3.csv",sep=''), row.names = FALSE);


#' Correlation Correlogram.
#'
#' correlogram function will draw Correlogram for correlation analysis.
#' @param data input data.frame
#' @param title main title
#' @param subtitle subtitle
#' @param caption caption
#' @return An object of class \code{ggplot}
#' @examples
#' plot<- correlogram(data=mtcars)
#' plot
#'
#' @import ggplot2
#' @import scales
#' @import reshape2
#' @import ggthemes
#' @import gganimate
#' @import gapminder
#' @import ggalt
#' @import ggExtra
#' @import ggcorrplot
#' @import dplyr
#' @import treemapify
#' @import ggfortify
#' @import zoo
#' @import ggdendro
#' @export
correlogram<-function(data,
                      title=NULL,subtitle=NULL,caption=NULL){
  df<-data[, sapply(data, class) == "numeric"]

  corr<-round(cor(df),2)

  ggcorrplot(corr, hc.order = TRUE,
             type = "lower",
             lab = TRUE,
             lab_size = 3,
             method="square",
             color=c("#008FD5", "white", "#FF2700")) +
    theme_fivethirtyeight() +
    labs(subtitle=subtitle,
         title=title,
         caption = caption)

}


test = dimops_rowsums(x)$to_robj()
truth = rowSums(xr)
cmp(test, truth)

test = dimops_rowmeans(x)$to_robj()
truth = rowMeans(xr)
cmp(test, truth)

test = dimops_colsums(x)$to_robj()
truth = colSums(xr)
cmp(test, truth)

test = dimops_colmeans(x)$to_robj()
truth = colMeans(xr)
cmp(test, truth)

s = x$dupe()
dimops_scale(x=s)
test = s$to_robj()
truth = scale(xr, center=TRUE, scale=TRUE)
attr(truth, "scaled:center") = NULL
attr(truth, "scaled:scale") = NULL
cmp(test, truth)


source("density.R")
source("tools.r")
source("sql.r")

divideVector <- function (N, vec) {
  vecRem <- 1:length(vec)
  distribute <- length(vec) %% N
  eachLen <- length(vec) %/% N
  validation <- list()
  for (i in 1:N) {
    if (i <= distribute) {
      to <- eachLen+1
    } else {
      to <- eachLen
    }
    validation[[i]] <- vecRem[1:to]
    vecRem <- vecRem[(to+1):length(vecRem)]
  }

  res <- list()
  for (i in seq(validation)) {
    res[[i]] <- list (
      train = vec[-validation[[i]]],
      validation = vec[validation[[i]]]
    )
  }
  return (res)
}

exeCV <- function (dat, fn, cvData, cvN) {
  scores <- c()
  for (i in 1:cvN) {
    dens <- fn(cvData[[i]]$train)
    plot(dens)
    score <- sum(-log(fitDistToX (dat, dens)$y)) / length(dat)
    scores <- c(scores, score)
  }
  return (scores)
}

exeAllCV <- function (algorithms, dat, cvN) {
  res <- list()
  cvData <- divideVector (cvN, dat)
  for ( i in seq(algorithms)) {
    fn <- algorithms[[i]]
    cvScore <- exeCV (dat, fn, cvData, cvN)
    res[[i]] <-cvScore
  }
  return (res)
}

dat <- datList$osm
#fn <- sj
cvN <- 10
#cvData <- divideVector (cvN, dat)
#s <- exeCV(dat, botev, cvData, cvN)

algorithms <- list (
  sj = sj,
  adeba = adeba,
  botev = botev,
  default = default
)

res <- exeAllCV (algorithms, dat, cvN)

for (i in seq(res)) {
  print(
    mean(
      res[[i]][1:(length(res[[i]])-1)]
      )
    )
}


#
# Exemplo 4
#

# definindo uma função quadrática
funcaoquadratica <- function(x) {
    valor <- x^2
    print(valor)
}
# calculando
funcaoquadratica(2)
funcaoquadratica(pi)


library(ggplot2)
library(rPref)

setwd("~/Documents/Source/jMetalPy/mo_results/")
normalize <- function(x) {
  return ((x - min(x)) / (max(x) - min(x)))
}

energies_01 <- read.table(file = 'FUN.DEMO.PSP_MO.1ZDD-0', col.names = c('OBJ1', 'OBJ2'))
angles_01 <- read.table(file='VAR.DEMO.PSP_MO.1ZDD-0')

energies_01.df <- as.data.frame.matrix(energies_01)
energies_01.df <- cbind(energies_01, data.frame(algorithm='DEMO'))
energies_01.df <- cbind(energies_01.df, angles_01)

sky_01 <- psel(energies_01.df, low(OBJ1) * low(OBJ2))

full_data = rbind(energies_01.df)

ggplot(full_data, aes(x = OBJ1, y = OBJ2, colour=factor(algorithm))) +
  geom_point(alpha=1/3)+
  geom_point(data = sky_01, size = 3) +
  geom_step(data = sky_01, direction = "vh") +
  labs(x="vdW Energy", y="Bonded + Seconday Structure", title = "PDB ID: 1ZDD" )+
  theme_minimal() + guides(colour="none")

#v1 <- normalize(energies_01$OBJ1)
#v2 <- normalize(energies_01$OBJ2)

#normalized_df <- cbind(v1, v2, data.frame(algorithm='1'))
#sky_norm <- psel(normalized_df, low(v1)* low(v2))

#ggplot(normalized_df, aes(x = v1, y = v2, colour=factor(algorithm))) +
#  geom_point(alpha=1/3)+
#  geom_point(data = sky_norm, size = 3) + geom_step(data = sky_norm, direction = "vh")


input <- readLines('stdin')
x <- as.integer(input[1])
y <- as.integer(input[2])

#define the function
rangeSum <- function(x,y)
{
    suma<-0
    for(a in x:y)
    {
        suma<-suma+a
    }
    return (suma)
}

result <- rangeSum(x, y)
print(result)

SoloLearn/R/Programming in R - Sum in Range .r


test <- read.csv("")
train <- read.csv("")
 jaccard <- function(s1, s2) {
 s1 <- paste("#",s1, "#", sep="")
 s2 <- paste("#", s2, "#", sep="")
 s1vec <- c()
 s2vec <- c()
 s1length <- nchar(s1)
 s2length <- nchar(s2)
 for(i in 2:s1length-1) {
 x <- substr(s1, i, i+1)
 s1vec <- c(s1vec, x)
 }
 for(i in 2:s2length-1) {
 x <- substr(s2, i, i+1)
 s2vec <- c(s2vec, x)
 }
 print(s1vec)
 print(s2vec)
 intersect <- intersect(s1vec, s2vec)
 union <- union(s1vec, s2vec)
 print(intersect(s1vec, s2vec))
 print(union(s1vec, s2vec))
 Score <- length(intersect) / length(union)
 return(Score)
 }
 jaccard(test$Name[1], train$Name[1])


# Casino winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Calculate poker_better
poker_better <- poker_vector > roulette_vector
print(poker_better)
# Calculate total_poker and total_roulette, as before

total_poker <- sum(poker_vector)
print(total_poker)
total_roulette <- sum(roulette_vector)
print(total_roulette)
# Calculate choose_poker
choose_poker <- total_poker > total_roulette

# Print choose_poker
print(choose_poker)


library(data.table)
library(ggplot2)
library(cowplot)
library(fixest)
library(lubridate)
library(dummies)
library(devtools)
library(tibble)
library(backports)
# install_github("yukai-yang/PSTR")
library(PSTR)

rm(list=ls())
gc()

source("myscript.r")

# the 'not in' function
'%!in%' <- Negate('%in%')

# the 'normalizing' function
mean_adj <- function(x){
  x <- x/mean(x)
  return(x)
}

# load the price and conflict data
load("dataset.RData")

# control variables
combined_dt[,w1 := x*Within_Reg]
combined_dt[,w2 := x*Distance_km/100]
combined_dt[,w3 := x*Travel_hr]

rice.fe <- feols(y~x+w1+w2 | Dyad+Month, combined_dt[Crop=="Rice"])
r.base <- summary(rice.fe)

maize.fe <- feols(y~x+w1+w2  | Dyad+Month, combined_dt[Crop=="Maize"])
m.base <- summary(maize.fe)

sorghum.fe <- feols(y~x+w1+w2  | Dyad+Month, combined_dt[Crop=="Sorghum"])
s.base <- summary(sorghum.fe)

## Table 4.a
linear_tab <- etable(r.base,m.base,s.base,drop=c("w1","w2"))

##-- Baseline, Dyad FE
rice.fe <- feols(y~x:I(1-s1bar)+x:s1bar+w1+w2 | Dyad+Month, combined_dt[Crop=="Rice"])
r.inter <- summary(rice.fe)

maize.fe <- feols(y~x:I(1-s1bar)+x:s1bar+w1+w2  | Dyad+Month, combined_dt[Crop=="Maize"])
m.inter <- summary(maize.fe)

sorghum.fe <- feols(y~x:I(1-s1bar)+x:s1bar+w1+w2  | Dyad+Month, combined_dt[Crop=="Sorghum"])
s.inter <- summary(sorghum.fe)

##-------------------------------------------------------------------------
## to obtain statistical significance in the difference between the regimes
rice.fe <- feols(y~x+x:s1bar+w1+w2 | Dyad+Month, combined_dt[Crop=="Rice"])
r.inter.d <- summary(rice.fe)

maize.fe <- feols(y~x+x:s1bar+w1+w2  | Dyad+Month, combined_dt[Crop=="Maize"])
m.inter.d <- summary(maize.fe)

sorghum.fe <- feols(y~x+x:s1bar+w1+w2  | Dyad+Month, combined_dt[Crop=="Sorghum"])
s.inter.d <- summary(sorghum.fe)
##-------------------------------------------------------------------------

## Table 4.c
interacted_tab <- etable(r.inter,m.inter,s.inter,drop=c("w1","w2"))

crop <- "Rice"
crop_dt <- combined_dt[Crop==crop]

# save as tibble to use the homogeneity test from PSTR the package
crop_tb <- as_tibble(crop_dt)

# candidate transition variables:
tvec <- c('s1bar','s3bar','s6bar','s12bar')

pstr <- NewPSTR(crop_tb,dep='y',indep=c("x"),indep_k=c("x"),tvars=tvec[1],im=2,iT=length(unique(crop_dt$Date)))

## the next few lines contribute to Table 3
# homogeneity test: F-distribution
options(warn=0)
LinTest(pstr)

# the bootstrap version (takes a little bit of time)
wb_test <- WCB_LinTest(pstr,iB=999)

wb_test$wcb_test
wb_test$wcb_sqtest

# define the transition variable and include in the dataset
tvr <- 's1bar'
combined_dt$tv <- combined_dt[,..tvr]

# estimte the PSTR
pstr_coef <- my_pstr(crop_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=0.5,c_start=.5,tf=1,max_it=100)

options(warn=0)

crop_dt$tv <- crop_dt[,..tvr]
if(length(pstr_coef)==2){
  crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
}else{
  crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c11"])*(crop_dt$tv-pstr_coef["c12"])/sd(crop_dt$tv)^2))^(-1))
}

# re-estimate the PSTR by fixing the estimated smoothness and centrality
# parameters and fitting the regression as a fixed effects model with
# monthly dummy variables
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad+Month, crop_dt)
r.pstr <- summary(crop.fe)

##-------------------------------------------------------------------------
## to obtain statistical significance in the difference between the regimes
rice.fe <- feols(y~x+x:G_tv+w1+w2 | Dyad+Month, crop_dt)
r.pstr.d <- summary(rice.fe)
##-------------------------------------------------------------------------

## Table 4.b
pstr_tab <- etable(r.pstr,drop=c("w1","w2"))

# plot the estimated transition function
gg_tf <- ggplot(crop_dt,aes(x=tv,y=G_tv))+
  geom_point(size=1,color="indianred")+
  labs(y=bquote(G({c^"*"}[ijt-1],gamma,kappa)),x=bquote({c^"*"}[ijt-1]))+
  theme_classic()+
  theme(axis.title = element_text(size=12), axis.text = element_text(size=10),legend.title = element_blank(),legend.text = element_text(size=8),legend.position = "none")

## Figure A2
ggsave("transition.png",gg_tf,width=6.5,height=3.5)

# # un-comment from here forward and run this loop to generate dyad-specific
# # figures of transition variables and transition functions over time
# # (not included in the paper)
# for(i in 1:length(unique(crop_dt$Dyad))){
#
#   dt <- crop_dt[Dyad==unique(Dyad)[i]]
#   dt <- dt[,.(Dyad,Market1,Market2,Date,x,tv,G_tv,z=z0)]
#
#   dt$aa <- NA
#   dt$bb <- NA
#   for(s in 2:(nrow(dt))){
#     if(dt$G_tv[s] >= mean(dt$G_tv,na.rm=T) & dt$G_tv[s-1] < mean(dt$G_tv,na.rm=T)){
#       dt$aa[s] <- as.character(dt$Date[s])
#     }else if(dt$G_tv[s] < mean(dt$G_tv,na.rm=T) & dt$G_tv[s-1] >= mean(dt$G_tv,na.rm=T)){
#       dt$bb[s] <- as.character(dt$Date[s])
#     }
#   }
#
#   if(dt$G_tv[1] >= mean(dt$G_tv,na.rm=T)){
#     dt$aa[1] <- as.character(dt$Date[1])
#   }
#   if(dt$G_tv[nrow(dt)] >= mean(dt$G_tv,na.rm=T)){
#     dt$bb[nrow(dt)] <- as.character(dt$Date[nrow(dt)])
#   }
#
#   dt$aa <- as.Date(dt$aa)
#   dt$bb <- as.Date(dt$bb)
#
#   dt$Date1 <- shift(dt$Date,type="lead")
#
#   gg_dyad <- ggplot(dt,aes(x=decimal_date(Date)))+
#     geom_line(aes(y=z),color="indianred",size=.8,na.rm=T)+
#     geom_rect(aes(xmin=decimal_date(dt$Date),xmax=decimal_date(dt$Date1),ymin=-Inf,ymax=Inf),fill=alpha("indianred",dt$G_tv*.25),na.rm=T)+
#     scale_x_continuous(breaks=c(2009,2012,2015,2018))+
#     labs(title=paste(dt$Market1[1],"\u2013",dt$Market2[1],sep=""),y=expression(c[ijt]),x="Year")+
#     theme_classic()+
#     theme(axis.title = element_text(size=12), axis.text = element_text(size=10),legend.title = element_blank(),legend.text = element_text(size=8),legend.position = "none")
#
#   ggsave(paste(substr(dt$Market1[1],1,3),"_",substr(dt$Market2[1],1,3),".png",sep=""),gg_dyad,width=6.5,height=3.5)
#
# }


# purpose: calculate the heterosis (MPH and HPH)
# Jinliang Yang
# 2.1.2012
# updated: 4.12.2012

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

diallel <- read.csv("cache/pheno_diallel_master_BLUE.csv")
dim(diallel)
# 225 8
p <- read.csv("cache/pheno_namparents_blue.csv")
dim(p)
# 27 8

namid <- read.table("nam_parents", header=TRUE)
namid <- namid[, c(1,3)]

diallel$z1 <- NA;
diallel$z2 <- NA;
diallel$Genotype <- as.character(diallel$Genotype)
for(i in 1:nrow(diallel)){
  tem <- unlist(strsplit(diallel$Genotype[i], split="x"))
  diallel$z1[i] <- tem[1];
  diallel$z2[i] <- tem[2];
}

diallel <- merge(namid, diallel, by.x="pop", by.y="z1")
diallel <- merge(namid, diallel, by.x="pop", by.y="z2")
diallel <- diallel[, c(5, 3,1, 4,2, 6:12)]
names(diallel)[2:5] <- c("z1", "z2", "p1", "p2")
diallel$p1 <- toupper(diallel$p1);
diallel$p2 <- toupper(diallel$p2);

diallel$KRN_HPH <- NA
diallel$KRN_MPH <- NA
diallel$CL_HPH <- NA
diallel$CL_MPH <- NA
diallel$CW_HPH <- NA
diallel$CW_MPH <- NA
diallel$CD_HPH <- NA
diallel$CD_MPH <- NA
diallel$AKW_HPH <- NA
diallel$AKW_MPH <- NA
diallel$TKW_HPH <- NA
diallel$TKW_MPH <- NA
diallel$KC_HPH <- NA
diallel$KC_MPH <- NA

##########################################################################################################
p$Genotype <- as.character(p$Genotype)
for (i in 1:nrow(diallel)){
  p1 <- as.character(diallel$p1[i]);
  p2 <- as.character(diallel$p2[i]);
  diallel$KRN_HPH[i] <- diallel$KRN[i] - max(p[p$Genotype==p1, ]$KRN, p[p$Genotype==p2, ]$KRN);
  diallel$KRN_MPH[i] <- diallel$KRN[i] - mean(c(p[p$Genotype==p1, ]$KRN, p[p$Genotype==p2, ]$KRN), na.rm=T);
  diallel$CL_HPH[i] <- diallel$CL[i] - max(p[p$Genotype==p1, ]$CL, p[p$Genotype==p2, ]$CL);
  diallel$CL_MPH[i] <- diallel$CL[i] - mean(c(p[p$Genotype==p1, ]$CL, p[p$Genotype==p2, ]$CL), na.rm=T);
  diallel$CW_HPH[i] <- diallel$CW[i] - max(p[p$Genotype==p1, ]$CW, p[p$Genotype==p2, ]$CW);
  diallel$CW_MPH[i] <- diallel$CW[i] - mean(c(p[p$Genotype==p1, ]$CW, p[p$Genotype==p2, ]$CW), na.rm=T);
  diallel$CD_HPH[i] <- diallel$CD[i] - max(p[p$Genotype==p1, ]$CD, p[p$Genotype==p2, ]$CD);
  diallel$CD_MPH[i] <- diallel$CD[i] - mean(c(p[p$Genotype==p1, ]$CD, p[p$Genotype==p2, ]$CD), na.rm=T);
  diallel$AKW_HPH[i] <- diallel$AKW[i] - max(p[p$Genotype==p1, ]$AKW, p[p$Genotype==p2, ]$AKW);
  diallel$AKW_MPH[i] <- diallel$AKW[i] - mean(c(p[p$Genotype==p1, ]$AKW, p[p$Genotype==p2, ]$AKW), na.rm=T);
  diallel$TKW_HPH[i] <- diallel$TKW[i] - max(p[p$Genotype==p1, ]$TKW, p[p$Genotype==p2, ]$TKW);
  diallel$TKW_MPH[i] <- diallel$TKW[i] - mean(c(p[p$Genotype==p1, ]$TKW, p[p$Genotype==p2, ]$TKW), na.rm=T);
  diallel$KC_HPH[i] <- diallel$KC[i] - max(p[p$Genotype==p1, ]$KC, p[p$Genotype==p2, ]$KC);
  diallel$KC_MPH[i] <- diallel$KC[i] - mean(c(p[p$Genotype==p1, ]$KC, p[p$Genotype==p2, ]$KC), na.rm=T);
}

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


####################################################################
#UNIVERSITY : STEVENS INSTITUE OF TECHNOLOGY
#Project : HW 02 EDA
#Purpose : Perform the EDA analysis on breast-cancer-wisconsin data
#First Name : Sarthak
#Last Name : Ahir
#CWID : 10479028
#Date : 10/10/2021
####################################################################
rm(list=ls())

#Load the “breast-cancer-wisconsin.csv” from canvas into R and perform the EDA analysis

newDataSet <- read.csv("~/Downloads/breast-cancer-wisconsin.csv", na.string = "?")

#Summarizing each column
summary(newDataSet)

View(newDataSet)
is.data.frame(newDataSet)

#Identifying missing values
is.na(newDataSet)
View(newDataSet)

#F6 missing values
is.na(newDataSet$F6)

#Replacing the missing values with the "mean" of the column.
x<-round(mean(newDataSet$F6, na.rm=TRUE))
newDataSet$F6[is.na(newDataSet$F6)]<-x

#summary of column
summary(newDataSet)

#Displaying the frequency table of "Class" vs. F6

freqTable <- table(Class = newDataSet$Class, F6 = newDataSet$F6)
print(freqTable)

#Displaying the scatter plot of F1 to F6, one pair at a time

plot(newDataSet$F1, newDataSet$F2, main="F1 and F2 Scatterplot",
     xlab="F1", ylab="F2", pch=21, bg = c("blue","yellow"))

plot(newDataSet$F2, newDataSet$F3, main="F2 and F3 Scatterplot ",
     xlab="F2", ylab="F3", pch=21, bg = c("green","yellow"))

plot(newDataSet$F3, newDataSet$F4, main="F3 and F4 Scatterplot ",
     xlab="F3", ylab="F4", pch=21, bg = c("orange","purple"))

plot(newDataSet$F4, newDataSet$F5, main="F4 and F5 Scatterplot ",
     xlab="F4", ylab="F5", pch=21, bg = c("red","orange"))

plot(newDataSet$F5, newDataSet$F6, main="F5 and F6 Scatterplot ",
     xlab="F5", ylab="F6", pch=21, bg = c("orange","green"))

#All pairs at once
plot(newDataSet[2:7], main = "F1 to F6 Scatter Plot", pch=21, bg = c("orange","green"))

#Show histogram plot for columns F7 to F9
hist(newDataSet$F7, col="green")
hist(newDataSet$F8, col="blue")
hist(newDataSet$F9, col="red")

# Box Plot for Columns F7 to F9
boxplot(newDataSet[8:10], main = "Histogram Box Plot for Columns F7 to F9")

#Delete all the objects from your R- environment.
rm(list=ls())

#Reload the “breast-cancer-wisconsin.data.csv” from canvas into R
newDataSet <- read.csv("~/Downloads/breast-cancer-wisconsin.csv", na.string = "?")

#Remove any row with a missing value in any of the columns
newDataSet[,1:11][newDataSet[,1:11]=="?"] <- NA
newDataSet <- na.omit(newDataSet)
summary(newDataSet)


# load libraries
library("tidyverse")
library("psych")
library("gridExtra")
library("scales")
library("limma")
library("edgeR")

# read the grouped protein summary file
MQ_raw <- read_tsv("KUR1502_data-export.txt")

# separate accessions from the data
accession <- MQ_raw$Accession

# get MS1 quantities
intensities <- MQ_raw$Intensity
ibaqs <- MQ_raw$iBAQ

# get the reporter ion intensities
MQ_tmt <- MQ_raw %>% select(-Accession, -Intensity, -iBAQ)

head(MQ_tmt)
nrow(MQ_tmt)

counts <- 1:nrow(MQ_tmt) # create vector of appropriate length
for(i in 1:nrow(MQ_tmt)){
    # TRUE will be coerced to 1 for the summing
    counts[i] <- sum(MQ_tmt[i, ] == 20)
}
table(counts) # create the summary

# let's see what the starting data look like
color = c(rep("red", 3), rep("blue", 4))
boxplot(log10(MQ_tmt), col = color, notch = TRUE, main = "Starting MaxQuant data")

SL_Norm <- function(df, color = NULL, plot = TRUE) {
    # This makes each channel sum to the average grand total
        # df - data frame of TMT intensities
        # returns a new data frame with normalized values

    # compute scaling factors to make colsums match the average sum
    norm_facs <- mean(c(colSums(df))) / colSums(df)
    cat("SL Factors:\n", sprintf("%-5s -> %f\n", colnames(df), norm_facs))
    df_sl  <- sweep(df, 2, norm_facs, FUN = "*")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(df_sl), col = color, notch = TRUE, main = "SL Normalized data")
    }
    df_sl
}

# SL norm the tmt data
MQ_tmt_sl <- SL_Norm(MQ_tmt, color)

# compute column sums before and after normalization
print("Before:")
format(round(colSums(MQ_tmt), digits = 0), big.mark = ",")
print("After:")
format(round(colSums(MQ_tmt_sl), digits = 0), big.mark = ",")

# load data into DGEList object
group <- c(rep("media", 3), rep("exosome", 4))
y <- DGEList(counts = MQ_tmt, group = group, genes = accession)

# we can see what y looks like
#y
y$samples # this is shorter to view

# run the TMM normalization
y <- calcNormFactors(y)

# check what changed
y$samples

apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute grand total (library size) scalings
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors
    cat("Overall Factors (lib.size+TMM):\n", sprintf("%-5s -> %f\n",
                                                     colnames(y$counts), norm_facs))

    # compute the normalized data as a new data frame
    tmt_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(tmt_tmm) <- str_c(colnames(y$counts), "_tmm")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(tmt_tmm), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    tmt_tmm
}

# get the normalized data values
MQ_tmt_tmm <- apply_tmm_factors(y, color)

# check returned table
head(MQ_tmt_tmm)

# check column totals
print("After TMM:")
format(round(colSums(MQ_tmt_tmm), digits = 0), big.mark = ",")

# define variables for the columns in each condition
M <- 1:3
E <- 4:7

CV <- function(df) {
    # Computes CVs of data frame rows
        # df - data frame,
        # returns vector of CVs (%)
    ave <- rowMeans(df)    # compute averages
    sd <- apply(df, 1, sd) # compute standard deviations
    cv <- 100 * sd / ave   # compute CVs in percent (last thing gets returned)
}

labeled_boxplot <- function(df, ylim, title) {
    # Makes a box plot with the median value labeled
        # df - data frame with data to compute CVs of
        # ylim - upper limit for y-axis
        # title - plot title
    cv = CV(df)
    boxplot(cv, ylim = c(0, ylim), notch = TRUE, main = title)
    text(x = 0.65, y = boxplot.stats(cv)$stats[3],
         labels = round(boxplot.stats(cv)$stats[3], 1))
}

# compare CV distributions
par(mfrow = c(2, 2))
labeled_boxplot(MQ_tmt[M], ylim = 150, title = "Starting Media CVs")
labeled_boxplot(MQ_tmt[E], ylim = 150, title = "Starting Exosome CVs")
labeled_boxplot(MQ_tmt_tmm[M], ylim = 75, title = "Media CVs after TMM")
labeled_boxplot(MQ_tmt_tmm[E], ylim = 75, title = "Exosome CVs after TMM")
par(mfrow = c(1, 1))

# see how things cluster after we have normalized data
plotMDS(log2(MQ_tmt_tmm), col = c(rep("red", 3), rep("blue", 4)), main = "MaxQuant TMM")

# scatter plots within groups and betwen groups
pairs.panels(log10(MQ_tmt_tmm), lm = TRUE, main = "After TMM")

# we need to get dispersion estimates
y <- estimateDisp(y)
plotBCV(y, main = "Dispersion trends")

collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate <- cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                     labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# compute the exact test models, p-values, FC, etc.
et <- exactTest(y, pair = c("media", "exosome"))

# make the results table
tt <- topTags(et, n = Inf, sort.by = "none")$table
med_exo <- collect_results(MQ_tmt_tmm, tt, M, "med", E, "exo")

pvalue_plots <- function(results, ylim, title) {
    # Makes p-value distribution plots
        # results - results data frame
        # ylim - ymax for expanded view
        # title - plot title
    p_plot <- ggplot(results, aes(PValue)) +
        geom_histogram(bins = 100, fill = "white", color = "black") +
        geom_hline(yintercept = mean(hist(results$PValue, breaks = 100,
                                     plot = FALSE)$counts[26:100]))

    # we will need an expanded plot
    p1 <- p_plot + ggtitle(str_c(title, " p-value distribution"))
    p2 <- p_plot + coord_cartesian(xlim = c(0, 1.0), ylim = c(0, ylim)) +
        ggtitle("p-values expanded")
    grid.arrange(p1, p2, nrow = 2) # from gridExtra package
}

# check the p-value distrubution
pvalue_plots(med_exo, 100, "Media vs Exosome-dosed")

# see how many up and down candidates (10% FDR)
summary(decideTests(et, p.value = 0.10))

# see which proteins have the smallest p-values
topTags(et)$table

# see how many candidates are in each category
med_exo %>% count(candidate)

log2FC_plots <- function(results, range, title) {
    # Makes faceted log2FC plots by candidate
        # results - results data frame
        # range - plus/minus log2 x-axis limits
        # title - plot title
    ggplot(results, aes(x = logFC, fill = candidate)) +
        geom_histogram(binwidth=0.1, color = "black") +
        facet_wrap(~candidate) +
        ggtitle(title) +
        coord_cartesian(xlim = c(-range, range))
}

# can look at log2FC distributions as a check
log2FC_plots(med_exo, 3, "LogFC by candidate for Media vs Exosome-dosed")

transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")

    df # return the data frame
}

MA_plots <- function(results, x, y, title, make_facet = TRUE) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # make_facet - flag to plot facet views
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    if (make_facet == TRUE) {
        ma_facet <- ggplot(temp, aes(x = A, y = M)) +
            geom_point(aes(color = candidate, shape = candidate)) +
            scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
            scale_x_continuous("log10 Ave_intensity") +
            ma_lines +
            facet_wrap(~ candidate) +
            ggtitle(str_c(title, " (separated)"))
    }

    # make the plots visible
    print(ma)
    if (make_facet == TRUE) {
         print(ma_facet)
    }
}

# MA plots of DE candidates
MA_plots(med_exo, "ave_med", "ave_exo", "Media versus exosome-dosed")

scatter_plots <- function(results, x, y, title, make_facet = TRUE) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # make_facet - flag to plot facet views
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    if (make_facet == TRUE) {
        scatter_facet <- ggplot(results, aes_string(x, y)) +
            geom_point(aes(color = candidate, shape = candidate)) +
            scatter_lines +
            facet_wrap(~ candidate) +
            ggtitle(str_c(title, " (separated)"))
    }

    # make the plots visible
    print(scatter)
    if (make_facet == TRUE) {
         print(scatter_facet)
    }
}

scatter_plots(med_exo, "ave_med", "ave_exo", "Media versus exosome-dosed")

volcano_plot <- function(results, x, y, title, ymax) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # title - plot title string
        # ymax - upper limit for y-axis

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        coord_cartesian(xlim = c(-5, 5), ylim = c(0, ymax)) +
        ggtitle(str_c(title, " Volcano Plot"))
}

# finally, a volcano plot
volcano_plot(med_exo, "ave_med", "ave_exo", "Media versus exosome-dosed", 50)

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_top_tags <- function(results, nleft, nright, top_tags) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top ipregulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}
# plot the top 20 up and 20 down proteins
set_plot_dimensions(7, 4)
plot_top_tags(med_exo, 3, 4, 20)
set_plot_dimensions(7, 7)

# column totals from the dilution series (25, 20, 15, 10, 5, 2.5) data
MQ <- c(252042061, 194468567, 147076787, 101203918, 49272033, 26071287)
PAW <- c(1996324081, 1562525113, 1207642244, 835353557, 400841992, 221591661)
dilution <- data.frame(PAW = PAW, MQ = MQ)

# from https://sejohnston.com/2012/08/09/a-quick-and-easy-function-to-plot-lm-results-in-r/
ggplotRegression <- function (fit, title) {
    require(ggplot2)
    ggplot(fit$model, aes_string(x = names(fit$model)[2], y = names(fit$model)[1])) +
        geom_point(size = 3) +
        stat_smooth(method = "lm", col = "red") +
        labs(title = title,
             subtitle = paste("Adj R2 = ",signif(summary(fit)$adj.r.squared, 5),
                              "Intercept =",signif(fit$coef[[1]],5 ),
                              " Slope =",signif(fit$coef[[2]], 5),
                              " P =",signif(summary(fit)$coef[2,4], 5)))
}

ggplotRegression(lm(MQ ~ PAW, data = dilution), "MQ reporter ions versus peak heights")

# get summ of reporter ions for each protein
totals  <- rowSums(MQ_tmt_tmm)

# add to data frame with MS1 abundances (drop zeros and take logs)
abundances <- data.frame(Total_TMT = totals, MS1_Intensity = intensities, iBAQ_Intensity = ibaqs)
abundances <- log10(abundances[abundances$MS1_Intensity > 0, ])

# make some scatter plots
pairs.panels(abundances, lm = TRUE,
             main = "Protein relative abundance measures")
ggplotRegression(lm(MS1_Intensity ~ Total_TMT, data = abundances),
                 "Correlation between MS1 and reporter ion intensities")

# save the testing results
write.table(med_exo, file = "KUR1502_MQ-results.txt", sep = "\t",
            row.names = FALSE, na = " ")

# log the session
sessionInfo()

# do the t-test on log transformed intensities to be safe
ttest_MQ <- log2(MQ_tmt_tmm)
# add average ratio columns (non-logged ratios), fold-change column, and row names
ttest_MQ$ave_med <- rowMeans(MQ_tmt_tmm[1:3])
ttest_MQ$ave_exo  <- rowMeans(MQ_tmt_tmm[4:7])
ttest_MQ$logFC <- log2(ttest_MQ$ave_exo / ttest_MQ$ave_med)
row.names(ttest_MQ) <- accession

# apply the basic two-sample t-test (we will pool variance)
t.result <- apply(ttest_MQ, 1, function(x) t.test(x[1:3], x[4:7], var.equal = TRUE))
# extract the p-value column from the t-test thingy
ttest_MQ$PValue <- unlist(lapply(t.result, function(x) x$p.value))
# do a Benjamini-Hochberg multiple testing correction
ttest_MQ$FDR <- p.adjust(ttest_MQ$PValue, method = "BH")

# add a DE candidate status column
ttest_MQ$candidate <- cut(ttest_MQ$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                          labels = c("high", "med", "low", "no"))

# count up, down and the rest (FDR less than 0.05)
all <- dim(ttest_MQ)[1]
up <- dim(ttest_MQ[(ttest_MQ$FDR <= 0.10) & (ttest_MQ$logFC > 0.0), ])[1]
down <- dim(ttest_MQ[(ttest_MQ$FDR <= 0.10) & (ttest_MQ$logFC <= 0.0), ])[1]
print("This is like decideTest in edgeR - 10% FDR cut:")
up
all - up - down
down
print("Candidate Counts:")
summary(ttest_MQ$candidate)

# what does the test p-value distribution look like?
ggplot(ttest_MQ, aes(PValue)) +
  geom_histogram(bins = 100, fill = "white", color = "black") +
  geom_hline(yintercept = mean(hist(ttest_MQ$PValue, breaks = 100, plot = FALSE)$counts[26:100])) +
  ggtitle("MQ data with t-test p-value distribution")

MA_plots(med_exo, "ave_med", "ave_exo", "MQ edgeR results", FALSE)
MA_plots(ttest_MQ, "ave_med", "ave_exo", "MQ t-test results")

scatter_plots(med_exo, "ave_med", "ave_exo", "MQ edgeR results", FALSE)
scatter_plots(ttest_MQ, "ave_med", "ave_exo", "MQ t-test results")

# compare volcano plots
volcano_plot(med_exo, "ave_med", "ave_exo", "EdgeR results", 4)
volcano_plot(ttest_MQ, "ave_med", "ave_exo", "t-test results", 4)


plot.trees <- function(bartlettdatafile){

bf <- read.table(bartlettdatafile,sep=',',header=T)

length 	<- bf$Distance
angle 	<- bf$Bearing
dbh 	<- bf$DBH
subplot <- bf$Subplot
species <- bf$Species
health	<- bf$Status
x	<- bf$x
y	<- bf$y

#scaled.dbh <- (dbh - min(dbh)) / (max(dbh) - min(dbh))
scaled.dbh <- dbh/10

angle <- (360 - angle) + 90

# convert from polar to cartesian coordinates
x <- length*cos(angle*pi/180)
y <- length*sin(angle*pi/180)

# corrections for subplots
# plot layout:
# NW--------NE
# |          |
# |     C    |
# |          |
# SW--------SE

# NE
x[subplot == 'NE' ] <- x[subplot == 'NE' ] + 25
y[subplot == 'NE' ] <- y[subplot == 'NE' ] + 25

# SE
x[subplot == 'SE' ] <- x[subplot == 'SE' ] + 25
y[subplot == 'SE' ] <- y[subplot == 'SE' ] - 25

# SW
x[subplot == 'SW' ] <- x[subplot == 'SW' ] - 25
y[subplot == 'SW' ] <- y[subplot == 'SW' ] - 25

# NW
x[subplot == 'NW' ] <- x[subplot == 'NW' ] - 25
y[subplot == 'NW' ] <- y[subplot == 'NW' ] + 25

# C -> no corrections needed

# create color vector
species.col <- as.matrix(species)

species.col[species.col == "FAGR"]	<- rgb(255,70,0,99,maxColorValue=255)
species.col[species.col == 'BEAL'] 	<- rgb(255,162,0,99,maxColorValue=255)
species.col[species.col == 'ACSA'] 	<- rgb(255,100,0,99,maxColorValue=255)
species.col[species.col == 'BEPA'] 	<- rgb(236,205,0,99,maxColorValue=255)
species.col[species.col == 'UNK'] 	<- rgb(99,99,99,99,maxColorValue=255)
species.col[species.col == 'TSCA'] 	<- rgb(29,208,0,99,maxColorValue=255)
species.col[species.col == 'ACRU'] 	<- rgb(255,0,0,99,maxColorValue=255)
species.col[species.col == 'ASCA'] 	<- rgb(0,200,100,99,maxColorValue=255)

# create shape vector
species.pch <- as.matrix(species)

species.pch[species == "FAGR"]	<-  20
species.pch[species == 'BEAL'] 	<-  15
species.pch[species == 'ACSA'] 	<-  8
species.pch[species == 'BEPA'] 	<-  15
species.pch[species == 'UNK'] 	<-  21
species.pch[species == 'TSCA'] 	<-  17
species.pch[species == 'ACRU'] 	<-  8
species.pch[species == 'ASCA'] 	<-  6

species.pch <- as.numeric(species.pch)

plot(x-1,y+30,type='n',xlab='m E-W from tower',ylab='m N from tower',lwd.tick=2,cex.lab=1.2,ylim=c(-1,50))
#symbols(x,y,scaled.dbh,bg=species.col,fg=NA,inches=T, lwd=1,xlab='m E-W from tower',ylab='m N-S from tower')
points(x-1,y+30,pch=species.pch,col=species.col,cex=scaled.dbh,lwd=2)
box(lwd=2)

# camera symbols and FOV lines
points(0,-1,pch=22,cex=2,lwd=2)
points(0,0,pch=25,cex=1,lwd=2)
lines(c(1,10),c(1,17.2),lwd=2)
lines(c(-1,-10),c(1,17.2),lwd=2)

legend('topleft',legend=unique(species),pch=c(20,15,8,15,21,17,8,6),col=unique(species.col),cex=0.8,pt.cex=1.2,bty='n',horiz=T)

#legend('topleft',legend=unique(subplot),pch=c(20,15,8,15,21,17,8,6),col=unique(subplot),cex=0.8,pt.cex=1.2,bty='n',horiz=T)

}
plot.trees('Bartlett_Tower_2009.csv')


################################### INTERPOLACAO VIA TRIANGULACAO ##################################

#' Triangulacao De \code{curvacolina}
#'
#' Funcao interna executada quando \code{metodo = "triangulacao"} em \code{interpolador}. O
#' argumento \code{tessfunc} permite controlar como o espaco projetado sera tesselado em triangulos.
#' Atualmente ha duas opcoes implementadas no pacote:ang
#'
#' \itemize{
#' \item{\code{\link{tessdelaunay}}}
#' \item{\code{\link{tessradial}}}
#' }
#'
#' A primeira executa a tesselacao pelo metodo de Delaunay atraves da funcao
#' \code{\link[geometry]{delaunayn}}. A segunda e uma versao alternativa quase igual a primeira, com
#' excessao dos triangulos definidos entre a ultima curva e o maximo. Pelo metodo de Delaunay e
#' possivel que acontecam platos, isto e, triangulos cujos tres vertices pertencem a mesma curva.
#' \code{tessradial} interfere apenas nessa regiao, forcando para que todos os triangulos entre a
#' ultima curva e o maximo tenham este ponto como um vertice, deixando os dois restantes como pontos
#' adjacentes na ultima curva.
#'
#' Esta funcao nao deve ser chamada pelo usuario diretamente na maioria dos casos
#'
#' @param colina objeto \code{curvacolina} retornado pelas funcoes de leitura
#' @param tessfunc funcao ou string com nome da funcao pela qual executar a tesselacao do espaco.
#'     Ver Detalhes
#' @param ... nao possui funcao, so existe para compatibilizacao com a chamada generica de
#'     \code{\link{interpolador}}
#'
#' @return objeto da classe \code{triangulacao} contendo a tesselacao da curva colina
#'
#' @export

triangulacao <- function(colina, tessfunc = tessdelaunay, ...) {
    hl <- pot <- NULL

    if(is.character(tessfunc)) tessfunc <- as.name(tessfunc)
    tri <- eval(as.call(list(tessfunc, colina)))

    new_triangulacao(tri, colina)
}

new_triangulacao <- function(tri, colina) {

    obj <- list(triangulos = tri, colina = colina)

    class(obj) <- c("triangulacao", "interpolador")
    attr(obj, "ntri") <- nrow(tri)

    return(obj)
}

#' @export

print.triangulacao <- function(x, ...) {
    cat("* Tesselacao ", "\n")
    cat("Numero de triangulos: ", attr(x, "ntri"), "\n")
    cat("-----\n")
    cat("* Curva colina \n")
    summary(x$colina)
}

# FUNCOES DE TRIANGULACAO --------------------------------------------------------------------------

#' Triangulacao Delauney
#'
#' Realiza triangulacao do espaco pelo metodo de Delauney via \code{geometry::delaunayn}
#'
#' @param colina objeto \code{curvacolina} contendo curva a tesselar
#'
#' @return matriz com tres colunas indicando, em cada linha, o indice em \code{colina$CC} dos pontos
#'     correspondentes aos vertices de cada triangulo gerado

tessdelaunay <- function(colina) {
    hl <- pot <- NULL
    geometry::delaunayn(colina$CC[, list(hl, pot)])
}

#' Triangulacao Radial
#'
#' Define os triangulos sempre usando o maximo como um dos vertices
#'
#' Este e um metodo de triangulacao especifico para uso em torno do maximo. Cada triangulo e
#' definido usando sempre o maximo como um dos vertices. Os dois vertices restantes sao pontos
#' adjacentes entre si na curva de rendimento imediatamente inferior ao maximo, ou seja, o espaco
#' entre ultima curva e ponto maximo e fatiado em triangulos com arestas radiais, para todos os
#' pontos da ultima curva.
#'
#' @param colina um data.frame ou data.table contendo queda liquida, potencia e rendimento
#'
#' @return matriz de tres colunas indicando o indicie em \code{dat} dos pontos correspondentes aos
#'     vertices de cada triangulo. Cada linha corresponde a um triangulo
#'
#' @importFrom utils tail

tessradial <- function(colina) {

    rend <- NULL

    tri <- tessdelaunay(colina)

    # identifica triangulos da ultima curva de rend para dentro
    ultrends <- tail(attr(colina, "rends"), 2)
    innertri <- sapply(seq(ncol(tri)), function(i) colina$CC$rend[tri[, i]] %in% ultrends)
    innertri <- rowMeans(innertri) == 1
    tri <- tri[!innertri, ]

    dat <- copy(colina$CC)
    chl  <- dat[rend == ultrends[2]]$hl
    cpot <- dat[rend == ultrends[2]]$pot
    dat <- dat[rend == ultrends[1]]
    angord <- orderpoly(dat, chl, cpot)

    N1 <- nrow(dat)
    N2 <- nrow(colina$CC[!(rend %in% ultrends)])
    N3 <- nrow(colina$CC)

    out <- cbind(angord, c(angord[-1], angord[1])) + N2
    out <- cbind(out, N3)
    out <- rbind(tri, out)

    return(out)
}

# METODOS ------------------------------------------------------------------------------------------

#' @rdname getcolina

getcolina.triangulacao <- function(object) object$colina

#' Amostragem De Pontos Na Triangulacao
#'
#' Realiza interpolacao baricentrica de \code{pontos} nos triangulos da tesselacao
#'
#' @param object objeto da classe \code{triangulacao} retornado pela funcao homonima
#' @param pontos data.frame ou matriz contendo coordenadas \code{(hl, pot)} dos pontos onde
#'     interpolar
#' @param as.gradecolina booleano -- se \code{FALSE} (padrao) retorna apenas o vetor de rendimentos
#'     interpolados nas coordenadas \code{pontos}; se \code{TRUE} um objeto \code{gradecolina}. Veja
#'     \code{\link{gradecolina}}
#' @param ... existe somente para consistencia de metodos. Nao possui utilidade
#'
#' @return se \code{as.gradecolina = FALSE}, vetor de rendimentos interpolados, do contrario um
#'     objeto \code{\link{gradecolina}}
#'
#' @export

predict.triangulacao <- function(object, pontos, as.gradecolina = FALSE, ...) {

    pontos <- pontos[complete.cases(pontos), ]

    if(nrow(pontos) == 0) return(numeric(0))

    npontos <- nrow(pontos)
    pontos <- data.matrix(pontos)

    triangulos <- object$triangulos
    colina     <- data.matrix(object$colina$CC)

    barycoord <- geometry::tsearchn(colina[, c("hl", "pot")], triangulos, pontos)

    rends <- sapply(seq(npontos), function(i) {
        indtri <- barycoord$idx[i]
        vertices <- triangulos[indtri, ]
        rends  <- colina[vertices, "rend"]
        sum(barycoord$p[i, ] * rends)
    })

    if(as.gradecolina) {
        out <- new_gradecolina(pontos, rends, object)
    } else {
        out <- as.numeric(rends)
    }

    return(out)
}


library(rbenchmark)
library(slam)
library(memuse)
library(coop)

reps <- 30
cols <- c("test", "replications", "elapsed", "relative")

generate <- function(m, n, size)
{
  x <- matrix(0, m, n)
  x[sample(m*n, size=size)] <- 100
  x
}

m <- 2000
n <- 2000

### Very sparse matrix --- .1% dense
cat("Very sparse (.1% dense):\n")
size <- .001*m*n

dense <- generate(m, n, size)
sparse <- as.simple_triplet_matrix(dense)

memuse(dense)
memuse(sparse)

benchmark(cosine(dense), cosine(sparse), as.matrix(sparse), columns=cols, replications=reps)
cat("\n\n")

### Fairly sparse matrix - 5% dense
cat("Fairly sparse (1% dense):\n")
size <- .01*m*n

dense <- generate(m, n, size)
sparse <- as.simple_triplet_matrix(dense)

memuse(dense)
memuse(sparse)

benchmark(cosine(dense), cosine(sparse), as.matrix(sparse), columns=cols, replications=reps)


#' bootstrap.face
#'
#' Apply the bootstrap test for testing a quadratic polynomial covariance
#'
#' @param data  "data frame with three arguments:
#'                  (1) "argvals": observation times;
#'                  (2) "subj": subject indices;
#'                  (3) "y": values of observations;
#'  Note that: we only handle complete data, so missing values are not allowed at this moment
#' @param nbs number of bootstrap samples, default = 1000
#' @param argvals.new  "argvals.new" if we want the estimated covariance function at "argvals.new"; if NULL,
#' then 100 equidistant points in the range of "argvals" in "data"
#' @param semi.iter indicator whether to use semi_iterative for bootstrap
#' @param tune.bs indicator whether to use tunning for bootstrap
#' @param center   "center" means if we want to compute population mean
#' @param knots   number of interior knots for B-spline basis functions to be used;
#' @param p the degrees of B-splines; defaults to 3.
#' @param m the order of differencing penalty; defaults to 2.
#' @param lambda  the value of the smoothing parameter for covariance smoothing; defaults to NULL.
#' @param lambda_mean the value of the smoothing parameter for mean smoothing; defaults to NULL.
#' @param search.length the number of equidistant (log scale) smoothing parameters to search; defaults to 14.
#' @param upper,lower bounds for log smoothing parameter for first step of estimation; defaults are -3 and 10, respectively.
#' @param pve Defaults 0.99. To select the number of eigenvalues by percentage of variance.
#'
#'
#' @import nlme
#' @return an object "bootstrap.face" contain:
#'  fit.alt: Alternative model fit (functional principal components analysis)
#'  fit.null: Null model fit (linear random effects)
#'  C.alt: Covariance matrix under alternative model
#'  C.null: Covariance matrix under null model
#'  tn: Test statistic
#'  p: p-value for test statistic based on the bs.approx
#'  bs.approx: List of values from the null distribution of Tn
#'
#' @references modified from face.sparse.inner from face package
#' and bootstrap.test.R written by Stephanie
bootstrap.face <- function(data, nbs = 1000, argvals.new = NULL,
                          trunc.eig = 1,
                          semi.iter = F, center.bs = F,
                          center = TRUE,
                           knots = 7, knots.option = "equally-spaced",
                           p = 3, m = 2, lambda = NULL, lambda_mean = NULL,
                           search.length = 14,
                           lower = -3, upper = 10,
                           pve = 0.99, off_diag = F, gam.mgcv = T, no.pen = F, dense.grid = 8e5) {
  #########################
  #### step 0: read in data
  #########################
  check.data(data)
  nb <- knots + p

  y <- data$y
  t <- data$argvals
  subj <- data$subj
  tnew <- argvals.new
  if (is.null(tnew)) tnew <- seq(min(t), max(t), length = 100)

  fit_mean <- NULL

  knots.initial <- knots
  #########################
  #### step 1: Test statistics
  #########################

  ###### a. Initialize C, X, Q
  r <- y
  if (center) {
    if (gam.mgcv) {
      fit_mean <- mgcv::gam(as.vector(y) ~ s(t, k = nb))
    } else {
      fit_mean <- pspline(data, argvals.new = tnew, knots = knots.initial, lambda = lambda_mean)
    }
    r <- y - fit_mean$fitted.values
  }

  raw <- raw.construct(data.frame("argvals" = t, "subj" = subj, "y" = as.vector(r)))
  C <- raw$C  # C
  st <- raw$st
  N2 <- raw$N2
  n0 <- raw$n0
  # indicator where ti = tj
  delta <- Matrix((st[, 1] == st[, 2]) * 1) # sparse
  delta <- c(as.matrix(delta))

  knots <- construct.knots(t, knots, knots.option, p)
  ## construct design & penalty on column dimension
  List <- pspline.setting(st[, 1], knots = knots, p, m, type = "simple", knots.option = knots.option)
  B1 <- List$B
  B1 <- Matrix(B1)
  DtD <- List$P
  ## construct design on row dimension
  B2 <- spline.des(knots = knots, x = st[, 2], ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  c <- dim(B1)[2]
  c2 <- c * (c + 1) / 2
  ## combine tensor product design
  B <- Matrix(t(KhatriRao(Matrix(t(B2)), Matrix(t(B1)))))
  G <- Matrix(duplication.matrix(c))
  ### double the weight for off-diagonal
  # v_idx <- which(delta == 0)
  # B[v_idx, ] <- sqrt(2) * B[v_idx, ]
  if (off_diag) {
    B <- B * (sqrt(2) * (1 - delta) + delta)
    C <- C * (sqrt(2) * (1 - delta) + delta)
  }

  # BtWB <- matrix(0, nrow = c^2, ncol = c^2)
  # Wdelta <- c()
  # WC <- c()
  # for (i in 1:n0) {
  #   # select combos for object i
  #   seq <- (sum(N2[1:i]) - N2[i] + 1):(sum(N2[1:i]))
  #   B3 <- Matrix(matrix(B[seq, ], nrow = length(seq)))
  #   BtWB <- BtWB + crossprod(B3, B3)
  #   Wdelta <- c(Wdelta, as.matrix(delta[seq]))
  #   WC <- c(WC, as.matrix(C[seq]))
  # }
  BtB <- crossprod(B)
  BG <- B %*% G # sparse

  GtBtBG <- crossprod(G, BtB %*% G)
  detde <- crossprod(delta) # detWde = sum(delta)
  GtBtdelta <- crossprod(BG, delta)
  XtX <- rbind(cbind(GtBtBG, GtBtdelta), cbind(t(GtBtdelta), detde))
  ## design X
  X <- cbind(BG, delta)
  #XtX <- crossprod(X)
  ## penalty
  P <- crossprod(G, Matrix(suppressMessages(kronecker(diag(c), DtD)))) %*% G
  Q <- bdiag(P, 0)

  ###### b. Pre-calculate s, F, B^*, Li, g, f, G (2 eigens)
  eSig <- eigen(XtX, symmetric = TRUE)
  V <- eSig$vectors
  E <- eSig$values
  E <- E + 0.000001 * max(E)
  Sigi_sqrt <- matrix.multiply(V, 1 / sqrt(E)) %*% t(V)

  tUQU <- crossprod(Sigi_sqrt, (Q %*% Sigi_sqrt))
  Esig <- eigen(tUQU, symmetric = TRUE)
  # s, f, F(m_F here)
  U <- Esig$vectors
  s <- Esig$values
  A0 <- Sigi_sqrt %*% U
  m_F <- as.matrix(X %*% A0)

  m_FtF <- crossprod(m_F) # FTF
  f <- crossprod(m_F, C) # f=FTC

  c2 <- c2 + 1
  g <- rep(0, c2)
  G1 <- matrix(0, c2, c2)
  mat_list <- list()
  # G(G1 here), g, Li
  for (i in 1:n0) {
    seq <- (sum(N2[1:i]) - N2[i] + 1):(sum(N2[1:i]))
    Fi <- matrix(m_F[seq, ], nrow = length(seq))
    Li <- crossprod(Fi)#Li <- FitFi

    fi <- crossprod(Fi, C[seq]) # t(Fi)Ci

    g <- g + fi * fi
    G1 <- G1 + Li * (fi %*% t(f))

    LList <- list()
    LList[[1]] <- Li
    #LList[[2]] <- Li
    mat_list[[i]] <- LList
  }
  # B^*
  st.construct <- function(tnew) {
    m1 <- length(tnew)
    if (m1 > 1) {
      st <- cbind(vech(kronecker(tnew, t(rep(1, m1)))),
                  vech(kronecker(rep(1, m1), t(tnew))))
    } else if (m1 == 1) {
      st <- rbind(st, c(tnew, tnew))
    }
    st
  }
  #stnew <- st.construct(tnew)
  #Bnew1 <- spline.des(knots = knots, x = stnew[, 1], ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  #Bnew2 <- spline.des(knots = knots, x = stnew[, 2], ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  #Bstar <- Matrix(t(KhatriRao(Matrix(t(Bnew2)), Matrix(t(Bnew1)))))

  #Xstar <- Bstar %*% G
  #delta_star <- which(stnew[, 1] != stnew[, 2])
  #Xstar[delta_star, ] <- sqrt(2) * Xstar[delta_star, ]
  dense.t <- seq(min(tnew), max(tnew), length.out = dense.grid)
  Xstar <- spline.des(knots = knots, x = dense.t, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  Xstar <- crossprod(Xstar) / dense.grid
  Eigen1 <- eigen(Xstar)
  Xstar.half <- Eigen1$vectors %*% diag(sqrt(Eigen1$values)) %*% t(Eigen1$vectors)
  Xstar.invhalf <- Eigen1$vectors %*% diag(1 / sqrt(Eigen1$values)) %*% t(Eigen1$vectors)

  Bnew <- spline.des(knots = knots, x = tnew, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design

  ###### c. Null estimate Ctilde0, f0 (2 eigens)
  fitNull <- function(data) {
     try(nlme::lme(y ~ 1, random = list(subj = pdSymm(~ 1 + argvals)),
          data = data), silent = T)
  }
  fit.null <- fitNull(data.frame("argvals" = t, "subj" = subj, "y" = as.vector(r)))
  if ("try-error" %in% class(fit.null)) {# issue with null fit
    stop(fit.null)
  }
  calc.R0 <- function(fit.null, times) {
    var.mat <- VarCorr(fit.null)
    sigsq0 <- as.numeric(var.mat[1, 1])
    sigsq1 <- as.numeric(var.mat[2, 1])
    cov01 <- as.numeric(var.mat[2, 3]) * sqrt(sigsq0 * sigsq1) # corr->cov
    Rbar0 <- sigsq0 + cov01 * (times[, 1] + times[, 2]) + sigsq1 * (times[, 1] * times[, 2])
    if (off_diag) {
      Rbar0 <- Rbar0 * (sqrt(2) * (1 - delta) + delta)
    }
    list(Rbar0 = Rbar0, coef.null = c(sigsq0, cov01, sigsq1))
  }

  Rbar0.fit <- calc.R0(fit.null, st)
  C0 <- Rbar0.fit$Rbar0

  ###### d. tunning(s, F, F^*, Li, g, f, G) to get lambda^*
  Lambda <- seq(lower, upper, length = search.length)
  Gcv <- 0 * Lambda
  gcv <- function(x) {
    lambda <- exp(x)
    d <- 1 / (1 + lambda * s)
    f_d <- f * d
    cv0 <- -2 * sum(f_d * f)
    cv1 <- sum(f_d * (m_FtF %*% f_d))
    cv2 <- 2 * sum(d * g)
    cv3 <- -4 * sum(d * (G1 %*% d))
    cv4 <- sum(unlist(sapply(mat_list, function(x) {
      a <- x[[1]] %*% f_d
      2 * sum(a * a * d)
    })))
    cv <- cv0 + cv1 + cv2 + cv3 + cv4
    return(cv)
  }
  if (is.null(lambda)) {
    Lambda <- seq(lower, upper, length = search.length) # construct lambda grid
    Length <- length(Lambda)
    Gcv <- rep(0, Length)
    for (i in 1:Length) {
      Gcv[i] <- gcv(Lambda[i])
    }
    i0 <- which.min(Gcv)
    lambda <- exp(Lambda[i0]) # lambda^*
  }

  ###### e. calculate estimated covariance function and test statistics
  Xxstar <- crossprod(Bnew)
  m_est_sigma <- (t(A0[c2, ]) * t(1 / (1 + lambda * s))) %*% t(m_F)
  sigsq <- m_est_sigma %*% C
  if (sigsq <= 0.000001) {
    # warning("error variance cannot be non-positive, reset to 1e-6!")
    sigsq <- 0.000001
  }
  if (no.pen || lambda == 0) {
    m_est <- A0[-c2, ] %*% t(m_F)
  } else {
    m_est <- matrix.multiply(A0[-c2, ], 1 / (1 + lambda * s)) %*% t(m_F)
  }

  trun_mat <- function(C) {
    alpha <- m_est %*% C
    Theta <- G %*% alpha
    Theta <- matrix(Theta, c, c)
    # sigma2 <- alpha[c2]
    # if (sigma2 <= 0.000001) {
    #   # warning("error variance cannot be non-positive, reset to 1e-6!")
    #   sigma2 <- 0.000001
    # }
    if (trunc.eig != 0) {
      # make sure Theta positive definite(2 eigens)
      Eigen <- eigen(Theta, symmetric = TRUE)
      Eigen$values[Eigen$values < 0] <- 0
      npc <- sum(Eigen$values > 0) # which.max(cumsum(Eigen$values)/sum(Eigen$values)>pve)[1]
      if (npc > 1) {
        pc <- Bnew %*% Eigen$vectors[, 1:npc]
        C <- tcrossprod(matrix.multiply(pc, Eigen$values[1:npc]), pc)
      }
      if (npc == 1) {
        C <- Eigen$values[1] * tcrossprod(Bnew %*% Eigen$vectors[, 1])
      }
    } else {
       C <- as.matrix(tcrossprod(Bnew %*% Matrix(Theta), Bnew))
    }
    list(C = C, Theta = Theta)
  }

  trunc.mat.inner <- function(Theta, trunc.eig = 1) {
  if (trunc.eig == 1) {
    eigen.fit <- eigen(Theta, symmetric = T)
    efuncs <- eigen.fit$vectors
  } else if (trunc.eig == 2) {
    Theta <- as.matrix(Xstar.half %*% Matrix(Theta) %*% Xstar.half)
    eigen.fit <- eigen(Theta, symmetric = T)
    efuncs <- Xstar.invhalf %*% eigen.fit$vectors
  }
  evals <- as.numeric(eigen.fit$values)
  evals[evals < 1e-5] <- 0
  return(matrix.multiply(efuncs, evals) %*% t(efuncs))
}

  # sigsq <- l_mat$sigma2
  C.alt <- trun_mat(C)
  C.null <- trun_mat(C0)

  if (trunc.eig == 0) {
    Tn <- C.alt$Theta - C.null$Theta
  } else {
    Theta.alt <- trunc.mat.inner(C.alt$Theta, trunc.eig)
    Theta.null <- trunc.mat.inner(C.null$Theta, trunc.eig)
    Tn <- Theta.alt - Theta.null
  }

  Tn <- Tn %*% Xstar
  Tn <- sqrt(sum(Tn * t(Tn)))

  #########################
  #### step 2: Bootstrap
  #########################

  raw.C <- function(data) {
    y <- data$y
    subj <- data$subj
    subj_unique <- unique(subj)
    n <- length(subj_unique)
    C <- c()
    for (i in 1:n) {
      r1 <- y[subj == subj_unique[i]]
      m1 <- length(r1)
      if (m1 > 1) {
        C <- c(C, vech(tcrossprod(r1)))
      } ## for if(m1>1)
      if (m1 == 1) {
        C <- c(C, r1^2)
      }
    } ## for i
    if (off_diag) {
      C <- C * (sqrt(2) * (1 - delta) + delta)
    }
    C
  }

  bs.stats <- c()
  bs.success <- 0
  if (center.bs) {
      mean.bs <- fit_mean$fitted.values
      this.bs <- data
  } else {
      mean.bs <- 0
  }

  if (semi.iter) {
    C0.bs <- matrix(NA, nrow = length(C), ncol = 0)
    C.bs  <- C0.bs
    y.bs <- resample(data, mean.bs, Rbar0.fit$coef.null, sigsq, L = nbs)

    while (bs.success < nbs) { #(0.15s)

      ###### a. generate Y_ij^(l) (0.01s)## fit_mean$fitted.values
      s_iterator <- bs.success + 1
      if (ncol(y.bs) < s_iterator) {
        y.bs <- cbind(y.bs, resample(data, mean.bs, Rbar0.fit$coef.null, sigsq, L = 5))
      }
      y <- y.bs[, s_iterator]

      ###### b. center Y_ij^(l) (0.01s)
      r <- y
      if (center && center.bs) {
        this.bs$y <- r
        if (gam.mgcv) {
          fit_mean.bs <- mgcv::gam(as.vector(y) ~ s(t, k = nb))
        } else {
          fit_mean.bs <- pspline(this.bs, argvals.new = tnew, knots = knots.initial, lambda = lambda_mean)
        }
        r <- y - fit_mean.bs$fitted.values
      }
      data.demean.bs <- data.frame(
        "argvals" = t,
        "subj" = subj, "y" = as.vector(r)
      )

      ###### c. Initialize C0^(l) (0.08s)
      fit.null.bs <- fitNull(data.demean.bs) # null fit
      if ("try-error" %in% class(fit.null.bs)) { # issue with null fit
        y.bs <- y.bs[, -s_iterator]
        next # if problem
      }
      Rbar0.fit.bs <- calc.R0(fit.null.bs, st)
      # C0.bs <- cbind(C0.bs, Rbar0.fit.bs$Rbar0)

      ###### d. Initialize C^(l) (0.05s)
      C.bs <- cbind(C.bs, Rbar0.fit.bs$Rbar0 - raw.C(data.demean.bs))
      bs.success <- bs.success + 1

    }
# ptm <- proc.time()
    # Compute delta.bs (0.17 s)
    delta.bs <- m_est %*% Matrix(C.bs)
# print(proc.time() - ptm)
    # compute bs statistics (0 s)
    bs.stats <- (Xstar %*% delta.bs) ^ 2
    bs.stats <- sqrt(colSums(bs.stats))

  } else {
    while (bs.success < nbs) { #(0.6s)
#ptm <- proc.time()
      ###### a. generate Y_ij^(l) (0.01s)
      y <- c(resample(data, mean.bs, Rbar0.fit$coef.null, sigsq))

      ###### b. center Y_ij^(l) (0.01s)
      r <- y
      if (center && center.bs) {
        this.bs$y <- r
        if (gam.mgcv) {
          fit_mean.bs <- mgcv::gam(as.vector(y) ~ s(t, k = nb))
        } else {
          fit_mean.bs <- pspline(this.bs, argvals.new = tnew, knots = knots.initial, lambda = lambda_mean)
        }
        r <- y - fit_mean.bs$fitted.values
      }
      data.demean.bs <- data.frame(
        "argvals" = t,
        "subj" = subj, "y" = as.vector(r)
      )

      ###### c. Initialize C0^(l) (0.04s)
      fit.null.bs <- fitNull(data.demean.bs) # null fit
      if ("try-error" %in% class(fit.null.bs)) { # issue with null fit
        next # if problem
      }

      C0.bs <- calc.R0(fit.null.bs, st)$Rbar0

      ###### d. Initialize C^(l) (0.00s)
      C.bs <- raw.C(data.demean.bs) #(0.00s)

      ###### e. calculate estimated covariance function and test statistics
      # (0.00 s)

      if (trunc.eig == 0) {
        Tn.bs <- matrix(G %*% (m_est %*% (C.bs - C0.bs)), c)
      } else {
        Theta.alt <- trunc.mat.inner(matrix(G %*% (m_est %*% C.bs), c), trunc.eig)
        Theta.null <- trunc.mat.inner(matrix(G %*% (m_est %*% C0.bs), c), trunc.eig)
        Tn.bs <- Theta.alt - Theta.null
      }
      Tn.bs <- Tn.bs %*% Xstar
      Tn.bs <- sqrt(sum(Tn.bs * t(Tn.bs)))

      bs.stats <- c(bs.stats, Tn.bs) # save bs stats
      bs.success <- bs.success + 1
#print(proc.time() - ptm)

    }
  }

  #########################
  #### step 3: P-values
  #########################
  p.bs <- function(stat, bs.stat) {
    p <- mean(stat <= bs.stat)
    list(p = p, mean = mean(bs.stat), var = var(bs.stat))
  }
  Tn.stats <- p.bs(Tn, unlist(bs.stats))

  list(
    mu = fit_mean$fitted.values,
    C.alt = C.alt$C,
    C.null = C.null$C,
    sigma2 = sigsq,
    Tn = Tn, p = Tn.stats$p, p.var = Tn.stats$var,
    bs.approx = bs.stats
  )
}

############################
# Written by: Stephanie Chen (stchen3@ncsu.edu)
# Purpose: Generate bootstrap resamples
# Updated: Aug 4, 2018
# Modified on July 30, 2021

resample <- function(data, mu, coef.null, sigsq, L = 1) {
  nsubj <- length(unique(data$subj))
  cov.mat <- matrix(c(coef.null[1], coef.null[2], coef.null[2], coef.null[3]), nrow = 2)
  b.mat <- matrix(rnorm(2 * nsubj * L), ncol = 2) %*% chol(cov.mat) # random effects

  # r.slope & r.int by subject
  par.random <- sapply(seq_len(L), function(i) {
        s_offset <- (i-1) * nsubj
        sapply(seq_len(nsubj), function(x) {
            b.mat[s_offset + x, 1] + b.mat[s_offset + x, 2] * subset(data, subj == x)$argvals
        })
    })

  if (is.list(par.random)) { # if a list
    par.random <- unlist(par.random)
  }
  # mean.null + null.par r.int & r.slope*t + alt.par residual
  matrix(mu + par.random + rnorm(nrow(data) * L, sd = sqrt(sigsq)), ncol = L)
}

# resample(data, 0, c(1,0,1), 2, L = 2)
# sapply(1:2, function(i) {
#         sapply(6:8, function(x) {
#             i*x
#         })
#     })


blue.red <- function (n)
  {
    n = n-2
    if ((n <- as.integer(n[1])) > 0) {
      even.n <- n%%2 == 0
      green = 2/6
      red = 0
      blue = 4/6
      alpha = 1.6
      k <- n%/%2
      l1 <- k + 1 - even.n
      l2 <- n - k + even.n
      c( if (l1 > 0) {
            hsv( h = blue,
                 s = seq(1, ifelse(even.n, 1/k, 0), length = l1),
                 v = 1)
          },
         if (l2 > 1) {
           hsv( h = red,
                s = seq(0, 1, length = l2),
                v = 1,
                alpha=alpha)
         }
       )
    }
  }


cubes <- numeric(5)
for(i in seq_along(cubes))
{
   cubes[i] <- cube(elements[i])
}


i <- 0
repeat
{
   i <- i + 1
   print(i)
   if(i %% 6 == 0) break
}


context("Testing  GeoSituation")

#create 4 Nodes

#  GeoSituation

context("\tTest 01: can objects be added correctly?")
test_that("Test for adding objects to geoSituation", {
  geo<-new("GeoSituation")
	geo<-add(geo,new("Node"))
  	expect_true(length(geo$nodes) == 1)
	geo<-add(geo,new("Node"))
  	expect_true(length(geo$nodes) == 2)
	geo<-add(geo,new("Warehouse"))
  	expect_true(length(geo$nodes) == 2)
  	expect_true(length(geo$warehouses) == 1)
	geo<-add(geo,new("Warehouse"))
  	expect_true(length(geo$nodes) == 2)
  	expect_true(length(geo$warehouses) == 2)
	geo<-add(geo,new("Customer"))
  	expect_true(length(geo$nodes) == 2)
  	expect_true(length(geo$warehouses) == 2)
  	expect_true(length(geo$customers) == 1)
	geo<-add(geo,new("Customer"))
  	expect_true(length(geo$nodes) == 2)
  	expect_true(length(geo$warehouses) == 2)
  	expect_true(length(geo$customers) == 2)

})

context("\tTest 02: can the distance matrix be created correctly?")
test_that("Test for calculation of distances", {

  #szenario taken from Tutorium #2 ws 13/14 aufg. 2
  geo<-new("GeoSituation")
  geo<-add(geo,new("Warehouse", id="L1", x=25,   y=70,   supply = 350   ))
  geo<-add(geo,new("Warehouse", id="L2", x=150,  y=115,  supply = 450   ))
  geo<-add(geo,new("Warehouse", id="L3", x=80,   y=140,  supply = 300   ))
  geo<-add(geo,new("Warehouse", id="L4", x=160,  y=10,   supply = 120   ))

  geo<-add(geo,new("Customer",  id="K1", x=15,   y=130,  demand = 150   ))
  geo<-add(geo,new("Customer",  id="K2", x=60,   y=80,   demand = 300   ))
  geo<-add(geo,new("Customer",  id="K3", x=175,  y=140,  demand = 180   ))
  geo<-add(geo,new("Customer",  id="K4", x=50,   y=100,  demand = 120   ))
  geo<-add(geo,new("Customer",  id="K5", x=30,   y=40,   demand = 100   ))
  geo<-add(geo,new("Customer",  id="K6", x=140,  y=80,   demand = 40    ))
  geo<-add(geo,new("Customer",  id="K7", x=100,  y=15,   demand = 80    ))
  geo<-add(geo,new("Customer",  id="K8", x=155,  y=55,   demand = 120   ))
  geo<-add(geo,new("Customer",  id="K9", x=125,  y=145,  demand = 130   ))

  m<-getDistanceMatrix(geo,"Warehouse", "Customer", digits=0)

  expect_true(length(geo$warehouses) ==4)
  expect_true(length(geo$customers) ==9)

  expect_true(nrow(m) ==4)
  expect_true(ncol(m) ==9)

  expect_true(m[1,1] == 61)
  expect_true(m[1,2] == 36)
  expect_true(m[3,4] == 50)
  expect_true(m[4,6] == 73)
  expect_true(m[2,4] + m[3,5] + m[4,2] == 335)

})
context("done.")
context("--------------------------------------------------")

context("\tTest 03: can the distance matrix be created correctly with a cost factor?")
test_that("Test for calculation of distances with calc", {

  #szenario taken from Tutorium #2 ws 13/14 aufg. 2
  geo<-new("GeoSituation")
  geo<-add(geo,new("Warehouse", id="L1", x=25,   y=70,   supply = 350   ))
  geo<-add(geo,new("Warehouse", id="L2", x=150,  y=115,  supply = 450   ))
  geo<-add(geo,new("Warehouse", id="L3", x=80,   y=140,  supply = 300   ))
  geo<-add(geo,new("Warehouse", id="L4", x=160,  y=10,   supply = 120   ))

  geo<-add(geo,new("Customer",  id="K1", x=15,   y=130,  demand = 150   ))
  geo<-add(geo,new("Customer",  id="K2", x=60,   y=80,   demand = 300   ))
  geo<-add(geo,new("Customer",  id="K3", x=175,  y=140,  demand = 180   ))
  geo<-add(geo,new("Customer",  id="K4", x=50,   y=100,  demand = 120   ))
  geo<-add(geo,new("Customer",  id="K5", x=30,   y=40,   demand = 100   ))
  geo<-add(geo,new("Customer",  id="K6", x=140,  y=80,   demand = 40    ))
  geo<-add(geo,new("Customer",  id="K7", x=100,  y=15,   demand = 80    ))
  geo<-add(geo,new("Customer",  id="K8", x=155,  y=55,   demand = 120   ))
  geo<-add(geo,new("Customer",  id="K9", x=125,  y=145,  demand = 130   ))

  m<-getDistanceMatrix(geo,"Warehouse", "Customer", digits=0, costfactor=2)
  expect_true(length(geo$warehouses) ==4)
  expect_true(length(geo$customers) ==9)

  expect_true(nrow(m) ==4)
  expect_true(ncol(m) ==9)

  expect_true(m[1,1] == 122)
  expect_true(m[1,2] == 72)
  expect_true(m[3,4] == 100)
  expect_true(m[4,6] == 146)
  expect_true(m[2,4] + m[3,5] + m[4,2] == 335*2)

})
context("done.")
context("--------------------------------------------------")


#' bplot rolling average plotting function
#'
#' This function orders and bins a variable in to groups defined by a window
#' and step size then computes rolling averages for multipe variables across each bin.
#' @param t Table of data.
#' @param x Variable to be binned on x-axis.
#' @param y Vector of variables to plot on y-axis.
#' @param ys Scale the y-axis variables first. Defaults to 1.
#' @param ystep Division of steps printed on y-axis scale. Defaults to 0.2.
#' @param ylab Label for Y-axis. Defaults to blank.
#' @param axis3 Column of length variable to be plotted on 3rd axis. Defaults to "NA" (not shown).
#' @param w Window size (number of values per bin). Defaults to 400.
#' @param s Step size (number of values to move along for each bin). Defaults to 80.
#' @param f Function to apply to y values for each bin ("mean","median","sum"). Defaults to "mean".
#' @param scale Scale the x-axis ("linear"=linear spacing of points based on mean vaue of bin or "bins"=equal spacing between all bins). Defaults to "linear".
#' @param leg Postion of legend. Defaults to "topleft".
#' @param col Vector of colours to use in plots. Defaults to 1:100.
#' @param max,min Minimum and Maximum range of y-axis.
#' @param feature Name of features being binned. Defaults to "data points".
#' @keywords bin average plots.
#' @export
#' @examples
#' bplot()

bplot<-function(t,x,y,ys=1,ystep=0,ylab="",axis3="NA",w=400,s=80,f="mean",
                scale="linear",leg="topleft",col=1:100,max="default",min="default",feature="data points"){
  library(zoo) #for rollapply function

  t<-t[order(t[,x]),] #order x-axis
  l<-length(y) #number of lines to plot
  #remove NAs
  for(i in 1:l){
    t<-t[!is.na(t[,y[i]]),]
    #scale the y-axes
    if(ys!=1){
      t[,y[i]]<-t[,y[i]]*ys
    }
  }
  xb<-t[,x] #get binning column
  if(scale=="log"){ #log binninng values if requested
    xb<-log(xb)
    x<-paste0("log(",x,")")
  }
  xbins<-rollapply(xb, width=w, by=s,FUN="mean", align="left") #bin and mean
  ybins<-NULL
  boxlist<-NULL
  ##for y variables bin and calculate avg/boxes
  for(i in 1:l){
    yb<-t[,y[i]]
    if(f=="boxes"){
      box<-rollapply(yb, width=w, by=s,FUN=function(b){b}, align="left")
      bins<-rollapply(yb, width=w, by=s,FUN="median", align="left")
      box<-t(box)
      ybins<-cbind(ybins,bins)
      boxlist[[i]]<-box
    }
    else{
      bins<-rollapply(yb, width=w, by=s,FUN=f, align="left")
      ybins<-cbind(ybins,bins)
    }
  }
  #set yscale
  if(min=="default"){
    min<-min(ybins)
  }
  if(max=="default"){
    max<-max(ybins)
  }
  #plot boxplots
  if(f=="boxes"){
    for(i in 1:l){
      for(j in 1:dim(boxlist[[i]])[2]){
        min<-min(min,quantile(boxlist[[i]][,j],0.25))
        max<-max(max,quantile(boxlist[[i]][,j],0.75))
      }
    }
    par(mar=c(5,5,5,5))
    sc<-xbins
    xlim<-c(min(sc),max(sc))
    #plot equal spaces between boxes
    if(scale=="bins"){
      sc<-1:length(xbins)
      xlim<-c(1,length(xbins))
    }
    boxplot(boxlist[[1]],outline=F,col="forest green",staplelty=0,whisklty=0,boxcol="forest green",medlty=0,axes=F,
            ylab="",mar=20,ylim=c(min,max),names="",xlim=xlim,main=paste(length(xb),feature),xlab=x,at=sc,boxwex=0.001)
    lines(sc,ybins[,1],col="dark grey",lwd=2)
    #insert color pallete
    if(l>1){
      for(i in 2:l){
        boxplot(boxlist[[i]],add=T,outline=F,col=i,staplelty=0,whisklty=0,boxcol=i,medlty=0,axes=F,xlab="",
                ylab="",mar=20,ylim=c(min,max),names="",main="",at=sc,boxwex=0.001)
        lines(sc,ybins[,i],col="dark grey",lwd=2)
      }
    }
  }
  #if line plots
  else{
    par(mar=c(5,5,5,5))
    sc<-xbins
    #plot equal spacing between bins
    if(scale=="bins"){
      sc<-1:length(xbins)
    }
    #plot line 1
    plot(sc,ybins[,1],col=col[1],axes=F,ylab=ylab,type="l",xlab=x,
         main=paste(length(xb),feature),ylim=c(min,max),lwd=2)
    #plot grid
    grid(nx = NULL, ny = NULL, col = "grey", lty = 1,lwd = 1, equilogs = TRUE)
    #plot other lines
    if(l>1){
      for(i in 2:l){
        lines(sc,ybins[,i],col=col[i],lwd=2)
      }
    }
  }
  ##adjust axes
  if(ystep==0){
    axis(2)
  }
  else{
    axis(2,at=seq(0,max,ystep),labels=seq(0,max,ystep),las=1)
  }
  if(scale=="linear" | scale=="log"){
    axis(1,at=xbins,labels=format(round(xbins, 2), nsmall = 2),las=1)
  }
  else{
    axis(1,at=c(seq(1,length(xbins),(length(xbins)/10)),length(xbins)),labels=format(round(c(xbins[seq(1,length(xbins),(length(xbins)/10),)],xbins[length(xbins)]), 2), nsmall = 2),las=2)
  }
  if(axis3!="NA"){
    lbins<-rollapply(t[,axis3], width=w, by=s,FUN="mean", align="left")
    par(new=T)
    plot(sc,lbins,col="grey",axes=F,ylab="",type="l",lty=2,lwd=2,xlab="")
    axis(4)
    if(leg != "off"){
      legend(x=leg,legend=c(y,axis3),lty=1,lwd=2,col=c(col[1:l],"grey"),box.lwd=0,bty="n")
    }
    mtext(axis3,side=4,line=2)
  }
  else{
    if(leg != "off"){
      legend(x=leg,legend=c(y),lty=1,lwd=2,col=c(col),box.lwd=0,bty="n")}
  }
}


new core words

0if ( -- )                      \  'dup 0= if'
  branch on processor Z-flag, no stack action!

0until ( -- )                   \  'dup 0= until'
  loop back on processor Z-flag, no stack action! small loops only!
  loop until Z-flag is set (e.g. checked bit is 0)

1until ( -- )                   \  'dup 0 <> until'
  loop back on processor Z-flag, no stack action! small loops only!
  loop until Z-flag is cleared (e.g. checked bit is 1)

mtst0 ( mask adr -- )
  check adr with mask, leaves no flag on stack, to be used with
  '0if', '0until' and '1until'

m@ ( adr -- n )
  (fast) direct fetch from RAM, do not use if 'adr' is a literal,
  constant or variable

mc@ ( adr -- c )
  (fast) direct fetch from RAM, do not use if 'adr' is a literal,
  constant or variable

swap- ( n1 n2 -- n2-n1 )        \ 'swap -'
  small and fast

1024*/ ( u1 u2 -- u3 )
  scale operator, multiply u1 and u2 with 32-bit intermediate,
  then divide by 1024 with rounding
  for scaling of ADC raw data or fixed point constant computation
  e.g. 'pi *' -> '3217 1024*/'

u*/ ( u1 u2 u3 -- u' )
  multiply u1 and u2 with 32-bit intermediate,
  then divide by u3 w/o rounding

u2/ ( u -- u' )                 \  '1 rshift'
  unsigned divide by 2

8<< ( u -- u' )                 \  '8 lshift'
  shift left by 8

8>> ( u -- u' )                 \  '8 rshift'
  shift right by 8

pick ( x1..xu..xn u -- x1..xu..xn xu )
  copy u-th value to TOP

sqr ( uc -- u' )                \  'dup *'
  square of unsigned value in TOP, uc < 256

sqrt ( u -- uc' )
  square root of unsigned value in TOP w/o rounding

ticks>n ( top -- ticks top )    \  'ticks swap'
  pushes the system ticks to NEXT

ticks= ( ticks -- ms )          \  'ticks swap -'
  leaves the time [ms] from ticks in TOP to the actual system ticks

us ( u -- )
  delay u microseconds, !!streched by interrupt routines!!

forget ( "name" -- )
  forget all the words back to "name"

gcd ( u1 u2 -- gcd )             \ for benchmarks only
  greatest common divider

do .. i .. j .. leave .. loop
!! one 'leave' per loop ONLY !!
!! in nested loops 'leave' MUST NOT be placed before the inner 'do' !!


library(randomForest)
library(dplyr)
library(reshape2)
library(stats)
library(e1071)
library(h2o)
library(jsonlite)
library(ggplot2)

multiloss <- function(p, actual){
  p <- pmin(pmax(p, 1e-15), 1 - 1e-15)
  sum(sapply(unique(actual),function(item){sum(-log(p[actual==item,item]))})
  )/nrow(p)
}

accuracy <- function(p, actual){
  p <- pmin(pmax(rf.response, 1e-15), 1 - 1e-15)
  p <- sapply(max.col(p), function (x) {colnames(p)[x]})
  mean(p==actual)
}

setwd("~/MachineLearning/MachineLearning")
train.data <- readRDS("train_data2.rds")
test.data <- readRDS("test_data.rds")
images.data <- read.csv("img_data2.csv")
images.data <- images.data %>% mutate(listing_id = listing) %>% select(-listing)

images.data[is.na(images.data)] <- 0

train.images <- inner_join(images.data, select(train.data, Photo_Counts, price, listing_id, interest_level))
test.images <- inner_join(images.data, select(test.data, Photo_Counts, price, listing_id))

traindex <- sample(1:nrow(train.images), 0.8 * nrow(train.images), replace=FALSE)

training <- train.images[traindex, ]
testing <- train.images[-traindex, ]

r.Forest <- randomForest(interest_level ~ . -listing_id, training, ntree=1000)

predictors <- testing %>% select(-interest_level)
truth <- as.character(testing$interest_level)

rf.response <- predict(r.Forest, predictors, type='prob')

multiloss(rf.response, truth)
accuracy(rf.response, truth)

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

plot.data <- train.images %>% filter(Photo_Counts > 0)

#plot.data <- plot.data %>% mutate(mu_l = exp(mu_l / 256))

ggplot() + geom_freqpoly(aes(plot.data$mu_s, ..density..,
                             color=plot.data$interest_level), bins = 100) +
  xlab("Mean Saturation") + ylab("Density") +
  scale_color_discrete(name="Interest\nLevel",
                      breaks=c("high", "medium", "low"),
                      labels=c("High", "Medium", "Low"))

ggplot(plot.data, aes(x=mode_h * mu_s, y=mu_l, color=interest_level)) + geom_point() + geom_jitter()


subroutine delout(delsum,nadj,madj,x,y,ntot,npd,nerror)

# Put a summary of the Delaunay triangles with a vertex at point i,
# for i = 1, ..., npd, into the array delsum.  Do this in the original
# order of the points, not the order into which they have been
# bin-sorted.
# Called by master.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension delsum(npd,4)

do i = 1,npd {
        area = 0.   # Initialize area of polygon consisting of triangles
                    # with a vertex at point i.
        # Get the coordinates of the point and the number of
        # (real) triangles emanating from it.
        np = nadj(i,0)
	xi = x(i)
	yi = y(i)
        npt = np
        do k = 1,np {
                kp = k+1
                if(kp>np) kp = 1
                if(nadj(i,k)<=0|nadj(i,kp)<=0) npt = npt-1
        }

        # For each point in the adjacency list of point i, find its
        # successor, and the area of the triangle determined by these
        # three points.
        do j1 = 1,np {
                j = nadj(i,j1)
                if(j<=0) next
		xj = x(j)
		yj = y(j)
                call succ(k,i,j,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                if(k<=0) next
		xk = x(k)
		yk = y(k)
                call triar(xi,yi,xj,yj,xk,yk,tmp)
                # Downweight the area by 1/3, since each
                # triangle eventually appears 3 times over.
                area = area+tmp/3.
        }
	delsum(i,1) = xi
	delsum(i,2) = yi
	delsum(i,3) = npt
	delsum(i,4) = area
}

return
end


library(watershed)
library(raster)
library(sf)
library(ggplot2)
library(flume)

dem = raster("data/elevation/mara_dem_102022.tif")
thresh = 1e7
len = 10000
ma = delineate(dem, threshold = thresh, reach_len=len, outlet = c(1040958, -154588))
Tp = pixel_topology(ma)

## for plotting
dem_cr = crop(dem, ma)
dem_df = as.data.frame(rasterToPoints(dem_cr))
colnames(dem_df)[3] = "elev"
ma_v = vectorise_stream(ma[["stream"]], Tp=Tp)

discharge = readRDS("data/mara_sites_final.rds")
discharge = st_snap(discharge, ma_v, tolerance=100)
discharge$ca = catchment(ma, type = "points", y = st_coordinates(discharge))
discharge = discharge[discharge$ca > thresh,]

ggplot() + geom_raster(data=dem_df, aes(x = x, y = y, fill = elev)) +
	geom_sf(data = ma_v, aes(colour=reach_id)) + scico::scale_fill_scico(palette = "turku") +
	geom_sf(data = discharge, colour='red', size = 0.75)

ma_v$catchment = catchment(ma, type = 'reach', Tp = Tp)
ma_v = cbind(ma_v, hydraulic_geometry(discharge$ca, discharge$q, ma_v$catchment))
Tp_r = reach_topology(ma, Tp)
layout = st_coordinates(lwgeom::st_startpoint(ma_v))
ma_v$len = st_length(ma_v)
st_write(ma_v, "res/mara.gpkg", append = FALSE)

ma_v$Q = units::drop_units(ma_v$Q)
ma_v$z = units::drop_units(ma_v$z)
ma_v$w = units::drop_units(ma_v$w)
mara = river_network(Tp_r, discharge = ma_v$Q,
	area = (ma_v$z*ma_v$w), length = len,
	layout = layout)

	plot(mara, edge.arrow.size=0, vertex.size=2, vertex.label=NA)

saveRDS(mara, "res/mara_network.rds")


 DGELS Example Program Results

 Least squares solution
      1.5339     1.8707    -1.5241     0.0392

 Square root of the residual sum of squares
      2.22E-02


library(ggplot2)
h <- read.csv("house-sales.csv", stringsAsFactors = FALSE)

h$br <- as.numeric(h$br)
h$year <- as.numeric(h$year)
h$price <- as.numeric(h$price)

h$datesold <- as.Date(h$datesold, format = "%m-%d-%y")
h$street <- gsub("\\\\", "", h$street)

qplot(price, data=h, geom="histogram", binwidth = 1e4, xlim=c(0, 2e6))
qplot(price - round_any(price, 10000, floor), data=h, geom="histogram", binwidth=100)

qplot(city, data=h, geom="bar")

# Focus on SF --------------------------------------------
ad <- read.csv("addresses.csv")
sf <- merge(sf, ad, by = c("street", "city", "zip"))

sf <- subset(h, city %in% "San Francisco")
qplot(datesold, data=sf, geom="bar", binwidth=1)
qplot(datesold, data=sf, geom="bar", binwidth=7)
qplot(datesold, log10(price), data=sf, geom="boxplot", group=round(datesold))

qplot(long, lat, data = sf, size = I(0.1), ylim=c(37.7, 37.81), colour=price) + scale_colour_gradient(trans = "sqrt")

# addresses <- sf[, c("street", "city", "zip")]
# addresses$lat <- NA
# addresses$long <- NA
# addresses$accuracy <- NA
# addresses$status <- NA
#
# write.table(unique(addresses), "addresses.csv", sep=",", row=F)


library(keras)
library(caret)

use_condaenv("r-tensorflow")
source(here::here("kerasPrep.R"))

# model -----------------------------------
model <- keras_model_sequential()

model %>%
  layer_dense(units = 128, input_shape = ncol(x_train), activation = "relu") %>%
  layer_dense(units = 64, activation = "relu") %>%
  layer_dense(units = 32, activation = "relu") %>%
  layer_dense(units = 8, activation = "relu") %>%
  layer_dense(units = 4, activation = "relu") %>%
  layer_dense(units = 2, activation = "softmax")
summary(model)

opt <- optimizer_adam(lr = 0.001, beta_1 = 0.99, beta_2 = 0.999)

model %>% compile(
  optimizer = opt,
  loss = "binary_crossentropy",
  loss_weights = list(0.001),
  metrics = "accuracy"
)

model %>% fit(
  x_train,
  y_train,
  epochs = 50,
  batch_size = 8,
  shuffle = TRUE,
  validation_split = 0.2
)


library("rgl")

crossdot <- function(a, b, c) {
	return (c[1]*(a[2]*b[3]-a[3]*b[2]) + c[2]*(a[3]*b[1]-a[1]*b[3]) + c[3]*(a[1]*b[2]-a[2]*b[1]) )
}

cross <- function(a, b) {
	return (c( a[2]*b[3]-a[3]*b[2] , a[3]*b[1]-a[1]*b[3] , a[1]*b[2]-a[2]*b[1] ))
}

arrow3d <- function(start, end, cl) {
	x <- (cross(end-start, c(0,0,1))/10)
	lines3d(c(start[1], end[1]), c(start[2], end[2]), c(start[3], end[3]), col=cl, lwd=3)
	head <- start+(end-start)*0.8
	lines3d(c(end[1], head[1]+x[1]), c(end[2], head[2]+x[2]), c(end[3], head[3]+x[3]), col=cl, lwd=3)
	lines3d(c(end[1], head[1]-x[1]), c(end[2], head[2]-x[2]), c(end[3], head[3]-x[3]), col=cl, lwd=3)
	lines3d(c(head[1]-x[1], head[1]+x[1]), c(head[2]-x[2], head[2]+x[2]), c(head[3]-x[3], head[3]+x[3]), col=cl, lwd=3)
}

if (rerun==0) {
	gas <- read.table("halo_gas.txt", head=TRUE)
	#n <- intersect(which(gas$m>2e5), which(sqrt(gas$x^2 + gas$y^2 + gas$z^2)<0.01))
	n <- which(sqrt(gas$x^2 + gas$y^2 + gas$z^2)<0.04)
	gas <- gas[n,]

	star <- read.table("halo_star.txt", head=TRUE)
	n <- which(sqrt(star$x^2 + star$y^2 + star$z^2)<0.04)
	star <- star[n,]
	n <- which(star$m > quantile(star$m, probs=0.8))
	#n <- sample(seq(length(star[,1])), 10000)
	star <- star[n,]

	phi <- read.table("halophi.txt", head=TRUE)
	phi$pot[which(is.nan(phi$pot))] <- 0
	phifunc <- splinefun(phi$r, phi$pot)
	realv <- sqrt(phifunc(phi$r, deriv=1)*phi$r)

	j0 <- c(0,0,0)
	for (i in seq(length(gas$x))) {
	  	j0 <- j0 + cross(c(gas$x[i], gas$y[i], gas$z[i]), c(gas$vx[i], gas$vy[i], gas$vz[i]))
	}
	j0 <- j0/sqrt(sum(j0^2))

	ratio <- numeric(length(gas$x))
	for (i in seq(length(gas$x))) {
		radius <- sqrt(gas$x[i]^2 + gas$y[i]^2 + gas$z[i]^2)
		ratio[i] <- crossdot(c(gas$x[i], gas$y[i], gas$z[i]), c(gas$vx[i], gas$vy[i], gas$vz[i]), j0)/radius
		radbin <- which.min(abs(phi$r - radius))
		ratio[i] <- ratio[i]/realv[radbin]
	}

	pcols <- ratio
	pcols[which(is.infinite(pcols))] = 0
	pcols <- pcols/max(pcols)
	pcols[which(pcols<0)] = 0

	sratio <- numeric(length(star$x))
	for (i in seq(length(star$x))) {
		radius <- sqrt(star$x[i]^2 + star$y[i]^2 + star$z[i]^2)
		sratio[i] <- crossdot(c(star$x[i], star$y[i], star$z[i]), c(star$vx[i], star$vy[i], star$vz[i]), j0)/radius
		radbin <- which.min(abs(phi$r - radius))
		sratio[i] <- sratio[i]/realv[radbin]
	}

	spcols <- sratio
	spcols[which(is.infinite(spcols))] = 0
	spcols <- spcols/max(spcols)
	spcols[which(spcols<0)] = 0

	force <- read.table("forcemap.txt", head=TRUE)
}

if (type==0) {
	n <- which(ratio>=1.0)
	plot3d(gas$x[n], gas$y[n], gas$z[n], col=rgb(pcols[n], 0, 0), xlim=c(-0.01, 0.01), ylim=c(-0.01, 0.01), zlim=c(-0.01, 0.01))
	n <- which(ratio<1.0)
	points3d(gas$x[n], gas$y[n], gas$z[n], col=rgb(0, 0, pcols[n]))
}

if (type==1) {
	n <- which(ratio>=1.0)
	plot3d(gas$x[n], gas$y[n], gas$z[n], col=rgb(pcols[n], 0, 0), xlim=c(-0.01, 0.01), ylim=c(-0.01, 0.01), zlim=c(-0.01, 0.01))
	n <- which(ratio<1.0)
	points3d(gas$x[n], gas$y[n], gas$z[n], col=rgb(0, 0, pcols[n]))
	arrow3d(-j0/500,j0/500, "green")
	for (i in seq(length(force$x))) {
		fscale <- 4e10
		arrow3d(c(force$x[i], force$y[i], force$z[i]), c(force$x[i], force$y[i], force$z[i])+c(force$Fx[i], force$Fy[i], force$Fz[i])/fscale, "black")
	}
}

if (type==2) {
	n <- which(sratio>=1.0)
	plot3d(star$x[n], star$y[n], star$z[n], col=rgb(spcols[n], 0, 0), xlim=c(-0.01, 0.01), ylim=c(-0.01, 0.01), zlim=c(-0.01, 0.01))
	n <- which(sratio<1.0)
	points3d(star$x[n], star$y[n], star$z[n], col=rgb(0, 0, spcols[n]))
	arrow3d(-j0/500,j0/500, "green")
}

if (type==3) {
	n <- which(sratio>=1.0)
	plot3d(star$x[n], star$y[n], star$z[n], col=rgb(spcols[n], 0, 0), xlim=c(-0.01, 0.01), ylim=c(-0.01, 0.01), zlim=c(-0.01, 0.01))
	n <- which(sratio<1.0)
	points3d(star$x[n], star$y[n], star$z[n], col=rgb(0, 0, spcols[n]))
	tr <- read.table("trcurve.txt", head=TRUE)
	theta <- seq(0,2*pi,by=pi/100)
	for (i in seq(length(tr$r)/2)) {
		xhat <- cross(c(tr$Lx[i], tr$Ly[i], tr$Lz[i]), c(1,0,0))
		yhat <- cross(c(tr$Lx[i], tr$Ly[i], tr$Lz[i]), xhat)
		xhat <- (xhat*tr$r[i])/sqrt(xhat[1]^2 + xhat[2]^2 + xhat[3]^2)
		yhat <- (yhat*tr$r[i])/sqrt(yhat[1]^2 + yhat[2]^2 + yhat[3]^2)
		lines3d(xhat[1]*cos(theta)+yhat[1]*sin(theta), xhat[2]*cos(theta)+yhat[2]*sin(theta), xhat[3]*cos(theta)+yhat[3]*sin(theta), col="green", lwd=2)
	}
}


library(tidyverse)
library(magrittr)
library(lubridate)

file <- 'Tester-20190329T211750.csv'

# Get rid of extra metadata
# 4 is number of unnecessary last rows, 3 is first rows
skip_first <- 3
skip_last <- 4
nrows <- length(readLines(file)) - skip_first - skip_last

# read in the data
data <- read_csv(file,
                 quote='"', skip=3, n_max = nrows,
                 col_names = FALSE)

# rename the columns using the select() function
# use the mutate function to parse the time (hms = hours minutes seconds)
data <- data %>%
  select(time = X1, fish_id = X4, zone = X9, distance = X11) %>%
  mutate(time = hms(time))

# generate some fake x, y coordinates
data$x = rnorm(n = nrows)
data$y = rnorm(n = nrows)

calc_distance <- function(x1, x2, y1, y2) {
  sqrt((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
}

distance <- function(data) {
  # length of data
  n <- nrow(data)

    # assume there is x and y columns, shift by a row to get distance from one row to another
  data$distance[2:n] <- calc_distance(data$x[1:n-1], data$x[2:n], data$y[1:n-1], data$y[2:n])

  # get the cumulative distance
  data$cumulative_dist <- c(0, cumsum(data$distance)[-nrow(data)])

  data
}

speed_binned <- function(data, bins_sec){
  # get the length of the recording in seconds
  max_time <- max(data$time)

  # cut into 3s chunks, from 0 to max_time and set to a new column
  data$cuts <- cut(data$time, seq(0, bins_sec*round(max_time/bins_sec), by = bins_sec),
                   include.lowest = TRUE)

  speed <- data %>%
    group_by(cuts) %>%
    # v = d/t (distance/bins_sec)
    summarise(avg_speed = mean(distance)/bins_sec)

  speed
}

# run the functions on our data
data <- distance(data)
speed <- speed_binned(data, 3)