#' Calculate Unobserved Selection Bias
#'
#' @description We calculate an effect of selection on unobservables
#'     on estiamted coefficient of treatment. This method is presented by
#'     Oster (2019, Journal of Business & Economic Statistics).
#'     Let b0 and r0 be the coefficient of treatment and R-squared
#'     resulting from the regression of outcome on treatment.
#'     Let b1 and r1 be the coefficient of treatment and R-squared
#'     resulting from the regression of outcome on
#'     treatment and observed covariates.
#'     Let rmax be the R-squared resulting from the hypothetical regression
#'     of outcome on treatment, observed covairates, and unobserved covariates.
#'     The value rmax depends on researchers.
#'     Oster' suggestion is `rmax = r1 * 1.3`
#'     (See a paper for detailed discussion).
#'     Define b^ = b1 - (b0 - b1)*(rmax - r1)/(r1 - r0).
#'     Under the following assumpetions,
#'     the value b^ converges to a true b in probability one.
#'     Assumption 1 is that
#'     covariates are orthogonal to unobservables.
#'     Assumption 2 is that
#'     the unobservable and observables are equally related to the treatment.
#'     Assumption 3 is that
#'     the coefficient of covariates on treatment is same as
#'     the coefficient of covairates on outcome.
#'     These assumptions are not precise. See a paper for detailed discussion.
#'
#'
#' @param x an object whose class is `RCT`.
#' @param r_max a numerical value of rmax. Default is null.
#' @param r_multiply a numerical value of multiple of r1. Default is `1.3`.
#'
#' @return a numeric vector whose class is `RCT` and `OsterBias`.
#'
#' @importFrom stringr str_split
#' @importFrom purrr map
#' @importFrom purrr as_vector
#' @importFrom magrittr %>%
#' @importFrom stats coef
#'
#' @export
#+
osterbias <- function(x, r_max = NULL, r_multiply = 1.3) {

  # class check
  if (sum(class(x) == "RCT") == 0) stop("Unsupported class.")

  # extract treatment variables
  d <- str_split(x$treat, "\\+") %>%
    map(~ gsub(" ", "", .)) %>%
    as_vector()

  # extract coefficients
  b0 <- coef(x$fit[[1]])[d]
  r0 <- summary(x$fit[[1]])$r.squared

  b1 <- coef(x$fit[[2]])[d]
  r1 <- summary(x$fit[[2]])$r.squared

  if (!is.null(r_max)) {
    bias <- d %>%
      map(~ (b0[.] - b1[.]) * ((r_max - r1) / (r1 - r0))) %>%
      as_vector()
  } else {
    bias <- d %>%
      map(~ (b0[.] - b1[.]) * ((r_multiply * r1 - r1) / (r1 - r0))) %>%
      as_vector()
  }

  names(bias) <- d
  class(bias) <- append(c("RCT", "OsterBias"), class(bias))

  return(bias)
}


# Diffuse_fraction_of_solar_radiation.R
#
# Pieter Beck (psabeck@gmail.com)
# 09-12-2013
# Modified by S.R. Supp 2014 (sarah@weecology.org)
#
# functions to calculate what fraction of incoming solar radiation reaches the surface as diffuse radiation
#
# Changelog:
#   VERS  | DATE  		 | CHANGES				| BY
#   ------|------------|----------------|----
#		1.0.0	|	09-12-2013 | Wrote script		| PB

#Id is diffuse radiation
#I is 'global radiation' (DSWRF) (for a horizontal plane, global irradiance is the sum of the diffuse and the direct component)
#Id/I (IdoverI) is the fraction of diffuse radiation in global radiation
#IdoverI is estimated as a function of kt (Liu and Jordan 1960) (and in some cases solar zenith angle)

#kt is the clearness index
#The clearness index measures the proportion of horizontal extraterrestrial radiation (Io)
#reaching the surface.
#it is defined as kt = I / (Io cos solarzen).
#DSWRF = Downward short wave radiation flux

IdoverI.calc <- function(kt,solarzen){
  #calculate the fraction of diffuse radiation in global radiation
  #using the Reindl* method (Helbig 2009)
  # Args:
  #  kt: The clearness index (sensu Liu and Jordan 1960)
  #  solarzen: solar zenith angle in radians
  # Returns:
  #   the fraction of diffuse radiation (Id) in global radiation (I)

  if (kt <= 0.3) {IdoverI <- 0.1020 - 0.248*kt}else{
  if(kt < 0.78){
    solar.elev <- pi/2 - solarzen
    IdoverI <- 1.4 - 1.749*kt + 0.177*sin(solar.elev)}else{
    IdoverI <- 0.147}
  }
  return(IdoverI)
}

SpSd.calc <- function(Rsurface, R_extra_terr, solarzen, Rup){
  #calculate direct (Sp) and diffuse (Sd) radiation from global radiation
  #and horizontal extraterrestrial radiation
  # Args:
  #  Rsurface: incoming shortwave radiation at the surface
  #  Rup: upward shortwave radiation, which should be added to diffuse radiation calculated from downward shortwave radiation
  #  R_extra_terr: horizontal extraterrestrial radiation
  #  solarzen: solar zenith angle in radians
  # Returns:
  #  A two-column matrix giving incoming direct [,1], and diffuse [,2] radiation at the surface

  if (solarzen > 2*pi){cat("STOP STOP STOP provide solarzenith in radiance to SpSd.calc\n");browser()}
  kt <- Rsurface/R_extra_terr
  #TODO: Added this check (e.g. if Rsurface and R_extra_terr == 0, kt == NaN which is a problem)
  if (is.na(kt)){
    kt = 0
  }
  #the formula in Lanini 2010 p1 is
  #kt <- Rsurface/(Io*cos(solarzen))
  #but this is for Io*cos(solarzen) being the horizontal extraterrestrial radiation
  #and thus is adjusted for latitude/solarzen before comparison with Rsurface
  #I believe sirad:extrat provides latitude-corrected (ie horizontal) extraterrestrial radiation
  IdoverI <- IdoverI.calc(kt,solarzen)
  IdoverI[IdoverI < 0] <- 0 ; IdoverI[IdoverI > 1] <- 1
  SpSd <- Rsurface * cbind(1-IdoverI,IdoverI)
  SpSd[2] <- SpSd[2] + Rup
  return(SpSd)
}

solarzen.calc <- function(coords,datetimePOSIXct){
  #calculate solar zenith based on lat, lon & time of day
  # Args:
  #  coords: coordinates
  #  datetimePOSIXct: a POSIXct object giving date and time
  # Returns:
  #  solar zenith angle

  require(maptools)
  solarelv <- solarpos(crds=coords,dateTime=datetimePOSIXct)
  solarelv <- solarelv[,2]
  #convert to radians
  solarelv <- pi*solarelv/180
  #convert to solar zenith (0 when sun is overhead) in radians
  solarzen <- pi/2 - solarelv
  #set below-horizon zeniths to pi/2
  solarzen[solarzen > pi/2] <- pi/2
  cat("in zolar zenith values, pi/2 (90degs) represents horizon/sub-horizon\n
      while 0 represents directly over-head\n")
  return(solarzen)
}

R_extra_terr.calc<-function(thisdate,lat.in.deg){
  #calculate hourly extraterrestrial irradiance in W/m2 using sirad package
  # Args:
  #  thisdate: string object giving date, e.g. "2011-12-31"
  #  lat.in.deg: lattitude in degrees
  # Returns:
  #  hourly extraterrestrial radiation
  # Example:
  #  R_extra_terr.calc(thisdate=c("2012-01-19","2012-01-19"),lat.in.deg=c(-69))

  require(sirad)
  JulianDay <- sirad::dayOfYear(thisdate)#dayOfYear("2011-01-01")
  lat.in.rad <- lat.in.deg*pi/180
  R_extra_terr <- extrat(i=JulianDay,lat.in.rad)#[[2]]
  #extrat[[1]] uses MJ/(day m^2) units
  #extrat[[2]] uses MJ/(hr m^2) units
  #convert output to W/m2
  conv.fac.daily <- (1000000/ 86400)
  conv.fac.hourly <- (1000000/ 86400)*24
  R_extra_terr[[1]] <- conv.fac.daily *  R_extra_terr[[1]]
  R_extra_terr[[2]] <- conv.fac.hourly *  R_extra_terr[[2]]
  #set negative hourly extrat irrad to 0
  #R_exta_terr <- R_exta_terr[[2]]
  R_extra_terr[[2]][R_extra_terr[[2]]<0] <- 0
  R_extra_terr <- R_extra_terr[[2]]
  R_extra_terr <- matrix(R_extra_terr,ncol=24)
  #cat("calculated 24hrs of extraterrestrial irradiance for\n", nrow(R_extra_terr)," latitude-date combinations\n")
  #output is hourly starting at solar midning
  return(R_extra_terr)
}

shift.vec <- function(vec,n,wrap=TRUE,pad=FALSE){
  # Shift a vector over by n spots
  #Args:
  #  vec: vector to be shifted
  #  n: number of spots to shift the vector over
  #  Wrap adds the entry at the beginning to the end
  #  pad does nothing unless wrap is false, in which case it specifies whether to pad with NAs
  # Returns:
  #  the vector vec, shifted over n sots
  # Source:
  #  http://stackoverflow.com/questions/6828937/what-to-do-with-imperfect-but-useful-functions

  if(length(vec)<abs(n)) {
    #stop("Length of vector must be greater than the magnitude of n \n")
  }
  if(n==0) {
    return(vec)
  } else if(length(vec)==n) {
    # return empty
    length(vec) <- 0
    return(vec)
  } else if(n>0) {
    returnvec <- vec[seq(n+1,length(vec) )]
    if(wrap) {
      returnvec <- c(returnvec,vec[seq(n)])
    } else if(pad) {
      returnvec <- c(returnvec,rep(NA,n))
    }
  } else if(n<0) {
    returnvec <- vec[seq(1,length(vec)-abs(n))]
    if(wrap) {
      returnvec <- c( vec[seq(length(vec)-abs(n)+1,length(vec))], returnvec )
    } else if(pad) {
      returnvec <- c( rep(NA,abs(n)), returnvec )
    }

  }
  return(returnvec)
}

shift_to_UTC <- function(hourly_tser,original.zone){
  #shift an hourly vector starting at midnight to start at midnight UTC
  # Args:
  #  hourly_tser: an hourly vector starting at midnight local time
  #  original.zone: the local time zone
  # Returns:
  #  an hourly vector, starting at midnight UTC
  # Example:
  #  shift_to_UTC(hourly_tser=1:24,original.zone="America/Mexico_City")

  require(timeDate)
  tt1<-timeDate("2010-01-01 00:00:00",zone=original.zone)
  tt2<-timeDate("2010-01-01 00:00:00",zone="UTC")
  shift.by <- as.numeric(tt2-tt1)
  cat("the 24 hour series will be shifted earlier hrs by ",shift.by," hours to match UTC\n")
  if (is.matrix(hourly_tser)){
    shifted_tser<-t(apply(hourly_tser,1,shift.vec,n=shift.by))
    }else{shifted_tser <- shift.vec(hourly_tser,n=shift.by)}
  return(shifted_tser)
}

R_extra_for_site.vec <- function(thisdate,lat.in.deg,original.zone){
  #given a date, latitude, and time zone, calculate extraterrestrial radiation
  #for that latitude
  #Args:
  #  thisdate: date
  #  lat.in.deg: latitude in degrees
  #  original.zone: timezone
  # Returns:
  #  Extraterrestrial radiation for the given latitude and day, in 6 hour steps

  if(length(thisdate)!=length(lat.in.deg)){
    cat("Please provide thisdate and lat.in.deg of equal length\n");browser()}
  #get the 24 R_extra_terr values for this lat & date
  R_extra_terr_24 <- R_extra_terr.calc(thisdate=thisdate,lat.in.deg=lat.in.deg)
  #determine by how many hours the series need to be shifted
  R_extra_terr_24UTC <- shift_to_UTC(R_extra_terr_24,original.zone=original.zone)
  #convert the R_extra_terr values from 24 hour to epoch
  epochmn <- function(x){tapply(x,rep(1:4,each=6),mean)}
  R_extra_terr_epochUTC <- t(apply(R_extra_terr_24UTC,1,epochmn))
  cat("all 24 hour series of extra-terrestrial R converted to 4 6-hour UTC epochs\n")
  rm(R_extra_terr_24,R_extra_terr_24UTC)
  return(R_extra_terr_epochUTC)
}


 DGGEV Example Program Results

 Eigenvalue( 1) =      20.000

 Eigenvector( 1)
    10.00000
     0.05714
     0.62857
     0.62857

 Eigenvalue( 2) = (     30.000,    -40.000)

 Eigenvector( 2)
 (    7.12215,    0.00000)
 (    1.42443,   -0.00000)
 (    0.85466,    1.13954)
 (    0.85466,    1.13954)

 Eigenvalue( 3) = (     30.000,     40.000)

 Eigenvector( 3)
 (    7.12215,   -0.00000)
 (    1.42443,    0.00000)
 (    0.85466,   -1.13954)
 (    0.85466,   -1.13954)

 Eigenvalue( 4) =      40.000

 Eigenvector( 4)
    10.00000
     0.11111
    -0.33333
     1.55556


normW   = {{args.normW | R}}
normE   = {{args.normE | R}}

W = read.table ({{i.Wfile | quote}}, sep="\t", header=T, row.names=1, check.names=F, strip.white=T)
W = as.matrix(W)

if (normW) {
	library(NetPreProc)
	W = abs(W)
	W = Laplacian.norm(W)
}

E = read.table ({{i.Efile | quote}}, header=F, row.names=1, check.names=F, strip.white=T)
E = as.matrix(E)
E = E[colnames(W), ]

RWR = function (W, e, c = {{args.c}}, eps = {{args.eps}}, tmax={{args.niter}}) {
	r0 = e
	for (i in 1:tmax) {
		r1 = ((1-c) * W) %*% r0 + c * e
		diff = norm (r1 - r0, 'f')
		if (diff < eps) break
		r0 = r1
	}

	return (list(r=r1, eps=diff, tmax=i))
}

r = RWR (W, E)
print (paste("eps: ", r$eps))
print (paste("tmax:", r$tmax))

write.table (round(r$r, 3), {{o.outfile | quote}}, quote=F, col.names=F, row.names = T, sep="\t")


input = mtcars[c("mpg","disp","hp","wt")]

model=lm(mpg~disp+hp+wt,data=input)
# x=summary(model)
print(model)
a=data.frame(disp=221,hp=102,wt=2.91)
y = predict(model,a)
print(y)


# Get stats for a subset of the data
subset_stats <- function(data, valcol, valcol2) {
  if (is.null(names(data)))
  {
    return(NULL)
  }
  print("Data:")
  print(str(data))
  print("Names:")
  print(names(data))
  print("Valcol:")
  print(valcol)
  col <- data[,valcol]
  col2 <- data[,valcol2]
  m <- lm(col ~ col2 + 0)
  res <- list(rmse = rmse(data$error),
              err_mean = mean(data$error),
              err_sd = sd(data$error),
              perc_err_mean = mean(data$perc_e),
              perc_err_sd = sd(data$perc_e),
              m = as.numeric(m$coefficients[1]),
              R2 = summary(m)$r.squared,
              n = nrow(data))

  #   res <- c(rmse(df$error),
  #            mean(df$error),
  #            sd(df$error),
  #            mean(df$perc_e),
  #            sd(df$perc_e),
  #            as.numeric(m$coefficients[1]),
  #            summary(m)$r.squared,
  #            nrow(df))

  return(res)
}


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     02.07.2017
#modificado: 09.12.2019

library("e1071")

trainset <- read.csv("../data/golf.csv",header=TRUE)
testset <- read.csv("../data/golf-testset.csv",header=TRUE)

#Recoding dummy variables
tmp1 = model.matrix(~trainset[,"Outlook"] - 1)
tmp2 = model.matrix(~trainset[,"Wind"] - 1)
colnames(tmp1) = paste("Outlook",levels(trainset[,"Outlook"]),sep="_")
colnames(tmp2) = paste("Wind",levels(trainset[,"Wind"]),sep="_")
trainset = cbind(tmp1,tmp2,trainset[,c("Temperature","Humidity","Play")])

tmp1 = model.matrix(~testset[,"Outlook"]-1)
tmp2 = model.matrix(~testset[,"Wind"]-1)
colnames(tmp1) = paste("Outlook",levels(testset[,"Outlook"]),sep="_")
colnames(tmp2) = paste("Wind",levels(testset[,"Wind"]),sep="_")
testset = cbind(tmp1,tmp2,testset[,c("Temperature","Humidity","Play")])

#Perform SVM fit
set.seed(12345)
mod <- svm(Play ~ .,                       #model design
                  trainset,                #training set
                  scale=TRUE,              #scaling stored for testing
                  type="C-classification", #SVM algorithm
                  kernel="radial",         #kernel type
                  gamma=1.0,               #kernel gamma
                  cost=1.0,                #C-constant (cost)
                  tolerance=0.001)         #convergence epsilon

#Test model
res <- predict(mod,                        #model
               testset)                    #testing set

#Confusion Matrix
conf_mat <- table(testset[,c("Play")],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


# Coeficientes
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

## Tu estaras a cargo en esta clase. Siguiendo este script, haras una regresion
## lineal usando las tecnicas de algebra de matrices.

## Aunque hemos visto en clases lo que un coeficiente es, el enfasis hasta ahora
## ha sido puesto en que los coeficientes son simples numeros. Lo son. Pero ya
## la proxima clase veremos mas en detalle por que es importante entender
## lo que ellos representan.

## Por el momento, recuerda (para siempre) la formula de beta.
## b = (x'x)^-1x'y

## Tambien recuerda la forma de la ecuacion de la regresion lineal:
## y = b0 + b1x1 + e

## Usando la formula para sacar betas, hoy calcularas beta0 (intercepto) y
## beta1 (coeficiente).

## En esta clase, pensaremos en la relacion que hay entre 'educacion' y
## 'prestigio'. Sera positiva? Negativa? Para responder esta pregunta,
## debes calcular beta1. Creo que estaremos de acuerdo en que la
## variable independiente ('x', o 'la causa') es 'educacion', y la dependiente
## ('y', o 'el efecto') es 'prestigio'. Seria raro pensar que "el prestigio
## causa la educacion", no? Cuanto sube mi prestigio cuando aumenta una unidad
## de educacion? Eso es precisamente lo que significa un coeficiente.

## Recuerda...
## prestigio <- educacion # Si
## educacion <- prestigio # No!

## Esto significa que,
## Prestigio = b0 + b1*Educacion + e

## Recuerda que todo esta indexado, menos los betas. Es decir, la formula real
## es asi:
## Prestigio_{i} = b0 + b1*Educacion_{i} + e_{i}
## "i" significa "individuo". Y representa a cada observacion.
## Esto significa que Pedro, Juan y Diego tienen, cada uno,
## sus propios niveles de prestigio,
## sus propios niveles de educacion,
## y su propio error. Recuerda, el error es la diferencia entre lo que
## predecimos (beta0 y beta1) y lo que observamos para Pedro, Juan y Diego.
## Es decir, si tenemos esto:

## Nombre    Educacion (x)    Prestigio (y)   beta0      Beta1     Error
# -----------------------------------------------------------------------
## Pedro        10                15            1         2         -6
## Juan         5                 10            1         2         ?
## Diego        2                 8             1         2         ?

## Recuerda (1): son los mismos betas para todos.
## Recuerda (2): Por ej., para el caso de Pedro, la formula
## "Prestigio = b0 + b1Educacion + e",
## o "Prestigio_{i} = b0 + b1Educacion_{i} + e_{i}", que es lo mismo,
## seria asi:

## Pedro:
## 15 = 1 + 2*10 - 6

######################################################################
## (1)
## Como seria para el caso de Juan y Diego?
## Responde
######################################################################

## Juan?

## Diego?

######################################################################
## OK; sigamos. Ahora carguemos una base de datos real.

if (!require("pacman")) install.packages("pacman"); library(pacman)
p_load(car) # En este paquete, "vive" la base "Prestige" ("Prestigio").

# Carga la base
data(Prestige)

# Mira como se ve la base de datos
head(Prestige)

# Extrae la 'x' para conseguir beta1
x = Prestige$education

# Ve como se ve "x"
x

## Recuerda que para conseguir beta0 debes anexar una columna de 1's.

## Aqui le decimos a R que repita 1s, del largo (o "lenght") de 'x'.
unos = rep(1,length(x))

# Ve como se ve "unos"
unos

# Ahora junta ambas cosas ("x" y "unos")

x = matrix(
  c(unos,x), # meter vectores 'unos' y 'x'
  ncol = 2 # y organizarlos en 2 columnas.
  )

x # mira como se ve la nueva matrix "x"

# Extrae la 'y'
y = matrix(Prestige$prestige)

y

######################################################################
## (2)
## Calcula beta0 y beta1
######################################################################

## Recuerda los operadores

# Transponer
# t()

# Invertir
# inv()
## Recuerda cargar "matlib" para usar la funcion "inv()".
if (!require("pacman")) install.packages("pacman"); library(pacman)
p_load(matlib)

# Multiplicar matrices
# Por ejemplo x*x es  x%*%x

# OK; ahora tu. Calcula b = (x'x)^-1x'y

######################################################################
# Problema
######################################################################

# Funciona
inv(t(x) %*% x) %*% t(x) %*% y

# No Funciona
inv(x) # Matrix debe ser cuadrada, pero "x" es rectancular.

# Por que?

inv(t(x) %*% x) # funciona
# Porque para multiplicar una matriz, debe ser CONFORMABLE.
# La dimension de "x" es 2x102 (dos columnas, 102 filas). Si "x" fuera 2x2, se podria.
# Sin embargo, al multiplicar x' (que es 102x2) y x (que es 2x102), por
# el "inner rule" (no se el espanol), es decir, el 2 y el otro 2,
# sabemos que la invertidad de x'x esta definida, porque x'x es cuadrado.

######################################################################
## (3)
## Comprueba que hiciste todo bien.
## Estima una regresion lineal, pero ocupando
## el comando "lm" (por "linear model"). El comando "lm" se ocupa asi:
## lm(y ~ x). Define 'y' como 'Prestige$prestige' y 'x' como 'Prestige$education'.

modelo = lm(Prestige$prestige ~ Prestige$education)

options(scipen=9999)
summary(modelo)

######################################################################
## (4) Usando el comando 'plot', haz un grafico entre Prestigio y Educacion.
data(Prestige)

######################################################################
## (5) Usando tus propias palabras, y usando los resultados
## de tu regresion lineal y el grafico, interpreta que significa
## beta0 y que significa beta1.

## (5.1) Que significa beta0? Responde.

## (5.2) Que significa beta1? Responde.


MGRAST_preprocessing <<- function(file_in,     # name of the input file (tab delimited text with the raw counts)
                                             file_out = "preprocessed_data",    # name of the output data file (tab delimited text of preprocessed data)

                                             produce_fig = FALSE,     # boolean - to produce a figure (TRUE) or not (FALSE)
                                             image_out = "my_boxplots",   # name of the output image (the boxplot figure)
                                             raw_data_boxplot_title      = "raw data",   # title for the top (raw data boxplot)
                                             centered_data_boxplot_title = "log2(x+1) & centered per sample, scaled 0 to 1 over all samples", # title for the lower (preprocesed data) boxplot
                                             figure_width                = 950,                      # usually pixels, inches if eps is selected; png is default
                                             figure_height               = 1000,                     # usually pixels, inches if eps is selected; png is default
                                             figure_res                  = NA                       # usually pixels, inches if eps is selected; png is default
                                             )

{

###### sub to import the input_file
#import_data <- function(file_name)
  {
    input_data = data.matrix(read.table(file_in, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))
  }
###### replace NA's with 0
  input_data[ is.na(input_data) ]<-0

###### get the diensions of the input object
  number_entries = (dim(input_data)[1]) # number rows
  number_samples = (dim(input_data)[2]) # number columns

###### perform log transformation
  log2_data = log2(input_data + 1)

###### create object to store data that are log transformed and centered
  log2_cent_data <<- matrix(0, number_entries, number_samples)

###### pull column and row names from the input_data
  dimnames(log2_cent_data)[[2]] <<- dimnames(input_data)[[2]] # colnames #edited 6-15-10
  dimnames(log2_cent_data)[[1]] <<- dimnames(input_data)[[1]] # rownames #edited 6-15-10

###### center data from each sample (column)
  for (i in 1:number_samples){
    sample = log2_data[,i]
    mean_sample = mean(sample)
    stdev_sample = sd(sample)
    for (j in 1:number_entries){
      log2_cent_data[j,i] <<- ((log2_data[j,i] - mean_sample)/stdev_sample)
    }
  }

###### norm values from 0 to 1
  min_value = min(log2_cent_data)
  for (i in 1:number_samples){
    for (j in 1:number_entries){
      log2_cent_data[j,i] <<- (log2_cent_data[j,i] + abs(min_value))
    }
  }
  max_value= max(log2_cent_data)
  for (i in 1:number_samples){
    for (j in 1:number_entries){
      if (log2_cent_data[j,i] == 0){
      }else{
        log2_cent_data[j,i] <<- ((log2_cent_data[j,i]/max_value))
      }
    }
  }

###### write the log transformed and centered data to a file
  write.table(log2_cent_data, file=file_out, sep="\t", col.names = NA, row.names = TRUE, quote = FALSE)

  if (produce_fig == TRUE){  # optional - produce an out put image
    suppressPackageStartupMessages(library(Cairo))
    CairoPNG(image_out, width = figure_width, height = figure_height, pointsize = 12, res = fiure_res , units = "px")
    split.screen(c(2,1))
    screen(1)
    boxplot(input_data, main = raw_data_boxplot_title, las=2)
    screen(2)
    boxplot(log2_cent_data, main = centered_data_boxplot_title, las=2)
    dev.off()
  }

}


library(tidyverse)
library(ggplot2)

norway_data <- read_csv("/Users/ryanlee/Documents/Projects/carbon-emissions-data/raw/norway_table_emissions.csv")
sweden_data <- read_csv("/Users/ryanlee/Documents/Projects/carbon-emissions-data/raw/sweden_table_emissions.csv")

#Scatterplots
ggplot(norway_data, aes(x = Year, y = Emissions)) + geom_line()
ggplot(sweden_data, aes(x = Year, y = Emissions)) + geom_line()

#Regressions of total emissions
norway_total_emissions_regression = lm(formula = Emissions ~ Year, data = norway_data)
sweden_total_emissions_regression = lm(formula = Emissions ~ Year, data = sweden_data)

#Regression of emissions per GDP
names(norway_data)[10] = 'gdp'
norway_gdp_emissions_regression = lm(formula = Emissions ~ Year / gdp, data = norway_data)

names(sweden_data)[10] = 'gdp'
sweden_gdp_emissions_regression = lm(formula = Emissions ~ Year / gdp, data = sweden_data)

#Scatterplots (emissions per GDP)
ggplot(norway_data, aes(x = Year, y = Emissions / gdp)) + geom_line()
ggplot(sweden_data, aes(x = Year, y = Emissions / gdp)) + geom_line()

#Regressions of emissions per capita
norway_emissions_per_capita_regression = lm(formula = Emissions ~ Year / Population, data = norway_data)
summary(norway_emissions_per_capita_regression)

sweden_emissions_per_capita_regression = lm(formula = Emissions ~ Year / Population, data = sweden_data)
summary(sweden_emissions_per_capita_regression)

summary(norway_total_emissions_regression)


source("llr.r")

n = 10000
p0 = 0.01
n1 = 1000
n2 = 10000
z = data.frame(
    k1 = as.numeric(gl(50, 1, n))-1,
    k2 = as.numeric(gl(200, 50, n))-1,
    llr = rep(0, n)
)
z$w1 = dbinom(z$k1, size=n1, p=p0)
z$w2 = dbinom(z$k2, size=n2, p=p0)
z$w = z$w1 * z$w2

for (i in 1:n) {
    z$llr[i] = llr(matrix(c(z$k1[i], n1 - z$k1[i], z$k2[i], n2 - z$k2[i]), nrow=2))
}
i = order(z$llr)
z = z[i,]
z$q = cumsum(z$w)

pdf('fig4.pdf', width=6, height=6)
par(mar=c(4,5,1,1))
plot(z$llr, log10(1-z$q), type='l', ylim=c(-7,0), xlim=c(0,30), ylab=NA, xlab=NA, yaxt='n')
axis(2, at=c(-7:0), las=2)
mtext(expression(-2 ~ log ~ lambda), side=1, line=3, cex=1.3)
mtext(expression(log10~(1-P)), side=2, line=2.5, cex=1.3)
lines(z$llr, log10(1-pchisq(z$llr, df=1)), col='red')
dev.off()


# examples with sort, order and rank

library(dslabs)
data(murders)

total <- murders$total

# sort data, from lowest to highest
sorted <- sort(total)
print('Sorted data:')
sorted

# order data, returning *indexes* corresponding
# with sorted data
indexes <- order(total)
print('Indexes:')
indexes

# return murders$abb INDEXED, ie, in the sequence
# assigned before
murders$abb[indexes]

# return 'ranking' of data, corresponding of
# position the value occupy in the sequence
# from lowest to highest
ranking <- rank(total)
print('Ranking:')
print(ranking)

# max and min functions
max(total)
min(total)

# which max and min?
index_max = which.max(total)
index_min = which.min(total)
index_max
murders$state[index_max]
index_min
murders$state[index_min]


# Load required libraries
library(tidyverse)
library(ggrepel)

# Load built-in dataset
data(mtcars)

mtcars[1]
# Load csv file
population_2020 <- read_csv('world_population2020.csv')
pop_2020 <- read_csv('https://raw.githubusercontent.com/yld-weng/datasets/master/CC0-PublicDomain/world_population2020.csv')

myCalculation <- function(number) {
  square = number*number
  square + 7
}

###################################################
########## Data manipulation & summaries ##########
###################################################

mtcars

tail(mtcars, 10)

summary(mtcars)

colMeans(mtcars)

sum(mtcars$carb)

head(mtcars, 10) %>% summarise(mean_mpg=mean(mpg), sd_disp=sd(disp))

firstTen <- head(mtcars, 10)
mean(firstTen$mpg)

# rename
rename(mtcars, 'miles/gallon'=mpg)
mtcars %>% rename('miles/gallon'=mpg)
rename(mtcars, 'miles/gallon'=mpg, 'horsepower'=hp)
names(mtcars)[names(mtcars) == 'mpg'] <- 'miles/gallon'

colnames(mtcars)

# groupby
mtcars %>% group_by(cyl) %>% summarise(Total = n(), avgMpg=mean(mpg), hpSD=sd(hp))

# select
mtcars %>% select(mpg, hp, cyl, qsec)
mtcars %>% select(!ends_with("c"))
mtcars %>% select(starts_with("m") & ends_with("g"))
mtcars %>% select(mpg:hp)
mtcars %>% select(contains("m"))

# filter
mtcars %>% filter(mpg > 30)
mtcars %>% filter(hp > 150 & hp < 200)
mtcars %>% filter(!is.na(mpg))

# mutate
# if you have categorical variables, can use filter(your_VAR %in% c(var1,var2,var3))
mtcars %>% mutate(carName=rownames(mtcars)) %>% filter(str_detect(carName, 'Volvo|Honda'))

# mutate with function
# Litres / kilometres
toKm <- function(x) {
  235.214583/x
}

mtcars %>% mutate('Litre/100km' = toKm(mpg))

mtcars %>% mutate('Litre/100km' = 235/mpg)

#arrange
mtcars %>% arrange(mpg, hp)

mtcars %>% arrange(desc(mpg)) %>% arrange(desc(hp))

#slice
mtcars %>% slice(29)
mtcars %>% slice_head(n=5)

# across
mtcars %>% summarise(across(,~median(., na.rm = TRUE)))

mtcars %>% summarise(across(contains('m'),~median(.)))
######################################
############### mtcars ###############
######################################

# simple scatter plot
ggplot(mtcars, aes(x=mpg, y=hp))

ggplot(mtcars, aes(x=mpg, y=hp)) + geom_point()

# Parameters
ggplot(mtcars, aes(mpg, hp)) + geom_point(alpha=.8,size=3, stroke=.8)

data(mtcars)
ggplot(mtcars, aes(mpg, hp, label=rownames(mtcars))) + geom_point(aes(color=factor(cyl)), size=4) + geom_text()

ggplot(mtcars, aes(mpg, hp, label=rownames(mtcars))) +
  geom_point(aes(color=factor(cyl)), size=4) +
  geom_smooth(method=lm) +
  geom_label_repel(
    nudge_x = -1.5,
    direction = "y",
    hjust = 0.5,
    force = 4,
    size = 4
  )

# Aesthetics
ggplot(mtcars, aes(mpg, hp, label=rownames(mtcars))) +
  geom_point(aes(color=factor(cyl)), size=4) +
  geom_smooth(method=lm, se=FALSE) +
  geom_label_repel(
    data=subset(mtcars, mtcars$mpg > 25 | mtcars$hp > 220),
    aes(label = mtcars %>% filter(mpg > 25 | hp > 220) %>% rownames(mtcars)),
    nudge_x = -2,
    direction = "y",
    hjust = 0.5,
    force = 4,
    size = 4
  ) +
  labs(title = "Cars: Horsepower vs Miles per Gallon",
       subtitle = "Explore fuel economy of popular cars via relationship
       between mpg and horsepower. Cars are grouped by number of cylinders."
  ) +
  theme_minimal() + scale_color_brewer(palette="Paired") +
  theme(legend.position = "bottom", text=element_text(size=17), legend.title=element_text(size = 18), plot.subtitle=element_text(size=13) ) +
  scale_x_continuous(position = "top") + scale_y_reverse()

#############################################################
############## 10 most used functions in Excel ##############
#############################################################

###### Conditional formula ######
pop_2020[(pop_2020$Population > 100000) & (pop_2020$Population < 200000),]
pop_2020[(pop_2020$Fert.Rate == 2.0 | pop_2020$Fert.Rate == 1.1),]

###### VLOOKUP ######
pop_2020[pop_2020$Region=="China",]$Land_Area

###### LEN ######
nchar(pop_2020[pop_2020$Region=="China",]$Land_Area)

###### COUNTA ######
sum(!is.na(pop_2020$Net_Migrants))

###### SUMIF / AVERAGEIF ######
sum(pop_2020[pop_2020$Density < 10,]$Population)

mean(pop_2020[pop_2020$Density < 10,]$Population)

###### LEFT / RIGHT ######
myString <- "ExcelToR"
substr(myString, 1, 5)
substr(myString, nchar(myString)-5+1, nchar(myString))

###### MAX / MIN ######
max(pop_2020$Density)
min(pop_2020$Density)

###### CONCATENATE ######
paste("Moving", "From", "Excel", "To", "R", sep = "!")

###### COUNTIF ######
pop_2020 %>% drop_na(Net_Migrants) %>% summarise(n = Net_Migrants > 500000) %>% count(n)

## INDEX ##
pop_2020[1,]
pop_2020[,4]
pop_2020[2:3,3]


	# DATA SETUP

		charity = read.csv("E:/STAT 897/Group Project/charity.csv")
		charity.t = charity
		charity.t$avhv = log(charity.t$avhv)
		charity.t$agif = log(charity.t$agif)
		charity.t$inca = log(charity.t$inca)
		charity.t$incm = log(charity.t$incm)
		charity.t$lgif = log(charity.t$lgif)
		charity.t$rgif = log(charity.t$rgif)
		charity.t$tgif = log(charity.t$tgif)
		charity.t$tlag = log(charity.t$tlag)

		data.train = charity.t[charity$part=="train",]
		x.train = data.train[,2:21]
		c.train = data.train[,22] # donr
		n.train.c = length(c.train) # 3984
		y.train = data.train[c.train==1,23] # damt for observations with donr=1
		# x.train.mat = model.matrix(damt~., data.train[c.train==1,2:23])[,-22]
		n.train.y = length(y.train) # 1995

		data.valid = charity.t[charity$part=="valid",]
		x.valid = data.valid[,2:21]
		c.valid = data.valid[,22] # donr
		n.valid.c = length(c.valid) # 2018
		y.valid = data.valid[c.valid==1,23] # damt for observations with donr=1
		#x.valid.mat = model.matrix(damt~., data.valid[c.valid==1,2:23])[,-22]
		n.valid.y = length(y.valid) # 999

		data.test = charity.t[charity$part=="test",]
		n.test = dim(data.test)[1] # 2007
		x.test = data.test[,2:21]

		x.train.mean = apply(x.train, 2, mean)
		x.train.sd = apply(x.train, 2, sd)
		x.train.std = t((t(x.train)-x.train.mean)/x.train.sd) # standardize to have zero mean and unit sd
		# x.train.mat.mean = apply(x.train.mat, 2, mean)
		# x.train.mat.sd = apply(x.train.mat, 2, sd)
		# x.train.mat.std = t((t(x.train.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		apply(x.train.std, 2, mean) # check zero mean
		apply(x.train.std, 2, sd) # check unit sd
		data.train.std.c = data.frame(x.train.std, donr=c.train) # to classify donr
		data.train.std.y = data.frame(x.train.std[c.train==1,], damt=y.train) # to predict damt when donr=1

		x.valid.std = t((t(x.valid)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		# x.valid.mat.std = t((t(x.valid.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		data.valid.std.c = data.frame(x.valid.std, donr=c.valid) # to classify donr
		data.valid.std.y = data.frame(x.valid.std[c.valid==1,], damt=y.valid) # to predict damt when donr=1

		x.test.std = t((t(x.test)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		data.test.std = data.frame(x.test.std)

		train.dat = data.frame(x = x.train.std, y = as.factor(data.train.std.c$donr))
		valid.dat = data.frame(x = x.valid.std, y = as.factor(data.valid.std.c$donr))

	#LIBRARIES

		library(MASS)
		library(tree)
		library(randomForest)
		library(gbm)
		library(e1071)
		library(lars)
		library(leaps)
		library(glmnet)
		library(pls)
		library(splines)
		library(gam)
		library(ISLR)
		library(magrittr)
		library(stringr)
		library(lubridate)
		library(dplyr)
		library(ggplot2)
		library(ggthemes)

		#EXPLORATORY DATA ANALYSIS
		# Helper Functions
		density_plots <- function( df , main = 'Density Plots') {
		  df %>%
		    gather(
		      key = measure ,
		      value = value
		    ) %>%
		    ggplot(
		      aes(
		        value ,
		        color = measure ,
		        group = measure
		      )) +
		    geom_density() +
		    facet_wrap( ~measure  , scales = 'free' ) +
		    ggtitle( label = main ) +
		    theme_gdocs() +
		    theme( plot.title = element_text( face = 'bold' , size = rel(1.5) , hjust = .5 ) )
		}

		## EDA Visuals ################################################################
		p    <- list()
		data <- charity %>% tbl_df
		cfg.predictors <-
		  c( "reg1" , "reg2" , "reg3" , "reg4" , "home" , "chld" , "hinc" ,
		     "genf" , "wrat" , "avhv" , "incm" , "inca" , "plow" , "npro" ,
		     "tgif" , "lgif" , "rgif" , "tdon" , "tlag" , "agif" )

		# raw data density plots
		p$density_raw <- {
		  data %>%
		    filter( part == 'train' ) %>%
		    dplyr::select( avhv , npro , tgif , lgif , rgif , agif , tdon , tlag , incm , inca ) %>%
		    density_plots( 'Density Plots of Raw Data' )
		}

		# log-transformed density plots
		p$density_logtransformed <- {
		  data %>%
		    filter( part == 'train' ) %>%
		    dplyr::select( avhv , npro , tgif , lgif , rgif , agif , tdon , tlag , incm , inca ) %>%
		    mutate_all( log ) %>%
		    density_plots( 'Density Plots of Log-Transformed Data' )
		}

		# correlation plot
		p$correlations <- {
		  data %>%
		    filter( part == 'train' ) %>%
		    select( cfg.predictors ) %>%
		    select( -matches('reg') ) %>%
		    cor() %>%
		    round( 3 ) %>%
		    ggcorrplot(
		      ggtheme = theme_gdocs ,
		      legend.title = 'r' ,
		      hc.order = T ,
		      colors = c('red' , 'white' , 'green') ,
		      show.diag = F ,
		      outline.color = 'black' ,
		      lab = T ,
		      lab_col = 'black' ,
		      lab_size = rel(2.5) ,
		      tl.cex = 13
		    ) +
		    ggtitle( 'Predictor Correlations' ) +
		    theme(
		      axis.ticks = element_blank() ,
		      panel.grid.major = element_blank() ,
		      panel.grid.minor = element_blank() ,
		      axis.text = element_text(face = 'bold', size = rel(3.5) , hjust = 0 ) ,
		      plot.title = element_text( face = 'bold' , size = rel(1.5) , hjust = .5 )
		    )
		}

		# predictors to damt - previously identified predictors are log-transformed first
		p$predstodamt <-  {
		  data %>%
		    filter( part == 'train' ) %>%
		    filter( damt > 0 ) %>%
  		  mutate_at(
  		    vars( avhv , tgif , lgif , rgif , agif , tlag , incm , inca ) ,
  		    log ) %>%
		    select( cfg.predictors , damt , -matches('reg') , -home , -genf ) %>%
		    gather( predictor , value , -damt ) %>%
		    ggplot( aes( value , damt , color = predictor , group = predictor ) ) +
		    geom_point() +
		    geom_density2d(  color = 'gray' ) +
		    geom_smooth( method = 'loess' , color = 'black') +
		    facet_wrap( ~ predictor , scales = 'free' ) +
		    theme_gdocs() +
		    theme(
		      legend.position = 'none'
		    )
		}

		# save plots to png
		p %>%
		  names %>%
		  lapply( function(x){
		    ggsave(
		      filename = paste0( 'plot-' ,  x , '.png' ) ,
		      plot = p[[x]]  ,
		      path = './output'
		    )
		  })

		#CLASSIFICATION MODELS: LOGIT, LDA, TREES-BASED, AND SVM

		#LOGISTIC REGRESSION
		model.logit <- glm(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
		                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
		                     x.tlag + x.agif,
		                  train.dat, family=binomial("logit"))

		post.valid.logit = predict(model.logit, valid.dat, type="response") # n.valid.c post probs

		profit.logit = cumsum(14.5*c.valid[order(post.valid.logit, decreasing=T)]-2)
		plot(profit.logit) # see how profits change as more mailings are made
		n.mail.valid = which.max(profit.logit) # number of mailings that maximizes profits
		c(n.mail.valid, max(profit.logit)) # report number of mailings and maximum profit

		cutoff.logit = sort(post.valid.logit, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
		chat.valid.logit = ifelse(post.valid.logit>cutoff.logit, 1, 0) # mail to everyone above the cutoff
		logit.table = table(chat.valid.logit, c.valid) # classification table
		logit.mail = sum(logit.table[2,])
		logit.mail.tp = logit.table[2,2]
		logit.error = (logit.table[2,1]+logit.table[1,2])/2018
		logit.profit = 14.5*logit.mail.tp - 2*logit.mail

		logit.error #validation error rate: 0.2215
		logit.mail #total mailings: 1,406
		logit.profit #total profit: $11,383.50

		#LDA Model Base
		model.ldaB = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
		                   x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
		                   x.tlag + x.agif,
		                 train.dat) # include additional terms on the fly using I()

		post.valid.ldaB = predict(model.ldaB, valid.dat)$posterior[,2] # n.valid.c post probs

		profit.ldaB = cumsum(14.5*c.valid[order(post.valid.ldaB, decreasing=T)]-2)
		plot(profit.ldaB) # see how profits change as more mailings are made
		n.mail.valid = which.max(profit.ldaB) # number of mailings that maximizes profits
		c(n.mail.valid, max(profit.ldaB)) # report number of mailings and maximum profit

		cutoff.ldaB = sort(post.valid.ldaB, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
		chat.valid.ldaB = ifelse(post.valid.ldaB>cutoff.ldaB, 1, 0) # mail to everyone above the cutoff
		ldaB.table = table(chat.valid.ldaB, c.valid) # classification table
		ldaB.mail = sum(ldaB.table[2,])
		ldaB.mail.tp = ldaB.table[2,2]
		ldaB.error = (ldaB.table[2,1]+ldaB.table[1,2])/2018
		ldaB.profit = 14.5*ldaB.mail.tp - 2*ldaB.mail

		ldaB.error #validation error rate: 0.2235
		ldaB.mail #total mailings: 1,406
		ldaB.profit #total profit: $11,354.50

		#LDA Model Base + Quad (hinc, chld, tdon, tlag, wrat, inca, npro, tgif)
		model.ldaF = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
		                   x.avhv + x.plow + x.npro + x.tgif + x.tdon +
		                   x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
		                   I(x.npro^2) + I(x.tgif^2),
		                 train.dat) # include additional terms on the fly using I()

		post.valid.ldaF = predict(model.ldaF, valid.dat)$posterior[,2] # n.valid.c post probs

		profit.ldaF = cumsum(14.5*c.valid[order(post.valid.ldaF, decreasing=T)]-2)
		plot(profit.ldaF) # see how profits change as more mailings are made
		n.mail.valid = which.max(profit.ldaF) # number of mailings that maximizes profits
		c(n.mail.valid, max(profit.ldaF)) # report number of mailings and maximum profit

		cutoff.ldaF = sort(post.valid.ldaF, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
		chat.valid.ldaF = ifelse(post.valid.ldaF>cutoff.ldaF, 1, 0) # mail to everyone above the cutoff
		ldaF.table = table(chat.valid.ldaF, c.valid) # classification table
		ldaF.mail = sum(ldaF.table[2,])
		ldaF.mail.tp = ldaF.table[2,2]
		ldaF.error = (ldaF.table[2,1]+ldaF.table[1,2])/2018
		ldaF.profit = 14.5*ldaF.mail.tp - 2*ldaF.mail

		ldaF.error #validation error rate: 0.1457
		ldaF.mail #total mailings: 1,267
		ldaF.profit #total profit: $11,763.00

		#CLASSIFICATION TREE, BASE MODEL

		model.treeB=tree(y~.,train.dat)
		summary(model.treeB)
		model.treeB

		tree.pred=predict(model.treeB,valid.dat,type="class")
		treeB.table = table(tree.pred,valid.dat$y)
		treeB.mail = sum(treeB.table[2,])
		treeB.mail.tp = treeB.table[2,2]
		treeB.error = (treeB.table[2,1]+treeB.table[1,2])/2018
		treeB.profit = 14.5*treeB.mail.tp - 2*treeB.mail

		treeB.error #validation error rate: 0.1516
		treeB.mail #total mailings: 1,165
		treeB.profit #total profit: $11,140.50

		#CLASSIFICATION TREE, RANDOM FORESTS MODEL

		#THE BELOW LOOP TO DISCOVER WHICH SEED RETURNS MAXIMUM PROFIT (SET.SEED(53) RETURNED MAXIMUM)
		# mat = matrix(, ncol=4)

		# for(i in 1:100){
		# iter = i
		# set.seed(i)
		# model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

		# summary(model.rf)
		# model.rf

		# tree.pred=predict(model.rf, valid.dat, type = "class")
		# rf.table = table(tree.pred, valid.dat$y)
		# rf.mail = sum(rf.table[2,])
		# rf.mail.tp = rf.table[2,2]
		# rf.error = (rf.table[2,1]+rf.table[1,2])/2018
		# rf.profit = 14.5*rf.mail.tp - 2*rf.mail

		# vec = c(iter, rf.error, rf.mail, rf.profit)
		# mat = rbind(mat, vec)
		# # print(i)
		# # print(rf.error) #validation error rate:
		# # print(rf.mail) #total mailings:
		# # print(rf.profit) #total profit: $
		# }

		set.seed(53)
		model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

		summary(model.rf)
		model.rf

		tree.pred=predict(model.rf,valid.dat,type="class")
		rf.table = table(tree.pred,valid.dat$y)
		rf.mail = sum(rf.table[2,])
		rf.mail.tp = rf.table[2,2]
		rf.error = (rf.table[2,1]+rf.table[1,2])/2018
		rf.profit = 14.5*rf.mail.tp - 2*rf.mail

		rf.error #validation error rate: 0.1070
		rf.mail #total mailings: 1,063
		rf.profit #total profit: $11,257.50

		#SVM CLASSIFICATION MODEL

		svm.train = svm(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
		                  x.avhv + x.plow + x.npro + x.tgif + x.tdon +
		                  x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2)
		                  + I(x.npro^2) + I(x.tgif^2),
		                data = train.dat, kernel = "linear", cost=10,scale = FALSE)

		summary(svm.train)
		set.seed(53)
		tune.charity = tune(svm, y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
		                      x.avhv + x.plow + x.npro + x.tgif + x.tdon +
		                      x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2)
		                    + I(x.npro^2) + I(x.tgif^2),
		                    data = train.dat, kernel = "linear", ranges = list(cost = c(0.001, 0.005, 0.01, 0.05, 0.1, 1, 5, 10)))

		summary(tune.charity)
		bestmod = tune.charity$best.model
		summary(bestmod)

		svm.pred = predict(bestmod, valid.dat)
		svm.table = table(predict = svm.pred, truth = valid.dat$y)
		svm.mail = sum(svm.table[2,])
		svm.mail.tp = svm.table[2,2]
		svm.error = (svm.table[2,1]+svm.table[1,2])/2018
		svm.profit = 14.5*svm.mail.tp - 2*svm.mail

		svm.error #validation error rate: 0.1115
		svm.mail #total mailings: 1,072
		svm.profit #total profit: $11,239.50

# PREDICTION MODELING

		# LEAST SQUARES REGRESSION

		#LEAST SQUARES MODEL (LM)

			model.ls3 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                 wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                 tgif + tdon + tlag + I(tlag^2) + agif,
						data.train.std.y)

			pred.valid.ls3 = predict(model.ls3, newdata = data.valid.std.y) # validation predictions
			ls3.mse = mean((y.valid - pred.valid.ls3)^2) # mean prediction error
			ls3.se = sd((y.valid - pred.valid.ls3)^2)/sqrt(n.valid.y) # std error

			ls3.mse
			ls3.se

		#BEST SUBSETS (BSS)

			bss.train.fit = regsubsets(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                             wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                             tgif + tdon + tlag + I(tlag^2) + agif,
				data=data.train.std.y, nvmax=17)

			which.min(summary(bss.train.fit)$bic)
			coef(bss.train.fit,which.min(summary(bss.train.fit)$bic))
			predict.regsubsets = function(object, newdata, id, ...){
				form = as.formula(object$call[[2]])
				mat = model.matrix(form, newdata)
				coefi = coef(object, id = id)
				xvars = names(coefi)
				mat[, xvars]%*%coefi
			}
			bss.pred = predict.regsubsets(bss.train.fit, data.valid.std.y, which.min(summary(bss.train.fit)$bic))
			bss.mse = mean((y.valid - bss.pred)^2) # mean prediction error
			bss.se = sd((y.valid - bss.pred)^2)/sqrt(n.valid.y) # std error

			bss.mse
			bss.se

		#BEST SUBSETS 10-FOLD VALIDATION (BSSF)

			k=10
			set.seed(53)
			bssf.folds = sample(1:k,nrow(data.train.std.y),replace=TRUE)
			bssf.cv.errors = matrix(NA, k, 10, dimnames=list(NULL, paste(1:10)))
			for (j in 1:k){
				bssf.train.fit=regsubsets(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
				                            wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
				                            tgif + tdon + tlag + I(tlag^2) + agif,
					data=data.train.std.y[bssf.folds!=j,], nvmax=17)
				for (i in 1:10){
					bssf.pred = predict(bssf.train.fit, data.train.std.y[bssf.folds==j,], id=i)
					bssf.cv.errors[j, i] = mean((bssf.pred - data.train.std.y$damt[bssf.folds==j])^2)
				}
			}
			bssf.mcv.errors = apply(bssf.cv.errors, 2, mean)
			which.min(bssf.mcv.errors) #Returns the number of variables in the Cross-Validation Selected model
			coef(bssf.train.fit, which.min(bssf.mcv.errors)) #Returns the coefficients for the CV selected model
			bssf.pred = predict.regsubsets(bssf.train.fit, data.valid.std.y, which.min(bssf.mcv.errors)) #Predicts y using the CV Selected model
			bssf.mse = mean((y.valid - bssf.pred)^2) #Calculates test MSE for the CV Selected model
			bssf.se = sd((y.valid - bssf.pred)^2)/sqrt(n.valid.y) # std error

			bssf.mse
			bssf.se

		#RIDGE REGRESSION (RR)

			#make x matrix and y from data.train.std.y
			rr.train.x = model.matrix(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                            wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                            tgif + tdon + tlag + I(tlag^2) + agif, data.train.std.y)[,-21]
			rr.train.y = data.train.std.y$damt
			rr.valid.x = model.matrix(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                            wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                            tgif + tdon + tlag + I(tlag^2) + agif, data.valid.std.y)[,-21]
			rr.valid.y = data.valid.std.y$damt

			set.seed(53)
			rr.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=0)

			rr.bestlam = rr.cv.out$lambda.min
			rr.bestlam

			rr.train.fit = glmnet(rr.train.x, rr.train.y, alpha=0, lambda=rr.bestlam)
			coef(rr.train.fit)[, 1]

			rr.pred = predict(rr.train.fit, s=rr.bestlam, newx=rr.valid.x)
			rr.mse = mean((y.valid - rr.pred)^2) # mean prediction error
			rr.se = sd((y.valid - rr.pred)^2)/sqrt(n.valid.y) # std error

			rr.mse
			rr.se

		#LASSO

			set.seed(53)
			lasso.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=1)

			lasso.bestlam = lasso.cv.out$lambda.min
			lasso.bestlam

			lasso.train.fit = glmnet(rr.train.x, rr.train.y, alpha=1, lambda=lasso.bestlam)
			coef(lasso.train.fit)[, 1]

			lasso.pred = predict(lasso.train.fit, s=lasso.bestlam, newx=rr.valid.x)
			lasso.mse = mean((y.valid - lasso.pred)^2)
			lasso.se = sd((y.valid - lasso.pred)^2)/sqrt(n.valid.y) # std error

			lasso.mse
			lasso.se

		#PRINCIPAL COMPONANTS

			set.seed(53)
			pcr.train.fit = pcr(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                      wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                      tgif + tdon + tlag + I(tlag^2) + agif,
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pcr.train.fit,val.type="MSEP")

			#PCR (M=10)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=10)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=13)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=13)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=16)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=16)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

		#PARTIAL LEAST SQUARES

			set.seed(53)
			pls.train.fit = plsr(damt ~ reg1 + reg2 + reg3 + reg4 + chld + hinc +
			                       wrat + I(wrat^2) + I(wrat^3) + I(wrat^4) + avhv + plow + npro +
			                       tgif + tdon + tlag + I(tlag^2) + agif,
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pls.train.fit,val.type="MSEP")

			#PLS (M=3)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=3)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=7)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=7)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=14)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=14)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

		#GAM

			#GAM - removed correlated variables
			gam.train.fit3 = gam(damt ~ reg1 + reg2 + reg3 + reg4 + s(chld,3) + s(hinc, 3) +
			                       poly(wrat, 3) + s(avhv, 3) + s(plow, 4) + s(npro, 3) +
			                       s(tgif, 4) + s(tdon, 3) + poly(tlag, 2) + s(agif, 4),
			                     data=data.train.std.y)

			gam.pred = predict(gam.train.fit3, data.valid.std.y)
			gam.mse = mean((y.valid - gam.pred)^2) # mean prediction error
			gam.se = sd((y.valid - gam.pred)^2)/sqrt(n.valid.y) # std error

			gam.mse
			gam.se

	#MODEL LDAF FINAL CLASSIFICATION MODEL

		model.ldaF = lda(donr ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + wrat +
		                   avhv + plow + npro + tgif + tdon +
		                   tlag + agif + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) + I(wrat^2) +
		                   I(npro^2) + I(tgif^2),
					 data.train.std.c) # include additional terms on the fly using I()

		n.mail.valid = which.max(profit.ldaF)
		tr.rate = .1 # typical response rate is .1
		vr.rate = .5 # whereas validation response rate is .5
		adj.test.1 = (n.mail.valid/n.valid.c)/(vr.rate/tr.rate) # adjustment for mail yes
		adj.test.0 = ((n.valid.c - n.mail.valid)/n.valid.c)/((1 - vr.rate)/(1 - tr.rate)) # adjustment for mail no
		adj.test = adj.test.1/(adj.test.1+adj.test.0) # scale into a proportion
		n.mail.test = round(n.test*adj.test, 0) # calculate number of mailings for test set
		post.test = predict(model.ldaF, data.test.std)$posterior[,2] # post probs for test data

		cutoff.test = sort(post.test, decreasing=T)[n.mail.test+1] # set cutoff based on n.mail.test
		chat.test = ifelse(post.test>cutoff.test, 1, 0) # mail to everyone above the cutoff
		table(chat.test)

	#GAM1 FINAL PREDICTION MODEL
		yhat.test = predict(gam.train.fit3, newdata = data.test.std) # test predictions

	#OUTPUT
	ip = data.frame(chat=chat.test, yhat=yhat.test) # data frame with two variables: chat and yhat
	write.csv(ip, file="E:/STAT 897/Group Project/Report/Report Elements/ip.csv",
          row.names=FALSE) # use group member initials for file name

Data Prep Classification and Prediction Analyis v6.r


options(digits = 2) #limits decimal points

Student <- c("John Davis", "Angela Williams", "Bullwinkle Moose",
 "David Jones", "Janice Markhammer", "Cheryl Cushing",
 "Reuven Ytzrhak", "Greg Knox", "Joel England",
 "Mary Rayburn")

  Math <- c(502, 600, 412, 358, 495, 512, 410, 625, 573, 522)
  Science <- c(95, 99, 80, 82, 75, 85, 80, 95, 89, 86)
  English <- c(25, 22, 18, 15, 20, 28, 15, 30, 27, 18)

  roster <- data.frame(Student, Math, Science, English, stringsAsFactors = FALSE)

  z <- scale(roster[, 2:4]) #scale function provides in SD units

  score <- apply(z,1, mean) #calculate row means using mean function
  roster<- cbind(roster, score) #add to roster

  y<- quantile(score,c(.8,.6,.4,.2)) #quantile function gives %tile rankj
  roster$grade[score >= y[1]] <- "A"
  roster$grade[score < y[1] & score >=y[2]] <- "B"
  roster$grade[score < y[2] & score >=y[3]] <- "C"
  roster$grade[score < y[3] & score >=y[4]] <- "D"
  roster$grade[score < y[4]] <- "F"

  name<-strsplit((roster$Student), " ") #extract last and first names
  lastname <- sapply(name, "[", 2) # 2nd element
  firstname <- sapply(name, "[, 1) #1st element
  roster <- cbind(firstname, lastname, roster[,-1]) #add to roster drop name

  roster<- roster[order(lastname,firstname),] #sort by last and first names


#' Activates the categories in an ART network
#'
#' This function returns a vector of category activations for the given
#' input vector, weight matrix, and bias value
#' @title ART_Activate_Categories
#' @param input A vector of size NumFeatures that contains the input signal into the network
#' @param weight Matrix of size NumFeatures-by-NumCategories which holds the weights of the network
#' @param bias Constant that is used to differentiate between very similar category activation values
#' @return Vector of size NumCategories that holds the activation value for each category
#' @details The length of the INPUT vector must equal the number of rows in the WEIGHT matrix,
#' and the BIAS value must be within the range [0, 1] (although values very near 0 are best).

ART_Activate_Categories = function(input, weight, bias)
{
  # Make sure the user supplied the required parameters.
  if(nargs() != 3)
  {
    stop('You must specify the 3 input parameters.');
  }

  # Check the size and range of the parameters.
  numFeatures=ncol(weight);
  numCategories= nrow(weight);

  if(length(input)!=numFeatures)
  {
    stop('The length of the input and rows of the weights do not match.');
  }
  if((bias < 0) | (bias > 1))
  {
    stop('The bias must be within the range [0, 1].');
  }

  # Set up the return variable.
  categoryActivation = matrix(1,numCategories,1);

  # Calculate the activation for each category.
  # This is done according to the following equation:
  #        Activation(j) = |Input^Weight(j)| / (bias + |Weight(j)|)
  for (j in 1:numCategories)
  {
    matchVector = pmin(input, weight[j,]);
    weightLength = sum(weight[j,]);
    categoryActivation[j,1] = sum(matchVector) / (bias + weightLength);
  }

  return (categoryActivation);
}


library(ambient)
library(dplyr)
library(tidyverse)
library(ggplot2)

# # # Step 1: Call the pdf command to start the plot
# pdf(file = "/Users/ishasharma/Desktop/plotsd46de.pdf",   # The directory you want to save the file in
#     width = 40, # The width of the plot in inches
#     height = 40) # The height of the plot in inches
#

long_grid(x=seq(0, 10, length.out = 1000), y=seq(0, 10, length.out = 1000))%>%
  mutate(
    x1 = x + gen_simplex(x, y) / 2,
    y1 = y + gen_simplex(x, y) / 2,
    worley = gen_simplex(x*8000, y*7000, value = 'distance', seed = 500),
    worley_frac =fracture(gen_simplex, billow, octaves = 1,
                          gain = spectral_gain(), x = x, y = y),
    full = blend(normalise(worley), normalise(worley_frac), gen_spheres(x1, y1))
  ) %>%
  plot(full)

# # Step 3: Run dev.off() to create the file!
# dev.off()


# Regression template for machine learning.

# Importing the data set
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Salary, SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Feature Scaling
training_set = scale(training_set)
test_set = scale(test_set)

# Fit regression to the dataset
# Create regressor

# Predict a new result with regression model
y_pred = predict(regressor, newdata = data.frame(Level = 6.5))

# Visualize graphic result of the regression model
# install.packages('ggplot2')
# library(ggplot2)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = dataset$Level, y = predict(regressor, newdata = dataset)),
            colour='blue') +
  ggtitle('Truth or Bluff (Regression Model)') +
  xlab('Level') + ylab('Salary')

# HIGH RESOLUTION: Visualize graphic result of the regression model
# install.packages('ggplot2')
# library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.1)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level=x_grid))),
            colour='blue') +
  ggtitle('Truth or Bluff (Regression Model)') +
  xlab('Level') + ylab('Salary')


# Author: Nikos Kougianos
# Date: 4/12/2020

# Use these 2 lines to set working directory as the current directory of the
# file. Tested on Rstudio @ Windows 10 OS.
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir);

# Read data
data <- read.table("iqdata.txt", sep=" ")

# Create one dataframe with non depressed mothers ->scorend
# and another one with depressed mothers

scorend <- data$V2[data$V1=="nd"]
scored <- data$V2[data$V1=="d"]
boxplot(scorend, scored, names=c("Non-depressed mothers","Depressed mothers"))
par(mfrow=c(2,1))
hist(scorend, xlab="IQ of children from Non-depressed mothers")
hist(scored, xlab="IQ of children from depressed mothers")
qqnorm(scorend,main="")
qqline(scorend)
title(main="Normal Probability plot for IQ of children from Non-depressed mothers")
qqnorm(scored,main="")
qqline(scored)
title(main="Normal Probability plot for IQ of children from depressed mothers")


# Setup
# -----
#
# The [sense library](https://github.com/SensePlatform/sense-r-module) includes
# a number of helper functions you can use from within R dashboards.

library('sense')

## [ggplot2](http://ggplot2.org/) is a great way to make pretty graphs.

library('ggplot2')

# Load Data
# ---------
#
# Download and load Boston housing price data.

system('wget -nc https://raw.github.com/vincentarelbundock/Rdatasets/master/csv/MASS/Boston.csv')
boston <- read.csv('Boston.csv')
head(boston)
summary(boston$price)

# Explore
# -------

qplot(boston$medv, main="Boston Median Housing Price")
qplot(boston$crim, boston$medv,
  main="Median Housing Prices vs. Crime",
  xlab="Crime", ylab="Median Housing Price (thousands)")
qplot(boston$age, boston$medv,
    main="Median Housing Prices vs. Building Age",
    xlab="Building Age", ylab="Median Housing Price (thousands)") +
  geom_smooth(method = "loess")


#Credit to Marie Charpignon

library(caret)

# Heart data
heart_df <- read.csv("heart_tidy.csv", sep = ',', header = FALSE)
str(heart_df)
head(heart_df)

# Train/Test split
set.seed(3033)
intrain <- createDataPartition(y = heart_df$V14, p= 0.7, list = FALSE)
training <- heart_df[intrain,]
testing <- heart_df[-intrain,]

# Check dimensions
dim(training)
dim(testing)

# Check absence of NA
anyNA(heart_df)

# Feature summary
summary(heart_df)

# Factor the outcome variable
training[["V14"]] = factor(training[["V14"]])
testing[["V14"]] = factor(testing[["V14"]])

# Part 1 - Train linear SVM model
trctrl <- trainControl(method = "repeatedcv", number = 10, repeats = 3)
set.seed(3233)
svm_Linear <- train(V14 ~., data = training, method = "svmLinear",
                    trControl=trctrl,
                    preProcess = c("center", "scale"),
                    tuneLength = 10)
# Model output
svm_Linear

# Test model
test_pred <- predict(svm_Linear, newdata = testing)
test_pred
confusionMatrix(test_pred,testing$V14)

# Part 2 - Model tuning
# Choose the value of C leading to best model performance
grid <- expand.grid(C = c(0.001, 0.01, 0.05, 0.1, 0.5, 1, 5, 20))
set.seed(3233)
svm_Linear_Grid <- train(V14 ~., data = training, method = "svmLinear",
                           trControl=trctrl,
                           preProcess = c("center", "scale"),
                           tuneGrid = grid,
                           tuneLength = 10)
# Model output
svm_Linear_Grid
plot(svm_Linear_Grid)

# Test model
test_pred_grid <- predict(svm_Linear_Grid, newdata = testing)
test_pred_grid

# Model performance
confusionMatrix(test_pred_grid,testing$V14)

2.10 Sensitivity Analysis and Model Evaluation/cross_validation_tutorial.r


rule {
	testSuite;
}

data pair(X,Y) =
	| pair : forall X, forall Y, X * Y -> pair(X, Y)
fst(*p) = let pair(*a, *b) = *p in *a
snd(*p) = let pair(*a, *b) = *p in *b

data intPair =
	| intPair : int * int -> intPair
fstInt(*p) = let intPair(*a, *b) = *p in *a
sndInt(*p) = let intPair(*a, *b) = *p in *b

data nat =
    | zero : nat
    | succ : nat -> nat
data tree(X) =
	| Nil : tree(X)
	| Tree : X * tree(X) * tree(X) -> tree(X)

data natNS()
constructor zeroNS : natNS
constructor succNS : natNS -> natNS

natNSAdd : natNS * natNS -> natNS
natNSAdd (*x, *y) =
	match *x with
	| zeroNS => *y
	| succNS(*z) => succNS(natNSAdd(*z, *y))

natNSToInt : natNS -> int
natNSToInt(*x) =
	match *x with
	| zeroNS => 0
	| succNS(*z) => natNSToInt(*z) + 1

testPatternMatching(*RES) {
	"abc" = "abc";
	1 = 1;
	3 = 1 + 2;
	3 = int(1.5 + 1.5);
	assert("true", *RES);
}
testNatNSadd(*RES) {
    *oneNS = succNS(zeroNS);
    *twoNS = succNS(*oneNS);
    *threeNS = natNSAdd(*oneNS, *twoNS);
    *i = natNSToInt(*threeNS);
    assert("*i == 3", *RES);
}
treeSize(*t) = match *t with
	| Nil => 0
	| Tree(*v, *l, *r) => 1 + treeSize(*l) + treeSize(*r)
partialTreeSize(*t) = match *t with
	| Tree(*v, *l, *r) => 1 + partialTreeSize(*l) + partialTreeSize(*r)

testNewSyntaxMatch(*RES) {
	*t = Tree(1, Nil, Nil);
	writeLine("stdout", type(*t));
	*n = treeSize(*t);
	assert("*n == 1", *RES);
}
testNewSyntaxMatch2(*RES) {
	assertError("partialTreeSize(Tree(1, Nil, Nil))", *RES);
}

~udMatcher1(*x) = let pair(*a, *b) = *x in (*a)

~udMatcher2(*x) = let pair(*a, *b) = *x in (*a, true)

~udMatcher3(*x) = let pair(*a, *b) = *x in list(*a)

testUserDefinedMatcher1(*RES) {
    assert("let udMatcher1(\*a) = pair(true,false) in \*a", *RES);
}

testUserDefinedMatcher2(*RES) {
    assert("let udMatcher2(\*a,\*b) = pair(false,false) in \*b", *RES);
}

testUserDefinedMatcher3(*RES) {
    assert("let udMatcher3(\*a) = pair(true,false) in elem(\*a,0)", *RES);
}
doubleFunc(*A) = *A * 2;

quadrupleFunc(*A) = let *B = doubleFunc(*A) in *B * 2;

testFunc1(*RES) {
    assert("doubleFunc(1)==2", *RES);
}

testFunc2(*RES) {
    assert("quadrupleFunc(3)==12", *RES);
}
testFactorial(*RES) {
    factorial(*f, 10);
    assert("*f == 10*9*8*7*6*5*4*3*2*1", *RES);
}
# factorial
factorial(*f,*n) {
    if(*n == 1) then {
        *f = 1;
    } else {
        factorial(*g, *n - 1);
        *f = *g * *n;
    }
} @("id", "20000")
testFibonacci(*RES) {
    fibr(*fs, 0, 37);
    *f = elem(*fs, 0);
    assert("*f == 24157817",*RES);
}
# fibonacci sequence
fibr : d list X * integer * integer -> integer
fibr(*fs, *i, *n) {
    if(*i == 0) then {
        *fs = list(0);
    } else if(*i == 1) then {
        *fs = list(1, 0);
    } else {
        *fs = cons(elem(*fs,0)+elem(*fs,1), *fs);
    }
    if(*i < *n) then {
        fibr(*fs, *i+1, *n);
    }
} @("id", "20001")

# assert rules
assert(*B) {
	assert(*B, *RES);
        writeLine("stdout", "*RES");
}

assertFalse(*B) {
	assertFalse(*B, *RES);
        writeLine("stdout", "*RES");
}

assertError(*B, *RES) {
	assert(*B, *RES);
        if(*RES like "[error]*") {
                *RES="[passed]";
        } else {
                *RES="[failed]";
        }

}

assert(*B,*RES) {
        if (errormsg(*RET = eval(*B),*E)==0) {
            if (*RET) {
                *RES="[passed]";
            } else {
                *RES="[failed]";
            }
        } else {
            *RES="[error]\n*E\n";
        }
	writeLine("stdout", "*B");
}

assertFalse(*B, *RES) {
    assert("*B == false", *RES);
}

fac(*A) = if *A == 0 then 1 else *A * fac(*A-1);
testFuncFac(*RES) {
    assert("fac(3) == 6", *RES);
}
fib2 : integer -> pair(integer, integer)
fib2(*i) =
    if *i == 0 then pair(-1, 0)
    else if *i == 1 then pair(0, 1)
    else let pair(*a, *b) = fib2(*i-1) in
        pair(*b, *a + *b);

fib : integer -> integer
fib(*i) = snd(fib2(*i));

testFuncFib(*RES) {
    assert("fib(5) == 5", *RES);
}

testPair1(*RES) {
    *p = pair(1, true);
    assert(str(snd(*p)), *RES);
}

testPair2(*RES) {
    *p = pair(1, true);
    assert(str(fst(*p)==1), *RES);
}

testPair3(*RES) {
    *p = pair(1, true);
    pair(*a,*b) = *p;
    assert("*a==1&&*b", *RES);
}

testLet1(*RES) {
    assertError("let 1 = 10 in true", *RES);
}

testLet2(*RES) {
    assert("let pair(\*a,\*b) = pair(1,2) in \*a == 1 && \*b==2", *RES);
}

testIntPair(*RES) {
    assert("fstInt(intPair(1, 2)) == 1", *RES);
}

testNewSyntaxMatch(*RES) {
	*t = Tree(1, Nil, Nil);
	writeLine("stdout", type(*t));
	*n = treeSize(*t);
	assert("*n == 1", *RES);
}
testNewSyntaxMatch2(*RES) {
	assertError("partialTreeSize(Tree(1, Nil, Nil))", *RES);
}

testSuite {
    runTests("test.*");
}
runTests(*Pattern) {
    *Start = time();
    *A = listextrules;
    *P=0;
    *F=0;
    *E=0;
    *O=0;
    *U=0;
    *FN="";
    *EN="";
    *C=0;
    foreach(*A) {
        if(*A like regex *Pattern && *A != "testSuite") then {
		writeLine("stdout", "*C: *A");
		if(arity(*A) == 1) then {
			eval("*A(\*RES)");
			writeLine("stdout", *RES);
			if(*RES like "[passed]*") then {*P=*P+1;}
			else if(*RES like "[failed]*") then {*F=*F+1;*FN="*FN*A\n"}
			else if(*RES like "[error]*") then {*E=*E+1;*EN="*EN*A\n"}
			else { *O=*O+1; }
		} else {
			*U=*U+1;
			eval(*A);
		}
		*C=*C+1;
	}
    }
    writeLine("stdout", "\nsummary *P passed *F failed *E error *O other *U undefined");
    if(*F!=0) {
        writeLine("stdout", "failed: *FN");
    }
    if(*E!=0) {
        writeLine("stdout", "error: *EN");
    }
    *Finish = time();
    *Time = double(*Finish) - double(*Start);
    writeLine("stdout", "time: *Time s");
}

INPUT null
OUTPUT ruleExecOut


#------------------------------------ Dirichlet process et echantillonnage de Gibbs-------------------------------------------
Dirichlet<- function(observations,iterations,alpha) {
    nbrp <- c(length(observations[,1]))
    print(nbrp);
    ParamOfClusters <- list()
    saving <- rep(1,iterations)
    clusters <- rep(1,nrow(observations))
    for (i in 1:max(clusters)) ParamOfClusters [[i]] <-Param_Update(observations[clusters==i,])
        for (m  in 1:iterations) {
        for (i in 1:nrow(observations) ){

            nbrp [clusters[i]] <- nbrp [clusters[i]] - 1
            if (nbrp [clusters[i]]!=0) {

            ParamOfClusters [[clusters[i]]] <- Param_Update(observations[clusters == clusters[i],])

     } else {
                ParamOfClusters [[ clusters[i] ]] <- NULL
                nbrp <- nbrp [-clusters[i]]
                clusters[ clusters>clusters[i] ] <-  clusters[ clusters>clusters[i] ] - 1
                   }

            process <- log(c(nbrp,alpha))
            for (k in 1:length(ParamOfClusters)){
                process[k] <- process[k] + LogofLik(ParamOfClusters[[k]],observations[i,]);
                }
            process <- exp(process - max(process));
            process <- process / sum(process);

            clusters[i] <- Tirage_multinomial(process)
            if (length(nbrp ) < clusters[i]) nbrp [clusters[i]]<-0
            nbrp [clusters[i]] <- nbrp [clusters[i]] + 1
            ParamOfClusters [[clusters[i]]] <- Param_Update(observations[clusters == clusters[i],])
        }

saving[m] <- max(clusters)
}
print(saving);
print(table(factor(saving)));
plot(observations,col=clusters)
return(clusters);

}

#--------------------------------------Fonctions utilisées à l'intérieur de l'algorithme---------------------------------------------------
Tirage_multinomial <- function (x) {
    a <- runif(1)
    b <- 0
    for (i in 1:length(x)) {
        b <- b + x[i]
        if (a<b) break;
        }
    return(i)
    }

Param_Update <- function (datas) {
    if (is.vector(datas)) datas<-matrix(datas,nrow=1)
    p <- c()
    for (i in 1:ncol(datas) ) {
        m <- mean( datas[,i] )
        s <-   sd( datas[,i] )
        if (is.na(s)) s<-1
        p <- c(p,m,s)
    }
    return(p)
}

    LogofLik <- function(params,data) {
    lg <- 0;
    for (i in 1:length(data) ) {
        m <- params[2*(i)-1]
        s <- params[2*(i)]
        lg <- lg + dnorm(data[i], m, s, log=TRUE)
    }
    return(lg)
}


### multi-wallenius
fp <- file.path("./examples/distribution/stan/multi_wallenius_hypergeometric_example.stan")
mod <- cmdstan_model(fp, force_recompile = T)

N <- 10
m <- c(500, 1000, 800)
n <- 55

odds <- c(0.2, 0.7, 0.1)
y <- rMWNCHypergeo(N, m, n, odds)

meanMWNCHypergeo(m, n, odds, precision=1E-7)

mod_out <- mod$sample(
  data = list(N = N,
              C = length(m),
              y = cbind(n, t(y)),
              m = m,
              tol = 0.01),
  chains = 2,
  init = 1,
  adapt_delta = 0.8,
  parallel_chains = 2,
  iter_warmup = 200,
  iter_sampling = 200
)

mod_out


=begin
  # sample-factorize03.rb

  require "algebra"

  A = AlgebraicExtensionField(Rational, "a") {|a| a**2 + a + 1}
  a = A.var
  P = Polynomial(A, "x")
  x = P.var
  f = x**4 + (2*a + 1)*x**3 + 3*a*x**2 + (-3*a - 5)*x - a + 1
  p f.factorize #=> (x + a)^3(x - a + 1)

((<_|CONTENTS>))
=end


#' Weighted Least Squares
#'
#' @param y outcome vector.
#' @param x design matrix
#' @param w weight matrix
#' @param se character.
#'   How to calculate robust variance-covariance matrix
#'   ("HC0", "HC1", "HC2", "HCj", "HC3", and "HC4")
#'   If "standard", calculate conventional variance-covariance matrix
#' @param cluster cluster variable.
#' @param cholesky logical (default is TRUE).
#'   When solving normal equation, use cholesky decomposition.
#'
#' @examples
#' \dontrun{
#' x <- cbind(x1 = rnorm(100), x2 = rnorm(100))
#' y <- x[, 1] + 2 * x[, 2] + rnorm(100)
#' w <- sample(c(1, 0.5), 100, TRUE)
#' est <- lm_internal(y, x)
#' est$estimate
#' }
#'
#'
wls <- function(y,
                x,
                w,
                se = "HC0",
                cluster,
                cholesky = TRUE) {
  # check matrix
  if (!is.matrix(y)) y <- matrix(y, ncol = 1)
  if (!is.matrix(x)) x <- as.matrix(x)
  x <- cbind("(Intercept)" = 1, x)
  if (nrow(y) != nrow(x)) stop("different number of rows x and y")
  if (missing(w)) w <- rep(1, nrow(x))
  omega <- diag(w)

  # output list
  output <- list()
  output$input$response <- y
  output$input$design <- x
  output$input$weights <- w

  # observation and degree of freedom
  n <- nrow(x)
  df <- nrow(x) - ncol(x)

  output$N <- n
  output$df <- df

  ##########################################################################
  # **solve normal equation**
  # Note: When using cholesky decomposition, there is another way to solve
  # 1. run `forwardsolve(t(cholesky), t(x) %*% w %*% y)`
  # 2. use its return value (ghat) and run `backsolve(cholesky, ghat)`
  ##########################################################################

  if (cholesky) {
    cholesky <- chol(t(x) %*% omega %*% x)
    xx <- solve(cholesky) %*% t(solve(cholesky))
  } else {
    xx <- solve(t(x) %*% omega %*% x)
  }

  p <- xx %*% t(x) %*% omega
  b <- p %*% y

  # predictions, residuals, and residual std.err.
  proj <- x %*% p
  yh <- proj %*% y
  eh <- y - yh

  yh <- c(yh)
  eh <- c(eh)

  s2 <- sum(eh ^ 2) / df

  output$yhat <- yh
  output$ehat <- eh
  output$resid.std.err <- s2

  # variance-covariance matrix
  if (missing(cluster)) {
    ## quotation
    standard <- rlang::quo(s2 * xx)
    hce <- rlang::quo(p %*% sigma %*% t(p))

    ## component of hce
    ## reference: https://economics.mit.edu/files/7422
    h <- diag(proj)
    util <- eh / (1 - h)
    mutil <- matrix(util, ncol = 1)
    sigma <- switch(se,
      "HC0" = diag(eh^2),
      "HC1" = diag(eh^2) * (n / df),
      "HC2" = diag(eh^2 / (1 - h)),
      "HCj" = (diag(util^2) - mutil %*% t(mutil) / n) * (n - 1) / n,
      "HC3" = diag(util^2),
      "HC4" = diag(eh^2 / (1 - h)^min(4, n * h / (n - df)))
    )

    vcov <- if (se == "standard") {
      rlang::eval_tidy(standard)
    } else {
      rlang::eval_tidy(hce, list(sigma = sigma))
    }

    output$vcov$matrix <- vcov
    output$vcov$type <- se
  } else {
    ## cluster-robust estimate of the variance matrix
    ## see http://cameron.econ.ucdavis.edu/research/
    ## Cameron_Miller_JHR_2015_February.pdf
    g <- unique(cluster)
    gvcov <- lapply(g, function(i) {
      bool <- cluster == i
      gx <- x[bool, ]
      gomega <- diag(w[bool])
      geh <- matrix(eh[bool], ncol = 1)
      t(gx) %*% gomega %*% geh %*% t(geh) %*% gomega %*% gx
    })
    gvcov <- Reduce("+", gvcov)
    vcov <- xx %*% gvcov %*% xx

    output$vcov$matrix <- vcov
    output$vcov$type <- "cluster-robust"
    output$vcov$cluster <- cluster

    df <- length(g) - 1

    output$df <- df
  }

  # create coefficient table
  bmat <- cbind(b, sqrt(diag(vcov)))
  t <- sapply(seq_len(nrow(bmat)), function(i) bmat[i, 1] / bmat[i, 2])
  bmat <- cbind(bmat, t)
  p <- apply(bmat, 2, function(t) 2 * pt(-abs(t), df))[, 3]
  bmat <- cbind(bmat, p)
  colnames(bmat) <- c("Estimate", "Std.Err.", "t", "P(>|t|)")

  output$estimate <- bmat
  output
}

#'
#' Fit weighted least squares
#'
#' @param y outcome variable
#' @param data data which is generated by [clean_rd_data()]
#' @param global logical. use all observations?
#' @param kernel character of kernel density ("uniform" or "triangular")
#' @param bw bandwidth.
#' @param point value of the running variable that
#'   the kernel weights weigh the most.
#' @param \dots se and cholesky arguments
#'
#' @importFrom rlang eval_tidy
#' @importFrom rlang as_label
#'
fit_wls <- function(y,
                    data,
                    global = TRUE,
                    kernel,
                    bw,
                    point,
                    ...){
  # outcome vector and design matrix
  args <- list(...)
  quo_y <- rlang::enquo(y)
  args$y <- rlang::eval_tidy(quo_y, data)

  exclude_x <- c(rlang::as_label(quo_y), "(weights)", "(cluster)", "d")
  args$x <- as.matrix(data[, !(names(data) %in% exclude_x), drop = FALSE])

  # weight vector
  if (global) {
    if (!is.null(data$"(weights)")) args$w <- data$"(weights)"
  } else {
    w <- if (!is.null(data$"(weights)")) data$"(weights)" else 1

    u <- abs(data$x - point) / bw
    kw <- switch(kernel,
      "triangular" = ifelse(u <= 1, (1 - u), 0),
      "uniform" = ifelse(u <= 1, 1 / 2, 0)
    )

    args$w <- w * kw
  }

  # cluster vector
  if (!is.null(data$"(cluster)")) args$cluster <- data$"(cluster)"

  # fit weighted least squares
  fit.wls <- do.call("wls", args)

  # output
  if (!global) {
    if (!is.null(data$"(weights)")) {
      fit.wls$input$local.wls$given.w <- w
    }
    fit.wls$input$local.wls$kernel.w <- kw
    fit.wls$input$local.wls$kernel <- kernel
    fit.wls$input$local.wls$data.point <- point
    fit.wls$input$local.wls$bandwidth <- bw
    fit.wls$input$local.wls$effective.nobs <- sum(kw > 0)
  }

  class(fit.wls) <- append("fit_wls", class(fit.wls))
  fit.wls
}

#' Re-fit Local Linear Regression
#'
#' @param object object with fit_wls class
#' @param extend numeric vector outside input data
#' @param force logical. Whether to ignore error about estimation
#'
#' @importFrom rlang quo
#' @importFrom rlang eval_tidy
#' @importFrom dplyr bind_rows
#' @importFrom stats predict
#'
fit_local_lm <- function(object,
                         extend,
                         force = TRUE) {
  outcome <- l <- NULL

  # recover data from input elements
  dt <- data.frame(object$input$response, object$input$design[, -1])
  colnames(dt) <- c("outcome", colnames(object$input$design)[-1])

  if (!is.null(object$input$local.wls$given.w)) {
    dt$"(weights)" <- object$input$local.wls$given.w
  }

  if (object$vcov$type == "cluster-robust") {
    dt$"(cluster)" <- object$vcov$cluster
  }

  # list of arguments for fit_wls
  args <- list()
  args$y <- rlang::quo(outcome)
  args$global <- FALSE
  args$data <- dt
  args$se <- object$vcov$type
  args$kernel <- object$input$local.wls$kernel
  args$bw <- object$input$local.wls$bandwidth

  # collect data point
  point <- unique(dt$x)
  if (!missing(extend)) point <- unique(c(extend, point))
  point <- sort(point)

  # fittted
  fit_quo <- rlang::quo(predict(do.call("fit_wls", l)))
  pred <- lapply(point, function(x) {
    args$point <- x
    if (force) {
      tryCatch({
        rlang::eval_tidy(fit_quo, list(l = args))
      }, error = function(e) {})
    } else {
      rlang::eval_tidy(fit_quo, list(l = args))
    }
  })

  # output
  dplyr::bind_rows(pred)

}


#' @export
derez <- function(x, new.nrow, new.ncol, row.pos, col.pos, mc.cores=1) {
  require('parallel')

  # This function only decreases resolution, doesn't increase
  new.nrow <- min(new.nrow, nrow(x))
  new.ncol <- min(new.ncol, ncol(x))

  # Divide rows and cols into approximately equal bins
  row.end <- round(seq(0, nrow(x), length.out=new.nrow+1))[-1]
  row.beg <- c(1, row.end[-new.nrow]+1)
  col.end <- round(seq(0, ncol(x), length.out=new.ncol+1))[-1]
  col.beg <- c(1, col.end[-new.ncol]+1)

  # Vectorized function to calculate mean for each bin
  avg.block <- function(i, j) {
    simplify2array(mclapply(1:length(i), function(k) {
      mean(x[row.beg[i[k]]:row.end[i[k]], col.beg[j[k]]:col.end[j[k]]])
    }, mc.cores=mc.cores))
  }

  # Outer calls the vectorized function to generate new matrix
  new.x <- outer(1:new.nrow, 1:new.ncol, avg.block)

  if ( missing(row.pos) && missing(col.pos) ) {
    return ( new.x )
  }

  new.row.pos <- NULL
  new.col.pos <- NULL

  if ( !missing(row.pos) ) {
    new.row.pos <- sapply(1:new.nrow, function (i) mean(row.pos[row.beg[i]:row.end[i]]))
  }
  if ( !missing(col.pos) ) {
    new.col.pos <- sapply(1:new.ncol, function (i) mean(col.pos[col.beg[i]:col.end[i]]))
  }

  return ( list(x=new.x, row.pos=new.row.pos, col.pos=new.col.pos) )

}


# Decision Tree Regression

# Importing the dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3] # Select the second column "Level" and the third column "Salary" only

# Splitting the data set into the Training set and Test set
#library(caTools)
#set.seed(123)
#split = sample.split(dataset$Profit, SplitRatio = 0.8)
#training_set = subset(dataset, split == TRUE)
#test_set = subset(dataset, split == FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fitting the Regression Model to the dataset
# install.packages('rpart')
library(rpart)
regressor = rpart(formula = Salary ~ .,
                  data = dataset,
                  control = rpart.control(minsplit = 1)) # Adding the split intervals

# Predicting a new result with Decision Tree Regression
y_pred = predict(regressor, data.frame(Level = 6.5)) # make sure the 6.5 value showed in four levels

# Visualizing the Decision Tree Regression results (for higher resolution ans smoother curve)
# Non-linear and Non-continuous Regression Model
# install.packages('ggplot2')
library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.01) # from 1-10 incremented by 0.01

ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level = x_grid))),#transform x_grid vector to a data frame
            color = 'blue') +
  ggtitle('Truth or Bluff (Decision Tree Rgeression)') +
  xlab('Level') +
  ylab('Salary')

Regression/Decision Tree/Decision Tree Regression.r


# Databricks notebook source
# install.packages(c("mlbench","rpart.plot", "e1071"))

# COMMAND ----------

library("caret")
library("e1071")
library("rpart")
library("tidyverse")

# COMMAND ----------

# Load the data
data("Boston", package = "MASS")
head(Boston)
#https://www.cs.toronto.edu/~delve/data/boston/bostonDetail.html

# COMMAND ----------

# MAGIC %md
# MAGIC ## Let's look into the Boston Dataset
# MAGIC ## Build a Decision Tree to predict Median Value

# COMMAND ----------

# MAGIC %md
# MAGIC ## What is the first step?

# COMMAND ----------

# Inspect the data
sample_n(Boston, 3)
# Split the data into training and test set
set.seed(123)
training.samples <- Boston$medv %>%
  createDataPartition(p = 0.8, list = FALSE)
train.data  <- Boston[training.samples, ]
test.data <- Boston[-training.samples, ]

# COMMAND ----------

# Fit the model on the training set
set.seed(123)
model <- train(
  medv ~., data = train.data, method = "rpart",
  trControl = trainControl("cv", number = 10),
  tuneLength = 10
  )
# Plot model error vs different values of
# cp (complexity parameter)
plot(model)

# COMMAND ----------

# Print the best tuning parameter cp that
# minimize the model RMSE
model$bestTune

# COMMAND ----------

# Plot the final tree model
par(xpd = NA) # Avoid clipping the text in some device
plot(model$finalModel)
text(model$finalModel, digits = 3)

# COMMAND ----------

# Decision rules in the model
model$finalModel
# Make predictions on the test data
predictions <- model %>% predict(test.data)
head(predictions)

# COMMAND ----------

summary(test.data$medv)

# COMMAND ----------

summary(predictions)

# COMMAND ----------

# Compute the prediction error RMSE
RMSE(predictions, test.data$medv)

# COMMAND ----------

# plot(predictions, test.data$medv)
 plot(predictions,test.data$medv,
      xlab="predicted",ylab="actual")
 abline(a=0,b=1)


library(devtools)
load_all()
n <- 10000
maf <- 0.3
g <- make_geno(n, 1, maf)
table(g)
e <- rnorm(n)
beta <- 2
y <- g * beta + e

summary(lm(y ~ g))

sigma <- 1 / (n-2) * sum(e^2)
denom <- sum((g - mean(g))^2)
sqrt(sigma / denom)

vy <- var(y)
vg <- var(g)

r2 <- 2^2 * 2 * 0.3 * 0.7 / vy

r2 <- vg / vy = vg / (vg + ve)
r2*vg + r2*ve = vg
ve = (vg - r2*vg)/r2

ve = vg*(1-r2)/r2

vy

tsigma <- vy - vy * r2

y <- make_phen(sqrt(0.4), g)

nsnp <- 10000
nid <- 10000
maf <- runif(nsnp)
g <- make_geno(nid, nsnp, maf)
eff <- rnorm(nsnp, sd=sqrt(0.2))
y <- g %*% eff + rnorm(nid, sd=sqrt(0.8))
# out <- gwas(y, g)
# summary(lm(y ~ g))
sum(eff^2 * 2 * maf * (1-maf))
mean(abs(eff))^2 * 2 * mean(maf) * (1-mean(maf)) * length(maf)

sqrt(0.2) * sqrt(2)/sqrt(pi)

library(simulateGP)

beta <- c(100)
hist(beta, breaks=100)
maf <- rbeta(length(beta), 0.8, 1)/2
hist(maf)
dat <- theoretical_gwas(beta, maf, 0.2, c(300000, 150000), minmaf=0.01)

library(ggplot2)

o <- subset(dat[[1]], pval < 5e-8)
ggplot(o, aes(x=abs(beta), y=abs(betahat))) +
geom_point() +
geom_smooth(method=lm) +
geom_abline(slope=1,intercept=0)

summary(lm(abs(betahat) ~ abs(beta), o))


fact <- function(n) {
  if (n <= 1) 1
  else n * Recall(n - 1)
}


# Q8.2 delta method
# h(beta_hat)+-Z(alpha/2)*t(dp(x))/dbeta)*var(beta)(dp(x)/dbeta)
# p(x)=exp(t(beta)X)/(1+exp(t(beta)X))
# dp(x)/d(beta)=x*exp(t(beta)*x)

px<-function(beta,x){
	return(exp(t(beta)%*%x)/(1+exp(t(beta)%*%x)))
}
dpx.dbeta<-function(beta,x){
	return(t(x)%*%exp(t(beta)%*%x)/(1+exp(t(beta)%*%x))^2)

}
colnames(coef(logitreg))==paste0(colnames(LogDPs)[1],StateName[k])


# script used to compute the canonical correlation
# not used on the final document

library('CCA')

library(MASS) # for lda
library(caret) # models and classification utils

source('functions.r')

file_path = './data/Muestra_563_UC3M_fixed.TPS'

tps = read_tps(file_path, remove_point_5 = TRUE, n_cases = 563)
x_coord_names = tps$x_colnames
y_coord_names = tps$y_colnames
x_procrustes_coord_names = sprintf("x_%s_proc",1:length(x_coord_names))
y_procrustes_coord_names = sprintf("y_%s_proc",1:length(y_coord_names))
x_allom_coord_names = sprintf("x_%s_allom",1:length(x_coord_names))
y_allom_coord_names = sprintf("y_%s_allom",1:length(y_coord_names))

data_filter = function(x) x %>% filter(diagnosis=='MAM' | diagnosis=='SAM')

results_cols = c("Accuracy", "Sensitivity","Specificity", "Precision", "Recall", "F1")
results = data.frame(matrix(ncol = length(results_cols), nrow = 0))
colnames(results) = results_cols

df = tps$df
df = perform_procrustes(df, x_coord_names, y_coord_names, plot_procrustes=FALSE)

# Canonical correlation of the landmarks

X = df %>% select(x_procrustes_coord_names)
Y = df %>% select(y_procrustes_coord_names)

canonical_correlation = cc(X, Y)

plt.cc(canonical_correlation, var.label = TRUE, ind.names = c(x_coord_names, y_coord_names))


#' @title folded_root
#' @description This is a placeholder for a description.
#' @param x default is x
#' @param p default is \code{1}.
#' @param inverse default is \code{NULL}.
#' @param ... other arguments passed to methods
#' @return  This is a placeholder for what it returns.
#' @author Jae Choi, \email{choi.jae.seok@gmail.com}
#' @export
folded_root = function(x, p=1, inverse=FALSE, ... ) {
  # as with Box-Cox transformation as (yp−1)/p,
  # limit when p→0, the logit function logit(p)=log(p)−log(1−p).
  # reference: https://stats.stackexchange.com/questions/399916/how-to-back-transform-a-folded-root/400119
  # default p = 1 .. ie.  expand scale from (0,1) to (-1, 1)
  # if      p = 1/2 .. ie.  expand scale from (0,1) to (-2, 2), etc
  # if      p -> 0 .. ie.  expand scale from (0,1) to (-Inf, Inf),  .. ie. logit ..etc

  if (!inverse) {
    i = which(x < 0)
    if ( length(i) > 0 ) {
      x[i] = 0
      message( "folded_root:: x was less than 0; truncating to 0" )
    }
    i = which(x > 1)
    if ( length(i) > 0 ) {
      x[i] = 1
      message( "folded_root:: x was greater than 1; truncating to 1" )
    }
    (x^p - (1-x)^p)/p
  } else {
    out = NULL
    Q = x  # rename to make it less confusing
    for ( i in 1:length(Q)) {
      q = Q[i]
      out = c(out,
        stats::uniroot( function(z) { folded_root(z, p) - q} , interval=c(0, 1), extendInt="no", ...)$root
      )
    }
    return(out)
  }
}


#' MLE for the Zero-truncated Poisson Lognormal distribution
#'
#' `ztplnMLE` fits the Zero-truncated Poisson lognormal distribution to data and
#'  estimates parameters mean `mu` and standard deviation `sig` in the lognormal
#'  distribution
#'
#'  The function searches the maximum likelihood estimates of mean `mu` and
#'  standard deviation `sig` using the optimization procedures in
#'  \code{\link{nlminb}}.
#'
#' @param n a integer vector of counts
#' @param lower_mu,upper_mu numeric values of lower and upper bounds for mean of
#'  the variables's natrual logarithm.
#' @param lower_sig,upper_sig numeric values of lower and upper bounds for
#' standard deviatoin of the variables's natrual logarithm
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @return \item{convergence}{An integer code. 0 indicates successful
#' convergence.}
#' @return \item{iterations}{Number of iterations performed.}
#' @return \item{message}{A character string giving any additional information
#' returned by the optimizer, or NULL. For details, see PORT documentation.}
#' @return \item{evaluation}{Number of objective function and gradient function
#'  evaluations}
#' @return \item{mu}{Maximum likelihood estimates of mu}
#' @return \item{sig}{Maximum likelihood estimates of sig}
#' @return \item{loglik}{loglikelihood}
#' @examples
#' y <- rztpln(100, 3, 2)
#' ztplnMLE(y)
#' @export
ztplnMLE <- function(n,
                     lower_mu = 0,
                     upper_mu = log(max(n)),
                     lower_sig = 0.001,
                     upper_sig = 10,
                     type1 = TRUE) {

  n <- n[n > 0]
  # set initial values using medians and sd for fast convergence
  params <- c(log(median(n)), sd(log(n)))

  loglik <- function(params, n) {
    mu <- params[1]
    sig <- params[2]
    if (type1) {
      lik <- do_dztpln(n, mu, sig)
    } else lik <- do_dztpln2(n, mu, sig)
    return(-sum(log(lik), na.rm = TRUE))
  }
  # faster than Nelder-Mead and BFGS in optim
  fit <- try(nlminb(params, # initial parameters
                    loglik, # function to be minimized (i.e., -logLike)
                    gradient = NULL,
                    lower = c(lower_mu, lower_sig),
                    upper = c(upper_mu, upper_sig),
                    n = n,
                    TRUE))
  fit$mu <- fit$par[1]
  fit$sig <- fit$par[2]
  fit$par <- NULL
  fit$loglik <- -fit$objective
  fit$objective <- NULL
  return(fit)
}


#' @useDynLib cop cop_allreduce_mat_qr
qr_reducer = function(x, root, comm=0L, type)
{
  comm_check_is_matrix(x, comm)
  comm_check_common_matrix_dims(x, comm)
  comm_check_is_int(root, comm)
  type = comm.match.arg(tolower(type), TYPES_STR_NUMERIC, comm=comm)
  type_int = type_str2int(type)

  root = as.integer(root)

  if (!is.double(x))
    storage.mode(x) = "double"

  comm = as.integer(comm)
  comm_ptr = pbdMPI::get.mpi.comm.ptr(comm)

  ret = .Call(cop_allreduce_mat_qr, x, comm_ptr, root, type_int)
  ret
}

#' QR Reduction
#'
#' Given an R matrix from a QR factorization on each process, this computes the
#' R matrix which is conceptually calculated by "stacking" all R matrices on top
#' of each other (like \code{do.call(rbind, R_list)}). The way this is actually
#' calculated is much more memory efficient, and probably more run time
#' efficient as well, if the local R matrices aren't very small.
#'
#' This can be used to create a TSQR. If the tall matrix is split by rows across
#' processes, compute the R matrix on the local chunk and then hand it to
#' \code{qr_reduce()}.
#'
#' @details
#' This works by defining a custom MPI data type (dense matrix) with a custom
#' reduction operation (given 2 R matrices, "stack" them, compute the stacked
#' QR and emit R). Each local operation uses the LAPACK functions
#' \code{_geqp3()}, similar to R's \code{qr()} with \code{LAPACK=TRUE}.
#'
#' @param x
#' The input data. Should be a numeric matrix. The matrix should be the same
#' dimensions across all processes.
#' @param comm
#' MPI communicator number.
#' @param type
#' The precision used for the intermediate calculations. Should be one of
#' "double" or "float".
#' @param root
#' MPI rank that should receive the return in the non-all version.
#'
#' @return
#' If the all version is called or if the calling rank is equal to \code{root},
#' then a numeric matrix is returned, and otherwise \code{NULL}.
#'
#' @examples
#' \dontrun{
#' suppressMessages(library(cop))
#'
#' x = matrix(1:4, 2) + 10*comm.rank()
#' out = qr_reduce(x)
#' mpi_print(out)
#'
#' finalize()
#' }
#'
#' @seealso \code{\link{cop_allreduce}()}
#'
#' @name qr_allreduce
#' @rdname qr_allreduce
NULL

#' @rdname qr_allreduce
#' @export
qr_allreduce = function(x, comm=0L, type="double")
{
  qr_reducer(x, root=REDUCE_TO_ALL, comm=comm, type=type)
}

#' @rdname qr_allreduce
#' @export
qr_reduce = function(x, root=0L, comm=0L, type="double")
{
  qr_reducer(x, root=root, comm=comm, type=type)
}


# R is flexible because you can often solve a single problem in many different ways.
# Some ways can be several orders of magnitude faster than the others.

# A. Memory allocation
# 1. Timings - growing a vector
# One of the deadly R sins, you should never grow a vector
# Slow code
growing <- function(n) {
    x <- NULL
    for(i in 1:n)
        x <- c(x, rnorm(1))
    x
}

# Use <- with system.time() to store the result as res_grow
system.time(res_grow <- growing(n = 30000))

# 2. Timings - pre-allocation
# Fast code
pre_allocate <- function(n) {
    x <- numeric(n) # Pre-allocate
    for(i in 1:n)
        x[i] <- rnorm(1)
    x
}

# Use <- with system.time() to store the result as res_allocate
n <- 30000
system.time(res_allocate <- pre_allocate(n))

# B. Importance of vectorizing the code
# 1. multiplication
# Slower for loop code
x <- rnorm(10)
x2 <- numeric(length(x))
for(i in 1:10)
    x2[i] <- x[i] * x[i]

# Vectorized version
# Store your answer as x2_imp
x2_imp <- x * x

# 2. calculating a log-sum
# Initial code
n <- 100
total <- 0
x <- runif(n)
for(i in 1:n)
    total <- total + log(x[i])

# Rewrite in a single line. Store the result in log_sum
log_sum <- sum(log(x))

# C. DataFrames and matrices
# 1. Column selection
# Which is faster, mat[, 1] or df[, 1]? As all values in a matrix have to contain the same data type, the matrix processing is much quicker.
# If either option can be picked, the matrix process will always be faster
microbenchmark(mat[, 1], df[, 1])

# 2. Row timings
# Which is faster, mat[1, ] or df[1, ]? As multiple data types can exist for a Data Frame with each column, this process will take longer
microbenchmark(mat[1, ], df[1, ])


library(e1071)
data(iris)

sample <- iris[sample(nrow(iris)), ]

train <- sample[1:105, ]
test <- sample[106:150, ]

# Training
tune <- tune(
    svm,
    Species~.,
    data = train,
    kernel = "radial",
    scale = FALSE,
    ranges = list(cost = c(0.001, 0.01, 0.1, 1, 5, 10, 100))
)
tune$best.model

summary(tune)

# Test
model <- svm(
    Species~.,
    data = train,
    kernel = "radial",
    cost = 5,
    scale = FALSE
)
pred <- predict(model, test)
table(pred, test$Species)


# Calculate temperature uncertainty and offset relative to pre-existing calibrations

Temperature_offset <- function(D47_mean, D47_err, known_T, slope, int){
    mean_T <- sqrt(slope * 10 ^ 6 / (D47_mean - int)) - 273.15
    diff_T <- mean_T - known_T
    T_upr <- sqrt(slope * 10 ^ 6 / (D47_mean - D47_err - int)) - 273.15
    diff_T_upr <- T_upr - known_T
    T_lwr <- sqrt(slope * 10 ^ 6 / (D47_mean + D47_err - int)) - 273.15
    diff_T_lwr <- T_lwr - known_T
    T_err <- (T_upr - T_lwr) / 2
    result <- c(mean_T, T_upr, T_lwr, diff_T, diff_T_upr, diff_T_lwr, T_err)
    names(result) <- c("reconstructed Temperature", "max reconstructed Temperature", "min reconstructed Temperature", "Temperature offset", "max Temperature offset", "min Temperature offset", "Temperature uncertainty")
    return(result)
}