#' f_sigmatau
#'
#' Construct the $\Sigma_tau$ diagonal matrix
#' given the dimension $K$
#'
#' @param k dimension of the diagonal matrix
#'
#' @return $K\times K \Sigma_tau$ diagonal matix,
#'          with $\M \Sigma_\tau_{ij} = 1$ if $i\geq j$ and $0$ otherwise.
#'
f_sigmatau <- function(k) {
    sigmatau <- matrix(0L, k, k)
    sigmatau[lower.tri(sigmatau, diag = T)] <- 1
    return(sigmatau)
}

#' f_sigma
#'
#' Construct the $\Sigma$ matrix
#' given the dimension $k_\tau, K_1$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $k_\tauK_1 \times k_\tauK_1 \Sigma$ diagonal block matix.
#'
f_sigma <- function(ktau, k1) {
    sigmatau <- f_sigmatau(ktau)
    return(kronecker(sigmatau, diag(k1)))
}

#' f_mate
#'
#' Construct the $E_{K_\tau}$ diagonal matrix
#' given the dimension $K_\tau$
#'
#' @param ktau dimension of the diagonal matrix
#'
#' @return $K_\tau \times K_\tau E_{K_\tau}$ diagonal matix,
#'          with $\M E_{11} = 1$ and $0$ anywhere else.
#'
f_mate <- function(ktau) {
    m_e <- matrix(0L, ktau, ktau)
    m_e[1, 1] <- 1
    return(m_e)
}

#' f_matf
#'
#' Construct the $(K_\tau-2) \times K_\tau$ $F_{K_\tau}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the diagonal matrix
#'
#' @return $(K_\tau-2)\times K_\tau F_{K_\tau}$,
#'          aka the first order differencing matrix,
#'          without the first row.
#'
f_matf <- function(ktau) {
    m_dif <- diff_matrix(ktau, 1)[-1, ]
    if (is.vector(m_dif)) {
        m_dif <- t(m_dif)
    }
    return(m_dif)
}

#' f_d11
#'
#' Construct the $K_{\tau}(K_1-2) \times K_{\tau}K_1$ $D_{11}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau}(K_1-2) \times K_{\tau}K_1$ $D_{11}$ matrix
#'
f_d11 <- function(ktau, k1) {
    kronecker(f_mate(ktau), diff_matrix(k1, 2))
}

#' f_d12
#'
#' Construct the $K_{\tau}(K_1-1) \times K_{\tau}K_1$ $D_{12}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau}(K_1-1) \times K_{\tau}K_1$ $D_{12}$ matrix
#'
f_d12 <- function(ktau, k1) {
    kronecker((diag(ktau) - f_mate(ktau)), diff_matrix(k1, 1))
}

#' f_dtau
#'
#' Construct the $K_{\tau - 2}K_1 \times K_{\tau}K_1$ $D_{\tau}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau - 2}K_1 \times K_{\tau}K_1$ $D_{\tau}$ matrix
#'
f_dtau <- function(ktau, k1) {
    kronecker(f_matf(ktau), diag(k1))
}

#' f_mats
#'
#' Construct the $K_1K_2 \times K_1K_2$ $S$ matrix
#' given the dimension $K_1, K_2$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#' @param lambdas vector of lambdas(penalty parameters)
#'
#' @return $K_{K_\tau}K_1 \timesK_{K_\tau}K_1$ $S$ matrix
#'
f_mats <- function(ktau, k1, lambdas) {
    s <- lambdas[1] * crossprod(f_dtau(ktau, k1))
    s <- s + lambdas[2] * crossprod(f_d11(ktau, k1))
    s <- s + lambdas[3] * crossprod(f_d12(ktau, k1))
    return(s)
}

#' f_matc
#'
#' Construct the $K_{K_\tau}K_1 \times $K_{K_\tau}K_1$ diagonla matrix $C$
#' given the dimension \code{v_dim}
#'
#' @param v_dim vector contain the dimension of covariates
#'             $(K_\tau, K_1, K_2, \cdots)$
#'
#' @param til_beta $K_\tauK_1\cdots$ vector of the coefficient $\tilde{\beta}$
#'
#' @return K_{K_\tau}K_1\cdots \times K_{K_\tau}K_1\cdots$ diagonal matrix $C$,
#'         with diagonal equals derivative of $\tilde{\beta}$.
#'          $\M C_{jj} = \begin{cases}
#'                      1, &\text{if } \tilde{\beta}_j=\beta_j\\
#'                       \exp(\beta_j), &\text{otherwise}.
#'                      \end{cases}$
#'
f_matc <- function(v_dim, til_beta) {
    if (prod(v_dim) != length(til_beta)) {
        print("v_dim:"); print(v_dim); print("til_beta:"); print(til_beta)
        stop("f_matc: input dimension invalid \n")
    }
    v_idx <- seq_len(v_dim[2])
    til_beta[v_idx] <- 1L
    m_c <- diag(til_beta)
    return(m_c)
}

#' f_g1
#'
#' Construct the $(K_0+m) \times (K_0+m)$ or $K \times K$ $G_1$ diagonal matrix
#' given the dimension $K = K_0 + m$
#'
#' @param k0 number of internal knots
#' @param m order of the basis splines
#'
#' @return $K\times K G_1$ diagonal matix,
#'          with $G_1_{ii} = (t_{i+m} - t_i)/m$.
#'
f_g1 <- function(k0, m) {
    h <- 1 / (1 + k0)
    v_knots <- seq_len(k0) * h
    v_knots <- c(rep(0, m), v_knots, rep(1, m))
    out <- diag(diff(x = v_knots, lag = m) / m)
    return(out)
}

#' f_g2
#'
#' Construct the $(K_0+m) \times (K_0+m)$ or $K \times K$ $G_2$ diagonal matrix
#' given the dimension $K = K_0 + m$
#'
#' @param k0 number of internal knots
#' @param m order of the basis splines
#'
#' @return $K\times K G_2$ diagonal matix,
#'          with $G_2_{ii} = (t_{i+m+1} - t_i)/m$.
#'
f_g2 <- function(k0, m) {
    out <- f_g1(k0, m + 1)
    out <- out[-1, -1]
    return(out)
}

#' f_n1
#'
#' Construct the $n \times (K_1)$ spline matrix for the first covariate
#' given the dimension $K_1 = k1 + m1$
#'
#' @param x observations for the first covariate
#' @param k1 number of internal knots
#' @param m1 order of the basis splines
#'
#'
#' @return $n \times K_1$ spline matrix for the first covariate,
#'
f_n1 <- function(x, k1, m1) {
    out <- spline_basis(x, k1, m1)
    return(out)
}

#' f_ntau
#'
#' Construct the $n \times (K_1)$ spline designfor the taus
#' given the dimension $K_\tau = k\tau + m\tau$
#'
#' @param v_tau observations for the tau
#' @param ktau number of internal knots
#' @param mtau order of the basis splines
#'
#'
#' @return $n \times K_\tau$ spline design for the taus,
#'
f_ntau <- function(v_tau, ktau, mtau) {
    spline_basis(v_tau, ktau, mtau, x_range = c(1, 0))
}

#' f_ntau
#'
#' Construct the $n \times (K_\tau)$ spline matrix $N_{\tau^*}$
#' given the dimension $K_\tau = k\tau + m\tau$
#'
#' @param taustar estimated tau for each observations
#' @param k\tau number of internal knots
#' @param m\tau order of the basis splines
#'
#' @import splines
#'
#' @return $n \times K_\tau$ intergrated spline matrix $N_{\tau^*}$
#'
f_ntaustar <- function(taustar, ktau, mtau) {
    out <- spline_basis(taustar, ktau, mtau + 1, x_range = c(1, 0))
    out <- out[, -1]
    return(out)
}


<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health using the Gini coefficient
## Florida Charts Census Tract Mortality Data:  R Project for Statistical Computing Code Script by DrewC!

### Step 1: Import Libraries and Import Dataset

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

## Import Standard Libraries
library(tidyverse)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis
library(pROC) # ROC tests with AUC output
library(ineq) # Gini coefficient and Lorenz curve

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_cedric = read.csv("_data/cedric_can_gini.csv") # Import dataset from _data folder
df_mungos = read.csv("_data/mungos_np_value.csv") # Import dataset from _data folder

## Join
df_bella = inner_join(df_cedric, df_mungos, by = "County")

## Verify
glimpse(df_bella)
glimpse(df_mungos)
glimpse(df_cedric)

## Export
write.csv(df_bella, "_data/bella_can_gini_np_value.csv") #clean in excel and select variable

### Step 2: Statistical Test

## Spearman's Rank for ERR
corr_err = cor.test(x = df_bella$Gini, y = df_bella$ERR, method = "spearman") # Pearson's Rank for Q->Q
print(corr_err)

## Spearman's Rank for MSPB
corr_mspb = cor.test(x = df_bella$Gini, y = df_bella$MSPB, method = "spearman") # Pearson's Rank for Q->Q
=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health using the Gini coefficient
## Florida Charts Census Tract Mortality Data:  R Project for Statistical Computing Code Script by DrewC!

### Step 1: Import Libraries and Import Dataset

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

## Import Standard Libraries
library(tidyverse)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis
library(pROC) # ROC tests with AUC output
library(ineq) # Gini coefficient and Lorenz curve

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_cedric = read.csv("_data/cedric_can_gini.csv") # Import dataset from _data folder
df_mungos = read.csv("_data/mungos_np_value.csv") # Import dataset from _data folder

## Join
df_bella = inner_join(df_cedric, df_mungos, by = "County")

## Verify
glimpse(df_bella)
glimpse(df_mungos)
glimpse(df_cedric)

## Export
write.csv(df_bella, "_data/bella_can_gini_np_value.csv") #clean in excel and select variable

### Step 2: Statistical Test

## Spearman's Rank for ERR
corr_err = cor.test(x = df_bella$Gini, y = df_bella$ERR, method = "spearman") # Pearson's Rank for Q->Q
print(corr_err)

## Spearman's Rank for MSPB
corr_mspb = cor.test(x = df_bella$Gini, y = df_bella$MSPB, method = "spearman") # Pearson's Rank for Q->Q
>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db
print(corr_mspb)


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# 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.

source("function.r")
input_file = "assunpink.csv"
output_file = "assunpink"
data_col = 3
year_col = 1
col_names = T
CSVFile = read.csv(file = input_file, header = col_names)
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
referenceyear = 2018
time_index = time.index(Year,referenceyear)
lmfit = lm(Data~time_index)
mu0.int = lmfit$coefficients[1]
mu1.int = abs(lmfit$coefficients[2])
scale.int = sd(Data)
set.seed(2)
shape.int = runif(1,-1,1)
k = 0
llf = function(x) {
    k =(1 + (x[4]*(Data-(x[1]+(x[2]*time_index)))/x[3]))^(-1/x[4])
    pdf = (1/x[3])*((k)^(x[4]+1))*exp(-k)
    -sum(log(pdf))
}
result = try(
    expr =  optim(par = c(mu0.int,mu1.int,scale.int,shape.int), method = "L-BFGS-B", fn = llf, lower = c(0,0,0,-Inf)), silent = TRUE
)
while (class(result) == "try-error"){
    k = k+1
    shape.int = runif(1,-1,1)
    result = try(
      expr =  optim(par = c(mu0.int,mu1.int,scale.int,shape.int), method = "L-BFGS-B", fn = llf, lower = c(0,0,0,-Inf)), silent = TRUE
    )
  }
  mu0 = result$par[1]
  mu1 = result$par[2]
  scale = result$par[3]
  shape = result$par[4]
  NLLH = result$value

  retevent = calc.nstat.ret.event(mu0,mu1,scale,shape,100,baseyear = referenceyear,analysisyear = referenceyear,1)

cat('Maximum Likelihood Estimation (Constrained)','\n')
cat('mu0 = ',mu0,'mu1 = ',mu1,'scale = ',scale,'shape = ',shape,'100yr return event = ',retevent,"NLLH =",NLLH,'\n')


graphics.off() # This closes all of R's graphics windows.
rm(list=ls())  # Careful! This clears all of R's memory!
library(ggplot2)
library(ggpubr)
library(ks)
library(rjags)
library(runjags)
setwd("~/Documents/MATH2269_Bayesian/2020/presentations/Module 6/Application2")
source("DBDA2E-utilities.R")

#===============PRELIMINARY FUNCTIONS FOR POSTERIOR INFERENCES====================

smryMCMC_HD = function(  codaSamples , compVal = NULL,  saveName=NULL) {
  summaryInfo = NULL
  mcmcMat = as.matrix(codaSamples,chains=TRUE)
  paramName = colnames(mcmcMat)
  for ( pName in paramName ) {
    if (pName %in% colnames(compVal)){
      if (!is.na(compVal[pName])) {
        summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ,
                                                          compVal = as.numeric(compVal[pName]) ))
      }
      else {
        summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ) )
      }
    } else {
      summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ) )
    }
  }
  rownames(summaryInfo) = paramName

  # summaryInfo = rbind( summaryInfo ,
  #                      "tau" = summarizePost( mcmcMat[,"tau"] ) )
  if ( !is.null(saveName) ) {
    write.csv( summaryInfo , file=paste(saveName,"SummaryInfo.csv",sep="") )
  }
  return( summaryInfo )
}

#===============================================================================

plotMCMC_HD = function( codaSamples , data , xName="x" , yName="y" ,
                        showCurve=FALSE ,  pairsPlot=FALSE , compVal = NULL,
                        saveName=NULL , saveType="jpg" ) {
  # showCurve is TRUE or FALSE and indicates whether the posterior should
  #   be displayed as a histogram (by default) or by an approximate curve.
  # pairsPlot is TRUE or FALSE and indicates whether scatterplots of pairs
  #   of parameters should be displayed.
  #-----------------------------------------------------------------------------
  y = data[,yName]
  x = as.matrix(data[,xName])
  mcmcMat = as.matrix(codaSamples,chains=TRUE)
  chainLength = NROW( mcmcMat )
  zbeta0 = mcmcMat[,"zbeta0"]
  zbeta  = mcmcMat[,grep("^zbeta$|^zbeta\\[",colnames(mcmcMat))]
  if ( ncol(x)==1 ) { zbeta = matrix( zbeta , ncol=1 ) }
  zVar = mcmcMat[,"zVar"]
  beta0 = mcmcMat[,"beta0"]
  beta  = mcmcMat[,grep("^beta$|^beta\\[",colnames(mcmcMat))]
  if ( ncol(x)==1 ) { beta = matrix( beta , ncol=1 ) }
  tau = mcmcMat[,"tau"]
  pred1 = mcmcMat[,"pred[1]"] # Added by Demirhan
  pred2 = mcmcMat[,"pred[2]"] # Added by Demirhan
  pred3 = mcmcMat[,"pred[3]"] # Added by Demirhan
  pred4 = mcmcMat[,"pred[4]"] # Added by Demirhan
  pred5 = mcmcMat[,"pred[5]"] # Added by Demirhan

  #-----------------------------------------------------------------------------
  # Compute R^2 for credible parameters:
  YcorX = cor( y , x ) # correlation of y with each x predictor
  Rsq = zbeta %*% matrix( YcorX , ncol=1 )
  #-----------------------------------------------------------------------------
  if ( pairsPlot ) {
    # Plot the parameters pairwise, to see correlations:
    openGraph()
    nPtToPlot = 1000
    plotIdx = floor(seq(1,chainLength,by=chainLength/nPtToPlot))
    panel.cor = function(x, y, digits=2, prefix="", cex.cor, ...) {
      usr = par("usr"); on.exit(par(usr))
      par(usr = c(0, 1, 0, 1))
      r = (cor(x, y))
      txt = format(c(r, 0.123456789), digits=digits)[1]
      txt = paste(prefix, txt, sep="")
      if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
      text(0.5, 0.5, txt, cex=1.25 ) # was cex=cex.cor*r
    }
    pairs( cbind( beta0 , beta , tau )[plotIdx,] ,
           labels=c( "beta[0]" ,
                     paste0("beta[",1:ncol(beta),"]\n",xName) ,
                     expression(tau) ) ,
           lower.panel=panel.cor , col="skyblue" )
    if ( !is.null(saveName) ) {
      saveGraph( file=paste(saveName,"PostPairs",sep=""), type=saveType)
    }
  }
  #-----------------------------------------------------------------------------
  # Marginal histograms:

  decideOpenGraph = function( panelCount , saveName , finished=FALSE ,
                              nRow=2 , nCol=3 ) {
    # If finishing a set:
    if ( finished==TRUE ) {
      if ( !is.null(saveName) ) {
        saveGraph( file=paste0(saveName,ceiling((panelCount-1)/(nRow*nCol))),
                   type=saveType)
      }
      panelCount = 1 # re-set panelCount
      return(panelCount)
    } else {
      # If this is first panel of a graph:
      if ( ( panelCount %% (nRow*nCol) ) == 1 ) {
        # If previous graph was open, save previous one:
        if ( panelCount>1 & !is.null(saveName) ) {
          saveGraph( file=paste0(saveName,(panelCount%/%(nRow*nCol))),
                     type=saveType)
        }
        # Open new graph
        openGraph(width=nCol*7.0/3,height=nRow*2.0)
        layout( matrix( 1:(nRow*nCol) , nrow=nRow, byrow=TRUE ) )
        par( mar=c(4,4,2.5,0.5) , mgp=c(2.5,0.7,0) )
      }
      # Increment and return panel count:
      panelCount = panelCount+1
      return(panelCount)
    }
  }

  # Original scale:
  panelCount = 1
  if (!is.na(compVal["beta0"])){
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
    histInfo = plotPost( beta0 , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(beta[0]) , main="Intercept", compVal = as.numeric(compVal["beta0"] ))
  } else {
    histInfo = plotPost( beta0 , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(beta[0]) , main="Intercept")
  }
  for ( bIdx in 1:ncol(beta) ) {
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
    if (!is.na(compVal[paste0("beta[",bIdx,"]")])) {
      histInfo = plotPost( beta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                           xlab=bquote(beta[.(bIdx)]) , main=xName[bIdx],
                           compVal = as.numeric(compVal[paste0("beta[",bIdx,"]")]))
    } else{
      histInfo = plotPost( beta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                           xlab=bquote(beta[.(bIdx)]) , main=xName[bIdx])
    }
  }
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( tau , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(tau) , main=paste("Scale") )
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( Rsq , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(R^2) , main=paste("Prop Var Accntd") )
  panelCount = decideOpenGraph( panelCount ,  saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred1 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred1" , main="Prediction 1" ) # Added by Demirhan
  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred2 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred3 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred4 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred5 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  # Standardized scale:
  panelCount = 1
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( zbeta0 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(z*beta[0]) , main="Intercept" )
  for ( bIdx in 1:ncol(beta) ) {
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
    histInfo = plotPost( zbeta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(z*beta[.(bIdx)]) , main=xName[bIdx] )
  }
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( zVar , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(z*tau) , main=paste("Scale") )
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( Rsq , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(R^2) , main=paste("Prop Var Accntd") )
  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMargZ") )

  #-----------------------------------------------------------------------------
}

#===============PRELIMINARY FUNCTIONS FOR POSTERIOR INFERENCES====================

myData <- read.csv("Assignment2PropertyPrices.csv")
head(myData)

# Scatter plots
p1 <- ggplot(myData, aes(x=Area, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Area") +
  ylab("SalePrice.100K.")

p2 <- ggplot(myData, aes(x=Bedrooms, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Bedrooms") +
  ylab("SalePrice.100K.")

p3 <- ggplot(myData, aes(x=Bathrooms, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Bathrooms") +
  ylab("SalePrice.100K.")

p4 <- ggplot(myData, aes(x=CarParks, y=SalePrice.100K.)) +
  geom_point() +
  xlab("CarParks") +
  ylab("SalePrice.100K.")

p5 <- ggplot(myData, aes(x=PropertyType, y=SalePrice.100K.)) +
  geom_point() +
  xlab("PropertyType") +
  ylab("SalePrice.100K.")

figure <- ggarrange(p1, p2, p3, p4, p5, nrow = 2, ncol = 3)
figure

# Histogram
hist(myData$SalePrice.100K., main= " Histogram of the dependent variable", xlab = "Cost")
# Kernel density estimation
plot(kde(myData$SalePrice.100K.), xlab = "Cost") # with default settings

# THE DATA.
y = myData[,"Y"]
x = as.matrix(myData[,c("X1","X2","X3","X4","X5")])

# Some more descriptives
cat("\nCORRELATION MATRIX OF PREDICTORS:\n ")
show( round(cor(x),3) )
cat("\n")

xPred = array(NA, dim = c(5,5))
xPred[1,] = c(600, 2, 2, 1, 1)
xPred[2,] = c(800, 3, 1, 2, 0)
xPred[3,] = c(1500, 2, 1, 1, 0)
xPred[4,] = c(2500, 5, 4, 4, 0)
xPred[5,] = c(250, 3, 2, 1, 1)

# Specify the data in a list, for later shipment to JAGS:
dataList <- list(
  x = x ,
  y = y ,
  xPred = xPred ,
  Nx = dim(x)[2] ,
  Ntotal = dim(x)[1]
)

# First run without initials!
initsList <- list(
  zbeta0 = 2000,
  zbeta = c(0.009, 1, 1, 1.2, -1.5),
  Var = 12000000
)

# WE WILL RUN THE MODEL WITH SCALING!

# THE MODEL.
modelString = "
# Standardize the data:
data {
  ysd <- sd(y)
  for ( i in 1:Ntotal ) {
    zy[i] <- y[i] / ysd
  }
  for ( j in 1:Nx ) {
    xsd[j] <-   sd(x[,j])
    for ( i in 1:Ntotal ) {
      zx[i,j] <- x[i,j] / xsd[j]
    }
  }
}
# Specify the model for scaled data:
model {
  for ( i in 1:Ntotal ) {
    zy[i] ~ dgamma( (mu[i]^2)/zVar , mu[i]/zVar )
    mu[i] <- zbeta0 + sum( zbeta[1:Nx] * zx[i,1:Nx] )
  }
  # Priors on standardized scale:
  zbeta0 ~ dnorm( 0 , 1/2^2 )  # 1/ variance for normal distribution
  zbeta[1] ~ dnorm( 0.0009/xsd[1] , 1/(0.01/xsd[1]^2) ) # 1/ variance for normal distribution
  zbeta[2] ~ dnorm( 1 , 1/(2/xsd[2]^2) ) ) # 1/ variance for normal distribution
  zbeta[3] ~ dnorm( 0 , 1/4 ) # 1/ variance for normal distribution
  zbeta[4] ~ dnorm( (1.2)/xsd[4] , 1/(0.1/xsd[4]^2) ) # 1/ variance for normal distribution
  zbeta[5] ~ dnorm( (-1.5)/xsd[5] , 1/(0.01/xsd[5]^2) ) # 1/ variance for normal distribution
  zVar ~ dgamma( 0.01 , 0.01 )
  # Transform to original scale:
  beta[1:Nx] <- ( zbeta[1:Nx] / xsd[1:Nx] ) * ysd
  beta0 <- zbeta0*ysd
  tau <- zVar * (ysd)^2

  # Compute predictions at every step of the MCMC
  for ( i in 1:5){
    pred[i] <- beta0 + beta[1] * xPred[i,1] + beta[2] * xPred[i,2] + beta[3] * xPred[i,3] + beta[4] * xPred[i,4] + beta[5] * xPred[i,5]
  }
  # pred[1] <- beta0 + beta[1] * xPred[1,1] + beta[2] * xPred[1,2] + beta[3] * xPred[1,3] + beta[4] * xPred[1,4]
  # pred[2] <- beta0 + beta[1] * xPred[2,1] + beta[2] * xPred[2,2] + beta[3] * xPred[2,3] + beta[4] * xPred[2,4]

}
" # close quote for modelString
# Write out modelString to a text file
writeLines( modelString , con="TEMPmodel_Assignment2.txt" )

parameters = c( "zbeta0" ,  "zbeta" , "beta0" ,  "beta" ,  "tau", "zVar") # Here beta is a vector!

adaptSteps = 1500  # Number of steps to "tune" the samplers
burnInSteps = 5000
nChains = 3
thinSteps = 40 # First run for 3
numSavedSteps = 10000
nIter = ceiling( ( numSavedSteps * thinSteps ) / nChains )

# Parallel run
runJagsOut <- run.jags( method="parallel" ,
                        model="TEMPmodel_Assignment2.txt" ,
                        monitor=c( "zbeta0" ,  "zbeta" , "beta0" ,  "beta" ,  "tau", "zVar", "pred")  ,
                        data=dataList ,
                        inits=initsList ,
                        n.chains=nChains ,
                        adapt=adaptSteps ,
                        burnin=burnInSteps ,
                        sample=numSavedSteps ,
                        thin=thinSteps , summarise=FALSE , plots=FALSE )
codaSamples = as.mcmc.list( runJagsOut )

# save.image(file="rEnvironment.RData")
#load(file="rEnvironment.RData") # Load the results with 124,000 iterations

diagMCMC( codaSamples , parName="beta0" )
diagMCMC( codaSamples , parName="beta[1]" )
diagMCMC( codaSamples , parName="beta[2]" )
diagMCMC( codaSamples , parName="beta[3]" )
diagMCMC( codaSamples , parName="beta[4]" )
diagMCMC( codaSamples , parName="beta[5]" )
diagMCMC( codaSamples , parName="tau" )
diagMCMC( codaSamples , parName="pred[1]" )
diagMCMC( codaSamples , parName="pred[2]" )
diagMCMC( codaSamples , parName="pred[3]" )
diagMCMC( codaSamples , parName="pred[4]" )
diagMCMC( codaSamples , parName="pred[5]" )
diagMCMC( codaSamples , parName="zbeta0" )
diagMCMC( codaSamples , parName="zbeta[1]" )

compVal <- data.frame("beta0" = NA, "beta[1]" = NA, "beta[2]" = NA, "beta[3]" = NA, "beta[4]" =  NA, "tau" = NA , check.names=FALSE)

summaryInfo <- smryMCMC_HD( codaSamples = codaSamples , compVal = compVal )
print(summaryInfo)

plotMCMC_HD( codaSamples = codaSamples , data = myData, xName=c("X1","X2","X3","X4") ,
             yName="Y", compVal = compVal)

# ============ Predictive check ============
coefficients <- summaryInfo[7:11,3] # Get the model coefficients out
Variance <- summaryInfo[12,3] # Get the variance out
# Since we imposed the regression model on the mean of the gamma likelihood,
# we use the model (X*beta) to generate the mean of gamma population for each
# observed x vector.
meanGamma <- as.matrix(cbind(rep(1,nrow(x)),  x)) %*% as.vector(coefficients)
# Generate random data from the posterior distribution. Here I take the
# reparameterisation back to alpha and beta.
randomData <- rgamma(n= 10000,shape=meanGamma^2/Variance, rate = meanGamma/Variance)

# Display the density plot of observed data and posterior distribution:
predicted <- data.frame(elapsed = randomData)
observed <- data.frame(elapsed = y)
predicted$type <- "Predicted"
observed$type <- "Observed"
dataPred <- rbind(predicted, observed)

ggplot(dataPred, aes(elapsed, fill = type)) + geom_density(alpha = 0.2)


 ## prediction equation is
 #y=25.0+1.5*x1+0.8*x2
Y <- matrix(c(25,19,33,23),4,1)
X <- matrix(c(1,1,1,1,-2,-2,2,2,5,-5,5,-5),4,3)
transpose_X=t(X)
transpose_X_X=transpose_X%*%X
inverse_transpose_X_X=solve(transpose_X_X)
inverse_transpose_X_X
# for  estimated standard error use inverse_trasnpose_X_X matrix
s_beta0=2*sqrt(0.25)
s_beta0
s_beta1=2*sqrt(0.0625)
s_beta2=2*sqrt(0.01)
s_beta1
s_beta2


subroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror)
# Find the circumcentre (x0,y0) of the triangle with
# vertices (x(i),y(i)), (x(j),y(j)), (x(k),y(k)).
# Called by qtest1, dirseg, dirout.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3)
logical collin

nerror = -1

# Get the coordinates.
xt(1) = x(i)
yt(1) = y(i)
xt(2) = x(j)
yt(2) = y(j)
xt(3) = x(k)
yt(3) = y(k)

# Check for collinearity
ijk = 0
call cross(xt,yt,ijk,cprd)
if(abs(cprd) < eps) collin = .true.
else collin = .false.

# Form the vector u from i to j, and the vector v from i to k,
# and normalize them.
a  = x(j) - x(i)
b  = y(j) - y(i)
c  = x(k) - x(i)
d  = y(k) - y(i)
c1 = sqrt(a*a+b*b)
c2 = sqrt(c*c+d*d)
a  = a/c1
b  = b/c1
c  = c/c2
d  = d/c2

# If the points are collinear, make sure that they're in the right
# order --- i between j and k.
if(collin) {
        alpha = a*c+b*d
        # If they're not in the right order, bring things to
        # a shuddering halt.
        if(alpha>0) {
		nerror = 3
		return
        }
        # Collinear, but in the right order; think of this as meaning
        # that the circumcircle in question has infinite radius.
        return
}

# Not collinear; go ahead, make my circumcentre.  (First, form
# the cross product of the ***unit*** vectors, instead of the
# ``normalized'' cross product produced by ``cross''.)
crss = a*d - b*c
x0 = x(i) + 0.5*(c1*d - c2*b)/crss
y0 = y(i) + 0.5*(c2*a - c1*c)/crss

return
end


library(deSolve)
library(tidyr)
library(reshape)
library(magrittr)
library(plyr)
library(dplyr)
library(ggplot2)

m <- 4  #number of age classes
mu <- c(0,0,0,1/(55*365)) #death rate in each age group; it is assumed that only adults die
nu <- c(1/(55*365),0,0,0) #is the birth rate into the childhood class; it is assumed only adults give birth.
n <- c(6,4,10,55)/75 # fraction in each age class (assumption that life expectancy is 75 years)
S0 <- c(0.05,0.01,0.01,0.008) # inital value for number of susceptible
E0 <- c(0.0001,0.0001,0.0001,0.0001) # inital value for number of exposed
I0 <- c(0.0001,0.0001,0.0001,0.0001) # inital value for number of infectious
R0 <- c(0.0298, 0.04313333, 0.12313333, 0.72513333) # inital value for number of recovered
ND <- 365 # time to simulate
beta <- matrix(c(2.089, 2.089, 2.086, 2.037, 2.089, 9.336, 2.086, 2.037, 2.086, 2.086,
                 2.086, 2.037, 2.037, 2.037, 2.037, 2.037), nrow=4, ncol=4) # matrix of transmission rates
gamma <- 1/5 # recovery rate
sigma <- 1/8 # rate at which individuals move from the exposed to the infectious classes
TS <- 1 # time step to simualte is days

# combining parameter and initial values
parms <- list(nu=nu, beta=beta, mu=mu, sigma=sigma, gamma=gamma)
INPUT <- c(S0, E0, I0, R0)

# constructing time vector
t_start <- 0 # starting time
t_end <- ND - 1 # ending time
t_inc <- TS #time increment
t_range <- seq(from= t_start, to=t_end+t_inc, by=t_inc) # vector with time steps

# differential equations
diff_eqs <- function(times, Y, parms){
  dY <- numeric(length(Y))
  with(parms,{
    # creates an empty matrix
    for(i in 1:m){
      dY[i] <- nu[i]*n[4] -  beta[,i]%*%Y[2*m + seq(1:m)] * Y[i] - mu[i] * Y[i] # S_i
      dY[m+i] <-  beta[,i] %*% Y[2*m + seq(1:m)] *Y[i] - mu[i] * Y[m+i] - sigma * Y[m+i] #E_i
      dY[2*m+i] <- sigma * Y[m+i] - gamma * Y[2*m + i] - mu[i] * Y[2*m+i] #I_i
      dY[3*m+i] <- gamma * Y[2*m+i] - mu[i] * Y[3*m + i] #R_i
    }
    list(dY)
  })
}

RES2=rep(0,17) #initalizing the result vector
number_years <- 100 #set the number of years to simulate

# initialize the loop
k=1
# yearly ageing
for(k in 1:number_years) {
  RES = lsoda(INPUT, t_range, diff_eqs, parms)
  #taking the last entry as the the new input that then is propagated accoring to the aging
  INPUT=RES[366,-1]
  INPUT[16]=INPUT[16]+INPUT[15]/10
  INPUT[15]=INPUT[15]+INPUT[14]/4-INPUT[15]/10
  INPUT[14]=INPUT[14]+INPUT[13]/6-INPUT[14]/4
  INPUT[13]=INPUT[13]-INPUT[13]/6

  INPUT[12]=INPUT[12]+INPUT[11]/10
  INPUT[11]=INPUT[11]+INPUT[10]/4-INPUT[11]/10
  INPUT[10]=INPUT[10]+INPUT[9]/6-INPUT[10]/4
  INPUT[9]=INPUT[9]-INPUT[9]/6

  INPUT[8]=INPUT[8]+INPUT[7]/10
  INPUT[7]=INPUT[7]+INPUT[6]/4-INPUT[7]/10
  INPUT[6]=INPUT[6]+INPUT[5]/6-INPUT[6]/4
  INPUT[5]=INPUT[5]-INPUT[5]/6

  INPUT[4]=INPUT[4]+INPUT[3]/10
  INPUT[3]=INPUT[3]+INPUT[2]/4-INPUT[3]/10
  INPUT[2]=INPUT[2]+INPUT[1]/6-INPUT[2]/4
  INPUT[1]=INPUT[1]-INPUT[1]/6
  RES2 <- rbind(RES2,RES)
  k=k+1
}

#rescaling time to years
time <- seq(from=0, to=100*(ND+1))/(ND+1)
#changing time to the rescaled time
RES2[ ,"time"] <- time

#labeling of the output from ODE solver
label <- c("S1", "S2", "S3", "S4","E1", "E2", "E3", "E4", "I1", "I2", "I3", "I4", "R1", "R2", "R3", "R4")
label1 <- substr(label, 1, 1)
Age <- substr(label, 2, 2)

df <- data.frame(time = RES2[, 1],
                 label1 = rep(label1, each =  nrow(RES2)),
                 Age = rep(Age, each =  nrow(RES2)),
                 value = c(RES2[, -1]))

# Plot
df$label1 <- factor(df$label1, levels = c("S","E","I","R"))
df$Age <- factor(df$Age)
df %>% mutate(label1 = recode(label1, S = "Susceptible")) %>%
       mutate(label1 = recode(label1, E = "Exposed")) %>%
       mutate(label1 = recode(label1, I = "Infectious")) %>%
       mutate(label1 = recode(label1, R = "Recovered"))  %>%
       mutate(Age = recode(Age, "1" = "0-6 years ")) %>%
       mutate(Age = recode(Age, "2" = "6-10 years ")) %>%
       mutate(Age = recode(Age, "3" = "10-20 years ")) %>%
       mutate(Age = recode(Age, "4" = "20+ years ")) %>%
ggplot() +
   geom_line(aes(x = time, y = value, color = Age)) +
   facet_wrap( ~label1, ncol=1, scales =  "free_y")+
   xlab("Time (years)") + ylab(" Individuals")


set.seed(0)

dot <- function(x){
  return(sum(x * x))
}

### DATA
# Public data
K = 3
M = 10000

# Alice's private data
N1 = 1000
y1 = rnorm(N1)
X1 = matrix(rnorm(N1 * M), N1, M)
C1 = matrix(rnorm(N1 * K), N1, K)

# Bob's private data
N2 = 2000
y2 = rnorm(N2)
X2 = matrix(rnorm(N2 * M), N2, M)
C2 = matrix(rnorm(N2 * K), N2, K)

# Carla's private data
N3 = 1500
y3 = rnorm(N3)
X3 = matrix(rnorm(N3 * M), N3, M)
C3 = matrix(rnorm(N3 * K), N3, K)

### PRIVATE COMPUTE compresses the data.
# Alice computes and secret shares...
yy1 = dot(y1)
Xy1 = t(X1) %*% y1
XX1 = apply(X1,2,dot)

Cty1 = t(C1) %*% y1
CtX1 = t(C1) %*% X1

R1 = qr.R(qr(C1))

# Bob computes and secret shares...
yy2 = dot(y2)
Xy2 = t(X2) %*% y2
XX2 = apply(X2, 2, dot)

Cty2 = t(C2) %*% y2
CtX2 = t(C2) %*% X2

R2 = qr.R(qr(C2))

# Carla computes and secret shares...
yy3 = dot(y3)
Xy3 = t(X3) %*% y3
XX3 = apply(X3, 2, dot)

Cty3 = t(C3) %*% y3
CtX3 = t(C3) %*% X3

R3 = qr.R(qr(C3))

### SECURE MULTI-PARTY COMPUTE is now independent of the sample sizes.
D = N1 + N2 + N3 - K - 1

yy = yy1 + yy2 + yy3
Xy = Xy1 + Xy2 + Xy3
XX = XX1 + XX2 + XX3

Cty = Cty1 + Cty2 + Cty3
CtX = CtX1 + CtX2 + CtX3

invR = solve(qr.R(qr(rbind(R1, R2, R3))))

Qty = t(invR) %*% Cty
QtX = t(invR) %*% CtX

QtyQty = dot(Qty)
QtXQty = t(QtX) %*% Qty
QtXQtX = apply(QtX, 2, dot)

yyq = yy - QtyQty
Xyq = Xy - QtXQty
XXq = XX - QtXQtX

# The endpoints of secure computation are effect size and squared standard error.
beta = Xyq / XXq
sigma_sq = (yyq / XXq - beta^2) / D

# These determine the t statistic and p-value.
sigma = sqrt(sigma_sq)
tstat = beta / sigma
pval = 2 * pt(-abs(tstat), D)

df = data.frame(beta=beta, sigma=sigma, tstat=tstat, pval=pval)

# VERIFY correctness for the first M0 columns of X:
M0 = 5

y = c(y1 ,y2, y3)
X = rbind(X1, X2, X3)
C = rbind(C1, C2, C3)

res = matrix(nrow=0,ncol=4)
for (m in 1:M0) {
  fit = lm(y ~ X[,m] + C - 1)
  res = rbind(res,as.vector(summary(fit)$coefficients[1,]))
}

df2 = data.frame(beta=res[,1], sigma=res[,2], tstat=res[,3], pval=res[,4])

all.equal(df[1:M0,],df2) # Returns TRUE


#### estimating the algorithms for doorspread and wing spread for filling in gaps in the datras flexfile.

library(icesDatras)
library(mgcv)

hh<-getDATRAS("HH","NS-IBTS",c(2003:2020),c(1)) ## HH data downloaded from the ICES data
hh<-hh[hh$HaulVal=="V",]

hh.NL<-hh[hh$Country=="NED",]
hh.NL<-hh.NL[hh.NL$DoorSpread>0,]

# correcting errors not yet changed in Datras
hh.NL[hh.NL$DoorSpread==48,]$DoorSpread<-74
hh.NL[hh.NL$Year==2005 & hh.NL$HaulNo==20,]$DoorSpread<-91
hh.NL[hh.NL$Year==2010 & hh.NL$DoorSpread>98,]$DoorSpread<--9
hh.NL<-hh.NL[hh.NL$DoorSpread>50,]
hh.NL<-hh.NL[hh.NL$Warplngt>0,]
hh.NL<-hh.NL[hh.NL$Depth>1,]

hh.NL$Doorcal.Den<-79.254-(34.368*exp(-0.029*hh.NL$Depth)) ## Danish algorithm for doorspread
hh.NL$Doorcal.MAF<-(33.251*log10(hh.NL$Depth))+ 15.744 ## Algorithm proposed by the EU project MAFCONS

plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,140))
lines(hh.NL$Doorcal.Den~hh.NL$Depth, col="blue")
lines(hh.NL$Doorcal.MAF~hh.NL$Depth, col="red")
# clear underestimation of the Dutch values

mm<-lm(hh.NL$Warplngt~hh.NL$Depth)

hh.NL<-hh.NL[is.na(hh.NL$Depth)==F,]
hh.NL<-hh.NL[is.na(hh.NL$Warplngt)==F,]

DoorSpread<- hh.NL$DoorSpread
Depth<- hh.NL$Depth
Warplngt<- hh.NL$Warplngt

t1<-nls(hh.NL$DoorSpread~a*log10(hh.NL$Depth)+d*log10(hh.NL$Warplngt)+ b, start = list(a = 16, b = -30, d = -15))

test1<-data.frame(Depth=seq(0,200,by=1))
test1$Warplngt<-mm$coefficients[1]+test1$Depth*mm$coefficients[2]

test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]
lines(test1$nls.fun~test1$Depth, col="gold")
## better fit
summary(t1)$parameters

###forcing to a doorspread of zero
zero<-hh.NL[1,]
zero$DoorSpread<-45
zero$Depth<-10
zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

max<-hh.NL[1,]
max$DoorSpread<-100
max$Depth<-180
max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

hh.NL1<-rbind(zero,hh.NL,max)
we = rep(1, dim(hh.NL1)[1])
we[1]<-1000
we[length(we)]<-1000

d1<-hh.NL1$DoorSpread
d2<-hh.NL1$Depth
d3<-hh.NL1$Warplngt

t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -30, d = -15))
test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]
lines(test1$nls.fun~test1$Depth, col="green")

##### year effect

plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,140))

for(i in unique(hh.NL$Year)){
d1<-hh.NL[hh.NL$Year==i,]$DoorSpread
d2<-hh.NL[hh.NL$Year==i,]$Depth
d3<-hh.NL[hh.NL$Year==i,]$Warplngt

t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b, start = list(a = 16, b = -30, d = -15))
test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

lines(test1$nls.fun~test1$Depth, col=i)
Sys.sleep(3)
}

#### groups 2003+2004, 2005-2014, 2015+2016, 2017-2020
plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,120), xlab="Depth (m)",ylab="Doorspread (m)")

zero<-hh.NL[1,]
zero$DoorSpread<-55
zero$Depth<-10
zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

max<-hh.NL[1,]
max$DoorSpread<-110
max$Depth<-180
max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2003,2004),],max)
we = rep(1, dim(hh.NL1)[1])
we[1]<-5
we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 # plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
    lines(test1$nls.fun~test1$Depth, col="red")
  summary(t1)$parameters

#####2005-2014

  zero<-hh.NL[1,]
  zero$DoorSpread<-55
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2005:2014),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 # plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="blue")
  summary(t1)$parameters

  #####2015-2016

  zero<-hh.NL[1,]
  zero$DoorSpread<-45
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2015:2016),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 #plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="green")
  summary(t1)$parameters

  ### 2017-2020
  zero<-hh.NL[1,]
  zero$DoorSpread<-55
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2017:2020),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 #plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="gold")
  summary(t1)$parameters


#'@title calcHMThrustFactor
#'
#'@description Calculate thrust deduction factor (\code{thrustFactor})
#'(dimensionless) from the Holtrop & Mennen method.
#'
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCp}})
#'@param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless) (see
#' \code{\link{calcCbw}})
#'@param Cstern Afterbody form coefficient: \itemize{\item V-shaped Hull = -10
#'         \item U-Shaped Hull =  10
#'         \item Normal Hull = 0 (default)}
#' Can supply either a vector of numericals, a single number, or rely on the default
#'@param lcb Longitudinal position of center of buoyancy (vector of numericals, see
#' \code{\link{calclcb}})
#'@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
#'
#'@details
#'Thrust deduction factor is a component of hull efficiency as well as a
#'component of propeller efficiency. It describes the increase in resistance on
#'the hull from water getting sucked back towards the propeller.
#'
#'Note: In "A Statistical Re-Analysis of Resistance and Propulsion Data", the
#'authors re-analyze with the inclusion of Series 64 hull forms for a total of
#'334 models included in the analysis. They suggest an update of the single
#'screw thrust equation but that the original equations should be used
#'for twin screw ships.
#'
#'Additionally, we are assuming conventional stern for all single screw ships.
#'Holtrop & Mennen also include an estimation for thrust factor for single screw
#'ships with open stern for fast sailing ships, but that is not included here.
#'
#'@return \code{thrustFactor} (vector of numericals, dimensionless)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calclcb}}}
#'
#'@family Holtrop-Mennen Calculations
#'
#'@examples
#' calcHMThrustFactor(c(32.25,32.20),c(218.75,209.25),c(13.57,11.49),c(80097,52382.04),
#'                    c(1,1),c(0.81,0.67),c(6.7,7),c(0.81,0.65))
#' calcHMThrustFactor(32.25,218.75,13.57,80097,
#'                    1,0.81,6.7,0.81)
#'
#'@export

calcHMThrustFactor<- function(breadth,lwl,maxDraft,maxDisplacement,nProp,Cp,
                         propDiam,Cbw,Cstern=0,lcb=0,seawaterDensity=1.025){

  #================
  c10<- ifelse(lwl/breadth<5.2,#case 1
               0.25-(0.003328402/((breadth/lwl)-0.134615385))
  ,#case 2
    breadth/lwl
  )
  #================

  thrustFactor<- ifelse(nProp==1,#begin single screw estimation ([2] method)
    0.25014*((breadth/lwl)^0.28956)*
      ((sqrt(breadth*maxDraft)/maxDisplacement)^0.2624)/
    ((1-Cp+0.0225*lcb)^0.01762)+0.0015*Cstern

    #end single screw estimation
  ,#begin twin screw estimation ([1] method)
    0.325*Cbw-0.1885*propDiam/sqrt(breadth*maxDraft)

  )#end twin screw estimation

  return(thrustFactor)
}


#edf plot
#  use beta distribution as an example
par(mfrow=c(2,2))
a <- 3
b <- 1.5
n <- 30
x <- seq(0, 1, length=100)
f <- dbeta(x, a, b)
plot(x, f, type="l", main="pdf")
F <- pbeta(x, a, b)
plot(x, F, type="l", main="CDF")
X <- rbeta(n,a,b)
hist(X, main=paste(n,"samples"), xlim=c(0,1))
rug(X)
eF <- ecdf(X)
plot(eF, main="EDF", verticals=TRUE, xlim=c(0,1))
par(mfrow=c(1,1))

#bootstrap resample of martin
martin <- c(0.13,-0.01,-0.01,0.42,-0.02,0.01,0.09,0.03,0.04,0.06,0.12,0.03)
nreps <- 1000
how.often <- matrix(NA, nrow=nreps, ncol=length(martin))
for(i in 1:nreps) how.often[i,] <- sample(martin,length(martin),replace=TRUE)
table(how.often)

boot.martin <- function(data, b, alpha, type="nonp") {
#  Purpose:  compute 95% CI endpoints for dataset
#  Input: dataset, number of replicates, type in ("nonp", "par-norm", "par-t")
#  output: histogram with CI endpoints
  boot <- matrix(NA, nrow=b+1, ncol=length(data))
  m <- mean(martin)
  sd <- sd(martin)
  title <- paste(b, type, "bootstraps", sep=' ')
  if (type == "nonp") {
    for(i in 1:b) {boot[i,] <- sample(data,length(data),replace=TRUE) }
  } else {
    if (type=="par-norm") {
    for(i in 1:b) {boot[i,] <- rnorm(length(data),m,sd) }
    } else {
      if (type=="par-t") {
      for(i in 1:b) {boot[i,] <- (rt(length(martin),length(martin)-1)*sd)+m }
      } else {
        stop("Bootstrap type !in 'nonp', 'par-norm', 'par-t")
      }}}

  n.elements <- b+1
  boot[n.elements, ] <- data
  mean.boot <- apply(boot,1,mean)  # rowMeans would work equally well
  hist(mean.boot, main=title, freq=FALSE)
  m <- mean.boot[1:b]
  x <- order(m)
  lower.quantile <- floor(alpha/2 * n.elements)
  upper.quantile <- ceiling((1-alpha/2) * n.elements)
  endpoints <- c(m[x[lower.quantile]], m[x[upper.quantile]])
  abline(v=endpoints[1], lty=2)
  abline(v=endpoints[2], lty=2)
  return(endpoints)
}

boot.martin(martin, b=99, alpha=0.05)
boot.martin(martin, b=999, alpha=0.05, 'par-norm')
boot.martin(martin, b=999, alpha=0.05, 'par-t')
boot.martin(martin, b=999, alpha=0.05, 'para-norm')


#media poblacional entre 2 muestras independientes

#mtcars es un built in dataframe mpg es el gas milage de los autos en 1974
#mt$am es el tipo de transmisi??n de los autos

'''
Assuming that the data in mtcars follows the normal distribution,
find the 95% confidence interval estimate of the difference between
the mean gas mileage of manual and automatic transmissions.
'''

#autos con transmision automatica
L = mtcars$am == 0
mpg.auto = mtcars[L,]$mpg

#autos con transmision manual

mpg.manual = mtcars[!L,]$mpg

t.test(mpg.auto,mpg.manual)

#otra forma

t.test(mpg ~ am, data=mtcars)

Parcial/3. Inferencia entre poblaciones/PopulationMeanTwoIndependentSamples.r


library(GA)

p <- c(15, 100, 90, 60, 40, 15, 10, 1, 1, 2, 3, 4)      # wartości przedmiotów
w <- c(2,  20, 20, 30, 40, 30, 60, 10, 10, 40, 30, 50)  # wagi
cap <- 113                                              # pojemność plecaka

knapsackFitness <- function(knapsack) {
  value <- sum(knapsack * p)
  weight <- sum(knapsack * w)

  # Funkcja kary, gdy nie używamy monitora
  if (weight > cap) {
    # value <- 0  # prosty element kary
    # value <- value * (cap/weight/1.1)
    value <- value - weight + cap
  }

  value
}

knapsackMonitor <- function(obj, digits = getOption("digits"), ...)
{
  for(i in 1:nrow(obj@population)) {
    weight <- sum(obj@population[i,] * w)
    while (weight > cap) {
      removeThing <- sample.int(length(p) - 1, 1) + 1
      obj@population[i,removeThing] <- 0
      weight <- sum(obj@population[i,] * w)
    }
  }

  fitness <- na.exclude(obj@fitness)
  sumryStat <- c(mean(fitness), max(fitness))
  sumryStat <- format(sumryStat, digits = digits)
  cat(paste("GA | iter =", obj@iter, "| Mean =", sumryStat[1],
            "| Best =", sumryStat[2]))
  cat("\n")
  flush.console()
}

set.seed(123)
GA <- ga(
  type = "binary",
  fitness = knapsackFitness,
  nBits = length(p),
  popSize = 50,
  maxiter = 1000,
  run = 100,
  seed = 123,
  monitor = knapsackMonitor
)

summary(GA)
plot(GA)


dev.off()

x = seq(1.8, 5.2, 0.1)

f1 <- function(x) {
  x^3 - 10*x^2 + 31*x - 30
}
f2 <- function(x) {
  3*x^2 - 20*x + 31
}

par(mfrow=c(2,1))
plot(x, f1(x), type='l')
abline(h=0)
points(2.45, f1(2.45))
points(4.22, f1(4.22))

plot(x, f2(x), type='l', yaxs="r")
abline(h=0)
points(2.45, f2(2.45))
points(4.22, f2(4.22))


# Abundant, deficient and perfect number classifications. 12/10/16 aev
require(numbers);
propdivcls <- function(n) {
  V <- sapply(1:n, Sigma, proper = TRUE);
  c1 <- c2 <- c3 <- 0;
  for(i in 1:n){
    if(V[i]<i){c1 = c1 +1} else if(V[i]==i){c2 = c2 +1} else{c3 = c3 +1}
  }
  cat(" *** Between 1 and ", n, ":\n");
  cat("   * ", c1, "deficient numbers\n");
  cat("   * ", c2, "perfect numbers\n");
  cat("   * ", c3, "abundant numbers\n");
}
propdivcls(20000);


# MULTIPLY transaction rates in a given cycle to obtain possible profit
fw.mult <- function(nodes, edges, rates, cycle) {

    profit = 1

    # find and multiply by pairs
    for (i in 1:(NROW(cycle)-1)) {
        next_value = rates[which(edges[,1]==nodes[cycle[i]] & edges[,2]==nodes[cycle[i+1]])]
        profit = profit * as.numeric(next_value)
    }

    # as number
    return(profit)
}

# RETRIEVE a path given a predecessor array and a source/target pair of nodes
fw.path <- function(nexts, source, target) {

    if(!is.numeric(source) | !is.numeric(target)) {
        cat("error: fw-path: no-numerical source/target\n")
        return()
    }

    if (nexts[source][target] == -1) {
        cat("error: fw-path: no paths between source/target\n")
        return()
    }

    # track steps
    path = c(source)
    following = nexts[source]
    while (following != target) {
        path = c(path, following)
        following = nexts[following, target]
    }

    # do last step
    path = as.matrix(c(path, target))

    # as vector
    return(path)
}

# APPLY classic Floyd-Warshall Algorithm
fw.find <- function(graph, summary, debug=T) {

    # receive graph as an EDGE LIST with the following format:
    #
    #        [,1]    [,2]    [,3]
    # [1,]  node 1  node 2  weight
    # [1,]  node 1  node 3  weight
    # [1,]  node 2  node 1  weight
    #   .     .       .       .
    #   .     .       .       .
    #   .     .       .       .

    # ready data
    edges = as.matrix(graph)
    nodes = unique(matrix(edges[,1:2], ncol=1))
    weights = as.numeric(as.character(edges[,3]))

    # distances matrix
    dists = matrix(rep(Inf, NROW(nodes)**2), nrow=NROW(nodes), byrow=T)

    # path reconstruction
    nexts = matrix(rep(-1, NROW(nodes)**2), nrow=NROW(nodes), byrow=T)

    # copy existing distances
    for (i in 1:NROW(edges)) {
        u = which(nodes==edges[i, 1]) # from
        v = which(nodes==edges[i, 2]) # to
        dists[u, v] = weights[i]
        nexts[u, v] = v
    }

    # distance to itself is zero
    for (i in 1:NROW(nodes)) {
        dists[i, i] = 0
    }

    if (debug) {
        cat("Applying Floyd-Warshall algorithm\n")
    }

    for (k in 1:NROW(nodes)) {

        if (debug) {
            cat("  computing all paths passing through node", k, "\n")
        }

        for (i in 1:NROW(nodes)) {
            for (j in 1:NROW(nodes)) {
                if (dists[i, k] + dists[k, j] < dists[i, j]) {
                    dists[i, j] = dists[i, k] + dists[k, j]
                    nexts[i, j] = nexts[i, k]
                }
            }
        }
    }

    # check for cycles
    cycle = NULL
    profit = NULL
    for (i in 1:NROW(nodes)) {

        if (dists[i, i] < 0) {
            # cycle path
            cycle = fw.path(nexts, i, i)

            # cycle mult
            rates = as.numeric(as.character(summary[,3]))
            profit = fw.mult(nodes, edges, rates, cycle)

            if (debug) {
                cat("Arbitrage cycle found!\n")
                print(nodes[cycle])
                cat("Possible profit:", profit, "\n")
            }

            break
        }
    }

    if (NROW(cycle) == 0) {
        if (debug) {
            cat("No negative cycles found :(\n")
        }
    }

    ret = list()
    ret$nodes = nodes
    ret$cycle = cycle
    ret$profit = profit

    return(ret)
}


=begin
  # sample-cayleyhamilton01.rb

  require "algebra"

  n = 4
  R = MPolynomial(Integer)
  MR = SquareMatrix(R, n)
  m = MR.matrix{|i, j| R.var("x#{i}#{j}") }
  Rx = Polynomial(R, "x")
  ch = m.char_polynomial(Rx)
  p ch.evaluate(m) #=> 0
((<_|CONTENTS>))
=end


bayes <- function(prior, likelihood, data)
{
	posterior <- matrix(0, nrow=length(data), ncol=length(prior))
	dimnames(posterior) <- list(data, names(prior))

	initial_prior = prior
	for(i in 1:length(data))
	{
		posterior[i, ] <-
			prior*likelihood[ , data[i]]/
			sum(prior * likelihood[ , data[i]])

		prior <- posterior[i , ]
	}

	return(rbind(initial_prior,posterior))
}


# n = 20;
# alpha = 0.01;
# x = rnorm(n, mean=10.5, sd=1.3);
#
# # 1.1
# hypothesisTest = t.test(x, mu=10, conf.level = 1-alpha);
# print(hypothesisTest);
#
# #1.1.a
# avg = mean(x);
# stDev = sd(x);
#
# critVal = qt(1-alpha/2, n-1, lower.tail = TRUE);
# lowBound = avg - (stDev * critVal)/sqrt(n);
# upBound = avg + (stDev * critVal)/sqrt(n);
# print((stDev * critVal)/sqrt(n))
#
# #!.1.b
# #TODO if
# print(lowBound);
# print(upBound);
#
# #1.1.c TODO if
# tVal = sqrt(n)*(avg-10)/stDev;
# critVal = qt(1-alpha/2, n-1, lower.tail = TRUE);
#
# lowBound = pt(tVal, n-1, lower.tail = FALSE);
# upBound = pt(tVal, n-1, lower.tail = TRUE);
# pVal = 2*min(lowBound, upBound);
# print(2*lowBound);
# print(2*upBound);
#
# #1.2
# #vybereme jednostranny t-test a cele to zopakujeme
# #Expiricky vime, ze avg = 10.5 a u = 10, proto je vyhodnejsi alternativa greater, protoze s danou pravdepodobnosti jsme schopni rict, ze hodnota je vetsi nez deset. Diky vlastnostem generovanych dat takto casteji zavrhneme H0 a pouzijeme Halph
#
# n = 20;
# alpha = 0.01
# x = rnorm(n, mean=10, sd=1)
# error = rnorm(n, mean=0.5, sd=0.8306624)
# y = x + error
#
# t.test(x, y=y, paired = TRUE, alternative = "less", conf.level = 1-alpha)
#

#2.1
# n = 20;
# alpha = 0.01
# x = rnorm(n, mean=10, sd=1)
# error = rnorm(n, mean=0.5, sd=0.8306624)
# y = x + error
#
# t.test(x, y=y, paired = TRUE, alternative = "less", conf.level = 1-alpha)

# n = 20;
# alpha = 0.01
# x = rnorm(n, mean=10, sd=1)
# error = rnorm(n, mean=0.5, sd=0.8306624)
# y = x + error
#
# res = t.test(x, y=y, paired = TRUE, alternative = "less", conf.level = 1-alpha)
# print(res)
# if(abs(res$statistic) > qt(1-alpha, n-1, lower.tail = TRUE)) {
#   print('Reject null hypothesis!')
# }

# 2.1.b
# res = t.test(x-y, alternative = "less", conf.level = 1-alpha)
# print(res)

#2.2
# n1 = 20;
# n2 = 25;
# alpha = 0.01
# x=rnorm(n1, mean=10, sd=1.3)
# y=rnorm(n2, mean=11.25, sd=1.3)
# res = t.test(x, y=y, paired = FALSE, var.equal = TRUE, alternative = "less", conf.level = 1-alpha)
# print(res)
# if(abs(res$statistic) > qt(1-alpha, n1+n2-2, lower.tail = TRUE)) {
#   print('Reject null hypothesis!')
# }

n1 = 20;
n2 = 25;
alpha = 0.01
x=rnorm(n1, mean=10, sd=1.3)
y=rnorm(n2, mean=11.28, sd=1.2)
res = t.test(x, y=y, paired = FALSE, var.equal = FALSE, alternative = "less", conf.level = 1-alpha)
print(res)
if(abs(res$statistic) > qt(1-alpha, n1+n2-2, lower.tail = TRUE)) {
  print('Reject null hypothesis!')
}

#
# #2.2
# n1 = 20;
# n2 = 25;
# alpha = 0.01
# x=rnorm(n1, mean=10, sd=1.3)
# y=rnorm(n2, mean=11.25, sd=1.3)
#
# res = t.test(x, y=y, paired = FALSE, var.equal = TRUE, alternative = "less", conf.level = 1-alpha)
# print(res);

df = n1 + n2 - 2;
sdiff = sqrt(var(x)/n1+var(y)/n2);
tVal = (mean(x)-mean(y))/(sdiff);
print(tVal)
if(abs(tVal) > qt(1-alpha, df, lower.tail = TRUE)) {
  print('Reject null hypothesis!')
}

# critVal = qt(1-alpha, df, lower.tail = TRUE);
#print(pt(tVal, df, lower.tail = TRUE))
#print(qt(res$p.value, df));

#2.3
# n1 = 20;
# n2 = 25;
# alpha = 0.01
# x=rnorm(n1, mean=10, sd=1.3)
# y=rnorm(n2, mean=11.28, sd=1.2)

# t.test(x, y=y, paired = FALSE, var.equal = FALSE, conf.level = 1-alpha)
#zodpadkovat vsechny kroky
#bude nutne prepsat vypocet bodu 2.2 podle vzorce pro rozdilne rozptyly
#... kdyz se muze clovek rozptylovat, muze se i ptylovat?

#3.1.a,b,c
# sequenceLength = 4000000;
# x = runif(sequenceLength, 0, 100)
# print(system.time(sort(x)))

#pouzijeme hypotezu X1 < X2 ..tj, je algoritmus X1 v prumeru rychlejsi?
#


#равномерно разпределение - равномерно разпределени случайни величини в интервал [a,b]
#функцията unif() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)

#100 случайни равномерно разпределени величини в интервала [0,2]
x = runif(n = 100, min = 0, max = 2)
hist(x, probability=TRUE, col=gray(.9), main="uniform on [0,2]") #хистограма на разпределението
curve(dunif(x,0,2),add=T) #теоретична плътност -> dunif(x,0,2) всяка от случайните величини с каква вероятност да се случи е

#генериране на извадка -> измежду числата x (от 1 до х, ако х е число, а не вектор), се взимат по случаен начин size числа
sample(x = 1:10, size = 10)
sample(x = 10, size = 10, replace = TRUE) #може да има повторения

#геометрично разпределение - частен случай на отрицателно биномното, кoгато искаме да имаме x неуспеха преди първия успех с вероятност за успех prob
#функцията geom() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)
Y=0:10
plot(Y, dgeom(x = Y, prob = 0.6), type="h", ylim=c(0,1), main="Geometric distribution for p=0.6", ylab="P(Y=Y)", xlab="Y=Number of failures before first success")

#екцпоненциално разпределение - непрекъсната случайна величнина
#функцията exp() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)
mu = 2500
x = rexp(n = 100, rate = 1/mu) #100 случайни експоненциално разпределени величини с вероятност 1/mu
hist(x,probability=TRUE,col=gray(.9),main="exponential mean=2500") #хистограма
curve(dexp(x = x, rate = 1/2500),add=T) #теоретична плътност

#нормално разпределение - очакване(средно) mu и дисперсия sigma (стандартно отклонение sigma)
#функцията norm() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)
#на финкцията се подава очакване (mu) и стандартно отклонение (sigma)
x=c(1:200)
plot(dnorm(x, 100,10), ylim=c(0,0.1))
lines(dnorm(x, 100,5), col="red")
lines(dnorm(x, 130,10), col="blue")

#стандартно нормално разпределение - нормално разпределение с очакване 0 и дисперсия 1
#по подразбиране в norm(x, mu = 0, sd = 1)
#за нормализиране се използва формулата y = (x - mu)/sigma
#където х е нормално разпределена случайна величина с очакване mu и дисперсия sigma^2,
#а у е стандарна нормално разпределене случайна величина

#-----------------------------------------------------

#01
#геометрично разпределение с вероятност 1/2, 1/3, 2/3
y=0:10 #случайни числа(за онагледяване)
plot(x = y, dgeom(x = y, prob = 1/2), ylim=c(0,0.8), ylab = "Probability", xlab = "Number of fails before the first success")
lines(x = y, dgeom(x = y, prob = 1/3), col="red")
lines(x = y, dgeom(x = y, prob = 2/3), col="blue")

#02
#експоненциално разпределение с mu =5
k.30 = dexp(x = 5, rate = 1/5)
plot(x = 1:30, y = dexp(x = 1:30, rate = 1/5), main = "Exponentila with mu = 5", ylab = "P(X = x)")

#03
x = rnorm(n = 50, mean = 5, sd = 5) #N(5,5) означава дисперсия 5 = sigma^2 => стандартно отклонение sigma = sqrt(5), но в случая няма значение :)
x.norm = (x - 5)/5
hist(x.norm, probability = TRUE)
x.standart = rnorm(50)
hist(x.standart, probability = TRUE)

#04
#z стандартно нормално разоределена случайна величина
pnorm(q = 0.92 , lower.tail = FALSE) #P(Z > 0.92)
pnorm(q = -0.5, lower.tail = FALSE) #P(Z > -0.5) = P(Z < 0.5)
#P(-0.64 < Z < 0.43) = P(Z < 0.43) - P(Z > -0.64)
pnorm(0.43) - pnorm(-0.64, lower.tail = FALSE)

#05
#x нормално разпределено с mu = 3 и sigma^2 = 4
pnorm(q = 6.2, mean = 3, sd = 2)

#06
pnorm(q = 3100, mean = 3500, sd = 500)
pnorm(-4/5) #нормирано z = (3100 - 3500)/500 = -4/5 е стандартно нормално разпределено N(0,1)

#07
#X = N(80, 10^2), Y=N(78, 13^2) => X-Y = N(80-78, 10^2 + 13^3) = N(2,269)
pnorm(0,2,sqrt(269),lower.tail = FALSE) #искаме Х > Y => X - Y > 0


#'@title Compute and return the degree measure of the angle of the slope of the time series.
#'
#'@description The time series is fitted with a linear model and the degree measure of the angle of the slope is returned.
#'
#'@usage  angleMagnitude <- getSlopeAngleSize(tsData)
#'
#'@param tsData A time series object.
#'
#'@return A numeric value representing the degree measure of the angle of the slope of the time series.
#'
#'@export

getSlopeAngleSize <- function(tsData)
{

    tsObj    <- tsData
	tsObj.lm <- lm(tsObj ~ time(tsObj))

	degreeAngleMeasure <- as.numeric(atan(tsObj.lm$coefficients[2])*(180/pi))

	return (degreeAngleMeasure)

}


#' Scale variable to have range between 0 and 1
#'
#' @param x Vector
#'
#' @export
#' @return Vector
range01 <- function(x)
{
	(x-min(x))/(max(x)-min(x))
}

#' Translate risk from liability to probability scale
#'
#' @param gx score on liability scale
#' @param h2x Disease heritability on liability scale
#' @param prev Prevalence
#'
#' @export
#' @return Vector of disease probabilities
gx_to_gp <- function(gx, h2x, prev)
{
	x_prime <- qnorm(prev, 0, 1)
	p <- pnorm(x_prime, mean=gx, sd = sqrt(1 - h2x), lower.tail=FALSE)
	return(p)
}

#' Plot liability vs probability disease risk
#'
#' @param x Disease risk on liability scale
#' @param o Disease risk on probability scale
#' @param xlab default="Values (low to high)"
#' @param ylab default=""
#' @param title default=""
#' @param xname Name of liability. Default="GRS"
#' @param oname Name of disease. Default="Disease"
#'
#' @export
#' @return ggplot
risk_cross_plot <- function(x, o, xlab="Values (low to high)", ylab="", title="", xname="GRS", oname="Disease")
{
	d <- dplyr::tibble(
		value = c(range01(o), range01(x)),
		key = c(rep(oname, length(o)), rep(xname, length(x))),
		gr = rep(1:length(x), times=2)
	)
	d$key <- factor(d$key, levels=c(xname, oname))
	ggplot2::ggplot(d, ggplot2::aes(x=value, y=key)) +
	ggplot2::geom_line(ggplot2::aes(group=gr), alpha=0.1) +
	ggplot2::geom_point(ggplot2::aes(colour=key)) +
	ggplot2::labs(x=xlab,y=ylab,title=title) +
	ggplot2::scale_colour_discrete(guide=FALSE) +
	ggplot2::theme(axis.text.x=ggplot2::element_blank(),axis.ticks.x=ggplot2::element_blank())
}

#' Make simulation to compare disease and liability scales
#'
#' Compares the liability and probability of disease under two scenarios - where all SNPs are known, and where only some SNPs are known
#'
#' @param G Matrix of genotypes
#' @param eff SNP effects on liability scale
#' @param prevalence Disease prevalence
#' @param prop_discovered Proportion of SNPs discovered
#'
#' @export
#' @return Data frame
risk_simulation <- function(G, eff, prevalence, prop_discovered)
{
	nid <- nrow(G)
	nsnp <- ncol(G)
	gx_true <- scale(G) %*% eff
	h2x <- var(gx_true)
	prob_disease <- gx_to_gp(gx_true, h2x, 1-prevalence)
	disease <- rbinom(nid, 1, prob_disease)
	eff_pred <- eff
	eff_pred[sample(1:nsnp, nsnp * (1-prop_discovered))] <- 0
	gx_pred <- as.numeric(G %*% eff_pred / sqrt(nsnp))
	dat <- dplyr::tibble(gx_true=as.numeric(gx_true), gx_pred=gx_pred, prob_disease=as.numeric(prob_disease), disease=disease)
	return(dat)
}


#Adjacency matrix1 i/p based on given undirected graph
adj_mat1 <- matrix(c(0,1,0,0,3,0,1,2,2,1,0,0,0,2,0
                    ,1,1,1,0,1,1,0,0,0,3,0,1,0
                    ,0,0,0,0,1,0,0,2),byrow = T,6,6)
show(adj_mat1)
degree <- rowSums(adj_mat1)
vertex <- seq(1,6)
show(data.frame(vertex,degree))

#Adjacency matrix2 i/p based on given directed graph
adj_mat2 <- matrix(c(0,0,0,1,0,0,0,0,1,0,0,0,1,0,0
                     ,0,1,0,0,0,0,0,0,1,0,0,0,
                     1,0,1,0,1,0,0,0,0),byrow = T,6,6)
show(adj_mat2)
degree_in <- rowSums(adj_mat2)
degree_out <- colSums(adj_mat2)
show(data.frame(vertex,degree_in,degree_out))


# Example : 3   Chapter : 8.3     Page No: 433
# Markov matrix Application.
A<-matrix(c(0,0.5,0.5,0.5,0,0.5,0.5,0.5,0),ncol=3)
u0<-c(8,16,32)
u1<-A%*%u0
u2<-A%*%u1
u3<-A%*%u2
print("Populations in three groups in subsequent months")
print(u1)
print(u2)
print(u3)


#Copyright 2016 Lingjiao Chen, Arun Kumar, Jeffrey Naughton, and Jignesh M. Patel, Version 0.8.
#All rights reserved.
#
#Licensed under the Apache License, Version 2.0 (the "License");
#you may not use this file except in compliance with the License.
#You may obtain a copy of the License at
#
#    http://www.apache.org/licenses/LICENSE-2.0
#
#Unless required by applicable law or agreed to in writing, software
#distributed under the License is distributed on an "AS IS" BASIS,
#WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#See the License for the specific language governing permissions and
#limitations under the License.

KmeansClustering <- function(Data,Max_Iter,Center_Number,k_center,nS)
{
# k_center is the k centers, and YA is the assignment
	All1 = matrix(1, nS, 1);
	All1_k = matrix(1,1,Center_Number);
	All1_C = t(matrix(1,1,nrow(k_center)));
	T2 = rowSums(Data^{2}) %*% All1_k;
	T22 = Data * 2;
	for( k in 1: Max_Iter )
	{
		Dist = T2 - as.matrix(T22 %*% k_center ) +  All1 %*% colSums(k_center ^2);
		YA = (Matrix(Dist == (rowMins((Dist)) %*% All1_k),sparse=TRUE))+0;
		k_center = as.matrix(  ( t(Data) %*% YA ) / ( (All1_C) %*% colSums(YA) )  );
	}
	return(list(k_center ,YA));
}


#   N-мерни променливи и изследване на връзките между тях

#       Какво предсталяват "n"-мерните данни?
#       Едномерните данни, това са масиви/листа от обекти (числа, стрингове, дати, друг тип обекти).
#   При двумерните данни имаме колекция от едномерни данни. Тоест, представянето е във формата на
#   матрици, data frame-ове или друга подобна структура, при която най-често по редове са представени
#   примерите/елементите, а по колони техните признаци (променливите).

# Пример за многомерни данни е
data("mtcars")
head(mtcars)
mtcars

# Нека да изследваме обема на двигателя за въпроснтие коли. Първо ще построим хистограма
hist(
  x = mtcars$disp,
  col = "red",
  xlab = "Displacement (u.in.)",
  main = "Histogram"
)

summary(mtcars$disp)
sd(mtcars$disp)

abline(v = mean(mtcars$disp), lwd = 2, lty = 4)
abline(v = median(mtcars$disp), lwd = 2, lty = 4, col = "blue")

#   От хистограмата се вижда, че имаме два пика.
#   Тоест, разпределението на променливата е
#   бимодално. Черната вертикалана прекъсната линия показва къде се намира средната стойност,
#   а синята прекъсната - медината. И в двата случая, малко трудно можем да приемем, че това е
#   очакването на разпределението.

#   Нека сега да проверим, какво би станало, ако групираме данните по броя на цилиндрите
disp_cyl4 <- mtcars$disp[which(mtcars$cyl == 4)]
disp_cyl6 <- mtcars$disp[which(mtcars$cyl == 6)]
disp_cyl8 <- mtcars$disp[which(mtcars$cyl == 8)]

par(mfrow = c(2, 2))
hist(x = disp_cyl4, col = "red", xlab = "4 cylinders", main = "Histogram of displacement (u.in.)")
hist(x = disp_cyl6, col = "lightblue", xlab = "6 cylinders", main = "Histogram of displacement (u.in.)")
hist(x = disp_cyl8, col = "forestgreen", xlab = "8 cylinders", main = "Histogram of displacement (u.in.)")
par(mfrow = c(1, 1))

summary(disp_cyl4)
sd(disp_cyl4)

summary(disp_cyl6)
sd(disp_cyl6)

summary(disp_cyl8)
sd(disp_cyl8)

#   За групата на двигетелите, които имат 4 цилиндъра, все още не може да получим добра оценка
#   за очакването, но за другите две групи - можем, защото имаме по един връх.

#   Анализирайки зависимостите на една променлива от други променливи, ние успяваме да подобрим
#   оценките на параметрите, които са ни неогходи. По този начин правим прогнозите си по-точни.

################################
#   Изследване на двумерни данни

#   1. Категорийни (обясняващи) VS категорийни (зависими)
#   Връзките между тези променливи най-лесно се виждат с помощта на cross таблици и barplot-ове.

#   Пример: Направили сме хипотетично прочуване, което измерва дали студентите, които пушат,
#   учат по-малко.

smokes <- c("Y", "N", "N", "Y", "N", "Y", "Y", "Y", "N", "Y")
amount <- c("0 - 5 hours", "5 - 10 hours", "5 - 10 hours", "more than 10 hours",
            "more than 10 hours", "0 - 5 hours", "5 - 10 hours", "0 - 5 hours",
            "more than 10 hours", "5 - 10 hours")
table(amount, smokes)
#   Данните показват, че пушачите учат по-малко от непушачите. Нека да разгледаме резулатите
#   не като честоти, а като проценти. За целта изпозлвае командата

prop.table(x = table(amount, smokes))
#   Показва ни в коя група, колко процента от данните попадат.

prop.table(x = table(amount, smokes), margin = 1)
#   Параметърът "margin" задава как желаем да изчисляваме процентите - по редове или по колони.
#   От данните виждаме, че имаме нарастване в процента на непушещите студентите, спрямо броя на
#   часовете, които отделят за учене.

barplot(table(smokes, amount))
#   Малко трудно бихме видяли разликите, освен ако не са фрапиращи.
#   В долния код ще се опитаме да нормализираме стойностите като използваме процентните
#   съотношения. При този подход, ясно се вижда превъзходствата на едни признаци в една група,
#   спрямо друга.
barplot(prop.table(x = table(smokes, amount), margin = 2))

# Друг подход е описаният по-долу
barplot(table(smokes, amount), beside = TRUE, legend.text = T, col = c('green', 'red'))
#   При този подход съще лесно се забелязват разликите в отделните групи. В сегашния barplot
#   сме задали и легенда

#   Освен че можем да изведем легенда на графиката (legend.text = TRUE), то можем и да я
#   попълним със стойности, които ни трябват. Попълването е показано в примера по-долу.
barplot(
  table(amount, smokes),
  main = "table(amount, smokes)",
  beside = TRUE,
  legend.text = c("less than 5", "5 - 10", "more than 10")
)

#   2. Категорийни (обясняващи) VS числови (зависими)
#   Когато имаме такава конфигурация при връзките, то най-удачно е да използваме One-way ANOVA
#   и t-test или техните непараемтрични еквиваленти. Тези анализи ще ги учим по-нататък в курса
#   по статистика. Ако искаме да ги изследваме графично, удачно решение е boxplot графиките.
amount <- c(5, 5, 5, 13, 7, 11, 11, 9, 8, 9, 11, 8, 4, 5, 9, 5, 10, 5, 4, 10)
category <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
tt <- boxplot(amount ~ category)

#   Както се вижда, лесно могат да се сравнят двете категории.
#   - Средната дебела линия във всяки един boxplot е медианата
#   - Страните на правоъгълника са 1 и 3-ти квартил,
#   - Дължината на опашките са минималната и максималните стойности, като са изключени потенциалните outlier-и.
#       Тоест интерпретацията на тази графика е, че стойнсотите на първата група като цяло са
#   по-големи защото и медианата и третия квартил за първата група са по-големи от тези на втората.
#   Отделно, минималната стойност и първия квартил за първата група съвпадат ( = 5), докато минималната
#   стойност на втората група е 4.

# ----------------------------------------------------------------------------------------------------
#       3. Числови (обясняващи) VS категорийни (зависими)
#   Този случай на връзка е сходен с горния. Затова тук също можем да използваме One-way ANOVA или
#   t-test, непараметричните им екваваленти и boxplot-ове. Също така можем да използваме и
#   логистичната регресия.

#   Този тип връзка ще бъде обяснена по-нататък

# ----------------------------------------------------------------------------------------------------
#       4. Числови (обясняващи) VS числови (зависими)
#       Това е може би групата, за която съществуват най-много похвати за анализи. Променливите от
#   числов тип могат да бъдат превърнати в категорийни и следователно за тях важат горнтие типове
#   анализи. Това, разбира се, би довело до загуба на информация, но в определени случаи е по-подходящо
#   заради по-голямата стабилност на моделите.
#       Похватите, които са характерни за изследването на този тип връзки са най-често корелационен
#   анализ и регресионен анализ, както и dotplot (графично представяне на връзката).
#       Почти винаги изследването на този тип връзка следва последователността dotplot, корелационен
#   анализ и регресионен анализ

data("mtcars")
mtcars
#   Да разгледаме пример от данните "mtcars". Интересуват ни променливите disp (обем на двигателя)
#   и wt (тегло)

plot(mtcars$disp, mtcars$wt)
#   От графиката се вижда, че съществува положителна линейна връзка. Тоест с нарастване на обема
#   на двигателя, нараства и теглото на автомобила. Следователно, можем да използваме линеен модел,
#   за да моделираме връзката.

#   ИНФОРМАЦИЯ, КОЯТО НЯМА ДА Я ИМА НА ИЗПИТА/КОНТРОЛНИТЕ
#   Преди да продължим с корелационния и регресионния анализ, нека да разгледаме друг пример.
#   Този път данните ще бъдат симулирани. И връзката няма да бъде линейна, а кубична.

set.seed(4455)
x <- runif(1000, -3, 3)
y <- x^3 - 3 + rnorm(length(x), sd = 2)
plot(x, y)
x^3
x^3 - 3
rnorm(length(x), sd = 2)
# Както се вижда от графиката, този тип връзка не прилича на линейна. Но чрез подходяща трансформация,
# връзката може да се представи като линейна. Например, ако създадем нова променлива
x3 <- x^3
#   Тогава, новата променлива x3 е в линейна зависимост с променливата y
par(mfrow = c(1, 2))
plot(x, y)
plot(x3, y)
par(mfrow = c(1, 1))

#   Корелационен анализ
#     Корелационният анализ измерва силата на линейна връзка между две променливи. Коефициентът на
#   корелация (rho) принадлежи на интервала [-1, 1]. Силата на връзката се определя от абсолютната
#   стойност на rho. Въпреки, че силата на връзката е субективна, все пак можем да определим някакви
#   нива.
N <- 1000

#   abs(rho) = 1 - Детерминистична връзка (y = f(x)). За една стойност на x имаме точно една
#   единствена стойност на y.
set.seed(3654)
x1 <- runif(N)
y1 <- 3*x1 + 4
rho1 <- round(cor(x1, y1), 3)

#   0.9 <= abs(rho) < 1 - Много силна корелация на между x и y
set.seed(3654)
x2 <- runif(N)
y2 <- 3*x2 + 4 + rnorm(N, sd = 0.2)
rho2 <- round(cor(x2, y2), 3)

#   0.75 <= abs(rho) < 0.9 - Силна корелация на между x и y
set.seed(3654)
x3 <- runif(N)
y3 <- -3*x3 + 4 + rnorm(N, sd = 0.5)
rho3 <- round(cor(x3, y3), 3)

#   0.5 <= abs(rho) < 0.75 - Средна корелация на между x и y
set.seed(3654)
x4 <- runif(N)
y4 <- -3*x4 + 4 + 1*rnorm(N)
rho4 <- round(cor(x4, y4), 3)

# 0 <= abs(rho) < 0.5 - Слаба корелация на между x и y
set.seed(3654)
x5 <- runif(N)
y5 <- 3*x4 + 4 + 3*rnorm(N)
rho5 <- round(cor(x5, y5), 3)

par(mfrow = c(2, 3))
plot(x1, y1, main = paste("rho:", rho1))
abline(a = 4, b = 3, col = "red", lwd = 2)

plot(x2, y2, main = paste("rho:", rho2))
abline(a = 4, b = 3, col = "red", lwd = 2)

plot(x3, y3, main = paste("rho:", rho3))
abline(a = 4, b = -3, col = "red", lwd = 2)

plot(x4, y4, main = paste("rho:", rho4))
abline(a = 4, b = -3, col = "red", lwd = 2)

plot(x5, y5, main = paste("rho:", rho5))
abline(a = 4, b = 3, col = "red", lwd = 2)
par(mfrow = c(1, 1))

#   От графиките се вижда, че колко по-разпръснати са наблюденията около правата,
#   толкова корелацията намалява.

#   Командата за корелация е cor. С командата може да се изследват както връзките
#   между две променливи, така и връзките между N-мерни ЧИСЛОВИ данни.

X <- x3;    Y <- y3
X_mean <- mean(X)
Y_mean <- mean(Y)

XY <- (X - X_mean)*(Y - Y_mean)

XX <- (X - X_mean)^2
YY <- (Y - Y_mean)^2

sum(XY)/sqrt(sum(XX)*sum(YY)) #   Стойността на корелацията
cor(x3, y3)

cor(x = mtcars$mpg, y = mtcars$hp)
# Връща ни само едно число - корелацията между двете променливи

cor(mtcars[, c("mpg", "disp", "hp", "drat", "wt", "qsec")])
mtcars
#       Връща СИМЕТРИЧНА матрица (A[i, j] == A[j, i]) с корелациите между отделните
#   променливи.
#       Интересно е, че, по главния диагонал, всички стойности са единици. Това е
#   следствие от формулата

# ---------------------------------
#       Съществуват три основни вида корелации - Pearson, Spearman и Kendall. Първата
#   корелация е параметрична оценка на връзката между две променливи, докато останалите
#   две - непараметрични.

#   Тоест корелацията на Pearson е по-точна, но е неустойчива при наличието на outlier-и
#   Останалите две корелации са по-стабилни и не толкова точни.

#   Най-лесно това ще го демонстрираме с примера по-долу
set.seed(4413)
x <- sort(rnorm(200, mean = 2))
y <- x + sqrt(1 - 0.8^2)*rnorm(length(x))
plot(x, y, main = paste("Pearson's rho:", round(cor(x, y), 2)))
abline(lm(y ~ x), col = "forestgreen", lwd = 2, lty = 4)
round(cor(x, y), 2) # 0.85

x1 <- c(x, 3.4, 3, 3.8, 3.5, 4, 4.1)
y1 <- c(y, 17, 18.5, 19.2, 19, 20, 22)
plot(x1, y1)
abline(lm(y1 ~ x1), col = "darkred", lwd = 2, lty = 3)

text(x = 0.5, y = 18, labels = paste0("Pearson's rho:", round(cor(x1, y1), 2)))
text(x = 0.5, y = 17, labels = paste0("Spearman's rho: ", round(cor(x1, y1, method = "spearman"), 2)))

# ---------------
# Линейни модели
# Линейна регресия
NN <- 300
set.seed(73391)
x1 <- round(runif(NN, 0, 5), 1)
x2 <- round(runif(NN, 2, 6), 1)
y <- 3 + 2.5*x1 + rnorm(NN)
DF <- data.frame(x1, x2, y)

#       Какво представлява линейната регресия?
#       Линейната регресия е статистически метод, който ни позволява да проучим и обобщим връзките
#   между две множества от непрекъснати променливи - X и y:
#       - в множеството X се намират обясняващите променливи (наречени още предиктори или независими
#   променливи) и върху тях се основават нашите прогнози;
#       - в множеството y се съдържа една променлива (вектор), наричаща се зависима променлива
#   променливаи или резултат, която искаме да прогнозираме.

#       Ако приемем, че размерът на вектора y e N, a размерът на множеството X е N x p, то
#   връзката между двете множества е y = b(0) + b(1)*x(1) + ... + b(p)*x(p) + error, където
#   b(0) е константа, а b(1), ..., b(p) са параметрите, които обясняват влиянието на X над y.
#   Линейната регресия ни позволява да оценим стойностите на тези p+1 коефцициенти.
#       Има няколко начина за намирането на тези коефициенти, но най-често използваният е OLS
#   (метод на най-малките квадрати)

#   В R, функцията за линейна регресия е lm()

#       Два начина за извикване на линейна регресия. Първият, ако виждаме нужните ни променливите
#   в средата на R. Лесно можем да проверим дали променливите са заредени в среда на R с функцията
#   ls().
ls() # List all variables
model1 <- lm(y ~ x1)

# RM variables
rm(list = c("x1", "x2", "y"))

#       Вторият начин е като посочим data frame-а или матрицата, който(която) съдържа необходимите
#   променливи.
model2 <- lm(y ~ x1, data = DF)
model2
rm(list = "model2")

#       Когато изследваме връзка между една зависима и една обясняваща променлива, тогава линейната
#   регресия е едномерна (или проста). При наличието на повече предиктори (обясняващи променливи),
#   тогава имаме многомерна линейна регресия.
#       Горните два модела са пример за проста линейна регресия
#       Многомерната линейна регресия ще бъде разгледана по-подробно по-нататък в курса.

#       След като сме построили линееен модел, следващата стъпка е да проверим до колко този модел
#   описва добре данни и какви са оценките на коефициенти му.
summary(model1)

#   -------
#       Хипотези и проверка на хипотези
#       Накратко, статистическата хипотеза е предположение за параметър на извадката/популацията.
#   Това предположение може да бъде вярно или невярно. Ето защо съществуват две взаимоизключващи се
#   хипотези - нулева (H0) и алтернативна (H1).
#       Имаме три типа хипотези:
#           1. H0: параметър = число, H1: параметър != число
#           2. H0: параметър <= число, H1: параметър > число
#           3. H0: параметър >= число, H1: параметър < число

#       Проверката на хипотезите става с помощта на тестове. На база вида на теста, искаме да
#   отхвърлим или не нулевата хипотеза H0. Дали нулевата хипотеза е отхвърлена се определя от
#   стойност, наречена "p-value". Стандартно, една H0 се отхвърля при стойност на p-value < 0.05.
#   При отхвърляне на нулева хипотеза, за вярна се приема алтернативната H1.
#   -------

#       Първо ще проверим дали коефициентите са статистически значими, тоест дали е необходимо да
#   участват в анализа. За всеки един коефициент проверяваме хипотезата дали коефициентът е равен
#   на 0 (b(i) ?= 0). За да бъде един коефициент значим, то трябва за него да отхвърлим горната
#   хипотеза. Както беше споменато по-горе, за да се отхвърли H0, то стойността на p-vaue трябва да
#   бъде по-малка от 0.05. Стойностите p-value се намират в колоната "Pr(>|t|)". Стойностите на
#   p-value за двата параметъра е 2e-16 << 0,05 и следователно двата параметъра са статистически
#   значими.

summary(model3 <- lm(y ~ x2, data = DF))
rm("model3")

#       Да разгледаме оценките пред коефицнета x2. Оценката на коефициента е -0,1505. Но въпреки, че
#   стойността му е различна от 0, то той е статистически незначим. Защо? Защото стойността на
#   p-value e 0,414 > 0,05. Тоест, този коефициент може да отпадне от анализа.

#       Следващата стъпка е да проверим до колко модела описва добре данните. За целта ще използваме
#   статистиките "Multiple R-squared" или "Adjusted R-squared". Статистиката "Multiple R-squared"
#   приема стойности в интервала [0-1]. Колкото тази статистика се приближава до единица, толкова
#   моделът е по-добър. И обратното, колкото стойността на R2 клони към 0, толкова  моделът не се
#   справя с описването на данните. Моделите, които имат стойности за R2 под 0.5, ги приемаме за
#   слаби.

#       Препоръчително е да се използва обаче статистиката Adjusted R-squared, защото тя "наказва",
#   когато използваме ненужни променливи. По принцип, тази статистика също приема стойности в
#   интервала [0-1], но когато използваме само статистически незначими, тогава Adjusted R-squared
#   може да приеме и отрицателни стойности.

summary(model1)
#   Какво можем да кажем за model2? Стойността на Adjusted R2 е 0.9284. Тоест моделът описва
#   много добре данните.

#   - Какво представлява R2 и как можем да го изчислим?
#   - За целта първо ще разгледаме начините да изчисляваме прогнози и остатъците (residuals).

#   Регресионното уравнение придобива вида y = 3.027 + 2.247*x1.

#       Линейната регресия позволява не само да се оценят връзките между отделните обясняващи
#   променливи и резулатата, но както споменахме по-горе, позволява да се правят прогнози. В R
#   използваме функцията "predict" за прогнозиране. Функцията съдържа два основни параметъра object
#   (построения модел) и newdata (данни, за които искаме да направим прогноза)
model1.predictions <- predict(object = model1, newdata = DF)
model1.predictions.alt <- model1$coefficients[1] + model1$coefficients[2]*DF$x1  #   Алтернативен начин
all(model1.predictions == model1.predictions.alt)
rm("model1.predictions.alt")

### ......


=begin
[((<index|URL:index.html>))]
= Algebra::LocalizedRing
((*(Class of Localization of Ring)*))

This class creates the fraction ring of the given ring.
To make a concrete class, use the class method
((<::create>)) or the function ((<Algebra.LocalizedRing>))().

== File Name:
* ((|localized-ring.rb|))

== SuperClass:

* ((|Object|))

== Included Ring
none.

== Associated Functions:

--- Algebra.LocalizedRing(ring)
    Same as ((<::create>))(ring).

--- Algebra.RationalFunctionField(ring, obj)
    Creates the rational function field over ((|ring|)) with
    the variable expressed by ((|obj|)). This class is equipped with
    the class method ((|::var|)) which returns the variable.

    Example: the quotient field over the polynomial ring over Rational
      require "algebra/localized-ring"
      require "rational"
      F = Algebra.RationalFunctionField(Rational, "x")
      x = F.var
      p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )
        #=> x^2/(x^4 + x^3 - x - 1)

--- Algebra.MRationalFunctionField(ring, [obj1[, obj2, ...]])
    Creates the rational function field over ((|ring|)) with
    the variables expressed by ((|obj1|)), ((|obj2|)), .... This class is equipped with
    the class method ((|::vars|)) which returns the array of variables.

    Example: the quotient field over the polynomial ring over Rational
      require "algebra/localized-ring"
      require "rational"
      G = Algebra.MRationalFunctionField(Rational, "x", "y", "z")
      x, y, z = G.vars
      f = (x + z) / (x + y) - z / (x + y)
      p f #=> (x^2 + xy)/(x^2 + 2xy + y^2)
      p f.simplify #=> x/(x + y)

== Class Method:

--- ::create(ring)
    Returns the fraction ring of which the numerator and the
    denominator are the elements of the ((|ring|)).

    This returns the subclass of Algebra::LocalizedRing. The subclass
    has the class method ((|::ground|)) and (({::[]})) which
    return ((|ring|)) and (({x/1})) respectively.

    Example: Yet Another Rational
      require "localized-ring"
      F = Algebra.LocalizedRing(Integer)
      p F.new(1, 2) + F.new(2, 3) #=> 7/6

    Example: rational function field over Integer
      require "polynomial"
      require "localized-ring"
      P = Algebra.Polynomial(Integer, "x")
      F = Algebra.LocalizedRing(P)
      x = F[P.var]
      p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )
        #=> (x^3 - x^2)/(x^5 - x^3 - x^2 + 1)

--- ::zero
    Returns zero.

--- ::unity
    Returns unity.

#--- ::[](num, den = nil)

#--- ::reduce(num, den)

== Methods:

#--- monomial?; true; end

--- zero?
    Returns true if ((|self|)) is zero.

--- zero
    Returns zero.

--- unity
    Returns unity.

--- ==(other)
    Returns true if ((|self|)) equals ((|other|)).

--- +(other)
    Returns the sum of ((|self|)) and ((|other|)).

--- -(other)
    Returns the difference of ((|self|)) from ((|other|)).

--- *(other)
    Returns the product of ((|self|)) and ((|other|)).

--- /(other)
    Returns the quotient of ((|self|)) by ((|other|)) using ((<inverse>)).

--- **(n)
    Returns the ((|n|))-th power of ((|self|)).

#--- to_s

#--- inspect

#--- hash

=end


#   An illustration written in R for the Monty Hall Problem
#   Copyright (C) 2019  Dr. Norbert Bátfai, nbatfai@gmail.com
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>
#
#   https://bhaxor.blog.hu/2019/01/03/erdos_pal_mit_keresett_a_nagykonyvben_a_monty_hall-paradoxon_kapcsan
#

kiserletek_szama=10000000
kiserlet = sample(1:3, kiserletek_szama, replace=T)
jatekos = sample(1:3, kiserletek_szama, replace=T)
musorvezeto=vector(length = kiserletek_szama)

for (i in 1:kiserletek_szama) {

    if(kiserlet[i]==jatekos[i]){

        mibol=setdiff(c(1,2,3), kiserlet[i])

    }else{

        mibol=setdiff(c(1,2,3), c(kiserlet[i], jatekos[i]))

    }

    musorvezeto[i] = mibol[sample(1:length(mibol),1)]

}

nemvaltoztatesnyer= which(kiserlet==jatekos)
valtoztat=vector(length = kiserletek_szama)

for (i in 1:kiserletek_szama) {

    holvalt = setdiff(c(1,2,3), c(musorvezeto[i], jatekos[i]))
    valtoztat[i] = holvalt[sample(1:length(holvalt),1)]

}

valtoztatesnyer = which(kiserlet==valtoztat)

sprintf("Kiserletek szama: %i", kiserletek_szama)
length(nemvaltoztatesnyer)
length(valtoztatesnyer)
length(nemvaltoztatesnyer)/length(valtoztatesnyer)
length(nemvaltoztatesnyer)+length(valtoztatesnyer)


pie1=413/527
pie2=392/608
# The sample awareness proportion is higher in Wichita, so let's make Wichita region 1.
#The estimated standard error is
sigma=sqrt(((pie1*(1-pie1))/527)+((pie2*(1-pie2))/608))
print(sigma)
alpha=0.025
z.alpha=qnorm(1-alpha)
error=z.alpha*sigma
#  95% confidence interval
left_i=(pie1-pie2)-error
right_i=(pie1-pie2)+error
print(left_i)
print(right_i)


f <- function(x) x^3 -3*x^2 + 2*x

findroots <- function(f, begin, end, tol = 1e-20, step = 0.001) {
  se <- ifelse(sign(f(begin))==0, 1, sign(f(begin)))
  x <- begin
  while ( x <= end ) {
    v <- f(x)
    if ( abs(v) < tol ) {
      print(sprintf("root at %f", x))
    } else if ( ifelse(sign(v)==0, 1, sign(v)) != se )  {
      print(sprintf("root near %f", x))
    }
    se <- ifelse( sign(v) == 0 , 1, sign(v))
    x <- x + step
  }
}

findroots(f, -1, 3)


beta1=.01291
se=.00283
# test statistic
t=beta1/se
print(t)
n=54
k=4
df=n-(k+1)
alpha=0.05
tvalue=qt(1-alpha,df)
 #the computed value of the test statistic > tvalue . we conclude there is significant evidence to reject H0


 #  odds of a randomly chosen person carrying HIV
p=.001/.009
#  occurrence of a positive test result causes the odds to change to
p_hiv=.001
p_positive_hiv=.95
p_nothiv=.999
p_positive_nothiv=.02
P_occurencepositive=(p_hiv*p_positive_hiv)/(p_nothiv*p_positive_nothiv)
print(P_occurencepositive)

# The odds of carrying HIV do go up given a positive test result, from about
#.001 (to 1) to about .0475 (to 1).


## Código para Cãlculos dos Dados de Galton
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181172
## 28 de maio de 2020

library(tidyverse)

galton <- readRDS(here::here("galton.rds"))
str(galton)

boys <- galton %>%
  filter(sex == "M") %>%
  select(-family, -mother, -sex, -nkids)
glimpse(boys)

grpf <- ggplot(data = boys, aes(x = father, y = height)) + geom_point(shape = 20) + geom_rug()
grpf <- grpf + labs(x = "Altura do Pai", y = "Altura do Filho", title = "Alturas em Polegadas")
grpf

grpf2 <- grpf + geom_smooth(method = "lm", se = FALSE, color = "red")
grpf2

summarytools::descr(boys)
paste("Coeficiente de Correlação:",
      with(boys, round(cor(father, height), 3)))

set.seed(1946)
boyscoef <-  coef(lm(height~father, data  = boys))
int <- boyscoef[1]; inc <- boyscoef[2]
x <- boys %>%
  filter((height >= 66 & height < 71) & (father >= 67 & father < 71)) %>%
  sample_n(5) %>%
  mutate(ypred = int + inc * father)
xplot <- ggplot(data = x, aes(x = father, y = height))
xplot <- xplot + geom_point(shape = 19, colour = "darkgreen")
xplot <- xplot + geom_abline(aes(intercept = int, slope = inc), colour = "darkred")
xplot <- xplot + geom_segment(aes(x = father[3], y = height[3], xend = father[3],
                                  yend = ypred[3]), colour = "blue",
                              arrow = arrow(length = unit(0.3,"cm")))
xplot <- xplot + geom_point(aes(x = father[3], y = ypred[3]),
                            shape = 19, color = "blue" )
xplot <- xplot + annotate(geom = "text", x = 68.2, y = 68.7,
                          label = "y-hat")
xplot <- xplot + annotate(geom = "text", x = 68.2, y = 66.8, label = "y(i)")
xplot

xplot2 <- xplot + geom_hline(yintercept = mean(boys$height), color = "orange")
xplot2 <- xplot2 + geom_segment(aes(x = father[3], y = ypred[3],
                                    xend = father[3],
                                    yend = mean(boys$height)),
                                colour = "green",
                                arrow = arrow(length = unit(0.3,"cm")))
xplot2 <- xplot2 + annotate(geom = "text", x = 67.7, y = 68.9,
                            label = "SSR", color = "darkgreen")
xplot2 <- xplot2 + annotate(geom = "text", x = 67.5, y = 69.3, label = "y-bar")
xplot2 <- xplot2 + annotate(geom = "text", x = 67.7, y = 68,
                            label = "SSE", color = "darkblue")
xplot2 <- xplot2 + geom_segment(aes(x = father[3] + 0.05, y = height[3],
                                    xend = father[3] + .05,
                                    yend = mean(boys$height)),
                                colour = "red",
                                arrow = arrow(length = unit(0.3,"cm")))
xplot2 <- xplot2 + annotate(geom = "text", x = 68.3, y = 68,
                            label = "SST", color = "darkred")
xplot2

fit1 <- lm(height ~ father, data = boys)
summary(fit1)

broom::tidy(fit1) %>% knitr::kable()

coef(fit1)

fit1 %>% broom::augment(newdata = data_frame(father = 72))


#' Piecewise cosine interpolation
#'
#' Returns a list of points which interpolate given data points. Similar to
#' \link[stats]{approx}.
#'
#' @param x,y numeric vectors giving the coordinates of the points to be
#'   interpolated.
#' @param xout an optional set of numeric values specifying where interpolation
#'   is to take place.
#' @param n If xout is not specified, interpolation takes place at n equally
#'   spaced points spanning the interval [\code{min(x)}, \code{max(x)}].
#' @param yleft the value to be returned when input \code{x} values are less
#'   than \code{min(x)}. The default is defined by the value of rule given
#'   below.
#' @param yright the value to be returned when input \code{x} values are greater
#'   than \code{max(x)}. The default is defined by the value of rule given
#'   below.
#' @param rule an integer (of length 1 or 2) describing how interpolation is to
#'   take place outside the interval [\code{min(x)}, \code{max(x)}]. If rule is
#'   \code{1} then \code{NA}s are returned for such points and if it is
#'   \code{2}, the value at the closest data extreme is used. Use, e.g.,
#'   \code{rule = 2:1}, if the left and right side extrapolation should differ.
#' @param ties Handling of tied \code{x} values. Either a function with a single
#'   vector argument returning a single number result or the string
#'   \code{"ordered"}.
#'
#' @details This function is based on and functions similarly to
#' \link[stats]{approx} and \link[stats]{spline} .
#'
#' @examples
#' y <- rnorm(10)
#' x <- 1:10
#' plot(x, y)
#' lines(approx.cos(x, y, n=200))
#' @export
approx.cos <- function(x, y=NULL, xout, n=50, yleft, yright, rule=1, ties=mean) {
  require('stats')

  stopifnot(is.numeric(rule), (lenR <- length(rule)) >= 1L,
            lenR <= 2L)
  if (lenR == 1)
    rule <- rule[c(1, 1)]

  x <- stats:::regularize.values(x, y, ties)
  y <- x$y
  x <- x$x

  nx <- as.integer(length(x))
  if (is.na(nx))
    stop("invalid length(x)")
  if (nx <= 1) {
    stop("need at least two non-NA values to interpolate")
  }

  if (missing(yleft))
    yleft <- if (rule[1L] == 1)
      NA
  else y[1L]
  if (missing(yright))
    yright <- if (rule[2L] == 1)
      NA
  else y[length(y)]
  stopifnot(length(yleft) == 1L, length(yright) == 1L)
  if (missing(xout)) {
    if (n <= 0)
      stop("'approx' requires n >= 1")
    xout <- seq.int(x[1L], x[nx], length.out = n)
  }
  x <- as.double(x)
  y <- as.double(y)

  # Select values of x we can actually interpolate
  xnew <- xout[xout >= min(x) & xout <= max(x)]

  # For each new x find which original x it is next to
  xi <- findInterval(xnew, x, TRUE)

  # calculate relative distance to original x
  dx <- (x[xi+1]-xnew)/(x[xi+1]-x[xi])

  # Interpolate with piecewise cosine function
  ynew <- (0.5 + cos(pi*dx)/2) * (y[xi+1] - y[xi]) + y[xi]

  # Add y values for any x values outside interval
  yout <- c(rep(yleft, sum(xout<min(x))), ynew, rep(yright, sum(xout>max(x))))

  list(x = xout, y = yout)
}


# Math

2+3
10-5
3-7
2*5
5/8
10/2
2^2

x <- 5
y <- 10
x/y
y*x
x+2

# character

"ali"
"emam"
ali
"ali" + "emam"
"ali" - "emam"
"5" + "5"
5 + "5"
x <- "ali"
y <- "emam"

# vector

c(1,2,3,4,5)
c("ali", "emam")
c(1,2,3, "ali") # only one type of data

x <- c(1,2,3,4,5)
y <- c("ali", "emam")
xx <- c(10,20,30,40,50)
xx + x

# functions

sqrt(25)
sqrt("25")

mean(x)
mean(y)
mean(xx)
xx <- c(10,20,30,40,50, NA)
mean(xx)
mean(xx, na.rm = T)
median(xx, na.rm = T)
summary(xx)
# def. new function
xx <- c(10,20,30,40,40, 40,50)
yy <- table(xx)
yy
which.max(yy)

get.mode <- function(x){
  y <- table(x)
  mode <- which.max(y)
  return(mode)
}

get.mode(xx)

# data.frame

gene1 <- c(20,30,40,60)
gene2 <- c(200,350,40,30)
gene3 <- c(56,156,23,75)
gene4 <- c(30,11,19,56)
df.genes <- data.frame(g1 = gene1, g2= gene2, g3= gene3, g4 = gene4)
View(df.genes)
mean(df.genes$g2)
mean(df.genes$g3)

df.genes$g1 + df.genes$g4

apply(df.genes, 2, mean) # col. by genes

apply(df.genes, 1, mean) # row. by sample

plot(df.genes)
hist(df.genes$g1)
hist(df.genes$g1,freq = F)
#install.packages("ggplot2")

library(ggplot2)
ggplot(df.genes,aes(x = g2))+ geom_histogram(bins = 5)