library(sandwich)
library(lmtest)

#given the outcome and the covariates
#returns a string formula
generate_formula <- function(outcome, covariates, remove=""){
  if (!remove == "") {
    remove <- paste0("-", remove, " +")
  }
  formula <- paste0(outcome, '~', remove, paste(covariates, collapse = ' + '))
  return(formula)
}

generate_quad_terms <- function(predictors){
  return(paste0("I(",predictors, "^2)"))
}

generate_interaction_terms <- function(predictors){
  return(paste0('(', paste(predictors, collapse = ' + '), ')^2', collapse = ' + '))
}

#given a model_object (such as a stepwise selection model)
#returns the names of all the coefficients remain in the model (except the intercept)
select_remained <- function(model_object){
  return(names(model_object$coefficients)[-1])
}

# i.e. expander = generate_quad_terms
#      select_from = select_remained
# returns a selector function that executes model selection on the specified terms
# (quadratic vs interactions)
# k = 3.84 ~ p = 0.05
selector_factory <- function(expander=generate_quad_terms, select_from=select_remained){
  selector <- function(data, base_var, add_var, outcome, remove=""){
    initial_model <- generate_formula(outcome, c(base_var, add_var), remove)
    full_model <- generate_formula(outcome, c(base_var, add_var, expander(add_var)), remove)
    res <- step(lm(as.formula(initial_model), data=data),
                scope=as.formula(full_model), scale = 0,trace = F, k=2,
                direction = "forward", test="F")
    return(select_from(res))
  }
  return(selector)
}

#shuffle the covariates but keep the outcomes(a matrix) constant
shuffle <- function(data, outcomes){
  assertthat::assert_that(length(outcomes) > 1)
  shuffled <- data[sample(nrow(data)),]
  shuffled[,outcomes] <- data[,outcomes]
  return(shuffled)
}

#given the data to be sampled and the sample size m
#returns a bootstrap sample of data
bootstrap_sample <- function(to_sample, m){
  if (is.vector(to_sample)){
    s <- sample(to_sample, m, replace = T)
  } else {
    s <- to_sample[sample(1:nrow(to_sample), m, replace = T),]
  }
  return(s)
}

# given the data to split, and the fraction of the trainning data (default 0.5)
# returns a list of the train and test sets
sample_splitting <- function(data, train_fraction=0.5){
  train_num <- round(nrow(data) * train_fraction)
  train_idx <- sample(1:nrow(data), train_num)
  train <- data[train_idx,]
  test <- data[-train_idx,]
  return(list(train=train, test=test))
}

# specific to example_1
# given:
  # data: the dataset to be expanded
  # base_var: the variables that remain the same, not expanded
  # add_var: the variables that will be expanded into quadratic and interaction terms
# returns a full dataset through model.matrix
generate_full_model_dat <- function(data, base_var, add_var, outcomes){
  full_model <- generate_formula(outcomes[1], c(
                                             base_var,
                                             add_var,
                                             generate_quad_terms(add_var),
                                             generate_interaction_terms(add_var)
                                             ))
  df <- as.data.frame(model.matrix(lm(as.formula(full_model), data = data)))
  return(cbind(df,data))
}

#given the outcome and covariates
#returns the fitted model object
get_result <- function(data, outcome, covariates, remove=""){
  f <- as.formula(generate_formula(outcome, covariates, remove))
  fit <- lm(f, data = data)
  return(fit)
}

#given a model object, sig level (default = 0.05), and using robust variance or not (default = F)
# returns the number of significant coefs not counting the intercept
get_num_sig <- function(fit, alpha=0.05, robust=F){
  if (robust) {
    p_vals <- lmtest::coeftest(fit, vcov=sandwich)[,4]
  } else {
    p_vals <- summary(fit)$coefficient[,4]
  }
  return(sum(p_vals[-1] <= alpha))
}

# specific to example 1
# given given a model object, sig level (default = 0.05), and using robust variance or not (default = F)
# returns the number of quad terms significant in the model
get_num_sig_quad_term <- function(fit, alpha=0.05, robust=F){
  if (robust) {
    p_vals <- coeftest(fit, vcov=sandwich)[,4]
  } else {
    p_vals <- summary(fit)$coefficient[,4]
  }
  quad_p_vals <- p_vals[grep("^I.*2", names(p_vals))]
  return(sum(quad_p_vals <= alpha))
}

# given the model object and the name of the variable of interest
# returns a list of the coef estimates for the variable
get_coef_est <- function(fit, var_name){
  estimates <- summary(fit)$coefficient[,1]
  return(estimates[var_name])
}

# example 2

make_data <- function(outcome="y", m=1000, to_shuffle=F){
  y <- rlnorm(m)
  X <- as.data.frame(purrr::map(1:10, rlnorm, n=m))
  covariates <- paste0("x",c(1:10))
  colnames(X) <- covariates
  X[,outcome] <- y
  # X <- abs(X) + 10
  if (to_shuffle) {
    X <- cbind(bootstrap_sample(X[,-which(names(X) == outcome)], m),
               bootstrap_sample(X[,outcome], m))
    colnames(X) <- c(covariates, outcome)
  }
  return(X)
}

# given the variable x to be transformed and the power of transformation
# returns the boxcox transformed x
boxcox_transform <- function(x, l){
  assertthat::assert_that(is.vector(x))
  if (l != 0){
    x <- (x^l - 1)/l
  } else {
    x <- log(x)
  }
  return(x)
}

# given a matrix/dataframe and a vector of powers for transformation
# returns the transformed dataframe
boxcox_dat_transform <- function(dat, ls){
  for (l in ls){
    dat[,names(l)] <- boxcox_transform(dat[,names(l)],l)
  }
  return(dat)
}

# multivariate_boxcox <- function(i){
#   dat <- make_data()
#
#   s <- summary(a <- car::powerTransform(dat$X))
#   lambdas <- s$result[,2]
#   #testTransform(a, lambdas)
#   X_trans <- boxcox_dat_transform(dat$X,lambdas)
#   fit <- lm(dat$y ~., data = cbind(X_trans,y))
#   s <- summary(a2 <- car::powerTransform(fit))
#   lambda_y <- s$result[,2]
#   y_trans <- boxcox_transform(y,lambda_y)
#   fit <- lm(y_trans ~ ., data=cbind(X_trans,y_trans))
#   return(fit)
# }

#takes in the covariates to be transformed
#returns a list of lambda for the boxcox power transformation of the given covariates
multivariate_covariates_transform <- function(X){
  s <- summary(car::powerTransform(X))
  ls <- s$result[,2]
  names(ls) <- names(X)
  return(ls)
}

# given the training data and the outcome name
# returns a list of lambdas for transformation (for covariates and the outcome)
get_lambdas <- function(train, outcome){
  ls <- multivariate_covariates_transform(train[,-which(names(train) == outcome)])
  X_train_trans <- boxcox_dat_transform(train[,-which(names(train) == outcome)], ls)
  fit <- lm(y ~., data=cbind(X_train_trans, y=train[,outcome]))
  s <- summary(car::powerTransform(fit))
  l_y <- s$result[,2]
  names(l_y) <- outcome
  ls <- c(ls, l_y)
  return(ls)
}

#given a dataset, the outcome name, the list of covariates and lambdas
# return the model object fitted post transformation
post_transform_inference <- function(dat, outcome, covariates, ls){
  transformed <- boxcox_dat_transform(dat, ls)
  f <- as.formula(generate_formula(outcome, covariates))
  fit <- lm(f, data = transformed)
  return(fit)
}

# given a dataset
# returns a function that allows bootstrap draws from the dataset, where shuffle is set to true.
bootstrap_shuffle_factory <- function(dataset){

  # given outcome name, sample size, and shuffle or not
  # returns the sample dataset
  sample_function <- function(outcome, m, to_shuffle=T){
    if (to_shuffle){
      covariates <- names(dataset)[-which(names(dataset) == outcome)]
      dat <- cbind(bootstrap_sample(dataset[,covariates], m), bootstrap_sample(dataset[,outcome], m))
      colnames(dat) <- c(covariates, outcome)
    } else {
      dat <- bootstrap_sample(dataset, m)
    }
    return(dat)
  }
  return(sample_function)
}


devtools::install_github("joeroe/rpaleoclim")
install.packages('rgdal')

library("rgdal")
library("rpaleoclim")
library("raster")

# Bio_1=Annual Mean Temperature [°C*10]
# Bio_2=Mean Diurnal Range [°C]
# Bio_3=Isothermality [Bio_2/Bio_7]
# Bio_4=Temperature Seasonality [standard deviation*100]
# Bio_5=Max Temperature of Warmest Month [°C*10]
# Bio_6=Min Temperature of Coldest Month [°C*10]
# Bio_7=Temperature Annual Range [°C*10]
# Bio_8=Mean Temperature of Wettest Quarter [°C*10]
# Bio_9=Mean Temperature of Driest Quarter [°C*10]
# Bio_10=Mean Temperature of Warmest Quarter [°C*10]
# Bio_11=Mean Temperature of Coldest Quarter [°C*10]
# Bio_12=Annual Precipitation [mm/year]
# Bio_13=Precipitation of Wettest Month [mm/month]
# Bio_14=Precipitation of Driest Month [mm/month]
# Bio_15=Precipitation Seasonality [coefficient of variation]
# Bio_16=Precipitation of Wettest Quarter [mm/quarter]
# Bio_17=Precipitation of Driest Quarter [mm/quarter]
# Bio_18=Precipitation of Warmest Quarter [mm/quarter]
# Bio_19=Precipitation of Coldest Quarter [mm/quarter]

lh_10m <- paleoclim("lh", "10m", region = extent(c(-15, 50, 30, 50)))
annual_temp = lh_10m[[c(1)]]
annual_temp =  setMinMax(annual_temp)

cellStats(annual_temp, min)
cellStats(annual_temp, max)

image(annual_temp)
col <- terrain.colors(7)[c(2:4)]
brk <- c(-60,200, 265)

plot(annual_temp, col=col, breaks= brk)


library(scales)

# set your folder
setwd("//Users//wayne//Documents//My research//0. Pop CSGLD//")

# total number of iterations
total_iters = 1e6
# learning rate for gradient Langevin dynamics
eta = 0.1
# temperature
T = 1
# hyperparameter
zeta = 0.9
# Total number of partitions
parts = 100
# Energy gap
div = 1
# Minimum energy for partition
min_energy = 0.15

# build the energy function and the gradient
energy = function(x) return(-log(0.4 * dnorm(x, -6, 1) + 0.6 * dnorm(x, 4, 1)))
grad_f = function(x) return(numDeriv::grad(energy, x) + 0.03 * rnorm(1, 0, 1))

# find the index for new samples
find_idx = function(sample) {
    stochastic_energy = energy(sample) + 0.03 * rnorm(1, 0, 1)
    return(min((as.integer((energy(sample) - min_energy) / div) + 1), parts-1))
}

random_field = function(theta, idx) {
    sub_random_field = -theta
    sub_random_field[idx] = sub_random_field[idx] + 1
    return(theta[idx] * sub_random_field)
}

# print process
print_progress = function(iter, total_iters) {
    if (iter %% (total_iters / 10) == 0) {
        print(paste('Iter ', scientific(iter, digits = 3), '/',  total_iters,' completed'))
    }
}

# Since we are converging to a biased equilibrium that approximates the ground truth, we will not compare it and will only
# focus on validate the reduction of variance
#############################################     Ground truth density of states  #########################################
parts_for_presentation = 11
# simulate samples from the Gaussian mixture distribution
real_samples = c(rnorm(1e6 * 0.4, -6, 1), rnorm(1e6 * 0.6, 4, 1))
# obtain the energy value for these samples
energy_each_sample = mapply(energy, real_samples)

# establish energy partition
grids = seq(1, parts_for_presentation) * div + min_energy
# compute density of states (ignore the first partition)
real_density_of_states = rep(0, (parts_for_presentation-1))
for (i in 1:(parts_for_presentation-1)) {
    real_density_of_states[i]  = (sum(energy_each_sample <= grids[i+1]) - sum(energy_each_sample <= grids[i])) / 1e6
}

chains = 10
#########################################    ICSGLD  (many short chains)    ##############################################
theta_ICSGLD = c()
candidate_seeds = seq(1, 10)
for (seeds in candidate_seeds) {
    set.seed(seeds)
    print(paste("Run ICSGLD (many short chains) based on the random seed", seeds))
    theta = rep(1, parts) / parts
    samples = rep(0, chains)
    indexs = rep(1, chains)
    for (iter in 1: total_iters) {
        decay = 1 / (iter^0.6 + 100)
        print_progress(iter, total_iters)
        # adaptive sampling part (parallelizable)
        for (cidx in 1: chains) {
            multiplier = 1 + zeta * T * (log(theta[indexs[cidx]+1]) - log(theta[indexs[cidx]])) / div
            samples[cidx] = samples[cidx] - eta * multiplier * grad_f(samples[cidx])  + sqrt(2 * eta * T) * rnorm(1, 0, 1)
            indexs[cidx] = find_idx(samples[cidx])
        }
        # interacting stochastic approximation
        interacting_random_field = 0
        for (cidx in 1: chains) {
            interacting_random_field = interacting_random_field + random_field(theta, indexs[cidx]) / chains
        }
        theta = theta + decay * interacting_random_field
    }
    # ignore the first empty partition where the minimum energy is around 1.42
    theta_ICSGLD = cbind(theta_ICSGLD, theta[2:parts_for_presentation])
}

#########################################    CSGLD  (a single long chain)    ##############################################
theta_CSGLD = c()
for (seeds in candidate_seeds) {
    set.seed(seeds)
    print(paste("Run CSGLD (a single long chain) based on the random seed", seeds))
    theta = rep(1, parts) / parts
    sample = 0
    idx = 1
    for (iter in 1: (total_iters*chains)) {
        decay = 1 / (iter^0.6 + 100)
        print_progress(iter, total_iters*chains)
        # adaptive sampling part
        multiplier = 1 + zeta * T * (log(theta[idx+1]) - log(theta[idx])) / div
        sample = sample - eta * multiplier * grad_f(sample)  + sqrt(2 * eta * T) * rnorm(1, 0, 1)
        idx = find_idx(sample)
        theta = theta + decay * random_field(theta, idx)
    }
    # ignore the first empty partition where the minimum energy is around 1.42
    theta_CSGLD = cbind(theta_CSGLD, theta[2:parts_for_presentation])
}

library(ggplot2)

ICSGLD_estimated_density_of_states = rowMeans(theta_ICSGLD)^zeta / sum(rowMeans(theta_ICSGLD)^zeta)
CSGLD_estimated_density_of_states = rowMeans(theta_CSGLD)^zeta / sum(rowMeans(theta_CSGLD)^zeta)

# we don't know the real equilibrium, we approximate it instead
biased_equilibrium = (ICSGLD_estimated_density_of_states + CSGLD_estimated_density_of_states) / 2

wdata = cbind(CSGLD_estimated_density_of_states, ICSGLD_estimated_density_of_states, biased_equilibrium)
ddf = as.data.frame(wdata)
ddf$X = seq(1, length(ICSGLD_estimated_density_of_states))
ddf$ICSGLD_theta_upper = ddf$ICSGLD_estimated_density_of_states + 2 * apply(theta_ICSGLD, 1, sd)
ddf$ICSGLD_theta_lower = ddf$ICSGLD_estimated_density_of_states - 2 * apply(theta_ICSGLD, 1, sd)
ddf$CSGLD_theta_upper = ddf$CSGLD_estimated_density_of_states + 2 * apply(theta_CSGLD, 1, sd)
ddf$CSGLD_theta_lower = ddf$CSGLD_estimated_density_of_states - 2 * apply(theta_CSGLD, 1, sd)

sub_p = ggplot(ddf, aes(X)) +
    geom_line(aes(y=ICSGLD_estimated_density_of_states, col="#7570B3"), size=0.5) +
    geom_line(aes(y=CSGLD_estimated_density_of_states, col="#FF9999"), size=0.5) +
    geom_line(aes(y=biased_equilibrium, col="black"), size=1) +
    geom_ribbon(aes(ymin=ICSGLD_theta_lower,ymax=ICSGLD_theta_upper, x=X),alpha=0.3, fill="#7570B3") +
    geom_ribbon(aes(ymin=CSGLD_theta_lower,ymax=CSGLD_theta_upper, x=X),alpha=0.3, fill="#FF9999") +
    scale_x_continuous(name="Energy") +
    scale_y_continuous(name="PDF in Energy (density of states)") +
    scale_color_identity(name = "Multipliers",
                       breaks = c("#7570B3", "#FF9999", "black"),
                       labels = c("ICSGLD xP10", "CSGLD xT10", bquote(hat(theta)["*"])),
                       guide = "legend")  +
    theme(legend.position=c(0.8, 0.2),
        legend.title = element_blank(),
        axis.title=element_text(size=20),
        legend.text = element_text(colour="grey15", size=24),
        legend.key.size = unit(2,"line"),
        legend.key = element_blank(),
        legend.background = element_rect(fill=alpha('grey', 0.1)),
        axis.text.y = element_text(size=16),
        axis.text.x = element_text(size=16))

print(sub_p)


library("ggplot2")

#head(mtcars)
mtcars$name <- rownames(mtcars)
head(mtcars)

#ggplot(data=mtcars, aes(x=reorder(name, mtcars$mpg), y=mpg)) + geom_bar(stat='identity')
#ggplot(data=mtcars, aes(x=reorder(name, -mtcars$mpg), y=mpg)) + geom_bar(stat='identity')
#ggplot(data=mtcars, aes(x=reorder(name, -mtcars$mpg), y=mpg)) + geom_bar(stat='identity') + theme(axis.text.x = element_text(angle = 90))
ggplot(data=mtcars, aes(x=reorder(name, mtcars$mpg), y=mpg)) + geom_bar(stat='identity') + coord_flip()
p <- ggplot(data=mtcars, aes(x=reorder(name, mtcars$mpg), y=mpg)) + geom_bar(stat='identity') + coord_flip()

p + labs(x='', y='', title='차량별 연비') + theme(plot.title = element_text(size=18))
p <- p + labs(x='', y='', title='차량별 연비') + theme(plot.title = element_text(size=18))

p + geom_text(aes(label=mpg), size=3, hjust=1.25, color='#FFFFFF')
p + geom_bar(data=mtcars[mtcars$name=='Honda Civic', ], aes(x=name, y=mpg), fill='#5CBED2', stat='identity') + geom_text(aes(label=mpg), size=3, hjust=1.25, color='#FFFFFF')

mtcars[1, ]
mtcars$name=='Honda Civic'


## Within-pair discordant MZ twins analysis (adjusted model, children, buccal cell DNAm)
# Authors: Suderman M., Odintsova V., van Dongen J.

library(limma)

# Load methylation data (betas)
# Load phenotype and covariate data (df)
# Variables for basic model
# familynumber
# sex
# age (age at DNA bloodsampling)
# gestational age
# birth weight
# maternal smoking during pregnancy (0=no, 1=yes)
# Epi (epithelium cells proportion)
# NK (natural killer cells proportion)
# Array_rownum (array rownumber)
# Sample_Plate (sample plate)
# hand01 (left-handedness variable: right-handed = 0, left-handed = 1)
# handdiscord (handedness discordance: discordant MZ twins = "disc handedness", concordant MZ twins = "conc handedness")

# remove cases without methylation data
OL <- intersect(rownames(df),rownames(betas))
df <- df[OL,]
beta <- beta[OL,]
table(rownames(df)==rownames(beta))

# sortby Family Number
df <- df[order(df$familynumber),]
betas <- betas[rownames(df),]
n.na <- apply(is.na(betas), 2, sum)
idx <- which(n.na < nrow(betas)-1)
betas <- betas[,idx]

# calculate residuals on the total sample
model <- model.matrix(~Epi + NK + Array_rownum + Sample_Plate, data=mydata)
fit <- lmFit(t(betas), model)
betas.res <- t(residuals(fit,t(betas)))
save(betas.res , file= paste(phenotype,date,"betaresiduals.RData",sep="_"))

# select twins from discordant pairs (handedness discordance variable)
mydata <- mydata[which(!is.na(mydata$handdiscord) & mydata$handdiscord == 'disc handedness'),]
left.data <- mydata[which(mydata$hand01 == "0"),]
right.data <- mydata[which(mydata$hand01 == "1"),]
right.idx = match(rownames(right.data), rownames(betas))
left.idx = match(rownames(left.data), rownames(betas))

# Testrun for 1 cpg to determine the number of estimates in output
#------------------------------------------------------------------------------------------------------------------------------------------------------
#mydata$CpGi <- betas[,1]

#------------------------------------------------------------------------------------------------------------------------------------------------------
dim(betas)
dim(betas.res)
sum(is.na(betas))
sum(is.na(betas.res))
table(apply(is.na(betas.res), 2, sum))

#------------------------------------------------------------------------------------------------------------------------------------------------------
Ncpgs <- ncol(betas)
results <- matrix(NA,nrow=Ncpgs,ncol=6)
#------------------------------------------------------------------------------------------------------------------------------------------------------
#check that family number corresponds to left and right twin in the pair
print(left.data$FamilyNumber)
print(right.data$FamilyNumber)
dim(left.idx)
dim(right.idx)
table(right.data$FamilyNumber==left.data$FamilyNumber)# should give TRUE

# Testrun for 1 cpg to determine the number of estimates in output
df$CpGi <- betas[,1]
table(apply(is.na(betas.res), 2, sum))
Ncpgs <- ncol(betas)
results <- matrix(NA,nrow=Ncpgs,ncol=6)
table(right.data$familynumber==left.data$familynumber)# should give TRUE

# Run model for all CpGs and save output
for (i in 1:Ncpgs) {
    meth.left <- betas.res[left.idx,i]
    meth.right <- betas.res[right.idx,i]
    n <- sum(!is.na(meth.left)&!is.na(meth.right))
    if (n > 2) {
      stats <- t.test(meth.left, meth.right, paired=T)
      results[i,] <- c(stats$estimate, stats$statistic, stats$conf.int, stats$p.value, n)
  }
  else results[i,ncol(results)] <- NA
}

save(results, file= "ttestresults.RData",sep="_")

# END


# Compute R potential scale reduction factor across chains using Rhat function of rstan package

## Load libraries

library(rstan)
library(stringr)

## Read chains

num_iters <- 1000
num_chains <- 4
num_pars <- 3

chains <- array(data=NA, dim=c(num_iters, num_chains, num_pars))
for (i in seq(1, num_chains)) {
  print(paste("Loading chain", str_pad(i, 2, pad='0')))
  chains[, i, ] <- as.matrix(read.table(paste('chain', str_pad(i, 2, pad='0'), '.csv', sep=''), header=FALSE, sep=","))
}

## Compute rhat

rhat_vals <- vector(mode="numeric", length=num_pars)
for (i in seq(1, num_pars)) {
  rhat_vals[i] <- Rhat(chains[, , i])
}

print(rhat_vals)


setwd("/home/remoteuser/Code/MRS")
source("SetComputeContext.r")

finalData <- RxXdfData(file.path(dataDir, "joined5XDFSubset"))

################################################
# Split out Training and Test Datasets
################################################

# split out the training data

trainDS <- RxXdfData( file.path(dataDir, "finalDataTrainSubset" ))

rxDataStep( inData = finalData, outFile = trainDS,
            rowSelection = ( Year != 2012 ), overwrite = T )

# split out the testing data

testDS <- RxXdfData( file.path(dataDir, "finalDataTestSubset" ))

rxDataStep( inData = finalData, outFile = testDS,
            rowSelection = ( Year == 2012 ), overwrite = T )

################################################
# Train and Test a Logistic Regression model
################################################

formula <- as.formula(ArrDel15 ~ Month + DayofMonth + DayOfWeek + Carrier + OriginAirportID +
                        DestAirportID + CRSDepTime + CRSArrTime + RelativeHumidityOrigin +
                        AltimeterOrigin + DryBulbCelsiusOrigin + WindSpeedOrigin +
                        VisibilityOrigin + DewPointCelsiusOrigin + RelativeHumidityDest +
                        AltimeterDest + DryBulbCelsiusDest + WindSpeedDest + VisibilityDest +
                        DewPointCelsiusDest
)

# Use the scalable rxLogit() function

logitModel <- rxLogit(formula, data = trainDS)

base::summary(logitModel)

# Predict over test data (Logistic Regression).

logitPredict <- RxXdfData(file.path(dataDir, "logitPredictSubset"))

# Use the scalable rxPredict() function

rxPredict(logitModel, data = testDS, outData = logitPredict,
          extraVarsToWrite = c("ArrDel15"),
          type = 'response', overwrite = TRUE)

# Calculate ROC and Area Under the Curve (AUC).

logitRoc <- rxRoc("ArrDel15", "ArrDel15_Pred", logitPredict)
logitAuc <- rxAuc(logitRoc)

plot(logitRoc)

##############################################
# Train and Test a Decision Tree model
##############################################

# Train using the scalable rxDTree function

dTreeModel <- rxDTree(formula, data = trainDS,
                      maxDepth = 6, pruneCp = "auto")

# Test using the scalable rxPredict function

treePredict <- RxXdfData(file.path(dataDir, "treePredictSubset"))

rxPredict(dTreeModel, data = testDS, outData = treePredict,
          extraVarsToWrite = c("ArrDel15"), overwrite = TRUE)

# Calculate ROC and Area Under the Curve (AUC)

treeRoc <- rxRoc("ArrDel15", "ArrDel15_Pred", treePredict)
treeAuc <- rxAuc(treeRoc)

plot(treeRoc)

save(dTreeModel, file = "dTreeModelSubset.RData")


library(tidyverse)
library(ggthemes)
library(lubridate)

pasajeros <- read_rds('fuentes/pases_subte_201801.rds')

colores <- c('LINEA_A'='#00ADDE',
             'LINEA_B'='#FF0000',
             'LINEA_C'='#005BB3',
             'LINEA_D'='#56B09B',
             'LINEA_E'='#76007C',
             'LINEA_H'='#FFDB00')

names(pasajeros)

nrow(pasajeros)

summary(pasajeros)

glimpse(pasajeros)

pasajeros %>%
  group_by(linea) %>%
  summarise(total_pasajeros_mes = sum(totales)) %>%
  arrange(-total_pasajeros_mes)

pasajeros %>%
  top_n(10, wt = promedio) %>%
  arrange(-promedio)

pasajeros %>%
  ggplot(.,aes(x = linea, y = promedio, fill= linea)) +
  geom_violin()+
  geom_boxplot(alpha=0.75, fill=NA)+
  theme_tufte()+
  theme(legend.position = 'none')+
  scale_fill_manual(values = colores)

pasajeros %>%
  group_by(desde, hasta, linea) %>%
  summarise(totales=sum(totales)) %>%
  ggplot(., aes(fill = linea))+
  geom_rect(aes(xmin=desde, xmax=hasta, ymin=0, ymax= totales))+
  theme_tufte()+
  theme(legend.position = 'none')+
  scale_x_time(limits = c(min(pasajeros$desde), max(pasajeros$hasta)))+
  scale_fill_manual(values = colores)+
  facet_wrap(.~linea, scales = 'free')

Materiales/Clase 7 - Markdown/07_practica_independiente.r


count <- function(a,b,matrix_type=0,input_filename='._____input_____.dat',
                                    table_filename='._____table_____.bin') {
# Count the number of matrices with row sums a and column sums b.
#
# INPUTS:
# a = vector of m nonnegative numbers
# b = vector of n nonnegative numbers, such that sum(a)==sum(b)
# matrix_type = 0: binary matrices, 1: nonnegative integer matrices
# input_filename = string that will be used as a filename for input data.
# table_filename = string that will be used as a filename for saving binary data.
#                  (This data will be used if you want sample, otherwise you can delete it.)
#
# OUTPUT:
# number = the number of matrices with row sums a and column sums b.
#          (This is a string, since it may be too large for normal R types.)
#
# (Note: This is a wrapper for the executable count.exe.)

m <- length(a)
n <- length(b)

# generate input file
sink(input_filename)
cat(m,n,matrix_type,'\n')
cat(as.character(a),'\n')
cat(as.character(b),'\n')
sink()

# run count.exe
arguments <- paste(input_filename, table_filename, '1')
output <- system2('count.exe', arguments, stdout=TRUE, stderr=TRUE)
status <- attr(output,"status")
if (!is.null(status)) stop(output)

return(output)
}

sample <- function(a,b,k,input_filename='._____input_____.dat',
                         table_filename='._____table_____.bin',
                         output_filename='._____output_____.dat') {
# Draw samples from the uniform distribution on matrices with specified margins.
#
# INPUTS:
# a = vector of m nonnegative numbers
# b = vector of n nonnegative numbers, such that sum(a)==sum(b)
# k = number of samples to draw
# input_filename = filename of input data (this must be the same one used in count()).
# table_filename = filename of saved binary data (same one used in count()).
# output_filename = string that will be used as a filename for output data.
#
# OUTPUT:
# samples = (m x n x k) array of sampled (m x n) matrices
#
# (Note: This is a wrapper for the executable sample.exe.)

if (!file.exists(input_filename))
    stop(sprintf('Input file %s does not exist. You must call count() first.',input_filename))
end
if (!file.exists(table_filename))
    stop(sprintf('Table file %s does not exist. You must call count() first.',table_filename))
end

m <- length(a)
n <- length(b)

# run sample.exe
arguments <- paste(input_filename, table_filename, output_filename, k, '1')
output <- system2('sample.exe', arguments, stdout=TRUE, stderr=TRUE)
status <- attr(output,"status")
if (!is.null(status)) stop(output)

# read samples from file
values = scan(output_filename, n = m*n*k, quiet = TRUE)

# rearrange samples into 3-D array
samples <- aperm(array(values, c(n,m,k)), c(2,1,3))

return(samples)
}


#' Sparsity
#'
#' Show the sparsity (as a count or proportion) of a matrix.  For
#' example, .99 sparsity means 99\% of the values are zero.
#' Similarly, a sparsity of 0 means the matrix is fully dense.
#'
#' @details
#' The implementation is very efficient for dense matrices.  For
#' sparse triplet matrices, the count is trivial.
#'
#' @param x
#' The matrix, stored as an ordinary R matrix or as a "simple
#' triplet matrix" (from the slam package).
#' @param proportion
#' Logical; should a proportion or a count be returned?
#'
#' @return
#' The sparsity of the input matrix, as a proportion or a count.
#'
#' @examples
#' ## Completely sparse matrix
#' x <- matrix(0, 10, 10)
#' coop::sparsity(x)
#'
#' ## 15\% density / 85\% sparsity
#' x[sample(length(x), size=15)] <- 1
#' coop::sparsity(x)
#'
#' @author Drew Schmidt
#' @export
sparsity <- function(x, proportion=TRUE) UseMethod("sparsity")

#' @export
sparsity.matrix <- function(x, proportion=TRUE)
{
  if (is.integer(x))
    count <- .Call(R_sparsity_int, x)
  else if (is.double(x))
    count <- .Call(R_sparsity_dbl, x, tol=1e-10)
  else
    stop("matrix 'x' must be numeric.")

  if (proportion)
    count / nrow(x) / ncol(x)
  else
    count
}

#' @export
sparsity.simple_triplet_matrix <- function(x, proportion=TRUE)
{
  if (proportion)
    1 - length(x$v) / nrow(x) / ncol(x)
  else
    nrow(x)*ncol(x) - length(x$v)
}

# Sparse matrix generator; used only for tests
# @param m,n Dimensions (rows, cols)
# @param prop Proportion of non-zeros.
dense_stored_sparse_mat <- function(m, n, prop)
{
  size <- prop*m*n
  x <- matrix(0, m, n)
  x[sample(m*n, size=size)] <- 10#rnorm(size)
  x
}


require(Hmisc)
ht <- function(x, filebase, ...) {
  ltx <- latex(x, file=paste('/tmp/', filebase, '.tex', sep=''),
               prmsd=TRUE, msdsize='scriptsize', round=3, pdig=2,
               npct='both', middle.bold=TRUE, ...)
  invisible(html(ltx, file=paste('/tmp/', filebase, '.html', sep='')))
}

n <- 500; set.seed(88)
sex <- factor(sample(c("female","male"), n, TRUE))
age <- rnorm(n, 50, 10)
height <- rnorm(n, 1.7, 0.5)
type <- factor(sample(c('A', 'B'), n, TRUE))
dbase= data.frame(sex, age, height, type)

ht(summaryM(age + height + type ~ sex , data=dbase, overall=TRUE,
            test=TRUE), 'a',
   caption="Cool descriptive statistics",
   label="table:summary")

## If this were in a knitr document you could have the following after the @
## that ends the chunk to also include the LaTeX typeset table (omit the ## )
## \input{/tmp/a}

# From Lauren Samuels
set.seed(1)
d <- expand.grid(x1=c('A', 'B'), x2=c('a', 'b', 'c'))
d$y <- runif(nrow(d))
d
w <- ht(
  summaryM(x2 + y ~ x1, data= d, test=TRUE, overall=TRUE, continuous=6),
  'b',
  caption="Descriptive stats and tests of between-group differences for all primary and secondary neuroimaging outcomes",
  label= "tbl:descrOutcomes",
  exclude1=FALSE)

## Example taken from help file for summaryM
set.seed(173)
sex <- factor(sample(c("m","f"), 500, rep=TRUE))
country <- factor(sample(c('US', 'Canada'), 500, rep=TRUE))
age <- rnorm(500, 50, 5)
sbp <- rnorm(500, 120, 12)
label(sbp) <- 'Systolic BP'
units(sbp) <- 'mmHg'
treatment <- factor(sample(c("Drug","Placebo"), 500, rep=TRUE))
treatment[1]
sbp[1] <- NA

# Generate a 3-choice variable; each of 3 variables has 5 possible levels
symp <- c('Headache','Stomach Ache','Hangnail',
          'Muscle Ache','Depressed')
symptom1 <- sample(symp, 500,TRUE)
symptom2 <- sample(symp, 500,TRUE)
symptom3 <- sample(symp, 500,TRUE)
Symptoms <- mChoice(symptom1, symptom2, symptom3, label='Primary Symptoms')
table(as.character(Symptoms))
# Produce separate tables by country
f <- summaryM(age + sex + sbp + Symptoms ~ treatment + country,
              groups='treatment', test=TRUE)
ht(f, 'c')

getHdata(pbc)
s5 <- summaryM(bili + albumin + stage + protime + sex +
                age + spiders ~ drug, data=pbc)
ht(s5, 'd', insert.bottom = "More stuff to add \\ldots")


# Run the code below to set up the data
# Change the points in the plot to light gray,
# decrease their size, and change their shape

library(tidyverse)
# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
unisex_data <- unisex_data %>%
  select(-prop) %>%
  spread(sex, n, fill=0)
unisex_data

# make a scatterplot
# Change the points in the plot to light gray,
# decrease their size, and change their shape
ggplot(unisex_data, aes(x=Male, y=Female, color=name)) +
  geom_point(color="lightgray", size=1, shape=17) +
  geom_smooth(method="lm", se=FALSE) +
  theme_minimal()

# Bonus:
# In the plot below, change the border of the points to be
# red and the inside to be blue.
# Hint: which is color and which is fill?
# More Bonus: increase the width of the border
ggplot(filter(unisex_data, name=="Casey"), aes(x=Male, y=Female)) +
  geom_point(shape=24, size=3, color="red", fill="blue", stroke=2)


LISP Interpreter Run

[[[
 First steps with my new construction for
 a self-delimiting universal Turing machine.
 We show that
    H(x,y) <= H(x) + H(y) + c
 and determine c.
 Consider a bit string x of length |x|.
 We also show that
    H(x) <= 2|x| + c
 and that
    H(x) <= |x| + H(the binary string for |x|) + c
 and determine both these c's.
]]]

[
 Here is the self-delimiting universal Turing machine!
]
define (U p) cadr try no-time-limit 'eval read-exp p

define      U
value       (lambda (p) (car (cdr (try no-time-limit (' (eval
            (read-exp))) p))))

(U bits 'cons x cons y cons z nil)

expression  (U (bits (' (cons x (cons y (cons z nil))))))
value       (x y z)

(U append bits 'cons a debug read-exp
          bits '(b c d)
)

expression  (U (append (bits (' (cons a (debug (read-exp)))))
            (bits (' (b c d)))))
debug       (b c d)
value       (a b c d)

[
 The length of alpha in bits is the
 constant c in H(x) <= 2|x| + 2 + c.
]
define alpha
let (loop) let x read-bit
           let y read-bit
           if = x y
              cons x (loop)
              nil
(loop)

define      alpha
value       ((' (lambda (loop) (loop))) (' (lambda () ((' (lam
            bda (x) ((' (lambda (y) (if (= x y) (cons x (loop)
            ) nil))) (read-bit)))) (read-bit)))))

length bits alpha

expression  (length (bits alpha))
value       1104

(U
 append
   bits alpha
   '(0 0 1 1 0 0 1 1 0 1)
)

expression  (U (append (bits alpha) (' (0 0 1 1 0 0 1 1 0 1)))
            )
value       (0 1 0 1)

(U
 append
   bits alpha
   '(0 0 1 1 0 0 1 1 0 0)
)

expression  (U (append (bits alpha) (' (0 0 1 1 0 0 1 1 0 0)))
            )
value       out-of-data

[
 The length of beta in bits is the
 constant c in H(x,y) <= H(x) + H(y) + c.
]
define beta
cons eval read-exp
cons eval read-exp
     nil

define      beta
value       (cons (eval (read-exp)) (cons (eval (read-exp)) ni
            l))

length bits beta

expression  (length (bits beta))
value       432

(U
 append
   bits  beta
 append
   bits 'cons a cons b cons c nil
   bits 'cons x cons y cons z nil
)

expression  (U (append (bits beta) (append (bits (' (cons a (c
            ons b (cons c nil))))) (bits (' (cons x (cons y (c
            ons z nil))))))))
value       ((a b c) (x y z))

(U
 append
   bits beta
 append
   append bits alpha '(0 0 1 1 0 0 1 1 0 1)
   append bits alpha '(1 1 0 0 1 1 0 0 1 0)
)

expression  (U (append (bits beta) (append (append (bits alpha
            ) (' (0 0 1 1 0 0 1 1 0 1))) (append (bits alpha)
            (' (1 1 0 0 1 1 0 0 1 0))))))
value       ((0 1 0 1) (1 0 1 0))

[
 The length of gamma in bits is the
 constant c in H(x) <= |x| + H(|x|) + c
]
define gamma
let (loop k)
   if = 0 k nil
   cons read-bit (loop - k 1)
(loop base2-to-10 eval read-exp)

define      gamma
value       ((' (lambda (loop) (loop (base2-to-10 (eval (read-
            exp)))))) (' (lambda (k) (if (= 0 k) nil (cons (re
            ad-bit) (loop (- k 1)))))))

length bits gamma

expression  (length (bits gamma))
value       1024

(U
 append
   bits gamma
 append
   [Arbitrary program for U to compute number of bits]
   bits' '(1 0 0 0)
   [That many bits of data]
   '(0 0 0 0  0 0 0 1)
)

expression  (U (append (bits gamma) (append (bits (' (' (1 0 0
             0)))) (' (0 0 0 0 0 0 0 1)))))
value       (0 0 0 0 0 0 0 1)

End of LISP Run

Elapsed time is 0 seconds.


#module load R/3.2.0
#install.packages("corpcor", repos="http://cran.r-project.org")
library(corpcor)
cat("
args:
inp1 = expression dataset
")
args = commandArgs(TRUE)
files = args[1]
dat <- read.table(files,head=T,sep='\t',row.names=1,stringsAsFactors=F)
dat2 <- t(dat)
co1 <- pcor.shrink(dat2,lambda=0, verbose=TRUE)
co2 <- round(co1,3)
write.table(co2,paste('corpcor/corpcor_',files,sep=''),quote=F,sep='\t')


#' Extract the information from the simulation data frame to analyse the interaction effects
#'
#' @param allsim dataset with all simulations values
#' @param dataset dataset with all variables
#' @param ic_dis choose between ic (interval confidences) and dis (distribution)
#' @return a data frame with naive ace and confident intervals
#' @export

naive_ace_ind <- function(allsim, dataset, ic_dis = "IC") {
  dataset <- data.frame(dataset)
    N <- dim(dataset)[1]
    sim <- dim(allsim)[2]
    m2 <- NA
    mean.res <- mean(as.matrix(allsim[1:N, ])) - mean(as.matrix(allsim[(N + 1):(N * 2), ]))
    for (f in 1:sim) {
        m1 <- mean(as.matrix(allsim[1:N, f])) - mean(as.matrix(allsim[(N + 1):(N * 2), f]))
        m2 <- c(m2, m1)
    }
    m2 <- m2[-1]
    if (ic_dis == "IC") {
        sdd <- stats::sd(m2[-1])
        lci <- mean.res - sdd * 1.96
        uci <- mean.res + sdd * 1.96
    } else if (ic_dis == "dis") {
        lci <- stats::quantile(m2, 0.025)
        uci <- stats::quantile(m2, 0.975)
    }
    return(list(mean.res, lci, uci))
}


#script to compute Inverse-Manhattan-Block distance results for simulated data=
#Eric Schulz and Charley Wu, June 2017

#house keeping
rm(list=ls())

#load packages
packages <- c('plyr', 'ggplot2', 'jsonlite', 'MASS', 'gridExtra')
lapply(packages, require, character.only = TRUE)

#read in data
dat<-read.csv("ExperimentData/simDataBMTLocal.csv")
#dat<-read.csv("ExperimentData/simDataGPLocal.csv")

##############################################################################################################
# COMPUTE MANHATTAN BLOCK DISTANCE
##############################################################################################################
computeIMD <- function(destinationFolder, d){
  cand<-expand.grid('x'=0:10, 'y'=0:10) #candidates)
  k<-1 #counter
  #loop through subjects
  for (h in 1:max(d$id)){
    dsub<-subset(d, id==h)
    #loop through rounds
    for (i in 1:8){
      dblock<-subset(dsub, round==i)
      dist<-matrix(0, nrow=121, ncol=nrow(dblock)-1)
      #loop through trials
      for (j in 1:(nrow(dblock)-1)){
        dist[,j]<-abs(cand$x-dblock$x[j])+abs(cand$y-dblock$y[j])
      }
      dist[dist==0]<-1
      dist<-dist^-1
      write.table(dist, file = paste0(destinationFolder,"/block", k, ".csv"), sep = ",", col.names = FALSE, row.names = FALSE)
      k<-k+1
    }
  }
}

computeIMD('bmtLocalBlockDistance', dat)
#computeIMD('gpLocalBlockDistance', dat)


#' @title calcKristWakeFrac
#'
#'@description Calculate wake fraction (\code{wakeFraction}) (dimensionless)
#'using the Kristensen method.
#'
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param lwl Waterline length (vector of numericals, m) (see
#'\code{\link{calclwl}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCbw}})
#'@param propDiam Propeller diameter (vector of numericals, m) (see
#'\code{\link{calcPropDia}})
#'@param M Fineness/slenderness coefficient (vector of numericals,
#'dimensionless) (see \code{\link{calcShipM}})
#'@param nProp Number of propellers (vector of numericals, see
#'\code{\link{calcPropNum}})
#'@param tankerBulkCarrierShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers and bulk carriers vessels (vector of
#' strings)
#'
#' @return \code{wakeFraction} (vector of numericals, dimensionless)
#'
#' @details
#' "The speed of advance of the propeller relative to the water in which it is working is
#'  lower than the observed speed of the vessel. This difference in speed,
#'  expressed as a percentage of the ship speed, is known as the wake fraction coefficient".
#'  \url{https://www.wartsila.com/encyclopedia/term/wake-fraction-coefficient}
#'
#'Wake fraction is a component of hull efficiency as well as a component of
#'propeller efficiency.
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierShipTypes} grouping  parameters to provide these ship
#' type groupings. Any ship types not included in this grouping will be considered as
#' miscellaneous vessels.
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcShipM}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcShipType}}}
#'
#' @family Kristensen Calculations
#'
#' @examples
#' calcKristWakeFrac("bulk.carrier",32.25,218.75, 0.8, 6.7,5.2, 1)
#' calcKristWakeFrac("oil.tanker",32.25,218.75, 0.8, 6.7,5.2, 1)
#' calcKristWakeFrac(c("bulk.carrier","container.ship"),
#'                   c(32.25,49),
#'                   c(218.75,400),
#'                   c(0.8,0.75),
#'                   c(6.7,9.6),
#'                   c(5.2,6.7),
#'                   c(1,1))
#'
#' @export

calcKristWakeFrac <- function(shipType, breadth,lwl, Cbw, propDiam,M, nProp,
                              tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier")
){

  wakeFraction<-ifelse(nProp==1,
            #a
            ((((0.1*breadth)/
                 lwl)+0.149)+
               (
                 #b
                 (((0.05*breadth)/
                     lwl)+0.449)/
                   #c
                   (
                     (585-((5027*breadth)/
                             lwl)+
                        11700*((breadth/
                                  lwl)^2)
                     )*
                       ((0.98-Cbw)^3)+1)))+
              # Assume w2 = 0 because we assume F_a = 0 where
              #F_a = [-2,0,2] and F_a=0 represents a N-shaped hull form
              #take this assumption for lack of better information
              #w3
              pmin(0.1,-0.18+(0.00756/((propDiam/lwl)+
                                         0.002))),
            #nprop == 2 case
            1.133*(Cbw^2)-0.797*Cbw+0.215
            )

  #apply adjustments from Kristensen, 2016 (to correct Harvald's algorithms toward data in more recent model tests)
  wakeFraction<-ifelse( (nProp==1) & ( shipType %in% tankerBulkCarrierShipTypes), #End of case definition
             (0.7*wakeFraction-0.45+0.08*M),#second case= container ships
             0.7*wakeFraction
            )

  return(wakeFraction)

}# end of function: calcWakeFrac


library(matrixStats)

process_rmse <- function(dist) {

    print("Post-processing RMSE", quote=FALSE)
    print(dist, quote=FALSE)

    trials = 100
    steps = 1000

    house_r_se <- matrix(, nrow=steps, ncol=trials)
    ukf_r_se   <- matrix(, nrow=steps, ncol=trials)
    cut4_r_se  <- matrix(, nrow=steps, ncol=trials)
    cut6_r_se  <- matrix(, nrow=steps, ncol=trials)

    house_v_se <- matrix(, nrow=steps, ncol=trials)
    ukf_v_se   <- matrix(, nrow=steps, ncol=trials)
    cut4_v_se  <- matrix(, nrow=steps, ncol=trials)
    cut6_v_se  <- matrix(, nrow=steps, ncol=trials)

    state_interp <- function(filename) {
        t <- as.matrix(read.csv(filename))[,1]
        x <- as.matrix(read.csv(filename))[,2:7]
        xi <- matrix(, nrow=steps, 6)
        for (i in 1:6) {
            xi[,i] <- approx(t, x[,i], n=steps, method="linear")$y
        }
        return (xi)
    }

    for (j in 1:trials) {

        print(paste("   Trial ", j), quote=FALSE)

        tru_file <- paste("out/tru_", dist, "_",  j, ".csv", sep="")

        house_file <- paste("out/house_est_", dist, "_", j, ".csv", sep="")
        ukf_file   <- paste("out/ukf_est_",   dist, "_", j, ".csv", sep="")
        cut4_file  <- paste("out/cut4_est_",  dist, "_", j, ".csv", sep="")
        cut6_file  <- paste("out/cut6_est_",  dist, "_", j, ".csv", sep="")

        tru <- state_interp(tru_file)

        house_est <- state_interp(house_file)
        ukf_est   <- state_interp(ukf_file)
        cut4_est  <- state_interp(cut4_file)
        cut6_est  <- state_interp(cut6_file)

        house_r_se[,j] <- rowSums((house_est[,1:3] - tru[,1:3])^2)
        ukf_r_se  [,j] <- rowSums((ukf_est  [,1:3] - tru[,1:3])^2)
        cut4_r_se [,j] <- rowSums((cut4_est [,1:3] - tru[,1:3])^2)
        cut6_r_se [,j] <- rowSums((cut6_est [,1:3] - tru[,1:3])^2)

        house_v_se[,j] <- rowSums((house_est[,4:6] - tru[,4:6])^2)
        ukf_v_se  [,j] <- rowSums((ukf_est  [,4:6] - tru[,4:6])^2)
        cut4_v_se [,j] <- rowSums((cut4_est [,4:6] - tru[,4:6])^2)
        cut6_v_se [,j] <- rowSums((cut6_est [,4:6] - tru[,4:6])^2)

    }

    # --- RMSE

    rmse_pos <- c(sqrt(mean(house_r_se)),
                  sqrt(mean(ukf_r_se)),
                  sqrt(mean(cut4_r_se)),
                  sqrt(mean(cut6_r_se)))

    rmse_vel <- c(sqrt(mean(house_v_se)),
                  sqrt(mean(ukf_v_se)),
                  sqrt(mean(cut4_v_se)),
                  sqrt(mean(cut6_v_se)))

    filter <- c("HOUSE", "UKF", "CUT-4", "CUT-6")

    rmse <- data.frame(filterno = 1:4, filter, rmse_pos, rmse_vel)

    file <- paste("out/rmse_", dist, ".csv", sep="")
    write.csv(rmse, file, row.names=FALSE, quote=FALSE)

    # --- RMSE vs. time

    time_percent <- seq(0, 100, length.out=steps)

    rmse_t <- data.frame(time_percent,
          house_pos = sqrt(rowMeans(house_r_se)),
          house_vel = sqrt(rowMeans(house_v_se)),
          ukf_pos   = sqrt(rowMeans(ukf_r_se)),
          ukf_vel   = sqrt(rowMeans(ukf_v_se)),
          cut4_pos  = sqrt(rowMeans(cut4_r_se)),
          cut4_vel  = sqrt(rowMeans(cut4_v_se)),
          cut6_pos  = sqrt(rowMeans(cut6_r_se)),
          cut6_vel  = sqrt(rowMeans(cut6_v_se)))

    file <- paste("out/rmse_t_", dist, ".csv", sep="")
    write.csv(rmse_t, file, row.names=FALSE, quote=FALSE)

    # --- Convergence

    convmse <- function(se) {
        cmse <- vector(, length = trials)
        for (j in 1:trials) {
            cmse[j] <- mean(se[,1:j])
        }
        return(cmse)
    }

    convsse <- function(se) {
        csse <- vector(, length = trials)
        for (j in 1:trials) {
            csse[j] <- sd(se[,1:j])
        }
        return(csse)
    }

    conv <- data.frame(ntrials = 1:trials,
                house_r_mse = convmse(house_r_se), house_r_sse = convsse(house_r_se),
                house_v_mse = convmse(house_v_se), house_v_sse = convsse(house_v_se),
                ukf_r_mse = convmse(ukf_r_se), ukf_r_sse = convsse(ukf_r_se),
                ukf_v_mse = convmse(ukf_v_se), ukf_v_sse = convsse(ukf_v_se),
                cut4_r_mse = convmse(cut4_r_se), cut4_r_sse = convsse(cut4_r_se),
                cut4_v_mse = convmse(cut4_v_se), cut4_v_sse = convsse(cut4_v_se),
                cut6_r_mse = convmse(cut6_r_se), cut6_r_sse = convsse(cut6_r_se),
                cut6_v_mse = convmse(cut6_v_se), cut6_v_sse = convsse(cut6_v_se))

    file <- paste("out/conv_", dist, ".csv", sep="")
    write.csv(conv, file, row.names = FALSE, quote=FALSE)

}

process_box <- function(dist) {

    print("Post-processing for boxplot", quote=FALSE)
    print(dist, quote=FALSE)

    print("Post-processing", quote=FALSE)

    trialno <- 1:100

    trials = length(trialno)

    f = 10
    tmin = 1
    kstart = f * tmin + 1

    house_r_err <- c()
    ukf_r_err   <- c()
    cut4_r_err  <- c()
    cut6_r_err  <- c()

    house_v_err <- c()
    ukf_v_err   <- c()
    cut4_v_err  <- c()
    cut6_v_err  <- c()

    for (j in 1:trials) {

        k <- trialno[j]

        print(paste("   Trial ", k), quote=FALSE)

        tru_file <- paste("out/tru_", dist, "_",  j, ".csv", sep="")

        house_file <- paste("out/house_est_", dist, "_", k, ".csv", sep="")
        ukf_file   <- paste("out/ukf_est_",   dist, "_", k, ".csv", sep="")
        cut4_file  <- paste("out/cut4_est_",  dist, "_", k, ".csv", sep="")
        cut6_file  <- paste("out/cut6_est_",  dist, "_", k, ".csv", sep="")

        tru <- as.matrix(read.csv(tru_file))[,2:7]

        kstop <- length(tru[,1])

        tru <- tru[kstart:kstop,]

        house_est <- as.matrix(read.csv(house_file))[kstart:kstop,2:7]
        ukf_est   <- as.matrix(read.csv(ukf_file))  [kstart:kstop,2:7]
        cut4_est  <- as.matrix(read.csv(cut4_file)) [kstart:kstop,2:7]
        cut6_est  <- as.matrix(read.csv(cut6_file)) [kstart:kstop,2:7]

        house_r_err <- c(sqrt(rowSums((house_est[,1:3] - tru[,1:3])^2)), house_r_err)
        ukf_r_err   <- c(sqrt(rowSums((ukf_est  [,1:3] - tru[,1:3])^2)), ukf_r_err)
        cut4_r_err  <- c(sqrt(rowSums((cut4_est [,1:3] - tru[,1:3])^2)), cut4_r_err)
        cut6_r_err  <- c(sqrt(rowSums((cut6_est [,1:3] - tru[,1:3])^2)), cut6_r_err)

        house_v_err  <- c(sqrt(rowSums((house_est[,4:6] - tru[,4:6])^2)), house_v_err)
        ukf_v_err    <- c(sqrt(rowSums((ukf_est  [,4:6] - tru[,4:6])^2)), ukf_v_err)
        cut4_v_err   <- c(sqrt(rowSums((cut4_est [,4:6] - tru[,4:6])^2)), cut4_v_err)
        cut6_v_err   <- c(sqrt(rowSums((cut6_est [,4:6] - tru[,4:6])^2)), cut6_v_err)

    }

    names <- c("HOUSE", "UKF", "CUT-4", "CUT-6")

    r_err <- data.frame(HOUSE=house_r_err, UKF=ukf_r_err, CUT4=cut4_r_err, CUT6=cut6_r_err)
    v_err <- data.frame(HOUSE=house_v_err, UKF=ukf_v_err, CUT4=cut4_v_err, CUT6=cut6_v_err)

    pos_file <- paste("out/pos_err_", dist, ".csv", sep="")
    vel_file <- paste("out/vel_err_", dist, ".csv", sep="")

    write.csv(r_err, pos_file, row.names = FALSE, quote=FALSE)
    write.csv(v_err, vel_file, row.names = FALSE, quote=FALSE)

}

process_rmse("gauss")
process_rmse("pearson")

process_box("gauss")
process_box("pearson")


fn.cd38 = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_cd38_ge_sig_score_subjects.txt")
fn.pb = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_PB.DC_SLEDAI_corr_score.txt")

df.cd38 = fread(fn.cd38)
df.pb = fread(fn.pb)

fn.pg = file.path(PROJECT_DIR, "data", "SLE", "phenotypes", "SLE_SUBJECT_PG.txt")
df.pg = read_tsv(fn.pg)

PG.group.names = c("SLE patients with plasmablast signature during flare", "Other SLE patients")

df = inner_join(df.cd38, df.pb, by="SUBJECT") %>%
  dplyr::filter(!is.na(PG)) %>%
  mutate(PG.group = ifelse(PG %in% 2:4, PG.group.names[1], PG.group.names[2])) %>%
  mutate(PG = factor(PG), PG.group = factor(PG.group, levels=PG.group.names))

df.cc.s = df %>% split(.$PG.group) %>%
  map(~cor.test(.$CD38_score_mean, .$PB_SLEDAI_corr_score, method="spearman")) %>%
  map_df(~data.frame(Spearman.rho=.$estimate, Spearman.p = .$p.value)) %>%
  mutate(PG.group = levels(df$PG.group) %>% factor())

df.cc.p = df %>% split(.$PG.group) %>%
  map(~cor.test(.$CD38_score_mean, .$PB_SLEDAI_corr_score, method="pearson")) %>%
  map_df(~data.frame(Pearson.cor=.$estimate, Pearson.p = .$p.value)) %>%
  mutate(PG.group = levels(df$PG.group) %>% factor())

df.cc = inner_join(df.cc.p[,c(3,1,2)], df.cc.s, by="PG.group")
fn.out = file.path(PROJECT_DIR, "generated_data/SLE/SLE_PB.DC.corr_vs_CD38.mean.score_2groups.txt")
fwrite(df.cc, fn.out, sep="\t")


#!/usr/bin/env Rscript
# Example: Rscript ./UKBBurden/scripts/gene_burden_test.r -c ./covar/version2/ukbb_covar_v2_both.csv -g ./gene_burden/cnv_burden_v1/rare_del_burden/rare_del_burden_v1_c15.tsv -p ./phenotypes/quant-blood_counts-c100081/quant-lymphocyte_count_f30120-191546.txt -d quant -n 8

library(data.table)
library(foreach)
library(parallel)
library(speedglm)
library("optparse")

option_list = list(
    make_option(c("-c", "--covar"), type="character", default=NULL,
              help="covariate file path", metavar="path"),
    make_option(c("-g", "--geno"), type="character", default=NULL,
              help="genotype file path", metavar="path"),
    make_option(c("-p", "--pheno"), type="character", default=NULL,
              help="phenotype file path", metavar="path"),
    make_option(c("-d", "--dtype"), type="character", default=NULL,
              help="data type (quant or binary)", metavar="char"),
    make_option(c("-o", "--out"), type="character", default="out.txt",
              help="output file name [default = %default]", metavar="char"),
    make_option(c("-n", "--nfork"), type="integer", default=1,
              help="number of forks for parallel [default = %default]", metavar='int')
);

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);

## Helper function
# RankNorm() from package RNOmni
RankNorm <- function (u, k = 0.375)
{
  if (!is.vector(u)) {
    stop("A numeric vector is expected for u.")
  }
  if ((k < 0) || (k > 0.5)) {
    stop("Select the offset within the interval (0,0.5).")
  }
  if (sum(is.na(u)) > 0) {
    stop("Please exclude observations with missing measurements.")
  }
  n <- length(u)
  r <- rank(u)
  out <- qnorm((r - k)/(n - 2 * k + 1))
  return(out)
}

## Input
# covar <- fread('./covar/version2/ukbb_covar_v2_both.csv')
# geno <- fread('./gene_burden/cnv_burden_v1/rare_del_burden/rare_del_burden_v1_c15.tsv', header=T)
# pheno <- fread('./phenotypes/quant-blood_counts-c100081/quant-lymphocyte_count_f30120-191546.txt', header=T, col.names = c('eid', 'y'))
# dtype <- 'quant'

covar <- fread(opt$covar, header=T)
geno <-  fread(opt$geno, header=T)
pheno <- fread(opt$pheno, header=T, col.names = c('eid', 'y'))
dtype <- opt$dtype
out <- opt$out

setnames(geno, 1, 'Gene') # The first one must be 'Gene'

pheno <- merge(pheno, covar, by='eid')
pheno[, eid:=as.character(eid)]
setkey(pheno, eid)

keep <- intersect(pheno$eid, colnames(geno))
pheno <- pheno[keep, ]

## Subsampling for binary to 1:99 case:control
if (dtype == 'binary') {
    n_case <- pheno[y==1, .N]
    n_ctrl <- pheno[y==0, .N]
    if (n_ctrl/n_case > 99) {
        set.seed(1993)
        max_ctrl <- n_case * 99
        keep <- c(pheno[y==1, eid], pheno[y==0, sample(eid, max_ctrl)])
        pheno <- pheno[keep, ]
    }
}

## Normalize y for quant
if (dtype == 'quant') pheno[, y:=RankNorm(y)]

cat("Number of samples:", length(keep), '\n') # No. of samples used

geno_keep = as.matrix(geno[, -1])[,keep]
rownames(geno_keep) <- geno$Gene

# Run test in parallel
cl <- parallel::makeForkCluster(opt$nfork)
doParallel::registerDoParallel(cl)

# loop over genes
res <- foreach(g=geno$Gene, .combine='rbind') %dopar% {
    pheno[, x:=geno_keep[g, ]]
    hom_ref_count = pheno[x==0, .N]
    het_alt_count = pheno[x==1, .N]
    hom_alt_count = pheno[x==2, .N]

    if (dtype == 'quant') {
        fit <- speedlm.fit(y = pheno$y, X = as.matrix(pheno[, .SD, .SDcols=-c('y', 'eid')]))
    }

    if (dtype == 'binary') {
        fit <- glm(data = pheno[, -1], formula = y ~ ., family = 'binomial')
    }

    coef_tb <- coef(summary(fit))
    if ('x' %in% rownames(coef_tb)) {
        ret <- c(g, coef_tb['x', ], hom_ref_count, het_alt_count, hom_alt_count)
    } else {
        ret <- c(g, rep(NA, 4), hom_ref_count, het_alt_count, hom_alt_count)
    }

    ret
}

res = setDT(as.data.frame(res))
if (dtype == 'binary') colnames(res) <- c('Gene', 'EST', 'SE', 'T', 'P', 'HOM_REF', 'HET_ALT', 'HOM_ALT')
if (dtype == 'quant') colnames(res)  <- c('Gene', 'EST', 'SE', 'Z', 'P', 'HOM_REF', 'HET_ALT', 'HOM_ALT')

fwrite(res, out, sep='\t')

parallel::stopCluster(cl)


#this function takes a dataframe which must contain the following columns (order is not important, names are)
#Year, Sex, Length, Landings, Discards, Catch
#function also takes a name for the graph title,  minimum and maximum years.
#by default the function bins length classes into 2mm slots - if you want anything different then change the line bin<-2 to something else!
plot.ld <- function(df, area, miny, maxy, mls, reference){
par(lwd=2)
bin <- 2
df$length2 <- df$Length+(ifelse(floor(df$Length/bin)-df$Length/bin==0,0,-1))

df2<-tapply.ID(df, "Landings", c("Year", "Sex", "length2"), "sum", "Landings")

df2$Discards<-tapply.ID(df, "Discards", c("Year", "Sex", "length2"), "sum", "temp")[,"temp"]
df2$Catch<-tapply.ID(df, "Catch", c("Year", "Sex", "length2"), "sum", "temp")[,"temp"]

df2$Length <- df2$length2+1
df<-df2
tab <- with(df, tapply(Catch, list(Year, Sex), max))
vec <- vectorise.names(tab, c("max", "Year", "Sex"))

ld2 <- merge(df, vec)
ld2$scaled.catch <- ld2$Catch/ld2$max
ld2$scaled.landing <- ld2$Landings/ld2$max
ld2$time.catch <- ld2$Year+(.9999*ld2$scaled.catch)
ld2$time.landing <- ld2$Year+(.9999*ld2$scaled.landing)

#stack the catch and landings together, to use cbind the columns need to be the same name, so make a temp data frame and rename time.landing time.catch
ld2 <- ld2[ld2$scaled.catch>0 & ld2$Year>=miny & ld2$Year<=maxy,]
ld2 <- sort.data.frame(~ Year+ Sex+ Length, ld2)
length(ld2$Year)
temp <- as.data.frame(ld2$Year)
names(temp)[1] <- "Year"
temp$Sex <- ld2$Sex
temp$Length <- ld2$Length
temp$time.catch <- ld2$time.landing
temp$type <- rep("land", length(temp$Year))

ld2$type <- rep("catch", length(ld2$Year))
ld3 <- rbind(ld2[,c("Year", "Sex", "Length","type","time.catch")],temp)
ld3 <- sort.data.frame(~Sex +type + Year+ Length, ld3)
length(ld2[,1])
length(ld3[,1])

#set the colours to be black and white
t <- trellis.par.get()$superpose.line
t$col <- rep("black", length(unique(ld3$Year)))
trellis.par.set("superpose.line",t)

###############################################
#here's the plot
plot1 <- with(ld3, xyplot( time.catch~Length|Sex, groups=Year, panel=function(x,y, subscripts,groups,...){
#panel.grid(h=-1, v=-1)
len <- length(x)
#print(len)
#print(x,y)
len2 <- len/2
#panel.superpose(x, y, subscripts, groups, type="l", lty=1)
panel.superpose(x[1:len2], y[1:len2], subscripts, groups, type="l", lty=2, lwd=1.8)
panel.superpose(x[len2+1:len], y[len2+1:len],subscripts, groups, type="l", lty=1, lwd=1.8)
if(reference>0) panel.abline(v=reference, lty=4)
panel.abline(v=mls, lty=3)

#create a df with the input data
df <- as.data.frame(y[len2+1:len])
names(df)[1] <- "freq"
df$len <- x[len2+1:len]
df$year <- floor(df$freq)
df$freq2 <- df$freq-df$year
df$lenfreq <- df$freq2*df$len
#print(df)

#plot the mean for the landings
m <-tapply.ID(df, c("lenfreq","freq2"), "year", "sum", c("meanlen", "totfreq"))
m$Mean.Land.Length <- m$meanlen/m$totfreq
m$year <- as.numeric(m$year)+0.5
panel.lines(m$Mean.Land.Length, m$year, type="l", lty=1, lwd=2, col="black")
#print(m[,c("year", "Mean.Land.Length")])

#now do the catches - all lengths
df <- as.data.frame(y[1:len2])
names(df)[1] <- "freq"
df$len <- x[1:len2]
df$year <- floor(df$freq)
df$freq2 <- df$freq-df$year
df$lenfreq <- df$freq2*df$len

#plot the mean for the catches
m2 <-tapply.ID(df, c("lenfreq","freq2"), "year", "sum", c("meanlen", "totfreq"))
m2$Mean.Catch.Length <- m2$meanlen/m2$totfreq
m2$year <- as.numeric(m2$year)+0.5
panel.lines(m2$Mean.Catch.Length, m2$year, type="l", lty=2, lwd=2, col="black")
m3 <- merge(m[,c("year", "Mean.Land.Length")], m2[,c("year", "Mean.Catch.Length")])
#print(m3)

#tab <- with(df,tapply(lenfreq, year, sum))
#meanvec <- vectorise.names(tab, c("meanlen", "year"))
#tab <- with(df,tapply(freq2, year, sum))#
#vec<- vectorise.names(tab, c("totfreq", "year"))
#m <- merge(meanvec, vec)
#m$meanval <- m$meanlen/m$totfreq
#m$year <- as.numeric(m$year)+0.5
#panel.lines(m$meanval, m$year, type="l", lty=2, col="red",lwd=2 )

},main=paste("Length frequencies for catch (dotted) and landed(solid):\n Nephrops in ", area, sep=""),
                          sub=(ifelse(reference>0, paste("Mean length of landings and catch vertically \n MLS (", mls, "mm) and ", reference, "mm levels displayed", sep=""),paste("Mean length of landings and catch vertically \n MLS (", mls, "mm) indicated", sep="")))
                          , xlab="length",ylab="Year", layout=c(2,1)))

print(plot1)
}


#!/usr/bin/env Rscript
#autor:      Joao Sollari Lopes
#local:      University of Reading, Reading, UK
#Rversion:   3.2.3
#criado:     01.03.2010
#modificado: 20.11.2017

# @arg data_file - file with summary of 'real' data (.trg)
# @arg rej_file  - file with rejection step results (.rej)
# @arg pri_file  - file with sample of priors (.pri)
reg_step <- function(data_file , rej_file , pri_file){

	#import locfit library
	library(locfit)

	#import Mark Beaumont's scripts
	source("make_pd2.r")
	source("loc2plot_d.r")

	#demographic parameters' priors (minimum and maximum values)
	minNe <- 0
	maxNe <- 50000
    trueNe <- 30000

	#import the .rej file
	abc.rej <- data.matrix(read.table(rej_file))

	#import the .pri files
	priors <- data.matrix(read.table(pri_file))

	#import the .trg files
	target <- data.matrix(read.table(data_file))

	# Plot line for effective size of population 1 and save it in a .eps file
	abc.reg.ne <- makepd4(target,abc.rej[,6],abc.rej[,7:9],tol=1,rej=F,transf="none")
    fname <- "../results/Ne_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.ne$x,weight=abc.reg.ne$wt,xlim=c(minNe,maxNe)),main="prior (black) and posterior (blue) distributions",xlab="Ne",col="blue")
	lines(locfit(~priors[,6],xlim=c(minNe,maxNe)),col="black")
    abline(v=trueNe,lty=2,col="black")
	dev.off()

	# Calculate mode and credible intervals for effective size of population 1
	print(loc1statsx(x=abc.reg.ne$x,wt=abc.reg.ne$wt, prob=0.10,alpha=1.0,xlim=c(minNe,maxNe)))
	print("Ne done.")

}

args = commandArgs(trailingOnly=TRUE)
reg_step(args[1],args[2],args[3])


set.seed(42)

# read training data

# note the na.strings so that the 1 empty entry is picked up as an NA
train <- read.csv('data/train.csv', sep=',', na.strings=c(''))
# drop some columns
train <- subset(train, select = -c(Cabin, Ticket, Name, Fare))
# correct some column types
train$Sex <- as.factor(train$Sex)
train$Embarked <- as.factor(train$Embarked)
train$Survived <- as.factor(train$Survived)

library(Hmisc)
train.imp = train

train.imp$Age <- impute(train$Age, 'random')
train.imp$Age <- impute(train$Age, median)
train.imp$Age <- impute(train$Age, min)
train.imp$Age <- impute(train$Age, max)
train.imp$Age <- impute(train$Age, -10)
train.imp$Age <- impute(train$Age, mean)
# or using with
#   train.imp$Age <- with(train, impute(Age, mean))
train.imp$Embarked <- impute(train.imp$Embarked, median)

# custom replacement function, impute uses the result in order
custom <- function(x) {
	m = is.na(x)
	# you can sum booleans to obtain a count of the true values
	# return (rep(1, each=sum(m)))
	return (seq(1, sum(m)))
}
train.imp$Age <- impute(train$Age, custom(train$Age))

summary(train.imp)


#######################################################################
## Model comparison and diagnostics
## implement a way to compute loo using sparse model design matrices
## (because we have a *lot* of observations and a *lot* of groups so using standard matrices eats all the memory)
##
# this function calculates the pointwise log-likelihoods
# here, data and draws will be sparse matrices, so need to convert them
# see the 'loo' package documentation for futher info about this kind of function
llfun = function(i, data, draws) {
  #draws = as.matrix(draws)  # maybe better to do this once, before calling the function - rather than on every iteration within the function...

  # convert the sparse matrix containing the data into a normal matrix and chuck out the 'y' and 'trials' columns
  d2 = data[, -which(colnames(data) %in% c("y", "trials"))]
  d2 = as.matrix(d2)

  # calculate the probabilities for the current observation
  eta = draws %*% d2
  eta = plogis(eta)
  # calculate log-likelihood
  dbinom(data[,"y"], size = data[,"trials"], prob = eta, log = TRUE)
}

#' This function takes a model fit with rstanarm and creates the 'args' parameter for loo.function()
#'
#' @param m stanreg, The model
#' @return nlist of arguments (data, draws, S, N)
get_args = function(m) {
  library(Matrix)

  # make a sparse data matrix containing the fixed and random effects
  x = get_x(m)
  data = Matrix(data = c(y=d.long$GiftGiven, trials=rep(1, nrow(d.long)), x=x), ncol=2+ncol(x), dimnames=list(NULL, c("y", "trials", dimnames(x)[[2]])))
  z <- get_z(m)
  data = Matrix::cBind(data, z)

  # make a sparse matrix of draws from the posterior distribution
  post = Matrix(as.matrix(m))
  draws = post[, seq_len(ncol(x)), drop = FALSE]
  b <- post[, rstanarm:::b_names(colnames(post)), drop = FALSE]
  draws <- Matrix::cBind(draws, b)
  draws = as.matrix(draws)

  args = nlist(data = data, draws = draws, S = NROW(draws), N = nrow(data))
  args
}

#' Calculates loo using sparse matrices
#'
#' @param m stanreg, The model
#' @return loo object
#'
loo_sparse = function(m, cores=1) {
  args = get_args(m)
  # calculate loo for this model
  loo_out = loo(llfun, args = args, cores=cores)
  attr(loo_out, "model")  = deparse(substitute(m))
  return(loo_out)
}

#' Calculate log-likelihood matrix using sparse model design matrices
#'
#' @seealso get_args, llfun
#' @param object stanreg, The model, fit with rstanarm
#'
#' @return matrix of log-likelihoods
#'
log_lik.sparse <- function(object) {
  args <- get_args(object)

  out <- vapply(
    seq_len(args$N),
    FUN = function(i) {
      as.vector(llfun(
        i = i,
        data = args$data[i,, drop = FALSE],
        draws = args$draws
      ))
    },
    FUN.VALUE = numeric(length = args$S)
  )
  colnames(out) <- rownames(model.frame(object))
  return(out)
}

#' A tweak of loo::model_weights() for cases where `loo` objects have already been calculated for models
#'
#' All params apart from `loo_list` are the same as in loo::model_weights()
#'
#' @param loo_list list, A bunch of `loo` objects
#' @param method
#' @param BB
#' @param BB_n
#' @param alpha
#' @param seed
#' @param optim_method
#'
#' @inheritParams loo::model_weights
#' @seealso loo::model_weights
#'
#' @return A vector of optimal model weights.
#'
model_weights.loo <-function(loo_list, method="stacking",BB=T,BB_n=1000, alpha=1, seed=NULL, optim_method="BFGS")
{
  if (!method %in%c("stacking","pseudobma") )
    stop("Must specify a method in stacking or pseudobma .")
  K<-length(loo_list)                #number of models
  if (K==1)
    stop("Only one model is found.")

  N <- nrow(loos[[1]]$pointwise)       #number of data points
  lpd_point<-matrix(NA,N,K)            #point wise log likelihood
  elpd_loo<-rep(NA,K)
  for( k in 1:K){
    #log_likelihood<- log_lik_list[[k]]
    L <- loo_list[[k]]
    lpd_point[,k] <- L$pointwise[,1]    #calculate log(p_k (y_i | y_-i))
    elpd_loo[k]<-L$elpd_loo
  }
  ## 1) stacking on log score
  if (method =="stacking"){
    w_stacking <- loo::stacking_weight(lpd_point, optim_method=optim_method)
    cat("The stacking weights are:\n")
    print(rbind(paste("Model"  ,c(1:K) ), round(w_stacking*100 )/100))
    return(w_stacking)
  }
  else
    if (method =="pseudobma"){
      uwts <- exp( elpd_loo - max( elpd_loo))
      w_loo1 <- uwts / sum(uwts)
      if(BB==F){
        cat("The Pseudo-BMA weights are:\n")
        print(rbind(paste("Model"  ,c(1:K) ),  round(w_loo1*100 )/100))
        return(w_loo1)
      }
      if(BB==T){
        w_loo2  <- loo::pseudobma_weight(lpd_point, BB_n,alpha, seed)
        cat("The Pseudo-BMA+ weights using Bayesian Bootstrap  are:\n ")
        print(rbind(paste("Model",c(1:K) ),  round(w_loo2*100 )/100))
        return (w_loo2 )
      }
    }
}

#' Model comparison with delta_elpd and delta_se
#'
#' @param ... At least two objects returned by \code{\link{loo}} or
#'   \code{\link{waic}}.
#'
#' @return A data.frame of model comparison info.
#'
#' @details See \code{compare_models} in \pkg{rstanarm} and \code{compare} in \pkg{loo}.
#'
compare_models_delta <- function(...)
{
  L = list(...)
  #L = list(loo.herd.null, loo.herd.control, loo.herd.deg, loo.herd.deg_int, loo.herd.btwn, loo.herd.eigen)

  if (!all(sapply(L, function(x) inherits(x, "loo"))))
    stop("All inputs should have class 'loo'.")
  if (length(L) <= 1L)
    stop("'compare' requires at least two models.")

  # retrieve model names from loo objects
  mnames = sapply(L, function(x) attr(x, "name"))
  # mnames <- as.character(match.call(expand.dots = TRUE))[-1L]

  if (length(mnames)==0)
    mnames <- paste0("model", seq_along(L))

  # compute SE of differences between adjacent models from top to bottom in ranking
  # this part was shamelessly nabbed and tweaked from compare() in Richard McElreath's rethinking package
  dSE.matrix <- matrix( NA , nrow=length(L) , ncol=length(L) )

  colnames(dSE.matrix) <- mnames
  rownames(dSE.matrix) <- mnames

  for ( i in 1:(length(L)-1) ) {
    for ( j in (i+1):length(L) ) {
      # get pointwise looic/waic from each loo object
      loo_ptw1 <- L[[i]]$pointwise[, grep("^elpd", dimnames(L[[i]]$pointwise)[[2]])]
      loo_ptw2 <- L[[j]]$pointwise[, grep("^elpd", dimnames(L[[j]]$pointwise)[[2]])]

      dSE.matrix[i,j] <- as.numeric( sqrt( length(loo_ptw1)*var( loo_ptw1 - loo_ptw2 ) ) )
      dSE.matrix[j,i] <- dSE.matrix[i,j]
    }#j
  }#i

  IC.list <- abs( unlist( sapply(L, function(x) x[ grep("^elpd", names(x)) ]) ) )
  dIC <- IC.list - min( IC.list )

  topm <- which( dIC==0 )
  dSEcol <- dSE.matrix[,topm]

  # w.IC <- rethinking::ICweights( IC.list )  # use rethinking package to calculate model weights

  result <- data.frame( delta=dIC, d_se=dSEcol )
  rownames(result) <- mnames
  result <- result[ order( result[["delta"]] ) , ]

  if (length(L)==2)
  {
    # two loo objects: produce a full model comparison table
    # (this part shamelessly lifted from loo::compare())
    sel <- grep("pointwise|pareto_k", names(L[[1L]]), invert = TRUE)
    x <- sapply(L, function(x) unlist(x[sel]))

    colnames(x) <- mnames
    rnms <- rownames(x)
    comp <- x
    patts <- c("^waic$|^looic$", "^se_waic$|^se_looic$", "elpd", "p_")
    row_ord <- unlist(sapply(patts, function(p) grep(p, rownames(comp))),
                      use.names = FALSE)
    col_ord <- order(x[grep("^elpd", rnms), ], decreasing = TRUE)
    comp <- as.data.frame( t(comp[row_ord, col_ord]) )
  } else {
    # three or more loo objects, so use rstanarm's comparison function as is
    #comp <- as.data.frame( rstanarm::compare_models( ... ) )
    comp <- as.data.frame( loo::compare( x=L ) )
  }

  # stick the deltas and weights on the end (in the correct order)
  #mnames_sorted = row.names(comp)
  comp <- dplyr::bind_cols(comp, result)
  rownames(comp) <- rownames(result)
  comp

  # rm(L, mnames, dSE.matrix, loo_ptw1, loo_ptw2, IC.list, dIC, topm, dSEcol, result, comp, i,j)
}


sumQuarerly<-T  # use sum of quarterly M2, or calc M2 from annual numbers dead.
first.year.on.plot<-1974
last.year.on.plot<-2050

if (sumQuarerly) { # calc M2 as sum of quarterly M2
     a<-Read.summary.data(read.init.function=F)
     a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & M2>=0),
               select=c(Species, Year,Age,M2,M1) ,drop=T)
  values<-tapply(a$M1+a$M2,list(a$Year,a$Age,a$Species),sum)
    values2<-tapply(a$M1+a$M2,list(a$Species,a$Year,a$Age),sum)

} else {  # calc M2 an an annual basis

     a<-Read.summary.data(read.init.function=F)
     a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & Z>0))
     a<-data.frame(Year=a$Year, Species=a$Species, Age=a$Age,Z=a$Z,
           dead=a$N.bar*a$Z,deadm=a$N.bar*(a$M2+a$M1))

  list.ZF<- list(a$Year,a$Age,a$Species)
  dead<-tapply(a$dead,list.ZF,sum,na.rm=T)
  deadM<-tapply(a$deadm,list.ZF,sum)
  Z<-tapply(a$Z,list.ZF,sum)
  values2<-deadM/dead*Z
}

round(values,3)
ftable(round(values2,3))


obtainthreshold <- function(env, Stocks, startindx, lookback, jump, longdur, shortdur){

  #longdur = 60
  #shortdur = 40
  iterations = 50

  results = data.frame(Date = as.character(), threshold = as.double(), error = as.double(), difference = as.double())

  IPR_df <- data.frame(Date = as.character(), Symbol = as.character(), IPR = as.integer(), Diff = as.double())

  #Stocks <- c("AC", "BNS", "BMO")
  EquityList <- c("tick", "ask", "bid")

  stock_data <- paste(Stocks[1],EquityList[1],sep="_")
  # Define time period
  starttime = startindx - lookback
  totaltime <- env[[stock_data]][["Date"]][(startindx - lookback):(startindx-1)]
  actiontime <- totaltime[seq(1,lookback,30)] # Times to perform active portion
  actiontime <- actiontime[-c(which(strftime(actiontime, format="%H:%M:%S") == "09:30:00",arr.ind=TRUE))]
  actiontime <- actiontime[-c(which(strftime(actiontime, format="%H:%M:%S") == "10:00:00",arr.ind=TRUE))]
  looprow <- length(actiontime) # Assuming starttime and endtime are times in seconds
  for (j in 1:looprow) {
    IPR_df <- data.frame()
    for (stock in Stocks){
      # Calculate IPR and difference
      stock_data <- paste(stock,EquityList[1],sep="_")
      tick_data <- env[[stock_data]]
      currtime <- starttime+30*j + 30 ####################### SUPER HARD CODE ALERTTTT ##############
#       P_asterix <- tick_data[currtime-1, "LAST_PRICE"]
#       P_asterix_j_date <-  tick_data[currtime - jump-1, "LAST_PRICE"]
#       start_row <- 1
#       price_estimates <- data.frame(Price = tick_data[starttime:currtime, "LAST_PRICE"])
#       ret1 <- return_and_stdev(price_estimates)$ret
#       stdev <- return_and_stdev(price_estimates)$stdev
#       z <- (log(P_asterix/P_asterix_j_date) - jump * ret1) / (sqrt(jump * stdev))
      weights <- c(1/3,1/3,1/3)
      # IPR <- lowpassfilter(tick_data, currtime, jump, start_row, weights, 30)
      #start1 <- Sys.time()
      IPR <- IPRcalc(tick_data, currtime, jump, starttime)
      diff = (SMA(currtime, shortdur,tick_data$LAST_PRICE) - SMA(currtime, longdur,tick_data$LAST_PRICE))/tick_data$LAST_PRICE[currtime]
      # diff = (SMA(currtime, shortdur,tick_data$LAST_PRICE) - SMA(currtime, longdur,tick_data$LAST_PRICE))
      IPR_df <- rbind(IPR_df, data.frame(Date = actiontime[j], Symbol = stock, IPR = IPR, Diff = diff))
      #print ("IPR Calculation:")
      #print (Sys.time() - start1)
    }
    # Allocate based on allocation function
    threshold <- 0.5
    direct = 1
    prevreturn = Inf
    for (k in 1:iterations){
      returns <- data.frame(Symbol = as.character(), return1 = as.double(), wdiff = as.double())
      currcash = 100000
      pastportvalue = 0
      futureportvalue = 0
      allocs = data.frame()
      start1 <- Sys.time()
      for (b in 1:nrow(IPR_df)){
        # Determine direction
        stock = as.character(IPR_df$Symbol[b])
        stock_data <- paste(stock,EquityList[1],sep="_")
        tick_data <- env[[stock_data]]

        if (IPR_df[b, "IPR"] < threshold){
          cashalloc = -(0.5/threshold)*(IPR_df[b, "IPR"]) + 0.5
        } else {
          cashalloc = -(0.5/(1-threshold))*(IPR_df[b, "IPR"]) + (-0.5*(1+1/(threshold-1)))
        }

        allocs = rbind(allocs, data.frame(Symbol = stock, Allocation = cashalloc))
        allocvalue = cashalloc * currcash
        futurequant<- floor(allocvalue/tick_data[currtime,"LAST_PRICE"])
        totalalloc = futurequant*tick_data[currtime,"LAST_PRICE"]
        stockreturn = tick_data[currtime + 30,"LAST_PRICE"]/ tick_data[currtime,"LAST_PRICE"]
        finalreturn = totalalloc * (stockreturn - 1)
        returns <- rbind(returns, data.frame(Symbol = stock, return1 = finalreturn, wdiff = cashalloc * IPR_df[b,"Diff"]))
      }
      #print ("Allocation Calculation")
      #print (Sys.time() - start1)
      bound <- 5
      portreturn = sum(returns["return1"])

      if (abs(sum(returns["return1"])) < bound) {
          results<-rbind(results,data.frame(Date = actiontime[j], threshold = threshold, error = portreturn, difference = sum(returns["wdiff"])))
          break
      } else {
        increment = log(abs(sum(returns["return1"])))/100
        if (abs(prevreturn) - abs(portreturn) > 0) {
          threshold <- threshold + direct * increment
        } else {
          direct = -direct
          threshold <- threshold + direct * increment
        }
        prevreturn = portreturn
      }
      if (k == iterations){
        results<-rbind(results,data.frame(Date = actiontime[j], threshold = threshold, error = portreturn, difference = sum(returns["wdiff"])))
      }
    }
  }
  results <- results[(-c(which(results$difference < (quantile(results$difference)[2] - IQR(results$difference)) |
                                results$difference > (quantile(results$difference)[4] + IQR(results$difference)),arr.ind=TRUE))),]
  results <- results[(-c(which(abs(results$error) > bound,arr.ind=TRUE))),]
  reg <- lm(results$threshold~results$difference)
  #plot(results$difference, results$threshold)
  #abline(reg)
  return (reg$coefficients)
}


\name{MSRL.coef}
\alias{MSRL.coef}
\title{Extract estimated regression coefficients from the multivariate square-root lasso.}
\usage{
MSRL.coef(fit, lambda = NULL)
}
\arguments{
	\item{fit}{An object of class MSRL obtained from MSRL.cv}
	\item{lambda}{The value of the tuning parameter at which to make predictions. Must belong to the set fit\eqref{\$}lambda.vec}.}
 % \item{time}{An \eqn{n}-variate or containing the failure/censoring times on the original scale -- not log-transformed.}
 %  \item{status}{An \eqn{n}-variate binary vector of same length as time: 0 indicates censored, 1 indicates failure. }
 %  \item{Z}{An \eqn{n \times q} design matrix for the linear mean function. Note that the first column should contain all ones to account for the intercept. We recommend construction using \code{model.matrix}. }
 %  \item{K}{Candidate kernel matrices in the form of an array of dimension \eqn{n \times n \times M}. The algorithm will work best if these kernels have diagonal entries on similar scales. }
 %  \item{tol}{The convergence tolerance. Default is \code{1e-7}.}
 %  \item{max.iter.MM}{The maximum number of iterations for the inner M-step algorithm.}
 %  \item{max.iter}{The maximum number of total EM-iterations.}
 %  \item{kern.type}{A character argument that can be set to either \code{K+I} or \code{multi-K}, indicating which algorithm to use. We highly recommend using \code{multi-K} in all cases, although if \eqn{M=1}, \code{K+I} can be faster, but less stable.}
 %  \item{quiet}{\code{TRUE/FALSE} -- print algorithm progress?}
 %  \item{initializer}{Only used when \code{kern.type = "multi-K"}: either \eqn{0,1} indicating the type of initialization used for the Monte-Carlo EM. The default is 0,  sets all variance components equal and gets an initial estimate of \eqn{\hat{\beta}} using the updating equation from Algorithm 2. The code 1 which fits a variance components model to the IPW-mean-imputed dataset.}
 %  \item{max.samples}{An upper bound on \eqn{s_k}, the Monte-Carlo sample size for the \eqn{k}th iteration. Note that the final imputed values of log-survival for censored subjects will be the average of \code{max.samples} Monte-Carlo draws.}
}
\value{
	\item{beta0}{The estimated intercept at the tuning parameter value \eqn{\lambda}, the third input argument.}
	\item{beta}{The estimated regression coefficient matrix at the tuning parameter value \eqn{\lambda}, the third input argument.}
  %  \item{beta}{\eqn{\hat{\beta}}: The estimated regression coefficient vector corresponding to the columns of \code{Z}. }
  % \item{sigma2}{\eqn{\hat{\sigma}^2}: The estimated variance components: a vector of length \eqn{M+1}, with the final element corresponding to the variance of \eqn{\epsilon}. }
  % \item{Tout}{The log-failure and imputed log-failure times obtained from our MCEM algorithm. These are primarily to be used in the prediction function.}
  % \item{Yimpute}{The mean-imputed values of the training time-to-failures based on the method of Datta et al (2005). }
}

\description{
  Extract estimated regression coefficients from the multivariate square-root lasso.
}


#' Runs cross-validation of Random Forests classification
#'
#' @param x A matrix of numeric predictors
#' @param y A factor or logical of responses
#' @param nfolds number of cross-validation folds (nfolds==-1 means leave-one-out)
#' @param folds optional, if not \code{NULL} then uses these fold assignments (one fold index for each row in \code{x})
#' @param verbose Use verbose output
#' @param ... additional parameters for randomForest
#'
#' @return
#'  \item{y}{Observed values}
#'  \item{predicted}{CV predicted values}
#'  \item{probabilities}{CV predicted class probabilities (or NULL if unavailable)}
#'  \item{confusion.matrix}{Confusion matrix (true-by-predicted)}
#'  \item{nfolds}{Number of folds used (or -1 for leave-one-out)}
#'  \item{params}{List of additional parameters, if any}
#'  \item{importances}{Feature-by-fold matrix of importances of features (mean decrease in accuracy) across folds}
#'  \item{final.model}{Final random forests model trained on whole data set}
#' @examples
#' # generate fake data: 50 samples, 20 variables
#' x <- matrix(rnorm(2000),100)
#' rownames(x) <- sprintf('Sample%02d',1:100)
#' colnames(x) <- sprintf('Feature%02d',1:20)
#' # generate fake response variable, function of columns 1-5 plus noise
#' y <- rowSums(sweep(x[,1:5],2,runif(5),'*')) + rnorm(100,sd=.5)
#' # y is now binary response variable
#' y <- factor(y > median(y))
#' names(y) <- rownames(x)
#'
#' # 10-fold cross validation, returning predictions
#' res.rf <- rf.cross.validation(x,y2)
#'
#' # plot importance of top ten variables
#' sorted.importances <- sort(rowMeans(res.rf$importances), decreasing=TRUE)
#' barplot(rev(sorted.importances[1:10]),horiz=TRUE, xlab='Mean Decrease in Accuracy')
#'
#' # Plot classification ROC curve
#' roc <- probabilities.to.ROC(res.rf$probabilities[,2], y2,plot=TRUE)
#'
#' # Report ROC AUC
#' cat('ROC AUC was:',roc$auc,'\n')
#'

"rf.cross.validation" <- function(x, y, nfolds=10, folds=NULL, verbose=FALSE, ...){
    require('randomForest')
    if(nfolds==-1) nfolds <- length(y)
    if(is.null(folds)) folds <- balanced.folds(y,nfolds=nfolds)
    result <- list()
    result$y <- as.factor(y)
    result$predicted <- result$y
    result$probabilities <- matrix(0, nrow=length(result$y), ncol=length(levels(result$y)))
    rownames(result$probabilities) <- rownames(x)
    colnames(result$probabilities) <- levels(result$y)
    result$importances <- matrix(0,nrow=ncol(x),ncol=nfolds)
    result$errs <- numeric(length(unique(folds)))

    # K-fold cross-validation
    for(fold in sort(unique(folds))){
        if(verbose) cat(sprintf('Fold %d...\n',fold))
        foldix <- which(folds==fold)
        model <- randomForest(x[-foldix,], factor(result$y[-foldix]), importance=TRUE, do.trace=verbose, ...)
        newx <- x[foldix,,drop=F]
        if(length(foldix)==1) newx <- matrix(newx,nrow=1)
        result$predicted[foldix] <- predict(model, newx)
        probs <- predict(model, newx, type='prob')
        result$probabilities[foldix,colnames(probs)] <- probs
        result$errs[fold] <- mean(result$predicted[foldix] != result$y[foldix])
        result$importances[,fold] <- model$importance[,'MeanDecreaseAccuracy']
    }
    rownames(result$importances) <- colnames(x)
    result$err <- mean(result$predicted != result$y)
    result$nfolds <- nfolds
    result$params <- list(...)
    result$confusion.matrix <- t(sapply(levels(y), function(level) table(result$predicted[y==level])))

    # train one final model on the whole data set
    result$final.model <- randomForest(x,result$y)

    return(result)
}

#' Runs cross-validation of LARS regression
#'
#' @param x A matrix of numeric predictors
#' @param y A factor or logical of responses
#' @param nfolds number of cross-validation folds (nfolds==-1 means leave-one-out)
#' @param folds optional, if not \code{NULL} then uses these fold assignments (one fold index for each row in \code{x})
#' @param verbose Use verbose output
#' @param ... additional parameters for lars
#'
#' @return:
#'  \item{y}{Observed values}
#'  \item{predicted}{CV predicted values}
#'  \item{fractions}{Vector of LASSO fractions used across folds}
#'  \item{best.fraction}{Best LASSO fraction used}
#'  \item{MSE}{Mean squared error}
#'  \item{RMSE}{Root mean squared error}
#'  \item{nfolds}{Number of folds used (or -1 for leave-one-out)}
#'  \item{params}{List of additional parameters, if any}
#'  \item{coefficients}{Feature-by-fold matrix of coefficients of features across folds}
#'  \item{final.model}{Final lars model trained on whole data set}
#' @examples
#' # generate fake data: 50 samples, 20 variables
#' x <- matrix(rnorm(2000),100)
#' rownames(x) <- sprintf('Sample%02d',1:100)
#' colnames(x) <- sprintf('Feature%02d',1:20)
#' # generate fake response variable, function of columns 1-5 plus noise
#' y <- rowSums(sweep(x[,1:5],2,runif(5),'*')) + rnorm(100,sd=.5)
#' names(y) <- rownames(x)
#'
#' # 10-fold cross validation with predictions
#' res.lars <- lars.cross.validation(x,y)
#' # plot predictions
#' plot(res.lars$y, res.lars$predicted, xlab="Observed", ylab="Predicted (hold-out)")
#'
#' # correlation
#' cat('Pearson correlation of predictions with truth?\n')
#' print(cor.test(res.lars$y, res.lars$predicted))
#'
#' # plot fraction of times each variable was included in a fold
#' sorted.importances <- sort(rowMeans(res.lars$coefficients > 0), decreasing=TRUE)
#' # bar plot of top ten variables
#' par(mar=c(4.5,6,2,1),las=2) # larger margin on left, perpendicular axis labels
#' barplot(rev(sorted.importances[1:10]),horiz=TRUE, xlab='Frequency of selection')
#'

"lars.cross.validation" <- function(x, y, nfolds=10, folds=NULL, verbose=FALSE, ...){
    require('lars')
    if(nfolds==-1) {
        nfolds <- length(y)
        folds <- 1:length(y)
    } else{
        folds <- sample(rep(1:nfolds,times=ceiling(length(y)/nfolds))[1:length(y)])
    }
    result <- list()
    result$y <- as.numeric(y)
    result$predicted <- result$y
    result$coefficients <- matrix(0,nrow=ncol(x),ncol=nfolds)
    result$fractions <- numeric(length(y))

    # K-fold cross-validation
    for(fold in sort(unique(folds))){
        if(verbose) cat(sprintf('Fold %d...\n',fold))
        foldix <- which(folds==fold)

        # do cv.lars on the training set to choose the best penalty
        cv.res <- cv.lars(x[-foldix,], result$y[-foldix], plot.it=FALSE, ...)
        threshold <- cv.res$index[which.min(cv.res$cv)]
        res <- lars(x[-foldix,], result$y[-foldix])

        # predict on test set
        newx <- x[foldix,,drop=F]
        yhat <- predict(res, newx, mode='fraction',type='fit',s=threshold)$fit

        # extract results
        result$predicted[foldix] <- yhat
        result$coefficients[,fold] <- coef(res,mode='fraction',s=threshold)
        result$fractions[fold] <- threshold
    }
    rownames(result$coefficients) <- colnames(x)
    result$MSE <- mean((result$predicted - result$y)^2)
    result$RMSE <- sqrt(result$MSE)
    result$nfolds <- nfolds
    result$params <- list(...)
    result$best.fraction <- mean(result$fractions)

    # train one final model on the whole data set
    result$final.model <- lars(x,result$y)
    return(result)
}

#' Get balanced folds where each fold has close to overall class ratio. This only works for non-numeric inputs.
#'
#' @param y Vector of classes; should be a factor, logical, or character
#' @param nfolds Number of folds. -1 means leave-one-out
#' @return Numeric vector of fold indices, one for each element of \code{y}
"balanced.folds" <- function(y, nfolds=10){
    if(is.numeric(y)) stop("MWAS balanced.folds function only accepts non-numeric inputs.")
    folds = rep(0, length(y))
    y <- as.factor(y)
    classes = levels(y)
    # size of each class
    Nk = table(y)
    # -1 or nfolds = len(y) means leave-one-out
    if (nfolds == -1 || nfolds == length(y)){
        invisible(1:length(y))
    }
    else{
    # Can't have more folds than there are items per class
    nfolds = min(nfolds, max(Nk))
    # Assign folds evenly within each class, then shuffle within each class
        for (k in 1:length(classes)){
            ixs <- which(y==classes[k])
            folds_k <- rep(1:nfolds, ceiling(length(ixs) / nfolds))
            folds_k <- folds_k[1:length(ixs)]
            folds_k <- sample(folds_k)
            folds[ixs] = folds_k
        }
        invisible(folds)
    }
}

#' Performs ROC analysis (and plot) on probability vector
#'
#' @param p Vector or probabilities of TRUE
#' @param y Logical, factor, or character of TRUE/FALSE
#' @param step.size Increments at which to calculate false and true positive rates
#' @param plot If \code{TRUE} then make a simple ROC curve plot.
#' @param ... Additional parameters to pass to \code{plot} function
#' @return
#'  \item{fprs}{Vector of false positive rates}
#'  \item{tprs}{Vector of true positive rates}
#'  \item{auc}{Area under the curve}
"probabilities.to.ROC" <- function(p,y,step.size=0.01, plot=TRUE,...){
    require('flux')
    y <- as.logical(y)
    fprs <- sapply(seq(1,0,-abs(step.size)), function(xx) mean(p[!y] >= xx))
    tprs <- sapply(seq(1,0,-abs(step.size)), function(xx) mean(p[y] >= xx))
    tprs[fprs > tprs] <- fprs[fprs > tprs]
    auc.res <- auc(fprs, tprs)
    plot(fprs,tprs,type='l', xlab='False Positive Rate',ylab='True Positive Rate',...)

    return(list(fprs=fprs, tprs=tprs, auc=auc.res))
}


x <- c(-8, -3, 9)
pr_1 <- 4
pr_2 <- 2
pr_3 <- pr_1 + pr_2

# Svolgimento
library(MASS)
print(0)
print(fractions(1/pr_3))
a <- x[3]/-(x[1]*pr_1 + x[2]*pr_2 + x[3]*(-pr_3))
print(fractions(a))
print(x[1]^2*(a*pr_1) + x[2]^2*(a*pr_2) + x[3]^2*(1-(a*pr_3)))


# Project: Surveyer
# Description: Package of Land and Engineering Surveying utilities
# Creating design matrix
# Authors: Milutin Pejovic, Milan Kilibarda, Branislav Bajat, Aleksandar Sekulic and Petar Bursac

rm(list = ls())

# Packages
library(tidyverse)
library(magrittr)
library(ggplot2)
library(geomnet)
library(ggnetwork)
library(sf)
library(ggmap)
library(sp)
library(rgdal)
library(leaflet)
library(xlsx)
library(data.table)
library(mapview)
library(mapedit)
library(leaflet.extras)
library(here)
library(matlib)
library(nngeo)

source(here("R/input_functions.r"))
source(here("R/functions.r"))

#================ Milutin =============================================================================

# Examples
vb_points <- readxl::read_xlsx(path = here::here("Data/Input/Without_observations/xlsx/VB.xlsx"), sheet = "Points", col_types = c("text", "numeric", "numeric", "logical", "logical", "logical"))
vb_obs <- readxl::read_xlsx(path = here::here("Data/Input/Without_observations/xlsx/VB.xlsx"), sheet = "Observations", col_types = c("numeric", "text", "text", "logical", "logical", "numeric", "numeric"))
vb <- surveynet.xlsx(points = vb_points, observations = vb_obs, dest_crs = 3857)

ib_points <- readxl::read_xlsx(path = here::here("Data/Input/Without_observations/xlsx/IB.xlsx"), sheet = "Points", col_types = c("text", "numeric", "numeric", "logical", "logical", "logical"))
ib_obs <- readxl::read_xlsx(path = here::here("Data/Input/Without_observations/xlsx/IB.xlsx"), sheet = "Observations", col_types = c("numeric", "text", "text", "logical", "logical", "numeric", "numeric"))
ib <- surveynet.xlsx(points = ib_points, observations = ib_obs, dest_crs = 3857)

# vb
# TODO: Proveriti da li dobro radi za razlicite jedinice. Mislim da ne, posto W ne uzima u obzir jedinice. Takodje, treba dodati opciju
vb.results <- design.snet(survey.net =  vb, result.units = "mm", ellipse.scale = 10, all = TRUE)

vb.results$design.matrices$Qx
vb.results$observations
plot(vb.results$ellipse.net$geometry)
plot(vb.results$observations$geometry, add = TRUE)

# ib
ib.results <- design.snet(survey.net =  ib, result.units = "mm", ellipse.scale = 1, all = FALSE)

plot(ib.results$ellipse.net$geometry)
plot(ib.results$observations$geometry, add = TRUE)
mapview(vb.results$ellipse.net, zcol = 'sp') + mapview(vb.results$observations, zcol = 'rii')

adj.net_spatial_view <- function(ellipses = ellipses, observations = observations){

  #points$fill_p <- "red"
  #points$fill_p[points$Point_object == TRUE] <- "DeepSkyBlue"
  #observations$fill_o <- ifelse(observations$distance == TRUE & observations$direction == FALSE,"LightGoldenRodYellow", ifelse(observations$distance == FALSE & observations$direction == TRUE, "Khaki","orange"))

  adj.net_view <- ggplot(data=observations) +
    #geom_sf(size=1,stroke=1, color = observations$rii)+
    geom_sf(data = observations)+
    geom_sf(data=ellipses,aes(fill = sp))+ #fill = sf.colors(length(ellipses$sp)),breaks = "sp") +
    geom_sf_text(data=ellipses, aes(label=Name,hjust = 2.5, vjust =2.5))+
    xlab("\nLongitude [deg]") +
    ylab("Latitude [deg]\n") +
    ggtitle("Adjusted observational plan - net quality")+
    guides(col = guide_legend())+
    theme_bw()
  return(adj.net_view)
}

adj_net_spatial_view(vb.results$ellipse.net,vb.results$observations)