### Copyright (c) 2013 Kendrick Boyd. This is free software. See
### LICENSE for details.

### Precision-Recall Analysis Stuff for R
###

### Precision-Recall curves
###
### positive (cases) scores (outputs, probabilities, etc.) are random
### variable Y negative (controls) scores are random variable X
###
### pi (prevalence) =  # positives / (# positives + # negatives)

######################################################################
### Binormal
### Assume scores are normally distributed.

### parameters:
### X ~ Normal(0,1)
### Y ~ Normal(pos.mean,pos.sd)

## Calculate true precision for a threshold under binormal distribution.
binormal.precision <- function(c,pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  r = (pi*pnorm(c,pos.mean,pos.sd,lower.tail=FALSE))/(pi*pnorm(c,pos.mean,pos.sd,lower.tail=FALSE) + (1-pi)*pnorm(c,mean=0,sd=1,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from a denominator of 0 should be precision 1
  return(r)
}

## Calculate true recall for a threshold under binormal distribution.
binormal.recall <- function(c,pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  pnorm(c,pos.mean,pos.sd,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under binormal distribution.
binormal.precision.at.recall <- function(recall, pi=0.5,pos.mean=1.0,pos.sd=1.0) {
  return(binormal.precision(qnorm(recall,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd))
}

# Plot the true binormal PR curve.
binormal.plot <- function(pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  plot(function(x) {binormal.precision(qnorm(x,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd)},xlim=c(0,1),ylim=c(0,1),xlab="Recall",ylab="Precision",sub=paste("pi=",pi,", pos.mean=",pos.mean,", pos.sd=",pos.sd))
}

# Calculate true area under binormal PR curve using numeric integration.
binormal.area <- function(pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  f <- function(q) { binormal.precision(qnorm(q,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd) }
  ## monte carlo integration
  #mean(f(runif(samples)))

  ## integrate method of R, much faster (although might have problems with x=0)
  r = integrate(f,0,1)
  return(r$value)
}

## Generate sample from binormal distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
binormal.sample <- function(n=1, pi=0.5, pos.mean=1.0, pos.sd=1.0, pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }
  num.neg = n-num.pos

  pos.values = rnorm(num.pos,mean=pos.mean,sd=pos.sd)
  neg.values = rnorm(num.neg,mean=0,sd=1)
  return(list(pos.values=pos.values,neg.values=neg.values))
}

######################################################################
### Bibeta
### Assumes scores are from two Beta distributions.
### Y ~ Beta(pos.a,pos.b)
### X ~ Beta(neg.a,neg.b)

## Calculates true precision for a threshold under bibeta distribution.
bibeta.precision <- function(c,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  ## X ~ Beta(neg.a,neg.b), Y ~ Beta(pos.a,pos.b)
  r = (pi*pbeta(c,pos.a,pos.b,lower.tail=FALSE))/(pi*pbeta(c,pos.a,pos.b,lower.tail=FALSE) + (1-pi)*pbeta(c,neg.a,neg.b,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from a denominator of 0 should have precision of 1
  return(r)
}

## Calculates true recall for a threshold under bibeta distribution.
bibeta.recall <- function(c,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  pbeta(c,pos.a,pos.b,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under bibeta distribution.
bibeta.precision.at.recall <- function(recall,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  return(bibeta.precision(qbeta(recall,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b))
}

## Plot the true bibeta PR curve.
bibeta.plot <- function(pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  plot(function(x) {bibeta.precision(qbeta(x,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b)},
       xlim=c(0,1),
       ylim=c(0,1),
       xlab="Recall",
       ylab="Precision",
       sub=paste("pi=",pi,",X (neg) ~ Beta(",neg.a,",",neg.b,"), Y (pos) ~ Beta(",pos.a,",",pos.b,")")
       )

}

## Calculate the true area under the bibeta PR curve using numeric integration.
bibeta.area <- function(pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  f <- function(q) { bibeta.precision(qbeta(q,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b) }

  ## use R's integrate method
  res = integrate(f,0,1)
  return(res$value)
}

## Generate sample from bibeta distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
bibeta.sample <- function(n=1,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1,pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }

  num.neg = n-num.pos

  ## Generates a sample of observed values for neg.values (X) ~
  ## Beta(neg.a,neg.b) and pos.values (Y) ~ Beta(pos.a,pos.b).

  pos.values = rbeta(num.pos,pos.a,pos.b)
  neg.values = rbeta(num.neg,neg.a,neg.b)

  return(list(pos.values=pos.values,neg.values=neg.values))
}

######################################################################
### Offset Uniform
### Assumes the scores are drawn from two uniform distributions
### spanning different ranges

### X ~ Uniform(0,1)
### Y ~ Uniform(a,a+b)

## Calculate true precision for a threshold under offset uniform distributions.
offsetuniform.precision <- function(c,pi=0.5,a=0.5,b=1) {
  r = (pi*punif(c,min=a,max=a+b,lower.tail=FALSE))/(pi*punif(c,min=a,max=a+b,lower.tail=FALSE) + (1-pi)*punif(c,min=0,max=1,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from denominator of 0 should have precision of 1
  return(r)
}

## Calculate true recall for a threshold under offset uniform distributions.
offsetuniform.recall <- function(c,pi=0.5,a=0.5,b=1) {
  punif(c,min=a,max=a+b,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under offset uniform distribution.
offsetuniform.precision.at.recall <- function(recall, pi=0.5,a=0.5,b=1) {
  return(offsetuniform.precision(qunif(recall,a,a+b,lower.tail=FALSE),pi=pi,a=a,b=b))
}

## Plot the true offset uniform PR curve.
offsetuniform.plot <- function(pi=0.5,a=0.5,b=1) {
  plot(function(x) {offsetuniform.precision(qunif(x,min=a,max=a+b,lower.tail=FALSE),
                                            pi=pi,
                                            a=a,
                                            b=b)},
       xlim=c(0,1),
       ylim=c(0,1),
       xlab="Recall",
       ylab="Precision",
       sub=paste("pi=",pi," a=",a,"b=",b))
}

## Calculate true area under offset uniform PR curve using numeric integration.
offsetuniform.area <- function(pi=0.5,a=0.5,b=1) {
  f <- function(q) { offsetuniform.precision(qunif(q,min=a,max=a+b,lower.tail=FALSE),
                                             pi=pi,
                                             a=a,
                                             b=b)}
  r = integrate(f,0,1)
  return (r$value)
}

## Generate sample from offset uniform distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
offsetuniform.sample <- function(n=1,pi=0.5,a=0.5,b=1,pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }
  num.neg = n-num.pos

  ## X (neg) ~ Uniform(0,1)
  ## Y (pos) ~ Uniform(a,a+b)

  pos.values = runif(n=num.pos,min=a,max=a+b)
  neg.values = runif(n=num.neg,min=0,max=1)

  return(list(pos.values=pos.values,neg.values=neg.values))
}

aucpr.conf.int <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,method="binomial",bootstrap.replicates=1000) {
  ## Calculates confidence interval for an AUCPR estimate.
  ## method=c("binomial","expit")
  m = match.arg(method,c("binomial","expit","bootstrap"))

  if (m=="binomial") {
    return(aucpr.conf.int.binomial(estimate,num.pos=length(pos.values),num.neg=length(neg.values),conf.level=conf.level))
  }
  else if (m=="expit") {
    return(aucpr.conf.int.expit(estimate,num.pos=length(pos.values),num.neg=length(neg.values),conf.level=conf.level))
  }
  else if (m=="bootstrap") {
    return(aucpr.conf.int.bootstrap(estimate,pos.values,neg.values,prcurve.estimator,conf.level,bootstrap.replicates))
  }
}

aucpr.conf.int.binomial <- function(estimate,num.pos,num.neg,conf.level=0.95) {
  ## Calculates confidence interval for an AUCPR estimate under
  ## binomial assumptions. Uses num.pos as the sample size (might not
  ## be best?).

  ci = estimate+qnorm(c((1-conf.level)/2,(1+conf.level)/2))*sqrt(estimate*(1-estimate)/num.pos)
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "binomial"
  return(ci)
}

aucpr.conf.int.expit <- function(estimate,num.pos,num.neg,conf.level=0.95) {
  ## Calculates confidence interval for an AUCPR estimate using expit.

  ## convert to logit scale
  est.logit = log(estimate/(1-estimate))
  ## standard error (from Kevin Eng)
  se.logit = sqrt(estimate*(1-estimate)/num.pos)*(1/estimate + 1/(1-estimate))
  ## confidence interval in logit
  ci.logit = est.logit+qnorm(c((1-conf.level)/2,(1+conf.level)/2))*se.logit

  ## back to original scale
  ci = exp(ci.logit)/(1+exp(ci.logit))
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "expit"
  return(ci)
}

aucpr.conf.int.bootstrap <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,replicates=1000) {
  areas = rep(0,replicates)

  for (i in 1:replicates) {
    p.v = sample(pos.values,replace=TRUE)
    n.v = sample(neg.values,replace=TRUE)

    res = prcurve.estimator(p.v,n.v)
    areas[i] = res$area
  }

  q = quantile(areas,c((1-conf.level)/2,(1+conf.level)/2))

  ci = c(q[1],q[2])
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "bootstrap"
  attr(ci,"median") = median(areas)
  attr(ci,"mean") = mean(areas)

  return (ci)
}

aucpr.conf.int.crossvalidation <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,folds=10) {
  areas = rep(0,folds)

  pos = sample(pos.values)
  neg = sample(neg.values)

  pos.counts = rep(c(as.integer(length(pos.values)/folds)+1,as.integer(length(pos.values)/folds)),c(length(pos.values)%%folds,10-length(pos.values)%%folds))
  neg.counts = rep(c(as.integer(length(neg.values)/folds)+1,as.integer(length(neg.values)/folds)),c(length(neg.values)%%folds,10-length(neg.values)%%folds))

  pos.index = 1
  neg.index = 1
  for (k in 1:folds) {
    p = pos[pos.index:(pos.index+pos.counts[k]-1)]
    n = neg[neg.index:(neg.index+neg.counts[k]-1)]

    areas[k] = prcurve.estimator(p,n)$area

    pos.index = pos.index + pos.counts[k]
    neg.index = neg.index + neg.counts[k]
  }

  ## normal approximation
  ##ci = mean(areas) + qnorm(c((1-conf.level)/2,(1+conf.level)/2))*sd(areas)/sqrt(length(areas))
  ## use t-distribution
  ci = mean(areas) + qt(c((1-conf.level)/2,(1+conf.level)/2),df=length(areas)-1)*sd(areas)/sqrt(length(areas))

  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "crossvalidation, t-dist"
  attr(ci,"values") = areas
  attr(ci,"mean") = mean(areas)

  return(ci)
}

# return confusion matrix info for >= threshold
# assume labels are 0 and 1
confusion.matrix <- function(values,labels,threshold)
{
  counts=table(factor(values>=threshold,c(FALSE,TRUE)),labels)
  ## print(counts)

  TP = counts[2,2]
  TN = counts[1,1]
  FP = counts[2,1]
  FN = counts[1,2]

  if (TP+FP == 0)
    return(list(tp=TP,tn=TN,fp=FP,fn=FN,precision=NaN,sensitivity=TP/(TP+FN),specificity=TN/(TN+FP),accuracy=(TP+TN)/(TP+TN+FP+TN)))
  else
    return(c(tp=TP,tn=TN,fp=FP,fn=FP,precision=TP/(TP+FP),sensitivity=TP/(TP+FN),specificity=TN/(TN+FP),accuracy=(TP+TN)/(TP+TN+FP+TN)))
}

## Create all confusion matrices from set of pos.values and neg.values
make.confusion.matrices <- function(pos.values,neg.values) {
  ## thresholds, sorting to have increasing recall
  thresholds = sort(c(-Inf,unique(c(pos.values,neg.values)),Inf),decreasing=TRUE)

  ## 0 - negative (control)
  ## 1 - positive (case)
  labels = c(rep(1,length(pos.values)),rep(0,length(neg.values)))
  values = c(pos.values,neg.values)

  # create set of confusion matrices
  d=sapply(thresholds,function(t) { confusion.matrix(values,labels,t) })

  return(d)
}

precisions.recalls.fast <- function(pos.values,neg.values) {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  z = 1
  precisions = rep(0,length(indices)+1)
  recalls = rep(0,length(indices)+1)

  tp = 0
  fp = 0

  for (i in 1:length(indices)) {
    if (labels[i]==1) {
      tp = tp + 1
    }
    else {
      fp = fp + 1
    }

    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can put a threshold

      ## if first, insert (r=0,p=1) point
      if (z==1) {
        recalls[z] = 0
        precisions[z] = 1
        z = z + 1
      }
      recalls[z] = tp/(length(pos.values))
      precisions[z] = tp/(tp+fp)
      z = z + 1
    }
  }

  ## truncate recals and precisions
  recalls = recalls[1:(z-1)]
  precisions = precisions[1:(z-1)]

  return (list(recalls=recalls,precisions=precisions))
}

# return c(v1[1],v2[1],v1[2],v2[2],...)  works with uneven vectors,
# appending the extra elements from the longer vector so return always
# has length of length(v1)+length(v2) from
# http://tolstoy.newcastle.edu.au/R/help/06/03/22717.html
interleave <- function(v1,v2) {
  ord1 <- 2*(1:length(v1))-1
  ord2 <- 2*(1:length(v2))
  c(v1,v2)[order(c(ord1,ord2))]
}

#################################################################
## Estimators
#################################################################
# Under, connects lowest precision on left side to highest precision
# on the right
prcurve.lowertrap <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  # get max and min precision for each unique recall
  r.unique = unique(recalls)
  p.min = sapply(r.unique,function(r) { min(precisions[recalls==r])})
  p.max = sapply(r.unique,function(r) { max(precisions[recalls==r])})

  # use min on left side and max on right side of each area between known recalls
  ids=2:length(r.unique)
  area = as.double((r.unique[ids]-r.unique[ids-1]) %*% (p.max[ids] + p.min[ids-1]) / 2)

  rs = rep(r.unique,each=2)
  ps = interleave(p.max,p.min)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.lowertrap,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,
              x=rs,
              y=ps,
              conf.int=ci))
}

# connects highest precisions at each recall, definitely an
# over-estimate
prcurve.uppertrap <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  # get max and min precision for each unique recall
  r.unique = unique(recalls)
  p.min = sapply(r.unique,function(r) { min(precisions[recalls==r])})
  p.max = sapply(r.unique,function(r) { max(precisions[recalls==r])})

  # use max precision for all recalls (NOT LEGITIMATE!)

  ids=2:length(r.unique)
  area = as.double((r.unique[ids]-r.unique[ids-1]) %*% (p.max[ids] + p.max[ids-1]) / 2)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.uppertrap,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,
              x=r.unique,
              y=p.max,
              conf.int=ci))
}

## estimate PR curve and area under PR curve using average precision
## method, mean precision at each positive example
prcurve.ap.slow <- function(pos.values, neg.values, conf.level=0.95, conf.int.method="binomial") {
  ## thresholds, sorting to have increasing recall
  ## only use thresholds for positives
  thresholds = sort(pos.values,decreasing=TRUE)

  labels = c(rep(1,length(pos.values)),rep(0,length(neg.values)))
  values = c(pos.values,neg.values)

  ## create set of confusion matrices
  d=sapply(thresholds,function(t) { confusion.matrix(values,labels,t) })
  recalls = unlist(d[6,])
  precisions = unlist(d[5,])

  area = mean(precisions)

  y = rep(precisions,each=2)
  x = c(0,rep(recalls[1:(length(recalls)-1)],each=2),recalls[length(recalls)])

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.ap.slow,
    conf.level=conf.level,
    method=conf.int.method)

  return (list(area=area,
               x=x,
               y=y,
               conf.int=ci))
}

prcurve.ap <- function(pos.values, neg.values, conf.level=0.95, conf.int.method="binomial") {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  rs = rep(0,length(pos.values))
  ps = rep(0,length(pos.values))
  z = 1
  cur.tp = 0
  cur.fp = 0
  for (i in 1:length(indices)) {
    if (labels[i]==1) {
      cur.tp = cur.tp + 1
    }
    else {
      cur.fp = cur.fp + 1
    }
    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can put a threshold here
      tp = tp + cur.tp
      fp = fp + cur.fp

      if (cur.tp > 0) {
        for (j in 1:cur.tp) {
          rs[z] = tp/length(pos.values)
          ps[z] = tp/(tp+fp)
          z = z + 1
        }
      }
      cur.tp = 0
      cur.fp = 0
    }

  }

  if (z != length(pos.values)+1) {
    cat("WARNING: did not fill recall and precision arrays correctly (z: received=",z,", expected=",length(pos.values)+1,")\n",sep="")
  }
  area = mean(ps)

  y = rep(ps,each=2)
  x = c(0,rep((rs[1:(length(rs)-1)]),each=2),rs[length(rs)])

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.ap,
    conf.level=conf.level,
    method=conf.int.method)

  return (list(area=area,
               x=x,
               y=y,
               conf.int=ci))
}

## estimate PR curve and area under PR curve with MLE parameters for
## positive and negative normal distributions
prcurve.binormal <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  ## Assume X ~ N(0,1), i.e. negatives have standard normal distribution.
  ## So only have 2 df to calculate.

  if (length(pos.values)<=1) {
    cat("ERROR: cannot use binormal estimate with fewer than 2 positive samples\n")
  }
  if (length(neg.values)<=1) {
    cat("ERROR: cannot use binormal estimate with fewer than 2 negative samples\n")
  }
  mean.hat = (mean(pos.values)-mean(neg.values))/sd(neg.values)
  sd.hat = sd(pos.values)/sd(neg.values)

  pi = length(pos.values)/(length(pos.values)+length(neg.values))

  area = binormal.area(pi=pi,pos.mean=mean.hat,pos.sd=sd.hat)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.binormal,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,pi.hat=pi,pos.mean.hat=mean.hat,pos.sd.hat=sd.hat, conf.int=ci))
}

## Use linear interpolation in ROC space, translate to PR space and
## find the precision for the specified recall (r) for interpolating
## between PR points (r1,p1) and (r2,p2)
interpolate.point <- function(r1,p1,r2,p2,r) {
  res = r / (r*(1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))) + (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1)))
  res[r==0] = p2
  return(res)
## if (r==0) {
##   ## hmm, use limit which is just p2
##   return(p2)
## }
## else {
##   return(r / (r*(1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))) + (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1))))
## }
}

interpolate.curve <- function(recalls,precisions,num.samples=1000) {

  ## sort by increasing recall
  indices = order(recalls,decreasing=FALSE)
  rs = recalls[indices]
  ps = precisions[indices]

  xs = rep(0,num.samples)
  ys = rep(0,num.samples)
  ## point lies between rs[index-1] and rs[index]
  index = 1
  for (i in 1:num.samples) {
    ## evenly spaced in [0,1], including end-points
    recall = (i-1)/(num.samples-1)
    xs[i] = recall

    while (rs[index]<recall) {
      index = index + 1
    }

    if (index==1) {
      ## use (0,1) as beginning interp point (creates horizontal line
      ## from smallest (r,p) at y=p
      ys[i] = interpolate.point(0,1,rs[index],ps[index],recall)
    }
    else {
      ys[i] = interpolate.point(rs[index-1],ps[index-1],rs[index],ps[index],recall)
    }
  }
  return(list(x=xs,y=ys))
}

## Use ROC interpolation to calculate areas between PR points
## Assumes recalls has no duplicates and sorted in ascending order
## only calculates area from min(recalls) to max(recalls)
interpolate.area <- function(recalls, precisions) {
  area = 0.0

  for (i in 2:length(recalls)) {
    ## calculate area for recalls[i-1] to recalls[i]

    r1 = recalls[i-1]
    p1 = precisions[i-1]
    r2 = recalls[i]
    p2 = precisions[i]

    if (r1 == r2) {
      cat("WARNING: recalls passed to interpolate.area are not unique\n")
    }
    if (r1 > r2) {
      cat("WARNING: recalls passed to interpolate.area are not sorted ascending\n")
      cat("recalls: ",recalls,"\n")
      cat("precisions: ",precisions,"\n")
    }

    if (r1==0) {
      ## definite integral is undefined
      ## use rectangle with height p2 (as interpolate.curve creates)
      area = area + p2*(r2-r1)

    }
    else {
      ## formula between these is p' = r' / (a + b*r')
      a = (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1))
      b = 1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))

      ## indefinite integral is (bx - a log (a + bx))/b^2
      ## area contribution is definite integral from r1 to r2
      area = area + (b*r2 - a*log(a+b*r2))/(b*b) - (b*r1 - a*log(a+b*r1))/(b*b)
    }

  }
  return(area)
}

## estimate PR curve and AUCPR by interpolating between the max
## precisions for each recall
prcurve.interpolate <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial",aggregator = max) {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  r.unique = unique(recalls)
  p.max = sapply(r.unique,function(r) { aggregator(precisions[recalls==r])})

  ## sort
  indices = order(r.unique,decreasing=FALSE)
  rs = r.unique[indices]
  ps = p.max[indices]

  area = interpolate.area(rs,ps)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator= function(p.v,n.v,c.l,c.i.m) { prcurve.interpolate(pos.values=p.v,neg.values=n.v,conf.level=c.l,conf.int.method=c.i.m,aggregator) },
    conf.level=conf.level,
    method=conf.int.method)

  curve = interpolate.curve(rs,ps)

  return(list(area=area,x=curve$x,y=curve$y,conf.int=ci))

}

roccurve.points <- function(pos.values,neg.values) {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  z = 1
  tprs = rep(0,length(indices)+1)
  fprs = rep(0,length(indices)+1)

  for (i in 1:length(indices)) {
    if (labels[i]==1) { tp = tp + 1 }
    else { fp = fp + 1 }

    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can place threshold

      ## if first, insert the all negative point (tpr=0,fpr=0)
      if (z==1) {
        tprs[z] = 0
        fprs[z] = 0
        z = z + 1
      }
      tprs[z] = tp/length(pos.values)
      fprs[z] = fp/length(neg.values)
      z = z + 1
    }
  }

  ## truncate to used indices
  tprs = tprs[1:(z-1)]
  fprs = fprs[1:(z-1)]

  return (list(tprs=tprs,fprs=fprs))
}

## Estimate PR curve by taking convex hull in ROC space, convert only
## points on convex hull in ROC to PR, then use interpolation to go
## between.
prcurve.interpolate.convex <- function(pos.values, neg.values, conf.level=0.95,conf.int.method="binomial") {
  pi = length(pos.values)/(length(pos.values)+length(neg.values))

  t = roccurve.points(pos.values,neg.values)

  ## add the point (1,0) to make convex hull calculation clean (won't
  ## pick up any worse than random points)
  points = matrix(c(t$fprs,1,t$tprs,0),ncol=2)

  hull.indices = chull(points)

  ## remove the dummy point (0,1) we added, it's always the last element
  ## with index length(points)/2
  indices = hull.indices[!hull.indices==length(points)/2]
  points = points[indices,]

  ## due to bugs in chull and just to be safe sort points ascending by
  ## recall (second column)
  points = points[order(points[,2],decreasing=FALSE),]

  ## convert to PR space
  precisions = rep(0,length(indices))
  recalls = rep(0,length(indices))
  for (i in 1:length(indices)) {
    if (points[i,1]==0 & points[i,2]==0) {
      ## all negative
      precisions[i] = 1.0
      recalls[i] = 0.0
    }
    else {
      recalls[i] = points[i,2]
      precisions[i] = pi*points[i,2]/(pi*points[i,2] + (1-pi)*points[i,1])
    }
  }

  ## remove duplicate recalls, most likely having multiple recall=1.0
  ## points coming from the y=1 horizontal line in ROC space
  recalls.unique = unique(recalls)
  precisions.unique = sapply(recalls.unique,function(r) { max(precisions[recalls==r])})

  ## check that recalls are sorted ascending, having problems with non-sorted recalls
  if (is.unsorted(recalls.unique)) {
    cat("pos.values = ",pos.values,"\n")
    cat("neg.values = ",neg.values,"\n")
    cat("recalls = ",recalls,"\n")
    cat("precisions = ",precisions,"\n")
    cat("recalls.unique = ",recalls.unique,"\n")
    cat("precisions.unique = ",precisions.unique,"\n")

  }

  area = interpolate.area(recalls.unique,precisions.unique)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.interpolate.convex,
    conf.level=conf.level,
    method=conf.int.method)

  curve = interpolate.curve(recalls.unique,precisions.unique)

  return(list(area=area,x=curve$x,y=curve$y,conf.int=ci))

}

## stratified bootstrap
## resample positive and negative separately
bootstrap <- function(pos.values,neg.values,prcurve.function,replicates=1000) {
  areas = rep(0,replicates)

  for (i in 1:replicates) {
    p.v = sample(pos.values,replace=TRUE)
    n.v = sample(neg.values,replace=TRUE)

    res = prcurve.function(p.v,n.v)
    areas[i] = res$area
  }

  return(areas)
}


my_calc <- function(x, y){
  s <- x+y
  return(s)
}

result <- my_calc(1,1)

my_calc <- function(x, y){
  s <- x+y
  d <- x-y
  return(c(s,d))
}

result <- my_calc(1,1)

my_calc2 <- function(x, y, z = 10){
  s <- x+y+z
  d <- x-y-z
  return(c(s,d))
}

my_calc2(1,2)

distr1 <- rnorm(100)
hist(distr1)
distr1[1:30] <- NA

distr1[is.na(distr1)] <- mean(distr1, na.rm = TRUE)

my_na_rm <- function(x){
  x[is.na(x)] <- mean(x, na.rm = TRUE)
  return(x)
}

rr <- my_na_rm(x=distr1)
rr

my_na_rm <- function(x){
  if(is.numeric(x)){
    x[is.na(x)] <- mean(x, na.rm = TRUE)
    return(x)
  }else{
    print("X is not numeric")
  }
}

my_na_rm <- function(x){
  if(is.numeric(x)){
    stat_test <- shapiro.test(x)
    if(stat_test$p.value > 0.05){
      x[is.na(x)] <- mean(x, na.rm = TRUE)
    }else{
      x[is.na(x)] <- median(x, na.rm = TRUE)
    }
    return(x)

  }else{
    print("X is not numeric")
  }
}

#trouble №2
dd <- c(-15.399, -19.577, 10.211, -15.013, 3.411, 5.092, 3.491, 7.952, 22.564, 15.529, 4.768, 23.097, -3.180, 0.827, -8.256, 31.052, -8.126, -9.064, 18.046, -0.116, NA, NA, NA, 20.240, NA, NA, 18.887, NA, NA, 3.192, NA, NA, 0.215, NA, NA, 21.160, NA, NA, -19.588 ,NA)

NA.position <- function(x){
  length(x[is.na(x)])
}

dir()
dir(pattern = "*.csv")

grants <- data.frame()

read_data <- function(){
  df <- data.frame()
  number <<- 0                                 # volotile !!!
  for(i in dir(pattern = "*.csv")){
    temp_df <- read.csv(i)
    df <- rbind(temp_df, df)
    number <- number+1
  }
  print(paste(as.character(number),"files were combined"))
  return(df)
}


"
Проверить работу арифметических операторов и приоритет выполнения операций в сложных выражениях
Выполнить серию из 10 вычислений по различным самостоятельно придуманным
формулам.Использовать все операторы из таблицы 1.

Выяснить правило, по которому выполняется расчет, если в формуле используется целочисленное деление
и остаток от деления. Убедиться, что значения выражений дают предсказуемый вами результа
т."

n <- 6
k <- 4
result <- factorial(n)/factorial(n-k)
print(result)

for (n in 1:16) {
  print(paste(n, "! = ", prod(1:n), sep = ""))
}

result <- 1+3
print(result)
result <- 1-3
print(result)
result <- 1*3
print(result)
result <- 1/3
print(result)
result <- 2^3
print(result)
result <- 2%/%3
print(result)
result <- 2%%3
print(result)


#!/usr/bin/env Rscript

##########################################
### 系数矩阵 (coeffcient matrix)
##########################################
r1 = c(1, -2, 1)
r2 = c(0, 2, -8)
r3 = c(-4, 5, 9)
coe = rbind(r1, r2, r3)

rownames(coe) = paste("r", seq(1, dim(coe)[1]), sep = "")
colnames(coe) = paste("x", seq(1, dim(coe)[2]), sep = "")

##########################################
### 增广矩阵 (augmented matrix)
##########################################
b = c(0, 8, -9)
aug = cbind(coe, b)

colnames(aug)[4] <- "y"

##########################################
### 高斯消去(Gauss-Jordan elimination)
##########################################
library("pracma")
help("rref")  # reduced row echelon form
rref(aug)

A = rbind(c(0,-3,-6,4,9),
          c(-1,-2,-1,3,1),
          c(-2,-3,0,3,-1),
          c(1,4,5,-9,-7))
rref(A)

B = rbind(c(0,3,-6,6,4,-5),
          c(3,-7,8,-5,8,9),
          c(3,-9,12,-9,6,15))
rref(B)

##########################################
### 基本变量和自由变量
### 主元列--> 基本变量 (化简后列上有非0值)
### 存在自由变量 --> 有通解
### R3 坐标系中, 有通解表示解再两个平面的交线上
##########################################

##########################################
### 线性组合 (理解几何意义) ---> 很重要的一课
### 向量加法的平行四边型法则 v, u, 0, (v+u)
### 线性代数的主要思想:
### TODO: 为某一已知的向量{v1, v2, v3, ... vp}线性组合出的所有向量
### span{v1, v2, ..., vp} = all c1v1 + c2v2 + ... + cpvp  向量集合
### 组合的意义
### 组合的几何意义
### 某一向量的b --> [a1, a2, ..., an]线性组合--> 这个b应该就是span中的一个
##########################################

############################################################
### 矩阵方程Ax = b
### 向量的线性组合看作[矩阵]与[向量]的积
### 矩阵 ---> 用来线性组合的列向量的组成
### 向量 ---> 线性组合时用到的常数组成
### >>>>> 矩阵方程, 向量方程, 线性方程组 <<<<<<
############################################################

############################################################
### Test
############################################################
A = cbind(c(1,-4,-3),
          c(3,2,-2),
          c(4,-6,-7),
          c(-5, -5, 0))
rref(A)

############################################################
### 齐次方程  Ax = 0
### 非齐次    Ax = b
### 通解的几何意义
############################################################

############################################################
### 矩阵变换 一个空间--> 另一个空间 (映射像)
### Ax = b --> T(x)
### A的n列 --> T的定义域R(n) ,  A每列m个元素--> T的余定义域
### m > n --> 原像
### m < n --> 投影
### m = n --> 剪切,拉伸等变换
############################################################


X = matrix( c(1,2,3,4,5,6), nrow=3,ncol=2)
X
t(X)%*%X
solve(t(X)%*%X)


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 11

rm(list = ls())

observed <- c(23, 18, 12, 7)

(k <- length(observed))
# 4

(n <- sum(observed))
# 60

LogLikelihood <- function(p, y) {
  (sum(y[1:(k - 1)] * dgeom(0:(k - 2), prob = p, log = TRUE)) +
     y[k] * pgeom(k - 2, prob = p, lower.tail = TRUE))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(0.5, NegativeLogLikelihood, y = observed,
             lower = 10e-4, upper = 1 - 10e-4, method = "L-BFGS-B")

(p.hat <- opt$par)
# 0.568016367320236

## a)

(expected <- n * c(dgeom(0:(k - 2), prob = p.hat), 1 - pgeom(k - 2, prob = p.hat)))
# 34.0809820392142 14.7224264265935 6.35984724962043 4.83674428457189

(Q <- sum((observed - expected) ^ 2 / expected))
# 10.3019299508017

(pvalue <- 1 - pchisq(Q, df = (k - 1) - 1))
# 0.00579381114321054

## b)

alpha <- 0.05

(criticvalue <- qchisq(1 - alpha, df = k - 1))
# 7.81472790325118

(alternative <- n * c(dnbinom(0:(k - 2), size = 2, prob = 0.6), 1 - pnbinom(k - 2, size = 2, prob = 0.4)))
# 21.6 17.28 10.368 28.512

(null <- n * c(dgeom(0:(k - 2), prob = 0.4), 1 - pgeom(k - 2, prob = 0.4)))
# 24 14.4 8.64 12.96

(Q <- sum((alternative - null) ^ 2 / null ))
# 19.824

(power <- 1 - pchisq(criticvalue, df = k - 1, ncp = Q))
# 0.973940021807995

## c)

fn <- function(n) {
  alternative <- n * c(dnbinom(0:(k - 2), size = 2, prob = 0.6), 1 - pnbinom(k - 2, size = 2, prob = 0.4))
  null <- n * c(dgeom(0:(k - 2), prob = 0.4), 1 - pgeom(k - 2, prob = 0.4))

  Q <- sum((alternative - null) ^ 2 / null )
  power <- 1 - pchisq(qchisq(1 - alpha, df = k - 1), df = k - 1, ncp = Q)

  return(power)
}

(n.exact <- uniroot(function(n){ fn(n) - 0.7 }, c(1, 100))$root)
# 26.6113581747679

ceiling(n.exact)
# 27


library("plyr")
library("MASS")

################################################################################
#   a
################################################################################
colours <- terrain.colors(5)

drawDataPoints <- function (inputs) {
    classA <- inputs[inputs$class == 1, ]
    classB <- inputs[inputs$class == 0, ]

    points(classA$x, classA$y, col = colours[1], lwd = 3)
    points(classB$x, classB$y, col = colours[2], lwd = 3)
}

drawDecisionBoundaryL <- function (weights, i = 1) {
    a <- weights[1]
    b <- weights[2]
    c <- weights[3]
    plot(NA, NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y", col = colours[i])
    abline(-(c/b), -(a/b))
}

drawDecisionBoundaryQ <- function (weights, xlim = c(-2,2), ylim = c(-2,2), length = 10) {
    f <- Vectorize(function(x,y) sum(featureQ(c(x, y)) * weights))
    x <- seq(xlim[1], xlim[2], length = length)
    y <- seq(ylim[1], ylim[2], length = length)
    z <- outer(x,y,f)
    contour(
        x = x, y = x, z = z,
        levels = 0, las = 1, drawlabels = FALSE, lwd = 3,
        xlim=xlim, ylim=ylim, xlab="x", ylab="y", add = TRUE
    )
}
drawErrors <- function (errors) {
    plot(errors, xlab="iteration", ylab="error", type="s")
}

featureL <- function (input) {
    x <- unlist(input[1])
    y <- unlist(input[2])
    return(unlist(c(x, y, 1)))
}

featureQ <- function (input) {
    x <- unlist(input[1])
    y <- unlist(input[2])
    return(unlist(c(x * x, x * y, y * y, x, y, 1)))
}

# activation function
hardlimiter <- function (n) {
    if (n > 0) {
        return(1)
    } else {
        return(0)
    }
}

sigmoid <- function (n) 1/(1 + exp(-n))

id <- function (n) n

perceptron <- function (input, weights, feature, activate) {
    return(activate(sum(feature(input) * weights)))
}

classifyA <- function (feature, activation, learningRate, iteration, inputs, weights) {
    errors <- c()
    for (j in 1:iteration) {
        numberOfErrors <- 0
        for (i in 1:nrow(inputs)) {
            input <- inputs[i, ]
            output <- perceptron(input, weights, feature, activation)
            error <- input$class - output
            correction <- error * learningRate
            weights <- weights + feature(input) * correction
            if (error != 0)
                numberOfErrors <- numberOfErrors + 1
        }
        errors <- c(errors, numberOfErrors)
    }
    return(list(
        weights = weights,
        errors = errors
        ))
}

inputs <- data.frame(
    x = c(-1, -1, 1, 1),
    y = c(-1, 1, -1, 1),
    class = c(1, 0, 0, 1))

result <- classifyA(featureQ, hardlimiter, 0.1, 100, inputs, rep(0, 6))
plot(NA, NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y")
drawDecisionBoundaryQ(result$weights)
drawDataPoints(inputs)
title("(a) dividing XOR with quadratic perceptrons")

drawErrors(result$errors)
title("error / iteration")

################################################################################
#   b
################################################################################

plotBoundary3 <- function(weights) {
    # vectors
    l01 <- weights[, 1] - weights[, 2]
    l12 <- weights[, 2] - weights[, 3]
    l20 <- weights[, 3] - weights[, 1]

    # cross point
    x <- ((l01[2]*l12[3])/l12[2] - l01[3]) / (l01[1] - (l12[1]*l01[2])/l12[2])
    y <- ((l01[1]*l12[3])/l12[1] - l01[3]) / (l01[2] - (l12[2]*l01[1])/l12[1])

    slope01 = l01[1]/(-l01[2])
    slope12 = l12[1]/(-l12[2])
    slope20 = l20[1]/(-l20[2])
    segments(x, y, x - 100, y - slope01 * 100)
    segments(x, y, x + 100, y + slope12 * 100)
    segments(x, y, x - 100, y - slope20 * 100)
}

tagClass <- function (inputs, class) {
    return(data.frame(x = inputs[, 1], y = inputs[, 2], class = class))
}

class0 = list(
    mean = c(0, 0),
    sigma = matrix(c(1, 0, 0, 1), 2, 2))

class1 = list(
    mean = c(10, 0),
    sigma = matrix(c(1, 0, 0, 4), 2, 2))

class2 = list(
    mean = c(5, 10),
    sigma = matrix(c(4, 0, 0, 1), 2, 2))

class0raw = mvrnorm(n = 100, class0$mean, class0$sigma)
class1raw = mvrnorm(n = 100, class1$mean, class1$sigma)
class2raw = mvrnorm(n = 100, class2$mean, class2$sigma)

class0 = tagClass(class0raw, 0)
class1 = tagClass(class1raw, 1)
class2 = tagClass(class2raw, 2)

weights = matrix(0, 3, 3)
learningRate <- 0.5
iteration <- 100
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ]), 3, 3)
        numberOfClasses <- 3
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureL, hardlimiter),
                perceptron(input, weights[, 2], featureL, hardlimiter),
                perceptron(input, weights[, 3], featureL, hardlimiter))

            correction <- featureL(input) * learningRate
            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] == 0) { # reinforce
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] == 1) { # punish
                    weights[, m] <- weights[, m] - correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}
plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])

plotBoundary3(weights)
title("(b) linear multiclass perceptron with hardlimiter activation function")
drawErrors(errors)
title("error / iteration")

weights = matrix(0, 3, 3)
learningRate <- 0.5
iteration <- 100
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ]), 3, 3)
        numberOfClasses <- 3
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureL, sigmoid),
                perceptron(input, weights[, 2], featureL, sigmoid),
                perceptron(input, weights[, 3], featureL, sigmoid))

            # wrong prediction, adjust all weights
            if (max(outputs) != outputs[k] || min(outputs) == outputs[k]) {
                correction <- featureL(input) * learningRate
                for (m in 1:numberOfClasses) {
                    if (m == k) {   # reinforce
                        weights[, m] <- weights[, m] + correction
                    } else {
                        weights[, m] <- weights[, m] - correction
                    }
                }
                numberOfErrors <- numberOfErrors + 1
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])

plotBoundary3(weights)
title("(b) linear multiclass perceptron with sigmoid activation function")

drawErrors(errors)
title("error / iteration")

################################################################################
#   c
################################################################################

class3 = list(
    mean = c(5, 5),
    sigma = matrix(c(1, 0, 0, 1), 2, 2))
class3 = tagClass(mvrnorm(n = 100, class3$mean, class3$sigma), 3)

weights = matrix(0, 6, 4)
learningRate <- 1
iteration <- 500
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ], class3[i, ]), 3, 4)
        numberOfClasses <- 4
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureQ, hardlimiter),
                perceptron(input, weights[, 2], featureQ, hardlimiter),
                perceptron(input, weights[, 3], featureQ, hardlimiter),
                perceptron(input, weights[, 4], featureQ, hardlimiter))
            correction <- featureQ(input) * learningRate
            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] == 0) { # reinforce
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] == 1) { # punish
                    weights[, m] <- weights[, m] - correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])
points(class3, col = colours[4])
drawDecisionBoundaryQ(weights[, 1], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 2], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 3], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 4], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
title("(b) quadratic multiclass perceptron with hardlimiter activation function")

drawErrors(errors)
title("error / iteration")

weights = matrix(0.5, 6, 4)
learningRate <- 0.1
iteration <- 500
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ], class3[i, ]), 3, 4)
        numberOfClasses <- 4
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(
                perceptron(input, weights[, 1], featureQ, sigmoid),
                perceptron(input, weights[, 2], featureQ, sigmoid),
                perceptron(input, weights[, 3], featureQ, sigmoid),
                perceptron(input, weights[, 4], featureQ, sigmoid))

            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] < 0.9) { # reinforce
                    correction <- featureQ(input) * learningRate * (1 - outputs[m])
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] > 0.1) { # punish
                    correction <- featureQ(input) * learningRate * (0 - outputs[m])
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])
points(class3, col = colours[4])
drawDecisionBoundaryQ(weights[, 1], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 2], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 3], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 4], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
title("(b) quadratic multiclass perceptron with sigmoid activation function")

drawErrors(errors)
title("error / iteration")


######################################################################
###
###  Mixture
###  Fonte: http://www.learnbymarketing.com/tutorials/k-means-clustering-in-r-example/
#######################################################################
# The data set refers to clients of a wholesale distributor. It includes the annual spending in monetary units (m.u.) on diverse product categories
# The variables are:
# 1) FRESH: annual spending (m.u.) on fresh products (Continuous);
# 2) MILK: annual spending (m.u.) on milk products (Continuous);
# 3) GROCERY: annual spending (m.u.)on grocery products (Continuous);
# 4) FROZEN: annual spending (m.u.)on frozen products (Continuous)
# 5) DETERGENTS_PAPER: annual spending (m.u.) on detergents and paper products (Continuous)
# 6) DELICATESSEN: annual spending (m.u.)on and delicatessen products (Continuous);
# 7) CHANNEL: customer's Channel - Horeca (Hotel/Restaurant/CafÃ©) or Retail channel (Nominal)
# 8) REGION: customer's Region “ Lisnon, Oporto or Other (Nominal)

rm(list=ls())
## Libraries
library(cluster)
##
WD = "/Users/gianlucamastrantonio/Desktop/statistico/lavori/lezioni/DataSpace/2018/Lez9/"
setwd(WD)

# dataset
data <-read.csv("Wholesale customers data.csv",header=T)
summary(data)

# facciamo dei plot
plot(data[,-c(1,2)])

# vediamo le stime di densità
plot(density(data[,3]), xlab= colnames(data)[3])
plot(density(data[,4]), xlab= colnames(data)[4])
plot(density(data[,5]), xlab= colnames(data)[5])
plot(density(data[,6]), xlab= colnames(data)[6])
plot(density(data[,7]), xlab= colnames(data)[7])
plot(density(data[,8]), xlab= colnames(data)[8])

# vediamo le densità in scala log
plot(density(log(data[,3])), xlab= colnames(data)[3])
plot(density(log(data[,4])), xlab= colnames(data)[4])
plot(density(log(data[,5])), xlab= colnames(data)[5])
plot(density(log(data[,6])), xlab= colnames(data)[6])
plot(density(log(data[,7])), xlab= colnames(data)[7])
plot(density(log(data[,8])), xlab= colnames(data)[8])

# vediamo qualche densità bivariata
smoothScatter(log(data[,3]),log(data[,4]),xlab= colnames(data)[3],ylab= colnames(data)[4])
smoothScatter(log(data[,3]),log(data[,5]),xlab= colnames(data)[3],ylab= colnames(data)[5])
smoothScatter(log(data[,3]),log(data[,6]),xlab= colnames(data)[3],ylab= colnames(data)[6])
smoothScatter(log(data[,3]),log(data[,7]),xlab= colnames(data)[3],ylab= colnames(data)[7]) #
smoothScatter(log(data[,3]),log(data[,8]),xlab= colnames(data)[3],ylab= colnames(data)[8])

smoothScatter(log(data[,4]),log(data[,5]),xlab= colnames(data)[4],ylab= colnames(data)[5])#
smoothScatter(log(data[,4]),log(data[,6]),xlab= colnames(data)[4],ylab= colnames(data)[6])
smoothScatter(log(data[,4]),log(data[,7]),xlab= colnames(data)[4],ylab= colnames(data)[7])
smoothScatter(log(data[,4]),log(data[,8]),xlab= colnames(data)[4],ylab= colnames(data)[8]) #

smoothScatter(log(data[,5]),log(data[,6]),xlab= colnames(data)[5],ylab= colnames(data)[6])
smoothScatter(log(data[,5]),log(data[,7]),xlab= colnames(data)[5],ylab= colnames(data)[7]) #
smoothScatter(log(data[,5]),log(data[,8]),xlab= colnames(data)[5],ylab= colnames(data)[8])

smoothScatter(log(data[,6]),log(data[,7]),xlab= colnames(data)[6],ylab= colnames(data)[7]) #
smoothScatter(log(data[,6]),log(data[,8]),xlab= colnames(data)[6],ylab= colnames(data)[8])

smoothScatter(log(data[,7]),log(data[,8]),xlab= colnames(data)[7],ylab= colnames(data)[8]) #

# eliminiamo i top-clienti
top.n.custs <- function (data,cols,n=5)
{
	idx.to.remove <-integer(0)
	for (c in cols)
	{
		col.order <-order(data[,c],decreasing=T)
		idx <-head(col.order, n)
		idx.to.remove <-union(idx.to.remove,idx)
	}
	return(idx.to.remove) #Return the indexes of customers to be removed
}
top.custs <-top.n.custs(data,cols=3:8,n=5)
length(top.custs)
# vediamo chi sono
data[top.custs,]
# eliminiamoli
data.rm.top<-data[-c(top.custs),]
 # standardizziamo
data.rm.top = as.data.frame(scale(data.rm.top))

# il modello
set.seed(76964057)
# definiamo 5 cluster
k <-kmeans(data.rm.top[,-c(1,2)], centers=5)
k$centers
summary(data.rm.top[,-c(1,2)])
table(k$cluster)
# rapporto tra varianze
k$withinss/k$betweenss

# qualche plot
plot(log(data[,3]),log(data[,7]),xlab= colnames(data)[3],ylab= colnames(data)[7], col=k$cluster)
plot(log(data[,7]),log(data[,8]),xlab= colnames(data)[7],ylab= colnames(data)[8], col=k$cluster)

# stimiamo il numero di componenti
rng<-2:20  # numero di cluster da testare
tries <-100  # iterazioni dell'algoritmo
avg.totw.ss <-integer(length(rng))
for(v in rng)
{
 	v.totw.ss <-integer(tries)
 	for(i in 1:tries)
	{
 		k.temp <-kmeans(data.rm.top[,-c(1,2)],centers=v)
 		v.totw.ss[i] <-k.temp$tot.withinss
 	}
 	avg.totw.ss[v-1] <-mean(v.totw.ss) #Average the 100 total withinss
}
plot(rng,avg.totw.ss,type="b", main="Total Within SS by Various K",
 ylab="Average Total Within Sum of Squares",
 xlab="Value of K")

#### #### #### #### #### #### #### #### #### #### #### ####
# cosa ci saremmo dovuto aspettare
# in caso di cluster ben separati?
# Simuliamo
n  = 1000
Data = cbind(c(rnorm(n, 0, 1),rnorm(n, 10, 1),rnorm(n, -10, 1)),c(rnorm(n, 0, 1),rnorm(n, 10, 1),rnorm(n, -10, 1)))
plot(Data)

Ksim1 = kmeans(Data,centers=1)
Ksim2 = kmeans(Data,centers=2)
Ksim3 = kmeans(Data,centers=3)
Ksim4 = kmeans(Data,centers=4)
Ksim5 = kmeans(Data,centers=5)

plot(1:5,c(mean(Ksim1$tot.withinss),mean(Ksim2$tot.withinss),mean(Ksim3$tot.withinss),mean(Ksim4$tot.withinss),mean(Ksim5$tot.withinss)),type="b", main="Total Within SS by Various K",
 ylab="Average Total Within Sum of Squares",
 xlab="Value of K")
#### #### #### #### #### #### #### #### #### #### #### ####
# esame della silhouette
# matrice delle distanze
D <- daisy(data.rm.top[-c(1,2)])
Nclust = 6
plot(silhouette(kmeans(data.rm.top[,-c(1,2)], centers=Nclust)$cluster, D), col=1:8, border=NA)


# ************************************************
### simon munzert
### introduction to R
# ************************************************

source("packages.r")
source("functions.r")

# ************************************************
# DEALING WITH VECTORS -----------------------

# numeric vectors
x <- c(4,8,15,16,23,42)
x
class(x)
length(x)
summary(x)

# character vectors
countries <- c("Germany", "France", "Netherlands", "Belgium")
countries
paste(countries, collapse = " ")
paste("Hello", "world!", sep = " ")
paste0("Hello", "world!")
c(countries, "Poland")
class(countries)

# logical vectors
x > 15
x == sqrt(225)

# logical and relational operators
# <,>,>=,<=,==,!=, is.na(), & (logical AND), | (logical OR), ! (logical NOT)

# missing values
y <- c(1,10,NA,7,NA,11)
sum(y)
sum(y, na.rm = TRUE)
!is.na(y) # not: y == NA
y*3

# seq and rep
seq(1, 10, 3)
rep(c(1, 2, 3), 2)
rep(c(1, 2, 3), each = 2)
seq_along(x)

# sorting
vec1 <- c(2, 20, -5, 1, 200)
vec2 <- seq(1, 5)
sort(vec1, decreasing = FALSE)
order(vec1, decreasing = FALSE)
vec2[order(vec1)]
vec3 <- c(1,10,NA,7,NA,11)
vec4 <- vec3[!is.na(vec3)]
vec4

# vectors with mixed element types are not possible
z <- c(1,2,"Bavaria", 4)
z
str(z)

# variables
zz <- c(1,2,Bavaria,4,5,6) # error
Bavaria <- 3
zz <- c(1,2,Bavaria,4,5,6)
zz
str(zz)

# transform vector type
zzchar <- as.character(zz)
zznum <- as.numeric(zzchar)

# combine vectors
xzz <- c(x,zz)

# subsetting
countries[2]
xzz[1:6] # works, too: xzz[seq(1,6)], xzz[c(1,2,3,4,5,6)]
xzz[c(2, 5, 10)]
xzz[-1]
xzz[Bavaria]
xzz[seq(0, 10, by = 2)]
xzz[c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE)]
y
y[is.na(y)]
y[!is.na(y)]
y[y > 5 & !is.na(y)]

countries
countries[3] <- "Switzerland"
countries

xzz
xzz[c(1 ,3 ,5 )] <- c(100,110,120)
xzz_new <- xzz
xzz_new[xzz <= 100] <- 0
xzz_new[xzz > 100] <- 1
xzz_new
ifelse(xzz > 100, 1, 0)


#' @export
homoskedastic_covariance_estimator <- function(X, y){
    s.2 <- unbiased_error_variance_estimation(X, y)

    solve(t(X) %*% X) * s.2
}

#' @export
white_heteroskedastic_covariance_estimator <- function(X, y){
    e.hat <- c(residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.hat^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
hinkley_heteroskedastic_covariance_estimator <- function(X, y){
    e.hat <- c(residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.hat^2) %*% X
    n <- dim(X)[1]
    k <- dim(X)[2]

    n/(n-k) * `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
horn_heteroskedastic_covariance_estimator <- function(X, y){
    e.bar <- c(standardized_residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.bar^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
mackinnon_heteroskedastic_covariance_estimator <- function(X, y){
    e.tilde <- prediction_error(X, y)
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.tilde^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

# Notations and Abbreviations

#' @export
V.hat_beta.hat <- homoskedastic_covariance_estimator
#' @export
vce <- homoskedastic_covariance_estimator

#' @export
V.hat.hc0_beta.hat <- white_heteroskedastic_covariance_estimator
#' @export
robust_vce0 <- white_heteroskedastic_covariance_estimator

#' @export
V.hat.hc1_beta.hat <- hinkley_heteroskedastic_covariance_estimator
#' @export
robust_vce1 <- hinkley_heteroskedastic_covariance_estimator

#' @export
V.hat.hc2_beta.hat <- horn_heteroskedastic_covariance_estimator
#' @export
robust_vce2 <- horn_heteroskedastic_covariance_estimator

#' @export
V.hat.hc3_beta.hat <- mackinnon_heteroskedastic_covariance_estimator
#' @export
robust_vce3 <- mackinnon_heteroskedastic_covariance_estimator


library(ggplot2)

# change these parameters if you wnt
samplesPerExperiment <- 32
nExperiments <- 1000

# generate the experimental data
controls = rnorm(n = samplesPerExperiment*nExperiments, mean = 50, sd = 20)
tests = rnorm(n = samplesPerExperiment*nExperiments, mean = 60, sd = 20)
dim(controls) <- c(samplesPerExperiment, nExperiments)
dim(tests) <- c(samplesPerExperiment, nExperiments)

# this function calculate a p values
pValue <- function(nSamples1, mean1, var1,
                   nSamples2, mean2, var2) {
    delta <- mean1 - mean2
    sp2 <- ((nSamples1 - 1) * var1 + (nSamples2 - 1) * var2) / (nSamples1 + nSamples2 - 2)
    stderr <- sqrt(sp2 * (1 / nSamples1 + 1 / nSamples2))
    t <- delta / stderr
    pt(-abs(t), df = 2 * samplesPerExperiment - 2) +
        1 - pt(abs(t), df = 2 * samplesPerExperiment - 2)
}

# apply the pValue function to the experimental data
pVector <- mapply(pValue,
       apply(controls, 2, length),
       apply(controls, 2, mean),
       apply(controls, 2, var),
       apply(tests, 2, length),
       apply(tests, 2, mean),
       apply(tests, 2, var))

# plot a histogram
myPlot <- ggplot() +
    geom_histogram(aes(x = pVector,
                   fill = ifelse(pVector <= 0.05, "#56B4E9", "#E69F00")),
                   binwidth = 0.05,
                   color = "white") +
    scale_fill_discrete(name = "Significance",
                        labels = c("p <= 0.05", "p > 0.05")) +
    theme(axis.title.x = element_blank()) +
    theme(axis.title.y = element_blank())

# ...profit!
plot(myPlot)

# print out stuff
print(sum(pVector <= 0.05))
print(sum(pVector > 0.05))
print(summary(pVector))


y=1200
n=2500
pie=y/n
sigma=sqrt((pie*(1-pie))/n)
pie0=0.44
#test statistic
z=(pie-pie0)/sigma
print(z)
# critical value
alpha=0.05
z.alpha=qnorm(1-alpha)
#Because the observed value of z exceeds the critical value 1.645, we conclude that the
#percentage of students that participate in binge drinking exceeds the national percentage of 44%
nbar = n + (z.alpha^2)
pie_bar=(y+z.alpha)/nbar

sigma_bar=sqrt((pie_bar*(1-pie_bar))/nbar)
error_bar=z.alpha*sigma_bar
left=pie_bar-error_bar
right=pie_bar+error_bar
print(left)
print(right)
# the percentage of binge drinkers at the university is, with 95% confidence,between 46% and 50%


# paired.t.r
x <- c(106,107,105,113,107,112,109,112,111,114)
y <- c(100, 92, 91, 82, 87, 96,101, 96, 79, 96)
dd <- x-y
nn <- length(dd) ; md <- mean(dd) ; sdd <- sd(dd)
t0 <- md / ( sdd/sqrt(nn) )
t0
1-pt(t0, nn-1)

lbd <- md - qt(.975, nn-1)* sdd/sqrt(nn)
ubd <- md + qt(.975, nn-1)* sdd/sqrt(nn)
list(lbd, ubd)


# title: "export_interval_model.r"
# author: "SAS Institute"
# date: "July 16, 2020" - Initial version

# Control to print all 13 digits
options(digits = 13)

# Load the necessary libraries
library(jsonlite)
library(zip)

compute_interval_model_metric <- function
(
    target,                   # Vector that contains values of target variable
    predValue                 # Vector that contains predicted values of target variable
)
{
    nobs = length(target)

    # Sum of corrected total (SST)
    mean_target = mean(target)
    sst <- sum((target - mean_target)^2)

    # Sum of Squares Error (SSE)
    sse <- sum((predValue - target)^2)

    # Mean Square Error (MSE)
    mse <- sse / nobs

    # Root Mean Square Error (RMSE)
    rmse <- ifelse(mse > 0.0, sqrt(mse), 0.0)

    # R-Square (RSQUARE)
    rsquare <- cor(target, predValue)
    rsquare <- rsquare * rsquare

    # Mean Absolute Error (MAE)
    mae <- mean(abs(predValue - target))

    output_list = list("MAE" = mae, "MSE" = mse, "NOBS" = nobs, "RMSE" = rmse, "RSQUARE" = rsquare, "SSE" = sse, "SST" = sst)
    return(output_list)

}   # End of function compute_interval_model_metric

export_interval_model <- function
(
    targetVar,                # Name of the target variable
    intervalVars,             # List of names of interval predictors
    nominalVars,              # List of names of nominal predictors
    nominalVarsLength,        # List of lengths of nominal predictors
    typeOfColumn,             # List of types of target variable and predictors
    targetValue,              # Vector that contains values of target variable
    predValue,                # Vector that contains predicted values of target variable
    algorithmCode,            # Code the algorthm used (1 = Logistic regression)
    modelObject,              # R model object
    analysisFolder,           # Full folder path of the analysis folder
    analysisPrefix,           # File name prefix of all the analysis files
    jsonFolder,               # Full folder path of the JSON destination folder
    analysisName,             # A string used as the name of the analysis
    analysisDescription,      # A string used for describing the analysis
    qDebug = 'N'              # Show the debugging output ('Y' or 'N')
)
{
    # Process some arguments
    qDebug = toupper(qDebug)

    # Initialize
    if (algorithmCode == 1) algorithm = 'Logistic regression'
    else if (algorithmCode == 2) algorithm = 'Discriminant'
    else if (algorithmCode == 3) algorithm = 'Decision tree'
    else if (algorithmCode == 4) algorithm = 'Gradient boosting'
    else if (algorithmCode == 5) algorithm = 'Generalized linear model'
    else algorithm = ''

    # Calculate the goodness-of-fit metrics
    output_list <- compute_interval_model_metric(targetValue, predValue)
    m_mae <- output_list$MAE
    m_mse <- output_list$MSE
    nObservation <- output_list$NOBS
    m_rmse <- output_list$RMSE
    m_rsquare <- output_list$RSQUARE
    m_sse <- output_list$SSE
    m_sst <- output_list$SST

    if (qDebug == 'Y')
    {
        # Display the model goodness-of-fit information
        print('=== Model Goodness-of-Fit Metrics ===')
        print(paste('          Mean Absolute Error =', m_mae))
        print(paste('            Mean Square Error =', m_mse))
        print(paste('       Root Mean Square Error =', m_rmse))
        print(paste('                     R-Square =', m_rsquare))
        print(paste('          Sum of Square Error =', m_sse))
        print(paste('Sum of Corrected Square Total =', m_sst))
    }

    # Generate all the necessary files for importing this model into Model Manager

    # 1. RDS file for storing the R model object
    saveRDS(modelObject, file = paste(jsonFolder, analysisPrefix, '_r.rds', sep = ''))

    # 2. The fileMetadata.json file
    fileMetadata <- data.frame(
        'role' = c('inputVariables', 'outputVariables', 'trainResource', 'score', 'scoreResource', 'train'),
        'name' = c('inputVar.json', 'outputVar.json', 'dmcas_fitstat.json',
                 paste(analysisPrefix, '_r_score.r', sep = ''),
                 paste(analysisPrefix, '_r.rds', sep = ''),
                 paste(analysisPrefix, '_train.r', sep = '')))

    # The write_json() function is part of the jsonlite library
    write_json(fileMetadata, path = paste(jsonFolder, 'fileMetadata.json', sep = ''), pretty = TRUE, auto_unbox = TRUE)

    # 3. The ModelProperties.json file
    ModelProperties <- list('name' = analysisName,
                            'description' = analysisDescription,
                            'function' = 'prediction',
                            'scoreCodeType' = 'r',
                            'trainTable' = ' ',
                            'trainCodeType' = 'r',
                            'algorithm' = algorithm,
                            'targetVariable' = targetVar,
                            'targetLevel' = 'INTERVAL',
                            'predictionVariable' = 'EM_PREDICTION',
                            'modeler' = Sys.info()['user'],
                            'tool' = R.version$language,
                            'toolVersion' = R.version.string)

    write_json(ModelProperties, path = paste(jsonFolder, 'ModelProperties.json', sep = ''), pretty = TRUE, auto_unbox = TRUE)

    # 4. The inputVar.json file
    inputVar <- data.frame('name' = character(), 'length' = integer(), 'type' = character(), 'level' = character())

    # Nominal predictors
    for (var in nominalVars)
    {
        typeOfVar <- typeOfColumn[var,]
        if (typeOfVar == 'character') vType = 'string'
        else if (typeOfVar == 'double' | typeOfVar == 'integer') vType = 'decimal'
        else vType = ''
        vList <- data.frame('name' = var, 'length' = nominalVarsLength[var,], 'type' = vType, 'level' = 'nominal')
        inputVar <- rbind(inputVar, vList, stringsAsFactors = FALSE)
    }

    # Interval predictors
    for (var in intervalVars)
    {
        typeOfVar <- typeOfColumn[var,]
        if (typeOfVar == 'double' | typeOfVar == 'integer') vType = 'decimal'
        else vType = ''
        vList <- data.frame('name' = var, 'length' = 8, 'type' = vType, 'level' = 'interval')
        inputVar <- rbind(inputVar, vList, stringsAsFactors = FALSE)
    }
    write_json(inputVar, path = paste(jsonFolder, 'inputVar.json', sep = ''), pretty = TRUE, auto_unbox = TRUE)

    # 5. The outputVar.json file
    outputVar <- data.frame(
        'name' = c('EM_PREDICTION', 'R_FUNC_ELAPSED'),
        'length' = c(8,8),
        'type' = c('decimal','decimal'),
        'level' = c('interval','interval'))

    write_json(outputVar, path = paste(jsonFolder, 'outputVar.json', sep = ''), pretty = TRUE, auto_unbox = TRUE)

    # 6. The dmcas_fitstat.json file
    dict_DataRole <- list('parameter' = '_DataRole_', 'type' = 'char', 'label' = 'Data Role',
                          'length'= 10, 'order' = 1, 'values' = array(c('_DataRole_'), dim=(1)), 'preformatted' = FALSE)

    dict_PartInd <- list('parameter' = '_PartInd_', 'type' = 'num', 'label' = 'Partition Indicator',
                         'length' = 8, 'order' = 2, 'values' = array(c('_PartInd_'), dim=(1)), 'preformatted' = FALSE)

    dict_PartInd__f <- list('parameter' = '_PartInd__f', 'type' = 'char', 'label' = 'Formatted Partition',
                            'length' = 12, 'order' = 3, 'values' = array(c('_PartInd__f'), dim=(1)), 'preformatted' = FALSE)

    dict_NObs <- list('parameter' = '_NObs_', 'type' = 'num', 'label' = 'Sum of Frequencies',
                      'length' = 8, 'order' = 4, 'values' = array(c('_NObs_'), dim=(1)), 'preformatted' = FALSE)

    dict_ASE <- list('parameter'= '_ASE_', 'type'= 'num', 'label'= 'Average Squared Error',
                     'length'= 8, 'order'= 5, 'values'= array(c('_ASE_'), dim=(1)), 'preformatted' = FALSE)

    dict_DIV <- list('parameter'= '_DIV_', 'type'= 'num', 'label'= 'Divisor for ASE',
                     'length'= 8, 'order'= 6, 'values'= array(c('_DIV_'), dim=(1)), 'preformatted' = FALSE)

    dict_RASE <- list('parameter'= '_RASE_', 'type'= 'num', 'label'= 'Root Average Squared Error',
                      'length'= 8, 'order'= 7, 'values'= array(c('_RASE_'), dim=(1)), 'preformatted' = FALSE)

    parameterMap <- list('_DataRole_'= dict_DataRole, '_PartInd_'= dict_PartInd, '_PartInd__f'=  dict_PartInd__f,
                         '_NObs_' = dict_NObs, '_ASE_' = dict_ASE, '_DIV_' = dict_DIV, '_RASE_' = dict_RASE)

    fitStats <- list('_DataRole_' = unbox('TRAIN'),
                     '_PartInd_' = unbox(1),
                     '_PartInd__f' = unbox('           1'),
                     '_DIV_' = unbox(nObservation),
                     '_MAE_' = unbox(m_mae),
                     '_MSE_' = unbox(m_mse),
                     '_NObs_' = unbox(nObservation),
                     '_RMSE_' = unbox(m_rmse),
                     '_RSQUARE_' = unbox(m_rsquare),
                     '_SSE_' = unbox(m_sse),
                     '_SST_' = unbox(m_sst))

    dmcas_fitstat <- list('name' = 'dmcas_fitstat',
                          'revision' = 0,
                          'order' = 0,
                          'parameterMap' = parameterMap,
                          'data' =  array(list(list('dataMap' = fitStats, 'rowNumber' = unbox(1))), dim = c(1)),
                          'version' = 1,
                          'xInteger' = FALSE,
                          'yInteger' = FALSE)

    write_json(dmcas_fitstat, path = paste(jsonFolder, 'dmcas_fitstat.json', sep = ''), pretty = TRUE, auto_unbox = TRUE, digits = 13)

    # Put all the files in the jsonFolder to the ZIP package
    files2zip <- array(c(paste(jsonFolder, 'fileMetadata.json', sep = ''),
                         paste(jsonFolder, 'ModelProperties.json', sep = ''),
                         paste(jsonFolder, 'inputVar.json', sep = ''),
                         paste(jsonFolder, 'outputVar.json', sep = ''),
                         paste(jsonFolder, 'dmcas_fitstat.json', sep = ''),
                         paste(jsonFolder, analysisPrefix, '_train.r', sep = ''),
                         paste(jsonFolder, analysisPrefix, '_r_score.r', sep = ''),
                         paste(jsonFolder, analysisPrefix, '_r.rds', sep = '')), dim = c(8))

    zipr(zipfile = paste(jsonFolder, analysisPrefix, '_r.zip', sep = ''), files = files2zip, recurse = FALSE, include_directories = FALSE)

}   # end of function export_binary_modell


=begin
  # sample-jordan-form01.rb

  require "algebra"

  M4 = SquareMatrix(Rational, 4)
  m = M4[
      [-1, 1, 2, -1],
      [-5, 3, 4, -2],
      [3, -1, 0, 1],
      [5, -2, -2, 3]
  ]
  m.jordan_form.display; #=>
  #  2,   0,   0,   0
  #  0,   1,   1,   0
  #  0,   0,   1,   1
  #  0,   0,   0,   1
  puts

  #-----------------------------------
  m = M4[
    [3, 1, -1, 1],
    [-3, -1, 3, -1],
    [-2, -2, 0, 0],
    [0, 0, -4, 2]
  ]
  jf, pt, qt, field, modulus  = m.jordan_form_info
  p modulus #=> [a^2 + 4]
  jf.display; puts #=>
  #  2,   1,   0,   0
  #  0,   2,   0,   0
  #  0,   0,   a,   0
  #  0,   0,   0,  -a

  m = m.convert_to(jf.class)
  p jf == pt * m * qt #=> true

  #-----------------------------------
  m = M4[
      [-1, 1, 2, -1],
      [-5, 3, 4, -2],
      [3, -1, 0, 1],
      [5, -2, -2, 0]
  ]
  jf, pt, qt, field, modulus  = m.jordan_form_info
  p modulus #=> [a^3 + 3a - 1, b^2 + ab + a^2 + 3]
  jf.display; puts #=>
  #  2,   0,   0,   0
  #  0,   a,   0,   0
  #  0,   0,   b,   0
  #  0,   0,   0, -b - a

  m = m.convert_to(jf.class)
  p jf == pt * m * qt #=> true
((<_|CONTENTS>))
=end


# title: "IODS Final Assignment: Boston Dataset"
# author: "Tuure Parviainen"
# date: "December 5, 2017"

# As there is not that much manipulation to be done, for such used test dataset as Boston, I'll look into normality of assumptions in the data as often at least prices are log-normal, so perhaps some transformations are in order. I'll use shapiro test and fitdistrplus package to analyse the distribution of the each variable.

# Loading packages

require("easypackages") # for loading and installing many packages at one time
packages_to_load <- c("dplyr", "tidyverse", "ggplot2", "fitdistrplus", "MASS", "reshape2")
packages(packages_to_load, prompt = TRUE) # lock'n'load install/load

setwd(dirname(rstudioapi::getActiveDocumentContext()$path)) # to set

data(Boston)

# Histogram of all variables
ggplot(data = melt(Boston), mapping = aes(x = value)) +
  geom_histogram(bins = 10) + facet_wrap(~variable, scales = 'free_x')

# Are these really normal?

shapiro.test(Boston[,1])

sha.test <- do.call(rbind, lapply(Boston, function(x) shapiro.test(x)[c("statistic", "p.value")]))

# Wiki: The null-hypothesis of this test is that the population is normally distributed. Thus, if the p-value is less than the chosen alpha level, then the null hypothesis is rejected and there is evidence that the data tested are not from a normally distributed population; in other words, the data are not normal. On the contrary, if the p-value is greater than the chosen alpha level, then the null hypothesis that the data came from a normally distributed population cannot be rejected (e.g., for an alpha level of 0.05, a data set with a p-value of 0.02 rejects the null hypothesis that the data are from a normally distributed population).

sha.test[,2] >= 0.05

# All false. We have non-normal data. However, Shapiro test does not do well when sample size is large. So we make QQ-plots.

# x11()
# QQ-plots
ggplot(data = melt(Boston), mapping = aes(sample = value)) +
  stat_qq() + facet_wrap(~variable, scales = 'free')

# I sense trouble with normality assumption required for regression.

# We will look at the different distributions fit to look for possible solution for skewdness.
fitW <- fitdist(Boston[,1], "weibull")
fitg <- fitdist(Boston[,1], "gamma")
fitln <- fitdist(Boston[,1], "lnorm")
fitn <- fitdist(Boston[,1], "norm")

cdfcomp(list(fitW, fitg, fitln, fitn), legendtext=c("Weibull", "gamma", "lognormal", "normal"))
denscomp(list(fitW, fitg, fitln, fitn), legendtext=c("Weibull", "gamma", "lognormal", "normal"))
qqcomp(list(fitW, fitg, fitln, fitn), legendtext=c("Weibull", "gamma", "lognormal", "normal"))
ppcomp(list(fitW, fitg, fitln, fitn), legendtext=c("Weibull", "gamma", "lognormal", "normal"))
gofstat(list(fitW, fitg, fitln, fitn), fitnames=c("Weibull", "gamma", "lognormal", "normal"))

descdist(Boston[,1], boot = 100)

# Normal distribution was the least likely for crim by AIC.

# We will compare two different transformations for data. Log and square root transformation.
BostonSq <- sqrt(Boston) %>% scale() %>% as.data.frame() %>%  melt()
BostonSq$group <- "Squared"
BostonL <- log(Boston) %>% scale() %>% as.data.frame() %>%  melt()
BostonL$group <- "Log"
BostonN <- Boston %>% scale() %>% as.data.frame() %>%  melt()
BostonN$group <- "Normal"

BostonGraph <- rbind(BostonSq, BostonL, BostonN)
BostonGraph <-BostonGraph[complete.cases(BostonGraph),]

# Here we plot all the distributions to a QQ plots
ggplot(data = BostonGraph, mapping = aes(sample = value)) +
  stat_qq(aes(color=group)) + facet_wrap(~variable, scales = 'free')
# Here we plot are histograms so we can evaluate the impact to the variables
ggplot(data = BostonGraph, mapping = aes(x = value)) +
  geom_histogram(aes(fill=group),bins = 15) + facet_wrap(~variable, scales = 'free')

# Here we see the impact of the scaled and transformed crim variable
ggplot(data = subset(BostonGraph,variable == "crim"), mapping = aes(x = value)) +
  geom_histogram(bins = 15, aes(fill=group)) + facet_wrap(~group)

# We also look at the median value (medv)
ggplot(data = subset(BostonGraph,variable == "medv"), mapping = aes(x = value)) +
  geom_histogram(bins = 15, aes(fill=group)) + facet_wrap(~group)

# No need for transformation (medv)

# Given that the data has consists already of indexes and ratios any further transformation is not probably necessary.
# However, for the assignment.

# We will have three datasets:
# Empty enviroment.
rm(list = ls())
# 1) Normal unchanged dataset
data(Boston)
head(Boston)
BostonN <- Boston # For some reason didn't manage to read directly
# 2) Scaled dataset
BostonS <- scale(BostonN) %>% as.data.frame()
# 3) Scaled dataset with the crim transformed with the square transformation (log can't deal with zeros).
BostonSSq <- Boston
BostonSSq$crim <-  sqrt(Boston$crim)
BostonSSq <- BostonSSq %>% scale() %>% as.data.frame()
# General note: It seems that some of the data has been censored for the high tax category

# Writing the files to Data folder
write.table(Boston, file = "data/boston.txt")
write.table(BostonS, file = "data/bostons.txt")
write.table(BostonSSq, file = "data/bostonssq.txt")


# @' export
t_ratio <- function(coef, std_err){
    coef/std_err
}

# @' export
f_stat <- function(coef, std_err){
    t_ratio(coef, std_err)^2
}

critical_values <- function(distribution, ...){
    quantile_func <- get(paste0("q", distribution))

    quantile90 <- quantile_func(p=0.9, ...)
    quantile95 <- quantile_func(p=0.95, ...)
    quantile99 <- quantile_func(p=0.99, ...)

    ci_lower_bound90 <- quantile_func(p=0.5*0.1, ...)
    ci_lower_bound95 <- quantile_func(p=0.5*0.05, ...)
    ci_lower_bound99 <- quantile_func(p=0.5*0.01, ...)

    ci_upper_bound90 <- quantile_func(p=1-0.5*0.1, ...)
    ci_upper_bound95 <- quantile_func(p=1-0.5*0.05, ...)
    ci_upper_bound99 <- quantile_func(p=1-0.5*0.01, ...)

    output <- data.frame(
        critical_values = c(quantile90, quantile95, quantile99),
        ci_lower_bound = c(ci_lower_bound90, ci_lower_bound95, ci_lower_bound99),
        ci_upper_bound = c(ci_upper_bound90, ci_upper_bound95, ci_upper_bound99),
        row.names = c("0.9", "0.95", "0.99")
    )

    return(output)
}

significant_level <- function(f_stat, df){
    crit_values <- critical_values(distribution="f", df1=1, df2=df)

    result <- sapply(f_stat, function(f){
        if      (f > crit_values["0.99", "critical_values"])   '***'
        else if (f > crit_values["0.95", "critical_values"])   '**'
        else if (f > crit_values["0.9", "critical_values"])    '*'
        else                                  ' '
    })
}


mean.square.error <- function(theta.hat,theta) {
#Purpose:
#  Calculates mean squared errors for a matrix of estimates
#   where the rows are the replicates and the columns are different
#   estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator

#count number of replicates for each estimator
  n <- dim(theta.hat)[1]
#count number of estimators
  num.ests <- dim(theta.hat)[2]
#create vector for results
  MSE.vec <- numeric(num.ests)

#Work out the sum of squared errors for each estimator:
#Go through each replicate
  for(i in 1:n) {
#go through each estimator
    for(j in 1:num.ests)
#Add the squared error for this replicate to the running total in MSE.vec
      MSE.vec[j] <- MSE.vec[j]+(theta.hat[i,j]-theta)^2
  }
#Turn from a sum of squared errors into mean square error by dividing by n
  MSE.vec <- MSE.vec/n

  return(MSE.vec)
}


### ANOVA

library(ggplot2)

# formulae

DV ~ IV # One-way

DV ~ IV1 + IV2 # Two-way

DV ~ IV1:IV2  # Two-way interaction

DV ~ IV1 + IV2 + IV1:IV2 # Main effects + interaction

DV ~ IV1 * IV2  # The same: Main effects + interaction

DV ~ IV1 + IV2 + IV3 + IV1:IV2

DV ~ (IV1 + IV2 + IV3)^2 # main effects and all possible interactions up to level 2

DV ~ IV1 + Error(subject/IV1) # repeated measures

# reading data

mydata <- read.csv('shops.csv')

# One-way ANOVA

boxplot(price ~ origin, data=mydata)

ggplot(mydata, aes(x = origin, y = price)) +
  geom_boxplot()

fit <- aov(price ~ origin, data=mydata)
summary(fit)

# Two-way ANOVA

fit1 <- aov(price ~ origin + store, data=mydata)
summary(fit1)

model.tables(fit1,"means")

# Interaction

pd = position_dodge(0.1)
ggplot(mydata, aes(x = store, y = price, color = origin, group = origin)) +
  stat_summary(fun.data = mean_cl_boot, geom = 'errorbar', width = 0.2, lwd = 0.8, position = pd)+
  stat_summary(fun.data = mean_cl_boot, geom = 'line', size = 1.5, position = pd) +
  stat_summary(fun.data = mean_cl_boot, geom = 'point', size = 5, position = pd, pch=15) +
  theme_bw()

fit3 <- aov(price ~ origin + store + origin:store, data=mydata)
summary(fit3)

fit4 <- aov(price ~ origin * store, data=mydata)
summary(fit4)

# Pairwise comparisons

ggplot(mydata, aes(x = food, y = price)) +
  geom_boxplot()

fit5 <- aov(price ~ food, data=mydata)
summary(fit5)

TukeyHSD(fit5)

# Repeated measures

mydata2 <- read.csv('therapy_data.csv')
str(mydata2)

mydata2$subject <- as.factor(mydata2$subject)

fit1 <- aov(well_being ~ therapy, data = mydata2)
summary(fit1)
fit1b <- aov(well_being ~ therapy + Error(subject/therapy), data = mydata2)
summary(fit1b)

fit2 <- aov(well_being ~ therapy*price, data = mydata2)
summary(fit2)

ggplot(mydata2, aes(x = price, y = well_being)) +
  geom_boxplot()

fit2b <- aov(well_being ~ therapy*price + Error(subject/(therapy*price)), data = mydata2)
summary(fit2b)

ggplot(mydata2, aes(x = price, y = well_being)) +
  geom_boxplot() +
  facet_grid(~subject)

fit3 <- aov(well_being ~ therapy*price*sex, data = mydata2)
summary(fit3)
fit3b <- aov(well_being ~ therapy*price*sex + Error(subject/(therapy*price)), data = mydata2)
summary(fit3b)


library(glue)
library(gtools)
printf <- defmacro(str, expr = {print(glue(str))})

# import data, rm not needed data, split data
data = read.csv("parkinsons.csv")
data = as.data.frame(scale(data)) # scale data
data = data[,-match(c("subject.", "age", "sex",
                      "test_time", "total_UPDRS"), names(data))]
n = dim(data)[1]
set.seed(12345)
id = sample(1:n, floor(n*0.6))
train = data[id,]
test = data[-id,]

fit = lm(motor_UPDRS~., train) # create model
fitted = predict(fit, test)

print(summary(fit))
printf("train MSE = {mean((fit$residual)^2)}") # mean square error
printf("test MSE = {mean((fitted - test$motor_UPDRS)^2)}")
N = dim(data)[2]

loglikelihood <- function(theta, sigma, x, y) {
  n = dim(x)[1]
  thetaTx = apply(x, 1, function(xi) (xi %*% theta))
  return(-((n/2)*log(2*pi*sigma^2)) - ((1/(2*sigma^2))*sum((thetaTx - y)^2)))
}

ridge <- function(theta, sigma, lambda, x, y) {
  return(-loglikelihood(theta, sigma, x, y) + (lambda*sum(theta^2)))
}

ridgeHelper <- function(param, lambda, x, y) {
  theta = matrix(param[-N], nrow=N-1, ncol=1)
  sigma = param[N]
  return(ridge(theta, sigma, lambda, x, y))
}

ridgeOpt <- function(lambda, x, y) {
  return(optim(par=rep(1,N), fn=ridgeHelper, method="BFGS", lambda=lambda, x=x, y=y)$par)
}

df <- function(lambda, x_) {
  x = as.matrix(x_)
  hat = x %*% (solve((t(x) %*% x) + lambda*diag(dim(x)[2])) %*% t(x))
  return(sum(diag(hat)))
}

ridgeOptRun <- function(lambda, train, test)  {
  xtrain = train[,names(train) != "motor_UPDRS"]
  xtest = test[,names(test) != "motor_UPDRS"]
  ytrain = train$motor_UPDRS
  ytest = test$motor_UPDRS

  param = ridgeOpt(lambda, xtrain, ytrain)
  theta = matrix(param[-N], nrow=N-1, ncol=1)
  sigma = param[N]
  printf("\n\n Ridge regression: lambda = {lambda}")
  printf("degrees of freedom => {df(lambda, xtrain)}")
  thetaTx = apply(xtrain, 1, function(xi) (xi %*% theta))
  printf("train MSE => {mean((thetaTx - ytrain)^2)}")
  thetaTx = apply(xtest, 1, function(xi) (xi %*% theta))
  printf("test MSE => {mean((thetaTx - ytest)^2)}")
}

ridgeOptRun(1, train, test)
ridgeOptRun(100, train, test)
ridgeOptRun(1000, train, test)


#Example simultion code
#Author: Len Thomas
#Last updated: 25th October 2013

#Functions to run a simulation to look at the MSE arising from
# using trimmed means to estimate the mean of a mixture distribution
# See ExampleSimulation.pdf for details
#Some code to drive the simulation is provided in ExampleSimulationDriver.r

#Note that there are two versions of the functions mix.dist and RMSE
#Have a look at them, and try to decide which is better!...

do.sim <- function(mix.par=0.2,mu1=5,sigma1=4,mu2=5,df=4,n=30,
                   alpha.vec=c(0,0.1,0.2), M=1000) {
#Purpose:
# Runs a simulation to compute the RMSEs for trimmed means from
#  samples taken from a 2 point normal and t mixture model
#Inputs:
# mix.par - mixture parameter of the distribution (range 0-1)
# mu1 - mean of the normal component of the mixture
# sigma1 - sd of the normal component of the mixture
# mu2 - mean of the t component of the mixture
# df - degrees of freedom for the t component
# n - size of samples to generate in simulation
# alpha.vec - vector of trimming levels to try (0=no trim i.e. mean,
#   0.5=trim 50th quantile above and below - i.e., median)
# M - number of simultions to run
#Output: List containing elements:
# MSE - vector of the MSEs at each trim level
# ests - matrix with M rows and length(alpha.vec) columns containing the raw estimates
# mu - the true mean of the input distribution

  #initialize matrix of outputs
  est.matrix <- matrix(NA,M,length(alpha.vec))
  #run simulation
  for(simulation in 1:M) {
    temp <- mix.dist(n,mix.par,mu1,sigma1,mu2,df)
    est.matrix[simulation,] <- estimate(temp,alpha.vec)
  }

  #work out the expected value of the input distribution
  E.Z<-get.E.Z(mix.par,mu1,mu2)

  #Calculate MSEs
  mean.square.error <- MSE(est.matrix,E.Z)

  return(list(MSE=mean.square.error, ests=est.matrix, mu=E.Z))

}

get.E.Z <- function(mix.par, mu1, mu2){
#Purpose: Returns the expected value of a mixture with mix proportion
# mix.par, and means mu1 and mu2
  return(mix.par*mu1+(1-mix.par)*mu2)
}

mix.dist <- function(n,mix.par,mu1,sigma1,mu2,df) {
#Purpose: Returns n samples from the mixture distribution
#Inputs:
# n - number of samples to return
# mix.par - pi in the practical notes -- proportion of samples from norm dist
# mu1 - mean of norm dist
# sigma1 - sd of norm dist
# mu2 - mean of t dist
# df - df for t dist
#Outputs:
# vector of n values from the mixture distribution
#Implementation note:
# This version uses vectorization - but wastefully samples from
# both the normal and t for each observation.  See below for another
# way to do this. Which is quicker, I wonder?

  #sample n values from a Bernoulli dist, to see which distribution
  # each data point comes from
  nu <- rbinom(n,1,mix.par)

  #sample values from the normal
  X <- rnorm(n,mu1,sigma1)
  #sample values from the t
  Y <- mu2 + rt(n,df)

  #put them together
  Z <- nu*X + (1-nu)*Y
  return(Z)
}

mix.dist.alt <- function(n,mix.par,mu1,sigma1,mu2,df) {
#Purpose: Alternative implementation of routine to sample n values
#  from the mixture distribution
#Inputs:
# n - number of samples to return
# mix.par - pi in the practical notes -- proportion of samples from norm dist
# mu1 - mean of norm dist
# sigma1 - sd of norm dist
# mu2 - mean of t dist
# df - df for t dist
#Outputs:
# vector of n values from the mixture distribution

  #create results vector
  Z<-numeric(n)

  #go through each observation...
  for(i in 1:n){
    #...determine if it comes from the normal or t distribution
    if(rbinom(1,1,mix.par)==1) {
      #normal distribution
      Z[i]<-rnorm(1,mu1,sigma1)
    } else {
      #t distribution
      Z[i]<-mu2+rt(1,df)
    }
  }

  return(Z)
}

estimate <- function(x,trim) {
#Purpose: Estimates trimmed means on data x, using a vector of trimming
# levels trim
#Inputs:
# x - data
# trim - vector of trimming levels
#Outputs:
# vector of trimmed means

  #create vector for results
  n.trimmed.means<-length(trim)
  trimmed.means<-numeric(n.trimmed.means)

  #loop through, calculating trimmed means
  for(i in 1:n.trimmed.means)
    trimmed.means[i] <- mean(x,trim[i])

  return(trimmed.means)
}

MSE <- function(theta.hat,theta) {
#Purpose: Calculates mean squared errors for a matrix of estimates
# where the rows are the replicates and the columns are different
# estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator
#Implementation note:
# This version uses a double loop.  See below for a more vectorized
#  version of this function.  Which is quicker?

  #count numeber of replicates for each estimator
  n <- dim(theta.hat)[1]
  #count number of estimators
  num.ests <- dim(theta.hat)[2]
  #create vector for results
  MSE.vec <- numeric(num.ests)

  #Work out the sum of squared errors for each estimator:
  #Go through each replicate
  for(i in 1:n) {
    #go through each estimator
    for(j in 1:num.ests)
      #Add the sqared error for this replicate of the estimator to
      # the running total in MSE.vec
      MSE.vec[j] <- MSE.vec[j]+(theta.hat[i,j]-theta)^2
  }
  #Turn from a sum of squared errors into mean square error by dividing
  # by n
  MSE.vec <- MSE.vec/n

  return(MSE.vec)
}

MSE.alt <- function(theta.hat,theta) {
#Purpose: Alternative vectorized implementation of function to
# calculate mean squared errors for a matrix of estimates
# where the rows are the replicates and the columns are different
# estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator

  #Declare function to calculate MSE of a vector
  MSE.vec <- function(theta.hat.vec, theta) {
  #Purpose: calculates MSE of a vector
  #Inputs:
  # theta.hat.vec - vector of estimates
  # theta - true value
  #Output: MSE
     square.error<-(theta.hat.vec-theta)^2
     MSE<-mean(square.error)
     return(MSE)
  }

  #Apply this function to each column of theta.hat
  MSE<-apply(theta.hat,2,MSE.vec,theta)

  return(MSE)
}


## 7.1
bl <- baeskel
y <- bl$Tension
x <- bl$Sulfur
plot(x, y)
abline(lm(y ~ x, data=bl))
lam <- c(-1, 0, 1)
new <- with(bl, seq(min(x), max(x), length=12))
with(bl, plot(x, y))
with(bl,
     for (j in 1:3){
         m1 <- lm(y ~ bcPower(x, lam[j]))
         lines(new, predict(m1, data.frame(x=new)), lty=j, col=j, lwd=2)
     }
)
legend("topleft", inset=0.02, legend=as.character(lam), lty=1:3, col=1:3, xjust=1, yjust=1)

## 7.2.1
stopping
plot(Distance ~ Speed, stopping)
m1 <- lm(Distance ~ Speed, data=stopping)
abline(m1)
m2 <- lm(Distance ~ Speed + I(Speed^2), data=stopping)
lines(stopping$Speed[order(stopping$Speed)], predict(m2)[order(stopping$Speed)], col="red", lty="dashed" )
pureErrorAnova(m1)
anova(m2)

## 7.2.2
invResPlot(m1)

## 7.8
UN3
mc <- UN3$ModernC
cg <- UN3$Change
pp <- UN3$PPgdp
fr <- UN3$Frate
pop <- UN3$Pop
ft <- UN3$Fertility
pb <- UN3$Purban
scatterplotMatrix(UN3[, c(1:7)], smooth=FALSE)
summary(bc <- powerTransform(cbind(pp, fr, pop, ft, pb) ~ 1, data=UN3))
logpp <- log(pp)
logpop <- log(pop)
logft <- log(ft)
newUN <- cbind(mc, logpp, fr, logpop, logft, pb)
scatterplotMatrix(newUN[, c(1:6)], smooth=FALSE)

## 7.8.2
newUN <- data.frame(newUN)
m1 <- lm(ModernC ~ logb(PPgdp,2) + Frate + logb(Pop, 2) + logb(Fertility,2) + Purban, data=UN3)
invResPlot(m1)
boxCox(m1, xlab=expression(lambda[y]))

## 8.3
head(pipeline)
scatterplot(Lab ~ Field | Batch, data=pipeline, smoother=FALSE, reg.line=FALSE, legend.plot=FALSE)
abline(lm(Lab ~ Field, pipeline))
abline(0,1, lty="dashed")

## 8.3.2
m1 <- lm(Lab ~ Field, pipeline)
ncvTest(m1)
e <- m1$residuals
#Field <- pipeline$Field
#Batch <- pipeline$Batch
#pipeline2 <- cbind(residule, Field, Batch)
plot(pipeline$Field, e)
abline(h=0, lty="dashed")

## residualPlots(m1, quadratic=FALSE)

## 8.4
stopping
m1 <- lm(Distance ~ Speed + I(Speed^2), data=stopping)
ncvTest(m1)
ncvTest(m1, ~Speed)
ncvTest(m1, ~Speed + I(Speed^2))

## 8.10
logBSAAM <- log(water$BSAAM)
logAPMAM <- log(water$APMAM)
logAPSAB <- log(water$APSAB)
logAPSLAKE <- log(water$APSLAKE)
logOPBPC <- log(water$OPBPC)
logOPRC <- log(water$OPRC)
logOPSLAKE <- log(water$OPSLAKE)
new <- data.frame(cbind(logBSAAM, logAPMAM, logAPSAB, logAPSLAKE, logOPBPC, logOPRC, logOPSLAKE))
m1 <- lm(logBSAAM ~ logAPMAM + logAPSAB + logAPSLAKE + logOPBPC + logOPRC + logOPSLAKE, data=new)
e <- m1$residuals
par(mfrow=c(1,1))
plot(e ~ m1$fitted.values); abline(h=0, lty="dashed")
par(mfrow=c(2,3))
for ( i in 1:6){
    plot(e ~ new[, i], data=new)
    abline(h=0, lty="dashed")
}
mmps(m1, layout=c(2,2))


#Q2. The sum of the squares of the first ten natural numbers is,
#12+22+...+102=385
#The square of the sum of the first ten natural numbers is,
#(1+2+...+10)2=552=3025
#Hence the difference between the sum of the squares of the first ten natural numbers and the square of the sum is
#3025−385=2640
#.Find the difference between the sum of the squares of the first one hundred natural numbers and the square of the sum.

sum=0;
sq=0;
res = 0;
n = 10;

sum = n*(n+1)/2;
sq=(n*(n+1)*(2*n+1))/6;
res=sum*sum-sq;
print(res)


.ols <- function(X, y){
    solve(t(X) %*% X, t(X) %*% y)
}

#' @export
ols <- function(formula, data, robust=FALSE){
    X <- model.matrix(formula, data)
    y <- model.frame(formula, data)[, 1]
    n <- dim(X)[1]
    k <- dim(X)[2]

    coef <- .ols(X, y)
    std_err <- standard_error(X, y, robust)
    residual <- y - X %*% coef

    t_ratio <- coef / std_err[["value"]]
    f_stat <- t_ratio^2
    stat_signif <- significant_level(f_stat, df=n-k)

    overall_significance <- overall_significance_f_test(X, y)
    resid_normality <- jarque_bera_test(residual)

    info <- list(
        "Dep. Variable: " = toString(formula[2]),
        "R-squared: " = format(r_squared(X, y), digits = 3),
        "Adj. R-squared: " = format(adjusted_r_squared(X, y), digits = 3),
        "R-tilde-squared: " = format(r.tilde_squared(X, y), digits = 3),
        "Covariance Type: " = std_err[["cov_type"]]
    )

    return(OLSResult(info, coef, std_err[["value"]], t_ratio, stat_signif, overall_significance, resid_normality))
}


setwd("C:/Users/Nina/Desktop/machinelearning_estatistica_R/dataset")
library(readxl)

# Problema: Quero prever quanto será o salário com base  no passar dos anos

# Sep é um separador de coluna e o dec = separador de casas decimais.
dados <- read.table("salary.csv", header = TRUE,
                   sep = ",", dec = ".") #Função que lê o arquivo csv e salva em uma base de dados R

# Verifica os nomes das variaveis
names(dados)

# Verifica a correlação linear entre duas variáveis quantitativas
cor(dados$years, dados$salary)

# O output é +0.97. Portanto é uma correlação linear forte e positiva, ou seja, com o passar dos anos aumenta o meu salário

# Realizando o modelo de Regressão Linear

# Obtenha o modelo de regressão linear simples. Com 90% de confiança, há relação linear entre as variáveis?
regressao <- lm(data=dados,
                salary ~ years)
options(scipen=999)
summary(regressao)

# De acordo co o output temos BO = 25792.2, significa que quando você tem 0 anos , ou seja, nem nasceu, você já tem um salário assim.
# Podemos notar que a base de dados não é verossímel a realidade.

regressao$coefficients[1] + regressao$coefficients[2] * 1

# Calcula os valores preditos da varíavel resposta para cada elemento da amostra
regressao$fitted.values #: calcula os valores preditos da variável resposta(Y) para cada elemento da amostra (faz uma previsão);

# calcula o erro ou os resíduos (valor observado - valor predito) para cada ponto da amostra
regressao$residuals

# obtém uma estimativa dos coeficientes da regressão.
regressao$coefficients

#  Gerar o gráfico de dispersão - variáveis quantitativas

plot (salary ~ years,pch = 4, data = dados)

# Esta função ajusta a reta do modelo aos dados
abline(regressao,col="red")

# Aqui a gente consegue ver um raio quadrado bem grande, ou seja, a interpretação disso 95% da variabilidade explicada da variável y pela x.
summary(regressao)

setwd("C:/Users/Nina/Desktop/machinelearning_estatistica_R/dataset")
library(readxl)

# Problema: Quero prever quanto será o salário com base  no passar dos anos

# Sep é um separador de coluna e o dec = separador de casas decimais.
dados <- read.table("salary.csv", header = TRUE,
                   sep = ",", dec = ".") #Função que lê o arquivo csv e salva em uma base de dados R

# Verifica os nomes das variaveis
names(dados)

# Verifica a correlação linear entre duas variáveis quantitativas
cor(dados$years, dados$salary)

# O output é +0.97. Portanto é uma correlação linear forte e positiva, ou seja, com o passar dos anos aumenta o meu salário

# Realizando o modelo de Regressão Linear

# Obtenha o modelo de regressão linear simples. Com 90% de confiança, há relação linear entre as variáveis?
regressao <- lm(data=dados,
                salary ~ years)
options(scipen=999)
summary(regressao)

# De acordo co o output temos BO = 25792.2, significa que quando você tem 0 anos , ou seja, nem nasceu, você já tem um salário assim.
# Podemos notar que a base de dados não é verossímel a realidade.

regressao$coefficients[1] + regressao$coefficients[2] * 1

# Calcula os valores preditos da varíavel resposta para cada elemento da amostra
regressao$fitted.values #: calcula os valores preditos da variável resposta(Y) para cada elemento da amostra (faz uma previsão);

# calcula o erro ou os resíduos (valor observado - valor predito) para cada ponto da amostra
regressao$residuals

# obtém uma estimativa dos coeficientes da regressão.
regressao$coefficients

#  Gerar o gráfico de dispersão - variáveis quantitativas

plot (salary ~ years,pch = 4, data = dados)

# Esta função ajusta a reta do modelo aos dados
abline(regressao,col="red")

# Aqui a gente consegue ver um raio quadrado bem grande, ou seja, a interpretação disso 95% da variabilidade explicada da variável y pela x.
summary(regressao)


###############
## Section 2 ##
###############

library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

ITN.data <- read.csv("ITN_data.csv", header=TRUE)

###############
## Table 2.1 ##
###############

## Logit model

ITN.logit <- glm(useditn ~  malariamessage+education+richest+poorest+pregnant+altitude, family=binomial(link="logit"), data=ITN.data, x=TRUE)
ITN.logit.results <- cbind(ITN.logit$coefficients, sqrt(diag(vcov(ITN.logit))), confint.default(ITN.logit, level=0.95))
N <- length(ITN.logit$fitted.values)
colnames(ITN.logit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(ITN.logit.results, digits=3)))
print(N)

###############
## Table 2.2 ##
###############

## Simulated Coefficients

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

mean.x <- colMeans(ITN.logit$x)
simprobs <- plogis(betadraw%*%mean.x)

simcoef.results <- append(quantile(simprobs, probs=c(0.5, 0.025, 0.975)), sd(simprobs))

## Bootstrapping

nsamples <- 1000
betas.boot <- matrix(NA,nsamples,length(beta))

for (i in 1:1000) {

	ITN.data.boot <- ITN.data[sample(seq(1,nrow(ITN.data),1), replace=TRUE),]
	logit.boot <- glm(useditn ~  malariamessage+education+richest+poorest+pregnant+altitude, family=binomial(link="logit"), data=ITN.data.boot)
	betas.boot[i,] <- logit.boot$coefficients
}

probs.boot <- plogis(betas.boot%*%mean.x)

boot.results <- append(quantile(probs.boot, probs=c(0.5, 0.025, 0.975)), sd(probs.boot))

## Delta Method

xb <- mean.x %*% beta
predicted.prob <- plogis(xb)

deltamethod.var <- (dlogis(xb)^2) * (t(mean.x) %*% covmat.beta %*% mean.x)
deltamethod.se <- sqrt(deltamethod.var)

delta.95ci.u <- predicted.prob + 1.96*deltamethod.se
delta.95ci.l <- predicted.prob - 1.96*deltamethod.se

delta.results <- cbind(predicted.prob, delta.95ci.l, delta.95ci.u, deltamethod.se)

## Summarize Results

statistical.uncertainty <- rbind(simcoef.results, boot.results, delta.results)
colnames(statistical.uncertainty) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(statistical.uncertainty) <- c("Simulated Coefficients", "Bootstrap", "Delta Method")

print(round(statistical.uncertainty, digits=3))


## Author: Sergio García Prado
## Title: Statistical Inference - Non parametric Tests - Exercise 08

rm(list = ls())

x1 <- c(1, 3, 3)  # c('A', 'C', 'C')
x2 <- c(2, 2, 3)  # c('B', 'B', 'C')

(s <- (x2 - x1)[x2 != x1])
# 1 -1

(n <- length(s))
# 2

(V <- sum((s > 0) * rank(abs(s))))
# 1.5

(V.mean <- n * (n + 1) / 4)
# 1.5

(V.var <- n * (n + 1) * (2 * n + 1) / 24)
# 1.25

## Asymptotic pvalue (with continuity correction, without tie correction)
1 - pnorm(V - 0.5, mean = V.mean, sd = sqrt(V.var))
# 0.672639576990711

## Asymptotic pvalue (with continuity correction, with tie correction)
(ties <- table(abs(s)))
# 1
# 2

(V.var.corrected <- V.var - sum(ties ^ 3 - ties) / 48)
# 1.125

1 - pnorm(V - 0.5, mean = V.mean, sd = sqrt(V.var.corrected))
#0.681324055883031

## Exact pvalue (not valid with ties)
1 - psignrank(V - 1, n)
# 0.5

wilcox.test(x1,  x2, paired = TRUE, alternative = "greater", exact = FALSE)
# Wilcoxon signed rank test with continuity correction
#
# data:  x1 - x2
# V = 1.5, p-value = 0.6813
# alternative hypothesis: true location is greater than 0