## @knitr logistic-fun
x <- seq(-4,4,by=.05)
p <- 1/(1 + exp(-x))   # Figure (*\ref{fig:lrm-logistic-fun}*)
plot(x, p, xlab="X", ylab="P", type="l")

## @knitr or-vs-diff
plot(0, 0, type="n", xlab="Risk for Subject Without Risk Factor",
     ylab="Increase in Risk",
     xlim=c(0,1), ylim=c(0,.6))   # Figure (*\ref{fig:lrm-or-vs-diff}*)
i <- 0
or <- c(1.1,1.25,1.5,1.75,2,3,4,5,10)
for(h in or) {
  i <- i + 1
  p <- seq(.0001, .9999, length=200)
  logit <- log(p/(1 - p))  # same as qlogis(p)
  logit <- logit + log(h)  # modify by odds ratio
  p2 <- 1/(1 + exp(-logit))# same as plogis(logit)
  d <- p2 - p
  lines(p, d, lty=i)
  maxd <- max(d)
  smax <- p[d==maxd]
  text(smax, maxd + .02, format(h), cex=.6)
}

## @knitr lrmodel
require(rms)
getHdata(sex.age.response)
d <- sex.age.response
dd <- datadist(d); options(datadist='dd')
f <- lrm(response ~ sex + age, data=d)
fasr <- f   # Save for later
w <- function(...)
  with(d, {
    m <- sex=='male'
    f <- sex=='female'
    lpoints(age[f], response[f], pch=1)
    lpoints(age[m], response[m], pch=2)
    af <- cut2(age, c(45,55), levels.mean=TRUE)
    prop <- tapply(response, list(af, sex), mean,
                   na.rm=TRUE)
    agem <- as.numeric(row.names(prop))
    lpoints(agem, prop[,'female'],
            pch=4, cex=1.3, col='green')
    lpoints(agem, prop[,'male'],
            pch=5, cex=1.3, col='green')
    x <- rep(62, 4); y <- seq(.25, .1, length=4)
    lpoints(x, y, pch=c(1, 2, 4, 5),
            col=rep(c('blue','green'),each=2))
    ltext(x+5, y,
          c('F Observed','M Observed',
            'F Proportion','M Proportion'), cex=.8)
  } )   # Figure (*\ref{fig:lrm-lrmodel}*)

plot(Predict(f, age=seq(34, 70, length=200), sex, fun=plogis),
     ylab='Pr[response]', ylim=c(-.02, 1.02), addpanel=w)
ltx <- function(fit) latex(fit, inline=TRUE, columns=54,
                           file='', after='$.', digits=3,
        size='Ssize', before='$X\\hat{\\beta}=')
ltx(f)

## @knitr simerr
sigmas  <- c(.5, .75, 1, 1.25, 1.5, 1.75, 2, 2.5, 3, 4)
ns      <- seq(25, 300, by=25)
nsim    <- 1000
xs      <- seq(-1.5, 1.5, length=200)
pactual <- plogis(xs)

dn <- list(sigma=format(sigmas), n=format(ns))
maxerr <- N1 <- array(NA, c(length(sigmas), length(ns)), dn)
require(rms)

i <- 0
for(s in sigmas) {
  i <- i + 1
  j <- 0
  for(n in ns) {
    j <- j + 1
    n1 <- maxe <- 0
    for(k in 1:nsim) {
      x <- rnorm(n, 0, s)
      P <- plogis(x)
      y <- ifelse(runif(n) <= P, 1, 0)
      n1 <- n1 + sum(y)
      beta <- lrm.fit(x, y)$coefficients
      phat <- plogis(beta[1] + beta[2] * xs)
      maxe <- maxe + max(abs(phat - pactual))
    }
    n1 <- n1/nsim
    maxe <- maxe/nsim
    maxerr[i,j] <- maxe
    N1[i,j] <- n1
  }
}
xrange <- range(xs)
simerr <- llist(N1, maxerr, sigmas, ns, nsim, xrange)

maxe <- reShape(maxerr)
# Figure (*\ref{fig:lrm-simerr}*)
xYplot(maxerr ~ n, groups=sigma, data=maxe,
       ylab=expression(paste('Average Maximum  ',
           abs(hat(P) - P))),
       type='l', lty=rep(1:2, 5), label.curve=FALSE,
       abline=list(h=c(.15, .1, .05), col=gray(.85)))
Key(.8, .68, other=list(cex=.7,
               title=expression(~~~~~~~~~~~sigma)))

## @knitr assumptions
plot(0:1, 0:1, xlab=expression(X[2]), ylab='logit{Y=1}',
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)

## @knitr emp-age-sex
getHdata(acath)
acath$sex <- factor(acath$sex, 0:1, c('male','female'))
dd <- datadist(acath); options(datadist='dd')
f <- lrm(sigdz ~ rcs(age, 4) * sex, data=acath)

## @knitr emp-age-sex-kn
kn <- specs(f)$how.modeled['age','Parameters']
kn <- setdiff(strsplit(kn, ' ')[[1]], '')
kn[length(kn)] <- paste('and', kn[length(kn)])
kn <- paste(kn, collapse=', ')

## @knitr emp-age-sex-pl
w <- function(...)
  with(acath, {
    plsmo(age, sigdz, group=sex, fun=qlogis, lty='dotted',
          add=TRUE, grid=TRUE)
    af <- cut2(age, g=10, levels.mean=TRUE)
    prop <- qlogis(tapply(sigdz, list(af, sex), mean,
                          na.rm=TRUE))
    agem <- as.numeric(row.names(prop))
    lpoints(agem, prop[,'female'], pch=4, col='green')
    lpoints(agem, prop[,'male'],   pch=2, col='green')
  } )   # Figure (*\ref{fig:lrm-emp-age-sex-pl}*)
plot(Predict(f, age, sex), ylim=c(-2,4), addpanel=w,
     label.curve=list(offset=unit(0.5, 'cm')))

## @knitr emp-age-sex-plunused
ggplot(Predict(f, age, sex)) +
  stat_plsmo(aes(x=age, y=sigdz), data=acath, fun=qlogis)

## @knitr lrtest
lr <- function(formula)
  {
    f <- lrm(formula, data=acath)
    stats <- f$stats[c('Model L.R.', 'd.f.')]
    cat('L.R. Chi-square:', round(stats[1],1),
        '  d.f.:', stats[2],'\n')
    f
  }
a <- lr(sigdz ~ sex + age)
b <- lr(sigdz ~ sex * age)
c <- lr(sigdz ~ sex + rcs(age,4))
d <- lr(sigdz ~ sex * rcs(age,4))
lrtest(a, b)
lrtest(a, c)
lrtest(a, d)
lrtest(b, d)
lrtest(c, d)

## @knitr dur
dz <- subset(acath, sigdz==1)
dd <- datadist(dz)
f <- lrm(tvdlm ~ rcs(cad.dur, 5), data=dz)
w <- function(...)
  with(dz, {
    plsmo(cad.dur, tvdlm, fun=qlogis, add=TRUE,
          grid=TRUE, lty='dotted')
    x <- cut2(cad.dur, g=15, levels.mean=TRUE)
    prop <- qlogis(tapply(tvdlm, x, mean, na.rm=TRUE))
    xm <- as.numeric(names(prop))
    lpoints(xm, prop, pch=2, col='green')
  } )   # Figure (*\ref{fig:lrm-dur}*)
plot(Predict(f, cad.dur), addpanel=w)

## @knitr problog
f <- lrm(tvdlm ~ log10(cad.dur + 1), data=dz)
w <- function(...)
  with(dz, {
    x <- cut2(cad.dur, m=150, levels.mean=TRUE)
    prop <- tapply(tvdlm, x, mean, na.rm=TRUE)
    xm <- as.numeric(names(prop))
    lpoints(xm, prop, pch=2, col='green')
  } )
#   Figure (*\ref{fig:lrm-problog}*)
plot(Predict(f, cad.dur, fun=plogis), ylab='P',
     ylim=c(.2, .8), addpanel=w)

## @knitr acath
acath <- transform(acath,
                   cholesterol = choleste,
                   age.tertile = cut2(age,g=3),
                   sx = as.integer(acath$sex) - 1)
# sx for loess, need to code as numeric
dd <- datadist(acath); options(datadist='dd')

# First model stratifies age into tertiles to get more
# empirical estimates of age x cholesterol interaction

f <- lrm(sigdz ~ age.tertile*(sex + rcs(cholesterol,4)),
         data=acath)
f
ltx(f)

## @knitr cholxage
print(anova(f), caption='Crudely categorizing age into tertiles',
      size='smaller')
yl <- c(-1,5)
plot(Predict(f, cholesterol, age.tertile),
     adj.subtitle=FALSE, ylim=yl)   # Figure (*\ref{fig:lrm-cholxage}*)

## @knitr iacholxage-loess
# Re-do model with continuous age
f <- loess(sigdz ~ age * (sx + cholesterol), data=acath,
           parametric="sx", drop.square="sx")
ages  <- seq(25,   75, length=40)
chols <- seq(100, 400, length=40)
g <- expand.grid(cholesterol=chols, age=ages, sx=0)
# drop sex dimension of grid since held to 1 value
p <- drop(predict(f, g))
p[p < 0.001] <- 0.001
p[p > 0.999] <- 0.999
zl <- c(-3, 6)   # Figure (*\ref{fig:lrm-iacholxage-loess}*)
wireframe(qlogis(p) ~ cholesterol*age,
          xlab=list(rot=30), ylab=list(rot=-40),
          zlab=list(label='log odds', rot=90), zlim=zl,
          scales = list(arrows = FALSE), data=g)

## @knitr iacholxage-lsp
f <- lrm(sigdz ~ lsp(age,c(46,52,59)) *
         (sex + lsp(cholesterol,c(196,224,259))),
         data=acath)
ltx(f)
print(anova(f), caption='Linear spline surface',
      size='smaller')
perim <- with(acath,
              perimeter(cholesterol, age, xinc=20, n=5))
zl <- c(-2, 4)   # Figure (*\ref{fig:lrm-iacholxage-lsp}*)
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)

## @knitr iacholxage-1
f <- lrm(sigdz ~ rcs(age,4)*(sex + rcs(cholesterol,4)),
         data=acath, tol=1e-11)
ltx(f)
print(anova(f), caption='Cubic spline surface',
      size='smaller')
# Figure (*\ref{fig:lrm-iacholxage-1}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)

## @knitr iacholxage-2
f <- lrm(sigdz ~ sex*rcs(age,4) + rcs(cholesterol,4) +
         rcs(age,4) %ia% rcs(cholesterol,4), data=acath)
print(anova(f), size='smaller',
      caption='Singly nonlinear cubic spline surface')
# Figure (*\ref{fig:lrm-iacholxage-2}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)
ltx(f)

## @knitr iacholxage-3
f <- lrm(sigdz ~ rcs(age,4)*sex + rcs(cholesterol,4) +
         age %ia% cholesterol, data=acath)
print(anova(f), caption='Linear interaction surface',
      size='smaller')
# Figure (*\ref{fig:lrm-iacholxage-3}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)
f.linia <- f  # save linear interaction fit for later
ltx(f)

## @knitr cholxage-model
# Make estimates of cholesterol effects for mean age in
# tertiles corresponding to initial analysis
mean.age <-
  with(acath,
       as.vector(tapply(age, age.tertile, mean, na.rm=TRUE)))
plot(Predict(f, cholesterol, age=round(mean.age,2),
             sex="male"),
     adj.subtitle=FALSE, ylim=yl) #3 curves, Figure (*\ref{fig:lrm-cholxage-model}*)

## @knitr dur-partial-resid
f <- lrm(tvdlm ~ cad.dur, data=dz, x=TRUE, y=TRUE)
resid(f, "partial", pl="loess", xlim=c(0,250), ylim=c(-3,3))
scat1d(dz$cad.dur)
log.cad.dur <- log10(dz$cad.dur + 1)
f <- lrm(tvdlm ~ log.cad.dur, data=dz, x=TRUE, y=TRUE)
resid(f, "partial", pl="loess", ylim=c(-3,3))
scat1d(log.cad.dur)   # Figure (*\ref{fig:lrm-dur-partial-resid}*)

## @knitr asr-influence
f <- update(fasr, x=TRUE, y=TRUE, data=sex.age.response)
## Also try which.influence(f, .4)
round(resid(f, 'dfbetas'), 1)   # Table (*\ref{table:dfbetas}*)

## @knitr sex-age-response-boot
d <- sex.age.response
dd <- datadist(d); options(datadist='dd')
f <- lrm(response ~ sex + age, data=d, x=TRUE, y=TRUE)
set.seed(3)  # for reproducibility
v1  <- validate(f, B=150)

## @knitr sex-age-response-booth
ap1 <- round(v1[,'index.orig'], 2)
bc1 <- round(v1[,'index.corrected'], 2)

## @knitr sex-age-response-bootp
latex(v1,
      caption='Bootstrap Validation, 2 Predictors Without Stepdown',
      insert.bottom='\\label{pg:lrm-sex-age-response-boot}',
      digits=2, size='Ssize', file='')

## @knitr sex-age-response-bootsw
v2 <- validate(f, B=150, bw=TRUE,
               rule='p', sls=.1, type='individual')

## @knitr sex-age-response-bootswh
ap2 <- round(v2[,'index.orig'], 2)
bc2 <- round(v2[,'index.corrected'], 2)

## @knitr sex-age-response-bootswp
latex(v2,
      caption='Bootstrap Validation, 2 Predictors with Stepdown',
      digits=2, B=15, file='', size='Ssize')

## @knitr sex-age-response-bootsw5
set.seed(133)
n  <- nrow(d)
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
x4 <- runif(n)
x5 <- runif(n)
f  <- lrm(response ~ age + sex + x1 + x2 + x3 + x4 + x5,
          data=d, x=TRUE, y=TRUE)
v3 <- validate(f, B=150, bw=TRUE,
               rule='p', sls=.1, type='individual')

## @knitr sex-age-response-bootsw5v
k <- attr(v3, 'kept')
# Compute number of x1-x5 selected
nx <- apply(k[,3:7], 1, sum)
# Get selections of age and sex
v <- colnames(k)
as <- apply(k[,1:2], 1,
            function(x) paste(v[1:2][x], collapse=', '))
table(paste(as, ' ', nx, 'Xs'))

## @knitr sex-age-response-bootsw5ph
ap3 <- round(v3[,'index.orig'], 2)
bc3 <- round(v3[,'index.corrected'], 2)

## @knitr sex-age-response-bootsw5p
latex(v3,   # (*\label{pg:lrm-sw5p}*)
 caption='Bootstrap Validation with 5 Noise Variables and Stepdown',
 digits=2, B=15, size='Ssize', file='')

## @knitr sex-age-response-bootsw52
v4 <- validate(f, B=150, bw=TRUE, rule='p', sls=.1,
               type='individual', force=1:2)
ap4 <- round(v4[,'index.orig'], 2)
bc4 <- round(v4[,'index.corrected'], 2)

## @knitr sex-age-response-bootsw52p
latex(v4,
      caption='Bootstrap Validation with 5 Noise Variables and Stepdown, Forced Inclusion of age and sex',
      digits=2, B=15, size='Ssize')

## @knitr calibrations
g <- function(v) v[c('Intercept','Slope'),'index.corrected']
k <- rbind(g(v1), g(v2), g(v3))
co <- c(2,5,4,1)
plot(0, 0, ylim=c(0,1), xlim=c(0,1),
     xlab="Predicted Probability",
     ylab="Estimated Actual Probability", type="n")
legend(.45,.35,c("age, sex", "age, sex stepdown",
                 "age, sex, x1-x5", "ideal"),
       lty=1, col=co, cex=.8, bty="n")
probs <- seq(0, 1, length=200); L <- qlogis(probs)
for(i in 1:3) {
  P <- plogis(k[i,'Intercept'] + k[i,'Slope'] * L)
  lines(probs, P, col=co[i], lwd=1)
}
abline(a=0, b=1, col=co[4], lwd=1)   # Figure (*\ref{fig:lrm-calibrations}*)

## @knitr cholxage-confbar
s <- summary(f.linia)
print(s, size='Ssize')
plot(s)   # Figure (*\ref{fig:lrm-cholxage-confbar}*)

## @knitr iacholxage-3-nomogram
# Draw a nomogram that shows examples of confidence intervals
nom <- nomogram(f.linia, cholesterol=seq(150, 400, by=50),
                interact=list(age=seq(30, 70, by=10)),
                lp.at=seq(-2, 3.5, by=.5),
                conf.int=TRUE, conf.lp="all",
                fun=function(x)1/(1+exp(-x)),  # or plogis
                funlabel="Probability of CAD",
                fun.at=c(seq(.1, .9, by=.1), .95, .99)
                )   # Figure (*\ref{fig:lrm-iacholxage-3-nomogram}*)
plot(nom, col.grid = gray(c(0.8, 0.95)),
     varname.label=FALSE, ia.space=1, xfrac=.46, lmgp=.2)

## @knitr val-prob
set.seed(13)
n <- 200
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
logit <- 2*(x1-.5)
P <- 1/(1+exp(-logit))
y <- ifelse(runif(n) <= P, 1, 0)
d <- data.frame(x1, x2, x3, y)
f <- lrm(y ~ x1 + x2 + x3, subset=1:100)
phat <- predict(f, d[101:200,], type='fitted')
# Figure (*\ref{fig:lrm-val-prob}*)
v <- val.prob(phat, y[101:200], m=20, cex=.5)

## Bayesian analysis

## @knitr bayes-bin_mods
dd <- datadist(sex.age.response)
options(datadist = 'dd')
require(brms)

# Frequentist model
fit_lrm <- lrm(response ~ sex + age, data=sex.age.response)

# Bayesian model
# Distribute chains across cpu cores:
options(mc.cores=parallel::detectCores())

# Set priors
# Solve for SD such that sex effect has only a 0.025 chance of
# being above 5 (or being below -5)

s1 <- 5 / qnorm(0.975)

# Solve for SD such that 10-year age effect has only 0.025 chance
# of being above 20

s2 <- (20 / qnorm(0.975)) / 10   # divide by 10 since ratio on 10b scale

stanvars <- stanvar(s1, name='s1') + stanvar(s2, name='s2')

prs <- c(prior(student_t(3,0,10), class='Intercept'),
         prior(normal(0, s1), class='b', coef='sexmale'),
         prior(normal(0, s2), class='b', coef='age'))

# Full model
fit_brms <- brm(response ~ sex + age, data=sex.age.response,
                family=bernoulli("logit"), prior=prs, iter=5000,
                stanvars=stanvars)

## @knitr bayes-bin_fits
# Frequentist model output
fit_lrm

summary(fit_lrm, age=20:21)

## @knitr bayes-bin_fits2
# Bayesian model output
post_samps <- posterior_samples(fit_brms, c("age","sex"))

fit_brms
posterior_interval(fit_brms, c("age","sex"))
prior_summary(fit_brms)

## @knitr bayes-post_plt
# display posterior densities for age and sex parameters
plot(fit_brms, c("age","sex"), combo=c("dens","trace","hex"))

## @knitr bayes-margeff
# Marginal effects plot
plot(conditional_effects(fit_brms, "age:sex"))

## @knitr bayes-biv
# Frequentist
# variance-covariance for sex and age parameters
sex_age_vcov <- vcov(fit_lrm)[2:3,2:3]

# Sampling based parameter estimate correlation coefficient
f_cc <- sex_age_vcov[1,2] / (sqrt(sex_age_vcov[1,1]) * sqrt(sex_age_vcov[2,2]))

# Bayesian
# Linear correlation between params from posterior
b_cc <- cor(post_samps)[1,2]

## @knitr bayes-postprobs
# Define P() as mean() just to provide a nice notation for
# computing posterior probabilities
P <- function(x) mean(x)
b1 <- post_samps[, 'b_sexmale']
b2 <- post_samps[, 'b_age']
(p1 <- P(b1 > 0))   # post prob(sex has positive association with Y)
(p2 <- P(b2 > 0))
(p3 <- P(b1 > 0 & b2 > 0))
(p4 <- P(b1 > 0 | b2 > 0))

## @knitr bayes-bidens
ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  theme(legend.position="none")

## @knitr bayes-MAP
# Calculate MAP interval
# Code from http://www.sumsar.net/blog/2014/11/how-to-summarize-a-2d-posterior-using-a-highest-density-ellipse/
samples <- as.matrix(post_samps)
coverage = 0.95
fit <- MASS::cov.mve(samples, quantile.used = round(nrow(samples) * coverage))
points_in_ellipse <- samples[fit$best,]
ellipse_boundary <- predict(cluster::ellipsoidhull(points_in_ellipse))
map <- data.frame(ellipse_boundary)
names(map) <- c("y","x")

ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  geom_polygon(data = map, aes(x=x,y=y), color = "grey", alpha = 0) +
  geom_point(aes(x = fixef(fit_brms)[,1][2], y = fixef(fit_brms)[,1][3]), color = "grey") +
  theme(legend.position="none")

## @knitr bayes-ellipse
# Function takes in variance-covariance matrix (D), point estimates (d),
# and a level of significance (alpha)
EllipseDF <- function(D, d, alpha = 0.05) {
  delta = sqrt(eigen(D)$values)
  # Root eigenvalues correspond to the half-lengths of the ellipse
  V = eigen(D)$vectors
  # Eigenvectors give the axes of the confidence ellipse
  R = sqrt(qchisq(1-alpha, df = length(delta)))
  # Scaling factor to get to 0.95 confidence
  a = R*delta[1] # scale the ellipse axes
  b = R*delta[2]
  t <- seq(0, 2*pi, length.out=200)
  # Generate radian measures from 0 to 2pi
  points.proj = V %*% t(cbind(a * cos(t), b * sin(t)))
  # Transform circle into ellipse
  return(data.frame(x = (points.proj)[1, ] + d[1],
                    y = (points.proj)[2, ] + d[2]))
}

D <- vcov(fit_lrm)[-1,-1]
beta <- coef(fit_lrm)[-1]
ci_ellipse <- EllipseDF(D, beta, alpha = 0.05)

ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  geom_polygon(data = map, aes(x=x,y=y), color = "grey", alpha = 0) +
  geom_polygon(data = ci_ellipse, aes(x = x,y = y), color = "red", alpha = 0) +
  geom_point(aes(x = fixef(fit_brms)[,1][2], y = fixef(fit_brms)[,1][3]), color = "grey") +
  geom_point(aes(x = coef(fit_lrm)[2], y = coef(fit_lrm)[3]), color = "red") +
  theme(legend.position="none")


##### 医学統計勉強会18第6回ロジスティック回帰分析　R code #####

### Low Infant Birth Weightデータの準備 ###

library(MASS)
data(birthwt)
head(birthwt, n=2)

birthwt2 <- birthwt[, -10]		# bwt: 出生体重を除く
birthwt2$race <- factor(birthwt2$race, label=c("white", "black", "other"))	# 因子型に変換し、水準のラベルを1, 2, 3から、white, black, otherに変更する。
birthwt2$ptl[birthwt2$ptl >= 1] <- "1+"		# ptl: 1以上の値を "1+" とする。
birthwt2$ftv[birthwt2$ftv >= 1] <- "1+"		# ftv: 1以上の値を "1+" とする。
head(birthwt2, n=2)

attach(birthwt2)	# birthwt2に含まれる変数を、個別に扱えるようにする。

### 連続説明変数の要約 ###
summary(age)
summary(lwt)

sd(age); IQR(age)
sd(lwt); IQR(lwt)

## boxplot ##
boxplot(age ~ low)
p <- t.test(age ~ low)$p.value	# Welch's t-test p-value
p <- round(p, 3)				# 小数点以下第3位まで四捨五入
boxplot(age ~ low, main="age", sub=paste("Welch's t-test p =", p))

boxplot(lwt ~ low)
p <- t.test(lwt ~ low)$p.value	# Welch's t-test p-value
p <- round(p, 3)				# 小数点以下第3位まで四捨五入
boxplot(lwt ~ low, main="lwt", sub=paste("Welch's t-test p =", p))

## scatter plot ##
plot(age, lwt)
x1 <- cov(age, lwt); x1 <- round(x1, 3)		# 共分散
x2 <- cor(age, lwt); x2 <- round(x2, 3)		# 相関係数
plot(age, lwt, pch = 16, sub=paste("cov =", x1, ": cor =", x2))

### 離散説明変数の要約 ###
tbl <- table(low, race)
print(tbl)
fisher.test(tbl)

tbl <- table(low, smoke)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ptl)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ht)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ui)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ftv)
print(tbl)
fisher.test(tbl)

### logistic regression ###

fit <- glm(low ~ age + lwt + race + smoke + ptl + ht + ui + ftv, family=binomial, data=birthwt2)
summary(fit)

## 係数の信頼区間 ##
confint(fit)

## オッズ比の信頼区間 ##
exp(confint(fit))

## イベントの予測確率 ##
fit$fitted

### goodness of fit test for logistic regression ###

## Hosmer-Lemeshow検定 ##
install.packages("ResourceSelection")	# 初回のみ
library(ResourceSelection)
hl <- hoslem.test(low, fit$fitted, g=10)

## ROC曲線とAUC ##
library(pROC)
tbl.roc <- roc(low, fit$fitted)
plot(tbl.roc, print.auc=TRUE, print.thres=TRUE)				# ROC曲線の描画
opt.sp <- tbl.roc$sp[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な特異度
opt.se <- tbl.roc$se[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な感度
abline((opt.sp+opt.se), -1)		# 最適なカットポイントを通る45度線

## 変数選択 ##
library(MASS)
fit.aic1 <- stepAIC(fit, direction="backward")			# backward elimination #
summary(fit.aic1)

fit0 <- glm(low ~ 1, family=binomial, data=birthwt2)	# forward selection #
fit.aic2 <- stepAIC(fit0, direction="forward", scope=list(upper=fit, lower=fit0))
summary(fit.aic2)

fit.aic3 <- stepAIC(fit0, direction="both", scope=list(upper=fit, lower=fit0))	# both #
summary(fit.aic3)

### Generalized Additive Model ###
install.packages("mgcv")	# 初回のみ
library(mgcv)
fit.gam <- gam(low ~ s(age) + s(lwt) + race + smoke + ptl + ht + ui, family=binomial, data=birthwt2)
summary(fit.gam)

par(mfrow=c(1,2))
plot(fit.gam)

## additive model ##
fit.gam2 <- gam(lwt ~ s(age), family=gaussian, data=birthwt2)

summary(fit.gam2)

plot(age, lwt)

ord <- order(age)

lines(age[ord], fit.gam2$fitted[ord], col="red", lwd=2)

fit.lm <- lm(lwt ~ age, data=birthwt2)

summary(fit.lm)

lines(age[ord], fit.lm$fitted[ord], col="green", lwd=2)


#
# # modified to get quantile function
# # this code is not efficient but should be OK for case of
# #  pair-copulas all permutation symmetric
#
# # Different copula family for each edge
# # nsim = #replications or sample size
# # parvec = vector of parameters to be optimized in nllk
# # A = dxd vine array with 1:d on diagonal
# # ntrunc = truncated level, assume >=1
# # pcondmat = matrix of names of conditional cdfs for trees 1,...,ntrunc
# #  (assuming only one needed for permutation symmetric pair-copulas)
# # qcondmat = matrix of names of conditional quantile functions for
# #        trees 1,...,ntrunc
# #   pcondmat and qcondmat are empty for diagonal and lower triangle,
# #    and could have ntrunc rows or be empty for rows ntrunc+1 to d-1
# # np = dxd where np[ell,j] is #parameters for parameter th[ell,j]
# #   for pair-copula in tree ell, variables j and A[ell,j]
# #   np=0 on and below diagonal
# # iinv=T to check that this is inverse of rvinepcond()
# #    in this case, columns of pmat come from rvinepcond()
# # iinv=F, get quantiles C_{d|1:(d-1)}(p|u[1:(d-1)]) based on last column of
# #       pmat[,d] where u[1],..,u[d-1] have been previously converted to
# #       u[1], C_{2|1}(u[2]|u[1]), ... C_{d-1|1:(d-2)}(u[d-1]|u[1:(d-2)])
# #       via rvinepcond()
# ## Output: nsim x d matrix with values in (0,1) or
# #        quantile C_{d|1...d-1}(p| u1,...,u[d-1])
# #rvinesimvec2=function(nsim,A,ntrunc,parvec,np,qcondmat,pcondmat,iprint=F)
# temrvineqcond=function(pmat,A,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# { d=ncol(A)
#   # get matrix ip1,ip2 of indices
#   ii=0
#   ip1=matrix(0,d,d); ip2=matrix(0,d,d)
#   for(ell in 1:ntrunc)
#   { for(j in (ell+1):d)
#     { ip1[ell,j]=ii+1; ip2[ell,j]=ii+np[ell,j]
#       ii=ii+np[ell,j]
#     }
#   }
#   #if(iprint) { print(ip1); print(ip2) }
#   out=varray2M(A)
#   M=out$mxarray
#   icomp=out$icomp
#   #p=matrix(runif(nsim*d),nsim,d)
#   p=pmat
#   nsim=nrow(p)
#   qq=array(0,c(nsim,d,d)); v=array(0,c(nsim,d,d))
#   u=matrix(0,nsim,d)
#   u[,1]=p[,1]; qq[,1,1]=p[,1]; qq[,2,2]=p[,2];
#   qcond=match.fun(qcondmat[1,2])
#   u[,2]=qcond(p[,2],p[,1],parvec[ip1[1,2]:ip2[1,2]])
#   qq[,1,2]=u[,2]
#   if(icomp[1,2]==1)
#   { #pcond=match.fun(pcondnames[1])
#     pcond=match.fun(pcondmat[1,2])
#     v[,1,2]=pcond(u[,1],u[,2],parvec[ip1[1,2]:ip2[1,2]])
#   }
#   # the main loop
#   for(j in 3:d)  # variable
#   { tt=min(ntrunc,j-1)
#     qq[,tt+1,j]=p[,j]
#     if(tt>1)
#     { for(ell in seq(tt,2)) # tree
#       { if(A[ell,j]==M[ell,j]) { s= qq[,ell,A[ell,j]] }
#         else { s=v[,ell-1,M[ell,j]] }
#         #qcond=match.fun(qcondnames[ell])
#         qcond=match.fun(qcondmat[ell,j])
#         qq[,ell,j]=qcond(qq[,ell+1,j], s, parvec[ip1[ell,j]:ip2[ell,j]]);
#       }
#     }
#     #qcond=match.fun(qcondnames[1])
#     qcond=match.fun(qcondmat[1,j])
#     qq[,1,j]=qcond(qq[,2,j],u[,A[1,j]], parvec[ip1[1,j]:ip2[1,j]])
#     u[,j]=qq[,1,j]
#     # set up for next iteration (not needed for last j=d)
#     #pcond=match.fun(pcondnames[1])
#     pcond=match.fun(pcondmat[1,j])
#     v[,1,j]=pcond(u[,A[1,j]],u[,j],parvec[ip1[1,j]:ip2[1,j]])
#     if(tt>1)
#     { for(ell in 2:tt)
#       { if(A[ell,j]==M[ell,j]) { s=qq[,ell,A[ell,j]] }
#         else { s=v[,ell-1,M[ell,j]] }
#         if(icomp[ell,j]==1)
#         { #pcond=match.fun(pcondnames[ell])
#           pcond=match.fun(pcondmat[ell,j])
#           v[,ell,j]=pcond(s, qq[,ell,j], parvec[ip1[ell,j]:ip2[ell,j]]);
#         }
#       }
#     }
#   }
#   if(iinv) u=u[,d]
#   u
# }
#
# #============================================================
#
# library(CopulaModel)
# source("hjcondvine.R")
# d=5
# np=matrix(1,d,d)
# ntrunc=4
# udat=matrix(c(.1,.2,.3,.4,.5, .6,.7,.8,.9,.5),2,5,byrow=T)
# parvec=c(2,2,2,2,1.5,1.5,1.5,1.2,1.2,1.1)
# D5=Dvinearray(d)
# pcondmat=matrix("pcondgum",d,d)
# qcondmat=matrix("qcondgum",d,d)
#
# pmatd=rvinepcond(parvec,udat,D5,ntrunc,pcondmat,np)
# print(pmatd)
#
# #rvineqcond=function(pmat,A,ntrunc,parvec,np,qcondmat,pcondmat,iprint=F)
#
# qmatd=temrvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd) # same as udat
#
# q5=temrvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5)
# # [1] 0.5 0.5
# pnewd=pmatd; pnewd[,d]=0.9
# q5b=temrvineqcond(pnewd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5b)
# # [1] 0.5227173 0.8994989
#
# # direct approach
# ntrunc=4
# pcond=pcondgum
# qcond=qcondgum
# parm=matrix(0,d,d) # format of parameter for vine
# ii=0;
# for(ell in 1:ntrunc)
# { for(j in (ell+1):d)
#   { parm[ell,j]=parvec[ii+1]
#     ii=ii+1
#   }
# }
#
# # compared with specific case for dvine
# pdchk=udat
# pdchk[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# tem12=pcond(udat[,1],udat[,2],parm[1,2])
# tem32=pcond(udat[,3],udat[,2],parm[1,3])
# pdchk[,3]=pcond(tem32,tem12,parm[2,3])
# tem1g23=pcond(tem12,tem32,parm[2,3])
# tem23=pcond(udat[,2],udat[,3],parm[1,3])
# tem43=pcond(udat[,4],udat[,3],parm[1,4])
# tem4g23=pcond(tem43,tem23,parm[2,4])
# pdchk[,4]=pcond(tem4g23,tem1g23,parm[3,4])
# tem1g234=pcond(tem1g23,tem4g23,parm[3,4])
# tem34=pcond(udat[,3],udat[,4],parm[1,4])
# tem54=pcond(udat[,5],udat[,4],parm[1,5])
# tem5g34=pcond(tem54,tem34,parm[2,5])
# tem2g34=pcond(tem23,tem43,parm[2,4])
# tem5g234=pcond(tem5g34,tem2g34,parm[3,5])
# pdchk[,5]=pcond(tem5g234,tem1g234,parm[4,5])
# # quantiles at .9
# p=rep(.9,2)
# s2=qcond(p,tem1g234,parm[4,5])
# s3=qcond(s2,tem2g34,parm[3,5])
# s4=qcond(s3,tem34,parm[2,5])
# s5=qcond(s4,udat[,4],parm[1,5])
# print(s5)
# # 1] 0.5227173 0.8994989
#
# #============================================================
#
# # truncated vines
#
# # ntrunc=2
# pmatd2=rvinepcond(parvec,udat,D5,2,pcondmat,np)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.7430672 0.76377507
# #[2,]  0.6 0.7328919 0.8830648 0.9508236 0.08757126
# qmatd2=temrvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd2) # same as udat
# q52=temrvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52)
# # [1] 0.5 0.5
# pnewd=pmatd2; pnewd[,d]=0.9
# q52b=temrvineqcond(pnewd,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52b)
# # [1] 0.6190225 0.9281953
#
# # ntrunc=1
# pmatd1=rvinepcond(parvec,udat,D5,1,pcondmat,np)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.5364857 0.5842195 0.63198274
# #[2,]  0.6 0.7328919 0.7951641 0.8831572 0.08282512
# qmatd1=temrvineqcond(pmatd1,D5,1,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd1) # same as udat
# q51=temrvineqcond(pmatd1,D5,1,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q51)
# # [1] 0.5 0.5
# pnewd=pmatd1; pnewd[,d]=0.9
# q51b=temrvineqcond(pnewd,D5,1,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q51b)
# # [1] 0.7332716 0.9529803
#


=begin
[((<index-ja|URL:index-ja.html>))]

= AlgebraicExtensionField
((*(代数拡大体)*))

代数拡大体を表現するクラス

== ファイル名:
* ((|algebraic-Extension-feild.rb|))

== スーパークラス:

* ((|ResidueClassRing|))

== インクルードしているモジュール:

なし。

== 関連するメソッド:

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    ((<::create>)) と同じ。

== クラスメソッド:

--- ::create(k, obj){|x| p(x) }
    体 ((|k|)) を、((|obj|)) で表される変数 ((|x|)) の多項式
    ((|p(x)|)) で拡大した環 ((|k[x]/(p(x))|))を返します。
    この環には、クラスメソッド ((<::var>))、((<::def_polys>))、
    ((<::env_ring>)) が定義されます。

    例: 有理数を方程式 (({x**2 + x + 1 == 0})) で拡大した体 F を作る。
      require "rational"
      require "algebraic-extension-field"
      F = Algebra::AlgebraicExtensionField.create(Rational, "x") {|x| x**2 + x + 1}
      x = F.var
      p( (x-1)** 3 / (x**2 - 1) ) #=> -3x - 3

--- ::to_ary
    (({[self, var]})) を返します。

    例: 代数拡大体と添加元を同時に定義する
      require "rational"
      require "algebraic-extension-field"
      F, a = Algebra.AlgebraicExtensionField(Rational, "a") {|a| a**2 + a + 1}

--- ::var
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    この剰余環における ((|x|)) で
    代表される剰余類を返します。

--- ::modulus
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、((|k[x]|))
    の要素 ((|p(x)|))  を返します。

--- ::def_polys
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    長さ ((|n|)) の各 ((<::modulus>)) の配列を返します。
    ここで、自身は、基礎体 ((|k0|)) 上高さ ((|n|)) の
    再帰的な ((|AlgebraicExtensionField|)) であるとします。

    例: 基礎体を有理数とし、2, 3, 5 の立方根による拡大体を作る
      require "algebra"
      # K0 == Rational
      K1 = AlgebraicExtensionField(Rational, "x1") { |x|
        x ** 3 - 2
      }
      K2 = AlgebraicExtensionField(K1, "x2") { |y|
        y ** 3 - 3
      }
      K3 = AlgebraicExtensionField(K2, "x3") { |z|
        z ** 3 - 5
      }

      p K3.def_polys #=> [x1^3 - 2, x2^3 - 3, x3^3 - 5]

      x1, x2, x3 = K1.var, K2.var, K3.var
      f = x1**2 + 2*x2**2 + 3*x3**2
      f0 = f.abs_lift

      p f0.type     #=> (Polynomial/(Polynomial/(Polynomial/Rational)))
      p f0.type == K3.env_ring #=> true

      p f #=> 3x3^2 + 2x2^2 + x1^2
      p f0.evaluate(x3.abs_lift, x2.abs_lift, x1.abs_lift)
          #=> x3^2 + 2x2^2 + 3x3^2

--- ::env_ring
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    多変数多項式環 ((|k0[x1, x2,.., xn]|)) を返します。
    ここで、自身は、基礎体 ((|k0|)) 上高さ ((|n|)) の
    再帰的な ((|AlgebraicExtensionField|)) であるとします。

--- ::ground
    剰余環のもとになる多項式環 ((|k[x]|)) を返します。

== メソッド
--- abs_lift
    ((<::env_ring>)) すなわち基礎体 ((|k0|)) 上
    の多変数多項式環 ((|k0[x1, x2,.., xn]|))
    へのリフトを返します。

--- [](n)
    ((<n>)) 次の係数を返します。(({lift[n]})) と同じです。

    例: Fibonacci 数列
      require "algebra"
      t = AlgebraicExtensionField(Integral, "t"){|x| x**2-x-1}.var
      (0..10).each do |n|
        p( (t**n)[1] ) #=> 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55
      end

=end


# Pvec if the vector of probabilities predicted by your model
# Cvec is the vector of 0's and 1's indicating the realized
# classifications of each observation.

ROCPlot <- function(Pvec,Cvec,Plot=T,Add=F) {
  NHam <- sum(Cvec==0)
  NSpam <- sum(Cvec==1)
  PvecS <- unique(sort(Pvec))
  x <- rep(NA,length(PvecS))
  y <- rep(NA,length(PvecS))
  for(i in 1:length(PvecS)) {
    x[i] <- sum(Pvec>=PvecS[i]&Cvec==0)/NHam
    y[i] <- sum(Pvec>=PvecS[i]&Cvec==1)/NSpam
  }
  x <- c(0,x,1)
  y <- c(0,y,1)
  ord <- order(x)
  x <- x[ord]
  y <- y[ord]

  AUC <- sum((x[2:length(x)]-x[1:(length(x)-1)])*(y[2:length(y)]+y[1:(length(y)-1)])/2)

  if(Add) {
    plot(x,y,type="l",xlim=c(0,1),ylim=c(0,1),xlab="P( classified + | Is - )",ylab="P( classified + | Is + )")
    title("ROC Curve")
    mtext(paste("AUC =",round(AUC,3)),side=3,line=0.5)
    abline(0,1)
    par(pty="m")
  } else {
    if(Plot) {
      par(pty="s")
      plot(x,y,type="l",xlim=c(0,1),ylim=c(0,1),xlab="P( classified + | Is - )",ylab="P( classified + | Is + )")
      title("ROC Curve")
      mtext(paste("AUC =",round(AUC,3)),side=3,line=0.5)
      abline(0,1)
      par(pty="m")
    }
  }

  invisible(list(x=c(0,x,1),y=c(0,y,1),AUC=AUC))
}


john_z <- function(x, parms) {
    ## transform x values to z which is normally distributed if Johnson distribution
    ## x can be one value or a set of values
    ## parms is the set of parameters from SuppDists::JohnsonFit on the entire dataset
    u <- (x - parms$xi) / parms$lambda
    type <- parms$type
    if (type == 'SU') {
        ## unbounded distribution
        fu <- u + (1 + u^2)^0.5
    } else if (type == 'SL') {
        ## log normal
        fu <- u
    } else if (type == 'SB') {
        ## bounded distribution
        fu <- u / (1-u)
    } else if (type == 'SN') {
        ## normal distribution
        fu <- exp(u)
    } else {
        cat('\n')
        cat('#####################################\n')
        cat('  ERROR IN JOHNSON_TOL         \n')
        cat('  no type returned from fit attempt  \n')
        cat('#####################################\n')
        print(jparms)
        ## stop()
    }
    ## z is normally distributed
    z    <- parms$gamma + parms$delta * log(fu)
    return(z)
}


### Illustrates the piece-wise linear approximation of the cumulative distribution using constant size bins
fade = rgb(0,0,0,alpha=0.5)
dot.size = 0.7
n = 10000
set.seed(5)

pdf("linear-interpolation.pdf", width=6, height=2.7, pointsize=10)
layout(matrix(c(1,2),byrow=T, ncol=2), widths=c(1.1,1))
u = sort(runif(n))
x = log(1-u)
x = sort(x)
F = ((0:(n-1))+0.5)/n
par(mar=c(2.5,3,0.5,1))
plot(x, F, cex=dot.size, pch=21, bg=fade, col=NA, type='b', xlim=c(-9,-4.5), ylim=c(0,0.01), xaxt='n', ylab=NA, mgp=c(1,0.5,0), xlab=NA)

axis(side=1, at=-10:-1, labels=NA)
title(xlab='x', line=0.8, cex.lab=1.5)
title(ylab='q', line=1.5, cex.lab=1.5)

left.end = x[1] - (x[2]-x[1])

lines(c(left.end, x[100]), c(0, 0.01), lwd=2)
lines(c(left.end, left.end), c(-0.0005, 0.0005), lt=1, col='black', lwd=0.5)
lines(c(x[100], x[100]), c(0.0085, 0.015), lt=1, col='black', lwd=0.5)
text(-7, 0.006, "100")

###text(-5, 0.4, adj=0, "Constant size bins result in large")
###text(-5, 0.35, adj=0, "errors at extreme quantiles")

par(mar=c(2.5,1.5,0.5,1))

plot(x, F, cex=dot.size, pch=21, bg=fade, col=NA, type='b', xlim=c(-9,-4.5), ylim=c(0,0.01), yaxt='n', xaxt='n')
axis(side=1, at=-10:-1, labels=NA)
axis(side=2, at=(0:6)/10, labels=NA)
title(xlab='x', line=0.8, cex.lab=1.5)
title(ylab='q', line=2, cex.lab=1.5)

q.to.k = function(q) {
    (asin(2*q-1)/pi + 1/2)
}

k.to.q = function(k,compression) {
    sin(k/compression*pi - pi/2)/2 + 0.5
}

weights = c(2, 8, 19, 35, 56, 81, 111)
q.bin = cumsum(c(0, weights)/n)

i.bin = c(1, cumsum(weights)+1)
i.right = i.bin-1
i.right = i.right[i.right > 0]
m = length(i.right)
i.bin = i.bin[1:m]

x.bin = c(left.end, (x[i.right[1:(m-1)]] + x[i.bin[2:m]])/2)
F.bin = (i.bin-1) / n
lines(x.bin, F.bin, lwd=2)
dy = 0.0005
for (i in 1:m) {
    x.text = (x[i.bin[i]] + x[i.right[i]])/2
    y.text = (F.bin[i] + F.bin[i+1])/2
    x.offset = 0.3 * y.text
    y.offset = dy * (1 + 500*y.text)
    x.pos = x.text - x.offset
    y.pos = y.text + y.offset
    lines(c(x.bin[i],x.bin[i]), c(F.bin[i]-dy+0.000, F.bin[i]+dy+y.offset*0.6-0.0005), lt=1, lwd=0.5, col='black')
    text(x.text - x.offset, y.text + y.offset, i.right[i]-i.bin[i]+1)
}
###text(-5, 0.35, adj=0, "Variable size bins keep errors")
###text(-5, 0.3, adj=0, "small at extreme quantiles")

dev.off()


#' Simulate variable based on the influences of other variables
#'
#' I need a function that takes some variables, and an effect size for each of them, and this creates a new variable where y = Xb + e, where X is the matrix of independent variables, b is their effect sizes, and e is a noise term. By default it's easier if b relates to the variance explained by each vector in X, and e has variance of 1 - sum(b).
#'
#' @param effs An array of effect sizes that the variables in indep have on the variable that you are simulating
#' @param indep A matrix of variables, rows = Samples and columns = variables that have an influence on the variable that you are simulating
#' @param vy What variance the output should have. Default = 1, meaning effs relate to the signed rsq of the influence of the indep variables on the outcome
#' @param vx What variance the indep variables should have. Default is to set to 1, meaning that the effects are the signed variance explained
#' @param my mean value of y to be output
#'
#' @export
#' @return Vector of y values
make_phen <- function(effs, indep, vy=1, vx=rep(1, length(effs)), my=0)
{
	if(is.null(dim(indep))) indep <- cbind(indep)
	stopifnot(ncol(indep) == length(effs))
	stopifnot(length(vx) == length(effs))
	cors <- effs * vx / sqrt(vx) / sqrt(vy)
	sc <- sum(cors^2)
	if(sc >= 1)
	{
		print(sc)
		stop("effects explain more than 100% of variance")
	}
	cors <- c(cors, sqrt(1-sum(cors^2)))
	indep <- t(t(scale(cbind(indep, stats::rnorm(nrow(indep))))) * cors * c(vx, 1))
	y <- drop(scale(rowSums(indep)) * sqrt(vy)) + my
	return(y)
}

#' Create genotype matrix
#'
#' @param nid Number of samples
#' @param nsnp Number of SNPs
#' @param af Allele frequency of all SNPs (all SNPs have the same allele frequency)
#'
#' @export
#' @return Matrix of genotypes, rows = individuals, columns = snps
make_geno <- function(nid, nsnp, af)
{
	return(matrix(rbinom(nid * nsnp, 2, af), nid, nsnp))
}

#' Get vector of effects that explain some amount of variance
#'
#' @param nsnp Number of SNPs
#' @param totvar Total variance explained by all SNPs
#' @param sqrt Output effect sizes in terms of standard deviations. Default=TRUE
#' @param mua Constant term to be added to effects. Default = 0
#'
#' @export
#' @return Vector of effects
choose_effects <- function(nsnp, totvar, sqrt=TRUE, mua=0)
{
	eff <- stats::rnorm(nsnp)
	eff <- sign(eff) * eff^2
	aeff <- abs(eff)
	sc <- sum(aeff) / totvar
	out <- eff / sc
	if(sqrt)
	{
		out <- sqrt(abs(out)) * sign(out)
	}
	return(out + mua)
}

#' Convert continuous trait to binary
#'
#' @param y Phenotype vector
#' @param prevalence Disease prevalence. Default = NULL
#' @param threshold Disease threshold Default = NULL
#'
#' @export
#' @return Vector of binary trait
y_to_binary <- function(y, prevalence=NULL, threshold=NULL)
{
	if(is.null(prevalence) & is.null(threshold)) stop("Prevalence or threshold needs to be non-null")
	if(!is.null(prevalence))
	{
		d <- y
		t <- quantile(d, 1-prevalence)
		d[y >= t] <- 1
		d[y < t] <- 0
		return(d)
	}
	if(!is.null(threshold))
	{
		d <- y
		d[y >= threshold] <- 1
		d[y < threshold] <- 0
		return(d)
	}
}

#' Ascertain some proportion of cases and controls from binary phenotype
#'
#' @param d Vector of 1/0
#' @param prop_cases Proportion of 1s to retain
#'
#' @export
#' @return Array of IDs
ascertain_samples <- function(d, prop_cases)
{
	d <- d[!is.na(d)]
	d <- d[d %in% c(0,1)]
	x1 <- sum(d==1)
	x0 <- sum(d==0)
	exp_cases <- x1
	exp_controls <- (x1 - prop_cases * x1) / prop_cases
	if(round(exp_controls) > x0)
	{
		exp_controls <- x0
		exp_cases <- (x0 - (1 - prop_cases) * x0) / (1 - prop_cases)
	}
	i0 <- which(d == 0)
	i0 <- sample(i0, exp_controls, replace=FALSE)
	i1 <- which(d == 1)
	i1 <- sample(i1, exp_cases, replace=FALSE)

	return(sort(c(i0, i1)))
}


LISP Interpreter Run

[[[[ Omega in the limit from below! ]]]]

define (all-bit-strings-of-size k)
    if = 0 k '(())
    (extend-by-one-bit (all-bit-strings-of-size - k 1))

define      all-bit-strings-of-size
value       (lambda (k) (if (= 0 k) (' (())) (extend-by-one-bi
            t (all-bit-strings-of-size (- k 1)))))

define (extend-by-one-bit x)
    if atom x nil
    cons append car x '(0)
    cons append car x '(1)
    (extend-by-one-bit cdr x)

define      extend-by-one-bit
value       (lambda (x) (if (atom x) nil (cons (append (car x)
             (' (0))) (cons (append (car x) (' (1))) (extend-b
            y-one-bit (cdr x))))))

define (count-halt p)
    if atom p 0
    +
    if = success car try t 'eval read-exp car p
       1 0
    (count-halt cdr p)

define      count-halt
value       (lambda (p) (if (atom p) 0 (+ (if (= success (car
            (try t (' (eval (read-exp))) (car p)))) 1 0) (coun
            t-halt (cdr p)))))

define (omega t) cons (count-halt (all-bit-strings-of-size t))
                 cons /
                 cons ^ 2 t
                      nil

define      omega
value       (lambda (t) (cons (count-halt (all-bit-strings-of-
            size t)) (cons / (cons (^ 2 t) nil))))

(omega 0)

expression  (omega 0)
value       (0 / 1)

(omega 1)

expression  (omega 1)
value       (0 / 2)

(omega 2)

expression  (omega 2)
value       (0 / 4)

(omega 3)

expression  (omega 3)
value       (0 / 8)

(omega 8)

expression  (omega 8)
value       (1 / 256)

End of LISP Run

Elapsed time is 0 seconds.


#--------Reference Point helper functions-------

#-------Spawners per recruit -----------------------------
s.per.recr<-function(nages,fec.age,mat.age,M.age, F.mult, sel.age, spawn.time ) {

  spr=0.0
  cum.survive=1.0
  z=0.0
  for (i in 1:(nages-1)  ) {
    z=M.age[i] + F.mult*sel.age[i]
    z.ts=(M.age[i]+F.mult*sel.age[i])*spawn.time
    spr=spr+cum.survive*fec.age[i]*mat.age[i]*exp(-z.ts)
    cum.survive=cum.survive*exp(-z )

  }

  z= M.age[nages] + F.mult*sel.age[nages]
  z.ts=(M.age[nages]+F.mult*sel.age[nages])*spawn.time
  spr=spr + fec.age[nages]*mat.age[nages]*cum.survive*exp(-z.ts)/( 1- exp(-z ) )

  return(spr)

}

#-------Yield per recruit -----------------------------
ypr<-function(nages, wgt.age, M.age, F.mult, sel.age ) {

  yield=0.0
  cum.survive=1.0
  z=0.0

  for (i in 1:(nages-1)  ) {
    z=M.age[i] + F.mult*sel.age[i]
    yield=yield + wgt.age[i]*F.mult*sel.age[i]*(1-exp(-z) )*cum.survive/z
    cum.survive=cum.survive*exp(-z)
  }

  z= M.age[nages] + F.mult*sel.age[nages]
  yield=yield + wgt.age[nages]*F.mult*sel.age[nages]*cum.survive/z

  return(yield)

}

#-------Equilibrium SSB ------------------------
ssb.eq<-function(recr.par, R0.BH, spr, spr0, is.steepness=T ) {

  if (is.steepness==T)  alpha.BH <- 4*recr.par/(1-recr.par)
  if (is.steepness==F)  alpha.BH <- recr.par
  sprF=spr/spr0

  ssb=spr0*R0.BH*(sprF*alpha.BH - 1.0)/(alpha.BH-1.0)

  return(ssb)

}
#------Beverton-Holt alpha-----------------------
bev.holt.alpha<-function(S,R0,recr.par,spr0, is.steepness=T){

  if (is.steepness==T)  alpha.BH <- 4*recr.par/(1-recr.par)
  if (is.steepness==F)  alpha.BH <- recr.par

  y=rep(0,length(S))
  y=R0*S*alpha.BH/(R0*spr0 +(alpha.BH-1.0)*S)
  return(y)

}


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Black-Litterman model Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Black-Litterman model Functions
###############################################################################
# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# note (5)
#
#' @export
bl.compute.risk.aversion <- function(bench, risk.free = 0)
{
	# The implied risk aversion coefficient can be estimated by dividing
	# the expected excess return by the variance of the portfolio
	lambda = mean(coredata(bench) - coredata(risk.free)) / var(coredata(bench))
	return( as.double(lambda) )
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (2)
#
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# formulas (1)
#
# use reverse optimization to compute the vector of equilibrium returns
#' @export
bl.compute.eqret <- function
(
	risk.aversion, 	# Risk Aversion
	cov, 			# Covariance matrix
	cap.weight, 	# Market Capitalization Weights
	risk.free = 0	# Rsik Free Interest Rate
)
{
	return( risk.aversion * cov %*% as.vector(cap.weight) +  as.double(risk.free))
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (8), (9), (10)
# compute the posterior estimate of the returns and covariance
#' @export
bl.compute.posterior <- function
(
	mu, 		# Equilibrium returns
	cov, 		# Covariance matrix
	pmat=NULL, 	# Views pick matrix
	qmat=NULL, 	# View mean vector
	tau=0.025, 	# Measure of uncertainty of the prior estimate of the mean returns
	confidences=NULL  # Confidence of each view
)
{
	out = list()

	if( !is.null(pmat) ) {
		if( is.null(confidences) ) {
		# The Black-Litterman Model In Detail by Jay Walters
		# Assume that the variance of the views will be proportional to the variance of the asset
		# returns, just as the variance of the prior distribution is. He and Litterman (1999)
		# This specification of the variance, or uncertainty, of the views essentially equally weights the investor's
		# views and the market equilibrium weights. By including tau in the expression, the final solution becomes
		# independent of tau as well.

		# contactenate 1 and remove first row, col ([-1,-1]) to work properly with single view
		omega = diag(c(1,diag(tau * pmat %*% cov %*% t(pmat))))[-1,-1]
		} else {
		omega = diag(c(1,confidences))[-1,-1]
		}

		temp = solve(solve(tau * cov) + t(pmat) %*% solve(omega) %*% pmat)

		out$cov = cov + temp

		out$expected.return = temp %*% (solve(tau * cov) %*% mu + t(pmat) %*% solve(omega) %*% qmat)
	} else {	# no views
		temp = tau * cov

		out$cov = cov + temp

		out$expected.return = temp %*% (solve(tau * cov) %*% mu )

	}
	return(out)
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (13)
#
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# formulas (2)
#
# compute the portfolio weights for the optimal portfolio on the unconstrained efficient frontier
#' @export
bl.compute.optimal <- function(risk.aversion, mu, cov)
{
	return( (1/risk.aversion) * solve(cov) %*% mu )
}

aa.black.litterman.examples <- function()
{
	# He & Litterman: The intuition Behind Black- Litterman Model Portfolios.

	data =
 '1,0.4880,0.4780,0.5150,0.4390,0.5120,0.4910
 0.4880,1,0.6640,0.6550,0.3100,0.6080,0.7790
 0.4780,0.6640,1,0.8610,0.3550,0.7830,0.6680
 0.5150,0.6550,0.8610,1,0.3540,0.7770,0.6530
 0.4390,0.3100,0.3550,0.3540,1,0.4050,0.3060
 0.5120,0.6080,0.7830,0.7770,0.4050,1,0.6520
 0.4910,0.7790,0.6680,0.6530,0.3060,0.6520,1'

	Corrmat = matrix( as.double(spl( gsub('\n', ',', data), ',')),
				nrow = len(spl(data, '\n')), byrow=TRUE)

	RiskAversion = 2.5

	stdevs = c(16.0, 20.3, 24.8, 27.1, 21.0,  20.0, 18.7)/100

	MktWeight = c(1.6, 2.2, 5.2, 5.5, 11.6, 12.4, 61.5)/100

	tau = 0.05

	Covmat = Corrmat * (stdevs %*% t(stdevs))

	EqRiskPrem = RiskAversion * Covmat %*% MktWeight
EqRiskPrem = bl.compute.eqret(RiskAversion, Covmat, MktWeight)

	AssetNames = c('Australia','Canada','France','Germany','Japan','UK','USA')

	Table2 = cbind(AssetNames, round(cbind(stdevs, MktWeight, EqRiskPrem) * 100,1))
		colnames(Table2) = c('Assets','Std Dev','Weq','PI')
		Table2

	#View1 is The German Equity Market Will Outperform the rest of European Markets by 5% a year.
	P = matrix(c(0, 0, -29.5, 100, 0, -70.5, 0)/100, nrow=1)
	Q = 5/100

	Omega = diag(c(1,diag(tau * P %*% Covmat %*% t(P))))[-1,-1]

	PostCov = solve(solve(tau*Covmat) + (t(P) %*% solve(Omega) %*% P))

	SigmaP = Covmat + PostCov

	ExpRet = PostCov %*% (solve(tau * Covmat) %*% EqRiskPrem + t(P) %*% solve(Omega) %*% Q)

post = bl.compute.posterior(EqRiskPrem, Covmat, P, Q, tau)
	ExpRet = post$expected.return
	SigmaP = post$cov

	OptimalWeights = (1/RiskAversion) * solve(SigmaP) %*% ExpRet
OptimalWeights = bl.compute.optimal(RiskAversion, ExpRet, SigmaP)

	Tab4Col4 = OptimalWeights - (MktWeight)/(1+tau)

	Table4 = cbind(AssetNames, round(cbind(t(P), ExpRet, OptimalWeights, round(Tab4Col4 * 1000)/1000)*100,1))
		colnames(Table4) = c('Assets', 'P', 'MU', 'W','W - Weq/1+tau')
		Table4

	# example from Thomas M. Idzorek's paper "A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL"
	x =
	c(0.001005,0.001328,-0.000579,-0.000675,0.000121,0.000128,-0.000445,-0.000437 ,
     0.001328,0.007277,-0.001307,-0.000610,-0.002237,-0.000989,0.001442,-0.001535 ,
     -0.000579,-0.001307,0.059852,0.027588,0.063497,0.023036,0.032967,0.048039 ,
    -0.000675,-0.000610,0.027588,0.029609,0.026572,0.021465,0.020697,0.029854 ,
     0.000121,-0.002237,0.063497,0.026572,0.102488,0.042744,0.039943,0.065994 ,
     0.000128,-0.000989,0.023036,0.021465,0.042744,0.032056,0.019881,0.032235 ,
    -0.000445,0.001442,0.032967,0.020697,0.039943,0.019881,0.028355,0.035064 ,
    -0.000437,-0.001535,0.048039,0.029854,0.065994,0.032235,0.035064,0.079958 )

    varCov <- matrix(x, ncol = 8, nrow = 8)
    mu <- c(0.08, 0.67,6.41, 4.08, 7.43, 3.70, 4.80, 6.60) / 100
    pick <- matrix(0, ncol = 8, nrow = 3, dimnames = list(NULL, letters[1:8]))
    pick[1,7] <- 1
    pick[2,1] <- -1; pick[2,2] <- 1
    pick[3, 3:6] <- c(0.9, -0.9, .1, -.1)

post = bl.compute.posterior(mu, varCov, pick, c(0.0525, 0.0025, 0.02), tau = 0.025)

	library(BLCOP)
    confidences <- 1 / c(0.000709, 0.000141, 0.000866)
    myViews <- BLViews(pick, c(0.0525, 0.0025, 0.02), confidences, letters[1:8])
    myPosterior <- posteriorEst(myViews, tau = 0.025, mu, varCov )
    myPosterior

 myPosterior@posteriorMean - post$expected.return
 myPosterior@posteriorCovar - post$cov

}


# A simple 2-layer neural network uses Perceptron as the activation function.
#
#          x - Descriptive features, multi-column table later converted to mxn matrix
#          y - Target feature, single column table later converted to 1D matrix
# yhat_train - zero matrix of same dimensions as y
#         w1 - first weight matrix with number of rows matching column
#              number of x and w1 column number equal to the number of nodes.
#              Initialized with unseeded random variable between 0 and 1
#         w2 - second weight matrix, 1D array with number of rows matching
#              node number
#              Initialized with unseeded random variable between 0 and 1
#         h1 - layer 1 of the heural network. Same number of rows as input
#              and column number equal to the number of nodes. Initialized with
#              zeros for all elements
#        dw1 - first weight gradient, dimensions match w1. Initialized with
#              zeros for all elements
#        dw2 - first weight gradient, dimensions match w2. Initialized with
#              zeros for all elements

perceptron <- function(input, output, n){
  nnclass <- setClass(
    "neural_net",
    slots = c(
      x = "matrix",
      y = "matrix",
      yhat_train = "matrix",
      w1 ="matrix",
      w2 ="matrix",
      h1 ="matrix",
      dw1 ="matrix",
      dw2 ="matrix"
    )
  )

  neural_net <- nnclass(
    x = as.matrix(input),
    y = as.matrix(output),
    yhat_train = matrix(0L,
                        nrow = dim(as.matrix(output))[1],
                        ncol = dim(as.matrix(output))[2]),
    w1 = matrix(runif(ncol(input)*n, 0, 1), nrow = ncol(input), ncol = n),
    w2 = matrix(runif(n, 0, 1), nrow = n, ncol=1),
    h1 = matrix(0L, nrow = nrow(input), ncol = n),
    dw1 = matrix(0L, nrow = ncol(input), ncol = n),
    dw2 = matrix(0L, nrow = n, ncol = 1)
  )

  setGeneric("feedforward", function(neural_net)
    standardGeneric("feedforward"))

  setGeneric("backprop", function(neural_net)
    standardGeneric("backprop"))

  # Feedfoward method updates h1 and yhat_train matrices
  setMethod(f = "feedforward", signature = "neural_net",
            function(neural_net){
              neural_net@h1 <- activation(dot(neural_net@x, neural_net@w1))
              neural_net@yhat_train <- activation(dot(neural_net@h1, neural_net@w2))
              return(neural_net)
            })

  # Backprop method updates weights and weight gradient matrices
  setMethod(f = "backprop", signature = "neural_net",
            function(neural_net){
              neural_net@dw1 <- dot(t(neural_net@x),
                                    dot(2*(neural_net@y - neural_net@yhat_train) *
                                    activation_der(neural_net@yhat_train), t(neural_net@w2)) *
                                    activation_der(neural_net@h1))
              neural_net@dw2 <- dot(t(neural_net@h1),
                                    2*(neural_net@y-neural_net@yhat_train) *
                                    activation_der(neural_net@yhat_train))
              neural_net@w1 = neural_net@w1 + neural_net@dw1
              neural_net@w2 = neural_net@w2 + neural_net@dw2
              return(neural_net)
            })

  return(neural_net)
}

# functions

dot <- function(a, b){
  c <- a %*% b
  return(c)
}

# sigmoid function
activation <- function(z){
  sigmoid <- 1/ (1 + exp(-z))
  return(sigmoid)
}

# Derivative of sigmoid function
activation_der <- function(z){
  sigmoid_der <- (activation(z)) * (1 - activation(z))
  return(sigmoid_der)
}

# Threshold function with binay output of 0 or 1 based on a threshold value f
# Kept separate from neural network classes as this can be used on test and train data
threshold <- function(yhat_thresh, f){
  yhat_thresh <- as.matrix(yhat_thresh)
  for(i in 1:nrow(yhat_thresh)){
    if (yhat_thresh[i,] < f){
      yhat_thresh[i,] <- 0L
    } else {
      yhat_thresh[i,] <- 1L
    }
  }
  return(yhat_thresh)
}

result <- function(result_x, result_w1, result_w2){
  result_x = as.matrix(result_x)
  result_h1 <- activation(dot(result_x, result_w1))
  yhat_test <- activation(dot(result_h1, result_w2))
  return(yhat_test)
}


 ZTGSEN Example Program Results

 Reordered Schur matrix A
                    1                 2                 3                 4
 1  ( 4.6904, 2.3452) (-2.1563, 0.1192) ( 1.9599,-0.5174) ( 1.8091,-1.2060)
 2  ( 0.0000, 0.0000) ( 2.0084,-1.0042) ( 0.9161,-0.2762) ( 1.8574,-0.5326)
 3  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 1.6985, 1.6985) ( 0.1270, 0.7231)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 6.0000,-2.0000)

 Reordered Schur matrix B
                    1                 2                 3                 4
 1  ( 2.3452, 0.0000) (-0.6181, 1.8237) ( 0.9290, 0.5409) ( 2.7136,-1.5076)
 2  ( 0.0000, 0.0000) ( 1.0042, 0.0000) ( 1.2251,-1.1857) ( 1.8541,-0.2929)
 3  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.8492, 0.0000) ( 0.1435, 0.9053)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 2.0000, 0.0000)

 Basis of left deflating invariant subspace
                    1                 2
 1  ( 0.9045, 0.3015) (-0.0033,-0.2397)
 2  ( 0.3015, 0.0000) ( 0.2497, 0.7157)
 3  ( 0.0000, 0.0000) ( 0.0549, 0.6042)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000)

 Basis of right deflating invariant subspace
                    1                 2
 1  ( 0.7071, 0.0000) (-0.5607, 0.0000)
 2  ( 0.7071, 0.0000) ( 0.5607, 0.0000)
 3  ( 0.0000, 0.0000) ( 0.0552, 0.6067)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000)

 Norm estimate of projection onto left  eigenspace for selected cluster
   8.90E+00

 Norm estimate of projection onto right eigenspace for selected cluster
   7.02E+00

 F-norm based upper bound on Difu
   2.18E-01

 F-norm based upper bound on Difl
   2.62E-01


#' Percent Change Without Div by 0 Error
#'
#' Calculates the percent change of two numbers or vectors, if prior = 0 then percent change is 100%
#'
#' @param prior A numeric object
#' @param current A numeric object
#' @param format If TRUE (default) then output is converted to a percentage with formattable, otherwise proportion
#' @param ... Any arguments passed to formattable::percent, most likely digits
#'
#' @export
#'
#' @examples
#' pct_change(0, 1) returns 100.00%
#' pct_change(2, 3, format = F) returns 0.5
#'

pct_change <- function(prior, current, format = T, ...){

  out <- ifelse(prior == 0, sign(current), (current/prior) - 1)

  if(format == T){
    formattable::percent(out, ...)
  }else{
      out}

}


## The web link for this lesson
## https://courses.edx.org/courses/HarvardX/PH525.4x/1T2015/courseware/92dbe89dc80c4fc084cad3f00b0381f7/494a3c869b7d4d9facbc92c1c8ded6c6/

download.file("http://bowtie-bio.sourceforge.net/recount/ExpressionSets/bottomly_eset.RData","bottomly_eset.RData")
load("bottomly_eset.RData")
library("Biobase")
pData(bottomly.eset)

# raw counts matrix
head(exprs(bottomly.eset))

total<- nrow(exprs(bottomly.eset))

ratios<- numeric()
for (i in 1:ncol(exprs(bottomly.eset))) {
        zeros<- sum(exprs(bottomly.eset)[,i] == 0)
        ratio<- zeros/total
        ratios<- c(ratios, ratio)
}

g<- as.factor(pData(bottomly.eset)$experiment.number)

library(ggplot2)
d<- data.frame(ratios=ratios, group=g)
ggplot(d) + geom_boxplot(aes(x=group, y=ratios))

## different batches have differnt proportion of 0s for the counts

## make a multidimensional scaling plot
##  However, when computing distances we prefer
# to have measures with similar variability across samples.
## Because this is RNAseq data, the variance depends on the mean:
library(genefilter)
A<- rowMeans(exprs(bottomly.eset))
SD<- rowSds(exprs(bottomly.eset))
plot(A,SD)

## log2 transformation to stablize the variance
y<- log2( exprs( bottomly.eset )+0.5)

library(devtools)
install_github("rafalib","ririzarr")
library(rafalib)
mypar(2,1)
hist(y[,1],nc=100)
hist(y[y[,1]>0,1],nc=100)
abline(v=3)

## use counts bigger than 8
y<- exprs( bottomly.eset )
ind<- which(apply( y>=8, 1, all))
y<- log2( y[ind,] )

## make a multidimensional scaling plot

s<- svd(y)
U<- s$u  ## orthogonal matrix  UtU = I
V<- s$v  ## orthogonal matrix
D<- diag(s$d)  # diagnonal matrix

library(rafalib)
mypar2(1,1)
plot(s$d)

Yhat<- U %*% D %*% t(V)
resid<- Y - Yhat
boxplot(resid, ylim = c(-2,2), range=0)

##### normalizing NGS count data for biased GC content, this is just to demonstrate
### that GC bias can affect counts, for real data analysis, GC bias correction methods
### for example:
### EDAseq bioconductor http://www.ncbi.nlm.nih.gov/pubmed/22177264

# Systematic bias is important to keep in mind, especially in experiments with many batches. Comparisons across batches are complicated by technical biases, and it is essential that conditions of interest (treatment vs untreated) be balanced across batches, or else the experiment will uncover a mix of biological differences and systematic bias, with no hope to disentangle the two. This issue comes up over and over again in genomic studies, since the beginning of microarray data and continuing to the present day, with massive sequencing-based genomic data sets.

# The ReCount project provides summaries of a number of RNA-seq experiments as ExpressionSet objects, so that labs around the world do not have to perform alignment just to "re-count" the number of reads which fall in genes. If you use data from this project make sure to cite the authors! Download the ExpressionSet for the Bottomly experiment, here. Load this object into R:

library(Biobase)
load("bottomly_eset.RData")
bottomly.eset
head(exprs(bottomly.eset))

# Examine the histogram of sample-sample correlations of log counts:

hist(cor(log(exprs(bottomly.eset) + 1)))

#There are a number of reasons for such high correlations:

#Biological correlation: genes are expressed similarly across organisms
# Systematic bias: technical bias affects the same genes similarly (for example, if the bias is due to the sequence of the gene, then this could be common across experiments)
# The presence of many zeros, which anchor the cloud of log counts at (0,0)
#Remove some of the rows with many zeros, and plot the histogram of correlations again:

mat = exprs(bottomly.eset)
rs = rowSums(mat)
hist(cor(log(mat[ rs > 10, ] + 1)))

#Subset and rename the ExpressionSet to remove the genes which have 2 or fewer reads across all samples:

e = bottomly.eset[ rowSums(exprs(bottomly.eset)) > 2, ]
dim(e)

# We now have 12971 genes and 21 samples. The genes are annotated with ENSEMBL IDs,
# stored as rownames (and in fData(e)). The quickest way for us to check the GC content
# of each gene is to use the precomputed TxDb for mouse in Bioconductor. If we were doing
# this analysis not just for quick check, we should load the ENSEMBL genes from the ENSEMBL
# GTF file and use these for computing GC.

biocLite("TxDb.Mmusculus.UCSC.mm9.knownGene")
biocLite("BSgenome.Mmusculus.UCSC.mm9")
biocLite("org.Mm.eg.db")

library("TxDb.Mmusculus.UCSC.mm9.knownGene")
library("BSgenome.Mmusculus.UCSC.mm9")
library("org.Mm.eg.db")

# Now we will connect the ENSEMBL IDs to Entrez IDs, and then get the sequence for the exons per gene.
## because in the TxDb.Mmusculus.UCSC.mm9.knownGene database, genes are in ENTREZID.

res = select(org.Mm.eg.db, keys=rownames(e), keytype="ENSEMBL", columns="ENTREZID")

#Note there are 1 to many mappings, which will we ignore for this quick analysis. Now add a column to the ExpressionSet, by getting the first match of the ENTREZ IDs to our ENSEMBL IDs.

fData(e)$ENTREZ = res$ENTREZID[ match(rownames(e), res$ENSEMBL) ]

#There are some NA's for those ENSEMBL IDs missing matches, which we will just remove from analysis:

sum(is.na(fData(e)$ENTREZ))
e = e[ !is.na(fData(e)$ENTREZ) , ]

#Now it's only two steps to get the GC content: get the genes, and get the sequence for the genes. First we get the exons for each gene:

txdb = TxDb.Mmusculus.UCSC.mm9.knownGene
grl = exonsBy(txdb, by="gene")

#We need to subset the ExpressionSet again to only those genes for which we have ranges:

e = e[ fData(e)$ENTREZ %in% names(grl), ]

#Now put the exon GRangesList in the order of the counts ExpressionSet and reduce the exons GRangesList.
## The reduce() call is necessary so that we don't overcount any overlapping exon sequence.

reduced.exons = reduce(grl[ fData(e)$ENTREZ ])

# Get the sequence for the reduced exons using getSeq. Note that the returned object is a
# DNAStringSetList. For each gene, we have a DNAStringSet of the reduced exon sequence.
# By calling DNAStringSet(lapply(x, unlist)) on the DNAStringSetList, 'x', we get a DNAStringSet
# for each gene with the joined reduced exon sequence. Note that this unlisting does take a few minutes to perform though.

#What is the GC-content (a ratio, answer between 0 and 1) for the first gene in reduced.exons?
# Hint: letterFrequency

?getSeq
mm9_genome<- BSgenome.Mmusculus.UCSC.mm9

exonSeq<- getSeq(mm9_genome, reduced.exons)
exonSeq_unlist<- DNAStringSet(lapply(exonSeq, unlist))
#G/C content for the first gene

sum(letterFrequency(x=exonSeq_unlist[1], letters=c("C","G"), as.prob=T))

gc<- apply(letterFrequency(x=exonSeq_unlist, letters=c("C","G"), as.prob=T), 1, sum)

# Plot the log counts over the GC content for one sample:

plot( log(exprs(e)[,1]+1) ~ gc)

# It might be easier to see a dependence with boxplots:

boxplot( log(exprs(e)[,1]+1) ~ cut(gc, 20))

# We can calculate the median log count for each bin of GC content for a single sample:

sapply(split(log(exprs(e)[,1]+1), cut(gc, 20)), median)

# We can perform this calculation across all samples as well:

gc.depend = sapply(1:ncol(e), function(i) sapply(split(log(exprs(e)[,i]+1), cut(gc, 20)), median))

# Plot the GC dependence and color the lines by batch identifier:

plot(gc.depend[,1], type="n", ylim=c(0,6))
batch = factor(e$experiment.number)
for (i in 1:ncol(e)) lines(gc.depend[,i], col=batch[i])
legend("bottom", levels(batch), col=1:3, lty=1)


=begin
  # sample-algebraicfield01.rb

  require "algebra"

  Px = Polynomial(Rational, "x")
  x = Px.var
  F = ResidueClassRing(Px, x**2 + x + 1)
  x = F[x]
  p( (x + 1)**100 )
      #=> -x - 1
  p( (x-1)** 3 / (x**2 - 1) )
      #=> -3x - 3

  G = Polynomial(F, "y")
  y = G.var
  p( (x + y + 1)** 7 )
      #=> y^7 + (7x + 7)y^6 + 8xy^5 + 4y^4 + (4x + 4)y^3 + 5xy^2 + 7y + x + 1

  H = ResidueClassRing(G, y**5 + x*y + 1)
  y = H[y]
  p( 1/(x + y + 1)**7 )
    #=> (1798/3x + 1825/9)y^4 + (-74x + 5176/9)y^3 +
    #     (-6886/9x - 5917/9)y^2 + (1826/3x - 3101/9)y + 2146/9x + 4702/9
((<_|CONTENTS>))
=end


asymp <-function(v=0.0, min=-10, max=+10)
{
  r = max - min;
  return (min + r * (pi/2 + atan(v)) / pi)
}

vtp2pol <- function(scale=0.0, resonance=0.0, shift=0.0, fbfact=0.0, rpfact=0.0)
{
  f = exp(scale/50) * 1000.0 * c(1,3,5,7,9,11,13,15) / 2
  b = exp(resonance/50) * 50.0 + 20.0 * 1:8

  for (j in 1:8) {
	if (j > 1)
	  minv = 50.0 + (f[j] + f[j-1]) / 2.0
	else
	  minv = 50.0
	if (j < 8)
	  maxv = (f[j+1] + f[j]) / 2.0 - 50.0
	else
	  maxv = f[j] + 450.0 * exp(scale/50)
	if (j%%2) {  # if j is odd positive values decrease freq
	  v = asymp(fbfact*.0325, maxv, minv)
	} else {  # if j is even positive values increase freq
	  v = asymp(fbfact*.0325, minv, maxv)
	}
	f[j] = v
  }

  if (rpfact < 0.0) {
	minv = f[1] + 50.0
	maxv = f[2] + (f[2] - minv)
	f[2] = asymp(rpfact*.0325, minv, maxv)
	minv = f[2] + 50.0
	maxv = f[3] + (f[3] - minv)
	f[3] = asymp(rpfact*.0325, minv, maxv)
  } else {
	maxv = f[4] - 50.0
	minv = f[3] - (maxv - f[3])
	f[3] = asymp(rpfact*.0325, minv, maxv)
	maxv = f[3] - 50.0
	minv = f[2] - (maxv - f[2])
	f[2] = asymp(rpfact*.0325, minv, maxv)
  }

  mid = exp(scale/50) * 500.0
  minv = 50.0 - f[1]
  maxv = -minv
  v = asymp(shift*0.325, minv, maxv)
  cat("minv=",minv," maxv=",maxv," v=",v,"\n")
  f = f + v

  rtn <- data.frame(f, b)
  return(rtn)
}

vtSpect <- function(vt)
{
    s=rep(1,101);
	for (i in 1:length(vt$f)) {
	  s = s * formant(vt$f[i], vt$b[i], 100, 8000)
    }
	s = s * hpc2(8, seq(0, 8000, 8000/100), 500)
    return(s)
}


dft <- function(timeScopeList, pointCount) {
    realPointCount <- length(timeScopeList)
    freqScopeList <- c()

    for(k in 1:pointCount) {
        sumCache <- 0
        for(n in 1:pointCount) {
            if (n>realPointCount) {
                break
            }

            sumCache <- sumCache + timeScopeList[n] * exp(-1i * 2 * pi * (k - 1) * (n - 1) / pointCount)
        }

        freqScopeList <- append(freqScopeList, sumCache)
    }

    return(freqScopeList)
}

print(dft(c(1, 2, 1, 2), 4))


# Databricks notebook source
# MAGIC %md
# MAGIC # Decision Trees
# MAGIC ### Not focused on best way to perform modelling using Decision Trees or Random Forest
# MAGIC #### Instead focus on intro and getting you started and using Decision Trees & Random Forest

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

# MAGIC %md
# MAGIC ## Who has used modelling in the past?
# MAGIC ### Slack Poll

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

library("caret")
library("tidyverse")
data(diamonds)
model <- lm(price ~ ., diamonds)
p <- predict(model, diamonds)

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

head(diamonds)

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

summary(model)

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

summary(p)

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

# MAGIC %md
# MAGIC ## Decision Trees
# MAGIC * Tree-based models
# MAGIC  - Non-parametric algorithms
# MAGIC  - Partitioning the feature space into a number of smaller (non-overlapping) regions with similar response values using a set of splitting rules.
# MAGIC * Predictions are obtained by fitting a simpler model (e.g., a constant like the average response value) in each region.
# MAGIC * Such divide-and-conquer methods can produce simple rules that are easy to interpret and visualize with tree diagrams.

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

# MAGIC %md
# MAGIC - One methodology for constructing Decision Trees is CART the classification and regression tree (CART) algorithm
# MAGIC   - Partition training data into homogeneous subgroups (nodes)
# MAGIC and then fits a simple constant in each node
# MAGIC - Nodes are formed recursively using binary partitions formed by asking simple yes-or-no questions about each feature (e.g., is age < 18?).
# MAGIC  - This is done a number of times until a suitable stopping criteria is satisfied (e.g., a maximum depth of the tree is reached).
# MAGIC - Then the model predicts the output based on
# MAGIC  - (1) the average response values for all observations that fall in that subgroup (regression problem), or
# MAGIC  - (2) the class that has majority representation (classification problem).

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

# MAGIC %md
# MAGIC
# MAGIC ### Example of Decision Tree
# MAGIC
# MAGIC ![DCT1.jpg](https://cdn-images-1.medium.com/max/824/0*J2l5dvJ2jqRwGDfG.png)

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

# MAGIC %md
# MAGIC
# MAGIC ![DCT2.jpg](https://cdn-images-1.medium.com/max/688/0*pb-1ufHK-OmR8k7r.png)

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

library(rpart)
model <- rpart(Species ~., data = iris)
par(xpd = NA) # otherwise on some devices the text is clipped
plot(model)
text(model, digits = 3)

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

dim(iris)

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

print(model, digits = 2)

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

# MAGIC %md
# MAGIC ## Decision Trees: Partitioning
# MAGIC
# MAGIC - CART uses binary recursive partitioning (it’s recursive because each split or rule depends on the splits above it).
# MAGIC - The objective at each node is to find the “best” feature to partition the remaining data into one of two regions (R1 and R2) such that the overall error between the actual response (yi) and the predicted constant (ci) is minimized.
# MAGIC - Having found the best feature/split combination, the data are partitioned into two regions and the splitting process is repeated on each of the two regions (hence the name binary recursive partitioning).

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

# MAGIC %md
# MAGIC ### Decision Trees: Deep
# MAGIC - Early stopping
# MAGIC   - Restrict the tree depth to a certain level or
# MAGIC  - Restrict the mini number of observations allowed in any terminal node
# MAGIC - Pruning
# MAGIC   - grow a very large, complex tree and then prune it back to find an optimal subtree

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

# Load the data and remove NAs
data("PimaIndiansDiabetes2", package = "mlbench")
PimaIndiansDiabetes2 <- na.omit(PimaIndiansDiabetes2)
# Inspect the data
sample_n(PimaIndiansDiabetes2, 3)
#https://rdrr.io/cran/mlbench/man/PimaIndiansDiabetes.html

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

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

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

# Build the model
set.seed(123)
model1 <- rpart(diabetes ~., data = train.data, method = "class")
# Plot the trees
par(xpd = NA) # Avoid clipping the text in some device
plot(model1)
text(model1, digits = 3)

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

# Make predictions on the test data
predicted.classes <- model1 %>%
  predict(test.data, type = "class")
head(predicted.classes)

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

# Compute model accuracy rate on test data
mean(predicted.classes == test.data$diabetes)

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

# MAGIC %md
# MAGIC #### Pruning the tree

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

?train

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

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

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

# Print the best tuning parameter cp that
# maximizes the model accuracy
model2$bestTune

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

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

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

# Decision rules in the model
model2$finalModel

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

# Make predictions on the test data
predicted.classes <- model2 %>% predict(test.data)
# Compute model accuracy rate on test data
mean(predicted.classes == test.data$diabetes)

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

# MAGIC %md
# MAGIC ## Take aways:
# MAGIC - Simple and easy to implement (no preprocessing required and categorical variables handled, handle missing values)
# MAGIC - Not great on predictive accuracy
# MAGIC - Deep trees have high variance / Shallow Trees bias.
# MAGIC
# MAGIC ## More technical:
# MAGIC - A problem with decision trees like CART is that they are greedy.
# MAGIC - Even with Bagging, the decision trees can have a lot of structural similarities and in turn have high correlation in their predictions.

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

# MAGIC %md
# MAGIC ## Another way to think about Decision Trees
# MAGIC - Great advantage of decision trees: make a complex decision simpler by breaking it down into smaller, simpler decisions using a divide-and-conquer strategy.
# MAGIC - Identify a set of if-else conditions that split the data according to the value of the features.

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

# MAGIC %md
# MAGIC # Before jumping to the next section, let's try out few examples


#' @title calcHMWettedSA
#'
#' @description Calculate hull wetted surface area (\code{wettedSA}) (m^2)
#' using the Holtrop & Mennen method.
#'
#'@param lwl Waterline length (vector of numericals, m) (see
#'\code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param actualDraft Actual draft (vector of numericals, m)
#'@param Cm Midship section coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCm}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCbw}})
#'@param Cwp Water plane area coefficient (vector of numericals, see
#'\code{\link{calcCwp}})
#'@param Abt Traverse bulb area (vector of numericals, m^2) (see
#'\code{\link{calcAbt}})
#'
#'@details
#'Actual draft is typically obtained from sources such as AIS messages or ship
#'records.
#'
#' @return \code{wettedSA} (vector of numericals, m^2)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCm}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcCwp}}
#'\item \code{\link{calcAbt}}}
#'
#' @family Holtrop-Mennen Calculations
#'
#' @examples
#'calcHMWettedSA(218.75,12.48,32.25,0.99,0.81,0.91,32.02)
#'
#' @export

calcHMWettedSA<- function(lwl,actualDraft,breadth,Cm,Cbw,Cwp,Abt){

wettedSA<-lwl*(2*actualDraft+breadth)*(Cm^0.5)*
    (0.453+0.4425*Cbw-0.2862*Cm-0.003467*(breadth/actualDraft)+
       0.3696*Cwp)+2.38*(Abt/Cbw)

    return(wettedSA)
}


#Notes can be found at the link below
#https://nbviewer.jupyter.org/github/corybaird/PLCY_Code_2020_winter/blob/main/Code_sessions/Session_2/Session_2_Notes.ipynb

# A.1 Import libraries¶

## Step 1
#install.packages('dplyr')
#install.packages('ggplot2')

#A.2 Import data¶

# Step 2
library(ggplot2)
library(dplyr)

mtcars = as_tibble(mtcars)
mtcars %>% head(2)

# 1. OLS regression
# 1.1 OLS: Built-in package lm
# 1.1.1 Regression summary¶

linear_reg = lm(mpg ~ wt, data=mtcars)

print(summary(linear_reg))

# 1.1.1.1 Accessing coefficients from summary

linear_reg_summary = summary(linear_reg)

linear_reg_summary$coefficients

# F-stat
print('F-stat')
linear_reg_summary$fstatistic

# R-sq
print(paste('R-sq:', linear_reg_summary$r.squared, sep=' '))

# 1.1.1.2 Accessing specific coefficients¶

#linear_reg_summary$coefficients["wt","Std. Error"] #Std. errors

#linear_reg_summary$coefficients["wt","t value"] #T-value

beta1_lm = linear_reg_summary$coefficients["wt","Estimate"] #Beta

beta1_lm

# 1.1.2 Residuals¶

#linear_reg$fitted.values #Yhat
#linear_reg$coefficients #coefficients
#linear_reg$residuals #Residuals

df_model = mtcars  %>% select(wt,mpg)

df_model = df_model  %>%
rename('y' = mpg) %>%
mutate(residu = linear_reg$residuals,
       predicted_y = linear_reg$fitted.values)

df_model %>% head(5)

# 1.1.2.1 Plot regression residuals¶

#predicted_y == yhat
df_model  %>% ggplot(aes(y, predicted_y))+ geom_point()

# 1.2 OLS: Using matrix algebra¶
# 1.2.1 Create matrices for X and Y values¶

X = as.matrix(mtcars %>% select(wt))
X = cbind(X,rep(1,length(X))) #Add constant/intercept
colnames(X)[2] <- "Intercept" #Name intercept
Y = as.matrix(mtcars %>% select(mpg))

# Method 1: SOLVE OLS USING Linear algebra
A = solve(t(X)%*%X)
bhat_hand = A  %*% t(X) %*% Y
print(bhat_hand)

# Method 2: SOlVE OLS using cov--Note only works for Single linear regression
cov(Y, X)['mpg','wt']/var(X)['wt','wt']

# 2. Regression diagnostics¶

#Step 1
#install.packages('lmtest')

#Step 2
library(lmtest)

# 2.1 Breusch pagan: test for heteroskedasticity¶

linear_reg = lm(mpg ~ wt, data=mtcars)
bptest(linear_reg)

### 2.1.1 Create function to check the above test
diagnostics <- function(regression) {
    bp_res = bptest(linear_reg)$p.value
    if (bp_res<.1){
        print(paste("P-value", round(bp_res,3)))
        print("Reject null. Thus there is evidence of heteroskedasticity")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of heteroskedasticity")
    }
}

diagnostics(linear_reg)

# 2.2 DW test: test for serial correlation¶

dwtest(linear_reg)

# 2.3 Functional misspecification¶
resettest(linear_reg)

# 2.4 Introduction to functions¶
# 2.4.1 Function: square numbers¶

square = function(a){
  solution = a^2
  return (solution)
}
square(4)

# 2.4.2 Function: add two numbers¶

add_numbers = function(a,b){
    solution = (a^2)+b
    return (solution)
}

add_numbers(2,3)

# 2.4.3 Function: using if and else¶

number_test = function(a,b,c) {
    print('You can print anything you want inside functions')
    solution1 = a+b
    solution = solution1-c
    print(paste("The solution is:", solution))
    if (solution>100){
        print('Big numbers are lame')
    }
    else{
        print('Small numbers are cool')
    }
}

number_test(1,2,5)

# 2.4.4 Function: BP, DW and RESET Test¶

diagnostics = function(regression) {
    #BP-test
    print('-------')
    print('BP-Test')
    bp_res = bptest(linear_reg)$p.value
    if (bp_res<.1){
        print(paste("P-value", round(bp_res,3)))
        print("Reject null. Thus there is evidence of heteroskedasticity")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of heteroskedasticity")
    }
    #DW-test
    print('-------')
    print('DW-Test')
    dw_res = dwtest(linear_reg)$p.value
    if (dw_res<.1){
        print(paste("P-value", round(dw_res,3)))
        print("Reject null. Thus there is evidence of serial correlation")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of serial correlation")
    }
    #Ramsey Reset test
    print('-------')
    print('Rest-Test')
    ram_res = resettest(linear_reg)$p.value
    if (ram_res<.1){
        print(paste("P-value", round(ram_res,3)))
        print("Reject null. Thus there is evidence of misspecification")
    }
    else{
        print(paste("P-value", round(ram_res,3)))
        print("Cannot reject null. No evidence of  misspecification")
    }
}

diagnostics(linear_reg)

# 3. Other regression models
# 3.1 Robust S.E. regression

library(MASS)

summary(rlm(mpg ~ wt, mtcars))

# 3.2 Fixed effects¶

library(plm)

data("Grunfeld", package="plm")
Grunfeld  %>% head(3)

# 3.2.1 Fixed effects: Individual fixed effects¶

grun.fe <- plm(inv~value+capital, index=c('firm','year'), data = Grunfeld, model = "within")
summary(grun.fe)$coefficients

# 3.2.2 Fixed effects: Individual AND time fixed effects¶

#Method 1: factor(year)
grun.fe <- plm(inv~value+capital+factor(year), index=c('firm','year'), data = Grunfeld, model = "within")

#Method 2: effect='twoways'
grun.fe <- plm(inv~value+capital, index=c('firm','year'), data = Grunfeld, model = "within", effect='twoways')
summary(grun.fe)$coefficients

# 3.3 Standard errors
# 3.3.1 Baseline standard error¶

summary(grun.fe)$coefficients

# 3.3.2 Clustered standard error¶

coeftest(grun.fe, vcovHC(grun.fe, type = 'HC0', cluster = c('group','time')))

# 3.4 Random effects¶

grun.re <- plm(inv~value+capital,index=c('firm','year'), data = Grunfeld, model = "random")
summary(grun.re)$coefficients

# 3.4.1 Robust standard errors¶

coeftest(grun.re, vcovHC(grun.re, type = 'HC0', cluster = c('group','time')))

# 3.5 Logistic regression¶

mtcars %>% head(2)

summary(glm(am~ cyl+disp+drat+mpg, family='binomial', mtcars))

# 4. Machine Learning: Supervised learning¶

# Step 1
#install.packages('caret')

# Step 2
library(caret)

data(Sacramento)
house_df = Sacramento %>% as_tibble()
house_df  = house_df %>% mutate(ID = row_number())
house_df %>% head(3)

# 4.1.1. Baseline regression¶

model = lm(price ~ beds+baths+sqft, data=house_df)

# 4.1.1.1 Evaluate model by calculating RMSE¶

rmse = function(acutal, predicted){
    error = predicted - acutal
    rmse = sqrt(mean(error^2))
    return(rmse)
}

# 4.1.1.2 Actual data=price , Predicted data=fitted.values¶

rmse(house_df$price, model$fitted.values)

# 4.1.2 Train-test regression¶

set.seed(42)

train = house_df  %>% sample_frac(.8)
train %>% head(2)

test = house_df[-train$ID,]
test %>% head(2)

model = lm(price ~ beds+baths+sqft, data=train)

p = predict(model, test)

rmse(p, test$price)

# 4.2 Cross validation¶

model <- train(
  price ~ beds+baths+sqft,
    data=house_df,
  method = "lm",
  trControl = trainControl(
    method = "cv",
    number = 10,
    verboseIter = FALSE
  )
)
model


### AR test and its corresponding power and sample size functions

AR.test=function(ivmodel, beta0=0, alpha=0.05){
  Yadj = ivmodel$Yadj; Dadj = ivmodel$Dadj; Zadj = ivmodel$Zadj;
  n=ivmodel$n;  k=ivmodel$p;  l=ivmodel$L

  if(ncol(Yadj)>1){
    print("The outcome variable should be in one dimension!")
	return(NULL)
  }
  if(ncol(Dadj)>1){
    print("The treatment variable should be in one dimension!")
	return(NULL)
  }
  if(l+k>=n){
    print("Too many IVs, AR can't handle!")
    return(NULL)
  }

### test
  temp=Yadj-beta0*Dadj
  Fstat=c(sum(qr.fitted(ivmodel$ZadjQR, temp)^2))/c(sum(temp^2)-sum(qr.fitted(ivmodel$ZadjQR, temp)^2))*(n-k-l)/l
  p.value=1-pf(Fstat, df1=l, df2=n-k-l)

### confidence interval
  cval=qf(1-alpha, df1=l, df2=n-k-l)*l/(n-k-l)
  coef.beta0sq=cval*sum(Dadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Dadj)^2)
  coef.beta0=-2*cval*sum(Dadj*Yadj)+2*(cval+1)*sum(Dadj*qr.fitted(ivmodel$ZadjQR, Yadj))
  coef.constant=cval*sum(Yadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Yadj)^2)
  Delta=coef.beta0^2-4*coef.constant*coef.beta0sq

  ci=matrix(NA, ncol=2)
  colnames(ci)<-c("lower", "upper")

  if(coef.beta0sq==0){
    if(coef.beta0>0){
      info=c("[",-coef.constant/coef.beta0,",Infinity)")
      ci[1,]=c(-coef.constant/coef.beta0, Inf)
    }
    if(coef.beta0<0){
      info=c("(-Infinity,",-coef.constant/coef.beta0,"]");
      ci[1,]=c(-Inf, -coef.constant/coef.beta0)
    }
    if(coef.beta0==0){
      if(coef.constant>=0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.constant<0){
        info="Empty Set"
      }
    }
  }

  if(coef.beta0sq!=0){
    if(Delta<=0){
      if(coef.beta0sq>0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.beta0sq<0){
        info="Empty Set"
      }
    }
    if(Delta>0){
      # Roots of quadratic equation
      root1=(-coef.beta0+sqrt(Delta))/(2*coef.beta0sq)
      root2=(-coef.beta0-sqrt(Delta))/(2*coef.beta0sq)
      upper.root=max(root1,root2)
      lower.root=min(root1,root2)
      if(coef.beta0sq<0){
        info=paste("[",lower.root,", ",upper.root,"]",sep="")
        ci[1, ]=c(lower.root, upper.root)
      }
      if(coef.beta0sq>0){
        info= paste("(-Infinity,",lower.root,"] union [",upper.root,",Infinity)")
        ci[1, ]=c(-Inf, lower.root)
        ci<-rbind(ci, c(upper.root, Inf))
      }
    }
  }

  return(list(Fstat=Fstat, df=c(l, n-k-l), p.value=p.value,
              ci.info=info, ci=ci))
}

AR.power=function(n, k, l, beta, gamma, Zadj_sq,
                  sigmau, sigmav, rho, alpha=0.05){
  if(length(gamma)!=ncol(as.matrix(Zadj_sq))|length(gamma)!=nrow(as.matrix(Zadj_sq))){
	print("The dimension of Zadj_sq doesn't match gamma")
	stop()
  }
  ncp=beta^2*n*c(t(as.matrix(gamma))%*%as.matrix(Zadj_sq)%*%as.matrix(gamma))/
	    (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)

  temp = qf(1-alpha, df1=l, df2=n-k-l)
  power = 1-pf(temp, df1=l, df2=n-k-l, ncp=ncp)

  return(power)
}

AR.size=function(power, k, l, beta, gamma, Zadj_sq,
                 sigmau, sigmav, rho, alpha=0.05){
  if(length(gamma)!=ncol(as.matrix(Zadj_sq))|length(gamma)!=nrow(as.matrix(Zadj_sq))){
    print("The dimension of Zadj_sq doesn't match gamma")
	stop()
  }
  ncp=beta^2*c(t(as.matrix(gamma))%*%as.matrix(Zadj_sq)%*%as.matrix(gamma))/
	  (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)

  oldn<-k+l+1
  state<-1
  while(state){
    temp = qf(1-alpha, df1=l, df2=oldn-k-l)
    temppower = 1-pf(temp, df1=l, df2=oldn-k-l, ncp=ncp*oldn)
    if(temppower < power){
	  oldn <- oldn*2
	}else{
	  state <- 0
	}
  }

  lower <- oldn%/%2
  upper <- oldn
  while((upper-lower)>2){
    new <- (upper+lower)%/%2
    temp = qf(1-alpha, df1=l, df2=oldn-k-l)
    temppower = 1-pf(temp, df1=l, df2=oldn-k-l, ncp=ncp*new)
    if(temppower < power){
	  lower <- new
	}else{
	  upper <- new
	}
  }

  return(upper)
}