#  James Rekow

abdListCreator = function(M = 40, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                          thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                          interSmplMult = 0.01, intTime = 100, lambda = 0, returnParams = FALSE,
                          conGraph = NULL){

  #  ARGS: M - number of samples
  #        N - number of bacterial species in each sample
  #        iStrength - interaction strength. In range [0, 1]. Describes how strongly the bacterial species
  #                    within each individual sample interact with each other. Higher value indicates a
  #                    greater degree of interaction
  #        univ - universality. In range [0, 1]. Describes how similar the underlying dynamics governing
  #               the time evolution of the bacterial species are in different samples. At univ = 1 the
  #               dynamics are identical in each sample. This determines the variance in the growth
  #               rate vector and interaction matrix of each sample
  #        sigmaMax - maximum standard deviation of elements in the interaction matrix describing
  #                   the bacterial dynamics of a sample. Every sample in a cohort has the same
  #                   value of sigmaMax (e.g. it is a property of the whole cohort). Universality
  #                   acts like a scaling factor being multiplied by sigmaMax when determing sd of
  #                   elements in the interaction matrix. Although universality also effects the
  #                   variance of the growth rate vectors, while sigmaMax does not
  #        thresholdMult - determines the cutoff at which changes are considered small steps. When
  #                        integrating samples if eucidean length of the change in the abundance
  #                        vector during one times step is less than the threshold value then that
  #                        change is considered a small step. If there are 5 consecutive small steps in
  #                        a row the system is assumed to be at equilibrium, and the integration step is
  #                        terminated
  #        maxSteps - maximum number of steps allowed in integration step. If the integration has not
  #                   been completed after this many steps the current abundance vector is returned
  #        tStep - time step in the integration step
  #        interSmplMult - the fraction of a sample's abundances that get transmitted
  #                        upon contact with another sample. Transmission is bi-directional
  #                        and does not deplete the abundance of the dog from which it is
  #                        transmitted
  #        intTime - total time during the interaction step. Unrelated to tStep
  #        lambda - rate parameter for the exponentially distributed wait times between interactions
  #        returnParams - if TRUE grList and imatList will also be returned
  #        conGraph - "connectivity graph". Vertices represent samples and edges connect
  #                   samples that can interact
  #
  #  RETURNS: abdList - a list of length M containing the integrated and interacted (if lambda > 0)
  #                     numerical abundance vectors of length N from a single cohort
  #
  #  NOTE: typical non-zero value for lambda is 0.5 - 0.15. Expected value of waiting time is 1 / rate

  library(igraph)
  source("cohortCreator.r")
  source("eulerIntegrate.r")
  source("intraCohortInteraction.r")

  #  give a warning if conGraph is supplied but there are no interactions
  if(lambda == 0 && (!is.null(conGraph))){
    warning("Changing the cohort connectivity (conGraph) will have no effect if
            there are no interactions.")
  } #  end if

  #  used to determine if the system is near equilibrium
  threshold = {thresholdMult * tStep} ^ 2

  #  define integrator function to apply eulerIntegrate with desired parameter vals
  integrator = function(smpl){
    return(eulerIntegrate(smpl, threshold = threshold, maxSteps = maxSteps, tStep = tStep))
  } #  end integrator function

  #  create cohort and abundance list
  chrt = cohortCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax)
  abdList = lapply(chrt, integrator)

  #  simulate intra-cohort interaction if lambda > 0
  if(lambda > 0){

    #  update the abundances of each sample in the cohort
    for(i in 1:M){
      chrt[[i]][[1]] = abdList[[i]]
    } #  end for

    #  simulate intra-cohort interactions
    abdList = intraCohortInteraction(chrt, M = M, N = N, lambda = lambda, threshold = threshold,
                                     maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                     interSmplMult= interSmplMult, conGraph = conGraph)

  } #  end if

  #  if returnParams is TRUE return grList and imatList along with abdList
  if(returnParams){

    grList = lapply(chrt, "[[", 2)
    imatList = lapply(chrt, "[[", 3)

    return(list(abdList, grList, imatList))

  } #  end if returnParams

  #  default is to only return abdList
  else{
    return(abdList)
  } #  end else

} #  end abdListCreator function


# derived from https://github.com/Microsoft/LightGBM/blob/master/R-package/README.md
library(lightgbm)
data(agaricus.train, package='lightgbm')
train <- agaricus.train
dtrain <- lgb.Dataset(train$data, label=train$label)
params <- list(objective='regression', metric='l2')
model <- lgb.cv(params, dtrain, 10, nfold=5, min_data=1, learning_rate=1, early_stopping_rounds=10)


airline <- scan("http://stat.ethz.ch/Teaching/Datasets/airline.dat")

f1 <- seq(1, 144, 1)
f2 <- rep(c(1, rep(0, 11)), 12)
f3 <- rep(c(rep(0, 1), 1, rep(0, 10)), 12)
f4 <- rep(c(rep(0, 2), 1, rep(0, 9)), 12)
f5 <- rep(c(rep(0, 3), 1, rep(0, 8)), 12)
f6 <- rep(c(rep(0, 4), 1, rep(0, 7)), 12)
f7 <- rep(c(rep(0, 5), 1, rep(0, 6)), 12)
f8 <- rep(c(rep(0, 6), 1, rep(0, 5)), 12)
f9 <- rep(c(rep(0, 7), 1, rep(0, 4)), 12)
f10 <- rep(c(rep(0, 8), 1, rep(0, 3)), 12)
f11 <- rep(c(rep(0, 9), 1, rep(0, 2)), 12)
f12 <- rep(c(rep(0, 10), 1, rep(0, 1)), 12)
f13 <- rep(c(rep(0, 11), 1), 12)

reg <- lm(log(airline) ~ f1 + f2 + f3 + f4 + f5 + f6 + f7 + f8 + f9 + f10 + f11 + f12 + f13 - 1)

plot(reg, which=1)


# Function to fit discrete heavy tail functions
# Mostly using poweRlaw package
#
fit_dis_heavy_tail <- function (data_set,xmins,options.output)
{
  require(fitdistrplus)

  n <- length(unique(data_set))
  n_models <- 6
  # List of models
  model_list = list(list(model=vector("list", length=0),
                         GOF=vector("list", length=0),
                         xmin_estimation=vector("list", length=0),
                         uncert_estimation=vector("list", length=0),
                         k=0,
                         LL=0,
                         n=n,
                         AICc=0,
                         delta_AICc=0,
                         AICc_weight=0,
                         model_name=character(0),
                         model_set=character(0)))
  fit_ht <- rep(model_list,n_models)
  dim(fit_ht) <- c(n_models)

  # Declare models
  #
  # Discrete power law
  fit_ht[[1]]$model <- displ$new(data_set)
  fit_ht[[1]]$k <- 1
  # Discrete log-normal
  fit_ht[[2]]$model <- dislnorm$new(data_set)
  fit_ht[[2]]$k <- 2
  # Discrete exponential
  fit_ht[[3]]$model <- disexp$new(data_set)
  fit_ht[[3]]$k <- 1
  # Poisson
  fit_ht[[4]]$model <- dispois$new(data_set)
  fit_ht[[4]]$k <- 1
  # power law with exponential cutoff
  fit_ht[[5]]$model <- ""
  fit_ht[[5]]$k <- 2
  # Uniform
  fit_ht[[6]]$model <- ""
  fit_ht[[6]]$k <- 1

  # Estimate Xmin with complete data_set for power law model
  #
  if(xmins>1) {
    fit_ht[[1]]$xmin_estimation <- estimate_xmin(fit_ht[[1]]$model,
                                                 xmins = 1:xmins,
                                                 pars = NULL,
                                                 xmax = max(data_set))
    fit_ht[[1]]$model$setXmin(fit_ht[[1]]$xmin_estimation)
  } else {
    fit_ht[[1]]$model$setXmin(1)

  }

  model_names <- c("Power", "LogNorm","Exp","Poisson","PowerExp","Uniform")

  AICc_weight <- matrix( nrow = n_models, ncol = 1,
                         dimnames = list(model_names))

  delta_AICc <- AICc_weight
  GOF <- delta_AICc
  aic_min=Inf
  norm_aic_weight=0

  for (i in 1:(n_models))
  {
      # Set cut-off (x_min)
      fit_ht[[i]]$model$xmin <- fit_ht[[1]]$model$xmin

      # Correct n with xmin
      fit_ht[[i]]$n <-length(data_set[data_set>=fit_ht[[1]]$model$xmin])

      # Fit models
      #            PowerExp is different!!!!!!!!!
      #
      if(i<5){
        fit_ht[[i]]$model$setPars(estimate_pars(fit_ht[[i]]$model))
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- dist_ll(fit_ht[[i]]$model)
      } else if(i==5) {
        # Fit Power Exponential (not poweRlaw package)
        #
        fit_ht[[i]]$model<- discpowerexp.fit(data_set,fit_ht[[1]]$model$xmin)
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- fit_ht[[i]]$model$loglike
      } else if(i==6) {
        # Fit Power Exponential (not poweRlaw package)
        #
        fit_ht[[i]]$model<- max(data_set)
        teta<- max(data_set)
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- log(teta^(-length(data_set)))
      }

      #
      # Get Loglikelihood
      LL <- fit_ht[[i]]$LL
      k <- fit_ht[[i]]$k

      # Compute AICc
      #
      fit_ht[[i]]$AICc <- (2*k-2*LL)+2*k*(k+1)/(n-k-1)
      aic_min <- min(aic_min,fit_ht[[i]]$AICc)
      fit_ht[[i]]$model_name <- model_names[i]
  }

  for (i in 1:n_models){
    delta_AICc[i] <- fit_ht[[i]]$AICc - aic_min
    fit_ht[[i]]$delta_AICc <- delta_AICc[i]
    norm_aic_weight <- norm_aic_weight + exp(-0.5*fit_ht[[i]]$delta_AICc)
  }

  # Akaike weigths and dataframe with parameters
  #
  daf<-data.frame()

  for (i in 1:n_models){
    AICc_weight[i]  <- exp(-0.5*fit_ht[[i]]$delta_AICc)/norm_aic_weight
    fit_ht[[i]]$AICc_weight <- AICc_weight[i]
    if(i<5){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=fit_ht[[i]]$model$pars[1],
                                  par2=fit_ht[[i]]$model$pars[2],
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))
    } else if(i==5){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=-fit_ht[[i]]$model$exponent,
                                  par2=fit_ht[[i]]$model$rate,
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))
    }else if(i==6){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=fit_ht[[i]]$model,
                                  par2= NA,
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))

    }
  }

  # Plots
  #
  if (options.output$ploting){
    #setwd(options.output$resultsDir)

    require(RColorBrewer)
    colp <-brewer.pal(8,"Dark2")
    fnam <-paste0(options.output$data_set_name, "_xmin",fit_ht[[1]]$model$xmin,".png")
    png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")
    po <-plot(fit_ht[[1]]$model,xlab="Degree",ylab="log[P(X > x)]",main=options.output$data_set_name)
    for (i in 1:n_models){
      if(i<5) {
        lines(fit_ht[[i]]$model, col=colp[i])
      } else if(i==5) {
        est1 <- fit_ht[[i]]$model
        est1$xmin <- fit_ht[[1]]$model$xmin
        x <- sort(unique(data_set))
        x <- x[x>=est1$xmin]
        shift <- max(po[po$x>=est1$xmin,]$y)
        y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
        lines(x,y,col=colp[i])
      } else if(i==6) {
        est1 <- fit_ht[[i]]$model
        xmin <- fit_ht[[1]]$model$xmin
        x <- sort(unique(data_set))
        x <- x[x>=xmin]
        shift <- max(po[po$x>=xmin,]$y)
        y <- 1-((x - xmin+1)/(est1-xmin+1)*shift)
        lines(x,y,col=colp[i])
      }
  }

    legend("topright",model_names,bty="n",col=colp,lty=c(1,1,1,1),cex=1)
    dev.off()
  }

  return(list(fitted_models=fit_ht,da_fit=daf))

}

fit_ht_dplyr_helper <-function(df,xmin=1){
  opt.output$data_set_name <- unique(df$Network)
  temp <-fit_dis_heavy_tail(df$Degree,xmin,opt.output)
  temp <-data.frame(temp$da_fit)
  temp$Network <- unique(df$Network)
  return(temp)
}

# Plot of frequencies of patch sizes with fitted continuous heavy tail functions
# x: data
# fit_ht_df : dataframe with fitted parameters
#
freq_plot_con_ht <- function(x,fit_ht,tit="") # PLOT ALL FROM X=1 ?????????????????
{
  require(dplyr)
  require(ggplot2)
  xx <-as.data.frame(table(x))
  xx$x <- as.numeric(as.character(xx$x))
  ff <- filter(fit_ht,ModelNames=="PowerExp")
  if(nrow(ff)>0){
    xmin <- ff$xmin
    xx$pexp <-dpowerexp(xx$x,1,ff$par1,ff$par2)
  } else {
    xx$pexp<-0
  }
  ff <- filter(fit_ht,ModelNames=="Power")
  xmin <- ff$xmin
  xx$pow  <-dpareto(xx$x,xmin,ff$par1)

  ff <- filter(fit_ht,ModelNames=="Exp")
  xx$exp  <-dexp(xx$x,ff$par1)

  xx <-mutate(xx,pexp=ifelse(x<xmin,NA,pexp),pow=ifelse(x<xmin,NA,pow),
              exp=ifelse(x<xmin,NA,exp),
              Freq=Freq/sum(Freq))

  minFreq <- min(xx$Freq) - 0.5*min(xx$Freq)
  minFreq <- ifelse(minFreq<0,0,minFreq)
  g <- ggplot(xx, aes(y=Freq,x=x)) +  theme_bw() + geom_point(alpha=0.3) +
    coord_cartesian(ylim=c(1,min(minFreq)))+
    scale_y_log10() +scale_x_log10() + ylab("Frequency") + xlab("Degree") +ggtitle(tit)

  mc <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

  g <- g + geom_line(aes(y=pow,x=x,colour="P.law")) +
#    geom_line(aes(y=pexp,x=x,colour="P.law with\nexp. cutoff"))+
    geom_line(aes(y=exp,x=x,colour="Exp."))+
    scale_colour_manual(values=mc,name="")

  fil <- gsub(" ", "", tit, fixed = TRUE)
  fil <- paste0(fil,".png")
  if(tit=="")
    print(g)
  else
    ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

# Calculates The Corrected Akaike Criterion
# k: number of parameters
# n: number of points
# mdl1,2: fitted nonlinear models
#
Akaike_criterion<-function(k,n,mdl1,mdl2,names)
{
  Akaike <-data.frame(Model=names, AICc=0)
  Akaike$AICc[1] <- 2*k - 2* logLik(mdl1) + 2*k*(k+1)/(n-k-1)
  Akaike$AICc[2] <- 2*k - 2* logLik(mdl2) + 2*k*(k+1)/(n-k-1)
  Akaike$Delta <- Akaike$AICc - min(Akaike$AICc)
  return(Akaike)
}

# Function to plot CCDF of fitted continuous heavy tail functions using ggplo2
#
# x: data
# fit_ht : dataframe with fitted parameters
# tit: file name to save graph
# fit_ht1: second set of parameters to superimpose in the same graph

cdfplot_displ_exp <- function(x,fit_ht,tit="",xmax=0)
{
  require(poweRlaw)
  require(viridis)
  m <- displ$new(x)
  tP <- plot(m,draw=F)
  require(ggplot2)
  require(dplyr)

  ff <- filter(fit_ht,ModelNames=="Power")
  xmin <- ff$xmin

  tP1 <- cdfplot_conpl_exp_helper(x,tP,fit_ht,xmin)

  #tP2 <-filter(tP2, powl>= min(tP$Rank))
  #tP1 <-filter(tP1, powl>= min(tP$Rank))

  #mc <- c("#E69F00", "#56B4E9", "#009E73","#F0E442", "#0072B2","#D55E00", "#CC79A7")
  # Brewer
  #mc <- c("#d7191c","#fdae61","#abd9e9","#2c7bb6")

  g <- ggplot(tP, aes(x=x,y=y)) +  theme_bw() + geom_point(alpha=0.3) +
    coord_cartesian(ylim=c(1,min(tP$y)))+
    scale_y_log10() +scale_x_log10() + ylab("log[P(X > x)]") + xlab("Degree") #+ggtitle(tit)
  if(xmax>0) {
    g<-g + xlim(0,xmax+1) + scale_x_log10()
  }
  brk<-unique(tP1$model)
  g <- g + geom_line(data=tP1,aes(y=powl,x=psize,colour=model)) +
    #scale_colour_discrete(name="",breaks=brk)
    #scale_colour_manual(values=mc,name="",breaks=brk)
    #scale_colour_brewer(type="dark2",palette=7,name="",breaks=brk)
    scale_colour_viridis(discrete = TRUE)

  fil <- gsub(" ", "", tit, fixed = TRUE)
  fil <- paste0(fil,".png")
  if(tit=="")
    print(g)
  else
    ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

cdfplot_conpl_exp_helper <- function(x,tP,fit_ht,xmin,mode="gt")
{
  x1 <- unique(x)

  # Select model and generate a data frame
  #
  ff <- filter(fit_ht,ModelNames=="PowerExp")

  if(mode=="gt") {
    x1 <- x1[x1>=xmin]
    shift <- max(filter(tP,x>=xmin)$y)
  } else {
    x1 <- x1[x1<xmin]
    #xmin<-1
    #shift <-1
    # First select lower subset the change to the Xmin of this subset
    xmin <- ff$xmin
    shift <- max(filter(tP,x>=xmin)$y)
  }

  tP2 <- data_frame(psize=x1, powl=ppowerexp(x1,xmin,ff$par1,ff$par2,lower.tail=F)*shift,model="PowerExp")

  ff <- filter(fit_ht,ModelNames=="Power")
  m <- displ$new(x)
  m$setPars(ff$par1)
  m$setXmin(xmin)
  tP1 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Power")

  ff <- filter(fit_ht,ModelNames=="Exp")
  m <- disexp$new(x)
  m$setPars(ff$par1)
  m$setXmin(xmin)
  tP3 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Exp")

  ff <- filter(fit_ht,ModelNames=="LogNorm")
  m <- dislnorm$new(x)
  m$setPars(c(ff$par1,ff$par2))
  m$setXmin(xmin)
  tP4 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="LogNorm")

  ff <- filter(fit_ht,ModelNames=="Poisson")
  m <- dispois$new(x)
  m$setPars(c(ff$par1,ff$par2))
  m$setXmin(xmin)
  tP5 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Poisson")
  tP1 <- bind_rows(tP1,tP2,tP3,tP4,tP5)
}

# Complementary cumulative distribution plot using base graphics and poweRlaw package
#
ccdf_base_plot_ht <- function(fit_ht,data_set,netName=""){
    # Plots
  #

    require(RColorBrewer)
    colp <-brewer.pal(8,"Dark2")
    if(netName!="") {
        fnam <-paste0(netName, "_xmin",fit_ht[1]$xmin,".png")
        png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")
    }

    po <-plot(fit_ht[1]$model,xlab="Degree",ylab="log[P(X > x)]",main=options.output$data_set_name)
    for (i in 1:n_models){
      if(i!=n_models) {
        lines(fit_ht[[i]]$model, col=colp[i])
      } else {
        est1 <- fit_ht[[i]]$model
        x <- sort(unique(data_set))
        x <- x[x>=est1$xmin]
        shift <- max(po[po$x>=est1$xmin,]$y)
        y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
        lines(x,y,col=colp[i])
      }
    }

    legend("topright",model_names,bty="n",col=colp,lty=c(1,1,1,1),cex=1)
    if(netName!="") dev.off()
}


######## Knowledge Discovery and Data Mining (CS 513) ########
# (Assignment 5 - Hierarchical Clustering and Churn Dataset)

# Course      : CS 513 - A
# First Name  : PARAS
# Last Name   : GARG
# Id          : 10414982
# Purpose     : Assignment 5 - Hierarchical Clustering and Churn Dataset

######## ******************************************** ########

# clearing object environment
rm(list=ls());

# 5.1. Please use the "Hierarchical Clustering in R and the "average" linkage method to cluster the following 10 items

  # creating vectors
  x <- c(7, 10, 13, 21, 28, 28, 35, 43, 44, 50);
  y <- c(57, 62, 63, 71, 78, 88, 89, 90, 94, 98);
  # binding x & y vectors in xy vector
  xy <- cbind(x, y);
  # calculating distance between x and y
  xyDist <- dist(xy);
  # calculating hierarchical clustering
  xyHierarchical <- hclust(xyDist);
  plot(xyHierarchical);
  # calculating average linkage clustering
  xyAverage <- hclust(xyDist, method="average");
  plot(xyAverage);

# 5.2. In the CHURN dataset use R to classify (cluster) the customers,
#      into 3 groups (clusters) based on :
#      international plan, voice plan, and customer service calls.

  # reading CHURN dataset
  #churn <- read.csv("https://raw.githubusercontent.com/ericchiang/churn/master/data/churn.csv");
  churn <- read.csv(file="churn.csv");
  View(churn);

  # internation calls vector
  inCalls <- churn[, "Intl.Calls"];

  # voice plan vector
  vPlan <- churn[, "VMail.Plan"];
    # factoring vPlan if 'yes' then consider it as '1' and if 'no' then '0'
    vPlan <- as.factor(vPlan);
    levels(vPlan) <- 1:length(levels(vPlan));
    vPlan <- as.numeric(vPlan)-1;

  # customer service calls vector
  csCalls <- churn[, "CustServ.Calls"];

  # matrix of vectors on which clustering is based
  vectorMatrix <- cbind(inCalls, vPlan, csCalls);

  # k-means clustering algorithm
  clust <- kmeans(vectorMatrix, 3);

  # plotting a graph
  ?plot()

  plot(vectorMatrix, col=clust$cluster);
  points(clust$centers, col=1:3, pch=10, cex=5)

CS 513 - Knowledge Discovery & Data Mining/Assignments/Assignment #5 - Hierarchical Clustering/Assignment #5 Solution.r


linearIndexFromCoordinate <- function( coords, dims ) {
  indices <- coords[1,]
  for ( d in 2:length(dims) ) {
    indices <- indices + (coords[d,]-1) * prod(dims[1:d-1]);
  }
  return(indices)
}


require(Hmisc)
yrs <- runif(30, 0, 10)
ev  <- sample(0:1, 30, TRUE)
w <- bootkm(Surv(yrs, ev), times=5)
describe(w)
quantile(w, c(.025, .975))

# Try with only 2 events
ev <- c(1, 1, rep(0, 28))
w <- bootkm(Surv(yrs, ev), times=5)
describe(w)
quantile(w, c(.025, .975))


# basics.r: Catherine Lai
# little helper functions

sigmoid <- function(x) {
	return(1/(1 + exp(-x)))
}

refactor <- function(vrmi) {
        for (fx in names(vrmi)) {
                if (is.factor(vrmi[[fx]])) {
                        vrmi[[fx]] <- factor(unlevel(vrmi[[fx]]))
                }
        }
        return(vrmi)
}

to.zscore <- function(x, x.mean=mean(x,na.rm=T), x.sd=sd(x,na.rm=T)) {
        (x - x.mean)/x.sd
}

unfactor <- function(x) {
        as.numeric(levels(x)[x])
}

unlevel <- function(x) {
        levels(x)[x]
}

##################################################################################
prange.value <- function(x0, xname="Time", yname="Value"){
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { max(x[[yname]],na.rm=T)-min(x[[yname]],na.rm=T) }
	else {NA}
}

mean.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { mean(x[[yname]], na.rm=T) }
	else {NA}
}

sd.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { sd(x[[yname]], na.rm=T) }
	else {NA}
}

median.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { median(x[[yname]], na.rm=T) }
	else {NA}
}
min.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { min(x[[yname]], na.rm=T) }
	else {NA}
}

max.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { max(x[[yname]], na.rm=T) }
	else {NA}
}

slope.value <- function(x0, xname="ActualTime", yname="Value", sampletime=F) {
	#print(c(xname, yname))
	x <- x0[!is.na(x0[[yname]]),]
	zy <- x[[yname]]
	zx <- x[[xname]]

	if(nrow(x) > 1) {
		if (sampletime) {
			y <- lm(Value ~ SampleTime, data=x)$coefficients[2]
		}  else {
			y <- lm(zy ~ zx)$coefficients[2]
		}
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

intercept.value <- function(x0, xname="ActualTime", yname="Value", sampletime=F) {
	x <- x0[!is.na(x0[[yname]]),]
	zy <- x[[yname]]
	zx <- x[[xname]]

	if(nrow(x) > 1) {
		if (sampletime) {
			y <- lm(Value ~ SampleTime, data=x)$coefficients[1]
		} else {
			y <- lm(zy ~ zx)$coefficients[1]
		}
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

jitter.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) {
		y <- x[[yname]]
        	(sum(abs(diff(y)),na.rm=T)/(length(y)-1))/(sum(abs(y),na.rm=T)/length(y))
	} else {NA}
}

npoints.value <- function(x, xname="Time", yname="Value") {
	length(x[[yname]][!is.na(x[[yname]])])
}

get.legendre.coeffs <- function(x, degree=5) {
	lp <- legendre.polynomials(degree, normalize=T)
	p <- legendre.coeff(x$ActualTime,x$Value,lp)
	p
}

#############################################################################################
pred.point2 <- function(y1, y2, x) {
	a <- y1[2] - ((y2[2]-y1[2])/(y2[1]-y1[1])) * y1[1]
	m = ((y2[2]-y1[2])/(y2[1]-y1[1]))
	m*x + a
}

unlist.df <- function(x) {
	y <- NULL
	if (length(x) > 0) {
		for (i in 1:length(x)) {
			y <- rbind(y, x[[i]])
		}
	}
	y
}

unlist.vec <- function(x) {
	y <- NULL
	for (i in 1:length(x)) {
		y <- c(y, x[[i]])
	}
	y
}


# stepwise regression in R

# N.B. I have always used SAS for stepwise and all subsets regression.
# The following is intended to get you started.  I have no personal
#  experience with any of the following functions.

# stepwise regression.  R takes a different perspective, using AIC.
#  this has the benefit of being a common criterion for many sorts
#  of models.

# first define and fit the full model

bear <- read.table('bear.txt',header=T)
bear.lm <- lm(weight~.,data=bear)

# the . on the right hand side indicates all numeric variables

# then walk through a add/delete algorithm based on AIC
#  the resulting model is stored in bear.step

bear.step <- step(bear.lm)

# all subsets regression:
# the leaps() in the leaps package implements all subsets regression

# my philosophy towards packages has been conservative.  There are
# great packages and some poor packages.  leaps() is widely cited, but
# I haven't any experience with it.  Hence, I can't and won't make
# any recommendations.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/bear.r


#' dmrff.pre
#'
#' Construct an object for including this dataset in a DMR meta-analysis.
#'
#' @param estimate Vector of association effect estimates
#' (corresponds to rows of \code{methylation}).
#' @param se Vector of standard errors of the effect estimates.
#' @param methylation Methylation matrix (rows=features, columns=samples).
#' @param chr Feature chromosome (corresponds to rows of \code{methylation}).
#' @param pos Feature chromosome position.
#' @param maxsize Maximum number of CpG sites in a DMR.
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A list object containing all information needed for inclusion in a meta-analysis.
#'
#' @export
dmrff.pre <- function(estimate, se, methylation, chr, pos, maxsize=20, verbose=T) {
    idx <- order(chr, pos)
    methylation <- impute.matrix(methylation)
    m <- methylation - rowMeans(methylation)
    ss <- sqrt(rowSums(m^2))
    rho <- do.call(cbind, mclapply(1:maxsize, function(size) {
        sapply(1:length(idx), function(i) {
            if (i + size <= length(idx)) {
                numer <- sum(m[idx[i],] * m[idx[i+size],])
                denom <- ss[idx[i]] * ss[idx[i+size]]
                numer/denom
            }
            else NA
        })
    })) ## 2 minutes, 3.5Mb x maxsize
    sites <- paste(chr, pos, sep=":")
    list(sites=sites,
         chr=chr,
         pos=pos,
         estimate=estimate,
         se=se,
         rho=rho)
}


#set the working directory
#load data

library(parallel)
no_cores <- detectCores() - 1
cl <- makeCluster(no_cores)

#method for calculating LF entropy
getEntropy <- function(seq, pat, patternExists)
{
	entropy <- 0

	try({

	if(length(patternExists)>0 && patternExists == TRUE)
	{
		seqID <- seq
		patternID <- pat
		seqLenght <- resSeqLen[resSeqLen$ID == seqID,]$SEQLENGTH

		positions <- resPatternPositions[resPatternPositions$SEQID == seqID & resPatternPositions$ID_FRAGMENT1 == patternID,]
		locationVector <- sort(positions$LOCATION)
		positionsVector <- numeric(seqLenght)

		positionsVector[locationVector[]] = locationVector[]

		lfVector <- double(seqLenght)
		lfVector[locationVector[1]] = 1 /(positionsVector[locationVector[1]])
		lfVector[locationVector[2: length(locationVector)]] = 1 /(positionsVector[locationVector[2: length(locationVector)]]-positionsVector[locationVector[1: (length(locationVector)-1)]])

		pslfVector <- cumsum(lfVector)
		z <- sum(pslfVector)
		dpVector <- double(length(pslfVector[pslfVector != 0]))
		dpVector <-  pslfVector[pslfVector != 0]/z
		dplogVector <- vapply(dpVector,log2,double(1))

		entropy <- -sum(dpVector*dplogVector)

	}
	})
	return(entropy)
}

#calucalete LF entropy for every sequence/repeat in the analysis

clusterExport(cl,"getEntropy")
clusterExport(cl,"resPatternFreq")
clusterExport(cl,"resPatternPositions")
clusterExport(cl,"resSeq")
clusterExport(cl,"resSeqLen")
clusterExport(cl,"resVocabular")
clusterExport(cl,"seqVectorsF_P")
clusterExport(cl,"totalSeq")
clusterExport(cl,"totalVoc")

system.time(seqVectorsF_P <- vapply(1:totalSeq, function(i) parSapply(cl, 1:totalVoc, function(j) getEntropy(resSeq[i,], resVocabular[j,]$ID, (is.na(resPatternFreq[resPatternFreq$SEQID==resSeq[i,] & resPatternFreq$ID_FRAGMENT1==resVocabular[j,]$ID,1:2]$ID_FRAGMENT1)==FALSE))), double(totalVoc)))
rownames(seqVectorsF_P) <- resVocabular[]$ID
colnames(seqVectorsF_P) <- resSeq[]$ID

stopCluster(cl)
#sequence vectors are ready for further analysis

#__________________________________________________________________________
#similarity matrix and clustering
#install.packages("lsa")
library(lsa)
seqVectorsF_P_Host <- seqVectorsF_P
colnames(seqVectorsF_P_Host) <- resHost[]$HOST
cosSimMatrix <- cosine(data.matrix(seqVectorsF_P_Host))
cosDisimMatrix <- abs(cosSimMatrix-1)

#install.packages("d3heatmap")
library(d3heatmap)

hc <- hclust(as.dist(cosDisimMatrix))
hcd <- as.dendrogram(hc)
plot(hcd, cex = 0.6)
d3heatmap(cosDisimMatrix, Rowv = hcd, Colv = "Rowv")

#install.packages("factoextra")
#install.packages("purrr")
library(purrr)
library(factoextra)
res.hc <- hclust(as.dist(cosDisimMatrix))
grp <- cutree(res.hc, k = 2)
plot(res.hc, cex = 1, main = "direct non-complementary")
rect.hclust(res.hc, k = 2, border = 2:5)
fviz_cluster(list(data = cosDisimMatrix, cluster = grp), repel = TRUE, ellipse.type = "norm")


Residualise <- function(dt, var1, var2) {
  # This functions returns the residuals of two variables in a data table
  # saving them inside the same data table.
  #
  # ARGS
  # - dt     [data table]  the data table where the variable to residualise are
  # - var1   [numeric]     the variable to be used for the residuals
  # - var2   [numeric]     the variable to be residualised
  #
  # RETURN
  # - dt_complete [data table]  the complete dataset plus the new residualised
  #                             variable

  # Use complete dataset for the model
  dt_complete <- dt[complete.cases(dt[, eval(as.name(var2))])]
  regressionVar2 <- lm(eval(as.name(var2)) ~ eval(as.name(var1)),
                       data = dt_complete)
  # Add the residuals to the complete dataset
  dt_complete[, paste0("residuals", ((var2))) := residuals(regressionVar2)]

  return(dt_complete)
}


source("mtcars_dane.r")
source("machine_dane.r")
source("imports-85_dane.r")

lm_regression_mtCars <- function(){
  cat("\n\n\n LM MTCARS \n")
  cars_train = wczytaj_mtcars()$train
  cars_test = wczytaj_mtcars()$test
  cars_columns = wczytaj_mtcars()$columns

  model = lm(qsec~., data=cars_train[,cars_columns])
  predicted = predict(model, cars_test)
  cat("\nRMSE dla LM = ", rmse(cars_test$qsec,predicted))
  cat("\nMSE dla LM = ", mse(cars_test$qsec,predicted))

}

lm_regression_imports <- function(){
  cat("\n\n\n LM IMPORTS-85 \n")

  imports_train = wczytaj_imports_85()$train
  imports_test = wczytaj_imports_85()$test
  imports_columns = wczytaj_imports_85()$columns

  model = lm(symboling~., data=imports_train[,imports_columns])
  predicted = predict(model, imports_test)
  cat("\nRMSE dla LM = ", rmse(imports_test$symboling,predicted))
  cat("\nMSE dla LM = ", mse(imports_test$symboling,predicted))

}

lm_regression_machine <- function(){
  cat("\n\n\n LM MACHINE \n")

  machine_train = wczytaj_machine()$train
  machine_test = wczytaj_machine()$test
  machine_columns = wczytaj_machine()$columns

  model = lm(PRP~., data=machine_train[,machine_columns])
  predicted = predict(model, machine_test)
  cat("\nRMSE dla LM = ", rmse(machine_test$PRP,predicted))
  cat("\nMSE dla LM = ", mse(machine_test$PRP,predicted))

}

lm_regression_energy <-  function(){
  cat("\n\n\n LM ENERGY \n")

  energy_train = wczytaj_energy_efficiency()$train
  energy_test = wczytaj_energy_efficiency()$test
  energy_columns = wczytaj_energy_efficiency()$columns

  model = lm(HeatingLoad~., data=energy_train[,energy_columns])
  predicted = predict(model, energy_test)
  cat("\nRMSE dla LM = ", rmse(energy_test$HeatingLoad,predicted))
  cat("\nMSE dla LM = ", mse(energy_test$HeatingLoad,predicted))
}


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "REBOL 3 Mezzanine: Math"
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies
	}
	License: {
		Licensed under the Apache License, Version 2.0
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
]

mod: func [
	"Compute a nonnegative remainder of A divided by B."
	; In fact the function tries to find the remainder,
	; that is "almost non-negative"
	; Example: 0.15 - 0.05 - 0.1 // 0.1 is negative,
	; but it is "almost" zero, i.e. "almost non-negative"
	[catch]
	a [number! money! time!]
	b [number! money! time!] "Must be nonzero."
	/local r
] [
	; Compute the smallest non-negative remainder
	all [negative? r: a // b   r: r + b]
	; Use abs a for comparisons
	a: abs a
	; If r is "almost" b (i.e. negligible compared to b), the
	; result will be r - b. Otherwise the result will be r
	either all [a + r = (a + b)  positive? r + r - b] [r - b] [r]
]

modulo: func [
	{Wrapper for MOD that handles errors like REMAINDER. Negligible values (compared to A and B) are rounded to zero.}
	;[catch]
	a [number! money! time!]
	b [number! money! time!] "Absolute value will be used"
	/local r
] [
	; Coerce B to a type compatible with A
	any [number? a  b: make a b]
	; Get the "accurate" MOD value
	r: mod a abs b
	; If the MOD result is "near zero", w.r.t. A and B,
	; return 0--the "expected" result, in human terms.
	; Otherwise, return the result we got from MOD.
	either any [a - r = a   r + b = b] [make r 0] [r]
]

sign?: func [
	"Returns sign of number as 1, 0, or -1 (to use as multiplier)."
	number [number! money! time!]
][
	case [
		positive? number [1]
		negative? number [-1]
		true [0]
	]
]

minimum-of: func [
	{Finds the smallest value in a series}
	series [series!] {Series to search}
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/local spot
][
	size: any [size 1]
	if 1 > size [cause-error 'script 'out-of-range size]
	spot: series
	forskip series size [
		if lesser? first series first spot [spot: series]
	]
	spot
]

maximum-of: func [
	{Finds the largest value in a series}
	series [series!] {Series to search}
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/local spot
][
	size: any [size 1]
	if 1 > size [cause-error 'script 'out-of-range size]
	spot: series
	forskip series size [
		if greater? first series first spot [spot: series]
	]
	spot
]


# model : y = b0 + b1x1 + b2x2 + b3x3 +e
#x1 = 1 if system 2 is used, x1 = 0 otherwise
#x2 = 1 if system 3 is used, x2 = 0 otherwise
#x3 = 1 if system 4 is used, x3 = 0 otherwise
u1=7
u2=9
u3=6
u4=15
b0=u1
b1=u2-u1
b2=u3-u1
b3=u4-u1
print(b0)
print(b1)
print(b2)
print(b3)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Missing Value Treatment
#==============================================================================
# Title          : Missing Value Treatment.r
# Description    : Code to perform missing data analysis and imputation using
#                  a few packages.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180401
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on r-statistics.co by Selva Prabhakaran
#                  ggplot2 documentation
#                  https://www.r-bloggers.com/ggplot-your-missing-data-2/
#                  ggplot your missing data, njtierney - rbloggers
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
# install.packages("VIM")
# install.packages("ggplot2")
# install.packages('mice')
# install.packages("DMwR")
# install.packages('Hmisc')
# install.packages('Amelia')
# install.packages('reshape2')
# install.packages('dplyr')
# install.packages('wakefield')
# install.packages('rpart')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(VIM) # VIM package for Visualization and Imputation of Missing Values
library(mice)
library(ggplot2)
library(DMwR)
library(Hmisc)
library(Amelia)
library(Zelig) # Amelia's LM
library(reshape2)
library(dplyr)
library(wakefield)
library(rpart)

#------------------------------------------------------------------------------
# Data generation/preparation and pattern
#------------------------------------------------------------------------------
n <- 254
mydata <- r_data_frame(
    n = n, id, race, age, sex, hour, iq, height, died,
	Scoring = rpois(50), Smoker = valid) %>% r_na(prob=0.0)
mydata <- data.frame(mydata)

# backup original data
original <- mydata
# Introduce missing values - test purposes.
set.seed(666)
mydata[sample(1:nrow(mydata), 40), "Age"] <- NA
mydata[sample(1:nrow(mydata), 40), "Height"] <- NA
mydata[sample(1:nrow(mydata), 40), "Race"] <- NA

head(mydata)

# list missing values in data.
md.pattern(mydata)

# Show complete cases
mydata[complete.cases(mydata),]

#------------------------------------------------------------------------------
# Correlations to explore missing values
#------------------------------------------------------------------------------
# Create data frame indicating missingness by 1
x <- as.data.frame(abs(is.na(mydata)))
# Select columns with some (but not all) missing values
y <- x[,sapply(x, sd) > 0]
# Create a correlation matrix: Variables missing together have high correlation
cor(y)
# Rows are observed variables, columns are indicator variables for missingness
# high correlation means the row variables is strongly correlated with
# missingness of the column variable
cor(mydata[,c(3,6,7,9)], y, use = "pairwise.complete.obs")

#------------------------------------------------------------------------------
# Visualising missing data
#------------------------------------------------------------------------------
missmap(mydata) # Amelia package

#..............................................................................
# ggplot_missing(x)
# This function plots missing data of a dataset.
# inputs: a is a data.frame.
# notes: ggplot2 solution, based on njtierney - rbloggers.
ggplot_missing <- function(x, title = "Visualising missing data"){
  x %>%
    is.na %>%
    melt %>%
    ggplot(data = .,
           aes(x = Var2,
               y = Var1)) +
    geom_raster(aes(fill = value)) +
    scale_fill_grey(name = "",
                    labels = c("Present","Missing")) +
    theme_minimal() +
    theme(axis.text.x  = element_text(angle=45, vjust=0.5)) +
    labs(x = "Variables in Dataset",
         y = "Rows / observations") +
	ggtitle(title)
}
#..............................................................................
ggplot_missing(mydata)

# mice ------------------------------------------------------------------------
aggr(mydata, prop = F, numbers = T) # in number
aggr(mydata, prop = T, numbers = T) # in proportions
# red for missing values, darker values are high values.
matrixplot(mydata, interactive = F, sortby = "Age")
# Margin plot.
# Red dots have at least one missing.
# No observation with two missing values here.
marginplot(mydata[,c("Age","Height")])

# VIM -------------------------------------------------------------------------
scattmatrixMiss(mydata, interactive = F, highlight = c("Age"))

#------------------------------------------------------------------------------
# Imputation mean / median / mode
#------------------------------------------------------------------------------

# Hmisc -----------------------------------------------------------------------
library(Hmisc)
impute(mydata$Age, 20)  # replace specific number
impute(mydata$Age, mean)  # replace with mean
impute(mydata$Age, median)  # median

# DMwR ------------------------------------------------------------------------
library(DMwR)
actuals <- original$Age[is.na(mydata$Age)]
predicteds <- rep(mean(mydata$Age, na.rm=T), length(actuals))
regr.eval(actuals, predicteds)

#------------------------------------------------------------------------------
# k-Nearest Neighbours (kNN) Imputation
#------------------------------------------------------------------------------

# DMwR ------------------------------------------------------------------------
knnOutput <- knnImputation(mydata[, c("Age","IQ","Height","Scoring")])
anyNA(knnOutput)

# compute accuracy
actuals <- original$Age[is.na(mydata$Age)]
predicteds <- knnOutput[is.na(mydata$Age), "Age"]
regr.eval(actuals, predicteds)

# rpart -----------------------------------------------------------------------

# categorical
class_mod <- rpart(Race ~ . - IQ,
	data=mydata[!is.na(mydata$Race), ], method="class",
	na.action=na.omit)

# numeric
anova_mod <- rpart(Age ~ . - IQ, data=mydata[!is.na(mydata$Age), ],
	method="anova", na.action=na.omit)
Race_pred <- predict(class_mod, mydata[is.na(mydata$Age), ])
Age_pred <- predict(anova_mod, mydata[is.na(mydata$Age), ])

# compute accuracy
actuals <- original$Age[is.na(mydata$Age)]
predicteds <- Age_pred
regr.eval(actuals, predicteds)

actuals <- original$Race[is.na(BostonHousing$Race)]
predicteds <- as.numeric(colnames(Race_pred)[apply(Race_pred, 1, which.max)])
mean(actuals != predicteds)  # compute misclass error.

#------------------------------------------------------------------------------
# Multiple imputation
#------------------------------------------------------------------------------

# mice ------------------------------------------------------------------------

# Multivariate Imputation by Chained Equations (MICE)
system.time(mi.mydata <- mice(mydata, seed = 666, printFlag = FALSE))
# Check mi object
mice:::print.mids(mi.mydata)
# Plot mi object
plot(mi.mydata)
# Check imputed values for Dream variable (5 columns for 5 datasets)
mi.mydata$imp$Age
# Show 3rd imputed dataset
complete(mi.mydata, action = 3)
# Fit a model for each imputed dataset
mi.fit.Scoring <- with(mi.mydata, lm(Scoring ~ Height + Age))
# Pool results from imputed datasets
mi.pool.res <- pool(mi.fit.Scoring)
# Show summary: nmis: number missing; fmi: fraction of missing information
summary(mi.pool.res)
## Complete case analysis
cc.res <- with(mydata, lm(Scoring ~ Height + Age))
summary(cc.res)

# Amelia ----------------------------------------------------------------------
mydatasub <- mydata[,c(3,6,7,9)]
## Perform imputation
system.time(am.mydata <- amelia(x = mydatasub,
			parallel = "multicore", p2s = 0))
## Summary of imputed dataset
summary(am.mydata)
## Plot for imformation
plot(am.mydata)

# Fit linear model using zelig
res.zelig <- zelig(Scoring ~ Height + Age, data = am.mydata, model = "normal")
# results
summary(res.zelig)

# EOF


symbol_to_number <- function(symbol) {
  switch(
    symbol,
    A = 0,
    C = 1,
    G = 2,
    T = 3
  )
}

pattern_to_number <- function(pattern) {
  pattern_length <- nchar(pattern)
  if (pattern_length == 0)
    return(0)

  symbol <- substr(pattern, pattern_length, pattern_length + 1)
  prefix <- substr(pattern, 0, pattern_length - 1)
  return(4 * pattern_to_number(prefix) + symbol_to_number(symbol))
}

# message("Pattern")
# pattern <- scan("stdin", what="character", nlines=1)
#
# print(pattern_to_number(pattern))


 DPBCON Example Program Results

 Estimate of condition number =  7.42E+01


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 install.packages("feather")
 install.packages("data.table")
 install.packages("ggplot2")
 install.packages("plotly")
 install.packages("animation")

 library(feather)
 library(data.table)
 library(ggplot2)
 library(plotly)
 library(animation)

 AggData <- as.data.table(read_feather("d:/DT_4_ind"))

 str(AggData)

 head(AggData)

 ggplot(data = AggData, aes(x = date, y = value)) +
     geom_line() +
     facet_grid(type ~ ., scales = "free_y") +
     theme(panel.border = element_blank(),
           panel.background = element_blank(),
           panel.grid.minor = element_line(colour = "grey90"),
           panel.grid.major = element_line(colour = "green"),
           panel.grid.major.x = element_line(colour = "red"),
           axis.text = element_text(size = 10),
           axis.title = element_text(size = 12, face = "bold"),
           strip.text = element_text(size = 9, face = "bold")) +
     labs(title = "Electricity Consumption - Industry", x = "Date", y = "Load (kW)")

 AggData

 AggData[, week_num := as.integer(as.factor(AggData[, week]))]

 AggData

 n_type <- unique(AggData[, type])

 n_type

 n_date <- unique(AggData[, date])

 n_weekdays <- unique(AggData[, week])

 period <- 48

 data_reg <- AggData[(type == n_type[2] & date %in% n_date[57:70])]

 data_reg

 ggplot(data_reg, aes(date_time, value)) +
     geom_line() +
     theme(panel.border = element_blank(),
           panel.background = element_blank(),
           panel.grid.minor = element_line(colour = "grey90"),
           panel.grid.major = element_line(colour = "green"),
           panel.grid.major.x = element_line(colour = "red"),
           axis.text = element_text(size = 10),
           axis.title = element_text(size = 12, face = "bold")) +
     labs(title = "Regression Analysis - Education Buildings", x = "Date", y = "Load (kW)")

 N <- nrow(data_reg)

 trainset_window <- N / period

 matrix_train <- data.table(Load = data_reg[, value], Daily = as.factor(rep(1:period, trainset_window)), Weekly = as.factor(data_reg[, week_num]))

 matrix_train

 linear_model_1 <- lm(Load ~ 0 + ., data = matrix_train)

 linear_model_1

 summary_1 <- summary(linear_model_1)

 summary_1

 paste("R-squared: ", round(summary_1$r.squared, 3), ", p-value of F test: ", 1-pf(summary_1$fstatistic[1], summary_1$fstatistic[2], summary_1$fstatistic[3]))

 datas <- rbindlist(list(data_reg[, .(value, date_time)], data.table(value = linear_model_1$fitted.values, data_time = data_reg[, date_time])))

 datas

 datas[, type := rep(c("Real", "Fitted"), each = nrow(data_reg))]

 datas

 ggplot(data = datas, aes(date_time, value, group = type, colour = type)) + geom_line(size = 0.8) + theme_bw() +
     labs(x = "Time", y = "Load (kW)", title = "Fit from Multiple Linear Regression")

 ggplot(data = data.table(Fitted_values = linear_model_1$fitted.values,
                          Residuals = linear_model_1$residuals),
        aes(Fitted_values, Residuals)) +
     geom_point(size = 1.7) +
     geom_smooth() +
     geom_hline(yintercept = 0, color = "red", size = 1) +
     labs(title = "Fitted values vs Residuals")

 ggQQ <- function(lm){
     d <- data.frame(std.resid = rstandard(lm))
     y <- quantile(d$std.resid[!is.na(d$std.resid)], c(0.25, 0.75))
     x <- qnorm(c(0.25, 0.75))
     slope <- diff(y)/diff(x)
     int <- y[1L] - slope * x[1L]

     p <- ggplot(data = d, aes(sample = std.resid)) +
         stat_qq(shape = 1, size = 3) +
         labs(title = "Normal Q-Q",
              x = "Theoretical Quantiles",
              y = "Standardized Residuals") +
         geom_abline(slope = slope, intercept = int, linetype = "dashed",
                     size = 1, col = "firebrick1")
     return(p)
 }

 ggQQ(linear_model_1)

 linear_model_2 <- lm(Load ~ 0 + Daily + Weekly + Daily:Weekly, data = matrix_train)

 linear_model_2

 c(Previous = summary(linear_model_1)$r.squared, New = summary(linear_model_2)$r.squared)

 ggplot(data.table(Residuals = c(linear_model_1$residuals, linear_model_2$residuals), Type = c(rep("Multiple Linear Reg - simple", nrow(data_reg)), rep("Multiple Linear Reg with interactions", nrow(data_reg)))), aes(Type, Residuals, fill = Type)) + geom_boxplot()

 ggplotly()

 datas <- rbindlist(list(data_reg[, .(value, date_time)], data.table(value = linear_model_2$fitted.values, data_time = data_reg[, date_time])))

 datas

 datas[, type := rep(c("Real", "Fitted"), each = nrow(data_reg))]

 datas

 ggplot(data = datas, aes(date_time, value, group = type, colour = type)) + geom_line(size = 0.8) + theme_bw() + labs(x = "Time", y = "Load (kW)", title = "Fit from Multiple Linear Reg")

 ggplot(data = data.table(Fitted_values = linear_model_2$fitted.values, Residuals = linear_model_2$residuals), aes(Fitted_values, Residuals)) + geom_point(size = 1.7) + geom_hline(yintercept = 0, color = "red", size = 1) +
 labs(title = "Fitted values vs Residuals")

 ggQQ(linear_model_2)

 predWeekReg <- function(data, set_of_date){
     data_train <- data[date %in% set_of_date]

     N <- nrow(data_train)
     window <- N / period # number of days in the train set
     matrix_train <- data.table(Load = data_train[, value],
                                Daily = as.factor(rep(1:period, window)),
                                Weekly = as.factor(data_train[, week_num]))
     lm_m <- lm(Load ~ 0 + Daily + Weekly + Daily:Weekly, data = matrix_train)

     pred_week <- predict(lm_m, matrix_train[1:(7*period), -1, with = FALSE])

     return(as.vector(pred_week))
 }

 mape <- function(real, pred){
     return(100 * mean(abs((real - pred)/real)))
 }

 n_weeks <- floor(length(n_date)/7) - 2

 n_weeks

 lm_pred_weeks_1 <- sapply(0:(n_weeks-1), function(i)
     predWeekReg(AggData[type == n_type[1]], n_date[((i*7)+1):((i*7)+7*2)]))

 lm_pred_weeks_2 <- sapply(0:(n_weeks-1), function(i)
     predWeekReg(AggData[type == n_type[2]], n_date[((i*7)+1):((i*7)+7*2)]))

 lm_pred_weeks_3 <- sapply(0:(n_weeks-1), function(i)
     predWeekReg(AggData[type == n_type[3]], n_date[((i*7)+1):((i*7)+7*2)]))

 lm_pred_weeks_4 <- sapply(0:(n_weeks-1), function(i)
     predWeekReg(AggData[type == n_type[4]], n_date[((i*7)+1):((i*7)+7*2)]))

 lm_err_mape_1 <- sapply(0:(n_weeks-1), function(i)
     mape(AggData[(type == n_type[1] & date %in% n_date[(15+(i*7)):(21+(i*7))]), value],
          lm_pred_weeks_1[, i+1]))

 lm_err_mape_1

 lm_err_mape_2 <- sapply(0:(n_weeks-1), function(i)
     mape(AggData[(type == n_type[2] & date %in% n_date[(15+(i*7)):(21+(i*7))]), value],
          lm_pred_weeks_2[, i+1]))

 lm_err_mape_2

 lm_err_mape_3 <- sapply(0:(n_weeks-1), function(i)
     mape(AggData[(type == n_type[3] & date %in% n_date[(15+(i*7)):(21+(i*7))]), value],
          lm_pred_weeks_3[, i+1]))

 lm_err_mape_3

 lm_err_mape_4 <- sapply(0:(n_weeks-1), function(i)
     mape(AggData[(type == n_type[4] & date %in% n_date[(15+(i*7)):(21+(i*7))]), value],
          lm_pred_weeks_4[, i+1]))

 lm_err_mape_4

 datas <- data.table(value = c(as.vector(lm_pred_weeks_1),
                               AggData[(type == n_type[1]) & (date %in% n_date[-c(1:14,365)]), value]),
                     date_time = c(rep(AggData[-c(1:(14*48), (17473:nrow(AggData))), date_time], 2)),
                     type = c(rep("MLR", nrow(lm_pred_weeks_1)*ncol(lm_pred_weeks_1)),
                              rep("Real", nrow(lm_pred_weeks_1)*ncol(lm_pred_weeks_1))),
                     week = c(rep(1:50, each = 336), rep(1:50, each = 336)))

 saveGIF({
  oopt = ani.options(interval = 0.9, nmax = 50)
  for(i in 1:ani.options("nmax")){
    print(ggplot(data = datas[week == i], aes(date_time, value, group = type, colour = type)) +
            geom_line(size = 0.8) +
            scale_y_continuous(limits = c(min(datas[, value]), max(datas[, value]))) +
            theme(panel.border = element_blank(), panel.background = element_blank(),
                  panel.grid.minor = element_line(colour = "grey90"),
                  panel.grid.major = element_line(colour = "grey90"),
                  panel.grid.major.x = element_line(colour = "grey90"),
                  title = element_text(size = 15),
                  axis.text = element_text(size = 10),
                  axis.title = element_text(size = 12, face = "bold")) +
            labs(x = "Time", y = "Load (kW)",
                 title = paste("Forecast of MLR (", n_type[1], "); ", "week: ", i, "; MAPE: ",
                               round(lm_err_mape_1[i], 2), "%", sep = "")))
    ani.pause()
  }}, movie.name = "industry_1.gif", ani.height = 450, ani.width = 750)

Chapter 14/Case Study 3 - Forecast of Electricity Consumption.r


#' Calculate a marginal likelihood estimate from a density fit
#'
#' Estimates the marginal likelihood from a set of Monte Carlo samples using a fitted posterior density approximation.
#' For Gaussian process fits, the marginal likelihood estimation only makes sense if the GP was normalized during the fitting.
#' @param fit An mvd.density object obtained from one of the density fitting functions.
#' @param x Matrix or vector of positions at which to evaluate the density function.
#' @param p Unnormalized posterior probability values.
#' @param log Boolean which specifies whether p is in log scale. If true, the marginal likelihood is also return in log scale.
#' @export
mvd.marginal.likelihood <- function(fit, x, p, log)
{
    if (fit$type == "gp") {
        if (fit$log == T) {
            stop("Cannot calculate marginal likelihood estimate for Gaussian process on log scale")
        } else {
            if (log) {
                return(-log(fit$s))
            } else {
                return(1/fit$s)
            }
        }
    } else {
        fitp <- mvd.pdf(fit, x, log = TRUE)
        if (log) {
            res <- lm(p - fitp ~ 1)
            logml <- as.numeric(res$coefficients["(Intercept)"])
            return(logml)
        } else {
            res <- lm(log(p) - fitp ~ 1)
            logml <- as.numeric(res$coefficients["(Intercept)"])
            return(exp(logml))
        }
    }
}


options(error=traceback)

get_score <- function(fighter, scores) {
  scores[fighter, ]$Score
}

update_scores <- function(fight, scores, k=32) {
  fighter <- as.character(fight$Fighter)
  opponent <- as.character(fight$Opponent)
  result <- as.character(fight$Result)

  f_score <- get_score(fighter, scores)
  o_score <- get_score(opponent, scores)

  # Transformed rating for Elo algorithm
  f_rating <- 10 ^ (f_score / 400)
  o_rating <- 10 ^ (o_score / 400)

  # Expected score
  f_exp = f_rating / (f_rating + o_rating)
  o_exp = o_rating / (f_rating + o_rating)

  if (result == "def." || result == "def") {
    f_result = 1
    o_result = 0
  }
  # "Fighter" never loses to "Opponent"
  # else if (result == "loss") {
  #  f_result = 0
  #  o_result = 1
  #}
  else if (result == "vs." || result == "vs") {
    if (result == "No Contest" || result == "No contest") {
      return(scores)
    } else {
      f_result = 0.5
      o_result = 0.5
    }
  }
  else {
    return(scores)
  }

  f_new_score = round(f_score + k * (f_result - f_exp))
  o_new_score = round(o_score + k * (o_result - o_exp))

  scores[scores[, "Fighter"] == fighter, ]$Score <- f_new_score
  scores[scores[, "Fighter"] == opponent, ]$Score <- o_new_score

  return(scores)
}

save_rankings <- function(rankings, filename) {
  sink(filename)
  print(data.frame(Rank=1:nrow(rankings), rankings), row.names=FALSE)
  closeAllConnections()
  print(paste(c("Full list saved in", filename), collapse=" "))
}

parse_date <- function(date_string) {
  date_formats <- c("%B %d, %Y", "%B %d %Y", "%d %B, %Y", "%d %B %Y")

  for (date_format in date_formats) {
    date_obj <- as.Date(date_string, format=date_format)
    if (!is.na(date_obj)) {
      break
    }
  }
  return(date_obj)
}

scraped_results <- read.csv2("results.csv")
extra_results <- read.csv2("results_extra.csv")

results <- rbind(scraped_results, extra_results)
results$Date <- sapply(results$Date, parse_date)
results <- results[order(results$Date, results$Fight.Number), ]

all_names <- c(as.character(results$Fighter), as.character(results$Opponent))
fighters <- unique(all_names)

scores <- data.frame(fighters, 1000)
names(scores) <- c("Fighter", "Score")
rownames(scores) <- scores$Fighter

for (i in 1:nrow(results)) {
  scores <- update_scores(results[i, ], scores)
}

ranked <- scores[order(-scores$Score), ]

top <- ranked[1:30, ]
print("Top 30:")
print(top, row.names=FALSE)

# Uncomment to save full list to file
# save_rankings(ranked, "rankings.txt")


library(doMC)
registerDoMC(cores=4)
library(caret)

setwd("~/Desktop/chapter 2")
mydata <- read.csv("WA_Fn-UseC_-HR-Employee-Attrition.csv")
mydata$EmployeeNumber=mydata$Over18=mydata$EmployeeCount=mydata$StandardHours = NULL

set.seed(10000)
fitControl = trainControl(method="repeatedcv", number=10,repeats=10)
caretmodel = train(Attrition~., data=mydata, trControl=fitControl, method = "knn", tuneLength = 20)
caretmodel

set.seed(1000)
fitControl = trainControl(method="repeatedcv", number=10,repeats=10)
caretmodel1 = train(Attrition~., data=mydata, trControl=fitControl, method = "knn", tuneLength = 20)

caretmodel1

caretmodel1$finalModel

modelLookup(model = "knn")

getModelInfo(model = "knn")

library(kknn)

# save the model to disk
saveRDS(caretmodel1, "production_model.rds")

setwd("~/Desktop/chapter 2")


# Load mlbench library, which contains the Pima dataframe

library(mlbench)

# Load dataframe

data(PimaIndiansDiabetes2)

# Dimensions of dataframe

print(c("Dimensions of dataframe:"))
print(dim(PimaIndiansDiabetes2))

# Frequency of diabetes cases

print("Frequency of diabetes cases:")
print(table(PimaIndiansDiabetes2$diabetes))

# Dimensions of dataframe without missing values

print("Dimensions of dataframe without missing values:")
print(dim(na.omit(PimaIndiansDiabetes2)))

# Frequency of diabetes cases without missing values

print("Frequency of diabetes cases without missing values:")
print(table(na.omit(PimaIndiansDiabetes2)$diabetes))

# Missing values per column

print("Missing values per column:")
print(sapply(PimaIndiansDiabetes2, function(x) sum(is.na(x))))

# Entries with missing values in the dataframe

# print("Entries with missing values in the dataframe:")
# print(table(is.na(PimaIndiansDiabetes2)))

# Missing values per row

# print("Missing values per row:")
# print(rowSums(is.na(PimaIndiansDiabetes2)))

# Keep only data without missing values

reduced_dframe <- na.omit(PimaIndiansDiabetes2)

# Fit logistic regression to the data

model <- glm(
  diabetes ~ pregnant + glucose + pressure + triceps + insulin + mass + pedigree + age,
  data=reduced_dframe,
  family="binomial"
)

# Print summary of logistic regression

print("Summary of logistic regression:")
print(summary(model))

# Convert factor output variable to numeric

reduced_dframe$diabetes <- ifelse(reduced_dframe$diabetes == "pos", 1, 0)

# Dimensions of reduced dataframe

print(c("Dimensions of reduced dataframe:"))
print(dim(reduced_dframe))

# Frequency of diabetes cases in reduced dataframe

print("Frequency of diabetes cases in reduced dataframe:")
print(table(reduced_dframe$diabetes))

# Write reduced dataframe to CSV

write.table(reduced_dframe[, -9], "x.csv", quote=FALSE, sep=",", row.names=FALSE)
write.table(reduced_dframe[c("diabetes")], "y.csv", quote=FALSE, sep=",", row.names=FALSE)


###############################
# Quadratic Discriminant Analysis#
##################################
## NO WorkClass , it casued mistakes !!!!!

qda.fit=qda(income~age+education+capitalGain+capitalLoss+hoursPerWeek+sex
            +race+maritalStatus+relationship+occupation,data=adult.data)
qda.fit
qda.class=predict(qda.fit,adult.test)$class
table(qda.class,adult.test$income)
mean(qda.class!=adult.test$income)

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


#  James Rekow

conGraphCreator = function(graphType = c("smallworld", "scaleFree", "gnp", "gnm"), meanDegree, v){

  #  ARGS: graphType - type of graph to create
  #        meanDegree - mean degree of graph. Some graph types have a limited number of possible
  #                     mean degrees, at least in the igraph implementations.
  #        v - number of vertices in conGraph
  #
  #  RETURNS: conGraph - connectivity graph describing which samples can interact with each other

  ##  Mean degree notes:
  #  sample_pa = 2 * m, m must be an integer
  #  sample_gnp = p * (n - 1)
  #  sample_gnm = 2 * m / n
  #  sample_smallworld = 2 * nei (if dim = 1, only nei and dim affect mean degree)

  #  NOTE: the actual mean degree of the produced conGraph is only approximate, but almost always
  #  within 0.4 of the given meanDegree. There is better agreement for larger graphs.

  library(igraph)

  #  vector of graph types which currenltly have a method to create them
  supportedGraphTypes = c("smallWorld", "scaleFree", "gnp", "gnm")

  #  check that the given graph type is supported
  if(!(graphType %in% supportedGraphTypes)){
    stop("Invalid graphType")
  } #  end if

  #  check that the given mean degree is even
  evenMeanDegree = meanDegree %% 2 == 0

  #  issue a warning if the given mean degree is not even
  if(!evenMeanDegree){
    warning("In the current implementation smallworld, scalefree, and gnm methods may not work as
            intended if meanDegree is odd.")
  } #  end if

  ##  Implement the method corresponding to graphType to create a connectivity graph of the given
  ##  type with the given mean degree and number of vertices

  if(graphType == "smallWorld"){
    nei = 0.5 * meanDegree
    conGraph = sample_smallworld(dim = 1, size = v, nei = nei, p = 0.2, loops = FALSE, multiple = FALSE)
  } #  end if

  if(graphType == "scaleFree"){
    m = 0.5 * meanDegree
    conGraph = sample_pa(n = v, power = 1, m = m, directed = FALSE)
  } #  end if

  if(graphType == "gnp"){
    p = meanDegree / (v - 1)
    conGraph = sample_gnp(n = v, p = p, directed = FALSE, loops = FALSE)
  } #  end if

  if(graphType == "gnm"){
    m = meanDegree * v / 2
    conGraph = sample_gnm(n = v, m = m, directed = FALSE, loops = FALSE)
  } #  end if

  return(conGraph)

} #  end conGraphCreator function


import('../../base/operators')

#' Function to calculate and return a cleaned linear model
#'
#' @param formula   A formula specifying the relationship between variables
#' @param data      A data.frame, list, or by default the formula env containing vars
#' @param min_pts   Minimum number of points to create a model for
#' @param return_intercept  Whether the result data.frame should contain the intercept
#' @param atomic_class  Variable classes that should not be split by default
#' @return          A data.frame containing the model result
rlm = function(formula, data=environment(formula), min_pts=3, return_intercept=FALSE,
              atomic_class='vector') {
    pts = model.frame(formula, data)
    size = lapply(pts, function(x) {
        # could potentially convert to factor first as well
        if (is.logical(x) || is.factor(x) || is.character(x))
            as.list(table(x))
        else
            sum(!(is.na(x) | x==0))
    })
    names(size) = names(pts)
    size$'(Intercept)' = nrow(pts)

    # that's a bit clumsy, but it works -
    # better would be to use delimiter "" in unlist
    orig_names = names(size)
    size = unlist(size)
    for (n in orig_names)
        names(size) = sub(paste0(n,"\\."), n, names(size))

    #TODO: should drop covariates if unique, only if nothing left drop regression
    # (and display a warning of what was dropped)
    # also, drop factor levels individually if < min_pts
    if (nrow(pts) < min_pts || any(apply(pts, 2, function(x) length(unique(x)) == 1)))
        return(NULL)

    re = MASS::rlm(formula, data) %>%
        broom::tidy() %>%
        cbind(size = sapply(.$term, function(x) size[x])) %>%
        dplyr::as_data_frame()
    if (return_intercept)
        re
    else
        dplyr::filter(re, term != "(Intercept)")
}

if (is.null(module_name())) {
    library(testthat)

    re1 = rlm(Sepal.Width ~ Sepal.Length, data=iris)
    expect_equal(unname(unlist(re1['term'])), 'Sepal.Length')
    expect_equal(unname(unlist(re1['size'])), 150)

    re2 = rlm(Sepal.Width ~ Sepal.Length, data=iris, return_intercept=TRUE)
    ref2 = broom::tidy(MASS::rlm(Sepal.Width ~ Sepal.Length, data=iris))
    expect_equal(dplyr::select(re2, -size), ref2)

    re3 = rlm(Sepal.Width ~ Sepal.Length, data=iris, min_pts=200)
    expect_null(re3)

    # r uses first factor level as reference, others to compare -> 2 rows
    re4 = rlm(Petal.Length ~ Species, data=iris)
    expect_equal(nrow(re4), 2)
    expect_equal(sum(is.na(re4$size)), 0)

    # make sure we catch character factors as well
    iris2 = iris
    iris2$Species = as.character(iris2$Species)
    re5 = rlm(Petal.Length ~ Species, data=iris2)
    expect_equal(nrow(re5), 2)
    expect_equal(sum(is.na(re5$size)), 0)
}


library('randomNames')
NUMOFLINKS = 100
relations = data.frame(source = randomNames(1000,which.names='both'), target = "")
relations = relations[rep(seq_len(nrow(relations)), sample(1:10,nrow(relations), replace=T)),]
relations = relations[sample(nrow(relations),NUMOFLINKS),]
relations$target = sample(relations$source,nrow(relations), replace = T)
relations = relations[relations[,1]!=relations[,2], ]

# Have a look to the input table !
head(relations)

## Plot the graph using the IGRAPH package
library("igraph")
vertices<-data.frame("name" = unique(unlist(relations))) # node names
g = graph.data.frame(relations, directed=F, vertices=vertices) # raw graph

vertices$group = edge.betweenness.community(g)$membership # betweeness centrality for each node for grouping

plot(g,
     #mark.groups=vertices$group, # group vertices by betweeness indicator (redish blob background)
     layout=layout.auto,
     vertex.color = vertices$group, # color vertices by edge betweeness
	vertex.label= relations$target,
	vertex.label.dist=4.0, #puts the name labels slightly off the dots
	vertex.label.color='black', #the color of the name labels
	vertex.label.font=1,
	vertex.label.cex=.75,	#specifies the size of the font of the labels. can also be made to vary
	vertex.frame.color='blue', #the color of the border of the dots
     vertex.size=5,
     edge.arrow.size=0.8)


library(tidyverse)

data1 <- read_csv("../data/figure-1-data.csv", col_types="fi")

pie_data <- data1 %>%
  mutate(proportion=count/sum(count)) %>%
  arrange(desc(proportion)) %>%
  mutate(lab.ypos = cumsum(proportion) - 0.5*proportion)

ggplot(pie_data, aes(x=2, y=proportion, fill=familiarity)) +
  geom_bar(stat="identity", color="white") +
  coord_polar(theta="y", start=0) +
  geom_text(aes(y=lab.ypos, label=paste(round(proportion*100), "%", sep="")), color="white") +
  scale_fill_brewer(palette="Set1", name="Familiarity", guide=guide_legend(reverse=TRUE)) +
  theme_void()


library("rjson")
library(Metrics)
library("segmented")

# traceback()

# p-value for breakpoints
# order by mse

fileName <- "../others/papers_plos_data_time_series2_filtered_html.json"
input_content <- fromJSON(file = fileName)

# fileName <- "../data/plos_one_2019.txt"
# fileName <- "../k3/average_curves_label_k3_xs_ys.txt"
# fileName <- "syn_data.txt"
# conn <- file(fileName,open="r")
# linn <-readLines(conn)
# data<-vector("list",length(linn)/3)

global_valid_curves <- 0
global_invalid_curves <- 0

normalize <- function(x) {
	temp <- ((x - min(x)) / (max(x) - min(x)))
	return (temp)
}

get_segmented <- function(dati,doi,filename_curves,filename_mse,itmax,k,stopiferror,nboot,yy,i,xx) {
	result <- tryCatch({

	    out.lm<-lm(y~x,data=dati)
	    o<-segmented(out.lm, seg.Z=~x, psi=NA, control=seg.control(it.max=itmax, display=FALSE,K=k, stop.if.error=stopiferror, n.boot=nboot))
		y.mse <- mse(yy,broken.line(o,link=FALSE)$fit)

		if (y.mse >= 0.0001) {
		 	global_invalid_curves <<- global_invalid_curves + 1
		} else {
			# print(global_valid_curves)

			global_valid_curves <<- global_valid_curves + 1

			slopes<-slope(o)$x[,1]

			breakpoints<-o$psi[,2]
			pred<-predict(o)
			write(y.mse,file=filename_mse,append=TRUE)
			write(doi, file = filename_curves, append = TRUE)
			write.table(t(slopes), file = filename_curves, append = TRUE, col.names=FALSE, row.names=FALSE)
			write.table(t(breakpoints), file = filename_curves, append = TRUE, col.names=FALSE, row.names=FALSE)
			write.table(t(pred), file = filename_curves, append = TRUE, col.names=FALSE, row.names=FALSE)

		}

		return (o)

	}, error = function(e) {
		print("-----------------------------------------------")
		print(i)
		#print(paste("dati:", dati))
		print(paste("MY_ERROR:  ",e))
        print(xx)
        print(yy)
		# print(paste("Line: ", out.lm))
		#traceback()
		#browser()
		print("-----------------------------------------------")
		return ('')
	})
	return (result)
}

tests <- function(itmax,k,stopiferror) {
	# filename <- paste("../data/plos_one_2019_breakpoints_k4_original1_data.txt",sep="")
	# filename <- "segmented_curves_5_7_years.txt"
	# filename_mse <- "mse_curves_error_5_7_years.txt"
	# filename <- "k3_test.txt"
	# filename_mse <- "k3_msg_test.txt"
	# filename <- "segmented_curves_ori_original.txt"
	# filename_mse <- "mse_curves_ori_original.txt"

	filename <- "segmented_curves_html.txt"
	filename_mse <- "mse_curves_html.txt"
	conn <- file(filename,open="w")
	close(conn)
	conn2 <- file(filename_mse,open="w")
	close(conn2)

	nboot <- 0
	if (stopiferror) {
		nboot <- 5
	}
	vector.mse <- c()
	vector.p.value <- c()
	#for (i in seq(1,length(linn)/3)){
	for (i in seq(1,length(input_content))) {
		# if (i%%1000==0){
		#  print(i)
		#}

        if (length(input_content[[i]][[1]]$months) > 1) {

            doi<- input_content[[i]][[2]]$DI

            xx<-input_content[[i]][[1]]$months[2:length(input_content[[i]][[1]]$months)]

            #l1<-input_content[[i]][[1]]$html_views[2:length(input_content[[i]][[1]]$html_views)]
            #l2<-input_content[[i]][[1]]$pdf_views[2:length(input_content[[i]][[1]]$pdf_views)]
            #yy<-unlist(lapply(seq_along(l1),function(i) unlist(l1[i])+unlist(l2[i])))
            yy<-input_content[[i]][[1]]$html_views[2:length(input_content[[i]][[1]]$html_views)]

            xx<-normalize(xx)
            yy<-normalize(yy)

            dati<-data.frame(x=xx,y=yy)

            y<-get_segmented(dati,doi=doi,filename,filename_mse,itmax,k,stopiferror,nboot,yy,i,xx)
        }
    }
}

# tests(100,2,FALSE)
tests(100,4,FALSE)
print(global_valid_curves)
print(global_invalid_curves)

# total 162534
# validos 129872
# invalidos 31995
# problemas 667


require(rms)
set.seed(1)
a <- runif(100)
b <- factor(sample(c('a','b','c'), 100, TRUE))
b[10] <- NA
d <- data.frame(a, b)
x <- aregImpute(~ a + b, data=d)
x$imputed$b
fit.mult.impute(a ~ b, ols, x, data=d)


####### This tests weights in deeplearning for poisson by comparing results with expected behaviour  ######

setwd(normalizePath(dirname(R.utils::commandArgs(asValues=TRUE)$"f")))
source('../../h2o-runit.R')

test <- function(h) {

	fre = h2o.importFile(locate("smalldata/glm_test/freMTPL2freq.csv.zip"),conn = h,destination_frame = "fre")
	fre$VehPower = as.factor(fre$VehPower)
	fre = h2o.assign(fre[1:6000,],key = "fre")
	#fren = as.data.frame(fre)
	#fren$VehPower = as.factor(fren$VehPower)
	#library(gbm)
	#gg = gbm(formula = ClaimNb~ Area +as.factor(VehPower)+ VehAge+ DrivAge+ BonusMalus+ VehBrand + VehGas +Density +Region,distribution =  "poisson",verbose = T,
	 #        weights=Exposure,data = fren,n.trees = 100,interaction.depth = 1,n.minobsinnode = 1,shrinkage = .1,bag.fraction = 1,train.fraction = 1)
	#gg$train.error #1.9965
	#pr = predict(gg,newdata = fren,type = "response")
	#summary(pr) #mean = 1.052; min = 1.004; max = 1.807;

	hh = h2o.deeplearning(x = 4:12,y = "ClaimNb",distribution =  "poisson",hidden = c(30),epochs = 100,train_samples_per_iteration = -1,overwrite_with_best_model = F,
                      reproducible = T,activation = "Tanh",balance_classes = F,force_load_balance = F,
                      seed = -8224042382692318000,score_training_samples = 0,score_validation_samples = 0,
                      weights_column="Exposure" ,training_frame = fre)
	mean_deviance = hh@model$training_metrics@metrics$mean_residual_deviance
	ph = as.data.frame(h2o.predict(hh,newdata = fre))
  print(mean_deviance)
  print(mean(ph[,1]))
  print(min(ph[,1]))
  print(max(ph[,1]))
	expect_equal(1.996517,mean_deviance, 1e-5)
	expect_equal(1.066273, mean(ph[,1]), 1e-5 )
	expect_equal(0.8973423, min(ph[,1]), 1e-5 )
	expect_equal(1.328029, max(ph[,1]), 1e-5 )

	testEnd()
}
doTest("Deeplearning weight Test: deeplearning w/ weights for poisson distribution", test)


numeric_vector<-c(1, 10, 49) # Assign values to numeric vector
larger_than_ten<-numeric_vector<10 # Validate vector
larger_than_ten # print vector

character_vector<-C("a","b","c") # Assign values to character vector
boolean_vector<-(TRUE, FALSE) # Assign values to boolean vector

numeric_vector<-c(1, 4, 10, 39, 50, 66) # Assign values to numeric vector
numeric_vector[c(2,5)]
numeric_vector[c(2)]+numeric_vector[c(5)]
numeric_vector<-c(6, 7, 8, 9, 1, 2, 3, 4, 5)


## 3. Walking Through An Experiment ##

library(readr)
data <- read.csv("weight_loss.csv")
mean_group_a <- mean(data$A)
mean_group_b <- mean(data$B)

## 5. Restating Our Hypotheses ##

library(readr)
data <- read.csv("weight_loss.csv")
var_group_a <- var(data$A)
var_group_b <- var(data$B)

## 6. Looking At Differences ##

library(readr)
data <- read.csv("weight_loss.csv")
diff_mean <- mean(data$A) - mean(data$B)
diff_var <- (var(data$A)/length(data$A)) + (var(data$B)/length(data$B))

## 8. p-values ##

reject_null_stat_one <- TRUE
reject_null_stat_two <- FALSE

Data Analyst in R/Step 5 - Probability and Statistics/5. Hypothesis Testing in R/2. Hypothesis Testing.r


# Classify using multiclass gradient boosting method.
library(xgboost)
library(caret)
source("utils/load-data.r")
source("utils/accuracy-statistics.r")

OutputDir = "../data/"

AllData = LoadClassificationData()
PureLabels = AllData@data[AllData@data$pure,]$dominant
ValidationData = LoadValidationData()
ImpureValidation = ValidationData@data[!AllData@data$pure,]
TrainData = LoadTrainingData()

# Create an evaluation function so we can see RMSEs in progress
MGB = function(filename = paste0(OutputDir, "stat-gradientboost.csv"), exclude=c(), ...)
{
    PureData = TrainData@data[AllData@data$pure,GetTrainingNames(exclude=exclude)]
    ImpureData = TrainData@data[!AllData@data$pure,GetTrainingNames(exclude=exclude)]

    TrainMatrix = xgb.DMatrix(as.matrix(PureData), label=as.numeric(PureLabels)-1)
    set.seed(0xfadedad)
    Model = xgboost(TrainMatrix, objective="multi:softprob", num_class = 9, ...)

    PredRaw = predict(Model, newdata=as.matrix(ImpureData))
    Prediction = matrix(PredRaw, byrow=TRUE, ncol=9, dimnames=list(list(), levels(PureLabels)))
    Prediction = data.frame(Prediction)[names(ImpureValidation)]*100
    # 21.78, amazing, but at a cost of range compression
    plot(unlist(Prediction), unlist(ImpureValidation))
    AST = AccuracyStatTable(Prediction, ImpureValidation)
    print(AST)
    write.csv(AST, filename)
}

# Unoptimised
MGB(nrounds=14, filename = paste0(OutputDir, "stat-gradientboost-unoptimised.csv"))
# 21.21
MGB(nrounds=5, exclude=c("is.water", "osavi", "aspect", "lswi", "swir", "height"))
# Optimised
MGB(nrounds=14, params=list(eta=0.05, max_depth=7))
# Note: pure fuzz here gets 25.43! Less than 27 when using all samples.


### Racing Diffusion Model

### Single accumulator

# pigt, digt, rwaldt Copyright (C) 2013  Trisha Van Zandt distributed with:
# Logan, Van Zandt, Verbruggen, and Wagenmakers (2014).  On the ability to
# inhibit thought and action: General and special theories of an act of control.
# Psychological Review.

# Comments and changes added by Andrew Heathcote and Gabriel Tillman

rWald <- function(n, B, v, A)
  # random deviate function for single acumulator
{
  rwaldt <- function(n, k, l, tiny = 1e-6) {
    # random sample of n from a Wald (or Inverse Gaussian)
    # k = criterion, l = rate, assumes sigma=1 Browninan motion
    # about same speed as statmod rinvgauss

    rlevy <- function(n = 1, m = 0, c = 1) {
      if (any(c < 0))
        stop("c must be positive")
      c / qnorm(1 - runif(n) / 2) ^ 2 + m
    }

    flag     <- l > tiny
    x        <- rep(NA, times = n)
    x[!flag] <- rlevy(sum(!flag), 0, k[!flag] ^ 2)
    mu       <- k / l
    lambda   <- k ^ 2
    y        <- rnorm(sum(flag)) ^ 2
    mu.0     <- mu[flag]
    lambda.0 <- lambda[flag]
    x.0      <- mu.0 + mu.0 ^ 2 * y / (2 * lambda.0) -
      sqrt(4 * mu.0 * lambda.0 * y + mu.0 ^ 2 * y ^ 2) * mu.0 /
      (2 * lambda.0)

    z             <- runif(length(x.0))
    test          <- mu.0 / (mu.0 + x.0)
    x.0[z > test] <- mu.0[z > test] ^ 2 / x.0[z > test]
    x[flag]       <- x.0
    x[x < 0]      <- max(x)
    x
  }

  # Act as if negative v never terminates, cluge to do single accumulator
  # case by passing negative v
  if (length(v) != n)
    v <- rep(v, length.out = n)
  if (length(B) != n)
    B <- rep(B, length.out = n)
  if (length(A) != n)
    A <- rep(A, length.out = n)

  # Kluge to return -Inf for negative rates, so can implment one accumulator case
  out      <- numeric(n)
  ok       <- v > 0
  nok      <- sum(ok)
  bs       <- B[ok] + runif(nok, 0, A[ok])
  out[ok]  <- rwaldt(nok, k = bs, l = v[ok])
  out[!ok] <- Inf
  out
}

dWald <- function(t, v, B, A)
  # density for single accumulator
{
  digt <- function(t, k = 1, l = 1, a = .1, tiny = 1e-10) {
    # pdf of inverse gaussian at t with k +/- a/2 uniform variability
    # returns digt.0 if a<1e-10

    digt.0 <- function(t, k = 1, l = 1) {
      # pdf of inverse gaussian at t with no k variability
      # much faster than statmod's dinvgauss funciton

      lambda <- k ^ 2
      l0     <- l == 0
      e      <- numeric(length(t))
      if (any(!l0)) {
        mu     <- k[!l0] / l[!l0]
        e[!l0] <-
          -(lambda[!l0] / (2 * t[!l0])) * (t[!l0] ^ 2 / mu ^ 2 - 2 * t[!l0] / mu  + 1)
      }
      if (any(l0))
        e[l0]   <- -.5 * lambda[l0] / t[l0]
      x         <- exp(e + .5 * log(lambda) - .5 * log(2 * t ^ 3 * pi))
      x[t <= 0] <- 0
      x
    }

    options(warn = -1)
    if (length(k) != length(t))
      k <- rep(k, length.out = length(t))
    if (length(l) != length(t))
      l <- rep(l, length.out = length(t))
    if (length(a) != length(t))
      a <- rep(a, length.out = length(t))

    tpos <- t <= 0

    atiny    <- a <= tiny & !tpos
    a[atiny] <- 0

    ltiny        <- (l <= tiny) & !atiny & !tpos
    notltiny     <- (l > tiny) & !atiny & !tpos
    l[l <= tiny] <- 0
    x            <- numeric(length(t))

    # No threshold variability
    if (any(atiny))
      x[atiny] <- digt.0(t = t[atiny], k = k[atiny], l = l[atiny])

    # Threshold variability
    if (any(!atiny)) {
      if (any(notltiny)) {
        # rate non-zero

        sqr.t   <- sqrt(t[notltiny])

        term.1a <-
          -(a[notltiny] - k[notltiny] + t[notltiny] * l[notltiny]) ^ 2 / (2 * t[notltiny])
        term.1b <-
          -(a[notltiny] + k[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / (2 * t[notltiny])
        term.1  <-
          (exp(term.1a) - exp(term.1b)) / sqrt(2 * pi * t[notltiny])

        term.2a <- log(.5) + log(l[notltiny])
        term.2b <-
          2 * pnorm((-k[notltiny] + a[notltiny]) / sqr.t + sqr.t * l[notltiny]) -
          1
        term.2c <-
          2 * pnorm((k[notltiny] + a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.2d <- term.2b + term.2c
        term.2  <- exp(term.2a) * term.2d

        term.3  <- term.1 + term.2
        term.4  <- log(term.3) - log(2) - log(a[notltiny])
        x[notltiny] <- exp(term.4)
      }

      if (any(ltiny)) {
        # rate zero
        log.t    <- log(t[ltiny])
        term.1   <- -.5 * (log(2) + log(pi) + log.t)
        term.2   <- (k[ltiny] - a[ltiny]) ^ 2 / (2 * t[ltiny])
        term.3   <- (k[ltiny] + a[ltiny]) ^ 2 / (2 * t[ltiny])
        term.4   <- (exp(-term.2) - exp(-term.3))
        term.5   <- term.1 + log(term.4) - log(2) - log(a[ltiny])
        x[ltiny] <- exp(term.5)
      }

    }

    x[x < 0 | is.nan(x)] <- 0
    x
  }

  out      <- numeric(length(t))
  ok       <- v > 0
  out[ok]  <- digt(t[ok],
                   k = B[ok] + A[ok] / 2,
                   l = v[ok],
                   a = A[ok] / 2)
  out[!ok] <- 0
  out
}

# # Check density and normalization

# # Without Starting Point Variability
# par(mfrow=c(1,2))
# n=1e6; A=0; v=2; B=1
# integrate(dWald,lower=0,upper=Inf,A=A,v=v,B=B)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

# # With Starting Point Variability
# n=1e6; A=1; v=2; B=1
# integrate(dWald,lower=0,upper=Inf,A=A,v=v,B=B)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

pWald <- function(t, v, B, A)
  # cumulative density for single accumulator
{
  pigt <- function(t, k = 1, l = 1, a = .1, tiny = 1e-10) {
    # cdf of inverse gaussian at t with k +/- a/2 uniform variability
    # returns pigt.0 if a<=0

    pigt.0 <- function(t, k = 1, l = 1) {
      # cdf of inverse gaussian at t with no k variability
      # much faster than statmod's pinvgauss funciton

      mu       <- k / l
      lambda   <- k ^ 2
      e        <- exp(log(2 * lambda) - log(mu))
      add      <- sqrt(lambda / t) * (1 + t / mu)
      sub      <- sqrt(lambda / t) * (1 - t / mu)
      p.1      <- 1 - pnorm(add)
      p.2      <- 1 - pnorm(sub)
      x        <- exp(e + log(p.1)) + p.2

      x[t < 0] <- 0
      x
    }

    options(warn = -1)
    if (length(k) != length(t))
      k  <- rep(k, length.out = length(t))
    if (length(l) != length(t))
      l  <- rep(l, length.out = length(t))
    if (length(a) != length(t))
      a  <- rep(a, length.out = length(t))

    tpos <- t <= 0

    atiny    <- a <= tiny & !tpos
    a[atiny] <- 0

    ltiny        <- (l <= tiny) & !atiny & !tpos
    notltiny     <- (l > tiny) & !atiny & !tpos
    l[l <= tiny] <- 0

    x <- numeric(length(t))

    # No threshold variability
    if (any(atiny))
      x[atiny] <- pigt.0(t[atiny], k[atiny], l[atiny])

    # Threshold variability
    if (any(!atiny)) {
      if (any(notltiny)) {
        # rate non-zero

        log.t   <- log(t[notltiny])
        sqr.t   <- sqrt(t[notltiny])

        term.1a <- .5 * log.t - .5 * log(2 * pi)
        term.1b <-
          exp(-((k[notltiny] - a[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / t[notltiny]) /
                2)
        term.1c <-
          exp(-((k[notltiny] + a[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / t[notltiny]) /
                2)
        term.1  <- exp(term.1a) * (term.1b - term.1c)

        term.2a <- exp(2 * l[notltiny] * (k[notltiny] - a[notltiny]) +
                         log(pnorm(-(
                           k[notltiny] - a[notltiny] + t[notltiny] * l[notltiny]
                         ) / sqr.t)))
        term.2b <- exp(2 * l[notltiny] * (k[notltiny] + a[notltiny]) +
                         log(pnorm(-(
                           k[notltiny] + a[notltiny] + t[notltiny] * l[notltiny]
                         ) / sqr.t)))
        term.2  <- a[notltiny] + (term.2b - term.2a) / (2 * l[notltiny])

        term.4a <-
          2 * pnorm((k[notltiny] + a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.4b <-
          2 * pnorm((k[notltiny] - a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.4c <-
          .5 * (t[notltiny] * l[notltiny] - a[notltiny] - k[notltiny] + .5 / l[notltiny])
        term.4d <-
          .5 * (k[notltiny] - a[notltiny] - t[notltiny] * l[notltiny] - .5 / l[notltiny])
        term.4  <- term.4c * term.4a + term.4d * term.4b

        x[notltiny] <- (term.4 + term.2 + term.1) / (2 * a[notltiny])
      }

      if (any(ltiny)) {
        # rate zero
        sqr.t   <- sqrt(t[ltiny])
        log.t   <- log(t[ltiny])
        term.5a <- 2 * pnorm((k[ltiny] + a[ltiny]) / sqr.t) - 1
        term.5b <- 2 * pnorm(-(k[ltiny] - a[ltiny]) / sqr.t) - 1
        term.5  <-
          (-(k[ltiny] + a[ltiny]) * term.5a - (k[ltiny] - a[ltiny]) * term.5b) /
          (2 * a[ltiny])

        term.6a <-
          -.5 * (k[ltiny] + a[ltiny]) ^ 2 / t[ltiny] - .5 * log(2) - .5 * log(pi) + .5 *
          log.t - log(a[ltiny])
        term.6b <-
          -.5 * (k[ltiny] - a[ltiny]) ^ 2 / t[ltiny] - .5 * log(2) - .5 * log(pi) + .5 *
          log.t - log(a[ltiny])
        term.6 <- 1 + exp(term.6b) - exp(term.6a)

        x[ltiny] <- term.5 + term.6
      }

    }

    x[x < 0 | is.nan(x)] <- 0
    x
  }

  out <- numeric(length(t))
  ok <- v > 0
  out[ok] <- pigt(t[ok],
                  k = B[ok] + A[ok] / 2,
                  l = v[ok],
                  a = A[ok] / 2)
  out[!ok] <- 0
  out

}

# # Check cumulative density
# par(mfrow=c(1,2))
#
# n=1e6; A=0; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pWald(qs,A=A,v=v,B=B)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")
#
# n=1e6; A=1; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pWald(qs,A=A,v=v,B=B)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")

### Race model

rWaldRace <- function(n, v, B, A, t0, gf = 0, return.ttf = FALSE)
  # random function for Wald race.
{
  B[B < 0] <- 0 # Protection for negatives
  A[A < 0] <- 0
  n_v      <- ifelse(is.null(dim(v)), length(v), dim(v)[1])
  ttf      <- matrix(t0 + rWald(n * n_v, B = B, v = v, A = A), nrow = n_v)
  if (return.ttf)
    return(ttf)
  resp <- apply(ttf, 2, which.min)
  out  <-
    data.frame(RT = ttf[cbind(resp, 1:n)], R = apply(ttf, 2, which.min))

  if (gf[1] > 0) {
    is.gf <- as.logical(rbinom(dim(out)[1], 1, gf))
    out$RT[is.gf] <- NA
    out$R[is.gf] <- 1
  }

  out
}

n1Wald <- function(dt, v, B, A, t0, gf = 0)
  # Generates defective PDF for responses on node=1, dt (decison time) is a vector of times
{
  B[B < 0] <- 0 # Protection for negatives
  A[A < 0] <- 0
  n_acc <- ifelse(is.null(dim(v)), length(v), dim(v)[1])
  if (is.null(dim(dt)))
    dt <- matrix(rep(dt, each = n_acc), nrow = n_acc)
  dt <- dt - t0

  is.go <- !is.na(dt[1, ])
  n.go <- sum(is.go)

  if (!is.matrix(v))
    v <- matrix(rep(v, n.go), nrow = n_acc)
  if (!is.matrix(B))
    B <- matrix(rep(B, n.go), nrow = n_acc)
  if (!is.matrix(A))
    A <- matrix(rep(A, n.go), nrow = n_acc)

  # Winner
  dt[1, is.go] <-
    (1 - gf[1]) * dWald(dt[1, is.go], A = A[1, ], v = v[1, ], B = B[1, ])
  if (n_acc > 1)
    for (i in 2:n_acc)
      dt[1, is.go] <-
    dt[1, is.go] * (1 - pWald(dt[i, is.go], A = A[i, ], v = v[i, ], B = B[i, ]))

  dt[1, !is.go] <- gf[1]

  dt[1, ]
}

#### Alternative Code

# Code here was written by Gabriel Tillman. Simplified
# the density and probability function, while allowing for the specification
# of the diffusion coefficient (i.e., d). The diffusion coeffient parameter
# is available for the dwald_alt function but not the pwald_alt function.
# Still working on math for that, when start point variability is included.

dwald_alt <- function(t, v, b, A, d) {
  if(A==0) A <- 1e-5
  s = (1 / sqrt(t)) / d
  alpha = (b - A - (t * v)) / (t * s)
  beta  = (b - (t * v)) / (t * s)
  1 / A * (-v * pnorm(alpha) + s * dnorm(alpha) +
             v * pnorm(beta) - s * dnorm(beta))
}

pwald_alt <- function(t, v, b, A) {
  require(pracma)
  if(A==0) A <- 1e-5
  B = b - A
  (
    A / 2 + 0.3989422804014327 * (exp(1) ^ (-((B - t * v) ^ 2 / (2 * t))) -
        exp(1) ^ (-((A + B - t * v) ^ 2 / (2 * t)))) *
      t ^ 0.5 + 0.5 * (B - 0.5 / v - t * v) *
      (-1 + erfc((-(B / sqrt(t)) + sqrt(t) * v) / sqrt(2))) +
      0.5 * (-A - B + 0.5 / v + t * v) * (-1 + erfc((-((A + B) / sqrt(t)) +
                                                       sqrt(t) * v) /
        sqrt(2))) + ((-(1 / 2)) * exp(1) ^ (2 * B * v) *
                       erfc((B + t * v) / (sqrt(2) * sqrt(t))) +
                       (1 / 2) * exp(1) ^ (2 * (A + B) * v) *
                       erfc((A + B + t * v) / (sqrt(2) * sqrt(t)))) /
      (2 * v)) / A
}

# Check dwald_alt integrates to 1
# With Starting Point Variability
# n=1e6; A=0; v=2; B=1
# integrate(dwald_alt,lower=0,upper=Inf,A=A,v=v,b=B+A,d=1)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

# Check pwald_alt density
# n=1e6; A=0; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pwald_alt(qs,A=A,v=v,b=B+A)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")


#' Calculate any of the DNA methylation alcohol scores from Liu et al. 2016
#'
#' @param x DNA methylation matrix (rows=CpG sites, columns=samples).
#' @param model Model name from available list (\code{\link{dnamalci.models}()}).
#' Default is the `dnamalc.144cpg` score.
#' @return Scores derived for each sample in \code{x}.
#'
#' @export
dnamalci <- function(x, model = "dnamalc.144cpg") {
    stopifnot(is.matrix(x))

    ret <- dnamalci.get.model(model)
    ret$name <- model

    sites <- intersect(rownames(x), names(ret$coefficients))

    score <- rep(NA, ncol(x))
    if (length(sites) == 1)
        score <- ret$coefficients[sites] * x[sites,]
    if (length(sites) > 1)
        score <- as.vector(rbind(ret$coefficients[sites]) %*% x[sites,,drop=F])

    ret$sites <- sites
    ret$score <- score
    ret
}