#######################################################################
#######################################################################
#######################################################################
######                                                           ######
######      Routines for simulation of high-dimensionsal         ######
######                   multivariate normals                    ######
######                                                           ######
#######################################################################
#######################################################################
rbigmvn.setup <- function(mu,covfunc,covpars,Sigmalist,coords,
                          groups,neighbours,nNN,MaxDist,coord.type,
                          method="Gibbs",vars.to.monitor) {
#######################################################################
#
#   To set up the quantities required to simulate from a
#   high-dimensional multivariate normal distribution using
#   routine rbigmvnorm. Arguments:
#
#   mu        mean vector of the distribution
#   covfunc   Name of a function to compute covariances between
#             pairs of points. This function itself should have
#             two arguments: the first a vector of parameters,
#             and the second a matrix of "co-ordinates" or
#             covariates. Denoting the parameter vector by theta,
#             and the co-ordinates for variable i by x[i], the
#             covariance between variables i and j can be
#             computed as f(x[i],x[j],theta). It should return a
#             matrix of covariances. Note that the argument
#             "Sigmalist" (see below) offers an alternative
#             way to define the covariance structure.
#   covpars   Vector of parameters for the covariance function
#   coords    Matrix giving the "coordinates" or covariate values
#             for each variable, for use when evaluating the
#             covariance function. Row i corresponds to variable
#             i; the number of rows should match the length of mu.
#   groups    A numeric vector, the same length as mu, containing group
#             numbers. Variables in the same group will be simulated
#             as a block within each Gibbs sampler iteration. If
#             there are M groups then they must be numbered from
#             1 to M.
#   neighbours  A list of M vectors, where M is the number of groups.
#             The jth element of this list should be a vector of
#             indices for the variables that are not in group j but
#             are in its neighbourhood. This argument should not
#             be supplied if either nNN or MaxDist is provided;
#             but it must be supplied if neither of these is provided.
#   nNN       Optional scalar, giving the number of nearest neighbours
#             to include in the neighbourhood of each group. If supplied,
#             then distfunc must also be supplied; and neither
#             neighbours nor MaxDist should be supplied. Conversely,
#             if this is not supplied then either neighbours or
#             MaxDist must be supplied
#   MaxDist   Optional scalar, or vector of length M (number of groups)
#             giving the maximum distance to consider as being within
#             the neighbourhood of each group. A variable will be
#             considered as in the neighbourhood of a group if it is
#             within MaxDist of at least one site in the group, but
#             not otherwise. If this argument is supplied, then
#             distfunc must also be supplied; and neither neighbours
#             nor nNN should be supplied. Conversely, if this is not
#             supplied then either neighbours or nNN must be supplied
#   Sigmalist An optional list of covariance matrices, with length M
#             where M is the total number of groups. This should not
#             be used if cov.func is supplied. If provided, its jth
#             element should be the covariance matrix of all pairs of
#             variables within both group j and its neighbours (as defined
#             via the "neighbours" argument, which must therefore be
#             provided in this case). The ordering of variables in
#             this matrix must correspond with that in the full joint
#             distribution (i.e. it consists of the rows and columns
#             of the full covariance matrix corresponding to the
#             current group and its neighbours).
#             Note that the routine does *not* check that the elements
#             of the list are in mutual agreement (for example, that
#             the supplied covariance between any pair of sites is the
#             same for all groups where that pair appears). It is the
#             user's responsibility to check this, therefore.
#   coord.type  Either "geographical" (if coords is a two-column
#             matrix containing latitudes and longitudes - NB in
#             this case the first column should be latitude) or
#             "euclidean". This controls how distances between
#             variables are calculated.
#   method    Either "Gibbs" or "factorize". If "Gibbs", the routine
#             will set things up for a Gibbs sampler; if "factorize"
#             then it will set things up so that simulation is done
#             in a single pass (no iteration) using factorisation of
#             the full joint distribution into products of conditionals.
#             The latter is potentially quicker, but this increase in
#             speed may be offset by the need to specify considerably
#             larger neighbourhoods in order to achieve the same
#             level of accuracy.
#   vars.to.monitor   An optional vector of indices in the range
#             1:length(mu). If provided, the routine will
#             calculate the quantities needed to produce a trace
#             plot of the logarithm of the joint density of the
#             corresponding variables during random variate
#             generation when method="Gibbs". This allows
#             convergence monitoring.
#
# Note that if neighbourhoods are defined using nNN or MaxDist, it
# becomes necessary to calculate all of the pairwise intersite distances,
# which has a computational cost quadratic in the number of sites ...
#
#######################################################################
#
#   Checks on inputs and set up storage for results
#
  p <- length(mu)
  if (!is.matrix(coords)) stop("coords must be a matrix")
  if (nrow(coords) != p) {
    stop("coords has wrong number of rows - should be length(mu)")
  }
  if (length(groups) != p) stop("groups should have same length as mu")
  M <- max(groups)
  if (!all(sort(unique(groups))==1:M)) {
    stop("groups should be numbered from 1 to M where M is total number of groups")
  }
  if (missing(covfunc)) {
    if (missing(Sigmalist)) stop("Either covfunc or Sigmalist must be supplied")
  } else {
    if (!is.function(covfunc)) stop("covfunc should be the name of a function")
  }
  if (as.numeric(missing(neighbours))+as.numeric(missing(nNN))+
        as.numeric(missing(MaxDist)) != 2) {
    stop("You must provide exactly one of neighbours, nNN and MaxDist")
  }
  if (!missing(neighbours)) {
    if (!is.list(neighbours)) stop("neighbours must be a list")
    if (length(neighbours) != M) {
      stop("neighbours must have a list element for each group")
    }
  }
  if (!missing(nNN)) {
    if (!(length(nNN) %in% c(1,M))) {
      stop("nNN must be either a scalar, or a vector with an element for each group")
    }
  }
  if (!missing(MaxDist)) {
    if (!(length(MaxDist) %in% c(1,M))) {
      stop("MaxDist must be either a scalar, or a vector with an element for each group")
    }
  }
  if (!missing(Sigmalist)) {
    if (!missing(covfunc)) stop("Only one of covfunc and Sigmalist can be specified")
    if (missing(neighbours)) stop("'neighbours' must be specified when using 'Sigmalist'")
    if (length(Sigmalist) != M) stop("Length of Sigmalist doesn't match number of groups")
  }
  if (coord.type=="geographical") {
    distfunc <- howfar
  } else if (coord.type=="euclidean") {
    distfunc <- function(coords1,coords2) {
      sqrt(outer(coords1[,1],coords2[,1],"-")^2 +
             outer(coords1[,2],coords2[,2],"-")^2)
    }
  } else {
    stop("coord.type must be either 'geographical' or 'euclidean'")
  }
  cat(paste("Tested all inputs and these are ok\n"))

  group.details <- matrix(0,nrow=M,ncol=p)
  Sig12.Sig22Inv <- CondCovChol <- vector("list",M)
#
#   Set up neighbourhood structures for each group
#
  for (i in 1:M) {
    cat(paste("Working on block",i,"of",M,"...                \n"))
    group.details[i,groups==i] <- 1 # in network stations=1
    if (!missing(neighbours)) {
      tmp <- neighbours[[i]]
      tmp <- tmp[!(tmp %in% (1:p)[groups==i])] # double check no neighbours are actual stations?
      group.details[i,tmp] <- 2 # network neighbours =2?
    }
    if (!missing(nNN)) {
      nNN.cur <- nNN
      if (length(nNN) > 1) nNN.cur <- nNN[i]
      dist.cur <- distfunc(coords[groups==i,],coords[groups!=i,])
      min.dist <- apply(dist.cur,MARGIN=2,FUN=min)
      wanted.sites <- order(min.dist)[1:nNN.cur]
      tmp <- (1:p)[groups!=i]
      group.details[i,tmp[wanted.sites]] <- 2
    }
    if (!missing(MaxDist)) {
      MD.cur <- MaxDist
      if (length(MaxDist) > 1) MD.cur <- MaxDist[i]
      dist.cur <- distfunc(coords[groups==i,],coords[groups!=i,])
      wanted.sites <- (dist.cur <= MD.cur)
      tmp <- (1:p)[groups!=i]
      group.details[i,tmp[wanted.sites]] <- 2
    }
#
#   Now set up the components of the partitioned covariance matrix, and
#   required Choleski factors. The variables to condition on are the ones
#   that are in the neighbourhood of the current group and, if method
#   method="factorize", that are also in lower-numbered groups (because
#   these will already have been allocated by the time we get to the
#   current group).
#

# Use this whereever you want to stop with access to variables
#    browser()

    if (method=="Gibbs") {
      wanted.vars <- (group.details[i,]>0)
    } else if (method=="factorize") {
      wanted.vars <- (group.details[i,]>0 & groups <= i)
    } else {
      stop("method must be either 'Gibbs' or 'factorize'")
    }
    if (missing(Sigmalist)) {
      Sigma <- covfunc(covpars,coords[wanted.vars,])
    } else {
      Sigma <- Sigmalist[[i]]

      if (nrow(Sigma) != sum(group.details[i,]>0)) {
        stop(paste("Dimensions of Sigmalist[[",i,
                   "]] don't match required number of variables",sep=""))
      }
      if (method=="factorize") {                     # Get rid of elements for
        tmp <- (groups[group.details[i,]>0] <= i)    # groups that haven't been
        Sigma <- matrix(Sigma[tmp,tmp],
	         nrow=length(which(tmp==TRUE)),
		 ncol=length(which(tmp==TRUE)))                      # done yet
      }
    }
#    cat(paste("Now in the block and working on Sigma",i,"\n",sep=""))

    tmp <- group.details[i,wanted.vars]
#    Sig11 <- matrix(Sigma[tmp==1,tmp==1],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
#    Sig12 <- matrix(Sigma[tmp==1,tmp==2],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
#    Sig22 <- matrix(Sigma[tmp==2,tmp==2],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
    Sig11 <- Sigma[tmp==1,tmp==1]
    Sig12 <- Sigma[tmp==1,tmp==2]
    Sig22 <- Sigma[tmp==2,tmp==2]
    	# for first few there may be no neighbours
#    print(tmp)
    #print(length(tmp))
#    if (nrow(Sig22)>0) {
    if (length(which(tmp==2))>0) {
      Sig12.Sig22Inv[[i]] <- Sig12 %*% solve(Sig22)
      CondCovChol[[i]] <- chol(Sig11 - tcrossprod(Sig12.Sig22Inv[[i]],Sig12))
    } else {
      CondCovChol[[i]] <- chol(Sig11)
    }
  }
#
# Choleski factor of inverse of covariance matrix for monitoring
# locations
#
  if (!missing(vars.to.monitor)) {
    if (!(method == "Gibbs")) {
      warning("argument vars.to.monitor is only used when method='Gibbs'")
      SigInvChol <- NULL
      vtm <- NULL
    } else {
      Sigma <- covfunc(covpars,coords[vars.to.monitor,])
      SigInvChol <- solve(chol(Sigma))
      vtm <- vars.to.monitor
    }
  } else {
    SigInvChol <- NULL
    vtm <- NULL
  }
  invisible(list(mu=mu,groups=groups,group.details=group.details,
                 Sig12.Sig22Inv=Sig12.Sig22Inv,CondCovChol=CondCovChol,
                 SigInvChol=SigInvChol,method=method,vars.to.monitor=vtm))
}
#######################################################################
#######################################################################
#######################################################################
rbigmvnorm <- function(n,setup,nburnin=0,nthin=1,init,monitor=FALSE) {
#######################################################################
#
#   To simulate from a high-dimensional multivariate normal
#   distribution. Arguments:
#
#   n         Number of realisations required
#   setup     A list object containing all of the information
#             required to carry out the simulation. This
#             should be produced via a call to rbigmvn.setup
#   nburnin   Number of Gibbs Sampler iterations to use as "burnin".
#             Only used if setup$method="Gibbs".
#   nthin     Thinning rate for the sampler after the burnin period:
#             the n returned values will correspong to iterations
#             nburnin+nthin, nburnin+(2*nthin), ... , nburnin+(n*nthin)
#             Only used if setup$method="Gibbs".
#   init      Starting value for the Gibbs sampler. If supplied,
#             this can be used (for example) to generate further
#             draws from a chain that is already known to have
#             converged to its limiting distribution, thereby
#             eliinating the need for any further burnin.
#             Only used if setup$method="Gibbs".
#   monitor   A logical scale indicated whether to produce a
#             trace plot of the logarithm of the joint density
#             for the variables defined by setup$vars.to.monitor.
#             The purpose is to assess convergence of the Gibbs
#             sampler. To produce the plot *does* slow down the
#             iterations, however. Only used if setup$method="Gibbs".
#
#######################################################################
  p <- length(setup$mu)
  M <- nrow(setup$group.details)
  if (!missing(init)) {
    if (length(init) != p) stop("Lengths of 'init' and 'mu' don't match")
  }
  if (monitor & is.null(setup$vars.to.monitor)) {
    warning("No monitoring variables defined - trace plot will not be produced")
    monitor <- FALSE
  }
  sim <- matrix(nrow=n,ncol=p)
#
# Initialisation if we're using a Gibbs sampler
#
  if (setup$method=="Gibbs") {
    logL <- rep(0,nburnin+(n*nthin))
    ntt <- nthin
    if (missing(init))  {
      cat("Initialising Gibbs sampler ...                           \r")
      z <- rep(NA,p)
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        e <- rnorm(sum(wanted))
        z[wanted] <- setup$mu[wanted] + (setup$CondCovChol[[i]] %*% e)
      }
    } else {
      z <- init
    }
#
# Burnin for Gibbs sampler
#
    for (iter in (if (nburnin < 1) NULL else 1:nburnin)) {
      cat(paste("Gibbs sampler burnin period: iteration",iter,"of",nburnin,"...\r"))
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        mu1 <- setup$mu[wanted]
        y2 <- z[setup$group.details[i,]==2]
        mu2 <- setup$mu[setup$group.details[i,]==2]
        e <- rnorm(length(mu1))
        z[wanted] <- mu1 + (setup$Sig12.Sig22Inv[[i]] %*% (y2-mu2)) +
          t(setup$CondCovChol[[i]]) %*% e
      }
      if (monitor) {
        logL[iter] <- -sum((t(setup$SigInvChol) %*%
                              (z[setup$vars.to.monitor]-
                                 setup$mu[setup$vars.to.monitor]))^2)/2
      }
    }
    if (monitor) {
      pp <- 1/(nburnin+(nthin*n))
      ylim <- -0.5*qchisq(c(pp,1-pp),df=length(setup$vars.to.monitor))
      if (nburnin > 0) ylim <- c(ylim,logL[1:nburnin])
      ylim <- extendrange(ylim)
      plot(1:(nburnin+(nthin*n)),type="n",xlab="Iteration",ylab="Score",
           main="Gibbs sampler iterations: log-density score for monitoring variables",
           ylim=ylim)
      abline(v=nburnin,col="red")
      if (nburnin > 0) lines(1:nburnin,logL[1:nburnin])
    } else {
      ntt <- 1
    }
  }

  for (cur.sim in 1:n) {
    cat(paste("Generating sample",cur.sim,"of",n,"...               \r"))
    if (setup$method == "factorize") z <- rep(NA,p)
    for (iter in 1:nthin) {
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        mu1 <- setup$mu[wanted]
        e <- rnorm(length(mu1))
        if (setup$method=="Gibbs") {
          cond.vars <- (setup$group.details[i,]==2)
        } else if (setup$method=="factorize") {
          cond.vars <- (setup$group.details[i,]==2) & (setup$groups < i)
        }
        if (sum(cond.vars) > 0) {
          y2 <- z[cond.vars]
          mu2 <- setup$mu[cond.vars]
          z[wanted] <- mu1 + (setup$Sig12.Sig22Inv[[i]] %*% (y2-mu2)) +
            t(setup$CondCovChol[[i]]) %*% e
        } else {
            z[wanted] <- mu1 + t(setup$CondCovChol[[i]]) %*% e
        }
      }
      if (monitor & setup$method=="Gibbs") {
        cur.idx <- nburnin + ((cur.sim-1)*ntt) + iter
        logL[cur.idx] <- -sum((t(setup$SigInvChol) %*%
                                 (z[setup$vars.to.monitor]-
                                    setup$mu[setup$vars.to.monitor]))^2)/2
        if (cur.idx > 1) lines(c(cur.idx-1,cur.idx),logL[c(cur.idx-1,cur.idx)])
      }
    }
    sim[cur.sim,] <- z
  }
  sim
}
######################################################################
######################################################################
######################################################################
howfar <- function(sites1,sites2,units="km") {
######################################################################
#
# Function to calculate the distance between sets of points on the
# earth's surface, with co-ordinates given in latitude and longitude.
# Arguments:
#
# sites1  A matrix with 2 columns, indicating the (lat, long)
#		coordinates of each site in the first set (in
#		degrees!)
# sites2	The same for the second set of sites
# units		Either "km" (the default) or "nm" for distances in
#		nautical miles (*not* nanometers!)
#
# Value:	A matrix of distances, with rows corresponding to
#		the sites in sites1 and columns corresponding to
#		those in sites2. If sites1 and sites2 have row names,
#		these are copied over as appropriate
######################################################################
  n1 <- dim(sites1)[1]; n2 <- dim(sites2)[1]
  z <- matrix(nrow=n1,ncol=n2)
  rownames(z) <- rownames(sites1)
  colnames(z) <- rownames(sites2)
  pi180 <- pi/180
  for (i in 1:n1) {
    lat1 <- sites1[i,1]
    long1 <- sites1[i,2]
    lat2 <- sites2[,1]
    long2 <- sites2[,2]
    z[i,] <- sin(sites1[i,1]*pi180)*sin(sites2[,1]*pi180) +
             cos(sites1[i,1]*pi180)*cos(sites2[,1]*pi180) *
             cos((sites2[,2]-sites1[i,2])*pi180)
#
#   Next line deals with rounding errors that take the previous
#   line slightly outside the range (-1,1)
#
    z[i,] <- (60*180/pi)*acos(pmax(pmin(z[i,],1),-1))
  }
  if (units == "km") {
    z <- 1.852*z
  } else if (units != "nm") {
    stop("units must be either 'km' or 'nm'")
  }
  z
}


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6

x = crossprod(matrix(stats::rnorm(30), 10))
xs = fl(x)
y = 1:3
ys = fl(y)

solve_xy = solve(x, y)

test = dbl(solve(xs))
stopifnot(all.equal(test, solve(x), tol=tol))

test = dbl(solve(xs, ys))
stopifnot(all.equal(test, solve_xy, tol=tol))

test = dbl(solve(xs, y))
stopifnot(all.equal(test, solve_xy, tol=tol))

test = solve(xs, as.double(y))
stopifnot(all.equal(test, solve_xy, tol=tol))


library(shiny)
library(quantmod)
library(VGAM)

# Define server logic for random distribution application
shinyServer(function(input, output) {

  # acquiring data
  dataInput <- reactive({
    if (input$get == 0)
      return(NULL)

    return(isolate({
      getSymbols(input$symb,src="yahoo", auto.assign = FALSE)
    }))
  })

  datesInput <- reactive({
    if (input$get == 0)
      return(NULL)

    return(isolate({
      paste0(input$dates[1], "::",  input$dates[2])
    }))
  })

  returns <- reactive({
    if (input$get == 0)
      return(NULL)

    dailyReturn(dataInput())
  })

  xs <- reactive({
    if (input$get == 0)
      return(NULL)

    span <- range(returns())
    seq(span[1], span[2], by = diff(span) / 100)
  })

  # tab based controls
  output$newBox <- renderUI({
    switch(input$tab,
           "Charts" = chartControls,
           "Model" = modelControls,
           "VaR" = helpText("VaR")
    )
  })

  # Charts tab
  chartControls <- div(
    wellPanel(
      selectInput("chart_type",
                  label = "Chart type",
                  choices = c("Candlestick" = "candlesticks",
                              "Matchstick" = "matchsticks",
                              "Bar" = "bars",
                              "Line" = "line"),
                  selected = "Line"
      ),
      checkboxInput(inputId = "log_y", label = "log y axis",
                    value = FALSE)
    ),

    wellPanel(
      p(strong("Technical Analysis")),
      checkboxInput("ta_vol", label = "Volume", value = FALSE),
      checkboxInput("ta_sma", label = "Simple Moving Average",
                    value = FALSE),
      checkboxInput("ta_ema", label = "Exponential Moving Average",
                    value = FALSE),
      checkboxInput("ta_wma", label = "Weighted Moving Average",
                    value = FALSE),
      checkboxInput("ta_bb", label = "Bolinger Bands",
                    value = FALSE),
      checkboxInput("ta_momentum", label = "Momentum",
                    value = FALSE),

      br(),

      actionButton("chart_act", "Add Technical Analysis")
    )
  )

  TAInput <- reactive({
    if (input$chart_act == 0)
      return("NULL")

    tas <- isolate({c(input$ta_vol, input$ta_sma, input$ta_ema,
                      input$ta_wma,input$ta_bb, input$ta_momentum)})
    funcs <- c(addVo(), addSMA(), addEMA(), addWMA(),
               addBBands(), addMomentum())

    if (any(tas)) funcs[tas]
    else "NULL"
  })

  output$chart <- renderPlot({
    chartSeries(dataInput(),
                name = input$symb,
                type = input$chart_type,
                subset = datesInput(),
                log.scale = input$log_y,
                theme = "white",
                TA = TAInput())
  })

  # Model tab
  modelControls <- div(
    br(),

    sliderInput("n", "Number of bins in histogram",
                min = 1, max = 250, value = 30
    ),

    br(),

    wellPanel(
      selectInput("family", "Model returns as",
                  choices = c("normal", "double exponential", "t"),
                  selected = "normal"
      ),

      sliderInput("mu", "Mean",
                  min = -1, max = 1, value = 0, step = 0.01
      ),

      sliderInput("sigma", "Standard Deviation",
                  min = 0, max = 0.1, value = 0.05, step = 0.001
      ),
      conditionalPanel(condition = "input.family == 't'",
                       sliderInput("df", "Degrees of freedom",
                                   min = 2, max = 1000, value = 10
                       )
      )

    )
  )

  ys <- reactive({
    if (input$get == 0)
      return(NULL)

    switch(input$family,
           "double exponential" = dlaplace(xs(),
                                           location = input$mu,
                                           scale = input$sigma
           ),
           "normal" = dnorm(xs(),
                            mean = input$mu,
                            sd = input$sigma
           ),
           "t" = dt((xs() - input$mu) / input$sigma,
                    df = input$df) * sqrt(2 * length(returns()))
    )
  })

  ks <- reactive({
    switch(input$family,
           "double exponential" = ks.test(returns(), "plaplace",
                                          input$mu, input$sigma),
           "normal" = ks.test(returns(), "pnorm",
                              input$mu, input$sigma),
           "t" = ks.test((returns() - input$mu) / input$sigma, "pt",
                         input$df)
    )
  })

  output$hist <- renderPlot({
    hist(returns(), xlab = "returns", freq = FALSE,
         main = paste(input$symb, "Daily Returns:",
                      input$dates[1], "-", input$dates[2], sep = " "),
         breaks = input$n)
    lines(xs(), ys(), col = "red")
  })

  output$ks <- renderText({
    paste0("Kolmogorv-Smirnoff statistic: ", ks()$statistic)
  })
  output$ksp <- renderText({
    paste0("P-value for model: ", ks()$p.value)
  })

  # VaR tab
  output$text3 <- renderText({paste0(input$symb, " 3: ", input$tab)})

})


setwd("d:/NUS/HighFreqData")
hf <- read.csv(file="d:/NUS/HighFreqData/HighFrequency.csv", header=TRUE, sep=",")
library(dplyr)
library(ggplot2)

roll <- function(inp){
  a <- acf(as.matrix(inp),plot=FALSE,lag=1,type="covariance")
  r<-0
  scov <- a$acf[2]
  print(scov)
  if (scov<0){
    return(2*sqrt(-scov))
  }else{
    return(0)
  }
}

#summary statistics
summary(hf)

#TODO: Share Volume
#share volume taken to be Q.trade
#correlation of share volume and share price --> positively correlated means it moves together
#number of shares traded hf[,3]
#price of shares traded hf[,2]

cor_sharevol_px <- lm(hf[,2]~hf[,3], data=hf)
print(cor_sharevol_px)
summary(cor_sharevol_px)
scatter.smooth(x=hf$Q.Trade., y=hf$P.Trade., main="Share volume ~ Share price")

total_shares_traded <- sum(hf[,3])
print(total_shares_traded)

#TODO: Dollar volume
hf<-dplyr::mutate(hf,dolvol=hf[,2]*hf[,3])
dol_vol<-0
len_hf <-nrow(hf)
for (i in 1:len_hf){
  dol_vol<- dol_vol+hf[i,2]*hf[i,3]
}
print(dol_vol)

#TODO: Turnover
turnover <- total_shares_traded/6000000
print(turnover)

#TODO: Quoted Spread
#primary buy (ask) price hf[,4] --> you buy at the ask price that someone needs to receive in order to let go of the stock
#primary sell (bid) price hf[,9] --> you sell at the bid price that someone is willing to pay for the stock
hf <-dplyr::mutate(hf,quo_spr=hf[,4]-hf[,9])
av_quo_spr <- 0
for (i in 1:len_hf){
  a=hf[i,4]-hf[i,9]
  if (av_quo_spr>0){
    av_quo_spr<- mean(av_quo_spr, a)
  }else {
    av_quo_spr<-a
  }
}
print(av_quo_spr)

#TODO: Relative Spread
hf <-dplyr::mutate(hf,rel_spr=(hf[,4]-hf[,9])/hf[,2])

av_rel_spr <- 0
for (i in 1:len_hf){
  a=(hf[i,4]-hf[i,9])/hf[i,2]
  if (av_rel_spr>0){
    av_rel_spr<- mean(av_rel_spr, a)
  }else {
    av_rel_spr<-a
  }
}
print(av_rel_spr)

#TODO: percentage spread
hf <- dplyr::mutate(hf,midquo=(hf[,4]+hf[,9])/2)
hf <- dplyr::mutate(hf,per_spr=quo_spr/midquo)

wide_hf <- ncol(hf)
av_per_spr <- mean(hf[,28])
print(av_per_spr)

#TODO: effective spread
hf <- dplyr::mutate(hf,eff_spr=2*abs(hf[,2]-midquo))
av_eff_spr <- mean(hf[,29])
print(av_eff_spr)

#TODO: roll effective spread
roll_spr <- roll(hf[,2])
print(roll_spr)

#TODO: depth at ask
#columns 19-23 --> sell quantities
#columns 14-18 --> buy quantities
hf<- dplyr::mutate(hf,depth_ask=hf[,19]+hf[,20]+hf[,21]+hf[,22]+hf[,23])
av_ask_depth <- mean(hf[,30])
print(av_ask_depth)

#TODO:depth at bid
hf<- dplyr::mutate(hf,depth_bid=hf[,14]+hf[,15]+hf[,16]+hf[,17]+hf[,18])
av_bid_depth <- mean(hf[,31])
print(av_bid_depth)

#TODO: quality index
hf <- dplyr::mutate(hf,qi=((depth_bid+depth_ask)/2)/per_spr)
av_qi<- mean(hf[,32])
print(av_qi)

#TODO: short-term volatility
#find mean r with simple return
ret <- 0
for (i in 2:len_hf){
  a=i-1
  ret=ret+(hf[i,2]/hf[a,2]-1)
}

mean_ret=ret/(len_hf-1)

volat<-0
for (i in 2:len_hf){
  a=i-1
  volat=volat+(hf[i,2]/hf[a,2]-1)^2
  #print(sum_ret_diff)
}
print(volat)

summary(hf)
#write.csv(hf,"hf_output.csv")


# Name: Barnabas Forgo
# Email: psybf@nottingham.ac.uk
# Student ID: 4211949

require(FuzzyToolkitUoN);
require(rgl);

fis1 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, trapMF(   "low", c(0:10), c(0, 0, 1, 3, 1)));
  fis= addMF(fis, "input", 2, trapMF(  "mild", c(0:10), c(1, 4, 6, 9, 1)));
  fis= addMF(fis, "input", 2, trapMF("severe", c(0:10), c(7, 9, 10, 10, 1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,4,3,1,1), # IF temperature is very low THEN urgency is emergency
    c(2,4,2,1,1), # IF temperature is low THEN urgency is medium
    c(3,4,1,1,1), # IF temperature is normal THEN urgency is very low
    c(4,4,2,1,1), # IF temperature is high THEN urgency is medium
    c(5,4,3,1,1) # IF temperature is very high THEN urgency is emergency
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis2 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, trapMF(   "low", c(0:10), c(0, 0, 1, 3, 1)));
  fis= addMF(fis, "input", 2, trapMF(  "mild", c(0:10), c(1, 4, 6, 9, 1)));
  fis= addMF(fis, "input", 2, trapMF("severe", c(0:10), c(7, 9, 10, 10, 1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,4,3,1,1),

    c(2,1,1,1,1),
    c(2,2,2,1,1),
    c(2,3,3,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,2,1,1),

    c(4,1,1,1,1),
    c(4,2,2,1,1),
    c(4,3,3,1,1),

    c(5,4,3,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis3 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, gaussMF(   "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 2, gaussMF(        "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF(     "medium", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 2, gaussMF(     "severe", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF("very severe", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,6,3,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,2,1,1),
    c(2,5,3,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,2,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,2,1,1),
    c(4,5,3,1,1),

    c(5,6,3,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis4 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, gaussMF(   "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 2, gaussMF(        "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF(     "medium", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 2, gaussMF(     "severe", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF("very severe", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 100, 1)));

  rulelist = rbind(
    c(1,6,5,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,3,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,3,1,1),
    c(4,5,4,1,1),

    c(5,6,5,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis5 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,3,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,3,1,1),
    c(4,5,4,1,1),

    c(5,6,5,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis6 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,3,1),

    c(2,1,1,1,1),
    c(2,2,2,1,1),
    c(2,3,3,1,1),
    c(2,4,4,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,2,1,1),
    c(3,4,3,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,2,1,1),
    c(4,3,3,1,1),
    c(4,4,4,1,1),
    c(4,5,4,1,1),

    c(5,6,5,3,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}

fisFinal <- function() {
  fis= newFIS("emergency", defuzzMethod="bisector", impMethod="prod")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);
  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,3,1), # IF temperature is very low THEN urgency is emergency

    c(2,1,1,1,1), # IF temperature is low AND headache is very low THEN urgenc#y is very low
    c(2,2,2,1,1), # IF temperature is low AND headache is low THEN urgency is low
    c(2,3,3,1,1), # IF temperature is low AND headache is mild THEN urgency is medium
    c(2,4,4,1,1), # IF temperature is low AND headache is severe THEN urgency is high
    c(2,5,4,1,1), # IF temperature is low AND headache is very severe THEN urgency is high

    c(3,1,1,1,1), # IF temperature is normal AND headache is very low THEN urgency is very low
    c(3,2,1,1,1), # IF temperature is normal AND headache is low THEN urgency is very low
    c(3,3,2,1,1), # IF temperature is normal AND headache is mild THEN urgency is low
    c(3,4,3,1,1), # IF temperature is normal AND headache is severe THEN urgency is medium
    c(3,5,4,1,1), # IF temperature is normal AND headache is very severe THEN urgency is high

    c(4,1,1,1,1), # IF temperature is high AND headache is very low THEN urgency is very low
    c(4,2,2,1,1), # IF temperature is high AND headache is low THEN urgency is low
    c(4,3,3,1,1), # IF temperature is high AND headache is mild THEN urgency is medium
    c(4,4,4,1,1), # IF temperature is high AND headache is severe THEN urgency is high
    c(4,5,4,1,1), # IF temperature is high AND headache is very severe THEN urgency is high

    c(5,6,5,3,1)  # IF temperature is very high THEN urgency is emergency
  );
  fis= addRule(fis, rulelist);

  return(fis);
}

showMFS <- function(fis) {
  par(mfrow=c(3,1));
  plotMF(fis,"input",1);
  plotMF(fis,"input",2);
  plotMF(fis,"output",1);
}

intsurf <- function(fis, ix1=1, ix2=2, ox1=1, accuracy=15) {
	require(rgl);

	i1 = fis$inputList[[ix1]]
	i2 = fis$inputList[[ix2]]
	o1 = fis$outputList[[ox1]]

	i1b = i1$inputBounds
	i2b = i2$inputBounds

	i1_min = i1b[1]
	i1_max = i1b[length(i1b)]

	i2_min = i2b[1]
	i2_max = i2b[length(i2b)]

	x_values = seq(i1_min, i1_max, length = accuracy)
	y_values = seq(i2_min, i2_max, length = accuracy)

	m_values = meshgrid(x_values, y_values)

	o_values = evalFIS(cbind(c(m_values$x), c(m_values$y)), fis)

	z_values = matrix(o_values[,ox1], accuracy, accuracy, byrow=TRUE)

  plot3d(i1b, i2b, o1$outputBounds,
    xlab=i1$inputName, ylab=i2$inputName, zlab=o1$outputName,
    type='n'
  );

  zlim <- range(o1$outputBounds)
  zlen <- zlim[2] - zlim[1] + 1

  colorlut <- rainbow(zlen, start=2/6, end=0)

  col <- colorlut[ z_values-zlim[1]+1 ]

  surface3d(x_values, y_values, z_values, color=col, lit=T, smooth=F, shininess=128)
  # persp3d(x_values, y_values, z_values, color=col, lit=T, smooth=F, shininess=128)
}

projectPng <- function(projectName, dir, ...) {
  # get a list of existing plots for the project
  plots <- list.files(path=dir, pattern=glob2rx(paste0(projectName, "*.png")))
  # pull out numeric component of the plot files
  nums <- as.numeric(gsub(paste(projectName, ".png", sep="|"), "", plots))
  last <- max(nums)
  if (last == -Inf) last <- 0;
  # Create a new file name with an incremented counter.
  newFile <- paste0(projectName, sprintf("%03d", last + 1), ".png")
  # now call png
  png(file.path(dir, newFile), ...)
}

fis= fisFinal();

# projectPng("cw", "C:\\work\\fuz", width=1000, height=1000, pointsize=20)
# intsurf(fis, accuracy=20);
# dev.off()
# intsurf(fis, accuracy=100);
# rgl.snapshot("C:\\work\\fuz\\lastfis.png")
# projectPng("cw", "C:\\work\\fuz", width=800, height=1000, pointsize=20)
# showMFS(fis);
# dev.off()

values= rbind(
    c(5,0),   # 1
    c(3,0),   # 2
    c(7,0),   # 3
    c(5,3),   # 4
    c(5,5),   # 5
    c(5,7),   # 6
    c(5,10),  # 7
    c(0,5),   # 8
    c(0,0),   # 9
    c(10,5),  #10
    c(0,10),  #11
    c(10,0),  #12
    c(10,10)  #13
  )

expected= rbind(
    0,   # 1
    0,   # 2
    0,   # 3
    15,  # 4
    25,  # 5
    50,  # 6
    75,  # 7
    100, # 8
    100, # 9
    100, #10
    100, #11
    100, #12
    100  #13
  )

rmse <- function(actual, expected) {
  return(sqrt(mean((actual - expected)^2)))
}

print(rmse(evalFIS(values, fis1()), expected))
print(rmse(evalFIS(values, fis2()), expected))
print(rmse(evalFIS(values, fis3()), expected))
print(rmse(evalFIS(values, fis4()), expected))
print(rmse(evalFIS(values, fis5()), expected))
print(rmse(evalFIS(values, fis6()), expected))
print(rmse(evalFIS(values, fisFinal()), expected))


year <- rep(2012:2014, each=4)
quarter <- rep(1:4,3)
cpi <- c(162.2,164.6,166.5,166.0,166.2,167.0,168.6,169.5,171.0,172.1,173.3,174.0)
plot(cpi,xaxt="n",ylab="cpi",xlab="")
axis(1,labels=paste(year,quarter,sep="Q"),at=1:12,las=3)
fit <- lm(cpi ~ year + quarter)
data2015 <- data.frame(year=2015,quarter=1:4)
cpi2015 <- predict(fit,newdata = data2015)
style  <- c(rep(1,12), rep(2,4))

#
# Different plot
#

plot(c(cpi,cpi2015),xaxt="n", ylab="CPI",xlab="",pch=style,col=style)
axis(1,at=1:16,las=3,labels=c(paste(year,quarter,sep="Q"),"2015q1","2015q2","2015q3","2015q4"))


# Enter your code here. Read input from STDIN. Print output to STDOUT
write(round(pnorm(9800, 205 * 49, sqrt( 49 * (15 ^ 2) )), 4), stdout())


a <- 5.0
l <- 2.0

N <- 10000
centX <- a/2 * runif(N)
centY <- a/2 * runif(N)
alpha <- runif(N, min=0, max=pi/2)

if (l < a) {
	ifx <- centX < l*cos(alpha)/2
	ify <- centY < l*sin(alpha)/2
	p <- mean(ifx | ify)
	print(p)
	newPi <- l^2 / (a^2 * p)
	print(newPi)
}


library(readr)
library(lme4)
library(lmerTest)

# read in data from 2-way ANOVA with between-subject factors
df_2way <- read_csv("df_2way.csv")
# fit linear model and get parameter estimates
my_model_fit <- lm(my_value ~ group * language, df_2way)
# display results of linear regression
summary(my_model_fit)
# display anova table
anova(my_model_fit)
# access underlying model
model_matrix = model.matrix(my_model_fit)
# inspect GLM
image(t(model_matrix))
# to change coding scheme
#model_fit <- lm(my_value ~ group * condition, df, contrasts = list(group = "contr.sum", condition = "contr.sum"))

# read in data from 4-way ANOVA with between-subject and within-subject factors
df_full <- read_csv("df_full.csv")
# get parameter estimates from a linear regression with random effects
my_model_fit <- lmer(my_value ~ group * language * task * condition + (1|sub_id), df_full)
# display results of linear regression
summary(my_model_fit)
# main and interaction effects
anova(my_model_fit)
# random effects
rand(my_model_fit)
# access underlying model for fixed effects
my_glm_fe = model.matrix(my_model_fit)
# access underlying model for random effects
my_glm_re = getME(my_model_fit, "Zt")
# inspect matrices
image(t(my_glm_fe))
image(t(my_glm_re))


a <- 5
l <- 3

N <- 100000
cent_x <- a * runif(N)
alpha <- runif(N, min=0, max=pi/2)

mn <- mean(cent_x < l*cos(alpha))
print(mn)
new_pi <- 2 * l / (mn * a)
print(new_pi)


# John Alan McDonald 2015-11-20
#-------------------------------------------------------------------------------
setwd('/workplace/taiga')
source('src/main/r/functions.r')
#-------------------------------------------------------------------------------
data(BostonHousing2)
summary(BostonHousing2)
write.tsv(BostonHousing2,file='data/BostonHousing2.tsv')

y <- BostonHousing2$cmedv

#BostonHousing2$chas <- as.factor(BostonHousing2$chas)

xcols <-
#  c('lon','lat')
  c('lon','lat','crim','zn','indus','nox','rm','age','dis','rad','tax',
    'ptratio','b','lstat','chas')
x <- BostonHousing2[,xcols,drop=FALSE]

train <- function (y,x,mtry=floor(max(1, length(xcols) / 3)),
                   ntree=128,nodesize=1) {
  print(
    system.time(
      forest <- randomForest(y=y,x=x,nodesize=nodesize,ntree=ntree,mtry=mtry,
        keep.forest=TRUE)))
  yhat <- predict(forest,x)

  #print(cbind(y,yhat,(y-yhat)))
#  print(table(yhat-y))
  mad <- function (y, yhat) {
    r <- (y - yhat)
    sum(abs(r)) / length(y) }

  rmse <- function (y, yhat) {
    r <- (y - yhat)
    sqrt(sum(r*r) / length(y)) }

  print(
    list(n=length(y),ntree=ntree,nodesize=nodesize,mtry=mtry,nattr=ncol(x),
      mean=mean(y),
      meanhat=mean(yhat),
      mad=mad(y,yhat),
      bias=(sum(yhat - y) / length(y)),
      #fbias=2*sum(yhat - y)/(sum(y) + sum(yhat)),
      rmse=rmse(y,yhat)))
}
train(y=y,x=x,ntree=512)


####
###UMR_Trib Data. Si Woodstoich Working Group
#5.14.19

#Playing around with new Trib data

library(plyr)
library(dplyr)

setwd("~/Woodstoich/RawData_5.14.19")

#importing data
Data<-read.table(file="UMR_Tribs_jcc_5.14.19.csv", header=TRUE, sep=',')
names(Data)

#Helper variables from Paul
N.mw=14.0067
P.mw=30.973762
C.mw=12.0107
Si.mw=28.0855

#Adding new colums with data in moles so to calc molar ratios
Data$uMSi<-(Data$SI/Si.mw*1000)
Data$uMNOX<-(Data$NOX/N.mw*1000)
Data$uMNHX<-(Data$NHX/N.mw*1000)
Data$uMSRP<-(Data$SRP/P.mw*1000)
Data$uMDIN<-(Data$uMNOX+Data$uMNHX)
Data$DINSi<-(Data$uMDIN/Data$uMSi)
Data$PSi<-(Data$uMSRP/Data$uMSi)

range(Data$uMSi, na.rm=T)

#subsetting to remove negatives
Data<-subset(Data, uMSi>0 & uMNOX>0 & uMSRP>0 & uMNHX>0)

#Fixing dates and adding year as a column
Data$DATE2=as.Date(Data$DATE, c("%m/%d/%Y"))
Data$YEAR=as.numeric(format(Data$DATE2,c("%Y")))

#making each site name into a unique number
unique(Data$LOCATCD)
Data$SiteNum<-as.numeric(as.factor(Data$LOCATCD))
head(Data$SiteNum)
unique(Data$SiteNum)

#Calc min and max dates for each site
SiteDates<-ddply(Data, c("LOCATCD"), summarise, min.date=min(YEAR), max.date=max(YEAR))
SiteDates$YrsData<-with(SiteDates, as.numeric(max.date-min.date))
LongTermSites<-subset(SiteDates, SiteDates$YrsData>20)

#Now merge these sites with >20 yrs data with larger dataset
Data3<-merge(LongTermSites, Data, by=c("LOCATCD"))
head(Data3)

#calc avg vaues by year at each site
AvgByYr2<-aggregate(cbind(Data3$uMSi, Data3$uMNHX, Data3$uMSRP, Data3$uMNOX, Data3$uMDIN,
                          Data3$DINSi, Data3$PSi) ~ Data3$LOCATCD + Data3$YEAR, FUN=mean)
names(AvgByYr2)
colnames(AvgByYr2) <- c("LOCATCD", "Year", "AvguMSi", "AvgNH4", "AvgSRP", "AvgNOX",
                        "AvgDIN", "AvgDIN_SiRatio", "AvgP_SiRatio")
Data4<-AvgByYr2[order(AvgByYr2$LOCATCD),]
range(Data4$Year)
range(Data4$AvgDIN_SiRatio)

##==============================================
##plotting avg annual values over time for each site with >20yrs data
##exported the results of simple linear regression
##=============================================

library(broom)

#Average DIN:DSi molar ratios over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.8,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"],
       xlim=c(1990, 2020), ylim=c(0,16), main=paste("Site", i), ylab="DIN:DSi",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,5,10,15), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

write.csv(df, file="R2_DIN_SiRatiosvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

#Average DIP:Si molar ratios over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.8,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgP_SiRatio"],
       xlim=c(1990, 2020), ylim=c(0,.1), main=paste("Site", i), ylab="SRP:DSi",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,0.05, 0.1), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgP_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgP_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

write.csv(df, file="R2_P_SiRatiosvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

#Average DSi values over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.5,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvguMSi"],
       xlim=c(1990, 2020), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM",
       mgp=c(1.6,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,50,100,150,200, 250), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvguMSi"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvguMSi"]~ Data4[Data4$LOCATCD==i, "Year"]))))
  }
dev.off()

write.csv(df, file="R2_DSivsTime_5.15.19.csv", row.names=TRUE, na = "NA")
#glace in the broom package give R2 (and apparently pvalues). tidy gives p values and slopes

#Average DIN values over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.5,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgDIN"],
       xlim=c(1990, 2020), ylim=range(Data4$AvgDIN), main=paste("Site", i), ylab="DIN uM",
       mgp=c(1.6,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,500,1000), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgDIN"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgDIN"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()
write.csv(df, file="R2_DINvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

#Average DIP values over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.5,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgSRP"],
       xlim=c(1990, 2020), ylim=range(Data4$AvgSRP), main=paste("Site", i), ylab="SRP uM",
       mgp=c(1.6,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,10,20,30), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgSRP"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgSRP"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

write.csv(df, file="R2_SRPvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

##=======================================================
##below is me f-ing around...ignore. didn't use
##=======================================================

#couldn't figure this out - to define the path inside the loop:
mypath<-file.path(~"Woodstoich","RawData_5.14.19", "img")
jpeg(file=mypath)

#if use below, i have to change site num to locatcd bc got rid of misc numbers:

#testing out the loop here - works! just going into wrong folder and these are each plot individually, not multi-panel:
#so putting in diff folder:
setwd("~/Woodstoich/RawData_5.14.19/img")
for(i in unique(Data4$SiteNumber)){
  jpeg(paste("plot_", i, ".jpeg", sep=""))
  plot(Data4[Data4$SiteNumber==i, "Year"], Data4[Data4$SiteNumber==i, "AvguMSi"],
       xlim=range(Data4$Year), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM", xlab="")
  dev.off()
}

#couldn't figure out matrix so using mfrow instead
layout(matrix(1:3, ncol=3))
layout(matrix(1:28,7,4,byrow=F))

#Test code for saving plot to folder
jpeg(file = "~/Woodstoich/RawData_5.14.19/img/plot2.jpeg")
plot(Data4$Year, Data4$AvgP_SiRatio)
dev.off()

#lets add trend line to plot
#practice plot not in loop:
plot(Data4$Year, Data4$AvguMSi, ylim=c(5,250), xlim=c(1990,2020), ylab="DSi uM", xlab="", las=1)
title("DSi uM concentrations over time, LOCATCD==WPO2.6M ", line=2, cex.main=.8)
abline(lm(Data4$AvguMSi ~ Data4$Year))
fit1<-lm(Data4$AvguMSi ~ Data4$Year)
fit2<-lm(Data4$AvguMSi ~ Data4$Year)

#this loop works - just need to save the files to a folder
for(i in unique(Data4$SiteNumber)){
  plot(Data4[Data4$SiteNumber==i, "Year"], Data4[Data4$SiteNumber==i, "AvguMSi"],
       xlim=range(Data4$Year), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM", xlab="")
  }
dev.off()

#this works but ignore
plot(Data4$Year[which(Data4$SiteNumber==1)], Data4$AvguMSi [which(Data4$SiteNumber==1)], ylim=c(5,250), xlim=c(1990,2020), ylab="DSi uM", xlab="", las=1)
title("DSi uM concentrations over time, Site ", line=2, cex.main=.8)

##not using but kept for maybe later
#calc avg vaues by year at each site
AvgByYr<-aggregate(Data$uMSi~ Data$SiteNum + Data$YEAR, FUN=mean)
colnames(AvgByYr) <- c("SiteNumber", "Year", "AvguMSi")
Data3<-AvgByYr[order(AvgByYr$SiteNumber),]

#these are 'or' not 'and' statements
Data5<-subset(Data,subset=uMSi>0 | uMNOX>0 | uMNHX>0 | uMSRP>0)
Data9<-Data[ !is.na(Data$uMSi | Data$uMNOX| Data$uMSRP | Data$NHX) & (Data$uMSi>0 | Data$uMNOX>0 |Data$uMNHX>0 | Data$uMSRP>0) ,]

#Does same thing as above but uses the 'which', which some pple don't like
Data8<-Data[ which(Data$uMSi>0 | Data$uMNOX>0 |Data$uMNHX>0 | Data$uMSRP>0) ,]


## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## population genetics
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Gset <- c("GG","GT","TT")
G_table <- expand.grid(Gf=Gset,Gm=Gset,GG=NA,GT=NA,TT=NA)
G_table[1,Gset] <- c(1  ,   0,   0)
G_table[2,Gset] <- c(1/2, 1/2,   0)
G_table[3,Gset] <- c(0  ,   1,   0)
G_table[4,Gset] <- c(1/2, 1/2,   0)
G_table[5,Gset] <- c(1/4, 1/2, 1/4)
G_table[6,Gset] <- c(0  , 1/2, 1/2)
G_table[7,Gset] <- c(0  ,   1,   0)
G_table[8,Gset] <- c(0  , 1/2, 1/2)
G_table[9,Gset] <- c(0  ,   0,   1)

pGenoOffCond <- vector("list",3)
names(pGenoOffCond) <- Gset
for (i in Gset) pGenoOffCond[[i]] <- t(subset(G_table, Gf==i)[,Gset])

p.offgenotype <- function(G_, Gf, pGm) {
    ## Look up the probability of an offspring genotype, given the maternal genotype and
    ## proportions of offspring sired by each paternal genotype.

    ## Args:
    ##   G_: Offspring genotype.
    ##   Gf: Maternal genotype.
    ##   pGm: Relative fecundities of different male genotypes.

    ## Returns:
    ##   The probability of offspring genotype G_.

    ## expect Gf to have length=1
    if (length(Gf) != 1)
        stop("offspring genotype function not vectorised for maternal genotype")
    ## return the required probability
    return((pGenoOffCond[[Gf]] %*% pGm)[G_,1])
}


austin_city_limits = read.csv('AustinCityLimits.csv')

table(austin_city_limits$Gender)
table(austin_city_limits$Season)
table(austin_city_limits$Genre)
table(austin_city_limits$Grammy)

table(austin_city_limits$Grammy, austin_city_limits$Genre, austin_city_limits$Gender)

cor(austin_city_limits$CupPoints12, austin_city_limits$Earnings12)
plot(austin_city_limits$CupPoints12, austin_city_limits$Earnings12)
abline(lm(austin_city_limits$Earnings12~austin_city_limits$CupPoints12), col="red")

barplot(table(austin_city_limits$Grammy, austin_city_limits$Genre),
        main="Grammy Count",
        xlab="Grammies",
        ylab="Count",
        border="red",
        col= c("red","green"))

prop.table(table(austin_city_limits$Grammy, austin_city_limits$Genre))

prop.table(table(austin_city_limits$Grammy, austin_city_limits$Genre, austin_city_limits$Gender))


library(Hmisc)
getHdata(titanic3)

g <- function(x) c(Mean=mean(x,na.rm=TRUE), N=sum(!is.na(x)))
with(titanic3, tapply(age, llist(sex,pclass), g))

g <- function(x) c(Mean=apply(x, 2, mean, na.rm=TRUE),
                   N=apply(x, 2, function(w)sum(!is.na(w))))
options(digits=3)
summary(cbind(age,fare) ~ sex + pclass, method='cross', fun=g, data=titanic3)
with(titanic3, g(cbind(age,fare)))

## From Kevin Thorpe kevin.thorpe@utoronto.ca
### generate data
set.seed(31)
demo <- data.frame(age=rnorm(100,50,10),sex=sample(c("Male","Female"),100,TRUE))
summary(~age,data=demo,method="reverse")
summary(~sex,data=demo,method="reverse")

### used to work

summary(~ age + sex, data=demo, method="reverse")

summaryM(age + sex ~ 1, data=demo)


airtemps <- c(212, 33.5, 90, 100, 0, -40)

celsius1 <- (airtemps[1]-32)*5/9
celsius2 <- (airtemps[2]-32)*5/9
celsius3 <- (airtemps[3]-32)*5/9

#executes the function function that creates the function

fahr_to_celsius <- function(fahr) {
     celsius <- (fahr-32)*5/9
     return(celsius)
}

celsius4 <- fahr_to_celsius(airtemps[1])
celsius1 == celsius4

#(0°C × 9/5) + 32 = 32°F

airtemps <- c(100, 0.83, 32.2, 37.7, 017.7, -40)
fahr1 <- (airtemps[1] * 9/5 + 32)
fahr2 <- (airtemps[1] * 9/5 + 32)
fahr3 <- (airtemps[1] * 9/5 + 32)

celsius_to_fahr <- function(celsius) {
      celsius <- (9/5) * celsius  + 32
      return(fahr)
}
ctemps <- fahr_to_celsius(airtemps)
ftemps <- celsius_to_fahr(ctemps)
airtemps = ftemps
fahr4 <- celsius_to_fahr(airtemps[1])


#Customizing Plots
#By: Will Bartsch  -  EPA-MED, Duluth
#Date: 5/1/13
##################################################################
set
#Load the necessary libraries.
library(ggplot2)
library(plotrix)

#Create a data frame to use for the plots.
location <- c("urban","urban","urban","urban","rural","rural","urban",
	"urban","urban","urban","rural","rural","rural","rural","urban",
	"urban","urban","rural","rural","rural")
nh4 <- c(14.01,17.12,17.51,12.32,5.68,12.02,19.16,16.22,19.59,16.82,
	7.78,11.89,8.6,12.74,13.96,19.44,13.83,9.93,7.76,8.49)
stress <- c(0.82,0.78,0.84,0.89,0.21,0.45,0.88,0.74,0.98,0.65,0.35,
	0.39,0.38,0.45,0.59,0.8,0.56,0.42,0.31,0.32)

wq <- data.frame(location, nh4, stress)

#Create some subsets to be used later.
wq_rural <- subset(wq, location=="rural")
wq_urban <- subset(wq, location=="urban")

#Create a default plot.
plot(wq$stress, wq$nh4)

#Set the range of the x and y axes and add labels and a title.
plot(wq$stress, wq$nh4, xlim=c(0,1), ylim=c(0,20),
	xlab="Relative Stress",
	ylab=expression(paste("NH"[4]^" +  ",mu,"g/L")),
	main="Ammonium Levels in Lakes", pch=16, col="red")

#Part of the y label is cut off; resize the margins.
#This will adjust margins on your future plots, not the current one.
par(mar=c(5, 5,4,2) )

#The default is (5,4,4,2). The order is (bottom, left, top, right).

#Use different symbols for the urban and rural locations.
#There are many ways to code this. For a couple of alternatives see
#the bonus material at the end of this document. We will use
#the subsets we created.

#pch selects the symbol. Run the code to see the 25 basic symbols:
plot(1:25, pch=c(1:25))
text(1:25, pos=3, offset=0.4)

#Make the plot using the solid triangle(17) and the solid circle(16).
#We will start with a blank plot that has the correct x and y limits,
#and the correct labels. Then we will add our data with the "points"
#command
plot(NULL,NULL, xlim=c(0,1), ylim=c(0,20),
	xlab=expression(paste(bold("Relative Stress"))),
	ylab=expression(paste("NH"[4]^" +  	",mu,"g/L")),
	main="Ammonium Levels in Lakes")
points(wq_urban$stress, wq_urban$nh4, pch=16, col="red")
points(wq_rural$stress, wq_rural$nh4 , pch=17, col="black")

#Add trend lines for each group. Start by doing a linear regression
#on both the urban and rural data. Then make an object of the
#summaries so they can be called on later.
nh4_urban_lm <- lm(wq_urban$nh4  ~ wq_urban$stress)
nh4_urban_lm_sum <- summary(nh4_urban_lm)

nh4_rural_lm <- lm(wq_rural$nh4  ~ wq_rural$stress)
nh4_rural_lm_sum <- summary(nh4_rural_lm)

#Display the summary.
nh4_rural_lm_sum

#Check the names of the summary components
names(nh4_rural_lm_sum)

#Call up the r squared
nh4_rural_lm_sum$r.squared

#Notice that under the coefficients section there is a table of
#values. We can call them out later using the table name and the
#number's position within that table.

#Use the "ablineclip" function from the plotrix package to add the
#trend lines. We will pull the necessary information from the
#linear model summaries we just created. x1 and x2 are cutoff values.
#We can eyeball the cutoff values or use the range function

range(wq_rural$stress)
range(wq_urban$stress)

ablineclip(nh4_rural_lm_sum$coefficients[1,1],
	nh4_rural_lm_sum$coefficients[2,1], lwd=2, x1=0.21, 	x2=0.45)
ablineclip(nh4_urban_lm_sum$coefficients[1,1],
	nh4_urban_lm_sum$coefficients[2,1], col="red", 	lwd=2,
	x1=0.56, x2=0.98)

#Customize the x axis and add a legend. If we want a custom axis we
#have to remove the default axis.

plot(NULL,NULL, xlim=c(0,1), ylim=c(0,20), xaxt="n",
	xlab=expression(paste(bold("Relative Stress"))),
	ylab=expression(paste("NH"[4]^" +  	",mu,"g/L")),
	main="Ammonium Levels in Lakes")

#xaxt="n"  removes the x axis. We can add it back in and customize
#it using the "axis" function. The axis is still set to the 0 to 1
#scale, so we can select positions on the scale to place our labels.
axis(1, at=c(0.2, 0.5, 0.8), labels=c("Low", "Medium", "High"),
	cex.axis=0.8)

#cex.axis changes the size of the labels. We just set them to 0.8
#of there standard size. Want the new axis labels to be
#perpendicular to the axis? Include "las=2" in the axis code.

#Add in the data.
points(wq_urban$stress, wq_urban$nh4, pch=16, col="red")
points(wq_rural$stress, wq_rural$nh4 , pch=17, col="black")
ablineclip(nh4_rural_lm_sum$coefficients[1,1],
	nh4_rural_lm_sum$coefficients[2,1], lwd=2, x1=0.21, 	x2=0.45)
ablineclip(nh4_urban_lm_sum$coefficients[1,1],
	nh4_urban_lm_sum$coefficients[2,1], col="red", 	lwd=2,
	x1=0.56, x2=0.98)
legend("bottomright", legend=c("Urban", "Rural"), pch=c(16,17),
	col=c("red","black"))

#Don't want a box around the legend? Add bty="n" to the legend code.
#If you want to add the r^2, p-value or equation of the line to a
#plot review the "Tips and Tricks" section from the April 2013
#meeting. It is available on the group site.

#Save the plot as a pdf
pdf("nh4.pdf")
par(mar=c(5,5,4,2))

plot(NULL,NULL, xlim=c(0,1), ylim=c(0,20),
	xlab=expression(paste(bold("Relative Stress"))),
	ylab=expression(paste("NH"[4]^" +  	",mu,"g/L")),
	main="Ammonium Levels in Lakes", xaxt="n")
points(wq_urban$stress, wq_urban$nh4, pch=16, col="red")
points(wq_rural$stress, wq_rural$nh4 , pch=17, col="black")
ablineclip(nh4_rural_lm_sum$coefficients[1,1],
	nh4_rural_lm_sum$coefficients[2,1], lwd=2, x1=0.21, 	x2=0.45)
ablineclip(nh4_urban_lm_sum$coefficients[1,1],
	nh4_urban_lm_sum$coefficients[2,1], col="red", 	lwd=2,
	x1=0.56, x2=0.98)
axis(1, at=c(0.2, 0.5, 0.8), labels=c("Low", "Medium", "High"),
	cex.axis=0.8)
legend("bottomright", legend=c("Urban", "Rural"), pch=c(16,17),
	col=c("red","black"))

dev.off()

#"dev.off()" stops the "pdf" function and sends the plot to the file
#that you have your directory set to.

################ ggplot2 ###################

#Now we will do a very similar graph in ggplot2

#Basic plot
nh4_a <-ggplot(data=wq, aes(x=stress, y=nh4))
nh4_a + geom_point()

#Customized plot using ggplot2
nh4_b <- ggplot(data=wq, aes(x=stress, y=nh4, color=location,
	shape=location))
nh4_b + geom_point() + scale_x_continuous(limits=c(0,1),
	breaks=c(0.2,0.5,0.8), labels=c("Low","Medium", "High")) +
	ylim(0,20) + ggtitle("Ammonium Levels in Lakes") +
	scale_colour_manual("Location",
	labels=c("Urban", "Rural"), breaks=c("urban", "rural"),
	limits=c("urban", "rural"), values=c("red", "black"))  +
	scale_shape_manual("Location", labels=c("Urban", "Rural"),
	breaks=c("urban", "rural"), limits=c("urban", "rural"),
	values=c(16,17)) +
	xlab(expression(paste(bold("Relative Stress")))) +
	ylab(expression(paste("NH"[4]^" +  ",mu,"g/L"))) +
	geom_smooth(method=lm, fill=NA)

######## Examples of code for common scientific expressions#######

#A blank plot is used as the canvas

plot(NULL,NULL, xlim=c(0,10),ylim=c(0,10),
	xlab=expression(paste
	('excess ', N[2], '-N (', mu, 'mol ', L^-1, 	')')),
	ylab=expression(paste(N[2], 'O saturation')))
text( 2,10, expression(paste(alpha, mu, beta)))
text(2,9, expression(paste(italic("E. coli")," ", "levels")))
text(2,8, "angled", srt=45)
  #the "srt" command can only be used with the "text" function,
  #it can't be used to label axes
text(2,7, "less angled", srt=30)
text(2,6, expression(paste('TOC (mmol', L^-1, ')')))
text(2,5, expression(paste(bold("Relative Stress"))))
text(2,4, expression(paste(underline("Relative Stress"))))

############ Bonus Material ###############

#Alternative ways to call just the urban or just the rural data.

#Alternative #1

#Use the original data frame and set the criteria when listing the
#items to be plotted

plot(NULL,NULL, xlim=c(0,1), ylim=c(0,20),
	xlab=expression(paste(bold("Relative Stress"))),
	ylab=expression(paste("NH"[4]^" +  	",mu,"g/L")),
	main="Ammonium Levels in Lakes")
points(wq$stress[wq$location=="urban"],
	wq$nh4[wq$location=="urban"], pch=16, col="red")
points(wq$stress[wq$location=="rural"],
	wq $nh4[wq$location=="rural"] , pch=17, col="black")

#Alternative #2

#Subset the data in the command line using the "with" function
plot(NULL,NULL, xlim=c(0,1), ylim=c(0,20),
	xlab=expression(paste(bold("Relative Stress"))),
	ylab=expression(paste("NH"[4]^" +  	",mu,"g/L")),
	main="Ammonium Levels in Lakes")
with(subset(wq, location=="urban"), points(stress, nh4,
	pch=16, col="red"))
with(subset(wq, location=="rural"), points(stress, nh4 ,
	pch=17, col="black"))

#Create a legend with both symbols and lines

legend("bottomright",
	legend=c("Urban", "Rural", "Urban Trend", "Rural Trend"),
	bty="n", lty=c(0,0,1,1), lwd=c(0,0,2,2), pch=c(16,17,1,1),
	pt.cex=c(1,1,0,0), col=c("red","black","red","black"))


###############################################################################
#  Copyright (C) 1994 - 2009, Performance Dynamics Company                    #
#                                                                             #
#  This software is licensed as described in the file COPYING, which          #
#  you should have received as part of this distribution. The terms           #
#  are also available at http://www.perfdynamics.com/Tools/copyright.html.    #
#                                                                             #
#  You may opt to use, copy, modify, merge, publish, distribute and/or sell   #
#  copies of the Software, and permit persons to whom the Software is         #
#  furnished to do so, under the terms of the COPYING file.                   #
#                                                                             #
#  This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY  #
#  KIND, either express or implied.                                           #
###############################################################################

# Load the library
library("pdq")
#
# Thruput bounds for closed tandem QNM with fixed Z
# Created by NJG on Fri Feb 27, 2009
clients = 200
think   = 8   * 10^(-3) # ms as seconds
stime   = 500 * 10^(-3) # ms as seconds
work    = "w"
for(k in list(1,20,50)) {
    xc<-0 # prudent to reset these
    yc<-0
    for (i in 1:clients) {
        Init("")
        CreateClosed(work, TERM, as.double(i), think)
        # create k queueing nodes in PDQ
        for (j in 1:k) {
       	    nname = paste("n",sep="",j) # concat j to node name
            CreateNode(nname,CEN,FCFS)
            SetDemand(nname,work,stime)
        }
        Solve(APPROX)
        # set up for plotting in R
        xc[i]<-as.double(i)
        yc[i]<-GetThruput(TERM,work)
        nopt<-(k*stime+think)/stime
     }
     if (k==1) {
     	# establish plot frame and first curve
        plot(xc, yc, type="l", ylim=c(0,1/stime), lwd=2, xlab="N Clients",
             ylab="Throughput X(N)")
        title("Increasing Number (K) of Queues")
      	abline(0, 1/(nopt*stime), lty="dashed",  col="blue")
      	abline(1/stime, 0, lty="dashed",  col = "red")
      	abline(v=nopt, lty="dashed", col="gray50") # grid line
        text(150,1.95,paste("K =", k))
      	text(5+k,1.4,paste("N* =",nopt),adj=c(0,0))
     } else {
    	# add the other curves
      	points(xc, yc, type="l", lwd=2)
      	abline(0,1/(nopt*stime), lty="dashed",  col="blue")
      	abline(v=nopt, lty="dashed", col="gray50")
       	text(150,1.85-0.085*k/10, paste("K =", k))
      	text(k+5,0.5-0.1*k/10,paste("N* =",nopt),adj=c(0,0))
     }
}


require(data.table)
require(Rcpp)
require(ggplot2)

nextTime = function(n, rateParameter) {
  return(sapply(1:n,function(i) -log(1.0 - runif(1)) / rateParameter))
}

# Randomly calculate message interarrivals using Poisson processes
messages = data.table("Interarrival" = nextTime(1000,1/10))
# Sum up interarrivals to get timestamps for each message
messages[,Timestamp:=cumsum(Interarrival)]

# Assigning each message a constant service time.  You could use a distribution here
serviceTime=5
messages[,serviceTime := serviceTime]

# Lets randomly increase the service time for some of the messages to simulate jitter
messages[runif(n=10, min=0, max=.N),serviceTime := runif(n=.N, min=90, max=100)]

messages[,responseTime := calculateResponseTime(Timestamp, serviceTime)]

ggplot(messages, aes(x=Timestamp, y=responseTime))+
  geom_point(color="cornflowerblue")+
  gtheme()+
  ylab("Response Time")+
  scale_y_continuous(breaks=number_ticks(10), limits=c(0,150))

ggplot(messages, aes(x=responseTime))+
  stat_ecdf(color="cornflowerblue")+
  gtheme()+
  ylab("Percentile")+
  xlab("Response Time")+
  scale_y_continuous(breaks=number_ticks(10))+
  scale_x_continuous(breaks=number_ticks(10))

# Calculate the latency difference between each message
messages[order(Timestamp), latencyDiff:=c(0,diff(responseTime))]

ggplot(messages[latencyDiff>0], aes(x=latencyDiff)) +
  stat_ecdf()+
  gtheme()+
  coord_cartesian(ylim=c(0.8,1))+
  ylab("Percentile")+
  xlab("Latency Delta")+
  scale_y_continuous(breaks=number_ticks(10))+
  scale_x_continuous(breaks=number_ticks(10))

# Identify all messages having "high" latency
messages[,highLatency := responseTime > 25]

# Identify contiguous sets of high latency messages using a run length encoding (see data.table ?rleid)
messages[,burstIdx := rleid(highLatency)]

# Mark messages which participated in a burst that contained an abnormal latencyDiff (service time).
# Max latency diff should in theory be the service time, given two messages arriving at exactly the same time
messages[,`Caused by Jitter` := max(latencyDiff, na.rm=T) > serviceTime,by=burstIdx]

ggplot(messages, aes(x=responseTime, color=`Caused by Jitter`)) +
  stat_ecdf()+
  gtheme()+
  ylab("Percentile")+
  xlab("Response Time")+
  scale_y_continuous(breaks=number_ticks(10))+
  scale_x_continuous(breaks=number_ticks(10))+
  scale_color_manual(values=c('cornflowerblue', 'green4'))

#filter to only high latency messages
highLatencyMessages = messages[highLatency == TRUE]


# 2. Calculate AIC, BIC, AIC weights, BIC weights
# Useful for model averaging and model selection.
ms=modelSelection(models=modelOutput, data=dat)
# simple plot to show differnces between models
par(mar=c(20,8,5,2))
x = ms$BIC - ms$BIC[1];
orderV = order(-x);
currentModels = rownames(ms);
myColor = rgb(red=69/255, green=139/255, blue=116/255,alpha=0.8)
barplot(x[orderV],
        names.arg=currentModels[orderV], las=1, col=myColor,
        border=NA, xlab="AIC values",horiz=TRUE,
        xlim = 50*round(1.5*c(min(x), max(x))/50))  # if names are too long this won't display correctly
mtext(side=3,text=subjnam)

# A second example. Let's suppose we want to compare a subset of the models, not all of them;
# e.g., Cisek urgency vs Ditterich urgency vs. Ratcliff model, First, create a character vector of the models you
# want to compare. The names must exactly match the names as they appear in the modelOutput list.
# otherwise you will get odd errors

modelsToTest=currentModels[orderV[seq(length(orderV)-5, length(orderV))]]
# modelsToTest=c("stoneEtaVarTer", "ratcliffVarTer","stoneEtaCollapse","stoneEtaDitterich")
# call the modelSelection function while subsetting from the modelOutput list
ms = modelSelection(models=modelOutput[modelsToTest], data=dat)
par(mar=c(20,8,5,2))
myColor = rgb(red=0/255, green=191/255, blue=255/255,alpha=0.8)
barplot(ms$AICw,names.arg=rownames(ms), horiz=TRUE, las=1, col=myColor,
        border=NA, xlab="AIC weights")  # if names are too long this won't display correctly

par(mfrow=c(1,2))
S = modelOutput$DDMSvSt$pars;
T = rbind(currParams, S);
barplot(T,beside=TRUE,
        names.arg = colnames(currParams),
        col=c("gray83","dodgerblue1"),border=NA, las=2, ylim=range(pretty(c(0, T))))


 ZGEQLF Example Program Results

 Least squares solution(s)
                    1                 2
 1  (-0.5044,-1.2179) ( 0.7629, 1.4529)
 2  (-2.4281, 2.8574) ( 5.1570,-3.6089)
 3  ( 1.4872,-2.1955) (-2.6518, 2.1203)
 4  ( 0.4537, 2.6904) (-2.7606, 0.3318)

 Square root(s) of the residual sum(s) of squares
      6.88E-02   1.87E-01


###########################################################################
########Chapter 5 - Introduction to Neural Networks - using R##############
####################Classifing breast cancer with R########################
###########################################################################

library("mlbench")
library(neuralnet)

data(BreastCancer)
summary(BreastCancer)

mvindex = unique (unlist (lapply (BreastCancer, function (x) which (is.na (x)))))
data_cleaned <- na.omit(BreastCancer)
summary(data_cleaned)

boxplot(data_cleaned[,2:10])
hist(as.numeric(data_cleaned$Mitoses))

par(mfrow=c(3, 3))
hist(as.numeric(data_cleaned$Cl.thickness))
hist(as.numeric(data_cleaned$Cell.size))
hist(as.numeric(data_cleaned$Cell.shape))
hist(as.numeric(data_cleaned$Marg.adhesion))
hist(as.numeric(data_cleaned$Epith.c.size))
hist(as.numeric(data_cleaned$Bare.nuclei))
hist(as.numeric(data_cleaned$Bl.cromatin))
hist(as.numeric(data_cleaned$Normal.nucleoli))
hist(as.numeric(data_cleaned$Mitoses))

str(data_cleaned)
input<-data_cleaned[,2:10]
indx <- sapply(input, is.factor)
input <- as.data.frame(lapply(input, function(x) as.numeric(as.character(x))))

max_data <- apply(input, 2, max)
min_data <- apply(input, 2, min)
input_scaled <- as.data.frame(scale(input,center = min_data, scale = max_data - min_data))
View(input_scaled)

Cancer<-data_cleaned$Class
Cancer<-as.data.frame(Cancer)
Cancer<-with(Cancer, data.frame(model.matrix(~Cancer+0)))

final_data<-as.data.frame(cbind(input_scaled,Cancer))

index = sample(1:nrow(final_data),round(0.70*nrow(final_data)))
train_data <- as.data.frame(final_data[index,])
test_data <- as.data.frame(final_data[-index,])

n = names(final_data[1:9])
f = as.formula(paste("Cancerbenign + Cancermalignant ~", paste(n, collapse = " + ")))

net = neuralnet(f,data=train_data,hidden=5,linear.output=FALSE)
plot(net)

predict_net_test <- compute(net,test_data[,1:9])
predict_result<-round(predict_net_test$net.result, digits = 0)
net.prediction = c("benign", "malignant")[apply(predict_result, 1, which.max)]
predict.table = table(data_cleaned$Class[-index], net.prediction)
predict.table

library(gmodels)
CrossTable(x = data_cleaned$Class[-index], y = net.prediction,
 prop.chisq=FALSE)
###########################################################################


# efg, Stowers Institute for Medical Research
# 29 Dec 2005
#http://research.stowers.org/mcm/efg/R/Visualization/cor-cluster/index.htm
# Explore creating hierarchical clusters using data with "known"
# correlation values.

library(mvtnorm)

# Based on R-News posting by Robin Hankin, 16 Dec 2005
# http://tolstoy.newcastle.edu.au/R/help/05/12/17693.html
CorrelatedXY <- function(N, mean1,mean2, variance1,variance2, correlation)
{
  corvar <- correlation * sqrt(variance1*variance2)
  rmvnorm(n=N,mean=c(mean1,mean2),
          sigma=matrix(c(variance1, corvar,
                         corvar,    variance2), 2,2))
}

N <- 1000
mean1 <- 2
mean2 <- 5
variance1 <- 1
variance2 <- 2

set.seed(17)

Raw <- CorrelatedXY(N, mean1, mean2, variance1, variance2, 0.0)
for (i in 1:5)
{
  Raw <- cbind(Raw, CorrelatedXY(N, mean1, mean2, variance1, variance2,
                                 (-1)^i * 0.2*i) )

}
colnames(Raw) <- paste(rep(c("P", "P", "M", "M"), 3),
                       sprintf("%2.2d", c(0,0,2,2,4,4,6,6,8,8,10,10)),
                       rep( c("A", "B"), 6), sep="")

# Look at correlation matrix
round( cor(Raw), 4)

corRaw <- cor(Raw)

library(spatstat)  # "im" function
plot(im(corRaw[nrow(corRaw):1,]), main="Correlation Matrix Map")

## Use correlations between variables as "distance"

dissimilarity <- 1 - cor(Raw)
distance <- as.dist(dissimilarity)
round(distance, 4)
plot(hclust(distance), main="Dissimilarity = 1 - Correlation", xlab="")

# only changes scaling
distance <- as.dist( (1 - cor(Raw))/2 )
round(distance, 4)
plot( hclust(distance), main="Dissimilarity = (1 - Correlation)/2", xlab="")

dissimilarity <- 1 - abs(cor(Raw))
distance <- as.dist(dissimilarity)
round(distance, 4)
plot(hclust(distance), main="Dissimilarity = 1 - Abs(Correlation)", xlab="")

dissimilarity <- sqrt(1 - cor(Raw)^2)
distance <- as.dist(dissimilarity)
round(distance, 4)
plot(hclust(distance), main="Dissimilarity = Sqrt(1 - Correlation^2)", xlab="")

# Go back to "best" distance metric
dissimilarity <- 1 - abs(cor(Raw))
distance <- as.dist(dissimilarity)

library(cluster)
plot(agnes(distance))

plot( pam(distance, 2))
plot( pam(distance, 6))

library(Hmisc)

plot( varclus(Raw, similarity="spearman") )
plot( varclus(Raw, similarity="pearson") )

library(pvclust)

cluster.bootstrap <- pvclust(Raw, nboot=1000, method.dist="abscor")
plot(cluster.bootstrap)
pvrect(cluster.bootstrap)

# Default "correlation" methods does not work well here
cluster.bootstrap <- pvclust(Raw, nboot=1000, method.dist="correlation")
plot(cluster.bootstrap)
pvrect(cluster.bootstrap)


library(randomForest)
library(rattle)
library(rpart.plot)
library(RColorBrewer)
library(rpart)

# The train and test data is stored in the ../input directory
train <- read.csv("trainingset.csv")
test  <- read.csv("testset.challenge.csv")

# We can inspect the train data. The results of this are printed in the log tab below
summary(train)

# Build the decision tree
my_tree_two <- rpart(formula = Survived ~ Pclass + Sex + Age + SibSp + Parch + Fare + Embarked, data=train, method="class")

# Visualize the decision tree using plot() and text()
plot(my_tree_two)
text(my_tree_two)

# Time to plot your fancified tree
fancyRpartPlot(my_tree_two)
# Make your prediction using the test set
my_prediction <- predict(my_tree_two, test, type = "class")

# Create a data frame with two columns: PassengerId & Survived. Survived contains your predictions
my_solution <- data.frame(PassengerId = test$PassengerId, Survived = my_prediction)

# Check that your data frame has 418 entries
nrow(my_solution)

# Write your solution to a csv file with the name my_solution.csv
write.csv(my_solution, file = "testset.prediction.csv", row.names = FALSE)
# Here we will plot the passenger survival by class
train$Survived <- factor(train$Survived, levels=c(1,0))
levels(train$Survived) <- c("Survived", "Died")
train$Pclass <- as.factor(train$Pclass)
levels(train$Pclass) <- c("1st Class", "2nd Class", "3rd Class")

png("testset.prediction.png", width=800, height=600)
mosaicplot(train$Pclass ~ train$Survived, main="Passenger Survival by Class",
           color=c("#8dd3c7", "#fb8072"), shade=FALSE,  xlab="", ylab="",
           off=c(0), cex.axis=1.4)
dev.off()
dim(train)


## Assignment 2 i.e Quiz 2 of R class##
## Quiz 1##
cube <- function(x, n) {
        x^3
}
cube(3)

# Since no use of n in the function enviroments, so it is evaluated i.e function
# does not depends on n, so there is no error at all.

## Quiz 2 ##

x<- 1:10
if(x >5) {
        x <- 0
}

# since the value of x is vector and it could evaluate for first value only
# Warning message:
#        In if (x > 5) { :
#                                the condition has length > 1 and only the first element will be used

#### Question 3 ####
f <- function(x) {
        g <- function(y) {
                y + z
        }
        z <- 4
        x + g(x)
}

z <- 10
f(3) # will call function g <- function(y) {y +z} in the function enviroment,
# z <- 4; 3 + g(3), now function g called in function enviroment i.e 3 + 4 = 7
# so, g (3) will return 7  and hence 3 + 7  = 10

#### Question 4 ####

x <- 5
y <- if (x < 3) {
        NA
} else {
        10
}

### Programming Assignement 2###

makeVector <- function(x = numeric()) {
        m <- NULL
        set <- function(y) {
                x <<- y
                m <<- NULL
        }
        get <- function() x
        setmean <- function(mean) m <<- mean
        getmean <- function() m
        list(set = set,
             get = get,
             setmean = setmean,
             getmean = getmean)
}

cachemean <- function(x, ...) {
        m <- x$getmean()
        if(!is.null(m)) {
                message("getting cached data")
                return(m)
        }
        data <- x$get()
        m <- mean(data, ...)
        x$setmean(m)
        m
}

makeCacheMatrix <- function(x = matrix()) {
        ## Initialise the matrix.
        inverseMatrix <- NULL
        # set the given matrix
        set <- function(matrix) {
                m <<- matrix
                inverseMatrix <<- NULL
        }

        # Get the given matrix
        get <- function()  {
                m
        }

        # find and set the inverse of the matrix
        setInverse <- function(solve) {
                inverseMatrix <<- solve
        }

        # Get the inverted matrix
        getInverse <- function() {
                inverseMatrix
        }

        # Return the list
        list(set = set,
             get = get,
             setInverse = setInverse,
             getInverse = getInverse
        )
}

cacheSolve <- function(x, ...) {
        ## Return a matrix that is the inverse of 'x'
        inverseMatrix <- x$getInverse()
        if(!is.null(inverseMatrix)) {
                message("getting cached inverse matrix")
                return(inverseMatrix)
        }

        originalMatrix <- x$get()
        inverseMatrix <- solve(originalMatrix, ...)
        x$setInverse(inverseMatrix)
        inverseMatrix
}

}


#' ---
#' title: "CWB making notes example"
#' author: "Tom Carroll"
#' date: "Day 3 of CWB"
#' ---
#' Generate random numbers for sample 1 and sample 2
sample1 <- rnorm(100,100,20)
sample2 <- rnorm(100,200,20)
#' Histogram for sample 1
#+ fig.width=3, fig.height=3
hist(sample1)
#' Histogram for sample 1
#+ fig.width=3, fig.height=3
hist(sample2)
#' Perform t-test
res <- t.test(sample1,sample2)
res
#' Boxplot of Results
#+ fig.width=5, fig.height=5
boxplot(sample1,sample2,col=c("red","green"))
#' Summary for sample 1
summary(sample1)
#' Summary for sample 2
summary(sample2)

#' Session Information
sessionInfo()


#+setup, include=FALSE, cache=FALSE
library(knitr)
opts_chunk$set(fig.path='figure-make-assoc-plots/', fig.align='center', fig.show='hold')

library(car)
library(DescTools)
library(Hmisc)
library(vcd)

load('mgAge.RData')
set.seed(3234)

#' Test for conditional independence
#+
ct <- xtabs(cases~State+age, data=mgAge)
test <- rowSums(ct) != 0
ct <- as.table(ct[test,])
colnames(ct) <- c('Grower/Finisher', 'Nursery', 'Sow/Boar', 'Suckling')
names(dimnames(ct))[[2]] <- 'Age Class'
coindep_test(ct, indepfun=function(x) sum(x^2))
assoc(ct, shade=TRUE, labeling_args=list(rot_labels=c(0,0,90,0),
                          offset_varnames=c(0,0,0,0.5)))
mosaic(ct, shade=TRUE, labeling_args=list(rot_labels=c(0,0,90,0),
                          offset_varnames=c(0,0,0,0.5)))
pdf('assoc-plots.pdf', width=6.8, height=7.8)
assoc(ct, shade=TRUE, labeling_args=list(rot_labels=c(0,0,90,0),
                          offset_varnames=c(0,0,0,0.5)))
dev.off()
Desc(ct)
Assocs(ct)
invisible(latex(describe(ct), file='age-state-indepedence.tex'))

#' See if model probablities of suckling cases are predictive of observed.
#'
#' First, let's get the data into the right format.
#+
mgAge$isSuckling <- mgAge$age == 'Suckling'
cs <- xtabs(cases~State+isSuckling, data=mgAge)
test <- rowSums(cs) != 0
cs <- cs[test,]
cs <- cs[,c(2,1)]
wt <- xtabs(samplingWeight~State + isSuckling, data=mgAge)
wt <- wt/rowSums(wt)
wt <- wt[test,]

#' Do empirical and theoretical probabilities seem to be correlated?
#+
pEmp <- cs[,1]/rowSums(cs)
pThe <- wt[, 'TRUE']
plot(x=pThe,y=pEmp, type='n')
text(x=pThe,y=pEmp, labels=rownames(wt))

#' Not particularly. Let's address this more carefully with a logistic
#' regression.
m <- glm(cs ~ 1 + pThe, family=binomial)
summary(m)
par(mfrow=c(2,2))
plot(m)
outlierTest(m)

#' Get the descriptive stats

df <- data.frame(prob.suckling=pEmp, n.all.ages=rowSums(cs), sampling.prob.suckling=pThe)
invisible(latex(describe(df), file='logistic-model-suckling-sampling.tex'))

#' There's no effect, but the diagnostics indicate that NC, OK, and IA
#' are having large effects on the fit, and IA and NC are
#' outliers. Let's refit without IA and NC.
#+
test2 <- rownames(cs) %nin% c('IA', 'NC')
cs2 <- cs[test2,]
pThe2 <- pThe[test2]
m2 <- glm(cs2~1 + pThe2, family=binomial)
summary(m2)
par(mfrow=c(2,2))
plot(m2)
outlierTest(m2)

#' Still no effect, and now KS, OK, and MN have the highest Cook's
#' distance. Let's refit without them.
#+
test3 <- rownames(cs) %nin% c('IA', 'NC', 'KS', 'OK', 'MN')
cs3 <- cs[test3,]
pThe3 <- pThe[test3]
m3 <- glm(cs3~1 + pThe3, family=binomial)
summary(m3)
par(mfrow=c(2,2))
plot(m3)
outlierTest(m3)

#' IL and CO have somewhat large Cook's distances. Let's refit without
#' them.
#+
test4 <- rownames(cs) %nin% c('IA', 'NC', 'KS', 'OK', 'MN', 'CO', 'IL')
cs4 <- cs[test4,]
pThe4 <- pThe[test4]
m4 <- glm(cs4~1 + pThe4, family=binomial)
summary(m4)
par(mfrow=c(2,2))
plot(m4)
outlierTest(m4)

#' No significan effect, but we've taken out most of the states with
#' lot's of cases. Perhaps they could be fit to their own model.
#'
#+
test5 <- rownames(cs) %in% c('IA', 'NC', 'KS', 'OK', 'MN', 'CO', 'IL')
cs5 <- cs[test5,]
pThe5 <- pThe[test5]
m5 <- glm(cs5~1 + pThe5, family=binomial)
summary(m5)
par(mfrow=c(2,2))
plot(m5)
outlierTest(m5)

#' The diagnostics don't look particularly good, but at least this
#' shows which directions the major states deviate from predictions
#' in.
#'
#' Let's get an estimate of the average difference between predicted
#' and observed logits.
#+
offset <- qlogis(pThe)
mm <- glm(cs~1, offset=offset, family=binomial)
summary(mm)
exp(coef(mm))
exp(confint(mm))
par(mfrow=c(2,2))
plot(mm)
cbind(pEmp, pFit=predict(mm, type='response'), pThe)

#' The logit is about 4 times higher than expected on average. More so
#' in IA and NC. In OK, the empirical and theoretical probabilities
#' are close, but that gives OK a large negative residual in the
#' fitted model.
#'
#' Now let's refit without the IA, NC, and OK.
#+
test2m <- rownames(cs) %nin% c('IA', 'NC', 'OK')
csm <- cs[test2m,]
offsetm <- offset[test2m]
mm2 <- glm(csm~1, offset=offsetm, family=binomial)
summary(mm2)
exp(coef(mm))
exp(confint(mm2))
par(mfrow=c(2,2))
plot(mm2)

#' No major changes, but KS and IL look influential now. Let's check
#' their influence.
#'
#+
test3m <- rownames(cs) %nin% c('IA', 'NC', 'OK', 'KS', 'IL')
csm <- cs[test3m,]
offsetm <- offset[test3m]
mm3 <- glm(csm~1, offset=offsetm, family=binomial)
summary(mm3)
exp(coef(mm3))
exp(confint(mm3))
par(mfrow=c(2,2))
plot(mm3)

#' The difference is starting to look smaller, and MN now has the
#' largest Cook's distance. Let check it's influence.
#+
test4m <- rownames(cs) %nin% c('IA', 'NC', 'OK', 'KS', 'IL', 'MN')
csm <- cs[test4m,]
offsetm <- offset[test4m]
mm4 <- glm(csm~1, offset=offsetm, family=binomial)
summary(mm4)
exp(coef(mm4))
exp(confint(mm4))
par(mfrow=c(2,2))
plot(mm4)

#' We've moved down in size a little again, but there are no
#' observations with large Cook's distances now, and there's still a
#' clear positive difference between the means.


#' rsq_1.1 - generate r-squared for observations relative to 1:1 line
#'
#' @param observed   observed values of dependent variable.
#' @param predicted  predicted values of dependent variable.
#'
#' @return returns r-squared value for observed vs. predicted. Can be negative.
#' @export
#'
#' @examples
rsq_1.1 <- function(observed, predicted){
  if(sum(is.na(observed )) > 0){stop('Error: NAs in observed vector.' )}
  if(sum(is.na(predicted)) > 0){stop('Error: NAs in predicted vector.')}
  #calculate residual sums of squares relative to actual prediction (i.e. "1:1 line")
  SS.res <- sum((observed - predicted)^2)
  #calculate total sum of squares.
  SS.tot <- sum((observed - mean(observed))^2)
  #calculate rsq and return.
  rsq.1 <- 1 - SS.res/SS.tot
  return(rsq.1)
}


#Un espece de noeud en 3D de ouf !!!
# A trefoil knot
library(rgl)
#Choose the size of the image on the output (800,650 to have 800 x 600)
r3dDefaults$windowRect <- c(0,50, 800, 650)
r3dDefaults$windowRect <- c(0,50, 480, 530)
open3d()
#If you want to put line on the background
#bg3d(sphere = TRUE, color = c("grey", "white"), lit = TRUE, back = "lines" ,lwd=2)
bg3d(col=rgb(0.2,0.8,0.5,0.8))
theta <- seq(0, 2*pi, len = 50)
knot <- cylinder3d(
center = cbind(sin(theta) + 3*sin(2*theta), 2*sin(3*theta), cos(theta) - 2*cos(2*theta)),
e1 = cbind(cos(theta) + 4*cos(2*theta),6*cos(3*theta),sin(theta) + 4*sin(2*theta)),radius = 0.9,closed = TRUE)
shade3d(addNormals(subdivision3d(knot, depth = 2)), col = rgb(0.4,0.2,0.8,0.3))
#For portfolio
rgl.snapshot( "#20_portfolio_knot_3D.png", fmt="png", top=TRUE  )
#Normal size
rgl.snapshot( "#20_knot_3D.png", fmt="png", top=TRUE  )
#Pour une image mobile en html (attention, doit etre accompagnée de ses 2 fichiers soeurs...)
writeWebGL( filename="#20_portfolio_knot_3D.html" ,  width=1500)


library('nonpar')
library('DescTools')

#MC-EffNet-2 with SC-EffNet_RGB
method_a_ss_scEffnet <- matrix(c(694, 79, 116, 57, 532, 144, 83, 138, 557), 3,3)
method_b_ss_scEffnet <- as.table(matrix(c(694, 79, 116, 57, 532, 144, 83, 138, 557), nrow=3))
stuart.maxwell(method_a_ss_scEffnet)
StuartMaxwellTest(method_b_ss_scEffnet)


dhat_shift <- function(x, y) {
	min_d = scale_d(x, y)
	L = length(y)
	range = -5:5
	for(shift in range) {
		if(shift<0) {
			if(-shift+1 > ncol(y)) {
				yshift = matrix(0, nrow = 1, ncol=ncol(y))
			} else {
				yshift <- matrix(nrow = 1, ncol = ncol(y))
				len <- length(y[,(-shift+1):length(y)])
				yshift[,1:len] <- y[,(-shift+1):length(y)]
				yshift[,(len+1):length(yshift)] <- 0
			}
		} else {
		 	yshift <- matrix(nrow = 1, ncol = ncol(y))
		 	if(shift < ncol(y)) {
		 		yshift[, (shift+1):length(yshift)]<-y[,1:(length(y)-shift)]
		 		if(shift!=0) {
		 			yshift[, 1:shift] <- 0
		 		}
		 	} else {
		 		yshift[, 1:ncol(yshift)] <- 0
		 	}
		}
		cur_d = scale_d(x, yshift)
		if(cur_d <= min_d) {
			optshift = shift
			opty = yshift
			min_d = cur_d
		}
	}
	dist = min_d
	return(list(dist=dist, optshift=optshift, opty=opty))
}

scale_d <- function(x, y) {
	alpha = sum(x*y)/sum(y*y)
	if(!is.nan(alpha)) {
	  dist = norm(x - alpha * y, type="2") / norm(x, type="2")
	} else {
	  return(Inf)
	}
	return(dist)
}