# File houses multiple functions (some scraped from the web, others created in
# house) to generate and process tissot indicatrix ellipses.

# The tissot() function generates Tissot indicatrix ellipse and distortion values
# Original Author:  Bill Huber (as sourced at http://gis.stackexchange.com/a/53452)
# Script was slightly modified to deal with some instabilities via numeric.deriv()

tissot <- function(coord, prj=function(z) z+0, asDegrees=TRUE,
                   A = 6378137, f.inv=298.257223563, idx_area = FALSE, ...) {
  #
  # Compute properties of scale distortion and Tissot's indicatrix at location `x` = c(`lambda`, `phi`)
  # using `prj` as the projection.  `A` is the ellipsoidal semi-major axis (in meters) and `f.inv` is
  # the inverse flattening.  The projection must return a vector (x, y) when given a vector (lambda, phi).
  # (Not vectorized.)  Optional arguments `...` are passed to `prj`.
  #
  # Source: "Map projections: a working manual", Snyder pp 20-26 (http://pubs.er.usgs.gov/publication/pp1395)
  #         (WGS 84 defaults for the ellipsoidal parameters).

  # Split coordinates into separate values
  lambda <- coord[1]
  phi <- coord[2]

  # All input and output angles are in degrees.
  to.degrees <- function(x) x * 180 / pi
  to.radians <- function(x) x * pi / 180
  clamp <- function(x) min(max(x, -1), 1)                             # Avoids invalid args to asin
  norm <- function(x) sqrt(sum(x*x))

  # Precomputation.
  if (f.inv==0) {                                                     # Use f.inv==0 to indicate a sphere
    e2 <- 0
  } else {
    e2 <- (2 - 1/f.inv) / f.inv                                       # Squared eccentricity
  }
  if (asDegrees) phi.r <- to.radians(phi) else phi.r <- phi
  cos.phi <- cos(phi.r)                                               # Convenience term
  e2.sinphi <- 1 - e2 * sin(phi.r)^2                                  # Convenience term
  e2.sinphi2 <- sqrt(e2.sinphi)                                       # Convenience term
  if (asDegrees) units <- 180 / pi else units <- 1                    # Angle measurement units per radian
  #
  # Lengths (the metric).
  #
  radius.meridian <- A * (1 - e2) / e2.sinphi2^3                      # (4-18) radius of curvature along meridian
  length.meridian <- radius.meridian                                  # (4-19) Length of a radian
  radius.normal <- A / e2.sinphi2                                     # (4-20) radius of curvature perpendicular to meridian
  length.normal <- radius.normal * cos.phi                            # (4-21)
  #
  # The projection and its first derivatives, normalized to unit lengths.
  #
  x <- c(lambda, phi)
 # d1 <- numericDeriv(quote(prj(x, ...)), theta="x")
  d <- numeric.deriv(expr=prj2(lambda,phi, ...), theta=c("lambda","phi"))
  z <- d[1:2]                                                         # Projected coordinates
  names(z) <- c("x", "y")
  g <- attr(d, "gradient")                                            # First derivative (matrix)
  g <- g %*% diag(units / c(length.normal, length.meridian))          # Unit derivatives
  dimnames(g) <- list(c("x", "y"), c("lambda", "phi"))
  g.det <- det(g)                                                     # Equivalent to (4-15)
  if(idx_area == TRUE){
    return(g.det)
  }
  #
  # Computation.
  #
  h   <- norm(g[, "phi"])                                             # (4-27)
  k   <- norm(g[, "lambda"])                                          # (4-28)
  a.p <- sqrt(max(0, h^2 + k^2 + 2 * g.det))                          # (4-12) (intermediate)
  b.p <- sqrt(max(0, h^2 + k^2 - 2 * g.det))                          # (4-13) (intermediate)
  a   <- (a.p + b.p)/2                                                # (4-12a) semi-major axis
  b   <- (a.p - b.p)/2                                                # (4-13a) semi-minor axis
  omega <- 2 * asin(clamp(b.p / a.p))                                 # (4-1a) max deviation from correct angle
  theta.p <- asin(clamp(g.det / (h * k)))                             # (4-14)
  conv <- (atan2(g["y", "phi"], g["x","phi"]) + pi / 2) %% (2 * pi) - pi # Middle of p. 21
  #
  # The indicatrix itself.
  # `svd` essentially redoes the preceding computation of `h`, `k`, and `theta.p`.
  #
  m <- svd(g)
  axes <- zapsmall(diag(m$d) %*% apply(m$v, 1, function(x) x / norm(x))) # major and minor axes distortion
  dimnames(axes) <- list(c("major", "minor"), NULL)

  return(list(location=c(lambda, phi), projected=z,
              meridian_radius=radius.meridian, meridian_length=length.meridian,
              normal_radius=radius.normal, normal_length=length.normal,
              scale.meridian=h, scale.parallel=k, scale.area=g.det, max.scale=a, min.scale=b,
              to.degrees(zapsmall(c(angle_deformation=omega, convergence=conv, intersection_angle=theta.p))),
              axes=axes, derivatives=g))
}

# Following function reprocesses the output of `tissot` into convenient
# geometrical data.
# Original Author:  Bill Huber (as sourced at http://gis.stackexchange.com/a/53452)

indicatrix <- function(x, scale=1, ...) {
  o <- x$projected
  base <- ellipse(o, matrix(c(1,0,0,1), 2), scale=scale, ...)             # A reference circle
  outline <- ellipse(o, x$axes, scale=scale, ...)
  axis.major <- rbind(o + scale * x$axes[1, ], o - scale * x$axes[1, ])
  axis.minor <- rbind(o + scale * x$axes[2, ], o - scale * x$axes[2, ])
  d.lambda <- rbind(o + scale * x$derivatives[, "lambda"], o - scale * x$derivatives[, "lambda"])
  d.phi <- rbind(o + scale * x$derivatives[, "phi"], o - scale * x$derivatives[, "phi"])
  return(list(center=x$projected, base=base, outline=outline,
              axis.major=axis.major, axis.minor=axis.minor,
              d.lambda=d.lambda, d.phi=d.phi))
}

ellipse <- function(center, axes, scale=1, n=36, from=0, to=2*pi) {
  # Vector representation of an ellipse at `center` with axes in the *rows* of `axes`.
  # Returns an `n` by 2 array of points, one per row.
  theta <- seq(from=from, to=to, length.out=n)
  t((scale * t(axes))  %*% rbind(cos(theta), sin(theta)) + center)
}

# NOTE: The prj() function is substituted for prj2(). It's currently
# not used in any of the  other function
prj <- function(z, proj.in = CRS("+proj=longlat +datum=WGS84"),
                proj.out) {
  z.pt <- SpatialPoints(coords=matrix(z, ncol=2), proj4string=proj.in)
  w.pt <- spTransform(z.pt, CRS=proj.out)
  return(w.pt@coords[1, ])
}

# Project x,y coord values
prj2 <- function(x, y=NULL, proj.in = "+proj=longlat +datum=WGS84",
                 proj.out) {
  names1 <-  NULL
  if(is.null(y) & length(x) == 2){
    x1 <- x
    y <- x1[2]
    x <- x1[1]
    names1 <- names(x1)
  }
  z.pt <- SpatialPoints(coords=matrix(c(x,y), ncol=2),
                        proj4string=CRS(proj.in))
  w.pt <- spTransform(z.pt, CRS=proj.out)
  out <- w.pt@coords[1, ]
  if (!is.null(names1) ){
    names(out) <- names1
  }
  return(out)
}

# Following function was added by Manny Gimond. The default precision in the
# numericDeriv() function forced some instabilities in the gradient output
# (e.g. try c(1-60,-40) in a "+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84"
# coordinate system). This function reduces the precision to alleviate the
# aforementioned  problem.
numeric.deriv <- function(expr, theta, rho=sys.frame(sys.parent()))
{
  # eps <- sqrt(.Machine$double.eps)
  eps <- (.Machine$double.eps)^0.3
  ans <- eval(substitute(expr), rho)
  grad <- matrix(, length(ans), length(theta),
                 dimnames=list(NULL, theta))

  for (i in seq_along(theta)) {
    old <- get(theta[i], envir=rho)
    delta <- eps * max(1, abs(old))
    assign(theta[i], old+delta, envir=rho)
    ans1 <- eval(substitute(expr), rho)
    assign(theta[i], old, envir=rho)
    grad[, i] <- (ans1 - ans)/delta
  }
  attr(ans, "gradient") <- grad
  ans
}

# Run the tissot function and extract its parameters
ti  <- function(coord, prj, proj.in = "+proj=longlat +datum=WGS84" ,
                proj.out, scale=500000, n = 61){
  TI <- tissot(coord, prj,
               proj.in = proj.in ,
               proj.out = CRS(proj.out))
  i <- indicatrix(TI, scale= scale, n=n)
  # Rounding may be needed for values approaching 0
  i <- lapply(i, round, digits=4)
  i[["axes"]] <- TI$axes
  i[["area"]] <- TI$scale.area
  return(i)
}

# Extract tissot area values
ti_area  <- function(coord, prj, proj.in = "+proj=longlat +datum=WGS84" ,
                     proj.out, idx_area = TRUE){
  i <- tissot(coord, prj,
              proj.in = proj.in ,
              proj.out = CRS(proj.out),
              idx_area = TRUE)
  return(i)
}

# Create an sfc poly from point data
tis2poly <- function(poly, proj.out){
  p <- st_multipolygon(poly)
  return(st_sfc(p, crs = proj.out))
}

# Create an sfc poyline from point data
tis2line <- function(polyline, proj.out){
  p <- lapply(polyline, function(x) st_linestring(matrix(x$poly[1:2], ncol=2)))
  return(st_sfc(p, crs = proj.out))
}

# Generate a local Indicatrix circle
local_TI <- function(long, lat, proj.in = "+proj=longlat +datum=WGS84",
                     proj.out){
  TI <- tissot(c(long, lat), prj, proj.in=proj.in, proj.out=proj.out)
  TI$max.scale
  TI$min.scale
  TI$max.scale / TI$min.scale

  i <- indicatrix(TI, scale=10^4, n=71)
  plot(i$outline, type="n", asp=1, xlab="x", ylab="y")
  rect(par("usr")[1],par("usr")[3],par("usr")[2],par("usr")[4],col = "grey90")
  grid(col="white")
  polygon(i$base, col="bisque", border="Gray")
  if(TI$min.scale != TI$max.scale){
    lines(i$axis.major, lwd=2, col=rgb(.45, 1, .45))
    lines(i$axis.minor, lwd=2, col=rgb(1, .35, .35))
  }
  lines(i$outline, asp=1, lwd=2, col=rgb(.35, .35, 1))
  lines(i$d.lambda, lwd=2, col=rgb(.35, .35, .35), lty=3)
  lines(i$d.phi, lwd=2, col=rgb(.35, .35, .35), lty=2)
  title.out<- sprintf("Long=%0.2f, Lat=%0.3f, Area scale=%0.3f,
                      Max scale=%0.3f, Min scale=%0.3f\n %s ",
                      long,lat,TI$scale.area, TI$max.scale,
                      TI$min.scale, proj.out)
  mtext(title.out,3,col="blue")
  return(TI)
}

# Generate sf objects
tissot_sf <- function(i.lst, proj.out){
  bases <- lapply(i.lst, function(x) list(poly = x$base))
  base_sf <- tis2poly(bases, proj.out)

  # Extract indicatrix
  ind <- lapply(i.lst, function(x) list(poly = x$outline))
  ind_sf <- tis2poly(ind, proj.out)
  ind_sf <- st_cast(ind_sf, "POLYGON")
  #st_is_valid(ind_sf)

  # Extract minor/major axes
  maja <- lapply(i.lst, function(x) st_linestring(x$axis.major))
  maja_sf <- st_sfc(maja, crs = proj.out)

  mina <- lapply(i.lst, function(x) st_linestring(x$axis.minor))
  mina_sf <- st_sfc(mina, crs = proj.out)

  # Extract lambda and phi
  lam <- lapply(i.lst, function(x) st_linestring(x$d.lambda))
  lam_sf <- st_sfc(lam, crs = proj.out)

  phi <- lapply(i.lst, function(x) st_linestring(x$d.phi))
  phi_sf <- st_sfc(phi, crs = proj.out)

  # Extract area values
  ind_sf <- st_as_sf(ind_sf)
  ind_sf$area <- sapply(i.lst, function(x) (x$area))

  # Output list
  list(base = base_sf, ind = ind_sf , maja = maja_sf, mina = mina_sf,
       lam = lam_sf, phi = phi_sf, area = ind_sf$area)
}

# Function to recenter and dissolve a map along a different longitude
# Code originally written by Michael Summner
# (https://github.com/AustralianAntarcticDivision/SOmap/issues/34)
c_recenter <- function(x, clon = NULL, ..., tryfix = TRUE) {
  if (is.null(clon)) return(x)
  if (!st_is_longlat(x)) stop("recentring not appropriate for non longlat data")
  ## save the crs while we do our munging
  crs <- st_crs(x)
  x <- st_set_crs(x, NA)

  ## try to fix problematic geometry
  if (tryfix) {
    if (all(grepl("POLYGON", st_geometry_type(x)))) x <- suppressWarnings(st_buffer(sf::st_as_sf(x), 0))
    x <- st_wrap_dateline(x, options = c("WRAPDATELINE=YES", "DATELINEOFFSET=180"))
  }
  wbox <- st_bbox(c(xmin = -180, ymin = -90, xmax = (clon)%%360 - 180, ymax = 90))
  west <- suppressWarnings(st_crop(x, wbox))
  west <- st_set_geometry(west, st_geometry(west) + c(360, 0))
  east <- suppressWarnings(st_crop(x, st_bbox(c(xmin = (clon)%%360 - 180, xmax = 180, ymin = -90, ymax = 90))))
  xx <- rbind(
    west, east
  )
  ## ensure geometries are of consistent type
  xx <- sf::st_cast(xx)
  bb <- st_bbox(xx)
  st_set_crs(xx, crs)
}

# Check for valid coordinate extent. If projected coord values are Inf,
# remove that coordinate value from the returned list.
# Note that ptransform is used here whereas spTransform is used for the
# actual projection of the data layers. ptransform is used for its simplicity
# (it returns Inf if a coordinate pair is out of a projection's bounds).
# I'm not sure how ptransform differs from spTransform--this may require
# some more checking.

coord_check <- function(lonlat, proj.in = "+proj=latlong +ellps=WGS84",
                        proj.out){
  coord.prj <- proj4::ptransform(data = lonlat/180 * pi,
                                 src.proj = proj.in,
                                 dst.proj = proj.out, silent=TRUE)
  coord.chk <- t(apply(coord.prj[,1:2], 1, function(x) !is.infinite(x)))
  coord.bool <- apply(coord.chk, 1, function(x) as.logical(min(x)))
  lonlat[coord.bool, ]
}


## Created on Wednesday, October  6, 2021 at 9:52pm EDT by Weekend Editor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../../tools"                              # Various tools available from author
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics hacks

library("hypergeo")                                    # For hypergeo() and genhypergeo()

##
## Compare with the example Julian Saffer plots on his GitHub repository:
## https://github.com/jsaffer/beta_quotient_distribution
## - Numerator beta distribution: alpha1 = 3, beta1 = 6
## - Denominator beta distribution: alpha2 = 12, beta2 = 7
##
## This comparison is "naive" in the sense that I'm just using the hypergeo library functions
## without any caution for large values of the hypergeometric function's parameters.  E.g., for
## the Moderna/Pfizer COVID-19 vaccine clinical trials, those could be O(10k-20k).  We almost
## certainly need some recurrence relation or other to help out with that.
##
## But Saffer's example is doable with naive numerics.
##
## IWBNI we also did the Monte Carlo version for comparison: take pairs of random draws from the
## numerator and denominator distributions, calculate a ratio, and histogram the probability
## density of the ratio.  Compare with theoretical distribution by something like a
## Kolmogorov-Smirnov test?
##

doit <- function(alpha1 =  3, beta1 = 6,               # Numerator beta distribution
                 alpha2 = 12, beta2 = 7,               # Denominator beta distribution
                 nPoints  = 1000,                      # Number of points on each curve
                 xmax     = 2.0,                       # Limit on horizontal axis from Saffer
                 ymax     = 3.75,                      # Limit on vertical axis from Saffer
                 alpha    = 0.40,                      # Transparency level of fill colors (0 to 1)
                 cols     = c(numerator   = "blue",    # Colors for various curves
                              denominator = "orange",  #  and the fill for them inside
                              ratio       = "green",   #  their 90% credible intervals
                              ratioCDF    = "red"),    # Finally, destination for plot
                 plotFile = "2021-09-13-beta-ratios-naive-comparison-vs-saffer.png") {

  dBetaRatio <- function(alpha1, beta1, alpha2, beta2, R) {
    ## Beta ratio PDF
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(R) && R >= 0)                 # Don't be ridiculous
    if (R <= 1)                                        # Small values of R
      beta(alpha1 + alpha2, beta2) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^(alpha1 - 1) *                               #
        hypergeo(alpha1 + alpha2, 1 - beta1, alpha1 + alpha2 + beta2, R)
    else                                               # Large values of R
      beta(alpha1 + alpha2, beta1) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^(-(alpha2+1)) *                              #
        hypergeo(alpha1 + alpha2, 1 - beta2, alpha1 + alpha2 + beta1, 1 / R)
  }                                                    #

  pBetaRatio <- function(alpha1, beta1, alpha2, beta2, R) {
    ## Beta ratio CDF
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(R) && R >= 0)                 # Don't be ridiculous
    if (R <= 1)                                        # Small values of R
      beta(alpha1 + alpha2, beta2) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^alpha1 / alpha1 *                            #
        genhypergeo(c(alpha1, alpha1 + alpha2, 1 - beta1), c(alpha1 + 1, alpha1 + alpha2 + beta2),
                    R)                                 #
    else                                               # Large values of R
     1 - beta(alpha1 + alpha2, beta1) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
       1 / (alpha2 * R^alpha2) *                       #
       genhypergeo(c(alpha2, alpha1 + alpha2, 1 - beta2), c(alpha2 + 1, alpha1 + alpha2 + beta1),
                   1 / R)                              #
  }                                                    #

  qBetaRatio <- function(alpha1, beta1, alpha2, beta2, q, minR = 0, maxR = 10) {
    ## Beta ratio quantile (numeric solution via CDF)
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(q) && is.numeric(minR) && is.numeric(maxR))
    stopifnot(0 <= q && q <= 1.0)                      # Don't be ridiculous
    stopifnot(0 <= minR && 0 <= maxR && minR < maxR)   # Really: don't be ridiculous
    uniroot(function(R) {q - pBetaRatio(alpha1, beta1, alpha2, beta2, R)}, c(minR, maxR))$"root"
  }                                                    #

  medianBetaRatio <- function(alpha1, beta1, alpha2, beta2, minR = 0, maxR = 10) {
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    qBetaRatio(alpha1, beta1, alpha2, beta2, 0.50, minR, maxR)
  }                                                    # Analytic version uses incomplete Beta func

  meanBetaRatio <- function(alpha1, beta1, alpha2, beta2) {
    alpha1 * (alpha2 + beta2 - 1) / ((alpha1 + beta1) * (alpha2 - 1))
  }                                                    # Mean has simple closed form

  meanBeta <- function(alpha, beta) { alpha / (alpha + beta) }

  colorCI <- function(col, alpha, xvals, yvals, x05, x95) {
    col <- col2rgb(col)                                # Base color to make transparent
    col <- rgb(col[[1]], col[[2]], col[[3]], max = 255, alpha = alpha * 255)
    foo <- subset(data.frame(x = xvals, pdf = yvals), subset = x05 <= x & x <= x95)
    polygon(x = c(rev(foo$"x"),                   foo$"x"),
            y = c(rep(0, length.out = nrow(foo)), foo$"pdf"),
            border = NA, col = col)                    # Filled in 90% credible interval
  }                                                    #

  ## Values where we numerically evaluate the distributions
  xvals    <- seq(from = 0, to = xmax, length.out = nPoints)

  ## Numerator beta distribution
  numPDF   <- dbeta(x = xvals, shape1 = alpha1, shape2 = beta1)
  numMean  <- meanBeta(alpha1, beta1)                  # Mean of numerator beta distribution
  num05    <- qbeta(p = 0.05, shape1 = alpha1, shape2 = beta1)
  num95    <- qbeta(p = 0.95, shape1 = alpha1, shape2 = beta1)

  ## Denominator bea distribution
  denomPDF  <- dbeta(x = xvals, shape1 = alpha2, shape2 = beta2)
  denomMean <- meanBeta(alpha2, beta2)                 # Mean of denominator beta distribution
  denom05   <- qbeta(p = 0.05, shape1 = alpha2, shape2 = beta2)
  denom95   <- qbeta(p = 0.95, shape1 = alpha2, shape2 = beta2)

  ## Ratiodistribution
  ratioPDF  <- sapply(xvals, function(R) { dBetaRatio(alpha1, beta1, alpha2, beta2, R) })
  ratioCDF  <- sapply(xvals, function(R) { pBetaRatio(alpha1, beta1, alpha2, beta2, R) })
  ratioMean <- meanBetaRatio(alpha1, beta1, alpha2, beta2)
  ratio05   <- qBetaRatio(alpha1, beta1, alpha2, beta2, 0.05)
  ratio95   <- qBetaRatio(alpha1, beta1, alpha2, beta2, 0.95)

  ## Saffer: 1152 x 648 --> us: 400 x 225
  withPNG(file.path(".", plotFile), 400, 225, FALSE, function() {
    withPars(function() {                              # Save/restore graphics parameters

      matplot(x    = xvals,                            # Plot PDFs and ratio CDF
              y    = matrix(data = c(numPDF, denomPDF, ratioPDF, ratioCDF), nrow = nPoints),
              lty  = c("solid", "solid", "solid", "dotted"),
              col  = c(cols[["numerator"]], cols[["denominator"]],
                       cols[["ratio"]],     cols[["ratioCDF"]]),
              type = "l", lwd = 2,                     #
              xlim = c(0, xmax), ylim = c(0, ymax),    #
              xlab = "X", ylab = "Pr(X) or Pr(> X)",   #
              main = "Saffer's Example Beta Ratio")    #

      colorCI(cols[["numerator"]],   alpha, xvals, numPDF,   num05,   num95)
      colorCI(cols[["denominator"]], alpha, xvals, denomPDF, denom05, denom95)
      colorCI(cols[["ratio"]],       alpha, xvals, ratioPDF, ratio05, ratio95)

      abline(v   = c(numMean, denomMean, ratioMean),   # Vertical dashed lines at means
             col = c(cols[["numerator"]], cols[["denominator"]], cols[["ratio"]]),
             lty = "dashed", lwd = 2)                  #

      ## Grid lines
      abline(h = seq(from = 0, to = 3.5, by = 0.5), col = "gray")
      abline(v = seq(from = 0, to = 2.0, by = 0.5), col = "gray")

    }, pty = "m",                                      # Maximal plotting area
       bg  = "white",                                  # White background
       mar = c(3, 3, 2, 1),                            # Pull in on margins a bit
       mgp = c(1.7, 0.5, 0),                           # Axis title, labels, ticks
       las = 1,                                        # Always horizontal axis labels
       ps  = 16)                                       # Larger type size for file capture
  })                                                   #

  invisible(NA)                                        # Return nothing of interest, invisibly
}                                                      #


##################################### FUNCOES PARA INTERPOLACAO ####################################

#' Modelo Para Interpolacao De Curva Colina
#'
#' Funcao para estimacao de diferentes interpoladores de curva colina
#'
#' \code{interpolador} serve como uma interface comum para estimacao de diversas formas atraves das
#' quais interpolar a colina original. Atualmente ha tres abordagens implementadas:
#'
#' \itemize{
#' \item{\code{\link{triangulacao}}}
#' \item{\code{\link{thinplate}}}
#' \item{\code{\link{tensorprod}}}
#' }
#'
#' Se \code{metodo = "triangulacao"}, a colina fornecida e projetada no plano hl x pot e entao
#' tesselada atraves da triangulacao de Delaunay. Interpolacao de um ponto em objetos de
#' triangulacao se da atraves de transformacao para coordenadas baricentricas e subsequente media
#' ponderada dos rendimentos nos vertices do triangulo que o contem.
#'
#' Quando \code{metodo = "thinplate"} ou \code{metodo = "tensorprod"}, a colina e suavizada atraves
#' de splines, cujo tipo depende do \code{metodo} passado: \code{"thinplate"} corresponde a
#' suavizacao por splines homonimas e \code{"tensorprod"} ao produto tensor de splines. A
#' interpolacao nesse caso consiste simplesmente da consulta a curva suavizada em pontos
#' selecionados.
#'
#' O argumento \code{...} permite passar os argumentos opcionais aos metodos especificos. As paginas
#' de ajuda dos interpoladores proveem mais informacao a respeito destes argumentos extras.
#'
#' \bold{Interpoladores Multiplos}:
#'
#' Existe a possibilidade de estimar um interpolador combinando mais de um metodo. Isto pode ser
#' feito passando um vetor de duas posicoes em \code{metodo} indicando os dois metodos a serem
#' usados conjuntamente com o argumento \code{quebra}, um numero indicando o rendimento da curva
#' a partir da qual o segundo metodo deve ser utilizado.
#'
#' Nestes casos, o objeto retornado tera classe \code{"interpolador"} e subclasse
#' \code{"interpoladorM"}, com todos os mesmos metodos disponivies.
#'
#' @param colina objeto da classe \code{curvacolina} (retornado pelas funcoes de leitura)
#' @param metodo um ou dois de \code{c("triangulacao", "thinplate", "tensorpro")}. Ver Detalhes
#' @param quebra opcional, numerico indicando o rendimento da curva a partir da qual chavear
#'     metodos. Ver Detalhes
#' @param ... demais parametros que possam ser passados as funcoes de ajuste de cada \code{metodo}.
#'     Ver Detalhes
#'
#' @examples
#'
#' # usando dado dummy contido no pacote
#' interp_tri <- interpolador(colinadummy, "triangulacao")
#'
#' # interpolando uma grade 20x20 no dominio da colina
#' pontos <- coordgrade(colinadummy, 20, 20)
#' grade <- predict(interp_tri, pontos)
#'
#' \dontrun{
#' # visualizacao 3d e 2d do resultado
#' plot(grade)
#' plot(grade, "2d")
#' }
#'
#' # INTERPOLADOR MULTIPLO
#' interp_mult <- interpolador(colinadummy[rend > 92], c("thinplate", "triangulacao"), 95.5)
#'
#' # interpolando uma grade 20x20 no dominio da colina
#' pontos <- coordgrade(colinadummy, 20, 20)
#' grade <- predict(interp_mult, pontos)
#'
#' \dontrun{
#' # visualizacao 3d e 2d do resultado
#' plot(grade)
#' plot(grade, "2d")
#' }
#'
#' @return objeto da classe \code{interpolador} e subclasse \code{metodo}, isto e, um modelo com o
#'     qual se realizar previsoes e, assim, interpolar o dado original
#'
#' @family interpolador
#'
#' @export

interpolador <- function(colina, metodo, quebra, ...) {

    rend <- NULL

    if(missing(quebra)) {
        interp_func <- match.call()
        interp_func[[1]] <- as.name(metodo)
        interp_func$metodo <- NULL

        interp <- eval(interp_func, envir = parent.frame())

        return(interp)
    } else {

        if(length(metodo) != 2) stop("Quando 'quebra' e fornecido, 'metodos' deve ter tamanho 2")

        colinas <- list(colina[rend <= quebra], colina[rend >= quebra])

        interp_func <- match.call()
        interp <- mapply(metodo, colinas, FUN = function(m, c) {
            interp_func[[1]] <- as.name(m)
            interp_func$colina <- c
            interp_func$metodo <- NULL

            eval(interp_func, envir = parent.frame())
        }, SIMPLIFY = FALSE)

        new_interpoladorM(interp, quebra)
    }
}

# METODOS ------------------------------------------------------------------------------------------

#' @rdname getcolina

getcolina.interpolador <- function(object) stop(paste0("Implemente metodo 'getcolina' do modelo: ", class(object)[1]))

#' Previsao Com Modelos Interpoladores
#'
#' Metodo para interpolar curva colina a partir de um objeto gerado por \code{interpolador}
#'
#' O argumento \code{as.gradecolina} permite alterar a saida da interpolacao. Se
#' \code{as.gradecolina = FALSE}, o padrao, apenas o vetor de rendimentos interpolados sera
#' retornado. Caso \code{as.gradecolina = TRUE}, a saida sera um objeto \code{\link{gradecolina}}.
#'
#' @param object objeto da classe \code{interpolador} retornado pela funcao homonima
#' @param pontos data.frame ou matriz contendo pontos nos quais amostrar o rendimento
#' @param as.gradecolina booleano indicando o nivel de detalhe na saida da funcao. Ver Detalhes
#' @param ... demais parametros que possam ser passados aos metodos de \code{predict} especificos
#'
#' @return vetor de rendimentos nas coordenadas especificadas em \code{pontos}
#'
#' @family interpolador
#'
#' @export

predict.interpolador <- function(object, pontos, as.gradecolina, ...) {
    stop(paste0("Implemente metodo 'predict' do modelo: ", class(object)[1]))
}


############################################################
# For owl monkey project, last revised 04.18
# Plots and statistical tests for Figure 1 and Figure S2
# in owl monkey paper.
#
# Gregg Thomas
############################################################

library(ggplot2)
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)
cat("----------\n")

figs2_opt = T
# CHANGE TO TRUE TO GENERATE FIG. S2

####################
## Estimating model parameters using Kong (2012) data
human_dm0 = 34; human_df = 31; human_num_f = 14.2; human_haploid = 2630000000; human_diploid = human_haploid * 2;
# Parameters observed from Drost & Lee (1995) and Kong (2012)

human_mu_c = (human_num_f / human_df)
cat("mu_c estimated from Kong params: ", human_mu_c, "\n")
human_mu_c = human_mu_c / human_haploid
cat("mu_c per site estimated from Kong params: ", human_mu_c, "\n")
# Estimating mu_c

# Calculate spermatogenic proportion and expected number of spermatogenic divisions
# per year using human (Kong) observations.
human_sc = 16
human_dy1 = ((2.01 / human_haploid) / human_mu_c)
human_sp = human_dy1 / (365/16)
cat("Human expected # of spermatogenic cycles/year: ", human_dy1, "\n")
cat("Human spermatogenic cell proportion given a cycle length of 16 days: ", human_sp, "\n")
cat("----------\n")
# Estimating the expected number of spermatogenic cycles per year

# 2.01 is the slope of the Kong line -- mutations per year in males after puberty.
# We can calculate the expected number of spermatogenic cycles per year (human_dy1) based on mu_c.
# Then, we can estimate the proportion of cells undergoing spermatogenesis at any given time (human_sp)
####################

####################
## Owl monkey prediction (purple dashed) using Kong parameters
om_puberty = 1; om_sc = 10.2;
om_dy1 = (365/om_sc) * human_sp
cat("Owl monkey expected # of spermatogenic cycles/year: ", om_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in owl monkeys using the human proportion
# of cells actively dividing (human_sp).

age_range = seq(om_puberty, 15, by=0.1)
rep_long = age_range - om_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

om_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (om_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

om_pred = data.frame(om_mu_g, age_range)
names(om_pred) = c("Mutation.rate", "Parental.age")
om_pred_reg = lm(om_mu_g ~ age_range)
cat("----------\n")
####################

####################
## Owl monkey observed data (purple solid)
in_data = read.csv("data/owl-monkey-filters.csv", header=TRUE)

if(figs2_opt) {
  cur_filter = subset(in_data, Min.DP==20 & Max.DP==60 & Min.AB==0.3 & Max.AB==0.7)
}else{
  cur_filter = subset(in_data, Min.DP==20 & Max.DP==60 & Min.AB==0.4 & Max.AB==0.6)
}
om_obs = cur_filter$MVs.corrected.for.FN
om_gt = cur_filter$Paternal.GT
om_callable = (cur_filter$Sites - cur_filter$Uncallable.SNP.sites) * 2
om_mu = om_obs / om_callable
cur_filter$CpG.rate = cur_filter$CpG.MVs / om_callable
om_obs_reg = lm(om_mu ~ om_gt)
# Read data and define current filter

cat("PREDICTED SLOPE (d_ym1)\n")
cat(coef(om_pred_reg)[2], " mutations per site per year\n")
cat(coef(om_pred_reg)[2] * human_haploid * 2, " mutations per year\n")
cat("OBSERVED SLOPE (dy_m1)\n")
cat(coef(om_obs_reg)[2], " mutations per site per year\n")
cat(coef(om_obs_reg)[2] * (mean(om_callable)), " mutations per year\n")
cat("----------\n")
# Predicted vs observed slopes (d_ym1)
####################

####################
## The plot for Fig. 1
fig1 = ggplot(cur_filter, aes(x=Paternal.GT, y=Mutation.rate.corrected.for.FN)) +
  geom_smooth(method='glm', color='#b66dff', fill="#f2e6ff", fullrange=T) +
  geom_point(color='#b66dff', size=3) +
  geom_smooth(aes(x=Paternal.GT, y=CpG.rate), method='glm', color="#6db6ff", fill=NA, fullrange=T) +
  geom_point(aes(x=Paternal.GT, y=CpG.rate), color="#6db6ff", size=3) +
  scale_x_continuous(breaks = seq(1, 60, by=2)) +
  scale_y_continuous(breaks = seq(0, 1.8e-8, by=0.4e-8)) +
  geom_line(data=om_pred, aes(x=Parental.age, y=Mutation.rate), linetype=2, size=0.75, color="purple") +
  geom_vline(xintercept=1, linetype=3, color="grey", size=0.75) +
  labs(x="Age of father at conception (y)",y="Mutation rate per site\nper generation") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title=element_text(size=20),
        axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
        axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm")
        )
print(fig1)
if(figs2_opt) {
  ggsave(filename="figS1C.pdf", fig1, width=6, height=5, units="in")
}else{
  ggsave(filename="fig1.pdf", fig1, width=6, height=5, units="in")
}
cat("--Regression summary for observed points--\n")
print(summary(om_obs_reg))
cat("----------\n")
####################

####################
## The F test for Fig. 1
pred_actual = coef(om_pred_reg)[1] + om_gt * coef(om_pred_reg)[2]
pred_resids = om_mu - pred_actual
#plot(age_range,om_mu_g, type='l',ylim=c(min(om_mu),max(om_mu)))
#points(om_gt, om_mu)
#segments(x0=om_gt,y0=om_mu,x1=om_gt,y1=om_mu-pred_resids)
#abline(om_obs_reg, lty=2)
#segments(x0=om_gt,y0=om_mu,x1=om_gt,y1=om_mu-resid(om_obs_reg),lty=2)
cat("--F test for differences between residuals of the predicted and observed lines--")
print(var.test(resid(om_obs_reg), pred_resids, alternative="two.sided"))
cat("----------\n")
####################
stop()
####################
## Paternal (orange) vs. Maternal (teal) mutations
pat_df = data.frame(cur_filter$Paternal.MVs[cur_filter$Paternal.MVs!=0], cur_filter$Paternal.GT[cur_filter$Paternal.MVs!=0])
names(pat_df) = c("Paternal.MVs", "Paternal.GT")
mat_df = data.frame(cur_filter$Maternal.MVs[cur_filter$Maternal.MVs!=0], cur_filter$Maternal.GT[cur_filter$Maternal.MVs!=0])
names(mat_df) = c("Maternal.MVs", "Maternal.GT")

p = ggplot(pat_df, aes(x=Paternal.GT, y=Paternal.MVs)) +
  geom_smooth(method='glm', color='#db6d00', fill='#ffe6cc', fullrange=T) +
  geom_point(color='#db6d00', size=3) +
  geom_vline(xintercept=1, linetype=3, color="grey", size=0.75) +
  geom_smooth(data=mat_df, aes(x=Maternal.GT, y=Maternal.MVs), method='glm', color='#009292', fill='#ccffff', fullrange=T) +
  geom_point(data=mat_df, aes(x=Maternal.GT, y=Maternal.MVs), color='#009292', size=3) +
  #scale_y_continuous(limits=c(0,16)) +
  labs(x="Age of parent at conception (y)",y="Mutation rate per site") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title=element_text(size=20),
        axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
        axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm")
  )
#print(p)
pat_reg = lm(pat_df$Paternal.MVs ~ pat_df$Paternal.GT)
cat("--Regression summary for paternal mutations--\n")
print(summary(pat_reg))
cat("--Regression summary for maternal mutations--\n")
mat_reg = lm(mat_df$Maternal.MVs ~ mat_df$Maternal.GT)
print(summary(mat_reg))
####################


#' Mixing Layer Depth
#'
#' Identification of the mixing layer depth (e.g. thermocline, pycnocline)
#'   using a modified version of the Maximum Angle Method.
#'
#' @param z Vector of depths, or 2-column dataframe containing depths in first
#'   column and variable of interest (e.g. temperature, salinity) in second
#'   column.
#' @param x Vector containing variable of interest (e.g. temperature, salinity)
#'   of same length as \code{z}.
#' @param np Number of points to use in linear regressions (see 'details').
#' @param min.range The minimum range in the value of \code{x} in order
#'   for a mixing layer to be detectable.
#' @param max.z Maximum value of \code{z} to use when searching for mixing
#'   layer depth.
#' @param return.index If TRUE, return the index of \code{z} corresponding to
#'   the mixing layer depth. Otherwise, return the depth.
#' @return either the mixing layer depth or the element index of z associated
#'   with said depth, depending on the value of \code{return.type}.
#'
#' @details The Maximum Angle Method is modified to better handle the
#'   identification of the mixing layer depth when the surface layer is
#'   poorly-mixed and to provide some flexibility in the linear regression, but
#'   may be less stable as a result. The modifications force the dual linear
#'   regressions to share the last/first data point and allow the user to
#'   specify the number of points used in the regressions.
#'
#' @references Chu, Peter C., and Chenwu Fan. "Maximum angle method for
#'   determining mixed layer depth from seaglider data." Journal of
#'   oceanography 67.2 (2011): 219-230.
#'
#' @examples
#' data(ctd)
#' zt = subset(ctd, date == date[1] & dist == dist[1])[c("depth", "ta")]
#' mld(zt)
#' mld(zt, return.index = TRUE)
#'
#' #' @seealso \code{\link{blt}}
#' @export
mld = function(z, x = NULL, np = 2, min.range = 0, max.z = NULL,
  return.index = FALSE){
  if(is.null(x)){
    x = z[, 2]
    z = z[, 1]
  }
  if(!is.null(max.z)){
    x = x[z <= max.z]
    z = z[z <= max.z]
  }
  if(np > floor(0.5*length(z)))
      stop("Argument 'np' is too large.")
  minx = min(x)
  maxx = max(x)
  rangex = maxx - minx
  # return NA if range of variable is too small
  if(rangex < min.range)
    return(NA)
  minz = z[min(which(x == min(x)))]
  maxz = z[max(which(x == max(x)))]
  rangez = maxz - minz
  if(minz != min(z) | maxz != max(z))
    warning("Data is noisy")
  m = np - 1
  j = np - 1
  K = length(z)
  tantheta = 0
  clinek = 1
  for(k in seq(j + 1, K - m)){
#   Gtop = lm(x ~ z, data.frame(z = z[seq(k - j, k)],
#     x = x[seq(k - j, k)]))$coefficients[[2]]
#   Gbot = lm(x ~ z, data.frame(z = z[seq(k, k + m)],
#     x = x[seq(k, k + m)]))$coefficients[[2]]
    # slope of line z ~ x is defined as cor(x, z)*sd(x)/sd(z)
    topmask = seq(k - j, k)
    botmask = seq(k, k + m)
    Gtop = cor(z[topmask], x[topmask])*sd(x[topmask])/sd(z[topmask])
    Gbot = cor(z[botmask], x[botmask])*sd(x[botmask])/sd(z[botmask])
    newtantheta = abs((Gbot - Gtop)/(1 + Gbot*Gtop))
    if(!is.na(newtantheta) & newtantheta > tantheta){
      clinek = k
      tantheta = newtantheta
    }
  }
  if(return.index)
    clinek
  else
    z[clinek]
}

#' Barrier Layer Thickness
#'
#' Calculate the thickness of the barrier layer.
#'
#' @param z Vector of depths, or 3-column dataframe containing depths in first
#'   column, temperatures in the second column and salinities in the third
#'   column.
#' @param t Vector of temperatures of same length as \code{z}.
#' @param s Vector of salinities of same length as \code{z}.
#' @param ... Other arguments passed to \code{mld}. Note that
#'   \code{return.index = FALSE} is fixed.
#' @return The thickness of the barrier layer.
##'
#' @details The 'Barrier Layer' is the region between the pycnocline and
#'   thermocline. This function identifies the thermocline and pycnocline
#'   depths using \code{mld} and calculates the thickness of the barrier as the
#'   difference the two depths.
#'
#' @references Chu, Peter C., and Chenwu Fan. "Maximum angle method for
#'   determining mixed layer depth from seaglider data." Journal of
#'   oceanography 67.2 (2011): 219-230.
#'
#' @seealso \code{\link{mld}}
#' @export
blt = function(z, t, s, ...){
  if(is.missing(t) | is.missing(s)){
    s = z[, 3]
    t = z[, 2]
    z = z[,1]
  }
  thermocline = mld(z, t, return.index = FALSE, ...)
  pycnocline = mld(z, s, return.index = FALSE, ...)
  abs(thermocline - pycnocline)
}

#' Stratify by a Variable
#'
#' Stratify data into zones using specified midpoints.
#'
#' @param x Vector of values.
#' @param midpoints Vector of midpoints or cut points to stratify \code{x} by.
#'   \code{min(x)} and \code{max(x)} are automatically included.
#' @param ... Other arguments to pass to \code{cut()}.
#'
#' @details This function is basically a wrapper for \code{cut()}, but requires
#'   the cuts be directly specified and that \code{include.lowest = TRUE}.
#'   Every element of \code{x} is therefore guaranteed to be included in one
#'   interval.
stratify = function(x, midpoints, ...){
  minx = min(x)
  maxx = max(x)
  if(any(midpoints >= maxx) | any(midpoints <= minx))
    stop("Midpoints must be within range (min(x), max(x))")
  cut(x, unique(c(minx, sort(midpoints), maxx)), include.lowest = TRUE, ...)
}


# Clear workspace and memory
rm(list = ls()); gc(reset = TRUE)

setwd('D:\\MY_video_tutorials')

# Build simple Neural Network model on the XOR data.

#loading keras library
library(keras)

vector1<-c(0,0,1,1)
vector2<-c(0,1,0,1)

train_data <- array(c(vector1, vector2), dim = c(4,2))

target_data <- array(c(0,1,1,0), dim = c(4,1))

#defining a keras sequential model
model <- keras_model_sequential()

#defining the model

model %>%
  layer_dense(units = 16, input_shape = 2) %>%
  layer_dropout(rate=0.1)%>%
  layer_activation(activation = 'relu') %>%
  layer_dense(units = 1) %>%
  layer_activation(activation = 'sigmoid')

#compiling the defined model with metric = accuracy and optimiser as adam.
model %>% compile(
  loss = 'binary_crossentropy',
  optimizer = 'adam',
  #optimizer = optimizer_adam( lr= 0.0001 , decay = 1e-6 ),
  metrics = c('accuracy')

)

# summary model

summary(model)

#fitting the model on the training dataset
model %>% fit(train_data, target_data, epochs = 500, batch_size = 10)

x<- c(1,0,1,1)
y<- c(1,1,0,0)

test_data_x <- array(c(x, y), dim = c(4,2))
test_data_y <-  array(c(0,1,1,1), dim = c(4,1))

#Evaluating model on the cross validation dataset

pred <- model %>% predict(test_data_x, batch_size = 128)
Y_pred <- round(pred)

# Confusion matrix
CM <- table(Y_pred, test_data_y)
CM

# evaluate the model
evals <- model %>% evaluate(test_data_x, test_data_y, batch_size = 10)

accuracy <- evals[2][[1]]* 100
accuracy


iterate.until.escape <- function(z, c, trans, cond, max=50, response=dwell) {
  #we iterate all active points in the same array operation,
  #and keeping track of which points are still iterating.
  active <- seq_along(z)
  dwell <- z
  dwell[] <- 0
  for (i in 1:max) {
    z[active] <- trans(z[active], c[active]);
    survived <- cond(z[active])
    dwell[active[!survived]] <- i
    active <- active[survived]
    if (length(active) == 0) break
  }
  eval(substitute(response))
}

re = seq(-2, 1, len=500)
im = seq(-1.5, 1.5, len=500)
c <- outer(re, im, function(x,y) complex(real=x, imaginary=y))
x <- iterate.until.escape(array(0, dim(c)), c,
                          function(z,c)z^2+c, function(z)abs(z) <= 2,
                          max=100)
image(x)


MGRAST_plot_pco <- function(
                            file_in,
                            file_out = "my_PCoA",
                            dist_method = "bray-curtis",
                            headers = 0
                            )

{

  # load packages
  suppressPackageStartupMessages(library(matlab))
  suppressPackageStartupMessages(library(ecodist))
  #suppressPackageStartupMessages(library(Cairo))
  #suppressPackageStartupMessages(library(gplots))

  # define sub functions
  func_usage <- function() {
    writeLines("
     You supplied no arguments

     DESCRIPTION: (MGRAST_plot_pco.r):
     This script will perform a PCoA analysis on the inputdata
     using the selected distance metric.  Output is a single file
     that has the normalized eigenvalues (top n lines) and eigenvectors
     (bottom n x m matris, n lines) where n is the number of variables (e.g.
     subsystems), and m the number of samples.

     USAGE: MGRAST_plot_pca(
                            file_in = \"file\",                                        # input data file, no default,
                            file_out = \"my_PCoA\",                                    # output file,     default = \"my_PCoA\"
                            dist_method = (choose from one of the following options) # distance/dissimilarity metric,
                                                                                # default = \"bray-curtis\"

                                          \"euclidean\" | \"maximum\"     | \"canberra\"    |
                                          \"binary\"    | \"minkowski\"   | \"bray-curtis\" |
                                          \"jacccard\"  | \"mahalanobis\" | \"sorensen\"    |
                                          \"difference\"

                            headers = 0 | 1                                          # default = 0, print headers in output_file
                            )\n"
               )
    stop("MGRAST_plot_pco stopped\n\n")
  }

  find_dist <- function(my_data, dist_method)
    {
      switch(dist_method,
             "euclidean" = dist(my_data, method = "euclidean"),
             "maximum" = dist(my_data, method = "maximum"),
             "manhattan" = dist(my_data, method = "manhattan"),
             "canberra" = dist(my_data, method = "canberra"),
             "binary" = dist(my_data, method = "binary"),
             "minkowski" = dist(my_data, method = "minkowski"),
             "bray-curtis" = distance(my_data, method = "bray-curtis"),
             "jaccard" = distance(my_data, method = "jaccard"),
             "mahalanobis" = distance(my_data, method = "mahalanobis"),
             "sorensen" = distance(my_data, method = "sorensen"),
             "difference" = distance(my_data, method = "difference")
             # unifrac
             # weighted_unifrac

             # distance methods with {stats}dist: dist(x, method = "euclidean", diag = FALSE, upper = FALSE, p = 2)
             #      euclidean maximum manhattan canberra binary minkowski

             # distance methods with {ecodist}distance: distance(x, method = "euclidean")
             #      euclidean bray-curtis manhattan mahalanobis jaccard "simple difference" sorensen

             )
    }

  # stop and give the usage if the proper number of arguments is not given
  if ( nargs() == 0 ){
    func_usage()
  }

  # load data
  {
    my_data <<- flipud(rot90(data.matrix(read.table(file_in, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))))
  }

  # calculate distance matrix
  dist_matrix <<- find_dist(my_data, dist_method)

  # perform the pco
  my_pco <<- pco(dist_matrix)

  # scale eigen values from 0 to 1, and label them
  eigen_values <<- my_pco$values
  scaled_eigen_values <<- (eigen_values/sum(eigen_values))
  for (i in (1:dim(as.matrix(scaled_eigen_values))[1])) {names(scaled_eigen_values)[i]<<-gsub(" ", "", paste("PCO", i))}
  scaled_eigen_values <<- data.matrix(scaled_eigen_values)
  #for (i in (1:dim(as.matrix(scaled_ev))[1])) dimnames(scaled_ev)[i]<<-gsub(" ", "", paste("PCO", i))

  # label the eigen vectors
  eigen_vectors <<- data.matrix(my_pco$vectors)
  dimnames(eigen_vectors)[[1]] <<- dimnames(my_data)[[1]]

  # write eigen values and then eigen vectors to file_out
  if ( headers == 1 ){
    write(file = file_out, paste("# file_in    :", file_in,
            "\n# dist_method:", dist_method,
            "\n#________________________________",
            "\n# EIGEN VALUES (scaled 0 to 1) >",
            "\n#________________________________"),
          append=FALSE)
    write.table(scaled_eigen_values,     file=file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")
  }else{
    write.table(scaled_eigen_values,     file=file_out, col.names=FALSE, row.names=TRUE, append = FALSE, sep="\t")
  }

  if ( headers == 1 ){
    write(file = file_out, paste("#________________________________",
            "\n# EIGEN VECTORS >",
            "\n#________________________________"),
          append=TRUE)
  }

  write.table(eigen_vectors, file=file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")

}


R0_calculateR <- function(estpar, fix_pars){
  alpha_p = fix_pars["alpha_p"]
  alpha_u = fix_pars["alpha_u"]
  beta_1 = fix_pars["beta_1"]
  beta_2 = fix_pars["beta_2"]
  delta_1 = fix_pars["delta_1"]
  delta_2 = fix_pars["delta_2"]
  lambda = fix_pars["lambda"]
  mu = fix_pars["mu"]
  mu_c = fix_pars["mu_c"]
  De = fix_pars["De"]
  Dr = fix_pars["Dr"]
  f = fix_pars["f"]
  N = fix_pars["N"]

  n_period = length(estpar)/2
  R0 = rep(0, n_period)

  for(i in 1:n_period){
    b = estpar[i]                 # values of beta for i_th period
    r = estpar[n_period + i]      # values of r for i_th period

    R0[i] = (b / (mu * De + 1)) * (alpha_u * (1 - r) / (1 / (beta_1 * Dr) + delta_1 * mu_c + mu)  +
                                   alpha_p * r * (1 - f) / (1 / Dr + mu_c + mu) +
                                   r * f / (beta_2 / Dr + mu_c / delta_2 + mu))
  }
  return(R0)
}


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 2.5C   Chapter : 2.5   Pageno : 88
# Inverse of the Pascal matrix by gauss jordan elimination method
library(pracma)
L<-matrix(c(1,1,1,1,0,1,2,3,0,0,1,3,0,0,0,1),ncol=4)
I<-eye(4)
LI<-cbind(L,I)
IL1<-rref(LI)
L1<-IL1[,c(5:8)]
print("Inverse of given Pascal matrix is")
print(L1)


phys <- c(15,  12,  8,   8,   7,   7,   7,   6,   5, 3)
# hist <- c(25,  17,  11,  13,  17,  20,  13,  9,   15)
hist <- c(10, 25,  17,  11,  13,  17,  20,  13,  9,   15) # how hard can it be to PROPERLY WRITE A FUCKING TASK?!

model = lm(formula = hist ~ phys, na.action = na.exclude)

newv <- data.frame(phys = 10)
vanga <- predict(model, newv, se.fit = T)
write(round(vanga$fit, 1), stdout())


<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: Pyhton Computing Language Code Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Import Libraries and Data

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

## Import Data
setwd("C:/Users/drewc/GitHub/HNB") # Set wd to project repository
df_fl = read.csv("_data/flcharts_50_stage.csv") # Import dataset from _data folder

### Step 2: Prepare Data for Classificaiton

## Tidy data types and objects
df_fl = df_fl %>% mutate_if(is.factor, as.numeric) # Change character to numeric values
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame
df_fl = subset(df_fl, select = -c(X.2, X.1, X)) # Remove variables with high missing values

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10

### Step 3: Develop Inequality Measures for Data

## Sort by mortality total
df_causes = subset(df_fl, select = -c(Tract, Total.Population, Pop.per.10000, Other.Non.rankable.Cause.of.Death)) # Remove variables with high missing values
df_sum = colSums(df_causes)
df_sum = as.data.frame(df_sum)
df_sum = rownames_to_column(df_sum) ## Invert Rows and Columns
colnames(df_sum) <- c("Cause", "Total") ## Change Column Names
df_sum = arrange(df_sum, desc(Total)) # Descend by variable in data frame
head(df_sum, 10)

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$Cancer = df_fl$Malignant.Neoplasm.or.Cancer

## Gini coefficient
gini_Metabolic = ineq(df_fl$Metabolic, type = "Gini")
gini_Vascular = ineq(df_fl$Vascular, type = "Gini")
gini_Cancer = ineq(df_fl$Cancer, type = "Gini")

## Sum
sum_Metabolic = sum(df_fl$Metabolic)
sum_Vascular = sum(df_fl$Vascular)
sum_Cancer = sum(df_fl$Cancer)

## Combine into Data Frame
df_topcause = data.frame("Cause" = c("Metabolic", "Vascular", "Cancer"), "Sum" = c(sum_Metabolic, sum_Vascular, sum_Cancer), "Gini" = c(gini_Metabolic, gini_Vascular, gini_Cancer))
print(df_topcause)

## Write Output to File
result = df_topcause # Save result df to variable
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Top Causes of Mortality",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Vascular",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Cancer

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Cancer",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Nephritis..Nephrotic.Syndrome..Nephrosis",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: Pyhton Computing Language Code Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Import Libraries and Data

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

## Import Data
setwd("C:/Users/drewc/GitHub/HNB") # Set wd to project repository
df_fl = read.csv("_data/flcharts_50_stage.csv") # Import dataset from _data folder

### Step 2: Prepare Data for Classificaiton

## Tidy data types and objects
df_fl = df_fl %>% mutate_if(is.factor, as.numeric) # Change character to numeric values
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame
df_fl = subset(df_fl, select = -c(X.2, X.1, X)) # Remove variables with high missing values

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10

### Step 3: Develop Inequality Measures for Data

## Sort by mortality total
df_causes = subset(df_fl, select = -c(Tract, Total.Population, Pop.per.10000, Other.Non.rankable.Cause.of.Death)) # Remove variables with high missing values
df_sum = colSums(df_causes)
df_sum = as.data.frame(df_sum)
df_sum = rownames_to_column(df_sum) ## Invert Rows and Columns
colnames(df_sum) <- c("Cause", "Total") ## Change Column Names
df_sum = arrange(df_sum, desc(Total)) # Descend by variable in data frame
head(df_sum, 10)

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$Cancer = df_fl$Malignant.Neoplasm.or.Cancer

## Gini coefficient
gini_Metabolic = ineq(df_fl$Metabolic, type = "Gini")
gini_Vascular = ineq(df_fl$Vascular, type = "Gini")
gini_Cancer = ineq(df_fl$Cancer, type = "Gini")

## Sum
sum_Metabolic = sum(df_fl$Metabolic)
sum_Vascular = sum(df_fl$Vascular)
sum_Cancer = sum(df_fl$Cancer)

## Combine into Data Frame
df_topcause = data.frame("Cause" = c("Metabolic", "Vascular", "Cancer"), "Sum" = c(sum_Metabolic, sum_Vascular, sum_Cancer), "Gini" = c(gini_Metabolic, gini_Vascular, gini_Cancer))
print(df_topcause)

## Write Output to File
result = df_topcause # Save result df to variable
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Top Causes of Mortality",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Vascular",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Cancer

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Cancer",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Nephritis..Nephrotic.Syndrome..Nephrosis",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db
close(file) # Close file


# V and beta supplied via graph.py script

V <- structure(c(3.19826308e-06, -1.28332733e-02,  1.28734322e+01, -1.28332733e-02,  5.14946331e+01, -5.16559253e+04, 1.28734322e+01, -5.16559253e+04,  5.18178740e+07
), .Dim = c(3L, 3L), .Dimnames = list(c("a0", "a1", "a2"), c("a0",
"a1", "a2")))

beta <- c(1.93057366e+05, -1.95738445e+02,  4.96009134e-02)
x <- seq(1993, 2100, by = 1)
X <- cbind(1, x, x ^ 2)
mu <- X %*% beta
# e <- sqrt( rowSums(X * (X %*% V)) )
# n <- 978
# lo <- mu + e * qt(0.025, n - 3)
# up <- mu - e * qt(0.025, n - 3)
# print(qnorm(.99999))

# e <-  1.644*(mu/sqrt(978))
# e <- qnorm(.95) *(mu/sqrt(978))
e <- 10 *(mu/sqrt(978))

lo <- mu + e
up <- mu - e

print(e)
print(n - 3)
print(mu)
print(lo)
print(up)
matplot(x, cbind(mu, lo, up), type = "l", col = 1, lty = c(1,2,2))
# matplot(x, cbind(mu), type = "l", col = 1, lty = c(1,2,2))


addfit <- function(xx, yy, col='black', interval='conf', alpha=0.05, sided=2, pch=1, vlines=NULL) {
    ## plot points
    points(xx, yy, pch=pch, col=col)

    ## put points in dataframe and remove any pairs that do not have values
    df <- na.omit( data.frame(xx,yy) )

    ## write points back out to xx and yy
    xx <- df$xx
    yy <- df$yy

    ## perform fit
    fit <- lm(yy~xx)
    intercept <- fit$coefficients[[1]]
    slope     <- fit$coefficients[[2]]

    ## add vertical lines to plot
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) abline(v=vlines, lty=3, col=col)

    ## add prediction to plot
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) {
        ## restrict fit to within vlines
        new.xx <- seq(min(vlines, na.rm=TRUE), max(vlines, na.rm=TRUE), len=100)
    } else {
        ## extend data to range of data
        new.xx <- seq(min(xx, na.rm=TRUE), max(xx, na.rm=TRUE), len=100)
    }
    if (interval == 'mean') {
        lines(new.xx, slope * new.xx + intercept, lwd=2, col=col)
    } else if (interval == 'line') {
        newdf <- data.frame(xx,yy)
        newdf <- newdf[order(newdf$xx),]
        xx <- newdf$xx
        yy <- newdf$yy
        lines(xx, yy, lwd=2, col=col)
    } else {
        pred   <- predict(fit, new=data.frame(xx=new.xx), interval=interval, level=1-alpha/sided)
        lines(new.xx, pred[,"fit"], lwd=2, col=col)
        lines(new.xx, pred[,"lwr"], lty=3, col=col)
        lines(new.xx, pred[,"upr"], lty=3, col=col)
    }

    ## print results of fit
    ## estbound(fit)

    ## calculate rise of fit over range bounds if supplied,
    ## otherwise calculate rise over range of data
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) {
        rise <- (vlines[2] - vlines[1]) * slope
    } else {
        rise <- (max(xx) - min(xx)) * slope
    }
    equation = paste0("y = ", signif(intercept,4), " + ", signif(slope,4), " * x; ",
                      expression(Delta), " = ", signif(rise,4))
    return(list(equation=equation, slope=slope, intercept=intercept, rise=rise))

}


#ANALIZA

#MODEL LOESS ZA NAPOVED EARNINGOV

morningstar_izbran<- filter(morningstar,Podatki=="Earnings Per Share USD")%>%
  select(Leto,Vrednost)
model_earning <-loess(dat=morningstar_izbran,
                      Vrednost~Leto,control=loess.control(surface="direct"))

loe_ear <- function(zeljena_leta){
  prihodnost_dobicek_na_delnico <- data.frame(Leto=c(zeljena_leta))
  napoved_dobicek_na_delnico <- prihodnost_dobicek_na_delnico %>%
    mutate(Vrednost=predict(model_earning,.))

  dobicek_na_delnico_graf <- ggplot(data=morningstar_izbran,
                                    aes(x=Leto,y=Vrednost,color="Dobiček na delnico"))+
    geom_smooth(method = "loess",formula = y~x,se=F) +
    geom_point(aes(color="Točne vrdednosti"))+
    geom_point(data=napoved_dobicek_na_delnico,
               aes(x=Leto,y=Vrednost,color="Napoved dobička za naprej"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Graf dobička na delnico po metodi loess")+
    scale_x_continuous(name = "Leto", breaks = seq(2011,2025,1))+
    scale_y_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(dobicek_na_delnico_graf)}

#MODEL NAPOVEDI EARNINGOV REGRESIJA

model_dobicek <- lm(data=morningstar_izbran,Vrednost ~ Leto) #ce klices ta model na fukcijo reg_pov ali opt_pov moras leta vnesti kot data frame

reg_ear<- function(zeljena_leta){
  prihodnost_dobicek <- data.frame(Leto=c(zeljena_leta))
  napoved_dobicek <- prihodnost_dobicek%>%
    mutate(Vrednost=predict(model_dobicek, .))

  premica_dobicek<-ggplot(morningstar_izbran,aes(x=Leto,y=Vrednost,
                                          color="Dobiček na delnico"))+
    geom_point(aes(color="Točne vrdednosti"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(data = napoved_dobicek,aes(x=Leto,y=Vrednost,
                                          color="Napoved dobička za naprej"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Graf dobička na delnico s pomočjo linearne regresije")+
    scale_x_continuous(name = "Leto", breaks = seq(2011,2025,1))+
    scale_y_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_dobicek)}

#REGRESIJA ZA POVEZAVO MED EARNINGI IN CENO

yah.mor <- right_join(morningstar_izbran,yahoo)
reg_pov <- function(prihodnost_dobicek_na_delnico,vrsta_modela){
  model_odvisnost1 <- lm(data=yah.mor,Najvisja_cena~Vrednost)
  prihodnost_povezava1 <- data.frame(Vrednost=c(predict(vrsta_modela,prihodnost_dobicek_na_delnico)))
  napoved_povezava1 <- prihodnost_povezava1%>%
    mutate(Najvisja_cena=predict(model_odvisnost1, .))

  premica_odvisnost<-ggplot(yah.mor,aes(x=Vrednost,y=Najvisja_cena,
                                        color="Približek za naše podatke"))+
    geom_point(aes(color="Točne vrednosti"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(data = napoved_povezava1,
               aes(x=Vrednost,y=Najvisja_cena,
                   color="Napoved cene preko dobička"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("green","red","black"))+
    labs(title="Napoved cene preko dobička s pomočjo linearne regresije")+
    scale_x_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    scale_y_continuous(name = "Cena (USD)", breaks = seq(0,140,10))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_odvisnost)}

#SKUPINE

cena.earning <- select(yah.mor,Vrednost,Najvisja_cena)
standardizacija <-as.matrix(cena.earning)%>%scale()
D <- dist(standardizacija)
model22 <- hclust(D)
cena.earning<-mutate(cena.earning,skupina=cutree(model22,k=2))

#OPT

opt_pov <- function(prihodnost_dobicek_na_delnico,vrsta_modela){
  model_opt <- lm(data=filter(cena.earning,skupina==1),
                  Najvisja_cena~Vrednost)
  prihodnost_opt <- data.frame(Vrednost=c(predict(vrsta_modela,prihodnost_dobicek_na_delnico)))
  napoved_opt<- prihodnost_opt%>%mutate(Najvisja_cena=predict(model_opt,.))

  premica_odvisnost_opt <- ggplot(filter(cena.earning,skupina==1),
                                  aes(x=Vrednost,y=Najvisja_cena,
                                      color="Izboljšan približek"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(aes(color="Točne vrdednosti"))+
    geom_point(data = napoved_opt,
               aes(x=Vrednost,y=Najvisja_cena,
                   color="Izboljšana napoved cene"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Izboljšana napoved cene preko dobička s pomočjo linearne regresije")+
    scale_x_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    scale_y_continuous(name = "Cena delnice (USD)", breaks = seq(0,110,5))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_odvisnost_opt)}


PATH <- '00_data/AUTOPREISE.CSV'

AP <- read.csv(PATH)
AP <- subset(AP, PREIS < 200000)

AP_FORMULA <- PREIS ~ KW + BESCHLEU + HOECHSTG + VERBR + HUBRAUM
AP_MODEL <- lm(AP_FORMULA, AP)
AP_STEP <- step(AP_MODEL)

summary(AP_MODEL)
summary(AP_STEP)

PREIS_PREDICTION <- predict(AP_MODEL, AP)
head(data.frame(AP$PREIS, PREIS_PREDICTION))

plot(AP$PREIS, PREIS_PREDICTION)
abline(y ~ x, coef = c(0, 1))


plotfit <- function(df, xx, yy, xlimspec=NULL, ylimspec=NULL, vlines=NULL,
                    main = 'equation', xlabel = NULL, ylabel = NULL,
                    interval='conf', alpha=0.05, sided=2, bg="grey90",
                    suppress='no') {
    ## create scatter plot with linear regression line and 95% confidence lines
    ## xx and yy are variables within dataframe df
    ## xlimspec and ylimspec can be used to force the range of the plot
    ## vlines will plot exactly two vertical lines at specified x locations
    ## main = 'equation'    # default is to print the fitted equation as the title
    ##      = 'your title'  # can specify title instead
    ## confidence or prediction limits
    ##     interval = 'conf' # confidence limits
    ##              = 'pred' # prediction limits
    ##              = 'none' # no limits added to plot
    ##     alpha    = 1 - confidence level
    ##     sided    = 2      # 2-sided interval
    ##              = 1      # 1-sided interval (currently plots upper and lower)
    ## bg controls the background color of the plot

    ## example usage: plotfit(df,hsub_in,power_ratio,ylimspec=c(0,1.1))
    ##                plotfit(mtcars, disp, mpg)
    ##                plotfit(mtcars, disp, mpg, vlines=c(100, 400))
    ##                plotfit(mtcars, disp, mpg, vlines=c(100, 400), interval='none')

    ## extract the names of xx and yy for plot axis labels if not defined
    if (missing(xlabel)) xlabel <- deparse(substitute(xx))
    if (missing(ylabel)) ylabel <- deparse(substitute(yy))

    ## extract xx and yy from df and create dataframe
    xx <- eval(substitute(xx),df)   # need to recognize name passed into function as xx
    yy <- eval(substitute(yy),df)   # need to recognize name passed into function as yy
    newdf <- data.frame(xx,yy)

    ## set min and max for plot if not specified
    xmin <- min(newdf$xx,na.rm=TRUE)
    xmax <- max(newdf$xx,na.rm=TRUE)
    ## xmax_plot <- xmax + (xmax-xmin)*1.2  # did this to make room for a legend
    ymin <- min(newdf$yy,na.rm=TRUE)
    ymax <- max(newdf$yy,na.rm=TRUE)
    if (missing(xlimspec)) { xlimspec <- c(xmin,xmax) }
    if (missing(ylimspec)) { ylimspec <- c(ymin,ymax) }

    ## change background of plot to specified color
    par(bg=bg)

    ## perform regrssion
    new.xx <- seq(min(newdf$xx,na.rm=TRUE),max(newdf$xx,na.rm=TRUE),len=100)
    fit <- lm(yy~xx,data=newdf)
    ## estbound(fit)
    pred   <- predict(fit, new=data.frame(xx=new.xx), interval=interval, level=1-0.05/sided)
    intercept <- fit$coefficients[[1]]
    slope <- fit$coefficients[[2]]

    ## plot points and fit
    if (main == 'equation') main = paste0("y = ", signif(intercept,4), "* x + ", signif(slope,4))
    plot(newdf$xx,newdf$yy,xlim=xlimspec,ylim=ylimspec,
         xlab=xlabel,ylab=ylabel,
         main=main)
    lines(new.xx,pred[,"fit"],lwd=1, col='red')

    ## if request confidence bounds, add to plot
    if (interval != 'none') {
        lines(new.xx,pred[,"lwr"],lty=3, col='red')
        lines(new.xx,pred[,"upr"],lty=3, col='red')
    }

    ## if request upper/lower range bounds, add to plot
    ## return rise of fit over range bounds if supplied, otherwise return rise over range of data
    if ( !is.null(vlines) ) {
        abline(v=vlines[1], col='black', lty='dashed')
        abline(v=vlines[2], col='black', lty='dashed')
        rise <- (vlines[2] - vlines[1]) * slope
    } else {
        rise <- (xmax - xmin) * slope
    }

    if (suppress != 'yes')
        return( list(intercept = intercept, slope = slope, rise = rise, pred = as_tibble(pred)) )

}


print(combn(0:4, 3))


rm(list=ls())

library(dplyr)
library(glmnet)

panel = read.table("../data/panel_chrom1.txt", header=F)
wsaf = read.table("../data/PG0402-C_chrom1.wsaf", header=F)$V1
myfit = glmnet( x = as.matrix(panel),
                y = wsaf,
                lambda = 1/seq(3, 5, length.out = 3),
#                lambda = 1/seq(2, 100, length.out = 3),
                type.gaussian = "naive",
                lower.limits= 0)

myfit = glmnet( x = as.matrix(panel), y = wsaf, lambda = 1/seq(3, 102, length.out = 100), type.gaussian = "naive",              lower.limits= 0)

panel = read.table("../data/panel_chrom1.txt", header=F)
wsaf = read.table("../data/PG0402-C_chrom1.wsaf", header=F)$V1
myfit = glmnet( x = as.matrix(panel), y = wsaf,  lambda = 1/seq(3, 5, length.out = 3),  type.gaussian = "naive", lower.limits= 0, maxit = 218)

x = as.matrix(panel)
y = (wsaf-mean(wsaf))/sd(wsaf)
abs(apply(x, 2, function(tmp){sum((tmp-mean(tmp))/sd(tmp)*y)}))

truex = cbind(rep(c(1,0),5), c(rep(1,5), rep(0,5)))
x = cbind(rnorm(10,truex[,1],.001), rnorm(10,truex[,2],.001))
y = 10*x[,1] + 5*x[,2]

write.table(truex, file="myX.txt", sep = "\t", row.names = F, col.names=F)
write.table(y, file="myy.txt", sep = "\t", row.names = F, col.names=F)

truex = as.matrix(read.table("../data/myX.txt", header=F))
y = read.table("../data/myy.txt", header=F)$V1
myfit = glmnet( x = truex,
                y = y,
                lambda = 1/seq(3, 5, length.out = 3),
#                lambda = 1/seq(2, 100, length.out = 3),
                type.gaussian = "naive",
                lower.limits= 0)

lm(y~truex)
normalized_x = matrix(myfit$xx, length(y), length(myfit$xx)/length(y), byrow=F)
normalized_y = myfit$yy

print(normalized_y[1:10], digits=4)
print(normalized_x[1:10,], digits=4)

myfit = glmnet( x = truex,
                y = y,
                lambda = 1/seq(3, 5, length.out = 3),
#                lambda = 1/seq(2, 100, length.out = 3),
                type.gaussian = "naive",
                lower.limits= 0)

myfit = glmnet( x = truex, y = y,lambda = 1/seq(3, 5, length.out = 3), type.gaussian = "naive", lower.limits= 0, maxit=1)

myfit = glmnet( x = truex,
                y = y,
                lambda = 1/seq(3, 5, length.out = 3),
#                lambda = 1/seq(2, 100, length.out = 3),
                type.gaussian = "naive",
                lower.limits= 0, maxit = 4)

lambdas = 1/seq(2, 100, length.out = 100)
results = list()
for ( i in 1:100 ){
    results[[i]] = admm.lasso(as.matrix(cbind(0,panel)),wsaf, lambdas[i])
}

a = admm.lasso(as.matrix(cbind(0,panel)),wsaf, 0.5)
# first index is for the intercept

which(results[100][[1]]$x > 0.01)
 [1] 13 21 25 27 30 38 62 69 76 88 92
> which(myfit$beta[,100] > 0.01)
V13 V21 V27 V62 V67 V88 V92
 13  21  27  62  67  88  92

y = wsaf
ybar = mean(y)
nulldev = sum((y - ybar)^2)

idx = 100
ytmp = myfit$a0[idx] + as.matrix(panel) %*% as.numeric(myfit$beta[,idx])

1 - sum((y - ytmp)^2)/nulldev

myfit$dev.ratio[idx]

ytmp = as.matrix(cbind(0,panel)) %*% a$x
1 - sum((y - ytmp)^2)/nulldev

######################### Normalizing y #######################
y = wsaf
w = rep(1, length(wsaf))
w=w/sum(w)
v=sqrt(w)

ym=sum(w*y)
y=v*(y-ym)
ys=sqrt(sum(y*y))
y=y/ys

####### my calculation
ym = mean(wsaf)
ytmp = (wsaf - ym)
ytmp / sqrt(sum(ytmp^2))

########################## Normalizing x #####################

#10710 do 10711 j=1,ni
#            if(ju(j).eq.0)goto 10711
#            xm(j)=dot_product(w,x(:,j))
#            x(:,j)=v*(x(:,j)-xm(j))
#            xv(j)=dot_product(x(:,j),x(:,j))
#            if(isd.gt.0) xs(j)=sqrt(xv(j))
#      10711 continue
#      10712 continue

#      if(isd .ne. 0)goto 10731
#            xs=1.0
#            goto 10741
#      10731 continue

#      10750 do 10751 j=1,ni
#            if(ju(j).eq.0)goto 10751
#            x(:,j)=x(:,j)/xs(j)
#      10751 continue
#      10752 continue
#            xv=1.0
#      10741 continue
#10721 continue


# boxplots for the playability attribute in the weatherr data:
# one with outlying values identified
par(mfrow=c(1, 2))
boxplot(weatherr$playability, range=0.5, col="grey", main="playability")
boxplot(playability~outlook, weatherr, col="grey", main="playability")

#histograms
#Two histograms for the playability attribute in the weatherr data are produced by
#the following R code: one displaying occurrence counts
#and the other displaying relative frequencies for the same set of nonequal-weight intervals
par(mfrow=c(1, 2))
hist(weatherr$playability, breaks=c(0.3, 0.4, 0.5, 0.7, 0.9), probability=FALSE,
     col="grey", main="")
hist(weatherr$playability, breaks=c(0.3, 0.4, 0.5, 0.7, 0.9), probability=TRUE,
     col="grey", main="")

#artificial barplot illustration using the weatherr data

par(mar=c(7, 4, 4, 2))
barplot(`names<-`(ave(weatherr$playability, weatherr$outlook, weatherr$wind),
                  interaction(weatherr$outlook, weatherr$wind)),
        las=2, main="Mean playability in outlook-wind subsets")
lines(c(0, 17), rep(mean(weatherr$playability), 2), lty=2)


a1<-c(10,3,8,9,6,5,4,2,1,7)
a2<-c(3,9,7,5,4,2,6,8,1,10)
a3<-c(4,2,3,1,7,5,6,9,8,10)
a4<-c(6,4,3,10,7,8,5,9,1,2)
a5<-c(9,6,8,5,1,4,7,2,3,10)
a6<-c(10,1,4,6,9,2,7,3,8,5)
d1<-c(1,1,1,0,0,0,1,0,1,1)
d2<-c(0,1,1,1,0,1,1,1,0,1)
d3<-c(0,0,1,1,0,0,1,0,0,0)
d4<-c(0,1,0,0,0,1,1,1,0,1)
a<-t(matrix(c(t(a1),t(a2),t(a3),t(a4),t(a5),t(a6)),10,6))
d<-t(matrix(c(t(d1),t(d2),t(d3),t(d4)),10,4))
m<-matrix(0,24,10)
for(i in 1:6){
    for(k in 1:4){
    	dd<-d[k,]
       	t=4*i-4+k
    	m[t,]<-dd[a[i,]]
    }
}


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

ncores <- 16
n <- 512; m <- 10; lengthtau <- 1024; lengthtest <- 1e4;
v_taus <- seq(0.001, 0.999, length.out = lengthtau)
k1 <- 11; ktau <- 2; m1 <- 4; mtau <- 3
v_k <- c(ktau, k1); v_m <- c(mtau, m1); v_dim <- v_k + v_m

quantile_regession <- function(x, y, constr, taus = v_taus) {
    fit_quanreg <- list()
    for (i in seq_along(taus)) {
        tau <- taus[i]
        fit_quanreg[[i]] <- rqss(y ~ qss(x, constraint = constr), tau = tau, data = data.frame(x, y))
    }
    return(fit_quanreg)
}

# compare functions(increasing in x & no constraint)
compare_incr <- function(m = 20, taus = v_taus, ...) {
    # L2 loss
    L2loss <- matrix(rep(0, length(taus) * 5), nrow = 5)
    colnames(L2loss) <- taus
    rownames(L2loss) <- c("quantile_sheet(gam)", "quantile sheets(scam)",
                        "cq_reg", "quantreg",  "quantregGrowth")
    # time
    m_time <- matrix(rep(0, 3 * 5), nrow = 5)
    rownames(m_time) <- rownames(L2loss)

    for (j in seq(m)) {
        #train
        x <- runif(n); ord <- order(x)
        x <- x[ord]
        y <- obs_f(x, ...)
        # test
        test_x <- seq(min(x), max(x), length.out = lengthtest)
        #quantile sheets
        m_time[1, ] <- m_time[1, ] + system.time(gam_fit <- qs_gam(x, y,
                maxit = 50, ntaus = 10,
                dims = v_dim, ords = NA,
                sp = NULL, tol = 1e-3))[1:3]
        m_time[2, ] <- m_time[2, ] + system.time(scam_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tedmi", "cr"),
                    opt = "nlm.fd", dims = v_dim))[1:3]
        # cq.reg
        m_time[3, ] <- m_time[3, ] + system.time(cq_fit <- cq.reg(x, y,
                    arg_bs = c("tedmi", "cr"), opt = "bfgs",
                    dims = v_dim, span = 0.05))[1:3]
        # quantreg
        m_time[4, ] <- m_time[4, ] + system.time(quan_fit <- quantile_regession(x, y, "I"))[1:3]
        # quantregGrowth non-crossing+ monotone
        m_time[5, ] <- m_time[5, ] + system.time(fit_wp <-  gcrq(y ~ ps(x, monotone = 1),
                tau = taus, data = data.frame(x, y)))[1:3]
        test_fit <- predict(fit_wp, data.frame(x = test_x))

        for (i in seq_along(taus)) {
            tau <- taus[i]
            truth <- truth_f(test_x, tau, ...)
            L2loss[1, i] <- L2loss[1, i] + mean((c(predict(gam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[2, i] <- L2loss[2, i] + mean((c(predict(scam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[3, i] <- L2loss[3, i] + mean((predict(cq_fit, data.frame(x1 = test_x, tau = tau)) - truth)^2)
            L2loss[4, i] <- L2loss[4, i] + mean((predict(quan_fit[[i]], data.frame(x = test_x)) - truth)^2)
            L2loss[5, i] <- L2loss[5, i] + mean((test_fit[, i] - truth)^2)
        }
    }

    list(L2loss = L2loss / m,
        time = m_time / m,
        model = list(gam_fit, scam_fit,
        cq_fit, quan_fit, fit_wp))
}
compare_no <- function(m = 20, taus = v_taus, ...) {
    # L2 loss
    L2loss <- matrix(rep(0, length(taus) * 5), nrow = 5)
    colnames(L2loss) <- taus
    rownames(L2loss) <- c("quantile_sheet(gam)", "quantile sheets(scam)",
                        "cq_reg", "quantreg",  "quantregGrowth")
    # time
    m_time <- matrix(rep(0, 3 * 5), nrow = 5)
    rownames(m_time) <- rownames(L2loss)
    for (j in seq(m)) {
        #data set
        x <- sort(runif(n))
        y <- obs_f(x, ...)
        # test
        test_x <- seq(min(x), max(x), length.out = lengthtest)
        #quantile sheets
        m_time[1, ] <- m_time[1, ] + system.time(gam_fit <- qs_gam(x, y,
                maxit = 50, ntaus = 10,
                dims = v_dim, ords = NA,
                sp = NULL, tol = 1e-3))[1:3]
        m_time[2, ] <- m_time[2, ] + system.time(scam_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "nlm.fd", dims = v_dim))[1:3]
        # cq.reg
        m_time[3, ] <- m_time[3, ] + system.time(cq_fit <- cq.reg(x, y,
                    arg_bs = c("tesmi1", "cr"), opt = "bfgs",
                    dims = v_dim, span = 0.05))[1:3]
        # quantreg
        m_time[4, ] <- m_time[4, ] + system.time(
                    quan_fit <- quantile_regession(x, y, "N"))[1:3]
        # quantregGrowth non-crossing+ monotone
        m_time[5, ] <- m_time[5, ] + system.time(fit_wp <-  gcrq(y ~ ps(x),
                tau = taus, data = data.frame(x, y)))[1:3]
        test_fit <- predict(fit_wp, data.frame(x = test_x))

        for (i in seq_along(taus)) {
            tau <- taus[i]
            truth <- truth_f(test_x, tau, ...)
            L2loss[1, i] <- L2loss[1, i] + mean((c(predict(gam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[2, i] <- L2loss[2, i] + mean((c(predict(scam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[3, i] <- L2loss[3, i] + mean((c(predict(cq_fit, data.frame(x1 = test_x, tau = tau))) - truth)^2)
            L2loss[4, i] <- L2loss[4, i] + mean((predict(quan_fit[[i]], data.frame(x = test_x)) - truth)^2)
            L2loss[5, i] <- L2loss[5, i] + mean((test_fit[, i] - truth)^2)
        }
    }

    list(L2loss = L2loss / m,
        time = m_time / m,
        model = list(gam_fit, scam_fit,
        cq_fit, quan_fit, fit_wp))
}
# comp <- compare_no(1, gmean = "linear", xsig = "linear", derr = "t3")
# comp <- compare_no(1, gmean = "sqrtsin", xsig = "quad", derr = "chisq3")

v_gmean <- c("linear", "log", "sin", "lsin", "sqrtsin")
v_xsig <- c("const", "linear", "quad")
v_derr <- c("norm", "chisq3", "t3", "t1")

comp <- mclapply(v_gmean, gmean_loop <- function(gmean) {
    mclapply(v_xsig, xsig_loop <- function(xsig) {
        mclapply(v_derr, derr_loop <- function(derr) {
            compare_no(m, gmean = gmean, xsig = xsig, derr = derr)
        }, mc.cores = ncores)
    }, mc.cores = ncores)
}, mc.cores = ncores)

save(comp, file = "sim_compare.RData")


### fimd2.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 7mar2012
### Version 2, 4nov2015
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.11

### Chapter 2 Multiple imputation

library("mice")
library("lattice")
library("MASS")

### Section 2.1.3 The expanding literature on multiple imputation
### Figure 2.1

cit  <- c(     2010, 37, 182, NA,
               2009, 36, 129, NA,
               2008, 27, 111, NA,
               2007, 35, 136, NA,
               2006, 18, 80, NA,
               2005, 20, 76, NA,
               2004,  6, 56, NA,
               2003, 17, 42, NA,
               2002, 14, 40, NA,
               2001, 13, 36, 57,
               2000,  8, 21, 33,
               1999,  6, 25, 47,
               1998, 6, 13, 22,
               1997, 6, 18, 29,
               1996, 4, 12, 28,
               1995, 3, 5, 20,
               1994, 2, 5, 34,
               1993, 2, 6, 15,
               1991, 2, 4, 19,
               1990, 1, 2, 15,
               1989, NA, NA, 11,
               1988, 1, NA, 13,
               1987, NA, NA, 10,
               1986, NA, NA, 5,
               1985, NA, NA, 1,
               1984, NA, NA, 2,
               1983, NA, NA, 5,
               1982, NA, NA, 2,
               1981, NA, NA, 1,
               1980, NA, NA, 5,
               1979, NA, NA, 2,
               1978, NA, NA, 1,
               1977, NA, NA, 2)
cit <- matrix(cit, nr=2010-1977, nc=4, byrow=TRUE)
cit <- as.data.frame(cit)
names(cit) <- c("Year","Title","Abstract","All")
par(mfrow=c(1,1))
par(cex=0.7, lwd=0.5)
plot(x=cit$Year, y=cit$Abstract, type="o",log="y",
     xlim=c(1975,2010),ylim=c(1,200),
     ylab="Number of publications (log)", xlab="Year", pch=2,
     axes=FALSE)
axis(1, lwd=par("lwd"))
axis(2, lwd=par("lwd"), las=1)
# box(lwd=0.5)
lines(x=cit$Year, y=cit$Title, pch=15, type="o")
lines(x=cit$Year, y=cit$All, pch=16, type="o")
legend(x=1975,y=200,legend=c("early publications",
                            "'multiple imputation' in abstract",
                            "'multiple imputation' in title"),
       pch=c(16,2,15), bty="n")

### Section 2.2.4 MCAR, MAR and MNAR again

logistic <- function(x) exp(x)/(1+exp(x))
set.seed(80122)
n <- 300
y <- mvrnorm(n=n,mu=c(0,0),Sigma=matrix(c(1,0.5,0.5,1),nrow=2))
y1 <- y[,1]
y2 <- y[,2]
r2.mcar <- 1-rbinom(n, 1, 0.5)
r2.mar  <- 1-rbinom(n, 1, logistic(y1))
r2.mnar <- 1-rbinom(n, 1, logistic(y2))

### Figure 2.2

y3 <- rbind(y,y,y)
r2 <- c(r2.mcar,r2.mar,r2.mnar)
r2 <- factor(r2, labels=c("Ymis","Yobs"))
typ <- factor(rep(3:1,each=n),labels=c("MNAR","MAR","MCAR"))
d <- data.frame(y1=y3[,1],y2=y3[,2],r2=r2,typ=typ)
trellis.par.set(box.rectangle=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(box.umbrella=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(plot.symbol=list(col=mdc(3),lwd=1))
tp <- bwplot(r2~y2|typ, data=d,
             horizontal=TRUE, layout=c(1,3),
             xlab=expression(Y^2),
             col=c(mdc(2),mdc(1)),strip=FALSE, xlim=c(-3,3),
             strip.left = strip.custom(bg="grey95"))
print(tp)

### Section 2.3.7 Numerical example
options(digits=3)
imp <- mice(nhanes, print=FALSE, m=10, seed=24415)
fit <- with(imp, lm(bmi~age))
est <- pool(fit)
names(est)
attach(est)
(r+2/(df+3))/(r+1)
(df+1)/(df+3)*lambda+2/(df+3)
detach(est)


## 1. Analyzing New York City Public Schools Data ##

library(readr)
library(dplyr)
combined <- read_csv("combined.csv")

combined <- combined %>%
  select(-SchoolName, -`SCHOOL NAME.y`, -Name, -`School Name`, -school_name, -`Location 1`) %>%
  rename(school_name = `SCHOOL NAME.x`)

## 2. Visualizing Relationships Between Variables Using Scatter Plots ##

library(ggplot2)
ggplot(data = combined,
  aes(x = frl_percent, y = avg_sat_score)) +
  geom_point()

ggplot(data = combined,
  aes(x = ell_percent, y = avg_sat_score)) +
  geom_point()

ggplot(data = combined,
  aes(x = sped_percent, y = avg_sat_score)) +
  geom_point()

## 4. Pivoting a Dataframe into a Longer One ##

combined_race_longer <- combined %>%
  pivot_longer(cols = asian_per:white_per,
               names_to = "race",
               values_to = "percent")

ggplot(data = combined_race_longer,
  aes(x = percent, y = avg_sat_score, color = race)) +
  geom_point()

## 7. Correlation Analysis: Measuring the Strength of Relationships Between Variables ##

round(cor(combined$avg_sat_score, combined$asian_per, use = "pairwise.complete.obs"),7)

## 8. Creating and Interpreting Correlation Matrices ##

cor_mat <- combined %>%
  select_if(is.numeric) %>%
  cor(use = "pairwise.complete.obs")

## 9. Identifying Interesting Relationships ##

cor_tib <- cor_mat %>%
  as_tibble(rownames = "variable")
apscore_cors <- cor_tib %>%
  select(variable, high_score_percent) %>%
  filter(high_score_percent > 0.25 | high_score_percent < -0.25)

Data Analyst in R/Step 3 - Data Cleaning in R/1. Data Cleaning in R/3. Correlations and Reshaping Data.r


#################################################################################
#
# Mark Cembrowski, Janelia Research Campus, Apr 7 2015
#
# This looks for the number of genes enriched in CA2 relative to the rest of the
# principal cells of the hippocampus.
#
#################################################################################

ca2EnrichVsFold <- function(fpkmThres=10){

	theFolds <- c(2:10)
	df <- as.data.frame(matrix(nrow=theFolds,ncol=1))
	for (ii in 1:length(theFolds)){
		numCa2Enrich <- length(enrichedGenes('ca2',fpkmThres=fpkmThres,
			foldThres=theFolds[ii],avgPass=T))
		df[ii,] <- numCa2Enrich
	}

	df <- cbind(theFolds,df)
	colnames(df) <- c('theFolds','total')

	print(df)

	# Plot.
	gg <- ggplot(df,aes(x=theFolds))
	gg <- gg + geom_line(aes(y=total),colour='black')
	gg <- gg + theme_bw()
	gg <- gg + expand_limits(y=0)
	gg <- gg + xlab('Fold difference') + ylab('Number of genes')
	print(gg)

	invisible(gg)
}


largura = 50
altura = 50
img = matrix(0, nrow=altura, ncol=largura)

cantos = c(0, 1, 0.5, 0.3)

for(i in seq(1, altura)) {
  for(j in seq(1, largura)) {
    #preencher com interpolação bilinear
  }
}

image(t(img), col=grey(seq(0,1,length=256)))