# purpose: calculate the heterosis
# Jinliang Yang
# 2.1.2012

setwd("/Users/yangjl/Documents/Heterosis_GWAS/pheno2011");
ptrait <- read.csv("diallel_ptrait.csv")

p <- subset(ptrait, Note=="Founder")
f1 <- subset(ptrait, Note=="F1")

f1$KRN_HPH <- NA
f1$KRN_MPH <- NA
f1$CL_HPH <- NA
f1$CL_MPH <- NA
f1$CW_HPH <- NA
f1$CW_MPH <- NA
f1$CD_HPH <- NA
f1$CD_MPH <- NA
f1$AKW_HPH <- NA
f1$AKW_MPH <- NA
f1$TKW_HPH <- NA
f1$TKW_MPH <- NA
f1$KC_HPH <- NA
f1$KC_MPH <- NA

for (i in 1:nrow(f1)){
  p1 <- as.character(f1$p1[i]);
  p2 <- as.character(f1$p2[i]);
  f1$KRN_HPH[i] <- f1$KRN[i] - max(p[p$ped==p1, ]$KRN, p[p$ped==p2, ]$KRN);
  f1$KRN_MPH[i] <- f1$KRN[i] - mean(c(p[p$ped==p1, ]$KRN, p[p$ped==p2, ]$KRN), na.rm=T);
  f1$CL_HPH[i] <- f1$CL[i] - max(p[p$ped==p1, ]$CL, p[p$ped==p2, ]$CL);
  f1$CL_MPH[i] <- f1$CL[i] - mean(c(p[p$ped==p1, ]$CL, p[p$ped==p2, ]$CL), na.rm=T);
  f1$CW_HPH[i] <- f1$CW[i] - max(p[p$ped==p1, ]$CW, p[p$ped==p2, ]$CW);
  f1$CW_MPH[i] <- f1$CW[i] - mean(c(p[p$ped==p1, ]$CW, p[p$ped==p2, ]$CW), na.rm=T);
  f1$CD_HPH[i] <- f1$CD[i] - max(p[p$ped==p1, ]$CD, p[p$ped==p2, ]$CD);
  f1$CD_MPH[i] <- f1$CD[i] - mean(c(p[p$ped==p1, ]$CD, p[p$ped==p2, ]$CD), na.rm=T);
  f1$AKW_HPH[i] <- f1$AKW[i] - max(p[p$ped==p1, ]$AKW, p[p$ped==p2, ]$AKW);
  f1$AKW_MPH[i] <- f1$AKW[i] - mean(c(p[p$ped==p1, ]$AKW, p[p$ped==p2, ]$AKW), na.rm=T);
  f1$TKW_HPH[i] <- f1$TKW[i] - max(p[p$ped==p1, ]$TKW, p[p$ped==p2, ]$TKW);
  f1$TKW_MPH[i] <- f1$TKW[i] - mean(c(p[p$ped==p1, ]$TKW, p[p$ped==p2, ]$TKW), na.rm=T);
  f1$KC_HPH[i] <- f1$KC[i] - max(p[p$ped==p1, ]$KC, p[p$ped==p2, ]$KC);
  f1$KC_MPH[i] <- f1$KC[i] - mean(c(p[p$ped==p1, ]$KC, p[p$ped==p2, ]$KC), na.rm=T);
}
#########################################################################################
par(mfrow=c(2,4))
hist(f1$KRN_HPH, main="KRN HPH", xlab="row", cex.lab=1.5);
hist(f1$KC_HPH, main="KC HPH", xlab="count", cex.lab=1.5);
hist(f1$TKW_HPH, main="TKW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$AKW_HPH, main="AKW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$CL_HPH, main="CL HPH", xlab="length (mm)", cex.lab=1.5);
hist(f1$CW_HPH, main="CW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$CD_HPH, main="CD HPH", xlab="diameter (mm)", cex.lab=1.5);

par(mfrow=c(2,4))
hist(f1$KRN_MPH, main="KRN HPH", xlab="row", cex.lab=2);
hist(f1$KC_MPH, main="KC HPH", xlab="count", cex.lab=2);
hist(f1$TKW_MPH, main="TKW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$AKW_MPH, main="AKW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$CL_MPH, main="CL HPH", xlab="length (mm)", cex.lab=2);
hist(f1$CW_MPH, main="CW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$CD_MPH, main="CD HPH", xlab="diameter (mm)", cex.lab=2);

#################################################################################
diallel <- f1

diallel$p1 <- toupper(diallel$p1)
diallel$p2 <- toupper(diallel$p2)

parents <- read.table("nam_parents", header=TRUE)
parents$parent <- toupper(parents$parent)
B73 <- data.frame(pop="B73", pedigree="B73", parent="B73")
parents <- rbind(B73, parents)

diallel <- merge(diallel, parents[, c(1,3)], by.x="p1", by.y="parent")
diallel <- merge(diallel, parents[, c(1,3)], by.x="p2", by.y="parent")

diallel$FID <- paste(diallel$pop.x, diallel$pop.y, sep="x")
diallel$IID <- 1
diallel <- diallel[,c("FID", "IID", "KRN", "CL", "CW", "CD", "AKW", "TKW", "KC",
                      "KRN_HPH", "CL_HPH", "CW_HPH", "CD_HPH", "AKW_HPH", "TKW_HPH", "KC_HPH",
                      "KRN_MPH", "CL_MPH", "CW_MPH", "CD_MPH", "AKW_MPH", "TKW_MPH", "KC_MPH")];

####default --missing-phenotype -9
diallel[is.na(diallel)] <- -9

write.table(diallel, "diallel_PLINK_040412.txt", row.names=FALSE, col.names=FALSE, quote=FALSE)

########################### Specific Combining Ability##########################################


# Maddison and Kremer long-run evidence

#########################################################################
# Pull Maddison data into dataframe
mad <- read.csv("maddison2010.csv", header=TRUE)

mad <- mad[which(mad$year>1819),] # only 1820 and later

mad$lndenmark <- round(log(mad$denmark),digits=2)
mad$lnfrance <- round(log(mad$france),digits=2)
mad$lnusa <- round(log(mad$usa),digits=2)
mad$lnenglandgbuk <- round(log(mad$englandgbuk),digits=2)
mad$lnhollandnetherlands <- round(log(mad$hollandnetherlands),digits=2)

#########################################################################
# Figure for long-run GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~year)
fig <- fig %>% add_trace(y = ~lnfrance, name = 'France', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnusa, name = 'USA', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnhollandnetherlands, name = 'Holland/Netherlands', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnenglandgbuk, name = 'England/UK', type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita in the long run', x=0),
              xaxis = list(title = 'Year', tick0=1820, dtick=20),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "mad-stable-lngdppc")

##########################################################################
# Pull Maddison world data in and figure for global GDP per capita and pop
#########################################################################
mad <- read.csv("maddison_world.csv", header=TRUE)

fig <- plot_ly(mad, x = ~ln_pop, y = ~ln_gdppc, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of GDP p.c. and population', x=0),
              xaxis = list(title = 'Log global population'),
              yaxis = list(title = 'Log global GDP per capita')
              )
api_create(fig, filename = "mad-global-lngdppc-pop")

# Calculate average growth rates between Maddison observations
mad <- # lag the population
  mad %>%
  mutate(lag.ln_pop = dplyr::lag(ln_pop, n = 1, default = NA))
mad <- # lag the year
  mad %>%
  mutate(lag.year = dplyr::lag(year, n = 1, default = NA))
mad <- # lag the GDP per capita
  mad %>%
  mutate(lag.ln_gdppc = dplyr::lag(ln_gdppc, n = 1, default = NA))
mad$gy <- (mad$ln_gdppc - mad$lag.ln_gdppc)/(mad$year-mad$lag.year)
mad$gl <- (mad$ln_pop - mad$lag.ln_pop)/(mad$year-mad$lag.year)

#########################################################################
# Figure of growth rate of population and growth rate of GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~gl, y = ~gy, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population and GDP p.c. growth', x=0),
              xaxis = list(title = 'Global population growth'),
              yaxis = list(title = 'GDP p.c.')
)
api_create(fig, filename = "mad-global-gy-gl")

#########################################################################
# Figure of pop growth rate and GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~gl, y = ~ln_gdppc, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population growth and GDP p.c.', x=0),
              xaxis = list(title = 'Global population growth'),
              yaxis = list(title = 'Global GDP p.c.')
)
api_create(fig, filename = "mad-global-y-gl")

#########################################################################
# Pull in Kremer data and create figure
#########################################################################
kr <- read.csv("kremer.csv", header=TRUE)
fig <- plot_ly(kr, x = ~pop, y = ~n, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population level and growth', x=0),
              xaxis = list(title = 'Population (millions)'),
              yaxis = list(title = 'Population growth rate')
)
api_create(fig, filename = "kremer-pop-gl")


# Classify using neural networks
library(neuralnet)
library(caret)
source("utils/load-data.r")
source("utils/accuracy-statistics.r")

AllData = LoadClassificationData()
TrainingData = LoadTrainingData()
TrainingNames = GetTrainingNames(exclude=c("osavi", "amplitude1"))

OutputDir = "../data/"

set.seed(0xfedbeef)
folds = createFolds(AllData$cropland, 4)
fold = folds$Fold1

# Naive attempt at raw data
Formula = paste0(paste0(GetValidationNames(), collapse="+"),"~",paste0(TrainingNames, collapse="+"))
Model = neuralnet(Formula, AllData@data[fold,], 12, lifesign="full", stepmax=100000, rep=5, threshold=10)
plot(Model)
Prediction = compute(Model, AllData@data[-fold,TrainingNames])

# Normalise from min-max to sum to 100%
ScaleNNPrediction = function(prediction, global=FALSE)
{
    PredMinScale = prediction
    Min = min(prediction)
    for (i in 1:nrow(prediction))
    {
        if (!global)
            Min = min(prediction[i,])
        PredMinScale[i,] = (prediction[i,]+abs(Min)) / sum(prediction[i,]+abs(Min))*100
    }
    PredMinScale = data.frame(PredMinScale)
    names(PredMinScale) = GetValidationNames()
    return(PredMinScale)
}

PredMinScale = Prediction$net.result
for (i in 1:nrow(Prediction$net.result))
{
    PredMinScale[i,] = (Prediction$net.result[i,]+abs(min(Prediction$net.result[i,]))) /
        sum(Prediction$net.result[i,]+abs(min(Prediction$net.result[i,])))*100
}
PredMinScale = data.frame(PredMinScale)
names(PredMinScale) = GetValidationNames()

# RMSE of 24, in line with gradient boosting results (quite poor) and somewhat biased
AccuracyStatTable(PredMinScale, AllData@data[-fold,GetValidationNames()])

# Normalise by using cutoff
TruncateNNPrediction = function(prediction)
{
    Result = prediction
    Result[Result < 0] = 0
    Result[Result > 1] = 1
    for (i in 1:nrow(Result))
        Result[i,] = Result[i,] / sum(Result[i,])*100
    return(Result)
}
PredCutScale = Prediction$net.result
for (i in 1:length(PredCutScale))
{
    PredCutScale[[i]] = max(0, PredCutScale[[i]])
}
for (i in 1:nrow(PredCutScale))
{
    PredCutScale[i,] = PredCutScale[i,] / sum(PredCutScale[i,])*100
}
PredCutScale = data.frame(PredCutScale)
names(PredCutScale) = GetValidationNames()

# Still 24 RMSE, this is better for water but more biased
AccuracyStatTable(PredCutScale, AllData@data[-fold,GetValidationNames()])

## Retry using scaled data
ScaleDataUntransf = AllData@data
ScaleDataUntransf$dominant = NULL
maxs = apply(ScaleDataUntransf, 2, max)
mins = apply(ScaleDataUntransf, 2, min)
ScaleDataUntransf = as.data.frame(scale(ScaleDataUntransf, center = mins, scale = maxs - mins))

NNCV = function(filename="stat-neuralnetworks.csv", exclude=c(), outdir=OutputDir, ...)
{
    TrainingNames = GetTrainingNames(exclude=exclude)
    Formula = paste0(paste0(GetValidationNames(), collapse="+"),"~",paste0(TrainingNames, collapse="+"))
    PredictionsPerFold = data.frame()
    for (f in 1:length(folds))
    {
        set.seed(0xfedbeef)
        ModelUntransf = neuralnet(Formula, ScaleDataUntransf[-folds[[f]],], lifesign="minimal", rep=10, ...)
        PredictionUntransf = compute(ModelUntransf, ScaleDataUntransf[folds[[f]],TrainingNames], rep=which.min(ModelUntransf$result.matrix[1,]))

        if (nrow(PredictionsPerFold) == 0)
            PredictionsPerFold = ScaleNNPrediction(PredictionUntransf$net.result)
        else
            PredictionsPerFold = rbind(PredictionsPerFold, ScaleNNPrediction(PredictionUntransf$net.result))
    }
    Validator = AllData@data[unlist(folds),GetValidationNames()]
    AST = AccuracyStatTable(PredictionsPerFold, Validator)
    print(AST)
    plot(unlist(PredictionsPerFold), unlist(Validator))
    write.csv(AST, paste0(outdir, filename))
    write.csv(CalcErrors(PredictionsPerFold, Validator), paste0(outdir, "errors-", filename))
}
# Unoptimised
NNCV("stat-neuralnetworks-unoptimised.csv", hidden=11, threshold=0.15)
# Optimised: 22.13
NNCV(exclude=c("osavi", "amplitude1", "aspect", "blue", "is.water", "amplitude2", "tpi"), hidden=9, threshold=0.05)

# No scaling: 24.5
#AccuracyStatTable(PredictionUntransf$net.result*100, AllData@data[-fold,GetValidationNames()])
# Row-based scaling: 22.3, better
#AccuracyStatTable(ScaleNNPrediction(PredictionUntransf$net.result), AllData@data[-fold,GetValidationNames()])
# Truncating: 21.8, slightly better than scaling
#AccuracyStatTable(TruncateNNPrediction(PredictionUntransf$net.result), AllData@data[-fold,GetValidationNames()])

# Train on pure, predict fuzzy
folds=list(which(!ScaleDataUntransf$pure))

# Unoptimised
NNCV("stat-neuralnetworks-pure-unoptimised.csv", hidden=11, threshold=0.15)
# Optimised
NNCV(exclude=c("osavi", "amplitude1", "aspect", "blue", "is.water", "amplitude2", "tpi"), hidden=9, threshold=0.05,
    filename="stat-neuralnetworks-pure.csv")


## Generate some random categorical data
x <- round(rnorm(1000, 100) * 10)

head(x)

barplot(table(x))

t <- table(x)

## Change to frequencies
t <- t/1000

barplot(t)

## Average frequency?
a <- mean(t)
a

## relative frequency over the average
head(t)
head(t/a)

barplot(t/a)

barplot(log(t/a))


cosine_R <- function(x)
{
  cp <- crossprod(x)
  rtdg <- sqrt(diag(cp))
  cos <- cp / tcrossprod(rtdg)
  return(cos)
}

library(compiler)
cosine_R <- cmpfun(cosine_R)

library(coop)
library(rbenchmark)
cols <- cols <- c("test", "replications", "elapsed", "relative")
reps <- 25

m <- 10000
n <- 250
x <- matrix(rnorm(m*n), m, n)

benchmark(cosine_R(x), cosine(x), replications=reps, columns=cols)
### Too slow!
#benchmark(lsa::cosine(x), cosine(x), replications=reps, columns=cols)


"Fits a k-nn model on the pre-processed training data from the Cleveland Heart Disease dataset (https://archive-beta.ics.uci.edu/ml/datasets/heart+disease) Saves the model as a rds file.
Usage: src/modeling.r --train=<train> --test=<test> --out_dir=<out_dir>

Options:
--train=<train>     Path (including filename) to training data (which needs to be saved as a csv file)
--test=<test>     Path (including filename) to testing data (which needs to be saved as a csv file)
--out_dir=<out_dir> Path to directory where the serialized model should be written
" -> doc

library(tidyverse)
library(tidymodels)
library(ggplot2)
library(GGally)
library(docopt)
library(rlang)
library(group2)
# source("R/accuracy_plot.r")
set.seed(4)

opt <- docopt(doc)

main <- function(train, test, out_dir) {

    # Perform Cross Validation
    training_data <- read.csv(train)
    training_data$diagnosis <- as.factor(training_data$diagnosis)
    hd_vfold <- vfold_cv(training_data, v = 5, strata = diagnosis)

   recipe <- recipe(diagnosis ~ ., data = training_data) %>%
       step_scale(all_predictors()) %>%
       step_center(all_predictors())

    # Create Classifier and Tuning
    knn_spec <- nearest_neighbor(weight_func = "rectangular", neighbors = tune()) %>%
        set_engine("kknn") %>%
        set_mode("classification")

    k_vals <- tibble(neighbors = seq(from = 1, to = 100, by = 5))

    knn_results <- workflow() %>%
        add_recipe(recipe) %>%
        add_model(knn_spec) %>%
        tune_grid(resamples = hd_vfold, grid = k_vals) %>%
        collect_metrics()

    accuracies <- knn_results %>%
        filter(.metric == "accuracy")

    accuracy_vs_k <- accuracy_plot(accuracies)

    try({
        dir.create(out_dir, recursive = TRUE)
    })

    ggsave(paste0(out_dir, "/accuracy_plot.png"),
         accuracy_vs_k,
         width = 8,
         height = 10)

    # Prediction and Training
    knn_spec <- nearest_neighbor(weight_func = "rectangular", neighbors = 12) %>%
        set_engine("kknn") %>%
        set_mode("classification")

    knn_fit <- workflow() %>%
        add_recipe(recipe) %>%
        add_model(knn_spec) %>%
        fit(data = training_data)

   # Load and Wrangle test data
    test_data <- read.csv(test)
    test_data$diagnosis <- as.factor(test_data$diagnosis)

    hd_predictions <- predict(knn_fit, test_data)  %>%
        bind_cols(test_data)

    hd_predictions %>%
        metrics(truth = diagnosis, estimate = .pred_class) %>%
        filter(.metric == "accuracy")

    # Assess Model Accuracy
    confusion_mat <- hd_predictions %>%
        conf_mat(truth = diagnosis, estimate = .pred_class)

    Truth <- factor(c(0, 0, 1, 1))
    Prediction <- factor(c(0, 1, 0, 1))
    Y <- c(9, 31, 27, 8)
    df <- data.frame(Truth, Prediction, Y)

    confusion_mat_plot <- ggplot(data =  df, mapping = aes(x = Truth, y = Prediction)) +
        geom_tile(aes(fill = Y), colour = "white") +
        geom_text(aes(label = sprintf("%1.0f", Y)), vjust = 1, colour="white") +
    theme_bw()

    ggsave(paste0(out_dir, "/confusion_matrix.png"),
           confusion_mat_plot,
           width = 8,
           height = 10)

}
main(opt[["--train"]], opt[["--test"]], opt[["--out_dir"]])


#  James Rekow

meanOverCurve = function(M, lambda){

  #  ARGS:
  #
  #  RETURNS: the expected value of the mean overlap of a DOC with M samples and exponentially distributed
  #           wait times between interactions with rate parameter lambda

  return(1 - exp(-100 * lambda / M))

} #  end meanOverCurve function


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 2.6A   Chapter : 2.6   Pageno : 101
# LU factorisation
library(pracma)
P<-matrix(c(1,1,1,1,1,2,3,4,1,3,6,10,1,4,10,20),ncol=4)
print("LU factorisation of P")
print(lu(P))


#' Evaluate the probability density function of a density approximation
#'
#' description
#' @param fit An mvd.density object obtained from one of the density fitting functions.
#' @param x Matrix or vector of positions at which to evaluate the density function.
#' @param log Boolean which specifies whether to return the probability density in log space.
#' @export
mvd.pdf <- function(fit, x, log = FALSE) {
    stopifnot(class(fit) == "mvd.density")

    if (fit$type == "kde") {
        return(.evaluate.kde(fit, x, log))
    } else if (fit$type == "kde.transformed") {
        transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
        p <- .evaluate.kde(fit$kde, transformed, log = log)
        return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else if (fit$type == "gmm") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

            p <- matrix(NA, nrow(x), fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[, ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[, ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(apply(p, 1, .logsum))
            } else {
                return(apply(p, 1, sum))
            }
        } else {
            stopifnot(length(x) == ncol(fit$centers))

            p <- rep(NA, fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(.logsum(p))
            } else {
                return(sum(p))
            }
        }
    } else if (fit$type == "gmm.transformed") {
        transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
        p <- mvd.pdf(fit$gmm, transformed, log = log)
        return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else if (fit$type == "gmm.truncated") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

            p <- matrix(NA, nrow(x), fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[, ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[, ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(apply(p, 1, .logsum))
            } else {
                return(apply(p, 1, sum))
            }
        } else {
            stopifnot(length(x) == ncol(fit$centers))

            p <- rep(NA, fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(.logsum(p))
            } else {
                return(sum(p))
            }
        }
    } else if (fit$type == "gp") {
        return(evaluate.gp(fit, x, log))
    } else if (fit$type == "vine.copula") {
        return(evaluate.vine.copula(fit, x, log))
    } else if (fit$type == "mfa") {
      return(evaluate.factor.mixture(fit, x, log))
    } else if (fit$type == "mfa.transformed") {
      transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
      p <- mvd.pdf(fit$mfa, transformed, log = log)
      return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else {
        stop("Unknown type")
    }
}


library(tibble)

get_tibble <- function() {
  tibble(x = 1:5, y = 1, z = x ^ 2 + y)
}


 DSYTRD Example Program Results

 Diagonal and off-diagonal elements of tridiagonal form

     i         D            E
     1      2.07000      5.82575
     2      1.47409      2.62405
     3     -0.64916      0.91627
     4     -1.69493


"angular" <- function(proportions, n)
{180/pi*asin(sqrt(proportions + (proportions==0)/(4*n) + (proportions==1)*((n-0.25)/n-1)))}
"angular.mod" <- function(count, n)
{180/pi*asin(sqrt((count+0.375)/(n+0.75)))}


G02BRJ Example Program Results

Number of variables (columns) = 3
Number of case      (rows)    = 9

Data matrix is:-

          1       2       3
  1     1.7000  1.0000  0.5000
  2     2.8000  4.0000  3.0000
  3     0.6000  6.0000  2.5000
  4     1.8000  9.0000  6.0000
  5     0.9900  4.0000  2.5000
  6     1.4000  2.0000  5.5000
  7     1.8000  9.0000  7.5000
  8     2.5000  7.0000  0.0000
  9     0.9900  5.0000  3.0000

Matrix of rank correlation coefficients:
Upper triangle -- Spearman's
Lower triangle -- Kendall's tau

          1       2       3
  1     1.0000  0.2941  0.4058
  2     0.1429  1.0000  0.7537
  3     0.2760  0.5521  1.0000

Number of cases actually used: 6


## 2. Tidy model outputs with broom::tidy() ##

library(readr)
williamsburg_north <- suppressMessages(read_csv("williamsburg_north.csv"))
library(broom)

condos_lm_fit <- lm(sale_price ~ gross_square_feet, data = williamsburg_north)

condos_lm_tidied <- tidy(x = condos_lm_fit, conf.int = TRUE)

## 4. Nested data ##

library(tidyr)
library(dplyr)
brooklyn_nested <- brooklyn_top_ten %>%
  group_by(neighborhood) %>%
  nest()

# Return neighborhood name with:
# brooklyn_nested$neighborhood[[6]]

# Return dataframe for Madison
Madison <- brooklyn_nested$data[[6]]

## 5. Generate many linear models ##

library(purrr)
# brooklyn_nested <- brooklyn_top_ten %>%
#   group_by(neighborhood) %>%
#   nest()
brooklyn_nested <- brooklyn_top_ten %>%
  group_by(neighborhood) %>%
  nest() %>%
  mutate(linear_model = map(.x = data,
                            .f = ~lm(sale_price ~ gross_square_feet, data = .)))

## 6. Returning tidy model outputs ##

library(broom)
# brooklyn_nested <- brooklyn_top_ten %>%
#   group_by(neighborhood) %>%
#   nest() %>%
#   mutate(linear_model = map(.x = data,
#                             .f = ~lm(sale_price ~ gross_square_feet, data = .)))
brooklyn_nested <- brooklyn_top_ten %>%
  group_by(neighborhood) %>%
  nest() %>%
  mutate(linear_model = map(.x = data,
                            .f = ~lm(sale_price ~ gross_square_feet,
                                     data = .))) %>%
  mutate(tidy_coefficients = map(.x = linear_model,
                              .f = tidy,
                              conf.int = TRUE))

## 7. Unnesting to return tidy data summaries ##

# brooklyn_nested <- brooklyn_top_ten %>%
#   group_by(neighborhood) %>%
#   nest() %>%
#   mutate(linear_model = map(.x = data,
#                             .f = ~lm(sale_price ~ gross_square_feet,
#                                      data = .))) %>%
#   mutate(tidy_coefficients = map(.x = linear_model,
#                               .f = tidy,
#                               conf.int = TRUE))
brooklyn_coefficients <- brooklyn_nested %>%
  select(neighborhood, tidy_coefficients) %>%
  unnest(cols = tidy_coefficients)

brooklyn_slope <- brooklyn_coefficients %>%
  filter(term == "gross_square_feet") %>%
  arrange(estimate)

## 8. Tidy summary statistics with broom::glance() ##

# brooklyn_nested <- brooklyn_top_ten %>%
#   group_by(neighborhood) %>%
#   nest() %>%
#   mutate(linear_model = map(.x = data,
#                             .f = ~lm(sale_price ~ gross_square_feet,
#                                      data = .))) %>%
#   mutate(tidy_coefficients = map(.x = linear_model,
#                               .f = tidy,
#                               conf.int = TRUE))
brooklyn_nested <- brooklyn_top_ten %>%
  group_by(neighborhood) %>%
  nest() %>%
  mutate(linear_model = map(.x = data,
                            .f = ~lm(sale_price ~ gross_square_feet,
                                     data = .))) %>%
  mutate(tidy_coefficients = map(.x = linear_model,
                                 .f = tidy,
                                 conf.int = TRUE)) %>%
  mutate(tidy_summary_stats = map(.x = linear_model,
                                  .f = glance))

brooklyn_summary_stats <- brooklyn_nested %>%
  select(neighborhood, tidy_summary_stats) %>%
  unnest(cols = tidy_summary_stats)

## 9. Augment dataframes with broom::augment() ##

brooklyn_nested <- brooklyn_top_ten %>%
  group_by(neighborhood) %>%
  nest() %>%
  mutate(linear_model = map(.x = data,
                            .f = ~lm(sale_price ~ gross_square_feet,
                                     data = .))) %>%
  mutate(tidy_coefficients = map(.x = linear_model,
                                 .f = tidy,
                                 conf.int = TRUE)) %>%
  mutate(tidy_summary_stats = map(.x = linear_model,
                                  .f = glance)) %>%
  mutate(data_augmented = map2(.x = linear_model,
                          .y = data,
                          .f = augment))
brooklyn_augmented <- brooklyn_nested %>%
  select(neighborhood, data_augmented) %>%
  unnest(data_augmented)

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/1. Linear Regression Modeling in R/5. Fitting Many Linear Models.r


data <- c(xy.coords(0,100), xy.coords(2556288,0), xy.coords(1364832,30), xy.coords(711936,50), xy.coords(498816,60), xy.coords(362880,65), xy.coords(128640,75), xy.coords(88120,84))

data <- xy.coords(list(0, 88120, 128640, 362880, 498816, 711936, 1364832, 2556288), list(100, 84, 75, 65, 60, 50, 30, 0))
f <- splinefun(data)

# From mathematica
s <- 1:2556299; y <- 100 + s * (-0.0002298 + 4.36414*10^-10*s - 8.57647*10^-22*s^3 + 7.30739*10^-28*s^4 - 1.63087*10^-34*s^5)
# The input data based on real values + educated guesses
data <- xy.coords(list(0, 88120, 128640, 362880, 498816, 711936, 1364832, 2556288), list(100, 84, 75, 65, 60, 50, 30, 0))
f <- splinefun(data, method="natural")
ffmm <- splinefun(data, method="fmm")
# This ones seems best because it doesn't go back up again
fhyman <- splinefun(data, method="hyman")
fmono <- splinefun(data, method="monoH.FC")
plot(f, from=1, to=2556288)
points(list(0, 88120, 128640, 362880, 498816, 711936, 1364832, 2556288), list(100, 84, 75, 65, 60, 50, 30, 0), pch="+")
curve(f, from=1, to=2556288)
curve(ffmm, from=1, to=2556288, col="blue")
curve(fhyman, from=1, to=2556288, col="red")
curve(fmono, from=1, to=2556288, col="green")
lines(s, y, col="purple")

# From Eureqa
internal <- 1:2556299; external <- 100.689 + 3.8502e-6*internal - 0.0631063*sqrt(internal - 3014.77)


#!/usr/bin/R
# compute descriptive statistics, correlation, and regression from raw.txt

# required pacakges
# - dplyr
# - Hmisc

# library
library("dplyr")
library("Hmisc")

# improt raw .txt to data frame
raw_data <- read.delim("raw_data-caffeine.txt")

# convert data to numerical matrix
df <- as.matrix(as.data.frame(lapply(raw_data, as.numeric)))

# output file - descriptive stats
sink("descriptive_stats-caffeine.txt", split=TRUE, append=FALSE)

# descriptive stats
summary(raw_data)

# output file - correlation and regression
sink("correlation-caffeine.txt", split=TRUE, append=FALSE)

# correlations (r) and significance (p)
rcorr(df, type=c("pearson"))


pdf_file<-"pdf/scatterplots_path_ellipse.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=10)

source("scripts/inc_datadesign_dbconnect.r")
par(mai=c(1,1,0.25,0.25),omi=c(1,0.5,1,0.5), mgp=c(4,1,0),family="Lato Light",las=1)

# Import data and prepare chart

sql<-"select * from gemeinden"
myData<-dbGetQuery(con,sql)
attach(myData)
mySelection<-subset(myData,bevinsg >= 12000 & bevinsg <= 16000)
attach(mySelection)
library(ellipse)
mx<-mean(bevm)
my<-mean(bevw)
mxy<-c(mx,my)
sxy<-sapply(mySelection[,c("bevm","bevw")],sd)
r<-cor(bevm,bevw)

# Define chart and other elements

plot(bevm,bevw,type="n",axes=F,xlab="Number of men",ylab="Number of women",xlim=c(4000,9000),ylim=c(4000,9000))
lines(ellipse(r,scale=sxy,centre=mxy))
abline(v=seq(4000,9000,by=1000),col="black",lty=3,lwd=1)
abline(h=seq(4000,9000,by=1000),col="black",lty=3,lwd=1)
axis(1,cex.axis=1.2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,cex.axis=1.2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
symbols(bevm,bevw,bg="red",circles=rep(2,nrow(mySelection)),inches=0.15,add=T,xpd=T,fg="white")
mySelection2<-subset(mySelection,bevm >= 7500 & bevw <= 6500)
attach(mySelection2)
text(bevm,bevw,iconv(gemeinde,"LATIN1","UTF-8"),family="Lato Black",pos=3,offset=1.1)

# Titling

mtext("Number of men and women in Germany",3,adj=0,line=1.5,cex=2.5,family="Lato Black",outer=T)
mtext("Municipalities, between 12,000 and 16,000 inhabitants",3,adj=0,line=-0.25,cex=1.5,font=3,outer=T)
mtext("Source: GV-ISys",1,line=2,adj=1,cex=1.25,font=3,outer=T)
dev.off()


csvfile = read.csv(file=" ?.csv", stringsAsFactors=F, header=T)
attach(data1)
data1 = data.frame(?, ?, ?, ?, ?, ?, ?)
library(nnet)
library(MASS)
library(NeuralNetTools)
library(neuralnet)

data2 = sample(2, nrow(data1), replace = T, prob=c(0.5, 0.5))
fixed <- data1[data2==1,]
test <- data1[data2==2,]

summary(fixed)

summary(test)

wnnet = nnet(? ~ ? + ? + ? + ? + ? + ?, data = fixed, size=3)

summary(wnnet)

names(wnnet)

wnnet$wts
wnnet$residuals

plotnet(wnnet)


#' Print a Simplex Table
#'
#' Using the notation of Bazaraa et. al., given a table \code{x} and a
#' basis vector \code{Bs}, this will produce the LaTeX for a simplex
#' tableau.
#'
#' @param x
#' A matrix of values for the simplex table.
#' @param Bs
#' The indices of the current basis.
#' @param digits
#' The number of decimal digits to use in the table.
#'
#' @importFrom xtable xtable align
#'
#' @export
tableau <- function(x, Bs, digits=0)
{
  namedBs <- sapply(Bs, function(i) ifelse(is.na(i), NA, paste0("$a_", i, "$")))
  df <- data.frame(cbind(x, namedBs))
  colnames(df) <- c("$z$", paste0("$x_", 1:(ncol(x)-2), "$"), "RHS", "$B_s$")

  tabl <- xtable::xtable(df, digits=digits)

  align <- paste0("r|r|", paste0(rep("r", ncol(x)-2), collapse=""), "|r|r|")
  xtable::align(tabl) <- align

  cat("\\begin{center}")
  print(tabl, floating=FALSE, include.rownames=FALSE,
        hline.after=c(-1:1, nrow(x)), sanitize.text.function=function(x){x})
  cat("\\end{center}")

  invisible()
}


#######################################################
### Gamma distribution with Lambda = 8, Alpha = 0.5 ###
#######################################################

mu <- exp(2.769201)
lambdaEstMLE <- exp(2.060237)
alphaEstMLE <- lambdaEstMLE/mu
print(paste0('Estimated alpha (MLE): ', alphaEstMLE))
print(paste0('Estimated lambda (MLE): ', lambdaEstMLE))


#' 32-Bit Floats
#'
#' @description
#' R comes with a suite of utilities for linear algebra with "numeric"
#' (double precision) vectors/matrices. However, sometimes single precision (or
#' less!) is more than enough for a particular task.  This package extends R's
#' linear algebra facilities to include 32-bit float (single precision) data.
#' Float vectors/matrices have half the precision of their "numeric"-type
#' counterparts but are generally faster to numerically operate on, for a
#' performance vs accuracy trade-off.  The internal representation is an S4
#' class, which allows us to keep the syntax identical to that of base R's.
#' Interaction between floats and base types for binary operators is generally
#' possible; in these cases, type promotion always defaults to the higher
#' precision.  The package ships with copies of the single precision 'BLAS' and
#' 'LAPACK', which are automatically built in the event they are not available
#' on the system.
#'
#' @importFrom utils capture.output str
#' @import methods
#'
#' @docType package
#' @name float-package
#' @author Drew Schmidt
#' @keywords package
NULL


library(pomp)
library(magrittr)
library(plyr)
library(reshape2)
library(ggplot2)
library(scales)
library(dplyr)

# measurement model
dmeas <- Csnippet("lik =  dnbinom_mu(cases, 1/od, H, 1); ")
rmeas <- Csnippet("cases = rnbinom_mu(1/od,H);")

# transmission model is Markovian SIRS with 3 age classes, seasonal forcing and overdispersion
sir.step <- Csnippet("double rate[7];
                      double dN[7];
                      double Beta1;
                      double dW;

                      // compute the environmental stochasticity
                      dW = rgammawn(sigma,dt);

                      Beta1 = beta1*(1 + beta11 * cos(M_2PI/52*t + phi)) * dW/dt;
                      rate[0] = mu*N;
                      rate[1] = Beta1*I/N;
                      rate[2] = mu;
                      rate[3] = gamma;
                      rate[4] = mu;
                      rate[5] = omega;
                      rate[6] = mu;

                      dN[0] = rpois(rate[0]*dt); // births are Poisson
                      reulermultinom(2, S, &rate[1], dt, &dN[1]);
                      reulermultinom(2, I, &rate[3], dt, &dN[3]);
                      reulermultinom(2, R, &rate[5], dt, &dN[5]);
                      S += dN[0] - dN[1] - dN[2] + dN[5];
                      I += dN[1] - dN[3] - dN[4];
                      R += dN[3] - dN[6] - dN[5];
                      H += dN[1];
                      ")

# initializer
init <- function(params, t0, ...) {
  x0 <- c(S=0,I=0,R=0,H=0)
  x0["S"] <- 79807318
  x0["I"] <- 3683
  x0["R"] <- params["N"] - x0["I"] - x0["S"]
  round(x0)
}

# paramter vector with betas and inital data, unit is weeks
params <- c(beta1=1, beta11=0.17, phi=0.1, gamma=1, mu=1/(75*52), N=80000000,
            omega=1/(1*52), od=0.1, sigma=0.05)

# create an empty data frame
dat <- data.frame(times=seq(1:400), cases = rep(0, 400))

#pomp object; initalize at t0 before t=0 so system can equilibrate
pomp(data = dat,
     times="times",
     t0=-100,
     dmeasure = dmeas,
     rmeasure = rmeas,
     rprocess = euler.sim(step.fun = sir.step, delta.t = 1/10),
     statenames = c("S", "I", "R", "H"),
     paramnames = names(params),
     zeronames=c("H"),
     initializer=init,
     params = params
) -> sir

#simulate one trajectory from the pomp object
df <- simulate(sir, as.data.frame=TRUE, seed=123)
# delete first row of the df because this is the accumulation of cases from t0 until t=0
df <-df[-1,]
# delete the last column of the df because this is the number of simulation
df <- df[,-7]

# plotting the simulated trajectory
df <-df%>% melt(id="time")
df$variable <- factor(df$variable)

df %>% mutate(variable = recode(variable, cases = "Cases")) %>%
  mutate(variable = recode(variable, S = "Susceptible")) %>%
  mutate(variable = recode(variable, I = "Infectious")) %>%
  mutate(variable = recode(variable, R = "Recovered")) %>%
  mutate(variable = recode(variable, H = "True incidence")) %>%
  # Plot
  ggplot() +
  geom_line(aes(x = time, y = value)) +
  facet_wrap( ~variable, ncol=1, scales =  "free_y")+
  xlab("Time (years)") + ylab(" Number of individuals")


##### calculate the TSLS esitmators and covariance matrix estimator

para=function(ivmodel){
  output=list()
  fit1=lm(ivmodel$Dadj~ivmodel$Zadj-1)
  output$gamma=coef(fit1)
  names(output$gamma)=NULL
  output$beta=c(KClass(ivmodel, k=1)$point.est)
  hat_eps=ivmodel$Yadj-c(output$beta)*ivmodel$Dadj
  hat_eta=resid(fit1)
  output$sigmau=sqrt(sum(hat_eps^2)/(ivmodel$n-ivmodel$p))
  output$sigmav=sqrt(sum(hat_eta^2)/(ivmodel$n-ivmodel$p))
  output$rho=sum(hat_eta*hat_eps)/(ivmodel$n-ivmodel$p)/output$sigmau/output$sigmav
  return(output)
}


#main function and helper functions for pTFCE R package

#main function

#' pTFCE main function.
#'
#' The threshold-free cluster enhancement (TFCE) approach integrates cluster information into voxel-wise statistical inference to enhance detectability of neuroimaging signal. Despite the significantly increased sensitivity, the application of TFCE is limited by several factors: (i) generalization to data structures, like brain network connectivity data is not trivial, (ii) TFCE values are in an arbitrary unit, therefore, P-values can only be obtained by a computationally demanding permutation-test.
#' Here, we introduce a probabilistic approach for TFCE (pTFCE), that gives a simple general framework for topology-based belief boosting.
#' The core of pTFCE is a conditional probability, calculated based on Bayes' rule, from the probability of voxel intensity and the threshold-wise likelihood function of the measured cluster size. We provide an estimation of these distributions based on Gaussian Random Field (GRF) theory. The conditional probabilities are then aggregated across cluster-forming thresholds by a novel incremental aggregation method. Our approach is validated on simulated and real fMRI data.
#' pTFCE is shown to be more robust to various ground truth shapes and provides a stricter control over cluster "leaking" than TFCE and, in the most realistic cases, further improves its sensitivity. Correction for multiple comparison can be trivially performed on the enhanced P-values, without the need for permutation testing, thus pTFCE is well-suitable for the improvement of statistical inference in any neuroimaging workflow.
#'
#' @references
#' T. Spisák, Z. Spisák, M. Zunhammer, U. Bingel, S. Smith, T. Nichols, T. Kincses, Probabilistic TFCE: a generalized combination of cluster size and voxel intensity to increase statistical power, Neuroimage.
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param img Nifti Z-score image to enhance ("nifti" class from "oro.nifti" package)
#' @param mask Mask
#' @param Rd Resel count (FSL smoothest: VOLUME*DHL)
#' @param V Number of voxels in mask (FSL smoothest: VOLUME)
#' @param resels Resel size (FSL smoothest: RESELS)
#' @param residual 4D residual data for a better estimate of image smoothness (optional)
#' @param dof Degrees of freedom (optional, but obligatory if residual is specified)
#' @param Nh Number of thresholds (not safe to change the default)
#' @param logpmin min threshold (not safe to change the default)
#' @param logpmax max threshold (not safe to change the default)
#' @param ZestThr Cluster-forming Z threshold below which P(h|c) is estimated as P(h), due to limitation of GRF theory. (default: 1.3, not safe to change)
#' @param verbose boolean: print progress bar and diagnostic messages if true (default)
#'
#' @details The function takes a Z-score image and a mask image (both "nifti" object of the oro.nifti package) as obligatory inputs.
#' Mask can be either binary or continous, in the latter case it will be thresholded at 0.5.
#' Parameters V (number of voxels) and Rd (voxels per RESEL, computed as V*RESELS from the smoothest outpout) are optional and are to be interpreted as in FSL "smoothest".
#' If you want pTFCE to compute FWER-based Z-threshold for correction of multiple comparisons, specify the parameter resels (resels field of smoothest), together with Rd and V.
#' If not specified, these values are estimated from the data, internally via the smoothest() function of this package, which is a direct port of the corresponding FSL function.
#' If Rd and/or V is not specified, and residual and dof is specified, image smoothness will be determined basedd on teh 4D residual data (more accurate, see ?smoothest()).
#' For more details on smoothness estimation, see https://github.com/spisakt/pTFCE/wiki/Some-important-notes-on-smoothness-estimation.
#' The default value of the parameter Nh should work with images having usual ranges of Z-scores. At low values, although the processing becomes faster, the estimation of the enhanced values might become inaccurate and the enhanced p-value distribution becomes increasingly non-uniform. It is not recommended to set it lower than 30.
#' The parameters logpmin and logpmax define the range of values the incremental thresholding procedure covers. By default, these are based on the input data and it is not recommended to cahnge them.
#'
#' @return An object of class "ptfce" is a list containing at least the following components:
#' \itemize{
#' \item{\strong{p} (uncorrected) pTFCE enhanced p-values}
#' \item{\strong{logp}  negative logarithm of pTFCE enhanced p-values}
#' \item{\strong{Z} pTFCE enhanced p-values converted to Z-scores}
#' \item{\strong{number_of_resels} number of resels (input for e.g. ptoz) }
#' \item{\strong{fwer0.05.Z} Z-score threshold corresponding to the corrected p<0.05 threshold, controlled for FWER}
#' }
#'
#' @export
#'
#' @examples \dontrun{Z=readNIfTI("Zmap.nii.gz");
#'
#' MASK=readNIfTI("mask.nii.gz");
#'
#' # OPTION 1: use standalone with Z-map-based smoothness estimation
#' pTFCE=ptfce(Z, MASK); # estimate smoothness based on the Z-score map
#' # (might be inaccurate, but still guarantees FWER)
#'
#' #OPTION 2: use smoothness estimation based oj residual data (more accurate)
#' RES4D=readNIfTI("res4D.nii.gz");
#' pTFCE=ptfce(Z, MASK, residual=RES4D) # a bit slow, currently...
#'
#' #OPTION 2: equivalent to option2, but faster (uses FSL)
#' # run FSL smoothest in the command line:
#' # smoothest -r res4d.nii.gz -d DOF -m mask.nii.gz > smoothness.txt
#'
#' smooth=read.table("smoothness.txt"); # output by FSL smoothest
#' pTFCE=ptfce(Z, V=smooth[2,2], Rd = smooth[1,2]*smooth[2,2], mask = MASK);
#'
#' # plot if you want
#' orthographic(pTFCE$Z)
#'
#' # save NIfTI image
#' writeNIfTI(pTFCE$Z, "pTFCE_Z")
#'
#' #See https://github.com/spisakt/pTFCE fro more examples
#' }
ptfce=function(img, mask, Rd=NA, V=NA, resels=NA, residual=NA, dof=NA,  logpmin=0, logpmax=-log(stats::pnorm(max(img), lower.tail = F)), ZestThr=1.3, Nh=100, verbose=T )
{
  if (length(img[is.na(img)])>0)
  {
    warning("NAs detected and replaced with zero!")
    img[is.na(img)] = 0
  }
  if (length(img[!is.finite(img)])>0)
  {
    warning("Infinite values detected and replaced with zero!")
    img[!is.finite(img)] = 0
  }
  autosmooth=F
  if (is.na(Rd) || is.na(V))
  {
    autosmooth=T
    if (!is.na(residual))
    {
        if (!is.na(dof))
        {
          warning("Smoothness estimatmion based on 4D residual data is suboptimal and might be slow! Consider using FSL smoothest instead!")
          smooth=smoothest(residual, mask, dof = dof,  verbose = verbose)
        }
        else
        {
          warning("Residual but no dof specified: defaulting back to Z-score map-based smoothnes estimation")
          smooth=smoothest(img, mask, verbose = verbose)
        }
    }
    else
    {
      smooth=smoothest(img, mask, verbose = verbose)
    }
    V=smooth$volume
    Rd=smooth$dLh*V
  }

  logp.thres=seq(logpmin, logpmax, length.out=Nh)
  dh=logp.thres[2]-logp.thres[1]
  p.thres=exp(-logp.thres)
  threshs=stats::qnorm(p.thres, lower.tail = F)
  threshs[1]=-9999999999 # exp(-Inf):=0 #TODO: machine minimum
  ndh = length(threshs)
  CLUST=array(NA, dim=c(dim(img), length(threshs)))
  PVC=array(1, dim=c(dim(img), length(threshs)))

  if (verbose) cat("* Performing pTFCE...\n")
  if (verbose) pb <- utils::txtProgressBar(style = 3)
  for (hi in 1:length(threshs))
  {
    if (verbose) utils::setTxtProgressBar(pb, hi/length(threshs))
    h=threshs[hi]
    thr=img
    thr[img>h]=1
    thr[img<=h]=0
    ccc=mmand::components(thr, kernel = mmand::shapeKernel(3, dim = 3, type = "diamond"))
    t=table(ccc)
    sizes=t[ccc]
    sizes=sizes*as.numeric(mask)

    CLUST[,,,hi]=sizes

    for (size in sort(unique(sizes)) )
    {
      if (size==0)
        next;
      PVC[,,,hi][sizes==size]=pvox.clust(V, Rd, size, h, ZestThr=ZestThr)
    }
    # plot if you want
    # orthographic(nifti(CLUST[,,, hi], datatype=16) )
  }
  # calculate pTFCE
  pTFCE=array(apply(PVC, c(1,2,3), function(x){exp( -aggregate_logpvals(-log(x), dh) )}), dim=dim(img))

  # copy nifit header information
  snames = methods::slotNames(img)
  snames = snames[ !snames %in% c(".Data", "dim_") ]
  pTFCE = oro.nifti::nifti(img = pTFCE, dim = dim(pTFCE))
  #BUG: this does not work if input is an array instead of nifti image
  class(pTFCE) = class(img)
  oro.nifti::datatype(pTFCE) = 16 # FLOAT32
  oro.nifti::bitpix(pTFCE) = 32 # FLOAT32
  pTFCE=oro.nifti::zero_trans(pTFCE)
  for (islot in snames) {
    methods::slot(pTFCE, islot) = methods::slot(img, islot)
  }
  # done copying header

  pTFCE[pTFCE==0]=.Machine$double.xmin #underflow
  pTFCE[pTFCE==1]=1-.Machine$double.neg.eps #underflow
  if (verbose) close(pb)
  if (autosmooth)
  {
    number_of_resels=smooth$volume / smooth$resels
    fwer0.05.Z=fwe.p2z(number_of_resels, 0.05)
  }
  else
  {
    if (is.na(resels))
    {
      warning("For GRF-based FWER correction, please specify resels, or use smoothness estimation based on the data, by not specifying Rd and V!")
      number_of_resels=NA
      fwer0.05.Z=NA
    }
    else
    {
      number_of_resels=V / resels
      fwer0.05.Z=fwe.p2z(number_of_resels, 0.05)
    }

  }
  Z=stats::qnorm(pTFCE, lower.tail = F)
  oro.nifti::datatype(Z) = 16 # FLOAT32
  oro.nifti::bitpix(Z) = 32 # FLOAT32
  Z=oro.nifti::zero_trans(Z)
  return(list(p=pTFCE,
              logp=-log(pTFCE),
              Z=Z,
              number_of_resels=number_of_resels,
              fwer0.05.Z=fwer0.05.Z
              )
         )
}

# helper functions

#' Aggregate logpvals by the "equidistant incremental logarithmic probability aggregation".
#'
#' @param logpvals vector of enhnaced -logP values correspoinding tho various thresholds
#' @param d delta -logP (giving the equidistant distribution in the log-space)
#'
#' @return aggregated -logP probability
#' @export
aggregate_logpvals=function(logpvals, d) #
{
  logpvals[is.infinite(logpvals)]=745
  s=sum(logpvals)
  return( 0.5*(sqrt(d*(8*s+d))-d) )
}

#' expected value of cluster size at threshold h in img of size V with RESEL count Rd
#' mainly ported from the source code of FSL (https://fsl.fmrib.ox.ac.uk/fsl/fslwiki)
#'
#' @param h image height, that is, Z score threshold
#' @param V Number of voxels
#' @param Rd Rd (dLh*V)
#'
#' @return Expected value of cluster size
Es=function(h, V, Rd)
{
  h2=h*h
  ret=  ( log(V)+stats::pnorm(h, log.p = T, lower.tail = F) )
  h2=h2[h>=1.1]
  ret[h>=1.1] = ret[h>=1.1] - ( log(Rd)+log(h2-1)-h2/2+-2*log(2*pi) ) # from FSL

  return( exp(ret) )

}

dvox=function(h) # PDF of Z threshold/voxel value
{
  stats::dnorm(h )
}

pvox=function(h) # p-value for voxel value
{
  stats::pnorm(h, lower.tail = F)
}

dclust=function(h, V, Rd, c, ZestThr=1.3, CONST=10^40) # PDF of cluster extent, given h thershold
{
  if (is.na(c))
    return(dvox(h))
  dcl=function(h, V, Rd, c)
  {
    lambda=(Es(h, V, Rd)/gamma(2.5) )^(-2/3)
    dclust=lambda*exp(-lambda*c^(2/3))
    #dclust[dclust==0]=.Machine$double.xmin # underflow happened
    dclust[h<ZestThr]=0
    dclust
  }
  # patch: the normalising constant can be ignored here as the expression will be normalised again later
  # So we spare a costly numarical integration and get much faster!
  # Tests still pass, with a tolearnce
  #dcl(h, V, Rd, c)#/integrate(function(x){dcl(x, V, Rd, c)}, -Inf, Inf)$value

  #bugfix (GitHUb Issue #8)
  # we can multiply to avoid underflow in the integration in dvox.clust
  # it will be normalised anyway
  dcl(h, V, Rd, c)*CONST
}

dvox.clust=function(h, V, Rd, c, ZestThr=1.3) # PDF of Z threshold value given cluster size
{
  if (is.na(c))
    #return(rep(0, length(h)))
    return(dvox(h))
  if (is.nan(dclust(h, V, Rd, c)[1])) # underflow
    return(dvox(h)*dclust(h, V, Rd, c))

  dvox(h)*dclust(h, V, Rd, c, ZestThr)/stats::integrate(function(x){dvox(x)*dclust(x, V, Rd, c, ZestThr)}, -Inf, Inf)$value
}

pvox.clust=function(V, Rd, c, actH, ZestThr=1.3) # p-value for Z threshold value given cluster size
{
  if (actH<=ZestThr)  # ZestThr: GRF theory might not apply at low thresholds
    return(pvox(actH))

  if (is.nan(dvox.clust(actH, V, Rd, c, ZestThr=ZestThr)[1])) # underflow
    return(exp(-745)) #TODO: make machnie independent

  stats::integrate(function(x){dvox.clust(x, V, Rd, c, ZestThr=ZestThr)}, actH, Inf)$value
}

#' Estimate global image smoothness.
#'
#' Ported form the C++ implementation of FSL.
#'
#' For mathematical background, see:
#' https://www.fmrib.ox.ac.uk/datasets/techrep/tr00df1/tr00df1/index.html
#'
#' @param img Z-score image or a 4D residual image, ("nifti" class from
#'   "oro.nifti" package)
#' @param mask image mask ("nifti" class from "oro.nifti" package)
#' @param dof degrees of freedom, obligatory if img is a 4D residual image
#' @param verbose boolean: print progress bar and diagnostic messages if true
#'   (default)
#'
#' @return An object of class "smoothness" is a list containing at least the
#'   following components:
#'   \itemize{
#'   \item \strong{volume}   volume of the mask used for estimating smoothness, in voxels
#'
#'   \item \strong{sigmasq}  sigma squared values in the x, y and z directions
#'
#'   \item \strong{FWHM}     full width at half maximum values of smoothness in the x, y and z
#'   direction (voxels)
#'
#'   \item \strong{dLh}      determininant of Lambda to the half (voxels^-3)
#'
#'   \item \strong{resels}   resel size (voxels per resel) }
#' @export
#'
#' @details The function takes two images (both "nifti" object of the oro.nifti
#'   package): (i) either a Z-score image or a 4D residual image together with
#'   the degrees of freedom, and (ii) a mask image as obligatory inputs. Mask
#'   can be either binary or continous, in the latter case it will be
#'   thresholded at 0.5.
#'
#'   For a Gaussian random field the smoothness is defined as  \deqn{W
#'   =|\Lambda|^{-1/2D} } where D is the dimensionality of the field and
#'   \eqn{\Lambda} the covariance matrix of it's first partial derivatives.
#'
#'   Using Z-score image is less optimal because:
#' \itemize{
#' \item Smoothness estimates need spatial derivatives, which are very noisy
#'   quantities and, for a single 3D map, can be computed just once on each
#'   direction.
#' \item The z-map may contain effects, and these affect smoothness.
#' }
smoothest=function(img, mask, dof=NA, verbose=T)
{
  if (verbose) cat("* Estimating smoothness based on the data...\n")
  if (verbose) pb <- utils::txtProgressBar(style = 3)

  stand = standardise(mask, img);
  mask_volume=stand$count
  mask=stand$mask
  img=stand$R
  N=0

  usez=T
  if (dim(img)[3] <= 1)
  {
    usez = F;
    warning("using 2d image mode, but it is not tested yet")
  }

  # Estimate the smoothness of the normalised residual field
  # see TR00DF1 for mathematical description of the algorithm.
  X = 1
  Y = 2
  Z = 3
  SSminus = c(0, 0, 0)
  S2 = c(0, 0, 0)

  # adjust zstart for 2d mode
  zstart=2
  if (!usez) zstart=1
  for (z in 2:dim(img)[3])
  {
    if (verbose) utils::setTxtProgressBar(pb, z/dim(img)[3])
    for (y in 2:dim(img)[2])
    {
      for (x in 2:dim(img)[1])
      {
        # Sum over N
        if( (mask[x, y, z]>0.5) &&
            (mask[x-1, y, z]>0.5) &&
            (mask[x, y-1, z]>0.5) &&
            ( (!usez) || (mask[x, y, z-1]>0.5) ) )
        {
          N=N+1

          if (!is.na(dim(img)[4])) # using res4D
          {
            for ( t in 1:dim(img)[4])
            {
              # Sum over M
              SSminus[X] =  SSminus[X] + img[x, y, z, t] * img[x-1, y, z, t]
              SSminus[Y] = SSminus[Y] + img[x, y, z, t] * img[x, y-1, z, t]
              if (usez) SSminus[Z] = SSminus[Z] + img[x, y, z, t] * img[x, y, z-1, t]

              S2[X] = S2[X] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x-1, y, z, t]*img[x-1, y, z, t])
              S2[Y] = S2[Y] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x, y-1, z, t]*img[x, y-1, z, t])
              if (usez) S2[Z] = S2[Z] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x, y, z-1, t]*img[x, y, z-1, t])
            }
          }
          else # using Z-score map
          {
            SSminus[X] =  SSminus[X] + img[x, y, z] * img[x-1, y, z]
            SSminus[Y] = SSminus[Y] + img[x, y, z] * img[x, y-1, z]
            if (usez) SSminus[Z] = SSminus[Z] + img[x, y, z] * img[x, y, z-1]

            S2[X] = S2[X] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x-1, y, z]*img[x-1, y, z])
            S2[Y] = S2[Y] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x, y-1, z]*img[x, y-1, z])
            if (usez) S2[Z] = S2[Z] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x, y, z-1]*img[x, y, z-1])

          }
        } # endif mask
      } #endz
    } #endy
  } #endx
  norm = 1.0/N
  v = dof # v - degrees of freedom (nu)
  if (!is.na(dim(img)[4])) # using res4D
  {
    print(paste("Non-edge voxels = ", N))
    print(paste("(v - 2)/(v - 1) = ", (v - 2)/(v - 1)))

    norm = (v - 2) / ((v - 1) * N * dim(img)[4]);
  }
  #print(paste("SSminus[X]", SSminus[X], "SSminus[Y]", SSminus[Y],"SSminus[Z]", SSminus[Z],"S2[X]", S2[X],"S2[Y]", S2[Y],"S2[Z]", S2[Z]))

  # for extreme smoothness
  if (SSminus[X]>=0.99999999*S2[X])
  {
    SSminus[X]=0.99999*S2[X]
    warning("Extreme smoothness detected in X - possibly biased global estimate.")
  }
  if (SSminus[Y]>=0.99999999*S2[Y])
  {
    SSminus[Y]=0.99999*S2[Y]
    warning("Extreme smoothness detected in Y - possibly biased global estimate.")
  }
  if (usez)
  {
    if (SSminus[Z]>=0.99999999*S2[Z])
    {
      SSminus[Z]=0.99999*S2[Z]
      warning("Extreme smoothness detected in Z - possibly biased global estimate.")
    }
  }

  # Convert to sigma squared
  sigmasq=rep(NA,3);

  sigmasq[X] = -1.0 / (4 * log(abs(SSminus[X]/S2[X])))
  sigmasq[Y] = -1.0 / (4 * log(abs(SSminus[Y]/S2[Y])))
  if (usez)
  {
    sigmasq[Z] = -1.0 / (4 * log(abs(SSminus[Z]/S2[Z])))
  }
  else
  {
    sigmasq[Z]=0
  }
  names(sigmasq)=c("x", "y", "z")

  # the following is determininant of Lambda to the half
  # i.e. dLh = | Lambda |^(1/2)
  # Furthermore, W_i = 1/(2.lambda_i) = sigma_i^2 =>
  #   det(Lambda) = det( lambda_i ) = det ( (2 W_i)^-1 ) = (2^D det(W))^-1
  #   where D = number of dimensions (2 or 3)
  if (usez)
  {
    dLh=((sigmasq[X]*sigmasq[Y]*sigmasq[Z])^-0.5)*(8^-0.5)
  }
  else
  {
    dLh=((sigmasq[X]*sigmasq[Y])^-0.5)*(4^-0.5)
  }
  #correcting for temporal DOF!!!!!
  if(!is.na(dim(img)[4]))
    dLh = dLh * interpolate(v);

  # Convert to full width half maximum
  FWHM=rep(NA,3)
  FWHM[X] = sqrt(8 * log(2) * sigmasq[X])
  FWHM[Y] = sqrt(8 * log(2) * sigmasq[Y])
  if (usez)
  {
    FWHM[Z] = sqrt(8 * log(2) * sigmasq[Z])
  }
  else
  {
    FWHM[Z]=0
  }
  names(FWHM)=c("x", "y", "z")

  resels = FWHM[X] * FWHM[Y]
  if (usez)
    resels = resels * FWHM[Z]

  if (verbose) close(pb)

  return(list(volume=mask_volume,
              sigmasq=sigmasq,
              FWHM=FWHM,
              dLh=dLh,
              resels=resels))
}

standardise=function(mask, R)
{
  M=dim(R)[4]
  if( !is.na(M) )
  {
    # For each voxel
    #    standardise data in 4th direction
    R=aperm(apply(R, c(1,2,3), scale), c(2,3,4,1))
    R[is.na(R)]=0
    std=apply(R, c(1,2,3), stats::sd)
    mask[std<=0]=0 #TODO_ready: updtae mask if it differs from the actual data

  }#endif 4d
  mask[is.na(mask)]=0

  count=sum(mask[mask>0.5])

  return(list(count=count, mask=mask, R=R))
}

interpolate=function(v)
{
  lut=rep(NA,500)
    lut[5]   = 1.5423138; lut[6]   = 1.3757105; lut[7]   = 1.2842680;
    lut[8]   = 1.2272151; lut[9]   = 1.1885232; lut[10]  = 1.1606988;
    lut[11]  = 1.1398000; lut[12]  = 1.1235677; lut[13]  = 1.1106196;
    lut[14]  = 1.1000651; lut[15]  = 1.0913060; lut[16]  = 1.0839261;
    lut[17]  = 1.0776276; lut[18]  = 1.0721920; lut[19]  = 1.0674553;
    lut[20]  = 1.0632924; lut[25]  = 1.0483053; lut[30]  = 1.0390117;
    lut[40]  = 1.0281339; lut[50]  = 1.0219834; lut[60]  = 1.0180339;
    lut[70]  = 1.0152850; lut[80]  = 1.0132621; lut[90]  = 1.0117115;
    lut[100] = 1.0104851; lut[150] = 1.0068808; lut[200] = 1.0051200;
    lut[300] = 1.0033865; lut[500] = 1.0020191;

  if (v<6) return(1.1) # ?? no idea - steve ??

  if (v>500)
  {
    retval=1.0321/v + 1
  }
  else
  {
    lut.low=lut[1:floor(v)]
    lut.high=lut[ceiling(v):length(lut)]

    j.first=which(lut==min(lut.low, na.rm = T))
    j.second=lut[j.first]

    i.first=which(lut==max(lut.high, na.rm = T))
    i.second=lut[i.first]

    retval = (j.second - i.second)/(j.first - i.first)*(v - i.first) + j.second
  }
  return(retval^0.5)

}

#' Convert Z-score value to FWER corrected p-value
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param resel_count resel count
#' @param Z z-score value
#'
#' @details The Z-score value is converted to to p-value, corrected for multiple comparisons by controlling for famili-wise error rate
#' The parameter resel_count is the number of resels (resolution elements) in the image, and can be obtained e.g by smoothest() (see examples).
#'
#' @return FWER-corrected p-value
#'
#' @export
#'
#' @examples
#' \dontrun{
#' s=smoothest(zmap, mask)
#' fwe.z2p(resel_count=s$volume/s$resels, Z=2.3)
#'
#' pTFCE=ptfe(zmap, mask)
#' fwe.z2p(pTFCE$number_of_resels, Z=3.1)
#' }
fwe.z2p=function(resel_count, Z)
{
  # based on FSL
  #the probability of a family wise error is approximately equiv- alent to the expected Euler Characteristic
  if (Z<2)
    p=1 # Below z of 2 E(EC) becomes non-monotonic
  else
    p = resel_count * 0.11694 * exp(-0.5*Z*Z)*(Z*Z-1)  #/* 0.11694 = (4ln2)^1.5 / (2pi)^2 */
  return(min(p,1.0))
}

#' Get Z-score threshold for an FWER corrected p-value
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param resel_count resel count
#' @param FWEP FWER corrected p-value
#'
#' @details The p-value, corrected for multiple comparisons by controlling for family-wise error rate, is converted to a Z-score threshold.
#' The parameter resel_count is the number of resels (resolution elements) in the image, and can be obtained e.g by smoothest() (see examples).
#'
#' @return Z-score threshold
#'
#' @export
#'
#' @examples
#' \dontrun{
#' s=smoothest(zmap, mask)
#' fwe.p2z(resel_count=s$volume/s$resels, FWEP=0.05)
#'
#' pTFCE=ptfe(zmap, mask)
#' fwe.p2z(pTFCE$number_of_resels, FWEP=0.05)
#' }
fwe.p2z=function(resel_count, FWEP=0.05)
{
  # based on FSL ptoz implementation
  p=FWEP/(resel_count*0.11694) #/* (4ln2)^1.5 / (2pi)^2 */

  #if (p<MINP) p=MINP;

  if (p>0.5)
    return(0)
  else
  {
      l=2
      u=100
      z=0
      while (u-l>0.001)
      {
        z=(u+l)/2
        pp=exp(-0.5*z*z)*(z*z-1)
        if (pp<p)
          u=z
        else
          l=z
      }

  }
  return(z)
}


# Classify using elastic net regression
library(glmnet)
library(doParallel)

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
registerDoParallel(cores=10)
source("pixel-based/utils/subpixel-confusion-matrix.r") # Replace with package eventually
source("utils/accuracy-statistics.r")

Data.df.orig = LoadTrainingAndCovariates()
Data.df.orig = st_set_geometry(Data.df.orig, NULL)
# Manually rescale
Data.df = Data.df.orig
#Data.df = RescaleBasedOn(Data.df.orig, Data.df.orig, GetAllPixelCovars())
#Data.df = NAToMean(Data.df, GetAllPixelCovars())
#Data.df[is.na(Data.df)] = -9999
Data.df[is.na(Data.df)] = 0
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val = RescaleBasedOn(Data.val, Data.df.orig, GetAllPixelCovars())
#Data.val = NAToMean(Data.val, GetAllPixelCovars())
#Data.val[is.na(Data.val)] = -9999
Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

AllCovars = GetAllPixelCovars()
Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

TargetMatrix = as.matrix(Data.df[,Classes])/100
CovarMatrix = as.matrix(Data.df[,AllCovars])

singlelasso = glmnet(CovarMatrix, TargetMatrix, family="mgaussian")
plot(singlelasso, label=TRUE, xvar="dev")
which(coef(singlelasso)$tree[,90] != 0) # Remaining covars
GetAllPixelCovars()[!(GetAllPixelCovars() %in% names(which(coef(singlelasso)$tree[,90] != 0)))] # Discarded covars
which(coef(singlelasso)$water[,50] != 0) # Remaining covars
GetAllPixelCovars()[!(GetAllPixelCovars() %in% names(which(coef(singlelasso)$water[,50] != 0)))] # Discarded covars
Predictions = predict(singlelasso, as.matrix(Data.val[,GetAllPixelCovars()]), type="response")
PredictionsClipped = Predictions
PredictionsClipped[PredictionsClipped < 0] = 0
PredictionsScaledA = apply(PredictionsClipped, 3, ScalePredictions, LeaveZeroes=FALSE)
PredictionsClipped[PredictionsClipped > 1] = 1
PredictionsScaledB = apply(PredictionsClipped, 3, ScalePredictions, LeaveZeroes=FALSE)
# There is almost no difference between A and B, A is just slightly better
AccChange = do.call(rbind, lapply(PredictionsScaledA, function(mat){AccuracyStats(mat[,Classes], Truth[,Classes])}))
plot(AccChange$RMSE, type="l")
plot(AccChange$MAE, type="l")
plot(AccChange$ME, type="l")
which.min(AccChange$RMSE) # 72
which.min(AccChange$MAE) # 90
# At 57 it seems nothing is dropped, coefficients are just shrunk
# What did we drop at 48?
for (i in 1:length(coef(singlelasso)))
    print(which(coef(singlelasso)[[i]][,48] == 0))
# jul.srad and mean.srad
# 90 is just OLS
# Let's try 72 (lambda=0.000401)
write.csv(PredictionsScaledA[[72]][,Classes], "../data/pixel-based/predictions/lasso-lambda0000401.csv", row.names=FALSE)
AccuracyStatisticsPlots(PredictionsScaledA[[72]][,Classes], Truth) # 21.4% RMSE, 12.6 MAE
SCM(PredictionsScaledA[[72]][,Classes]/100, Truth/100, plot=TRUE, totals=TRUE) # OA 56±0.04 kappa 0.43±0.05
NSE(unlist(PredictionsScaledA[[72]][,Classes])/100, unlist(Truth[,Classes]/100)) # 0.49

lambdas = cv.glmnet(CovarMatrix, TargetMatrix, family="mgaussian", parallel=TRUE)
lambdas[["lambda.min"]]
bestlambda = lambdas[["lambda.1se"]]
coef(lambdas, s=bestlambda) # Dropped roughness, mean.ndvi and intercept
lasso_prob <- predict(lambdas, newx = as.matrix(Data.val[,GetAllPixelCovars()]), s=bestlambda,type="response")
Predictions = as.data.frame(lasso_prob[,,1])*100
write.csv(Predictions, "../data/pixel-based/predictions/lasso-1se-9999.csv")
Predictions[Predictions < 0] = 0 # Remove negative vals
Predictions[Predictions > 100] = 100# Cap ones over 100
Predictions = ScalePredictions(Predictions, FALSE)

AccuracyStatisticsPlots(Predictions, Truth) # 22.3% RMSE, 13.4 MAE
SCM(Predictions/100, Truth/100, plot=TRUE, totals=TRUE) # OA 53±0.04 kappa 0.40±0.05
NSE(unlist(Predictions)/100, unlist(Truth[,Classes]/100)) # 0.45
PlotHex(Predictions, Truth[,Classes], "Lasso regression, lambda at 1se")
PlotBox(Predictions, Truth[,Classes], main="Lasso regression, lambda at 1se", binpredicted=TRUE)

# What if we use min (82 covars vs 71)
lasso_prob <- predict(lambdas, newx = as.matrix(Data.val[,GetAllPixelCovars()]), s=lambdas[["lambda.min"]],type="response")
Predictions = as.data.frame(lasso_prob[,,1])*100
write.csv(Predictions, "../data/pixel-based/predictions/lasso-min-9999.csv")
Predictions[Predictions < 0] = 0 # Remove negative vals
Predictions[Predictions > 100] = 100# Cap ones over 100
Predictions = ScalePredictions(Predictions, FALSE)

AccuracyStatisticsPlots(Predictions, Truth) # 22.1% RMSE, 13.3 MAE, tiny amount better
SCM(Predictions/100, Truth/100, plot=TRUE, totals=TRUE) # OA 54±0.04 kappa 0.40±0.05
NSE(unlist(Predictions)/100, unlist(Truth[,Classes]/100)) # 0.45
PlotHex(Predictions, Truth[,Classes], "Lasso regression, lambda at min")
PlotBox(Predictions, Truth[,Classes], main="Lasso regression, lambda at min", binpredicted=TRUE)

# If we scale the data

CovarMatrix = as.matrix(apply(Data.df[,GetAllPixelCovars()], 2, scale))

lambdas = cv.glmnet(CovarMatrix, TargetMatrix, family="mgaussian", parallel=TRUE)
lambdas[["lambda.min"]]
bestlambda = lambdas[["lambda.1se"]]
coef(lambdas, s=bestlambda) # Dropped roughness, mean.ndvi and intercept
lasso_prob <- predict(lambdas, newx = CovarMatrix, s=bestlambda,type="response")

AccuracyStatisticsPlots(as.data.frame(lasso_prob[,,1]), as.data.frame(TargetMatrix)) # 18.5% RMSE


data<-read.csv("forestfires.csv")
library(ggplot2)

coord2<-data[,c(1,2,13)]
coord2$area<-log(coord2$area+1)
coord2$Y<-10-coord2$Y

ggplot(coord2, aes(x = X, y = Y, fill = area)) +
  geom_tile() +
  scale_fill_gradient(low = "yellow", high = "red")


# Master Thesis Project - Extreme Value Theory
# Plotting a sample of the Brownian Motions
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("./generalBM.r")

# Let the user enter the time horizon of the brownian motion
cat("Time increment ?")
h <- as.numeric(readline("h :\n"))

cat("Mean ?")
mu <- as.numeric(readline("mu :\n"))

cat("Standard deviation ?")
sigma <- as.numeric(readline("sigma :\n"))

# Generating the Brownian Motion
BM_vect <- generalBM(mu,sigma,h)

# Plot the Brownian Motion
quartz()

plot(BM_vect, type ='l')
abline(h = 0, col = "red")

# Some Data on the sum of the B(ti)
cat("Mean of sum :\n")
print(mean(BM_vect))
cat("\nVariance of sum :\n")
print(var(BM_vect))

# Now checking the increments respect a few properties of BM
cat("\nTime horizon T =\n")
print(ceiling(1/h))
cat("\nSelect two times a and b, 0 < a < b <=T\n")
a <- as.numeric(readline("Your a :\n"))
b <- as.numeric(readline("Your b :\n"))
cat("\na :\n")
print(a)
cat("\nb\n")
print(b)

Nbtries <- 1000
incr <- rep(0,Nbtries)

for (i in 1:Nbtries) {

	# Loop to gather data for a histogram
	# recovering B(a) and B(b)
	vect <- generalBM(mu,sigma,1/b)
	incr[i] <- vect[b] - vect[a]

}

hist(incr, main = "Density plot", freq = FALSE, col = "lightgreen")
curve(dnorm(x, mean = mean(incr), sd = sd(incr)), add = TRUE, col = "darkblue", lwd = 4)
curve(dnorm(x, mean = mu, sd = sigma*sqrt(b-a)), add = TRUE, col = "red", lwd = 4)

print(mean(incr))
print(sd(incr))


hamming=function(hamms,limit) {
  tmp=hamms
  for(h in c(2,3,5)) {
    tmp=c(tmp,h*hamms)
  }
  tmp=unique(tmp[tmp<=limit])
  if(length(tmp)>length(hamms)) {
    hamms=hamming(tmp,limit)
  }
  hamms
}
h <- sort(hamming(1,limit=2^31-1))
print(h[1:20])
print(h[length(h)])


#use cars dataset construct scatterplot use base function, use lab arguent of plot function where thick marks o f X & Y axis
#specifies integer. Use cex.axis to control size of numbers associated with axis. change the orientation of labels
#from vertical to horizontal

data = data.frame(cars)
par(mfrow=c(2,2))
plot(data,cex.lab = 1.5,cex= 1.9, col.lab=2.5, col = "dark blue")

#using points() function add new observation to the last plot using red color.
#the values are speed = 23,26 and dist=60,61
points(c(23,26),c(60,61),cex= 3.0, col = "dark red")

#TO create more than 1 plot in the same layout use functions par and mfrow
#create 2 histograms representing each column of cars dataset
hist(data$speed,data$dist,xlim=c(0,50), breaks = 5)

#use layout function to print 3 plots on lef side scatter plot of cars, on top right histogram of speed
#on on bottom right of column distance

disp=layout(matrix(c(1,2,3,0),2,2),TRUE)
plot(data,cex.lab = 1.5,cex= 1.9, col.lab=2.5, col = "dark blue")
hist(data$speed,data$dist,xlim=c(0,50), breaks = 5)
hist(data$dist,data$speed,xlim=c(0,50), breaks = 5)

#use lattice package and given datsaet. construct barchart of goals done (use var = gd)
#grouping by team
library(lattice)
data = data.frame(read.csv("sampledataset.csv",sep=";"))

barchart(data$win~data$gd|data$team, groups = data$team, horiz=FALSE)

#constrct histrogram use win attr. ovew gs attr. on home and group by team
histogram(data$win~data$team, groups =  data$team)

#plot timeseries graph using xyplot.ts()

xyplot.ts(data$gd, groupby = data$team)

library(plotly)

Animals <- c("giraffes", "orangutans", "monkeys")
SF_Zoo <- c(20, 14, 23)
LA_Zoo <- c(12, 18, 29)
data <- data.frame(Animals, SF_Zoo, LA_Zoo)

p <- plot_ly(data, x = ~Animals, y = ~SF_Zoo, type = 'bar', name = 'SF Zoo') %>%
  add_trace(y = ~LA_Zoo, name = 'LA Zoo') %>%
  layout(yaxis = list(title = 'Count'), barmode = 'group')

p


# system of ODEs

d_rho_pm <- function(rho, parms, z = 4) {
  with(parms,
       d * (rho[4] - rho[1] - rho[2]) +
         (rho[5] - rho[3] - rho[1]) *
         (delta*rho[4] + (z-1)/z * (1 - delta) *
            (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b - c*rho[4]) -
         rho[1]*( r + f/z + (z-1)/z * f * rho[1]/rho[5] + m)
  )
}
d_rho_pp <- function(rho, parms, z = 4) {
  with(parms,
       2 * (rho[4] - rho[1] - rho[2]) *
         (delta*rho[4] + (1-delta)/z +(z-1)/z * (1 - delta) *
            (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b - c*rho[4]) - 2*rho[2]*m
  )
}
d_rho_mm <- function(rho, parms, z = 4) {
  with(parms,
       2 * (rho[5] - rho[3] - rho[1]) -
         2*rho[3]*(r+(z-1)/z*f*rho[1]/rho[5])
  )
}
d_rho_p <- function(rho, parms, z = 4) {
  with(parms,
       (delta*rho[4] + (1 - delta) *
          (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b-c*rho[4])*(1-rho[4]-rho[5])-m*rho[4]
  )
}

d_rho_m <- function(rho, parms, z = 4) {
  with(parms,
       d*(1-rho[4]-rho[5])-(r+f*rho[1]/rho[5])*rho[5]
  )
}

odesys <- function (t, rho, parms = model_parms) {
  list(c(
    d_rho_pm(rho, parms),
    d_rho_pp(rho, parms),
    d_rho_mm(rho, parms),
    d_rho_p(rho, parms),
    d_rho_m(rho, parms)
  ))
}


#  James Rekow

library(ggplot2)
source("elbowSSRatioTest.r")

SSRatio1 = elbowSSTest(M = 40, N = 20, numSubgroups = 7, lambda = 100, univ = 1)
SSRatio2 = elbowSSTest(M = 40, N = 20, numSubgroups = 7, lambda = 30, univ = 1)
SSRatio3 = elbowSSTest(M = 40, N = 20, numSubgroups = 7, lambda = 0, univ = 1)

SSRatio = c(SSRatio1, SSRatio2, SSRatio3)

len = length(SSRatio1)
clarity1 = rep("good", len)
clarity2 = rep("ok", len)
clarity3 = rep("bad", len)

clarity = as.factor(c(clarity1, clarity2, clarity3))

numCenters = rep(1:10, 3)

SSRatioDF = data.frame(numCenters = numCenters, SSRatio = SSRatio, clarity = clarity)

p = ggplot(SSRatioDF, aes(x = numCenters, y = SSRatio, col = clarity)) +
      geom_point() +
      geom_line() +
      scale_x_discrete(limits = as.character(1:10)) +
      ggtitle("Identifying Elbows in Plots of SSRatio VS. Number of Centers",
              subtitle = "M = 40, N = 20, univ = 1, lambda = 0 (bad), 20 (ok), 100 (good)")

dev.new()
plot(p)


vect = setRefClass("vect",
                    fields = list(
                      comp = 'numeric',
                      len = 'numeric',
                      unit = 'numeric'
                    ),
                    methods = list(
                    initialize = function(a, b = NA){
                      validateInput(a)
                      if(length(b) == 1 & anyNA(b)){
                        comp <<- a
                      }
                      else{
                        validateInput(b)
                        validateLength(a, b)

                        comp <<- b - a
                      }
                      len <<- vectLength(comp)
                      unit <<- vectUnit(comp, len)
                    },
                    vectInverse = function(){
                      return(vect(-comp))
                    },
                    vectResize = function(a){
                      comp <<- unit * a
                      len <<- a
                    },
                    vectUnit = function(a, l){
                      return(a/l)
                    },
                    vectLength = function(v){
                      return(sqrt(sum(v^2)))
                    },
                    validateInput = function(a){
                      if(anyNA(a)){
                        stop("Input contains NA values")
                      }
                      if(any(is.nan(a))){
                        stop("Input contains NaN")
                      }
                      if(any(is.infinite(a))){
                        stop("Input contains Inf values")
                      }
                      if(!is.numeric(a)){
                        stop("Input is not numeric")
                      }
                    },
                    validateLength = function(a, b){
                      if(length(a) != length(b)){
                        stop("Input points don't have the same length")
                      }
                    }
                  ))

'%v+%' = function(a, b){
  return(vect(a$comp + b$comp))
}
'%v-%' = function(a, b){
  return(vect(a$comp - b$comp))
}
'%v*%' = function(a, b){
  return(vect(a$comp * b))
}
'%v/%' = function(a, b){
  return(vect(a$comp / b))
}


## In this file, we will use the data(stock.csv) to plot the histograms

## 1. Process Data
data.frompast <- read.csv(file='stock.csv', header=TRUE, sep=",")
summary(data.frompast)

## reoder the data, make it from past to now
data <- data[c(nrow(data.frompast):1),]
summary(data)

data.date.start <- toString(data$date[1])
data.date.start.year <- as.numeric(strsplit(data.date.start, "-")[[1]][1])
data.date.start.month <- as.numeric(strsplit(data.date.start, "-")[[1]][2])
data.date.start.day <- as.numeric(strsplit(data.date.start, "-")[[1]][3])

## 2. Plot graphs
par(mfrow = c(2, 2))

## 2.1 trend of closing price

## Why we do not use ts?
## Because the data is daily recorded.
##closeprice.ts <- ts(data$closePrice,frequency = 365, start=c(data.date.start.year, data.date.start.month))

plot(x=as.Date(data$date), y=data$closePrice, type="l", xlab="date", ylab="closing price", main="Trend of closing price")

## 2.2 histogram of closing price
hist(x=data$closePrice, xlab="closing price", breaks=nrow(data)/50, main="histogram of closing price(step=50)")

## 2.3 histogram of change amount
hist(x=as.numeric(as.character(data$changeAmount)), xlab="change amount", breaks=nrow(data)/20, main="histogram of change amount(step=20)")
hist(x=as.numeric(as.character(data$changeAmount)), xlab="change amount", breaks=nrow(data)/100, main="histogram of change amount(step=100)")


\name{test_linear_PA}
\alias{test_linear_PA}
\title{
 Fitting various distributions to a degree vector
}
\description{
This function implements the method in Handcock and Jones (2004) to fit various distributions to a degree vector. The implemented distributions are Yule, Waring, Poisson, geometric and negative binomial. The Yule and Waring distributions correspond to a preferential attachment situation. In particular, the two distributions correspond to the case of \eqn{A_k = k} for \eqn{k \ge 1} and \eqn{\eta_i = 1} for all \eqn{i} (note that, the number of new edges and new nodes at each time-step are implicitly assumed to be \eqn{1}).

Thus, if the best fitted distribution, which is chosen by either the Akaike Information Criterion (AIC) or the Bayesian Information Criterion (BIC), is NOT Yule or Waring, then the case of \eqn{A_k = k} for \eqn{k \ge 1} and  \eqn{\eta_i = 1} for all \eqn{i}  is NOT consistent with the observed degree vector.

The method allows the low-tail probabilities to NOT follow the parametric distribution, i.e., \eqn{P(K = k) = \pi_k} for all \eqn{k \le k_min} and \eqn{P(K = k) = f(k,\theta)} for all \eqn{k > k_min}. Here \eqn{k_min} is the degree threshold above which the parametric distribution holds, \eqn{\pi_k} are probabilities of the low-tail, \eqn{f(.,\theta)} is the parametric distribution with parameter vector \eqn{\theta}.

For fixed \eqn{k_min} and \eqn{f}, \eqn{\pi_k} and \eqn{\theta} can be estimated by Maximum Likelihood Estimation. We can choose the best \eqn{k_min} for each \eqn{f} by comparing the AIC (or BIC). More details can be founded in Handcock and Jones (2004).
}
\usage{
 test_linear_PA(degree_vector)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{degree_vector}{
    a degree vector
  }
}
\value{
  Outputs a \code{Linear_PA_test_result} object which contains the fitting of five distributions to the degree vector: Yule (\code{yule}), Waring (\code{waring}), Poisson (\code{pois}), geometric (\code{geom}) and negative binomial (\code{nb}). In particular, for each distribution, the AIC and BIC are calcualted for each \eqn{k_min}.
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Handcock MS, Jones JH (2004). “Likelihood-based inference for stochastic models of sexual network formation.” Theoretical Population Biology, 65(4), 413 – 422. ISSN 0040-5809. \url{https://doi.org/10.1016/j.tpb.2003.09.006}. Demography in the 21st Century, \url{http://www.sciencedirect.com/science/article/pii/S0040580904000310}.
}
\examples{
\dontrun{
  library("PAFit")
  set.seed(1)
  net   <- generate_BA(n = 1000)
  stats <- get_statistics(net, only_PA = TRUE)
  u     <- test_linear_PA(stats$final_deg)
  print(u)
}
}

\concept{linear preferential attachment}
\concept{fitting degree distributions}


simpleMultipleReg <- function(formula) {

    ## parse and evaluate the model formula
    mf <- model.frame(formula)

    ## create design matrix
    X <- model.matrix(attr(mf, "terms"), mf)

    ## create dependent variable
    Y <- model.response(mf)

    ## solve
    solve(t(X) %*% X) %*% t(X) %*% Y
}

simpleMultipleReg(y ~ x + I(x^2))


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

# 4. faza: Analiza podatkov

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

star_skup_60_64 <- starostne_skupine %>%  filter(starostne_skupine == "60-64 let")

g63 <- ggplot(star_skup_60_64) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  geom_smooth(method = "gam", se = FALSE)

mgam1 <- gam(stevilo ~ leto ,
             data = star_skup_60_64)
leta1 <- data.frame(leto = seq(2021,2026))
napoved <- leta1 %>% mutate(stevilo = predict(mgam1, .))

tabela.napoved <- bind_rows(star_skup_60_64, napoved) %>% select(-starost)
tabela.napoved1 <- tabela.napoved[c(17:22),]

graf_napoved_60_64 <- ggplot(tabela.napoved,
                          aes(x = leto, y = stevilo)) +
  geom_point() +
  scale_x_continuous(name = "leto", breaks = seq(2005,2026,1)) +
  ylab("število delovno aktivnih") +
  ggtitle("Napoved števila delovno aktivnih v starostni skupini od 60 do 64 do leta 2026") +
  geom_smooth(method = 'gam', formula = y ~ x, se = FALSE, color="darkgoldenrod1") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1))

novi_podatki <- data.frame(leto = seq(2021, 2026))
napoved <- novi_podatki %>% mutate(stevilo=predict(mgam1, .))

graf_napoved_60_64 <- graf_napoved_60_64 +
  geom_point(data=tabela.napoved1,
             aes(x=leto, y=stevilo),
             color="red")

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

star_skup_25_29 <- starostne_skupine %>%  filter(starostne_skupine == "25-29 let")

g638 <- ggplot(star_skup_25_29) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  geom_smooth(method = "gam", se = FALSE)

mgam2 <- gam(stevilo ~ leto ,
             data = star_skup_25_29)
napoved <- leta1 %>% mutate(stevilo = predict(mgam2, .))

tabela.napoved2 <- bind_rows(star_skup_25_29, napoved) %>% select(-starost)
tabela.napoved3 <- tabela.napoved2[c(17:22),]

graf_napoved_25_29 <- ggplot(tabela.napoved2) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  scale_x_continuous(name = "leto", breaks = seq(2005,2026,1)) +
  ylab("število delovno aktivnih") +
  ggtitle("Napoved števila delovno aktivnih v starostni skupini od 25 do 29 let do leta 2026") +
  geom_smooth(method = 'gam', formula = y ~ x, se = FALSE, color="aquamarine2") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1)) +
  expand_limits(y=0)

novi_podatki2 <- data.frame(leto = seq(2021, 2026))
napoved2 <- novi_podatki2 %>% mutate(stevilo=predict(mgam2, .))

graf_napoved_25_29 <- graf_napoved_25_29 +
  geom_point(data=tabela.napoved3,
             aes(x=leto, y=stevilo),
             color="red")


state_prob <- c(7,5,3,2,1.2,0.5,0.3,0.4)
risk_grade_prob <- 0.5*(1/2)^(0:19)
N = 2e6

gen_lvr <- function(N) {
  x = -rgamma(N,9,0.5)
  x = x - min(x)
  x = x/max(x)
  pmax(0.01, x)
}

gen_datatable_synthetic2 <- function(N=2e6, mk = 201711) {
  dt = data.table(
    month = rep(mk,N),
    account_id = sprintf("id%010d",1:N), # id
    curr_bal =  rgamma(N,2,0.5)*125000, # numeric e.g. 23.5749
    curr_lvr = gen_lvr(N),
    int_rate = rep(0.05, N),
    risk_grade = sample(1:20, N, replace = T, prob = risk_grade_prob),
    state = sample(c("NSW","VIC","QLD","WA","SA","TAS","NT","ACT"), N, replace = T, prob = state_prob/sum(state_prob)),
    default = sample(0:1, N, replace = T, prob = c(0.97, 0.03))
  )[,risk_grade_pd := c(0.0001*(1.575)^(1:20))[risk_grade]][, value := curr_bal/curr_lvr]
  fst::write_fst(dt, sprintf("synthetic_data/%d.fst", mk), compress=100)
}


#' Compute principal components of a methylation matrix.
#'
#' @param  normalized.beta Output from \code{meffil.normalize.samples}
#' @param  probe.range Default = 5000. How many probes to be used in calculating PCs
#' @param  autosomal Default = TRUE. If true, remove probes on sex chromosomes.
#' @param  verbose=T Print progress messages?
#' @return the principal components of \code{normalized.beta}.
#'
#' @export
meffil.methylation.pcs <- function(normalized.beta,
                                   probe.range=5000, autosomal=T, verbose=F) {
    if (autosomal) {
        featureset <- guess.featureset(rownames(normalized.beta))
        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        autosomal.sites <- intersect(autosomal.sites, rownames(normalized.beta))
        normalized.beta <- normalized.beta[autosomal.sites,]
    }

    msg("Calculating variances", verbose=verbose)

    var.sites <- meffil.most.variable.cpgs(normalized.beta, n=probe.range)
    var.idx <- match(var.sites, rownames(normalized.beta))

    msg("Calculating beta PCs", verbose=verbose)
    prcomp(t(meffil:::impute.matrix(normalized.beta[var.idx,], margin=1)))$x
}


designBasedCont = function(gamma, outcome_vec, pcf_cat_vec, instid_vec){
	#' Compute Design Based Draper-Gittoes Z-Scores
	#'
	#'	\code{designBased} implements design based approach and
	#' computes O, E, and z vectors following Draper-Gittoes (2004)
	#'
	#' @param gamma Parameter in [0,1] controling pooling.
	#' Gamma = 1 is complete global pooling, gamma = 0 is complete local pooling.
	#' @param outcome_vec Vector with elements in {0,1} denoting the binary outcome.
	#' @param pcf_cat_vec Vector with unique values for each PCF category.
	#' @param instid_vec Vector with unique values for each institution.

	#Some of the inputs need to be factors
	pcf_cat_vec = as.factor(pcf_cat_vec)
	instid_vec = as.factor(instid_vec)
	instid_vec_i = as.integer(instid_vec)
	pcf_cat_vec_i = as.integer(pcf_cat_vec)

	#Summarize
	instid_unique = levels(instid_vec)
	instid_unique_i = as.integer(instid_unique)
	n = length(outcome_vec)
	n_u = length(levels(instid_vec))
	unique_cat = levels(pcf_cat_vec)
	n_cat = length(unique_cat)
	p_global = mean(outcome_vec)

	#Compute Table 2 in Draper-Gittoes
	y_mat = n_mat = s_mat = matrix(0, nrow =n_u, ncol = n_cat)

	for (i in 1:n){
    inst = as.integer(instid_vec[i])
    categ = as.integer(pcf_cat_vec[i])
    n_mat[inst,categ] = n_mat[inst,categ] + 1
    y_mat[inst, categ] = y_mat[inst, categ] + outcome_vec[i]
	}
	ybar_mat = y_mat / n_mat
	ybar_mat[n_mat == 0] = 0

	#Create variance mat.
	mean_mat2 = matrix(0, nrow = n_u, ncol = n_cat)
	for (i in 1:n_cat){
		for (j in 1:n_u){
			outcomes = outcome_vec[pcf_cat_vec_i == i & instid_vec_i == j]
			if (length(outcomes) > 0){
				mean_mat2[j,i] = mean(outcomes)
			}
			if (length(outcomes) > 1){
				s_mat[j,i] = var(outcomes)
				}
		}
	}

	s_global = var(outcome_vec)
	s_mat[n_mat == 1] = s_global

	#Compute marginals
	pcf_ybar_vec = apply(y_mat, 2, sum) / apply(n_mat, 2, sum)
	n_u_vec = apply(n_mat, 1, sum)
	n_cat_vec = apply(n_mat, 2, sum)

	#Equation (2) in Draper-Gittoes (2004)
	O = apply(y_mat, 1, sum) / apply(n_mat, 1, sum)
	#Equation (3) in D-G
	E = apply(t(t(n_mat) * pcf_ybar_vec), 1, sum) / n_u_vec
	#Equation (4) in D-G
	D = O - E

	#Variance
	lambdaFun = function(i,k,j){
		#Equation (7) in D-G. #Unchanged for continious
		if (i == k){
			return(n_mat[i,j]/n_u_vec[i] * (1 - (n_mat[i,j]/n_cat_vec[j])))
		} else{
			return( -1 * (n_mat[i,j] * n_mat[k,j]) / (n_u_vec[i] * n_cat_vec[j]) )
		}
	}

	vFun = function(k,j, gamma = 0.5){
		#Equation (11) in D-G #Changed for continous
		n = n_mat[k,j]
		if (n > 0){
			s_local = s_mat[k,j]
			s_use = gamma * s_global + (1-gamma) * s_local
			return(s_use/n)
		} else {
			return(0)
		}
	}
	computeVi = function(i, gamma){
		#Equation (8) in D-G #Unchanged for cnontnious
		v = 0
		for (k in 1:n_u){
			for (j in 1:n_cat){
				v = v + lambdaFun(i,k,j)^2 * vFun(k, j, gamma)
			}
		}
		return(v)
	}
	# #Now compute w/ lapply
	V = sapply(1:n_u, computeVi, gamma)
	SE = sqrt(V)

	out_df = data.frame(
			inst = as.numeric(as.character(instid_unique)),
			effect = O-E,
			O = O,
			E = E,
			D = D,
			SE = SE,
			Z = (O - E) / SE,
			n = n_u_vec
	)
	return( out_df[order(out_df$inst), ])
}


rm(list=ls(all=TRUE))

library(maptools)
library(spdep)

setwd("D:\\Dropbox\\Projects\\2014\\NIH_withDrChun_DrGriffith\\Programmings\\VisUncertainty\\VisUncertainty\\bin\\Debug\\SampleData\\Texas")
sample.shp <- readShapePoly("tl_2014_tx_cnt_SP.shp")
sample.df <- as.data.frame(sample.shp)
sample.nb <- poly2nb(sample.shp)

sample.est <- sample.df$medinc
sample.var <- sample.df$mi_se

sample.result <- UncernSAM(sample.est, sample.var, sample.nb)

nb <- sample.nb
x.e <- sample.est
x.v <- sample.var
listw <- sample.listw
sn <- listw2sn(listw)
V <- as(as(as_dgRMatrix_listw(listw), "RsparseMatrix"), "CsparseMatrix")
nw <- sum(rowSums(V))

#d.x <- x - mean(x)
#z.x <- d.x/(sqrt(sum(d.x^2)/n))
((n-1)/(2*nw))

UncernSAM <- function(x.e, x.v, nb)
{
  n <- length(x.e)

  res.bd <- vector(mode = 'numeric', length = n)
  res.bc <- vector(mode = 'numeric', length = n)
  res.hd <- vector(mode = 'numeric', length = n)

  nb.n <- card(nb)

  for(i in 1:n){
    tmp.bd <- 0
    tmp.bc <- 0
    tmp.hd <- 0

    for (j in 1:nb.n[i])
    {
      nb.idx <- nb[[i]][j]
      lc.bd <- Bhatta.dist(x.e[i], x.e[nb.idx], x.v[i], x.v[nb.idx])
      lc.bc <- Bhatta.coef(x.e[i], x.e[nb.idx], x.v[i], x.v[nb.idx])
      lc.hd <- He.dist(x.e[i], x.e[nb.idx], x.v[i], x.v[nb.idx])

      tmp.bd <- tmp.bd + lc.bd
      tmp.bc <- tmp.bc + lc.bc
      tmp.hd <- tmp.hd + lc.hd
    }

    res.bd[i]<-tmp.bd/nb.n[i]
    res.bc[i]<-tmp.bc/nb.n[i]
    res.hd[i]<-tmp.hd/nb.n[i]
  }

  res <- list(res.bd, res.bc, res.hd)
  res
}

boxplot(res)
plot(x.e, res.bc)

sample.bbox <- bbox(sample.shp)
plot(sample.shp,axes=T,col=grey(0.9),border="white",
     xlim=sample.bbox[1,],ylim=sample.bbox[2,])               # first background

plotColorRamp(res,sample.shp,n.breaks=6,    # second add map
              my.title="",
              my.legend="Bc",addToMap=T)

hist(res)

mod.c <- sn[,3]*Bhatta.dist(x.e[sn[,1]], x.e[sn[,2]], x.v[sn[,1]], x.v[sn[,2]])

mod.c <- ((n-1)/(2*nw))*sum(sn[,3]*(x[sn[,1]]-x[sn[,2]])^2)

mapping.seq(sample.shp, mod.c, 6, vec.int)

Bhatta.dist <- function(x1, x2, v1, v2){

  var.comp <- log((1/4)*((v1^2/v2^2)+(v2^2/v1^2)+2))
  mean.var.comp <- ((x1-x2)^2)/(v1^2+v2^2)
  bha.dist <- (1/4)*(var.comp+mean.var.comp)

  return(bha.dist)
}
Bhatta.coef <- function(x1, x2, v1, v2){

  var.comp <- log((1/4)*((v1^2/v2^2)+(v2^2/v1^2)+2))
  mean.var.comp <- ((x1-x2)^2)/(v1^2+v2^2)
  bha.dist <- (1/4)*(var.comp+mean.var.comp)
  bha.coef <- exp(bha.dist * -1)
  return(bha.coef)
}

He.dist <- function(x1, x2, v1, v2){

  var.comp <- log((1/4)*((v1^2/v2^2)+(v2^2/v1^2)+2))
  mean.var.comp <- ((x1-x2)^2)/(v1^2+v2^2)
  bha.dist <- (1/4)*(var.comp+mean.var.comp)
  bha.coef <- exp(bha.dist * -1)
  hell.dist <- sqrt(1-bha.coef)
  return(hell.dist)
}

mapping.seq <- function(polys, x, nclass, predifendBreaks){
  require(RColorBrewer)
  require(classInt)

  pal.red <- brewer.pal(nclass, "Reds")
  q.n <- classIntervals(x, nclass, style="fixed", fixedBreaks=predifendBreaks, intervalClosure="right")
  cols.red <- findColours(q.n, pal.red)
  plot(sample.shp, col=cols.red)
  brks <- round(q.n$brks,3)
  leg <- paste(brks[-(nclass+1)], brks[-1], sep=" - ")
  legend("bottomright", fill=pal.red, legend=leg, bty="n")
}

plotColorRamp <- function(var.name,shape,n.breaks=8,my.title="",
                          my.legend=deparse(substitute(var.name)),
                          addToMap=F) {
  ##
  ## Plot a color ramp variable "var.name"
  ##
  require(spdep); require(RColorBrewer); require(classInt)

  ## define breaks and color assignment
  q.breaks <- classIntervals(var.name, n=n.breaks, style="quantile")
  pal.YlOrRd <- brewer.pal(n.breaks, "YlOrRd")
  map.col <- pal.YlOrRd[findInterval(var.name,q.breaks$brks,rightmost.closed=T)]
  ## generate choropleth map
  plot(shape,col=map.col,border=grey(0.9),axes=T,add=addToMap)
  legend("bottomleft", title=my.legend,legend=leglabs(round(q.breaks$brks,digits=2)),
         fill=pal.YlOrRd,bty="n",ncol=1)
  title(my.title)
  box()
} # end:plotColorRamp


library(readr)
library(modEvA)
library(sjPlot)

adam_measures <- read_csv('data/measures_csv/adam-measures-with-d-2.csv')
sarah_measures <- read_csv('data/measures_csv/sarah-measures-with-d-2.csv')

adam_glm <- glm(CHI_CP ~ Semantic*Age + PosBi*Age + LexUni*Age + ADT_CP*Age,
                data=adam_measures)
adam_dsq <- Dsquared(model = adam_glm, adjust = TRUE)
summary(adam_glm)
print(paste('adjusted D^2:', adam_dsq))

sarah_glm <- glm(CHI_CP ~ Semantic*Age + PosBi*Age + LexUni*Age + ADT_CP*Age,
                 data=sarah_measures)
sarah_dsq <- Dsquared(model = sarah_glm, adjust = TRUE)
summary(sarah_glm)
print(paste('adjusted D^2:', sarah_dsq))

# plot interaction effects
# Age:Adt_Complexity (Adam)
plot_model(adam_glm, type='eff', terms=c('ADT_CP', 'Age'))
# Age:PosBi_Recurrence (Adam)
plot_model(adam_glm, type='eff', terms=c('PosBi', 'Age'))

# Age:Adt_Complexity (Sarah)
plot_model(sarah_glm, type='eff', terms=c('ADT_CP', 'Age'))


################################################################################
context("Test Engine load Calculations")
################################################################################

#calcLLAF=======================================================================

test_that("calcLLAF LLAF works",
          {
            #create Benchmark
            testLLAF<-data.table::data.table(
              engineType=c("SSD","MSD","ST","GT","LNG"),
              location=c("OutsideECA","ECA","GreatLakes","ECA","OutsideECA"),
              fuelSulfur=c(0.5, 0.1, 0.1, 0.1, 0.5),
              loadFactor=c(0.0284596685,0.0521665062,0.1766855145,0.078203076,0.708915957249701)
            )
            coefs<-ShipEF::LLAFCoeff

            testLLAF[loadFactor>0.2, so2:= 1]
            testLLAF[loadFactor<=0.2,
                     so2:=(coefs[pollutant=="so2",a]*( (14.1205/loadFactor + 205.7169) * fuelSulfur)+coefs[pollutant=="so2",b])/
                       (coefs[pollutant=="so2",a]*( (14.1205/0.2 + 205.7169) * fuelSulfur)+coefs[pollutant=="so2",b])
            ]

            testLLAF[loadFactor>0.2, hc:= 1]
            testLLAF[loadFactor<=0.2,
                     hc:=(coefs[pollutant=="hc",a]*(loadFactor^-coefs[pollutant=="hc",x])+coefs[pollutant=="hc",b])/
                       (coefs[pollutant=="hc",a]*(0.2^-coefs[pollutant=="hc",x])+ coefs[pollutant=="hc",b])
            ]

            testLLAF[loadFactor>0.2, co2:= 1]
            testLLAF[loadFactor<=0.2,
                     co2:=(coefs[pollutant=="co2",a]*(loadFactor^-coefs[pollutant=="co2",x])+coefs[pollutant=="co2",b])/
                       (coefs[pollutant=="co2",a]*(0.2^-coefs[pollutant=="co2",x])+ coefs[pollutant=="co2",b])
            ]

            testLLAF[loadFactor>0.2, co:= 1]
            testLLAF[loadFactor<=0.2,
                     co:=(coefs[pollutant=="co",a]*(loadFactor^-coefs[pollutant=="co",x])+coefs[pollutant=="co",b])/
                       (coefs[pollutant=="co",a]*(0.2^-coefs[pollutant=="co",x])+ coefs[pollutant=="co",b])
            ]

            testLLAF[loadFactor>0.2, nox:= 1]
            testLLAF[loadFactor<=0.2,
                     nox:=(coefs[pollutant=="nox",a]*(loadFactor^-coefs[pollutant=="nox",x])+coefs[pollutant=="nox",b])/
                       (coefs[pollutant=="nox",a]*(0.2^-coefs[pollutant=="nox",x])+ coefs[pollutant=="nox",b])
            ]

            testLLAF[loadFactor>0.2, pm2.5:= 1]
            testLLAF[loadFactor<=0.2,
                     pm2.5:=(coefs[pollutant=="pm2.5",a]*(loadFactor^-coefs[pollutant=="pm2.5",x])+coefs[pollutant=="pm2.5",b])/
                       (coefs[pollutant=="pm2.5",a]*(0.2^-coefs[pollutant=="pm2.5",x])+ coefs[pollutant=="pm2.5",b])
            ]

            testLLAF[loadFactor>0.2, pm10:= 1]
            testLLAF[loadFactor<=0.2,
                     pm10:=(coefs[pollutant=="pm10",a]*(loadFactor^-coefs[pollutant=="pm10",x])+coefs[pollutant=="pm10",b])/
                       (coefs[pollutant=="pm10",a]*(0.2^-coefs[pollutant=="pm10",x])+ coefs[pollutant=="pm10",b])
            ]

            #Run Calculation
            calcLLAF_out<-data.table(
              calcLLAF(engineType = testLLAF$engineType,
                          location = testLLAF$location,
                          loadFactor = testLLAF$loadFactor,
                          pollutants = "ALL")
            )

            #Compare output against benchmark
            expect_equal(calcLLAF_out$hc,
                         testLLAF$hc
            )

            expect_equal(calcLLAF_out$co2,
                         testLLAF$co2
            )

            expect_equal(calcLLAF_out$co,
                         testLLAF$co
            )

            expect_equal(calcLLAF_out$nox,
                         testLLAF$nox
            )

            expect_equal(calcLLAF_out$pm2.5,
                         testLLAF$pm2.5
            )

            expect_equal(calcLLAF_out$so2,
                         testLLAF$so2
            )

            expect_equal(calcLLAF_out$pm10,
                         testLLAF$pm10
            )

          }
)

test_that("calcLLAF LLAF works for input LLAF tables",
          {

            tbl<-data.table(load=c(1:100))

            # make up adjustment factors (2x the load in percent space,
            # or 200x the load in fraction space)
            tbl[,co:=load*2]
            tbl[,pm2.5:=load*2]
            tbl[,nox:=load*2]

            #create a temporary file and write the made up adjustment factors
            tmpName<-tempfile()
            fwrite(tbl, file = tmpName)

            # subset only some of the pollutants available
            pollutants<-c("co","nox")

            # this creates 18 different loads to test with
            loadFactor<-seq(0.1,1, by=0.051)

            # this creates 18 engine types to test with
            engineType<-c(rep("MSD-ED",6),
                          rep("GT-ED", 6),
                          rep("SSD", 6))

            # run the function using the input table
            calcLLAF_out<-calcLLAF(engineType,
                                   rep("ECA", 18),
                                   loadFactor,
                                   pollutants=c("co","nox"),
                                   inputTableLocation=tmpName)

            #delete that temporary file
            file.remove(tmpName)

            # first 12 should be 1 because they are electric drive engines
            # last 6 should be the load factor (which is in fraction space) times
            # 200 (see above comment where the adjustment factors are made up)
            expect_equal(calcLLAF_out$co,
                         c(rep(1,12),loadFactor[13:18]*200)
                        )

            expect_equal(calcLLAF_out$nox,
                         c(rep(1,12),loadFactor[13:18]*200)
                         )

})


########################################################################
#
# A stat

StatQtile <- ggproto(
  "StatQtile", Stat, required_aes = c("x", "y"),

  compute_group = function(data, scales, upper, lower) {
    data %>%
      group_by(x) %>%
      summarise(ymax=quantile(y, upper),
                ymin=quantile(y, lower),
                y=median(y))
  }
)

stat_qtile <- function(mapping = NULL, data = NULL, geom = "smooth",
                       position = "identity", na.rm = FALSE, show.legend = NA,
                       inherit.aes = TRUE, upper=0.95, lower=0.05, ...) {
  layer(
    stat = StatQtile, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, upper=upper, lower=lower, se=TRUE, ...)
  )
}