# load data
all_global_data <- read.table("global-dump.txt",
                              header = TRUE,
                              sep="\t",
                              col.names=c("ap", "pr","au", "gt",
                                          "rms", "pklv", "rssi", "snr", "loc"),
                              fill=FALSE,
                              strip.white=TRUE)

phone_data_gt <- all_global_data[c("gt", "ap", "rms", "pklv", "rssi")]
phone_data_pr <- all_global_data[c("pr", "ap", "rms", "pklv", "rssi")]

# for evaluation
library(caret)
fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

<<<<<<< HEAD

=======
##############################################################################
# For Head Count (Ground truth)
##############################################################################
>>>>>>> deb4eee798046ff3050e2fdc49aff179daa28237
# Linear forward selection
library(caret)
tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.gt.forward <- train(gt~., data=phone_data_gt, method="leapForward",
                   trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(linear.gt.forward)

tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.pr.forward <- train(pr~., data=phone_data_pr, method="leapForward",
                   trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(linear.pr.forward)

# linear backward selection
library(caret)
tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.gt.backward <- train(gt~., data=phone_data_gt, method="leapBackward",
                   trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(linear.gt.backward)

tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.pr.backward <- train(pr~., data=phone_data_pr, method="leapBackward",
                   trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(linear.pr.forward)

# linear stepwise selection
library(caret)
tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.gt.stepwise <- train(gt~., data=phone_data_gt, method="leapSeq",
                   trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(linear.gt.stepwise)
<<<<<<< HEAD
lm(gt~., data = phone_data_gt)
=======
>>>>>>> deb4eee798046ff3050e2fdc49aff179daa28237

tuning_params <- expand.grid(nvmax=seq(1,4,1))
set.seed(100)
linear.pr.stepwise <- train(pr~., data=phone_data_pr, method="leapSeq",
                   trControl=fit_control, tuneGrid = tuning_params)
<<<<<<< HEAD
plotWithBars(linear.pr.stepwise)
lm(pr~., data = phone_data_pr)

=======
plotWithBars(linear.pr.forward)
>>>>>>> deb4eee798046ff3050e2fdc49aff179daa28237

#kNN
library(caret)
fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)
tuning_params <- expand.grid(k=seq(1,30,1))
set.seed(100)
knn.gt <- train(gt~., data=phone_data_gt, method="knn",
                trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(knn.gt)

fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)
tuning_params <- expand.grid(k=seq(1,30,1))
set.seed(100)
knn.pr <- train(pr~., data=phone_data_pr, method="knn",
                trControl=fit_control, tuneGrid = tuning_params)
plotWithBars(knn.pr)

# k-fold cross validation function
crossval.svm <- function(k = 10, epsilon = 0.1, cost = 1, coef0 = 0, nu=0, kernel="radial",
                         type="eps-regression", data="gt"){
  library(caret)
  library(e1071)

  if (data=="gt") {
    df <- phone_data_gt
    set.seed(100)
    folds <- createFolds(phone_data_gt[,c("gt")], k = k,
                         list = TRUE, returnTrain = FALSE)
    formula <- gt~.
  } else {
    df <- phone_data_pr
    set.seed(100)
    folds <- createFolds(phone_data_pr[,c("pr")], k = k,
                         list = TRUE, returnTrain = FALSE)
    formula <- pr~.
  }

  svm.accuracies <- c()
  for (i in 1:10) {
    if (type=="eps-regression") {
      model <- svm(formula, df[-folds[[i]],],
                   epsilon=epsilon,
                   cost=cost,
                   coef0=coef0,
                   type=type,
                   kernel=kernel
      )
    } else {
      model <- svm(formula, df[-folds[[i]],],
                   nu=nu,
                   cost=cost,
                   coef0=coef0,
                   type=type,
                   kernel=kernel
      )
    }

    if (data=="gt") {
      predictions <- predict(model, phone_data_gt[-folds[[i]],])

      rmse <- sqrt(mean((phone_data_gt[-folds[[i]],]$gt - predictions)^2))
      svm.accuracies = append(rmse, svm.accuracies)
    } else {
      predictions <- predict(model, phone_data_pr[-folds[[i]],])

      rmse <- sqrt(mean((phone_data_pr[-folds[[i]],]$pr - predictions)^2))
      svm.accuracies = append(rmse, svm.accuracies)
    }
  }

  return(svm.accuracies)
}

# plot the result with error bars
plotWithBars <- function(model){
  library(ggplot2)

  foo <- model$results
  title <- paste("The Performance of", model$modelInfo$label, sep=" ")
  colnames(foo)[1] <- "params"

  ggplot(foo, aes(x=params, y=RMSE)) +
    geom_errorbar(aes(ymin=RMSE-RMSESD, ymax=RMSE+RMSESD), width=.1) +
<<<<<<< HEAD
    geom_line() + geom_point() +
    # expand_limits(y = 0)+
    theme_bw()+
=======
    geom_line() + geom_point()+ expand_limits(y = 0)+ theme_bw()+
>>>>>>> deb4eee798046ff3050e2fdc49aff179daa28237
    xlab(model$modelInfo$parameters$label) +
    ylab("RMSE (Repeated Cross-Validation)") +
    ggtitle(title)
}
plotWithBars(knn.gt)

##############################################################################
# SVM
##############################################################################

# headcount ###########
library(e1071)
tune_control <- tune.control(sampling = "cross", cross=10)

# ap-only as predictor
set.seed(100)
tuneResult <- tune(svm, gt~ap,  data=phone_data_gt,
                   ranges = list(epsilon = seq(0,0.5,0.01), cost = (1:10)),
                   tunecontrol=tune_control)

std <- function(x) sd(x)/sqrt(length(x))
se <- function(x) sqrt(var(x)/length(x))
std(c(1,2,3,4))
sd(c(1,2,3,4))
var(c(1,2,3,4))
se(c(1,2,3,4))

# eps-regression
set.seed(100)
tuneResult.eps.linear.gt <- tune(svm, gt~.,  data=phone_data_gt,
                              ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                            kernel="linear", type="eps-regression"),
                              tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = 0,
                             cost = 4,
                             kernel = "linear",
                             type = "eps-regression",
                             data="pr")
mean(svm.accuracy)

set.seed(100)
tuneResult.eps.rad.gt <- tune(svm, gt~.,  data=phone_data_gt,
                            ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                          kernel="radial", type="eps-regression"),
                            tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.rad.gt$best.parameters$epsilon,
                             cost = tuneResult.eps.rad.gt$best.parameters$cost,
                             kernel = "radial",
                             type = "eps-regression")
mean(svm.accuracy)

set.seed(100)
tuneResult.eps.sig.gt <- tune(svm, gt~.,  data=phone_data_gt,
                            ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                          kernel="sig", coef0=(1:5),
                                          type="eps-regression"),
                            tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.sig.gt$best.parameters$epsilon,
                             cost = tuneResult.eps.sig.gt$best.parameters$cost,
                             kernel = "sigmoid",
                             coef0=tuneResult.eps.sig.gt$best.parameters$coef0,
                             type = "eps-regression")
mean(svm.accuracy)

# nu-regression
set.seed(100)
tuneResult.nu.linear.gt <- tune(svm, gt~.,  data=phone_data_gt,
                            ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                          kernel="linear", type="nu-regression"),
                            tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.sig.gt$best.parameters$nu,
                             cost = tuneResult.nu.sig.gt$best.parameters$cost,
                             kernel = "linear",
                             type = "nu-regression")
mean(svm.accuracy)

set.seed(100)
tuneResult.nu.rad.gt <- tune(svm, gt~.,  data=phone_data_gt,
                           ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                         kernel="radial", type="nu-regression"),
                           tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.rad.gt$best.parameters$nu,
                             cost = tuneResult.nu.rad.gt$best.parameters$cost,
                             kernel = "radial",
                             type = "nu-regression")
mean(svm.accuracy)

set.seed(100)
tuneResult.nu.sig.gt <- tune(svm, gt~.,  data=phone_data_gt,
                           ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                         kernel="sig", coef0=(1:5),
                                         type="nu-regression"),
                           tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.sig.gt$best.parameters$nu,
                             cost = tuneResult.nu.sig.gt$best.parameters$cost,
                             kernel = "sigmoid",
                             coef0=tuneResult.nu.sig.gt$best.parameters$coef0,
                             type = "nu-regression")
mean(svm.accuracy)

# unique device ###########
# eps-regression
set.seed(100)
tuneResult.eps.linear.pr <- tune(svm, pr~.,  data=phone_data_pr,
                                 ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                               kernel="linear", type="eps-regression"),
                                 tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.linear.pr$best.parameters$epsilon,
                             cost = tuneResult.eps.linear.pr$best.parameters$cost,
                             kernel = "linear",
                             type = "eps-regression",
                             data = "pr")
mean(svm.accuracy)

set.seed(100)
tuneResult.eps.rad.pr <- tune(svm, pr~.,  data=phone_data_pr,
                              ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                            kernel="radial", type="eps-regression"),
                              tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.rad.pr$best.parameters$epsilon,
                             cost = tuneResult.eps.rad.pr$best.parameters$cost,
                             kernel = "radial",
                             type = "eps-regression",
                             data = "pr")
mean(svm.accuracy)

set.seed(100)
tuneResult.eps.sig.pr <- tune(svm, pr~.,  data=phone_data_pr,
                              ranges = list(epsilon = seq(0,1,0.1), cost = (1:10),
                                            kernel="sig", coef0=(1:5),
                                            type="eps-regression"),
                              tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.sig.pr$best.parameters$epsilon,
                             cost = tuneResult.eps.sig.pr$best.parameters$cost,
                             kernel = "sigmoid",
                             type = "eps-regression",
                             data = "pr",
                             coef0 = tuneResult.eps.sig.pr$best.parameters$coef0)
mean(svm.accuracy)

# nu-regression
set.seed(100)
tuneResult.nu.linear.pr <- tune(svm, pr~.,  data=phone_data_pr,
                                ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                              kernel="linear", type="nu-regression"),
                                tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.linear.pr$best.parameters$nu,
                             cost = tuneResult.nu.linear.pr$best.parameters$cost,
                             kernel = "linear",
                             type = "nu-regression",
                             data = "pr")
mean(svm.accuracy)

set.seed(100)
tuneResult.nu.rad.pr <- tune(svm, pr~.,  data=phone_data_pr,
                             ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                           kernel="radial", type="nu-regression"),
                             tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.rad.pr$best.parameters$nu,
                             cost = 100000,
                             kernel = "radial",
                             type = "nu-regression",
                             data = "pr")
mean(svm.accuracy)

set.seed(100)
tuneResult.nu.sig.pr <- tune(svm, pr~.,  data=phone_data_pr,
                             ranges = list(nu = seq(0.1,1,0.1), cost = (1:10),
                                           kernel="sig", coef0=(1:5),
                                           type="nu-regression"),
                             tunecontrol=tune_control)
svm.accuracy <- crossval.svm(k = 10,
                             nu = tuneResult.nu.sig.pr$best.parameters$nu,
                             cost = tuneResult.nu.sig.pr$best.parameters$cost,
                             kernel = "sigmoid",
                             type = "nu-regression",
                             data = "pr",
                             coef0 = tuneResult.nu.sig.pr$best.parameters$coef0)
mean(svm.accuracy)

# high C value
highC <- c(100000,10000,3000,2000,1000)
highCmean <- c()
highCsd <- c()
svm.accuracy <- crossval.svm(k = 10,
                             epsilon = tuneResult.eps.rad.gt$best.parameters$epsilon,
                             cost = 100000,
                             kernel = "radial",
                             type = "eps-regression")
mean(svm.accuracy)
sd(svm.accuracy)
highCmean <- append(mean(svm.accuracy), highCmean)
highCsd <- append(sd(svm.accuracy), highCsd)
df <- data.frame(highC, highCmean, highCsd)

# plot the result
ggplot(df, aes(x=highC, y=highCmean)) +
geom_errorbar(aes(ymin=highCmean-highCsd, ymax=highCmean+highCsd), width=.1) +
geom_line() + geom_point()+ expand_limits(y = 0)+ theme_bw()+
xlab("Cost") +
ylab("RMSE (Cross-Validation)")
+
ggtitle()

# the code below was not used
# polynomial kernels
# these took so long time to execute
# warning maximum number of loop is also received
set.seed(100)
tuneResult.nu.poly.gt <- tune(svm, gt~.,  data=phone_data_gt,
                              ranges = list(nu = seq(0.1,1,0.1),
                                            kernel="poly", coef0=(1:5), degree=(1:5),
                                            type="nu-regression"),
                              tunecontrol=tune_control)
set.seed(100)
tuneResult.eps.poly.gt <- tune(svm, gt~.,  data=phone_data_gt,
                               ranges = list(epsilon = seq(0,1,0.1),
                                             kernel="poly", coef0=(1:5), degree=(1:5),
                                             type="eps-regression"),
                               tunecontrol=tune_control)

set.seed(100)
tuneResult.nu.poly.pr <- tune(svm, pr~.,  data=phone_data_pr,
                              ranges = list(nu = seq(0.1,1,0.1),
                                            kernel="poly", coef0=(1:5), degree=(1:5),
                                            type="nu-regression"),
                              tunecontrol=tune_control)

set.seed(100)
tuneResult.eps.poly.pr <- tune(svm, pr~.,  data=phone_data_pr,
                               ranges = list(epsilon = seq(0,1,0.1),
                                             kernel="poly", coef0=(1:5), degree=(1:5),
                                             type="eps-regression"),
                               tunecontrol=tune_control)


#' Balance test of Covariates across treatments
#'
#' @description This function implements F-test for the null hypothesis that
#'     observed variables are balanced across treatments.
#'     First, this function runs a linear regression of covariate on treatments,
#'     using `lm()`.
#'     After that, we obtaine F-statistics and its p-value, using `anova()`.
#'
#' @param x a formula object whose right hand side is covariates (`~ x1 + x2`).
#' @param d a formula object whose right hand side is treatment variable (`~ d`)
#' @param data an object whose class is `data.frame`
#'
#' @return A matrix including mean of covariate in each treatment and
#'     p-value of F-statistics. This matrix has `RCT` and `xbalance` classes.
#'
#' @importFrom purrr map
#' @importFrom purrr reduce
#' @importFrom magrittr %>%
#'
#' @export
#+
fbalance <- function(x, d, data) {

  # make formula
  xvar <- all.vars(x)
  model <- xvar %>%
    map(~ paste0(., "~", all.vars(d))) %>%
    map(~ as.formula(.))

  # estimate OLS and extract p-value of F-value via anova()
  ols1 <- model %>% map(~ lm(., data = data))
  pval <- ols1 %>% map(~ anova(.)[["Pr(>F)"]][1])

  # extract average value of each treatment via lm()
  ols2 <- model %>% map(~ lm(update(., . ~ -1 + .), data = data))
  mu <- ols2 %>% map(~ coef(.))

  # make matric including results
  tab <- seq_len(length(model)) %>%
    map(~ matrix(c(mu[[.]], pval[[.]]), nrow = 1)) %>%
    reduce(rbind)

  colnames(tab) <- c(names(mu[[1]]), "p-value (F test)")
  rownames(tab) <- xvar

  # return
  class(tab) <- append(c("RCT", "xbalance"), class(tab))
  return(tab)

}


F08XPJ Example Program Results

Number of eigenvalues for which SELCTG is true = 2
(dimension of deflating subspaces)

Selected generalized eigenvalues
 1      (2.00, -5.00)
 2      (3.00, -1.00)


library('lavaan')

setwd('~/git/sem_python/tests')
data <- read.csv('HolzingerSwineford1939.csv')

model <- '
visual  =~ x1 + x2 + x3
textual =~ x4 + x5 + x6
speed   =~ x7 + x8 + x9
'

fit <- cfa(model, data = data, auto.fix.first = FALSE, std.lv = TRUE)
summary(fit)


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

# Regressor
library(e1071)
regressor = svm(formula = Salary ~.,
                data = dataset,
                type = 'eps-regression')

# Predicting a new result
y_pred = predict(regressor, data.frame(Level = 6.5))

# Visualising the result
library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.1)
ggplot() +
    geom_point(aes(x = dataset$Level, y = dataset$Salary),
               colour = 'red') +
    geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level = x_grid))),
              colour = 'blue') +
    ggtitle('SVR salary progression') +
    xlab('Position') +
    ylab('Salary')


H=100
f=rep(F,H)
which(Reduce(function(d,n) xor(replace(f,seq(n,H,n),T),d), 1:H, f))


=begin
  # sample-map01.rb

  require "algebra"
  a = Map[0=>2, 1=>2, 2=>0]
  b = Map[0=>1, 1=>1, 2=>1]
  p a * b #=> {0=>2, 1=>2, 2=>2}
((<_|CONTENTS>))
=end


library(ggplot2)
library(psych)
#load data
data <- read.csv("Downloads/MachineLearning-master/Example Data/OLS_Regression_Example_3.csv", stringsAsFactors=F)
#replace gender with 0 and 1, male and female respectively
data$Gender[which(data$Gender=="Male")] = 0
data$Gender[which(data$Gender=="Female")] = 1
#change us metrics to eu matrics
data$Height = data$Height * 2.54
data$Weight = data$Weight * 0.45359237
#plot data (human)
human.plot <- ggplot(data)
human.plot + geom_point(aes(x = Height, y = Weight)) + labs(title = "Weight and heights for male and females")
#plot data (female and male separate)
maleFemale.plot <- ggplot(data)
maleFemale.plot + geom_point(aes(x = Height, y = Weight, color = Gender)) + labs(title = "Weight and heights for male and females")
#visualize the correlation
pairs.panels(data[c("Gender", "Height", "Weight")])
#train a linear model
lm_model <- lm(Weight~Gender+Height, data=data)
summary(lm_model)
#predict a test data
test.data <- data.frame(0, 170)
colnames(test.data) <- c("Gender", "Height")
test.data$Gender <- as.factor(test.data$Gender)
predict(lm_model, test.data)


# functon to scale effort, such that catchability becomes close to one,
# mean.Z is mean Z at age
# N1 is mean stock number at age 1
#
scale.effort<-function(FLIndices,N,mean.Z=1,N1=300000){
    n.ages<-20

    N<-rep(NA,n.ages)
    N[1]<-N1*exp(mean.Z)
    N[2]<-N1
    for (i in (3:n.ages)) N[i]<-N[i-1]*exp(-mean.Z)
    j<-1
    fact<-rep(NA,length(FLIndices))
    for (fl in (FLIndices)) {
        catch<-as.vector(yearMeans(fl@catch.n))
        eff<-as.numeric(yearMeans(fl@effort))
        CPUE<-catch/eff
        a1<-fl@range["min"]+1
        a2<-fl@range["max"]+1
        q<-CPUE/N[a1:a2]
        fac<-mean(q)
        i<-1E12
        while (TRUE) if ((fac/i)>1) break else i<-i/10
        fact[j]<-i
        fl@effort<-fl@effort*i
        fl@index<-fl@index/i
        FLIndices[[j]]<-fl
        j<-j+1

    }
    cat("\nScaling factors by index:\n",fact,"\n")
    FLIndices
}


#######################################
# Research Methods for Global Studies #
# R demo - class 5	                  #
#######################################

# More on random numbers and chaos: Logistic Map example
n = 5000
r = 3.9
x1 = .5
x = rep(NA, n)
x[1] = x1
for(i in 1:(n-1)){
  x[i+1] = r*x[i]*(1-x[i])
}
plot(x, type="l")

plot(x, jitter(rep(1, n), 10), pch=19, cex=.5, col="#0000ff22")

hist(x)

dx = density(x)
plot(dx)
points(x, jitter(rep(1, n), 10), pch=19, cex=.5, col="#0000ff22")
lines(dx)

# Coin flips
c = rbinom(10, 1, .5)
mean(c)

c = rbinom(100, 100, .5)
hist(c)

# Sampling
pop = x
plot(density(pop))
mean(pop)
var(pop)
sd(pop)
quantile(pop, c(.05, .5, .95))

s = sample(pop, 10, replace=TRUE)
mean(s)
var(s)

s_means = sapply(1:10000, function(i) mean(sample(pop, 50, replace=TRUE)))
plot(density(s_means))

mean(s_means)
mean(pop)
var(s_means)
var(pop)


sal  = read.csv("//<Path>//")
sortedSalary = sort(sal$Salary)
plot(sal$Salary,sal$Yrs.since.phd)
regressionModel = lm(sal$Yrs.since.phd ~ sal$Salary)
abline(regressionModel)
qqnorm(sortedSalary)
qqline(sortedSalary)


data(NYTimes)
data <- NYTimes[ samples(1:3100, size=1000,replace=F) ]

matrix <- create_matrix(cbind(as.vector(data$Title),as.vector(data$Subject)), language="english", removeNumbers=TRUE, stemWords=TRUE)
k <- length(unique(data$Topic.Code))
lda <- LDA(matrix, k)

print(lda@gamma[1,])
plot(colSums(lda@gamma)/nrow(lda@gamma),t='h')

sum(sapply( 1:nrow(lda@gamma), function(i) sum(lda@gamma[i,]>0.1) > 1))


 #============
 #digits: get number of bits of an integer
 #		 or a floating number.
 #		 [-1,1] return negative values
 #		 0 return 1
 #		others return positive values
 #============
digits<-function(num){
	digt<-0
	if(num==0){
		return(1)
	}
	if(num<1 & num>-1 & num!=0){
		residule<-0
		while(residule==0){
			residule<-round(num,digits=digt)
			digt<-digt+1
		}
	return(-digt+1)
	}else{
		residule<- num
		while(residule!=0){
			residule<-round(residule/10)
			digt<-digt+1
		}
		return(digt-1)
	}
}

#==========
#getGrid: Derive grid with two input vector
#		    (general function)
#==========
getGrid<-function(lon,lat){
	lon_<-rep(lon,length(lat))
	lat_<-sort(rep(lat,length(lon)))
	grid<-as.data.frame(cbind("lon"=lon_,"lat"=lat_))
	grid
}

#==========
#维持在同个scale上，即原res是多少，输出应在同一个数量级上
#==========
roundUnregular<-function(data){
	diff<-diff(sort(unique(data$lon)))
	digit<-1
	while(!all(diff==diff[1])){
		lon<-round(data$lon/digit)*digit
		#data$lat<-round(data$lat/digit)*digit
		diff<-diff(sort(unique(lon)))
		#cat(digit, "  ")
		digit<-digit+1000
	}
	digit<-1
	diff<-diff(sort(unique(data$lat)))
	while(!all(diff==diff[1])){
		lat<-round(data$lat/digit)*digit
		#data$lat<-round(data$lat/digit)*digit
		diff<-diff(sort(unique(lat)))
		#cat(digit, "  ")
		digit<-digit+1000
	}
	if(digit!=1){
	data$lon<-lon
	data$lat<-lat
	}
	 #cat("map(res=", "Deg) will be projected on a ", length(unique(data$lon)),
	#	"*",length(unique(data$lat)), " grid. \n",sep="")

	 data
}

#==========
#
#==========
getRegularGrid<-function(data,res){
	data<-roundUnregular(data,res)
	lon<-sort(unique(data$lon))
	lat<-sort(unique(data$lat))
	grid<-getGrid(lon,lat)
	grid
}


#Data munging
# repeate op on a matrix using apply
# repeat op on a list
# mapply
# aggregate

# Don't use a loop, really

myMatrix <- matrix(1:9, nrow=3)
apply(myMatrix, MARGIN = 2, sum)

# but there are built in ops for these
colSums(myMatrix)
rowSums(myMatrix)

myMatrix[2,1] <- NA
rowSums(myMatrix)
# get around NA
apply(myMatrix, 1, sum, na.rm=TRUE)

#iterate over a list
myList <- list(A=myMatrix, B=1:5, C=matrix(1:4, 2), D=2)
lapply(myList, sum, na.rm=TRUE)
sapply(myList, sum, na.rm=TRUE)

#lapply works on vectors as they are lists
someNames <- c("Shawn", "Sean", "Seathan")
lapply(someNames, nchar)

#mapply
firstList <- list(A=matrix(1:16,4), B=matrix(1:16,2), C=1:5)
secondList <- list(A=matrix(1:16,4), B=matrix(1:16,8), C=15:1)

mapply(identical, firstList, secondList)
mapply(sum, firstList, secondList)

#subsets of data using aggregate
require(ggplot2)
data(diamonds)
head(diamonds)
mean(diamonds$price)
aggregate(price ~ cut, diamonds, mean)
aggregate(price ~ cut + color, diamonds, mean)
aggregate(cbind(price, carat) ~ cut + color, diamonds, mean)

#plyr
require(plyr)
head(baseball)
baseball$sf[baseball$year < 1954] <- 0
any(is.na(baseball$sf))
baseball$hbp[is.na(baseball$hbp)] <- 0
any(is.na(baseball$hbp))
baseball <- baseball[baseball$ab >= 50, ]
baseball$obp <- with(baseball, (h + bb + hbp) / (ab + bb + hbp + sf))
obp <- function(data){
    return(c(OBP= with(data, sum(h + bb + hbp) / sum(ab + bb + hbp + sf))))
}
careerOBP <- ddply(baseball, .variables = "id", obp)
careerOBP <- careerOBP[order(careerOBP$OBP, decreasing = TRUE), ]

#llply
myList <- list(A=matrix(1:9, 3), B=1:5, C=matrix(1:4, 2), D=2)
lapply(myList, sum)
llply(myList, sum)
identical(lapply(myList, sum), llply(myList, sum))

sapply(myList, sum)
laply(myList, sum)

#helper functions
aggregate(price ~ cut, diamonds, each(mean, median))
numcolwise(sum, na.rm=TRUE)(diamonds)
sapply(diamonds[, sapply(diamonds, is.numeric)], sum)

#combine datasets
sports <- c("Hockey", "Baseball", "football")
leagues <- c("NHL", "MBA", "NFL")
trophy <- c("Stanley Cup", "Commissioner's Trophy", "Vince Lombardi Trophy")

sports1 <- cbind(sports, leagues, trophy)

sports2 <- data.frame(sports=c("Basketball", "Golf"),
                      leagues=c("NBA", "PGA"),
                      trophy=c("Larry O'Brien Championship Trophy", "Wanamaker Trophy"))

sports <- rbind(sports1, sports2)

#cbind is for adding columns from different vectors or df
#rbind will add rows to a new df

#join datasets

codes <- read.table("http://www.jaredlander.com/data/countryCodes.csv ", sep = ",", stringsAsFactors = FALSE)
countries <- read.table("http://www.jaredlander.com/data/GovType.csv ", sep = ",", stringsAsFactors = FALSE)

View(countries)

#to join we can use merge
countryMerged <- merge(x=codes, y=countries, by.x="Country name", by.y="Country")


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('longit')
knitr::read_chunk('~/doc/rms/Longitudinal/shared.R')

## ----spaghetti,h=5,w=7,ps=7,cap='Time profiles for individual subjects, stratified by study site and dose'----
require(rms)
options(prType='latex')    # for model print, summary, anova
getHdata(cdystonia)
attach(cdystonia)

# Construct unique subject ID
uid <- with(cdystonia, factor(paste(site, id)))

# Tabulate patterns of subjects' time points
table(tapply(week, uid,
             function(w) paste(sort(unique(w)), collapse=' ')))

# Plot raw data, superposing subjects
xl <- xlab('Week'); yl <- ylab('TWSTRS-total score')
ggplot(cdystonia, aes(x=week, y=twstrs, color=factor(id))) +
       geom_line() + xl + yl + facet_grid(treat ~ site) +
       guides(color=FALSE) # Fig. (*\ref{fig:longit-spaghetti}*)

## ----quartiles,cap='Quartiles of \\co{TWSTRS} stratified by dose',w=5,h=4-----
# Show quartiles
require(data.table)
cdystonia <- data.table(cdystonia)
cdys <- cdystonia[, j=as.list(quantile(twstrs, (1 : 3)/4)),
                  by = list(treat, week)]
cdys <- upData(cdys, rename=c('25%'='Q1', '50%'='Q2', '75%'='Q3'), print=FALSE)
ggplot(cdys, aes(x=week, y=Q2)) + xl + yl + ylim(0, 70) +
  geom_line() + facet_wrap(~ treat, nrow=2) +
  geom_ribbon(aes(ymin=Q1, ymax=Q3), alpha=0.2)   # Fig. (*\ref{fig:longit-quartiles}*)

## ----e------------------------------------------------------------------------
baseline <- subset(data.frame(cdystonia,uid), week == 0,
                   -week)
baseline <- upData(baseline, rename=c(twstrs='twstrs0'),
                   print=FALSE)
followup <- subset(data.frame(cdystonia,uid), week > 0,
                   c(uid,week,twstrs))
rm(uid)
both     <- merge(baseline, followup, by='uid')

dd       <- datadist(both)
options(datadist='dd')

## ----k------------------------------------------------------------------------
require(nlme)
cp <- list(corCAR1,corExp,corCompSymm,corLin,corGaus,corSpher)
z  <- vector('list',length(cp))
for(k in 1:length(cp)) {
  z[[k]] <- gls(twstrs ~ treat * rcs(week, 3) +
                rcs(twstrs0, 3) + rcs(age, 4) * sex, data=both,
                correlation=cp[[k]](form = ~week | uid))
}
anova(z[[1]],z[[2]],z[[3]],z[[4]],z[[5]],z[[6]])

## ----l,results='asis'---------------------------------------------------------
a <- Gls(twstrs ~ treat * rcs(week, 3) + rcs(twstrs0, 3) +
         rcs(age, 4) * sex, data=both,
         correlation=corCAR1(form=~week | uid))
a

## ----variogram,cap='Variogram, with assumed correlation pattern superimposed'----
v <- Variogram(a, form=~ week | uid)
plot(v)  # Figure (*\ref{fig:longit-variogram}*)

## ----resid,h=6,w=7.5,cap='Three residual plots to check for absence of trends in central tendency and in variability.  Upper right panel shows the baseline score on the $x$-axis.  Bottom left panel shows the mean $\\pm 2\\times$SD.  Bottom right  panel is the QQ plot for checking normality of residuals from the GLS fit.',scap='Residual plots for GLS model'----
both$resid <- r <- resid(a); both$fitted <- fitted(a)
yl <- ylab('Residuals')
p1 <- ggplot(both, aes(x=fitted, y=resid)) + geom_point() +
      facet_grid(~ treat) + yl
p2 <- ggplot(both, aes(x=twstrs0, y=resid)) + geom_point()+yl
p3 <- ggplot(both, aes(x=week, y=resid)) + yl + ylim(-20,20) +
      stat_summary(fun.data="mean_sdl", geom='smooth')
p4 <- ggplot(both, aes(sample=resid)) + stat_qq() +
      geom_abline(intercept=mean(r), slope=sd(r)) + yl
gridExtra::grid.arrange(p1, p2, p3, p4, ncol=2)   # Figure (*\ref{fig:longit-resid}*)

## ----anova,results='asis',w=3.25,h=2.25,cap='Results of \\fu{anova} from generalized least squares fit with continuous time AR1 correlation structure.  As expected, the baseline version of $Y$ dominates.',scap='ANOVA for GLS model'----
plot(anova(a))     # Figure (*\ref{fig:longit-anova}*)

## ----pleffects,h=5,w=7,cap='Estimated effects of time, baseline TWSTRS, age, and sex'----
ylm <- ylim(25, 60)
p1 <- ggplot(Predict(a, week, treat, conf.int=FALSE),
             adj.subtitle=FALSE, legend.position='top') + ylm
p2 <- ggplot(Predict(a, twstrs0), adj.subtitle=FALSE) + ylm
p3 <- ggplot(Predict(a, age, sex), adj.subtitle=FALSE,
             legend.position='top') + ylm
gridExtra::grid.arrange(p1, p2, p3, ncol=2)   # Figure (*\ref{fig:longit-pleffects}*)

## ----o,results='asis'---------------------------------------------------------
summary(a)  # Shows for week 8

## ----p------------------------------------------------------------------------
# To get results for week 8 for a different reference group
# for treatment, use e.g. summary(a, week=4, treat='Placebo')

# Compare low dose with placebo, separately at each time
k1 <- contrast(a, list(week=c(2,4,8,12,16), treat='5000U'),
                  list(week=c(2,4,8,12,16), treat='Placebo'))
options(width=80)
print(k1, digits=3)

## ----q------------------------------------------------------------------------
# Compare high dose with placebo
k2 <- contrast(a, list(week=c(2,4,8,12,16), treat='10000U'),
                  list(week=c(2,4,8,12,16), treat='Placebo'))
print(k2, digits=3)

## ----contrasts,h=3,w=5.5,cap='Contrasts and 0.95 confidence limits from GLS fit'----
k1 <- as.data.frame(k1[c('week', 'Contrast', 'Lower', 'Upper')])
p1 <- ggplot(k1, aes(x=week, y=Contrast)) + geom_point() +
      geom_line() + ylab('Low Dose - Placebo') +
      geom_errorbar(aes(ymin=Lower, ymax=Upper), width=0)
k2 <- as.data.frame(k2[c('week', 'Contrast', 'Lower', 'Upper')])
p2 <- ggplot(k2, aes(x=week, y=Contrast)) + geom_point() +
      geom_line() + ylab('High Dose - Placebo') +
      geom_errorbar(aes(ymin=Lower, ymax=Upper), width=0)
gridExtra::grid.arrange(p1, p2, ncol=2)   # Figure (*\ref{fig:longit-contrasts}*)

## ----nomogram,h=5,w=6,cap='Nomogram from GLS fit.  Second axis is the baseline score.',scap='Nomomgram from GLS fit.'----
n <- nomogram(a, age=c(seq(20, 80, by=10), 85))
plot(n, cex.axis=.55, cex.var=.8, lmgp=.25)  # Figure (*\ref{fig:longit-nomogram}*)


library(keras)

# Data Preparation ---------------------------------------------------

batch_size <- 128
num_classes <- 10
epochs <- 30

# The data, shuffled and split between train and test sets
c(c(x_train, y_train), c(x_test, y_test)) %<-% dataset_mnist()

x_train <- array_reshape(x_train, c(nrow(x_train), 784))
x_test <- array_reshape(x_test, c(nrow(x_test), 784))

# Transform RGB values into [0,1] range
x_train <- x_train / 255
x_test <- x_test / 255

cat(nrow(x_train), 'train samples\n')
cat(nrow(x_test), 'test samples\n')

# Convert class vectors to binary class matrices
y_train <- to_categorical(y_train, num_classes)
y_test <- to_categorical(y_test, num_classes)

# Define Model --------------------------------------------------------------

model <- keras_model_sequential()
model %>%
  layer_dense(units = 256, activation = 'relu', input_shape = c(784)) %>%
  layer_dropout(rate = 0.4) %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dropout(rate = 0.3) %>%
  layer_dense(units = 10, activation = 'softmax')

summary(model)

model %>% compile(
  loss = 'categorical_crossentropy',
  optimizer = optimizer_rmsprop(),
  metrics = c('accuracy')
)

# Training & Evaluation ----------------------------------------------------

# Fit model to data
history <- model %>% fit(
  x_train, y_train,
  batch_size = batch_size,
  epochs = epochs,
  verbose = 1,
  validation_split = 0.2
)

plot(history)

score <- model %>% evaluate(
  x_test, y_test,
  verbose = 0
)

# Output metrics
cat('Test loss:', score[[1]], '\n')
cat('Test accuracy:', score[[2]], '\n')


#' Marginal function for use in fit.vine.copula: empirical distribution function
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param reflect_bounds If true, reflect samples across bounds to improve the estimate near the boundaries.
#' @export
fit.marginal.ecdf <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), reflect_bounds = T) {
    marginal <- list()
    marginal$type <- "ecdf"

    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal$ecdfs <- apply(x, 2, ecdf)
    marginal$varnames <- colnames(x)
    marginal$x <- x
    marginal$x_reflected <- list()
    marginal$correction_factor <- rep(1, ncol(x))
    for (i in 1:ncol(x)) {
        marginal$x_reflected[[i]] <- x[, i]
        if (reflect_bounds) {
            if (bounds[i, 1] != -Inf) {
                reflected <- bounds[i, 1] - (x[, i] - bounds[i, 1])
                marginal$x_reflected[[i]] <- c(marginal$x_reflected[[i]], reflected)
                marginal$correction_factor[i] <- marginal$correction_factor[i] + 1
            }
            if (bounds[i, 2] != Inf) {
                reflected <- bounds[i, 2] + (bounds[i, 2] - x[, i])
                marginal$x_reflected[[i]] <- c(marginal$x_reflected[[i]], reflected)
                marginal$correction_factor[i] <- marginal$correction_factor[i] + 1
            }
        }
    }

    marginal$bw <- rep(NA, ncol(x))
    for (i in 1:ncol(x)) {
        hmax <- 10 * sd(marginal$x_reflected[[i]])
        marginal$bw[i] <- bw.SJ(marginal$x_reflected[[i]], lower = 1e-6 * hmax, upper = hmax)
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Marginal function for use in fit.vine.copula: single parametric distribution
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
fit.marginal.parametric <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x)))) {
    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal <- list()
    marginal$type <- "parametric"
    marginal$dists <- list()
    fitctrl <- list(maxit = 1000)
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] >= bounds[i, 2]) {
            stop("Upper bound must be strictly higher than lower bound")
        }

        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> beta
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- 0
            marginal$dists[[i]]$max <- 1
            dfit <- MASS::fitdistr(x[, i], dbeta, list(shape1 = 1, shape2 = 1), control = fitctrl)
            marginal$dists[[i]]$shape1 <- as.numeric(dfit$estimate["shape1"])
            marginal$dists[[i]]$shape2 <- as.numeric(dfit$estimate["shape2"])
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> gamma
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "gamma"
            rescale <- 1 / mean(x[, i])
            dfit <- MASS::fitdistr(x[, i], dgamma, list(shape = 2, scale = 1), control = fitctrl)
            dfit <- MASS::fitdistr(x[, i] * rescale, dgamma, list(shape = 2, scale = 1), control = fitctrl)
            marginal$dists[[i]]$shape <- as.numeric(dfit$estimate["shape"])
            marginal$dists[[i]]$scale <- as.numeric(dfit$estimate["scale"]) / rescale
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> normal
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "normal"
            marginal$dists[[i]]$mu <- mean(x[, i])
            marginal$dists[[i]]$sigma <- sd(x[, i])
        } else {
            # [a,b] -> scaled beta
            a <- bounds[i, 1];
            b <- bounds[i, 2];
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- a
            marginal$dists[[i]]$max <- b
            dfit <- MASS::fitdistr((x[, i] - a) / (b - a), dbeta, list(shape1 = 1, shape2 = 1), control = fitctrl)
            marginal$dists[[i]]$shape1 <- as.numeric(dfit$estimate["shape1"])
            marginal$dists[[i]]$shape2 <- as.numeric(dfit$estimate["shape2"])
        }

        marginal$dists[[i]]$name <- colnames(x)[i]
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Marginal function for use in fit.vine.copula: mixture of parametric distributions
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
fit.marginal.mixture <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x)))) {
    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal <- list()
    marginal$type <- "mixture"
    marginal$dists <- list()
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] >= bounds[i, 2]) {
            stop("Upper bound must be strictly higher than lower bound")
        }

        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> beta
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- 0
            marginal$dists[[i]]$max <- 1

            d <- data.frame(y = x[, i])
            cf <- coef(lm(qlogis(y) ~ 1, data = d))
            m <- betareg::betamix(y ~ 1 | 1, data = d, k = 1:3, control = betareg::betareg.control(start = list(mean = 0, precision = 1)), FLXcontrol = list(tolerance = 0.01), which = "AIC")
            k <- m$flexmix@k
            if (k == 1) {
                mu <- plogis(coef(m)[1])
                phi <- exp(coef(m)[2])
                marginal$dists[[i]]$p <- 1
            } else {
                mu <- plogis(coef(m)[, 1])
                phi <- exp(coef(m)[, 2])
                marginal$dists[[i]]$p <- m$flexmix@prior
            }
            marginal$dists[[i]]$a <- mu * phi
            marginal$dists[[i]]$b <- (1 - mu) * phi
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> gamma
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "gamma"

            rescale <- 1 / mean(x[, i])
            rescaled <- x[, i] * rescale
            ms <- list()
            AIC <- rep(NA, 3)
            for (k in 1:3) {
                ms[[k]] <- mixtools::gammamixEM(rescaled, k = k, epsilon = 0.01)
                AIC[k] <- 2 * k - 2 * ms[[k]]$loglik
            }
            k <- which.min(AIC)
            m <- ms[[k]]

            marginal$dists[[i]]$p <- m$lambda
            marginal$dists[[i]]$shape <- m$gamma.pars[1,]
            marginal$dists[[i]]$scale <- m$gamma.pars[2,] / rescale
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> normal
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "normal"

            ms <- list()
            AIC <- rep(NA, 3)
            ms[[1]] <- list()
            ms[[1]]$lambda <- 1
            ms[[1]]$mu <- mean(x[, i])
            ms[[1]]$sigma <- sd(x[, i])
            AIC[1] <- log(nrow(x)) * 2 - 2 * sum(dnorm(x[, i], ms[[1]]$mu, ms[[1]]$sigma, log = T))
            for (k in 2:3) {
                capture.output(return_value <- try(ms[[k]] <- mixtools::normalmixEM(x[, i], k = k, epsilon = 0.01, arbmean = T, arbvar = T)))
                if (inherits(return_value, "try-error")) {
                    AIC[k] <- NA
                } else {
                    AIC[k] <- 2 * k - 2 * ms[[k]]$loglik
                }
            }
            k <- which.min(AIC)
            m <- ms[[k]]

            marginal$dists[[i]]$p <- m$lambda
            marginal$dists[[i]]$mu <- m$mu
            marginal$dists[[i]]$sigma <- m$sigma
        } else {
            # [a,b] -> scaled beta
            a <- bounds[i, 1];
            b <- bounds[i, 2];
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- a
            marginal$dists[[i]]$max <- b

            d <- data.frame(y = (x[, i] - a) / (b - a))
            m <- betareg::betamix(y ~ 1, data = d, k = 1:3, FLXcontrol = list(tolerance = 0.01), which = "AIC")

            k <- m$flexmix@k
            if (k == 1) {
              mu <- plogis(coef(m)[1])
              phi <- exp(coef(m)[2])
                marginal$dists[[i]]$p <- 1
            } else {
                mu <- plogis(coef(m)[, 1])
                phi <- exp(coef(m)[, 2])
                marginal$dists[[i]]$p <- m$flexmix@prior
            }
            marginal$dists[[i]]$a <- mu * phi
            marginal$dists[[i]]$b <- (1 - mu) * phi
        }

        marginal$dists[[i]]$name <- colnames(x)[i]
    }

    return(structure(marginal, class = "mvd.marginal"))
}

.fit.pareto.tail <- function(x, u, fixed_beta = NA) {
    exceedances <- x[x > u]
    excess <- exceedances - u
    Nu <- length(excess)
    xbar <- mean(excess)

    result <- list()
    if (is.na(fixed_beta)) {
        s2 <- var(excess)
        xi0 <- -0.5 * (((xbar * xbar) / s2) - 1)
        beta0 <- 0.5 * xbar * (((xbar * xbar) / s2) + 1)
        theta <- c(xi0, beta0)

        negloglik1 <- function(theta, tmp) {
            xi <- theta[1]
            beta <- theta[2]
            cond1 <- beta <= 0
            cond2 <- (xi <= 0) && (max(tmp) > (-beta / xi))
            if (cond1 || cond2) {
                f <- 1e+06
            } else {
                y <- logb(1 + (xi * tmp) / beta)
                y <- y / xi
                f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
            }
            f
        }

        fit <- optim(theta, negloglik1, lower = c(0, 0), upper = c(Inf, Inf), tmp = excess, method = "L-BFGS-B")
        result$xi <- fit$par[1]
        result$beta <- fit$par[2]
    } else {
        s2 <- var(excess)
        xi0 <- -0.5 * (((xbar * xbar) / s2) - 1)

        negloglik2 <- function(xi, tmp, beta) {
            cond1 <- beta <= 0
            cond2 <- (xi <= 0) && (max(tmp) > (-beta / xi))
            if (cond1 || cond2) {
                f <- 1e+06
            } else {
                y <- logb(1 + (xi * tmp) / beta)
                y <- y / xi
                f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
            }
            f
        }

        fit <- optimize(negloglik2, lower = 0, upper = 1000, tmp = excess, beta = fixed_beta)
        result$xi <- fit$minimum
        result$beta <- fixed_beta
    }

    return(result)
}

.pareto.cdf <- function(x, u, xi, beta) {
    z <- (x - u) / beta
    return(1 - (1 + xi * z) ^ (-1/xi))
}

.pareto.pdf <- function(x, u, xi, beta, log = T) {
    z <- (x - u) / beta
    if (log) {
        p <- log(1 / beta) - (1 / xi + 1) * log(1 + xi * z)
    } else {
        p <- (1 / beta) * (1 + xi * z) ^ (-1 / xi - 1)
    }
    return(p)
}

# Marginal function for use in fit.vine.copula: empirical distribution function with pareto tails
.pareto.quantile <- function(x, u, xi, beta) {
    return(u + beta * ((1.0 - x) ^ (-xi) - 1.0) / xi);
}

#' Marginal function for use in fit.vine.copula: ecdf + pareto tail
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param reflect_bounds If true, reflect samples across bounds to improve the estimate near the boundaries.
#' @param pareto_threshold Cumulative probability threshold for the start of the pareto tail
#' @param ecdf_bounds_threshold Use a pareto tail only if the density of the kernel density estimate at the boundary is below this value.
#' @export
fit.marginal.ecdf.pareto <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), reflect_bounds = T, pareto_threshold = 0.1, ecdf_bounds_threshold = 1e-3) {
    marginal <- list()
    marginal$type <- "ecdf.pareto"

    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal$ecdf <- fit.marginal.ecdf(x, bounds, reflect_bounds)

    use.pareto.tail <- matrix(T, ncol(x), 2)
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] != -Inf) {
            dp <- sum(dnorm(bounds[i, 1], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])
            use.pareto.tail[i, 1] <- dp < ecdf_bounds_threshold
        }
        if (bounds[i, 2] != Inf) {
            dp <- sum(dnorm(bounds[i, 2], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])
            use.pareto.tail[i, 2] <- dp < ecdf_bounds_threshold
        }
    }

    for (i in 1:ncol(x)) {
        if (use.pareto.tail[i, 1]) {
            u <- as.numeric(quantile(x[, i], pareto_threshold))

            dp <- sum(dnorm(u, marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])

            marginal$lower.tails[[i]] <- .fit.pareto.tail(-x[, i], - u, pareto_threshold / dp)
            marginal$lower.tails[[i]]$u <- u
            marginal$lower.tails[[i]]$q <- pareto_threshold
            marginal$lower.tails[[i]]$d <- dp
        } else {
            marginal$lower.tails[[i]] <- list()
        }
        if (use.pareto.tail[i, 2]) {
            u <- as.numeric(quantile(x[, i], 1 - pareto_threshold))

            dp <- sum(dnorm(u, marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])

            marginal$upper.tails[[i]] <- .fit.pareto.tail(x[, i], u, pareto_threshold / dp)
            marginal$upper.tails[[i]]$u <- u
            marginal$upper.tails[[i]]$q <- pareto_threshold
            marginal$upper.tails[[i]]$d <- dp
        } else {
            marginal$upper.tails[[i]] <- list()
        }
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Transform variables to U[0,1] using a fitted marginal function
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @export
mvd.marginal.transform <- function(x, marginal) {
    stopifnot(class(marginal) == "mvd.marginal")

    if (!is.matrix(x)) {
        x <- t(as.matrix(x))
    }
    transformed <- matrix(nrow = nrow(x), ncol = ncol(x))

    if (marginal$type == "ecdf") {
        for (i in 1:ncol(x)) {
            transformed[, i] <- marginal$ecdfs[[i]](x[, i])
        }
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(x)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                is_tail <- x[, i] < marginal$lower.tails[[i]]$u
                transformed[is_tail, i] <- marginal$lower.tails[[i]]$q - marginal$lower.tails[[i]]$q * .pareto.cdf(-x[is_tail, i], - marginal$lower.tails[[i]]$u, marginal$lower.tails[[i]]$xi, marginal$lower.tails[[i]]$beta)
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                is_tail <- x[, i] > marginal$upper.tails[[i]]$u
                transformed[is_tail, i] <- (1 - marginal$upper.tails[[i]]$q) + marginal$upper.tails[[i]]$q * .pareto.cdf(x[is_tail, i], marginal$upper.tails[[i]]$u, marginal$upper.tails[[i]]$xi, marginal$upper.tails[[i]]$beta)
                is_body[is_tail] <- F
            }
            transformed[is_body, i] <- marginal$ecdf$ecdfs[[i]](x[is_body, i])
        }
    } else if (marginal$type == "parametric") {
        for (i in 1:ncol(x)) {
            if (marginal$dists[[i]]$type == "beta") {
                transformed[, i] <- pbeta((x[, i] - marginal$dists[[i]]$min) / (marginal$dists[[i]]$max - marginal$dists[[i]]$min), marginal$dists[[i]]$shape1, marginal$dists[[i]]$shape2)
            } else if (marginal$dists[[i]]$type == "normal") {
                transformed[, i] <- pnorm(x[, i], marginal$dists[[i]]$mu, marginal$dists[[i]]$sigma)
            } else if (marginal$dists[[i]]$type == "gamma") {
                transformed[, i] <- pgamma(x[, i], shape = marginal$dists[[i]]$shape, scale = marginal$dists[[i]]$scale)
            }
        }
    } else if (marginal$type == "mixture") {
        transformed <- matrix(0, nrow(x), ncol(x))
        for (i in 1:ncol(x)) {
            margin <- marginal$dists[[i]]
            if (margin$type == "beta") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pbeta((x[, i] - margin$min) / (margin$max - margin$min), margin$a[j], margin$b[j])
                }
            } else if (marginal$dists[[i]]$type == "normal") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pnorm(x[, i], margin$mu[j], margin$sigma[j])
                }
            } else if (marginal$dists[[i]]$type == "gamma") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pgamma(x[, i], shape = margin$shape[j], scale = margin$scale[j])
                }
            }
        }
    } else {
        stop("Unknown marginal type")
    }

    return(transformed)
}

#' Reverse transform variables from U[0,1]
#' @param transformed Matrix or vector of transformed samples. For matrices, rows are samples and columns are variables.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @export
reverse.transform.marginals <- function(transformed, marginal) {
    stopifnot(class(marginal) == "mvd.marginal")

    if (!is.matrix(transformed)) {
        transformed <- as.matrix(transformed)
    }
    x <- matrix(nrow = nrow(transformed), ncol = ncol(transformed))

    if (marginal$type == "ecdf") {
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(transformed)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                tail <- marginal$lower.tails[[i]]
                is_tail <- transformed[, i] < tail$q
                x[is_tail, i] <-  -.pareto.quantile(1.0 - (transformed[is_tail, i] / tail$q), - tail$u, tail$xi, tail$beta);
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                tail <- marginal$upper.tails[[i]]
                is_tail <- transformed[, i] > 1.0 - tail$q
                x[is_tail, i] <- .pareto.quantile((transformed[is_tail, i] - (1.0 - tail$q)) / tail$q, tail$u, tail$xi, tail$beta);
                is_body[is_tail] <- F
            }
            x[is_body, i] <- quantile(marginal$ecdf$ecdfs[[i]], transformed[is_body, i], type = 4)
        }
    } else if (marginal$type == "parametric") {
    } else if (marginal$type == "mixture") {
        for (i in 1:ncol(transformed)) {
            margin <- marginal$dists[[i]]
            ix <- sample(length(margin$p), nrow(x), replace = T, prob = margin$p)
            if (margin$type == "beta") {
                x[, i] <- margin$min + qbeta(transformed[, i], margin$a[ix], margin$b[ix]) * (margin$max - margin$min)
            } else if (margin$type == "normal") {
                x[, i] <- qnorm(transformed[, i], margin$mu[ix], margin$sigma[ix])
            } else if (margin$type == "gamma") {
                x[, i] <- qgamma(transformed[, i], shape = margin$shape[ix], scale = margin$scale[ix])
            }
        }
    } else {
        stop("Unknown marginal type")
    }

    return(x)
}

#' Probability density function of a marginal distribution fitted with one of the marginal distribution functions.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param log Whether to return the density in log
#' @export
mvd.marginal.pdf <- function(marginal, x, log = T) {
    stopifnot(class(marginal) == "mvd.marginal")
    stopifnot(log)

    p <- matrix(NA, nrow(x), ncol(x))

    if (marginal$type == "ecdf") {
        stopifnot(ncol(x) == length(marginal$bw))
        for (i in 1:ncol(x)) {
            for (j in 1:nrow(x)) {
                dp <- sum(dnorm(x[j, i], marginal$x_reflected[[i]], marginal$bw[i])) * marginal$correction_factor[i]
                p[j, i] <- log(dp) - log(length(marginal$x_reflected[[i]]))
            }
        }
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(x)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                is_tail <- x[, i] < marginal$lower.tails[[i]]$u
                p[is_tail, i] <- log(marginal$lower.tails[[i]]$q) + .pareto.pdf(-x[is_tail, i], - marginal$lower.tails[[i]]$u, marginal$lower.tails[[i]]$xi, marginal$lower.tails[[i]]$beta, log = T)
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                is_tail <- x[, i] > marginal$upper.tails[[i]]$u
                p[is_tail, i] <- log(marginal$upper.tails[[i]]$q) + .pareto.pdf(x[is_tail, i], marginal$upper.tails[[i]]$u, marginal$upper.tails[[i]]$xi, marginal$upper.tails[[i]]$beta, log = T)
                is_body[is_tail] <- F
            }
            for (j in which(is_body)) {
                dp <- sum(dnorm(x[j, i], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
                p[j, i] <- log(dp) - log(length(marginal$ecdf$x_reflected[[i]]))
            }
        }
    } else if (marginal$type == "parametric") {
        for (i in 1:ncol(x)) {
            if (marginal$dists[[i]]$type == "beta") {
                a <- marginal$dists[[i]]$min
                b <- marginal$dists[[i]]$max
                p[, i] <- dbeta((x[, i] - a) / (b - a), marginal$dists[[i]]$shape1, marginal$dists[[i]]$shape2, log = T) - log(b - a)
            } else if (marginal$dists[[i]]$type == "normal") {
                p[, i] <- dnorm(x[, i], marginal$dists[[i]]$mu, marginal$dists[[i]]$sd, log = T)
            } else if (marginal$dists[[i]]$type == "gamma") {
                p[, i] <- dgamma(x[, i], shape = marginal$dists[[i]]$shape, scale = marginal$dists[[i]]$scale, log = T)
            }
        }
    } else if (marginal$type == "mixture") {
        for (i in 1:ncol(x)) {
            margin <- marginal$dists[[i]]
            dp <- rep(0, nrow(x))
            if (margin$type == "beta") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dbeta((x[, i] - margin$min) / (margin$max - margin$min), margin$a[j], margin$b[j])
                }
                p[, i] <- log(dp) - log(margin$max - margin$min)
            } else if (margin$type == "normal") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dnorm(x[, i], margin$mu[j], margin$sigma[j])
                }
                p[, i] <- log(dp)
            } else if (margin$type == "gamma") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dgamma(x[, i], shape = margin$shape[j], scale = margin$scale[j])
                }
                p[, i] <- log(dp)
            }
        }
    } else {
        stop("Unknown marginal type")
    }
    return(p)
}

.marginal.correct.p <- function(marginal, x, p, log = T) {
    stopifnot(class(marginal) == "mvd.marginal")
    mp <- mvd.marginal.pdf(marginal, x, log)
    for (i in 1:ncol(x)) {
        p <- p + mp[, i]
    }
    return(p)
}


#' rnorm
#'
#' Generate from a normal distribution using a gpu.
#'
#' @details
#' Uses \code{curand_normal()} from cuRAND.
#'
#' @param n
#' The number of values to generate
#' @param mean,sd
#' Parameters for normal random variables.
#' @param seed
#' Seed for the random number generation.
#' @param type
#' 'double' or 'float'
#'
#' @references CUDA Toolkit Documentation for cuRAND
#' \url{https://docs.nvidia.com/cuda/curand/index.html}
#'
#' @useDynLib curand R_curand_rnorm
#' @export
rnorm = function(n, mean=0, sd=1, seed=getseed(), type="double")
{
  type = match.arg(tolower(type), c("double", "float"))
  type = ifelse(type == "double", TYPE_DOUBLE, TYPE_FLOAT)

  if (n < 0)
    stop("invalid arguments")
  else if (n == 0)
  {
    if (type == TYPE_DOUBLE)
      return(numeric(0))
    else
      return(float(0))
  }

  n1 = floor(sqrt(n))
  n2 = n - n1*n1

  if (sd < 0 || is.badval(mean) || is.badval(sd))
  {
    warning("NAs produced")
    ret = setnan(n1, n2, type)
  }
  else
    ret = .Call(R_curand_rnorm, as.integer(n1), as.integer(n2), as.double(mean), as.double(sd), as.integer(seed), type)

  if (type == TYPE_DOUBLE)
    ret
  else
    float32(ret)
}


women_research <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/women_research.csv")

women_research %<>%
	dplyr::arrange(desc(country), field) %>%
	dplyr::mutate(percent_men = 1 - percent_women,
	       		  ratio = percent_men/percent_women)

women_research %>%
   		 ggplot2::ggplot(ggplot2::aes(x = country, y = ratio, group = field, col = field,fill = field, shape = field)) +
		 ggplot2::geom_point(size = 4.5)  +
		 ggplot2::theme_bw() + ggplot2::ylim(c(0, 12)) +
		 ggplot2::geom_hline(yintercept = 1, lwd = 1.5, col = 'red') +
		 ggplot2::coord_flip() +
	     ggplot2::theme(axis.text = ggplot2::element_text(size = 17),
			   plot.subtitle = ggplot2::element_text(size = 13),
			   plot.title = ggplot2::element_text(size = 25),
			   axis.title = ggplot2::element_text(size = 20),
			   legend.text = ggplot2::element_text(size = 15)) +
	     ggplot2::labs(title = "% of women authors in Scopus articles and patent applications (2011-2015)",
	          caption = "Tidy Tuesday | @emilyhho") +
#ggplot2::scale_y_continuous(c(0,1,3,6,9,12)) +
	     ggplot2::xlab("") +
	     ggplot2::scale_y_continuous(name = "Ratio of Men / Women publishing", c(0,1, 3, 6, 9, 12))

ggplot2::ggsave("economist.png")


## This runs all of the examples in the help file for ggplot2.Predict,
## removing \dontrun{} and not commenting out commands
require(rms)
n <- 500     # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
cholesterol    <- rnorm(n, 200, 25)
sex            <- factor(sample(c('female','male'), n,TRUE))
label(age)            <- 'Age'      # label is in Hmisc
label(cholesterol)    <- 'Total Cholesterol'
label(blood.pressure) <- 'Systolic Blood Pressure'
label(sex)            <- 'Sex'
units(cholesterol)    <- 'mg/dl'   # uses units.default in Hmisc
units(blood.pressure) <- 'mmHg'

# Specify population model for log odds that Y=1
L <- .4*(sex=='male') + .045*(age-50) +
  (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male')) +
  .01 * (blood.pressure - 120)
# Simulate binary y to have Prob(y=1) = 1/[1+exp(-L)]
y <- ifelse(runif(n) < plogis(L), 1, 0)

ddist <- datadist(age, blood.pressure, cholesterol, sex)
options(datadist='ddist')

fit <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)),
               x=TRUE, y=TRUE)
an <- anova(fit)
p <- Predict(fit, age)
ggplot(p)
ggplot(p, ylim=c(-.5, .5))
ggplot(p, xlim=c(40,50))   # problem reported by JoAnn Alvarez

p <- Predict(fit)
# Plot effects in two vertical sub-panels with continuous predictors on top
ggplot(p, sepdiscrete='vertical')
# Plot effects of all 4 predictors with test statistics from anova, and P
ggplot(p, anova=an, pval=TRUE)
ggplot(p, rdata=llist(blood.pressure, age))
# spike histogram plot for two of the predictors
ggplot(p, rdata=llist(blood.pressure, age), sepdiscrete='vertical')

p <- Predict(fit, name=c('age','cholesterol'))   # Make 2 plots
ggplot(p)

p <- Predict(fit, age=seq(20,80,length=100), sex, conf.int=FALSE)
#                        # Plot relationship between age and log
                         # odds, separate curve for each sex,
ggplot(p, subset=sex=='female' | age > 30)
# No confidence interval, suppress estimates for males <= 30

p <- Predict(fit, age, sex)
ggplot(p, rdata=llist(age,sex))
                         # rdata= allows rug plots (1-dimensional scatterplots)
                         # on each sex's curve, with sex-
                         # specific density of age
                         # If data were in data frame could have used that
p <- Predict(fit, age=seq(20,80,length=100), sex='male', fun=plogis)
                         # works if datadist not used
ggplot(p, ylab=expression(hat(P)))
                         # plot predicted probability in place of log odds
per <- function(x, y) x >= 30
ggplot(p, perim=per)       # suppress output for age < 30 but leave scale alone

# Do ggplot2 faceting a few different ways
p <- Predict(fit, age, sex, blood.pressure=c(120,140,160),
             cholesterol=c(180,200,215))
ggplot(p)
ggplot(p, cholesterol ~ blood.pressure)
ggplot(p, ~ cholesterol + blood.pressure)
# color for sex, line type for blood.pressure:
ggplot(p, groups=c('sex', 'blood.pressure'))
# Add legend.position='top' to allow wider plot
# Map blood.pressure to line thickness instead of line type:
ggplot(p, groups=c('sex', 'blood.pressure'), aestype=c('color', 'size'))

# Plot the age effect as an odds ratio
# comparing the age shown on the x-axis to age=30 years

ddist$limits$age[2] <- 30    # make 30 the reference value for age
# Could also do: ddist$limits["Adjust to","age"] <- 30
fit <- update(fit)   # make new reference value take effect
p <- Predict(fit, age, ref.zero=TRUE, fun=exp)
# The following fails because of the 3rd element of addlayer
# if ylim is not given, as y=0 is included and can't take log
ggplot(p, ylab='Age=x:Age=30 Odds Ratio', ylim=c(.5, 10),
       addlayer=geom_hline(yintercept=1, col=gray(.7)) +
                geom_vline(xintercept=30, col=gray(.7)) +
                scale_y_continuous(trans='log',
                      breaks=c(.5, 1, 2, 4, 8)))

# Compute predictions for three predictors, with superpositioning or
# conditioning on sex, combined into one graph

p1 <- Predict(fit, age, sex)
p2 <- Predict(fit, cholesterol, sex)
p3 <- Predict(fit, blood.pressure, sex)
p <- rbind(age=p1, cholesterol=p2, blood.pressure=p3)
ggplot(p, groups='sex', varypred=TRUE, adj.subtitle=FALSE, colfill='blue')
ggplot(p, groups='sex', varypred=TRUE, adj.subtitle=FALSE,
       sepdiscrete='vert', rdata=data.frame(age, cholesterol, sex))

# For males at the median blood pressure and cholesterol, plot 3 types
# of confidence intervals for the probability on one plot, for varying age
ages <- seq(20, 80, length=100)
p1 <- Predict(fit, age=ages, sex='male', fun=plogis)  # standard pointwise
p2 <- Predict(fit, age=ages, sex='male', fun=plogis,
              conf.type='simultaneous')               # simultaneous
p3 <- Predict(fit, age=c(60,65,70), sex='male', fun=plogis,
              conf.type='simultaneous')               # simultaneous 3 pts
# The previous only adjusts for a multiplicity of 3 points instead of 100
f <- update(fit, x=TRUE, y=TRUE)
g <- bootcov(f, B=500, coef.reps=TRUE)
p4 <- Predict(g, age=ages, sex='male', fun=plogis)    # bootstrap percentile
p <- rbind(Pointwise=p1, 'Simultaneous 100 ages'=p2,
           'Simultaneous     3 ages'=p3, 'Bootstrap nonparametric'=p4)
# as.data.frame so will call built-in ggplot
ggplot(as.data.frame(p), aes(x=age, y=yhat)) + geom_line() +
 geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2, linetype=0)+
 facet_wrap(~ .set., ncol=2)

# Plots for a parametric survival model
n <- 1000
set.seed(731)
age <- 50 + 12*rnorm(n)
label(age) <- "Age"
sex <- factor(sample(c('Male','Female'), n,
              rep=TRUE, prob=c(.6, .4)))
cens <- 15*runif(n)
h <- .02*exp(.04*(age-50)+.8*(sex=='Female'))
t <- -log(runif(n))/h
label(t) <- 'Follow-up Time'
e <- ifelse(t<=cens,1,0)
t <- pmin(t, cens)
units(t) <- "Year"
ddist <- datadist(age, sex)
Srv <- Surv(t,e)

# Fit log-normal survival model and plot median survival time vs. age
f <- psm(Srv ~ rcs(age), dist='lognormal')
med <- Quantile(f)       # Creates function to compute quantiles
                         # (median by default)
p <- Predict(f, age, fun=function(x) med(lp=x))
ggplot(p, ylab="Median Survival Time")
# Note: confidence intervals from this method are approximate since
# they don't take into account estimation of scale parameter

# Fit an ols model to log(y) and plot the relationship between x1
# and the predicted mean(y) on the original scale without assuming
# normality of residuals; use the smearing estimator
# See help file for rbind.Predict for a method of showing two
# types of confidence intervals simultaneously.
set.seed(1)
x1 <- runif(300)
x2 <- runif(300)
ddist <- datadist(x1,x2)
y  <- exp(x1+x2-1+rnorm(300))
f <- ols(log(y) ~ pol(x1,2)+x2)
r <- resid(f)
smean <- function(yhat)smearingEst(yhat, exp, res, statistic='mean')
formals(smean) <- list(yhat=numeric(0), res=r[!is.na(r)])
#smean$res <- r[!is.na(r)]   # define default res argument to function
ggplot(Predict(f, x1, fun=smean), ylab='Predicted Mean on y-scale')

# Make an 'interaction plot', forcing the x-axis variable to be
# plotted at integer values but labeled with category levels
n <- 100
set.seed(1)
gender <- c(rep('male', n), rep('female',n))
m <- sample(c('a','b'), 2*n, TRUE)
d <-  datadist(gender, m); options(datadist='d')
anxiety <- runif(2*n) + .2*(gender=='female') + .4*(gender=='female' & m=='b')
tapply(anxiety, llist(gender,m), mean)
f <- ols(anxiety ~ gender*m)
p <- Predict(f, gender, m)
ggplot(p)     # horizontal dot chart; usually preferred for categorical predictors
ggplot(p, flipxdiscrete=FALSE)  # back to vertical
ggplot(p, groups='gender')
ggplot(p, ~ m, groups=FALSE, flipxdiscrete=FALSE)

# Example from Yonghao Pua <puayonghao@gmail.com>
n <- 500
set.seed(17)
age <- rnorm(n, 50, 10)
# create an ordinal variable
duration <- factor(sample(c('None', '10', '20', '30' ,'>30'), n,TRUE))
duration <- factor(duration, levels(duration)[c(5, 1:4)])
# arrange factor levels in ascending order
levels(duration) # shows the correct order "None" "10"   "20"   "30"   ">30"
label(age) <- 'Age'
label(duration) <- 'Duration'

L <-.045*(age-50) +.01*(duration=='10') +.2*(duration=='20')+
  .3*(duration=='30')+ .9*(duration=='>30')

y <- ifelse(runif(n) < plogis(L), 1, 0)
ddist <- datadist(age, duration)
options(datadist='ddist')
fit <- lrm(y ~ age + duration)
p <- Predict(fit, fun=plogis)
ggplot(p)
ggplot(p, sepdiscrete='vertical', colfill='green', anova=anova(fit))

## From JoAnn Alvarez 2016-10

n <- 800     # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
cholesterol    <- rnorm(n, 200, 25)
sex            <- factor(sample(c('female','male'), n,TRUE))
eyecolor       <- factor(sample(c('green','blue'), n,TRUE))
L <- .4*(sex=='male') +
  .045*(age-50) +
  3*(eyecolor == 'blue')*(sex=='female') +
  (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
y <- ifelse(runif(n) < plogis(L), 1, 0)
ddist <- datadist(age, eyecolor, cholesterol, sex)
options(datadist='ddist')
fit <- lrm(y ~ sex * (eyecolor + age + rcs(cholesterol,4)))
p <- Predict(fit, cholesterol, sex, eyecolor)

ggplot(p)

# Confidence bands automatically suppessed:
ggplot(p, groups = c('eyecolor', 'sex'), aestype=c('color', 'linetype'))

colorscale <- function(...)
  scale_color_manual(...,
                     values=c("#000000", "#E69F00", "#56B4E9",
                              "#009E73","#F0E442", "#0072B2", "#D55E00", "#CC79A7"))

ggplot(as.data.frame(p), aes(x=cholesterol, y=yhat, color=eyecolor, linetype=sex)) +
  labs(x=expression(cholesterol), y="log odds",
       title="Adjusted to:age=50.2 ")  +
  geom_line(data=p, mapping=aes(color=eyecolor, linetype=sex)) +
  colorscale(name=expression(eyecolor)) +
  scale_linetype_discrete(name=expression(sex)) +
  theme(legend.position='right') +
#  geom_ribbon(data=p, aes(ymin=lower, ymax=upper), alpha=0.2,
#              linetype=0, fill=I('black'), show.legend=FALSE) +
  coord_cartesian(ylim=c(-4, 6)) +
  theme(plot.title=element_text(size=8, hjust=1))


# Derived variables
# Experiment:  Classification
# Mark E. Madsen
# (c) 2013 - see file LICENSE for license terms

# calculate theta as a number, and as a factor
# assume haploid so 2Nmu, not 4Nmu
class.grouped$theta <- class.grouped$population_size * class.grouped$mutation_rate * 2.0
class.grouped$theta_factor <- factor(class.grouped$theta)

# Total number of classes is the coarseness for each dimension multiplied
class.grouped$total_num_classes <- as.numeric(class.grouped$classification_coarseness) ^ as.numeric(class.grouped$dimensionality)
class.grouped$total_classes_factor <- factor(class.grouped$total_num_classes)

grouped.theta_subset <- subset(class.grouped, class.grouped$theta_factor == c("0.2", "1", "10"))


library(philentropy)
{{rimport}}('__init__.r')

infile  = {{i.infile | R}}
outfile = {{o.outfile | R}}
inopts  = {{args.inopts | R}}
method  = {{args.method | R}}
transfm = {{args.transfm | R}}
na      = {{args.na | R}}

indata = read.table.inopts(infile, inopts)
indata[is.na(indata)] = na

d = distance(indata, method = method, test.na = F)
if (transfm != FALSE) {
	ma = max(d)
	mi = min(d)
	scaled = 1 - (d-mi) / (ma-mi)
	if (transfm == 'scale') {
		d = scaled
	} else if (transfm == 'similarity' || transfm == 'sim') {
		d = 1 - scaled
	}
}
rownames(d) = rownames(indata)
colnames(d) = rownames(indata)
write.table(round(d, 3), outfile, col.names = TRUE, row.names = TRUE, sep = "\t", quote = F)


copom_dates <- as.Date(
  c("2022-03-17", "2022-05-05", "2022-06-17", "2022-08-04")
)
terms <- c(1, 3, 25, 44, 66, 87, 108, 131, 152, 172, 192, 214, 236, 277)
rates <- c(
  0.1065, 0.1064, 0.111, 0.1138, 0.1168, 0.1189, 0.1207, 0.1219,
  0.1227, 0.1235, 0.1234, 0.1236, 0.1235, 0.1235
)
curve <- spotratecurve(
  rates, terms, "discrete", "business/252", "Brazil/ANBIMA",
  refdate = as.Date("2022-02-23")
)
interpolation(curve) <- interp_flatforwardcopom(copom_dates, "second")
plot(curve, use_interpolation = TRUE, show_forward = TRUE)

source("examples/utils-functions.R")

curve <- get_curve_from_web()
copom_dates <- get_copom_dates(curve@refdate, 8)
interpolation(curve) <- interp_flatforwardcopom(copom_dates, "second")
plot(curve, use_interpolation = TRUE, show_forward = TRUE)
interpolation(curve)@moves$moves * 1e4


library(pROC)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix_gene.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_sample_info_2.txt")
info = fread(fn.si) %>%
  mutate(subject = as.character(subject))

fn.poB = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_percent_of_B_filtered.txt")
flow.poB = fread(fn.poB) %>% tibble::column_to_rownames("sample") %>%
  data.matrix()

fn.info = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_sample_info_filtered.txt")
flow.info = fread(fn.info) %>%
  mutate(subject = as.character(subject))

flow.df = flow.info %>% dplyr::select(sample) %>% add_column(CD38hi = flow.poB[,"Gate3"])

info = info %>% left_join(flow.df, by="sample")

si = with(info, time == 0 & Response %in% c("low","high") & !is.na(CD38hi))
sum(si)
dat = dat[,si]
info = info[si,] %>% mutate(Response = factor(Response, levels=c("low","high")))

# calculate robust regression removing ns samples --------
ns = 2
cmb = combn(1:nrow(info), ns)
cc.rob = matrix(NA,nrow=nrow(dat),ncol=ncol(cmb))
for (ic in 1:ncol(cmb)) {
  cat(ic," ")
  ridx = cmb[,ic]
  cc.rob[,ic] = cor(t(dat[,-ridx]), info$CD38hi[-ridx], method="spearman", use="pairwise.complete.obs")
}
rownames(cc.rob) = rownames(dat)
cc.rob.rank = apply(-cc.rob,2,rank)
ntop = 20
cc.rob.ntop = rowSums(cc.rob.rank<=ntop)

cc.rob.mean = apply(cc.rob,1,mean)
cc.rob.median = apply(cc.rob,1,median)
cc.rob.sd = apply(cc.rob,1,sd)
cc.rob.1cv = cc.rob.mean / cc.rob.sd
cc.rob.ntop.rank = rank(cc.rob.ntop)

cc.rob.1cv.ord = order(cc.rob.1cv,decreasing = T)
cc.rob.1cv.sort = sort(cc.rob.1cv,decreasing = T)
head(cc.rob.1cv.sort, 10)

# calculate AUC for each gene
auc.one=matrix(nrow=nrow(dat), ncol=3)
for (k in 1:nrow(dat)) {
  X = dat[k,]
  Y = info$Response
  auc.one[k, c(2,1,3)] = ci.auc(Y,X,direction="<", quiet=T)
}
rownames(auc.one) = rownames(dat)
colnames(auc.one) = c("auc.gene", "auc.ci95.min", "auc.ci95.max")

# output
df.out = data.frame(cor.ntop20 = cc.rob.ntop,
                    cor.mean = cc.rob.mean,
                    cor.sd = cc.rob.sd,
                    cor.meadian = cc.rob.median,
                    cor.mean.sd.ratio = cc.rob.1cv,
                    as.data.frame(auc.one)) %>%
  tibble::rownames_to_column("gene")

fn.cor = file.path(PROJECT_DIR, "generated_data","CHI","robust_corr_all.genes.txt")
fwrite(df.out, fn.cor, sep="\t", quote=T)


# Two within subject variables, one between
# Data from Bouton & Schwartzentruber (1985)
# Methods8, p. 486

data <- read.table("http://www.uvm.edu/~dhowell/methods8/DataFiles/Tab14-11.dat", header = T)
names(data)
attach(data)

##  I should use "reshape," but I can't get it to work. This is pretty easy.
Phase <- factor(rep(1:2, each = 24, times = 4))
Cycle <- factor(rep(1:4, each = 48))
Group = factor(rep(1:3, each = 8,times = 8))
dv <- c(C1P1, C1P2, C2P1, C2P2, C3P1, C3P2, C4P1, C4P2)
Subj <- factor(rep(1:24, times = 8))

df <- cbind(Subj, dv, Group, Phase, Cycle)

cat("Means and sd by Group \n")
tapply(dv, Group, mean); tapply(dv, Group, sd)
cat("\n Means and sd by Cycle\n")
tapply(dv, Cycle, mean); tapply(dv, Cycle, sd)
cat("\n Means and sd by Phase\n")
tapply(dv, Phase, mean); tapply(dv, Phase, sd)

options(contrasts = c("contr.sum","contr.poly"))
model1 <- aov(dv ~ (Group*Cycle*Phase) + Error(Subj/(Cycle*Phase)), contrasts = contr.sum)
summary(model1)
coefficients(model1)

interaction.plot(Phase, factor(Group), dv, type="b", pch = c(2,4,6),
  legend = "F", col = c(3,4,6))
legend(1, 40, c("A-B", "A-A", "L-A-B"), col = c(4,6,3), text.col = "green4", lty = c(2, 1, 3), pch = c(4, 6, 2), merge = TRUE, bg = 'gray90')

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


suppressPackageStartupMessages(library(float))

x = matrix(1:30, 10)
y = matrix(1:10, 2, 10)
z = matrix(1:5, 5, 3)

xs = fl(x)
ys = fl(y)
zs = fl(z)

test = dbl(t(xs))
stopifnot(all.equal(test, t(x)))

test = dbl(t(ys))
stopifnot(all.equal(test, t(y)))

test = dbl(t(zs))
stopifnot(all.equal(test, t(z)))


selectionsort.loop <- function(x)
{
   lenx <- length(x)
   for(i in seq_along(x))
   {
      mini <- (i - 1) + which.min(x[i:lenx])
      start_ <- seq_len(i-1)
      x <- c(x[start_], x[mini], x[-c(start_, mini)])
   }
   x
}


require(rms)
create <- FALSE
if(create) {
d <- csv.get("hongLiData.csv", lowernames=TRUE, charfactor=TRUE)
d <-
  upData(d,
         labels=c(surg.discharge.days="Discharge Days",
                  primarysite="Primary Site",
                  facilitytype="Facility Type",
                  insurance1="Insurance",
                  race1="Race",
                  region="Region",
                  samefacility="Same Facility",
                  port.nccn.fail="outcome"))
d <- d[Cs(port.nccn.fail, surg.discharge.days, primarysite, facilitytype,
          insurance1, race1, samefacility, region)]
save(d, file='nomogram2.rda', compress=TRUE)
} else load('nomogram2.rda')

ddist  <-  datadist(d);  options(datadist='ddist')

f <- lrm(port.nccn.fail ~ surg.discharge.days + primarysite +
           facilitytype + insurance1 + race1 + samefacility + region,
         data=d)

for(abbrev in c(FALSE, TRUE)) {

  n <- nomogram(f, lp.at=seq(-2, 5, by=0.5), fun=plogis,
                fun.at=c(seq(.1, .9, by=.1), .95, .99, .999),
                funlabel="Risk of Delayed PORT Initiation",
                abbrev=abbrev, minlength=1, lp=FALSE)
  if(! abbrev) n1 <- n else n2 <- n
  }

plot(n1)
plot(n2)
attr(n2, 'info')$Abbrev

# Hong Li <liho@musc.edu>
# The variable samefacility has two categories and region has 4 categories. But in the nomogram, the variable samefacility and region are switched, i.e. samefacility has 4 categories and region has 2 categories. All other variables are correct.


# For genes with multiple probesets, pick probeset most correlated to the PC1 of all probesets.
# verified OK for random genes.
pick.probeset <- function(exprset,gene.map.file)
{
  library(Biobase)
  library(plyr)
  probinf = featureNames(exprset)
  dat = exprs(exprset)

  map = read.table(gene.map.file, sep="\t", header=T, stringsAsFactors=F)
  # overlap(map[,1], probinf)
  map = map[(map[,1] %in% probinf) & !is.na(map[,2]),];
        stopifnot(!duplicated(probinf), !duplicated(map[,1]), map[,1:2] != "", !is.na(map[,1:2]))
  map$idx = match(map[,1], probinf);  stopifnot(!is.na(map$idx))
  map = ddply(map, 2, function(df)
        {
          if (nrow(df)==1) {
            return(data.frame(df, pc1varexpl=NA, nprobeset=1,
                              cor2pc1=NA, stringsAsFactors=F))
          }
          datgene = t(dat[df$idx,])
          pr = prcomp(datgene)
          if(all(pr$sdev==0)) {
            return(data.frame(df[1,], pc1varexpl=NA, nprobeset=nrow(df),
                       cor2pc1=NA, stringsAsFactors=F))
          }
          pc1varexpl = 100*(pr$sdev[1])^2/sum(pr$sdev^2)
          cors = abs(cor(pr$x[,"PC1",drop=F], datgene))
          data.frame(df[which.max(cors),], pc1varexpl=pc1varexpl, nprobeset=nrow(df), cor2pc1=cors[which.max(cors)], stringsAsFactors=F)
        })
  stopifnot(!duplicated(map[,2]), !duplicated(map[,1]))
  write.table(map, file=sub('(\\.[^\\.]*)$','_PC1\\1',gene.map.file), sep="\t", quote=F, row.names=F)

  return(0)
}


## Created on Tuesday, February  8, 2022 at 11:11pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2022, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../../tools"
source(file.path(toolsDir, "pipeline-tools.r"))        # For saveDataframe()
source("./2021-11-12-covid-treatments-simple-efficacy-confidence-limits.r")
library("reshape2")                                    # For acast()

##
## Moderna's animal trial of an Omicron-specific COVID-19 vaccine showed "no better
## than original vaccine."
##
## - N = 8 monkeys = 4 control + 4 treatment
## - Original efficacy 80% or so.
##
## Could you, even in principle, tell the difference between 80% efficacy and 100%, with
## only 4 animals in each group?
##
## Summary of study:
##   https://arstechnica.com/science/2022/02/monkey-study-casts-doubt-on-need-for-an-omicron-specific-booster/
## Study itself, says nothing re efficacy but is all about B cells and T cells:
##   https://www.biorxiv.org/content/10.1101/2022.02.03.479037v1
##
## Summary of CDC stuff on efficacy of booster:
##   https://arstechnica.com/science/2022/01/unvaccinated-5x-more-likely-to-get-omicron-than-those-boosted-cdc-reports/
## The CDC MMWR's themselves, quoting booster efficacy vs Omicron:
##   https://www.cdc.gov/mmwr/volumes/71/wr/mm7104e2.htm?s_cid=mm7104e2_w
##   https://www.cdc.gov/mmwr/volumes/71/wr/mm7104e3.htm?s_cid=mm7104e3_w
##

## Efficacy against urgent care with Omicron: 82%
## Efficacy against hospitalization with Omicron: 94%
## Can we tell if ANYTHING in the monkey trial is statistically significantly different from that?
doit <- function(Ntrt = 4, Ncnt = 4, destPath = "./2022-02-09-moderna-monkey-trial.tsv") {
  saveDataframe(dcast(transform(expand.grid(Ktrt = 0 : Ntrt, Kcnt = 0 : Ncnt),
                                Eff = Vectorize(function(Ntrt, Ktrt, Ncnt, Kcnt) {
                                  effs <- 100.0 * efficacyAndCL(Ntrt, Ktrt, Ncnt, Kcnt)
                                  sprintf("%+6.1f%% (%+6.1f%% - %+6.1f%%)",
                                          effs[["Eff"]], effs[["LCL"]], effs[["UCL"]])
                                })(Ntrt, Ktrt, Ncnt, Kcnt)),
                      Kcnt ~ Ktrt, value.var = "Eff"), #
                destPath)                              #
}                                                      #


################################ exon9CNV (the exon9 amplicon); fixed sd for each run
#cm: cluster mean
#cs: cluster std
#pm: cluster membership probability matrix
#cw: cluster weight
CN3.add = 1
cprob <- function(point, m) {
    # dnorm: normal density function (x, mean, and sd)
    sapply(1:m$n, function(i){dnorm(point, m$cm[i], m$cs[i])})
}

estep <- function(m) {
    m$pm <- sapply(m$v, function(x){temp <- cprob(x, m) * m$cw; temp/sum(temp)})
    temp <- apply(m$pm, 1, sum)
    m$cw <- temp/sum(temp)   #cluster weight
    return(m)
}

mstep <- function(m) {
    temp <- m$pm * t(replicate(m$n, m$wt))
    pwt <- apply(temp, 1, sum)
    m$cm <- as.vector(temp %*% m$v / pwt)
    dis <- t(replicate(m$n, m$v)) - replicate(length(m$v), m$cm)
    m$cs <- rep(sqrt(sum(apply(temp *  dis * dis, 1, sum)) / sum(pwt)), m$n)  #cluster sd, 3 class
    return(m)
}

#log likelihood
ll <- function(m) {
    sum(sapply(m$v, function(x){log(sum(cprob(x, m) * m$cw))}))
}

exon9CNV <- function(nn_sub, exon9_idx) {
    do = as.numeric(nn_sub[exon9_idx,])
	THRES.CN4 = median(do)+0.8
	exon.CN4.idx = (do>THRES.CN4+0.2)
	do[do>THRES.CN4] = THRES.CN4

	amplicon.THRES.CN0 = median(do)-2
	do[do<amplicon.THRES.CN0] = amplicon.THRES.CN0

    cm2 <- median(do)
    cm = c(cm2-1, cm2, cm2+exon.CN3.add)
    cs <- c(0.1, 0.1, 0.1) #cluster sd, 3 class
    n <- length(cm) #number of clusters
    cw <- rep(1/n, n) #cluster weight
    pd <- c(cm) # one prior data point

    pw <- rep(1, length(pd)) #prior data point weights

    v <- c(pd, do) #all data points for clustering
    wt <- c(pw, rep(1, length(do))) #weights of all data points
    oll <- -.Machine$double.xmax #likelihood from the previous iteration
    np <- length(pd) #number of prior data points

    m <- list(v=v, n=n, wt=wt, cm=cm, cs=cs, pm=0, cw=cw)
    m <- estep(m)
    nll <- ll(m)
    i <- 1
    while(i < 60 && nll - oll > 0.00001) {
        oll <- nll
        m <- mstep(m)
        m <- estep(m)
        nll <- ll(m)
        i <- i+1
    #    cat("iter=",i,"loglikelihood=",nll,"\n")
    }

    # retrieve call / calculate Phred score
    temp <- sapply(do, function(v){cprob(v,m)})
    call <- apply(temp, 2, which.max)
    # apply(temp, 2, max), maximal density
    temp <- apply(temp, 2, function(v){v/sum(v)})
    # temp is now probability
    temp <- apply(temp, 2, function(v){1-max(v)})
    temp[temp < .Machine$double.xmin] <- .Machine$double.xmin
    Phred <- -10 * log10(temp)
    Phred[Phred>100] <- 100

    ExonOut <- list(call=call, Phred=Phred, m=m, do=do, np=np, exon.CN4.idx=exon.CN4.idx)
    return(ExonOut)
}

######################fit gene level; fixed sd for each amplicon in a run
estepGene <- function(m) {
  m$pm <- apply(m$v, 2, function(x){temp <- cprobGene(x, m) * m$cw; temp/sum(temp)})
  temp <- apply(m$pm, 1, sum)
  m$cw <- temp/sum(temp)   #cluster weight
  return(m)
}

mstepGene <- function(m) {
  temp <- m$pm * t(replicate(m$n, m$wt))
  pwt <- apply(temp, 1, sum)
  m$cm <- apply(temp %*% t(m$v), 2, function(v){v/pwt})
  for(i in 1:m$na) {
    dis <- t(replicate(m$n, m$v[i,])) - replicate(length(m$v[i,]), m$cm[,i])
    m$cs[,i] <- rep(sqrt(sum(apply(temp *  dis * dis, 1, sum)) / sum(pwt)), m$n)   #cluster sd;
  }
  return(m)
}

#log likelihood
llGene <- function(m) {
  sum(apply(m$v, 2, function(x){log(sum(cprobGene(x, m) * m$cw))}))
}

cprobGene <- function(point, m) {
  cprobGenei <- function(point, mu, sd) {
    prod(sapply(1:length(point), function(i){dnorm(point[i], mu[i], sd[i])}))
  }
  sapply(1:m$n, function(i){cprobGenei(point, m$cm[i,], m$cs[i,])})
}

# check individual amplicon
cprobGeneIDX <- function(point, m, idx) {
  cprobGenei <- function(point, mu, sd) {
    sapply(idx, function(i){dnorm(point[i], mu[i], sd[i])})
  }
  sapply(1:m$n, function(i){cprobGenei(point, m$cm[i,], m$cs[i,])})
}

# Voting...

geneCNV <- function(nn_sub, geneamp_idx) {
    do <- as.matrix(nn_sub[geneamp_idx,]) #real data
    na <- length(geneamp_idx) #number of amplicons
    samples <- dim(nn_sub)[2]

    cm2 <- apply(do, 1, median)
    cm = rbind(cm2-1, cm2, cm2+CN3.add)

  	gene.CN4.idx = NULL
    for(d_idx in 1:dim(do)[1]) {
		THRES.CN4 = median(as.numeric(do[d_idx,]))+0.8
		gene.CN4.idx = rbind(gene.CN4.idx, (do[d_idx,]>THRES.CN4+0.2))
	    do[d_idx,do[d_idx,] > THRES.CN4] = THRES.CN4
	}

	# include flooding of CN0 cases for clustering stability
    for(d_idx in 1:dim(do)[1]) {
		amplicon.THRES.CN0 = median(as.numeric(do[d_idx,]))-3
	    do[d_idx,do[d_idx,] < amplicon.THRES.CN0] = amplicon.THRES.CN0
	}

    n <- nrow(cm) #number of clusters
    cs <- matrix(0.1, n, na) #cluster sd;
    cw <- rep(1/n, n) #cluster weight

    pd <- t(cm)
    pw <- rep(1, ncol(pd)) #prior data point weights

    pw <- c(0.1,0.1,0.1)  # put less weight on the prior -> lower confidence when inconsistent

    v <- cbind(pd, do) #all data points for clustering
    wt <- c(pw, rep(1, ncol(do))) #weights of all data points
    oll <- -.Machine$double.xmax #likelihood from the previous iteration
    np <- ncol(pd) #number of prior data points

    m <- list(v=v, n=n, na=na, wt=wt, cm=cm, cs=cs, pm=0, cw=cw)
    m <- estepGene(m)
    nll <- llGene(m)
    i <- 1

    while(i < 60 && nll - oll > 0.00001) {
        oll <- nll
        m <- mstepGene(m)
        m <- estepGene(m)
        nll <- llGene(m)
        i <- i+1
#        cat("iter=",i,"loglikelihood=",nll,"\n")
    }

    temp <- apply(do, 2, function(v){cprobGene(v,m)})
    call.allamplicon <- apply(temp, 2, which.max)

    VOTE = NULL
	tempProb = vector("list",na)
    for(idx in 1:length(geneamp_idx)) {
        tempProb[[idx]] <- apply(do, 2, function(v){cprobGeneIDX(v,m,idx)})
        VOTE = rbind(VOTE, as.numeric(apply(tempProb[[idx]], 2, which.max)))
    }
    VOTE.call = NULL
    for(idx in 1:length(call.allamplicon)) {
        VOT = as.data.frame(table(VOTE[,idx]))
        VOT = VOT[order(VOT$Freq, decreasing=TRUE),]
        VOTE.call = c(VOTE.call, as.numeric(as.character(VOT$Var1[1])))
    }
	# remove at most three amplicons for voting...

	if(length(which(call.allamplicon == VOTE.call)) == samples) {
	    # when Voting over all amplicons is consistent with VOTE over individual amplicons
	    call = VOTE.call
		print(paste("[Use all amplicons for voting]",sep=""))
	} else {
		MisMatch = NULL
	    for(i in 1:na) {   MisMatch = c(MisMatch, length(which(VOTE[i,] != VOTE.call)))  }

    	# exclude the top (at most 3) mismatched amplicons
		ampIDX = 1:na
		MistMatchIDX = which(MisMatch>0)
		if( length(MistMatchIDX) <=4 ) {
		    ampIDX = setdiff(ampIDX, MistMatchIDX)
			print(paste("Exclude inconsistent gene-level amplicons:",MistMatchIDX,sep=""))
		} else {
    		MisMatchTMP = cbind(ampIDX, MisMatch)
	    	MisMatchTMP = MisMatchTMP[order(MisMatchTMP[,2], decreasing=T),]
		    ampIDX = MisMatchTMP[-c(1:4),1]
			print(paste("Exclude inconsistent gene-level amplicons:",MisMatchTMP[1:4,1],sep=""))
		}

    	# use remaining amplicons for calculate posterior probability
		for(a_idx in 1:length(ampIDX)) {
		    if(a_idx==1) {
			    temp=tempProb[[ampIDX[a_idx]]]
			} else {
			    temp=temp*tempProb[[ampIDX[a_idx]]]
			}
		}
		# make new call with less amplicons, and trust it anyway
		call <- apply(temp, 2, which.max)
	}
	temp <- apply(temp, 2, function(v){v/sum(v)})
    # temp is now probability
    temp <- apply(temp, 2, function(v){1-max(v)})
    temp[temp < .Machine$double.xmin] <- .Machine$double.xmin
    Phred <- -10 * log10(temp)
    Phred[Phred>100] <- 100

    GeneOut <- list(call=call, Phred=Phred, m=m, do=do, np=np, na=na, gene.CN4.idx=gene.CN4.idx)
    return(GeneOut)
}

#Reporting <- function(LogFile) {
#	if (!file.exists(LogFile)){    stop(paste("Log File ",LogFile," does not exist.  Please check again.", sep="");    }
#	myLog = read.csv(LogFile, sep="\t")
#}


seaflow_data <- read.csv(file="seaflow_21min.csv", header=TRUE, sep=",")
seaflow_data <- seaflow_data[1:72342,]

print("============================================================\n")
print("Q2 answer: summary of seaflow data, pop")
print(summary(seaflow_data$pop))
print("============================================================\n")
print("Q3 answer: summary of fsc_small")
print(summary(seaflow_data$fsc_small))

library(caret)
dataPart <-createDataPartition(seaflow_data$cell_id,p=0.5,list=FALSE)
training <- seaflow_data[-dataPart,]
testset<-seaflow_data[dataPart,]

print("============================================================\n")
print("Q4 answer: mean of the time column in training set")
print(mean(training$time))

library(ggplot2)

#ggplot(seaflow_data, aes(x=seaflow_data$pe,y=seaflow_data$chl_small,color=seaflow_data$pop))+geom_point(size=2)

print("============================================================\n")
print("Q5 answer: check the plot to tell which mixes with 'ultra'")
print(ggplot(seaflow_data, aes(x=pe,y=chl_small,color=pop))+geom_point(size=2))

library(rpart)

fol <-formula(pop~fsc_small+fsc_perp+fsc_big+pe+chl_big+chl_small)

rpartmodel <-rpart(fol, method = "class", data=training)

print("============================================================\n")
print("Q6 answer: decision tree model, check for what class is not present in the tree")
print("Q7 answer: decision tree model, check threshold for pe on which split happens")
print("Q8 answer: decision tree model, check for what features are used for comparison most")
print(rpartmodel)

#rpartmodelVars <- names(rpartmodel[,1:13])

dtpredict <- predict(rpartmodel, data=testset)

# get the dtprediction for each entry
i1 <- max.col(dtpredict, ties.method="first")
dtpredictresult <- data.frame(cell_id=rownames(dtpredict), pop=colnames(dtpredict)[i1])

validationdata <- testset[, c("cell_id", "pop")]

# since the levels of both validation and predictions are not same (remember crypto
# cannot be predicted by the rpart model?) we need to fix that.
# first we extract the predicted pop values:
dttest <- dtpredictresult$pop
# next we extract the pop values in the validation/test data
valtest <- validationdata$pop
# now fix the levels:
dttest <-factor(dttest, levels=levels(valtest))

evaluaterpartpredict <- dttest==valtest
accuracyrpartpredict <- sum(evaluaterpartpredict)/length(valtest)

print("============================================================\n")
print("Q9 answer: accuracy of the rpart predict")
print(accuracyrpartpredict)

library(randomForest)

randomforestmodel <- randomForest(fol, data=training)
randforestpredict <- predict(randomforestmodel, data=testset)
rftest <- randforestpredict == valtest
accuracyrandforestpredict <- sum(rftest)/length(valtest)

print("============================================================\n")
print("Q10 answer: accuracy of the random forest predict")
print(accuracyrandforestpredict)

print("============================================================\n")
print("Q11 answer: see which values have highest Gini score")
print(importance(randomforestmodel))

library(e1071)
svmmodel <- svm(fol, data=training)
svmpredict <- predict(svmmodel, data=testtet)
svmtest <- svmpredict == valtest
accuracysvm <- sum(svmtest)/length(valtest)

print("============================================================\n")
print("Q12 answer:  accuracy of the svm predict")
print(accuracysvm)

# for the next creating a table, we have one of the set (predicted/training) less number
# of rows than the test, so we just add a dummy null set in the prediction to get the table working
randforestpredict[36172] <- "null"
svmpredict[36172] <- "null"

print("============================================================\n")
print("Q13 answer: confusing matrix for random forest prediction")
print(table (pred=randforestpredict, true=testset$pop))
print("Q13 answer: confusing matrix for svm prediction")
print(table (pred=svmpredict, true=testset$pop))

print("============================================================\n")
print("Q15 answer: to answer this, plot all measurements against time, see which is not continuous")
print(ggplot(training, aes(x=time,y=fsc_small,color=pop))+geom_point(size=1))
print(ggplot(training, aes(x=time,y=fsc_perp,color=pop))+geom_point(size=1))
# this next one!
print(ggplot(training, aes(x=time,y=fsc_big,color=pop))+geom_point(size=1))
print(ggplot(training, aes(x=time,y=pe,color=pop))+geom_point(size=1))
print(ggplot(training, aes(x=time,y=chl_small,color=pop))+geom_point(size=1))
print(ggplot(training, aes(x=time,y=chl_big,color=pop))+geom_point(size=1))

# remove data pertaining to file 208
training_minus208 <- subset(training, training[,c("file_id")] != 208)
testset_minus208 <- subset(testset, testset[, c("file_id")] != 208)

svmmodel2 <- svm(fol, data=training_minus208)
svmpredict2 <- predict(svmmodel, data=testset_minus208)
validationdata2 <- testset_minus208[, c("cell_id", "pop")]
valtest2 <- validationdata2$pop
svmtest2 <- svmpredict2 == valtest2
accuracysvm2 <- sum(svmtest2)/length(valtest2)

print("============================================================\n")
print("Q14 answer:  accuracy of the svm predict after cleaning data")
print(accuracysvm2)


###############################################################################
#                               DIAGRAMA DE SECTORES                          #
###############################################################################
#  Considere la Encuesta de Desarrollo e Innovación Tecnológica (EDIT),       #
#  2015-2016, para Colombia. En esta encuesta se toman todas las empresas     #
#  industriales a nivel nacional que cumplen los parámetros de inclusión      #
#  (establecimientos industriales con 10 o más personas ocupadas o que        #
#  registren un valor de producción anual mayor o igual a un valor            #
#  determinado). Toda la información al respecto de la encuesta se encuentra  #
#  disponible en https://www.dane.gov.co/. La base de datos dada en EDIT.txt  #
#  contiene la información de n=1,718 empresas que reportaron los datos en    #
#  relación con:                                                              #
#                                                                             #
#  * Departamento interno de I+D (1 = Sí, 2 = “No”).                          #
#  * Disminución en el pago de impuestos (1 = Alta, 2 = Media, 3 = Nula).     #
#  * Ventas nacionales totales (en miles de millones de pesos).               #
###############################################################################

# establecer directorio de trabajo
# IMPORTANTE: no olvide cambiar este directorio en su computador
library(rstudioapi)
filename = "graficos.r"
filepath = rstudioapi::getActiveDocumentContext()$path
dir = substr(filepath, 1, nchar(filepath)-nchar(filename))
setwd(dir)
# importar datos
EDIT <- read.table(file = "EDIT.txt", header = TRUE)
# tamaño de la muestra
n <- nrow(EDIT)
# tabla de frecuencias relativas
tabla <- 100*table(EDIT$ID)/n
names(tabla) <- c("Sí","No")
print(round(x = addmargins(tabla), digits = 2))
# diagramas
par(mfrow = c(1,2))
barplot(height = tabla, xlab = "Departamento I+D", ylab = "Porcentaje", col = "gray90")
pie(x = tabla, col = c("white", "gray90"))