# Synthetic Data Project
# Differential private algorithm using beta, binomial, and Laplace probabilities

# Authors:
# Version:  5/14/2017

# Copyright 2017

# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
# associated documentation files (the "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the
# following conditions:

# The above copyright notice and this permission notice shall be included in all copies or substantial
# portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

# import Laplace distribution functions
sys.source("LaplaceDistribution.r", env=environment())

#####################################################################################
#### DP algorithm
#####################################################################################

DP.threshold <- function (S, M, epsilon, alpha, nIter=250000) {

  ### add random Laplace noise to S
  ### note that this converts S to a real number
  ### since the Laplace distribution (double exponential) is symmetric about 0,
  ### nS maybe greater than or less than S
  ### also, nS can be negative or greater than M
  nS <- S + rlaplace(1, 0, 1/epsilon)

  ### Range of S
  RangeS <- 0:M

  ### Initial value of p
  ### shape parameters of (1, 1) correspond to the uniform(0, 1) distribution
  ### use supplied initial shape parameters
  ### p = rbeta(1, alpha[1], alpha[2])
  ### note that E[rbeta(n, shape1, shape2)] = shape1/(shape1+shape2)
  ### use of rbeta(1, S, M-S) would give a theoretical mean p of S/M,
  ### but S=0 requires rbeta() to return 0, in order to satisfy a mean value of 0.00
  ### once a supplied or randomly generated value of S becomes 0, all subsequent
  ### p and S values are 0
  ### similarly, S=50 requires rbeta() mean of 1.00, once supplied or generated S=50,
  ### all subsequent S values are 50
  ### adding initial beta parameters prevents expected value numerators of zero and
  ### gives mean of (S+alpha1)/(S+alpha1+alpha2) for S=M and should be unequal to 1.00
  p <- rbeta(1, S+alpha[1], M-S+alpha[2])

  ### generate Laplace density (using random nS) for each centrality value in 0:M
  dslap <- dlaplace(RangeS, nS, 1/epsilon)

  ### Gibbs interaction
  f.iter <- function(j) {
    # update S
    # product of binomial mass (using curent p) and Laplace density for each 0:M
    prob <- dbinom(RangeS, M, prob=p)*dslap
    # randomly select one S in 0:M
    # selection weights are probability products for each 0:M
    S <- sample(RangeS, 1, prob=prob)
    # update p
    # note that E(p) = (shape par 1)/(shape par 1 + shape par 2)
    # = (alpha[1]+S)/(alpha[1]+S + alpha[2]+M-S)
    # = (alpha[1]+S)/(alpha[1]+alpha[2]+M)
    # variance = ab/((a+b)^2*(a+b+1)), where a=shape par 1, b=shape par 2
    p <<- rbeta(1, S+alpha[1], M-S+alpha[2])
  }

  ### iterate MCMC and return all but first 1,000 generated values
  if(nIter<10000)
    nIter <- 10000
  sapply(1:nIter, f.iter)[1001:nIter]

}


                                   CCHHAAPPTTEERR  33

                              AArriitthhmmeettiicc FFuunnccttiioonnss

               This chapter describes FRANZ LISP's functions for doing
          arithmetic.  Often the same function is known by many names.
          For  example,  _a_d_d is also _p_l_u_s, and _s_u_m.  This is caused by
          our desire to be compatible with  other  Lisps.   The  FRANZ
          LISP  user should avoid using functions with names such as +
          and * unless their arguments are fixnums.  The Lisp compiler
          takes advantage of these implicit declarations.

               An  attempt  to  divide or to generate a floating point
          result outside of the range of floating point  numbers  will
          cause  a  floating  exception signal from the UNIX operating
          system.  The user can catch and process  this  interrupt  if
          desired (see the description of the _s_i_g_n_a_l function).

             33..11..  SSiimmppllee AArriitthhmmeettiicc FFuunnccttiioonnss

          ((aadddd ['n_arg1 ...]))
          ((pplluuss ['n_arg1 ...]))
          ((ssuumm ['n_arg1 ...]))
          ((++ ['x_arg1 ...]))

               RETURNS: the  sum of the arguments. If no arguments are
                        given, 0 is returned.

               NOTE: if the size of the partial sum exceeds the  limit
                     of a fixnum, the partial sum will be converted to
                     a bignum.  If any of the arguments  are  flonums,
                     the  partial  sum  will  be converted to a flonum
                     when that argument is processed  and  the  result
                     will thus be a flonum.  Currently, if in the pro-
                     cess of doing the addition a bignum must be  con-
                     verted  into  a  flonum  an  error  message  will
                     result.

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--11

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--22

          ((aadddd11 'n_arg))
          ((11++ 'x_arg))

               RETURNS: its argument plus 1.

          ((ddiiffff ['n_arg1 ... ]))
          ((ddiiffffeerreennccee ['n_arg1 ... ]))
          ((-- ['x_arg1 ... ]))

               RETURNS: the result of subtracting from n_arg1 all sub-
                        sequent arguments.  If no arguments are given,
                        0 is returned.

               NOTE: See the description of add for  details  on  data
                     type conversions and restrictions.

          ((ssuubb11 'n_arg))
          ((11-- 'x_arg))

               RETURNS: its argument minus 1.

          ((mmiinnuuss 'n_arg))

               RETURNS: zero minus n_arg.

          ((pprroodduucctt ['n_arg1 ... ]))
          ((ttiimmeess ['n_arg1 ... ]))
          ((** ['x_arg1 ... ]))

               RETURNS: the  product  of  all  of  its  arguments.  It
                        returns 1 if there are no arguments.

               NOTE: See the  description  of  the  function  _a_d_d  for
                     details  and  restrictions  to the automatic data
                     type coercion.

          ((qquuoottiieenntt ['n_arg1 ...]))
          ((// ['x_arg1 ...]))

               RETURNS: the result of dividing the first  argument  by
                        succeeding ones.

               NOTE: If  there  are  no arguments, 1 is returned.  See
                     the description of the function _a_d_d  for  details
                     and restrictions of data type coercion.  A divide
                     by zero will cause a floating exception interrupt
                     -- see the description of the _s_i_g_n_a_l function.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--33

          ((**qquuoo 'i_x 'i_y))

               RETURNS: the integer part of i_x / i_y.

          ((DDiivviiddee 'i_dividend 'i_divisor))

               RETURNS: a  list  whose  car  is the quotient and whose
                        cadr is  the  remainder  of  the  division  of
                        i_dividend by i_divisor.

               NOTE: this is restricted to integer division.

          ((EEmmuullddiivv 'x_fact1 'x_fact2 'x_addn 'x_divisor))

               RETURNS: a  list  of the quotient and remainder of this
                        operation:
                        ((x_fact1 * x_fact2) + (sign extended) x_addn) / x_divisor.

               NOTE: this is useful for creating a  bignum  arithmetic
                     package in Lisp.

             33..22..  pprreeddiiccaatteess

          ((nnuummbbeerrpp 'g_arg))

          ((nnuummbbpp 'g_arg))

               RETURNS: t  iff  g_arg  is  a number (fixnum, flonum or
                        bignum).

          ((ffiixxpp 'g_arg))

               RETURNS: t iff g_arg is a fixnum or bignum.

          ((ffllooaattpp 'g_arg))

               RETURNS: t iff g_arg is a flonum.

          ((eevveennpp 'x_arg))

               RETURNS: t iff x_arg is even.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--44

          ((ooddddpp 'x_arg))

               RETURNS: t iff x_arg is odd.

          ((zzeerroopp 'g_arg))

               RETURNS: t iff g_arg is a number equal to 0.

          ((oonneepp 'g_arg))

               RETURNS: t iff g_arg is a number equal to 1.

          ((pplluusspp 'n_arg))

               RETURNS: t iff n_arg is greater than zero.

          ((mmiinnuusspp 'g_arg))

               RETURNS: t iff g_arg is a negative number.

          ((ggrreeaatteerrpp ['n_arg1 ...]))
          ((>> 'fx_arg1 'fx_arg2))
          ((>>&& 'x_arg1 'x_arg2))

               RETURNS: t iff the arguments are in a strictly decreas-
                        ing order.

               NOTE: In  functions _g_r_e_a_t_e_r_p and _> the function _d_i_f_f_e_r_-
                     _e_n_c_e is used to compare adjacent values.  If  any
                     of  the arguments are non-numbers, the error mes-
                     sage will come from the _d_i_f_f_e_r_e_n_c_e function.  The
                     arguments  to _> must  be fixnums or both flonums.
                     The arguments to _>_& must both be fixnums.

          ((lleesssspp ['n_arg1 ...]))
          ((<< 'fx_arg1 'fx_arg2))
          ((<<&& 'x_arg1 'x_arg2))

               RETURNS: t iff the arguments are in a strictly increas-
                        ing order.

               NOTE: In  functions _l_e_s_s_p and _< the function _d_i_f_f_e_r_e_n_c_e
                     is used to compare adjacent values.   If  any  of
                     the  arguments are non numbers, the error message
                     will come  from  the  _d_i_f_f_e_r_e_n_c_e  function.   The
                     arguments  to  _< may be either fixnums or flonums
                     but must be the same type.  The arguments  to  _<_&
                     must be fixnums.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--55

          ((== 'fx_arg1 'fx_arg2))

          ((==&& 'x_arg1 'x_arg2))

               RETURNS: t  iff the arguments have the same value.  The
                        arguments to = must be the either both fixnums
                        or  both flonums.  The arguments to =& must be
                        fixnums.

             33..33..  TTrriiggnnoommeettrriicc FFuunnccttiioonnss

                     Some of these funtcions are taken from  the  host
                math  library,  and  we take no further responsibility
                for their accuracy.

          ((ccooss 'fx_angle))

               RETURNS: the (flonum)  cosine  of  fx_angle  (which  is
                        assumed to be in radians).

          ((ssiinn 'fx_angle))

               RETURNS: the  sine  of fx_angle (which is assumed to be
                        in radians).

          ((aaccooss 'fx_arg))

               RETURNS: the (flonum) arc cosine of fx_arg in the range
                        0 to -n.

          ((aassiinn 'fx_arg))

               RETURNS: the  (flonum)  arc sine of fx_arg in the range
                        --n/2 to -n/2.

          ((aattaann 'fx_arg1 'fx_arg2))

               RETURNS: the (flonum) arc tangent of fx_arg1/fx_arg2 in
                        the range --n to -n.

             33..44..  BBiiggnnuumm//FFiixxnnuumm MMaanniippuullaattiioonn

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--66

          ((hhaaiippaarrtt bx_number x_bits))

               RETURNS: a fixnum (or bignum) which contains the x_bits
                        high bits of _(_a_b_s _b_x___n_u_m_b_e_r_) if x_bits is pos-
                        itive,  otherwise  it returns the _(_a_b_s _x___b_i_t_s_)
                        low bits of _(_a_b_s _b_x___n_u_m_b_e_r_).

          ((hhaauulloonngg bx_number))

               RETURNS: the number of significant bits in bx_number.

               NOTE: the result is equal to the least integer  greater
                     to or equal to the base two logarithm of one plus
                     the absolute value of bx_number.

          ((bbiiggnnuumm--lleeffttsshhiifftt bx_arg x_amount))

               RETURNS: bx_arg shifted left by x_amount.  If  x_amount
                        is  negative,  bx_arg will be shifted right by
                        the magnitude of x_amount.

               NOTE: If bx_arg is shifted right, it will be rounded to
                     the nearest even number.

          ((ssttiicckkyy--bbiiggnnuumm--lleeffttsshhiifftt 'bx_arg 'x_amount))

               RETURNS: bx_arg  shifted left by x_amount.  If x_amount
                        is negative, bx_arg will be shifted  right  by
                        the magnitude of x_amount and rounded.

               NOTE: sticky rounding is done this way: after shifting,
                     the low order bit is changed to 1 if any 1's were
                     shifted off to the right.

             33..55..  BBiitt MMaanniippuullaattiioonn

          ((bboooollee 'x_key 'x_v1 'x_v2 ...))

               RETURNS: the result of the bitwise boolean operation as
                        described in the following table.

               NOTE: If there are more than 3 arguments, then  evalua-
                     tion  proceeds  left  to  right with each partial
                     result becoming the new value of x_v1.  That is,
                          _(_b_o_o_l_e _'_k_e_y _'_v_1 _'_v_2 _'_v_3_) _=_= _(_b_o_o_l_e _'_k_e_y _(_b_o_o_l_e _'_k_e_y _'_v_1 _'_v_2_) _'_v_3_).
                     In the following table, * represents bitwise and,
                     + represents bitwise or, O+ represents bitwise xor
                     and  ~  represents  bitwise  negation  and is the
                     highest precedence operator.

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--77

          +-------------------------------------------------------------------------------------------+
          |                                    (boole 'key 'x 'y)                                     |
          |                                                                                |
          +-------------------------------------------------------------------------------------------+
          | key         0          1          2         3         4          5          6         7   |
          |result       0        x * y     ~ x * y      y      x * ~ y       x        x O+ y     x + y |
          |                                                                                |
          |common                                                                                |
          |names                  and                          bitclear                xor       or   |
          |                                                                                |
          +-------------------------------------------------------------------------------------------+
          |                                                                                |
          | key         8          9         10        11         12        13         14        15   |
          |result   ~ (x + y)   ~(x O+ y)     ~ x     ~ x + y     ~ y      x + ~ y   ~ x + ~ y    -1   |
          |common                                                                                |
          |names       nor       equiv               implies                          nand            |
          +-------------------------------------------------------------------------------------------+

          ((llsshh 'x_val 'x_amt))

               RETURNS: x_val shifted left by x_amt if x_amt is  posi-
                        tive.   If x_amt is negative, then _l_s_h returns
                        x_val shifted right by the magnitude if x_amt.

               NOTE: This  always returns a fixnum even for those num-
                     bers whose magnitude is so large that they  would
                     normally be represented as a bignum, i.e. shifter
                     bits are lost.  For more  general  bit  shifters,
                     see _b_i_g_n_u_m_-_l_e_f_t_s_h_i_f_t and _s_t_i_c_k_y_-_b_i_g_n_u_m_-_l_e_f_t_s_h_i_f_t_.

          ((rroott 'x_val 'x_amt))

               RETURNS: x_val rotated left by x_amt if x_amt is  posi-
                        tive.   If  x_amt  is  negative, then x_val is
                        rotated right by the magnitude of x_amt.

             33..66..  OOtthheerr FFuunnccttiioonnss

                     As noted above, some of the  following  functions
                are  inherited  from  the  host math library, with all
                their virtues and vices.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--88

          ((aabbss 'n_arg))
          ((aabbssvvaall 'n_arg))

               RETURNS: the absolute value of n_arg.

          ((eexxpp 'fx_arg))

               RETURNS: _e raised to the fx_arg power (flonum) .

          ((eexxpptt 'n_base 'n_power))

               RETURNS: n_base raised to the n_power power.

               NOTE: if either of the arguments are flonums, the  cal-
                     culation will be done using _l_o_g and _e_x_p.

          ((ffaacctt 'x_arg))

               RETURNS: x_arg factorial. (fixnum or bignum)

          ((ffiixx 'n_arg))

               RETURNS: a fixnum as close as we can get to n_arg.

               NOTE: _f_i_x  will  round  down.  Currently, if n_arg is a
                     flonum larger than the size  of  a  fixnum,  this
                     will fail.

          ((ffllooaatt 'n_arg))

               RETURNS: a flonum as close as we can get to n_arg.

               NOTE: if n_arg is a bignum larger than the maximum size
                     of a  flonum,  then  a  floating  exception  will
                     occur.

          ((lloogg 'fx_arg))

               RETURNS: the natural logarithm of fx_arg.

          ((mmaaxx 'n_arg1 ... ))

               RETURNS: the maximum value in the list of arguments.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--99

          ((mmiinn 'n_arg1 ... ))

               RETURNS: the minimum value in the list of arguments.

          ((mmoodd 'i_dividend 'i_divisor))
          ((rreemmaaiinnddeerr 'i_dividend 'i_divisor))

               RETURNS: the  remainder  when  i_dividend is divided by
                        i_divisor.

               NOTE: The sign of the result will have the same sign as
                     i_dividend.

          ((**mmoodd 'x_dividend 'x_divisor))

               RETURNS: the balanced representation of x_dividend mod-
                        ulo x_divisor.

               NOTE: the  range  of  the  balanced  representation  is
                     abs(x_divisor)/2    to    (abs(x_divisor)/2)    -
                     x_divisor + 1.

          ((rraannddoomm ['x_limit]))

               RETURNS: a fixnum between 0 and x_limit - 1 if  x_limit
                        is  given.   If  x_limit  is  not  given,  any
                        fixnum,  positive  or   negative,   might   be
                        returned.

          ((ssqqrrtt 'fx_arg))

               RETURNS: the square root of fx_arg.

                                             Printed: October 16, 1993


# Article submitted
# Fusion of Evidences in Intensities Channels for Edge Detection in PolSAR Images
# GRSL - IEEE Geoscience and Remote Sensing Letters
# Anderson A. de Borba, Maurı́cio Marengoni, and Alejandro C Frery
# Despriction (function)
# Finds the l(L, mu) using log-likelihood, (internal side)
# Input: L, mu > 0
#
# Output: l(L, mu) - log-likelihood
loglike <- function(param){
	L    <- param[1]
	mu   <- param[2]
	aux1 <- L * log(L)
  	aux2 <- L * sum(log(z[1: j])) / j
  	aux3 <- L * log(mu)
  	aux4 <- log(gamma(L))
  	aux5 <- (L / mu) * sum(z[1: j]) / j
  	ll   <- aux1 + aux2 - aux3 - aux4 - aux5
	return(ll)
	}


#' @title calcOpenWaterEff
#'
#' @description Calculate the open water efficiency (\code{openWaterEff})
#' (dimensionless) using the Kristensen method with Harvald regressions.
#'
#' @param Rtot Total ship resistance (vector of numericals, kN) (see
#' \code{\link{calcKristTotalRes}} or \code{\link{calcHMTotalRes}})
#' @param thrustFactor Thrust deduction factor (vector of numericals,
#' dimensionless) (see \code{\link{calcKristThrustFactor}} or
#' \code{\link{calcHMThrustFactor}})
#' @param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#' @param wakeFraction Wake fraction coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcKristWakeFrac}} or
#' \code{\link{calcHMWakeFraction}})
#' @param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @return \code{openWaterEff} (vector of numericals, dimensionless)
#'
#'@references
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calcKristTotalRes}}
#'\item \code{\link{calcHMTotalRes}}
#'\item \code{\link{calcKristThrustFactor}}
#'\item \code{\link{calcHMThrustFactor}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcKristWakeFrac}}
#'\item \code{\link{calcHMWakeFraction}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcSpeedUnitConversion}}}
#'
#' @examples
#'  calcOpenWaterEff(398.487,0.1894947,1,0.3199536,6.7,0,seawaterDensity=1.025)
#'
#' @export

calcOpenWaterEff<-function(Rtot,thrustFactor,nProp,wakeFraction,propDiam,shipSpeed,seawaterDensity=1.025){

   cth<- (8/pi)*Rtot/(1-thrustFactor)/nProp/seawaterDensity/((1-wakeFraction)*shipSpeed*propDiam)^2

openWaterEff<- ifelse(shipSpeed==0,
                  0,
                  ((2/(1+sqrt((cth)+1)))*pmax(0.65, 0.81-0.014*(cth)))
)

return(openWaterEff)

}


## Inversion for bedform migration rates and sediment flux in the ancient
## Eric Barefoot
## May 2018

## TODO
# clean up documentation more.
# complete the uncertainty routines.
# add the ability to also account for variance in data.

# This collection of functions provides functionality for calculating bedform migration rates using methods put out by Rob Mahon and Brandon McElroy in 2018

# describe inputs and other stuff needed

# Mahon et al. use a Bayesian approach for paleohydraulic inversion, meaning that the coefficients that they describe for the empirical fit each have a distribution. They provide uncertainties for the distribution in their Table 1.
# In this way, we can ascribe ranges for the coefficients, and potentially provide a range of estimates of paleoslope accordingly. I think this means we can have confidence intervals, but I'm not sure about that.
# Initially, the user is allowed to select a percentile, and that percentile will be chosen for each parameter.

# In the future, users should be allowed to vary each parameter individually.

# get libraries

library(tibble)

## Set values and lookup table for empirical constants.

param_names = c('alpha0', 'alpha1', 'alpha2', 'beta0', 'beta1', 'gamma', 'delta0', 'delta1')

params_vals = c(-2.08, 0.254, -1.09, 0.6113, 1.305, 2.9, 0.0513, 0.7744)

params_uncert = c(0.036, 0.016, 0.044, 0.144, 0.0515, 0.7, 0.0017, 0.0123)

pars = tibble(name = param_names, vals = params_vals, uncert = params_uncert)

## Define functions from Mahon et al. 2018

# a function for table lookup. just feed it the name of the constant you want.
fun_paramVal = function(pars_list, param_name, zscore = 0) {

  therow = pars_list[which(pars_list$name == param_name), ] # lookup the constant

  val = as.numeric(therow[2]) # extract the value
  dev = as.numeric(therow[3] * zscore) # extract the magnitude of deviation from mean at zscore.

  return(list(val = val, dev = dev))

}

# equation 1 from the paper.

#' Bedform-bedload equation
#'
#' \code{bedform_bedload} calculates the sediment flux through bedload in a river based on the height and migration rate of bedforms. From Simons et al. (1965), Implemented from Mahon et al. (2018)
#' @param hd The mean height of bedforms in meters.
#' @param V The dune migration rate in meters per second.
#' @param phi The porosity of the riverbed material. Default is 0.36.
#' @return Returns a vector \code{qs}, the sediment flux in m^3/s.
#' @export

bedform_bedload = function(hd, V, phi = 0.36) {

  qs = (1 - phi) * (hd * V) / 2

  return(qs)

}

# equation 2 from the paper.

#' Bedform velocity relation
#'
#' \code{bedform_velocity} estimates the velocity of a migrating bedform using a power law fit for slope. Implemented from Mahon et al. (2018)
#' @param S The dimensionless river slope.
#' @param beta0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param beta1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{V}, the bedform migration rate in m/s.
#' @export

bedform_velocity = function(beta0, beta1, S) {

  logV = beta0 + beta1 * log10(S)

  V = 10^(logV)

  return(V)

}

# equation 3 from the paper

#' Bedform length to height relation
#'
#' \code{height_length} estimates the mean height of bedforms based on the mean bedform length. Implemented from Mahon et al. (2018)
#' @param L The mean bedform length.
#' @param delta0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param delta1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{hd}, the bedform migration rate in m/s.
#' @export

height_length = function(delta0, delta1, L) {

  hd = delta0 * L ^ delta1

  return(hd)

}

# equation 4 from the paper

#' Paleoslope relation
#'
#' \code{paleo_slope} estimates the slope of an ancient river. Originally developed in Trmapush et al. 2014. Implemented from Mahon et al. (2018)
#' @param D50 The median bedload grain size. Determined from samples.
#' @param Hbf The mean bankfull flow depth. Determined from preserved barforms.
#' @param alpha0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param alpha1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param alpha2 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{S}, the dimensionless paleoslope of the ancient river.
#' @export

paleo_slope = function(alpha0, alpha1, alpha2, D50, Hbf) {

  logS = alpha0 + alpha1 * log10(D50) + alpha2 * log10(Hbf)

  S = 10^logS

  return(S)

}

# equation 5 from the paper

#' Dune height from cosets relation
#'
#' \code{dune_height} estimates the height of dunes based on cross-stratification. Originally developed by Leclair and Bridge (2001). Implemented from Mahon et al. (2018)
#' @param Tsm The mean thickness of cross-bedded cosets. (see publication for more information)
#' @param gamma Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{hd}, the dune height in the ancient river.
#' @export

dune_height = function(gamma, Tsm) {

  hd = gamma * Tsm

  return(hd)

}

# self-contained function for calculating sediment flux rates from outcrops.
# have to have grain size measurements and bankfull depth estimates

#' Estimating sediment flux in ancient rivers.
#'
#' \code{ancient_1} estimates the sediment flux (\code{qs}) of ancient river deposits based on dune cross-stratification, bankfull depth reconstruction, and grain size. Implemented from Mahon et al. (2018). Original relations referenced therein.
#' @param Tsm The mean thickness of cross-bedded cosets. (see publication for more information)
#' @param D50 The median bedload grain size. Determined from samples.
#' @param Hbf The mean bankfull flow depth. Determined from preserved barforms.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusion.
#' @return Returns a list with elements:
#' \code{S}, the river slope (dimensionless).
#' \code{hd}, the dune height in the ancient river (m).
#' \code{V}, the dune migration rate in the ancient river (m/s).
#' \code{qs}, the bedload flux in the ancient river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

ancient_1 = function(Tsm, D50, Hbf, uncert = NULL) {

  S_est = paleo_slope(
    alpha0 = fun_paramVal(pars, 'alpha0')$val,
    alpha1 = fun_paramVal(pars, 'alpha1')$val,
    alpha2 = fun_paramVal(pars, 'alpha2')$val,
    D50 = D50,
    Hbf = Hbf
  )
  hd_est = dune_height(gamma = fun_paramVal(pars, 'gamma')$val, Tsm)
  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S_est)
  qs_est = bedform_bedload(hd = hd_est, V = V_est)

  if (is.null(uncert)) {

    return(list(S = S_est, hd = hd_est, V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}

# self-contained function for calculating dune migration rates in the modern.
# uses measured dune heights

#' Estimating sediment flux in modern rivers if bedform height is known.
#'
#' \code{modern_1} estimates the sediment flux (\code{qs}) of modern rivers based on bedform height and river slope. Implemented from Mahon et al. (2018).
#' @param hd The mean height of migrating bedforms.
#' @param S The reach-average slope of the river.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusions.
#' @return Returns a list with elements:
#' \code{V}, the dune migration rate in the river (m/s).
#' \code{qs}, the bedload flux in the river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

modern_1 = function(hd, S, uncert = NULL) { # if bedforme height is known

  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S)
  qs_est = bedform_bedload(hd = hd, V = V_est)

  if (is.null(uncert)) {

    return(list(V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}

# self-contained function for calculating dune migration rates in the modern.
# uses measured dune lengths
#' Estimating sediment flux in modern rivers if bedform height is unknown, but bedform length is known.
#'
#' \code{modern_2} estimates the sediment flux (\code{qs}) of modern rivers based on bedform length and river slope. Implemented from Mahon et al. (2018).
#' @param L The mean length of migrating bedforms.
#' @param S The reach-average slope of the river.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusions.
#' @return Returns a list with elements:
#' \code{V}, the dune migration rate in the river (m/s).
#' \code{qs}, the bedload flux in the river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

modern_2 = function(L, S, uncert = NULL) { # if bedforme height is unknown, but length is known

  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S = S)
  hd_est = height_length(delta0 = fun_paramVal(pars, 'delta0')$val, delta1 = fun_paramVal(pars, 'delta1')$val, L = L)
  qs_est = bedform_bedload(hd = hd_est, V = V_est)

  if (is.null(uncert)) {

    return(list(V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}


#install packages
install.packages("minpack.lm")
install.packages("boot")
library(minpack.lm)
library(boot)

# Exsampledata of mortalitybase, absolute frequency of deaths in age x
dx <- c(355,27,16,13,12,9,10,8,8,8,8,9,8,10,12,15,26,29,38,41,45,
        44,45,46,48,48,47,52,51,57,57,68,69,70,79,87,87,92,103,107,
        123,130,146,160,175,199,212,241,269,303,338,370,422,473,527,
        578,638,699,777,844,908,983,1073,1143,1232,1307,1369,1479,
        1513,1638,1742,1854,1939,2044,2170,2315,2473,2608,2803,3022,
        3210,3432,3600,3778,3887,3966,3951,3853,3706,3478,3220,2978,
        2631,2220,1883,1430,1116,830,588,399,260,381)

# Data of mortalitybase, absolute frequency of survivers in age x
lx <- rev(cumsum(rev(dx)))

#qx = obserevd probability of death between the ages of x and age x+1
qx <- dx/lx
logqx  <- log(dx/lx)

#w = limiting age of the mortality table/ database
w <- length(dx)-1
x<- 0:90
data <- data.frame(Y=rep(0:w, dx))

#Models:
in this example 4 models are used:

#Gompertzfunction S(x)
GompertzFuncS <- function(x, m, s) {
  return(exp(exp(-m/s)-exp((x-m)/s)))
}
#Inverse Gompertzfunction S(X)
InvGompertzFuncS <- function(x, m, s) {
  return((1-exp(-exp(-(x-m)/s)))/(1-exp(-exp(m/s))))
}
#Weibullfunction S(X)
WeibullFuncS <- function(x, m, s) {
  return(exp(-(x/m)^(m/s)))
}
#Inverse Weibullfunction S(X)
InvWeibullFuncS <- function(x, m, s) {
  return(1-exp(-(x/m)^(-m/s)))
}

#Aggregation of models:
#Function to combine all models in one S(X)
S <- function(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4) {
  return(psi1 * GompertzFuncS(x, m1, s1) +
           psi2 * InvGompertzFuncS(x, m2, s2) +
           psi3 * WeibullFuncS(x, m3, s3) +
           psi4 * InvWeibullFuncS(x, m4, s4))
}
myS <- function(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4) {
  return(psi1 * GompertzFuncS(x, m1, s1) +
           psi2 * InvGompertzFuncS(x, m2, s2) +
           psi3 * WeibullFuncS(x, m3, s3) +
           psi4 * InvWeibullFuncS(x, m4, s4))
}
#Function to define probability of death  ages of x and age x+1 X as Q(X) = 1- S(X+1)/S(x)
Q <- function(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4) {
  psi4 <- 1 - psi1 - psi2 - psi3
  return(1 - (S(x+1, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)/
                S(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)))
}
#Function to return the logarithmic probability of death  ages of x and age x+1 as log(Q(X))
logQ <- function(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4) {
  psi4 <- 1 - psi1 - psi2 - psi3
  return(log(1 - (myS(x+1, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)/
                    myS(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4))))
}
#fitting of parameters on the statistical values qx
qx <- qx[0:91]
PaperFit <- nlsLM(qx  ~ Q(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                  start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                               m1=85, m2=42, m3=.26, m4=23,
                               s1=11, s2=14, s3=1, s4=8),
                  weights = 1/abs(qx) , control = nls.control(maxiter=1000))
#fitting of parameters on the logarithmic statistical values qx using logQ
logqx <- logqx[0:91]
logPaperFit <- nlsLM(logqx ~ logQ(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                     start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                  m1=85, m2=42, m3=.26, m4=23,
                                  s1=11, s2=14, s3=1, s4=8), weights = 1/abs(logqx), control = nls.control(maxiter=1000))
qxPaperFit <- predict(PaperFit, data=data.frame(x=0:90))
logqxPaperFit <- predict(logPaperFit, data=data.frame(x=0:90))
##Visualization:
plot(x, logSterbewahrscheinlichkeit)
lines(x, logqxPaperFit, col="red")
#fitting of parameters on the logarithmic statistical values non parametric Bootstrap
bootfit <- function(data, indices) {
  d <- data[indices, ]
  # Bestimme für d die logqx Werte
  dx <- as.numeric(table(d))
  #lx = observed number of people alive, relative to an original cohort, at age x
  lx <- rev(cumsum(rev(dx)))
  #qx = obserevd probability of death between the ages of x and age x+1
  qx <- dx/lx
  #w = imiting age of the mortality table/ database
  w <- length(dx)-1
  #x= age
  x <- 0:90
  qx <- qx[0:91]
  PaperFit <- nlsLM(Sterbewahrscheinlichkeit ~ Q(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                       start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                    m1=85, m2=42, m3=.26, m4=23,
                                    s1=11, s2=14, s3=1, s4=8),
                       weights = 1/abs(qx), control = nls.control(maxiter=1000))
  qxPaperFit <- predict(PaperFit, data=data.frame(x=0:90))
  return(PaperFit$m$getPars())
}
logbootfit <- function(data, indices) {
  d <- data[indices, ]
  # Bestimme für d die logqx Werte
  dx <- as.numeric(table(d))
  #lx = observed number of people alive, relative to an original cohort, at age x
  lx <- rev(cumsum(rev(dx)))
  #qx = obserevd probability of death between the ages of x and age x+1
  qx <- dx/lx
  logqx  <- log(dx/lx)
  #w = imiting age of the mortality table/ database
  w <- length(dx)-1
  #x= age
  x <- 0:90
  logqx<- logqx[0:91]
  logPaperFit <- nlsLM(logqx ~ logQ(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                       start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                    m1=85, m2=42, m3=.26, m4=23,
                                    s1=11, s2=14, s3=1, s4=8),
                       weights = 1/abs(logqx), control = nls.control(maxiter=1000))
  logqxPaperFit <- predict(logPaperFit, data=data.frame(x=0:90))
  return(logPaperFit$m$getPars())
}
#call non parametric bootstrap
set.seed(2)
np_boot <- boot(data=data, statistic=bootfit, R=1000)
set.seed(1)
lognp_boot <- boot(data=data, statistic=logbootfit, R=1)
set.seed(2)

#plot results
lines(x, logqxPaperFit, col="red")
lines(x, logQ(x,9.862212e-01, 2.189063e-03, 7.514800e-03, 8.311480e+01, 3.440280e+01, 2.878187e+01, 2.196682e+01, 9.342605e+00, 6.470701e+00, 2.004074e+02, 5.208513e+00)
, col="blue")
lines(x, logQ(x, 0.917213634, 0.067941919, 0.004328894, 86.424663344,  57.935706039, 0.379915365, 34.177258127, 7.591399243, 4.847847541, 0.928726117, 4.373326151  ), col="red")


## Dati
x1 <- 22.05 # (minore)
p1 <- 0.09

x2 <- 25.84 # (maggiore)
p2 <- 0.08

x3 <- 0.578

## Svolgimento

mat_a <- matrix(data = c(1,qnorm(p1),1,qnorm(1-p2)),
              nrow = 2, ncol = 2, byrow = TRUE)
mat_b <- c(x1, x2)
tmp <- solve(mat_a, mat_b)
mi <- tmp[1]
sigma <- tmp[2]
rm(mat_a, mat_b, tmp)

risultato3 <- 1 - pnorm(x3) + pnorm(-x3)

print(mi)
print(sigma)
print(risultato3)


# coding: utf-8

# # Práctico 8 - Predecir información faltante en redes
#
# # 1. Ambientes de trabajo
#
# ## 1.a) Ambiente COLAB remoto
#
# 1.   Abrir en navegador: https://colab.research.google.com/
# 2.   Abrir el notebook de la tarea:
#      File-> Open Notebook -> Github -> https://github.com/prbocca/na101_master -> homework_8_prediction
# 3.   Guardar el notebook en su Google Drive:
#      File -> Save a Copy in Drive...
# 4.   Renombrar el archivo `"cedula ID"_ar_hw8.ipynb`, por ejemplo *33484022_ar_hw8.ipynb*
# 5.   Al final usted deberá descargar el notebook. Asegurarse que se están guardando las salidas de ejecución en el notebook: File -> Download .ipynb
# 6.   Luego estos archivos deberán ser enviados a prbocca@fing.edu.uy
#
# ##1.b) Ambiente RSTUDIO local (opcional)
#
# Abrir el .r de la tarea en: https://github.com/prbocca/na101_master/tree/master/homework_8_prediction

# ## 1.c) Cargar Librerias

# In[ ]:

# cargar librerias
load_libs <- function(libraries = libs, install=TRUE){
  if (install){ # instalar librerias no instaladas
    new.packages <- libs[!(libs %in% installed.packages()[,"Package"])]
    if(length(new.packages)) install.packages(new.packages)
  }
  #cargo librerias
  for (lib in libraries){
    require(lib, character.only=TRUE, quietly = FALSE)
  }
}

libs = c("ROCR", #evaluacion de problemas de clasificacion
         "rgexf", #igraph to gephi
         "vioplot",  "cowplot",
         # "org.Sc.sgd.db", "GOstats", "GO.db", #parecen no estar disponibles en el ambiente COLAB y los instalaremos luego de otra manera
         "foreach", "doMC", #procesamiento en paralelo
         "sand","igraph", "ggplot2", "reshape2") #las basicas

load_libs(libs)

# ## 1.d) Descargar funciones auxiliares

# In[ ]:

#directorio donde se va a trabajar
data_path = "/content/ar/hw8/"

dir.create(data_path, showWarnings = FALSE, recursive = TRUE)
setwd(data_path)
getwd()
list.files()

# cargo funciones auxiliares
source("https://raw.githubusercontent.com/prbocca/na101_master/master/homeworks_common.r")

# # 2. Predicción de enlaces en `R`.
#
# Seguir las Secciones 7.1 y 7.2 del libro [SANDR], ejecutando el código fuente incluido.
#

# In[ ]:

# Chapter 7 Network Topology Inference
# 7.1 Introduction
# 7.2 Link Prediction SANDR (esta es el tutorial de SANDR incluido como ejercicio)
#########################################################
# To illustrate the potential of simple scoring methods like this, recall the network
# fblog of French political blogs. The number of nearest common neighbors for
# each pair of vertices in this network, excluding—if incident to each other—the two
# vertices themselves, may be computed in the following manner.
#library(sand)
fblog = upgrade_graph(fblog)  #evita warnings por ser un grafo en version vieja
nv <- vcount(fblog)
ncn <- numeric()
A <- get.adjacency(fblog)
for(i in (1:(nv-1))){
  ni <- neighborhood(fblog, 1, i)
  nj <- neighborhood(fblog, 1, (i+1):nv)
  nbhd.ij <- mapply(intersect, ni, nj, SIMPLIFY=FALSE)
  temp <- unlist(lapply(nbhd.ij, length)) -
    2 * A[i, (i+1):nv]
  ncn <- c(ncn, temp)
}

# In[ ]:

# In Fig. 7.2 we compare the scores s(i, j) for those vertex pairs that are not incident
# to each other (i.e., ‘no edge’), and those that are (i.e., ‘edge’), using so-called violin
# plots.
#library(vioplot)
Avec <- A[lower.tri(A)]
vioplot(ncn[Avec==0], ncn[Avec==1],
        names=c("No Edge", "Edge"))
title(ylab="Number of Common Neighbors")

# In[ ]:

# It is evident from this comparison that there is a decided tendency towards larger
# scores when there is in fact an edge present. Viewing the calculation we have done
# here as a ‘leave-one-out’ cross-validation, and calculating the area under the curve
# (AUC) of the corresponding ROC curve,
#library(ROCR)
pred <- prediction(ncn, Avec)
perf <- performance(pred, "auc")
slot(perf, "y.values")

#agrego el plot de la curva ROC
roc.perf = performance(pred, measure = "tpr", x.measure = "fpr")
plot(roc.perf, col="red")
abline(a=0, b= 1)

# $\def\ccalN{{\mathcal N}}$
#
# # 3. Predicción de aristas en redes reales.
#
# En este ejercicio veremos que tan bien funcionan los métodos informales de *score* para predecir enlaces en distintas redes. Este ejercicio fue originalmente propuesto por el Prof. Aaron Clauset, en su curso "Network Analysis and Modeling", CSCI 5352, del Santa Fe Institute.
#
# Como vimos, los métodos informales de predicción de enlaces basados en *score* definen una medida de enlace para todo par de vértices que no son aristas (es decir, definen el *score*, $s(i,j)$, para todo $(i,j) \notin E^{obs}$), y predicen las aristas faltantes como aquellas parejas con mayor `score`.
# Hay muchas funciones de `score` posibles, en este ejercicio probaremos tres:
# *   camino más corto: $s(i,j)= \frac{1}{dist_{G^{obs}}(i,j)}$, siendo $dist_{G^{obs}}(i, j)$ la distancia geodésica observada entre los vértices $i$ y $j$ en el grafo observado;
#
# *   vecinos en común: $s(i,j)=|\ccalN_i^{obs}\cap \ccalN_j^{obs}|$; y
#
# *   producto de grados observados: $s(i,j)= d_i d_j$.

# ## 3.a) Descargar y cargar la red de la enfermedad de Malaria.
#
# Existen muchas representaciones en red de las relaciones entre los genes para la enfermedad de la Malaria.
# Usaremos la red de: *D. B. Larremore, A. Clauset, and C. O. Buckee, "A network approach to analyzing highly recombinant malaria parasite genes." PLOS Computational Biology 9(10), e1003268 (2013).*
#
# Esta red tiene $307$ vértices y $2684$ aristas.
# Los vértices son genes, y dos genes están conectados si ellos comparten un substring cuyo largo es estadísticamente significativo. Se tiene una etiqueta en los vértices que clasifica los genes.
# Visualizar la red en la siguiente Figura (el color de los vértices es la etiqueta de clasificación, y el tamaño representa el grado): ![alt text](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_malaria.png)
#
# Descargar el grafo desde: https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_malaria.graphml.

# In[ ]:

# descargar y cargar datos
g_malaria = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: -
#
#
#
##################################################################
summary(g_malaria)

#plot
set.seed(25)
E(g_malaria)$color = "gray"
plot(g_malaria, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=V(g_malaria)$label, vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_malaria), main="Malaria")

# ## 3.b) Descargar y cargar la red de las relaciones entre directivos en empresas públicas de Noruega.
#
# Usaremos los datos del siguiente trabajo: *C. Seierstad and T. Opsahl, "For the few not the many? The effects of affirmative action on presence, prominence, and social capital of women directors in Norway." Scand. J. Manag. 27(1), 44-54 (2011)*.
#
# Es una red de afiliaciones entre directores que comparten alguna junta directiva en  las compañias públicas noruegas.
# La red tiene una gran componente, con $854$ vértices (directivos) y $2745$ aristas (juntas directivas en común), y corresponde a la realidad de agosto de 2011.
# Se incluyen algunos metadatos, como los nombres de directores y compañías, la ciudad y código postal para empresas, y el género de los directores. Visualizar la red en la siguiente Figura (el color de los vértices es el género (azul-hombre, rojo-mujer), y el tamaño representa el grado): ![alt text](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_gcdirectores.png)
#
# Descargar el grafo desde:
# https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_gcdirectores.graphml.
#

# In[ ]:

# descargar y cargar datos
g_gcdirectores = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: -
#
#
#
##################################################################
summary(g_gcdirectores)

#plot
set.seed(25)
E(g_gcdirectores)$color = "gray"
plot(g_gcdirectores, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=V(g_gcdirectores)$gender, vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_gcdirectores), main="Red de afiliación de directores noruegos: componente gigante")

# ## 3.c) Predecir enlaces
#
# Para medir la calidad de predicción de cada método usaremos la métrica $AUC$ (*Area Under Curve*). Ver la página de Wikipedia sobre ROC: http://bit.ly/2ehXHrb. Un predictor aleatorio tiene $AUC=0.5$ y un predictor perfecto tiene $AUC=1.0$ por tanto los métodos serán mejores a mayor valor de $AUC$.
#
# Utilizando la métrica AUC, evaluar la capacidad predictiva del método de *score* de vecinos en común, sobre una subred observada con el $\%80$ de las aristas de la red de Malaria.
#
# Se disponen de varias funciones auxiliares precargadas, incluyendo `score()` y  `delete_edges_rand()`.
# Es posible ver las funciones axiliares en: https://raw.githubusercontent.com/prbocca/na101_master/master/homeworks_common.r.
#
# El siguiente código resuelve el ejercicio y ejemplifica como usar las funciones auxiliares. Se obtiene una muy buena capacidad predictiva, con un $AUC=0.917$ y la curva ROC de la siguiente Figura: ![Curva ROC para el método de score de vecinos en común, sobre una subred con el %80 de las aristas de la red de Malaria.](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/roc_malaria.png)
#
#

# In[ ]:

# computo las aristas reales y las pongo en un vector (triangular inferior, mismo orden que score())
A_malaria <- get.adjacency(g_malaria)
A_malaria_v <- A_malaria[lower.tri(A_malaria)]

#creo una subred observada
set.seed(42)
g_malaria_obs = delete_edges_rand(g_malaria, p=0.2)

# computo las aristas observadas y las pongo en un vector (triangular inferior, mismo orden que score())
A_malaria_obs = get.adjacency(g_malaria_obs)
A_malaria_obs_v <- A_malaria_obs[lower.tri(A_malaria_obs)]
true_possibleedges_no_obs = A_malaria_v[A_malaria_obs_v==0] #vector real sobre aristas no observadas

# computo aristas predichas
s_cn  = score(g_malaria_obs, type="common neighbors")
pred_possibleedges_no_obs = s_cn$score[A_malaria_obs_v==0] #vector prediccho sobre aristas no observadas

# computo la performance
pred_malaria <- prediction(pred_possibleedges_no_obs, true_possibleedges_no_obs)
perf_malaria <- performance(pred_malaria, "auc")
printf("El método de score usando vecinos en cumún, tiene un AUC=%s", slot(perf_malaria, "y.values"))
# el valor de AUC es 0.9172444

#plot de la curva ROC
roc_malaria = performance(pred_malaria, measure = "tpr", x.measure = "fpr")
plot(roc_malaria, col="red")
title("ROC para la red de Malaria y %20 de aristas no observadas")
abline(a=0, b=1)

# ## 3.d) Estudio exahustivo de capacidad predictiva
#
# Realizar un estudio más exahustivo sobre la calidad predictiva del método de score, probando las tres funciones de score definidas anteriormente, variando el porcentaje de aristas observadas entre \%99 y \%20.
# Buscando eliminar casuística, repetir la prueba sorteando distintos grafos observados.
# Realizar este procedimiento para las siguientes redes:
# *   grafo aleatorio de Erdos Renyi con $100$ vértices y una probabilidad de arista de $0.20$;
#
# *   modelo Barabási-Albert con $100$ vértices y $m=9$ aristias agregadas en cada paso;
#
# *   red de Malaria; y
#
# *   red de directores.
#
#
# Es posible utilizar la función auxiliar cargada previamente `summary_predictions(g, n_sample, p, types=c("1/dist","common neighbors", "degree product"), metric="auc", cores=1)`, que recibe un grafo $g$, crea un grafo observado para cada probabilidad de eliminación de arista del vector $p$, y prueba el métoodo de *score* para distintos tipos de medidas y para la métrica $AUC$. Repite cada caso `n_sample` y promedia resultados.
#
#

# In[ ]:

# defino los parámetros del experimento

# para cada grafo, sorteo un subgrafo observado, calculo todos los tipos de score, predigo aristas faltantes y evaluo la metrica
p_v = c(0.01, 0.05, 0.10, 0.20, 0.50, 0.80) #las probabilidades de eliminacion de arista a evaluar
n_sample = 5 #cantidad de sorteos de g_obs
types = c("1/dist","common neighbors", "degree product")
metric="auc"
n_cores = 1 #la ejecución en COLAB solo permite 1 CPU

# In[ ]:

#realizo los cálculos para el grafo aleatorio

# sorteo un grafo
g_erdosrenyi = erdos.renyi.game(100,0.20)
write.graph(g_erdosrenyi, file="g_erdosrenyi.graphml", format= "graphml")
plot(g_erdosrenyi, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color="black", vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_erdosrenyi), main="Erdos-Renyi")

# evaluo la capacidad predictiva sobre ese grafo
results_erdosrenyi = summary_predictions(g_erdosrenyi, n_sample, p_v, types, metric, cores=n_cores)
saveRDS(results_erdosrenyi, "results_erdosrenyi.RDS")

# imprimo resultados
ggplot(results_erdosrenyi$results_summary, aes(100*p, auc, colour = score)) +
  geom_line() +
  geom_point(data=results_erdosrenyi$results, aes(100*p, auc, colour = score), alpha=0.01) +
  labs(title = "AUC para distintos scores y porcentaje de aristas no observadas",
       subtitle = "grafo Erdos Renyi", x="% aristas no observadas", y="AUC")

# In[ ]:

#realizo los cálculos para el grafo Barabasi-Albert

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# In[ ]:

#realizo los cálculos para el grafo g_malaria

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# In[ ]:

#realizo los cálculos para el grafo g_gcdirectores

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# ## 3.e) Interpretar resultados de sección anterior
#
# En la sección anterior debieron obtenerse resultados similares a los de la siguiente Figura: ![AUC de los métodos de score para predecir enlaces, usando distintos porcentajes de aristas no observadas y distintas redes.](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/result_auc_p.png)
#
# Como es de esperar:
# *    no puede predecirse aristas en los grafos aleatorios;
# *    el *score* del producto de grado solo es útil en el modelo preferencial de Barabási-Albert debido a que en la construcción del grafo son más probables las aristas entre vértices más populares; y
# *    la capadidad predictiva en redes reales es bastante buena, inclusive para altos porcentajes de aristas no observadas.

# # 4. Predicción de atributos de vértices en `R`
#
# Seguir las Secciones 8.1 y 8.2 del libro [SANDR], ejecutando el código fuente incluido.
#

# In[ ]:

# Chapter 8 Modeling and Prediction for Processes on Network Graphs
# 8.1 Introduction
# 8.2 Nearest Neighbor Methods
#############################################################

# We illustrate through the problem of protein function prediction.
# We saw examples of strong assortative mixing of protein function in
# the underlying network of protein–protein interactions. While the gold standard for
# establishing the functionality of proteins is through direct experimental validation
# (or ‘assays’), results like these have been taken to suggest that, given the vast num-
# ber of proteins yet to be annotated, it is natural to approach this problem from the
# perspective of statistical prediction. Approaches to protein function prediction that
# incorporate network-based information have become standard.
set.seed(42)

data(ppi.CC)
ppi.CC = upgrade_graph(ppi.CC)
summary(ppi.CC)
# IGRAPH 006c919 UN-- 134 241 --
#   + attr: name (v/c), ICSC (v/n), IPR000198 (v/n), IPR000403 (v/n), IPR001806 (v/n), IPR001849 (v/n),
# | IPR002041 (v/n), IPR003527 (v/n)
# contains a network data object, called ppi.CC, that consists of a network of 241
# interactions among 134 proteins, as well as various vertex attributes.
#
# The vertex attribute ICSC is a binary vector
V(ppi.CC)$ICSC[1:10]

# A visualization of this network is shown in Fig. 8.1.
V(ppi.CC)[ICSC == 1]$color <- "yellow"
V(ppi.CC)[ICSC == 0]$color <- "blue"
plot(ppi.CC, vertex.size=5, vertex.label=NA)

# In[ ]:

# A simple, but often quite effective, method for producing local predictions is the
# nearest-neighbor method. See Hastie, Tibshirani, and Friedman [71, Chap. 2.3.2],
# for example, for general background on nearest-neighbor methods. For networks,
# the nearest-neighbor method centers on the calculation, for a given vertex i ∈ V , of
# the nearest-neighbor average
# i.e., the average of the values of the vertex attribute vector X in the neighborhood
# N i of i. Here |N i | denotes the number of neighbors of i in G. Calculation of these
# averages over all vertices i ∈ V corresponds to a nearest-neighbor smoothing of X
# across the network.

# In the context of protein function prediction, X is a binary vector, with entries
# indicating whether or not each protein is or is not annotated with a function of
# interest (e.g., ICSC). In predicting binary vertex attributes, the nearest-neighbor av-
#   erages (8.1) typically are compared to some threshold. For example, a threshold
# of 0.5 is commonly used, with a nearest-neighbor average greater than this value
# meaning that a majority of neighbors have the characteristic indicated by X = 1,
# resulting in a prediction for X i of 1 as well. Such methods are also known as ‘guilt-
#   by-association’ methods in some fields.

# me quedo con la componente gigante
clu <- clusters(ppi.CC)
ppi.CC.gc <- induced.subgraph(ppi.CC, clu$membership==which.max(clu$csize))
plot(ppi.CC.gc, vertex.size=5, vertex.label=NA)

# we can calculate the nearest-neighbor average
# for each of the proteins in the giant connected component of our network.
nn.ave <- sapply(V(ppi.CC.gc), function(x) mean(V(ppi.CC.gc)[nei(x)]$ICSC))

# We then plot histograms of the resulting values, separated according to the status
# of the vertex defining each neighborhood, i.e., according to the status of the ‘ego’
# vertex, in the terminology of social networks.
# The results, shown in Fig. 8.2, confirm that ICSC can be predicted with fairly
# good accuracy.
par(mfrow=c(2,1))
hist(nn.ave[V(ppi.CC.gc)$ICSC == 1], col="yellow",
     ylim=c(0, 30), xlab="Proportion Neighbors w/ ICSC",
     main="Egos w/ ICSC")
hist(nn.ave[V(ppi.CC.gc)$ICSC == 0], col="blue",
     ylim=c(0, 30), xlab="Proportion Neighbors w/ ICSC",
     main="Egos w/out ICSC")

# In particular, using a threshold of 0.5 would yield an error rate
# of roughly 25 %.
nn.pred <- as.numeric(nn.ave > 0.5)
mean(as.numeric(nn.pred != V(ppi.CC.gc)$ICSC))
#[1] 0.2598425

# In[ ]:

# La siguiente sección requiere previamente instalar algunos paquetes especiales

if (!requireNamespace("BiocManager", quietly = TRUE))
    install.packages("BiocManager")
BiocManager::install()
BiocManager::install(c("GOstats", "GO.db", "org.Sc.sgd.db"))

# In[ ]:

# Interestingly, we can push this illustration a bit further by taking advantage of the
# evolving nature of biological databases like GO. In particular, the proteins annotated
# in GO as not having a given biological function include both (1) those that indeed are
# known not to have that function, and (2) those whose status is simply unknown. As
# a result, by comparing against more recent versions of GO, it is sometimes possible
# to identify proteins whose status has changed for a given functional annotation,
# indicating that in the interim it has been discovered to in fact have that function.
# The R package GOstats, a part of the Bioconductor package, may be used to
# manipulate and analyze Gene Ontology, as contained in the database GO.db.
library(GOstats)
library(GO.db)
# And the annotations specific to the organism yeast can be obtained from the
# org.Sc.sgd.db database.
library(org.Sc.sgd.db)
# At the time of this writing, these annotations were last updated in September of
# 2013, roughly six years after the data in ppi.CC were assembled.

# In[ ]:

# We extract those proteins with the function ICSC—now subsumed under the
# term intercellular signaling transduction (ICST), or GO label 003556—and keep
# only those that have been identified from direct experimental assay, as indicated by
# the evidence code ‘IDA’.
x <- as.list(org.Sc.sgdGO2ALLORFS)
current.icst <- x[names(x) == "GO:0035556"]
ev.code <- names(current.icst[[1]])
icst.ida <- current.icst[[1]][ev.code == "IDA"]
# We then separate out the names of those proteins that had ICSC in our original data
orig.icsc <- V(ppi.CC.gc)[ICSC == 1]$name
# and similarly extract the names of those proteins under the new annotations that
# were present in the giant connected component of our original network.
candidates <- intersect(icst.ida, V(ppi.CC.gc)$name)
# Among these candidates, there are four that have been newly discovered to have
# ICSC, with the following names.
new.icsc <- setdiff(candidates, orig.icsc)
new.icsc
# [1] "YDL159W" "YHL007C" "YIL033C" "YLR362W"
# And among these four, we find that two of them would have been correctly predicted
# by comparing the value of their nearest-neighbor averages to a threshold of 0.5.
nn.ave[V(ppi.CC.gc)$name %in% new.icsc]

# # 5. Predicción de atributos de vértices en redes reales.
#
# Por lo general, los vértices de las redes reales tiene atributos, los cuales pueden ser categóricos, escalares o reales.
# En muchos casos no se conocen estos atributos para algunos vértices, por ejemplo cuando solo se tiene una muestra de la red, cuando explicitamente el atributo es ocultado por el vértice, cuando el atributo aun no existe y se creará a futuro, etc.
#
# Un método sencillo para predecir los atributos faltantes es el método de los vecinos más cercanos (*NNM - nearest-neighbor method*), donde se estima el atributo faltante en el vértice $i$ como el promedio de los atributos en el vecindario de $i$. La idea de vecindario y promedio puede variar dependiendo del caso particular. Este método suele funcionar bien cuando existe una marcada homofilia entre los vértices participantes respecto a ese atributo.

# ## 5.a) Cargar los datos
#
# Cargar la red de la enfermedad de Malaria y la red de relaciones entre directivos en empresas públicas de Noruega siguiendo el procedimiento del ejercicio anterior.
#

# In[ ]:

# Cargar la red de Malaria
g_malaria = read.graph(file="g_malaria.graphml", format= "graphml")
summary(g_malaria)

# Cargar la red de directores
g_gcdirectores = read.graph(file="g_gcdirectores.graphml", format= "graphml")
summary(g_gcdirectores)

# ## 5.b) Predecir atributos en la red de Malaria
#
# Evaluar la precisión del método NNM, sobre una subred observada con el $\%80$ de los atributos de vértice `label` de la red de Malaria.
# El atributo `label`, disponible en la red, es un enumerado (variable categórica) y es representado en `igraph` como números. Por tal motivo, el promedio sobre los vecinos del método NNM se define como el enumerado de mayor frecuencia.
# Para medir la calidad de predicción del método usaremos la exactitud  (*accuracy* - fracción de predicciones correctas).
#
# Se disponen de varias funciones auxiliares, incluyendo `nnm()` y `delete_vertex_attr_rand()`.
# Es posible ver las funciones axiliares en: https://github.com/prbocca/na101_master/raw/master/homeworks_common.r.
#
# El siguiente código resuelve el ejercicio y ejemplifica como usar las funciones auxiliares. Se obtiene una muy buena capacidad predictiva, con una exactitud de $acc=0.712$.
#

# In[ ]:

#creo una subred observada
set.seed(42)
g_malaria_obs = delete_vertex_attr_rand(g_malaria,"label", p=0.2)
vertex_attr_deleted = is.na(vertex_attr(g_malaria_obs, "label")) #vector booleando con los atributos borrados

#computo vector con los atributos reales
vertex_attr_actual = vertex_attr(g_malaria, "label")[vertex_attr_deleted] #vector con los atributos reales
vertex_attr_actual = factor(vertex_attr_actual, levels=unique(vertex_attr(g_malaria, "label")))

#computo vector con atributos predichos
vertex_attr_pred  = nnm(g_malaria_obs,"label", fun="freq")[vertex_attr_deleted] #vector con los atributos predichos
vertex_attr_pred = factor(vertex_attr_pred, levels=unique(vertex_attr(g_malaria, "label")))

# computo la exactitud
cm = as.matrix(table(pred=vertex_attr_pred, actual=vertex_attr_actual)) # create the confusion matrix
accuracy = sum(diag(cm)) / sum(cm)
printf("La exactitud de NNM para la red de Malaria es %s", accuracy) # [1] 0.7121212

# otra forma corta de hacerlo
# comparo con funcion de prediccion que hace todo
#r = evaluate_predictions_vertexattr(g_malaria, g_malaria_obs, "label", fun="freq", metric="acc")
#r$metrics

# ## 5.c) Predecir atributos en la red de directores
#
# En la red de relaciones entre directivos se conoce el género de los directivos, como un atributo binario de vértice llamado `gender`.
# Dado que el atributo es binario se puede utilizar tanto la métrica de exactitud como $AUC$ vista anteriormente. Además el método NNM puede realizarse usando el promedio entre los vecinos (y no la frecuencia más alta).
# Repetir la parte anterior para esta red.
# ¿Qué se puede concluir sobre la homofilia en esta red?
#

# In[ ]:

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# ## 5.d) Estudio exahustivo de capacidad predictiva
#
# Realizar un estudio más exahustivo sobre la calidad predictiva del método NNM, variando el porcentaje de atributos `label` observados entre \%99 y \%20 para la red de Malaria.
# Buscando eliminar casuística, repetir la prueba sorteando distintos grafos observados.
#
# Es posible utilizar la función auxiliar cargada previamente  `summary_predictions_vertexattr(g, attr, n_sample, p, fun="mean", metric="auc", cores=1)`, que recibe un grafo `g`, crea un grafo observado para cada probabilidad de eliminación de arista del vector `p`, y prueba el método NNM promediando con la función `fun` y para la métrica `acc`. Repite cada caso `n_sample` y promedia resultados.
#
# Deben obtenerse resultados similares a los de la siguiente Figura: ![precisión del método NNM para predecir atributos de vértices, usando distintos porcentajes de atributos no observados](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/result_acc_p.png). Observar que en este caso, la capadidad predictiva no es muy buena, y existe gran variación en los resultados entre muestras.
#
#

# In[ ]:

# defino los parámetros del experimento

# para cada grafo, sorteo un subgrafo observado, calculo todos los tipos de score, predigo aristas faltantes y evaluo la metrica
p_v = c(0.01, 0.05, 0.10, 0.20, 0.50, 0.80) #las probabilidades de eliminacion de arista a evaluar
n_sample = 5 #cantidad de sorteos de g_obs
metric="acc" #metric="auc" #metric="f"
n_cores = 1 #la ejecución en COLAB solo permite 1 CPU

# In[ ]:

#realizo los calculos para el grafo g_malaria

results_malaria_vertexattr = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: ver funciones auxiliares
#
#
#
##################################################################
str(results_malaria_vertexattr)

#imprimo resultados
ggplot(results_malaria_vertexattr$results_summary, aes(100*p, acc)) +
  geom_line() +
  geom_point(data=results_malaria_vertexattr$results, aes(100*p, acc), alpha=0.20) +
  labs(title = "Precisión para distintos porcentajes de atributos no observados",
       subtitle = "grafo Malaria", x="% atributos de vértices no observados", y="precisión")


#' @title pressure2Depth
#' @description Unesco 1983. Algorithms for computation of fundamental properties of seawater, 1983
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
pressure2Depth <- function (pressure, lat = 45) {
    lat <- lat * 0.0174532925199433
    x <- sin(lat)^2
    gr <- 9.780318 * (1 + (0.0052788 + 2.36e-05 * x) * x) + 1.092e-06 * pressure
    d <- (((-1.82e-15 * pressure + 2.279e-10) * pressure - 2.2512e-05) *
        pressure + 9.72659) * pressure/gr

    return(d)
}


# Day 7: The Treachery of Whales

get_day7_input_path <- function() {
    paste(getwd(), "/2021/Day 7/Day7_input.txt", sep = "")
}

part1 <- function(fuel_type = "standard") {
    positions <- strtoi(unlist(strsplit(readLines(get_day7_input_path()), ",")))

    unique_crab_pos <- sort(unique(positions))
    max_crab_pos <- unique_crab_pos[length(unique_crab_pos)]
    crabs <- matrix(ncol = 2)[-1, ]

    for (i in seq_len(length(unique_crab_pos))) {
        sum_crabs_in_pos <- sum(positions == unique_crab_pos[i])
        crabs <- rbind(crabs, c(unique_crab_pos[i], sum_crabs_in_pos))
    }

    optimal_pos <- 0
    optimal_fuel <- 2147483647

    for (i in 0:max_crab_pos) {
        fuel_used <- 0
        target_pos <- i
        for (c in seq_len(length(unique_crab_pos))) {
            if (fuel_type == "standard") {
                fuel_used <- fuel_used +
                    calc_fuel_std(target_pos, crabs[c, 1], crabs[c, 2])
            } else {
                fuel_used <- fuel_used +
                    calc_fuel_crab(target_pos, crabs[c, 1], crabs[c, 2])
            }
        }

        if (fuel_used < optimal_fuel) {
            optimal_fuel <- fuel_used
            optimal_pos <- target_pos
        }
    }

    cat("Optimal Position: ", optimal_pos, "; Fuel Used: ", optimal_fuel, "\n")
}

part2 <- function() {
    part1("crab")
}

calc_fuel_std <- function(tar_pos, cur_pos, num_crabs) {
    abs(tar_pos - cur_pos) * num_crabs
}

calc_fuel_crab <- function(tar_pos, cur_pos, num_crabs) {
    delta <- abs(tar_pos - cur_pos)
    crab_adj <- 0

    if (delta > 0) {
        crab_adj <- sum(1:delta)
    }

    crab_adj * num_crabs
}

part1()
part2()


library(epimdr)
library(bbmle)
library(statnet)

data(niamey)
head(niamey[, 1:5])

par(mar = c(5,5,2,5))
plot(niamey$absweek, niamey$tot_cases, type = "b",
     xlab = "Week", ylab = "Incidence")
par(new = TRUE)
plot(niamey$absweek, niamey$cum_cases, type = "l",
     col = "red", axes = FALSE, xlab = NA, ylab = NA, log = "y")
axis(side = 4)
mtext(side = 4, line = 4, "Cumulative incidence")
legend("topleft", legend = c("Cases", "Cumulative"),
       lty = c(1,1), pch = c(1,NA), col = c("black", "red"))

fit=lm(log(cum_cases)~absweek, subset=absweek<7,
     data=niamey)
r=fit$coef["absweek"]
V=c(1.5, 1.8)
V*r+1

V = c(1.5, 1.8)
f = (5/7)/V
V * r + 1 + f * (1 - f) * (V * r)^2

llik.cb = function(S0, beta, I) {
    n = length(I)
    S = floor(S0 - cumsum(I[-n]))
    p = 1 - exp(-beta * (I[-n])/S0)
    L = -sum(dbinom(I[-1], S, p, log = TRUE))
    return(L)
}

twoweek = rep(1:15, each = 2)
y = sapply(split(niamey$cases_1[1:30], twoweek), sum)
sum(y)

S0cand = 6500
betacand = seq(0,10, by = .1)
ll = rep(NA, length(betacand))
for(i in 1:length(betacand)){
     ll[i] = llik.cb(S0 = S0cand, beta = betacand[i],
     I = y)}
plot(ll ~ betacand, ylab = "Neg log-lik",
     xlab = expression(beta))
betacand[which.min(ll)]

betacand = 2.3
S0cand = seq(5920,8000, length = 101)
ll = rep(NA, length = 101)
for(i in 1:101){
     ll[i] = llik.cb(S0 = S0cand[i], beta = betacand,
     I = y)}
plot(ll ~ S0cand, ylab = "Neg log-lik",
     xlab = expression(S[0]))
S0cand[which.min(ll)]

fit = mle2(llik.cb, start = list(S0 = 7085, beta = 2.3),
    method = "Nelder-Mead",data = list(I = y))
summary(fit)
confint(fit)

cov2cor(vcov(fit))

sim.cb=function(S0, beta, I0){
   I=I0
   S=S0
   i=1
   while(!any(I==0)){
        i=i+1
        I[i]=rbinom(1, size=S[i-1], prob=1-
           exp(-beta*I[i-1]/S0))
        S[i]=S[i-1]-I[i]
   }
   out=data.frame(S=S, I=I)
   return(out)
}

plot(y, type="n", xlim=c(1,18),
   ylab="Predicted/observed", xlab="Week")
for(i in 1:100){
     sim=sim.cb(S0=floor(coef(fit)["S0"]),
     beta=coef(fit)["beta"], I0=11)
     lines(sim$I, col=grey(.5))
}
points(y, type="b", col=2)

data(flu)
plot(flu$day, flu$cases, type="b", xlab="Day",
     ylab="In bed", log="y")
tail(flu)

fit=lm(log(cases)~day, subset=day<=5,
     data=flu)
r=fit$coef["day"]
V=c(2,3)
V*r+1

data(ebola)
par(mar = c(5,5,2,5))
plot(ebola$day, ebola$cases, type="b", xlab="Week",
     ylab="Incidence")
par(new=T)
plot(ebola$day, ebola$cum_cases, type="l", col="red",
      axes=FALSE, xlab=NA, ylab=NA, log="y")
axis(side = 4)
mtext(side = 4, line = 4, "Cumulative incidence")
legend("right", legend=c("Cases", "Cumulative"),
     lty=c(1,1), pch=c(1,NA), col=c("black", "red"))
tail(ebola)

fit=lm(log(cum_cases)~day, subset=day<100,
   data=ebola)
r=fit$coef["day"]
V=15
f=.5
V*r+1+f*(1-f)*(V*r)^2

#Data aggregation
cases=sapply(split(ebola$cases,
   floor((ebola$day-.1)/14)), sum)
sum(cases)

#Removal MLE
fit = mle2(llik.cb, start = list(S0 = 20000, beta = 2),
   method = "Nelder-Mead",data = list(I = cases))
summary(fit)

confint(fit, std.err = c(100, 0.1))

names(ferrari)
ferrari$Ebolacases95
sum(ferrari$Ebolacases95, na.rm = TRUE)
y = c(na.omit(ferrari$Ebolacases95))

fit = mle2(llik.cb, method = "Nelder-Mead",
    start = list(S0 = 300, beta = 2),
    data = list(I = y))
fit
confint(fit, std.err = 2)

data(gonnet)
nwt = network(gonnet, directed = TRUE)
plot(nwt, vertex.col = c(0, rep(1, 17), rep(2, 71)))

F1 = quote(beta * S * I/N)
F2 = 0

Vm1 = quote(mu * E + sigma * E)
Vm2 = quote(mu * I + alpha * I + gamma * I)

Vp1 = 0
Vp2 = quote(sigma * E)

V1 = substitute(a - b, list(a = Vm1, b = Vp1))
V2 = substitute(a - b, list(a = Vm2, b = Vp2))

f11 = D(F1, "E"); f12 = D(F1, "I")
f21 = D(F2, "E"); f22 = D(F2, "I")

v11 = D(V1, "E"); v12 = D(V1, "I")
v21 = D(V2, "E"); v22 = D(V2, "I")

paras = list(S = 1, E = 0, I = 0, R = 0, mu = 0,
   alpha = 0, beta = 5, gamma = .8, sigma = 1.2, N = 1)
f = with(paras,
   matrix(c(eval(f11),eval(f12),eval(f21),
   eval(f22)), nrow = 2, byrow = TRUE))
v=with(paras,
   matrix(c(eval(v11),eval(v12),eval(v21),
   eval(v22)), nrow=2, byrow=TRUE))

max(eigen(f %*% solve(v))$values)

with(paras,
sigma/(sigma+mu)*beta/(gamma+mu+alpha))

F1 = expression(betai * S * I / N + betah* S * H / N +
   betaf * S * F / N)
F2=0
F3=0
F4=0

Vm1 = quote(sigma * E)
Vm2 = quote(Theta * gammah * I + (1 - Theta) * (1-
   Lambda) * gammar * I + (1 - Theta) * Lambda *
   gammaf * I)
Vm3 = quote(Lambda * etaf * H + (1 - Lambda) * etar * H)
Vm4 = quote(chi * F)

Vp1 = 0
Vp2 = quote(sigma * E)
Vp3 = quote(Theta * gammah * I)
Vp4 = quote((1 - Theta) * (1 - Lambda) * gammar * I+
   Lambda * etaf * H)

V1 = substitute(a - b, list(a = Vm1, b = Vp1))
V2 = substitute(a - b, list(a = Vm2, b = Vp2))
V3 = substitute(a - b, list(a = Vm3, b = Vp3))
V4 = substitute(a - b, list(a = Vm4, b = Vp4))

f11 = D(F1, "E"); f12 = D(F1, "I"); f13 = D(F1, "H")
     f14 = D(F1, "F")
f21 = D(F2, "E"); f22 = D(F2, "I"); f23 = D(F2, "H")
     f24 = D(F2, "F")
f31 = D(F3, "E"); f32 = D(F3, "I"); f33 = D(F3, "H")
     f34 = D(F3, "F")
f41 = D(F4, "E"); f42 = D(F4, "I"); f43 = D(F4, "H")
     f44 = D(F4, "F")

v11 = D(V1, "E"); v12 = D(V1, "I"); v13 = D(V1, "H")
     v14 = D(V1, "F")
v21 = D(V2, "E"); v22 = D(V2, "I"); v23 = D(V2, "H")
     v24 = D(V2, "F")
v31 = D(V3, "E"); v32 = D(V3, "I"); v33 = D(V3, "H")
     v34 = D(V3, "F")
v41 = D(V4, "E"); v42 = D(V4, "I"); v43 = D(V4, "H")
     v44 = D(V4, "F")

gammah = 1/5 * 7
gammaf = 1/9.6 * 7
gammar = 1/10 * 7
chi = 1/2 * 7
etaf = 1/4.6 * 7
etar = 1/5 * 7
paras = list(S = 1,E = 0, I = 0, H = 0, F = 0,R = 0,
     sigma = 1/7*7, Theta = 0.81, Lambda = 0.81, betai = 0.588,
     betah = 0.794, betaf = 7.653, N = 1, gammah = gammah,
     gammaf = gammaf, gammar = gammar, etaf = etaf,
     etar = etar, chi = chi)

f = with(paras,
matrix(c(eval(f11), eval(f12), eval(f13), eval(f14),
     eval(f21), eval(f22), eval(f23), eval(f24),
     eval(f31), eval(f32), eval(f33), eval(f34),
     eval(f41), eval(f42), eval(f43), eval(f44)),
     nrow = 4, byrow = T))

v = with(paras,
matrix(c(eval(v11), eval(v12), eval(v13), eval(v14),
     eval(v21), eval(v22), eval(v23), eval(v24),
     eval(v31), eval(v32), eval(v33), eval(v34),
     eval(v41), eval(v42), eval(v43), eval(v44)),
     nrow = 4, byrow = T))

max(eigen(f %*% solve(v))$values)


#' Generate likelihood statistics (AIC, AICC, BIC, etc.)
#'
#' Generate likelihood statistics that include the Jacobian adjustment for transformations as done in the X-13ARIMA-SEATS program
#'
#' @param Y numeric vector, original time series.
#' @param Lnlkhd numeric scalar, maximized log likelihood of model.
#' @param Np Integer scalar, Number of parameters in model used. Default is 2.
#' @param Nintvl Integer scalar, Number of differences in model used. Default is 2.
#' @param Adj numeric vector, prior adjustment factor time series. Default is NULL, which indicates there is no prior adjustment.
#' @param Logit logical scalar, if TRUE the logit transformation is used. Default is FALSE.
#' @param Trans logical scalar, if TRUE a Box-Cox transform is used. Default is TRUE
#' @param Lam numeric scalar, Box-Cox transformation parameter. Default is 0 (Log transform).
#' @param Eick numeric scalar, weighting paramter for Empiracle Information Criterion. Default is NULL (EIC not computed).
#' @return List of likelihood diagnostics and related estimates (ll = log likelihood, jacadj = jacobian transformation adjustment,
#'    lladj = adjusted likelihood, nobs = number of observations, neffective = effective number of observations,
#'    nparams = number of parameters, df = Nspobs - Nintvl - Np, aic = AIC, aicc = AICC, hannanquinn = Hannan Quinn,
#'    bic = BIC, bic2 = BIC2, EIC = Empiracle Information Criterion)
#' @examples
#' ic_default_log_est <-
#'    rjd3highfreq::fractionalAirlineEstimation(log(ic_obs), periods=c(365.25/7),
#'                                              x=ic_default_matrix)
#' ic_default_log_lkhd_stat <-
#'    gen_likelihood_stats(ic_obs,
#'                         Lnlkhd = ic_default_log_est$likelihood$ll,
#'                         Nintvl = 2,
#'                         Np     = ic_default_log_est$likelihood$nparams)
#' ic_default_log_aicc <- ic_default_log_lkhd_stat$aicc
#' @import stats
#' @export
gen_likelihood_stats <- function(Y, Lnlkhd, Nintvl = 2, Np = 2, Adj = NULL,
                                 Logit = FALSE, Trans = TRUE, Lam = 0.0,
                                 Eick = NULL) {
   # Author: Brian C. Monsell (OEUS), Version 2.0, 2/2/2022

   # generate jacobian adjustment
   Nspobs <- length(Y)
   jacadj <- jacobian_trans_adj(Y, Nspobs, Nintvl, Adj = Adj, Logit = Logit, Trans = Trans, Lam = Lam)

   dnefob <- Nspobs - Nintvl
   TWO <- 2.0
   lladj <- Lnlkhd + jacadj

   # AIC
   Aic=-TWO*(lladj-Np)

   # AICC
   Aicc=-TWO*(lladj-dnefob*Np/(dnefob-(Np+1)))

   # Hannon-Quinn
   Hnquin=-TWO*(lladj-log(log(dnefob))*Np)

   # BIC
   Bic=-TWO*(lladj)+Np*log(dnefob)

   # BIC2
   Bic2=(-TWO*Lnlkhd+Np*log(dnefob))/dnefob

   # BICC

   # EIC (only produced if EICk is specified) and return a list of likelihood statistics
   if (!is.null(Eick)) {
      Eic=-TWO*(lladj)+Np*Eick
      return(list(ll = Lnlkhd, jacadj = jacadj, lladj = lladj, nobs = Nspobs, neffective = dnefob,
               nparams = Np, df = dnefob - Np, aic = Aic, aicc = Aicc, hannanquinn = Hnquin,
               bic = Bic, bic2 = Bic2, eic = Eic, eick = Eick))
   } else {
      return(list(ll = Lnlkhd, jacadj = jacadj, lladj = lladj, nobs = Nspobs, neffective = dnefob,
               nparams = Np, df = dnefob - Np, aic = Aic, aicc = Aicc, hannanquinn = Hnquin,
               bic = Bic, bic2 = Bic2))
   }

}


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/caching/data_all.csv', sep = ';')
data_amf <- read.csv('../../results/client_algos/data_all.csv', sep = ';')
data_noamf <- read.csv('../../results/caching_none/data_all.csv', sep = ';')

# Means
aggregate(data$time, list(data$combination), median)
# HTTP+Filter   732.0
# Filter        1126.0
# HTTP          652.5
# None          254672.5
aggregate(data_noamf$time, list(data_noamf$combination), median)
# HTTP          2408.0
# None          4156.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: No statistical difference between combinations
kruskal.test(time ~ combination, data = data)
# p: < 2.2e-16
# => Reject H0, non-equal means => big statistical difference

# H0: Filter == HTTP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_1' | data$combination=='combination_2'),])
# p: 0.02255
# => Reject H0, non-equal means => Filter > HTTP

# H0: HTTP+Filter == HTTP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_2'),])
# p: 0.7694
# => Accept H0, equal means => HTTP+Filter == HTTP

# H0: AMF-nocache == noAMF-nocache
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_3' | data_noamf$combination=='combination_1'),])
# p: < 2.2e-16
# => Reject H0, non-equal means => AMF-nocache < noAMF-nocache

# H0: AMF-cache == noAMF-cache
kruskal.test(time ~ combination, data = data[which(data_amf$combination=='combination_3' | data_noamf$combination=='combination_0'),])
# p: < 2.2e-16
# => Reject H0, non-equal means => AMF-cache < noAMF-cache


for(j in 2:10) {
  r <- sprintf("%d: ", j)
  for(n in 1:j) {
    r <- paste(r, format(exp(2i*pi*n/j), digits=4), ifelse(n<j, ",", ""))
  }
  print(r)
}


#@reemuru
#data mining
#conditional inference trees

#set the working directory
setwd("./ci-trees/")

#load imports-85 file with headers in the first row
letter<- read.csv(file = "letter.csv", header = TRUE, sep = ",")

#load and initialize the necessary packages
#install.packages("psych")
#install.packages("party")
library(psych)
library(party)

#check for missing data
summary(letter)

#structure of the dataset, verify DV is factor
str(letter)

#view distribution of DV
plot(letter$class)

#scatterplot matrix
modLetter<-letter
modLetter$xbox<-NULL
modLetter$ybox<-NULL
modLetter$width<-NULL
modLetter$high<-NULL
pairs.panels(modLetter)

#divide the data into training set and test set
set.seed(1234)
ind <- sample(2, nrow(letter), replace = TRUE, prob = c(0.7, 0.3))
train.data <- letter[ind == 1, ]
test.data <- letter[ind == 2, ]

#set class as DV with all remaining variables as IV using . wildcard for training data
myFormula<-class~.
model <- ctree(myFormula, data = train.data)

#print the tree
print(model)

#build the confusion matrix for training data in model
table(predict(model), train.data$class)
cm<-table(predict(model), train.data$class)

#accuracy = TN + TP / N + P for training data in model
#sum diag and divide by sum of all observations to derive classification accuracy
sum(diag(table(predict(model), train.data$class)))/sum(table(predict(model), train.data$class))

#set class as DV with all remaining variables as IV using . wildcard for test data
myFormula<-class~.
model <- ctree(myFormula, data = test.data)
#build the confusion matrix for test data
table(predict(model), test.data$class)
cm<-table(predict(model), test.data$class)

#accuracy = TN + TP / N + P test data
#sum diag and divide by sum of all observations to derive classification accuracy
sum(diag(table(predict(model), test.data$class)))/sum(table(predict(model), test.data$class))

#reload dataset
letter<- read.csv(file = "letter.csv", header = TRUE, sep = ",")

#subset for the letter Q and O only to observe performance against letters with similar structure
letter<-subset(letter, class=="Q" | class=="O")
#drop unused levels
letter$class<-droplevels(letter$class)

#rebuild the model
#divide the data into training set and test set
set.seed(1234)
ind <- sample(2, nrow(letter), replace = TRUE, prob = c(0.7, 0.3))
train.data <- letter[ind == 1, ]
test.data <- letter[ind == 2, ]

#set class as DV with ybar, x2ybr and xegvy as predictors
myFormula<-class~+ybar+x2ybr+xegvy
model2 <- ctree(myFormula, data = train.data)

#print the tree
print(model2)

#evaluate the model for the training data
trainPred <- predict(model2, newdata = train.data)
table (trainPred, train.data$class)
cm2<-table(trainPred, train.data$class)

#accuracy = TN + TP / N + P
(cm2[1]+cm2[4])/sum(cm2)

#evaluate the model for the test data
myFormula<-class~+ybar+x2ybr+xegvy
model2 <- ctree(myFormula, data = train.data)

testPred <- predict(model2, newdata = test.data)
table (testPred, test.data$class)
cm3<-table(testPred, test.data$class)

#accuracy = TN + TP / N + P
(cm3[1]+cm3[4])/sum(cm3)

#dataviz
plot(model)
plot(model2)
#mosaic plot using test data
mosaicplot(table(predict(model2, test.data), test.data$class), shade=TRUE, main="O vs. Q")


#' Calculate each of the variability estimates used by the PEB
#'
#' A utility function used to calculate each of the variability
#' estimates used by the PEB algorithm from from any two of them
#'
#' @export
#' @family peb
#'
#' @param mu The population mean
#'
#' @param sigma2 The within group variation
#'
#' @param tau2 The between group variation
#'
#' @param v The total variation (=sigma2 + tau2)
#'
#' @param beta1,beta The proportion of toal variation attributable to between group variation (=tau2 / v)
#'
#' @note mu,sigma2,tau2,v, and beta may be substitured by a the object returned by \code{\link{PEBparams}}
#'
#' @return a list containing the values sigma2, tau2, v, beta1, and mu,
#' and a function 'bn' which calculates bn for various values of n
#' given these parameters in this
#'

pebVarArgs <-  function(...){
	# calculates all the
	ARGS = list(...)
	# fastPath out for the special case that the only argument
	# was the product of PEBparams()
	if((length(ARGS) == 1) & inherits(ARGS[[1]],'PEBparams')){
		params <- ARGS[[1]]
		sigma2 = params$s2
		tau2 = params$t2
		v = sigma2 + tau2
		mu = params$mu
		fun = function(n)tau2/((sigma2/n) + tau2)
		return(list(sigma2=sigma2,
					tau2=tau2,
					v=v,
					mu=mu,
					beta1=fun(1),
					bn = fun))
	}

	sigma2 = if('sigma2' %in% names(ARGS)) ARGS$sigma2 else NA
	tau2 = if('tau2' %in% names(ARGS)) ARGS$tau2 else NA
	v = if('v' %in% names(ARGS)) ARGS$v else NA
	beta1 = (if('beta1' %in% names(ARGS))
				ARGS$beta1
			else if('beta' %in% names(ARGS))
				ARGS$beta
			else NA)

	if(!is.na(sigma2)) 	stopifnot(sigma2>0)
	if(!is.na(tau2)) 	stopifnot(tau2>0)
	if(!is.na(v)) 		stopifnot(v>0)
	if(!is.na(beta1)) 	stopifnot(beta1>0)

	if(sum(c((is.na(sigma2)||is.nan(sigma2)),
			 (is.na((tau2)||is.nan(tau2))),
			 (is.na((v)||is.nan(v))),
			 (is.na((beta1)||is.nan(beta1))))) != 2)
		stop("please specifiy exacty two parameters out of 'sigma2','tau2','v', and 'beta'")
	# beta1 / v specified
	if(is.na(tau2) & (!is.na(beta1))& (!is.na(v)))
		tau2 = beta1*v
	if(is.na(sigma2) & (!is.na(beta1))& (!is.na(v)))
		sigma2 = (1-beta1)*v
	# sigma2 /v specified
	if(is.na(sigma2) & (!is.na(tau2))& (!is.na(v)))
		sigma2 = v - tau2
	# tau2/v specified
	if(is.na(tau2) & (!is.na(sigma2))& (!is.na(v)))
		tau2 = v - sigma2
	# tau2 / V specified
	if(is.na(sigma2) & (!is.na(tau2))& (!is.na(beta1)))
		sigma2 = (tau2/beta1) - tau2
	# tau2 / V specified
	if(is.na(tau2) & (!is.na(sigma2))& (!is.na(beta1)))
		tau2 = (sigma2*beta1)/(1-beta1)
	if(is.na(sigma2) |is.na(tau2) )
		stop('Insufficient arguments:  ')
	if(is.na(v))
		v = sigma2 + tau2
	if(is.na(beta1))
		beta1 = tau2 / v
	return(list(sigma2=sigma2,
			   	tau2=tau2,
			   	v=v,
			   	beta1=beta1,
				mu=ARGS$mu,
				bn = function(n)tau2/((sigma2/n) + tau2)))
}


# Performing calculations in the Matrix

# Construct star_wars_matrix
box_office <- c(460.998, 314.4, 290.475, 247.900, 309.306, 165.8)
region <- c("US", "non-US")
titles <- c("A New Hope",
                 "The Empire Strikes Back",
                 "Return of the Jedi")

star_wars_matrix <- matrix(box_office,
                      nrow = 3, byrow = TRUE,
                      dimnames = list(titles, region))

# Calculate worldwide box office figures
worldwide_vector <- rowSums(star_wars_matrix)