# 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


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


	# 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);
}


#------------------------------------ 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)
}


=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)

}


#' @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)
}


# 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)
}


# Covariance structure: Compound symmetry
#
# This function generates a covariance matrix with compound symmetry structure.
#
# @param p Dimension.
# @param rho Correlation strength.
# @return A covariance matrix (p by p).
# @export
# @examples
# library(NRRR)
# CorrCS(10, 0.5)
CorrCS <- function(p,rho){
  Sigma <- matrix(nrow=p,ncol=p,rho)
  diag(Sigma) <- 1
  Sigma
}

# Covariance structure: Autoregressive
#
# This function generates a covariance matrix with autoregressive structure.
#
# @param p Dimension.
# @param rho Correlation strength.
# @return A covariance matrix (p by p).
# @export
# @examples
# library(NRRR)
# CorrAR(10, 0.5)
CorrAR <- function(p,rho){
  Sigma <- matrix(nrow=p,ncol=p,NA)
  for(i in 1:p){
    for(j in 1:p){
      Sigma[i,j] <- rho^(abs(i-j))
    }
  }
  Sigma
}

# Compute || Y - XC ||_F^2
#
# This function computes the sum of squared errors
# with given (A,B,U,V) and (X,Y).
#
# @param Y Response matrix with n rows and jy*d columns.
# @param X Design matrix with n rows and jx*p columns.
# @param Ag Matrix U.
# @param Bg Matrix V.
# @param Al Matrix A.
# @param Bl Matrix B.
# @param jx Number of basis functions to expand x(s).
# @param jy Number of basis functions to expand y(t).
# @export
# @return The returned items
#   \item{C}{the NRRR estimator of the coefficient matrix C.}
#   \item{XC}{a matrix, prediction of Y.}
#   \item{E}{a matrix, estimated error matrix.}
#   \item{sse,obj}{ a scaler, the sum of squared errors.}
Obj <- function(Y,X,Ag,Bg,Al,Bl,jx,jy){

  if(nrow(Bg)!=ncol(Bg)){
    Bl <- kronecker(diag(jx),Bg)%*%Bl
  }
  if(nrow(Ag)!=ncol(Ag)){
    Al <- kronecker(diag(jy),Ag)%*%Al
  }
  C <- Bl%*%t(Al)
  XC <- X%*%C
  E <- Y - XC
  sse <- sum(E^2)

  return(list(C=C,XC=XC,E=E,sse=sse,obj=sse))
}

cv.rrr <- function (Y,
                    X,
                    nfold = 10,
                    maxrank = min(dim(Y), dim(X)),
                    norder = NULL,
                    coefSVD = FALSE)
{
  ## record function call
  Call <- match.call()

  p <- ncol(X)
  q <- ncol(Y)
  n <- nrow(Y)

  ndel <- round(n / nfold)
  if (is.null(norder))
    norder <- sample(seq_len(n), n)

  cr_path <- matrix(ncol = nfold, nrow = maxrank + 1, NA)
  for (f in seq_len(nfold)) {
    if (f != nfold) {
      iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
    }
    else {
      iddel <- norder[(1 + ndel * (f - 1)):n]
    }
    ndel <- length(iddel)
    nf <- n - ndel
    idkeep <- (seq_len(n))[-iddel]
    Xf <- X[-iddel,]
    Xfdel <- X[iddel,]
    Yf <- Y[-iddel,]
    Yfdel <- Y[iddel,]
    ini <- rrr.fit(Yf, Xf, nrank = maxrank, coefSVD =  coefSVD)
    C_ls <- ini$coef.ls
    A <- ini$A
    tempFit <- Xfdel %*% C_ls
    tempC <- matrix(nrow = q, ncol = q, 0)
    for (i in seq_len(maxrank)) {
      tempC <- tempC + tcrossprod(A[, i])
      cr_path[i + 1, f] <-
        sum((Yfdel - tempFit %*% tempC) ^ 2)
    }
    cr_path[1, f] <- sum(Yfdel ^ 2)
  }
  index <- order(colSums(cr_path))
  crerr <- rowSums(cr_path[, index]) / length(index) * nfold
  minid <- which.min(crerr)
  rankest <- minid - 1
  ini <- rrr.fit(Y, X, nrank = maxrank)
  C_ls <- ini$coef.ls
  A <- ini$A

  out <- if (identical(rankest, 0)) {
    list(
      call = Call,
      cr.path = cr_path,
      cr.error = crerr,
      norder = norder,
      coef = matrix(0, nrow = p, ncol = q),
      rank = 0,
      coef.ls = C_ls
    )
  }
  else {
    list(
      call = Call,
      cr.path = cr_path,
      cr.error = crerr,
      norder = norder,
      coef.ls = C_ls,
      coef = C_ls %*% tcrossprod(A[, seq_len(rankest)]),
      rank = rankest
    )
  }
  #class(out) <- "cv.rrr"
  out
}

rrr.fit <- function(Y,
                    X,
                    nrank = 1,
                    weight = NULL,
                    coefSVD = FALSE)
{
  Call <- match.call()

  q <- ncol(Y)
  n <- nrow(Y)
  p <- ncol(X)
  stopifnot(n == nrow(X))

  S_yx <- crossprod(Y, X)
  S_xx <- crossprod(X)

  ## FIXME: 0.1 is too arbitrary
  S_xx_inv <- tryCatch(
    MASS::ginv(S_xx),
    error = function(e)
      solve(S_xx + 0.1 * diag(p))
  )

  ## FIXME: if weighted, this needs to be weighted too
  C_ls <- tcrossprod(S_xx_inv, S_yx)

  if (!is.null(weight)) {
    stopifnot(nrow(weight) == q && ncol(weight) == q)
    eigenGm <- eigen(weight)
    ## FIXME: ensure eigen success?
    ## sqrtGm <- tcrossprod(eigenGm$vectors * sqrt(eigenGm$values),
    ##                      eigenGm$vectors)
    ## sqrtinvGm <- tcrossprod(eigenGm$vectors / sqrt(eigenGm$values),
    ##                         eigenGm$vectors)
    sqrtGm <- eigenGm$vectors %*% (sqrt(eigenGm$values) *
                                     t(eigenGm$vectors))
    sqrtinvGm <- eigenGm$vectors %*% (1 / sqrt(eigenGm$values) *
                                        t(eigenGm$vectors))

    XC <- X %*% C_ls %*% sqrtGm
    ## FIXME: SVD may not converge
    ## svdXC <- tryCatch(svd(XC,nu=nrank,nv=nrank),error=function(e)2)
    svdXC <- svd(XC, nrank, nrank)
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
    AA <- tcrossprod(A)
    C_rr <- C_ls %*% sqrtGm %*% AA %*% sqrtinvGm
  } else {
    ## unweighted
    XC <- X %*% C_ls
    svdXC <- svd(XC, nrank, nrank)
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
    AA <- tcrossprod(A)
    C_rr <- C_ls %*% AA
  }

  ret <- list(
    call = Call,
    coef = C_rr,
    coef.ls = C_ls,
    fitted = X %*% C_rr,
    fitted.ls = XC,
    A = A,
    Ad = Ad,
    rank = nrank
  )

  if (coefSVD) {
    coefSVD <- svd(C_rr, nrank, nrank)
    coefSVD$d <- coefSVD$d[1:nrank]
    coefSVD$u <- coefSVD$u[, 1:nrank, drop = FALSE]
    coefSVD$v <- coefSVD$v[, 1:nrank, drop = FALSE]
    ret <- c(ret, list(coefSVD = coefSVD))
  }

  #class(ret) <- "rrr.fit"
  ret
}

rrs.fit <- function(Y,
                    X,
                    nrank = min(ncol(Y), ncol(X)),
                    lambda = 1,
                    coefSVD = FALSE)
{
  Call <- match.call()

  q <- ncol(Y)
  n <- nrow(Y)
  p <- ncol(X)

  S_yx <- t(Y) %*% X
  ## This is a key difference
  S_xx <- t(X) %*% X + lambda * diag(p)

  ## S_xx_inv <- tryCatch(solve(S_xx+0.1*diag(p)),error=function(e)ginv(S_xx))
  ## S_xx_inv <- ginv(S_xx)
  ## Use the Woodbury matrix identity
  if (lambda != 0) {
    S_xx_inv <- 1 / lambda * diag(p) -
      lambda ^ (-2) * t(X) %*% MASS::ginv(diag(n) + lambda ^ (-1) * X %*%
                                            t(X)) %*% X
  } else{
    S_xx_inv <- MASS::ginv(S_xx)
    if (sum(is.na(S_xx_inv)) > 0) {
      S_xx_inv <- solve(S_xx + 0.1 * diag(p))
    }
  }

  C_ls <- S_xx_inv %*% t(S_yx)

  ypy.svd <- TRUE
  ##if(ypy.svd){
  ##This is another key difference
  XC <- rbind(X, sqrt(lambda) * diag(p)) %*% C_ls
  svdXC <- tryCatch(
    svd(XC, nu = nrank, nv = nrank),
    error = function(e)
      2)
  if (tryCatch(
    svdXC == 2,
    error = function(e)
      3) == 3) {
    A <- svdXC$v[, 1:nrank]
    Ad <- (svdXC$d[1:nrank]) ^ 2
  } else{
    ypy.svd <- FALSE
  }
  #}
  if (!ypy.svd) {
    SS <- S_yx %*% C_ls
    SS <- (SS + t(SS)) / 2
    eigenSS <- eigen(SS, symmetric = TRUE)
    A <- as.matrix(eigenSS$vectors[, 1:nrank])
    Ad <- eigenSS$values[1:nrank]
  }

  AA <- A %*% t(A)
  C_rr <- C_ls %*% AA

  ##    if(c.svd){
  ##      svd_C <- svd(C_rr,nv=nrank,nu=nrank)
  ##      U <- as.matrix(svd_C$u[,1:nrank])
  ##      V <- as.matrix(svd_C$v[,1:nrank])
  ##      D <- diag(svd_C$d[1:nrank],nrow=nrank)
  ##
  ##      ####return ls estimator C_ls, reduced-rank estimator C_rr
  ##      ####return SVD of C_rr
  ##      list(A=A,Ad=Ad,C_ls=C_ls,C_rr=C_rr,U=U,V=V,D=D,C=C_rr,rank=nrank)
  ##    }else{
  ##      list(A=A,Ad=Ad,C_ls=C_ls,C_rr=C_rr,C=C_rr,rank=nrank)
  ##    }

  ret <- list(
    call = Call,
    coef = C_rr,
    coef.ls = C_ls,
    fitted = X %*% C_rr,
    fitted.ls = XC,
    A = A,
    Ad = Ad,
    nrank = nrank
  )

  if (coefSVD) {
    coefSVD <- svd(C_rr, nrank, nrank)
    coefSVD$d <- coefSVD$d[1:nrank]
    ret <- c(ret, list(coefSVD = coefSVD))
  }

  #class(ret) <- "rrs.fit"
  ret
}


#' Lambda
#'
#' Seasonal model for the intensity function, \eqn{\lambda(t) = a + b + b \sin(c\,2 \pi/365 + x 2 \,\pi / 365)}.
#'
#' @param x \code{numeric} vector of time points.
#' @param params \code{numeric} vector of parameters of length = 4.
#' @param  names A vector. Can be used to label
#' @return a \code{numeric} vector of the same length as \code{x}.
#' @examples
#' lambda(c(1,2,3,4,5,6), c(1,1,1,1) )
lambda<-function(x, params, names=F){
  p1<-params[1]
  p2<-params[2]
  p3<-params[3]
  p4<-params[4]
   # period = 365 # (days)
  period = 52 # (weeks)

  ret = p1 + p2 + (p2 + p4 * x)* sin(2 * pi / period * p3 + x * 2 * pi / period) + p4* x

  if(names){
    ret = c(0, ret)
    names(ret) = c('NA', 0:(length(ret)-2))
    return(ret)
  }else{
    return(ret)
  }
}

#' Negative log-likelihood
#'
#' \eqn{l(\lambda) = \log L(\lambda) = - \int_0^T\lambda(x) dx + \sum_{i=1}^n\log \lambda(x_i)}
#'
#' @param params A \code{numeric} vector of parameters of length = 4.
#' @param data A \code{numeric} vector of event times.
#' @return \code{numeric}.
#' @examples
#' neg.log.like(c(1,1,1,1),c(1,2,3,4,5,6))
neg.log.like<-function(params, data){
  lower<-min(data)
  upper<-max(data)
  integrate(lambda,lower,upper,params,subdivisions = 5000)$value - sum(log(lambda(data,params)))
}

#' Optimize function \code{neg.log.like} conditioned on having the last parameter fixed.
#'
#' @param data A \code{numeric} vector of event times.
#' @param cpar A \code{numeric}.
#' @param iteration This is the maximum number of interations allowed for the function \code{optimx}.
#' @return 2D 4x2 matrix.
#' @importFrom optimx optimx
#' @examples
#' cmle1(data, 1, iterations=20)
cmle1<-function(data, cpar, iterations=10000){
  fn<-function(par){
    if (all(par>c(0,2,0)) & all(par<c(100, 100, 60)) ){
      res = neg.log.like(c(par, cpar), data)
    }
    else{
      res = Inf
    }
    return(res)
  }
  n = 10
  start<-data.frame(p1=runif(n,0, 100), p2=runif(n, 2, 100), p3=runif(n, 1, 60))
  opt<-function(init){
    res<-optimx(as.vector(init),
                fn,
                method='Nelder-Mead',
                control=list(maxit=iterations, dowarn=FALSE)) # all.methods=TRUE
    # if (res$convcode != 0){
    #   cat("optimisation did not converge with code:", res$convergence, "\n")
    # }
    return(c(res$value, res$convcode, unlist(res[,1:3])))
  }
  res = apply(start, 1, opt)
  id = which.min(res[1,])
  return(res[3:5, id])
}

#' Optimize function \code{neg.log.like} conditioned on having the first three parameters fixed.
#'
#' @param data A \code{numeric} vector of event times.
#' @param cpar \code{numeric}.
#' @return \code{numeric}.
#' @examples
#' cmle2(data, c(1,1,1))
cmle2<-function(data, cpar){
  fn<-function(par){
    res = neg.log.like(c(cpar, par), data)
  }
  # else if ((par[4] < -0.1) | (par[4] > 0.1)){
  #   res = 1000000 * par[4] ^ 2
  # }
  res = optimize(fn, interval = c(0,10), tol = 0.00001)
  return(res$minimum)
}

#' Estimate the parameters for the seasonal model given the aggregated vector of event times.
#'
#' Optimize the function \code{neg.log.like} recursively calling \code{clme1} and \code{cmle2}.
#'
#' @param data A \code{numeric} vector of event times.
#' @param n.cycles \code{integer}. Number of times the conditional optimizers are called.#
#' @param start \code{numeric}. Starting parameters (not yet implemented).
#' @param save.on.dir \code{logical}. If TRUE, will save the inferred parameter in `timefactor_parameters.RData`.
#' @return \code{numeric}. A 2D 2x4 matrix with the estimated parameters.
#' @examples
#' cmle(data)
cmle<-function(data, n.cycles=10, start=NULL, save.on.dir=TRUE){
  par = cmle1(data, 0)
  trace = matrix(data=0, nrow = n.cycles, ncol = 4)
  for (i in 1:n.cycles){
    cat("Estimating parameters for temporal trend, step ", i, " of ", n.cycles, ".\r")
    trace[i,1:3] = par
    par1 = cmle2(data, par)
    trace[i,4] = par1
    par = cmle1(data, par1)
  }
  par1 = cmle2(data, par)
  Parameters = c(par, par1)
  trace[i,] = Parameters
  attributes(Parameters) = list(trace=trace)
  if(save.on.dir){
    save.and.tell('Parameters', file=file.path(getwd(), paste0('timefactor_parameters.RData')))
  }
  return(Parameters)
}

#' Lambda
#'
#' Seasonal model for the intensity function, \eqn{\lambda(t) = a + b + b \sin(c\,2 \pi/365 + x 2 \,\pi / 365)}.
#'
#' @inheritParams lambda
#' @return a \code{numeric} vector of the same length as \code{x}.
#' @examples
#' predict.cmle(c(1,2,3,4,5,6), c(1,1,1,1) )
predict.cmle<-lambda

predict.cmle.ci<-function(x, parameters){
  data.frame(upper=qpois(0.975,lambda(x,parameters)),
             lower=qpois(0.025,lambda(x,parameters)))
}

expand.histogram<-function(histo){
  Histo = data.frame(Names = as.integer(names(histo)), freq = unlist(histo))
  return(unlist(do.call(c, apply(Histo, 1, function(x){rep(x[1], x[2]) }) )))
}

Loess<-function(counts, span = 0.2){
  df = data.frame(time = 1:length(counts), counts = counts)
  loess(counts ~ time, df, span=span)
}

predict.Loess<-function(x, fit){
  df = data.frame(time = x)
  predict(fit, df)
}

predict.Loess.ci<-function(x, fit){
  df = data.frame(time = x)
  data.frame(upper= unlist(-predict(fit, df, se = T)[['se.fit']] + predict(fit, df, se = T)[['fit']]),
             lower= unlist(predict(fit, df, se = T)[['se.fit']] + predict(fit, df, se = T)[['fit']]))
}


library(MASS)

a_white <- 11
a_black <- 10
b_white <- 9
b_black <- 18

# a_white <- 19
# a_black <- 18
# b_white <- 17
# b_black <- 17

# a_white <- 12
# a_black <- 8
# b_white <- 10
# b_black <- 14

a <- a_white + a_black
b <- b_white + b_black

primadomanda <- ((b_white+1)/(b+1) * a_white/a) + ((b_white/(b+1)) * (a_black/a))
secondadomanda <- ((b_white+1)/(b+1) * a_white/a) / primadomanda

print(fractions(primadomanda))
print(fractions(secondadomanda))


# Example : 1   Chapter : 10.1     Page No: 496
# r of complex numbers
rad2deg <- function(rad) {
  (rad * 180) / (pi)
}
z<-complex(real=1,imaginary=1)
z1<-Conj(z)
print("r of z and its conjugate are")
print(Mod(z))
print(Mod(z1))
print("The argument of z and its conjugate in degrees are")
print(paste(rad2deg(Arg(z)),"degrees")) # in radians which is equal to 45 degree
print(paste(rad2deg(Arg(z1)),"degrees"))


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

StocSIRS <- function(y, pars, T, steps) {

	out <- matrix(NA, nrow = (T+1), ncol = 4)

	R0 <- pars[['R0']]
	r <- pars[['r']]
	N <- pars[['N']]
	eta <- pars[['eta']]
	berr <- pars[['berr']]
    re <- pars[['re']]

	S <- y[['S']]
	I <- y[['I']]
	R <- y[['R']]

	B0 <- R0 * r / N
	B <- B0

	out[1,] <- c(S,I,R,B)

	h <- 1 / steps

	for ( i in 1:(T*steps) ) {

        #Bfac <- 1/2 - cos((2*pi/365)*i)/2
        Bfac <- exp(2*cos((2*pi/365)*i) - 2)

		B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

		BSI <- Bfac*B*S*I
		rI <- r*I
        reR <- re*R

		dS <- -BSI + reR
		dI <- BSI - rI
		dR <- rI - reR

		S <- S + h*dS  #newInf
		I <- I + h*dI  #newInf - h*dR
		R <- R + h*dR  #h*dR

		if (i %% steps == 0)
			out[i/steps+1,] <- c(S,I,R,B)

	}

	colnames(out) <- c("S","I","R","B")
	return(out)

}

### suggested parameters
#
# T 		<- 200
# i_infec 	<- 10
# steps 	<- 7
# N 		<- 500
# sigma 	<- 5
#
# pars <- c(R0 = 3.0, 	# new infected people per infected person
#           r = 0.1, 	# recovery rate
#		    N = 500,    # population size
#		    eta = 0.5, 	# geometric random walk
#		    berr = 0.5, # Beta geometric walk noise
#           re = 1)  	# resuceptibility rate


intToLogicalBits <- function(intx) as.logical(intToBits(intx))
logicalBitsToInt <- function(lb) as.integer(sum((2^(0:31))[lb]))
"%AND%" <- function(x, y)
{
   logicalBitsToInt(intToLogicalBits(x) & intToLogicalBits(y))
}
"%OR%" <- function(x, y)
{
   logicalBitsToInt(intToLogicalBits(x) | intToLogicalBits(y))
}

35 %AND% 42    # 34
35 %OR% 42     # 42


# vectorized approach based on scalar code from primeSieve and mersenne in CRAN package `numbers`
require(gmp)
n <- 4423  # note that the sieve below assumes n > 9

# sieve the set of primes up to n
p <- seq(1, n, by = 2)
q <- length(p)
p[1] <- 2
for (k in seq(3, sqrt(n), by = 2))
  if (p[(k + 1)/2] != 0)
    p[seq((k * k + 1)/2, q, by = k)] <- 0
p <- p[p > 0]
cat(p[1]," special case M2 == 3\n")
p <- p[-1]

z2 <- gmp::as.bigz(2)
z4 <- z2 * z2
zp <- gmp::as.bigz(p)
zmp <- z2^zp - 1
S <- rep(z4, length(p))

for (i in 1:(p[length(p)] - 2)){
  S <- gmp::mod.bigz(S * S - z2, zmp)
  if( i+2 == p[1] ){
    if( S[1] == 0 ){
      cat( p[1], "\n")
      flush.console()
    }
    p <-  p[-1]
    zmp <- zmp[-1]
    S <-  S[-1]
  }
}


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

library("GA")

#Define data
n <- c("pocketknife","beans","potatoes","unions","sleepingbag","rope","compass")                # Items
p <- c(10,20,15,2,30,10,30) # Profits
w <- c(1,5,10,1,7,5,1)      # Weights
W <- 20                     # Knapsack ’s capacity

#Define fitness function
knapsack <- function(x){
    if(sum(x*w) > W)
	    return(0)
    else
		return(sum(x*p))
}

# Run SGA
SGA <- ga(type="binary",
  fitness=knapsack,         #fitness function
  nBits=length(n),          #chromosome length
  popSize=100,              #population size
  pcrossover=0.8,           #crossover rate
  pmutation=0.1,            #mutation rate
  elitism=5,                #number of best individuals sure to be selected
  maxiter=100,              #number of generations
  names=n,                  #name of "genes"
  seed=12345)               #random seed

res <- SGA@solution
print(res)                  #Best solution
sum(res)                    #Total number of selected items
sum(res*p)                  #Total profit of selected items
sum(res*w)                  #Total weight of selected items

#Plot model
plot(SGA@summary[,"mean"],type="l",ylab="mean fitness",xlab="iteration",
  col="blue",lty=1,lwd=2)
barplot(SGA@fitness,ylab="fitness",xlab="",col="blue")


##### Chapter 8: Association Rules -------------------

## Example: Identifying Frequently-Purchased Groceries ----
## Step 2: Exploring and preparing the data ----

# load the grocery data into a sparse matrix
library(arules)
groceries <- read.transactions("groceries.csv", sep = ",")
summary(groceries)

# look at the first five transactions
inspect(groceries[1:5])

# examine the frequency of items
itemFrequency(groceries[, 1:3])

# plot the frequency of items
itemFrequencyPlot(groceries, support = 0.1)
itemFrequencyPlot(groceries, topN = 20)

# a visualization of the sparse matrix for the first five transactions
image(groceries[1:5])

# visualization of a random sample of 100 transactions
image(sample(groceries, 100))

## Step 3: Training a model on the data ----
library(arules)

# default settings result in zero rules learned
apriori(groceries)

# set better support and confidence levels to learn more rules
groceryrules <- apriori(groceries, parameter = list(support =
                          0.006, confidence = 0.25, minlen = 2))
groceryrules

## Step 4: Evaluating model performance ----
# summary of grocery association rules
summary(groceryrules)

# look at the first three rules
inspect(groceryrules[1:3])

## Step 5: Improving model performance ----

# sorting grocery rules by lift
inspect(sort(groceryrules, by = "lift")[1:5])

# finding subsets of rules containing any berry items
berryrules <- subset(groceryrules, items %in% "berries")
inspect(berryrules)

# writing the rules to a CSV file
write(groceryrules, file = "groceryrules.csv",
      sep = ",", quote = TRUE, row.names = FALSE)

# converting the rule set to a data frame
groceryrules_df <- as(groceryrules, "data.frame")
str(groceryrules_df)


subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror)

# The Lee-Schacter test for the LOP (all points are real,
# i.e. non-ideal).  If the LOP is ***not*** satisfied (i.e. if
# vertex j is inside the circumcircle of vertices h, i, and k) then the
# diagonals should be swapped, i.e. shdswp ("should-swap") is true.
# Called by qtest.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot)
integer h
logical shdswp

# The vertices of the quadrilateral are labelled
# h, i, j, k in the anticlockwise direction, h
# being the point of central interest.

# Make sure the quadrilateral is convex, so that
# it makes sense to swap the diagonal.
# call acchk(i,j,k,shdswp,x,y,ntot,eps)
# if(!shdswp) return
#
# 23 July 2011:
# The foregoing test is a load of dingos' kidneys.  (1) It is
# unnecessary, and (2) it is wrong!  (1) If the LOP is not satisfied
# (the only circumstance under which there should be a swap) then the
# quadrilateral ***must*** be convex, and so swapping can sensibly
# take place.  (2) The vertices i, j, k in will ***always*** be in
# anticlockwise order, since the vertices h, i, j, k of the quadrilateral
# are in such order and i is connected to k, whence j can't be inside
# the triangle ihk.  So the test does nothing.  But then it didn't need
# to do anything.

# Get the coordinates of vertices h and j.
xh = x(h)
yh = y(h)
xj = x(j)
yj = y(j)

# Find the centre of the circumcircle of vertices h, i, k.
call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror)
if(nerror>0) return
if(shdswp) return # The points h, i, and k are colinear, so
                  # the circumcircle has `infinite radius', so
                  # (xj,yj) is definitely inside.

# Check whether (xj,yj) is inside the circle of centre
# (x0,y0) and radius r = dist[(x0,y0),(xh,yh)]

a  = x0-xh
b  = y0-yh
r2 = a*a+b*b
a  = x0-xj
b  = y0-yj
ch = a*a + b*b
if(ch<r2) shdswp = .true.
else shdswp = .false.

return
end


Nsr = (1 - albedoCoefficient) * solarRadiation
clearSkySolarRadiation = (0.75 + 2 * 10**(-5) * elevation) * extraSolarRadiation
averageT = ((maxTair + 273.16)** 4 + (minTair + 273.16)** 4) / 2
surfaceEmissivity = (0.34 - 0.14 * sqrt(vaporPressure / 10))
cloudCoverFactor = (1.35 * (solarRadiation / clearSkySolarRadiation) - 0.35)
Nolr = stefanBoltzman * averageT * surfaceEmissivity * cloudCoverFactor
netRadiation= Nsr - Nolr
netOutGoingLongWaveRadiation = Nolr


## First use no ordinal high-end category overrides, and compare power
## to t-test when there is no covariate

require(Hmisc)
n <- 100
delta <- .5
sd <- 1
require(pwr)
power.t.test(n = n / 2, delta=delta, sd=sd, type='two.sample')  # 0.70
source('~/R/Hmisc/R/popower.s')
set.seed(1)
w <- simRegOrd(n, delta=delta, sigma=sd, pr=TRUE)     # 0.686

## Now do ANCOVA with a quadratic effect of a covariate
n <- 100
x <- rnorm(n)
w <- simRegOrd(n, nsim=400, delta=delta, sigma=sd, x=x,
               X=cbind(x, x^2),
               Eyx=function(x) x + x^2, pr=TRUE)
w$power  # 0.68

## Fit a cubic spline to some simulated pilot data and use the fitted
## function as the true equation in the power simulation
require(rms)
N <- 1000
set.seed(2)
x <- rnorm(N)
y <- x + x^2 + rnorm(N, 0, sd=sd)
f <- ols(y ~ rcs(x, 4), x=TRUE)

n <- 100
j <- sample(1 : N, n, replace=n > N)
x <-   x[j]
X <- f$x[j,]
w <- simRegOrd(n, nsim=400, delta=delta, sigma=sd, x=x,
               X=X,
               Eyx=Function(f), pr=TRUE)
w$power  ## 0.70

## Finally, add discrete ordinal category overrides and high end of y
## Start with no effect of treatment on these ordinal event levels (OR=1.0)

w <- simRegOrd(n, nsim=400, delta=delta, odds.ratio=1, sigma=sd,
               x=x, X=X, Eyx=Function(f),
               p=c(.98, .01, .01),
               pr=TRUE)
w$power  ## 0.61   (0.3 if p=.8 .1 .1, 0.37 for .9 .05 .05, 0.50 for .95 .025 .025)

## Now assume that odds ratio for treatment is 2.5
## First compute power for clinical endpoint portion of Y alone
or <- 2.5
p <- c(.9, .05, .05)
popower(p, odds.ratio=or, n=100)   # 0.275
## Compute power of t-test on continuous part of Y alone
power.t.test(n = 100 / 2, delta=delta, sd=sd, type='two.sample')  # 0.70
## Note this is the same as the p.o. model power from simulation above
## Solve for OR that gives the same power estimate from popower
popower(rep(.01, 100), odds.ratio=2.4, n=100)   # 0.706
## Compute power for continuous Y with ordinal override
w <- simRegOrd(n, nsim=400, delta=delta, odds.ratio=or, sigma=sd,
               x=x, X=X, Eyx=Function(f),
               p=c(.9, .05, .05),
               pr=TRUE)
w$power  ## 0.72


#R version 3.3.2

# Implementation provided by
# Banks J., Garrabrant S.M., Huber M.L., Perizzolo A.
# in their paper titled "Using TPA to count linear extensi-ons"
# published in Journal of Discrete Algorithms, 2018.

#necessary to install the library for the first time
#install.packages('gtools', repos='http://cran.us.r-project.org')

library(gtools)
library(Matrix)

chain.step <- function(state,beta,i,c1,c2,posetmatrix) {
# Takes one step in the Karzanov-Khatchyan chain using randomness in i, c1, c2
# Assumes that home state is the identity permutation
# Line 2 of Algorithm 5.1
d <- i + 1 - state[i]
# Line 3 of Algorithm 5.1
if ((state[i] <= length(state)) && (state[i+1] <= length(state)))
posetflag <- posetmatrix[state[i],state[i+1]]
else
posetflag <- 0
if ( (c1 == 1) && (posetflag == 0) &&
(d <= ceiling(beta)) && ((d < beta) || (c2 == 1))) {
13
a <- state[i+1]; state[i+1] <- state[i]; state[i] <- a
}
return(state)
}

bounding.chain.step <- function(cstate,beta,i,c1,c2,posetmatrix) {
# Based on Algorithm 5.2
# Here cstate is a matrix with two rows, the first is the underlying state,
# while the second is the bounding state
n <- dim(cstate)[2]
# Line 1
if (cstate[2,i+1] == cstate[1,i]) c3 <- 1 - c1
else c3 <- c1
# Line 2 & 3
cstate[1,] <- chain.step(cstate[1,],beta,i,c3,c2,posetmatrix)
cstate[2,] <- chain.step(cstate[2,],beta,i,c1,c2,posetmatrix)
# Line 4 through 6
if (cstate[2,n] == (n+1))
cstate[2,n] <- 1 + sum(cstate[2,] <= n)
#Line 7
return(cstate)
}
generate <- function(t,beta,posetmatrix) {
n <- dim(posetmatrix)[1]; beta <- min(beta,n-1)
# Line 1
sigma <- 1:n; B <- rep(n+1,n)
# Line 2 thorugh 4
for (item in 1:(n - ceiling(beta)))
B[item+ceiling(beta)] <- item
B0 <- B
cstate <- matrix(c(sigma,B),byrow=TRUE,nrow=2)
# Line 5 through 8
i <- floor(runif(t)*(n-1))+1;c1 <- rbinom(t,1,1/2)
c2 <- rbinom(t,1,1+beta-ceiling(beta))
for (s in 1:t) {
cstate <- bounding.chain.step(cstate,beta,i[s],c1[s],c2[s],posetmatrix)
}
# Line 9
if (sum(cstate[2,] < (n+1)) == n) return(cstate[2,])
# Line 11-15
else {
cstate[1,] <- generate(2*t,beta,posetmatrix)
14
cstate[2,] <- B0
for (s in 1:t)
cstate <- bounding.chain.step(cstate,beta,i[s],c1[s],c2[s],posetmatrix)
}
return(cstate[1,])
}

approximate.sample <- function(n,beta,posetmatrix,tvdist) {
# Generates an approximate sample from the target distribution
x <- 1:n
n <- length(x)
t <- 10*n^3*log(n)*log(1/tvdist)
for (i in 1:t) {
i <- runif(1)*(n-1)+1
c1 <- rbinom(1,1,1/2)
c2 <- rbinom(1,1,1+beta-ceiling(beta))
x <- chain.step(x,beta,i,c1,c2,posetmatrix)
}
return(x)
}
checksum <- function(x) {
checksum <- 0
n <- length(x)
for (i in n:1) {
onespot <- which(x == 1)
checksum <- checksum + factorial(i-1)*(onespot-1)
x <- x[-onespot] - 1
}
return(checksum+1)
}

count.perfect.linear.extensions <- function(n = 4,beta = 4,posetmatrix,trials = 100) {
# Generates a number of linear extensions, then counts the results
results <- rep(0,factorial(n))
# Burnin to an approximate sample
x <- 1:n
n <- length(x)
# Take data
for (i in 1:trials) {
15
x <- generate(1,beta,posetmatrix)
cs <- checksum(x)
results[cs] <- results[cs] + 1
}
return(results/trials)
}

tpa.count.linear.extensions <- function(r,posetmatrix) {
# Algorithm 6.1
# Returns an estimate of the number of linear
# extensions consistant with posetmatrix
require(Matrix)
n <- dim(posetmatrix)[1]
# Line 1
k <- 0
# Line 2 through 12
for (i in 1:r) {
beta <- n - 1; k <- k - 1
while (beta > 0) {
k <- k + 1
x <- generate(1,beta,posetmatrix)
xinv <- invPerm(x)
betastep <- rep(0,n); y <- rep(0,n)
for (j in 1:n) {
y[j] <- runif(1)*((1+beta-ceiling(beta))*(xinv[j]-j == ceiling(beta))+
((xinv[j]-j) < ceiling(beta)))
betastep[j] <- (xinv[j]-j-1+y[j])*(xinv[j]-j > 0)
}
beta <- max(betastep)
# cat(" X: ",x,"\n X^{-1}: ",xinv,"\n Y: ",y,"\n betastep: ",betastep,"\n beta: ",beta,"\n")
}
}
cat(" Estimate: [",exp((k-2*sqrt(k))/r),",",exp((k+2*sqrt(k))/r),"]\n")
return(exp(k/r))
}

tpa.approximation <- function(posetmatrix,epsilon,delta) {
# Gives an $(\epsilon,\delta)$-ras for the number of posets
r1 <- ceiling(2*log(2/delta))
a1 <- tpa.count.linear.extensions(r1,posetmatrix)
16
a1 <- log(a1)
r2 <- ceiling(2*(a1+sqrt(a1)+2)*
(log(1+epsilon)^2-log(1+epsilon)^3)^(-1)*log(4/delta))
a2 <- tpa.count.linear.extensions(r2,posetmatrix)
return(a2)
}

brute.force.count.linear.extensions <- function(posets) {
# Counts the number of linear extensions of a poset by direct
# ennumeration of all n! permutations and checking each to see
# if it is a linear extension
#
# The poset is given as an n by n matrix whose (i,j)th entry
# is the indicator function of $i \preceq j$
require(gtools)
n <- dim(posets)[1]
A <- permutations(n,n)
nfact <- nrow(A)
le.flag <- rep(1,nfact)
count <- 0
for (i in 1:nfact) {
for (a in 1:(n-1))
for (b in (a+1):n) {
le.flag[i] <- le.flag[i]*(1-posets[A[i,b],A[i,a]])
}
count <- count + le.flag[i]
}
return(count)
}


#' Find optimal radia
#'
#' This function compute the optimal cylinder radia, such that the corresponding
#' cylinders contain one event in average
#' for the chosen N heights (\code{heights}) and a given \code{baseline.matrix}.
#' It returns an Nx2 \code{Matrix} whose first column contains the heights and
#' and the second column contains the corresponding radia.
#' @param baseline.matrix A \code{Matrix} enconding the baseline.
#' @param heigths \code{integer}.
#' @return A \code{Matrix}.
#' @examples
#' radia_and_heights = f_radia_and_heights(baseline.matrix, 1:10)
f_radia_and_heights<-function(baseline.matrix, heigths=1:100){
  n.heigths = ncol(baseline.matrix)
  mean.baseline = mean(baseline.matrix[, 1:n.heigths])
  # R = 3959 # earth radius in miles
  # lat1 = min(postcode2coord$latitude)
  # lat2 = max(postcode2coord$latitude)
  # lon1 = min(postcode2coord$longitude)
  # lon2 = max(postcode2coord$longitude)
  # total.area = (pi / 180) * R * R  * abs(sin(lat1)-sin(lat2)) * abs(lon1-lon2)
  total.area = 130279 # total area of England in km2s
  n.points = nrow(baseline.matrix)
  mean.spatial.baseline = mean.baseline * n.points / total.area
  # we want A such that A * mean.spatial.baseline=1,  A * mean.spatial.baseline=1/2,  A * mean.spatial.baseline=1/3, etc
  radia = sapply(heigths, function(x){sqrt(1 / mean.spatial.baseline / pi / x)} )
  ret = cbind(heigths, radia)
  colnames(ret) = c('heights','radia')
  return(ret)
}

#' Find optimal radia
#'
#' This function compute the optimal cylinder radia, such that the corresponding
#' cylinders contain one event in average
#' for the chosen N heights (\code{heights}) and a given tabulated baseline.
#' It returns an Nx2 \code{Matrix} whose first column contains the heights and
#' and the second column contains the corresponding radia.
#' @param baseline.matrix An \code{expand.grid} tab enconding the baseline.
#' @param heigths \code{integer}.
#' @return A \code{Matrix}.
#' @examples
#' radia_and_heights = f_radia_and_heights(baseline.matrix, 1:10)
f_radia_and_heights_<-function(baseline.tab, heights=1:100){
  n.heights = length(unique(baseline.tab$t))
  mean.baseline = mean(baseline.tab$z[baseline.tab$z>0]) # z strictly > 0 to exclude the grid points on unpopulated area.

  total.area = 130279 # total area of England in km2
  idx = baseline.tab$z > 0
  n.points = sum(idx) / n.heights
  delta2 = prod(attributes(baseline.tab)$delta2)
  mean.spatial.baseline = mean.baseline / (n.points * delta2) * total.area
  # we want A such that A * mean.spatial.baseline=1,  A * mean.spatial.baseline=1/2,  A * mean.spatial.baseline=1/3, etc
  radia = sapply(heights, function(x){sqrt(1 / mean.spatial.baseline / pi / x )} )
  ret = cbind(heigths, radia)
  colnames(ret) = c('heights','radia')
  return(ret)
}

#' Draw random cylinder coordinates
#'
#' Find the coordinates (centers and height limits) of cylinders
#' that contain events defined in \code{observation.matrix}, with radia and heights
#' given in \code{radia_and_heights}.
#'
#' @param n.cylinders An \code{integer}; the number of cylinders to draw.
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param time.range An \code{integer} vector.
#' @param radia_and_heights A \code{Matrix}.
#' @param postcode2coord A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @importFrom truncnorm rtruncnorm
#' @import Matrix
#' @return A \code(data.frame).
#' @examples
#' cylinders=rcylinder(10, observation.matrix, time.range, radia_and_heights, postcode2coord)
rcylinder<-function(n.cylinders, observation.matrix, time.range, radia_and_heights, postcode2coord, only.last=F){
  if (any(rownames(observation.matrix)=='NA')){
    cat("WARNING: any(rownames(observation.matrix)=='NA'")
  }
  cols = as.character(time.range[1]:time.range[2])
  cases = which(observation.matrix[, cols] > 0, arr.ind = T)
  # cases is of the form:
  #           row col
  # PL15 9NE 5851 231
  # SY11 3PN 6370 255
  if (sum(observation.matrix[, cols]) > 0){
    idx = sample(1:nrow(cases), n.cylinders, replace = T)
    y = postcode2coord[cases[idx, 1], 'y']
    x = postcode2coord[cases[idx, 1], 'x']

    # t = cases[idx,2] + time.range[1] - 1
    # print(head(t))
    t = as.integer(colnames(observation.matrix[,cols])[cases[idx,2]])
    # radia and heights are given as input in the matrix radia_and_heights

    radia_and_heights = radia_and_heights[sample(1:nrow(radia_and_heights), n.cylinders, replace=T),]
    # randomise wilst keeping same radius and height and avoiding negative t
    rho = radia_and_heights[, 2]
    random_radia = runif(n.cylinders, 0, rho)
    theta = runif(n.cylinders, 0, 2* pi)

    y = y + sin(theta) * random_radia
    x = x + cos(theta) * random_radia
    tt = t + runif(n.cylinders, -radia_and_heights[,1]/2, radia_and_heights[,1]/2)

   if (only.last){
      t.upp = as.integer(time.range[2])
    }else{
      t.upp = ceiling(tt + radia_and_heights[,1] / 2)
    }
    t.max = as.integer(time.range[2])

    if (only.last){
      t.low = floor(t.upp - radia_and_heights[,1])
      t.low = ifelse(t < t.low, t, t.low)
    }else{
      t.low = floor(tt - radia_and_heights[,1] / 2)
    }
    t.min = as.integer(time.range[1])

    t.low = ifelse(t.low >= t.min, t.low, t.min)
    t.upp = ifelse(t.upp <= t.max, t.upp, t.max)

    t.low = as.integer(ifelse(t.low == t.max, t.low - 1, t.low))
    # isx = (t.low == t.upp)
    # if (any(isx)){
    #   print(c(t.low[isx], t.upp[isx]))
    # }

    return(data.frame(x=x, y=y, rho=rho, t.low=t.low, t.upp=t.upp))
  }else{
    return(data.frame(x=double(), y=double(), rho=double(), t.low=integer(), t.upp=integer()))
  }
}

#' Compute exceedance probabality in a cylinder.
#'
#' A cylinder is defined by the circle coordinated (say, x,y, and radius) and lower and upper height limits (aay, t.low and t.upp, respectively).
#' For a given cylinder, this function computes the number of observed events (\code{n_cases}) in the cylinder according to
#' \code{observation.matrix}, the expected number \code{mu} of events according the Poisson point model (with intensity
#' defined in \code{baseline.matrix}), and the probability that .
#' The function returns \code{c(n_cases, mu, p.val)}.
#'
#' @param cylinder
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param baseline.matrix A \code{Matrix} object enconding the baseline.
#' @param postcode.locations A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @import Matrix
#' @return A \code{numeric} vector of dimension 3.
#' @examples
#' exceedance=compute(c(x,y,rho,t.low,t.upp), observation.matrix, baseline.matrix, postcode.locations)
compute<-function(cylinder, observation.matrix, baseline.matrix, postcode.locations){
  t.range = as.character(as.integer(cylinder['t.low']):as.integer(cylinder['t.upp']))
  observations = observation.matrix[,t.range]
  baselines = baseline.matrix[,t.range]

  d = sqrt(
    (as.numeric(postcode.locations$x) - as.numeric(cylinder['x']))^2 +
      (as.numeric(postcode.locations$y) - as.numeric(cylinder['y']))^2
  )
  in_circle = (d<as.numeric(cylinder['rho'])) & (!is.na(d))
  n_cases = sum(observations[in_circle, ], na.rm=T)
  # postcodes<-paste(rownames(observations[in_circle, ]), collapse = ",")
  # the sum of Poisson RVs is Poisson
  mu = sum(baselines[in_circle, ])
  #mu = sum(baselines[in_circle, ]) + 1

  #  ci = qpois(c(0.25, 0.95) , lambda=mu)
  p.val = ppois(n_cases-1, lambda=mu, lower.tail=FALSE)
  return (c(n_cases, mu, p.val))
}

#' Compute exceedance probabality in a cylinder.
#'
#' A cylinder is defined by the circle coordinated (say, x,y, and radius) and lower and upper height limits (aay, t.low and t.upp, respectively).
#' For a given cylinder, this function computes the number of observed events (\code{n_cases}) in the cylinder according to
#' \code{observation.matrix}, the expected number \code{mu} of events according the Poisson point model (with intensity
#' defined in \code{tab.baseline}), and the probability that .
#' The function returns \code{c(n_cases, mu, p.val)}.
#'
#' @param cylinder
#' @param observation.matrix A \code{sparseMatrix} object enconding the events.
#' @param tab.baseline An \code{expand.grid} tab enconding the baseline.
#' @param postcode.locations A \code{data.frame} that maps the rows of \code{observation.matrix} to geographical coordinates.
#' @import Matrix
#' @return A \code{numeric} vector of dimension 3.
#' @examples
#' exceedance=compute(c(x,y,rho,t.low,t.upp), observation.matrix, tab.baseline, postcode.locations)
compute.from.tab.baseline<-function(cylinder, observation.matrix, tab.baseline, postcode.locations){
  t.low = as.numeric(cylinder['t.low'])
  t.upp = as.numeric(cylinder['t.upp'])
  x0 = as.numeric(cylinder['x'])
  y0 = as.numeric(cylinder['y'])
  rho = as.numeric(cylinder['rho'])
  t.range = as.character(as.integer(cylinder['t.low']):as.integer(cylinder['t.upp']))
#  cat("t.range",t.range,"\n")

  observations = observation.matrix[,t.range]

  d = sqrt(
    (tab.baseline$x - x0)^2 +
    (tab.baseline$y - y0)^2
  )
  in_circle = (d < rho) & !is.na(d)
  in_height = (tab.baseline$t >= t.low) & (tab.baseline$t <= t.upp)

  mu = sum(tab.baseline[in_circle & in_height,]$z) #* attributes(tab.baseline)$delta2 #multiply by delta2 as this is the bin size

#  in_of_square = sum(in_circle & in_height) * delta2
#  out_of_square = pi * rho* rho - in_of_square
#  correct by taking into account that outsise the square there is nothing.
#  mu = mu * pi * rho *rho / in_of_square

  d = sqrt(
      (as.numeric(postcode.locations$longitude) - x0)^2 +
      (as.numeric(postcode.locations$latitude)  - y0)^2
  )
  in_circle = (d < rho) & (!is.na(d))

  n_cases_in_cylinder = sum(observations[in_circle, ], na.rm = T)

#  ci = qpois(c(0.25,0.95) , lambda=mu)
  p.val = ppois(n_cases_in_cylinder-1, lambda=mu, lower.tail=FALSE)
  return (c(n_cases_in_cylinder, mu, p.val))
}

warning_ratio<-function(i, observation.matrix, cylinders, postcode.locations){
  # check if the location i
  x = as.numeric(postcode.locations[i, 'longitude'])
  y = as.numeric(postcode.locations[i, 'latitude'])

  ## da vettorizzare
  # in_circle = apply(cylinders, 1, function(X){
  #   ifelse(sqrt((as.numeric(X['x']) - x)^2 + (as.numeric(X['y']) - y)^2) < as.numeric(X['rho']), TRUE, FALSE)
  # })

  # vettorizzato
  in_circle = sqrt((as.numeric(cylinders['x']) - x)^2 + (as.numeric(cylinders['y']) - y)^2) < as.numeric(cylinders['rho'])

  times = which(observation.matrix[i,] > 0)

  if (length(times) > 0){
    in_cylinder_height = matrix(FALSE, nrow = nrow(cylinders), ncol=length(times))

    for (i in 1:length(times)){

      #da vettorizzare:
      in_cylinder_height[,i] = apply(cylinders, 1,  function(X){
        TT = as.numeric(names(times[i]))
        (as.numeric(X['t.low']) < TT) & (as.numeric(X['t.upp']) > TT)
      })

      # vettorizzato
      #TT = as.numeric(names(times[i]))
      #in_cylinder_height[,i] = (as.numeric(cylinders['t.low']) < TT) & (as.numeric(cylinders['t.upp']) > TT)

    }

    # number of cylinders that include locations `i`
    in_cylinder = sum(in_circle * in_cylinder_height)
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height)

    return(warning / in_cylinder)
  }else{
    return(NA)
  }
}
#
# warning_ratio2<-function(i, observation.matrix, t, cylinders, postcode.locations){
#   times = which(observation.matrix > 0)
#   if (length(times) > 0){
#     # check if the location is in any circle
#     x = as.numeric(postcode.locations[i,'longitude'])
#     y = as.numeric(postcode.locations[i,'latitude'])
#
#
#     in_circle = apply(cylinders, 1, function(X){
#       ifelse(sqrt((as.numeric(X['x']) - x)^2 + (as.numeric(X['y']) - y)^2) < as.numeric(X['rho']), TRUE, FALSE)
#     })
#     in_cylinder_height = (cylinders['t.low'] < t) & (cylinders['t.upp'] > t)
#     # number of cylinders that include locations
#     in_cylinder = sum(in_circle * in_cylinder_height)
#     # number of cylinder with `warning` flag that include location `i`
#     warning = sum(cylinders$warning * in_circle * in_cylinder_height)
#     if (in_cylinder == 0){
#       return(0)
#     }else{
#       return(warning / in_cylinder)
#     }
#   }else{
#     return(0)
#   }
# }

warning.score<-function(case, cylinders, date.time.field = 'week'){
  x = as.numeric(case['x'])
  y = as.numeric(case['y'])
  TT = as.numeric(case[date.time.field])

  d = sqrt((cylinders$x - x)^2 + (cylinders$y - y)^2)
  in_circle = as.integer(d <= cylinders$rho)
  in_cylinder_height = as.integer((cylinders$t.low <= TT) & (cylinders$t.upp >= TT))

  # number of cylinders that include geo-coordinate of `case`
  in_cylinder = sum(in_circle * in_cylinder_height, na.rm=T)
  if (in_cylinder>0){
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height, na.rm=T)
    re = warning / in_cylinder
  }else{
    re = 0
  }
  return(re)
}

warning.score2 <-function(case, TT, cylinders) {

  x = as.numeric(case['x'])
  y = as.numeric(case['y'])

  d = sqrt((cylinders$x - x)^2 + (cylinders$y - y)^2)
  in_circle = as.integer(d <= cylinders$rho)
  in_cylinder_height = as.integer((cylinders$t.low <= TT) & (cylinders$t.upp >= TT))

  # number of cylinders that include geo-coordinate of `case`
  in_cylinder = sum(in_circle * in_cylinder_height, na.rm=T)
  if (in_cylinder>0){
    # number of cylinder with `warning` flag that include location `i`
    warning = sum(cylinders$warning * in_circle * in_cylinder_height, na.rm=T)
    re = warning / in_cylinder
  }else{
    re = 0
  }
  return(re)
}