################################################################
### Code for replication study:
### "A New Approach to Estimating the Production Function for Housing"
### by Dennis Epple, Brett Gordon, and Holger Sieg, forthcoming AER.
###
### This code is used to estimate the production function.
###
###
################################################################

## ----Load-Libraries------
library(MASS)
library(splines)
## library(odesolve) - This function is no longer maintained by CRAN
library(deSolve)
library(lokern)
source("./Notes/Gradient_Descent_001.R")

## ----read-the-data----
getwd()
# Just pland, v, and lotarea
#data = read.csv("./Data/Pittsburgh_post1995.txt", header=TRUE)
data = read.csv("Pittsburgh_post1995.txt", header=TRUE)
N = dim(data)[1]

v = data$v
pland = data$pland
lotarea = data$lotarea
muni = data$muni
tcog = data$tcog

sorted = sort(v,index.return=TRUE, method="quick")
pland = pland[sorted$ix]
lotarea = lotarea[sorted$ix]
muni = muni[sorted$ix]
tcog = tcog[sorted$ix]
v = sorted$x

v.full = v
pland.full = pland

#Calculate 1 and 99 percentile for v
percentile <- quantile(data$v, probs = c(0.01,0.99))

# The 99 percentile = 144.4683 and 1 percentile = 0.923818
goodv = (((v.full < percentile[2])*(v > percentile[1])) == 1)
v = v.full[goodv]
pland = pland.full[goodv]
lotarea = lotarea[goodv]
muni = muni[goodv]

N = length(v)
logpland = log(pland)
logv = log(v)
v2 = v^2
v3 = v^3
v4 = v^4

v.sd = sqrt(var(v))
logv.sd = sqrt(var(logv))

remove(data)

plot(logv, logpland, main="Value per Unit Land vs. Land Value per Unit Land\nBaltimore City Residential Properties",
     xlab="log(v)", ylab="log(pland)") #,xlim=c(-2,5), ylim=c(-3,3.5))

## ----- Estimate-the-regressions ------

### Basic regressions

lm.loglin = lm(logpland ~ logv)
lm.lin = lm(pland ~ v - 1)
lm.quad = lm(pland ~ v + v2 - 1)
lm.cub = lm(pland ~ v + v2 + v3 - 1)
lm.quart = lm(pland ~ v + v2 + v3 + v4 - 1)
#Linear model using Gaussian Generalized Linear Model
glm.lin = glm(pland ~ v - 1)

#Log Linear model using Gaussian Generalized Linear Model
glm.loglin = glm(logpland ~ logv)

#Log Linear model with a different Gradient Descent Loss Function
#thetaValues = gradientDescentLinearModel(logv, logpland, 0.1, 1000)

## ---Create-Coefficient-Table

# table<- data.frame(matrix(ncol=7,nrow = 6))
# namesOfColumn <- c("Coefficients","Log_Linear","Linear","Quadratic","Cubic",
#                    "Gaussian_Generalized_Linear_Model",
#                    "Gaussian_Generalized_Log_Linear_Model",
#                    "Gradient_Descent_Log_Linear_Model")
# colnames(table) <- namesOfColumn
# table$Coefficients <- c("v", "v^2", "v^3", "constant", "log(v)", "N")
# table[4,2] <- round(lm.loglin$coefficients[1],2)
# table[5,2] <- round(lm.loglin$coefficients[2],2)
# table[1,3] <- round(lm.lin$coefficients[1],2)
# table[1,4] <- round(lm.quad$coefficients[1],2)
# table[2,4] <- round(lm.quad$coefficients[2],5)
# table[1,5] <- round(lm.cub$coefficients[1],2)
# table[2,5] <- round(lm.cub$coefficients[2],5)
# table[3,5] <- round(lm.cub$coefficients[3],2)
# table[1,6] <- round(glm.lin$coefficients[1],2)
# table[4,7] <- round(glm.loglin$coefficients[1],2)
# table[5,7] <- round(glm.loglin$coefficients[2],2)
# #table[4,8] <- round(thetaValues[1],2)
# #table[5,8] <- round(thetaValues[2],2)
# table[6,2:7] <- as.numeric(N)
# View(table)

stargazer(lm.loglin, lm.lin, lm.quad, lm.cub, glm.lin, glm.loglin, summary=FALSE, out = "file.out", type = "text")
?stargazer
# colnames(table) = gsub("_", " ", colnames(table))
# table[is.na(table)]<- " "

# table %>%
#   stargazer(type ='text', summary = FALSE,
#             digits =2,
#             title = "Table 1 - Descriptive statistics of Residential data")

### Non-parametric estimation of r(v)

gkern.deriv = glkerns(v, pland, deriv=1,n.out=300, hetero=TRUE,bandwidth=v.sd*1.1)
gkern = glkerns(v, pland, deriv=0,n.out=500, hetero=TRUE,bandwidth=v.sd*1.1)
gkern.interp = interpSpline(gkern$x.out,gkern$est,na.action=na.omit,bSpline=TRUE)

gkern.log = glkerns(logv, logpland, deriv=0,n.out=300, hetero=TRUE)
gkern.log.interp = interpSpline(gkern.log$x.out,gkern.log$est,na.action=na.omit,bSpline=TRUE)
gkern.log.fitted = predict(gkern.log.interp, logv) ## ??

par(mfrow=c(1,2))
plot(gkern.deriv$x.out,gkern.deriv$est, type="l")
plot(gkern.log$x.out,gkern.log$est, type="l", col="red")
plot(gkern$x.out,gkern$est, type="l")  ## ??

### Plot the regressions
par(mfrow=c(1,2))
plot(logv, lm.loglin$fitted.values, type="l",xlim=c(-2,5), ylim=c(-3,3.5))
lines(logv, lm.loglin$fitted.values, col="red")
lines(logv, log(lm.lin$fitted.values), col="blue")
lines(logv, log(lm.quad$fitted.values), col="green")
lines(logv, log(lm.cub$fitted.values), col="orange")

#Plot to add line generated by Gaussian Generalized Linear Model
lines(logv, glm.loglin$fitted.values, col = '#009E73')

#Plot to add line using Log linear model with Gradient Descent Loss Function
#abline(coef=thetaValues, col = '#F0E442')

#Calculate the predicted values from using Log linear model with Gradient Descent Loss Function
#predictedValuesGD <- calculatePredictionValues(logv, logpland, thetaValues[2], thetaValues[1])

#Added two new model prediction
#1) Gaussian Generalized Log Linear Model: Gaus.LLM
#2) Gradient Descent Log Linear Model: GradDes.LLM

regs = data.frame("Log-Linear"=lm.loglin$fitted.values, "Linear"=log(lm.lin$fitted.values),"Quadratic"=log(lm.quad$fitted.values),
                  "Cubic"=log(lm.cub$fitted.values), "Log Kernel"=gkern.log.fitted$y, 'Gaus.LLM'=glm.loglin$fitted.values)

regs_table2 = data.frame("Log-Linear" = summary(lm.loglin)$coeff)

matplot(cbind(logv,logv,logv,logv,logv,logv), regs, col=1:ncol(regs), lty=1:ncol(regs),lwd=c(2,2,2,2), type="l",
        main="Fitted Regressions for r(v)", xlab="v", ylab="p_l", xlim=c(-0.5,5), ylim=c(-2.2,3.5))
legend(3.9, 0.5, names(regs), col=1:ncol(regs), lty=1:ncol(regs), cex = 0.5 )

## -----Derive-supply-functions-for-each-model-----

vseq.n = 1000
vseq = seq(1,100,length.out=vseq.n)

### Calculate supply functions for quad and cubic cases
r = lm.quad$coefficients
p.quad = (vseq^r[1])*exp(2*r[2]*(vseq-1))
s.quad = vseq/p.quad

r = lm.cub$coefficients
c = 2*r[2] + 1.5*r[3]
p.cub = (vseq^r[1])*exp(2*r[2]*(vseq-1) + 1.5*r[3]*(vseq^2 - 1))
s.cub = vseq/p.cub

# Now create price grid given this upperbound
lb = min(range(p.quad)[1],range(p.cub)[1])
ub = min(range(p.quad)[2],range(p.cub)[2])
pgrid = seq(lb,ub,length.out=vseq.n)

### Calculate supply functions for linear and log-linear cases

alpha = as.numeric(exp(lm.loglin$coefficients[1])*lm.loglin$coefficients[2])
beta = as.numeric(lm.loglin$coefficients[2] - 1)

### Calculate supply function for GLM Log-linear case

alpha_glm = as.numeric(exp(glm.loglin$coefficients[1])*glm.loglin$coefficients[2])
beta_glm = as.numeric(glm.loglin$coefficients[2] - 1)

# Determine upper bound on p, since beta < 0 implies (c+log(p)) < 0
### For log-linear model
ec = exp(-alpha/beta)

### FOr GLM Log-linear model
ec_glm = exp(-alpha_glm/beta_glm)

### Linear case
k = lm.lin$coefficients[1]
s.lin = pgrid^((1-k)/k)

### Log-linear case
s.loglin = (1/pgrid)*((1 + (beta/alpha)*log(pgrid))^(1/beta))

### GLM Log-Linear case
sglm.loglin = (1/pgrid)*((1 + (beta_glm/alpha_glm)*log(pgrid))^(1/beta_glm))

### Solve ODE for kernel supply function

rprime = interpSpline(gkern.deriv$x.out,gkern.deriv$est,na.action=na.omit,bSpline=TRUE)

## calc.supply.deriv = function(t,y, params) list((y/t)*((1/(predict(rprime,y*t))$y)-1))
calc.supply.deriv = function(pgrid.kern,xstart, params) list((xstart/pgrid.kern)*((1/(predict(rprime,xstart*pgrid.kern))$x)-1))
##dd = function(pgrid.kern,xstart, params)  ## ??

## list((xstart/pgrid.kern)*((1/(predict(rprime,xstart*pgrid.kern))$x)-1)) ## ??

xstart = c(1)
pgrid.kern = c(1, seq(1.001,ub,length.out=vseq.n-1))

ode.out = lsoda(xstart, pgrid.kern, calc.supply.deriv, parms=1, rtol=1e-5, atol=1e-7)
s.kern = data.frame(s=ode.out[,2],p=ode.out[,1])

### Plot all the supply functions

s.funcs = data.frame("Log-Linear"=s.loglin,"Linear"=s.lin,"Quadratic"=s.quad,
                     "Cubic"=s.cub, "Kernel"=s.kern$s, "GLM Log-Linear" = sglm.loglin)
p.grids = cbind(pgrid,pgrid,p.quad,p.cub,s.kern$p,pgrid)

s.lin.range = range(s.lin*pgrid)
s.loglin.range = range(s.loglin*pgrid)
s.quad.range = range(s.quad*p.quad)
s.cub.range = range(s.cub*p.cub)
s.kern.range = range(s.kern$s*s.kern$p)
sglm.loglin.range = range(sglm.loglin*pgrid)

matplot(s.funcs,p.grids,col=1:ncol(s.funcs), lty=1:ncol(s.funcs),lwd=c(2,2,2,2), type="l",
        main="Supply Functions", xlab="Supply", ylab="Price",xlim=c(0,39))
legend(20, 1.5, names(s.funcs), col=1:ncol(s.funcs), lty=1:ncol(s.funcs))

## ----Production-Function-Estimation------

v.lin.hat = s.lin*pgrid
v.loglin.hat = s.loglin*pgrid
v.quad.hat = s.quad*p.quad
v.cub.hat = s.cub*p.cub
v.kernel = s.kern$p*s.kern$s
v.glmloglin.hat = sglm.loglin*pgrid

lm.lin.fitted = lm.lin$coefficients[1]*v.lin.hat
lm.loglin.fitted = exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v.loglin.hat))
lm.quad.fitted = lm.quad$coefficients[1]*v.quad.hat + lm.quad$coefficients[2]*v.quad.hat^2
lm.cub.fitted = lm.cub$coefficients[1]*v.cub.hat + lm.cub$coefficients[2]*v.cub.hat^2 + lm.cub$coefficients[3]*v.cub.hat^3
kernel.fitted = predict(gkern.interp,v.kernel)$y
glm.loglin.fitted = exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v.glmloglin.hat))

m.lin = v.lin.hat-lm.lin.fitted
m.loglin = v.loglin.hat-lm.loglin.fitted
m.quad = v.quad.hat-lm.quad.fitted
m.cub = v.cub.hat-lm.cub.fitted
m.kernel = v.kernel - kernel.fitted
m.glmloglin = v.glmloglin.hat-glm.loglin.fitted

##Normalize the production function for the kernel case
m.kernel = m.kernel + (1-m.kernel[1])

prod.funcs = data.frame("Log-Linear"=s.loglin,"Linear"=s.lin,"Quadratic"=s.quad, "Cubic"=s.cub, "Kernel"=s.kern$s)

m.grids = cbind(m.loglin, m.lin, m.quad, m.cub,m.kernel)

matplot(m.grids,prod.funcs, col=1:ncol(prod.funcs), lty=1:ncol(prod.funcs),lwd=c(2,2,2,2), type="l",
        main="Production Functions", xlab="m = (M/L)", ylab="Output", xlim=c(0,80), ylim=c(0,42))
legend(60, 12, names(prod.funcs), col=1:ncol(prod.funcs), lty=1:ncol(prod.funcs))

## ----Calculate-supply-elasticities----

## Missing definition of 'calc.elas' and 'fdiff' function. Added the defintion of 'calc.elas' and 'fdiff'

fdiff <- function(x, fun, h=NULL, order=1, accur=4, ...) {
  macheps <- .Machine$double.eps

  if (order==1) {
    if(is.null(h)) h <- macheps^(1/3)* abs(x)
    ifelse (accur==2, w <- c(-1/2,1/2), w <- c(1/12,-2/3, 2/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,1), xd <- x + h*c(-2,-1,1,2))
    return(sum(w*fun(xd,...))/h)
  }
  else if (order==2) {
    if(is.null(h)) h <- macheps^(1/4)* abs(x)
    ifelse (accur==2, w <- c(1,-2,1), w <- c(-1/12,4/3,-5/2,4/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,0,1), xd <- x + h*c(-2,-1,0,1,2))
    return(sum(w*fun(xd,...))/h^2)
  }
}
calc.elas = function(grid,sfunc,bspline=TRUE){
  require(splines)
  s.interp = interpSpline(grid,sfunc,na.action=na.omit,bSpline=bspline)
  s.elas = rep(NA,length(grid))
  for(i in 1:length(grid)){
    s.elas[i] = (fdiff(grid[i],function(x){(predict(s.interp,x))$y}))*(grid[i]/sfunc[i])
  }
  return(s.elas)
}

## Usual Code
require(splines)
s.loglin.elas = calc.elas(pgrid,s.loglin)
s.lin.elas = calc.elas(pgrid,s.lin)
s.quad.elas = calc.elas(pgrid,s.quad)
s.cub.elas = calc.elas(pgrid,s.cub)
s.kern.elas = calc.elas(s.kern$p,s.kern$s)
sglm.loglin.elas = calc.elas(pgrid,sglm.loglin)

s.elas = list("Linear"=s.lin.elas, "Log-linear"=s.loglin.elas, "Quad"=s.quad.elas,
              "Cubic"=s.cub.elas, "Kernel"=s.kern.elas, "GLM-Log-Linear" = sglm.loglin.elas)
sapply(s.elas,mean)
sapply(s.elas,range)
sapply(s.elas,sd)

### Calculate demand elasticities

p.inv = function(v,s.interp){
  pstar = rep(NA,length(v))
  s.inv = function(p,v,sfunc){ ((predict(sfunc,p))$y*p - v) }
  for(i in 1:length(v)){
    pstar[i] = (uniroot(s.inv,c(0.0001,100),v=v[i],sfunc=s.interp))$root
  }
  return(pstar)
}

s.lin.interp = interpSpline(pgrid,s.lin,na.action=na.omit,bSpline=TRUE)
s.loglin.interp = interpSpline(pgrid,s.loglin,na.action=na.omit,bSpline=TRUE)
s.quad.interp = interpSpline(p.quad,s.quad,na.action=na.omit,bSpline=TRUE)
s.cub.interp = interpSpline(p.cub,s.cub,na.action=na.omit,bSpline=TRUE)
s.kern.interp = interpSpline(s.kern$p,s.kern$s,na.action=na.omit,bSpline=TRUE)
sglm.loglin.interp = interpSpline(pgrid,sglm.loglin,na.action=na.omit,bSpline=TRUE)

p.lin.inv = p.inv(v,s.lin.interp)
p.loglin.inv = p.inv(v,s.loglin.interp)
p.quad.inv = p.inv(v,s.quad.interp)
p.cub.inv = p.inv(v,s.cub.interp)
p.kern.inv = p.inv(v,s.kern.interp)
p.glmloglin.inv = p.inv(v,sglm.loglin.interp)

elas.lin = calc.average.elas(p.lin.inv,s.lin.interp)
elas.loglin = calc.average.elas(p.loglin.inv,s.loglin.interp)
elas.quad = calc.average.elas(p.quad.inv,s.quad.interp)
elas.cub = calc.average.elas(p.cub.inv,s.cub.interp)
elas.kern = calc.average.elas(p.kern.inv,s.kern.interp)
elas.glmloglin = calc.average.elas(p.glmloglin.inv,sglm.loglin.interp)

p.loglin.inv.median = p.inv(median(v),s.loglin.interp)
elas.loglin.median = calc.average.elas(p.loglin.inv.median,s.loglin.interp)

p.glmloglin.inv.median = p.inv(median(v),sglm.loglin.interp)
elas.glmloglin.median = calc.average.elas(p.glmloglin.inv.median,sglm.loglin.interp)

## ----Calculate-the-elasticity-of-substitution-for-land-vs-non-land-inputs-----

n = 50
L = lotarea
m = v - exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v))
M = m*L
Lseq = seq(min(L),max(L),length.out=n)
Mseq = seq(min(M),max(M),length.out=n)

n = 50
L = lotarea
m_glm = v - exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v))
M_glm = m_glm*L
Lseq_glm = seq(min(L),max(L),length.out=n)
Mseq_glm = seq(min(M_glm),max(M_glm),length.out=n)

## ----Decclare-Functions----

pfunc.CD = function(k,Lseq,Mseq){
  Q = matrix(NA,nrow=length(Lseq),ncol=length(Mseq))
  A = 1/((1-k)^(1-k))
  for(i in 1:(length(Lseq))){ for(k in 1:(length(Mseq))){
    Q[i,k] = A*(Lseq[i]^k)*(Mseq[k]^(1-k))
  }}
  return(Q)
}

Q.CD = pfunc.CD(lm.lin$coefficients[1],Lseq,Mseq)
persp(Lseq,Mseq,Q.CD,theta=-20,phi=45,xlim=c(500000,1200000),ylim=c(20000,300000))

pfunc.full = function(Lseq,Mseq,prod.interp){
  Q = matrix(NA,nrow=length(Lseq),ncol=length(Mseq))
  for(i in 1:(length(Lseq))){
    Q[i,] = pfunc.full2(Lseq[i],Mseq,prod.interp)
  }
  return(Q)
}

pfunc.full2 = function(lval,mval,prod.interp){
  return(lval*(predict(prod.interp,mval/lval)$y))
}

pfunc.full.L = function(lval, mval,prod.interp, ord = 1){
  temp = function(x,mval){ return(pfunc.full2(x,mval,prod.interp))}
  return(fdiff(lval, temp, h=NULL, order=ord, accur=4, mval))
}

pfunc.full.M = function(mval,lval,prod.interp, ord = 1){
  temp = function(x,lval){ return( pfunc.full2(lval,x,prod.interp))}
  return(fdiff(mval, temp, h=NULL, order=ord, accur=4, lval))
}

pfunc.full.LM = function(Lval, Mval, prod.interp){
  h = (.Machine$double.eps)^(1/3)*abs(min(Lval,Mval))

  f.xy = pfunc.full2(Lval+h, Mval+h, prod.interp)
  f.x_y = pfunc.full2(Lval+h, Mval-h, prod.interp)
  f._xy = pfunc.full2(Lval-h, Mval+h, prod.interp)
  f._x_y = pfunc.full2(Lval-h, Mval-h, prod.interp)

  return(((f.xy-f.x_y)-(f._xy-f._x_y))/(4*h^2))
}

calc.elas.sub = function(Lseq, Mseq, prod.interp){
  n.L = length(Lseq)
  n.M = length(Mseq)
  Q.elas.sub = matrix(NA,nrow=n.L, ncol=n.M)
  for(i in 1:n.L){
    for(k in 1:n.M){
      F.L = pfunc.full.L(Lseq[i],Mseq[k],prod.interp, ord=1)
      F.M = pfunc.full.M(Mseq[k],Lseq[i],prod.interp, ord=1)
      F.LL = pfunc.full.L(Lseq[i],Mseq[k],prod.interp, ord=2)
      F.MM = pfunc.full.M(Mseq[k],Lseq[i],prod.interp, ord=2)
      F.LM = pfunc.full.LM(Lseq[i],Mseq[k],prod.interp)

      numer = F.L*F.M*(F.L*Lseq[i] + F.M*Mseq[k])
      denom = Lseq[i]*Mseq[k]*((2*F.L*F.M*F.LM)  - ((F.L^2)*F.MM) - ((F.M^2)*F.LL))

      Q.elas.sub[i,k] = numer/denom
    }
  }
  return(Q.elas.sub)
}

# A function to compute highly accurate first- and second-order derivatives
# From Fornberg and Sloan (Acta Numerica, 1994, p. 203-267; Table 1, page 213)
fdiff <- function(x, fun, h=NULL, order=1, accur=4, ...) {
  macheps <- .Machine$double.eps

  if (order==1) {
    if(is.null(h)) h <- macheps^(1/3)* abs(x)
    ifelse (accur==2, w <- c(-1/2,1/2), w <- c(1/12,-2/3, 2/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,1), xd <- x + h*c(-2,-1,1,2))
    return(sum(w*fun(xd,...))/h)
  }
  else if (order==2) {
    if(is.null(h)) h <- macheps^(1/4)* abs(x)
    ifelse (accur==2, w <- c(1,-2,1), w <- c(-1/12,4/3,-5/2,4/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,0,1), xd <- x + h*c(-2,-1,0,1,2))
    return(sum(w*fun(xd,...))/h^2)
  }
}

# y is a data frame, x is a matrix
plot.with.legend = function(x,y,col=1:ncol(x),lty=1:ncol(x),xlim=NULL,ylim=NULL,
                            titles=names(y),lposx=(max(x)-max(x)/4),lposy=max(y)/3,main="",xl="",yl="",...){
  matplot(x,as.matrix(y),col=col, lty=lty,lwd=c(2,2,2,2), type="l",
          main=main,xlab=xl,ylab=yl,xlim=xlim,ylim=ylim, ...)
  legend(lposx,lposy, titles, col=col, lty=lty)
}

### Calculate the derivative of a function over a given range of values
calc.deriv = function(grid,fun,interp.obj=NULL,high.density=FALSE){
  require(splines)
  fun.interp = NULL
  if(! is.null(interp.obj)){
    fun.interp = interp.obj
  }
  else if(!high.density && length(grid)>200){
    interp.grid = rep(NA,200)
    interp.grid[1] = grid[1]
    interp.grid[200] = grid[200]
    interp.grid = sample(grid,198)
    fun.grid = fun[interp.grid]
    fun.interp = interpSpline(interp.grid,fun.grid,na.action=na.omit,bSpline=FALSE)
  }
  else{
    fun.interp = interpSpline(grid,fun,na.action=na.omit,bSpline=FALSE)
  }
  d = rep(NA,length(grid))
  for(i in 1:length(grid)){
    d[i] = fdiff(grid[i],function(x){(predict(fun.interp,x))$y})
  }
  return(list(x=grid,d=d))
}

calc.elas = function(grid,sfunc,bspline=TRUE){
  require(splines)
  s.interp = interpSpline(grid,sfunc,na.action=na.omit,bSpline=bspline)
  s.elas = rep(NA,length(grid))
  for(i in 1:length(grid)){
    s.elas[i] = (fdiff(grid[i],function(x){(predict(s.interp,x))$y}))*(grid[i]/sfunc[i])
  }
  return(s.elas)
}

### pa - actual set of prices corresponding to the data
### s - supply function
calc.average.elas = function(pa,s.interp,bspline=TRUE){
  require(splines)
  s.pred = predict(s.interp,pa)
  s.elas = rep(NA,length(pa))
  for(i in 1:length(pa)){
    s.elas[i] = (fdiff(pa[i],function(x){(predict(s.interp,x))$y}))*(pa[i]/s.pred$y[i])
  }
  return(s.elas)
}
## ----Simulate-supply-and-production-functions-to-calcalate-standard-errors-----
require(splines)
prod.lin.interp = interpSpline(m.lin,s.lin,na.action=na.omit,bSpline=TRUE)
prod.loglin.interp = interpSpline(m.loglin,s.loglin,na.action=na.omit,bSpline=TRUE)
prod.quad.interp = interpSpline(m.quad,s.quad,na.action=na.omit,bSpline=TRUE)
prod.cub.interp = interpSpline(m.cub,s.cub,na.action=na.omit,bSpline=TRUE)
prod.glmloglin.interp = interpSpline(m.glmloglin,sglm.loglin,na.action=na.omit,bSpline=TRUE)

require(R.basic)

Q = pfunc.full(Lseq, Mseq,prod.loglin.interp)
Q.vec = as.vector(Q)
L.vec = as.vector(rep(Lseq,n))
M.vec = rep(NA, length(Q.vec))
for(i in 1:n){ for(k in 1:n){
  M.vec[(i-1)*n + k] = Mseq[i]
}}
plot3d(L.vec,M.vec,Q.vec)

Q_glm = pfunc.full(Lseq_glm, Mseq_glm,prod.glmloglin.interp)
Q.vec.glm = as.vector(Q_glm)
L.vec.glm = as.vector(rep(Lseq_glm,n))
M.vec.glm = rep(NA, length(Q.vec.glm))
for(i in 1:n){ for(k in 1:n){
  M.vec.glm[(i-1)*n + k] = Mseq_glm[i]
}}
plot3d(L.vec.glm,M.vec.glm,Q.vec.glm)

Q.elas.loglin = calc.elas.sub(Lseq, Mseq, prod.loglin.interp)
Q.elas.lin = calc.elas.sub(Lseq, Mseq, prod.lin.interp)
Q.elas.quad = calc.elas.sub(Lseq, Mseq, prod.quad.interp)
Q.elas.cub = calc.elas.sub(Lseq, Mseq, prod.cub.interp)
Q.elas.glmloglin = calc.elas.sub(Lseq_glm, Mseq_glm, prod.glmloglin.interp)

sup.loglin = function(grid,parms){
  alpha = as.numeric(exp(parms[1])*parms[2])
  beta = as.numeric(parms[2] - 1)
  return((1/grid)*((1 + (beta/alpha)*log(grid))^(1/beta)))
}

sup.glmloglin = function(grid,parms){
  alpha = as.numeric(exp(parms[1])*parms[2])
  beta = as.numeric(parms[2] - 1)
  return((1/grid)*((1 + (beta/alpha)*log(grid))^(1/beta)))
}

prod.loglin = function(q,s){
  v.hat = s.loglin*pgrid
  lm.loglin.fitted = exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v.hat))
  m.loglin = v.hat-lm.loglin.fitted
  return(list(m=m.loglin,q=s))
}

prod.glmloglin = function(q,s){
  v.hat = sglm.loglin*pgrid
  glm.loglin.fitted = exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v.hat))
  m.loglin = v.hat-glm.loglin.fitted
  return(list(m=m.loglin,q=s))
}

sim.sup.prod = function(mod,grid,sfunc,pfunc,nsim){
  r = mod$coefficients[,"Estimate"]
  sd = mod$coefficients[,"Std. Error"]
  r.sim = matrix(NA,nrow=nsim,ncol=length(r))
  for(i in 1:length(r)){
    r.sim[,i] = rnorm(nsim,mean=r[i],sd=sd[i])
  }

  s.sd = rep(NA,length(grid))
  s.mat = matrix(NA,nrow=length(grid),ncol=nsim)
  for(k in 1:length(grid)){
    for(i in 1:nsim){
      s.mat[k,i] = sfunc(grid[k],r.sim[i,])
    }
    s.sd[k] = sd(s.mat[k,])
  }

  p.sd = rep(NA,length(grid))
  p.mat = matrix(NA,nrow=length(grid),ncol=nsim)
  for(i in 1:nsim){
    ## Calculate the prod function for this supply function
    pfunc.temp = pfunc(grid,s.mat[,i])
    p.mat[,i] = pfunc.temp$q
  }
  for(k in 1:length(grid)) p.sd[k] = sd(p.mat[k,])

  return(list(s.sd=s.sd,p.sd=p.sd))
}

sim.funcs = sim.sup.prod(summary(lm.loglin),pgrid,sup.loglin,prod.loglin,100)

s.loglin.ub = s.loglin + 2*sim.funcs$s.sd
s.loglin.lb = s.loglin - 2*sim.funcs$s.sd
prod.loglin.lb = s.loglin - 2*sim.funcs$p.sd
prod.loglin.ub = s.loglin + 2*sim.funcs$p.sd

# Supply and production plots
plot(s.loglin,pgrid,type="l",main="Loglin Supply Function with \n 95% Confidence Band",xlab="Supply",ylab="Price", xlim=c(0,40))
lines(s.loglin.lb,pgrid,col="red",lty=2)
lines(s.loglin.ub,pgrid,col="red",lty=2)

plot(m.loglin,s.loglin, type="l",main="Loglin Production Function with \n 95% Confidence Band",xlab="m",ylab="q", xlim=c(0,80))
lines(m.loglin, prod.loglin.ub, col="red",lty=2)
lines(m.loglin, prod.loglin.lb, col="red",lty=2)

# Supply and production plots in log-log scale
plot(log(s.loglin),log(pgrid),type="l",main="Log-linear Supply Function with \n 95% Confidence Band",
     xlab="log(Supply)",ylab="log(Price)", xlim=c(0,log(40)), lwd=2)
lines(log(s.loglin.lb),log(pgrid),col="black",lty=2)
lines(log(s.loglin.ub),log(pgrid),col="black",lty=2)

plot(log(m.loglin),log(s.loglin), type="l",main="Log-linear Production Function with \n 95% Confidence Band",
     xlab="log(m)",ylab="log(q)", xlim=c(0,log(80)), lwd=2)
lines(log(m.loglin), log(prod.loglin.ub), col="black",lty=2)
lines(log(m.loglin), log(prod.loglin.lb), col="black",lty=2)

# Supply and production plots in GLM log-log scale
sim.glmfuncs = sim.sup.prod(summary(glm.loglin),pgrid,sup.glmloglin,prod.glmloglin,100)

s.glmloglin.ub = sglm.loglin + 2*sim.glmfuncs$s.sd
s.glmloglin.lb = sglm.loglin - 2*sim.glmfuncs$s.sd
prod.glmloglin.lb = sglm.loglin - 2*sim.glmfuncs$p.sd
prod.glmloglin.ub = sglm.loglin + 2*sim.glmfuncs$p.sd

# Supply and production plots
plot(sglm.loglin,pgrid,type="l",main="GLM-Loglin Supply Function with \n 95% Confidence Band",xlab="Supply",ylab="Price", xlim=c(0,40))
lines(s.glmloglin.lb,pgrid,col="red",lty=2)
lines(s.glmloglin.ub,pgrid,col="red",lty=2)

plot(m.glmloglin,sglm.loglin, type="l",main="GLM-Loglin Production Function with \n 95% Confidence Band",xlab="m",ylab="q", xlim=c(0,80))
lines(m.glmloglin, prod.glmloglin.ub, col="red",lty=2)
lines(m.glmloglin, prod.glmloglin.lb, col="red",lty=2)

# Supply and production plots in log-log scale
plot(log(sglm.loglin),log(pgrid),type="l",main="GLM-Log-linear Supply Function with \n 95% Confidence Band",
     xlab="log(Supply)",ylab="log(Price)", xlim=c(0,log(40)), lwd=2)
lines(log(s.glmloglin.lb),log(pgrid),col="black",lty=2)
lines(log(s.glmloglin.ub),log(pgrid),col="black",lty=2)

plot(log(m.glmloglin),log(sglm.loglin), type="l",main="GLM-Log-linear Production Function with \n 95% Confidence Band",
     xlab="log(m)",ylab="log(q)", xlim=c(0,log(80)), lwd=2)
lines(log(m.glmloglin), log(prod.glmloglin.ub), col="black",lty=2)
lines(log(m.glmloglin), log(prod.glmloglin.lb), col="black",lty=2)

###########################################


#Copyright (c) 2016 Riccardo Francescato
#insert a vector for eache experiment repetition
RawData0 = c(130,34,20,
			150,136,25,
			138,174,96)
RawData1 = c(155,40,70,
			188,122,70,
			110,120,104)
RawData2 = c(74,80,82,
			159,106,58,
			168,150,82)
RawData3 = c(180,75,58,
			126,115,45,
			160,139,60)

RawData = c(RawData0,RawData1,RawData2,RawData3)

a = 3 # numer of treatments A (columns)
b = 3 # numer of treatments B (rows)
n = 4 # numer of repetitions
N = a*b*n
alpha = .05
SRawData = RawData0+RawData1+RawData2+RawData3
SRawMatrix = matrix(SRawData,ncol=a,byrow = TRUE)
RawMatrix = matrix(RawData,ncol=a,byrow = TRUE)

# ANOVA
sum(SRawMatrix[1,])

SSt <- sum(RawData^2) - sum(RawData)^2/N
SSa = 0
for (i in 1:b){
	SSa=SSa+sum(SRawMatrix[i,])^2
}
SSa=(1/(b*n))*SSa-sum(RawData)^2/N

SSb = 0
for (i in 1:a){
	SSb=SSb+sum(SRawMatrix[,i])^2
}
SSb=(1/(a*n))*SSb-sum(RawData)^2/N

SSab = (1/n)*sum(SRawMatrix^2) - sum(RawData)^2/N - SSa - SSb

SSe = SSt - SSab - SSa - SSb

MSa	= SSa/(a-1)
MSb = SSb/(b-1)
MSab = SSab/((a-1)*(b-1))
MSe = SSe/(a*b*(n-1))
F0a = MSa/MSe
F0b = MSb/MSe
F0ab = MSab/MSe
Fa = qf(alpha,df1=(a-1),df2=(a*b*(n-1)),lower.tail=F)
Fb = qf(alpha,df1=(b-1),df2=(a*b*(n-1)),lower.tail=F)
Fab = qf(alpha,df1=((a-1)*(b-1)),df2=(a*b*(n-1)),lower.tail=F)
cat(paste0(" Treatment A  SS: ",SSa," Df: ", a-1 ," MS: ",MSa, " F0a: ",F0a," Fa crit: ",Fa,
		"\n Treatment B  SS: ",SSb," Df: ", b-1 ," MS: ",MSb," F0b: ",F0b," Fb crit: ",Fb,
		"\n Interaction AB  SS: ",SSab," Df: ", (a-1)*(b-1) ," MS: ",MSab," F0ab: ",F0ab," Fab crit: ",Fab,
		"\n Error   SS: ",SSe," Df: ",a*b*(n-1) ," MS: ",MSe,
		"\n Total  SS: ",SSt," Df: ", (a*b*n)-1,
		"\n Fcrit: ", Fa))


# Programming in `R`
# Thanks to Sina Rasooli!

# How to run script?!

## Sum
3 + 4

## Subtract
2 - 5

## Multiply
1.2 * 6.8

## Divide
(123 + 321) / 2

## Exponentiation
3^5

## Modulo
37%%9

## Assign Variable
x <- 42
z <- "salam"
y = 32
23 -> x

## Print
x
y

## Arithmatic with Variables
x + y
x - y
x * y
x^y
x / y
x %% y

## Arithmatic and Assignment
z = x + y
z

## Variable Types
### Numerics
x = 1.2
x = 3
### Logical
y = FALSE # `F` or `FALSE`
y = T # `T` or `TRUE`
### Character
z = "salam"

## Determine Class
class(x)
class(y)
class(z)

## R Help
?mean
help(lm)
??mean
example("median")

## Vectors
x = vector()
x
x = c(1, 2, 3)
x
y = c("a","b","c")
y
z = c(T,F,F)
z

## Vectors: What if Mixed?
x = c(3,T)
x
class(x)
typeof(x)
x = c(4,"a")
x
x = c(5, F, "b")
x

## Attributes: name
x_sleep = c(6.5, 7.5, 7, 8, 6)
x_names = c("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday")
names(x_sleep) = x_names
x_sleep
x_sleep["Monday"] = 2
x_sleep["Shanbe"] = 4
x_sleep
x_sleep[1]

## Vector Summation
x = c(1,2,3)
y = c(4,5,6)
x+y

## Vector Simple Functions
x = c(1.2,3.4,5.6)
sum(x)
mean(x)
median(x)
sd(x)

## Vector: Indexing
x_sleep = c(6.5, 7.5, 7, 8, 6)
x_names = c("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday")
x_sleep[2]
x_sleep[-2]
names(x_sleep) = x_names
x_sleep["Tuesday"]

## Vector Slicing
x = 1:10
x
x_sleep[c(2,3,4)]
x_sleep["Sunday":"Tuesday"]
y = c(4,3,1)
x_sleep[y]
x_sleep[c("Sunday","Tuesday")]
x_sleep[c(T,T,T,F,T)]
x_sleep
x_sleep[-c(1,2)]

## Vector Selection
?sleep
sleep
x = sleep$extra
x
sleep$ID
x_selection = x > 1.1
x_selection
y = x[ x_selection ]
y

## Matrices
matrix( data = 1:10, byrow = T, nrow = 5 )

## Matrics: from Vectors
x = c( 460.998, 314.4 )
y = c( 290.475, 247.9 )
z = c( 309.306, 165.8 )
w = c( x, y, z )
m = matrix( data = w, byrow = T, nrow = 3 )

## Matrics: Attributes
m
colnames(m) = c("A","B")
rownames(m) = c("gozashte", "haal","aayande")

## Matrices: Slicing
m[2,]
m["haal",]
m["gozashte",1]
m[c("aayande","gozashte"),"A"]

## Matrices: simple Functions
rowSums(m)
colSums(m)
colMeans(m)
rowMeans(m)

## Matrices: rbind, cbind
cbind( m, rowSums(m) )
rbind( m, colSums(m) )

## Matrices: scalar arithmatics
m + 1000
m - 1000
m * 2
m / 5
m %% 3

## Matrices: multiply by vector
m * c(10,100,1000)
m * c(1, 0)

## Matrices: Matrix Multiplications
m %*% c(1,0)
c(1,0,0) %*% m
t(m) %*% m
m %*% t(m)

## Factors
x = c("m","f","f","m","m")
x = factor(x)
x
class(x)
## Factors: Ordered
x = c("a","a","c","b","c","a")
y = factor( x, ordered = T, levels = c("c","b","a") )
x = c(1,2,3,2,3)
x
x = factor(x)
x

## Factors: Levels
levels(y) = c("A","B","C")
y

## Factors: summary
summary(x)
summary(y)

## Factors: comparison
y[3] > y[1]

## DataFrames: example
class(mtcars)
typeof(mtcars)
help("mtcars")

## DataFrames: head
?mtcars
View(mtcars)
head(mtcars)
tail(mtcars)
dim(mtcars)
nrow(mtcars)
ncol(mtcars)

## DataFrames: str
str(mtcars)

## DataFrames: summary
summary(mtcars)

## DataFrames: constructor
names = c("Yashar","Sina","Hoda","Maryam")
ages = c(22,24,22,21)
row_ids = c(1,1,2,2)
class_df = data.frame(names, ages, row_ids)
class_df

## DataFrames: slicing
class_df[1,1]
class_df[2,]
class_df[,3]
class_df[1:2,2:3]
class_df[,1]
class_df$names
class_df[,"row_ids"]
class_df$ages < 23
class_df[class_df$ages < 23 ,]

## DataFrames: subset
subset( class_df, subset = ( ages < 23 ) )

## DataFrames: order
a = c(3,1,4,5,2)
order(a)
a[ order(a) ]

class_df[order(class_df$ages), ]

## Lists: construction
a = 1:10
b = matrix(1:10, byrow = T, nrow = 5)
c = mtcars[1:10,]
my_list = list( a,b,c )
my_list

## Lists: names
my_list = list( W = a, U = b, V = c )
my_list

names(my_list) = c("A","B","C")
my_list

## Lists: slicing
my_list$A
my_list[[3]]


r <- function(x, log = TRUE){
  xbar <- mean(x, na.rm = TRUE)
  ans <- n*(xbar - .5)
  if(!log) ans <- exp(ans)
  return(ans)
}

theta0 <- 0
theta1 <- 1
n <- 100
alpha0 <- 0.05
cprime <- qnorm(1-alpha0, sd = 1/sqrt(n))
cprime
logc <- n*(cprime-.5)

X0 <-rnorm(n, mean = theta0, sd = 1)
X1 <-rnorm(n, mean = theta1, sd = 1)

## Uma observação: este teste não é ruim:
cat("Rejeita H0 para X0?", r(X0) > logc, "\n")
cat("Rejeita H0 para X1?", r(X1) > logc, "\n")

## Porém...
type_II_prob <- function(n){
    ans <- pnorm(q = qnorm(1-alpha0, sd = 1/sqrt(n)), mean = theta1, sd = 1/sqrt(n), lower.tail = TRUE)
}
ns <- c(1, 25, 100)
data.frame(n = ns, beta = type_II_prob(ns), logc = exp(ns*(cprime-.5)))

curve(type_II_prob, 1, 100,
      xlab = "Tamanho de amostra (n)", ylab = expression(beta(delta)))


sample <- 50000
X <- rexp(sample, 0.2)
x <- data.frame(X = seq(1, sample , 1), Y = sort(X))
plot(x,xlab="Position",ylab="values",main="Scatter_Plot for Exp distribution")
##

list <- split(X,seq(1,500,1))
##

pdata1 <- rep(0, 100);
pdata2 <- rep(0, 100);
pdata3 <- rep(0, 100);
pdata4 <- rep(0, 100);
pdata5 <- rep(0, 100);

for(i in 1:100){
  val=round(X[i], 0);
  if(val <= 100){
    pdata1[val] = pdata1[val] + 1/ 100;
  }
}
for(i in 101:200){
  val=round(X[i], 0);
  if(val <= 100){
    pdata2[val] = pdata2[val] + 1/ 100;
  }
}
for(i in 201:300){
  val=round(X[i], 0);
  if(val <= 100){
    pdata3[val] = pdata3[val] + 1/ 100;
  }
}
for(i in 301:400){
  val=round(X[i], 0);
  if(val <= 100){
    pdata4[val] = pdata4[val] + 1/ 100;
  }
}
for(i in 401:500){
  val=round(X[i], 0);
  if(val <= 100){
    pdata5[val] = pdata5[val] + 1/ 100;
  }
}

xcols1 <- c(0:99)
xcols2 <- c(0:99)
xcols3 <- c(0:99)
xcols4 <- c(0:99)
xcols5 <- c(0:99)

str(pdata1)
str(xcols1)

plot(xcols1, pdata1, "l", xlab="list1", ylab="f(X)", main="pdf")

str(pdata2)
str(xcols2)

plot(xcols2, pdata2, "l", xlab="list2", ylab="f(X)", main="pdf")

str(pdata3)
str(xcols3)

plot(xcols3, pdata3, "l", xlab="list3", ylab="f(X)", main="pdf")

str(pdata4)
str(xcols4)

plot(xcols4, pdata4, "l", xlab="list4", ylab="f(X)", main="pdf")

str(pdata5)
str(xcols5)

plot(xcols5, pdata5, "l", xlab="list5", ylab="f(X)", main="pdf")

cdata1 <- rep(0, 100)

cdata1[1] <- pdata1[1]

for(i in 2:100){
  cdata1[i] = cdata1[i-1] + pdata1[i]
}

plot(xcols1, cdata1, "o", col="blue", xlab="list1", ylab="F(X)", main="cdf")

cdata2 <- rep(0, 100)

cdata2[1] <- pdata2[1]

for(i in 2:100){
  cdata2[i] = cdata2[i-1] + pdata2[i]
}

plot(xcols2, cdata2, "o", col="red", xlab="list2", ylab="F(X)", main="cdf")

cdata3 <- rep(0, 100)

cdata3[1] <- pdata3[1]

for(i in 2:100){
  cdata3[i] = cdata3[i-1] + pdata3[i]
}

plot(xcols3, cdata3, "o", col="green", xlab="list3", ylab="F(X)", main="cdf")

cdata4 <- rep(0, 100)

cdata4[1] <- pdata4[1]

for(i in 2:100){
  cdata4[i] = cdata4[i-1] + pdata4[i]
}

plot(xcols4, cdata4, "o", col="yellow", xlab="list4", ylab="F(X)", main="cdf")

cdata5 <- rep(0, 100)

cdata5[1] <- pdata5[1]

for(i in 2:100){
  cdata5[i] = cdata5[i-1] + pdata5[i]
}

plot(xcols5, cdata5, "o", col="grey", xlab="list5", ylab="F(X)", main="cdf")

mn <- rep(0,500)
std <- rep(0,500)

i=1
for(i in 1:500)
{
  mn[i] <- mean(list[[i]])
  std[i] <- sd(list[[i]])
}
print (mn[1])
print (mn[2])
print (mn[3])
print (mn[4])
print (mn[5])
print (std[1])
print (std[2])
print (std[3])
print (std[4])
print (std[5])
##

pdata_m <- rep(0, 10);

for(i in 1:500){
  val1=round(mn[i], 0);
  if(val1 <= 10){
    pdata_m[val1] = pdata_m[val1] + 1/ 500;
  }
}

xcols_m <- c(1:10)

str(pdata_m)
str(xcols_m)

plot(xcols_m, pdata_m, "l", xlab="mean", ylab="f(X)", main="pdf of means")

cdata_m <- rep(0, 10)

cdata_m[1] <- pdata_m[1]

for(i in 2:10){
  cdata_m[i] = cdata_m[i-1] + pdata_m[i]
}

plot(xcols_m, cdata_m, "o", col="pink", xlab="mean", ylab="F(X)", main="cdf of means")
tab <- table(round(mn))
str(tab)
plot(tab, "h", xlab="Value", ylab="Frequency")
##

mnf <- rep(0, 1)
stdf <- rep(0, 1)
mnf <- mean(mn)
stdf <- sd(mn)

print(mnf)
print(stdf)


##### 医学統計勉強会18第7回生存時間解析　R code #####

library(survival)

x <- c(2, 4, 4, 5, 7, 8, 10)		# 生存時間
cens0 <- c(1, 1, 1, 1, 1, 1, 1)		# censoring status: 打ち切り状態（0：打ち切り無し，1：打ち切り有り）

Surv(x, cens0)

fit0 <- survfit(Surv(x, cens0) ~ 1)	# 生存関数のKaplan-Meier推定量を求める

plot(fit0)						# Kaplan-Meier curveの描画（信頼区間有り）
plot(fit0, conf.int=FALSE, xlab="time", ylab="Survival Function")		# Kaplan-Meier curveの描画（信頼区間有なし）

cens1 <- c(1, 1, 1, 1, 0, 1, 0)		# 7日目（5番目）と10日目（7番目）に打ち切り

Surv(x, cens1)

fit1 <- survfit(Surv(x, cens1) ~ 1)	# 生存関数のKaplan-Meier推定量を求める
plot(fit1, conf.int=FALSE, xlab="time", ylab="Survival Function")

### 白血病患者に対する寛解期間の臨床比較試験 ###

library(MASS)

data(gehan)

fit.gehan <- survfit(Surv(time, cens) ~ treat, data=gehan)
plot(fit.gehan, mark.time=TRUE, col=c("blue", "red"))
legend(25,1,legend=c("6-MP", "control"), col=c("blue", "red"), lty=1, bty="n")

survdiff(Surv(time, cens) ~ treat, data=gehan)		# log-rank検定

survdiff(Surv(time, cens) ~ treat, data=gehan, rho=1)		# the Peto & Peto modification of the Gehan-Wilcoxon test

### NCCTG Lung Cancer Data ###
fit.lung <- survfit(Surv(time, status) ~ pat.karno, data=lung)
plot(fit.lung, col=rainbow(8), main="NCCTG Lung Cancer Data")
label <- names(table(lung$pat.karno))
legend(800, 1, legend=label, lty=rep(1,8), col=rainbow(8), bty="n")

survdiff(Surv(time, status) ~ pat.karno, data=lung)
survdiff(Surv(time, status) ~ pat.karno + strata(inst), data=lung)

### Cox proportional hazard model: 白血病患者に対する寛解期間の臨床比較試験 ###

fit.ph <- coxph(Surv(time, cens) ~ treat, data=gehan)
summary(fit.ph)

### complementary log-log plot: Gehanの白血病データ ###

plot(fit.gehan, fun="cloglog", ylab="Log(-Log(survival))", xlab="time", lty=1:2)
legend(2, 0.6, c("control", "6-MP"), lty=1:2)

### Cox比例ハザードモデルにおける比例ハザード性の仮定についての、Schoenfeld residualによる検定 ###
cox.zph(fit.ph)

### 一般化加法モデルによる非線形モデル: 在郷軍人の肺がんデータ ###

fit <- coxph(Surv(time, status) ~ trt + karno + age, data=veteran)

cox.zph(fit)		# karno, ageのp値は小さく比例ハザード性の破綻が示唆される

library(mgcv)
fit.gam <- gam(time ~ trt + s(karno) + s(age), family=cox.ph(), weights=status, data=veteran)
summary(fit.gam)
plot(fit.gam)


#!/usr/bin/Rscript

require(deSolve)

## ==============================================================================
## Numerical solution of the SIR epidemiological model, a
## system of ordinary differential equations with state variables
## # susceptible (X), # infected (Y) # resistant (Z)
## ==============================================================================

parameters <- c(beta  = 0.01,
                gamma = 0.01,
                m = 0.1)

state <- c(X = 100, Y = 1, Z = 0)

## the ODE system

lorenz <- function(t, state, parameters) {
    with(as.list(c(state, parameters)),{

# rate of change

        dX <- -beta*X*Y + gamma*Z
        dY <- beta * X * Y - m*Y
        dZ <- m*Y - gamma * Z

# return the rate of change

        list(c(dX, dY, dZ))

    })

}

times <- seq(0, 100, by = 0.01)

out <- ode(y = state, times = times, func = lorenz, parms = parameters)

head(out)

par(oma = c(0, 0, 3, 0))
matplot(out[,"time"],out[,2:4], xlab = "Time (days)", type="l", ylab = "Numbers",col="black")
legend("topright", inset=0, legend=c("X (susceptible)", "Y (infected)", "Z (immune)"),  lty=1:3,  col="black",  bty = "n", horiz=FALSE)
mtext(outer = TRUE, side = 3, "SIR Model", cex = 1.5)


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 06

rm(list = ls())

observed <- c(442, 38, 514, 6)

(k <- length(observed))
# 4

(n <- sum(observed))
# 1000

EspectedProbabilities <- function(p) {
  c(0.5 * p, 0.5 * (1 - p), 0.5 * p ^ 2 + p * (1 - p), 0.5 * (1 - p) ^ 2)
}

LogLikelihood <- function(p, y) {
  sum(y * log(EspectedProbabilities(p)))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(0.5, NegativeLogLikelihood, y = observed, hessian = TRUE,
             lower = 10e-4, upper = 1 - 10e-4, method = 'L-BFGS-B')

(p.hat <- opt$par)
# 0.912941500560347

expected <- EspectedProbabilities(p.hat) * n

(Q <- sum((observed - expected) ^ 2 / expected))
# 3.08815842598583

(pvalue <- 1 - pchisq(Q, 2))
# 0.213508376478253


# Goal: "Dummy variables" in regression.

# Suppose you have this data:
people = data.frame(
  age =       c(21,62,54,49,52,38),
  education = c("college", "school", "none", "school", "college", "none"),
  education.code = c(  2,        1,      0,        1,         2,      0 )
  )
# Here people$education is a string categorical variable and
# people$education.code is the same thing, with a numerical coding system.
people

# Note the structure of the dataset --
str(people)
# The strings supplied for `education' have been treated (correctly) as
# a factor, but education.code is being treated as an integer and not as
# a factor.

# We want to do a dummy variable regression. Normally you would have:
#  1 Chosen college as the omitted category
#  2 Made a dummy for "none" named educationnone
#  3 Made a dummy for "school" named educationschool
#  4 Ran a regression like lm(age ~ educationnone + educationschool, people)
# But this is R. Things are cool:
lm(age ~ education, people)

# ! :-)
# When you feed him an explanatory variable like education, he does all
# these steps automatically. (He chose college as the omitted category).

# If you use an integer coding, then the obvious thing goes wrong --
lm(age ~ education.code, people)
# because he's thinking that education.code is an integer explanatory
# variable. So you need to:

lm(age ~ factor(education.code), people)
# (he choose a different omitted category)

# Alternatively, fix up the dataset --
people$education.code <- factor(people$education.code)
lm(age ~ education.code, people)

#
# Bottom line:
# Once the dataset has categorical variables correctly represented as factors, i.e. as
str(people)
# doing OLS in R induces automatic generation of dummy variables while leaving one out:
lm(age ~ education, people)
lm(age ~ education.code, people)

# But what if you want the X matrix?
m <- lm(age ~ education, people)
model.matrix(m)
# This is the design matrix that went into the regression m.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o2.r


library(diffeqr)
diffeqr::diffeq_setup()

f <- function (u, p, t) {
    # State variables
    # ---------------
    # u1: rabbits
    # u2: foxes
    du1 = p[1]*u[1] - p[2]*u[1]*u[2]
    du2 = -p[3]*u[2] + p[4]*p[2]*u[1]*u[2]

    return(c(du1, du2))
}

u0 = c(10, 5)
tspan <- list(0.0, 18.0)
p = c(1.0, 0.1, 1.5, 0.75)
sol = diffeqr::ode.solve(f, u0, tspan, p=p, saveat=0.01)

udf = as.data.frame(sol$u)
matplot(sol$t, udf, type = "l", xlab = "Time", ylab = "Population")
legend("topright", c("Rabbits", "Foxes"), lty = c(1,2), col = c(1,2), box.lwd = 0)


newton <- function(f, fprime, x0, tol_approx=1e-8, tol_consec=1e-8){
    # Solves a given equation for its roots using Newton's Method given its derivative
    # and an initial guess.  Also takes in function value tolerance and consecutive value tolerance.
    #
    # Args:
    #     f (function): equation to be solved
    #     fprime (function): derivative of f
    #     x0 (numeric): initial guess
    #     tol_approx (numeric): tolerance from 0
    #     tol_consec (numeric): tolerance from previous value
    # Returns:
    #     numeric: root of f
    x1 <- x0
    x0 <- x0 - 1 # To enter loop
    while (abs(f(x1))>tol_approx || abs(x1-x0)>tol_consec){
        x0 <- x1
        x1 <- x1 - f(x0)/fprime(x0)
    }
    return(x1)
}

bisection <- function(f, a, b, tol_approx=1e-8, tol_consec=1e-8){
    # Solves a given equation for its roots using Bisection Method given an initial
    # interval.  Also takes in function value tolerance and consecutive value tolerance.
    #
    # Args:
    #     f (function): equation to be solved
    #     a (numeric): left bound (function evaluation must be of opposite sign than b)
    #     b (numeric): right bound (function evaluation must be of opposite sign than a)
    #     tol_approx (numeric): tolerance from 0
    #     tol_consec (numeric): tolerance from previous value
    # Returns:
    #     numeric: root of f
    if (f(a)*f(b) > 0) stop('Initial bounds must evaluate to opposite sign.')
    xL <- a;    xR <- b;    xM <- NA
    while (abs(xR-xL) > tol_consec || max(abs(c(f(xL),f(xR)))) > tol_approx){
        xM <- .5 * (xL + xR)
        if(f(xL)*f(xM) < 0) xR <- xM else xL <- xM # If sign changes in [xL,xM], make xM the new right bound, otherwise left
    }
    return(xM)
}

call_black_scholes <- function(S, K, T, sigma, r, q){
    # Returns the Black-Scholes value of a vanilla call option.
    d1 <- (log(S/K) + (r - q + 0.5*sigma*sigma)*T) / (sigma*sqrt(T))
    return(S*exp(-q*T)*pnorm(d1) - K*exp(-r*T)*pnorm(d1 - sigma*sqrt(T)))
}

calculate_implied_vol <- function(S, K, T, r, q, price, solver='newton'){
    # Returns the Black-Scholes implied volatility.
    vega <- function(sigma){
        # Vega of a vanilla option in the Black-Scholes framework.
        # This is plugged into Newton's method as the first derivative.
        d1 <- (log(S/K) + (r - q + 0.5*sigma*sigma)*T) / (sigma*sqrt(T))
        return(S*exp(-q*T)*sqrt(T)*dnorm(d1))
    }

    if (solver == 'newton') {
        newton(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, vega, x0=0.25)
    } else if (solver == 'bisection'){
        bisection(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, a=1e-4, b=1.5)
    } else {
        uniroot(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, interval=c(1e-4,1.5))
    }

}

calculate_smile <- function(S, T, r, q, strikes, prices, plot_smile=FALSE, plot_title='', solver='newton'){
    # Calculates the implied volatility for a range of strikes.
    # Can plot the implied volatility smile.
    #
    # Args:
    #     S (numeric): Spot price
    #     T (numeric): Maturity
    #     r (numeric): Risk-neutral return rate
    #     q (numeric): Continuous dividend rate
    #     strikes (array-like): A range of strike prices
    #     prices (array-like): Prices for range of strikes
    #     plot_smile (logical): Should the function plot the implied volatility smile
    # Returns:
    #     (vector): The vector of implied volatilities for the range of strike prices

    implied_vols <- mapply(function(K,V) calculate_implied_vol(S, K, T, r, q, V, solver=solver), strikes, prices)
    if (plot_smile) plot(strikes, implied_vols, main=plot_title, xlab='K', ylab='Implied Volatility', type='l', col='blue', las=1)
    return(implied_vols)
}


cat("Likelihood functions; ");
# Likelihood Function;
# The parameters may have different numbers depend on the model we are
# going to use;
# par5 is (p,r1,lambda1,r2,lambda2) for mixed model and par2 is (r,lambda)
# for simple model;
# Construct likelihood kernel
## Generation interval kernel
# probability transfer from i to j, the interval is +-1day;
# shifted gamma distribution: allow for negative serial intervals
ptij <- function(ti,tj,dt,tshft,a,b){
  pgamma(ti-tj+dt+tshft,shape=a,scale=b)-pgamma(ti-tj-dt+tshft,shape=a,scale=b)
}

logit<-function(x){
  exp(x)/(1-exp(x))
}

# serial interval pdf;
serintpdf <- function(x,tshft,r,lambda){
  dgamma(x+tshft,shape=r,scale=lambda)
}
unifpdf <- function(x,u1,u2){
  dunif(x,min=u1,max=u2)
}

#serial interval cdf;
serintcdf <- function(x,tshft,r,lambda){
  pgamma(x+tshft,shape=r,scale=lambda)
}

maxgenint <- function(par){ # only positive roots
  f <- function(x){1-serintcdf(exp(x),par[1],par[2],par[3])-10^-3}
  return(c(-par[1],exp(uniroot(f, c(-10^8,10^8))$root)))
}

## Likelihood: product over all terms
ppij <- function(i,j,par,data){
  ifelse(i!=j,ptnegij(data[i],data[j],1,par[1],par[2],par[3]),0)
}

# Generate table with probabilities for generation interval kernel
# Maximum admissable generation interval: 99.9 percentile of interval
# distribution
probtab <- function(par){
  j <- 0
  stop <- FALSE
  prvect <- c()
  while(stop!=TRUE){
    new <- ptij(j,0,1,par[1],par[2],par[3])
    prvect[j+1] <- new
    if(sum(prvect)>(0.999999*2) | j>100 | new==0) {stop <- TRUE}
    j <- j+1
  }
  return(c(prvect,0))
}

# Generate vector of time differences (time intervals) for all possible
# contacts:
# replace inadmissable ones with -2 (including self, this is the outer
# Replace). See next line for reason why not -1.

diffs <- function(i,vec,rng){
  diff_t <- vec[i]-vec
  diff_t[which(diff_t<rng[1] | diff_t>rng[2])] <- -2
  diff_t[i] <- -2
  return(diff_t)
}

# Probability of j infecting i
# two parameters
probvec <- function(i,par,data,maxint){
  serintpdf(diffs(i,data,maxint),par[1],par[2],par[3])
}
probunif <- function(i,par,data){
  unifpdf(data[i]-data,par[1],par[2])
}

# probij <- function(i,j,par,data){
#   c(probunif(i,c(0,tswuhan),timedata)[j==1], # for Wuhan, uniform distribution
#     probvec(i,par,data,maxgenint(par))[j>1])
# }

probij <- function(i,j,par,data){
  probvec(i,par,data,maxgenint(par))[j]
}

# j can be vector, i can only be a number.
probijnp <- function(i,j,par,data){
  pvec<-probij(i,(1:length(data)),par,data)
  return(pvec[j]/(1-pvec[j])*prod(1-pvec))
}


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

plot(Seatbelts)
x1 = tslm(DriversKilled ~ trend, data=Seatbelts)
x2 = tslm(DriversKilled ~ season, data=Seatbelts)
x3 = tslm(DriversKilled ~ trend + season, data=Seatbelts)

CV(x1)
CV(x2)
CV(x3)

#fazendo previsao
r1 = forecast(x1,h=12)
r2 = forecast(x2,h=12)
r3 = forecast(x3,h=12)

autoplot(r1)
autoplot(r2)
autoplot(r3)

plot(r1)
lines(r2$mean, col="red")
lines(r3$mean, col="green")
legend("topright",legend=c("Tend","Seas","Tend + Seas"), col = c("blue","red","green"), lty=1:2, cex=0.8)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/8.3.Regressao Linear.r


# https://fivethirtyeight.com/features/can-you-solve-these-colorful-puzzles/
# You play a game with four balls: One ball is red, one is blue,
# one is green and one is yellow. They are placed in a box. You
# draw a ball out of the box at random and note its color. Without
# replacing the first ball, you draw a second ball and then paint
# it to match the color of the first. Replace both balls, and repeat
# the process. The game ends when all four balls have become the
# same color. What is the expected number of turns to finish the game?

# Libraries
library(ggplot2)

# Input
num_colors <- 4
num_balls  <- 4
num_trials <- 25000

# Code
rpl <- num_balls > num_colors
num_turns <- numeric(num_trials)

for (i in 1:num_trials) {
  a <- sample(1:num_colors, num_balls, replace = rpl)
  count <- 0
  while(!isTRUE(all.equal(min(a), max(a)))) {
    b  <- sample(a, 2, replace = FALSE)
    c1 <- min(which(a == b[1]))
    c2 <- min(which(a == b[2]))
    a[c(c1, c2)] <- b[1]
    count <- count + 1
  }
  num_turns[i] <- count
}

# Output
ggplot(mapping = aes(num_turns)) +
  geom_histogram(binwidth = 1) +
  theme_bw() +
  labs(title = "Riddler 4/28", x = "Num. of Turns", y = "Count")
median(num_turns)
mean(num_turns)


#!/usr/bin/env Rscript

##############################################################################
## Functions

integer_partition = function(n) {
    part_nums = c()
    for (k in 1:n) {
        part_nums = c(part_nums, A(n=n, k=k))
    }
    return(part_nums)
}

A = function(n, k) {
    if ((k == 1) || (n == k)) {
        return(1)
    }
    if ((k > n) || (k < 1)) {
        return(0)
    }
    return(A(n=(n-1), k=(k-1)) + A(n=(n-k), k=k))
}

expand_integer_vector = function(v) {
    expanded = c()
    for (i in 1:length(v)) {
        expanded = c(expanded, rep(i, v[i]))
    }
    return(expanded)
}

get_psi_prior = function(n) {
    integer_parts = integer_partition(n=n)
    return(1/(n * integer_parts))
}

parse_file_ext = function(path) {
    return(tail(strsplit(path, '\\.')[[1]], n=1))
}

plot_div_model_prior = function(n, output_path="partition_numbers.pdf") {
    prior_probs = get_psi_prior(n=n)
    names(prior_probs) = c(1:n)
    partition_numbers = expand_integer_vector(integer_partition(n=n))
    plot_letters = LETTERS[1:2]
    format = 'pdf'
    ext = parse_file_ext(output_path)
    if ((tolower(ext) == 'eps') || (tolower(ext) == 'ps')) {
        format = 'eps'
    }

    if (format == 'eps') {
        postscript(output_path, onefile = F, paper="special", horizontal=F, width=7.087, height=3)
    } else {
        pdf(output_path, width=7.087, height=3)
    }
    par(yaxs = "i", xaxs = "i")
    par(cex.axis=0.7)
    par(mgp = c(1.4,0.4,0)) # mgp adjusts space of axis labels
    # oma is space around all plots
    par(oma = c(0,0,0.3,0.2), mar = c(2.65,2.45,0.5,0.1))
    par(mfrow = c(1, 2))
    hist(partition_numbers,
            breaks= c(1:(n+1)),
    		right=FALSE,
    		xlab="",
    		ylab=bquote("# of divergence models"),
            main="",
    		# xlim=c(0,22),
    		# ylim=c(0,140),
    		xaxt="n",
    		col="gray50", border="gray50")
    box()
    axis(1, at=seq(1.5, (n+.5), 1), labels=c(1:n), tick=F)
    axis(1, at=c(1:(n+1)), labels=F)
    #mtext("Number of divergence models", WEST<-2, padj=0, cex=1, outer = T)
    mtext(plot_letters[[1]], side=3, adj=0, line=0, cex=0.75, font=2)

    par(mgp = c(1,0.4,0)) # mgp adjusts space of axis labels
    barplot(prior_probs,
            border="gray50",
            space=0,
            # axis.lty=1,
    	    xaxt = "n",
            col="gray50",
    		xlab="",
            ylab=bquote(italic(p)(italic(M)[group("|", bold(tau), "|")*","*italic(i)])),
            ylim=c(0, max(prior_probs))
            )
    box()
    axis(1, at=seq(0.5, (n-.5), 1), labels=c(1:n), tick=F)
    axis(1, at=c(0:n), labels=F)
    mtext(plot_letters[[2]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote("# of divergence events, " * group("|", bold(tau), "|")), SOUTH<-1, padj=-0.7, cex=1.1, outer = T)
    dev.off()
}

##############################################################################
## Main CLI

## Option parsing
suppressPackageStartupMessages(library("optparse"))
option_list <- list(
        make_option(c("-n", "--num-elements"), type="integer", dest="n", default=22,
                help="Number of elements (default: 22)"),
        make_option(c("-o", "--output-path"), type="character",
                dest="output_path", default="partition_numbers.pdf",
                help=paste("Output path for plot file (default: ",
                           "'./partition_numbers.pdf'). If you want an EPS-",
                           "formatted plot file, simply specify a path with ",
                           "an '.eps' or '.ps' extension. Otherwise, the ",
                           "plot file will be a PDF."))
)
options <- parse_args(OptionParser(option_list=option_list))

plot_div_model_prior(n = options$n,
                     output_path = options$output_path)


# 调用R包
library("FactoMineR");
library("factoextra");

data(decathlon2)
head(decathlon2)

decathlon2.active <- decathlon2[1:23, 1:10]
head(decathlon2.active[, 1:6], 4)

# 获得数据
library("FactoMineR")
library("factoextra")
data(decathlon2)
decathlon2.active <- decathlon2[1:23, 1:10]

# PCA计算
res.pca <- PCA(decathlon2.active, graph = FALSE)
# 提取变量的分析结果
var <- get_pca_var(res.pca)
var

# Coordinates of variables
head(var$coord, 4)
# col.var设定线条颜色
fviz_pca_var(res.pca, col.var = "black")

head(var$cos2)
library("corrplot")
# is.corr表示输入的矩阵不是相关系数矩阵
corrplot(var$cos2, is.corr=FALSE)

# Total cos2 of variables on Dim.1 and Dim.2
# 在第一第二主成分是显示结果（通过值的叠加显示）
fviz_cos2(res.pca, choice = "var", axes = 1:2)

# Color by cos2 values: quality on the factor map
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping
             )

# Change the transparency by cos2 values
fviz_pca_var(res.pca, alpha.var = "cos2")

head(var$contrib, 4)
library("corrplot")
corrplot(var$contrib, is.corr=FALSE)

# Contributions of variables to PC1
# 各变量对第一主成分的贡献
fviz_contrib(res.pca, choice = "var", axes = 1, top = 10)
# Contributions of variables to PC2
# 各变量对第二主成分的贡献
fviz_contrib(res.pca, choice = "var", axes = 2, top = 10)

fviz_contrib(res.pca, choice = "var", axes = 1:2, top = 10)

fviz_pca_var(res.pca, col.var = "contrib",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07")
             )

# Change the transparency by contrib values
fviz_pca_var(res.pca, alpha.var = "contrib")

# Create a random continuous variable of length 10
# 生成随机数
set.seed(123)
my.cont.var <- rnorm(10)
# Color variables by the continuous variable
# col.var设置颜色
# gradient.cols设置颜色渐变范围
fviz_pca_var(res.pca, col.var = my.cont.var,
             gradient.cols = c("blue", "yellow", "red"),
             legend.title = "Cont.Var")

# Create a grouping variable using kmeans
# Create 3 groups of variables (centers = 3)
set.seed(123)
# 进行聚类
# center聚类数量
res.km <- kmeans(var$coord, centers = 3, nstart = 25)
# 将向量编码为因子
grp <- as.factor(res.km$cluster)
# Color variables by groups
fviz_pca_var(res.pca, col.var = grp,
             palette = c("#0073C2FF", "#EFC000FF", "#868686FF"),
             legend.title = "Cluster")

#proba用于表征维度的显着性阈值，
res.desc <- dimdesc(res.pca, axes = c(1,2), proba = 0.05)
# Description of dimension 1 第一主成分
res.desc$Dim.1

# 第二主成分
res.desc$Dim.2

ind <- get_pca_ind(res.pca)
ind

fviz_pca_ind(res.pca)

# Quality of individuals
head(ind$cos2)
# repel=TRUE能够避免部分重合的点重叠
fviz_pca_ind(res.pca, col.ind = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping (slow if many points)
             )

fviz_pca_ind(res.pca, col.ind = "cos2", pointsize = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping (slow if many points)
             )

fviz_cos2(res.pca, choice = "ind")

# Total contribution on PC1 and PC2
fviz_contrib(res.pca, choice = "ind", axes = 1:2)

head(iris, 3)

# The variable Species (index = 5) is removed before PCA analysis
# 第5列不进行PCA运算
iris.pca <- PCA(iris[,-5], graph = FALSE)

fviz_pca_ind(iris.pca,
             # show points only (nbut not "text") 只显示点而不显示文本，默认都显示
             geom.ind = "point",
             # 设定分类种类
             col.ind = iris$Species,
             # 设定颜色
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             # 添加椭圆 Concentration ellipses
             addEllipses = TRUE,
             legend.title = "Groups",
             )

fviz_pca_ind(iris.pca,
             label = "none", # hide individual labels
             habillage = iris$Species, # color by groups
             addEllipses = TRUE, # Concentration ellipses
             palette = "jco"
             )

# Variables on dimensions 2 and 3
fviz_pca_var(res.pca, axes = c(2, 3))
# Individuals on dimensions 2 and 3
fviz_pca_ind(res.pca, axes = c(2, 3))

# Show variable points and text labels
fviz_pca_var(res.pca, geom.var = c("point", "text"))

# Show individuals text labels only
fviz_pca_ind(res.pca, geom.ind =  "text")

# Change the size of arrows an labels
fviz_pca_var(res.pca, arrowsize = 1, labelsize = 5,
             repel = TRUE)
# Change points size, shape and fill color
# Change labelsize
fviz_pca_ind(res.pca,
             pointsize = 3, pointshape = 21, fill = "lightblue",
             labelsize = 5, repel = TRUE)

# Add confidence ellipses
fviz_pca_ind(iris.pca, geom.ind = "point",
             # 使用iris数据集
             col.ind = iris$Species, # color by groups
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             addEllipses = TRUE, ellipse.type = "confidence",
             legend.title = "Groups"
             )
# Convex hull
fviz_pca_ind(iris.pca, geom.ind = "point",
             col.ind = iris$Species, # color by groups
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             # 用凸包多边形代替椭圆
             addEllipses = TRUE, ellipse.type = "convex",
             legend.title = "Groups"
             )

fviz_pca_var(res.pca, axes.linetype = "dotted")

ind.p <- fviz_pca_ind(iris.pca, geom = "point", col.ind = iris$Species)
ggpubr::ggpar(ind.p,
              title = "Principal Component Analysis",
              # 下标题
              subtitle = "Iris data set",
              # 说明
              caption = "Source: factoextra",
              # x,y轴标题
              xlab = "PC1", ylab = "PC2",
              # 标题名字位置
              legend.title = "Species", legend.position = "top",
              # 主题和配设
              ggtheme = theme_gray(), palette = "jco"
              )

fviz_pca_biplot(res.pca, repel = TRUE,
                col.var = "#2E9FDF", # Variables color
                col.ind = "#696969"  # Individuals color
                )

fviz_pca_biplot(iris.pca,
                # 观测量颜色
                col.ind = iris$Species, palette = "jco",
                # 添加椭圆
                addEllipses = TRUE, label = "var",
                # 线条颜色
                col.var = "black", repel = TRUE,
                legend.title = "Species")

fviz_pca_biplot(iris.pca,
                # Fill individuals by groups
                geom.ind = "point",
                # 点的形状
                pointshape = 21,
                # 点的大小
                pointsize = 2.5,
                # 按照组类特定形状
                fill.ind = iris$Species,
                col.ind = "black",
                # Color variable by groups
                # 颜色
                col.var = factor(c("sepal", "sepal", "petal", "petal")),
                # 标题
                legend.title = list(fill = "Species", color = "Clusters"),
                repel = TRUE        # Avoid label overplotting
             )+
  ggpubr::fill_palette("jco")+      # Indiviual fill color
  ggpubr::color_palette("npg")      # Variable colors

fviz_pca_biplot(iris.pca,
                # Individuals
                geom.ind = "point",
                fill.ind = iris$Species, col.ind = "black",
                pointshape = 21, pointsize = 2,
                palette = "jco",
                addEllipses = TRUE,
                # Variables
                alpha.var ="contrib", col.var = "contrib",
                gradient.cols = "RdYlBu",

                legend.title = list(fill = "Species", color = "Contrib",
                                    alpha = "Contrib")
                )

# Visualize variable with cos2 >= 0.6
# 可视化cos2>0.6
fviz_pca_var(res.pca, select.var = list(cos2 = 0.6))

# Select by names
# 根据名字显示
name <- list(name = c("Long.jump", "High.jump", "X100m"))
fviz_pca_var(res.pca, select.var = name)

# 根据前五贡献
# top 5 contributing individuals and variable
fviz_pca_biplot(res.pca, select.ind = list(contrib = 5),
               select.var = list(contrib = 5),
               ggtheme = theme_minimal())


# Derive statistics from confusion matrix
# [ref] https://en.wikipedia.org/wiki/Confusion_matrix
generateCM <- function(pred, ref){
  return(table(pred, ref))
}

cmToMetrics <- function(cm, positive=1){
  # Decode the matrix
  if(positive==0){
    TP <- cm[1,1]/sum(cm)
    TN <- cm[2,2]/sum(cm)
    FP <- cm[1,2]/sum(cm)
    FN <- cm[2,1]/sum(cm)
  } else {
    TP <- cm[2,2]/sum(cm)
    TN <- cm[1,1]/sum(cm)
    FP <- cm[2,1]/sum(cm)
    FN <- cm[1,2]/sum(cm)
  }
  # Derive Metrics
  sensitivity <- TP/(TP+FN)
  specificity <- TN/(FP+TN)
  prevalence <- TP+FN/(FN+TP+FP+TN)
  ppv <- TP/(TP+FP)
  npv <- TN/(TN+FN)
  fpr <- FP/(FP+TN)
  fnr <- FN/(FN+TP)
  fdr <- FP/(FP+TP)
  FOR <- FN/(TN+FN)
  accuracy <- (TP+TN)/(FN+TP+FP+TN)
  F1 <- 2*TP/(2*TP+FP+FN)
  MCC <- (TP*TN-FP*FN)/sqrt((TP+FP)*(TP+FN)*(TN+FP)*(TN+FN))
  informedness <- sensitivity + specificity - 1
  markedness <- ppv + npv -1
  # Output
  output <- c("Accuracy"=accuracy,
              "True.Positive"=TP,
              "False.Negative"=FN,
              "False.Positive"=FP,
              "True.Negative"=TN,
              "Sensitivity"=sensitivity,
              "Specificity"=specificity,
              "Prevalence"=prevalence,
              "Positive.Predictive.Value"=ppv,
              "Negative.Predictive.Value"=npv,
              "False.Positive.Rate"=fpr,
              "False.Discovery.Rate"=fdr,
              "False.Negative.Rate"=fnr,
              "False.Omission.Rate"=FOR,
              "F1.Score"=F1,
              "Matthews.correlation.coefficient"=MCC,
              "Informedness"=informedness,
              "Markedness"=markedness)
  return(output)
}


# Multinomial logistic regression simulation code
# For K levels of the dependent variable, estimates K-1 sets of
# coefficients for the independent variables.

# Currently set up for 3 classes but can be extended to any number

# Raymond Viviano
# rayviviano@gmail.com
# March 23, 2020

# TODO: Encapsulate certain code sections into smaller functions
# TODO: Bound coverage probability between 0 & 1

# Easy access to mlogit models
suppressPackageStartupMessages(library(mlogit))

# Set error reporting options
options(show.error.locations=TRUE)
options(error=recover)

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Ensure reproducible results
set.seed(10000)

# Set logistic regression parameters (Can be calculated as log(oddsRatio)) for
# Classes A and B (against reference C).

# Class a
b0a <- .2        # Set Logistic Regression Intercept True Value
b1a <- .5        # Set Logistic Regression Slope True Value

# Class b
b0b <- -.2
b1b <- .75

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 55

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=12)

# Loop through simulations
for(i in 1:nsims){
    # Participant/subject/case/index
    case = c(1:n)

    # Generate independant variable data, uniform random between -1 and 1
    x <- runif(n, -1, 1)

    # Compute probabilities of each class based on generated data
    prob.a <- exp(b0a +b1a*x) / (1 + exp(b0a + b1a*x) + exp(b0b + b1b*x))
    prob.b <- exp(b0b +b1b*x) / (1 + exp(b0a + b1a*x) + exp(b0b + b1b*x))
    prob.c <- 1 - prob.a - prob.b

    # Generate y data based on calculated probabilities
    y <- rep(NA, n)
    for (j in 1:n){
        y[j] <- sample(c("a", "b", "c"), 1, replace = TRUE,
                       prob = c(prob.a[j], prob.b[j], prob.c[j]))
    }

    # Prep data for mlogit package
    sim.data <- data.frame(case, x, y, stringsAsFactors=FALSE)

    # Convert data to long format for mlogit
    sim.data <- mlogit.data(sim.data, shape='wide', choice="y", id.var='case')

    # Estimate logit model
    model <- mlogit(y ~ -1|x, data=sim.data, reflevel='c')

    # Get variance-covariance matrix
    var.covar <- vcov(model)

    # Put model paramters in simulation matrix
    sim.prms[i,1] <- model$coef[1]             # Estimate for b0a
    sim.prms[i,2] <- model$coef[3]             # Estimate for b1a
    sim.prms[i,3] <- model$coef[2]             # Estimate for b0b
    sim.prms[i,4] <- model$coef[4]             # Estimate for b1b
    sim.prms[i,5] <- sqrt(diag(var.covar)[1])  # b0a standard error
    sim.prms[i,6] <- sqrt(diag(var.covar)[3])  # b1a standard error
    sim.prms[i,7] <- sqrt(diag(var.covar)[2])  # b0b standard error
    sim.prms[i,8] <- sqrt(diag(var.covar)[4])  # b1b standard error
    sim.prms[i,9]  <- summary(model)$CoefTable[,4][1] # b0a pvalue
    sim.prms[i,10] <- summary(model)$CoefTable[,4][3] # b1a pvalue
    sim.prms[i,11] <- summary(model)$CoefTable[,4][2] # b0b pvalue
    sim.prms[i,12] <- summary(model)$CoefTable[,4][4] # b1b pvalue
}

# Get Covarage probabilities for the parameters
b0a.coverage <- coverage.prob(sim.prms[,1], sim.prms[,5], b0a, .95, n-length(coef(model)))
b1a.coverage <- coverage.prob(sim.prms[,2], sim.prms[,6], b1a, .95, n-length(coef(model)))
b0b.coverage <- coverage.prob(sim.prms[,3], sim.prms[,7], b0b, .95, n-length(coef(model)))
b1b.coverage <- coverage.prob(sim.prms[,4], sim.prms[,8], b1b, .95, n-length(coef(model)))

# Print intercept for class a coverage probability and 95% confidence interval
print("Coverage Probability for b0a")
print(b0a.coverage)

# Print coefficent on x for class a coverage probability and 95% confidence interval
print("Coverage Probability for b1a")
print(b1a.coverage)

# Print intercept for class b coverage probability and 95% confidence interval
print("Coverage Probability for b0b")
print(b0b.coverage)

# Print coefficent on x for class b coverage probability and 95% confidence interval
print("Coverage Probability for b1b")
print(b1b.coverage)

cat("Power to detect b0a\n")
power.detect.effect(sim.prms[,9])

cat("\nPower to detect b1a\n")
power.detect.effect(sim.prms[,10])

cat("Power to detect b0b\n")
power.detect.effect(sim.prms[,11])

cat("\nPower to detect b1b\n")
power.detect.effect(sim.prms[,12])


set.seed(1)

# case 1: t-oracles; case 2: normal oracles.
case = 1
# energy function for the Gaussian mixture distribution
if (case == 1) {
    mean1 = -4
    mean2 = 3
    f = function(x) return(-log(0.4 * dnorm(x, mean=mean1, sd=0.7) + 0.6 * dnorm(x, mean=mean2, sd=0.5)))
    noisy_f = function(x) return(f(x) + rt(1, df=5))
} else {
    mean1 = -3
    mean2 = 2
    f = function(x) return(-log(0.4 * dnorm(x, mean=mean1, sd=0.7) + 0.6 * dnorm(x, mean=mean2, sd=0.5)))
    noisy_f = function(x) return(f(x) + rnorm(1, 0, 2))
}
# target Gaussian mixture distribution
density = function(x) exp(-f(x))

# Important hyperparameters
lr = 0.03
T_high = 10
T_low = 1

# Other hyperparameters
x_low = 0
x_high = 0
part1 = 100
grad_std = 0.1
thinning = 100

# You can set a larger value to obtain more stable results.
total = 100000

################################################### SGLD ###################################################
samples_sgld = c()
x_low = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)

        if (j %% (thinning) == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_sgld = c(samples_sgld, samples_part)
}

################################################### Naive reSGLD ###################################################
samples_naive = c()
x_low = 0
x_high = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)
        x_high = x_high - lr * (numDeriv::grad(f, x_high) + rnorm(1, 0, grad_std)) + sqrt(2 * lr * T_high) * rnorm(1, 0, 1)

        integrand_corrected = min(1, exp((1 / T_high - 1 / T_low) * (noisy_f(x_high) - noisy_f(x_low))))

        if (runif(1) < integrand_corrected) {
            tmp = x_low
            x_low = x_high
            x_high = tmp
        }
        if (j %% thinning == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_naive = c(samples_naive, samples_part)
}

################################################### reSGLD ###################################################
samples_ptsgld = c()
hat_var = 10
counter = 1
x_low = 0
x_high = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)
        x_high = x_high - lr * (numDeriv::grad(f, x_high) + rnorm(1, 0, grad_std)) + sqrt(2 * lr * T_high) * rnorm(1, 0, 1)

        if (j %% 20 == 0) {
            loss_stat = c()
            for (jjj in 1:10) {
                loss_stat = c(loss_stat, noisy_f(x_low))
            }
            unbiased_var = var(loss_stat)
            hat_var = (1 - 1 / counter) * hat_var + (1 / counter) * unbiased_var
            counter = counter + 1
        }

        integrand_corrected = min(1, exp((1 / T_high - 1 / T_low) * (noisy_f(x_high) - noisy_f(x_low) - (1 / T_high - 1 / T_low) * hat_var)))

        if (runif(1) < integrand_corrected) {
            tmp = x_low
            x_low = x_high
            x_high = tmp
        }
        if (j %% thinning == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_ptsgld = c(samples_ptsgld, samples_part)
}

real_samples = c(rnorm(length(samples_ptsgld)*0.4, mean=mean1, sd=0.7), rnorm(length(samples_ptsgld)*0.6, mean=mean2, sd=0.5))

wdata = data.frame(
        Type = factor(rep(c("Ground truth", "SGLD", "Naive reSGLD", "reSGLD"), each=length(samples_ptsgld))),
        weight = c(real_samples, samples_sgld, samples_naive, samples_ptsgld)
        )

library(ggplot2)

p=ggplot(wdata, aes(x = weight)) +
    stat_density(aes(x=weight, colour=Type, linetype=Type), size=2, geom="line", position="identity") +
    scale_linetype_manual(values=c("solid", "dotdash", "longdash", "twodash"))+
    scale_color_manual(values = c("#666666", "#7570B3", "#E7298A", "#1B9E77")) +
    scale_x_continuous(name="X") +
    scale_y_continuous(name="Density") +
    theme(
        legend.position = c(0.3, 0.8),
        legend.title =element_blank(),
        legend.text = element_text(colour="grey15", size=24),
        legend.key.size = unit(2,"line"),
        legend.key = element_blank(),
        legend.background=element_rect(fill=alpha('grey', 0.1)),
        axis.title=element_text(size=24),
        axis.text.y = element_text(size=24),
        axis.text.x = element_text(size=24)
        )
p


# Fiecare student primește un i unic
i <- 1

# Exercițiul 1
# Folosim repartiția hipergeometrică
p1 <- dhyper(x=1, m=2, n=i, k=2)
p2 <- dhyper(x=2, m=2, n=i, k=2)

print("P(X = 2):")
print(p1 / (p1 + p2))

# Exercițiul 2
# Folosim repartiția binomială
print("P(X = i):")
print(dbinom(i, size=100, prob=1/6))

# Exercițiul 3
# Folosim repartiția normală
right <- 1

print("P(X < 1):")
print(pnorm(right, mean=3, sd=sqrt(54)))

# Statistică
X <- c(1, 2, 3, i + 3)
n <- 4

# Exercițiul 4
X_bar <- mean(X)
sigma <- sqrt(3)

alpha <- 0.01

dx <- (sigma*qnorm(1 - alpha/2))/sqrt(n)

c(X_bar - dx, X_bar + dx)

# Exercițiul 5
s = var(X)

aux <- (n - 1) * s

left <- aux/qchisq(alpha/2, df=n-1)
right <- aux/qchisq(1-alpha/2, df=n-1)

# Exercițiul 6
C <- cbind(1, X, X^2)
y <- c(1, 2, 3, 4)

# beta = (C^T * C)^(-1) * C^T * y
beta <- solve(t(C)%*%C, t(C)%*%y)

print(t(beta)) # Afișare pe linie

# Verificare cu lm
X_sq <- X^2

model <- lm(y ~ X + X_sq)
print(model$coefficients)


alpha=0.05
q.alpha=qtukey(1-alpha,3,15)
n=10
sw2=10.28 # calculated in 14.10
W=q.alpha*(sqrt(sw2/n))
W
sample_means=c(25.1,23.5,37.8)
# by ordering sample mean from lowest to highest , we rank display panels by 2 1 3
# if diffrence between means > W then we declare them to be significantly different from each other


#===============================================================
# Find k-Almost-primes
# R implementation
#===============================================================
#---------------------------------------------------------------
# Function for prime factorization from Rosetta Code
#---------------------------------------------------------------

findfactors <- function(n) {
  d <- c()
  div <- 2; nxt <- 3; rest <- n
  while( rest != 1 ) {
    while( rest%%div == 0 ) {
      d <- c(d, div)
      rest <- floor(rest / div)
    }
    div <- nxt
    nxt <- nxt + 2
  }
  d
}

#---------------------------------------------------------------
# Find k-Almost-primes
#---------------------------------------------------------------

almost_primes <- function(n = 10, k = 5) {

  # Set up matrix for storing of the results

  res <- matrix(NA, nrow = k, ncol = n)
  rownames(res) <- paste("k = ", 1:k, sep = "")
  colnames(res) <- rep("", n)

  # Loop over k

  for (i in 1:k) {

    tmp <- 1

    while (any(is.na(res[i, ]))) { # Keep looping if there are still missing entries in the result-matrix
      if (length(findfactors(tmp)) == i) { # Check number of factors
        res[i, which.max(is.na(res[i, ]))] <- tmp
      }
      tmp <- tmp + 1
    }
  }
  print(res)
}


#' @export
#' @title correlationMatrix
#' @description couldn't accurately describe
#' @param \code{X}
#' @param \code{dfr} degrees of freedom
#' @param \code{meth.}
#' @return \code{}
#' @note X is the matrix of values with each column representing a single variable.  The upper triangle of the resulting matrix is p-values and lower is cor test value
#' @family statistical
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
correlationMatrix <- function(X, dfr = nrow(X) - 2,meth.=c("pearson", "kendall", "spearman")) {
			 R <- round(cor(X,method=meth.),digits=4)
				 above <- row(R) < col(R)
				 r2 <- R[above]^2
				 Fstat <- r2 * dfr / (1 - r2)
				 R[above] <- 1 - pf(Fstat, 1, dfr)
				 if( any(R[above]==0)) {
				R[above][which(R[above]==0)]<-0.0001
	 		 }
			 R
			}


## LASSO BAYESIANO
rm(list =ls())
##load("hiv.rda")
##204 binary attributes and 704 observations
library(monomvn)
data(diabetes)
attach(diabetes)
## Ordinary Least Squares regression
reg.ols <- regress(x, y)
## Lasso regression
reg.las <- regress(x, y, method="lasso")
## Bayesian Lasso regression. T: N�m de Muestras a Posteriori
## thin: number of MCMC samples to skip before a sample is collected (via thinning)
reg.blas <- blasso(x, y, T= 2000, thin = 50)
## summarize the beta (regression coefficients) estimates
plot(reg.blas, burnin=200)
points(drop(reg.las$b), col=2, pch=20)
points(drop(reg.ols$b), col=3, pch=18)
legend("topleft", c("blasso-map", "lasso", "lsr"), col=c(2,2,3), pch=c(21,20,18))
## plot the size of different models visited
plot(reg.blas, burnin=200, which="m")
## get the summary
s <- summary(reg.blas, burnin=200)
s$coef
## Residual Variance
s$s2
## calculate the probability that each beta coef != zero
s$bn0
## A summary of the model order
s$m
## Lambda
s$lambda2

### BOOTSTRAP
par(mfrow=c(1,1))
library(glmnet)
require(boot)
##X <- model.matrix(y~.,data=diabetes)
cv.out=cv.glmnet(x,y,alpha=1)
plot(cv.out)
bestlam=cv.out$lambda.min
bestlam
fit1=glmnet(x,y)
coef(fit1,s=bestlam) # extract coefficients at a single value of lambda
## Funci�n que extrae los coeficientes de LASSO dado el mejor lambda de VC
## Muestra de bootstrap
sample(1:10, size = 10, replace = T)
set.seed(44)
B <- 1000
betas <- matrix(0,B,11)
lambdas <- rep(0, B)
n.x <- nrow(x)
for (i in 1:B){
  mi.muestra <- sample(nrow(x), size = n.x, replace = T)
  x.b <- x[mi.muestra,]
  y.b <- y[mi.muestra]
  cv.out=cv.glmnet(x.b,y.b,alpha=1)
  fit1=glmnet(x.b,y.b,alpha=1)
  coefs <-coef(fit1,s=cv.out$lambda.min)
  betas[i,] <- coefs[,1]
  lambdas[i] <- cv.out$lambda.min
}
boxplot(betas)
abline(h=0, col = "green", pch =20)
media.betas <- apply(betas, 2, mean)
points(drop(media.betas), col=3, pch=18)
sd.betas <- apply(betas, 2, sd)
limite.inferior <- apply(betas, 2, quantile, probs =0.025, na.rm = FALSE)
limite.superior <- apply(betas, 2, quantile, probs =0.975, na.rm = FALSE)
intervalo.percentil = cbind(limite.inferior,limite.superior)
rownames(intervalo.percentil) <- rownames(coefs)
intervalo.percentil
mean(lambdas)


model_snowaccumulation <- function (tsmax = 0.0,
         tmax = 0.0,
         trmax = 0.0,
         precip = 0.0){
    #'- Name: SnowAccumulation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snowfall accumulation  calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates the depth of snow cover and recalculate weather data
    #'- inputs:
    #'            * name: tsmax
    #'                          ** description : maximum daily air temperature (tmax) below which all precipitation is assumed to be snow
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 1000
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: tmax
    #'                          ** description : current maximum air temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: trmax
    #'                          ** description : tmax above which all precipitation is assumed to be rain
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: precip
    #'                          ** description : current precipitation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'- outputs:
    #'            * name: Snowaccu
    #'                          ** description : snowfall accumulation
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW/d
    #'                          ** uri :
    fs <- 0.0
    if (tmax < tsmax)
    {
        fs <- 1.0
    }
    if (tmax >= tsmax && tmax <= trmax)
    {
        fs <- (trmax - tmax) / (trmax - tsmax)
    }
    Snowaccu <- fs * precip
    return (list('Snowaccu' = Snowaccu))
}


# Generates a new board - either a random one, sample blinker or gliders, or user specified.
gen.board <- function(type="random", nrow=3, ncol=3, seeds=NULL)
{
    if(type=="random")
    {
       return(matrix(runif(nrow*ncol) > 0.5, nrow=nrow, ncol=ncol))
    } else if(type=="blinker")
    {
       seeds <- list(c(2,1),c(2,2),c(2,3))
    } else if(type=="glider")
    {
       seeds <- list(c(1,2),c(2,3),c(3,1), c(3,2), c(3,3))
    }
    board <- matrix(FALSE, nrow=nrow, ncol=ncol)
    for(k in seq_along(seeds))
    {
      board[seeds[[k]][1],seeds[[k]][2]] <- TRUE
    }
    board
}

# Returns the number of living neighbours to a location
count.neighbours <- function(x,i,j)
{
   sum(x[max(1,i-1):min(nrow(x),i+1),max(1,j-1):min(ncol(x),j+1)]) - x[i,j]
}

# Implements the rulebase
determine.new.state <- function(board, i, j)
{
   N <- count.neighbours(board,i,j)
   (N == 3 || (N ==2 && board[i,j]))
}

# Generates the next interation of the board from the existing one
evolve <- function(board)
{
   newboard <- board
   for(i in seq_len(nrow(board)))
   {
      for(j in seq_len(ncol(board)))
      {
         newboard[i,j] <- determine.new.state(board,i,j)
      }
   }
   newboard
}

# Plays the game.  By default, the board is shown in a plot window, though output to the console if possible.
game.of.life <- function(board, nsteps=50, timebetweensteps=0.25, graphicaloutput=TRUE)
{
   if(!require(lattice)) stop("lattice package could not be loaded")
   nr <- nrow(board)

   for(i in seq_len(nsteps))
   {
      if(graphicaloutput)
      {
         print(levelplot(t(board[nr:1,]), colorkey=FALSE))
      } else print(board)

      Sys.sleep(timebetweensteps)

      newboard <- evolve(board)

      if(all(newboard==board))
      {
         message("board is static")
         break
      } else if(sum(newboard) < 1)
      {
         message("everything is dead")
         break
      } else board <- newboard
   }
   invisible(board)
}

# Example usage
game.of.life(gen.board("blinker"))
game.of.life(gen.board("glider", 18, 20))
game.of.life(gen.board(, 50, 50))


## Stochastic GRADIENT DESCENT ALGORITHM
stochastic_gd<-function(design_matrix,response,
                        gradient_fn,cost_fn,threshold=0.01,
                        max_pass=1,
                        init_weights=matrix(rep(0,ncol(design_matrix)),ncol=1),
                        learning_rate=0.1){
  theta<-init_weights
  alpha<-learning_rate
  n<-nrow(design_matrix)
  cost<-numeric()
  nrows<-nrow(X)
  for(k in 1:max_pass){
    index<-(1:nrows)[order(runif(nrows))]
    if(!is.null(cost_fn)){
      cost<-c(cost,cost_fn(response,design_matrix%*%theta))
    }
    if(tail(cost,n=1)<threshold){
      break
    }
    for (i in index){
      theta<-theta-alpha*gradient_fn(theta,design_matrix[i,],response[i,])
    }
  }
  list(weights=theta,cost=cost)
}


A <- 0.1

r <- (1:100)

eta <- -1.1

L <- A*r^eta

plot(L~r)

plot(log(L)~log(r))

pl <- data.frame(r,L,logL=log(L))

head(pl)

lm(logL~log(r),data=pl)

# do it with 1000 points
rm(list=ls())

pl <- data.frame(r=seq(1,100,0.1))

pl$L<- 0.4*pl$r^-1.3
pl$logL <-log(pl$L)
pl$logr <-log(pl$r)

lm(logL~logr,data=pl)

cumPowerL <- function(x) {
  sum(pl[pl$r >=x,]$L)

}

pl$cumL <- sapply(pl$r,cumPowerL)

plot(log(cumL)~logr,data=pl)

pl1 <- pl[pl$logr<3,]

lm1 <- lm(log(cumL)~logr,data=pl1)

lm0  <- lm(log(cumL)~logr,data=pl)

summary(lm1)

coef(lm1)

summary(lm0)

abline(lm1,col="red")

abline(lm0,col="blue")

# Exercise 4

pl2 <- pl[1:50,]

lm2 <- lm(log(cumL)~logr,data=pl2)

summary(lm2)

coef(lm2)

abline(lm2,col="green")


library(deSolve)
library(reshape2)
library(ggplot2)

sir_ode <- function(times,init,parms){
  with(as.list(c(parms,init)), {
  # ODEs
  dS <- -beta*S*I
  dI <- beta*S*I-gamma*I
  dR <- gamma*I
  list(c(dS,dI,dR))
  })
}

parms <- c(beta=0.1,gamma=0.05)
init <- c(S=0.99,I=0.01,R=0)
times <- seq(0,200,length.out=2001)
sir_out <- lsoda(init,times,sir_ode,parms)

sir_out_long <- melt(as.data.frame(sir_out),"time")

# Plot
ggplot(sir_out_long, aes(x=time, y=value, colour=variable, group=variable)) +
  geom_line(lwd=2) + xlab("Time") + ylab("Number")


# bivariate skew-normal copula with parameters rho, ga1, ga2
# such that determinant with these 3 correlation is positive definite
# checks on cdf, pdf and conditional distributions

# Rmat= [1 ga1 ga2; ga1 1 rho; ga2 rho 1 ]
# is correlation matrix of (Z0,Z1,Z2)
# the bivariate skew normal distribution is (Y1,Y2) = [Z1,Z2|Z0>0]
# the conditional distribution is univariate extended skew-normal
# with 4 parameters: xi=location, omega=scale, alpha=ga/sqrt(1-ga^2),
# tau=(negative threshold)

# these functions make use of functions in library(sn) and
# library(CopulaModel)

# param=c(rho,ga1,ga2), constraint is that
# correlation matrix with these parameters should be positive definite
dbskewn=function(y1,y2,param)
{ rho=param[1]; ga1=param[2]; ga2=param[3]
  r2=1-rho^2
  #a1=ga1/sqrt(1-ga1^2)
  #a2=ga2/sqrt(1-ga2^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s/r2)
  be1=(ga1-rho*ga2)/r2
  be2=(ga2-rho*ga1)/r2
  bpdf=2*dbvn2(y1,y2,rho)*pnorm((be1*y1+be2*y2)/s)
  bpdf
}

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

# compare
library(CopulaModel)
library(sn)

rho=.7; ga1=.5; ga2=.1
rho=.4; ga1=.4; ga2=-.1
rho=.3; ga1=.4; ga2=-.3
a1=ga1/sqrt(1-ga1^2)
a2=ga2/sqrt(1-ga2^2)
mypar=c(rho,ga1,ga2)
y1=.5; y2=2.1
y1=-.5; y2=-1.3
y1=.5; y2=-1.3
out2=dbskewn(y1,y2,mypar)

# sn library
rmat=matrix(c(1,rho,rho,1),2,2)
#alpv=c(a1,a2) # this is not correct
gav=c(ga1,ga2)
tem=solve(rmat,gav)
alpv=tem/sqrt(1-sum(gav*tem))
out=dmsn(c(y1,y2),Omega=rmat,alpha=alpv)
cat(out,out2,"\n")
# Ok matches
# check some identities
tem2=rmat%*%alpv
gv=tem2/sqrt(1+sum(alpv*tem2))
print(c(gv))
print(gav)
print(1-sum(gav*tem))
print(1/(1+sum(alpv*tem2)))
# Ok these match

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

# skew-normal copula from Azzalini-DallaValle's bivariate skew-normal
# u,v = values or vectors in (0,1)
# param = (rho,ga1,ga2), with -1<rho<1, -1<ga1<1, -1<ga2<1
#  and a constraint 1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho>0

# Output: bivariate skew-normal copula density
dbskewncop=function(u,v,param)
{ rho=param[1]; ga1=param[2]; ga2=param[3]
  r2=1-rho^2
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s/r2)
  be1=(ga1-rho*ga2)/r2
  be2=(ga2-rho*ga1)/r2
  y1=qsn(u,0,1,alpha=a1)
  y2=qsn(v,0,1,alpha=a2)
  bpdf=2*dbvn2(y1,y2,rho)*pnorm((be1*y1+be2*y2)/s)
  denom=dsn(y1,alpha=a1)*dsn(y2,alpha=a2)
  cpdf=bpdf/denom
  cpdf
}

# Output: bivariate skew-normal copula cdf
pbskewncop=function(u,v,param)
{ rho = param[1]; gav = param[2:3]
  rmat=matrix(c(1,rho,rho,1),2,2)
  tem=solve(rmat,gav)
  alpv=tem/sqrt(1-sum(gav*tem))
  ga1=gav[1]; ga2=gav[2]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  cdf=pmsn(c(y1,y2),Omega=rmat,alpha=alpv)
  cdf
}

# pcond21 = P(V<v|U=u) for bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional cdf P(V<v|U=u) of bivariate skew-normal copula
pcondbskewncop21=function(v,u,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om21=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om21
  tau21=a1*y1
  xi21=rho*y1
  a21=(ga2-rho*ga1)/s/om21
  ccdf=psn(y2,xi=xi21,omega=om21,alpha=a21,tau=tau21)
  ccdf
}

# pcond12 = P(U<u|V=v) for bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional cdf P(U<u|V=v) of bivariate skew-normal copula
pcondbskewncop12=function(u,v,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om12=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om12
  tau12=a2*y2
  xi12=rho*y2
  a12=(ga1-rho*ga2)/s/om12
  ccdf=psn(y1,xi=xi12,omega=om12,alpha=a12,tau=tau12)
  ccdf
}

# qcond21 = bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional quantile C_{2|1}^{-1}(p|u)of bivariate skew-normal copula
qcondbskewncop21=function(p,u,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); #y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om21=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om21
  tau21=a1*y1
  xi21=rho*y1
  a21=(ga2-rho*ga1)/s/om21
  y2=qsn(p,xi=xi21,omega=om21,alpha=a21,tau=tau21)
  v=psn(y2,alpha=a2)
  v
}

# qcond12 = bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional quantile C_{1|2}^{-1}(p|v)of bivariate skew-normal copula
qcondbskewncop12=function(p,v,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  #y1=qsn(u,alpha=a1);
  y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om12=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om12
  tau12=a2*y2
  xi12=rho*y2
  a12=(ga1-rho*ga2)/s/om12
  y1=qsn(p,xi=xi12,omega=om12,alpha=a12,tau=tau12)
  u=psn(y1,alpha=a1)
  u
}

#============================================================
# all checks OK

# conditional u given v
chkcopderiv2=function(u,vvec,cpar,bcdf,pcond,bpdf,str=" ",eps=1.e-4)
{ nn=length(vvec)
  cat("\n",str, " with parameter ", cpar,"\n")
  cat("u   v    cdf      numccdf     ccdf\n")
  cat("u   v    ccdf     numpdf      pdf\n")
  for(i in 1:nn)
  { v=vvec[i]
    cdf=bcdf(u,v,cpar)
    cdf2=bcdf(u,v+eps,cpar)
    ccdf=pcond(u,v,cpar)
    #cat(u,v,cdf,(cdf2-cdf)/eps,ccdf,"\n")
    tem=(cdf2-cdf)/eps
    cat(u,v,cdf,tem,ccdf,"\n")
    if(abs(tem-ccdf)>eps*30) cat("*** ccdf roundoff???\n")
    ccdf2=pcond(u+eps,v,cpar)
    pdf=bpdf(u,v,cpar)
    #cat(u,v,ccdf,(ccdf2-ccdf)/eps,pdf,"\n")
    tem=(ccdf2-ccdf)/eps
    cat(u,v,ccdf,tem,pdf,"\n")
    if(abs(tem-pdf)>eps*30) cat("*** dcop roundoff???\n")
  }
  invisible(0)
}

# check of psn\circ qsn is OK,
# check of (psn(y+eps)-psn(y))/eps is OK

#param=c(.7,.5,.5)
#param=c(.7,.7,.1)
#param=c(.5,.0,.1)
#param=c(.1,.1,.1)
param=c(.2,.3,.1)

# compare pcondbskewncop21 and pcondbskewncop12
a=c(.4,.5,.6)
b=c(.1,.7,.8)
for(j in 1:3)
{ out1=pcondbskewncop21(a[j],b[j],param)
  out2=pcondbskewncop12(a[j],b[j],param[c(1,3,2)])
  cat(out1,out2,"\n")
}
# above two should be the same

#u=.3
u=.8
vvec=seq(.4,.9,.1)

#for(v in vvec) chkcopderiv(u,v,param,bcdf=pbskewncop,pcond=pcondbskewncop21,bpdf=dbskewncop,str="bskn",eps=1.e-4)

chkcopderiv(u,vvec,param,bcdf=pbskewncop,pcond=pcondbskewncop21,
  bpdf=dbskewncop)
# OK

chkcopderiv2(u,vvec,param,bcdf=pbskewncop,pcond=pcondbskewncop12,
  bpdf=dbskewncop)
# OK

cat("\ncheck pcond and qcond as functional inverses\n")
uvec=seq(.1,.6,.1)
vvec=seq(.4,.9,.1)
#par.pla=pla.b2cpar(.7)
#chkcopcond(uvec,vvec,par.pla,pcondpla,qcondpla,"pla")
chkcopcond(uvec,vvec,param,pcondbskewncop21,qcondbskewncop21,"bskn")
chkcopcond(uvec,vvec,param,pcondbskewncop12,qcondbskewncop12,"bskn")
# should above two be the same?
chkcopcond(vvec,uvec,param,pcondbskewncop12,qcondbskewncop12,"bskn")

# looks OK


view_list <- function(list) {

  for (item in 1:length(list)) {

    print(head(list[[item]]))

  }
}

#' row-wise centering
#'
#' center the col of matrix x
#' @param x a matrix
#'
#' @keywords norm internal
center_colmeans <- function(x) {
  xcenter <- colMeans(x)
  x - rep(xcenter, rep.int(nrow(x), ncol(x)))
}

#' The 2norm or Frobenius norm function
#'
#'
#' @param x vector or matrix to calculate its 2norm or Frobenius norm
#' @return 2norm or Frobenius norm
#'
#' @keywords norm internal
norm_2 <- function(x) sqrt(sum(x^2))

#' Differencing matrix
#'
#' @param k number of coeficient to be diffed
#' @param m order of differencing
#'
#' @keywords
#'
diff_matrix <- function(k, m) {
  m_diff <- diag(k)
  while (m > 0) {
    m_diff <- diff(m_diff)
    m <- m - 1
  }
  if (is.vector(m_diff)) {
    m_diff <- t(m_diff)
  }
  return(m_diff)
}

#' P-spline basis
#'
#' Construct the $n \times K$ spline matrix using quiv-distant knots
#' $K = k_0 + m$
#'
#' @param x observations for the first covariate
#' @param k0 number of internal knots
#' @param m order of the basis splines
#' @param x_range range of the spline basis,
#'                default to be NULL then use the c(max, min)
#'
#' @import splines
#'
#' @return $n \times K$ spline matrix for the first covariate,
#'
spline_basis <- function(x, k0, m, x_range=NULL) {
  if (is.null(x_range)) {
    x_range <- c(max(x), min(x))
  }

  big <- x_range[1]; small <- x_range[2]
  h <- (big - small) / (k0 + 1)
  v_knots <- seq_len(k0) * h + small
  v_knots <- c(rep(small, m), v_knots, rep(big, m))
  out <- splines::splineDesign(v_knots, x, ord = m)
  return(out)
}


## This is free software and is offered with no warranty whatsoever.

##utility function returns true if n-m is odd

.odd <- function(n,m) {
  if (((n-m)%%2) == 0) {
    FALSE
  } else {
    TRUE
  }
}

##derivative (wrt r) of zernike polynomials
## Iterative version of recurrence relation
## given in Eqn. 13 of Mathworld Zernike article.

drzernike <- function(rho, n, m) {
    if ((n<0) || (m<0) || (n<m) || (.odd(n,m))) stop("Bad argument to drzernike")
    if ((n==0) && (m==0))return(0*rho)
    if (n==m) return(n*rho^(n-1))
    if (m==0) dr <- 0*rho else dr <- m*rho^(m-1)
    for (nn in seq(m+2, n, by=2)) {
        dr <- dr + nn*(rzernike(rho,nn-1,abs(m-1))+rzernike(rho,nn-1,m+1))
    }
    dr
}

### Zernike polynomial

Zernike <- function(rho, theta, n, m, t) {
    sqrt(n+1) * rzernike(rho, n, m) * switch(t, n=1, c=sqrt(2)*cos(m*theta),
	 s=sqrt(2)*sin(m*theta))
}

## make a list of radial and azimuthal indexes in extended Fringe sequence
## from order minorder to maxorder

makezlist <- function(minorder=0, maxorder=14) {
    n <- numeric()
    m <- numeric()
    t <- character(length=0)

    for (order in seq(minorder, maxorder, by=2)) {
        mmax <- order/2
        mtemp <- 0
        if (mmax > 0) {
          mtemp <- c(mtemp, rep(1:mmax, each=2))
        }
        mtemp <- rev(mtemp)
        n <- c(n, order-mtemp)
        m <- c(m, mtemp)
        t <- c(t, rep(c("c", "s"), mmax), "n")
    }
    list(n=n, m=m, t=t)
}

## Augmented Fringe set

zlist.fr <- makezlist(2,12)

## list of ZP indexes in ISO/ANSI sequence

#' Construct list of ZP indexes in ISO/ANSI sequence with sine terms first
#'
#' @param maxorder maximum radial and azimuthal order
#' @return a named list with n=radial indexes, m=azimuthal, and t indicating
#'  trig function to apply
#' @examples
#' zlist.iso <- makezlist.iso(maxorder=6)
#' zlist <- makezlist(0, 6)
makezlist.iso <- function(maxorder=12) {
  n <- numeric(0)
  m <- numeric(0)
  t <- "n"
  for (i in 0:maxorder) {
    n <- c(n, rep(i, i+1))
    m <- c(m, abs(seq(-i, i, by=2)))
    if (i >= 1) {
      t <- c(t, rep("s" , (i+1) %/% 2))
      if (i %% 2 == 0) {
        t <- c(t, "n")
      }
      t <- c(t, rep("c", (i+1) %/% 2))
    }
  }
  list(n=n, m=m, t=t)
}

## Vector of factors from conversion between "normalized" and conventional Zernike definitions

zmult <- function(zlist = makezlist()) {
    mult <- sqrt(zlist$n+1)
    mult[zlist$m > 0] <- sqrt(2)*mult[zlist$m > 0]
    mult
}

## create a matrix of Zernike polynomial values

zpm.arb <- function(rho, theta, phi=0, zlist=makezlist()) {
	zm <- matrix(0, nrow=length(rho), ncol=length(zlist$n))
	for (i in (1:length(zlist$n))) {
		zm[,i] <- Zernike(rho,theta-pi*phi/180, zlist$n[i], zlist$m[i], zlist$t[i])
	}
	colnames(zm) <- colnames(zm, do.NULL=FALSE, prefix="Z")
	zm
}

## a faster Zernike matrix fill

zpm <- function(rho, theta, phi=0, maxorder = 14, nthreads=parallel::detectCores()/2) {
  if (phi != 0) theta <- theta - pi*phi/180
  if (nthreads == 1) {
    zm <- zpmC(rho, theta, maxorder)
  } else {
    RcppParallel::setThreadOptions(numThreads = nthreads)
    zm <- zpmCP(rho, theta, maxorder)
  }
  colnames(zm) <- paste("Z",0:(ncol(zm)-1), sep="")
  zm
}

## fit zernikes to data

fitzernikes <- function(wf, rho, theta, phi=0, maxorder = 14,
                        nthreads=parallel::detectCores()/2, uselm=FALSE, isoseq=FALSE) {
  if (isoseq) {
    theta <- theta - pi * phi/180
    zm <- zpm_cart(x=rho*cos(theta), y=rho*sin(theta), maxorder=maxorder)
  } else {
    zm <- zpm(rho, theta, phi=phi, maxorder=maxorder, nthreads=nthreads)
  }
  zm.names <- colnames(zm)
  if (uselm) {
      fmla <- as.formula(paste("wf ~ -1 + ", paste(zm.names, collapse="+")))
      dataf <- data.frame(cbind(wf, zm))
      fit <- lm(fmla, data=dataf)
  } else {
      fit <- qr.solve(crossprod(zm),crossprod(zm, wf))
  }
  fit
}


 DSTEV Example Program Results

 Eigenvalues
     0.6476  3.5470  8.6578 17.1477
 Eigenvectors
          1       2       3       4
 1   0.9396  0.3388  0.0494  0.0034
 2  -0.3311  0.8628  0.3781  0.0545
 3   0.0853 -0.3648  0.8558  0.3568
 4  -0.0167  0.0879 -0.3497  0.9326

 Error estimate for the eigenvalues
        3.8E-15

 Error estimates for the eigenvectors
        1.3E-15    1.3E-15    7.5E-16    4.5E-16