library(data.table)
library(ggplot2)
library(fixest)

## clean up the environment (just in case)
rm(list=ls())
gc()

"%!in%" <- Negate("%in%")

####################
###  ACLED DATA  ###
####################

## load the data
load("data_violence_acled.RData")

## aggregate by location
xy_dt <- datacomb_dt[,.(incidents=sum(incidents),incidents_dum=mean(incidents_dum),incidents_pop=mean(incidents_pop),price=mean(price),price_ch=mean(price_ch),max_area=mean(max_area),tot_area=mean(tot_area),population_mln=mean(population_mln)),by=.(country,xy)]

count_dt <- datacomb_dt[incidents>0,.(incidents=sum(incidents),incidents_dum=.N)]
baseline_dt <- datacomb_dt[max_area>0,.(incidents_frac=mean(incidents_dum))]

## number of grid cells by country
xysum_dt <- xy_dt[,.(gridcells=.N),by=.(country)]

datacomb_dt <- merge(datacomb_dt,xysum_dt,by="country",all.x = T)

# aggregates by harvest season
seasonal_acled_dt <- datacomb_dt[max_area>0,.(incidents=mean(incidents),incidents_dum=mean(incidents_dum),incidents_pop=mean(incidents_pop),max_area=mean(max_area),tot_area=mean(tot_area),population_mln=mean(population_mln)),by=.(season)]
seasonal_acled_dt <- seasonal_acled_dt[order(season)]

scale_acled <- 100*sd(datacomb_dt[max_area>0]$price_ch)*seasonal_acled_dt$max_area/seasonal_acled_dt$incidents_dum

# the regression
acled_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, datacomb_dt)

acled_sum <- summary(acled_fe,cluster=~xy+country^year)

coef_acled_dt <- as.data.table(acled_sum$coeftable[-1,])
colnames(coef_acled_dt) <- c("est","se","trat","pval")
coef_acled_dt[,`:=`(season=as.factor(0:11))]

coef_acled_dt$est <- coef_acled_dt$est*scale_acled
coef_acled_dt$se <- coef_acled_dt$se*scale_acled
coef_acled_dt$source <- as.factor("ACLED")

rm(list=setdiff(ls(),"coef_acled_dt"))

###################
###  UCDP DATA  ###
###################

## load the data
load("data_violence_ucdp.RData")

## aggregate by location
xy_dt <- datacomb_dt[,.(incidents=sum(incidents),incidents_dum=mean(incidents_dum),incidents_pop=mean(incidents_pop),price=mean(price),price_ch=mean(price_ch),max_area=mean(max_area),tot_area=mean(tot_area),population_mln=mean(population_mln)),by=.(country,xy)]

count_dt <- datacomb_dt[incidents>0,.(incidents=sum(incidents),incidents_dum=.N)]
baseline_dt <- datacomb_dt[max_area>0,.(incidents_frac=mean(incidents_dum))]

## number of grid cells by country
xysum_dt <- xy_dt[,.(gridcells=.N),by=.(country)]

datacomb_dt <- merge(datacomb_dt,xysum_dt,by="country",all.x = T)

# aggregates by harvest season
seasonal_ucdp_dt <- datacomb_dt[max_area>0,.(incidents=mean(incidents),incidents_dum=mean(incidents_dum),incidents_pop=mean(incidents_pop),max_area=mean(max_area),tot_area=mean(tot_area),population_mln=mean(population_mln)),by=.(season)]
seasonal_ucdp_dt <- seasonal_ucdp_dt[order(season)]

scale_ucdp <- 100*sd(datacomb_dt[max_area>0]$price_ch)*seasonal_ucdp_dt$max_area/seasonal_ucdp_dt$incidents_dum

# the regression
ucdp_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, datacomb_dt)

ucdp_sum <- summary(ucdp_fe,cluster=~xy+country^year)

coef_ucdp_dt <- as.data.table(ucdp_sum$coeftable[-1,])
colnames(coef_ucdp_dt) <- c("est","se","trat","pval")
coef_ucdp_dt[,`:=`(season=as.factor(0:11))]

coef_ucdp_dt$est <- coef_ucdp_dt$est*scale_ucdp
coef_ucdp_dt$se <- coef_ucdp_dt$se*scale_ucdp
coef_ucdp_dt$source <- as.factor("UCDP")

rm(list=setdiff(ls(),c("coef_acled_dt","coef_ucdp_dt")))

coeftab_dt <- rbind(coef_acled_dt,coef_ucdp_dt)

## need to do this to join the end-points of the circular plot
extra_rows <- coeftab_dt[season==0]
extra_rows$season <- as.factor(12)

coeftab_dt <- rbind(coeftab_dt,extra_rows)
coeftab_dt <- coeftab_dt[order(source,season)]

coeftab_dt$season <- as.numeric(as.character(coeftab_dt$season))

theme_black <- function(){
  theme(
    panel.background=element_rect(fill="transparent",color=NA),
    panel.grid=element_blank(),
    plot.background=element_rect(fill="transparent",color=NA),
    legend.background=element_rect(fill="transparent",color=NA),
    plot.title=element_text(size=12,colour="gray55",family="sans"),
    axis.title=element_text(size=10,colour="gray55",family="sans"),
    axis.text=element_text(size=8,colour="gray55",family="sans",margin=margin(t=1,r=1,b=1,l=1)),
    axis.line.x=element_line(colour="gray55"),
    axis.line.y=element_line(colour="gray55"),
    axis.ticks=element_line(colour="gray55"),
    legend.position="none",
    legend.title=element_blank(),
    legend.text=element_text(size=10,colour="gray55",family="sans"),
    legend.key.size=unit(.75,'lines'),
    strip.background=element_blank(),
    strip.text=element_text(size=10,colour="gray55",family="sans",face="bold",margin=margin(.1,0,.1,0,"cm"))
  )
}

theme_white <- function(){
  theme(
    panel.background=element_rect(fill="transparent",color=NA),
    panel.grid=element_blank(),
    plot.background=element_rect(fill="transparent",color=NA),
    legend.background=element_rect(fill="transparent",color=NA),
    plot.title=element_text(size=12,colour="gray35",family="sans"),
    axis.title=element_text(size=10,colour="gray35",family="sans"),
    axis.text=element_text(size=8,colour="gray35",family="sans",margin=margin(t=1,r=1,b=1,l=1)),
    axis.line.x=element_line(colour="gray35"),
    axis.line.y=element_line(colour="gray35"),
    axis.ticks=element_line(colour="gray35"),
    legend.position="none",
    legend.title=element_blank(),
    legend.text=element_text(size=10,colour="gray35",family="sans"),
    legend.key.size=unit(.75,'lines'),
    strip.background=element_blank(),
    strip.text=element_text(size=10,colour="gray35",family="sans",face="bold",margin=margin(.1,0,.1,0,"cm"))
  )
}

## circular plot for illustrating the seasonal effect
gg_coef_white <- ggplot(coeftab_dt,aes(x=season,y=est))+
  geom_ribbon(aes(ymin=est-1.96*se,ymax=est+1.96*se,fill=source),alpha=.25)+
  geom_line(aes(color=source),size=.6)+
  geom_hline(yintercept = seq(-16,12,4),color="gray55",size=.3,linetype=3) +
  geom_hline(yintercept = 0,color="gray35",size=.4,linetype=2) +
  scale_x_continuous(breaks = 0:11,labels=c("H(arvest)",paste0("H+",c(1:11))))+
  scale_y_continuous(breaks = seq(-8,8,4))+
  scale_color_manual(values=c("indianred","darkgray"))+
  scale_fill_manual(values=c("indianred","darkgray"))+
  facet_wrap(~source)+
  coord_polar(start=-pi*2)+
  labs(x="months after harvest (H)",y="% change in violence")+
  theme_white()+
  theme(axis.line.x=element_blank(),axis.line.y=element_blank())

gg_coef_black <- ggplot(coeftab_dt,aes(x=season,y=est))+
  geom_ribbon(aes(ymin=est-1.96*se,ymax=est+1.96*se,fill=source),alpha=.25)+
  geom_line(aes(color=source),size=.6)+
  geom_hline(yintercept = seq(-16,12,4),color="gray55",size=.3,linetype=3) +
  geom_hline(yintercept = 0,color="gray55",size=.4,linetype=2) +
  scale_x_continuous(breaks = 0:11,labels=c("H(arvest)",paste0("H+",c(1:11))))+
  scale_y_continuous(breaks = seq(-8,8,4))+
  scale_color_manual(values=c("indianred","darkgray"))+
  scale_fill_manual(values=c("indianred","darkgray"))+
  facet_wrap(~source)+
  coord_polar(start=-pi*2)+
  labs(x="months after harvest (H)",y="% change in violence")+
  theme_black()+
  theme(axis.line.x=element_blank(),axis.line.y=element_blank())

## saving the plot
ggsave("Figures/circular_acled_ucdp.png",gg_coef_white,width=6.5,height=3.5,device="png",dpi=200)
ggsave("Presentation/circular_acled_ucdp.png",gg_coef_white,width=6.5,height=3.5,device="png",dpi="retina")
ggsave("Online/circular_acled_ucdp.png",gg_coef_black,width=6.5,height=3.5,device="png",dpi="retina")


context("bind")

test_that("vector", {
    ref = rbind(1:2, 3:4)
    expect_equal(ref, bind(list(1:2, 3:4), along=1))
    expect_equal(ref, t(bind(list(1:2, 3:4), along=2)))
})

test_that("keep names", {
    x = setNames(1:2, letters[1:2])
    m = bind(list(x,x), along=2)

    expect_equal(names(x), rownames(m))

    colnames(m) = LETTERS[1:2]
    expect_equal(bind(list(m,m), along=1), rbind(m, m))

    expect_equal(bind(list(m,m), along=2), cbind(m, m))
})


#' Find Max Support for a Binary Matrix
#'
#' @param x binary matrix of features
#' @param y binary vector of predictor
#' @param xe binary vector of example observation
#' @param ye binary value of example predictor
#' @param complement whether to add the complement of x as features
#' @export
#' @importClassesFrom Matrix TsparseMatrix
max_support <- function(x, y, xe, ye, R_max = ncol(x), ws = 1, complement = TRUE) {
  # add complement variables
  if (complement) {
    x <- cbind(x, 1L - x)
    xe <- c(xe, 1L - xe)
  }

  # check dimensions
  n <- nrow(x)
  d <- ncol(x)
  stopifnot(length(y) == n)
  stopifnot(length(xe) == d)
  stopifnot(length(ye) == 1)

  # build constraint matrix
  idx <- which(y != ye)
  n_neg <- length(idx)
  n_pos <- length(which(y == ye))

  # initialize empty contraint matrix
  m <- matrix(0L, nrow = 4 + n_neg + n, ncol = 2 + d + n)

  # add "consistent" constraints
  m[1:n_neg,1:d] <- 1L - x[idx,]

  # add "rule" constraints
  m[n_neg + (1:n), 1:d] <- 1 - x[1:n,1:d]
  for (i in 1:n) {
    m[n_neg + i, d + i] <- 1L + d
  }
  #m[s + (1:n), d + (1:n)] <- 1L + d

  # add "relevance" constraint
  m[1 + n_neg + n, 1:d] <- xe
  m[1 + n_neg + n, 1 + d + n] <- -1L

  # add auxillary (sum(alpha) == R)
  m[2 + n_neg + n, 1:d] <- 1L
  m[2 + n_neg + n, 1 + d + n] <- -1L

  # max sparsity
  m[3 + n_neg + n, 1 + d + n] <- 1L

  # add auxillary (sum(r) == S)
  m[4 + n_neg + n, d + (1:n)] <- 1L
  m[4 + n_neg + n, 2 + d + n] <- -1L

  #return(m)

  # convert contraint matrix to sparse i,j,v triplet
  m <- methods::as(m, "TsparseMatrix")
  mi <- m@i + 1L
  mj <- m@j + 1L
  mv <- as.integer(m@x)

  # run min_set_cover algorithm
  r <- max_support_cpp(mi, mj, mv, n, d, n_neg, R_max, ws)

  # remove complement variables
  if (complement) {
    alpha <- r$alpha
    r$alpha <- ifelse(alpha > d/2, alpha - d/2, alpha)
  }

  r
}


################################################################
## Title: Data Science For Database Professionals
## Description: Setting up relevant R packages
## Author: Microsoft
################################################################

####################################################################################################
##Install packages
####################################################################################################

##Install packages for data exploration usage
if (!require("devtools"))
    install.packages("devtools")
devtools::install_github("rstudio/d3heatmap")
install.packages("dplyr")
install.packages("gplots")
install.packages("ggplot2")
install.packages("qcc")
install.packages("Rcpp")
install.packages("d3heatmap")
install.packages("GGally")

##Install packages for model building usage
install.packages("unbalanced")
install.packages("rpart")
install.packages("randomForest")
install.packages("Matrix")
install.packages("xgboost")
install.packages("Ckmeans.1d.dp")
install.packages("DiagrammeR")
install.packages("ROCR")
install.packages("pROC")
install.packages("AUC")

######################################################################################################
##Set directory
######################################################################################################
setwd("C:/demo/TelcoChurn/TelcoChurn")

####################################################################################################
##Define functions
####################################################################################################

##Define evaluation metrics
evaluate_model <- function(data, observed, predicted) {
    confusion <- table(data[[observed]], data[[predicted]])
    print(confusion)
    tp <- confusion[rownames(confusion) == 1, colnames(confusion) == 1]
    fn <- confusion[rownames(confusion) == 1, colnames(confusion) == 0]
    fp <- confusion[rownames(confusion) == 0, colnames(confusion) == 1]
    tn <- confusion[rownames(confusion) == 0, colnames(confusion) == 0]
    accuracy <- (tp + tn) / (tp + fn + fp + tn)
    precision <- tp / (tp + fp)
    recall <- tp / (tp + fn)
    fscore <- 2 * (precision * recall) / (precision + recall)
    metrics <- c("Accuracy" = accuracy,
               "Precision" = precision,
               "Recall" = recall,
               "F-Score" = fscore)
    return(metrics)
}

##Define ROC curve for rx-model
roc_curve <- function(data, observed, predicted) {
    data <- data[, c(observed, predicted)]
    data[[observed]] <- as.numeric(as.character(data[[observed]]))
    rxRocCurve(actualVarName = observed,
             predVarNames = predicted,
             data = data)
}

##Define ROC curve for open source R model
roc.curve <- function(s) {
    Ps = (S > s) * 1
    FP = sum((Ps == 1) * (Y == 0)) / sum(Y == 0)
    TP = sum((Ps == 1) * (Y == 1)) / sum(Y == 1)
    vect = c(FP, TP)
    names(vect) = c("FPR", "TPR")
    return(vect)
}


# Add the necessary columns
murders <- mutate(murders, rate = total/population * 100000, rank = rank(-rate))

# Filter to show the top 5 states with the highest murder rates

filter(murders, rank <= 5)


library(reshape2)
load("cs1, slow, 400, 10000")
d1 = out$timingData;
d1[,"type"] = "Slow, 400, 10000"
sumData1 = out$allTiming;
sumData1[,"modelId"] = as.factor(rownames(sumData1));
iX= order(sumData1["meanV"])
totalTime = data.frame(c(mean(as.matrix(out$allDurations)),
                         sd(as.matrix(out$allDurations))/sqrt(length(as.matrix(out$allDurations)))));
colnames(totalTime) = "Slow, 400, 10000";

S = data.frame("Slow, 400, 10000" = out$allTiming$meanV)

load("cs1, fast, 400, 10000")
d2 = out$timingData;
d2[,"type"] = "Fast, 400, 10000"
sumData2 = out$allTiming;
sumData2[,"modelId"] = seq(1,nrow(sumData2));

S = cbind(S, "Fast_400_10000" = out$allTiming$meanV)
totalTime[,"Fast, 400, 10000"] = c(mean(as.matrix(out$allDurations)),
                                   sd(as.matrix(out$allDurations))/sqrt(length(as.matrix(out$allDurations))));

load("cs1, fast, 200, 10000");
d3 = out$timingData;
d3[,"type"] = "Fast, 200, 10000"
sumData3 = out$allTiming;
sumData3[,"modelId"] = as.factor(rownames(sumData3));

S = cbind(S, "Fast_200_10000" = out$allTiming$meanV)

totalTime[,"Fast, 200, 10000"] = c(mean(as.matrix(out$allDurations)),
                                 sd(as.matrix(out$allDurations))/sqrt(length(as.matrix(out$allDurations))));

load("cs1, Fast, 200, 5000");
d4 = out$timingData;
d4[,"type"] = "Fast, 200, 5000"
sumData4 = out$allTiming;
sumData4[,"modelId"] = as.factor(rownames(sumData4));

S = cbind(S, "Fast_200_5000" = out$allTiming$meanV)
totalTime[,"Fast, 200, 5000"] = c(mean(as.matrix(out$allDurations)),
                                sd(as.matrix(out$allDurations))/sqrt(length(as.matrix(out$allDurations))));

rownames(S) = rownames(out$allTiming)

d = rbind(d1, d2, d3, d4);
d$value = d$value/3600;
d$value[d$value > 8] = 8;

p3 = ggplot(d, aes(npars, value, color=type), stat="identity");
p3 = p3 + geom_jitter(alpha=0.4, position = position_jitter(w=0.3,h=0.0, seed=1), size=3);
p3 = p3 + ylim(0,8);

p3 = p3 + theme_minimal();
p3 = p3 +  theme(aspect.ratio = 1) + theme(panel.grid = element_blank()) + theme(text = element_text(size=16));
p3 = p3 + theme(axis.line.x = element_line(color="black", size = .5),
                axis.line.y = element_line(color="black", size = .5), axis.ticks = element_line(size=0.5),axis.ticks.length = unit(.25, "cm") )
p3 = p3 +  labs(y = "Run time (Hrs)", x='Number of parameters');
cor.test(formula=~value+npars, data = d)

sumData = cbind(sumData4[iX,c("meanV","modelId")], sumData3[iX, "meanV"], sumData2[iX,"meanV"], sumData1[iX,"meanV"]);
colnames(sumData) = c("Fast, 200, 5000", "modelId", "Fast, 200, 10000", "Fast, 400, 10000", "Slow, 400, 10000");
sumData = melt(sumData,id="modelId")

p1=ggplot(sumData, aes(x=reorder(modelId, value), y=value/3600, fill=variable, order=variable));
p1=p1 + geom_bar(alpha=0.8, stat = "identity", position="dodge") + theme_minimal() + coord_flip();
p1=p1 +  theme(aspect.ratio = 1) + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p1 = p1 +  labs(y = "Run time (Hrs)", x='Models') + theme(text = element_text(size=16));

rownames(totalTime) = c("mean", "se");
totalTime = data.frame(t(totalTime)/3600);

p2 = ggplot(totalTime, aes(x=reorder(rownames(totalTime), mean), y=mean, fill=factor(rownames(totalTime)))) + geom_bar(stat="identity");
p2 = p2 + theme_minimal() +  theme(aspect.ratio = 1) + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p2 = p2 +  labs(y = "Run time (Hrs)", x='Variants') + theme(text = element_text(size=16)) + coord_flip();
p2 = p2 + geom_errorbar(aes(ymin=mean-se,ymax=mean+se), width=0.2, position=position_dodge(.9))

grid.arrange(p3, p1, p2, nrow=2, ncol=2)


set.seed(1234)
library(knockoff)
library(corpcor)
library(RSpectra)
library(Rdsdp)
library(gtools)
for(i in 1:25) {
    X<-read.table(paste("data/X_64_",as.character(i),".txt",sep=""))
    X<-scale(X)
    X1<-X[1:8000,] #exclude the test sets
    X_k<-create.second_order(X1,shrink=T)
    write.table(X_k,file=paste("data/Xk_64_",as.character(i),".txt",sep=""),quote=F,row.names=F,col.names=F)
}

Comparisons with knockoffs/Scenarios 1 and 2/second-order_knockoffs.r


# Data are made by get_correlation3.R
# get the correlated noise from values of F at age in the terminal year, and N  at age in the Terminal Year+1

#data.path<-      # directory vi data

# read covariance matrix
outFile<-file.path(data.path,"Nnext_F_covariance.in")
COV<-read.csv(file=outFile)
COV<-as.matrix(COV)
dimnames(COV)[[1]]<- dimnames(COV)[[2]]

# read estimated values used for constructing covariance matrix
outFile<-file.path(data.path,"Nnext_F_value.in")
est<-scan(file=outFile)

#read labels for noise
outFile<-file.path(data.path,"Nnext_F_labels.in")
label<-read.table(file=outFile,header=T)

# find beging and end of each type of data
Nlast<-min(grep("term_F",dimnames(COV)[[1]]))-1
fin<-length(est)

# get the values of F at age in the terminal year, and N  at age in the Terminal Year+1
n<-1  # number of replicates
if (n==1) {
  noiseFactor<-mvrnorm(n=n, mu=est, Sigma=COV)
  noiseFactor[1:Nlast]<- exp(noiseFactor[1:Nlast]-est[1:Nlast])   # N
  noiseFactor[(Nlast+1):fin]<- noiseFactor[(Nlast+1):fin]/est[(Nlast+1):fin] # F
  noise<-data.frame(label,noiseFactor=noiseFactor)
}
if (n>1) {
  noiseFactor<-mvrnorm(n=n, mu=est, Sigma=COV)
  noiseFactor[,1:Nlast]<- exp(noiseFactor[,1:Nlast]-rep(est[1:Nlast],each=n))   # N
  noiseFactor[,(Nlast+1):fin]<- noiseFactor[,(Nlast+1):fin]/rep(est[(Nlast+1):fin],each=n) # F
  apply(noiseFactor[,1:4],2,summary)

  X11()
  par(mfcol=c(7,7),mar=c(3,1,1,1))     #c(bottom, left, top, right)
  for (i in (1:dim(noiseFactor)[[2]])) {
    hist(noiseFactor[,i],main=dimnames(noiseFactor)[[2]][[i]])
  }
}

noise


  # ----------------------------------------------------------------------------------------------
  # predict the maturity of crabs based upon determined data
  # ----------------------------------------------------------------------------------------------

  predictmaturity = function(x, method="DFA") {
    # codes

    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    # maturity codes
    immature = 0
    mature = 1
    mat.unknown = 2

    # basic biological limits
      x$mat[ which( x$cw<50 ) ]  = immature
      x$mat[ which( x$cw>150 ) ] = mature

    # males: order is important .. last is most imperative
      x$mat[ which( x$sex == male & x$shell %in% c(4,5)) ] = mature
      x$mat[ which( x$sex == male & x$cw < 50) ] = immature
      x$mat[ which( x$sex == male & x$cw > 150) ] = mature
      x$mat[ which( x$sex == male & x$chela < 5) ] = immature
      x$mat[ which( x$sex == male & x$chela > 33) ] = mature

    # female: sequence is important .. last is most imperative
      x$mat[ which( x$sex == female & x$shell %in% c(4,5)) ] = mature
      x$mat[ which( x$sex == female & x$cw < 30) ] = immature
      x$mat[ which( x$sex == female & x$cw > 80) ] = mature
      x$mat[ which( x$sex == female & x$abdomen < 20) ] = immature
      x$mat[ which( x$sex == female & x$abdomen > 50) ] = mature
      x$mat[ which( x$sex == female & x$gonad %in% c(1,2,3) )] = immature
      x$mat[ which( x$sex == female & x$eggPr == 0 )] = immature
      x$mat[ which( x$sex == female & x$eggPr %in% c(1:4) )] = mature # berried females
      x$mat[ which( x$sex == female & x$eggcol %in% c(1,2,3,4) )] = mature

    if (method=="DFA") {
      # males
      test.male = -25.32404 * log(x$cw) + 19.775707 * log(x$chela) + 56.649941
      x$mat[ which(x$sex==male & test.male <= 0 ) ] = immature
      x$mat[ which(x$sex==male & test.male > 0 ) ] = mature
    # females
      test.female = 16.422757 * log(x$cw) - 14.756163 * log(x$abdomen) - 14.898721
      x$mat[ which(x$sex==female  & test.female > 0 ) ] = immature
      x$mat[ which(x$sex==female  & test.female <= 0) ] = mature
    }

    if (method=="logistic.regression") {
      require(mgcv)

      ##TODO- need to add a final step for animals without a SC. Maybe revert to DFA method for these only?

      x$rs = NA
      x$mat.predicted = NA

      WW = which( x$mat %in% c(immature, mature) )
      MM = which( x$sex==male )
      FF = which( x$sex==female )
      SC = which( x$shell %in% 1:5 )
      cleandata_mm = which( x$cw > 0 & x$chela > 0 )
      cleandata_ff = which( x$cw > 0 & x$abdomen > 0 )

      x$mat = as.factor(x$mat)
      x$sex = as.factor(x$sex)
      #      x$shell = as.factor(x$shell)

      imm = intersect( intersect( intersect( MM, WW ), SC ), cleandata_mm )
      iff = intersect( intersect( intersect( FF, WW ), SC ), cleandata_ff )

      modm1 = glm( mat ~ log(cw) + log(chela) + shell, data=x[imm,], family=binomial(link="logit") )
      modf1 = glm( mat ~ log(cw) + log(abdomen) + shell, data=x[iff,], family=binomial(link="logit") )

      x$rs[imm]  = residuals( modm1 )
      x$rs[iff]  = residuals( modf1 )

      # reject too large a residual variability
      rs3 =  which( abs(x$rs) > 1.96 )  # reject too large a residual variability -- log-scaled ... residual =1 is large
      # these have potentially problematic data inputs in either cw and/or chela. etc
      # assume CW is OK and set all other data in the main dataset to uncertain/missing
      x$chela[rs3] = NA
      x$abdomen[rs3] = NA

      # update data vectors removing "bad" data and redo model
      cleandata_mm = which( x$cw > 0 & x$chela > 0 )
      cleandata_ff = which( x$cw > 0 & x$abdomen > 0 )
      imm = intersect( intersect( intersect( MM, WW ), SC ), cleandata_mm )
      iff = intersect( intersect( intersect( FF, WW ), SC ), cleandata_ff )

      modm1 = glm( mat ~ log(cw) + log(chela) + shell, data=x[imm,], family=binomial(link="logit") )
      modf1 = glm( mat ~ log(cw) + log(abdomen) + shell, data=x[iff,], family=binomial(link="logit") )

      # require( boot )  # inv.logit
      # plot( modm1, trans=inv.logit,  rug=T, jit=T, scale=0 )
      # plot( modf1, trans=inv.logit,  rug=T, jit=T, scale=0 )

      # update data vectors removing "bad" data and redo model
      cleandata_mm = which( x$cw > 0 & x$chela > 0 )
      cleandata_ff = which( x$cw > 0 & x$abdomen > 0 )
      imm = intersect( intersect( intersect( MM, WW ), SC ), cleandata_mm )
      iff = intersect( intersect( intersect( FF, WW ), SC ), cleandata_ff )

      modm1 = glm( mat ~ log(cw) + log(chela) + shell, data=x[imm,], family=binomial(link="logit") )
      modf1 = glm( mat ~ log(cw) + log(abdomen) + shell, data=x[iff,], family=binomial(link="logit") )

      # identify inds without maturity indications
      WW = which( !(x$mat %in% c(immature, mature) )  )
      imm = intersect( intersect( intersect( MM, WW ), SC ), cleandata_mm )
      iff = intersect( intersect( intersect( FF, WW ), SC ), cleandata_ff )

      x$mat.predicted[imm] = ifelse( predict( modm1, x[imm,], type="response" ) < 0.5, immature, mature )
      x$mat.predicted[iff] = ifelse( predict( modf1, x[iff,], type="response" ) < 0.5, immature, mature )

      x$mat[imm] = x$mat.predicted[imm]
      x$mat[iff] = x$mat.predicted[iff]

#animals without shell did not get assigned mat through models to this point so...
      cleandata_mm = which( x$cw > 0 & x$chela > 0 )
      cleandata_ff = which( x$cw > 0 & x$abdomen > 0 )
      NoC= which( is.na(x$shell)) #individuals w/o shell condition
      WW = which( !(x$mat %in% c(immature, mature) )  ) #individuals w/o maturity indications

      imm = intersect( intersect( intersect( MM, WW ), NoC ), cleandata_mm )
      iff = intersect( intersect( intersect( FF, WW ), NoC ), cleandata_ff )

      modm1 = glm( mat ~ log(cw) + log(chela), data=x[imm,], family=binomial(link="logit") )
      modf1 = glm( mat ~ log(cw) + log(abdomen) , data=x[iff,], family=binomial(link="logit") )

      x$mat.predicted[imm] = ifelse( predict( modm1, x[imm,], type="response" ) < 0.5, immature, mature )
      x$mat.predicted[iff] = ifelse( predict( modf1, x[iff,], type="response" ) < 0.5, immature, mature )

      x$mat[imm] = x$mat.predicted[imm]
      x$mat[iff] = x$mat.predicted[iff]

      x$rs = NULL
      x$mat.predicted = NULL

    }

    return(x)
  }


lsh_minhash <- function(m, rows_per_band = 5) {
  num_hashes <- nrow(m)
  bands <- seq(1, num_hashes, rows_per_band)

  results <- pbmcapply::pbmclapply(bands, function(b) {
    m_band <- m[b:(b + rows_per_band - 1L),]
    hashes <- apply(m_band, 2, digest::digest, "murmur32")
    buckets <- createBuckets(hashes)

    # Filter results with only one entry
    purrr::keep(buckets, ~ length(.x) > 1)
  })

  # clean up results
  results <- purrr::compact(results)
  results <- purrr::flatten(results)
  results[!duplicated(results)]
}

#' Locality Sensitivity Hashing
#'
#' @param s shingled document
#' @param hashes number of hash functions
#' @param rows number of rows per bands
#' @export
lsh <- function(s, hashes = 100, rows = 5) {
  m <- minhash(s, hashes)
  lsh_minhash(m, rows)
}


library(eNetXplorer)

dn.enet = "results/Clinical_enet/"
dn.fig = str_replace(dn.enet, "results", "figures")
dir.create(dn.fig, showWarnings = F, recursive = T)
fn.run = file.path(dn.enet, "enet_data.Rdata")

load(fn.run, verbose = T)

a = 1
ai = which.min(abs(result$alpha - a))
albl = paste0("a",a)

feature = result$feature

freq.mean = result$feature_freq_mean[,ai]
freq.sd = result$feature_freq_sd[,ai]
freq.pval = result$feature_freq_model_vs_null_pval[,ai]
coef.mean = result$feature_coef_wmean[,ai]
coef.sd = result$feature_coef_wsd[,ai]
coef.pval = result$feature_coef_model_vs_null_pval[,ai]
DF.model = data.frame(feature, freq.mean, freq.sd, freq.pval, coef.mean, coef.sd, coef.pval, model="model")

freq.mean = result$null_feature_freq_mean[,ai]
freq.sd = result$null_feature_freq_sd[,ai]
coef.mean = result$null_feature_coef_wmean[,ai]
coef.sd = result$null_feature_coef_wsd[,ai]
DF.null = data.frame(feature, freq.mean, freq.sd, freq.pval, coef.mean, coef.sd, coef.pval, model="null")

DF.stat = rbind(DF.model, DF.null) %>%
  mutate(model = factor(model, levels=c("null","model"))) %>%
  mutate(feature = factor(feature, levels=sort(unique(feature), decreasing=T)))

# scatter plot of predictin performance
DF.plot = data.frame(
  sample = rownames(result$predictor),
  measured = result$response,
  pred_mean = result$predicted_values[[ai]][,1],
  pred_sd = result$predicted_values[[ai]][,2]
) %>%
  separate(sample, c("subject","visit"), sep="_", remove=F)

df.cor = data.frame(x=Inf, y=-Inf,
                    label=sprintf("Pearson correlation: %.2g (p = %.3g)",
                                  result$model_QF_est[albl], result$QF_model_vs_null_pval[albl]))

ggplot(DF.plot, aes(measured, pred_mean, col=visit)) +
  geom_point() +
  geom_errorbar(aes(ymin=pred_mean-pred_sd, ymax=pred_mean+pred_sd), width=0.1) +
  geom_smooth(method="lm", alpha=0.2, col="red", lty=2) +
  geom_abline(slope=1, intercept = 0, col="black", lty=2) +
  # geom_text(aes(label=sub("s","",subject)), hjust=-0.3, size=3) +
  geom_text(data=df.cor, aes(x,y,label=label), hjust=1.1, vjust=-1, inherit.aes = F) +
  xlab("Actual GA") +
  ylab("Out-of-bag Predicted GA") +
  theme_bw()
fn.fig = file.path(dn.fig, sprintf("eNet_%s_scatter", albl))
ggsave(file=paste0(fn.fig, ".png"), w=6, h=5)
ggsave(file=paste0(fn.fig, ".pdf"), w=6, h=5, useDingbats=FALSE)

features.in = NULL
if(is.null(features.in)){
  fi = DF.model$freq.mean > max(DF.null$freq.mean, na.rm=T) &
    abs(DF.model$coef.mean) > max(abs(DF.null$coef.mean[!is.na(DF.model$coef.mean)]), na.rm=T) &
    DF.model$coef.pval < 0.1
} else {
  fi = DF.stat$feature %in% features.in
}
features.in = feature[fi]
DF.plot.2 = DF.stat %>%
  dplyr::filter(feature %in% features.in) %>%
  arrange(desc(model), abs(coef.mean)) %>%
  mutate(feature = fct_inorder(as.character(feature)))
p1 = ggplot(DF.plot.2, aes(feature, freq.mean*100, fill=model)) +
  geom_col(position="dodge") +
  geom_errorbar(aes(ymin=pmax(0, (freq.mean-freq.sd)*100), ymax=pmin(100,(freq.mean+freq.sd)*100)),
                position=position_dodge(width = 0.9), width=0.25) +
  scale_fill_manual(values = c("grey60","red")) +
  scale_y_continuous(breaks=c(0, 50, 100)) +
  coord_flip() +
  xlab("") +
  ylab("% selected") +
  guides(fill=F) +
  theme_classic() + theme(axis.line.y = element_blank(), axis.ticks.y = element_blank())
p2 = ggplot(DF.plot.2, aes(feature, coef.mean, fill=model)) +
  geom_col(position="dodge") +
  geom_errorbar(aes(ymin=coef.mean-coef.sd, ymax=coef.mean+coef.sd),
                position=position_dodge(width = 0.9), width=0.25) +
  geom_hline(yintercept = 0) +
  scale_fill_manual(values = c("grey60","red")) +
  # coord_flip(ylim=c(-1.1,1.1)) +
  coord_flip() +
  xlab("") +
  ylab("Coefficient mean") +
  guides(fill=F) +
  theme_classic() + theme(axis.line.y = element_blank(), axis.ticks.y = element_blank(), axis.text.y = element_blank())
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))
l = list(g1, g2)

library(gridExtra)
lay  = matrix(c(1,1,2,2,2), nrow=1)
mg = grid.arrange(arrangeGrob(g1,g2, layout_matrix = lay))
fn.fig = file.path(dn.fig, sprintf("eNet_%s_selected", albl))
ggsave(file=paste0(fn.fig, ".png"), plot=mg, w=6, h=3)
ggsave(file=paste0(fn.fig, ".pdf"), plot=mg, w=6, h=3, useDingbats=FALSE)


plot(blacklist$V3, blacklist$V2, xlab = "No of user criteria", ylab = "Gas consumed")
lo <- loess(blacklist$V2~blacklist$V3)
lines(predict(lo), col='red', lwd=2)

plot(users$V1, users$V2, xlab = "No of users", ylab = "Gas consumed")
lo <- loess(users$V2~users$V1)
lines(predict(lo), col='red', lwd=2)


#' Annotation: log tick marks
#'
#' This annotation adds log tick marks with diminishing spacing.
#' These tick marks probably make sense only for base 10.
#'
#' @param base the base of the log (default 10)
#' @param sides a string that controls which sides of the plot the log ticks appear on.
#'   It can be set to a string containing any of `"trbl"`, for top, right,
#'   bottom, and left.
#' @param outside logical that controls whether to move the log ticks outside
#' of the plot area. Default is off (`FALSE`). You will also need to use
#' `coord_cartesian(clip = "off")`. See examples.
#' @param short a [grid::unit()] object specifying the length of the
#'   short tick marks
#' @param mid a [grid::unit()] object specifying the length of the
#'   middle tick marks. In base 10, these are the "5" ticks.
#' @param long a [grid::unit()] object specifying the length of the
#'   long tick marks. In base 10, these are the "1" (or "10") ticks.
#' @param scaled is the data already log-scaled? This should be `TRUE`
#'   (default) when the data is already transformed with `log10()` or when
#'   using `scale_y_log10()`. It should be `FALSE` when using
#'   `coord_trans(y = "log10")`.
#' @param colour Colour of the tick marks.
#' @param size Thickness of tick marks, in mm.
#' @param linetype Linetype of tick marks (`solid`, `dashed`, etc.)
#' @param alpha The transparency of the tick marks.
#' @param color An alias for `colour`.
#' @param ... Other parameters passed on to the layer
#'
#' @export
#' @seealso [scale_y_continuous()], [scale_y_log10()] for log scale
#'   transformations.
#' @seealso [coord_trans()] for log coordinate transformations.
#'
#' @examples
#' # Make a log-log plot (without log ticks)
#' a <- ggplot(msleep, aes(bodywt, brainwt)) +
#'  geom_point(na.rm = TRUE) +
#'  scale_x_log10(
#'    breaks = scales::trans_breaks("log10", function(x) 10^x),
#'    labels = scales::trans_format("log10", scales::math_format(10^.x))
#'  ) +
#'  scale_y_log10(
#'    breaks = scales::trans_breaks("log10", function(x) 10^x),
#'    labels = scales::trans_format("log10", scales::math_format(10^.x))
#'  ) +
#'  theme_bw()
#'
#' a + annotation_logticks()                # Default: log ticks on bottom and left
#' a + annotation_logticks(sides = "lr")    # Log ticks for y, on left and right
#' a + annotation_logticks(sides = "trbl")  # All four sides
#'
#' a + annotation_logticks(sides = "lr", outside = TRUE) +
#'  coord_cartesian(clip = "off")  # Ticks outside plot
#'
#' # Hide the minor grid lines because they don't align with the ticks
#' a + annotation_logticks(sides = "trbl") + theme(panel.grid.minor = element_blank())
#'
#' # Another way to get the same results as 'a' above: log-transform the data before
#' # plotting it. Also hide the minor grid lines.
#' b <- ggplot(msleep, aes(log10(bodywt), log10(brainwt))) +
#'  geom_point(na.rm = TRUE) +
#'  scale_x_continuous(name = "body", labels = scales::math_format(10^.x)) +
#'  scale_y_continuous(name = "brain", labels = scales::math_format(10^.x)) +
#'  theme_bw() + theme(panel.grid.minor = element_blank())
#'
#' b + annotation_logticks()
#'
#' # Using a coordinate transform requires scaled = FALSE
#' t <- ggplot(msleep, aes(bodywt, brainwt)) +
#'   geom_point() +
#'   coord_trans(x = "log10", y = "log10") +
#'   theme_bw()
#' t + annotation_logticks(scaled = FALSE)
#'
#' # Change the length of the ticks
#' a + annotation_logticks(
#'   short = unit(.5,"mm"),
#'   mid = unit(3,"mm"),
#'   long = unit(4,"mm")
#' )
annotation_logticks <- function(base = 10, sides = "bl", outside = FALSE, scaled = TRUE,
    short = unit(0.1, "cm"), mid = unit(0.2, "cm"), long = unit(0.3, "cm"),
    colour = "black", size = 0.5, linetype = 1, alpha = 1, color = NULL, ...)
{
  if (!is.null(color))
    colour <- color

  layer(
    data = dummy_data(),
    mapping = NULL,
    stat = StatIdentity,
    geom = GeomLogticks,
    position = PositionIdentity,
    show.legend = FALSE,
    inherit.aes = FALSE,
    params = list(
      base = base,
      sides = sides,
      outside = outside,
      scaled = scaled,
      short = short,
      mid = mid,
      long = long,
      colour = colour,
      size = size,
      linetype = linetype,
      alpha = alpha,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomLogticks <- ggproto("GeomLogticks", Geom,
  extra_params = "",
  handle_na = function(data, params) {
    data
  },

  draw_panel = function(data, panel_params, coord, base = 10, sides = "bl",
                        outside = FALSE, scaled = TRUE, short = unit(0.1, "cm"),
                        mid = unit(0.2, "cm"), long = unit(0.3, "cm"))
  {
    ticks <- list()
    flipped <- inherits(coord, "CoordFlip")
    x_name <- if (flipped) "y" else "x"
    y_name <- if (flipped) "x" else "y"

    # Convert these units to numbers so that they can be put in data frames
    short <- convertUnit(short, "cm", valueOnly = TRUE)
    mid   <- convertUnit(mid,   "cm", valueOnly = TRUE)
    long  <- convertUnit(long,  "cm", valueOnly = TRUE)

    if (grepl("[b|t]", sides)) {

      # Get positions of x tick marks
      xticks <- calc_logticks(
        base = base,
        minpow = floor(panel_params$x.range[1]),
        maxpow = ceiling(panel_params$x.range[2]),
        start = 0,
        shortend = short,
        midend = mid,
        longend = long
      )

      if (scaled)
        xticks$value <- log(xticks$value, base)

      names(xticks)[names(xticks) == "value"] <- x_name   # Rename to 'x' for coordinates$transform
      xticks <- coord$transform(xticks, panel_params)
      xticks = xticks[xticks$x <= 1 & xticks$x >= 0,]

      if (outside)
        xticks$end = -xticks$end

      # Make the grobs
      if (grepl("b", sides)) {
        ticks$x_b <- with(data, segmentsGrob(
          x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
          y0 = unit(xticks$start, "cm"), y1 = unit(xticks$end, "cm"),
          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
        ))
      }
      if (grepl("t", sides)) {
        ticks$x_t <- with(data, segmentsGrob(
          x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
          y0 = unit(1, "npc") - unit(xticks$start, "cm"), y1 = unit(1, "npc") - unit(xticks$end, "cm"),
          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
        ))
      }
    }

    if (grepl("[l|r]", sides)) {
      yticks <- calc_logticks(
        base = base,
        minpow = floor(panel_params$y.range[1]),
        maxpow = ceiling(panel_params$y.range[2]),
        start = 0,
        shortend = short,
        midend = mid,
        longend = long
      )

      if (scaled)
        yticks$value <- log(yticks$value, base)

      names(yticks)[names(yticks) == "value"] <- y_name   # Rename to 'y' for coordinates$transform
      yticks <- coord$transform(yticks, panel_params)
      yticks = yticks[yticks$y <= 1 & yticks$y >= 0,]

      if (outside)
        yticks$end = -yticks$end

      # Make the grobs
      if (grepl("l", sides)) {
        ticks$y_l <- with(data, segmentsGrob(
          y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
          x0 = unit(yticks$start, "cm"), x1 = unit(yticks$end, "cm"),
          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
        ))
      }
      if (grepl("r", sides)) {
        ticks$y_r <- with(data, segmentsGrob(
          y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
          x0 = unit(1, "npc") - unit(yticks$start, "cm"), x1 = unit(1, "npc") - unit(yticks$end, "cm"),
          gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
        ))
      }
    }

    gTree(children = do.call("gList", ticks))
  },

  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = 1)
)

# Calculate the position of log tick marks
# Returns data frame with:
# - value: the position of the log tick on the data axis, for example 1, 2, ..., 9, 10, 20, ...
# - start: on the other axis, start position of the line (usually 0)
# - end: on the other axis, end position of the line (for example, .1, .2, or .3)
calc_logticks <- function(base = 10, ticks_per_base = base - 1,
    minpow = 0, maxpow = minpow + 1, start = 0, shortend = .1, midend = .2, longend = .3) {

  # Number of blocks of tick marks
  reps <- maxpow - minpow

  # For base 10: 1, 2, 3, ..., 7, 8, 9, 1, 2, ...
  ticknums  <- rep(seq(1, base - 1, length.out = ticks_per_base), reps)

  # For base 10: 1, 1, 1, ..., 1, 1, 1, 2, 2, ... (for example)
  powers <- rep(seq(minpow, maxpow - 1), each = ticks_per_base)

  ticks  <- ticknums * base ^ powers
  ticks  <- c(ticks, base ^ maxpow)  # Add the last tick mark

  # Set all of the ticks short
  tickend <- rep(shortend, length(ticks))

  # Get the position within each cycle, 0, 1, 2, ..., 8, 0, 1, 2. ...
  cycleIdx <- ticknums - 1

  # Set the "major" ticks long
  tickend[cycleIdx == 0] <- longend

  # Where to place the longer tick marks that are between each base
  # For base 10, this will be at each 5
  longtick_after_base <- floor(ticks_per_base/2)
  tickend[ cycleIdx == longtick_after_base ] <- midend

  tickdf <- new_data_frame(list(value = ticks, start = start, end = tickend), n = length(ticks))

  return(tickdf)
}


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1
dftest[,"Seasonality"] <- ((as.numeric(dftest$Date) + 143) %% 52) + 1

#Add Year column
dftrain[,"Year"] <- (as.numeric(format(as.Date(dftrain$Date), "%Y")))
dftest[,"Year"] <- (as.numeric(format(as.Date(dftest$Date), "%Y")))

#Add previous year column to the test dataset
dftest[,"PYear"] <- dftest$Year - 1

#Weekly_Sales are last year sales
dfresult <- merge(dftest, dftrain, by.x = c("Store","Dept", "Seasonality", "PYear"),
	by.y = c("Store","Dept", "Seasonality", "Year"), all.x = TRUE)

#for depts with no data use 0 sales
dfresult$Weekly_Sales[is.na(dfresult$Weekly_Sales)] <- 0

#preparing the submission file
#Adding a column with store_department_date
dfresult[,"Id"] <- paste(dfresult$Store, dfresult$Dept, format(as.Date(dfresult$Date.x), "%Y-%m-%d" ), sep = "_")

#save results in a csv file
write.csv(file = "Solution3.csv", x = subset(dfresult, select = c(Id, Weekly_Sales)), row.names=FALSE)


# NOTES
# Run this locally to run a test from the /docker/docker directory"
# test_dir("tests", reporter = JunitReporter$new(file = "junit_result.xml"))

# Load ttestthat
library(testthat)

context("Linear Regression Model")

# Load functions to test
source("../model.R")

# Loading Model
test_that("Load Model", {
    model <- load_model("../model.rds")
    expect_that(class(model), equals("lm"))
})

# Shape of response
test_that("Output Shape of response", {
    model <- load_model("../model.rds")
    result<- predict_weight(height=22, model)
    expect_equal(length(result), 1)
})


par(mfrow=c(2,2))
x_lim <- c(-10, 80)
y_lim <- c(-10, 70)

dat <- read.table('oup', header=F, row.names=NULL)
plot(dat,xlim=x_lim, ylim=y_lim)

modes <- read.table('log', header=F, row.names=NULL, sep="")
plot(modes,xlim=x_lim, ylim=y_lim)

plot(dat,xlim=x_lim, ylim=y_lim)
files <- list.files(pattern="cluster_*")
i<-1
for(file in files)
{
	#if(i==1) {plot(read.csv(file, header=T, row.names=NULL), xlim=x_lim, ylim=y_lim, col=i, pch=i)}
	points(read.csv(file, header=T, row.names=NULL), col=i, pch=2*i-1)
	i <- i + 1
}

i<-1
for(file in files)
{
	if(i==1) {plot(read.csv(file, header=T, row.names=NULL), xlim=x_lim, ylim=y_lim, col=i, pch=i)}
	else {points(read.csv(file, header=T, row.names=NULL), col=i, pch=2*i-1)}
	i <- i + 1
}


#######################
library(devtools)
devtools::load_all()
library(parallel)
RNGkind("L'Ecuyer-CMRG")
seed <- 999983
set.seed(seed)

data(grid)

s_k <- 100
s_n <- 100
s_m <- 4
s_r <- r_grid_quad[2]

l_semi.t <- type_2(seed, s_k, s_n, s_m, "quadratic", s_r, L = 1000,
            fast.tn = T, semi.iter = T, center.bs = F)
save(l_semi.t, file = "semi_t.RData")

l_semi.f <- type_2(seed, s_k, s_n, s_m, "quadratic", s_r, L = 1000,
            fast.tn = T, semi.iter = F, center.bs = F)
save(l_semi.f, file = "semi_f.RData")

load("semi_t.RData")
load("semi_f.RData")

# power
l_semi.t[[1]]
l_semi.f[[1]]
# mse for sigma2
l_semi.t[[2]]
l_semi.f[[2]]
# runtime
rowMeans(matrix(unlist(l_semi.t[[3]]), nrow = 3))
rowMeans(matrix(unlist(l_semi.f[[3]]), nrow = 3))


pdf_file<-"pdf/maps_germany_cartogram_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file, width=12,height=6)
par(omi=c(0.15,0.25,0.55,0.15), mai=c(0,0,0,1), family="Lato Light", mfcol=c(1,2))

library(maptools)
library(gdata)
library(cartogram)
library(RColorBrewer)

# Prepare chart and import data

nuts2013<-readShapeSpatial("myData/NUTS_2013_03M_SH/data/NUTS_RG_03M_2013.shp", proj4string=CRS("+proj=longlat"))
m <- spTransform(nuts2013, CRS=CRS("+proj=merc"))
DE<-m[substr(m$NUTS_ID, 1, 2)=="DE" & m$STAT_LEVL_==1,]

bl<-read.xls("myData/bl.xlsx")
DE@data$BIP<-bl$BIP
DE@data$AUS<-bl$AUS

westfarben<-brewer.pal(5,"PuRd")[2:5]
ostfarben<-brewer.pal(5,"PuBu")[2:5]

farb_nr<-cut(DE$BIP, c(0,100000,200000,300000,650000))
levels(farb_nr)<-c("up to 100 m €", "100 - 200 m €", "200 - 300 m €", "over 300 m €")

DE@data$farb_nr<-farb_nr
ostwest<-c(2,1,1,1,1,0,2,1,1,1,1,1,2,2,1,2)
DE@data$ostwest<-ostwest
DEWest<-DE[DE$ostwest==1, ]
DEOst<-DE[DE$ostwest==2, ]

# Create chart

plot(DEWest, col=westfarben[DEWest$farb_nr], border="white", new=T)
plot(DEOst, col=ostfarben[DEOst$farb_nr], border="white", add=T)
plot(DE[DE$ostwest==0, ], col="grey", border="white", add=T)

legend(1580000, 6400000, xpd=T, c("", "", "", ""), cex=0.95, border=FALSE, bty="n", fill=westfarben)
legend(1620000, 6400000, xpd=T, levels(farb_nr), cex=0.95, border=FALSE, bty="n", fill=c(ostfarben[1], ostfarben[2], "white", "white"), text.col="darkgrey")

DEC<-cartogram(DE, "BIP", 9)
DECWest<-DEC[DEC$ostwest==1, ]
DECOst<-DEC[DEC$ostwest==2, ]

plot(DECWest, col=westfarben[DECWest$farb_nr], border="white")
plot(DECOst, col=ostfarben[DECOst$farb_nr], border="white", add=T)
plot(DEC[DEC$ostwest==0, ], col="grey", border="white", add=T)

# Titling

mtext("Gross domestic product of the federal states 2015", line=0, adj=0, cex=2.2, family="Lato Black", outer=T)
mtext("Source: de.statista.com", side=1, line=-1, adj=1, cex=0.9, font=3, outer=T)
dev.off()


pdf_file<-"pdf/scatterplots_areas.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=9)

par(mai=c(0.85,1,0.25,0.25),omi=c(1,0.5,1,0.5),family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
myPersons<-read.xls("myData/persons.xlsx", encoding="latin1")
attach(myPersons)
myData<-subset(myPersons,w>0 & s=="m" & name!="Max Schmeling")
attach(myData)

# Define chart and other elements

plot(type="n",xlab="Height (cm)",ylab="Weight (kg)",h,w,xlim=c(160,220),ylim=c(50,125),axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

myC1<-rgb(255,0,210,maxColorValue=255)
myC2<-rgb(0,208,226,100,maxColorValue=255)

myP1<-subset(myData[c("h","w")],w>20*(h/100*h/100) & w<25*(h/100*h/100))
myP2<-subset(myData[c("h","w")],w<20*(h/100*h/100))
myP3<-subset(myData[c("h","w")],w>25*(h/100*h/100))

myDes2<-as.matrix(subset(name,w<20*(h/100*h/100)))
myDes3<-as.matrix(subset(name,w>25*(h/100*h/100)))

symbols(myP1,bg=myC1,fg="white",circles=rep(1,nrow(myP1)),inches=0.25,add=T)
symbols(myP2,bg=myC2,fg="white",circles=rep(1,nrow(myP2)),inches=0.25,add=T)
symbols(myP3,bg=myC2,fg="white",circles=rep(1,nrow(myP3)),inches=0.25,add=T)

text(myP2,myDes2,cex=0.75,pos=1,offset=1.1,family="Lato Black")
text(myP3,myDes3,cex=0.75,pos=3,offset=1.1,family="Lato Black")

curve(20*(x/100*x/100),xlim=c(160,220),add=T)
curve(25*(x/100*x/100),xlim=c(160,220),add=T)

abline(v=mean(h,na.rm=T),lty=3)
abline(h=mean(w,na.rm=T),lty=3)
text(182.5,52,"Average height: 182 cm",adj=0,font=3)

# Titling

mtext("Relationship between height and weight",3,adj=0,line=2,cex=2.1,outer=T,family="Lato Black")
mtext("Selected celebrities",3,adj=0,line=0,cex=1.4,outer=T,font=3)
mtext("Source: celebrityheights.com, howmuchdotheyweigh.com",1,line=1,adj=1,cex=0.95,outer=T,font=3)
dev.off()


library(pROC)
source(file.path(PROJECT_DIR, "R/functions/get_score.r"))

# load CD38 signature genes
fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", "CD38_ge_sig.txt")
cd38.genes = fread(fn.sig, header = F) %>% unlist(use.names=F)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "YF", "YF_GE_matrix_gene_day0.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "YF", "YF_sample_info_day0.txt")
info = fread(fn.si)

gi = toupper(rownames(dat)) %in% toupper(cd38.genes)
sum(gi)

XX = rep(NA,nrow(info))

for (trial in c(1,2)) {
  lbl = paste0("T",trial)
  print(lbl)
  si = info$Trial==trial
  # ihl = info$Response[si] %in% c("low","high")

  X = get_score(dat[gi,si])

  XX[si] = X
}

df.out  = info %>% dplyr::select(subject, Trial, Response) %>%
  mutate(CD38_score = XX)

fn.out = file.path(PROJECT_DIR, "generated_data", "YF", "YF_cd38_ge_sig_score.txt")
fwrite(df.out, fn.out, sep="\t", quote=T)


# Importing libraries.
  library(shiny)
  library(queueing)

  # Shiny server that receives input, output and session values.
    shinyServer(function(input,output,session){

      # Listening to the click event where "$click" is the id of the button.
      observeEvent(input$click,{

        # Values that arrive from Javascript. You can see them through the server console.
          print(input$click)

        # Values from the mm1k model:  λ, μ, severs and k 😷.
          lambda <- input$click$lambda
          mean <- input$click$mean
          servers <- input$click$servers
          k <- (input$click$k - servers)

        # I send the values to build the model.
          i_mm1k <- NewInput.MM1K(lambda = lambda, mu = mean, k = k)
        # I check that the conditions are met in order to use this model ✔.
          CheckInput(i_mm1k)
        # building the model ⚒.
          o_mm1k <- QueueingModel(i_mm1k)
        # Extracting the values.
          # [Values that will be sent to Javascript]
            # The probability (p0, p1, ..., pk) of the clients in the system.
              pn <- Pn(o_mm1k)
            # The traffic intensity.
              traffic_intensity <- (L(o_mm1k) - Lq(o_mm1k))
            # The server use.
              server_use <- RO(o_mm1k)
            # The mean number of clients in the system.
              mnc_system <- L(o_mm1k)
            # The mean number of clients in the queue.
              mnc_queue <- Lq(o_mm1k)
            # The mean number of clients in the server.
              mnc_server <- (L(o_mm1k) - Lq(o_mm1k))
            # The mean time spend in the system.
              mts_system <- W(o_mm1k)
            # The mean time spend in the queue.
              mts_queue <- Wq(o_mm1k)
            # The mean time spend in the server.
              mts_server <- W(o_mm1k) - Wq(o_mm1k)
            # The mean time spend in the queue when there is queue.
              mtsq_queue <- Wqq(o_mm1k)
            # The throughput.
              throughput <- Throughput(o_mm1k)

          # I create a list that will save all the previous values to send them to Javascript and it receives them as a vector.
          # Unfortunately I didn't know how to send it as an associative vector.
            info <- list(pn, traffic_intensity,server_use, mnc_system, mnc_queue, mnc_server, mts_system, mts_queue, mts_server, mtsq_queue, throughput)

          # I send the values to Javascript.
          session$sendCustomMessage("handler_stable_state_chart", info)
      })
    })


library(optparse)
library(lattice)
library(ggplot2)
library(randomForest)
library(caret)

parse.path <- function(path) {
    if (is.null(path)){
        print_help(opt_parser)
        stop("path is a mandatory argument", call.=FALSE)
    }
    return(path)
}

parse.target <- function(target) {
    if (is.null(target)){
        print_help(opt_parser)
        stop("target is a mandatory argument", call.=FALSE)
    }
    return(target)
}

parse.maximum_iterations <- function(maximum_iterations) {
    if (is.null(maximum_iterations)) {
        print_help(opt_parser)
        stop("maximum_iterations is a mandatory argument", call.=FALSE)
    }
    if (!is.numeric(maximum_iterations)) {
        print_help(opt_parser)
        stop("maximum_iterations must be a number", call.=FALSE)
    }
    return(maximum_iterations)
}

parse.maximum_depth <- function(maximum_depth) {
    if (is.null(maximum_depth)) {
        print_help(opt_parser)
        stop("maximum_depth is a mandatory argument", call.=FALSE)
    }
    if (!is.numeric(maximum_depth)) {
        print_help(opt_parser)
        stop("maximum_depth must be a number", call.=FALSE)
    }
    return(maximum_depth)
}

load.data <- function(type, path, target) {
    x <- read.csv(paste(path, "/features_", type, ".csv", sep = ""))
    y <- read.csv(paste(path, "/labels_", type, ".csv", sep = ""))

    data = x
    data[length(x) + 1] = y

    data[[target]] = as.factor(data[[target]])
    return(data)
}

option_list = list(
    make_option(c("-p", "--path"), type="character", default=NULL, help="path to features and labels files", metavar="character"),
    make_option(c("-t", "--target"), type="character", default=NULL, help="target feature", metavar="character"),
    make_option(c("-i", "--maximum_iterations"), type="integer", default=100, help="maximum number of iterations", metavar="integer"),
    make_option(c("-d", "--maximum_depth"), type="integer", default=3, help="maximum depth of the tree", metavar="integer")
)

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

path = parse.path(opt$path)
target = parse.target(opt$target)
maximum_iterations = parse.maximum_iterations(opt$maximum_iterations)
maximum_depth = parse.maximum_depth(opt$maximum_depth)

train = load.data("train", path, target)
test = load.data("test", path, target)

common <- intersect(names(train), names(test))
for (p in common) {
    if (class(train[[p]]) == "factor") {
        levels(test[[p]]) <- levels(train[[p]])
    }
}

rf <- randomForest(
    formula(paste(target, "~.")),
    data=train,
    maxit=maximum_iterations,
    nodesize=maximum_depth
)
prediction <- predict(rf, test)
confusionMatrix(prediction, test[[target]])


#' Mean pairwise distance
#'
#' @param comm Community matrix giving sites (rows) by species (columns). Column names should match the
#'                   names in the phylogeny
#' @param phylogeny Phylogeny in the format used by \code{\link{ape}}; if missing dis is required
#' @param dis Species distance matrix; if missing will be extracted from the phylogeny
#' @param dis.transform Function (e.g., sqrt) to transform distance before computing mpd
#' @details Computes mean pairwise distance (MPD) for all site pairs (including within and between site MPD)
#' @return Matrix of pairwise distances; diagonal is witin site (alpha) MPD, other values are pairwise distances (beta MPD)
#' @useDynLib mbm c_mpd
#' @export
mpd <- function(comm, phylogeny, dis, dis.transform)
{
	if(missing(dis))
	{
		if(missing(phylogeny)) stop("Either phylogeny or dis matrix must be specified")
		dis <- cophenetic(phylogeny)
	} else {
		# do some error checking
		if((nrow(dis) != ncol(dis)) | any((colnames(dis) != rownames(dis))))
			stop("dis must be square with identical row and column names")
	}

	# make sure all species in comm and in dis match
	taxa <- sort(intersect(colnames(comm), rownames(dis)))
	if(length(taxa) < ncol(comm))
		warning(ncol(comm) - length(taxa), " taxa were dropped from comm because they were not in dis")
	if(length(taxa) < nrow(dis))
		warning(nrow(dis) - length(taxa), " taxa were dropped from dis because they were not in comm")
	dis <- dis[taxa, taxa]
	comm <- comm[,taxa]

	if(! missing(dis.transform))
		dis <- dis.transform(dis)

	spMat <- which(comm > 0, arr.ind = TRUE)
	spMat <- spMat[order(spMat[,1]),]
	sites = spMat[,1] - 1	# subtract one from indices because C is 0 indexed
	species = spMat[,2] - 1
	cDist <- numeric(nrow(comm)^2)
	res <- .C("c_mpd", species=as.integer(species), sites=as.integer(sites), N=as.integer(length(sites)),
		dist=as.double(dis), K=as.integer(nrow(dis)), dest=as.double(cDist), S=as.integer(nrow(comm)))
	matrix(res$dest, nrow=nrow(comm), ncol=nrow(comm), dimnames=list(rownames(comm), rownames(comm)))
}


# 3. faza: Vizualizacija podatkov
# **************************************************
# Zemljevid
# **************************************************
#source("lib/libraries.r")
slo.regije.shp = readOGR("podatki/SVN_adm_shp/SVN_adm1.shp") # preberemo podatke o zemljevidu
slo.regije.map = slo.regije.shp %>% spTransform(CRS("+proj=longlat +datum=WGS84")) # pretvorimo v ustrezen format
Imena_regij <- c(slo.regije.shp$NAME_1)

slo.regije.poligoni = fortify(slo.regije.map)
slo.regije.poligoni1<-slo.regije.poligoni %>%
  left_join(
    rownames_to_column(slo.regije.map@data),
    by = c("id" = "rowname")
  )

slo.regije.poligoni_kratek= slo.regije.poligoni1[,c("NAME_1", "long", "lat", "order", "hole", "piece", "id", "group")]

temperature_po_krajih <- read.csv("podatki/povprecne_temperature.csv",sep = ";")
Gorenjska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Gorenjska regija",2])
Goriška <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Goriska regija",2])
Jugovzhodna_Slovenija <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "JV SLO",2])
Koroška <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Koroska regija",2])
Notranjo_kraška <-mean(temperature_po_krajih[temperature_po_krajih[,3] == "Notranjsko-kraska regija",2])
Obalno_kraska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Obalno-kraska regija",2])
Osrednjeslovenska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Osrednjoslovenska regija",2])
Podravska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Podravska regija",2])
Pomurska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Pomurska regija",2])
Savinjska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Savinjska regija",2])
Posavska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Posavska regija",2])
Zasavska <- mean(temperature_po_krajih[temperature_po_krajih[,3] == "Zasavska regija",2])
povprecna_temperatura <- c(Gorenjska,Goriška,Jugovzhodna_Slovenija,Koroška,Notranjo_kraška,Obalno_kraska,Osrednjeslovenska,Podravska,Pomurska,Savinjska,Posavska,Zasavska)
Tabela_regije <- data.frame(NAME_1=Imena_regij,povprecna_temperatura)
left_join(Tabela_regije,slo.regije.poligoni_kratek,
          by = "NAME_1"
) %>%
  ggplot() +
  geom_polygon(
    mapping = aes(long, lat, group = group, fill = povprecna_temperatura),
    color = "grey"
  ) +
  coord_map() +
  scale_fill_binned() +
  theme_classic() +
  theme(
    axis.line = element_blank(),
    axis.ticks = element_blank(),
    axis.text = element_blank(),
    axis.title = element_blank(),
  ) +
  guides(fill=guide_legend(title="Povprečna letna \ntemperatura"))


#' @inheritParams stat_identity
#' @inheritParams geom_contour
#' @export
#' @eval rd_aesthetics("stat", "contour")
#' @eval rd_aesthetics("stat", "contour_filled")
#' @section Computed variables:
#' The computed variables differ somewhat for contour lines (computed by
#' `stat_contour()`) and contour bands (filled contours, computed by `stat_contour_filled()`).
#' The variables `nlevel` and `piece` are available for both, whereas `level_low`, `level_high`,
#' and `level_mid` are only available for bands. The variable `level` is a numeric or a factor
#' depending on whether lines or bands are calculated.
#' \describe{
#'  \item{`level`}{Height of contour. For contour lines, this is numeric vector that
#'    represents bin boundaries. For contour bands, this is an ordered factor that
#'    represents bin ranges.}
#'  \item{`level_low`, `level_high`, `level_mid`}{(contour bands only) Lower and upper
#'    bin boundaries for each band, as well the mid point between the boundaries.}
#'  \item{`nlevel`}{Height of contour, scaled to maximum of 1.}
#'  \item{`piece`}{Contour piece (an integer).}
#' }
#' @rdname geom_contour
stat_contour <- function(mapping = NULL, data = NULL,
                         geom = "contour", position = "identity",
                         ...,
                         bins = NULL,
                         binwidth = NULL,
                         breaks = NULL,
                         na.rm = FALSE,
                         show.legend = NA,
                         inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatContour,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      bins = bins,
      binwidth = binwidth,
      breaks = breaks,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname geom_contour
#' @export
stat_contour_filled <- function(mapping = NULL, data = NULL,
                                geom = "contour_filled", position = "identity",
                                ...,
                                bins = NULL,
                                binwidth = NULL,
                                breaks = NULL,
                                na.rm = FALSE,
                                show.legend = NA,
                                inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatContourFilled,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      bins = bins,
      binwidth = binwidth,
      breaks = breaks,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatContour <- ggproto("StatContour", Stat,

  required_aes = c("x", "y", "z"),
  default_aes = aes(order = after_stat(level)),

  setup_params = function(data, params) {
    params$z.range <- range(data$z, na.rm = TRUE, finite = TRUE)
    params
  },

  compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL,
                           breaks = NULL, na.rm = FALSE) {

    breaks <- contour_breaks(z.range, bins, binwidth, breaks)

    isolines <- xyz_to_isolines(data, breaks)
    path_df <- iso_to_path(isolines, data$group[1])

    path_df$level <- as.numeric(path_df$level)
    path_df$nlevel <- rescale_max(path_df$level)

    path_df
  }
)

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatContourFilled <- ggproto("StatContourFilled", Stat,

  required_aes = c("x", "y", "z"),
  default_aes = aes(order = after_stat(level), fill = after_stat(level)),

  setup_params = function(data, params) {
    params$z.range <- range(data$z, na.rm = TRUE, finite = TRUE)
    params
  },

  compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL, breaks = NULL, na.rm = FALSE) {
    breaks <- contour_breaks(z.range, bins, binwidth, breaks)

    isobands <- xyz_to_isobands(data, breaks)
    names(isobands) <- pretty_isoband_levels(names(isobands))
    path_df <- iso_to_polygon(isobands, data$group[1])

    path_df$level <- ordered(path_df$level, levels = names(isobands))
    path_df$level_low <- breaks[as.numeric(path_df$level)]
    path_df$level_high <- breaks[as.numeric(path_df$level) + 1]
    path_df$level_mid <- 0.5*(path_df$level_low + path_df$level_high)
    path_df$nlevel <- rescale_max(path_df$level_high)

    path_df
  }
)

#' Calculate the breaks used for contouring
#'
#' @inheritParams geom_contour
#' @param z_range Range of values within which breaks should be calculated
#'
#' @return A vector of breaks
#' @noRd
#'
contour_breaks <- function(z_range, bins = NULL, binwidth = NULL, breaks = NULL) {
  breaks <- allow_lambda(breaks)

  if (is.numeric(breaks)) {
    return(breaks)
  }

  breaks_fun <- fullseq
  if (is.function(breaks)) {
    breaks_fun <- breaks
  }

  # If no parameters set, use pretty bins
  if (is.null(bins) && is.null(binwidth)) {
    breaks <- pretty(z_range, 10)
    return(breaks)
  }

  # If provided, use bins to calculate binwidth
  if (!is.null(bins)) {
    # round lower limit down and upper limit up to make sure
    # we generate bins that span the data range nicely
    accuracy <- signif(diff(z_range), 1)/10
    z_range[1] <- floor(z_range[1]/accuracy)*accuracy
    z_range[2] <- ceiling(z_range[2]/accuracy)*accuracy

    if (bins == 1) {
      return(z_range)
    }

    binwidth <- diff(z_range) / (bins - 1)
    breaks <- breaks_fun(z_range, binwidth)

    # Sometimes the above sequence yields one bin too few.
    # If this happens, try again.
    if (length(breaks) < bins + 1) {
      binwidth <- diff(z_range) / bins
      breaks <- breaks_fun(z_range, binwidth)
    }

    return(breaks)
  }

  # if we haven't returned yet, compute breaks from binwidth
  breaks_fun(z_range, binwidth)
}

#' Compute isoband objects
#'
#' @param data A data frame with columns `x`, `y`, and `z`.
#' @param breaks A vector of breaks. These are the values for
#'   which contour lines will be computed.
#'
#' @return An S3 "iso" object, which is a `list()` of `list(x, y, id)`s.
#' @noRd
#'
xyz_to_isolines <- function(data, breaks) {
  isoband::isolines(
    x = sort(unique(data$x)),
    y = sort(unique(data$y)),
    z = isoband_z_matrix(data),
    levels = breaks
  )
}

xyz_to_isobands <- function(data, breaks) {
  isoband::isobands(
    x = sort(unique(data$x)),
    y = sort(unique(data$y)),
    z = isoband_z_matrix(data),
    levels_low = breaks[-length(breaks)],
    levels_high = breaks[-1]
  )
}

#' Compute input matrix for isoband functions
#'
#' Note that [grDevices::contourLines()] needs transposed
#' output to the matrix returned by this function.
#'
#' @param data A data frame with columns `x`, `y`, and `z`.
#'
#' @return A [matrix()]
#' @noRd
#'
isoband_z_matrix <- function(data) {
  # Convert vector of data to raster
  x_pos <- as.integer(factor(data$x, levels = sort(unique(data$x))))
  y_pos <- as.integer(factor(data$y, levels = sort(unique(data$y))))

  nrow <- max(y_pos)
  ncol <- max(x_pos)

  raster <- matrix(NA_real_, nrow = nrow, ncol = ncol)
  raster[cbind(y_pos, x_pos)] <- data$z

  raster
}

#' Convert the output of isolines functions
#'
#' @param iso the output of [isoband::isolines()]
#' @param group the name of the group
#'
#' @return A data frame that can be passed to [geom_path()].
#' @noRd
#'
iso_to_path <- function(iso, group = 1) {
  lengths <- vapply(iso, function(x) length(x$x), integer(1))

  if (all(lengths == 0)) {
    warn("stat_contour(): Zero contours were generated")
    return(new_data_frame())
  }

  levels <- names(iso)
  xs <- unlist(lapply(iso, "[[", "x"), use.names = FALSE)
  ys <- unlist(lapply(iso, "[[", "y"), use.names = FALSE)
  ids <- unlist(lapply(iso, "[[", "id"), use.names = FALSE)
  item_id <- rep(seq_along(iso), lengths)

  # Add leading zeros so that groups can be properly sorted
  groups <- paste(group, sprintf("%03d", item_id), sprintf("%03d", ids), sep = "-")
  groups <- factor(groups)

  new_data_frame(
    list(
      level = rep(levels, lengths),
      x = xs,
      y = ys,
      piece = as.integer(groups),
      group = groups
    ),
    n = length(xs)
  )
}

#' Convert the output of isoband functions
#'
#' @param iso the output of [isoband::isobands()]
#' @param group the name of the group
#'
#' @return A data frame that can be passed to [geom_polygon()].
#' @noRd
#'
iso_to_polygon <- function(iso, group = 1) {
  lengths <- vapply(iso, function(x) length(x$x), integer(1))

  if (all(lengths == 0)) {
    warn("stat_contour(): Zero contours were generated")
    return(new_data_frame())
  }

  levels <- names(iso)
  xs <- unlist(lapply(iso, "[[", "x"), use.names = FALSE)
  ys <- unlist(lapply(iso, "[[", "y"), use.names = FALSE)
  ids <- unlist(lapply(iso, "[[", "id"), use.names = FALSE)
  item_id <- rep(seq_along(iso), lengths)

  # Add leading zeros so that groups can be properly sorted
  groups <- paste(group, sprintf("%03d", item_id), sep = "-")
  groups <- factor(groups)

  new_data_frame(
    list(
      level = rep(levels, lengths),
      x = xs,
      y = ys,
      piece = as.integer(groups),
      group = groups,
      subgroup = ids
    ),
    n = length(xs)
  )
}

#' Pretty isoband level names
#'
#' @param isoband_levels `names()` of an [isoband::isobands()] object.
#'
#' @return A vector of labels like those used in
#'   [cut()] and [cut_inverval()].
#' @noRd
#'
pretty_isoband_levels <- function(isoband_levels, dig.lab = 3) {
  interval_low <- gsub(":.*$", "", isoband_levels)
  interval_high <- gsub("^[^:]*:", "", isoband_levels)

  label_low <- format(as.numeric(interval_low), digits = dig.lab, trim = TRUE)
  label_high <- format(as.numeric(interval_high), digits = dig.lab, trim = TRUE)

  # from the isoband::isobands() docs:
  # the intervals specifying isobands are closed at their lower boundary
  # and open at their upper boundary
  sprintf("(%s, %s]", label_low, label_high)
}